#' @title f-test
#' @description f-test
#' @param sd1 First standard deviation
#' @param sd2 Second standard deviation
#' @param df1 First degrees of freedom
#' @param df2 Second degrees of freedom
#' @param prob Probability
#' @return Test decision
#' @rdname f_test
f_test <- function(sd1, sd2, df1, df2, prob){
  if(sd1 > sd2){
    F.estimated <- sd1^2/sd2^2
    F.quantile <- qf(p = prob, df1 = df1, df2 = df2)
  }else{
    F.estimated <- sd2^2/sd1^2
    F.quantile <- qf(p = prob, df1 = df1, df2 = df2)
  }
  if(F.estimated < F.quantile){
    note <- TRUE
  }else{
    note <- FALSE
  }
  return(list(f_estimated = F.estimated, f_quantile = F.quantile, decision = note))
}

#' @title deform.snet
#' @description Two-epochs deformation analysis based on congruency testing
#' @param snet_1_path Path to the data of the first epoch of the measurements
#' @param snet_2_path Path to the data of the second epoch of the measurements
#' @param sd.apriori Apriori standard deviation
#' @param units Units of the results, Default: 'mm'
#' @param dim_type Dimension type of the network, Default: '1D'
#' @param prob Probability for statistical testing, Default: 0.95
#' @param wdh_model Weightening model for leveling measurements, Default: list("n_dh", "sd_dh", "d_dh", "E")
#' @return dataframe with two columns: "Name" indicating the name of the point and "stable" indicating the stability status of the point (TRUE or FALSE)
#' @details DETAILS
#' @examples
#' \dontrun{
#' if(interactive()){
#'  #EXAMPLE1
#'  }
#' }
#' @seealso
#' @rdname snet.stable
#' @export
#' @importFrom dplyr arrange select case_when
#' @importFrom MASS ginv
deform.snet <- function(snet_1_path, snet_2_path, sd.apriori, units = "mm",  dim_type = "1D", prob = 0.95, wdh_model = list("n_dh", "sd_dh", "d_dh", "E")){
  "%!in%" <- Negate("%in%")
  wdh_model <- wdh_model[[1]]
  units.lookup.table <- c(mm = 1000, cm = 100, m = 1)
  if(length(sd.apriori) == 1){
    sd0_i <- sd.apriori[1]
    sd0_j <- sd.apriori[1]
  }else{
    sd0_i <- sd.apriori[1]
    sd0_j <- sd.apriori[2]
  }
  #=================== Reading snets ===============================
  snet_i <- suppressWarnings(read_surveynet(file = snet_1_path))
  snet_j <- suppressWarnings(read_surveynet(file = snet_2_path))

  #=================== Checking snets ==============================
  if(!identical(snet_i$observations[, c("from", "to")], snet_j$observations[, c("from", "to")])){
    print("Observation plans are not identical in two epochs.")
  }

  used_points_i <- unique(c(snet_i$observations$from, snet_i$observations$to))
  used_points_j <- unique(c(snet_j$observations$from, snet_j$observations$to))

  if(!!any(used_points_i %!in% snet_i[[1]]$Name)){
    stop(paste("There is no coordinates for point", paste(used_points_i[which(used_points_i %!in% snet_i[[1]]$Name)], "in reference epoch"), sep = " "))
  }else{used_points_i <- snet_i[[1]]$Name
  }

  if(!!any(used_points_i %!in% snet_i[[1]]$Name)){
    stop(paste("There is no coordinates for point", paste(used_points_j[which(used_points_j %!in% snet_j[[1]]$Name)]), "in target epoch",  sep = " "))
  }else{used_points_j <- snet_j[[1]]$Name
  }

  if(!identical(used_points_i, used_points_i)){
    print("Two epochs contains different points.")
    if(length(used_points_i) > length(used_points_j)){
      print(paste("Points", used_points_i[which(used_points_i %!in% used_points_j)], "do not exist in the target epoch", sep = " "))
      used_points <- used_points_j
    }else{
      if(length(used_points_i) < length(used_points_j)){
        print(paste("Points", used_points_j$Points$Name[which(used_points_j %!in% used_points_i)], "do not exist in the reference epoch", sep = " "))
        used_points <- used_points_i
      }
      print("Only the results for common points will be processed.")
    }
  }else{
    used_points <- used_points_i
  }

  if(!identical(snet_i$Points$h, snet_j$Points$h)){
    stop(print("Approximate coordinates in two epoches must be the same"))
  }

  if(!identical(snet_i$points$Name[snet_i$points$Point_object], snet_j$points$Name[snet_j$points$Point_object])){
    stop(print("Reference points must be the same"))
  }
  snet_i[[1]] <- snet_i[[1]][match(snet_i[[1]]$Name, used_points), ] %>% dplyr::arrange(Point_object, desc = TRUE)
  snet_j[[1]] <- snet_j[[1]][match(snet_j[[1]]$Name, used_points), ] %>% dplyr::arrange(Point_object, desc = TRUE)
  #===========================================================================

  #=================== Adjustment ============================================
  snet_i_adj <- suppressMessages(adjust.snet(adjust = TRUE, survey.net = snet_i, dim_type = "1D", sd.apriori = sd0_i,  all = TRUE, prob = prob, wdh_model = wdh_model))
  snet_j_adj <- suppressMessages(adjust.snet(adjust = TRUE, survey.net = snet_j, dim_type = "1D", sd.apriori = sd0_j,  all = TRUE, prob = prob, wdh_model = wdh_model))
  if(any(c(snet_i_adj$Summary$`Test decision`, snet_j_adj$Summary$`Test decision`) != "Model is correct")) {
    return(list(snet_1_adj = snet_i_adj[1:3], snet_2_adj = snet_i_adj[1:3]))
    stop("One epoch adjustment failed")
  }
  #============================================================================
  points_i <- snet_i_adj$Points
  points_j <- snet_j_adj$Points

  points_i$Stable <- NA
  points_j$Stable <- NA

  Qx_i <- snet_i_adj$Matrices$Qx
  Qx_j <- snet_j_adj$Matrices$Qx

  #=================== Calculating reference accuracy factor ==================
  s0_i <- snet_i_adj$Summary$`sigma aposteriori`
  s0_j <- snet_j_adj$Summary$`sigma aposteriori`
  f_i <- snet_i_adj$Summary$`Degrees of freedom`
  f_j <- snet_j_adj$Summary$`Degrees of freedom`

  if(f_test(sd1 = s0_i, sd2 = s0_j, df1 = f_i, df2 = f_j, prob = prob)[[3]]){
    s0 <- sqrt((f_i*s0_i^2+f_j*s0_j^2)/(f_i + f_j))
    f0 <- f_i + f_j
  }else{
    if(s0_i > s0_j){
      s0 <- s0_i
      f0 <- f_i
      print("Two epoches are not equally precised! Computation will be continued with the worse reference standard deviation.")
    }else{
      s0 <- s0_j
      f0 <- f_j
      print("Two epoches are not equally precised! Computation will be continued with the worse reference standard deviation.")
    }
  }
  #============================================================================

  #=================== Testing whole network ==================================

  d_all <- (points_j$h - points_i$h)*units.lookup.table[units]

  Qd_all <- Qx_i + Qx_j

  Qd_all_ginv <- MASS::ginv(Qd_all)

  dd_all <- (crossprod(d_all, Qd_all) %*% d_all)

  teta_all_squared <- ((crossprod(d_all, Qd_all_ginv) %*% d_all)/qr(Qd_all)$rank)

  snet_test <- f_test(sd1 = sqrt(teta_all_squared), sd2 = s0, df1 = qr(Qd_all)$rank, df2 = f0, prob = prob)

  if(sum(points_i$Point_object) == 0){
    fix <- "all"
    if(!snet_test[[3]]){
      r_points_ind <- !points_i$Point_object
      names(r_points_ind) <- points_i$Name
      iter <- 0
      m <- sum(r_points_ind)
      while(!snet_test[[3]] & m > 1) {
        iter = iter + 1
        r_ind_matrix <- diag(sum(r_points_ind)) == 1
        teta_r <- rep(NA, sum(r_points_ind))
        for(i in 1:sum(r_points_ind)){
          drb <- d_all[r_points_ind][r_ind_matrix[i, ]]
          drf <- d_all[r_points_ind][!r_ind_matrix[i, ]]

          Qdbb  <- Qd_all_ginv[r_points_ind, r_points_ind][r_ind_matrix[i, ], r_ind_matrix[i, ]]
          Qdbf  <- Qd_all_ginv[r_points_ind, r_points_ind][r_ind_matrix[i, ], !r_ind_matrix[i, ]]
          Qdfb  <- Qd_all_ginv[r_points_ind, r_points_ind][!r_ind_matrix[i, ], r_ind_matrix[i, ]]
          Qdff  <- Qd_all_ginv[r_points_ind, r_points_ind][!r_ind_matrix[i, ], !r_ind_matrix[i, ]]

          dsb <- drb + solve(Qdbb) %*% Qdbf %*% drf
          Qsff <- Qdff - Qdfb %*% solve(Qdbb) %*% Qdbf

          dd_b <- (crossprod(dsb, Qdbb) %*% dsb)
          teta_r[i] <- dd_b
        }
        names(teta_r) <- points_i$Name[r_points_ind]
        max_teta_name <- names(teta_r[which(teta_r==max(teta_r))])
        points_i[points_i$Name == max_teta_name, "Stable"] <- FALSE
        points_j[points_j$Name == max_teta_name, "Stable"] <- FALSE

        r_points_ind[which(points_i$Stable == FALSE)] <- FALSE
        names(r_points_ind) <- points_i$Name

        d_rest <- d_all[r_points_ind]

        Qd_rest_ginv <- Qd_all_ginv[r_points_ind, r_points_ind]

        dd_rest <- (crossprod(d_rest, Qd_rest_ginv) %*% d_rest)

        teta_rest_squared <- ((crossprod(d_rest, Qd_rest_ginv) %*% d_rest)/qr(Qd_rest_ginv)$rank)

        snet_test <- f_test(sd1 = sqrt(teta_rest_squared), sd2 = s0, df1 = qr(Qd_rest_ginv)$rank, df2 = f0, prob = prob)
        m <- sum(r_points_ind)
      }
    }
  }else{
    # ================== Testing for reference points ============================

    r_points_names <- snet_i_adj$Points$Name[!snet_i_adj$Points$Point_object]
    o_points_names <- snet_i_adj$Points$Name[snet_i_adj$Points$Point_object]

    r_points_ind <- !points_i$Point_object
    names(r_points_ind) <- points_i$Name

    dr <- d_all[r_points_ind]
    names(dr) <- points_i$Name[r_points_ind]
    do <- d_all[!r_points_ind]
    names(do) <- points_i$Name[!r_points_ind]

    Qdrr <- Qd_all_ginv[r_points_ind, r_points_ind]
    Qdro  <- Qd_all_ginv[r_points_ind, !r_points_ind]
    Qdor  <- Qd_all_ginv[!r_points_ind, r_points_ind]
    Qdoo  <- Qd_all_ginv[!r_points_ind, !r_points_ind]

    dso <- do + solve(Qdoo) %*% Qdor %*% dr
    Qsrr <- Qdrr - Qdro %*% solve(Qdoo) %*% Qdor

    dd_r <- (crossprod(dr, Qsrr) %*% dr) # kvadratna forma

    teta_r_squared <- ((crossprod(dr, Qsrr) %*% dr)/qr(Qsrr)$rank)

    r_test <- f_test(sd1 = sqrt(teta_r_squared), sd2 = s0, df1 = qr(Qsrr)$rank, df2 = f0, prob = prob)

    if(!r_test[[3]]){
      iter <- 0
      m <- sum(r_points_ind)
      while(!r_test[[3]] & m > 1) {
        iter = iter + 1
        r_ind_matrix <- diag(sum(r_points_ind)) == 1
        teta_r <- rep(NA, sum(r_points_ind))
        for(i in 1:sum(r_points_ind)){
          drb <- d_all[r_points_ind][r_ind_matrix[i, ]]
          drf <- d_all[r_points_ind][!r_ind_matrix[i, ]]

          Qdbb <- Qdrr[r_ind_matrix[i, ], r_ind_matrix[i, ]]
          Qdbf  <- Qdrr[r_ind_matrix[i, ], !r_ind_matrix[i, ]]
          Qdfb  <- Qdrr[!r_ind_matrix[i, ], r_ind_matrix[i, ]]
          Qdff  <- Qdrr[!r_ind_matrix[i, ], !r_ind_matrix[i, ]]

          dsb <- drb + solve(Qdbb) %*% Qdbf %*% drf
          Qsff <- Qdff - Qdfb %*% solve(Qdbb) %*% Qdbf

          dd_b <- (crossprod(dsb, Qdbb) %*% dsb)
          teta_r[i] <- dd_b
        }
        names(teta_r) <- points_i$Name[r_points_ind]
        max_teta_name <- names(teta_r[which(teta_r==max(teta_r))])
        points_i[points_i$Name == max_teta_name, "Stable"] <- FALSE
        points_j[points_j$Name == max_teta_name, "Stable"] <- FALSE

        r_points_ind <- is.na(!points_i$Point_object & points_i$Stable)
        names(r_points_ind) <- points_i$Name

        dr <- d_all[r_points_ind]
        names(dr) <- points_i$Name[r_points_ind]
        do <- d_all[!r_points_ind]
        names(do) <- points_i$Name[!r_points_ind]

        Qdrr <- Qd_all_ginv[r_points_ind, r_points_ind]
        Qdro  <- Qd_all_ginv[r_points_ind, !r_points_ind]
        Qdor  <- Qd_all_ginv[!r_points_ind, r_points_ind]
        Qdoo  <- Qd_all_ginv[!r_points_ind, !r_points_ind]

        Qsrr <- Qdrr - Qdro %*% solve(Qdoo) %*% Qdor

        teta_r_squared <- ((crossprod(dr, Qsrr) %*% dr)/qr(Qsrr)$rank)

        r_test <- f_test(sd1 = sqrt(teta_r_squared), sd2 = s0, df1 = qr(Qsrr)$rank, df2 = f0, prob = prob)
        m <- sum(r_points_ind)
      }
    }
    #================== Testing for object points ==============================

    points_i$Stable[r_points_ind] <- TRUE
    points_i$Stable[!points_i$Stable] <- NA

    points_j$Stable[r_points_ind] <- TRUE
    points_j$Stable[!points_j$Stable] <- NA

    o_points_ind <- !r_points_ind
    names(o_points_ind) <- points_i$Name

    dso <- do + solve(Qdoo) %*% Qdor %*% dr
    teta_o_squared <- ((crossprod(dso, Qdoo) %*% dso)/qr(Qdoo)$rank)
    o_test <- f_test(sd1 = sqrt(teta_o_squared), sd2 = s0, df1 = qr(Qdoo)$rank, df2 = f0, prob = prob)

    if(!o_test[[3]]){
      iter <- 0
      m <- sum(o_points_ind)
      while(!o_test[[3]] & m > 1) {
        iter = iter + 1
        o_ind_matrix <- diag(sum(is.na(points_i$Stable))) == 1
        teta_o <- rep(NA, sum(is.na(points_i$Stable)))
        dobs <- rep(NA, sum(is.na(points_i$Stable)))
        Qdoo_o <- Qd_all_ginv[o_points_ind, o_points_ind]
        for(i in 1:sum(o_points_ind)){
          drb <- (points_j$h[is.na(points_i$Stable)][o_ind_matrix[i, ]] - points_i$h[is.na(points_i$Stable)][o_ind_matrix[i, ]])*units.lookup.table[units]
          drf <- (points_j$h[is.na(points_i$Stable)][!o_ind_matrix[i, ]] - points_i$h[is.na(points_i$Stable)][!o_ind_matrix[i, ]])*units.lookup.table[units]

          Qdbb  <- Qdoo_o[o_ind_matrix[i, ], o_ind_matrix[i, ]]
          Qdbf  <- Qdoo_o[o_ind_matrix[i, ], !o_ind_matrix[i, ]]
          Qdfb  <- Qdoo_o[!o_ind_matrix[i, ], o_ind_matrix[i, ]]
          Qdff  <- Qdoo_o[!o_ind_matrix[i, ], !o_ind_matrix[i, ]]

          dsb <- drb + solve(Qdbb) %*% Qdbf %*% drf
          Qsff <- Qdff - Qdfb %*% solve(Qdbb) %*% Qdbf

          dd_b <- (crossprod(dsb, Qdbb) %*% dsb)
          teta_o[i] <- dd_b
          dobs[i] <- drb
        }
        names(teta_o) <- points_i$Name[o_points_ind]
        names(dobs) <- points_i$Name[o_points_ind]
        max_teta_name <- names(teta_o[which(teta_o==max(teta_o))])
        max_do <- dobs[which(teta_o == max(teta_o))]
        points_i[points_i$Name == max_teta_name, "Stable"] <- FALSE
        points_j[points_j$Name == max_teta_name, "Stable"] <- FALSE

        o_points_ind <- is.na(points_i$Stable)
        names(o_points_ind) <- points_i$Name

        # Qdrr <-  Qd_all_ginv[o_points_ind, o_points_ind]
        # Qdro  <- Qd_all_ginv[o_points_ind, !o_points_ind]
        # Qdor  <- Qd_all_ginv[!o_points_ind, o_points_ind]
        # Qdoo  <- Qd_all_ginv[!o_points_ind, !o_points_ind]

        Qdrr <-  Qd_all_ginv[(!r_points_ind & o_points_ind), (!r_points_ind & o_points_ind)]
        Qdro  <- Qd_all_ginv[(!r_points_ind & !o_points_ind), (!r_points_ind & o_points_ind)]
        Qdor  <- Qd_all_ginv[(!r_points_ind & o_points_ind), (!r_points_ind & !o_points_ind)]
        Qdoo  <- Qd_all_ginv[(!r_points_ind & !o_points_ind), (!r_points_ind & !o_points_ind)]

        do <- d_all[!r_points_ind & o_points_ind]

        Qsrr <- Qdrr - Qdro %*% solve(Qdoo) %*% Qdor

        teta_o_squared <- ((crossprod(do, Qsrr) %*% do)/qr(Qsrr)$rank)
        o_test <- f_test(sd1 = sqrt(teta_o_squared), sd2 = s0, df1 = qr(Qsrr)$rank, df2 = f0, prob = prob)

        m <- sum(o_points_ind)
        if(!o_test[[3]] & m == 1){
          points_i[o_points_ind, "Stable"] <- FALSE
          points_j[o_points_ind, "Stable"] <- FALSE
        }
      }
    }

  }
  points_i$Stable[is.na(points_i$Stable)] <- TRUE
  points_j$Stable[is.na(points_j$Stable)] <- TRUE

  return(points_i %>% dplyr::select(id, Name, Stable))
}


