make_prior_data <- function(family, params, func) {
  list(
    family = get_family(family),
    # parameters = as.data.frame(params),
    parameters = params,
    prior_function = func
  )
}

describe_prior <- function(family, parameters) {
  range <- parameters[["range"]]
  parameters <- parameters[!grepl("range", names(parameters))]
  if (!is.null(range)) {
    range_text <- paste0("\n    range: ", range_as_text(range), "\n")
  }

  if (all(range == c(-Inf, Inf))) {
    range_text <- "\n"
  }

  if (class(family) == "beta") {
    range_text <- "\n"
  }

  parameter_names <- names(parameters)
  parameter_values <- unname(parameters)
  return(paste0(
    "Prior\n",
    "  Family\n    ", class(family), "\n",
    "  Parameters\n",
    paste0("    ", parameter_names, ": ", parameter_values, collapse = "\n"),
    range_text
  ))
}

range_as_text <- function(range) {
  paste0(range[1], " to ", range[2])
}

prior_data_names <- c("family", "parameters", "prior_function")

#################################################################
##                 DEFINITIONS OF THE PRIORS                   ##
#################################################################

# class definition

#' Specify a prior
#' @description Define priors using different different distribution families
#' @param family the prior distribution (see details)
#' @param ... see details
#'
#' @details
#' ## Available distribution families
#' The following distributions families can be used for the prior
#' * \code{normal} a normal distribution
#' * \code{student_t} a scaled and shifted t-distribution
#' * \code{cauchy} a Cauchy distribution
#' * \code{uniform} a uniform distribution
#' * \code{point} a point
#' * \code{beta} a beta distribution
#' The parameters that need to be specified will be dependent on the
#' family
#'
#' ## Normal distribution
#' When \code{family} is set to \code{normal} then the following
#' parameters may be be set
#' * \code{mean} mean of the normal prior
#' * \code{sd} standard deviation of the normal prior
#' * \code{range} (optional) a vector specifying the parameter range
#'
#' ## Student t distribution
#' When \code{family} is set to \code{student_t} then the following
#' parameters may be set
#' * \code{mean} mean of the scaled and shifted t prior
#' * \code{sd} standard deviation of the scaled and shifted t prior
#' * \code{df} degrees of freedom of the scaled and shifted t prior
#' * \code{range} (optional) a vector specifying the parameter range
#'
#'  ## Cauchy distribution
#' When \code{family} is set to \code{cauchy} then the following
#' parameters may be set
#' * \code{location} the centre of the Cauchy distribution (default: 0)
#' * \code{scale} the scale of the Cauchy distribution
#' * \code{range} (optional) a vector specifying the parameter range
#'
#' ## Uniform distribution
#' When \code{family} is set to \code{uniform} then the following
#' parameters must be set
#' * \code{min} the lower bound
#' * \code{max} the upper bound
#'
#' ## Point
#' When \code{family} is set to \code{point} then the following
#' parameters may be set
#' * \code{point} the location of the point prior (default: 0)
#'
#' ## Beta
#' When \code{family} is set to \code{beta} then the following
#' parameters may be set
#' * \code{alpha} the first shape parameter
#' * \code{beta} the second shape parameter
#'
#' @md
#' @return an object of class \code{prior}
#' @export
#'
#' @examples
#'
#' # specify a normal prior
#' prior(family = "normal", mean = 0, sd = 13.3)
#'
#' # specify a half-normal (range 0 to Infinity) prior
#' prior(family = "normal", mean = 0, sd = 13.3, range = c(0, Inf))
#'
#' # specify a student t prior
#' prior(family = "student_t", mean = 0, sd = 13.3, df = 79)
#'
#' # specify a truncated t prior
#' prior(family = "student_t", mean = 0, sd = 13.3, df = 79, range = c(-40, 40))
#'
#' # specify a cauchy prior
#' prior(family = "cauchy", location = 0, scale = .707)
#'
#' # specify a half cauchy prior
#' prior(family = "cauchy", location = 0, scale = 1, range = c(-Inf, 0))
#'
#' # specify a uniform prior
#' prior(family = "uniform", min = 0, max = 20)
#'
#' # specify a point prior
#' prior(family = "point", point = 0)
#'
#' # specify a beta prior
#' prior(family = "beta", alpha = 2.5, beta = 3.8)
prior <- function(family, ...) {
  if (!methods::existsMethod(signature = family, f = "make_prior")) {
    stop(family, " is not a valid distribution family")
  }
  make_prior(family = new(family), ...)
}

setGeneric("make_prior",
  function(family, ...) standardGeneric("make_prior"),
  signature = "family",
)

setMethod(
  "make_prior",
  signature(family = "normal"),
  function(family, mean, sd, ...) {
    make_prior.normal(family, mean, sd, ...)
  }
)

setMethod(
  "make_prior",
  signature(family = "point"),
  function(family, point = 0) {
    if (missing(point)) {
      warning("Point value is missing. Assuming 0", call. = FALSE)
    }
    make_prior.point(family, point)
  }
)

setMethod(
  "make_prior",
  signature(family = "uniform"),
  function(family, min, max) {
    make_prior.uniform(family, min, max)
  }
)

setMethod(
  "make_prior",
  signature(family = "student_t"),
  function(family, mean, sd, df, ...) {
    make_prior.student_t(family, mean, sd, df, ...)
  }
)

setMethod(
  "make_prior",
  signature(family = "cauchy"),
  function(family, location = 0, scale, ...) {
    make_prior.cauchy(family, location, scale, ...)
  }
)

setMethod(
  "make_prior",
  signature(family = "beta"),
  function(family, alpha, beta, ...) {
    make_prior.beta(family, alpha, beta, ...)
  }
)

truncate_normalise <- function(family, range, ...) {
  unnormalised <- function(x) get_function(family)(x = x, ...) # nolint

  truncated_function <- function(x) {
    ifelse(in_range(x, range),
      unnormalised(x),
      0
    )
  }

  constant <- 1 / integrate(
    Vectorize(truncated_function),
    range[1],
    range[2]
  )$value

  normalised <- function(x) truncated_function(x) * constant
  return(normalised)
}

#' @method prior normal
#' @usage prior(family = "normal", mean, sd, range)
#' @noRd
make_prior.normal <- function(family, mean, sd, range = NULL) { # nolint
  if (missing(mean) | missing(sd)) {
    stop("You must specify `mean` and `sd` for a normal prior", call. = FALSE)
  }

  if (sd <= 0) {
    stop("`sd` must be greater than 0")
  }

  if (missing(range)) {
    range <- get_default_range(family)
  }

  params <- list(mean = mean, sd = sd, range = range)

  func <- truncate_normalise(
    family = family,
    range = range,
    mean = mean,
    sd = sd
  )

  desc <- describe_prior(family, params)
  data <- make_prior_data(family, params, func)

  new(
    Class = "prior",
    data = data,
    theta_range = params$range,
    type = "normal",
    func = func,
    desc = desc,
    dist_type = "continuous",
    plot = list(
      range = get_plot_range(family)(params),
      labs = list(x = "\u03F4", y = "P(\u03F4)")
    ),
    parameters = list(mean = mean, sd = sd),
    function_text = paste0(
      "prior(\"normal\", mean = ",
      mean, ", sd = ",
      sd, ")"
    )
  )
}

#' @method prior point
#' @usage prior(family = "point", point)
#' @noRd
make_prior.point <- function(family, point = 0) {
  func <- function(x) get_function(family)(x = x, point = point)
  width <- 4
  range <- c(point - width, point + width)
  params <- list(point = point)
  # func <- make_distribution("point", list(point = point)) # nolint
  desc <- describe_prior(family, params)

  data <- make_prior_data(family, params, func)
  new(
    Class = "prior",
    data = data,
    theta_range = c(point, point),
    func = func,
    type = "point",
    dist_type = "point",
    plot = list(
      range = get_plot_range(family)(params),
      labs = list(x = "\u03F4", y = "P(\u03F4)")
    ),
    parameters = list(point = point),
    function_text = paste0("prior(\"point\", point = ", point, ")"),
    desc = desc
  )
}

#' @method prior uniform
#' @usage prior(family = "uniform", min, max)
#' @noRd
make_prior.uniform <- function(family, min, max) {
  if (missing(min) | missing(max)) {
    stop("You must specify `min` and `max` for a uniform  prior", call. = FALSE)
  }

  func <- function(x) get_function(family)(x = x, min = min, max = max)
  params <- list(min = min, max = max)

  desc <- describe_prior(family, params)

  data <- make_prior_data(family, params, func)

  new(
    Class = "prior",
    data = data,
    theta_range = c(min, max),
    func = func,
    type = "normal",
    desc = desc,
    dist_type = "continuous",
    plot = list(
      range = get_plot_range(family)(params),
      labs = list(x = "\u03F4", y = "P(\u03F4)")
    ),
    parameters = list(mean = mean, sd = sd),
    function_text = paste0(
      "prior(\"uniform\", min = ",
      min, ", max = ", max, ")"
    )
  )
}

#' @method prior student_t
#' @usage prior(family = "student_t", mean, sd, df, range)
#' @noRd
make_prior.student_t <- function(family, mean, sd, df, range = NULL) {
  if (missing(mean) | missing(sd) | missing(df)) {
    stop("You must specify `mean`, `sd`, and `df` for a student_t prior",
      call. = FALSE
    )
  }

  if (missing(range)) {
    range <- get_default_range(family)
  }

  func <- truncate_normalise(
    family = family,
    range = range,
    mean = mean,
    sd = sd,
    df = df
  )

  params <- list(mean = mean, sd = sd, df = df, range = range)

  desc <- describe_prior(family, params)

  data <- make_prior_data(family, params, func)

  new(
    Class = "prior",
    data = data,
    theta_range = range,
    func = func,
    type = "normal",
    desc = desc,
    dist_type = "continuous",
    plot = list(
      range = get_plot_range(family)(params),
      labs = list(x = "\u03F4", y = "P(\u03F4)")
    ),
    parameters = list(mean = mean, sd = sd, df = df),
    function_text = paste0(
      "prior(\"student_t\", mean = ", mean,
      ", sd = ", sd,
      ", df = ", df, ")"
    )
  )
}

#' @method prior cauchy
#' @usage prior(family = "cauchy", location, scale, range)
#' @noRd
make_prior.cauchy <- function(family, location = 0, scale, range = NULL) {
  if (missing(range)) {
    range <- get_default_range(family)
  }

  func <- truncate_normalise(family = family, range = range, location = location, scale = scale)

  params <- list(location = location, scale = scale, range = range)
  desc <- describe_prior(family, params)

  data <- make_prior_data(family, params, func)

  new(
    Class = "prior",
    data = data,
    theta_range = params$range,
    func = func,
    type = "normal",
    desc = desc,
    dist_type = "continuous",
    plot = list(
      range = get_plot_range(family)(params),
      labs = list(x = "\u03F4", y = "P(\u03F4)")
    ),
    parameters = list(location = location, scale = scale),
    function_text = paste0(
      "prior(\"cauchy\", location = ",
      location, ", scale = ",
      scale, ")"
    )
  )
}

#' @method prior beta
#' @usage prior(family = "beta", alpha, beta)
#' @noRd
make_prior.beta <- function(family, alpha, beta, range = NULL) {
  if (missing(alpha) | missing(beta)) {
    stop("You must specify `alpha` and `beta` for a beta  prior", call. = FALSE)
  }

  if (missing(range)) {
    range <- get_default_range(family)
  }

  func <- truncate_normalise(family = family, range = range, beta = beta, alpha = alpha)
  params <- list(alpha = alpha, beta = beta, range = range)

  desc <- describe_prior(family, params)

  data <- make_prior_data(family, params, func)

  new(
    Class = "prior",
    data = data,
    theta_range = params$range,
    func = func,
    type = "normal",
    desc = desc,
    dist_type = "continuous",
    plot = list(
      range = get_plot_range(family)(params),
      labs = list(x = "\u03F4", y = "P(\u03F4)")
    ),
    parameters = list(alpha = alpha, beta = beta),
    function_text = paste0(
      "prior(\"beta\", alpha = ",
      alpha, ", beta = ", beta, ")"
    )
  )
}


#' Computes the infloss on the off-diagonals of two matrices
#'
#' @param A Matrix
#' @param B Matrix with the same size as A
#' @return Maximal off-diagonal difference between A and B
#' @export
infloss <- function(A, B)
{
  dif <- abs(A - B)
  diag(dif) <- rep(0, dim(A)[1])
  return(max(dif))
}

#' Computes precision of a precision matrix estimator
#'
#' @param theta True precision matrix
#' @param theta.estimate Estimator of theta
#' @return Precision of theta.estimate with theta being the target
#' @export
precision <- function(theta, theta.estimate)
{
  adj.theta <- apply(theta, c(1,2), function(x) if (x!=0){return(1)} else {return(0)})
  diag(adj.theta) <- rep(0, dim(theta)[1])
  adj.estimate <- apply(theta.estimate, c(1,2), function(x) if (x!=0){return(1)} else {return(0)})
  diag(adj.estimate) <- rep(0, dim(theta)[1])
  num.edges.estimate <- sum(adj.estimate)/2
  num.edges.same <- sum (apply(adj.theta - adj.estimate, c(1,2), function(x) if(x!=0) {return(1)} else{return(0)}))/2
  return(num.edges.same/ num.edges.estimate)
}

#' Compute recall of a precision matrix estimator
#'
#' @param theta True precision matrix
#' @param theta.estimate Estimator of theta
#' @return Recall of theta.estimate with theta being the target
#' @export
recall <- function(theta, theta.estimate)
{
  adj.theta <- apply(theta, c(1,2), function(x) if (x!=0){return(1)} else {return(0)})
  diag(adj.theta) <- rep(0, dim(theta)[1])
  adj.estimate <- apply(theta.estimate, c(1,2), function(x) if (x!=0){return(1)} else {return(0)})
  diag(adj.estimate) <- rep(0, dim(theta)[1])
  num.edges.theta <- sum(adj.theta)/2
  num.edges.same <- sum (apply(adj.theta - adj.estimate, c(1,2), function(x) if(x!=0) {return(1)} else{return(0)}))/2
  return(num.edges.same/ num.edges.theta)
}

#' Compute performance of a precision matrix estimator
#'
#' @param theta True precision matrix
#' @param theta.estimate Estimator of theta
#' @param decimal Number of decimals such that entries of absolute size 1e-decimal are set to zero
#' @return f1 F_1-score of theta.estimate with theta being the target
#' @return recall Recall of theta.estimate with theta being the target
#' @return precision Precision of theta.estimate with theta being the target
#' @export
f1score <- function(theta, theta.estimate, decimal=4)
{
  #we don't want to include edges with values like e-17 which occure due to the
  #precision matrix generation algorithm. Thats why we round...
  theta <- round(theta, decimal)
  theta.estimate <- round(theta.estimate, decimal)

  #generate the adjacency matrices. diagonal entries are set to 0
  adj.theta <- apply(theta, c(1,2), function(x) if (x!=0){return(1)} else {return(0)})
  diag(adj.theta) <- rep(0, dim(theta)[1])
  #we use a little trick here: set values of the adjacency matrix to 2.
  #we do this so that we can count the number of same edges in an easy way:
  #if both edges are nonexistent -> adj.Theta - adj.estimate = 0
  #if one of them is existent -> adj.Theta - adj.estimate \in \{ 1, -2\}
  #if both are existent -> adj.Theta - adj.estimate = -1
  adj.estimate <- apply(theta.estimate, c(1,2), function(x) if (x!=0){return(2)} else {return(0)})
  diag(adj.estimate) <- rep(0, dim(theta)[1])

  # every edge occurs exactly 2 times
  num.edges.theta <- sum(adj.theta)/2
  num.edges.estimate <- sum(adj.estimate/2)/2

  num.edges.same <- sum(apply(adj.theta - adj.estimate, c(1,2), function(x) if(x==-1) {return(1)} else{return(0)})) / 2

  recall <- num.edges.same / num.edges.theta
  if( num.edges.estimate > 0)
  {
    precision <- num.edges.same / num.edges.estimate
    f1 <- 2 * (precision * recall)/ (precision + recall)
  }
  else
  {
    precision <- 0
    f1 <- 0
  }

  return(list("f1"=f1, "recall"=recall, "precision"=precision))
}


# Example : 1   Chapter : 8.2     Page No: 427
# Find the currents
A<-matrix(c(-1,-1,0,-1,0,0,1,0,-1,0,-1,0,0,1,1,0,0,-1,0,0,0,1,1,1),ncol=4)
AT<-t(A)
Laplacian_matrix<-AT%*%A
Laplacian_matrix<-Laplacian_matrix[-4,-4]
b<-c(1,0,0)
x<-solve(Laplacian_matrix,b)
x<-c(x,0)
print("Voltages are given by S * ")
print(x)
print("S is source")
y<--1*A%*%x
print("Currents are given by S * ")
print(y)


#' The bivariate GLMGA distribution
#'
#' @param y1 vector of quantiles.
#' @param y2 vector of quantiles.
#' @param sigma vector of parameters with length = 2.
#' @param a  common parameter with length = 1.
#' @param b vector of parameters with length = 2.
#'
#' @return Density function of the bivariate GLMGA distribution with parameters sigma, a and b.
#' @export
#'
#' @examples
#' n.grid <- 20
#' sigma <- c(0.5, 0.5)
#' a <- 20
#' b <- c(5, 5)
#' xgrid <- ygrid <- seq(0.01, 20, length.out = n.grid)
#' grid <- expand.grid("u1" = xgrid, "u2" = ygrid)
#' mtrx3d <- matrix(0, nrow = nrow(grid), ncol = 3)
#' mtrx3d[, 1] <- grid[, 1]
#' mtrx3d[, 2] <- grid[, 2]
#' for (i in 1:nrow(mtrx3d)) {
#'   mtrx3d[i, 3] <- dMGLMGA(
#'     y1 = grid[i, 1], y2 = grid[i, 2],
#'     sigma = sigma,
#'     a = a, b = b
#'   )
#' }
#' head(mtrx3d)
dMGLMGA <- function(y1, y2, sigma, a, b) {
  sigma1 <- sigma[1]
  sigma2 <- sigma[2]
  b1 <- b[1]
  b2 <- b[2]
  d <- 2
  out1 <- gamma(a + d / 2) / (gamma(a) * gamma(0.5)^d * (sigma1 * y1 * sigma2 * y2)) * ((2 * b1)^sigma1 * y1)^(-1 / (2 * sigma1)) * ((2 * b2)^sigma2 * y2)^(-1 / (2 * sigma2))
  out2 <- (((2 * b1)^(sigma1) * y1)^(-1 / sigma1) + ((2 * b2)^(sigma2) * y2)^(-1 / sigma2) + 1)^(a + d / 2)

  z <- out1 / out2
  return(z)
}


source('base.r')

# calculate manhattan distance between vectors p, q
manhattan.distance <- function(p, q){
  return (sum(abs(p - q)))
}

# calculate median of input vector
kmedians.medians.of.columns <- function(X){

  medians = list()
  nr_of_columns <- ncol(X)

  for (i in 1:nr_of_columns){
    medians[[i]] = median(X[,i], na.rm = F)
  }

  return(unlist(medians))
}

# initialize centroids by randomly selecting vectors from the dataset
kmedians.init.centroids.with.random.selection <- function(X, nr_of_centroids){

  centroids <- list()
  nr_of_dimensions = ncol(X)

  random_indexes <- sample.int(nrow(X), nr_of_centroids)

  for (i in 1:nr_of_centroids){
    index = random_indexes[i]
    centroids[[i]] <- as.vector(X[index, ])
  }

  return (centroids)
}

# initialize centroids by calculating k-means clusters
kmedians.init.centroids.with.kmeans <- function(X, nr_of_centroids){

  centroids <- list()
  nr_of_dimensions = ncol(X)
  kmeans_result <- kmeans(X, nr_of_centroids, nstart = 25)
  kmeans_centroids <- as.matrix(kmeans_result["centers"][[1]])

  for (i in 1:nrow(kmeans_centroids)){
    centroids[[i]] <- as.vector(kmeans_centroids[i, ])
  }

  return (centroids)
}

# initialize centroids
kmedians.init.centroids <- function(X, nr_of_centroids, type){

  if (type == 'k-means')
    return(kmedians.init.centroids.with.kmeans(X, nr_of_centroids))

  return(kmedians.init.centroids.with.random.selection(X, nr_of_centroids))
}

# calculate centroid that is nearest to data_vector
kmedians.nearest.centroid <- function(centroids, data_vector){

  nr_of_centroids = length(centroids)
  distance_from_centroids = list()

  for (k in 1:nr_of_centroids){
    centroid = centroids[[k]]
    distance_from_centroids[[k]] = manhattan.distance(data_vector, centroid)
  }

  min_distance = min(unlist(distance_from_centroids))
  centroid_index = which.min(unlist(distance_from_centroids))

  return (list(centroid_index, min_distance))
}

# allocate data vectors to centroids
kmedians.allocate.to.centroids <- function(X, centroids){

  nr_of_items = nrow(X)
  centroid_allocations = matrix(nrow = nr_of_items, ncol = 1)

  for (i in 1:nr_of_items){
    data_vector <- X[i,]
    nearest_centroid <- kmedians.nearest.centroid(centroids, data_vector)
    centroid_allocations[i,1] = nearest_centroid[[1]]
  }

  return(centroid_allocations)
}

# update centroids based on median of latest allocations
kmedians.update.centroids <- function(X, centroids, centroid_allocations){

  new_centroids <- list()
  nr_of_centroids <- length(centroids)

  for (k in 1:nr_of_centroids){
    item_indexes_allocated_to_centroid <- which(centroid_allocations[, 1] == k)
    items_allocated_to_centroid <- as.matrix(X[item_indexes_allocated_to_centroid, ])

    if (nrow(items_allocated_to_centroid) == 0){
      new_centroids[[k]] <- integer(ncol(X))
    }
    else{
      items_medians <- kmedians.medians.of.columns(items_allocated_to_centroid)
      new_centroids[[k]] <- items_medians
    }
  }

  return(new_centroids)
}

# perform kmedians clustering on input data
kmedians <- function(X, centers, max_iterations = 100){

  centroids <- kmedians.init.centroids(X, centers, 'k-means')

  for (i in 1:max_iterations){

    centroid_allocations = kmedians.allocate.to.centroids(X, centroids)
    new_centroids <- kmedians.update.centroids(X, centroids, centroid_allocations)
    print(paste('Update centroids - iteration :', i, sep = " "))

    no_change_in_centroids = vectors.are.equal(unlist(centroids), unlist(new_centroids))
    if (no_change_in_centroids) { break }

    centroids = new_centroids
  }

  rownames(centroid_allocations) <- row.names(X)
  return(centroid_allocations)
}


knitr::opts_chunk$set(echo = TRUE)
set.seed(2021)

library(tidyverse)
library(rBeta2009)
library(kableExtra)
library(latex2exp)
library(magrittr)
library(pwr)

gx <- function(x) {
  return(0.5 * exp(-abs(x)))
}

fx <- function(x) {
  return(exp(-(abs(x) ^ 3) / 3))
}

fgx <- function(x) {
  return(fx(x) / gx(x))
}

m <- fgx(-1)

m_gx <- function(x, m) {
  return(m * gx(x))
}

par(mfrow = c(2, 2))

curve(fx, -5, 5, xlab = "x", ylab = "f(x)",
      col = "darkgrey", lwd = 2, main = "Gráfico de f(x)")

curve(gx, -5, 5, xlab = "y", ylab = "g(y)",
      col = "darkgrey", lwd = 2, main = "Gráfico de g(y)")

curve(fgx, -4, 4, ylab = "f(x)/g(x)", main = "Gráfico de f(x)/g(x)")
points(c(-1, 1), c(m, m), pch = 20, col = "blue")
abline(h = m, lty = 2, col = "blue")
segments(c(-1, 1), c(0, 0), c(-1, 1), c(m, m), lty = 2, col = "blue")

curve(m_gx(x, m), -5, 5, col = "red", ylab = "f(x) e m*g(x)",
      main = "Gráfico de f(x) e mg(x)")
curve(fx(x), add = TRUE)
legend("topright", c("f(x)", "m*g(x)"), col = c("black", "red"),
       lty = 1, bty = "n")

gerador <- function(n) {
  nger <- n0 <- 0
  ax <- c()
  while (n0 < n) {
    rej <- TRUE
    while (rej) {
      nger <- nger + 1
      u <- runif(1)
      y <- ifelse(u <= 0.5, log(2 * u), - log(2 * (1 - u)))

      if (m * runif(1) <= fgx(y)) {
        n0 <- n0 + 1
        ax[n0] <- y
        rej <- FALSE
      }
    }
  }

  result <- list(sample = ax, n_gerado = nger)
  return(result)

}

amostra_gerada_50 <- gerador(50)
ax_50 <- amostra_gerada_50$sample

amostra_gerada_100 <- gerador(100)
ax_100 <- amostra_gerada_100$sample

amostra_gerada_400 <- gerador(400)
ax_400 <- amostra_gerada_400$sample

par(mfrow = c(2, 2))
hist(ax_50, freq = FALSE, main = "Histograma da amostra n = 50",
     xlab = "x", ylab = "Densidade",
     col = "orange", border = "brown")
hist(ax_100, freq = FALSE, main = "Histograma da amostra n = 100",
     xlab = "x", ylab = "Densidade",
     col = "orange", border = "brown")
hist(ax_400, freq = FALSE, main = "Histograma da amostra n = 400",
     xlab = "x", ylab = "Densidade",
     col = "orange", border = "brown")

amostra <- c(ax_50, ax_100, ax_400)
tamanho <- c(rep(50, length(ax_50)),
             rep(100, length(ax_100)),
             rep(400, length(ax_400)))

df <- data.frame(amostra, tamanho)

boxplot(amostra ~ tamanho,
        data = df,
        main = "Diferentes Boxplots para\ncada tamanho de amostra",
        xlab = "Tamanho da amostra",
        ylab = "Observações",
        col = "orange",
        border = "brown"
)

r <- 1000
lambda <- 2
po_sample <- function(r, lambda, n) {

  pvalue <- c()
  aceptance <- c()
  medias_v <- c()
  poder_dif <- seq(2.2, 4, length.out = 5) - 2
  power_1 <- c()

  for (i in 1:r) {

    sample_p <- rpois(n, lambda)
    media <- mean(sample_p)

    p_value <- pnorm(media, mean = lambda, sd = sqrt(1 / n * lambda))
    pvalue[i] <- p_value

    medias_v[i] <- media

    if (pvalue[i] >= 0.05) {
      aceptance[i] <- 1
    }
    else {
      aceptance[i] <- 0
    }
  }

  poder_1 <- power.t.test(n = n, delta = poder_dif[1],
                          sd = sqrt(1 / n * lambda),
                          sig.level = .05,
                          alternative = "two.sided",
                          type = "one.sample")
  power_1[1] <- (as.numeric(unlist(poder_1[5])))

  poder_2 <- power.t.test(n = n, delta = poder_dif[2],
                          sd = sqrt(1 / n * lambda),
                          sig.level = .05,
                          alternative = "one.sided",
                          type = "one.sample")
  power_1[2] <- as.numeric(unlist(poder_2[5]))

  poder_3 <- power.t.test(n = n, delta = poder_dif[3],
                          sd = sqrt(1 / n * lambda),
                          sig.level = .05,
                          alternative = "one.sided",
                          type = "one.sample")
  power_1[3] <- as.numeric(unlist(poder_3[5]))

  poder_4 <- power.t.test(n = n, delta = poder_dif[4],
                          sd = sqrt(1 / n * lambda),
                          sig.level = .05,
                          alternative = "one.sided",
                          type = "one.sample")
  power_1[4] <- as.numeric(unlist(poder_4[5]))

  poder_5 <- power.t.test(n = n, delta = poder_dif[5],
                          sd = sqrt(1 / n * lambda),
                          sig.level = .05,
                          alternative = "one.sided",
                          type = "one.sample")
  power_1[5] <- as.numeric(unlist(poder_5[5]))

  results <- list(pvalor = pvalue, aceita = aceptance,
                  media = medias_v, poder = power_1)

  return(results)
}