# establece ruta para leer/escribir
setwd("~/Desktop/sip/data")

# lee datos
d <- read.csv("ptot-edo-2010-2020.csv")
str(d)

# quita total nacional
d <- d[-which(d$edon==33),]

# recalcula cambio %
d$chg <- NULL
d$chg <- d$ptot2020 / d$ptot2010

# población total
sum(d$ptot2020)
# cambio
sum(d$ptot2020) / sum(d$ptot2010)
# subre/sub-crecimeiento
d$sobsub <- round(d$chg - sum(d$ptot2020) / sum(d$ptot2010), 2)
d[order(d$sobsub), c("estado", "sobsub")]

quantile(d$sobsub, probs = c(0,.33,.5,.67,1))

quantile(d$ptot2020, probs = c(0,.33,.5,.67,1))
d$size <- 0
d$size[d$ptot2020 <= 2332000]                         <- 1
d$size[d$ptot2020 >  2332000 & d$ptot2020 <= 3763000] <- 2
d$size[d$ptot2020 >  3763000]                         <- 3
# factor
d$size <- factor(d$size, levels = 1:3, labels = c("ch","med","gde"))
table(d$size)

# ¿cuántas personas cree Ud. que debería representar un diputado federal? = DIVISOR
r1787 <- 33000 # el techo de 1878 (constitución EUA dice r > 30000)
# divisor ideal EEUU hoy (nacional)
r.usa <- round(328200000 / 435)
r.usa

# relación ideal mx 2020
r2020 <- round(sum(d$ptot2020) / 300)
# relación ideal mx previas
r1990 <- round(sum(d$ptot1990) / 300)
r2000 <- round(sum(d$ptot2000) / 300)
r2010 <- round(sum(d$ptot2010) / 300)
r1990
r2000
r2010
r2020

# Si usaramos esto
R <- 100000

# Jeferson:
# (1) Población del estado por divisor = COCIENTE
# (2) Parte entera del conciente = APPORTIONMENT
app <- data.frame(edo = d$edo,
                  jef90 = as.integer(d$ptot1990 / R),
                  jef00 = as.integer(d$ptot2000 / R),
                  jef10 = as.integer(d$ptot2010 / R),
                  jef20 = as.integer(d$ptot2020 / R))
# (3) Mínimo dos por estado (regla Mx, no EEUU)
app$jef90[app$jef90<2] <- 2
app$jef00[app$jef00<2] <- 2
app$jef10[app$jef10<2] <- 2
app$jef20[app$jef20<2] <- 2
app

# tamaño del Congreso resultante, muy grande
colSums(app[,-1])

# pongamos la tercera parte
R  <- 300000
app <- data.frame(edo = d$edo,
                  jef90 = as.integer(d$ptot1990 / R),
                  jef00 = as.integer(d$ptot2000 / R),
                  jef10 = as.integer(d$ptot2010 / R),
                  jef20 = as.integer(d$ptot2020 / R))
# (3) Mínimo dos por estado (regla Mx, no EEUU)
app$jef90[app$jef90<2] <- 2
app$jef00[app$jef00<2] <- 2
app$jef10[app$jef10<2] <- 2
app$jef20[app$jef20<2] <- 2
app
# tamaño del Congreso resultante, muy grande
colSums(app[,-1])

# hamilton compromise
# (1) Fija el tamaño del cuerpo dada la relación de representación
N <- as.integer( sum(d$ptot2020) / R )
N  # 420, no 403, dice Hamilton. Algunas fracciones tendrán q asignarse para llegar al tamaño
# (2) Regla de tres:  N * Pob estatal / Pob total = cociente
Q = N * (d$ptot2020 / sum(d$ptot2020))
entero <-     as.integer(Q)
resto <-  Q - as.integer(Q)
# (3) Mínimo uno por estado
entero[entero<2] <- 2
# Cuántos hay?
faltan <- N - sum(entero) # falta asignar 17
app$ham20 <- entero
sel <- order(-resto)[1:faltan] # índices de los 17 restos mayores
# verifica
resto[sel]
resto[-sel]
# distribuye los diputados restantes
app$ham20[sel] <- app$ham20[sel] + 1
# verifica
sum(app$ham20)

app[,c("edo","jef20","ham20")]
# población creciente
app$dif <- app$ham20 - app$jef20
app$dif.r <- round(app$ham20 / app$jef20,2)
app[order(d$ptot2020),c("edo","jef20","ham20","dif","dif.r")]

# descripción según tamaño del estado
app$size <- d$size
with(app, table(size, dif))
with(app, table(size, dif.r))
with(app, aggregate(dif,   list(size), mean))
with(app, aggregate(dif.r, list(size), mean))

# mejor comparación con cuerpos del mismo tamaño
# jeferson
R  <- sum(d$ptot2020) / 300 # con SMDs de diputados
R  <- sum(d$ptot2020) / 315 # prueba-y-error para que suma de enteros llegue a 300
app <- data.frame(edo = d$edo,
                  jef20 = as.integer(d$ptot2020 / R))
app$jef20[app$jef20<2] <- 2
app
# tamaño del Congreso resultante, muy grande
sum(app[,-1])

# hamilton
N <- 300
Q = N * (d$ptot2020 / sum(d$ptot2020))
entero <-     as.integer(Q)
resto <-  Q - as.integer(Q)
# (3) Mínimo uno por estado
entero[entero<2] <- 2
# Cuántos hay?
faltan <- N - sum(entero) # falta asignar 17
app$ham20 <- entero
sel <- order(-resto)[1:faltan] # índices de los 17 restos mayores
app$ham20[sel] <- app$ham20[sel] + 1
# verifica
sum(app$ham20)

app
# población creciente
app$dif <- app$ham20 - app$jef20
app$dif.r <- round(app$ham20 / app$jef20,2)
app[order(d$ptot2020),]

# descripción según tamaño del estado
app$size <- d$size
with(app, table(size, dif))
with(app, table(size, dif.r))
with(app, aggregate(dif,   list(size), mean))
with(app, aggregate(dif.r, list(size), mean))

# webster
R  <- sum(d$ptot2020) / 300.342 # prueba-y-error para que suma de enteros llegue a 300
app$web20 <- round(d$ptot2020 / R)
app$web20[app$web20<2] <- 2
# tamaño del Congreso resultante, muy grande
sum(app$web)

## # Hill --- aún no jala, verlo en Balinski
## N <- 300
## Q = N * (d$ptot2020 / sum(d$ptot2020))
## entero <-     as.integer(Q)
## geomedia <- sqrt( entero * (entero+1))
## app$hill20 <- entero
## app$hill[Q - geomedia > 0] <- entero[Q - geomedia > 0] + 1
## # (3) Mínimo uno por estado
## app$hill20[app$hill20<2] <- 2
## # Cuántos hay?
## sum(app$hill20)

# diferencias con hamilton app <-
app <- within(app, {
                djef20 <- jef20 - ham20 ;
                dweb20 <- web20 - ham20 ;
                drjef20 <- round(jef20 / ham20, 2);
                drweb20 <- round(web20  / ham20, 2)
})

plot(d$ptot2020, app$djef20, pch = 8)
sel <- which(app$djef20!=0)
text(d$ptot2020[sel], (app$djef20[sel]+.07), labels = app$edo[sel], cex = .6)
# points(d$ptot2020, app$dweb20, col = "red")

# R de cada estado contra la ideal
plot(d$ptot2020, (d$ptot2020 / app$ham20))
abline(h = R)
plot(d$ptot2020, (d$ptot2020 / app$jef20))
abline(h = R)