a <- po_sample(r, lambda, 10)
b <- po_sample(r, lambda, 30)
c <- po_sample(r, lambda, 75)
d <- po_sample(r, lambda, 100)

freqa <- table(a$aceita) * 100 / sum(table(a$aceita))
freqb <- table(b$aceita) * 100 / sum(table(b$aceita))
freqc <- table(c$aceita) * 100 / sum(table(c$aceita))
freqd <- table(d$aceita) * 100 / sum(table(d$aceita))

tabela <- rbind("Amostra n = 10" = freqa, "Amostra n = 30" = freqb,
                "Amostra n = 75" = freqc, "Amostra n = 100" = freqd)
tabela_1 <- as.data.frame(tabela)

tabela_1 %>% mutate_all(linebreak) %>%
knitr::kable(tabela_1, align = "c",
             caption = "Tabela de Erro Tipo I (em %)",
             col.names = c("Rejeita Hipótese Nula",
                           "Não Rejeita Hipótese Nula"),
             format = "latex") %>%
    kable_styling(position = "center")

tabela_2 <- rbind("Amostra n = 10" = a$poder, "Amostra n = 30" = b$poder,
                  "Amostra n = 75" = c$poder, "Amostra n = 100" = d$poder)
p <- seq(2.2, 4, length.out = 5)
df2 <- data.frame(round(tabela_2, 2))

knitr::kable(df2, align = "c",
             caption = "Tabela do Poder do Teste $\\lambda \\in[2,2;4]$",
             col.names = c(paste("$\\lambda =$", p[1]),
                           paste("$\\lambda =$", p[2]),
                           paste("$\\lambda =$", p[3]),
                           paste("$\\lambda =$", p[4]),
                           paste("$\\lambda =$", p[5])),
             format = "latex", escape = F) %>%
kable_styling(position = "center")

library("rmarkdown")
render("Trabalho1/trab1.Rmd", "pdf_document")

update.packages(ask = FALSE, checkBuilt = TRUE)
tinytex::tlmgr_update()


a <- 5.0
l <- 8.0

n <- 10000
centX <- a/2 * runif(n)
alpha <- runif(n, min=0, max=pi/2)

if (l < a) {
	ifa <- (centX <= l*cos(alpha) / 2)
	p <- mean(ifa)
	print(p)
	newPi <- 2 * l / (p * a)
	print(newPi)
} else {
	minArr <- vector()
	for (i in seq(1, n))
	{
		minArr <- c(minArr, min(c(l*cos(alpha[i])/2, a/2)))
	}
	ifa <- (centX <= minArr)
	p <- mean(ifa)
	print(p)
	newPi <- 2 * l / ((p-1) * a) - 2 * (sqrt(l^2-a^2) + a*asin(a/l)) / ((p-1) * a)
	print(newPi)
}


> ## Demo from RO implementors
> library(R0)
Loading required package: MASS
>
> # Generating an epidemic with given parameters
> mGT <- generation.time("gamma", c(3,1.5))
> mEpid <- sim.epid(epid.nb=1, GT=mGT, epid.length=30, family="poisson", R0=1.67, peak.value=500)
> mEpid <- mEpid[,1]
> # Running estimations
> est <- estimate.R(epid=mEpid, GT=mGT, methods=c("EG","ML","TD"))
Waiting for profiling to be done...
Warning messages:
1: In est.R0.TD(epid = c(1, 1, 1, 1, 1, 3, 1, 2, 1, 6, 2, 6, 4, 12,  :
  Simulations may take several minutes.
2: In est.R0.TD(epid = c(1, 1, 1, 1, 1, 3, 1, 2, 1, 6, 2, 6, 4, 12,  :
  Using initial incidence as initial number of cases.
>
> # Model estimates and goodness of fit can be plotted
> plot(est)
> plotfit(est)
# Sensitivity analysis for the EG estimation; influence of begin/end dates
s.a <- sensitivity.analysis(res=est$estimates$EG, begin=1:15, end=16:30, sa.type="time")
# This sensitivity analysis can be plotted
plot(s.a)

# Set up the R environment with the necessary packages
install.packages(c("dplyr", "R0", "magrittr", "RCurl"))

# RUN PATTERN DEVELOPED BY C. MOREFIELD and ABSTRACTED by J. Mallery
# Load libraries
library(R0)
library(RCurl)
library(data.table)

fetch_JHU_Data <- function() {
	csv <- getURL("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_19-covid-Confirmed.csv")
	data <- read.csv(text = csv, check.names = F)
	names(data)[1] <- "ProvinceState"
	names(data)[2] <- "CountryRegion"
	numberColumns <- length(names(data))
	data.table(data) }

prepare_dates <- function (date_vector)	{as_date(mdy(date_vector))}

fetch_JHU_Dates <- function() {
	rawdat = RCurl::getURL("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_19-covid-Confirmed.csv")
	curdata = read.csv(text=rawdat, stringsAsFactors=FALSE, check.names=FALSE)
	date_vector <- names(curdata)[-c(1:4)]
	prepare_dates(date_vector )
	}

trimLeading <- function(x, value=0) {
	w <- which.max(cummax(x != value))
	x[seq.int(w, length(x))] }

extract_country_data <- function (name, data) {
	cdata <- data[CountryRegion == name]
	cdata}

extract_ProvinceState_data <- function (name, data) {data[ProvinceState == name] }

diff_data <- function (cdata) {
	cdata <- append(cdata[1], diff(cdata))
	cdata <- trimLeading(cdata, value = 0)
	cdata}

prepare_data <- function (cdata) {
	cdata <- cdata[,5:numberColumns]
	names(cdata) <- NULL
	cdata <- unlist(c(cdata))
	cdata <- diff_data(cdata)
	cdata}

# Fetch the data
my_data <- fetch_JHU_Data()
numberColumns <- length(names(my_data))
my_dates <- fetch_JHU_Dates()

# SERIAL TIME INTERVAL
GT.cov2 <- generation.time("gamma", c(4.75, 3.96))
# GT.cov2 <- generation.time("gamma", c(5.8,.95)) # from DOI 10.7326/M20-0504

# EUROPE
data.France <- extract_ProvinceState_data("France", my_data)
diff.France <- prepare_data(data.France)
R.France <- My_Estimate_R(my_dates,diff.France)
R.France

epid.count <- prepare_data(extract_country_data("Germany", my_data))
R.Germany <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Germany

epid.count <- prepare_data(extract_country_data("Germany", my_data))
R.Germany <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Germany

epid.count <- prepare_data(extract_country_data("Italy", my_data))
R.Italy <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Italy

epid.count <- prepare_data(extract_country_data("Spain", my_data))
R.Spain <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Spain

epid.count <- prepare_data(extract_ProvinceState_data("United Kingdom", my_data))
R.UK <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.UK

# MIDDLE EAST
epid.count <- prepare_data(extract_country_data("Iran", my_data))
R.Iran<- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Iran

# ASIA
epid.count <- prepare_data(extract_country_data("Korea, South", my_data))
R.SouthKorea <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.SouthKorea

epid.count <- prepare_data(extract_country_data("Singapore", my_data))
R.Singapore <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Singapore

# US States and Regions

epid.count <- prepare_data(extract_ProvinceState_data("Illinois", my_data))
R.Illinois <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Illinois

epid.count <- prepare_data(extract_ProvinceState_data("New York", my_data))
R.NewYork <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.NewYork

epid.count <- prepare_data(extract_ProvinceState_data("Massachusetts", my_data))
R.Massachusetts <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Massachusetts

epid.count <- prepare_data(extract_ProvinceState_data("California", my_data))
R.California <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.California

epid.count <- prepare_data(extract_ProvinceState_data("New Hampshire", my_data))
R.NewHampshire <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.NewHampshire

epid.count <- c(267, 99, 76, 126, 4, 71, 261, 172, 0, 362, 148)
R.Washington <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Washington

data.US <- c(2, 2, 5, 5, 5, 5, 5, 7, 8, 8, 11, 11, 11, 11, 11, 11, 11, 11, 12, 12, 13, 13, 13, 13, 13, 13, 13, 13, 15, 15, 15, 51, 51, 57, 58, 60, 68, 74, 98, 118, 149, 217, 262, 402, 518, 583, 959, 1281, 1663, 2179, 2727, 3499, 4632, 6421, 7783, 13677, 19100, 25489, 38757)

epid.count <- diff_data(data.US)
R.US <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.US

Data.Grafton.NH <- c(1,2,2,2,2,2,3,3,3,3,3,3,3,3,5,7,7,9,12,13)
epid.count <- diff_data(Data.Grafton.NH)
R.Grafton.NH <- estimate.R(epid.count, GT = GT.cov2, methods = c("EG"))
R.Grafton.NH

# Vince Carey R Code to Estimate time dependent reproduction numbers
# with the attached code you should be able to do
# %vjcair> Rscript pure.R | tail -1
# Waiting for profiling to be done...
# 4.920046
suppressMessages({
suppressPackageStartupMessages({
ii = rownames(installed.packages())
if (!("BiocManager" %in% ii)) install.packages("BiocManager")
library(BiocManager)
if (!("R0" %in% ii)) BiocManager::install("R0")
library(R0)
if (!("lubridate" %in% ii)) BiocManager::install("lubridate")
library(lubridate)
})
})

#	c("1/22/20", "1/23/20", "1/24/20", "1/25/20", "1/26/20", "1/27/20", "1/28/20", "1/29/20", "1/30/20", "1/31/20", "2/1/20", "2/2/20", "2/3/20", "2/4/20", "2/5/20", "2/6/20", "2/7/20", "2/8/20", "2/9/20", "2/10/20", "2/11/20", "2/12/20", "2/13/20", "2/14/20", "2/15/20", "2/16/20", "2/17/20", "2/18/20", "2/19/20", "2/20/20", "2/21/20", "2/22/20", "2/23/20", "2/24/20", "2/25/20", "2/26/20", "2/27/20", "2/28/20", "2/29/20", "3/1/20", "3/2/20", "3/3/20", "3/4/20", "3/5/20", "3/6/20", "3/7/20", "3/8/20", "3/9/20", "3/10/20", "3/11/20", "3/12/20", "3/13/20", "3/14/20", "3/15/20", "3/16/20", "3/17/20", "3/18/20", "3/19/20", "3/20/20", "3/21/20")
datevec <- as_date(mdy(
	c( "1/24/20", "1/25/20", "1/26/20", "1/27/20", "1/28/20", "1/29/20", "1/30/20", "1/31/20", "2/1/20", "2/2/20", "2/3/20", "2/4/20", "2/5/20", "2/6/20", "2/7/20", "2/8/20", "2/9/20", "2/10/20", "2/11/20", "2/12/20", "2/13/20", "2/14/20", "2/15/20", "2/16/20", "2/17/20", "2/18/20", "2/19/20", "2/20/20", "2/21/20", "2/22/20", "2/23/20", "2/24/20", "2/25/20", "2/26/20", "2/27/20", "2/28/20", "2/29/20", "3/1/20", "3/2/20", "3/3/20", "3/4/20", "3/5/20", "3/6/20", "3/7/20", "3/8/20", "3/9/20", "3/10/20", "3/11/20", "3/12/20", "3/13/20", "3/14/20", "3/15/20", "3/16/20", "3/17/20", "3/18/20", "3/19/20", "3/20/20", "3/21/20", "3/22/20")
	))
cumevents <- data.US
names(cumevents) = datevec
plot(cumevents~as_date(ymd(names(cumevents))), main="US as of 3/22/2020 from JHU. World-o-Meters")
epid.count <- (diff(cumevents))
est1 = estimate.R(epid.count, GT = GT.cov2 , t = as_date(ymd(names(epid.count))),
  begin=1L, end=as.integer(length(epid.count)), methods=c("EG"))
cat(est1$estimates$EG$R, "\n")

library(dplyr)
library(magrittr)
library(RCurl)
library(R0)

fetch_JHU_Data = function (as.data.frame = FALSE)
{
    csv <- getURL("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_19-covid-Confirmed.csv")
    data <- read.csv(text = csv, check.names = F)
    names(data)[1] <- "ProvinceState"
    names(data)[2] <- "CountryRegion"
    numberColumns <- length(names(data))
    if (!as.data.frame)
        return(data.table(data))
    data
}
get_series = function (province = "", country, dataset = try(fetch_JHU_Data(as.data.frame = TRUE)))
{
    if (inherits(dataset, "try-error"))
        stop("could not get data from fetch_JHU_Data()")
    stopifnot(all(c("ProvinceState", "CountryRegion") %in% colnames(dataset)))
    stopifnot(country %in% dataset$CountryRegion)
    ans = dataset %>% dplyr::filter(ProvinceState == province &
        CountryRegion == country)
    ans[, -c(1:4)]
}
plot_series = function (province = "", country, dataset = try(fetch_JHU_Data(as.data.frame = TRUE)),
    ...)
{
    if (inherits(dataset, "try-error"))
        stop("could not get data from fetch_JHU_Data()")
    ser = get_series(province = province, country = country,
        dataset = dataset)
    dates = lubridate::as_date(mdy(fix_slash_dates(names(dataset)[-c(1:4)])))
    plot(dates, ser, main = paste(province, country), ...)
}

as_vector = function(x) data.matrix(x)[1,,drop=TRUE]

my_plot <- function (title, cumulative_vector){}
	plot(cumulative_vector~as_date(ymd(names(cumulative_vector))), main= title)

# cvec = as_vector(get_series(country="Italy"))
# ivec = diff(cvec)
# tivec = trimLeading(ivec)
# estimate.R(tivec, GT=generation.time("gamma", c(3.5,4.8)), methods="EG")
# estimate.R(incidence_vector, GT = generation_time , t = as_date(myd(names(tivec))), begin=1L, end=as.integer(length(incidence_vector)), methods=c("EG"))}
# estimate.R(incidence_vector, GT=generation_time, methods="EG")
# 	estimate.R(incidence_vector, GT = generation_time , t = as_date(myd(names(tivec))), begin=1L, end=as.integer(length(incidence_vector)), methods=c("EG"))

# pass in the time vector and diff data
My_Estimate_R <- function (generation_time, incidence_vector) {
		estimate.R(incidence_vector, GT = generation_time , t = as_date(myd(names(incidence_vector))), begin=1L, end=as.integer(length(incidence_vector)), methods=c("EG"))
	}

# SCRIPTS FOR ESTIMATING VARIOUS REGIONS

GT.cov2 <- generation.time("gamma", c(4.75, 3.96))

data.France <- as_vector(get_series("France", "France"))
diff.France <- diff_data(data.France)
R.France <- My_Estimate_R (GT.cov2, diff.France)
R.France

data.Germany <- as_vector(get_series("", "Germany"))
diff.Germany <- diff_data(data.Germany)
R.Germany <- My_Estimate_R (GT.cov2, diff.Germany)
R.Germany

data.Italy <- as_vector(get_series("", "Italy"))
diff.Italy <- diff_data(data.Italy)
R.Italy <- My_Estimate_R (GT.cov2, diff.Italy)
R.Italy

data.Spain <- as_vector(get_series("", "Spain"))
diff.Spain <- diff_data(data.Spain)
R.Spain <- My_Estimate_R (GT.cov2, diff.Spain)
R.Spain

data.UK <- as_vector(get_series("United Kingdom",  "United Kingdom",))
diff.UK <- diff_data(data.UK)
R.UK <- My_Estimate_R (GT.cov2, diff.UK)
R.UK

# Middle East

data.Iran <- as_vector(get_series("", "Iran"))
diff.Iran <- diff_data(data.Iran)
R.Iran <- My_Estimate_R (GT.cov2, diff.Iran)
R.Iran

data.SouthKorea <- as_vector(get_series("", "Korea, South"))
diff.SouthKorea <- diff_data(data.SouthKorea)
R.SouthKorea <- My_Estimate_R (GT.cov2, diff.SouthKorea)
R.SouthKorea

data.Singapore <- as_vector(get_series("", "Singapore"))
diff.Singapore <- diff_data(data.Singapore)
R.Singapore <- My_Estimate_R (GT.cov2, diff.Singapore)
R.Singapore

# US States and Regions

data.NewYork <- as_vector(get_series("New York","US"))
diff.NewYork <- diff_data(data.NewYork)
R.NewYork <- My_Estimate_R (GT.cov2, diff.NewYork)
R.NewYork

data.Illinois <- as_vector(get_series("Illinois", "US"))
diff.Illinois <- diff_data(data.Illinois)
R.Illinois <- My_Estimate_R (GT.cov2, diff.Illinois)
R.Illinois

data.Massachusetts <- as_vector(get_series("Massachusetts", "US"))
diff.Massachusetts <- diff_data(data.Massachusetts)
R.Massachusetts <- My_Estimate_R (GT.cov2, diff.Massachusetts)
R.Massachusetts

data.California <- as_vector(get_series("California", "US"))
diff.California <- diff_data(data.California)
R.California <- My_Estimate_R (GT.cov2, diff.California)
R.California

data.NewHampshire <- as_vector(get_series("New Hampshire", "US"))
diff.NewHampshire <- diff_data(data.NewHampshire)
R.NewHampshire <- My_Estimate_R (GT.cov2, diff.NewHampshire)
R.NewHampshire


##### Chapter 3: Classification using Nearest Neighbors --------------------

## Example: Classifying Cancer Samples ----
## Step 2: Exploring and preparing the data ----

# import the CSV file
wbcd <- read.csv("wisc_bc_data.csv", stringsAsFactors = FALSE)

# examine the structure of the wbcd data frame
str(wbcd)

# drop the id feature
wbcd <- wbcd[-1]

# table of diagnosis
table(wbcd$diagnosis)

# recode diagnosis as a factor
wbcd$diagnosis <- factor(wbcd$diagnosis, levels = c("B", "M"),
                         labels = c("Benign", "Malignant"))

# table or proportions with more informative labels
round(prop.table(table(wbcd$diagnosis)) * 100, digits = 1)

# summarize three numeric features
summary(wbcd[c("radius_mean", "area_mean", "smoothness_mean")])

# create normalization function
normalize <- function(x) {
  return ((x - min(x)) / (max(x) - min(x)))
}

# test normalization function - result should be identical
normalize(c(1, 2, 3, 4, 5))
normalize(c(10, 20, 30, 40, 50))

# normalize the wbcd data
wbcd_n <- as.data.frame(lapply(wbcd[2:31], normalize))

# confirm that normalization worked
summary(wbcd_n$area_mean)

# create training and test data
wbcd_train <- wbcd_n[1:469, ]
wbcd_test <- wbcd_n[470:569, ]

# create labels for training and test data

wbcd_train_labels <- wbcd[1:469, 1]
wbcd_test_labels <- wbcd[470:569, 1]

## Step 3: Training a model on the data ----

# load the "class" library
library(class)

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test,
                      cl = wbcd_train_labels, k=21)

## Step 4: Evaluating model performance ----

# load the "gmodels" library
library(gmodels)

# Create the cross tabulation of predicted vs. actual
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred,
           prop.chisq=FALSE)

## Step 5: Improving model performance ----

# use the scale() function to z-score standardize a data frame
wbcd_z <- as.data.frame(scale(wbcd[-1]))

# confirm that the transformation was applied correctly
summary(wbcd_z$area_mean)

# create training and test datasets
wbcd_train <- wbcd_z[1:469, ]
wbcd_test <- wbcd_z[470:569, ]

# re-classify test cases
wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test,
                      cl = wbcd_train_labels, k=21)

# Create the cross tabulation of predicted vs. actual
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred,
           prop.chisq=FALSE)

# try several different values of k
wbcd_train <- wbcd_n[1:469, ]
wbcd_test <- wbcd_n[470:569, ]

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test, cl = wbcd_train_labels, k=1)
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred, prop.chisq=FALSE)

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test, cl = wbcd_train_labels, k=5)
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred, prop.chisq=FALSE)

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test, cl = wbcd_train_labels, k=11)
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred, prop.chisq=FALSE)

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test, cl = wbcd_train_labels, k=15)
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred, prop.chisq=FALSE)

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test, cl = wbcd_train_labels, k=21)
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred, prop.chisq=FALSE)

wbcd_test_pred <- knn(train = wbcd_train, test = wbcd_test, cl = wbcd_train_labels, k=27)
CrossTable(x = wbcd_test_labels, y = wbcd_test_pred, prop.chisq=FALSE)


#' f_descent
#'
#' The descent algorithm using back tracking line search stepsize
#'
#' @param v_y   vector of y
#' @param v_x   vector of x
#' @param v_k0  vector of internal knots for covariates
#' @param v_m   vector of orders for covariates
#'
#' @param init initialization for $\beta$
#' @param alpha threshold $\alpha$, within $(0, 0.5)$.
#' @param bet   shrinkage rate $\bet$, within $(0, 1)$.
#' @param v_smooth  vector of smoothing parameters
#' @param maxit maximum number of iterations
#' @param eps   stopping critria threshhold
#' @param eta   stopping criteria for gradient size
#' @param trace indicator whether to plot trace
#'
#'
#' @return the estimated $\beta$
#'
f_descent <- function(v_y, v_x, v_k0, v_m, init = NULL,
                        alpha = 0.3, bet = 0.5, v_smooth = rep(1, 3),
                        maxit = 1e4, eps = 1e-3, eta = NULL, trace = NULL) {

#-------------------------------------------------------
##### set up #####
#-------------------------------------------------------
    function_call <- match.call()
    x_ord <- order(v_x)
    v_x <- v_x[x_ord]
    v_y <- v_y[x_ord]
    s_center <- mean(v_x)
    s_sd <- sd(v_x)
    v_x <- c(scale(v_x))
    iter <- 0L
    converge <- F
    s_n <- length(v_y)
    #Define dimensions
    k1 <- v_k0[2]; ktau <- v_k0[1]; m1 <- v_m[2]; mtau <- v_m[1]
    v_dim <- v_k0 + v_m
    #Require
    m_n1 <- f_n1(v_x, k1, m1)
    m_g1 <- f_g1(ktau, mtau)
    m_g2 <- f_g2(ktau, mtau)
    m_sigmatau <- f_sigmatau(v_dim[1])
    m_sigma <- f_sigma(v_dim[1], v_dim[2])
    m_s <- f_mats(v_dim[1], v_dim[2], v_smooth)

    #Precalculate h1
    m_h1 <- f_h1(m_n1, m_g1, m_g2, m_sigmatau)

    #Initialization
    if (is.null(init)) {
        init <- f_init(v_y, v_x, m_sigma, m_n1, v_k0, v_m, m_s)
    }
    til_beta <- init
    v_beta <- og_beta(til_beta, v_dim[1], v_dim[2])
    v_grad <- 0

    #Calculate H2 (most time consuming)
    v_taustar <- f_tausearch(v_y, m_n1, til_beta, m_sigma, ktau, mtau)
    m_ntaustar <- f_ntaustar(v_taustar, ktau, mtau)
    m_h2 <- f_h2(m_n1, m_ntaustar, m_g1, m_sigmatau)

    ##Loss
    s_loss <- f_criteria(v_beta, til_beta, v_taustar, v_y, m_sigma, m_h1, m_h2, m_s)

    ##trace
    ##trace
    if (!is.null(trace)) {
        v_taus <- trace
        con_quan <- list(x = v_x, y = v_y, center = s_center, sd = s_sd,
                    v_k0 = v_k0, v_m = v_m, m_sigma = m_sigma, n1 = m_n1,
                    til_beta = til_beta)
        sub <- paste("Iter:", iter, ", Error=", round(s_loss, 3))
        main <- paste("alpha=", alpha, "beta=", bet,
                "Smoothing:", v_smooth[1:2], "dim:", v_dim)
        cq_plot(trace, con_quan, sub = sub, main = main)
    }

    #Repeat
    while (maxit > iter) {
        iter <- iter + 1

        #Calculate gradient
        v_deriv <- f_lossderiv(til_beta, v_k0 + v_m, m_sigma, m_h1, m_h2) / s_n
        v_grad <- f_grad(v_beta, v_deriv, m_s)
        grad_size <-  sum(v_grad ^ 2)

        #backtracking line search
        t <- 1
        repeat{
            new_beta <- v_beta - t * v_grad
            new_tilbeta <- tilde_beta(new_beta, v_dim[2])
            new_loss <- f_criteria(new_beta, new_tilbeta, v_taustar, v_y, m_sigma, m_h1, m_h2, m_s)
            t <- bet * t
            if (new_loss <= (s_loss - alpha * t * grad_size) || t < 1e-4) {
                break
            }
        }

        #Update v_beta
        v_beta <- new_beta
        til_beta <- new_tilbeta

        #Update H2 (most time consuming)
#ptm <- proc.time()# Start the clock!
        v_taustar <- f_tausearch(v_y, m_n1, til_beta, m_sigma, ktau, mtau)
#print(proc.time() - ptm)# Stop the clock
        m_ntaustar <- f_ntaustar(v_taustar, ktau, mtau)
        m_h2 <- f_h2(m_n1, m_ntaustar, m_g1, m_sigmatau)

        ##trace
        if (!is.null(trace)) {
            con_quan$til_beta <- til_beta
            sub <- paste("Iter:", iter, ", Error=", round(new_loss, 3))
            cq_plot(trace, con_quan, sub = sub, main = main)
        }

        #Check stop criterion
        if (is.null(eta)) {
            converge <- (abs(new_loss - s_loss) <= eps * abs(s_loss))
        } else {
            converge <- (sqrt(grad_size) / norm_2(v_beta) <= eta)
        }

        s_loss <- new_loss
        #If gradient size criteria
        if (is.na(converge)) {
            converge <- F
            break
        }
        if (converge) break
    }

#-------------------------------------------------------
##### Output #####
#-------------------------------------------------------
    out <- list(
        beta = v_beta,
        til_beta = til_beta,
        gradient = v_grad,
        converge = converge,
        grad_size = sum(v_grad ^ 2),
        iter = iter,
        loss = s_loss,
        tau = v_taustar,
        x = v_x,
        y = v_y,
        center = s_center,
        sd = s_sd,
        v_k0 = v_k0,
        v_m = v_m,
        n1 = m_n1,
        m_sigma = m_sigma,
        mat_s = m_s,
        alpha = alpha,
        bet = bet,
        call = function_call)

    return(out)
}


# ===
# R code used as basis for illustratig the CLT theorem and
# construction of the confidence interval.
# ===

# ---
# Load the libraries that we need. Indicate whether "shiny" is needed (probably not)
# ---

load_libraries <- function(withshiny = FALSE) {
   library(tidyverse)  # Load the whole tidyverse (ggplot2, dplyr, purrr etc..)
   library(statsr)     # Companion package for the Coursera "Statistics with R" specialization
   library(reshape2)   # Provides "reshape" to "melt" a data frame
   if (withshiny) {
      library(shiny)   # "An R package to build interactive web apps straight from R.", by RStudio.
   }
   library(testit)     # For "assert": https://www.rdocumentation.org/packages/testit/versions/0.11
                       # install.packages('testit')
}