# Relative Representation Index (Ansolabehere Snyder)
# RRI =  (pob.nal / 300) / (pob.edo / ndip.edo)
app$rri.jef <- round((sum(d$ptot2020) / 300) / (d$ptot2020 / app$jef20), 2);
app$rri.ham <- round((sum(d$ptot2020) / 300) / (d$ptot2020 / app$ham20), 2);
app$rri.web <- round((sum(d$ptot2020) / 300) / (d$ptot2020 / app$web20), 2);

plot(c(.5,1.5), c(.5,1.5), type = "n")
points(app$rri.ham, app$rri.jef)
abline(a = 0, b = 1, lty = 2)

plot(d$ptot2020, app$rri.jef, type = "n", main = "Jefferson")
text(d$ptot2020, app$rri.jef, labels = app$edo, cex = .75)
abline(h = 1)

plot(d$ptot2020, app$rri.ham, type = "n", main = "Hamilton")
text(d$ptot2020, app$rri.ham, labels = app$edo, cex = .75)
abline(h = 1)

app[,c("edo", "rri.ham", "rri.jef")]


coul <- function(r, qi, qj){
	return ((qi * qj)/(4.0*pi*0.0055264*r))
}

buck <- function(r, A, rho, C){
	return (A*exp(-r/rho) - C/r^6)
}

morse <- function(r, D, gamma, r_star){
	return (D*(exp(-2*gamma*(r-r_star)))-2*exp(-gamma*(r-r_star)))
}

pot <- function(r, qi, qj, A, rho, C, D, gamma, r_star){
	return (coul(r, qi,qj) + buck(r, A, rho, C) + morse(r, D, gamma, r_star))
}

A <- 693.650934
rho <- 0.327022
C <- 0.0

D <- 0.577190
gamma <- 1.650000
r_star <- 2.369000

q_O <- -1.2
q_U <- 2.4

UO_pot <- function(r){
	return(pot(r, q_O, q_U, A, rho, C, D, gamma, r_star))
}

xlim <- c(0, 4)
ylim <- c(-25, 30)

pdf("analytical_plot.pdf", fonts = "Helvetica")
r <- seq(0.5, 4, length.out = 200)
r_coarse <- seq(0.98, 4, length.out = 10)

UO <- UO_pot(r)
UO_coarse <- UO_pot(r_coarse)

plot(r, UO, xlim = xlim, ylim = ylim, type = "l", xlab = NA, ylab = NA)
points(r_coarse, UO_coarse, col = 'red', pch=16)
abline(h=0, lty="dashed")
abline(v=r_coarse, col = "lightblue")
dev.off()

pdf("table_plot.pdf")
plot(r_coarse, UO_coarse, xlim = xlim, ylim = ylim, type = "l", xlab = NA, ylab = NA)
points(r_coarse, UO_coarse, col = 'red', pch=16)
abline(h=0, lty="dashed")
dev.off()


#!/usr/bin/env R

# http://stackoverflow.com/questions/3485456/useful-little-functions-in-r

spike_file = 'spikes-103-0.gdf'

voltage_file = 'voltages-104-0.dat'

t_sim = 10

# Gets the frequencies returned by the FFT function
getFFTFreqs = function(Nyq.Freq, data) {
  # Odd number of sample
  if ((length(data) %% 2) == 1) {
    FFTFreqs = c(seq(0, Nyq.Freq, length.out=(length(data)+1)/2),
           seq(-Nyq.Freq, 0, length.out=(length(data)-1)/2))
  }
  else {
    FFTFreqs = c(seq(0, Nyq.Freq, length.out=length(data)/2),
         seq(-Nyq.Freq, 0, length.out=length(data)/2))
  }

  return (FFTFreqs)
}

# FFT plot
# Params:
# x,y -> the data for which we want to plot the FFT
# samplingFreq -> the sampling frequency
# shadeNyq -> if true the region in [0;Nyquist frequency] will be shaded
# showPeriod -> if true the period will be shown on the top
# Returns a list with:
# freq -> the frequencies
# FFT -> the FFT values
# modFFT -> the modulus of the FFT
plotFFT = function(x, y, samplingFreq, shadeNyq=TRUE, showPeriod = TRUE) {
  Nyq.Freq = samplingFreq/2
  FFTFreqs = getFFTFreqs(Nyq.Freq, y)

  FFT = fft(y)
  modFFT = Mod(FFT)
  FFTdata = cbind(FFTFreqs, modFFT)

  plot(FFTdata[1:nrow(FFTdata)/2,], t="l", pch=20, lwd=2, cex=0.8, main="",
      xlab="Frequency (Hz)", ylab="Power")

  if (showPeriod == TRUE) {
    # Period axis on top
    a = axis(3, lty=0, labels=FALSE)
    axis(3, cex.axis=0.6, labels=format(1/a, digits=2), at=a)
  }

  if (shadeNyq == TRUE) {
    # Gray out lower frequencies
    rect(0, 0, 2/max(x), max(FFTdata[,2])*2, col="gray", density=30)
  }

  ret = list("freq"=FFTFreqs, "FFT"=FFT, "modFFT"=modFFT)
  return (ret)
}

bin.ts = function(data, time, bins) {
  times = seq(min(time), max(time), (max(time) - min(time))/bins)
  freq = hist(time, times, plot=FALSE)$counts
  d = data.frame(time=times[-length(times)], freq=freq)
}

spikes = read.csv2(spike_file,
  sep='\t',
  col.names=c('neuron', 'time', 'spike'),
  header=FALSE,
  stringsAsFactors=FALSE
)
spikes$spike = 1
spikes$time = as.numeric(spikes$time)

spikes.binned = bin.ts(spikes$spike, spikes$time, 1000)

par(mfrow=c(2,1))
plotFFT(spikes.binned$time, spikes.binned$freq, 1000/10)

voltages = read.csv2(voltage_file,
  sep='\t',
  col.names=c('neuron', 'time', 'voltage', 'NA'),
  header=FALSE,
  stringsAsFactors=FALSE
)
voltages$time = as.numeric(voltages$time)
voltages$voltage = as.numeric(voltages$voltage)

voltages.binned = bin.ts(voltages$voltage, voltages$time, 1000)

plotFFT(voltages.binned$time, voltages.binned$freq, nrow(voltages.binned)/t_sim)


isLeapYear <- function(year) {
    ifelse(year%%100==0, year%%400==0, year%%4==0)
}

for (y in c(1900, 1994, 1996, 1997, 2000)) {
    print(paste(y, " is ", ifelse(isLeapYear(y), "", "not "), "a leap year.", sep=""))
}


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 16, 2016

# ref: http://www.ats.ucla.edu/stat/r/pages/greek_letters.htm
par(mfrow = c(1, 2))
curve(dnorm, from = -3, to = 3, n = 1000, main = "Normal Probability Density Function")
text(-2, 0.3, expression(f(x) == paste(frac(1, sqrt(2 * pi * sigma^2)),
                                       " ", e^{
                                         frac(-(x - mu)^2, 2 * sigma^2)
                                       })), cex = 1.2)
x <- dnorm(seq(-3, 3, 0.001))
plot(seq(-3, 3, 0.001), cumsum(x)/sum(x), type = "l", col = "blue",
     xlab = "x", main = "Normal Cumulative Distribution Function")
text(-1.5, 0.7, expression(phi(x) == paste(frac(1, sqrt(2 * pi)),
     " ", integral(e^(-t^2/2) * dt, -infinity, x))), cex = 1.2)


crp = function(n, a) {
  restaurant = data.frame(table = 1, customers = 1)
  for (j in seq(n - 1)) {
    restaurant = arrival(restaurant, a)
    }
  restaurant
  }

arrival = function(r, a) {
  p = 1 - a / (sum(r$customers) + a)
  if (rbinom(1, 1, p)) {
    join_table(r, a)
    } else {
    start_table(r)
    }
  }

join_table = function(r, a) {
  probs = r$customers / sum(r$customers)
  table = sample(1:nrow(r), size = 1, prob = probs)
  r[table, 'customers'] = r[table, 'customers'] + 1
  r
  }

start_table = function(r) {
  rbind(r, c(nrow(r) + 1, 1))
  }


#------------------------------------------------------------------------------
#	 class calculating metrics for regression models.
#
#	This class has several functions calculating metrics of predictive ability
#	of regression models.
#	To obtain the metrics, initialize the object and call
#	\emph{calculate.metrics} method.
#
#	Following metrics are calculated for regression models.
#
#	\describe{
#		\item{Mean squared error (MSE)}{
#			\eqn{mean((prediction - response) ^ 2)}
#		}
#		\item{Root mean squared error (RMSE)}{
#			\eqn{sqrt(mean((prediction - response) ^ 2))}
#		}
#		\item{R squared, \eqn{R ^ 2}}{
#			\eqn{Pearson's product moment correlation coefficient ^ 2}
#
#			Note that this definition of \eqn{R^2} may produce high values
#			for models without predictive ability so that I recommend to use
#			\eqn{Q ^ 2} instead of \eqn{R ^ 2}.
#			See
#			\href{http://www.russpoldrack.org/2012/12/the-perils-of-leave-one-out.html}{
#				this
#			},
#			\href{http://not2hastie.tumblr.com}{this} and
#			\href{https://metarabbit.wordpress.com/2014/03/06/evaluating-regression-with-cross-validation/}{
#				this
#			}.
#		}
#		\item{Spearman's rho}{
#			\code{cor(response, prediction, method = "spearman")}
#		}
#		\item{Kendall's tau}{
#			\code{cor(response, prediction, method = "spearman")}
#		}
#		\item{Q squared, \eqn{Q^2}}{
#			\eqn{
#				1 - \sum((prediction - response) ^ 2)
#				/ \sum((response - mean(response)) ^ 2)
#			}
#		}
#	}
#------------------------------------------------------------------------------
regression.metrics.calculator <- R6::R6Class("regression.metrics.calculator")

#------------------------------------------------------------------------------
#	Calculate mean squared error (MSE).
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"private", "calc.mse",
	function(fit) {
		if (is.factor(fit$response)) {
			return(NA)
		}
		return(mean((fit$prediction - fit$response) ^ 2))
	}
)

#------------------------------------------------------------------------------
#	Calculate root mean squared error (RMSE).
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"private", "calc.rmse",
	function(fit) {
		return(sqrt(private$calc.mse(fit)))
	}
)

#------------------------------------------------------------------------------
#	Calculate R squared.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"private", "calc.r.squared",
	function(fit) {
		if (is.factor(fit$response)) {
			return(NA)
		}
		return(stats::cor(fit$response, fit$prediction) ^ 2)
	}
)

#------------------------------------------------------------------------------
#	Calculate Spearman's rho.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"private", "calc.spearman",
	function(fit) {
		if (is.factor(fit$response)) {
			return(NA)
		}
		return(stats::cor(fit$response, fit$prediction, method = "spearman"))
	}
)

#------------------------------------------------------------------------------
#	Calculate Kendall's tau.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"private", "calc.kendall",
	function(fit) {
		if (is.factor(fit$response)) {
			return(NA)
		}
		return(stats::cor(fit$response, fit$prediction, method = "kendall"))
	}
)

#------------------------------------------------------------------------------
#	Calculate Q squared.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"private", "calc.q.squared",
	function(fit) {
		if (is.factor(fit$response)) {
			return(NA)
		}
		press <- sum((fit$prediction - fit$response) ^ 2)
		tss <- sum((fit$response - mean(fit$response)) ^ 2)
		return(1 - press / tss)
	}
)

#------------------------------------------------------------------------------
#	Calculate all metrics.
#
#	Args:
#		fit:
#			a list having result of one fold of cross validation
#			with "response", "prediction" and "index" fields.
#
#	Returns:
#		calculated metrics in following format.
#
#			list(
#				matrix(mse, rmse, r.squared, spearman, kendall, q.squared)
#			)
#
#		Because classification.metrics.calculator can returns metrics for
#		different threshold determination method, the format of the result
#		should be a list having matrix.
#------------------------------------------------------------------------------
regression.metrics.calculator$set(
	"public", "calculate.metrics",
	function(fit) {
		metrics <- cbind(
			mse = private$calc.mse(fit),
			rmse = private$calc.rmse(fit),
			r.squared = private$calc.r.squared(fit),
			spearman = private$calc.spearman(fit),
			kendall = private$calc.kendall(fit),
			q.squared = private$calc.q.squared(fit)
		)
		# To have same result format with classification.metrics.calculator,
		# return the matrix of metrics in a list.
		return(list(metrics))
	}
)


#getwd()
library(dplyr)

par(mfrow = c(1, 1))

# Načtení dat z xlsx souboru
data_xlsx = readxl::read_excel("./1S/ukol_123.xlsx",
                  sheet = "Vysledky mereni",
                  skip = 0)

data_xlsx = data_xlsx[,-1] # odstraníme první sloupec s indexy
colnames(data_xlsx)=c("A22","A5","B22","B5","C22","C5","D22","D5")
head(data_xlsx)