# ---
# Load the "ames" dataset and return the "area" information
# ---

load_dataset_ames_area <- function() {
   data(ames)
   # We are interested in the area of transacted property, in feet²
   ames_area <- select(ames,area)
   # "ames_area" is a tibble of 1 column named "area"
   # to rename column "area" to just "x" (one could also use dplyr's rename function)
   # names(ames_area)[names(ames_area) == "area"] <- "x"
   str(ames_area)
   return (ames_area)
}

# ---
# Given a plot created by ggplot2, add vertical lines for certain statistics
# ---

add_stats_vlines_to_plot <- function(stats, plot, add_median = TRUE) {

   stddev            <- stats$stddev
   mean              <- stats$mean
   median            <- stats$median
   stddev_range_high <- stats$mean + stddev
   stddev_range_low  <- stats$mean - stddev

   color_mean    <- "red"
   color_stddev  <- "blue"
   color_median  <- "orange"

   # add a vertical line for "mean"

   x_where <- mean
   plot <- plot +
           geom_vline(xintercept=x_where, color=color_mean) +
           annotate(geom="text", x=x_where,  y=0, label="<>", color=color_mean)

   # add a vertical line for "median"

   if (add_median) {
      x_where <- median
      plot <- plot +
             geom_vline(xintercept=x_where, color=color_median) +
             annotate(geom="text", x=x_where,  y=0, label="∇", color=color_median)
   }

   # add a dashed vertical line for "1-stddev range, low value"

   x_where <- stddev_range_high
   plot <- plot +
           geom_vline(xintercept=x_where, color=color_stddev, linetype="dotdash") +
           annotate(geom="text", x=x_where, y=0, label="sd-", color=color_stddev)

   # add a dashed vertical line for "1-stddev range, high value"

   x_where <- stddev_range_low
   plot <- plot +
           geom_vline(xintercept=x_where, color=color_stddev, linetype="dotdash") +
           annotate(geom="text", x=x_where, y=0, label="sd+", color=color_stddev)

   return(plot)
}

# ---
# Create a ggplot2 histogram of "ames" "area" values. This may be
# over the whole population or just over a sample. Returns the plot.
# ---

plot_histogram_of_ames_area_data <- function(ames_area_data, binwidth, x_max, titlestr) {

   stats <- compute_ames_area_stats(ames_area_data)

   subtitlestr <-
      paste0(stats$num_obs, " observations",
             ", binwidth = " , binwidth,
             ", min = "      , stats$min,
             ", max = "      , stats$max,
             ", mean = "     , round(stats$mean,1),
             ", median = "   , stats$median,
             ", stddev = "   , round(stats$stddev,1))

   plot <-
      ggplot(ames_area_data) +
      coord_cartesian(xlim=c(0,x_max)) +
      geom_histogram(aes(x=area), binwidth=binwidth, color="grey") +
      labs(x="property area (feet²)", title=titlestr, subtitle=subtitlestr)

   stats_to_add <-
     setNames(as.list(c(stats$stddev,
                        stats$mean,
                        stats$median)),
              c("stddev", "mean", "median"))

   plot <- add_stats_vlines_to_plot(stats_to_add, plot)

   return(plot)
}

# ---
# Create a Probability Density Function for the "ames" "area" values. This may
# be over the whole population or just over a sample.
# "Adjust" gives the kernel width (measure of "smoothness")
# ---

create_pdf_for_ames_area_data <- function(ames_area_data, adjust) {
   density_obj = density(ames_area_data$area, adjust=adjust)
   # str(density_obj)
   pdf <- tibble(x=density_obj$x, y=density_obj$y)
   # str(pdf)
   return(pdf)
}

# ---
# Create a ggplot2 graph of a Probability Density Function for the "ames" "area"
# values. This may be over the whole population or just over a sample. Returns the plot
# ---

plot_pdf_of_ames_area_data <- function(ames_area_data, adjust, x_max, titlestr) {

   stats <- compute_ames_area_stats(ames_area_data)

   subtitlestr <-
      paste0(stats$num_obs, " observations",
             ", smoothing = ", adjust,
             ", min = "      , stats$min,
             ", max = "      , stats$max,
             ", mean = "     , round(stats$mean,1),
             ", median = "   , stats$median,
             ", stddev = "   , round(stats$stddev,1))

   pdf <- create_pdf_for_ames_area_data(ames_area_data,adjust)

   plot <-
      ggplot(pdf) +
      coord_cartesian(xlim=c(0,x_max)) +
      geom_line(aes(x=x,y=y)) +
      labs(x="property area (feet²)", y="dp/dx", title=titlestr, subtitle=subtitlestr)

   stats_to_add <-
     setNames(as.list(c(stats$stddev,
                        stats$mean,
                        stats$median)),
              c("stddev", "mean", "median"))

   plot <- add_stats_vlines_to_plot(stats_to_add, plot)

   return(plot)
}

# ---
# Create a single sample by selecting observations at random
# ---

create_single_sample_of_ames_area_observations <- function(ames_area, sample_size) {
   # Use dplyr:sample_n
   # Resulting "sample" is a tibble "sample_size x 1", listing observations
   sample <- sample_n(ames_area, size=sample_size, replace=FALSE)
   # str(sample)
   return(sample)
}

# ---
# Compute statistics of ames area data (either a sample or the whole set
# of observations)
# ---

compute_ames_area_stats <- function(ames_area_data) {

   # Use "summarise" from package "dplyr".
   # This creates a tibble of dimensions "1 x 8", with the columns having the
   # names given below.

   stats <-
      summarise(ames_area_data,
                mean   = mean(area),
                median = median(area),
                stddev = sd(area),
                iqr    = IQR(area),
                min    = min(area),
                max    = max(area),
                quart1 = quantile(area, 0.25), # first ¼-ile, 25th %-ile
                quart3 = quantile(area, 0.75)) # third ¼-ile, 75th %-ile

   stats <- add_column(stats, num_obs = nrow(ames_area_data))
   return(stats)

}

# ---
# Create multiple samples (and then their sample stats) from the ames dataset
# ---

create_multiple_ames_area_sample_stats <- function(ames_area, sample_size, sample_count) {
   # message("Creating ", sample_count, " samples of ", sample_size, " individuals, and their corresponding sample statistics")

   # Create empty list to store the "sample_count" sample statistics

   fillable_list  <- rep(list(NA), sample_count)

   # This can probably be done in vector fashion instead of a loop...

   for(i in 1:sample_count) {
      # "sample" is a tibble "sample_size x 1", listing observations
      sample <- create_single_sample_of_ames_area_observations(ames_area, sample_size)
      # "sample_stats" is a tibble "1 x 9", with columns "mean", "median", "stddev", ...
      sample_stats <- compute_ames_area_stats(sample)
      # str(sample_stats)
      fillable_list[[i]] <- sample_stats
   }

   # Not sure why the next instruction works but it does!
   # The result is a tibble with "sample_size x 9", with columns "mean", "median", "stddev", ...

   multiple_sample_stats <- do.call(rbind.data.frame, fillable_list)
   return(multiple_sample_stats)
}

# ---
# Compute the sampling stats (mean of sample means) from the collection of sample stats (sample means etc.)
# ---

compute_sampling_stats_for_mean <- function(multiple_sample_stats) {

   # Use "summarise" from package "dplyr".
   # This creates a tibble of dimensions "1 x 5", with the columns having the
   # names given below.

   stats <-
      summarise(multiple_sample_stats,
                mean   = mean(multiple_sample_stats$mean),
                median = median(multiple_sample_stats$mean),
                stddev = sd(multiple_sample_stats$mean),
                min    = min(multiple_sample_stats$mean),
                max    = max(multiple_sample_stats$mean))

   stats <- add_column(stats, sample_count = nrow(multiple_sample_stats))
   stats <- add_column(stats, sample_size  = mean(multiple_sample_stats$num_obs)) # constant over samples

   return(stats)
}

# ---
# Create a ggplot2 histogram of the "mean" sample statistics (over the samples). Returns the plot.
# ---

plot_histogram_of_ames_area_sample_stats_for_mean <- function(multiple_sample_stats, binwidth, mean_min, mean_max) {

   sampling_stats <- compute_sampling_stats_for_mean(multiple_sample_stats)

   titlestr <- "Histogram of mean of property area over samples of property transactions made in Ames, Iowa, 2006-2010"

   subtitlestr <-
      paste0(sampling_stats$sample_count, " samples of ",
             sampling_stats$sample_size, " observations ",
             ", binwidth = " , binwidth,
             ", min = "      , round(sampling_stats$min,1),
             ", max = "      , round(sampling_stats$max,1),
             ", mean = "     , round(sampling_stats$mean,1),
             ", stddev = "   , round(sampling_stats$stddev,2),
             "\nOverlaid: limit Gaussian postulated by CLT (scaled)")

   plot <-
      ggplot(multiple_sample_stats) +
      coord_cartesian(xlim=c(mean_min,mean_max)) +
      geom_histogram(aes(x=mean), binwidth=binwidth, color="grey") +
      labs(x="mean of property area over a single sample (feet²)", title=titlestr, subtitle=subtitlestr)

   stats_to_add <-
     setNames(as.list(c(sampling_stats$stddev,
                        sampling_stats$mean,
                        sampling_stats$median)),
              c("stddev", "mean", "median"))

   plot <- add_stats_vlines_to_plot(stats_to_add, plot, add_median = FALSE)

   return(plot)
}

# ---
# Overlay the Normal to which the histogram should converge according to the CLT
# ---

overlay_clt_normal <- function(plot, binwidth, mean_min, mean_max, population_mean, population_stddev, sample_size, sample_count) {
   num_points <- 200
   x <- seq(mean_min, mean_max, (mean_max-mean_min)/(num_points-1))
   stretch <- sample_count*binwidth # stretch the small Normal curve to the same dimension as the histogram
   y <- dnorm(x, mean=population_mean, sd=population_stddev/sqrt(sample_size))*stretch
   normal = tibble(x,y)
   plot <- plot + geom_line(data = normal, aes(x=x,y=y))
   return(plot)
}

# ---
# Compute a confidence interval then add its lower and upper limit to the "sample_stat", which is returned
# ---

add_confidence_interval <- function(sample_stats, confidence, verbose) {
   zscore             = -qnorm((1.0-confidence)/2)  # positive surface in tail of the Gaussian (one side)
   sample_size        = sample_stats$num_obs
   standard_error     = sample_stats$stddev / sqrt(sample_size)
   margin_of_error    = zscore*standard_error
   conf_interval_low  = sample_stats$mean - margin_of_error
   conf_interval_high = sample_stats$mean + margin_of_error
   if (verbose) {
      message("The confidence interval at "
              ,(confidence*100)
              ,"% is ["
              ,conf_interval_low
              ,","
              ,conf_interval_high
              ,"]")
   }
   res <- add_column(sample_stats
                     ,conf_interval_low  = conf_interval_low
                     ,conf_interval_high = conf_interval_high)
   return(res)
}

# ---
# Return TRUE if the population mean is indeed within the confidence interval
# ---

check_confidence_interval <- function(ames_area, population_mean, sample_size, confidence) {
   # create a single sample and compute its statistics
   # "sample_stats" is a tibble of 9x1 observations with variables "mean", "median, "stddev" etc..
   sample_stats <- create_multiple_ames_area_sample_stats(ames_area,
                      sample_size=sample_size,
                      sample_count=1)
   # extend the "sample_stats" tibble with information about the confidence interval
   sample_stats <- add_confidence_interval(sample_stats, confidence, verbose=FALSE)
   # str(sample_stats)
   # return TRUE if the population mean is indeed within the confidence interval
   return(sample_stats$conf_interval_low < population_mean && population_mean < sample_stats$conf_interval_high)
}


############################################################################
# Marek Opuszko
# Analytics of the COVID-19 (Corona) Spread
############################################################################

#
# In order to easily model the whole thing, the data is logarithmized so
# that we can then use a simple linear regression. Building on this,
# we can then make forecasts for the next few days
library(tidyr)
library(data.table)
library(ggplot2)
require(scales)
library(ggsci)
library(ggdark)

###################################################################################################
# 1. PREPROCESSING - DATA PREPARATION
###################################################################################################

# Define Working Directory
setwd("~/yourdirectoryhere")

subject = "Deaths" # or "Deaths" or "Recovered Cases"

# Load the Dataset
if (subject=="Cases") {
  data = read.csv("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_confirmed_global.csv")
}else if(subject == "Deaths") {
  data = read.csv("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_deaths_global.csv")
}else if(subject == "Recovered Cases") {
  data = read.csv("https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_recovered_global.csv")
}

# The dataset needs some adjustments. Clearing data types:
data$Province.State = as.character(data$Province.State)
data$Country.Region = as.character(data$Country.Region)

#We can remove lat and long since we are not using this geo information here
data$Lat <-  NULL
data$Long <- NULL
# check the data frame
str(data)

# We need to change the format of the data frame, from wide (columns) to long
# meaning we want a "date" and a "cases" variable instead of multiple columns for each date
# This is necesary to make use of the data for later functions and plotting

# using the melt function to transpose the data frame (needs prior transformation to data table format)
data_transformed <- melt(as.data.table(data), id=c("Province.State","Country.Region"), fun="Sum")
# change the variable names to something more "speaking"
names(data_transformed) <-  c("region","country","date","cases")
# remove the X invoked by R (no variable names beginning with a number allowed)
data_transformed$date <- gsub("X", "0", paste(data_transformed$date))
# transform character dates to actual date format
data_transformed$date <- as.Date(data_transformed$date, "%m.%d.%Y")
# This is optional, save the new formatted data frame
write.csv(data_transformed,paste0("covid_19_data_",subject,"_confirmed.csv"),row.names=FALSE)

###################################################################################################
# 2. ANALYTICS
# 2.1 World wide Trend
###################################################################################################

# Aggregate all cases by date -> overall sum over all countries for on date
data_subset <- aggregate(cases ~ date , data = data_transformed, sum)
# Aggregated Cases by Date and by Country
data_subset_countries <- aggregate(cases ~ country + date , data = data_transformed, sum)

# First Impressions - Plot
plot(data_subset$cases ~ data_subset$date)
# We see a string exponential development from mid of march ...
# logarithmize the cases to linearize expoential growth
plot(log(data_subset$cases) ~ data_subset$date)

# In order to make predictions we will simplify the model and use a simple linear
# regression model for the timespan the cases grow exponentially

lastDay <- max(data_subset$date)
# let's use the last two weeks ...
data_model <- data_subset[data_subset$date >= lastDay-21,]
# check plot ...
plot(log(data_model$cases) ~ data_model$date)

# To understand the regression, it's better to use Day Numbers
# so we can ask later on, what will today plus 7 days look like?
data_model$daynr = seq(1,length(data_model$cases))
# logarithmize the cases to apply linear regression
data_model$casesLog = log(data_model$cases)

# Check the plot ... looks "linear" ?
plot(data_model$casesLog ~ data_model$date)

# Run a simple linear regression
model <- lm(data_model$casesLog ~ data_model$daynr)
# extract Coefficients
a = as.numeric(model$coefficients[1])
b = as.numeric(model$coefficients[2])

###################################################################################################
# 2.2 Predictions ... the whole world
###################################################################################################
# Function to predict cases based on our simple model
predict <- function(day,a,b){
  cases = a + b*day
  return(cases)
}

# Since the model is based an logarithmic values <- reverse operation of the values
predict_cases <- function(day,a,b) {
  result = exp(predict(day,a,b))
  return(result)
}

today = length(data_model$daynr)

# Prediction of our model for today (31st of March as i'm writing this)
predict_cases(today,a,b)
# 800,000 vs 780,000 ... not bad ..

# Prediction of our model for tomorrow
predict_cases(today+1,a,b)
# Prediction of our model for one week into the future
predict_cases(today+7,a,b)
# 1,69 Million cases 7th of April :/

# Prediction of our model for two weeks into the future
predict_cases(today+14,a,b)

# Plot the model timespan
dateMin = min(data_model$date)
dateMax = max(data_model$date) + 7
ggplot(data_model, aes(x=date,y=cases)) +
  geom_line(aes(y=cases),size=1.1,alpha=0.7,color="white") +
  geom_point(aes(y=cases),alpha=0.5,color="grey") +
  scale_y_log10(labels = scales::comma) +
  geom_smooth(method = lm, fullrange=TRUE, color="red") +
  ggtitle(paste0("Worldwide COVID-19 ",subject," over Time")) + xlab("Date") +
  ylab("Number (log)")+
  xlim(dateMin, dateMax) +
  scale_color_nejm() +
  dark_theme_gray() +
  theme(axis.text.x = element_text(size = 15)) +
  theme(axis.text.y = element_text(size = 12)) +
  theme(plot.title = element_text(size=20,color="orange"))

# Plot the whole date span
ggplot(data_subset, aes(x=date,y=cases)) +
  geom_line(aes(y=cases),size=1.1,alpha=0.7,color="white") +
  geom_point(aes(y=cases),alpha=0.5,color="grey") +
  scale_y_log10(labels = scales::comma) +
  geom_smooth(method = loess, fullrange=TRUE, color="red") +
  ggtitle(paste0("Worldwide COVID-19 ",subject)) + xlab("Date") +
  ylab("Number (log)")+
  scale_color_nejm() +
  dark_theme_gray() +
  theme(axis.text.x = element_text(size = 15)) +
  theme(axis.text.y = element_text(size = 12)) +
  theme(plot.title = element_text(size=20,color="orange"))

###################################################################################################
# 2.3 Predictions ... Single Countries or Regions
###################################################################################################

###################################################################################################
# US
###################################################################################################
needle = c("US")

# Subset by Country list
data_subset_US = data_subset_countries[which(data_subset_countries$country %in% needle),]

# first impressions
plot(log(data_subset_US$cases) ~ data_subset_US$date)
# exponential growth since beginning of march
data_model_US <- data_subset_US[data_subset_US$date >= lastDay-14,]
plot(log(data_model_US$cases) ~ data_model_US$date)

# create Day Nr
data_model_US$daynr = seq(1,length(data_model_US$cases))
# logarithmize
data_model_US$casesLog = log(data_model_US$cases)

# Regression
model_US <- lm(data_model_US$casesLog ~ data_model_US$daynr)
# extract coefficients
a = as.numeric(model_US$coefficients[1])
b = as.numeric(model_US$coefficients[2])

today = length(data_model_US$daynr)

# Prediction of our model for today, tomorrow, etc (31st of March as i'm writing this)
predict_cases(today,a,b)
predict_cases(today+1,a,b)
predict_cases(today+7,a,b)
predict_cases(today+14,a,b)

# Plot the model timespan
dateMin = min(data_model_US$date)
dateMax = max(data_model_US$date) + 7
ggplot(data_model_US, aes(x=date,y=cases)) +
  geom_line(aes(y=cases),size=1.1,alpha=0.7,color="white") +
  geom_point(aes(y=cases),alpha=0.5,color="grey") +
  scale_y_log10(labels = scales::comma) +
  geom_smooth(method = lm, fullrange=TRUE, color="red") +
  ggtitle(paste0("US COVID-19 ",subject," over Time")) + xlab("Date") +
  ylab("Number (log)")+
  xlim(dateMin, dateMax) +
  scale_color_nejm() +
  dark_theme_gray() +
  theme(axis.text.x = element_text(size = 15)) +
  theme(axis.text.y = element_text(size = 12)) +
  theme(plot.title = element_text(size=20,color="orange"))

# Plot the whole date span
ggplot(data_subset_US, aes(x=date,y=cases)) +
  geom_line(aes(y=cases),size=1.1,alpha=0.7,color="white") +
  geom_point(aes(y=cases),alpha=0.5,color="grey") +
  scale_y_log10(labels = scales::comma) +
  geom_smooth(method = loess, fullrange=TRUE, se=FALSE, color="red") +
  ggtitle(paste0("US COVID-19 ",subject)) + xlab("Date") +
  ylab("Number (log)")+
  scale_color_nejm() +
  dark_theme_gray() +
  theme(axis.text.x = element_text(size = 15)) +
  theme(axis.text.y = element_text(size = 12)) +
  theme(plot.title = element_text(size=20,color="orange"))

##############################################################################################
# what About the daily increase/change?
# Lazy Approach: Calculate the daily cases based on the subtraction today and yesterday
# Works only for single cases, not if you have groups !!!
##############################################################################################
yesterday = c(data_subset_US$cases[1],data_subset_US$cases[1:length(data_subset_US$cases)-1])
data_subset_US$newInfects = data_subset_US$cases - yesterday

ggplot(data_subset_US, aes(x=date,y=newInfects,colour=country)) +
  geom_line(aes(y=newInfects),size=1.1,alpha=0.7) +
  geom_point(aes(y=newInfects),alpha=0.5) +
  geom_smooth(method = loess, aes(color=country),color="white") +
  ggtitle(paste0("Daily COVID-19 ",subject," in the US")) + xlab("Date") +
  ylab("Daily Increase")+
  xlim(dateMin, dateMax) +
  scale_color_nejm() +
  dark_theme_gray() +
  theme(axis.text.x = element_text(size = 15)) +
  theme(axis.text.y = element_text(size = 12)) +
  theme(plot.title = element_text(size=30,color="orange"))

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

###################################################################################################
# Top 6 Countries in Case Numbers
###################################################################################################
needle = c("China","US","Italy","Germany","Spain","Iran")

# Subset by Country list
data_subset_top6 = data_subset_countries[which(data_subset_countries$country %in% needle),]
# Plot - log scales
ggplot(data_subset_top6, aes(x=date,y=cases,color=country)) +
  geom_line(aes(y=cases),size=1.1,alpha=0.7) +
  geom_point(aes(y=cases),alpha=0.5) +
  scale_y_log10(labels = scales::comma) +
  ggtitle(paste0("COVID-19 ",subject," over Time")) + xlab("Date") +
  ylab("Number (log)")+
  scale_color_nejm() +
  dark_theme_gray() +
  theme(axis.text.x = element_text(size = 15)) +
  theme(axis.text.y = element_text(size = 12)) +
  theme(plot.title = element_text(size=20,color="orange"))
# Plot - normal scales
ggplot(data_subset_top6, aes(x=date,y=cases,color=country)) +
  geom_line(aes(y=cases),size=1.1,alpha=0.7) +
  geom_point(aes(y=cases),alpha=0.5) +
  ggtitle(paste0("COVID-19 ",subject," over Time")) + xlab("Date") +
  ylab("Number (log)")+
  scale_color_nejm() +
  dark_theme_gray() +
  theme(axis.text.x = element_text(size = 15)) +
  theme(axis.text.y = element_text(size = 12)) +
  theme(plot.title = element_text(size=20,color="orange"))

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


# ......................................................................................
# ..............................Cvičení 2 - Pravděpodobnost.............................
# ..................Adéla Vrtková, Michal Béreš, Martina Litschmannová .................
# ......................................................................................

# 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

# V tomto cvičení projdeme úvod do pravděpodobnosti. Předpokládáme znalosti z přednášky,
# především pojmy: **definice pravděpodobnosti, podmíněná pravděpodobnost, věta o úplné
# pravděpodobnosti, Bayesova věta**.
#
#  Pomocné funkce ####
#
# * Úplná pravděpodobnost ####
# $P(A)=\sum_{i=1}^{n}P(B_i)P(A|B_i)$

# spočítání pravděpodobnosti P(A) - věta o úplné pravděpodobnosti
uplna_pravdepodobnost = function(P_B, P_AB)
{   # uvažujeme P_B jako vektor hodnot P(B_i) a P_BA jako vektor hodnot P(A|B_i)
    P_A = 0
    for (i in 1:length(P_B))
    {
        P_A = P_A + P_B[i]*P_AB[i]
    }
    return(P_A)
}

# * Bayesova věta ####
# $P(B_k|A)=\frac{P(B_k)P(A|B_k)}{\sum_{i=1}^{n}P(B_i)P(A|B_i)}$

# spočítání podmíněné pravděpodobnosti P(B_k|A) - Bayesova věta
bayes = function(P_B, P_AB, k)
{   # uvažujeme P_B jako vektor hodnot P(B_i), P_BA jako vektor hodnot P(A|B_i)
    P_A = uplna_pravdepodobnost(P_B, P_AB)
    P_BkA = P_B[k]*P_AB[k]/P_A
    return(P_BkA)
}

# **Přidáme funkce z munulého cvičení pro počítání kombinatorických výběrů, jsou v
# skriptu kombinatorika.R**

source('kombinatorika.R')

#  Příklady ####
# * Příklad 1. ####
# Určete pravděpodobnost, že při hodu 20stěnnou spravedlivou (férovou) kostkou padne
# číslo větší než 14.

omega = 1:20
A = c(15,16,17,18,19,20)
# pravděpodobnost jako podíl příznivých ku všem
length(A)/length(omega)

# * Příklad 2. ####
# Určete pravděpodobnost, že při hodu 20stěnnou kostkou padne číslo větší než 14,
# víte-li, že sudá čísla padají 2x častěji než lichá.

p_liche = 1/(20+10)
p_sude = 2*p_liche
pravd = c(p_liche, p_sude, p_liche, p_sude, p_liche, p_sude, p_liche, p_sude,
          p_liche, p_sude, p_liche, p_sude, p_liche, p_sude, p_liche, p_sude,
          p_liche, p_sude, p_liche, p_sude)
pravd
#pravdepodobnost je
sum(pravd[15:20])

# * Příklad 3. ####
# Určete pravděpodobnost, že ve sportce uhodnete 4 čísla. (Ve sportce se losuje 6 čísel
# ze 49.)

(kombinace(6,4)*kombinace(43,2))/kombinace(49,6)

# * Příklad 4. ####
# Z abecedního seznamu studentů zapsaných na dané cvičení vybere učitel prvních 12 a
# nabídne jim sázku: „Pokud se každý z Vás narodil v jiném znamení zvěrokruhu, dám
# každému z Vás 100 Kč. Pokud jsou však mezi Vámi alespoň dva studenti, kteří se
# narodili ve stejném znamení, dá mi každý z Vás 100 Kč.“ Vyplatí se studentům sázku
# přijmout? S jakou pravděpodobností studenti vyhrají?

permutace(12)/variace_opak(12,12)

# * Příklad 5. ####
# Spočtěte pravděpodobnost toho, že z bodu 1 do bodu 2 bude protékat elektrický proud,
# je-li část el. obvodu včetně pravděpodobnosti poruch jednotlivých součástek vyznačen
# na následujícím obrázku. (Poruchy jednotlivých součástek jsou na sobě nezávislé.)
# Obrázek viz sbírka úloh.

# rozdělíme na bloky I=(A,B) a II=(C,D,E)
PI = 1 - (1 - 0.1)*(1 - 0.3)
PI
PII = 0.2*0.3*0.2
PII
# výsledek
(1 - PI)*(1-PII)

# * Příklad 6. ####
# Ohrada má obdélníkový tvar, východní a západní stěna mají délku 40 m, jižní a severní
# pak 100 m. V této ohradě běhá kůň. Jaká je pravděpodobnost, že je k jižní stěně blíž
# než ke zbývajícím třem?

# geometrická pravděpodobnost
ohrada = 40*100
#blize k jihu
blize_J = 20*60 + 20*20
#pravdepodobnosti
blize_J/ohrada