data_xlsx$A_d = data_xlsx$A22-data_xlsx$A5
data_xlsx$B_d = data_xlsx$B22-data_xlsx$B5
data_xlsx$C_d = data_xlsx$C22-data_xlsx$C5
data_xlsx$D_d = data_xlsx$D22-data_xlsx$D5

data=reshape(data=as.data.frame(data_xlsx),
                  direction="long",
                  varying=list(c("A5", "B5", "C5", "D5"),
                               c("A22","B22","C22","D22"),
                               c("A_d","B_d","C_d","D_d")),
                  v.names=c("C5","C22","delta"),
                  times=c("Amber","Bright","Clear","Dim"),
                  timevar="vyrobce")
row.names(data) = 1:nrow(data)
data = data[-length(data)]
data = na.omit(data)

head(data)
tail(data)

# data_A = data %>% filter(vyrobce=="Amber")
# data_A = data_A[-1]

# data_B = data %>% filter(vyrobce=="Bright")
# data_B = data_B[-1]

# data_A_d = data_A$C22-data_A$C5

# data_A_DK = quantile(data_A_d, 0.25, na.rm=T)
# data_A_HK = quantile(data_A_d, 0.75, na.rm=T)
# data_A_IQR = data_A_HK - data_A_DK
# data_A_DM = data_A_DK - 1.5*data_A_IQR
# data_A_HM = data_A_HK + 1.5*data_A_IQR

# data_A_d_bezOP = data_A_d
# data_A_d_bezOP[data_A_d<=data_A_DM|data_A_d>=data_A_HM] = NA

data_A_d = data %>% filter(vyrobce=="Amber") %>% pull(delta)
data_A_d_bezOP = data_A_d
data_A_d_bezOP[data_A_d_bezOP %in% boxplot(data_A_d, plot = FALSE)$out] = NA

# data_B_d = data_B$C22-data_B$C5

# data_B_DK = quantile(data_B_d, 0.25, na.rm=T)
# data_B_HK = quantile(data_B_d, 0.75, na.rm=T)
# data_B_IQR = data_B_HK - data_B_DK
# data_B_DM = data_B_DK - 1.5*data_B_IQR
# data_B_HM = data_B_HK + 1.5*data_B_IQR

# data_B_d_bezOP = data_B_d
# data_B_d_bezOP[data_B_d<=data_B_DM|data_B_d>=data_B_HM] = NA

data_B_d = data %>% filter(vyrobce=="Bright") %>% pull(delta)
data_B_d_bezOP = data_B_d
data_B_d_bezOP[data_B_d_bezOP %in% boxplot(data_B_d, plot = FALSE)$out] = NA

sd(data_A_d_bezOP, na.rm=TRUE)
sd(data_B_d_bezOP, na.rm=TRUE)

par(mfrow = c(1, 1))

boxplot(data_A_d, data_B_d, names=c("Amber","Bright"), ylab="pokles světelného toku (lm)", main="Boxploty světelnosti")

par(mfrow = c(2, 2))

hist(data_A_d_bezOP,
    main="Amber",
    xlab="pokles světelného toku (lm)",
    ylab="četnost",
    xlim=c(-15,15),
    ylim=c(0,15))

qqnorm(data_A_d_bezOP,
        xlab="Teoretické kvantily",
        ylab="Výběrové kvantily",
        main="Amber")
qqline(data_A_d_bezOP)

hist(data_B_d_bezOP,
    main="Bright",
    xlab="pokles světelného toku (lm)",
    ylab="četnost",
    xlim=c(-15,15),
    ylim=c(0,15))

qqnorm(data_B_d_bezOP,
        xlab="Teoretické kvantily",
        ylab="Výběrové kvantily",
        main="Bright")
qqline(data_B_d_bezOP)

moments::skewness(data_A_d_bezOP, na.rm=T)
moments::skewness(data_B_d_bezOP, na.rm=T)

moments::kurtosis(data_A_d_bezOP, na.rm=T)-3
moments::kurtosis(data_B_d_bezOP, na.rm=T)-3

# test normality Shapirovovým - Wilkovovým testem
shapiro.test(data_A_d_bezOP)$p.value
shapiro.test(data_B_d_bezOP)$p.value

# test symetrie
lawstat::symmetry.test(data_A_d_bezOP, boot=FALSE)$p.value
lawstat::symmetry.test(data_B_d_bezOP, boot=FALSE)$p.value

mean(data_A_d_bezOP, na.rm=T)
mean(data_B_d_bezOP, na.rm=T)

t.test(data_A_d_bezOP, conf.level = 0.95, alternative = "greater")$conf.int
t.test(data_B_d_bezOP, conf.level = 0.95, alternative = "greater")$conf.int

t.test(data_A_d_bezOP, alternative="greater", conf.level=0.95)$p.value
t.test(data_B_d_bezOP, alternative="greater", conf.level=0.95)$p.value

var(data_A_d_bezOP,na.rm=T)
var(data_B_d_bezOP,na.rm=T)

prumer = mean(data_A_d_bezOP, na.rm=T) - mean(data_B_d_bezOP, na.rm=T)

# F-Test
var.test(x = data_A_d_bezOP, y = data_B_d_bezOP, ratio = 1, conf.level = 0.95, alternative = "two.sided")$p.value

# 95% oboustranný interval
t.test(x = data_A_d_bezOP, y = data_B_d_bezOP, mu = prumer, conf.level = 0.95, alternative = "two.sided")$conf.int

# Dvouvýběrový studentův T-test (p-hodnota)
t.test(x = data_A_d_bezOP, y = data_B_d_bezOP, mu = prumer, conf.level = 0.95, alternative = "two.sided")$p.value

# medián x0,1 - median()
# stř.hodnota je mean() - průměr


#' windspeed
#'
#' @description Calculate meteorological wind speed.
#'
#' @param u numeric U zonal component (m/s),
#' @param v numeric V meridian component (m/s),
#' @return wind speed (m/s)
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords Scaler speed wind
#'
#'
#' @export

windspeed=function(u, v) {return(sqrt(u^2+v^2))}


# Simpson's paradox

# Generate data
datalist = list()

for (i in seq(0, 100, 10)) {
  age = runif(10, i, i + 10)
  exercise = (runif(10) + .1 * age) / 10 + .1 * rnorm(10, 0, 2)
  cholesterol = (i / 10) - exercise + .4 * rnorm(10, 0, 2)
  df = data.frame(age, exercise, cholesterol)
  datalist[[(i / 10) + 1]] = df
}

# Combine all data
data_simpson = do.call(rbind, datalist)

# Plot
plot(data_simpson$age, data_simpson$exercise)
plot(data_simpson$age, data_simpson$cholesterol)
plot(data_simpson$exercise, data_simpson$cholesterol)

# Model
model_1 = lm(cholesterol ~ exercise, data=data_simpson)
model_2 = lm(cholesterol ~ exercise + age, data=data_simpson)

# Check
summary(model_1)
summary(model_2)


## ----echo=FALSE---------------------------------------------------------------
require(Hmisc)
knitrSet('parsurv')

## ----hr-vs-surv,echo=FALSE,cap='Absolute clinical benefit as a function of survival in a control subject and the relative benefit (hazard ratio).  The hazard ratios are given for each curve.',scap='Absolute clinical benefit as a function of survival in a control subject and the relative benefit.'----
plot(0, 0, type="n", xlab="Survival for Control Subject",
     ylab="Improvement in Survival",
     xlim=c(0,1), ylim=c(0,.7))
i <- 0
hr <- seq(.1, .9, by=.1)
for(h in hr) {
  i <- i + 1
  p <- seq(.0001, .9999, length=200)
  p2 <- p^h
  d <- p2 - p
  lines(p, d, lty=i)
  maxd <- max(d)
  smax <- p[d==maxd]
  text(smax,maxd+.02, format(h), cex=.6)
}

## ----t-hazard,mfrow=c(2,2),top=1,h=5,w=5,cap='$\\log(T)$ distribution for $\\sigma=0.25, 0.6, 1, 2$ and for degrees of freedom $1, 2, 3, 5, 7, 15, 500$ (almost log-normal).  The top left plot has degrees of freedom written in the plot.',scap='Hazard functions for $\\log(T)$ distribution'----
require(rms)
haz <- survreg.auxinfo$t$hazard
times <- c(seq(0, .25, length=100), seq(.26, 2, length=150))
high <- c(6, 1.5, 1.5, 1.75)
low  <- c(0, 0, 0, .25)
dfs  <- c(1, 2, 3, 5, 7, 15, 500)
cols <- rep(1, 7)
ltys <- 1:7
i <- 0
for(scale in c(.25, .6, 1, 2)) {
  i <- i + 1
  plot(0, 0, xlim=c(0,2), ylim=c(low[i], high[i]),
    xlab=expression(t), ylab=expression(lambda(t)), type="n")
  col <- 1.09
  j <- 0
  for(df in dfs) {
    j <- j+1
    ## Divide by t to get hazard for log t distribution
    lines(times,
          haz(log(times), 0, c(log(scale), df))/times,
          col=cols[j], lty=ltys[j])
    if(i==1) text(1.7, .23 + haz(log(1.7), 0,
         c(log(scale),df))/1.7, format(df))
  }
  title(paste("Scale:", format(scale)))
}   # Figure (*\ref{fig:parsurv-t-hazard}*)

## ----kprats-check,mfrow=c(2,2),h=5,w=6,bot=1,ps=9,cap='Altschuler--Nelson--Fleming--Harrington nonparametric survival estimates for rats treated with DMBA,~\\cite{pik66} along with various transformations of the estimates for checking distributional assumptions of three parametric survival models.',scap='Examples of checking parametric survival model assumptions'----
getHdata(kprats)
kprats$group <- factor(kprats$group, 0:1, c('Group 1', 'Group 2'))
dd <- datadist(kprats); options(datadist="dd")

S <- with(kprats, Surv(t, death))
f <- npsurv(S ~ group, type="fleming", data=kprats)
survplot(f, n.risk=TRUE, conf='none',   # Figure (*\ref{fig:parsurv-kprats-check}*)
         label.curves=list(keys='lines'), levels.only=TRUE)
title(sub="Nonparametric estimates", adj=0, cex=.7)

# Check fits of Weibull, log-logistic, log-normal
xl <- c(4.8, 5.9)
survplot(f, loglog=TRUE, logt=TRUE, conf="none", xlim=xl,
         label.curves=list(keys='lines'), levels.only=TRUE)
title(sub="Weibull (extreme value)", adj=0, cex=.7)
survplot(f, fun=function(y)log(y/(1-y)), ylab="logit S(t)",
         logt=TRUE, conf="none", xlim=xl,
         label.curves=list(keys='lines'), levels.only=TRUE)
title(sub="Log-logistic", adj=0, cex=.7)
survplot(f, fun=qnorm, ylab="Inverse Normal S(t)",
         logt=TRUE, conf="none",
         xlim=xl,cex.label=.7,
         label.curves=list(keys='lines'), levels.only=TRUE)
title(sub="Log-normal", adj=0, cex=.7)

## ----fittedpsm,results='asis'-------------------------------------------------
fw <- psm(S ~ group, data=kprats, dist='weibull')
fl <- psm(S ~ group, data=kprats, dist='loglogistic',
          y=TRUE)
fn <- psm(S ~ group, data=kprats, dist='lognormal')
latex(fw, fi='')
latex(fl, fi='')
latex(fn, fi='')

## ----kprats-psm-np,w=3.75,h=2.5,cap='Agreement between fitted log-logistic model and nonparametric survival estimates for rat vaginal cancer data.',scap='Fitted log-logistic model'----
survplot(f, conf.int=FALSE,   # Figure (*\ref{fig:parsurv-kprats-psm-np}*)
         levels.only=TRUE, label.curves=list(keys='lines'))
survplot(fl, add=TRUE, label.curves=FALSE, conf.int=FALSE)

## ----echo=FALSE,results='asis'------------------------------------------------
latex(pphsm(fw), fi='', digits=4)

## ----kprats-resid-np,w=3.75,h=2.5,cap='Kaplan--Meier estimates of distribution of standardized censored residuals from the log-logistic model, along with the assumed standard log-logistic distribution (dashed curve).  The step functions in red is the estimated distribution of all residuals, and the step functions in black are the estimated distributions of residuals stratified by group, as indicated.  The blue curve is the assumed log-logistic distribution.',scap='Checking AFT distributional assumption using residuals'----
r <- resid(fl, 'cens')
survplot(npsurv(r ~ group, data=kprats),
         conf='none', xlab='Residual',
         label.curves=list(keys='lines'), levels.only=TRUE)
survplot(npsurv(r ~ 1), conf='none', add=TRUE, col='red')
lines(r, lwd=1, col='blue')   # Figure (*\ref{fig:parsurv-kprats-resid-np}*)

## ----eval=FALSE---------------------------------------------------------------
## psm(Surv(d.time, event) ~ 1)