# * Příklad 7. ####
# U pacienta je podezření na jednu ze čtyř vzájemně se vylučujících nemocí - N1, N2, N3,
# N4 s pravděpodobností výskytu P(N1)=0,1; P(N2)=0,2; P(N3)=0,4; P(N4)=0,3. Laboratorní
# zkouška A je pozitivní v případě první nemoci v 50 % případů, u druhé nemoci v 75 %
# případů, u třetí nemoci v 15 % případů a u čtvrté v 20 % případů. Jaká je
# pravděpodobnost, že výsledek laboratorní zkoušky bude pozitivní?

# věta o úplné pravděpodobnosti
P_N = c(0.1,0.2,0.4,0.3) # P(N1), P(N2), ...
P_PN = c(0.5,0.75,0.15,0.2) # P(P|N1), P(P|N2), ...
P_P = uplna_pravdepodobnost(P_B = P_N, P_AB = P_PN) # P(P)
P_P

# * Příklad 8. ####
# Telegrafické znaky se skládají ze signálů „tečka“, „čárka“. Je statisticky zjištěno,
# že se zkomolí 25 % sdělení „tečka“ a 20 % signálů „čárka“. Dále je známo, že signály
# se používají v poměru 3:2. Určete pravděpodobnost, že byl přijat správně signál,
# jestliže byl přijat signál „tečka“.

# Bayesova věta
P_O = c(0.6, 0.4)   #    P(O.),    P(O-)
P_PO = c(0.75, 0.2) # P(P.|O.), P(P.|O-)
bayes(P_B = P_O, P_AB = P_PO, k = 1) # k = 1 protože správně = O.

# * Příklad 9. ####
# V jednom městě jezdí 85 % zelených taxíků a 15 % modrých. Svědek dopravní nehody
# vypověděl, že nehodu zavinil řidič modrého taxíku, který pak ujel. Testy provedené za
# obdobných světelných podmínek ukázaly, že svědek dobře identifikuje barvu taxíku v 80
# % případů a ve 20 % případů se mýlí.
#  - Jaká je pravděpodobnost, že viník nehody skutečně řídil modrý taxík?
#  - Následně byl nalezen další nezávislý svědek, který rovněž tvrdí, že taxík byl
# modrý. Jaká je nyní pravděpodobnost, že viník nehody skutečně řídil modrý taxík?
#  - Ovlivní pravděpodobnost, že viník nehody skutečně řídil modrý taxík to, zda dva
# výše
# zmínění svědci vypovídali postupně nebo najednou?

# a) opět Bayesova věta
P_B = c(0.85, 0.15)  #    P(Z),    P(M)
P_SB = c(0.20, 0.80) # P(SM|Z), P(SM|M)
bayes(P_B = P_B, P_AB = P_SB, k = 2) # modrý je druhý

# b) první možnost - druhý průchod Bayesem
P_M = bayes(P_B = P_B, P_AB = P_SB, k = 2)
P_B = c(1 - P_M, P_M)  #     P(Z),     P(M)
P_SB = c(0.20, 0.80)   # P(S2M|Z), P(S2M|M)
bayes(P_B = P_B, P_AB = P_SB, k = 2)

# c) nebo odpověděli najednou
P_B = c(0.85, 0.15)      #         P(Z),         P(M)
P_SB = c(0.20^2, 0.80^2) # P(S1M&S2M|Z), P(S1M&S2M|M)
bayes(P_B = P_B, P_AB = P_SB, k = 2)

# * Příklad 10. ####
# Potřebujeme zjistit odpověď na určitou citlivou otázku. Jak odhadnout, kolik procent
# dotazovaných na otázku odpoví ANO a přitom všem respondentům zaručit naprostou
# anonymitu? Jedním z řešení je tzv. dvojitě anonymní anketa:
# Necháme respondenty hodit korunou a dvojkorunou a ti, kterým padl na koruně líc
# napíšou na lísteček odpověď (ANO/NE) na citlivou otázku. Ostatní respondenti napíší,
# zda jim padl na dvojkoruně líc (ANO/NE). Jakým způsobem určíme podíl studentů, kteří
# na citlivou otázku odpověděli ANO?
# Předpokládejme, že respondenti byli dotazování, zda podváděli u zkoušky. Z anketních
# lístků se zjistilo, že „ANO“ odpovědělo 120 respondentů a „NE“ odpovědělo 200
# respondentů. Kolik procent studentů podvádělo u zkoušky?

# věta o úplné pravděpodobnosti
# P(A) = P(K_lic)*P(A|K_lic)+P(K_rub)*P(D_lic|K_rub)
# rovnice 120/320=0.5*x+0.5*0.5
(120/320-0.5^2)/0.5

# * Bonus - Monty Hall Problem ####
#
# Začneme s vygenerováním n instancí soutěže - cena bude náhodný index dveří (1,2,3) za
# kterými se může nacházet cena

n = 10000 # počet pokusů
cena = sample.int(n = 3, size = n, replace = TRUE) # náhdný výběr dveří
head(cena) # head vykresli prvních 6 prvků/řádků

# Totéž pro naši původní volbu - náhodný index dveří.

volba_orig = sample.int(n = 3, size = n, replace = TRUE) # původní volba
head(volba_orig)

# V prvním kole moderátor jedny prázdné dveře otevře, takto se to dá nasimulovat:

otevrene_dvere = rep(0, n) # inicializace vektoru
dvere_c = 1:3 # pomocná proměnná - identifikátory dveří
for (i in 1:n){
    dvere_k_otevereni = c(TRUE, TRUE, TRUE) # inicializace
    dvere_k_otevereni[cena[i]] = FALSE # nesmíme otevřít dveře s cenou
    dvere_k_otevereni[volba_orig[i]] = FALSE # ani naše vybrané dveře
    # ve zbytku jsou buď 2 (pokud jsme se trefili) nebo 1 dveře (pokud ne)
    idx_dvere = dvere_c[dvere_k_otevereni]
    if (length(idx_dvere) == 1){
        otevrene_dvere[i] = idx_dvere # pokud jedny otevřeme je
    } else { # pokud 2 tak jedny náhodně vybereme a otevřeme je
        otevrene_dvere[i] = sample(x = idx_dvere, size = 1)
    }
}
head(otevrene_dvere)

# Naše nová volba pokud se tak rozhodneme - součet indexů je 1+2+3=6 takže pokud my máme
# vybraný nějaký index, dále nějaký index se otevře, tak do zbytku 6 jsou ty třetí =
# naše nová volba.

nova_volba = 6 - (volba_orig + otevrene_dvere)
head(nova_volba)

# Úspěšnost při originální volbě:

p_orig = sum(cena == volba_orig)/n
p_orig

# Úspěšnost při výměně:

p_zmena = sum(cena == nova_volba)/n
p_zmena

p_orig + p_zmena


#!/usr/bin/env Rscript

numsteps <- 10000000

args <- commandArgs(trailingOnly=TRUE)

if (length(args)>0) {
  numsteps <- strtoi(args)
}

cat("Calculating PI using:\n ", numsteps, "slices \n")
cat("  1 process\n")

start <- Sys.time()

sum <- 0.0
step <- 1.0/numsteps

for (i in 1:numsteps) {
  x <- (i - 0.5) * step
  sum <- sum + 4.0/(1.0 + (x^2))
}

mypi = sum * step

stop <- Sys.time()
elapsed <- stop - start

cat("Obtained value of PI:", mypi, "\n")
cat("Time taken:", elapsed, "seconds\n")


NCPgen <- function(q,R,K,CaseN,ConN) {
  # q is the AF
  # R is the RR

  p <- 1-q;

  p_d_aa <- K / (p*p + 2*p*q*R + q*q*R*R);
  p_d_ab <- p_d_aa * R;
  p_d_bb <- p_d_aa * R * R;

  p_aa_d <- p_d_aa * p * p/ K ;
  p_ab_d <- p_d_ab * p * q * 2 / K ;
  p_bb_d <- p_d_bb * q * q/ K ;

  p_aa_u <- (p*p - K * p_aa_d)  / (1-K) ;
  p_ab_u <- (2*p*q - K * p_ab_d) / (1-K) ;
  p_bb_u <- (q*q - K * p_bb_d)  / (1-K)	;

  p_case <- p_aa_d + 0.5*p_ab_d;
  p_con <- p_aa_u + 0.5*p_ab_u;
  q_case <- 1 - p_case ;
  q_con <- 1 - p_con ;

#  NCP <- chisq.test(matrix(c(2*p_case*CaseN,2*p_con*ConN,2*q_case*CaseN,2*q_con*ConN),2,2),correct=F);

  summary(as.table(matrix(c(2*p_case*CaseN,2*p_con*ConN,2*q_case*CaseN,2*q_con*ConN),2,2)))$statistic;

}

denovoGen <- function(R, q,f,CaseN,ConN) {

    # q is number of de novo mutations
    # R is the relative risk of having a variant
    # CaseN is the number of cases - N*r/(1+r)
    # CaseN is the number of controls - N/(1+r)
    MutCases = rpois(CaseN, q * 1* (1-f) )  + rpois(CaseN, q * R * f )
    MutCon = rpois(ConN, q * 1)

    m <- glm(c(MutCases, MutCon)~ c(rep(1, CaseN), rep(0, ConN)), family="poisson")
    -(m$deviance-m$null.deviance)

}

denovoGenPower <- function(R, q,f,CaseN,ConN, p_cut_denovo) {

   pchisq(qchisq(p_cut_denovo, 1, low=F), 1, ncp=denovoGen(R, q,f,CaseN,ConN), low=F)

}

getSingleVarPower <- function(f, AF, R, K, N, r, P_cut_single){
  chi <- unlist(lapply(AF[1:f], function(i){ NCPgen(i,R,K,N*r/(1+r),N/(1+r)) }))
  power_snp <- pchisq(qchisq(P_cut_single, 1, low=F), 1, ncp=chi, low=F)
  ret <- 1-prod(1-power_snp)
  ret
}

getBurdenPower <- function(f, AF, sum_var, R, K, N, r, p_cut_burden){

  ratio <- sum(AF[1:f] * (1-AF[1:f]) ) / sum_var
  chi <- NCPgen(sum(AF) , exp(log(R)*ratio), K, N*r/(1+r),N/(1+r))
  pchisq(qchisq(p_cut_burden, 1, low=F), 1, ncp=chi , low=F)
}

getDenovoPower_parametric <- function(rr, q,f, N, r,  p_cut_denovo){

  MutCases <- N*r/(1+r)
  MutCon <- N/(1+r)
  x1 <- q * 1* (1-f) +  q * rr * f
  x0 <- q * 1
  chi <- (x1-x0)^2/(x1/MutCases+x0/MutCon)
  power <- pchisq(qchisq(p_cut_denovo, 1, low=F), 1, ncp=chi, low=F)
  power
}


Full_Data<-structure(list(item = c("map", "compass", "water", "sandwich",
"glucose", "tin", "banana", "apple", "cheese", "beer", "suntan_cream",
"camera", "T-shirt", "trousers", "umbrella", "waterproof_trousers",
"waterproof_overclothes", "note-case", "sunglasses", "towel",
"socks", "book"), weigth = c(9, 13, 153, 50, 15, 68, 27, 39,
23, 52, 11, 32, 24, 48, 73, 42, 43, 22, 7, 18, 4, 30), value = c(150,
35, 200, 160, 60, 45, 60, 40, 30, 10, 70, 30, 15, 10, 40, 70,
75, 80, 20, 12, 50, 10)), .Names = c("item", "weigth", "value"
), row.names = c(NA, 22L), class = "data.frame")

Bounded_knapsack<-function(Data,W)
{
	K<-matrix(NA,nrow=W+1,ncol=dim(Data)[1]+1)
	0->K[1,]->K[,1]
	matrix_item<-matrix('',nrow=W+1,ncol=dim(Data)[1]+1)
	for(j in 1:dim(Data)[1])
	{
		for(w in 1:W)
		{
			wj<-Data$weigth[j]
			item<-Data$item[j]
			value<-Data$value[j]
			if( wj > w )
			{
				K[w+1,j+1]<-K[w+1,j]
				matrix_item[w+1,j+1]<-matrix_item[w+1,j]
			}
			else
			{
				if( K[w+1,j] >= K[w+1-wj,j]+value )
				{
					K[w+1,j+1]<-K[w+1,j]
					matrix_item[w+1,j+1]<-matrix_item[w+1,j]
				}
				else
				{
					K[w+1,j+1]<-K[w+1-wj,j]+value
					matrix_item[w+1,j+1]<-item
				}
			}
		}
	}
return(list(K=K,Item=matrix_item))
}

backtracking<-function(knapsack, Data)
{
	W<-dim(knapsack$K)[1]
	itens<-c()
	col<-dim(knapsack$K)[2]
	selected_item<-knapsack$Item[W,col]
	while(selected_item!='')
	{
		selected_item<-knapsack$Item[W,col]
		if(selected_item!='')
		{
			selected_item_value<-Data[Data$item == selected_item,]
			if(-knapsack$K[W - selected_item_value$weigth,col-1]+knapsack$K[W,col]==selected_item_value$value)
			{
				W <- W - selected_item_value$weigth
				itens<-c(itens,selected_item)
			}
			col <- col - 1
		}
	}
return(itens)
}

print_output<-function(Data,W)
{
	Bounded_knapsack(Data,W)->Knap
	backtracking(Knap, Data)->Items
	output<-paste('You must carry:', paste(Items, sep = ', '), sep=' ' )
	return(output)
}

print_output(Full_Data, 400)


#' @title calcKristTotalRes
#'
#' @description Calculate total ship resistance (\code{Rtot}) (kN) using the
#' Kristensen method.
#'
#' @param wettedSA Wetted hull surface area (vector of numericals, m^2) (see
#' \code{\link{calcKristWettedSA}})
#' @param Cf Frictional resistance coefficient (vector of numericals,
#' dimensionless) (see \code{\link{calcCf}})
#' @param Cr Residual resistance coefficient (vector of numericals,
#' dimensionless) (see \code{\link{calcKristCr}})
#' @param Ca Incremental hull (roughness) resistance coefficient (vector of
#' numericals, dimensionless) (see \code{\link{calcKristCa}})
#' @param Caa Air resistance coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcKristCaa}})
#' @param seawaterDensity Sea water density. Default = 1.025 (g/cm^3). Can
#' supply either a vector of numericals, a single number, or rely on the default
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#' @param serviceMargin A service margin to account for weather and sea effects:
#' \itemize{\item Coastal operations = 10 \item At-sea operations = 15} Can
#' supply either a vector of numericals, a single number, or rely on the default
#'
#' @details
#' Note that service margin is included here as a resistance term.
#'
#' @return \code{Rtot} (vector of numericals, kN)
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'@seealso \itemize{
#'\item \code{\link{calcCf}}
#'\item \code{\link{calcSpeedUnitConversion}}
#'}
#'
#' @family Kristensen Calculations
#' @family Resistance Calculations
#'
#' @examples
#' calcKristTotalRes(10714.62,0.0015,0.00043,6.46e-05,5e-05,1.025,10.8,15)
#'
#' @export

calcKristTotalRes<- function(wettedSA,Cf,Cr,Ca,Caa,seawaterDensity,shipSpeed,
                             serviceMargin){

  Rtot<- wettedSA*(Cf+Cr+Ca+Caa)*seawaterDensity*(shipSpeed^2)*0.5*(1+serviceMargin/100)
  return(Rtot)
}


inputs <- c(1, 2, 3, 2.5)
weights1 <- c(0.2, 0.8, -0.5, 1.0)
weights2 <- c(0.5, -0.91, 0.26, -0.5)
weights3 <- c(-0.26, -0.27, 0.17, 0.87)
bias1 <- 2
bias2 <- 3
bias3 <- 0.5

output <- c(inputs[1] * weights1[1] + inputs[2] * weights1[2] + inputs[3] * weights1[3] + inputs[4] * weights1[4] + bias1,
            inputs[1] * weights2[1] + inputs[2] * weights2[2] + inputs[3] * weights2[3] + inputs[4] * weights2[4] + bias2,
            inputs[1] * weights3[1] + inputs[2] * weights3[2] + inputs[3] * weights3[3] + inputs[4] * weights3[4] + bias3)
output


v = c(2, 3, 7, 1, 5, 10, 2)
soma = 0
for(i in 1:length(v)) {
  soma = soma + v[i]*v[i]
}
print(sqrt(soma))


"""
К статье по метаанализам

"""

library(epiR)
library(pwr)

# Размер эффекта

# График Стандартной ошибки

SE = c()
mu = c()

for (i in seq(500)) {
  sample <- rnorm(n = i, mean = 0, sd = 3)
  SE[i] = sd(sample)/sqrt(length(sample))
  mu[i] =  mean(sample)
}

plot(mu,xlab = 'Sample size', ylab = 'Sample mean', type="l")

plot(SE,xlab = 'Sample size', ylab = 'Standard error', type="l")

# standartise demo

m1 =  abs(-6)/2
m2 = (-14)/10
sd1 = sqrt(2*(1-0.5)/n1 + (m1)/(2*n1))
sd2 = sqrt(2*(1-0.5)/n2 + (m2)/(2*n2))

sd1r = sqrt((2^2 + 2^2 - 2*(0.5 * 2*2))/n1)
sd2r = sqrt((10^2 + 16^2 - 2*(0.5 * 10*16))/n2)

n1 = 58
n2 = 82

-14 - sd2r

-m1 - 2*sd1
m2 + 2*sd2

pooled_sd = sqrt(((n1-1) * sd1^2 + (n2-1) * sd2^2)/(n1 + n2 - 2))

# Модели

# Фиксированные эффекты

SE = c()
mu = c()

for (i in seq(100)) {
  sample <- rnorm(n = i, mean = 0, sd = 3)
  SE[i] = sd(sample)/sqrt(length(sample))
  mu[i] =  mean(sample)
}

plot(mu, SE, xlab = 'Effect size', ylab = 'Standard error', xlim=c(-2,2))
abline(v=0, col='red', lwd=3)

"""
Forest plot
"""

library(meta)

data(Fleiss1993cont)

example = metacont(n.psyc, mean.psyc, sd.psyc, n.cont, mean.cont, sd.cont,
         data = Fleiss1993cont, studlab = paste(study, year),
         random = TRUE, fixed=TRUE)

forest.meta(example)

drapery(example, labels = "studlab", type = "pvalue")

"""
Effect size
"""

x <- seq(- 5, 5, by = 0.01)
y <- dt(x, df = 50)

# расчет критических значений
critical = qt(p=0.05/2, df=length(x), lower.tail=F)
critical_one_sided = qt(p=0.05, df=length(x), lower.tail=F)

plot(x,
     y,
     type = "l",
     main = " ",
     xlab="t-статистики", ylab="Плотность вероятности",
     las=1,
     col = 'blue',
     xlim=c(-5, 6)
)

lines(x + 2,
      y,
      type = "l",
      main = " ",
      xlab="t-статистики", ylab="Плотность вероятности",
      las=1,
      col = 'red'
)

"""
Funnel plot
"""

library(metafor)

### copy BCG vaccine data into 'dat'
dat <- dat.bcg

### calculate log risk ratios and corresponding sampling variances
dat <- escalc(measure="RR", ai=tpos, bi=tneg, ci=cpos, di=cneg, data=dat)

### fit random-effects model
res <- rma(yi, vi, data=dat, slab=paste(author, year, sep=", "))

### draw a standard funnel plot
funnel(res)

### note: same plot, except that reference line is centered at zero
funnel(dat$yi, dat$vi)

### the with() function can be used to avoid having to retype dat$... over and over
with(dat, funnel(yi, vi))

"""
Egger test
"""


#
# Exemplo 1
#

# Serie de Taylor para a exponencial de x
# em x=3 em volta do ponto x=2 até n=4
x <- 3
taylor <- exp(2) + exp(2) * (x - 2)
taylor <- taylor + exp(2) * (x - 2)^2 / factorial(2)
taylor <- taylor + exp(2) * (x - 2)^3 / factorial(3)
taylor <- taylor + exp(2) * (x - 2)^4 / factorial(4)

taylor
# valor real da exponencial de x
exp(x)


# DySyn_distance <- function (x, method= "hellinger"){
#
#   if (method == "ord") {
#     x_dif <- x[1,]-x[2,]
#     acum <- 0
#     aux <- 0
#     for(i in 1:length(x_dif)){
#       aux <- x_dif[i]+aux
#       acum <- acum+aux
#     }
#     return(abs(acum))
#   }
#   return(as.numeric(philentropy::distance(x, method = method, p=0.5)))
#
# }

DySyn_distance <- function (x, method= "hellinger"){

  if (method == "ord") {
    x_dif <- x[1,]-x[2,]
    acum <- 0
    aux <- 0
    for(i in 1:length(x_dif)){
      aux <- x_dif[i]+aux
      acum <- acum+aux
    }
    return(abs(acum))
  }
  if(method == "topsoe"){
    re <- 0
    for(i in 1:ncol(x))
      re <- re + ( x[1,i] * log( (2*x[1,i])/(x[1,i] + x[2,i]) ) + x[2,i]*log( (2*x[2,i])/(x[2,i] + x[1,i]) ) )

    return(re)
  }
  if(method == "jensen_difference"){
    re <- 0
    for(i in 1:ncol(x))
      re <- re + (  ((x[1,i]*log(x[1,i]) + x[2,i]*log(x[2,i]) )/2) - ((x[1,i] + x[2,i])/2 ) * log((x[1,i] + x[2,i])/2 )   )

    return(re)
  }
  if(method == "taneja"){
    re <- 0
    for(i in 1:ncol(x))
      re <- re + ( ((x[1,i] + x[2,i])/2) * log( (x[1,i] + x[2,i]) / (2 * sqrt(x[1,i] * x[2,i]) )) )
    return(re)
  }
  if(method == "hellinger"){
    re <- 0
    for(i in 1:ncol(x))
      re <- re + sqrt((x[1,i] * x[2,i]))
    return(2*sqrt(1 - re))
  }

  if(method == "prob_symm"){
    re <- 0
    for(i in 1:ncol(x))
      re <- re + ( (x[1,i] - x[2,i] )^2 / (x[1,i] +x[2,i]) )
    return(2*re)
  }

  stop("measure argument must be a valid option")
}

getHist <- function(scores, nbins){
  breaks <- seq(0,1,length.out = nbins+1)
  breaks <- c(breaks[-length(breaks)], 1.1)
  re <- rep((1/(length(breaks)-1)),length(breaks)-1)
  for(i in 2:length(breaks)){
    re[i-1] <- (re[i-1] + length(which(scores >= breaks[i-1] & scores < breaks[i])))/(length(scores)+1)
  }
  return(re)
}

TernarySearch  <- function(left, right, f, eps=1e-4){
  while(TRUE){
    if (abs(left - right) < eps) return((left + right) / 2)

    leftThird  <- left + (right - left) / 3
    rightThird <- right - (right - left) / 3

    if (f(leftThird) > f(rightThird))
      left <- leftThird
    else
      right <- rightThird
  }

}


halve <- function(a) floor(a/2)
double <- function(a) a*2
iseven <- function(a) (a%%2)==0

ethiopicmult <- function(plier, plicand, tutor=FALSE) {
  if (tutor) { cat("ethiopic multiplication of", plier, "and", plicand, "\n") }
  result <- 0
  while(plier >= 1) {
    if (!iseven(plier)) { result <- result + plicand }
    if (tutor) {
      cat(plier, ", ", plicand, " ", ifelse(iseven(plier), "struck", "kept"), "\n", sep="")
    }
    plier <- halve(plier)
    plicand <- double(plicand)
  }
  result
}

print(ethiopicmult(17, 34, TRUE))


## Author: Sergio García Prado
## Title: Statistical Inference - Non parametric Tests - Exercise 15

rm(list = ls())

x <- c(0.01, 0.02, 0.03, 0.01, 0.01, 0.01, 0.02, 0.04,
       0.05, 0.03, 0.02, 0.01, 0.06, 0.01, 0.01, 0.04)

y <- c(0.02, 0.04, 0.03, 0.01, 0.04, 0.06, 0.01, 0.01,
       0.05, 0.01, 0.04, 0.03, 0.04, 0.06, 0.03, 0.01)

(s <- (x - y)[x != y])
# -0.01 -0.02 -0.03 -0.05 0.01 0.03 0.02 -0.02 -0.02 0.02 -0.05 -0.02 0.03

(n <- length(s))
# 13

sum(duplicated(s))
# 5

(V <- sum((s > 0) * rank(abs(s))))
# 30.5

(V.mean <- n * (n + 1) / 4)
# 45.5

(V.var <- n * (n + 1) * (2 * n + 1) / 24)
# 204.75

# Asymptotic pvalue (with continuity correction, without tie correction)
2 * (1 - pnorm(abs(V + 0.5 * sign(V.mean - V) - V.mean) / sqrt(V.var)))
# 0.310896828516612

## Asymptotic pvalue (with continuity correction, with tie correction
# TODO

# Exact pvalue (not valid due to ties)
2 * (1 - psignrank(V - (V.mean < V), n, lower.tail = V.mean < V))
# 0.339599609375

wilcox.test(x, y, paired = TRUE, alternative = "two.sided", exact = FALSE)
# Wilcoxon signed rank test with continuity correction
#
# data:  x and y
# V = 49, p-value = 0.3388
# alternative hypothesis: true location shift is not equal to 0


# Using arithmetic operators on variables
number1 <- 10
number2 <- 3

# Addition
number1 + number2

# Subtraction
number1 - number2

# Multiplication
number1 * number2

# Exponent
number1 ^ number2

# Modulus
number1 %% number2

# Integer Division
number1 %/% number2

# Using arithmetic operators on vectors
vector1 <- c(5, 10, 15)
vector2 <- c(3, 6, 9)

# Addition
vector1 + vector2

# Subtraction
vector1 - vector2

# Multiplication
vector1 * vector2

# Division
vector1 / vector2

# Exponent
vector1 ^ vector2

# Modulus
vector1 %% vector2

# Integer Division
vector1 %/% vector2

0 - Learn R from scratch/arithmetic_operators.r


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

calculateW2 <- function(x) {
    # We call mean and sd functions outside of loop for performance reasons
    mean <- mean(x)
    s <- sd(x)

    result <- c()

    tmp <- 0

    # Loop vector
    for (i in 1:length(x)) {
        if (abs((i - mean) / s) < 1) {
            tmp = 1
        } else if (abs((i - mean) / s) >= 1 &
                   abs((i - mean) / s) < 2) {
            tmp = 0.5
        } else {
            tmp = 0
        }
        result <- append(result, tmp)
    }

    return(result)

}

calculateW3 <- function(x) {
    mean <- mean(x)
    s <- sd(x)

    tmp = 1 / (s * sqrt(2 * pi))
    result = tmp * exp((-1 / (2 * s ** 2)) * ((x - mean) ** 2))

    return(result)

}

# This function is the solution of the exercise
f <- function(x) {
    # Initialize object to return
    result <- c()

    # Calculate w1
    result[[1]] <- rep(1, length(x))
    # Calculate w2
    result[[2]] <- calculateW2(x)
    # Calculate w3
    result[[3]] <- calculateW3(x)
    return(result)
}

# Call function f with a vector with values from 1 to 50
f(1:50)


cube <- function(x) x^3
croot <- function(x) x^(1/3)
compose <- function(f, g) function(x){f(g(x))}

f1 <- c(sin, cos, cube)
f2 <- c(asin, acos, croot)

for (i in 1:3) {
	print (compose(f1[[i]], f2[[i]])(.5))
}