## ----eval=FALSE---------------------------------------------------------------
## units(d.time) <- "Year"
## f <- psm(Surv(d.time,cdeath) ~ lsp(age,65)*sex)
## # default is Weibull
## anova(f)
## summary(f)          # summarize effects with delta log T
## latex(f)            # typeset math. form of fitted model
## survest(f, times=1) # 1y survival est. for all subjects
## survest(f, expand.grid(sex="female", age=30:80), times=1:2)
## # 1y, 2y survival estimates vs. age, for females
## survest(f, data.frame(sex="female",age=50))
## # survival curve for an individual subject
## survplot(f, sex=NA, age=50, n.risk=T)
## # survival curves for each sex, adjusting age to 50
## f.ph <- pphsm(f)    # convert from AFT to PH
## summary(f.ph)       # summarize with hazard ratios
##                     # instead of changes in log(T)

## ----kprats-Functions,results='asis'------------------------------------------
med   <- Quantile(fl)
meant <- Mean(fl)
haz   <- Hazard(fl)
surv  <- Survival(fl)
latex(surv, file='', type='Sinput')

## ----kprats-hazard,w=4,h=2.75,top=.6,ps=9,cap='Estimated hazard functions for log-logistic fit to rat vaginal cancer data, along with median survival times.',scap='Estimated log-logistic hazard functions'----
# Plot estimated hazard functions and add median
# survival times to graph
survplot(fl, group, what="hazard")   # Figure (*\ref{fig:parsurv-kprats-hazard}*)
# Compute median survival time
m <- med(lp=predict(fl,
           data.frame(group=levels(kprats$group))))
m
med(lp=range(fl$linear.predictors))
m <- format(m, digits=3)
text(68, .02, paste("Group 1 median: ", m[1],"\n",
                    "Group 2 median: ", m[2], sep=""))
# Compute survival probability at 210 days
xbeta <- predict(fl,
                 data.frame(group=c("Group 1","Group 2")))
surv(210, xbeta)


server <- function(input, output) {
  output$coolplot <- renderPlot({
    n<-input$n
    x<-input$x
    H0<-input$H0
    H1<-input$H1
    LR<-round(max(dbinom(x,n,H0)/dbinom(x,n,H1),dbinom(x,n,H1)/dbinom(x,n,H0)),digits=2) #Calculate LR (H1 over H0 and H0 over H1, pick max)
    H0H1<-ifelse(dbinom(x,n,H0)>dbinom(x,n,H1),"The data are more likely under the null hypothesis than the alternative hypothesis","The data are more likely under the alternative hypothesis than the null hypothesis")
    theta<- seq(0,1,len=1000)
    like <- dbinom(x,n,theta)
    plot(theta,like,type='l',xlab=expression(theta), ylab='Likelihood', lwd=2)
    points(H0,dbinom(x,n,H0), lwd=2)
    points(H1,dbinom(x,n,H1), lwd=2)
    segments(H0, dbinom(x,n,H0), x/n, dbinom(x,n,H0), lty=2, lwd=2)
    segments(H1, dbinom(x,n,H1), x/n, dbinom(x,n,H1), lty=2, lwd=2)
    segments(x/n, dbinom(x,n,H0), x/n, dbinom(x,n,H1), lwd=2)
    abline(v=H0, col="gray40", lty=3, lwd=2)
    abline(v=H1, col="gray40", lty=3, lwd=2)
    title(paste('Likelihood Ratio:',LR))

    #create Table
    studies<-c(0:n)
    ProbH0<-dbinom(studies,n,H0)
    ProbH1<-dbinom(studies,n,H1)
    table<-cbind(studies,ProbH0,ProbH1)
    colnames(table) <- c("Number of significant studies", "Probability of observing x out of n significant studies when H0 is true","Probability of observing x out of n significant studies when H1 is true")

    output$text1 <- renderText({
      paste("When H1 is true, in the long run, the probability of observing", x," out of ",n, " significant studies, given" ,H1, "power, is:", dbinom(x,n,H1),". If all studies examine true effects with",100*H1,"% power,",100*round(dbinom(x,n,H1),digits=4),"% of published articles with",n,"studies should observe",x,"significant results. When power is less than",100*round(0.5^(1/n), digits=4),"% observing",n,"out of",n,"significant results is less likely (i.e., occurs less than 50% of the time) than observing mixed results.")
    })
    output$text2 <- renderText({
      paste("When H0 is true, in the long run, the probability of observing", x," out of ",n, " significant studies, given a" ,H0, "Type 1 error rate, is:", round(dbinom(x,n,H0),digits=10),". When all studies examine null-effects with a",100*H0,"% Type 1 error rate,",100*round(dbinom(x,n,H0),digits=4),"% of published articles with",n,"studies should observe",x,"significant results.")
    })
    output$text3 <- renderText({
      paste(H0H1, "with a likelihood ratio of",LR,".")
    })
    output$table = renderDataTable(
      table,
      options = list(paging = FALSE, searching = FALSE)
    )
  })
}


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

rm(list=ls(all=TRUE))

library(methods)
library(rstan)

cat("Stan version:", stan_version(), "\n")
stanmodelcode <- "

#### define GP function
functions {

real normal_generalized_poisson_log(int y, real theta, real lambda, real sigob) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=500)
           +(normal_lpdf(y|theta,sigob))*(y>500);
		  ### +log(1-normal_cdf(0.08*u,u,0.01))*(b0>0.08*u);   #### +log(b0>0.08*u); (b0>0.08*u)
  }

}

#### define our data, integer value
data {
int<lower=0> N;
int y[N];
real E[N];
}

#### define parameters
parameters {

real lambda;
real u;
real b0;
real<lower=0> sig2;
vector[N] e;
real sigob;
}

#### define some parameters which is the function of other parameters
transformed parameters {
vector[N] mu;

### define the mean function
#mu[1] <- exp(u*exp(-b0)+e[1]);

mu[1] <- y[1];  ## not tested

  for (n in 2:N) {

      mu[n] <- mu[n-1]*exp(u*exp(-b0*n)+e[n]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.24,0.01);
b0 ~ normal(0.031,0.001);
sig2 ~  gamma(1,1);
e~normal(0,sig2);
sigob ~ uniform(100,1100);

for (j in 1:N) {

y[j] ~ normal_generalized_poisson( mu[j]*E[j], lambda, sigob);
}

}

#### calculate DIC
generated quantities {
vector[N] log_lik;
real dev; // deviance

  for (n in 1:N){
    log_lik[n] <- normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
  }

  dev <- 0;
        for ( n in 1:N ) {
            dev <- dev + (-2) * normal_generalized_poisson_log (y[n],mu[n]*E[n], lambda, sigob);
        }

}

"

######

####### read new data Y
setwd("./covid19modelrisk/data/covid19_infected/")

  y=read.csv("COVID-19_confirmed__Germany.csv")
##  y=read.csv("COVID-19_confirmed__Italy.csv")
##  y=read.csv("COVID-19_confirmed__Japan.csv")
##  y=read.csv("COVID-19_confirmed__Spain.csv")
##  y=read.csv("COVID-19_confirmed__United Kingdom.csv")
##  y=read.csv("COVID-19_confirmed__US.csv")
##  y=read.csv("COVID-19_confirmed_Australia.csv")

y=y[,2]

E=rep(1,length(y))

N=length(y)
dat <- list(N = N, y = y,E=E)

#### initial values
inits =list(list(lambda=0,u=0.24,b0=0.031,sig2=0.0005,e=rep(0.01,N),sigob=1000))  ### 134

fit <- stan(model_code = stanmodelcode, model_name = "example",init =inits,
data = dat, warmup=10000,iter = 100000, chains = 1, seed=999,thin=1)
print(fit,digits = 4)

####  threshold =500

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

####################  trace plot

library(methods)
library(rstan)

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

k=7

pdf(paste("M2_",abn[k],"_p1.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("u","b0","lambda"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)

dev.off()

pdf(paste("M2_",abn[k],"_p2.pdf",sep=""), width = 16.5, height = 8.50)

traceplot(fit, pars=c("sigob","sig2"), inc_warmup = T,  nrow = 2, ncol = 1, window = NULL, include = TRUE)
dev.off()

##################   plot 30/45/60/   length(y)

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.95 )

pdf(paste("M2_",abn[k],"_30.pdf",sep=""), width = 16.5, height = 8.50)

m=30

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M2_",abn[k],"_45.pdf",sep=""), width = 16.5, height = 8.50)

m=45

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M2_",abn[k],"_60.pdf",sep=""), width = 16.5, height = 8.50)

m=60

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

pdf(paste("M2_",abn[k],"_all.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

########    log plot          ####################################################

k=2

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[10001:100000,(6+N):(5+2*N)] , 2 , quantile, probs=0.95 )

y=log(y)
Epars_m=log(Epars_m)
Epars_9=log(Epars_9)
Epars_5=log(Epars_5)

setwd("./covid19modelrisk/output/plot/")

pdf(paste("M2_",abn[k],"_log.pdf",sep=""), width = 16.5, height = 8.50)

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main=paste("In-sample fit results of M2 model for ",name[k],sep=""),lwd = 2)

dev.off()

#####################################################################################################################################################
######################################      forecast          ###################################

GP.r <- function(L, s)
{

v=0
Lp=exp(log(L)+ (v - 1) * log(L + v * s) - v * s - L - lgamma(v + 1))
sLp=Lp

# calculate the vector of cum pmf
v=1
while((sLp<0.9999999) & ((L + v * s )> 0))
{Lp1=exp(log(L)+ (v - 1) * log(L + v * s) - v * s - L - lgamma(v + 1))
Lp=c(Lp,Lp1)
sLp=sLp+Lp1
v=v+1
}

csLp=c(cumsum(Lp),1) ##### add a max for it
x=length(Lp)

# first check if you are in the first interval

U = runif(1)
B = FALSE
i = 1

while(B == FALSE) {

  if(U > csLp[i])  ### U may greater than max of csLp if do not set 1
    { i=i+1}
  else
    {X=i-1
     B=TRUE}

}

return(X)

}

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

P=20
Mu=matrix(,nrow=90000,ncol=P)
X=matrix(,nrow=90000,ncol=P)

lambda_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,1]
u_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,2]
b0_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,3]
sig2_p=as.data.frame(fit@sim[[1]][[1]])[10001:100000,4]

set.seed(999)

for (r in 1:90000){

Mu[r,1]=y[length(y)]
for (s in 1:(P-1) ){

e=rnorm(1,0,sig2_p[r])

Mu[r,s+1]=Mu[r,s]*exp(u_p[r]*exp(-b0_p[r]*(s+length(y)))+e)

}}

sigob=1000
for (r in 1:90000){
for (s in 1:P ){

X[r,s]=rnorm(1,Mu[r,s], sigob)

}}

Xm=apply(X,2,mean)

X5 <- apply( X , 2 , quantile, probs=0.05 )

X9 <- apply( X , 2 , quantile, probs=0.95 )

Zm=c(y,Xm)
Z5=c(y,X5)
Z9=c(y,X9)

##### read forecast
setwd("./covid19modelrisk/data/covid19_infected/")

##  FT=read.csv("COVID-19_confirmed__Germany_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__Italy_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__Japan_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__Spain_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__United Kingdom_FT.csv")[,2]
##  FT=read.csv("COVID-19_confirmed__US_FT.csv")[,2]
FT=read.csv("COVID-19_confirmed_Australia_FT.csv")[,2]

M=length(FT)

e=FT-Xm
mae=mean(abs(e))
rmse=sqrt(mean(e^2))
############ PR
 p=e/FT
# p1=e1/mean(mo1)
mape=mean(abs(p))
########## QR
md=sum(abs(FT[2:M]-FT[1:(M-1)]))/(M-1)
qj=e/md
mase=mean(abs(qj))

list(mae,rmse,mape,mase)

Z_FT=c(y,FT)

k=7

name=c("Germany","Italy","Japan","Spain","U.K.","U.S.","Australia")
abn=c("GM","IT","JP","SP","UK","US","AU")

m=length(Zm)

setwd("./covid19modelrisk/output/forecast/")

pdf(paste("M2_",abn[k],"_F.pdf",sep=""), width = 16.5, height = 8.50)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(Zm[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m])),ylab="Count",xlab="Time",main=paste("Out-sample forecast results of M2 model for ",name[k],sep=""),pch=19,col="red",xaxt = 'n')
polygon(c(rev(newx), newx), c(rev(Z9[1:m]), Z5[1:m]), col = "grey80", border = NA)

par(new=TRUE)
plot(Zm[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m])),ylab="Count",xlab="Time",main=paste("Out-sample forecast results of M2 model for ",name[k],sep=""),pch=19,col="red",xaxt = 'n')
lines(newx,Z9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Z5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(Z_FT[1:m],ylim=c(min(Zm[1:m]),max(Zm[1:m],Z9[1:m])),ylab="Count",xlab="Time",main=paste("Out-sample forecast results of M2 model for ",name[k],sep=""),pch=19,xaxt = 'n')
legend("topleft", legend=c("Observed data", "Forecasted data"), col=c("black", "red"), lty=c(1,1), lwd = 3,cex=2)

# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/27","Mar/17","May/05","Jun/25","Aug/06"))   ### GM
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/31","Mar/13","May/09","Jun/29","Aug/06"))   ### IT
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/22","Mar/12","Apr/30","Jun/19","Aug/06"))   ### JP
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Feb/01","Mar/20","May/10","Jun/30","Aug/06"))   ### SP
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/31","Mar/21","May/09","Jun/29","Aug/06"))   ### UK
# axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/22","Mar/12","Apr/30","Jun/19","Aug/06"))   ### US
axis(1, at=c(0,50,100,150,length(y)), labels=c("Jan/26","Mar/16","May/04","Jun/24","Aug/06"))   ### AU

dev.off()

######   RMSE results        ###############################################################

### Germany
> list(mae,rmse,mape,mase)
[[1]]
[1] 12517.73

[[2]]
[1] 14479.24

[[3]]
[1] 0.05425658

[[4]]
[1] 10.42504

## Italy
> list(mae,rmse,mape,mase)
[[1]]
[1] 28633.06

[[2]]
[1] 33356.15

[[3]]
[1] 0.1114455

[[4]]
[1] 42.5554

## Japan
> list(mae,rmse,mape,mase)
[[1]]
[1] 3407.51

[[2]]
[1] 3475.616

[[3]]
[1] 0.06044399

[[4]]
[1] 3.404822

## Spain
> list(mae,rmse,mape,mase)
[[1]]
[1] 6404.752

[[2]]
[1] 7764.212

[[3]]
[1] 0.01816862

[[4]]
[1] 1.153605

## UK
> list(mae,rmse,mape,mase)
[[1]]
[1] 21333.73

[[2]]
[1] 24918.48

[[3]]
[1] 0.06618652

[[4]]
[1] 20.42946

## US
> list(mae,rmse,mape,mase)
[[1]]
[1] 378799.5

[[2]]
[1] 464800.3

[[3]]
[1] 0.06784786

[[4]]
[1] 8.161634

## AU
> list(mae,rmse,mape,mase)
[[1]]
[1] 3069.551

[[2]]
[1] 3986.055

[[3]]
[1] 0.1254013

[[4]]
[1] 12.61277

##########################################################################################################################
##########################################################################################################################
##########################################################################################################################
n=length(y)

u=0.04
b0=0.004

n=length(y)

x=c()
x[1]=100
for (i in 1:(n-1) ){

x[i+1]=x[i]*exp(u*exp(-b0*i))
}
x=round(x)

plot(y,ylim=c(min(y),max(y)))
par(new=TRUE)
plot(x,col="red",ylim=c(min(y),max(y)))

#####   initial values         ##########################################################################

### Germany
u=0.24
b0=0.031#u*0.08 ###

## Italy
u=0.24
b0=0.03#u*0.08 ###

## Japan
u=0.05
b0=0.0055

## Spain
u=0.3
b0=0.037

## UK
u=0.3
b0=0.037

## US
u=0.1
b0=0.0067

## AU
u=0.04
b0=0.004


#   Data frame
#   Друга структура за съхраняване на данни в R е data frame. Разликата с матрицата е,
#   че елементите в матрицата е вектор от вектори и всички елементи са от един тип, докато
#   data frame-a е лист от вектори и елементите на data frame-а са от един тип, само в рамките
#   на отделния вектор.

set.seed(104)

#	Искаме да създадем data frame със симулирани 30 наблюдения.
N <- 30

girl_names <- c("Ashley Cooper", "Doris Parker", "Linda Torres", "Cynthia Collins", "Paula Taylor",
                "Maria Perez", "Kelly Gray", "Wanda Bryant", "Kimberly Griffin", "Theresa Watson",
                "Ruby Brown", "Christine Wright", "Rose Washington", "Marilyn Perry", "Teresa Baker",
                "Andrea Roberts", "Amanda Reed", "Tina Harris", "Judy Murphy", "Nicole Howard",
                "Susan Flores", "Janice Martin", "Pamela Johnson")

boys_dating_diary <- data.frame(
  #	Dates - 30 дни от днес назад
  asking_for_dating_DATE = as.Date(Sys.time()) - N:1,
  #	Strings - names of the girls
  girl_names = sample(x = girl_names, size = N, replace = T),
  # Boolean
  accept = sample(x = c(T, F), size = N, replace = T, prob = c(0.1, 0.9)),
  # Uniform distribution from 1 to 10
  rating = round(runif(N, 1, 10))
)

sample(x = girl_names, size = N, replace = T)
sample(x = c(T, F), size = N-10, replace = T, prob = c(0.1, 0.9))
sort(round(runif(N, 1, 10)))
?runif

#	- N:1 - създава се вектор с числа от N до 1 (намаляващ вариационен ред)
#	- sample(x, size, replace, prob) - на случаен принцип се избират
#	 - x - вектор, от който се избират елементите,
#	 - size - размерът на желаната извадка (в нашия случай 30),
#	 - replace - опцията дали да се преизбират наново елементи.
#   Ако size > x, то задължително трябва replace = TRUE
#	 - prob - вектор с вероятностите за избиране на случаен елемент.
#   Трябва дължината на prob да бъде равна на дължината на x и сборът да бъде равен на 1.

# Date frame to string
str(boys_dating_diary)

# В R можем да вземем първите и последните няколко реда с помощта на функциите head() и tail()
# Default for n is 6
head(x = boys_dating_diary)
head(x = boys_dating_diary, n = 3)
tail(x = boys_dating_diary, n = 3)

# Обединяване на матрици и data frame-ове по редове и колони
# Union of metrices by rows and cols
M1 <- matrix(data = 1:20, nrow = 10, byrow = T)
M2 <- matrix(data = 21:30, nrow = 2, byrow = T)
M1; M2

# Функциите за обединяване на две матрици/data frame-ове са:
# - rbind - обединение по редове - долепя втората матрица под първата
# - cbind - обединение по колони - долепя втората матрица след първата

# Error! Numbers of Rows and Columns must match!
rbind(M1, M2)

# Check dimensions of matrices
nrow(M1)
ncol(M1)
dim(M2)

# Transponse matrices
# Нека да транспонираме втората матрица (транспонирането е операция, за която редовете се
# превръщат в колони). Функцията за транспониране в R е t()
M2.t <- t(M2)
M2
M2.t
dim(M2.t)

rbind(M1, M2.t)

# Union of cols
M3 <- matrix(data = 21:40, nrow = 10, byrow = T)
cbind (M1, M3)

# cbind and rbind on Date Frames
boys_dating_diary_2 <- data.frame(
  #	Dates - 30 дни от днес назад
  asking_for_dating_DATE = as.Date(Sys.time()) - 30 -N:1,
  #	Strings - names of the girls
  girl_names = sample(x = girl_names, size = N, replace = T),
  # Boolean
  accept = sample(x = c(T, F), size = N, replace = T, prob = c(0.5, 0.5)),
  # Uniform distribution from 1 to 10
  rating = round(runif(N, 1, 10))
)
test = cbind(boys_dating_diary, boys_dating_diary_2)

# Функциите apply, lapply, sapply и т.н. могат да се прилагат и върху data frame-ове

# Взимане на ред, колона и елемент от data frame
# Всеки от начините, които споменахме при взиамне на елементи от матрица, са приложими и
# за data frame, като отделно имаме и допълнителни.

#	dataframe[rows, cols]

# First row and every columns
boys_dating_diary[1, ]

# First col of every row
boys_dating_diary[, 1]
boys_dating_diary[1:nrow(boys_dating_diary), 2]

# Fifth row - second and third col
boys_dating_diary[5, c(2, 3)]

# Fifth row, second col
boys_dating_diary[5, 2]

#	Get or set row names
row.names(boys_dating_diary)
row.names(boys_dating_diary) <- paste("try", 1:nrow(boys_dating_diary), sep = "_")
#	С paste() обединяваме вектори със стрингове (n-тия елемент на единия вектор с n-тия елемент на друг вектор)
# Имената трябва да са уникални

# При data frame-а можем да вземем елементи и посредством техните имена

# - По колони
#	С "$" взимаме елементи от листа. Data frame-а е ЛИСТ от ВЕКТОРИ => взимаме вектора
boys_dating_diary$girl_names
boys_dating_diary[, "girl_names"]
boys_dating_diary[, 2]
# Последните 3 са еквивалентни

# - По редове - име на реда
boys_dating_diary["try_1", ]

# - По имена на редове и колони
boys_dating_diary["try_1", c("girl_names", "accept")]

# -----------
# Филтриране
# Следващата стъпка е филтрирането на данни и взимането на подгрупи по зададен признак

#	& - логическо "и", | - логическо "или", == - проверка за равенство

# which() - Връща вектор с индекстите на елементите, за които булевото условие връща TRUE.
#	Тоест взимаме индексите на елементите, които ни вълнуват по някакъв начин.

# Нека да проверим кои от всички 30 опита са се оказали сполучиливи. Тоест,
# приели са поканата на момчето
# Връща реда
which(boys_dating_diary$accept)
# Prints the rows
boys_dating_diary[which(boys_dating_diary$accept), girl_names]
# Prints only the names
boys_dating_diary[which(boys_dating_diary$accept), "girl_names"]

# More complex filter
boys_dating_diary[which(boys_dating_diary$rating >= 7 & boys_dating_diary$accept), ]
# Returns only FALSE AND TRUE for every row
boys_dating_diary$rating >= 7

# Where IN
boys_dating_diary[which(boys_dating_diary$girl_names %in% c("Doris Parker", "Theresa Watson")), ]

# Как да вземем имената на момичетата, с които въпросният индивид се е опитал да се свърже през последната седмица?
# Дали са приели?
lastWeekdays <- as.Date(Sys.time()) - 7:0
boys_dating_diary[which(boys_dating_diary$asking_for_dating_DATE %in% lastWeekdays), ]

attach(boys_dating_diary)
girl_names
detach(boys_dating_diary)

# ------------------------------------------------------------------------
#                           О П И С А Т Е Л Н А    С Т А Т И С Т И К А
#   1. Променливи
#   Най-простата дефиниция за променливи е характеристика, която се варира от един човек/обект
#   до друг. Променливите са категоризирани в два типа
#   - количествени или числови (представят се с числа)
#   - категорийни или качествени (нечислово изобразяване)

#   Категорийните променливи се разбиват на два подтипа
#   - номинални (без подредба) - Примери за стойности на НОМИНАЛНИ променливи са: видове заведения, различни
#   държави и организции, видове алкохол, раси и т.н.
#   - ординални (с подредба) -  Примери за стойности на ОРДИНАРНИ променливи са:
#   степени на образование/квалификация, нива на социалните общества и т.н.

#   Количествените се разбиват на два подтипа
#   - Непрекъснати (стойностите могат да варират в даден числов интервал)  - възраст, различни съотношения, тегло
#   - Дискретни (възможните стойности могат да бъдат изброени) - брой катастрофи на шофьори, брой на деца

#   2. Разпределения
#   Разпределение - това е таблица, графика или формула, съдържаща стойностите на наблюденията
#   и колко често се случват. Разпределенията се характеризират с
#   - форма
#   - модалност (modality)
#   - локация
#   - размах
#   - симетричност/асиметричност
#   - ексцес.
#   - плътност

# ------------------------------------------------------
#   На графиката по-долу са представени няколко от формите на плътността на разпределенията
N <- 2*(10^4) # 20k
distributions <- c("Kambanovidna", "J-", "Pravoygylna", "Dqsno asimetrichna", "Dvumodalna")
par(mfrow = c(2, 3))

for (distr in distributions) {
  distribution_values <- switch(distr,
    "Kambanovidna" = rnorm(N), # Normal distribution
    "J-" = rexp(N), # Exponential distribution
    "Pravoygylna" = round(runif(N), 2), # Uniform distribution - Равномерно разпределение
    "Dqsno asimetrichna" = rgamma(N, shape = 5),   # Gamma distribution
    "Dvumodalna" = c(rnorm(N, mean = -2, sd = 2), rnorm(N, mean = 3, sd = 1)) #
  )

  distr_density <- density(distribution_values)
  ?hist
  hist(
    distribution_values,
    col = "pink",
    prob = T,
    main = paste(distr, "forma na razpredelenie"),
    ylab = "Density",
    xlab = "Values",
    ylim = range(distr_density$y),
    xlim = range(distr_density$x)
  )

    lines(distr_density, lwd = 3, col = "blue") # lwd - width of line
}
par(mfrow = c(1, 1))

# ----------------------------------------------------------------------
# Salaries
country = c('Switzerland', 'Norway', 'Iceland', 'Denmark', 'Finland', 'Netherlands', 'Germany',
            'Ireland', 'Sweden', 'United Kingdom', 'Austria', 'Belgium', 'France', 'Italy',
            'Spain', 'Malta', 'Slovenia', 'Estonia', 'Czech Republic', 'Portugal', 'Slovakia',
            'Poland', 'Croatia', 'Lithuania', 'Greece', 'Latvia', 'Hungary', 'Romania',
            'Bulgaria', 'Russia', 'Bosnia And Herzegovina', 'Serbia', 'Belarus', 'Albania',
            'Macedonia', 'Ukraine', 'Moldova')

avg_sal_in_USD = c(4959.48, 3416.1, 3136.95, 2975.8, 2583.43, 2575.2, 2538.92, 2521.51, 2494.39,
                   2394.78, 2219.23, 2162.23, 2140.64, 1675.32, 1480.64, 1278.04, 1180.66,
                   1158.76, 1069.03, 925.84, 894.2, 884.81, 852.23, 804.68, 795.34, 771.91,
                   708.91, 649.68, 611.41, 558.01, 481.17, 412.22, 409.62, 348.56, 346.15,
                   293.26, 284.94)

salaryDF <- data.frame(country, avg_sal_in_USD)

# Cars
Country <- c("Austria", "Belgium", "Croatia", "Czechia", "Denmark", "Estonia", "Finland",
             "France", "Germany", "Greece", "Hungary", "Ireland", "Italy", "Latvia",
             "Lithuania", "Luxembourg", "Netherlands", "Norway", "Poland", "Portugal",
             "Romania", "Slovakia", "Slovenia", "Spain", "Sweden", "Switzerland", "UK")

Car <- c("Volkswagen", "Volkswagen", "Skoda", "Skoda", "Peugeot", "Toyota", "Nissan",
         "Renault", "Volkswagen", "Toyota", "Suzuki", "Hyundai", "Fiat", "Volkswagen",
         "Fiat", "Volkswagen", "Volkswagen", "Nissan", "Skoda", "Renault", "Dacia",
         "Skoda", "Renault", "Seat", "Volvo", "Skoda", "Ford")

carsDF <- data.frame(Country, Car)

# --------------------------------------------------------------------------------
#                   А Н А Л И З    Н А    Е Д Н О М Е Р Н А    П Р О М Е Н Л И В А
#                                   (UNIVARIATE ANALYSIS)

#  ------------
#  3. Категорийни променливи
#  Категорийните промеенливи като цяло носят по-малко информация отколкото числовите променливи.
#  Често обаче, те носят по-голяма стабилност за прогнозните моделите отколкото числовите.

#   Освен графично представяне на данните (ще го разгледаме по-късно), най-добре честотата се
#   вижда посредством таблици. Функцията, която ни трябва е table()

# Взима първите 6 реда
head(carsDF)

# Взима честотното разпределение на категориините променливи
tt <- table(carsDF$Car)
tt
sort(tt)

# Взима процентното разпределение на променливите
round(prop.table(tt) * 100, 2)
sort(round(prop.table(tt) * 100, 2))

# Volkswagen държи най-голям пазарен дял по страни в Европа, следван от Skoda

# --------------
# 4. Числови променливи
#   4.1. Оценка на центъра (локацията) на разпределение (mean)
#       4.1.1. Средна стойност (Очакване)
meanFunc <- function(x) {
  sum(x) / length(x)
}

salaryDF$avg_sal_in_USD
meanFunc(salaryDF$avg_sal_in_USD)
mean(salaryDF$avg_sal_in_USD)

#       4.1.2. Медиана (Median)
#       Подреждаме данните във вариационен ред. Взимаме средната стойност (при нечетен брой)
#   или средната стойност на средните два елемента (при четен брой елементи).

medianFunction <- function(x) {
  x_sorted <- sort(x)
  length_of_x <- length(x_sorted)

  if (length_of_x %% 2 == 0) {
    x_sorted[length_of_x/2 + c(0, 1)]
    return (mean(x_sorted[length_of_x/2 + c(0, 1)]))
  } else {
    print(round(length_of_x/2 + 0.25))
    return (x_sorted[round(length_of_x/2 + 0.25)])
  }
}

medianFunction(c(1, 2, 3))
medianFunction(salaryDF$avg_sal_in_USD)
median(salaryDF$avg_sal_in_USD)

medianFunction(1:10)
median(1:10)

#     4.1.3. Мода - най-често срещаната стойност
modeFunction <- function(x) {
  tt <- table(x)

  return (names(tt))[tt == max(tt)]
}

table(round(salaryDF$avg_sal_in_USD / 100))

modeFunction(round(salaryDF$avg_sal_in_USD / 100))

#   Модата може да има повече от една стойност
#   table() - честотоното разпределение на променлива (коя стойност колко пъти се повтаря)
#   which.max() - връща индекса на първото число, което приема МАКСИМАЛНА стойност
#   which.min() - връща индекса на първото число, което приема МИНИМАЛНА стойност
#   names() - връща имената на стойностите

#   Описателна статистика за центъра на разпределението
summary(salaryDF$avg_sal_in_USD)

# Квантили
quantile(salaryDF$avg_sal_in_USD, prob = seq(0.1, 0.9, by = 0.1))
?quantile

#   Задача 1 - Ежедневни инциденти с мотоциклети
#   Шотландският изпълнителен директор в отдел "Аналитични услуги" на Транспортна
#   статистика събира данни за произшествията с мотоциклети. В таблицата по-долу са
#   представени, броят на инцидентите с мотоциклети в Шотландия по пътища с ограничение
#   до 30 и над 30 мили в час, случили се по дни от седмицата.
Day <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday")
Built_up <- c(88, 100, 76, 98, 103, 85, 69)
Non_built_up <- c(70, 58, 59, 53, 56, 94, 102)

motorcycleAccidentsDF <- data.frame(Day, Built_up, Non_built_up)
#   а. Каква е средната стойност и медианата на броя на произшествията за двата вида пътища
mean(motorcycleAccidentsDF$Built_up)
median(motorcycleAccidentsDF$Built_up)

mean(motorcycleAccidentsDF$Non_built_up)
median(motorcycleAccidentsDF$Non_built_up)

#   б. Каква е формата на разпределението по различните пътища. Интересува ни само модалността.

# Задача 2 - Инвестиции в акциите "LMT" и "FB"
Date <- c('2015-09', '2015-10', '2015-11', '2015-12', '2016-01', '2016-02', '2016-03', '2016-04',
          '2016-05', '2016-06', '2016-07', '2016-08', '2016-09', '2016-10', '2016-11', '2016-12',
          '2017-01', '2017-02', '2017-03', '2017-04', '2017-05', '2017-06', '2017-07', '2017-08',
          '2017-09', '2017-10', '2017-11', '2017-12', '2018-01', '2018-02', '2018-03', '2018-04',
          '2018-05', '2018-06', '2018-07', '2018-08', '2018-09')
FB <- c(89.9, 101.97, 104.24,
        104.66, 112.21, 106.92, 114.1, 117.58, 118.81, 114.28, 123.94, 126.12, 128.27, 130.99,
        118.42, 115.05, 130.32, 135.54, 142.05, 150.25, 151.46, 150.98, 169.25, 171.97, 170.87,
        180.06, 177.18, 176.46, 186.89, 178.32, 159.79, 172, 191.78, 194.32, 172.58, 175.73,
        164.46)
LMT <- c(207.31, 219.83, 219.16, 217.15, 211, 215.79, 221.5, 232.38, 236.23, 248.17, 252.73,
         242.97, 239.72, 246.38, 265.25, 249.94, 251.33, 266.58, 267.6, 269.45, 281.13, 277.61,
         292.13, 305.39, 310.29, 308.16, 319.12, 321.05, 354.85, 352.44, 337.93, 320.84, 314.54,
         295.43, 326.1, 320.41, 345.96)
stocksDF <- data.frame(Date, LMT, FB)

#   Анализът трябва да се извърши върху възвръщаемостите на цените, получени по diff(log(x)),
#   където "x" е цената на актива

#   а. Какви са средните стойности и медианите. Според вас как се интерпретират тези числа
#   б. Можете ли да кажете в кой актив бихте инвестирали при наличието само на тази информация

log(10, base = 10)

x = 1:5


# 4. faza: Analiza podatkov

l <- data.frame(leto=c(2020, 2021, 2022))

# Graf za napoved števila delovno aktivnih moških z visokošolsko ali višješolsko izobrazbo

visokoizobrazeni_moski <- tabela_po_izobrazbi %>% filter(izobrazba == 'Višješolska, visokošolska') %>%
  filter(spol == 'Moški')
visokoizobrazeni_moski$leto = as.numeric(as.character(visokoizobrazeni_moski$leto))

model_visokoizobrazeni.moski <- lm(stevilo ~ leto, data=visokoizobrazeni_moski)
napoved_moski <- mutate(l, stevilo=predict(model_visokoizobrazeni.moski,l))

graf_napovedi_visokoizobrazeni.moski <- ggplot(visokoizobrazeni_moski, aes(x=leto, y=stevilo)) +
  geom_point() + geom_smooth(method=lm, fullrange=TRUE) +
  geom_point(data=napoved_moski, aes(x=leto, y=stevilo), color='plum1', size=3) +
  scale_x_continuous(breaks=2008:2022) + theme_minimal() +
  labs(title = 'Napoved števila delovno aktivnih moških \nz visokošolsko ali višješolsko izobrazbo',
       x = 'Leto', y = 'Število v 1000')

# Graf za napoved števila delovno aktivnih žensk z visokošolsko ali višješolsko izobrazbo

visokoizobrazene_zenske <- tabela_po_izobrazbi %>% filter(izobrazba == 'Višješolska, visokošolska') %>%
  filter(spol == 'Ženske')
visokoizobrazene_zenske$leto = as.numeric(as.character(visokoizobrazene_zenske$leto))

model_visokoizobrazene.zenske <- lm(stevilo ~ leto, data=visokoizobrazene_zenske)
napoved_zenske <- mutate(l, stevilo=predict(model_visokoizobrazene.zenske,l))

graf_napovedi_visokoizobrazene.zenske <- ggplot(visokoizobrazene_zenske, aes(x=leto, y=stevilo)) +
  geom_point() + geom_smooth(method=lm, fullrange=TRUE) +
  geom_point(data=napoved_zenske, aes(x=leto, y=stevilo), color='plum1', size=3) +
  scale_x_continuous(breaks=2008:2022) + theme_minimal() +
  labs(title = 'Napoved števila delovno aktivnih žensk \nz visokošolsko ali višješolsko izobrazbo',
       x = 'Leto', y = 'Število v 1000')


#' Calculate the realized volatility for a transction price time-series
#'
#' @param price and xts object containting transaction prices
#' @param interval the window size to calculate realized volatility over. The
#' default is 5 mintes.
#' @param interval const the number of trading periods specified by the interval
#  for example if you are looking at daily this should be set to 252, which
#' is the number of trading days in a year. It should be noted that this is
#' only needed for calculations like realized volatility. For comparison
#' of two stocks over the same intervals it is fine to leave this as 1.
#' @examples
#' data(aapl_fix)
#' ctp = consolidate_prices(aapl_fix$sys_date, aapl_fix$sys_time,
#'  aapl_fix$td_price, aapl_fix$td_size, date_format="%Y-%m-%d",
#'  time_format="%H:%M:%S")
#' rv = realized_volatility(ctp$price)
#' plot(rv)
#' @export
realized_volatility = function(price, interval=minutes(5),
                               interval_const=1) {
  log_price = log(price)
  log_diff_price = na.omit(diff(log_price))
  if (is.null(getDoParName())) registerDoSEQ()
  ret=foreach(it=inclusive_window_gen(time(log_diff_price), interval),
    .combine=rbind) %dopar% {
    ldp = log_diff_price[it]
    data.frame(
      list(volatility=
        100*sqrt(interval_const/length(ldp)*mean(ldp^2, na.rm=TRUE)),
        time=tail(time(ldp), 1)))
  }
  xts(ret$volatility, order.by = ret$time)
}


### Obtain effectRatio code from GitHub ###
source("https://raw.githubusercontent.com/hyunseungkang/matchIV/master/effectRatio.r")

##### Example Run #####
### Generate simulated data ###

### Simulated data contains n=1000 individuals,
### the response (denoted as R), the exposure
### (denoted as D), the instrument (denoted as
###  Z), and the covariates (denoted as X)

### Simulated Data Characteristics
### R is continuous (e.g. height)
### D is continuous (e.g. amount of malaria parasite in plasma)
### Z is binary (1/0 e.g. Sickle cell trait status)
### X1 is a continuous variable (e.g. birthweight),
### X2 is a binary variable (1/0, e.g. sex)
### NOTE1: our method can handle continuous, discrete, binary R,D,Xs,
###       and many covariates. Our method only
###       requires that Z is binary (1/0) and non-missing.
### NOTE2: If some values of Xs are missing
###        (e.g. contains NAs), then
###        you must provide a "cleaned" X
###        without NAs, depending on how
###        you want to take care of missing
###        values (e.g. imputation, MCAR, MAR, etc.)
### NOTE3: If R or D are missing, then you must provide a
###        cleaned R and D without NAs.

set.seed(1) #Random number generator seed. Change it as you please!
n = 1000
Z = runif(n) < 0.5
X1 = rnorm(n,rep(c(0,1),n/2))
X2 = rep(c(0,1),n/2)
X = cbind(X1,X2)

# Generate R and D
# Note that R and D are non-linear functions of X.
# -3 is the true value of the causal effect of D on R in this example
# Our point estimator should be close to -3 and our confidence interval
# should have the desired level of coverage
D = -1 + 0.2 * Z + X1 - 2*X1^2 - 2 * X2 + rnorm(n)
R = 2 - 3 * D + X1 - 2*X1^2 - 2 * X2 + rnorm(n)

### Run our method (automatically matches and estimateds Lambda)
estLambda(Z,R,D,X)

### Run 2SLS
est2SLS(Z,R,D,X)

### EXPECTED RESULT:
###         In most cases, you will notice that our method (estLambda)'s
###         point estimate will be closer to -3. Furthermore, our confidence
###         interval should have the desired 95% level of coverage.
###         In contrast, 2SLS (est2SLS) will be off from -3 most of the
###         time and its confidence interval will not have the desired
###         95% level of coverage.

#### Some other functions
### Match analysis
fullmatchvec = matching(Z,X) #full-match individuals
balanceCheck(Z,X,fullmatchvec) #checks balance of covariates


mean mean<- 15.28
var <- 9.07

domanda1_a <- 13.92
domanda1_b <- 16.19
domanda2 <- 10.87
domanda3 <- 12.85

sd <- sqrt(var)
x <- seq(mean-5, mean+5, length.out = 100)

risposta1 <- pnorm(mean = mean, sd = sd, q = c(domanda1_a,domanda1_b))
risposta2 <- pnorm(mean = mean, sd = sd, q = domanda2)
risposta3 <- c(pnorm(mean = mean, sd = sd, q = -domanda3),
               pnorm(mean = mean, sd = sd, q = domanda3))

plot(x, dnorm(mean = mean, sd = sd, x = x), type="l")
print(risposta1[2]-risposta1[1])
print(risposta2)
print( risposta3[1] + (1-risposta3[2]))


# Function that returns the Proba-V tile number when given a set of coordinates
ProbaVTileID = function(point)
{
    # X00Y00 is -180.0005, -170.0005,  65.0005,  75.0005  (xmin, xmax, ymin, ymax)
    # X12Y13 is  -60.0005,  -50.0005, -64.9995, -54.9995
    # X17Y03 is  -10.0005,   -0.0005,  35.0005,  45.0005
    # X18Y04 is   -0.0005,    9.9995,  25.0005,  35.0005
    # X18Y06 is   -0.0005,    9.9995,   5.0005,  15.0005
    # X18Y07 is   -0.0005,    9.9995,  -4.9995,   5.0005
    # X35Y12 is  169.9995,  179.9995, -54.9995, -44.9995
    # Point 0,0 is at X18Y07

    # xmin: -180.0005 + 10 * X
    # xmax: xmin + 10
    # ymin:   65.0005 - 10 * Y
    # ymax: ymin + 10

    # Inversion: (180.0005 + xmin)/10 = X
    XID = as.integer((180.0005 + point$x)/10)
    # Inversion:  (75.0005 - ymin)/10 = Y
    YID = as.integer((75.0005 - point$y)/10)

    return(sprintf("X%02dY%02d", XID, YID))
}

# Africa is from X16Y03 to X23Y10


#!/usr/bin/Rscript

################################################################################
#           Fundamentos de la Ciencia de Datos - 78106 - R-PL1                 #
#                               Grupo 4 - P1                                   #
#   Authors:                                                                   #
#   - David Emanuel Craciunescu                                                #
#   - Laura Pérez Medeiro                                                      #
#                                                                              #
################################################################################

################################################################################
#                       IMPORTS AND DEPENDENCY CHECKS                          #
################################################################################

library(docopt)
library(foreign)
library(tools)
library(splus2R)

# list_of_packages[!(list_of_packages %in% installed.packages()[, "Package"])]

################################################################################
#                               CALCULATIONS                                   #
################################################################################

# 1. Calculate absolute and relative satellite radius frequencies.

## 1.1. Absolute frequencies.
absoluteFreq    <- function(set) {table(set)}
cumAbsoluteFreq <- function(set) {cumsum(absoluteFreq(set))}

## 1.2. Relative frequencies.
   relativeFreq <- function(set) {table(set) / length(set)}
cumRelativeFreq <- function(set) {cumsum(relativeFreq(set))}

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

# 2. Arithmetic mean.
arithmeticMean <- function(set, usrTrim = 0) (mean(set, trim = usrTrim))

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

# 3. Measures of dispersion.

# The following page was used as a reference for this section.
# http://iridl.ldeo.columbia.edu/dochelp/StatTutorial/Dispersion/index.html#Intro

## 3.1. Range.
          range <- function(set) {max(set) - min(set)}

## 3.2. Standard Deviation.
   stdDeviation <- function(set)
{
   sd(set) * (sqrt((length(set) - 1) / length(set)))
}

## 3.3. Variance.
       variance <- function(set) {var(set) * (length(set) - 1 / length(set))}

## 3.4. Root Mean Square.
    rootMeanSqr <- function(set) {sqrt(mean(set ^ 2))}

## 3.5. Root Mean Square Anomaly.
  rootMeanSqrAn <- function(set) {sqrt(sum(set - mean(set)) ^ 2) / length(set)}

## 3.6. Interquartile Range.
interQuartRange <- function(set) {IQR(set)}

## 3.7. Median Absolute Deviation.
medAbsDeviation <- function(set) {mad(set)}

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

# 4. Measures of order.

## 4.1. Median.
getMedian    <- function(set) {median(set)}

## 4.2. Mode.
getMode      <- function(set)
{
    uniqueVal <- unique(set)
    uniqueVal[which.max(tabulate(match(set, uniqueVal)))]
}

## 4.2. Quartiles.
getQuartiles <- function(set) {quantile(set)}

## 4.3. 54th Quantile.
getQuantiles <- function(set, range = 0) {quantile(set, probs = range)}

################################################################################
#                                 INTERFACE                                    #
################################################################################

'
sStats 1.1, a simple statistical analyzer

Usage:
    sstats freq (--abs | --cum_abs | --rel | --cum_rel) (--path=PATH --var=VAR)
    sstats mean (--path=PATH --var=VAR)
    sstats disp (--iq | --mad | --rng | --rms | --rmsa | --std | --vari) (--path=PATH --var=VAR)
    sstats ord (--med | --mod | --qnt=QUANT | --qrt) (--path=PATH --var=VAR)
    sstats -a | --authors
    sstats -h | --help
    sstats -l | --license
    sstats --version

Options:
    -a --authors        Show authors of the program.
    -h --help           Show this screen.
    -l --license        Show license information.
    --version           Show version information.

Commands:
    freq - frequency analyzer
    --abs               Absolute frequency
    --cum_abs           Cumulative absolute frequency
    --rel               Relative frequency
    --cum_rel           Cumulative relative frequency

    mean                Arithmetic mean

    disp - dispersion measures
    --iq                Interquartile range
    --mad               Median absolute deviation
    --rng               Range
    --rms               Root mean square
    --rmsa              Root mean square anomaly
    --std               Standard deviation
    --vari              Variance

    ord - ordering measures
    --med               Median
    --mod               Mode
    --qnt=QUANT         Quantile
    --qrt               Quartile

Input:
    Only processes .txt and .sav files.
' -> docString

args <- docopt(docString, version = 'sStats 1.1')

################################################################################
#                               PARSE INPUT                                    #
################################################################################

if (args $ authors) {
    cat("Proudly developed by @craciunescu and @laurapm\n")

} else if (args $ license) {
    cat(readLines("../LICENSE"), fill = T)

} else {

    # Process input file | Check for supported extension
    ext <- lowerCase(file_ext(file.path(args$path)))

    if (ext == "txt") {
        dataset <- read.table(args$path)
    } else if (ext == "sav") {
        dataset <- read.spss(args$path, to.data.frame = T)
    } else {
        print("The input file cannot be processed")
    }

    # R does not accept direct variable reference to dataset column.

    column <- args$var
    data <- c(dataset[column][!is.na(dataset[column])])

    ############################################################################
    #                               COMMANDS                                   #
    ############################################################################

    # Frequencies.
    if (args $ freq) {

        if (args $ abs) {
            cat("Absolute frequency of data")
            absoluteFreq(data)

        } else if (args $ cum_abs) {
            cat("Cumulative absolute frequency\n")
            cumAbsoluteFreq(data)

        } else if (args $ rel) {
            cat("Relative frequency of data")
            relativeFreq(data)

        } else if (args $ cum_rel) {
            cat("Cumulative relative frequency of data")
            cumRelativeFreq(data)

        } else {
            cat("Unsupported behavior for FREQ command")
            print(docString)
        }

    # Means.
    } else if (args $ mean) {
        cat("Arithmetic mean =", arithmeticMean(data), "\n")

    # Dispersion.
    } else if (args $ disp) {
        if (args $ iq) {
            cat("Interquartile Range =", interQuartRange(data), "\n")

        } else if (args $ mad) {
            cat("Median Absolute Deviation =", medAbsDeviation(data), "\n")

        } else if (args $ rng) {
            cat("Range =", range(data), "\n")

        } else if (args $ rms) {
            cat("Root mean square =", rootMeanSqr(data), "\n")

        } else if (args $ rmsa) {
            cat("Root mean square anomaly =", rootMeanSqrAn(data), "\n")

        } else if (args $ std) {
            cat("Standard deviation =", stdDeviation(data), "\n")

        } else if (args $ vari) {
            cat("Variance =", variance(data), "\n")

        } else {
            cat("Unsupported behavior for DISP command")
            cat(docString)
        }

    # Ordering.
    } else if (args $ ord) {
        if (args $ med) {
            cat("Median =", getMedian(data), "\n")

        } else if (args $ mod) {
            cat("Mode =", getMode(data), "\n")

        } else if (!is.null(args$qnt)) {

            quant <- as.numeric(args$qnt)

            if ((quant > 0) && (quant <= 1))
            {
                cat("Quantile", quant*100, "% =" , getQuantiles(data, quant), "\n")
            } else {
                cat("Unsupported Quantile Value\n")
                cat("--qnt=[0-1]\n")
            }

        } else if (args$qrt) {
            cat("Quartiles\n")
            getQuartiles(data)

        } else {
            cat("Unsupported behavior for ORD command")
            cat(docString)
        }

    # Unsupported behavior.
    } else {
        cat("An unidentified error has occurred")
        cat("Please report bugs to github.com/craciunescu/sstats")
        cat("\n")
        cat(docString)
    }
}


# book: Design and Analysis of Experiments with R
# review: the theory is a mess, but can be used as a guide for which packages to use for specific plans

set.seed(42)

f = factor(rep(c(35, 40, 45), each = 4))
f

# randomize
f1 = sample(f, 12)
f1

# numbers of observations
e = 1:12
e

plan = data.frame(loaf = e, time = f1)
plan

getwd()
setwd("/home/tony/source/design-of-experiments")
write.csv(plan, file = 'plan.csv', row.names = FALSE)

bread = read.csv("plan.csv")
bread

height = c(9.75, 8.75, 4.5, 6.5, 6.5, 5.0, 10.5, 5.5, 6.5, 9.5, 8.25, 6.75)
bread = data.frame(loaf = plan$loaf, time = plan$time, height = height)
bread

install.packages('daewr')
library(daewr)

model1 = lm(height ~ time, data = bread)
summary(model1)

# - 1 removes the free coefficient
model2 = lm(height ~ time - 1, data = bread)
summary(model2)

install.packages('gmodels')
library(gmodels)

# compare 35 to 40 minutes
fit.contrast(model1, "time", c(1, -1, 0))
# the same fit.contrast won't work on model2, because it is missing its free coefficient

# build ANOVA table
model3 = aov(height ~ time, data = bread)
summary(model3)

plot(model3, which = 1)
plot(model3, which = 2) # qq-plot

library(MASS)
bc = boxcox(model3)
lambda = bc$x[which.max(bc$y)]
lambda

# when you have observations close to being outliers, you can normalize (transform) the data
breadtr = transform(bread, heighttr = height ^ lambda)
breadtr

model4 = aov(heighttr ~ time, data = breadtr)
summary(model4) # the p-value is smaller for model4 than for model3
summary(model3)

# the probability distributions in the plots are hardly influenced by transformations
plot(model4, which = 2)

# use this plot to see if the order of the observations made in time has a functional dependence
# it is possible to have a time series
plot(residuals(model4) ~ loaf, data = bread)

model3tukey = TukeyHSD(model3, ordered = T)
model3tukey

contr.poly(3)
contrasts(bread$time)

install.packages('agricolae')
library(agricolae)

# Newman-Koils test
print(SNK.test(model3, 'time', group = FALSE))

install.packages('multcomp')
library(multcomp)

contrd = glht(model3, linfct = mcp(treat = 'Dunnet'), alternative = 'greater')
summary(contrd)


# Goals: Simulate a dataset from a "fixed effects" model, and
#        obtain "least squares dummy variable" (LSDV) estimates.
#
# We do this in the context of a familiar "earnings function" -
#  log earnings is quadratic in log experience, with parallel shifts by
#  education category.

# Create an education factor with 4 levels --
education <- factor(sample(1:4,1000, replace=TRUE),
                    labels=c("none", "school", "college", "beyond"))
# Simulate an experience variable with a plausible range --
experience <- 30*runif(1000)            # experience from 0 to 20 years
# Make the intercept vary by education category between 4 given values --
intercept <- c(0.5,1,1.5,2)[education]

# Simulate the log earnings --
log.earnings <- intercept +
  2*experience - 0.05*experience*experience + rnorm(1000)
A <- data.frame(education, experience, e2=experience*experience, log.earnings)
summary(A)

# The OLS path to LSDV --
summary(lm(log.earnings ~ -1 + education + experience + e2, A))

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/o4.r