library(tidyverse)
library(magrittr)
library(readxl)
library(here)
library(ggplot2)
library(purrr)
library(writexl)

A <- c(393.979,	419.038)
B <- c(366.358,550.138)
C <- c(601.903,632.171)
D <- c(705.481,538.638)

O1 <- c(500.000,500.000)
O2 <- c(585.023,548.609)
O3 <- c(500.000,548.609)
O4 <- c(585.023,500.000)
O5 <- c(542.511,524.304)

points <- rbind(A, B, C, D, O1, O2, O3, O4, O5) %>% as.data.frame() %>% rownames_to_column("Name") %>% rename(x = V1, y = V2)

obs_plan <- data.frame(station = rep(c("A", "A", "A", "B", "B", "C", "C", "C", "D", "D"), 2), obs.point = rep(c("B", "O1", "O3", "A", "O1", "D", "O2","O3", "C", "O2"), 2), type = c(rep("p", 10), rep("d", 10)) )

st_coords <- A
target_coords <- O1
orient_coords <- B

dist <- function(pt1_coords, pt2_coords, axes = c("Easting", "Northing")){
  ## check if the axis were set:
  if(length(axes) < 2) stop("axes must be defined with Easting and Northing")
  if(!any(axes %in% list("Northing", "Easting"))){ stop(paste(type, "axes must be Northing and Easting.")) }

  Northing_ind <- which(axes == "Northing")
  Easting_ind <- which(axes == "Easting")

  ## body
  Easting1 <- pt1_coords[Easting_ind]
  Northing1 <- pt1_coords[Northing_ind]
  Easting2 <- pt2_coords[Easting_ind]
  Northing2 <- pt2_coords[Northing_ind]
  dEasting <- as.numeric(Easting2 - Easting1)
  dNorthing <- as.numeric(Northing2 - Northing1)
  distance <- sqrt(dEasting^2 + dNorthing^2)
  return(distance)
}

ni <- function(pt1_coords, pt2_coords, type = list("dec", "dms", "rad"), axes = c("Easting", "Northing")){
  ## check if the axis were set:
  if(length(axes) < 2) stop("axes must be defined with Eastinging and Northinging")
  if(!any(axes %in% list("Northing", "Easting"))){ stop(paste(type, "axes must be Northing and Easting.")) }

  Northing_ind <- which(axes == "Northing")
  Easting_ind <- which(axes == "Easting")

  ## check if the type exists:
  if(length(type) > 1){ type <- type[[1]] }
  if(!any(type %in% list("dms", "dec", "rad"))){ stop(paste(type, "method not available.")) }

  ## body
  Easting1 <- pt1_coords[Easting_ind]
  Northing1 <- pt1_coords[Northing_ind]
  Easting2 <- pt2_coords[Easting_ind]
  Northing2 <- pt2_coords[Northing_ind]
  dEasting <- as.numeric(Easting2 - Easting1)
  dNorthing <- as.numeric(Northing2 - Northing1)
  atg <- ifelse(dEasting < 0, atan(dNorthing/dEasting)*180/pi + 180, atan(dNorthing/dEasting)*180/pi)
  ang <- ifelse(atg < 0, atg + 360, atg)

  deg <- floor(ang); minut <- floor((ang-deg)*60); sec <- ((ang-deg)*60-minut)*60

  if(type == "dms"){
    ang <- c(deg, minut, sec)
    names(ang) <- c("deg","min","sec")
  }
  if(type == "rad"){
    ang <- ang*pi/180
  }

  return(ang)
}

# ni(pt1_coords = st_coords, pt2_coords = target_coords, type = "dms", axes = c("Easting", "Northing"))

# st_coords = A; target_coords = B; Hz_orient = NULL; Hz0 = 255; sd_cent = 2; sd_Hz = 5; seed = 111; c =  10; sd_colim = 5; sd_cent_back = 5; sd_cent_target = 5; sd_focus = NULL; faces = list("mean", "both" ,"face1", "face2"); type = list("dec", "dec", "rad"); axes = c("Northing", "Easting")

sim_Hz <- function(st_coords, target_coords, Hz_orient = NULL, Hz0 = 0, sd_cent = 2, sd_Hz = 5, c =  10, sd_colim = 5, sd_cent_target = NULL, sd_focus = NULL, seed = NULL, faces = list("mean", "both" ,"face1", "face2"), type = list("dms", "dec", "rad"), axes = c("Northing", "Easting")){
  ## check if the axis were set:
  if(length(axes) < 2) stop("axes must be defined with Easting and Northing")
  if(!any(axes %in% list("Northing", "Easting"))){ stop(paste(type, "axes must be Northing and Easting.")) }

  Northing_ind <- which(axes == "Northing")
  Easting_ind <- which(axes == "Easting")

  ## check if the type exists:
  if(length(type) > 1){ type <- type[[1]] }
  if(!any(type %in% list("dms", "dec", "rad"))){ stop(paste(type, "method not available.")) }

  d <- dist(pt1_coords = st_coords, pt2_coords = target_coords, axes = axes)
  ni1 <- ni(pt1_coords = st_coords, pt2_coords = target_coords, type = "dec", axes = axes)
  z <- 360-Hz0
  ro <- 180/pi*3600
  twoc = 2*c

  ## check if the type exists:
  if(length(type) > 1){ type <- type[[1]] }
  if(!any(type %in% list("dms", "dec", "rad"))){ stop(paste(type, "method not available.")) }

  if(ni1 >= Hz0){
    Hz <- z+ni1-360
  }else{
    Hz <- z+ni1
  }

  # seed mora biti fiksiran za stanicu
  if(!is.null(sd_cent)){
    set.seed(seed)
    sd_cent <- abs(rnorm(1, 0, sd_cent))
    sd_cent <- sqrt((sd_cent^2*ro^2)/(2*(d*1000)^2))
    Hz <- Hz + sd_cent/3600
    }
  if(!is.null(sd_cent_target)){
    set.seed(seed)
    sd_cent_target <- abs(rnorm(1, 0, sd_cent_target))
    sd_cent_target <- sqrt((sd_cent_target^2*ro^2)/(2*(d*1000)^2))
    Hz <- Hz + sd_cent_target/3600
    }

  set.seed(Sys.time())
  Hz <- Hz + sqrt((rnorm(1, 0, sd_Hz))^2)/3600

  if(type == "dms"){
    HzD <- floor(Hz); HzM <- floor((Hz-HzD)*60); HzS <- ((Hz-HzD)*60-HzM)*60
    Hz <- c(HzD, HzM, HzS)
    names(Hz) <- c("deg","min","sec")
    return(round(Hz))
  }
  if(type == "rad"){
    Hz <- Hz*pi/180
  }
return(Hz)
}

# sim_Hz(A, O1, Hz0 = 255, sd_cent = 12, sd_cent_target = 12, sd_Hz = 16, seed = 111, type = "dms", axes = c("Easting", "Northing"))

sim_ang <- function(st_coords, orient_coords, target_coords, seed, Hz0 = 0, sd_Hz = 5, c =  10, sd_cent = 2, sd_cent_back = 2, sd_cent_target = 0, type = list("dms", "dec", "rad"), axes = c("Easting", "Northing")){
  ## check if the axis were set:
  if(length(axes) < 2) stop("axes must be defined with Easting and Northing")
  if(!any(axes %in% list("Northing", "Easting"))){ stop(paste(type, "axes must be Northing and Easting.")) }

  ## check if the type exists:
  if(length(type) > 1){ type <- type[[1]] }
  if(!any(type %in% list("dms", "dec", "rad"))){ stop(paste(type, "method not available.")) }

  Hz1 <- sim_Hz(st_coords = st_coords, target_coords =  target_coords, Hz0 = Hz0, sd_cent = sd_cent, sd_Hz = sd_Hz, sd_cent_target = sd_cent_target, type = "dec", seed = seed, axes = c("Northing", "Easting"))
  Hz2 <- sim_Hz(st_coords = st_coords, target_coords =  orient_coords, Hz0 = Hz0, sd_cent = sd_cent, sd_Hz = sd_Hz, sd_cent_target = sd_cent_back, type = "dec", seed = seed, axes = c("Northing", "Easting"))

  # ni1 <- ni(pt1_coords = st_coords, pt2_coords = target_coords, type = "dec", axes = c("Northing", "Easting"))
  # ni2 <- ni(pt1_coords = st_coords, pt2_coords = orient_coords, type = "dec", axes = c("Northing", "Easting"))

  dang <- as.numeric(Hz1-Hz2)
  dang <- ifelse(dang < 0, 360+dang, dang)

  if(type == "dms"){
    deg <- floor(dang); minut <- floor((dang-deg)*60); sec <- ((dang-deg)*60-minut)*60
    dang <- c(deg, minut, sec)
    names(dang) <- c("deg","min","sec")
  }
  if(type == "rad"){
    dang <- dang*pi/180
  }

  return(dang)
}

# sim_ang(st_coords = A, target_coords = O1, orient_coords = B, seed = NULL, Hz0 = 288, sd_cent = 2, sd_cent_back =  2, sd_cent_target = 1,  type = "dms", axes = c("Easting", "Northing"))

sim_dist <- function(st_coords, target_coords, sd_cent_station = NULL, sd_cent_target = NULL, sd_dist = 3, seed = NULL, axes = c("Easting", "Northing")){
  ## check if the axis were set:
  if(length(axes) < 2) stop("axes must be defined with Easting and Northing")
  if(!any(axes %in% list("Northing", "Easting"))){ stop(paste(type, "axes must be Northing and Easting.")) }

  distance = dist(pt1_coords = st_coords, pt2_coords = target_coords, axes = axes)

  if(!is.null(sd_cent_station)){
    set.seed(seed)
    sd_cent_station <- abs(rnorm(1, 0, sd_cent_station))
    sd_cent_station <- sqrt(sd_cent_station^2/2)
  }
  if(!is.null(sd_cent_target)){
    set.seed(seed)
    sd_cent_target <- abs(rnorm(1, 0, sd_cent_target))
    sd_cent_target <- sqrt(sd_cent_target^2/2)
  }
  distance <- distance + sd_cent_station/1000 + sd_cent_target/1000
  set.seed(seed)
  distance <- distance + sqrt((rnorm(1, 0, sd_dist))^2)/1000
  return(distance)
}

# sim_dist(st_coords = A, target_coords = B, seed = 111, sd_cent_station = 2, sd_cent_target =  2, sd_dist = 3)

#station = as.numeric(points[1, c(2,3)])
#target_points = points[c(2, 5), ]

#stA <- data.frame(rep = points[which(points$Name == obs_plan[1, 1]), c(2,3)], target_points)

#station_Hz <- function(station, target_points, Hz0 = 0, sd_cent_station = 2, sd_Hz = 5, c =  10, sd_colim = 5, sd_cent_target = NULL, sd_focus = NULL, seed = NULL, faces = list("mean", "both" ,"face1", "face2"), type = list("dms", "dec", "rad"), axes = c("Northing", "Easting")){
#  target_points %>% group_by(Name) %>% Hz(st_coords = station, target_coords =  (target_points[,c(2,3)]), Hz0 = Hz0, sd_cent = sd_cent, sd_Hz = sd_Hz, sd_cent_target = sd_cent_target, type = "dec", seed = seed, axes = c("Northing", "Easting"))
#
#  t(apply(target_points, 1, function(x) Hz(st_coords = station, target_coords = as.numeric(x[c(2:3)]), Hz0 = 270, sd_cent = 2, sd_Hz = 5, sd_cent_target = 2, type = "dms", seed = 111, axes = c("Northing", "Easting"))))
#
#}

#obs_Hz <- filter(obs_plan, type == "p") %>% select(1,2)
#Hz0 = c(0, 0, 0, 0); sd_cent_station = c(1, 1, 1, 1); sd_cent_target = c(1, 1, 1, 1); sd_Hz = c(5, 5, 5, 5); seed = NULL #c(111, 222, 333, 444)
#red = FALSE

sim_Hz_all <- function(obs_Hz, points, red = TRUE, Hz0 = NA, sd_cent_station = c(1, 1, 1, 1), sd_cent_target = c(1, 1, 1, 1), sd_Hz = c(5, 5, 5, 5), seed = c(111, 222, 333, 444), type = list("dms", "dec", "rad"), axes = c("Northing", "Easting")){

  if(is.na(Hz0)) {Hz0 <- sample(1:359, size = length(unique(obs_Hz$station)))}else{
    if(length(Hz0) != length(unique(obs_Hz$station))) stop("Hz0 must be of length either 1 or number of stations")
  }

  if(length(sd_cent_station) == 1) sd_cent_station <- rep(sd_cent_station, length(unique(obs_Hz$station)))
  if(length(sd_cent_station) != length(unique(obs_Hz$station))) stop("sd_cent_station must be of length either 1 or the number of stations")

  if(length(sd_cent_target) == 1) sd_cent_target <- rep(sd_cent_target, length(unique(obs_Hz$station)))
  if(length(sd_cent_target) != length(unique(obs_Hz$station))) stop("sd_cent_target must be of length either 1 or the number of stations")

  if(length(sd_Hz) == 1) sd_Hz <- rep(sd_Hz, length(unique(obs_Hz$station)))
  if(length(sd_Hz) != length(unique(obs_Hz$station))) stop("sd_Hz must be of length either 1 or the number of stations")

  if(!is.null(seed)){
    if(length(seed) == 1) seed <- rep(seed, length(unique(obs_Hz$station)))
    if(length(seed) != length(unique(obs_Hz$station))) stop("seed must be of length either 1 or the number of stations")
  }else{
    seed <- rep(NULL, length(unique(obs_Hz$station)))
  }

  obs_Hz <- mutate(obs_Hz, x_station = rep(NA, dim(obs_Hz)[1]), y_station = rep(NA, dim(obs_Hz)[1]), x_target = rep(NA, dim(obs_Hz)[1]), y_target = rep(NA, dim(obs_Hz)[1]))
  for(i in 1:dim(obs_Hz)[1]){
    obs_Hz[i , c("x_station", "y_station")] <- points[which(obs_Hz$station[i] == points$Name), 2:3]
    obs_Hz[i , c("x_target", "y_target")] <- points[which(obs_Hz$obs.point[i] == points$Name), 2:3]
  }

  obs.Hz.list <- split(obs_Hz, obs_Hz$station)
  for(i in 1:length(obs.Hz.list)){
    obs.Hz.list[[i]]$Hz0 <- rep(Hz0[i], dim(obs.Hz.list[[i]])[1])
    obs.Hz.list[[i]]$sd_cent_station <- rep(sd_cent_station[i], dim(obs.Hz.list[[i]])[1])
    obs.Hz.list[[i]]$sd_cent_target <- rep(sd_cent_target[i], dim(obs.Hz.list[[i]])[1])
    obs.Hz.list[[i]]$sd_Hz <- rep(sd_Hz[i], dim(obs.Hz.list[[i]])[1])
    obs.Hz.list[[i]]$seed <- rep(seed[i], dim(obs.Hz.list[[i]])[1])
  }

  meas.Hz.list <- as.list(rep(NA, length(obs.Hz.list)))
  if(!is.null(seed)){
    for(i in 1:length(obs.Hz.list)){
      meas.Hz.list[[i]] <- t(apply(obs.Hz.list[[i]], 1, function(x) sim_Hz(st_coords = as.numeric(x[c(3:4)]), target_coords = as.numeric(x[c(5:6)]), Hz0 = as.numeric(x[7]), sd_cent = as.numeric(x[8]), sd_cent_target = as.numeric(x[9]), sd_Hz = as.numeric(x[10]), type = "dms", seed = as.numeric(x[11]), axes = c("Northing", "Easting"))))
    }
  }else{
    for(i in 1:length(obs.Hz.list)){
      meas.Hz.list[[i]] <- t(apply(obs.Hz.list[[i]], 1, function(x) sim_Hz(st_coords = as.numeric(x[c(3:4)]), target_coords = as.numeric(x[c(5:6)]), Hz0 = as.numeric(x[7]), sd_cent = as.numeric(x[8]), sd_cent_target = as.numeric(x[9]), sd_Hz = as.numeric(x[10]), type = "dms", axes = c("Northing", "Easting"))))
    }
  }

  if(red){
    meas.Hz.list <-  do.call(rbind, meas.Hz.list) %>% as.data.frame() %>% mutate(dec = deg + min/60 + sec/3600) %>% select(dec)
    Hz_meas <- cbind(do.call(rbind, obs.Hz.list), meas.Hz.list) %>% group_by(station) %>% mutate(dec.red = dec - dec[1])
    Hz_meas$dec.red[which(Hz_meas$dec.red < 0)] <- Hz_meas$dec.red[which(Hz_meas$dec.red < 0)] + 360
    Hz_meas <- Hz_meas %>% mutate(deg = floor(dec.red), minut = floor((dec.red-deg)*60), sec = ((dec.red-deg)*60-minut)*60) %>% select(station, obs.point, deg, minut, sec)

  }else{
    Hz_meas <- cbind(do.call(rbind, obs.Hz.list), do.call(rbind, meas.Hz.list)) %>% select(station, obs.point, deg, min, sec)
  }

  return(Hz_meas)
}

# obs_Hz <- filter(obs_plan, type == "p") %>% select(1,2)

# sim_Hz_all(obs_Hz = obs_Hz, points = points, Hz0 = NA, red = TRUE, sd_cent_station = 2, sd_cent_target = 3, sd_Hz = 10, seed = NULL)

# obs_d <- filter(obs_plan, type == "d") %>% select(1,2)
#sd_cent_station = c(1, 1, 1, 1); sd_cent_target = c(3, 3, 3, 3); sd_dist = c(3, 3, 3, 3); seed = c(111, 222, 333, 444)

sim_dist_all <- function(obs_d, points, sd_cent_station = c(1, 1, 1, 1), sd_cent_target = c(1, 1, 1, 1), sd_dist = c(3, 3, 3, 3), seed = c(111, 222, 333, 444)){

      if(length(sd_cent_station) == 1) sd_cent_station <- rep(sd_cent_station, length(unique(obs_d$station)))
      if(length(sd_cent_station) != length(unique(obs_d$station))) stop("sd_cent_station must be of length either 1 or the number of stations")

      if(length(sd_cent_target) == 1) sd_cent_target <- rep(sd_cent_target, length(unique(obs_d$station)))
      if(length(sd_cent_target) != length(unique(obs_d$station))) stop("sd_cent_target must be of length either 1 or the number of stations")

      if(length(sd_dist) == 1) sd_dist <- rep(sd_dist, length(unique(obs_d$station)))
      if(length(sd_dist) != length(unique(obs_d$station))) stop("sd_dist must be of length either 1 or the number of stations")

      if(!is.null(seed)){
        if(length(seed) == 1) seed <- rep(seed, length(unique(obs_d$station)))
        if(length(seed) != length(unique(obs_d$station))) stop("seed must be of length either 1 or the number of stations")
      }else{
        seed <- sample(1:1000, size = length(unique(obs_d$station))) # rep(NULL, length(unique(obs_d$station)))
      }

      obs_d <- mutate(obs_d, x_station = rep(NA, dim(obs_d)[1]), y_station = rep(NA, dim(obs_d)[1]), x_target = rep(NA, dim(obs_d)[1]), y_target = rep(NA, dim(obs_d)[1]))
      for(i in 1:dim(obs_d)[1]){
        obs_d[i , c("x_station", "y_station")] <- points[which(obs_d$station[i] == points$Name), 2:3]
        obs_d[i , c("x_target", "y_target")] <- points[which(obs_d$obs.point[i] == points$Name), 2:3]
      }

      obs.d.list <- split(obs_d, obs_d$station)
      for(i in 1:length(obs.d.list)){
        obs.d.list[[i]]$sd_cent_station <- rep(sd_cent_station[i], dim(obs.d.list[[i]])[1])
        obs.d.list[[i]]$sd_cent_target <- rep(sd_cent_target[i], dim(obs.d.list[[i]])[1])
        obs.d.list[[i]]$sd_dist <- rep(sd_dist[i], dim(obs.d.list[[i]])[1])
        obs.d.list[[i]]$seed <- rep(seed[i], dim(obs.d.list[[i]])[1])
      }

      meas.d.list <- as.list(rep(NA, length(obs.d.list)))
      if(!is.null(seed)){
        for(i in 1:length(obs.d.list)){
          meas.d.list[[i]] <- data.frame(dist = (apply(obs.d.list[[i]], 1, function(x) sim_dist(st_coords = as.numeric(x[c(3:4)]), target_coords = as.numeric(x[c(5:6)]), sd_cent = as.numeric(x[7]), sd_cent_target = as.numeric(x[8]), sd_dist = as.numeric(x[9]), seed = as.numeric(x[10]), axes = c("Northing", "Easting")))))
        }
      }else{
        for(i in 1:length(obs.d.list)){
          meas.d.list[[i]] <- data.frame(dist = (apply(obs.d.list[[i]], 1, function(x) sim_dist(st_coords = as.numeric(x[c(3:4)]), target_coords = as.numeric(x[c(5:6)]), sd_cent = as.numeric(x[7]), sd_cent_target = as.numeric(x[8]), sd_dist = as.numeric(x[9]), axes = c("Northing", "Easting")))))
        }
      }

      d_meas <- cbind(do.call(rbind, obs.d.list), do.call(rbind, meas.d.list)) %>% select(station, obs.point, dist)

      return(d_meas)
  }

# sim_dist_all(obs_d = obs_d, points = points, sd_cent_station = 2, sd_cent_target = 2, sd_dist = 3, seed = NULL)

########### ISPIT 14.6.2019. ######################################################

points <- rbind(A, B, C, D, O1, O2, O5) %>% as.data.frame() %>% rownames_to_column("Name") %>% rename(x = V1, y = V2)
obs_plan <- data.frame(station = rep(c("A", "A", "A", "B", "B", "B", "C", "C", "C", "D", "D", "D"), 2), obs.point = rep(c("B", "O1", "O5", "A", "O1", "O5", "D", "O2", "O5", "C", "O5", "O2"), 2), type = c(rep("p", 12), rep("d", 12)) )
obs_plan <- obs_plan[-which(obs_plan$obs.point %in% c("A", "B", "C", "D") & obs_plan$type == "d"), ]

obs1_d <- filter(obs_plan, type == "d") %>% select(1,2)
sim_dist_1 <- sim_dist_all(obs_d = obs1_d, points = points, sd_cent_station = 2, sd_cent_target = 2, sd_dist = 3, seed = NULL)

obs1_Hz <- filter(obs_plan, type == "p") %>% select(1,2)
sim_Hz_1 <- sim_Hz_all(obs_Hz = obs1_Hz, points = points, Hz0 = NA, red = TRUE, sd_cent_station = 2, sd_cent_target = 3, sd_Hz = 10, seed = NULL)

sim_obs1 <- dplyr::full_join(sim_Hz_1, sim_dist_1) %>% mutate(sd_Hz = 5, sd_dist = 3, SD = NA, VzD = NA, VzM = NA, VzS = NA, sd_Vz = NA) %>% dplyr::select(from = station, to = obs.point, HzD = deg, HzM = minut, HzS = sec, HD = dist, SD, VzD, VzM, VzS, sd_Hz, sd_dist, sd_Vz)
points1 <- points %>% dplyr::mutate(id = row_number(), FIX_X = FALSE, FIX_Y = FALSE, Point_object = FALSE) %>% dplyr::select(id, Name, x, y, FIX_X, FIX_Y, Point_object)

obs1_list <- list(Points = points1, Observations = sim_obs1)
writexl::write_xlsx(obs1_list, path = "zadatak_1462019.xlsx")

########### ZADATAK 1 ######################################################

points <- rbind(A, B, C, D, O1, O2, O3, O4) %>% as.data.frame() %>% rownames_to_column("Name") %>% rename(x = V1, y = V2)

obs_plan1 <- data.frame(station = rep(c("A", "A", "A", "B", "B", "C", "C", "C", "D", "D"), 2), obs.point = rep(c("B", "O1", "O3", "A", "O1", "D", "O2","O3", "A", "O2"), 2), type = c(rep("p", 10), rep("d", 10)) )
obs_plan2 <- data.frame(station = rep(c("A", "A", "A", "B", "B", "C", "C", "D", "D", "D"), 2), obs.point = rep(c("B", "O1", "O4", "A", "O1", "D", "O2", "A", "O2", "O4"), 2), type = c(rep("p", 10), rep("d", 10)) )

obs_plan1 <- obs_plan1[-which(obs_plan1$obs.point %in% c("A", "B", "C", "D") & obs_plan1$type == "d"), ]

obs1_d <- filter(obs_plan1, type == "d") %>% select(1,2)
sim_dist_1 <- sim_dist_all(obs_d = obs1_d, points = points, sd_cent_station = 2, sd_cent_target = 2, sd_dist = 3, seed = NULL)

obs1_Hz <- filter(obs_plan1, type == "p") %>% select(1,2)
sim_Hz_1 <- sim_Hz_all(obs_Hz = obs1_Hz, points = points, Hz0 = NA, red = TRUE, sd_cent_station = 2, sd_cent_target = 3, sd_Hz = 10, seed = NULL)

sim_obs1 <- dplyr::full_join(sim_Hz_1, sim_dist_1) %>% mutate(sd_Hz = 10, sd_dist = 3, SD = NA, VzD = NA, VzM = NA, VzS = NA, sd_Vz = NA) %>% dplyr::select(from = station, to = obs.point, HzD = deg, HzM = minut, HzS = sec, HD = dist, SD, VzD, VzM, VzS, sd_Hz, sd_dist, sd_Vz)
points1 <- points %>% dplyr::mutate(id = row_number(), FIX_X = FALSE, FIX_Y = FALSE, Point_object = FALSE) %>% dplyr::select(id, Name, x, y, FIX_X, FIX_Y, Point_object)

obs1_list <- list(Points = points1, Observations = sim_obs1)
writexl::write_xlsx(obs1_list, path = "obs11_list.xlsx")

obs_d <- filter(obs_plan2, type == "d") %>% select(1,2)
sim_dist_all(obs_d = obs_d, points = points, sd_cent_station = 2, sd_cent_target = 2, sd_dist = 3, seed = NULL)

obs_Hz <- filter(obs_plan2, type == "p") %>% select(1,2)
sim_Hz_all(obs_Hz = obs_Hz, points = points, Hz0 = NA, red = FALSE, sd_cent_station = 2, sd_cent_target = 3, sd_Hz = 10, seed = NULL)

write.table(sim_d, "sim_d.txt", sep = " ")

getwd()

################### 1D simulacija #######################################################

options(digits = 4)

points <- read_xlsx(here("data/1D_simulation.xlsx"))
observations <- read_xlsx(here("data/1D_simulation.xlsx"), sheet = 2, col_types = c("text", "text", "numeric", "numeric"))

observations$H_from <- points$H[match(observations$from, points$Name)]
observations$H_to <- points$H[match(observations$to, points$Name)]

#observations <- observations %>% mutate(dH = H_to - H_from, obs = paste(from, to, sep = "_"), a = runif(stations))

obs <- observations %>% dplyr::mutate(dH = H_to - H_from,
                                      rand = purrr::pmap(., function(stations, ...){runif(stations, max = 0.2)})) %>%
                 dplyr::mutate(dh_obs = purrr::pmap(., function(rand, dH, ...){rand/sum(rand)*dH})) %>%
                 dplyr::select(from, to, dh_obs) %>%
                 tidyr::unnest() %>%
                 dplyr::mutate(l11 = runif(n(), min = 0.8, max = 1.6),
                               l21 = l11 - dh_obs,
                               l12 = l11 + runif(n(), min = 0.1, max = 0.3),
                               l22 = l12 - dh_obs,
                               d1 = runif(n(), min = 5, max = 20),
                               d2 = d1 + runif(n(), min = 1, max = 5)) %>%
                 dplyr::mutate_at(.vars = c("l11","l12", "l21", "l22"), .funs = function(x) {x + rnorm(1, mean = 0, sd = 0.0002/sqrt(2))}) %>%
                 dplyr::mutate_at(.vars = c("l11","l12", "l21", "l22"), .funs = function(x) {round(x, 4)}) %>%
                 dplyr::group_by(from, to) %>% dplyr::mutate(n = 1:n()) %>% dplyr::ungroup() %>%
                 dplyr::select(from, to , n, l11, l12, l21, l22)

write_xlsx(obs, "obs3.xlsx")

                 lapply(obs.list, function(x), )

                 options(digits = 6)

                 n = 5
                 DH = 2
                 a = runif(n, max = 0.1)
                 out = (a/sum(a)*DH)
                 sum(out)

dhh <- 0.192

ll <- function(dh, )

ll <- runif(2, min = 1.5, max = 2)

l1 <- ll[1] + 0.192/2
l2 <- ll[2] - 0.192/2

l2 - l1


#' extremes
#'
#' Min/max values for any combination of float/numeric vector(s)/matri[x|ces].
#'
#' @details
#' If there are any elements in \code{...}, all elements in the list will first
#' be summed in their native precision, then converted to double precision so
#' they can be combined with \code{base::sum()}.  The final result will be cast
#' to single precision if \code{...} contains only integer and/or float objects.
#' Otherwise, the return will be double precision.
#'
#' @param x
#' A float matrix.
#' @param ...
#' Additional elements (numeric/float vectors/matrices) to sum.
#' @param na.rm
#' should NA's be removed?
#'
#' @return
#' A single value.
#'
#' @examples
#' library(float)
#' x = flrunif(10, 3)
#'
#' min(x)
#' min(x, 1)
#'
#' @useDynLib float R_min_spm R_max_spm R_whichmin_spm R_whichmax_spm
#' @name extremes
#' @rdname extremes
NULL

min_float32_ = function(x, na.rm)
{
  ret = .Call(R_min_spm, DATA(x), na.rm)
  float32(ret)
}

max_float32_ = function(x, na.rm)
{
  ret = .Call(R_max_spm, DATA(x), na.rm)
  float32(ret)
}

extremer = function(x, na.rm, dFUN, sFUN)
{
  if (is.float(x))
    dbl(sFUN(x, na.rm=na.rm))
  else
    dFUN(x, na.rm=na.rm)
}

extreme = function(x, ..., na.rm=FALSE, dFUN, sFUN)
{
  additional = list(...)
  first = sFUN(x, na.rm=na.rm)

  if (length(additional) > 0)
  {
    additional = dFUN(sapply(additional, extremer, na.rm=na.rm, dFUN=dFUN, sFUN=sFUN))
    if (any(sapply(additional, is.double)))
      dFUN(dbl(first),  additional)
    else
    {
      additional = fl(additional)
      sFUN(c(first, additional), na.rm=na.rm)
    }
  }
  else
    first
}

min_float32 = function(x, ..., na.rm=FALSE)
{
  extreme(x, ..., na.rm=na.rm, dFUN=base::min, sFUN=min_float32_)
}

max_float32 = function(x, ..., na.rm=FALSE)
{
  extreme(x, ..., na.rm=na.rm, dFUN=base::max, sFUN=max_float32_)
}

whichmin_float32 = function(x)
{
  .Call(R_whichmin_spm, DATA(x))
}

whichmax_float32 = function(x)
{
  .Call(R_whichmax_spm, DATA(x))
}

#' @rdname extremes
#' @export
setMethod("min", signature(x="float32"), min_float32)

#' @rdname extremes
#' @export
setMethod("max", signature(x="float32"), max_float32)

#' @rdname extremes
#' @export
setMethod("which.min", signature(x="float32"), whichmin_float32)

#' @rdname extremes
#' @export
setMethod("which.max", signature(x="float32"), whichmax_float32)


library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(dplyr)
library(tidyr)
library(EnvStats)
library(scales)
library(stringr)
library(abind)

process_covariates <- function(countries, interventions, d, ifr.by.country,N2){
  serial.interval = read.csv("data/serial_interval.csv")
  # Pads serial interval with 0 if N2 is greater than the length of the serial
  # interval array
  if (N2 > length(serial.interval$fit)) {
    pad_serial.interval <- data.frame(
      "X"=(length(serial.interval$fit)+1):N2,
      "fit"=rep(1e-17, max(N2-length(serial.interval$fit), 0 ))
    )
    serial.interval = rbind(serial.interval, pad_serial.interval)
  }
  # various distributions required for modeling
  mean1 <- 5.1; cv1 <- 0.86; # infection to onset
  mean2 <- 17.8; cv2 <- 0.45 # onset to death
  x1 <- rgammaAlt(1e6,mean1,cv1) # infection-to-onset distribution
  x2 <- rgammaAlt(1e6,mean2,cv2) # onset-to-death distribution

  ecdf.saved <- ecdf(x1+x2)
  forecast <- 0
  dates <- list()
  reported_cases <- list()
  stan_data <- list(M=length(countries$Regions),N=NULL,deaths=NULL,f=NULL,
                   N0=6,cases=NULL,SI=serial.interval$fit[1:N2],features=NULL,
                   EpidemicStart = NULL, pop = NULL)
  deaths_by_country <- list()
  covariate_list <- list()
  k=1
  # going over each region
  for (Country in countries$Regions){
    IFR <- ifr.by.country$ifr[ifr.by.country$country == Country]
    region_pop <- ifr.by.country[ifr.by.country$country==Country,]
    region <- d[d$Country==Country,]
    region$DateRep <-region$DateRep
    region <-region[order(as.Date(region$DateRep)),]  # ensure date ordering

    # padding in raw data backwards ex. portugal
    date_min <- dmy('31/12/2019')
    if (region$DateRep[1] > date_min){
      print(paste(Country,'In padding ECDC data'))
      pad_days <-region$DateRep[1] - date_min
      pad_dates <- date_min + days(1:pad_days[[1]]-1)
      padded_data <- data.frame("Country" = rep(Country, pad_days),
                                "DateRep" = pad_dates,
                                "Cases" = as.integer(rep(0, pad_days)),
                                "Deaths" = as.integer(rep(0, pad_days)),
                                stringsAsFactors=F)

     region <- bind_rows(padded_data,region)
    }
    index = which(region$Cases>0)[1]
    index1 = which(cumsum(region$Deaths)>=10)[1] # also 5
    index2 = index1-30

    print(sprintf("First non-zero cases is on day %d, and 30 days before 10 deaths is day %d",index,index2))
    region=region[index2:nrow(region),]
    stan_data$EpidemicStart = c(stan_data$EpidemicStart,index1+1-index2)
    stan_data$pop = c(stan_data$pop,region_pop$popt)
    # NPI interventionss are being used
    interventions_region <- interventions[interventions$Country == Country, c(2,3,4,5,6)] # school, self-isolation, public, lockdown, social-distancing
    for (ii in 1:ncol(interventions_region)) {
      covariate = names(interventions_region)[ii]
      region[covariate] <- (region$DateRep >= interventions_region[1,covariate])*1  # should this be > or >=?
    }

    dates[[Country]] =region$DateRep
    # hazard estimation
    N = length(region$Cases)
    print(sprintf("%s has %d days of data",Country,N))
    forecast = N2 - N
    if(forecast < 0) {
      print(sprintf("%s: %d", Country, N))
      print("ERROR!!!! increasing N2")
      N2 = N
      forecast = N2 - N
    }

    # IFR is the overall probability of dying given infection
    convolution = function(u) (IFR * ecdf.saved(u))

    f = rep(0,N2) # f is the probability of dying on day i given infection
    f[1] = (convolution(1.5) - convolution(0))
    for(i in 2:N2) {
      f[i] = (convolution(i+.5) - convolution(i-.5))
    }
    reported_cases[[Country]] = as.vector(as.numeric(region$Cases))
    deaths=c(as.vector(as.numeric(region$Deaths)),rep(-1,forecast))
    cases=c(as.vector(as.numeric(region$Cases)),rep(-1,forecast))
    deaths_by_country[[Country]] = as.vector(as.numeric(region$Deaths))
    region_intervention <- as.data.frame(region[, colnames(interventions_region)])
    region_intervention[N:(N+forecast),] <- region_intervention[N,]
    school =region_intervention[,1]
    selfIsolation =region_intervention[,2]
    publicEvents = region_intervention[,3]
    lockdown = region_intervention[,4]
    socialDistancing = region_intervention[,5]
    firstIntervention = 1*((school+ selfIsolation+ publicEvents+ lockdown + socialDistancing) >= 1)
    ## append data
    stan_data$N = c(stan_data$N,N)
    # stan_data$x = cbind(stan_data$x,x)
    stan_data$f = cbind(stan_data$f,f)
    stan_data$deaths = cbind(stan_data$deaths,deaths)
    stan_data$cases = cbind(stan_data$cases,cases)

    stan_data$N2=N2
    stan_data$x=1:N2
    if(length(stan_data$N) == 1) {
      stan_data$N = as.array(stan_data$N)
    }
    df_features = data.frame('school' = school, 'selfIsolation' = selfIsolation, 'publicEvents' = publicEvents,
                             'firstIntervention' = firstIntervention, 'lockdown' = lockdown, 'socialDistancing' = socialDistancing)
    features <- as.matrix(df_features)
    covariate_list[[k]] <- features
    k <- k+1
  }
  stan_data$P = dim(features)[2]
  stan_data$X = array(NA, dim = c(stan_data$M , stan_data$N2 ,stan_data$P ))
  for (i in 1:stan_data$M){
    stan_data$X[i,,] = covariate_list[[i]]
  }
  return(list("stan_data" = stan_data, "dates" = dates, "reported_cases"=reported_cases, "deaths_by_country" = deaths_by_country))
}

process_covariates_age <- function(countries, google_mobility, d, ifr.by.country, ifr.by.age, serial.interval, pop_by_age, contact_tab, seedAge, N2, forecast)
{
  # various distributions required for modeling
  set.seed(5678) # make reproducible
  mean1 <- 5.1; cv1 <- 0.86; # infection to onset
  mean2 <- 18.8; cv2 <- 0.45 # onset to death
  x1 <- rgammaAlt(1e6,mean1,cv1) # infection-to-onset distribution
  x2 <- rgammaAlt(1e6,mean2,cv2) # onset-to-death distribution
  ecdf_death <- ecdf(x1+x2)

  #	disrectise to days since infection
  ifr_by_dsi <- vector('numeric',N2)
  ifr_by_dsi[1] <- ecdf_death(1.5) - ecdf_death(0)
  for(s in 2:N2)
  {
    ifr_by_dsi[s] <- ecdf_death(s+.5) - ecdf_death(s-.5)
  }

  # serial intervention cut
  serial.interval.cut <- length( which(serial.interval$fit * 5e6 >= 1 ) )

  # contact bands
  cntct_bands <- nrow(contact_tab[[1]][[1]])

  # going over each region
  dates <- list()
  reported_cases <- list()
  deaths_by_country <- list()
  stan_data <- list(
    #	constants
    M = length(countries), 									# int<lower=1> M		number of countries
    N0 = 6L, 												# int<lower=1> N0		N0 = 6 to make it consistent with Rayleigh
    N = vector('integer',length(countries)),				# int<lower=1> N[M]		days of observed data for country m. each entry must be <= N2
    N2 = as.integer(N2), 									# int<lower=1> N2		days of observed data + # of days to forecast
    A = as.integer(cntct_bands), 							# int<lower=1> A		number of age bands
    SI_CUT = serial.interval.cut, 							# int<lower=1> SI_CUT	number of days in serial interval to consider
    P_RES = 1L,												#int<lower=1> P_RES; 	number of predictors for residential contacts
    P_NONRES = 4L,											# int<lower=1> P_NONRES number of predictors for non-residential contacts
    WKEND_IDX_N= vector('integer',length(countries)),		# int WKEND_IDX_N[M];	number of weekend indices in each location
    #	data
    pop = vector('numeric',length(countries)),				# real pop[M];									population counts
    popByAge = matrix(NA_integer_, as.integer(cntct_bands), length(countries)),		# matrix<lower=0, upper=1>[A,M] popByAge	proportion of age bracket in population in location
    epidemicStart = vector('integer',length(countries)), 	# int epidemicStart[M];
    deaths = matrix(NA_integer_, N2, length(countries)), 	# int deaths[N2, M];	 						reported deaths
    wkend_idx = matrix(NA_integer_, N2, length(countries)),	# int<lower=1> wkend_idx[N2,M]; 				indices of 1:N2 that correspond to weekends in location m
    covariates_nonres = vector('list', length(countries)),	# matrix[N2,P_NONRES]  covariates_nonres[M]		predictors for non-residential contacts
    covariates_res = vector('list', length(countries)),		# matrix[N2,P_RES] covariates_res[M]			predictors for residential contacts
    #	priors
    cntct_weekdays_mean = vector('list', length(countries)), 								# matrix[A,A] cntct_mean[M]						mean of prior contact rates between age groups
    cntct_weekends_mean = vector('list', length(countries)),
    ifr_country_scale = vector('numeric', length(countries)),						# real<lower=0> ifr_country_scale[M]; 			relative probability of death for location, s days after infection, for age band a
    ifr_age = matrix(data=ifr.by.age$ifr_mean, ncol=cntct_bands, nrow=N2, byrow=TRUE), 	# matrix<lower=0>[N2,A] ifr_age; 				probability of death for age band a, stored N2 times
    hyperpara_ifr_age = ifr.by.age[, c("alpha", "beta")],
    rev_ifr_daysSinceInfection = rev( ifr_by_dsi ), 									# row_vector[N2] rev_ifr_daysSinceInfection;	probability of death s days after infection in reverse order
    rev_serial_interval = rev( serial.interval$fit[1:serial.interval.cut] ), 			# row_vector[SI_CUT] rev_serial_interval;		fixed pre-calculated serial interval using empirical data from Neil in reverse order
    init_A = ifelse(cntct_bands==101, 30L, ifelse(cntct_bands==20, as.numeric(seedAge), NA_integer_))	# int<lower=1, upper=A> init_A					age band in which initial cases occur in the first N0 days
  )

  cat('\nProcessing country data... \n')
  for(m in seq_along(countries))
  {
    #m <- 1
    Country <- countries[m]

    #	create padded data of cases and deaths
    # start counting 30 days prior to reaching 10 deaths
    d1 <- d[d$Country==Country,]
    d1$date <- as.Date(d1$DateRep,format='%Y-%m-%d')
    d1$t <- decimal_date(d1$date)
    d1 <- d1[order(d1$t),]
    date_min <- dmy('31/12/2019')
    if (as.Date(d1$DateRep[1], format='%Y-%m-%d') > as.Date(date_min, format='%Y-%m-%d')){
      print(paste(Country,'In padding'))
      pad_days <- as.Date(d1$DateRep[1], format='%Y-%m-%d') - date_min
      pad_dates <- date_min + days(1:pad_days[[1]]-1)
      padded_data <- data.frame("Country" = rep(Country, pad_days),
                                "DateRep" = format(pad_dates, '%Y-%m-%d'),
                                "t" = decimal_date(as.Date(pad_dates,format='%Y-%m-%d')),
                                "date" = as.Date(pad_dates,format='%Y-%m-%d'),
                                "Cases" = as.integer(rep(0, pad_days)),
                                "Deaths" = as.integer(rep(0, pad_days)),
                                stringsAsFactors=F)
      padded_data$DateRep = as.Date(padded_data$DateRep, format='%Y-%m-%d')
      d1 <- bind_rows(padded_data, d1)
    }
    index <- which(d1$Cases>0)[1]
    index1 <- which(cumsum(d1$Deaths)>=10)[1] # also 5
    index2 <- index1-30L
    print(sprintf("First non-zero cases is on day %d, and 30 days before 10 deaths is day %d",index,index2))
    d1 <- d1[index2:nrow(d1),]

    #	add data on mobility indices
    google_mobility$date = as.Date(google_mobility$date,format='%Y-%m-%d')
    google_mobility$ISO_name = as.character(google_mobility$ISO_name)
    tmp <- google_mobility %>%
      select(-c(ISO_code,county)) %>%
      rename(Country:=ISO_name)
    d1 <- d1 %>%
      group_by(Country,date) %>%
      left_join(tmp) %>%
      ungroup()
    for(x in c("grocery.pharmacy", "parks", "residential", "retail.recreation","transitstations","workplace"))
    {
      d1[[x]]
      z <- which(is.na(d1[[x]]))
      z2 <- which(diff(z)!=1)
      if(!length(z2))
        z2 <- length(z)
      d1[[x]][1:z2] <- 0
      z <- which(is.na(d1[[x]]))
      if(length(z))
        d1[[x]][z] <- d1[[x]][z[1]-1]
    }

    #	determine the index of weekend dates
    wkend_idx <- which(as.integer(format(d1$date, "%u"))>5)

    # store dates for data from this country
    dates[[Country]] <- d1$date

    # hazard estimation
    N <- nrow(d1)
    print(sprintf("%s has %d days of data",Country,N))
    forecast <- N2 - N
    if(forecast < 0) {
      print(sprintf("%s: %d", Country, N))
      print("ERROR!!!! increasing N2")
      N2 <- N
      forecast <- N2 - N
    }

    #	calculate probability of deaths in age a after s days of infection for this country
    # to obtain ifr.by.age.country, I scale here ifr.by.age with the ratio ifr.by.country/ifr.china
    # where ifr.china is 0.657% as in Verity 2020
    # TODO this will likely need to be revised
    ifr_china <- 0.00657
    ifr_country_scale <- ifr.by.country$ifr[ifr.by.country$country == Country] / ifr_china

    reported_cases[[Country]] <- as.vector(as.numeric(d1$Cases))
    deaths <- c(as.vector(as.numeric(d1$Deaths)),rep(-1,forecast))
    cases <- c(as.vector(as.numeric(d1$Cases)),rep(-1,forecast))
    deaths_by_country[[Country]] <- as.vector(as.numeric(d1$Deaths))
    covariates <- d1 %>% select(-c(DateRep, Cases, Deaths, Country, date, t))
    covariates[N:(N+forecast),] <- covariates[N,]

    #	add constants
    stan_data$N[m] <- N
    stan_data$WKEND_IDX_N[m] <- length(wkend_idx)
    stan_data$wkend_idx[,m] <- c(wkend_idx, rep(0,N2-length(wkend_idx)))

    # add data
    stan_data$pop[m] <- ifr.by.country$popt[ifr.by.country$country==Country]
    stan_data$popByAge[,m] <- pop_by_age[,Country]
    stan_data$epidemicStart[m] <- index1+1L-index2	#TODO confirm, this is always 31?
    stan_data$deaths[,m] <- deaths
    stan_data$covariates_res[[m]] <- as.matrix( covariates %>% select(residential) )
    stan_data$covariates_nonres[[m]] <- as.matrix( covariates %>% select(parks, retail.recreation, transitstations, workplace) )

    # add priors
    stan_data$cntct_weekends_mean[[m]] <- as.matrix(contact_tab[["United_Kingdom"]][["weekend"]])
    stan_data$cntct_weekdays_mean[[m]] <- as.matrix(contact_tab[["United_Kingdom"]][["weekday"]])

    stan_data$ifr_country_scale[m] <- ifr_country_scale

    if(length(stan_data$N) == 1)
    {
      stan_data$N <- as.array(stan_data$N)
    }
  }

  # transform in array single vector
  if(stan_data$M == 1){
    stan_data$pop = as.array(stan_data$pop)
    stan_data$epidemicStart = as.array(stan_data$epidemicStart)
    stan_data$ifr_country_scale = as.array(stan_data$ifr_country_scale)
  }

  return(list("stan_data" = stan_data, "dates" = dates, "reported_cases"=reported_cases, "deaths_by_country" = deaths_by_country))
}


#==============================================================================
#	Test for cforest
#==============================================================================

source("tests.r")

test.data <- list(
	call = list(
		substitute(
			cforest(
				Sepal.Length ~ ., data = iris,
				controls = cforest_control(ntree = 10, mtry = 3)
			)
		),
		substitute(
			cforest(
				Species ~ ., data = iris,
				controls = cforest_control(ntree = 10, mtry = 3)
			)
		)
	),
	formula = list(
		Sepal.Length ~ Sepal.Width + Petal.Length + Petal.Width + Species,
		Species ~ Sepal.Length + Sepal.Width + Petal.Length + Petal.Width
	),
	model.type = list("regression", "classification")
)

test.model.adapter("cforest", iris, test.data, object.has.call = FALSE)

rm(test.data)


#' @importFrom crayon yellow
make_model_matrix <- function(form, x) {
  ret <- model.matrix(form, x)
  ts <- terms(form, data = x)
  if (attributes(ts)$intercept == 0) {
    stop(yellow("No intercept specified. This should be done using the",
                "use_bias parameter."))
  } else {
    ret <- ret[,-1]
  }
  ret
}

create_input_and_hidden_layers <-
  function(x_train, hidden_layers, hidden_layers_activation,
           hidden_layer_names,
           use_bias,
           model_name) {

  model <- keras_model_sequential(name = model_name)

  for (i in seq_along(hidden_layers)) {
    if (i == 1) {
      model %>% layer_dense(input_shape = ncol(x_train),
                            units = hidden_layers[i],
                            activation = hidden_layers_activation[i],
                            name = paste("hidden_layer", i, sep = "_"),
                            use_bias = use_bias[i],
                            trainable = TRUE,
                            kernel_initializer = "random_normal")
    } else {
      model %>% layer_dense(units = hidden_layers[i],
                            activation = hidden_layers_activation[i],
                            name = paste("hidden_layer", i, sep = "_"),
                            use_bias = use_bias[i],
                            trainable = TRUE,
                            kernel_initializer = "random_normal")
    }
  }
  model
}


#' Plot WoE patterns for variables
#'
#' Plots calculated WoE for every variable
#'
#' @param iv WoE data for variables - output from iv.mult with summary=FALSE (false is default for iv.mult)
#' @export
#' @examples
#' iv.plot.woe(iv.mult(german_data,"gb"))
#' iv.plot.woe(iv.mult(german_data,"gb",vars=c("ca_status","housing","age","duration"),summary=FALSE))

iv.plot.woe <- function(iv) {
  x <- rbind.fill(iv)
  woe <- NULL
  ggplot(data=x) + geom_bar(aes(y=woe,x=class),stat="identity",position="identity") +
    facet_wrap(facets=~variable, scales="free_x")  +
    theme(
      panel.grid.major.x = element_blank(),
      panel.grid.major.y = element_line(linetype="dashed",colour="grey"),
      panel.grid.minor = element_blank(),
      panel.background = element_blank(),
      axis.ticks.x = element_blank(),
      axis.ticks.y = element_blank(),
      axis.text.x = element_text(angle = 45, hjust = 1)
    ) +
    xlab("Variable") +
    ylab("WoE") +
    ggtitle("Weight of Evidence (WoE) Patterns")
}


# Simulation Tutorial in R for Engineers and Geoscientists
# Michael Pyrcz, University of Texas at Austin, Twitter @GeostatsGuy

# This will be used in my Introduction to Geostatistics undergraduate class
# It is assumed that students have no previous R experience.
# This utilizes the gstat library by Edzer Pedesma, appreciation to Dr. Pedesma for assistance.

# Load the required libraries, you may have to first go to "Tools/Install Packages..." to install these first
library(gstat)                                 # geostatistical methods by Edzer Pebesma
library(sp)                                    # spatial points addition to regular data frames
library(plyr)                                  # splitting, applying and combining data by Hadley Wickham
library(fields)                                # required for the image plots

# Specify the grid parameters (same as GSLIB / GEO-DAS parameterization in 2D)
nx = 100
ny = 100
xmn = 5.0
ymn = 5.0
xsize = 40.0
ysize = 40.0
xmin = xmn - xsize*0.5
ymin = ymn - ysize*0.5
xmax = xmin + nx * xsize
ymax = ymin + ny * ysize
x<-seq(xmin,xmax,by=xsize)                     # used for axes on image plots
y<-seq(ymin,ymax,by=ysize)

# Specify the parameters For plotting
colmap = topo.colors(100)                      # define the color map and descritation

# Declare functions

# This function completes standard normal transform on a data vector

nscore <- function(x) {                        # written by Ashton Shortridge, May/June, 2008
  # Takes a vector of values x and calculates their normal scores. Returns
  # a list with the scores and an ordered table of original values and
  # scores, which is useful as a back-transform table. See backtr().
  nscore <- qqnorm(x, plot.it = FALSE)$x  # normal score
  trn.table <- data.frame(x=sort(x),nscore=sort(nscore))
  return (list(nscore=nscore, trn.table=trn.table))
}

# This function builds a spatial points dataframe with the locations for estimation / simulation

addcoord <- function(nx,xmin,xsize,ny,ymin,ysize) { # Michael Pyrcz, March, 2018
  # makes a 2D dataframe with coordinates based on GSLIB specification
  coords = matrix(nrow = nx*ny,ncol=2)
  ixy = 1
  for(iy in 1:nx) {
    for(ix in 1:ny) {
      coords[ixy,1] = xmin + (ix-1)*xsize
      coords[ixy,2] = ymin + (iy-1)*ysize
      ixy = ixy + 1
    }
  }
  coords.df = data.frame(coords)
  colnames(coords.df) <- c("X","Y")
  coordinates(coords.df) =~X+Y
  return (coords.df)
}

sim2darray <- function(spdataframe,nx,ny,ireal) { # Michael Pyrcz, March, 2018
  # makes a 2D array from realizations spatial point dataframe
  model = matrix(nrow = nx,ncol = ny)
  ixy = 1
  for(iy in 1:ny) {
    for(ix in 1:nx) {
      model[ix,iy] = spdataframe@data[ixy,ireal]
      ixy = ixy + 1
    }
  }
  return (model)
}

sim2vector <- function(spdataframe,nx,ny,ireal) { # Michael Pyrcz, March, 2018
  # makes a 1D vector from spatial point dataframe
  model = rep(0,nx*ny)
  ixy = 1
  for(iy in 1:ny) {
    for(ix in 1:nx) {
      model[ixy] = spdataframe@data[ixy,ireal]
      ixy = ixy + 1
    }
  }
  return (model)
}

# Set the working directory, I always like to do this so I don't lose files and to simplify subsequent read and writes
setwd("C:/PGE337")

# Read the data table from a comma delimited file - data on GitHub/GeostatsGuy/GeoDataSets
mydata = read.csv("2D_MV_200Wells.csv")        # read in comma delimited data file

# Let's visualize the first several rows of our data so we can make sure we successfully loaded it
head(mydata)                                   # show the first several rows of a data table in the console
# The columns are variables with variable names at the top and the rows are samples

# Convert the dataframe to a spatial points dataframe
class(mydata)                                  # confirms that it is a dataframe
coordinates(mydata) = ~X+Y                     # indicate the X, Y spatial coordinates
summary(mydata)                                # confirms that it is now a spatial points dataframe
head(coordinates(mydata))                      # check the first several coordinates

# Normal scores transform of the porosity data to assist with variogram calculation
npor.trn = nscore(mydata$porosity)                  # normal scores transform
mydata[["NPorosity"]]<-npor.trn$nscore         # append the normal scores transform into the spatial data table
head(mydata)

# Make the model 2D grid
coords <- addcoord(nx,xmin,xsize,ny,ymin,ysize) # make a dataframe with all the estimation locations
summary(coords)                                # check the coordinates

# What is the sill of the raw variable
sill = var(mydata$porosity)
min = min(mydata$porosity)
max = max(mydata$porosity)
zlim = c(min,max)                              # define the property min and max

# Anisotropic variogram
vm1 <- vgm(psill = 0.5*sill, "Sph", 400, anis = c(000, 1.0),nugget=0.5*sill)
vm1
vm2 <- vgm(psill = 1.0*sill, "Exp", 200, anis = c(035, 0.5),nugget=0.0*sill)
vm2
vm3 <- vgm(psill = 1.0*sill, "Sph", 600, anis = c(060, 0.2),nugget=0.0*sill)
vm3

# Gaussian simulation

condsim1 = krige(porosity~1, mydata, coords, model = vm1, nmax = 100, nsim = 4)
condsim2 = krige(porosity~1, mydata, coords, model = vm2, nmax = 100, nsim = 4)
condsim3 = krige(porosity~1, mydata, coords, model = vm3, nmax = 100, nsim = 4)

krige1 = krige(porosity~1, mydata, coords, model = vm1, nmax = 100)
krige2 = krige(porosity~1, mydata, coords, model = vm2, nmax = 100)
krige3 = krige(porosity~1, mydata, coords, model = vm3, nmax = 100)

# nmax is the maximum number of data for each kriging solution
# this may take a long time to run, decrease nmax to spped up (e.g. 100)

# Plot all the realizations
#par(mar=c(1,1,1,1))
par(mfrow=c(2,2))
real1 <- sim2darray(condsim1,nx,ny,1)      # extract realization #1 to a 2D array and plot
#image.plot(real1,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim,col=colmap,legend.shrink = 0.6); mtext(line=1, side=3, "Realization #1", outer=F);box(which="plot")
image.plot(real1,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim);
points(mydata$X,mydata$Y,pch="+",cex=1.0,col="black") # add well locations

real2 <- sim2darray(condsim1,nx,ny,2)      # extract realization #2 to a 2D array and plot
image.plot(real2,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim,col=colmap,legend.shrink = 0.6); mtext(line=1, side=3, "Realization #2", outer=F);box(which="plot")
points(mydata$X,mydata$Y,pch="+",cex=1.0,col="black") # add well locations

real3 <- sim2darray(condsim1,nx,ny,3)      # extract realization #3 to a 2D array and plot
image.plot(real3,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim,col=colmap,legend.shrink = 0.6); mtext(line=1, side=3, "Realization #3", outer=F);box(which="plot")
points(mydata$X,mydata$Y,pch="+",cex=1.0,col="black") # add well locations

est <- sim2darray(krige1,nx,ny,1)      # extract realization #4 to a 2D array and plot
image.plot(est,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim,col=colmap,legend.shrink = 0.6); mtext(line=1, side=3, "Kriging", outer=F);box(which="plot")
points(mydata$X,mydata$Y,pch="+",cex=1.0,col="black") # add well locations

par(mfrow=c(2,2))
real1 <- sim2darray(condsim2,nx,ny,1)      # extract realization #1 to a 2D array and plot
image.plot(real1,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim,col=colmap,legend.shrink = 0.6); mtext(line=1, side=3, "Realization #1", outer=F);box(which="plot")
points(mydata$X,mydata$Y,pch="+",cex=1.0,col="black") # add well locations

real2 <- sim2darray(condsim2,nx,ny,2)      # extract realization #2 to a 2D array and plot
image.plot(real2,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim,col=colmap,legend.shrink = 0.6); mtext(line=1, side=3, "Realization #2", outer=F);box(which="plot")
points(mydata$X,mydata$Y,pch="+",cex=1.0,col="black") # add well locations

real3 <- sim2darray(condsim2,nx,ny,3)      # extract realization #3 to a 2D array and plot
image.plot(real3,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim,col=colmap,legend.shrink = 0.6); mtext(line=1, side=3, "Realization #3", outer=F);box(which="plot")
points(mydata$X,mydata$Y,pch="+",cex=1.0,col="black") # add well locations

est <- sim2darray(krige2,nx,ny,1)      # extract realization #4 to a 2D array and plot
image.plot(est,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim,col=colmap,legend.shrink = 0.6); mtext(line=1, side=3, "Kriging", outer=F);box(which="plot")
points(mydata$X,mydata$Y,pch="+",cex=1.0,col="black") # add well locations

par(mfrow=c(2,2))
real1 <- sim2darray(condsim3,nx,ny,1)      # extract realization #1 to a 2D array and plot
image.plot(real1,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim,col=colmap,legend.shrink = 0.6); mtext(line=1, side=3, "Realization #1", outer=F);box(which="plot")
points(mydata$X,mydata$Y,pch="+",cex=1.0,col="black") # add well locations

real2 <- sim2darray(condsim3,nx,ny,2)      # extract realization #2 to a 2D array and plot
image.plot(real2,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim,col=colmap,legend.shrink = 0.6); mtext(line=1, side=3, "Realization #2", outer=F);box(which="plot")
points(mydata$X,mydata$Y,pch="+",cex=1.0,col="black") # add well locations

real3 <- sim2darray(condsim3,nx,ny,3)      # extract realization #3 to a 2D array and plot
image.plot(real3,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim,col=colmap,legend.shrink = 0.6); mtext(line=1, side=3, "Realization #3", outer=F);box(which="plot")
points(mydata$X,mydata$Y,pch="+",cex=1.0,col="black") # add well locations

est <- sim2darray(krige3,nx,ny,1)      # extract realization #4 to a 2D array and plot
image.plot(est,x=x,y=y,xlab="X(m)",ylab="Y(m)",zlim = zlim,col=colmap,legend.shrink = 0.6); mtext(line=1, side=3, "Kriging", outer=F);box(which="plot")
points(mydata$X,mydata$Y,pch="+",cex=1.0,col="black") # add well locations

par(mfrow=c(3,2))

# Minimum acceptance checks, check the distributions and variagrams of the realization

# Variogram 1
# Plot the CDFs for the 4 realizations and compare to the raw data CDF
plot(ecdf(condsim1@data[,1]),main="Variogram 1",xlab="Gaussian Values",ylab="Cumulative Probability",col="red")
plot(ecdf(condsim1@data[,2]),add=TRUE,col="red")
plot(ecdf(condsim1@data[,3]),add=TRUE,col="red")
plot(ecdf(condsim1@data[,4]),add=TRUE,col="red")
plot(ecdf(mydata$porosity),add=TRUE,col="black")

# Calculate the varograms for the major and minor directions and compare to the variogram model
# We just arbitrarily picked 035, 125 azimuth, model is isotropic so direction shouldn't matter
vg.sim1.035 = variogram(sim1~1,condsim1,cutoff = 1000,width =20,alpha = 35.0,tol.hor=22.5)
vg.sim1.125 = variogram(sim1~1,condsim1,cutoff = 1000,width =20,alpha = 125.0,tol.hor=22.5)
vg.sim2.035 = variogram(sim2~1,condsim1,cutoff = 1000,width =20,alpha = 35.0,tol.hor=22.5)
vg.sim2.125 = variogram(sim2~1,condsim1,cutoff = 1000,width =20,alpha = 125.0,tol.hor=22.5)
vg.sim3.035 = variogram(sim3~1,condsim1,cutoff = 1000,width =20,alpha = 35.0,tol.hor=22.5)
vg.sim3.125 = variogram(sim3~1,condsim1,cutoff = 1000,width =20,alpha = 125.0,tol.hor=22.5)
vg.sim4.035 = variogram(sim4~1,condsim1,cutoff = 1000,width =20,alpha = 35.0,tol.hor=22.5)
vg.sim4.125 = variogram(sim4~1,condsim1,cutoff = 1000,width =20,alpha = 125.0,tol.hor=22.5)

# Plot the vairograms from the realizations and the model variogram.
plot(vg.sim1.035$dist,vg.sim1.035$gamma,pch=19,cex=0.1,main="Variogram 1",xlab="  Lag Distance (m) ",ylab=" Semivariogram ", col="black",xlim=c(0,1000),ylim=c(0,1.2*sill))
points(vg.sim1.125$dist,vg.sim1.125$gamma,pch=19,cex=0.1,col="red")
points(vg.sim2.035$dist,vg.sim2.035$gamma,pch=19,cex=0.1,col="black")
points(vg.sim2.125$dist,vg.sim2.125$gamma,pch=19,cex=0.1,col="red")
points(vg.sim3.035$dist,vg.sim3.035$gamma,pch=19,cex=0.1,col="black")
points(vg.sim3.125$dist,vg.sim3.125$gamma,pch=19,cex=0.1,col="red")
points(vg.sim4.035$dist,vg.sim4.035$gamma,pch=19,cex=0.1,col="black")
points(vg.sim4.125$dist,vg.sim4.125$gamma,pch=19,cex=0.1,col="red")
abline(h = 1.0*sill)
# Include variogram model
unit_vector = c(0,1,0)                         # unit vector for 000 azimuth
vm1.000 <- variogramLine(vm1,maxdist=1000,min=0.0001,n=100,dir=unit_vector,covariance=FALSE) # calculate 035 variogram model
lines(vm1.000$dist,vm1.000$gamma,pch=19,cex=0.1,col="black") # include variogram model
unit_vector = c(1,0,0)                         # unit vector for 090 azimuth
vm1.090 <- variogramLine(vm1,maxdist=1000,min=0.0001,n=100,dir=unit_vector,covariance=FALSE) # calculate 125 variogram model
lines(vm1.090$dist,vm1.090$gamma,col="red")

# Repeat the above checks for the 2 other sets of simulated realizations
# Variogram 2
# Plot the CDFs for the 4 realizations and compare to the raw data CDF
plot(ecdf(condsim2@data[,1]),main="Variogram 2",xlab="Gaussian Values",ylab="Cumulative Probability",col="red")
plot(ecdf(condsim2@data[,2]),add=TRUE,col="red")
plot(ecdf(condsim2@data[,3]),add=TRUE,col="red")
plot(ecdf(condsim2@data[,4]),add=TRUE,col="red")
plot(ecdf(mydata$porosity),add=TRUE,col="black")

vg.sim1.035 = variogram(sim1~1,condsim2,cutoff = 1000,width =20,alpha = 35.0,tol.hor=22.5)
vg.sim1.125 = variogram(sim1~1,condsim2,cutoff = 1000,width =20,alpha = 125.0,tol.hor=22.5)
vg.sim2.035 = variogram(sim2~1,condsim2,cutoff = 1000,width =20,alpha = 35.0,tol.hor=22.5)
vg.sim2.125 = variogram(sim2~1,condsim2,cutoff = 1000,width =20,alpha = 125.0,tol.hor=22.5)
vg.sim3.035 = variogram(sim3~1,condsim2,cutoff = 1000,width =20,alpha = 35.0,tol.hor=22.5)
vg.sim3.125 = variogram(sim3~1,condsim2,cutoff = 1000,width =20,alpha = 125.0,tol.hor=22.5)
vg.sim4.035 = variogram(sim4~1,condsim2,cutoff = 1000,width =20,alpha = 35.0,tol.hor=22.5)
vg.sim4.125 = variogram(sim4~1,condsim2,cutoff = 1000,width =20,alpha = 125.0,tol.hor=22.5)

plot(vg.sim1.035$dist,vg.sim1.035$gamma,pch=19,cex=0.1,main="Variogram 2",xlab="  Lag Distance (m) ",ylab=" Semivariogram ", col="black",xlim=c(0,1000),ylim=c(0,1.2*sill))
points(vg.sim1.125$dist,vg.sim1.125$gamma,pch=19,cex=0.1,col="red")
points(vg.sim2.035$dist,vg.sim2.035$gamma,pch=19,cex=0.1,col="black")
points(vg.sim2.125$dist,vg.sim2.125$gamma,pch=19,cex=0.1,col="red")
points(vg.sim3.035$dist,vg.sim3.035$gamma,pch=19,cex=0.1,col="black")
points(vg.sim3.125$dist,vg.sim3.125$gamma,pch=19,cex=0.1,col="red")
points(vg.sim4.035$dist,vg.sim4.035$gamma,pch=19,cex=0.1,col="black")
points(vg.sim4.125$dist,vg.sim4.125$gamma,pch=19,cex=0.1,col="red")
abline(h = 1.0*sill)
# Include variogram model
unit_vector = c(sin(35*pi/180),cos(35*pi/180),0) # unit vector for 035 azimuth
vm2.035 <- variogramLine(vm2,maxdist=1000,min=0.0001,n=100,dir=unit_vector,covariance=FALSE) # calculate 035 variogram model
lines(vm2.035$dist,vm2.035$gamma,pch=19,cex=0.1,col="black") # include variogram model

unit_vector = c(sin(55*pi/180),-1*cos(35*pi/180),0) # unit vector for 125 azimuth
vm2.125 <- variogramLine(vm2,maxdist=1000,min=0.0001,n=100,dir=unit_vector,covariance=FALSE) # calculate 125 variogram model
lines(vm2.125$dist,vm2.125$gamma,col="red") # include variogram model

# Variogram 3
# Plot the CDFs for the 4 realizations and compare to the raw data CDF
plot(ecdf(condsim3@data[,1]),main="Variogram 3",xlab="Gaussian Values",ylab="Cumulative Probability",col="red")
plot(ecdf(condsim3@data[,2]),add=TRUE,col="red")
plot(ecdf(condsim3@data[,3]),add=TRUE,col="red")
plot(ecdf(condsim3@data[,4]),add=TRUE,col="red")
plot(ecdf(mydata$porosity),add=TRUE,col="black")

c = sqrt(2)

vg.sim1.060 = variogram(sim1~1,condsim3,cutoff = 1000,width =20,alpha = 60.0,tol.hor=22.5)
vg.sim1.150 = variogram(sim1~1,condsim3,cutoff = 1000,width =20,alpha = 150.0,tol.hor=22.5)
vg.sim2.060 = variogram(sim2~1,condsim3,cutoff = 1000,width =20,alpha = 60.0,tol.hor=22.5)
vg.sim2.150 = variogram(sim2~1,condsim3,cutoff = 1000,width =20,alpha = 150.0,tol.hor=22.5)
vg.sim3.060 = variogram(sim3~1,condsim3,cutoff = 1000,width =20,alpha = 60.0,tol.hor=22.5)
vg.sim3.150 = variogram(sim3~1,condsim3,cutoff = 1000,width =20,alpha = 150.0,tol.hor=22.5)
vg.sim4.060 = variogram(sim4~1,condsim3,cutoff = 1000,width =20,alpha = 60.0,tol.hor=22.5)
vg.sim4.150 = variogram(sim4~1,condsim3,cutoff = 1000,width =20,alpha = 150.0,tol.hor=22.5)

plot(vg.sim1.060$dist,vg.sim1.060$gamma,pch=19,cex=0.1,main="Varogram 3",xlab="  Lag Distance (m) ",ylab=" Semivariogram ", col="black",xlim=c(0,1000),ylim=c(0,1.2*sill))
points(vg.sim1.150$dist,vg.sim1.150$gamma,pch=19,cex=0.1,col="red")
points(vg.sim2.060$dist,vg.sim2.060$gamma,pch=19,cex=0.1,col="black")
points(vg.sim2.150$dist,vg.sim2.150$gamma,pch=19,cex=0.1,col="red")
points(vg.sim3.060$dist,vg.sim3.060$gamma,pch=19,cex=0.1,col="black")
points(vg.sim3.150$dist,vg.sim3.150$gamma,pch=19,cex=0.1,col="red")
points(vg.sim4.060$dist,vg.sim4.060$gamma,pch=19,cex=0.1,col="black")
points(vg.sim4.150$dist,vg.sim4.150$gamma,pch=19,cex=0.1,col="red")
abline(h = 1.0*sill)
# Include variogram model
unit_vector = c(sin(60*pi/180),cos(60*pi/180),0) # unit vector for 060 azimuth
vm3.060 <- variogramLine(vm3,maxdist=1000,min=0.0001,n=100,dir=unit_vector,covariance=FALSE) # calculate 035 variogram model
lines(vm3.060$dist,vm3.060$gamma,pch=19,cex=0.1,col="black") # include variogram model

unit_vector = c(sin(30*pi/180),-1*cos(60*pi/180),0) # unit vector for 125 azimuth
vm3.150 <- variogramLine(vm3,maxdist=1000,min=0.0001,n=100,dir=unit_vector,covariance=FALSE) # calculate 125 variogram model
lines(vm3.150$dist,vm3.150$gamma,col="red") # include variogram model

# On your own try changing the variogram parameters and observe the results.  Also consider kriging with a trend.

# Hope this was helpful,

# Michael

# Appreciation to Edzer Pedesma for the gstat package.


num = as.integer(readline(prompt="Enter int: "))
factorial = 1
if(num < 0) {
print("Error: must be +")
} else if(num == 0) {
print("1")
} else {
for(i in 1:num) {
factorial = factorial * i
}
print(paste(factorial))
}


# install.packages(c("knitr", "bookdown"))

library(lubridate)
library(dplyr)
library(tidyverse)
library(reshape2)
library(corrplot)
library(ggplot2)
library(ggpmisc)
library(sf)
library(rnaturalearth)
library(fastICA)
library(FactoMineR)
library(factoextra)
library(knitr)

options(encoding = "UTF-8")

SEED = 360
set.seed(SEED)

theme_plot = theme(title = element_text(),
                  plot.title = element_text(margin = margin(5,5,5,5), size = 16, hjust = 0.5))

id_sondes_list = c(825, 827, 828, 830)

# load sonde coordinates
coordinates_df = as.data.frame(read.csv(file="sensors_coordinates.csv", header=TRUE, sep=",", dec=".", na.strings=NA))
coordinates_df = coordinates_df[coordinates_df$TopoOH == "La Touques", c("id_sonde", "lib_sonde", "lat_wgs84", "lon_wgs84")]
coordinates_df$color = rep("black", nrow(coordinates_df))
coordinates_df$color[coordinates_df$id_sonde %in% id_sondes_list] = "red"

df = as.data.frame(read.csv(file="base.csv", header=TRUE, sep=";", dec=",", row.names=1, na.strings=NA))
df$date = ymd(df$date)
df$t = ymd_hms(df$t)
df$id_sonde = as.factor(df$id_sonde)

custom_summary = function(df) {
    quantitative_summary = function(column, epsilon=1e-20) {
        col_min = min(column)
        col_max = max(column)
        col_first_quantile = quantile(column, 0.25)
        col_median = median(column)
        col_third_quantile = quantile(column, 0.75)
        col_mean = mean(column)
        col_geometric_mean = exp(mean(log(column - col_min + epsilon))) + col_min - epsilon
        col_etendue = max(column) - min (column)
        col_iqr = col_third_quantile - col_first_quantile
        col_var = var(column)
        col_sd = sd(column)
        col_coeff_vaiation = col_sd / col_mean

        mat = matrix(c(col_min, col_max, col_first_quantile, col_median, col_third_quantile, col_mean, col_geometric_mean, col_etendue, col_iqr, col_var, col_sd, col_coeff_vaiation), byrow=TRUE, nrow=1)
        colnames(mat) = c("Min", "Max", "1st quantile", "Median", "3rd quantile", "Mean", "Geometric mean", "Value range", "IQR", "Variance", "Standard deviation", "Variation coefficient")
        return(mat)
    }

    qualitative_summary = function(column) {
        return(summary(column))
    }

    datetime_summary = function(column) {
        return(list(Min = min(column), Max = max(column)))
    }

    date_summary = function(column) {
        return(list(Min = min(column), Max = max(column)))
    }

    l = list()
    for(n in names(df)) {
        if(class(df[[n]]) == "Date") {
            l[[n]] = date_summary(df[[n]])
        } else if(class(df[[n]]) == "POSIXct" || class(df[[n]]) == "POSIXt") {
            l[[n]] = datetime_summary(df[[n]])
        } else if(class(df[[n]]) == "factor") {
            l[[n]] = qualitative_summary(df[[n]])
        } else if(class(df[[n]]) == "numeric") {
            l[[n]] = quantitative_summary(df[[n]])
        } else {
            l[[n]] = summary(df[[n]])
        }
    }
    return(l)
}

rmarkdown::render(input = "report.rmd", output_file = "report.pdf")


# OBRESTNE KRIVULJE
# Finančni praktikum 2020/21
# Mitja Mandić

#prva naloga

euribor.15 <- read.table("prva_naloga/podatki/hist_EURIBOR_2015.csv", sep = ",", header = TRUE, row.names = 1, check.names = FALSE)
euribor.15 <- as.data.frame(t(euribor.15[,c(1, 22, 42, 64, 84, 104, 126, 149, 170, 192, 214, 235)]))
euribor.16 <- read.table("prva_naloga/podatki/hist_EURIBOR_2016.csv", sep = ",", header = TRUE, row.names = 1, check.names = FALSE)
euribor.16 <- as.data.frame(t(euribor.16[,c(1, 21, 42, 63, 84, 106, 128, 149, 172, 194, 215, 237)]))
euribor.17 <- read.table("prva_naloga/podatki/hist_EURIBOR_2017.csv", sep = ",", header = TRUE, row.names = 1, check.names = FALSE)
euribor.17 <- as.data.frame(t(euribor.17[,c(1, 23, 43, 66, 84, 106, 128, 149, 172, 193, 215, 237)]))

euribor <- rbind(euribor.15,euribor.16,euribor.17)

prva.c.6m <- ts(euribor[,"6m"], start = 2015, frequency = 12)
prva.c.12m <- ts(euribor[,"12m"], start = 2015, frequency = 12)

ts.plot(prva.c.6m,prva.c.12m, gpars = list(xlab = "Datum", ylab = "%", col = c("red", "blue")))
legend("topright", bty="n", lty=c(1,1), col=c("red","blue"),
       legend=c("6m", "12m"))
title("EURIBOR")
graf.ts <- recordPlot()
#druga naloga

#1. julij 2015, 3. oktober 2016, 1. september 2017

druga.b <- euribor[c("01/07/2015", "03/10/2016", "01/09/2017"),]
#druga.b <- as.data.frame(t(druga.b))

  plot(t(druga.b[1,]), ylim = c(-0.4, 0.4), col = c("red"),x=c(1/4,1/2,1,2,3,6,9,12), pch = 16, ylab = "%", xlab = "Časovna enota")
points(t(druga.b[2,]), col = c("blue"),pch = 16,x=c(1/4,1/2,1,2,3,6,9,12))
points(t(druga.b[3,]), col = c("black"),pch = 16,x=c(1/4,1/2,1,2,3,6,9,12))
lines(t(druga.b[1,]),col = c("red"),pch = 16,x=c(1/4,1/2,1,2,3,6,9,12))
lines(t(druga.b[2,]),col = c("blue"),pch = 16,x=c(1/4,1/2,1,2,3,6,9,12))
lines(t(druga.b[3,]),col = c("black"),pch = 16,x=c(1/4,1/2,1,2,3,6,9,12))
legend("topleft",bty="n",lty = c(1,1),col=c("red", "blue", "black"), legend=c("1. julij 2015", "3. oktober 2016", "1. september 2017"))
title("Casovna struktura Euribor")
graf.druga.b <- recordPlot()
#Vse krivulje so naraščajoče, torej imajo višjo donosnost pri kasnejših datumih zapadlosti, torej imajo normalno obliko.
#So precej položne in z izjemo leta 2015 skozi negativne.

#tretja naloga
T <- 6
U <- 12

euribor.tretja <- euribor[,c("6m","12m")]
euribor.tretja[,"terminska"] <- 2 * ((1 + euribor.tretja[,"12m"]/100)/(1 + 1/2 * euribor.tretja[,"6m"]/100) - 1)*100 #račun terminske obrestne mere

napoved <- euribor.tretja[,"terminska"]
napoved[c(31,32,33,34,35,36)] <- 0
napoved[c(seq(7,36))] <- napoved[c(seq(1,30))]

napoved[c(1,2,3,4,5,6)] <- NA
euribor.tretja["napoved"] <- napoved #Dodan stolpec z napovedanimi vrednostmi.

  plot(x=euribor.tretja[seq(6,12),"napoved"],y=euribor.tretja[seq(6,12),"6m"], xlim = c(-0.3,0.5), ylim = c(-0.3,0.5), type="p",
                xlab = "napoved", ylab = "opazovano",col = "blue")
points(x=euribor.tretja[seq(13,24),"napoved"],y=euribor.tretja[seq(13,24),"6m"], col = "red")
points(x=euribor.tretja[seq(25,36),"napoved"],y=euribor.tretja[seq(25,36),"6m"], col = "green")
lines(x = c(-0.5,0,5), y = c(-0.5,0,5), col = "grey")
legend("topleft",bty="n",lty = c(1,1),col=c("blue", "red", "green"), legend=c("2015", "2016", "2017"))
abline(lm(euribor.tretja[,"6m"]~euribor.tretja[,"napoved"]))
title("6m euribor 2015-2017")
graf.3c <- recordPlot()

plot(x=euribor.tretja[seq(6,12),"napoved"],y=euribor.tretja[seq(6,12),"6m"], xlim = c(-0.1,0.5), ylim = c(-0.1,0.5), type="p",
                     xlab = "napoved", ylab = "opazovano",col = "blue")
abline(lm(euribor.tretja[seq(6,12),"6m"]~euribor.tretja[seq(6,12),"napoved"]))
lines(x = c(-0.5,0,5), y = c(-0.5,0,5), col = "grey")
title("6m Euribor 2015")
graf.3d.prva <- recordPlot()

plot(x=euribor.tretja[seq(13,24),"napoved"],y=euribor.tretja[seq(13,24),"6m"], xlim = c(-0.3,0.3), ylim = c(-0.3,0.3), type="p",
                                     xlab = "napoved", ylab = "opazovano",col = "red")
abline(lm(euribor.tretja[seq(13,24),"6m"]~euribor.tretja[seq(13,24),"napoved"]))
lines(x = c(-0.5,0,5), y = c(-0.5,0,5), col = "grey")
title("6m Euribor 2016")
graf.3d.druga <- recordPlot()

plot(x=euribor.tretja[seq(25,36),"napoved"],y=euribor.tretja[seq(25,36),"6m"], xlim = c(-0.3,0.1), ylim = c(-0.3,0.1), type="p",
                       xlab = "napoved", ylab = "opazovano",col = "green")
abline(lm(euribor.tretja[seq(25,36),"6m"]~euribor.tretja[seq(25,36),"napoved"]))
lines(x = c(-0.5,0,5), y = c(-0.5,0,5), col = "grey")
title("6m Euribor 2017")
graf.3d.tretja <- recordPlot()

#odgovor 3.e
#Regresijska premica bi morala biti simetrala lihih kvadrantov, na kateri bi ležale vse narisane točke. Ker je napoved večja od
#izmerjene vrednosti, so točke na grafih v desnem spodnjem kotu.

#link na github repo: https://github.com/mitja-mandic/financni-praktikum


bw <- ceiling(max(ledger_data$amount) - min(ledger_data$amount)) / (sqrt(length(ledger_data$amount))+1)
p <- qplot(amount, data = ledger_data, geom = "histogram", binwidth = bw, position="identity",
                       facets = . ~ year, xlab = commodity, ylab = "Number of days")

suppressMessages(ggsave(file="histogram-amount-facet-year.svg", plot = p, width = 12, height = 4))


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

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

# MAGIC %md
# MAGIC
# MAGIC ## Dataset
# MAGIC - Car Evaluation data set from Data Source: https://archive.ics.uci.edu/ml/machine-learning-databases/car/
# MAGIC
# MAGIC ## Problem
# MAGIC - Predict Condition of Cars based on features provided
# MAGIC  - Let's try both Decision Trees and Random Forest and compare their performance
# MAGIC
# MAGIC ## Questions
# MAGIC 1- What is the first step?
# MAGIC 2- What's after that?

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

# MAGIC %md
# MAGIC
# MAGIC ## Tips
# MAGIC 1- Load the packages
# MAGIC 2- Load the data
# MAGIC 3- Split the data

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

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

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

#packages

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

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

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

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

display(head(data1))

#display(class(data1))

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

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

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

head(data1)

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

str(data1)

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

summary(data1)

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

# MAGIC %md
# MAGIC
# MAGIC ## Try on your own

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


##
##  Java Information Dynamics Toolkit (JIDT)
##  Copyright (C) 2012, Joseph T. Lizier
##
##  This program is free software: you can redistribute it and/or modify
##  it under the terms of the GNU General Public License as published by
##  the Free Software Foundation, either version 3 of the License, or
##  (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##  GNU General Public License for more details.
##
##  You should have received a copy of the GNU General Public License
##  along with this program.  If not, see <http://www.gnu.org/licenses/>.
##

# = Example 5 - Multivariate transfer entropy on binary data =

# Multivariate transfer entropy (TE) calculation on binary data using the discrete TE calculator:

# Load the rJava library and start the JVM
library("rJava")
.jinit()

# Change location of jar to match yours:
#  IMPORTANT -- If using the default below, make sure you have set the working directory
#   in R (e.g. with setwd()) to the location of this file (i.e. demos/r) !!
.jaddClassPath("../../infodynamics.jar")

# Generate some random binary data.
numObservations <- 100
sourceArray<-matrix(sample(0:1,numObservations*2, replace=TRUE),numObservations,2)
sourceArray2<-matrix(sample(0:1,numObservations*2, replace=TRUE),numObservations,2)
# Destination variable takes a copy of the first bit of the source in bit 1,
#  and an XOR of the two bits of the source in bit 2:
destArray <- cbind( c(0L, sourceArray[1:numObservations-1,1]), # column 1
		    c(0L, 1L*xor(sourceArray[1:numObservations-1,1],
		                 sourceArray[1:numObservations-1,2]))) # column 2

# Convert the 2D arrays to Java format:
sourceArrayJava <- .jarray(sourceArray, "[I", dispatch=TRUE)
sourceArray2Java <- .jarray(sourceArray2, "[I", dispatch=TRUE)
destArrayJava <- .jarray(destArray, "[I", dispatch=TRUE)

# Create a TE calculator and run it:
teCalc<-.jnew("infodynamics/measures/discrete/TransferEntropyCalculatorDiscrete", 4L, 1L)
.jcall(teCalc,"V","initialise") # V for void return value
# We need to construct the joint values for the dest and source before we pass them in,
#  and need to use the matrix conversion routine when calling from Matlab/Octave:
mUtils<-.jnew("infodynamics/utils/MatrixUtils")
.jcall(teCalc,"V","addObservations",
		.jcall(mUtils,"[I","computeCombinedValues", sourceArrayJava, 2L),
		.jcall(mUtils,"[I","computeCombinedValues", destArrayJava, 2L))
result<-.jcall(teCalc,"D","computeAverageLocalOfObservations")
cat("For source which the 2 bits are determined from, result should be close to 2 bits : ", result, "\n")

.jcall(teCalc,"V","initialise")
.jcall(teCalc,"V","addObservations",
		.jcall(mUtils,"[I","computeCombinedValues", sourceArray2Java, 2L),
		.jcall(mUtils,"[I","computeCombinedValues", destArrayJava, 2L))
result2<-.jcall(teCalc,"D","computeAverageLocalOfObservations")
cat("For random source, result should be close to 0 bits in theory: ", result2, "\n");
cat("Result for random source is inflated towards 0.3 due to finite observation length ",
    .jcall(teCalc,"I","getNumObservations"), "\n",
    "One can verify that the answer is consistent with that from a\n",
    "random source by checking: teCalc.computeSignificance(1000); ans.pValue\n");


############################################################################
## Preprocessing
#### Generate simulated data with noise

devtools::use_data_raw()
df <- read.table('data/demo.n500_p20_eq1.counts.txt', head=F, row.names=1, sep='\t')

aux.poisson <- function(v, depth){
    v <- round(v/sum(v) * depth)
    sapply(v, function(x) rpois(1, x))
}
df.noise <- apply(df, 2, aux.poisson, depth=5000)

params <- read.table('data/demo.n500_p20_eq1.truth.txt', head=T)

truth2param <- function(truth){
    a.truth <- truth[is.na(truth$source_taxon),3]
    p <- length(a.truth)
    b.truth <- matrix(truth[!is.na(truth$source_taxon),3],p,p)
    tmp.diag <- truth[truth$source_taxon==truth$target_taxon,3][-(1:p)]
    a.truth <- -a.truth/tmp.diag
    b.truth <- -b.truth/tmp.diag
    return(list(a.truth=a.truth, b.truth=b.truth))
}

scaled.params <- truth2param(params)

beemDemo <- list(dat.w.noise=df.noise, dat.wo.noise=df,
            scaled.params=scaled.params,
            original.params=params, biomass.true=colSums(df))

devtools::use_data(beemDemo)
devtools::load_all()

##############################################################################
library(beemStatic)
data("beemDemo")
attach(beemDemo)

res <- func.EM(dat.w.noise, ncpu=4, scaling=median(biomass.true), max.iter=200, alpha = 0.5)

diagnoseFit(res, dat.w.noise, annotate = FALSE)

diagnoseBiomass(res, true.biomass = biomass.true)

plot(beem2biomass(res), biomass.true, xlab='BEEM biomass estimation', ylab='True biomass')

est <- beem2param(res)

showInteraction(res, dat.w.noise)

par(mfrow=c(1,2))
plot(est$a.est, scaled.params$a.truth, xlab='BEEM estimation', ylab='Truth', main='Growth rates')
auc.b(est$b.est, scaled.params$b.truth, main='Interaction matrix')

spearman <- cor(t(dat.w.noise), method='spearman')

library(SpiecEasi)
se <- spiec.easi(t(dat.w.noise), method='mb')
se.stab <- as.matrix(getOptMerge(se))

par(mfrow=c(1,3), cex=1)
auc.b(spearman, scaled.params$b.truth, is.association = TRUE, main='Spearman correlation')
auc.b(se.stab, scaled.params$b.truth, is.association = TRUE, main='SPIEC-EASI')
auc.b(est$b.est, scaled.params$b.truth, main='BEEM-static')

par(mfrow=c(1,2), cex=1)
tmp <- scaled.params$b.truth
tmp[tmp!=0 & res$b.uncertain<0.5] <- 0
auc.b(est$b.est, scaled.params$b.truth, main='BEEM-static')
auc.b(est$b.est, tmp, main='BEEM-static (excluding uncertain edges)')


require(rms)
d <- expand.grid(a=c('a1','a2'), b=c('b1','b2'))
d$y <- Surv(c(1,3,2,4))
f <- y ~ a * strat(b)
m <- model.frame(f, data=d)
Terms <- terms(f, specials='strat', data=d)
specials <- attr(Terms, 'specials')
temp <- survival:::untangle.specials(Terms, 'strat', 1)
Terms <- Terms[- temp$terms]
# X <- rms:::Design(m)
# atr <- attr(X, 'Design')
# atr$colnames

model.matrix(Terms, m)
colnames(model.matrix(Terms, m)[, -1, drop=FALSE])

cph(f, data=d)


#UNIDADE 3#

> nome <- "Jonathan Sartori Bruzarrosco"
> seg <- 5
> ter <- 4
> qua <- 1
> qui <- 6
> sex <- 2
> diasemana <- c(5,4,1,6,2)
> diasemana[2]
[1] 4
> is.vector(diasemana)
[1] TRUE
> is.vector(seg)
[1] TRUE
> nomesemana <- c("DOMINGO", "SEGUNDA", "TERÇA", "QUARTA", "QUINTA", "SEXTA", "SABADO")
> diasemana <- c(1,2,3,4,5,6,7)
> names(diasemana) <- nomesemana
> diasemana
DOMINGO SEGUNDA   TERÇA  QUARTA  QUINTA
      1       2       3       4       5
  SEXTA  SABADO
      6       7
> ##OU SEJA ACIMA A JUNÇÃO DE DOIS ELEMENTOS##
>
> nomes <- c("Jonathan", "Danielle")
> nomes
[1] "Jonathan" "Danielle"
>
> ##ACRESCENTAR ELEMENTO##
> nomes[length(nomes)+1] <- "Natasha"
> nomes
[1] "Jonathan" "Danielle" "Natasha"
> nomes[length(nomes)+1] <- "Raissa"
> nomes
[1] "Jonathan" "Danielle" "Natasha"
[4] "Raissa"
> nomes
[1] "Jonathan" "Danielle" "Natasha"  "Raissa"
>
> ##REMOVER VALOR##
>
> nomes <- nomes[-4]
> nomes
[1] "Jonathan" "Danielle" "Natasha"
>
> for(nome in nomes){}
> for(nome in nomes){
+     print(paste("onome é: ", nome))
+ }
[1] "onome é:  Jonathan"
[1] "onome é:  Danielle"
[1] "onome é:  Natasha"
>
> for(nome in nomes){
+     print(paste("o nome é: ", nome))
+ }
[1] "o nome é:  Jonathan"
[1] "o nome é:  Danielle"
[1] "o nome é:  Natasha"

> ##CRIAR FUNÇOES##
>
> 2+4
[1] 6
>
> soma <- function(v1, v2){
+     resul <- v1 + v2
+     return(resul)
+ }
> View(soma)
> View(soma)
> soma(2,4)
[1] 6
> soma(2,89)
[1] 91
>
> ##POSSO ALTERAR A FUNCAO##
>
> func_generic <- function(v1, v2, op){
+     if(op=="+"){
+         resul <- v1 + v2
+     }
+     if(op=="-"){
+         resul <- v1 - v2
+     }
+     return(resul)
+ }
> func_generic(4,3,"+")
[1] 7
> func_generic(4,3,"-")
[1] 1

> maior <- function(lista){}
> maior <- function(lista){
+     maior<-0
+     print(paste("valor maior: " , maior))
+     for(val in lista){
+         print(paste("valor da variavel val: ", val))
+         if(maior<val){
+             maior <- val
+         }
+     }
+ }
>
> numero <- c(1,5,51,3)
> maior(numero)
[1] "valor maior:  0"
[1] "valor da variavel val:  1"
[1] "valor da variavel val:  5"
[1] "valor da variavel val:  51"
[1] "valor da variavel val:  3"
>
> maior <- function(lista){
+     maior<-0
+     print(paste("valor maior: " , maior))
+     for(val in lista){
+         print(paste("valor da variavel val: ", val))
+         if(maior<val){
+             maior <- val
+         }
+     }
+     return(maior)
+ }
> maior(numero)
[1] "valor maior:  0"
[1] "valor da variavel val:  1"
[1] "valor da variavel val:  5"
[1] "valor da variavel val:  51"
[1] "valor da variavel val:  3"
[1] 51
>
> ##ISSO TAMBEM VALE PARA CHARACTER##
> maior(nomes)
[1] "valor maior:  0"
[1] "valor da variavel val:  Jonathan"
[1] "valor da variavel val:  Danielle"
[1] "valor da variavel val:  Natasha"
[1] "Natasha"
> maior(nomesemana)
[1] "valor maior:  0"
[1] "valor da variavel val:  DOMINGO"
[1] "valor da variavel val:  SEGUNDA"
[1] "valor da variavel val:  TERÇA"
[1] "valor da variavel val:  QUARTA"
[1] "valor da variavel val:  QUINTA"
[1] "valor da variavel val:  SEXTA"
[1] "valor da variavel val:  SABADO"
[1] "TERÇA"

> ##trabalhar com factor##
> ##organiza e categoriza as informacoes##
> ordendado <- factor(nomes)
> ordendado
[1] Jonathan Danielle Natasha
Levels: Danielle Jonathan Natasha
>
> ##ORDENOU A ORDEM DE NOMES##
>
> votacao <- c("candidato1", "candidato2", "candidato1", "candidato1")
> resultado <- factor(votacao)
> resultado
[1] candidato1 candidato2 candidato1 candidato1
Levels: candidato1 candidato2
>
> summary(resultado)
candidato1 candidato2
         3          1

> ##OU SEJA ELE CALCULOU A VOTACAO##

> ##UNIDADE 4##

>
> ##MANIPULAÇÃO DE DADOS##
>
> ##IMPORTAR ARQUIVO DO EXECL COMO EXEMPLO##
>
> library(readxl)
> pagamento <- read_excel("C:/Users/jonat/Downloads/pagamento.xls")

> ##UTILIZAR A FUNÇÃO SELECT##
>
> ##PARA UTILIZAR PRECISAMOS DA PACKAGE (DPLYR)##
>
> library(dplyr)

Attaching package: ‘dplyr’

The following objects are masked from ‘package:stats’:

    filter, lag

The following objects are masked from ‘package:base’:

    intersect, setdiff, setequal, union

> ##no exemplo da planilha dele tem:##
> ##valor, regiao, notas, cidades##
>
> ##vai selecionar valor e regiao##
>
> resul <- pagto %>% select(valor, regiao)
Error in select(., valor, regiao) : object 'pagto' not found
> ##object pagto, foi uma variavel importada do excel##
>
> view(resul)
Error in view(resul) : could not find function "view"
> ##Mostra os resul em tabela das variaveis que ele tem)

> ##ordenar dados da tabela##
>
> resul <- pagto %>% select(Valor, Regiao) %>% filter(valor>100)
Error in select(., Valor, Regiao) : object 'pagto' not found
> ##resultado mostra as notas maiores que 1000##
>
> ##criar ou modificar colunas##
> ##Mutate##
>
> resul <- pagto %>% select(Valor, Regiao) %>% mutate(pix = (Valor * 0.135))
Error in select(., Valor, Regiao) : object 'pagto' not found
> view(resul)
Error in view(resul) : could not find function "view"
> ##mostrou as tabelas com o valor das multiplicacoes##
>
> ##summarise e group_by##
>
> resul <- pagto %>% select(valor, regiao, nrnota, prestador) %>% group_by(regiao) %>% summarise((total = mean(valor)))
Error in select(., valor, regiao, nrnota, prestador) :
  object 'pagto' not found
> view(resul)
Error in view(resul) : could not find function "view"
> ##Mostrou a media do agrupamento##
>
> resul <- pagto %>% select(nrnota, valor, prestador,regiao) %>% count(regiao)
Error in select(., nrnota, valor, prestador, regiao) :
  object 'pagto' not found
> view(resul)
Error in view(resul) : could not find function "view"
> ##count = mostrou a recorrencia
>
>
> ##ORDENAÇÃO##
>
> ##ARRANGE##
>
> pagto %>% arrange(prestador)
Error in arrange(., prestador) : object 'pagto' not found
> ##ordena do maior para o menos
>
> pagto %>% arrange(desc(prestador))
Error in arrange(., desc(prestador)) : object 'pagto' not found
> ##ordenou do menor para o maior##
>

##UNIDADE 5 ##


library(shiny)
library(shinythemes)
library(ggplot2)
library(dplyr)
library(RCurl)
library(zoo)

#Data for county data plots
us_counties = read.csv(text = getURL("https://raw.githubusercontent.com/nytimes/covid-19-data/master/us-counties.csv"))
us_counties$date = as.Date(us_counties$date)
us_counties = us_counties[order(us_counties$county),]

#world data for country by country cases and deaths
world_wide = read.csv(text = getURL("https://raw.githubusercontent.com/datasets/covid-19/master/data/countries-aggregated.csv"))
world_wide$Date = as.Date(world_wide$Date)
world_filt = world_wide %>%
  select("Date", "Country", "Confirmed", "Deaths") %>%
  filter(Country %in% c("Sweden", "US", "Belgium", "Canada", "New Zealand", "Brazil", "India", "Belgiam", "Italy", "Germany", "France", "United Kingdom")) %>%
  mutate(daily_cases = Confirmed - lag(Confirmed, default = first(Confirmed))) %>%
  mutate(daily_deaths = Deaths - lag(Deaths, default = first(Deaths))) %>%
  arrange("Date")

world_filt <- data.frame(lapply(world_filt, function(x) {
  gsub("US", "United States", x)
}))

#US Deaths- maybe make this filterable likek the county plots in the future
us_data = world_filt %>%
  filter(world_filt$Country == "United States")

us_data$Date = as.Date(us_data$Date)
us_data$daily_cases = as.numeric(us_data$daily_cases)
us_data$daily_deaths = as.numeric(us_data$daily_deaths)

pop_data = read.table("population.csv", stringsAsFactors = F,sep = ",", header=T)
pop_data_2018 =pop_data %>%
  filter(Year == 2018)

median_ages = read.table("median_age.txt", sep = "\t", header =F)
names(median_ages) = c("Line", "Country", "Median_Age")

all_data = merge(pop_data_2018,median_ages, by.x = 'Country.Name', by.y='Country')

all_pop_covid_data = merge(all_data,world_filt, by.x = 'Country.Name', by.y='Country')
all_pop_covid_data$Value = as.numeric(all_pop_covid_data$Value)
all_pop_covid_data$Confirmed = as.numeric(all_pop_covid_data$Confirmed)
all_pop_covid_data$Date = as.Date(all_pop_covid_data$Date)
all_pop_covid_data$Deaths = as.numeric(all_pop_covid_data$Deaths)

# Define UI for covid by county app
ui <- navbarPage(theme = shinytheme("darkly"),
      "Covid Tracking",
      tabPanel(
      "County Tracking",

      pageWithSidebar(

      # App title ----
      headerPanel("Covid-19 Daily Cases per County"),

      # Sidebar panel for inputs ----
      sidebarPanel(

        #State selector
        selectInput("state", "State:",
                choices = sort(unique(us_counties$state))),

        #county selector
        selectInput("county", "County:",
                choices = NULL)

      ),

  # Main panel for displaying outputs ----
  mainPanel(
    # Output: Formatted text for caption ----
    h3(textOutput("caption")),

    plotOutput("countyPlot"),

    tagList("Data Source:",a("New York Times GitHub", href="https://raw.githubusercontent.com/nytimes/covid-19-data/master/us-counties.csv"))
  )
 )
),
tabPanel("World Cases",
         plotOutput("worldCases")),
tabPanel("World Deaths",
         plotOutput("worldDeaths")),
tabPanel("US Deaths",
         plotOutput("usDeaths"))
)

# Define server logic to plot cases by county
server <- function(session,input, output) {

  observe({
    counties_in_state <- us_counties %>%
    filter(state == input$state) %>%
    select(county)
    updateSelectInput(session, "county", "County:", choices = unique(counties_in_state))
  })

  filtered_data<-reactive({
    us_counties %>%
      filter(state==input$state, county==input$county) %>%
      arrange("date") %>%
      mutate(daily_cases = cases - lag(cases, default = first(cases))) %>%
      mutate(rollavg=rollapply(daily_cases,7,mean, align='right',fill=NA))

  })

  # Compute the formula text ----
  formulaText <- reactive({
    paste("Cases in", input$county, "county", input$state)
  })

  # Return the formula text for printing as a caption ----
  output$caption <- renderText({
    formulaText()
  })

  # Generate a plot of daily cases by county
  output$countyPlot <- renderPlot({
    ggplot(filtered_data(), aes(x=date,y = daily_cases)) +
      geom_col(fill = "dark blue") +
      xlab("Date") +
      ylab("New Cases") +
      scale_x_date(date_breaks = "1 month", date_labels =  "%b %Y") +
      geom_line(data=filtered_data(), aes(x=date, y=rollavg), colour="red", size = 1.3)
  })

  #World Death plot
  output$worldDeaths <- renderPlot({
    ggplot(data = all_pop_covid_data, aes(x =Date, y = Deaths/Value, col = Country.Name)) +
      geom_line(size = 1.2) +
      scale_x_date(date_breaks = "1 month", date_labels =  "%b %Y")
  })

  #world cases plot
  output$worldCases <- renderPlot({
    ggplot(data = all_pop_covid_data, aes(x = Date, y = Confirmed/Value*100,col = Country.Name))+
      geom_line(size = 1.2) +
      scale_x_date(date_breaks = "1 month", date_labels =  "%b %Y")
  })

  #US daily deaths
  output$usDeaths <- renderPlot({
  ggplot(data=us_data, aes(x=Date,y = daily_deaths/daily_cases)) +
    geom_col(fill = "dark blue") +
    xlab("Date") +
    ylab("Death Rate") +
    scale_x_date(date_breaks = "1 month", date_labels =  "%b %Y")
  })

    }

shinyApp(ui, server)


#! /usr/bin/Rscript --vanilla

# See RWeka doc http://cran.r-project.org/web/packages/RWeka/RWeka.pdf

library("rjson")

library("rJava")
library("RWeka")
library("cvTools")

args = commandArgs(TRUE)

csv_path = fromJSON(args[2])
training_split = fromJSON(args[3])
cache_path = fromJSON(args[4])

print(csv_path)
csv = read.csv(csv_path)

# Split training and test data
#sample_size = floor( training_split * nrow(csv) )

# Seed to make results reproducible. Leave out to keep random each time.
# set.seed(123)

#sample_indices = sample(seq_len(nrow(csv)), size=sample_size)

#trainset = csv[sample_indices, ]
#testset = csv[-sample_indices, ]

# Ten-fold validation
num_folds = 10
folds = cvFolds(nrow(csv), K=num_folds)

for(i in 1:num_folds) {

	trainset <- csv[folds$subsets[folds$which != i], ]
	testset <- csv[folds$subsets[folds$which == i], ]

	# Train model

	m = J48(bugginess ~ ., data=trainset)

	# Evaluate with test data
	if(nrow(testset) > 0) {
		print(paste("FOLD ", i))
	    print(evaluate_Weka_classifier(m, newdata=testset))
	}
}

# Save the (most recent) predicted model, if desired
if(!is.null(cache_path)) {

    # jcache Needed for this object type, see http://r.789695.n4.nabble.com/How-to-save-load-RWeka-models-into-from-a-file-td870876.html
    rJava::.jcache(m$classifier)

    save(m, file=cache_path)
}

# Print directed graph

dot_path = 'decision_tree_model.dot'

sink(dot_path)
write_to_dot(m)
sink()

print('Decision tree graph saved in dot file (requires Graphviz to view) has been saved in your current working directory as:')
print(dot_path)


# 3. faza: Vizualizacija podatkov

require(dplyr)
library(ggplot2)
require(tmap)
library(cowplot)
library(plotrix)

#1.graf (TIP LASTNIŠTVA)

povprecje.lastnistva.po.regijah <- tabelaI %>% group_by(regija, `Tip lastništva`) %>%
  summarise(povprecje=(sum(`Število prebivalcev`)/3)/1000)

graf_povprecja_po_regijah <- ggplot(data=povprecje.lastnistva.po.regijah, aes(x=regija, y=povprecje, fill=`Tip lastništva`)) +
  geom_col(position = 'dodge') +
  coord_flip() +
  labs(x = "Regija", y = "Povprečno število (/1000)", title = "Povprečno število v posameznih statističnih \nregijah glede na tip lastništva") +
  theme_dark() +
  scale_fill_brewer(palette = "BrBG")

#2.graf in #3.graf (VRSTA STAVBE)

Vrste_st <- split(tabelaII, tabelaII$`vrsta stavbe`)
Eno_st <- Vrste_st[[1]] %>% select(-`vrsta stavbe`)
Dvo_st <- Vrste_st[[2]] %>% select(-`vrsta stavbe`)
Tro_Vec_st <- Vrste_st[[3]] %>% select(-`vrsta stavbe`)
Eno_dvo_st <- rbind(Eno_st, Dvo_st) %>% group_by(regija) %>% summarise(povprecje=sum(povprecje))

stanovanje <- left_join(Tro_Vec_st, tabelaIII, by = c("regija"))
stanovanje$povprecje.x <- as.numeric(stanovanje$povprecje.x)
stanovanje$povprecje.y <- as.numeric(stanovanje$povprecje.y)
stanovanje <- transform(stanovanje, delez = round((povprecje.x/povprecje.y)*100, 2)) %>% select(-povprecje.x, -povprecje.y)

hisa <- left_join(Eno_dvo_st, tabelaIII, by = c("regija"))
hisa$povprecje.x <- as.numeric(hisa$povprecje.x)
hisa$povprecje.y <- as.numeric(hisa$povprecje.y)
hisa <- transform(hisa, delez = round((povprecje.x/povprecje.y)*100, 2)) %>% select(-povprecje.x, -povprecje.y)

zemljevid <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/SVN_adm_shp.zip",
                             "SVN_adm1", encoding = "UTF-8")
zemljevid$NAME_1 <- c("Gorenjska", "Goriška","Jugovzhodna", "Koroška", "Primorsko-notranjska", "Obalno-kraška",
                      "Osrednjeslovenska", "Podravska", "Pomurska", "Savinjska", "Posavska", "Zasavska")
zemljevid <- fortify(zemljevid)

graf2 <- ggplot() + geom_polygon(data=left_join(zemljevid, stanovanje, by=c("NAME_1"="regija")),
                                                aes(x=long, y=lat, group=group, fill=delez)) +
  geom_line() +
  theme(axis.text.x=element_blank(), axis.ticks.x=element_blank(), axis.text.y=element_blank(),
        axis.ticks.y=element_blank()) +
  guides(fill=guide_colorbar(title="Delež (%)")) +
  ggtitle("Povprečen delež ljudi, ki živi v tro ali večstanovanjskih stavbah \npo statističnih regijah v zadnjih desetih letih") +
  labs(x = " ") +
  labs(y = " ") +
  scale_fill_gradient(low = "white", high = "cadetblue",
                      space = "Lab", na.value = "#e0e0d1", guide = "black",
                      aesthetics = "fill") +
  theme_dark()

graf3 <- ggplot() + geom_polygon(data=left_join(zemljevid, hisa, by=c("NAME_1"="regija")),
                                 aes(x=long, y=lat, group=group, fill=delez)) +
  geom_line() +
  theme(axis.text.x=element_blank(), axis.ticks.x=element_blank(), axis.text.y=element_blank(),
        axis.ticks.y=element_blank()) +
  guides(fill=guide_colorbar(title="Delež (%)")) +
  ggtitle("Povprečen delež ljudi, ki živi v eno ali dvostanovanjski stavbi \npo statističnih regijah v zadnjih desetih letih") +
  labs(x = " ") +
  labs(y = " ") +
  scale_fill_gradient(low = "white", high = "darkgoldenrod3",
                      space = "Lab", na.value = "#e0e0d1", guide = "black",
                      aesthetics = "fill") +
  theme_dark()

#5.graf (STOPNJA PREOBREMENJENOSTI)

graf_st.preobremenjenosti <- ggplot(data=tabelaIV, aes(x=leto, y=`Število prebivalcev`, col=Spol)) +
                                      geom_line(size=1) + facet_grid(~starost) +
  theme_bw() +
  scale_color_manual(values=c("darkgoldenrod3", "cadetblue")) +
  labs(x = "Leto", y = "Število prebivalcev", title = "Število prebivalcev preobremenjenih s stanovanjskimi stroški \nglede na starost, spol in leto") +
  scale_x_continuous(breaks=seq(2010, 2020, 4))


# Script for generating frames for a animation on danish population

# convert -delay 10 -loop 0 frame* befolkning.gif

IMAGEFILE = 'frame%03d.png'
PLOTTITLE = 'Population, Denmark, %s'

data2 <- read.csv("befolkningstal.csv")

frameI = 1

maxcount =  max(data2, na.rm = TRUE)
originYear = 1970
for(i in 1:ncol(data2)){
	frameName = sprintf(IMAGEFILE, frameI)
	frameI = frameI + 1
	totalPopulation = sum(data2[,i], na.rm = TRUE)
	plotTitle = sprintf("Population, Denmark, %d
Total Population: %d", originYear + i, totalPopulation)

	png(frameName)
	barplot(data2[,i], main = plotTitle, ylab = "Count", xlab ="Age", ylim=c(0,maxcount),
	 xlim = c(0,100), border = NA, space = 0, names.arg = 1:nrow(data2)-1)
	dev.off()
}


washington_covid <- read.csv("data/washington_unemployment/crosstab_real.csv",
                             stringsAsFactors = FALSE)

claims_data <- read.csv("data/washington_unemployment/initial_claims.csv",
                        stringsAsFactors = FALSE)

library("dplyr")
library("ggplot2")
library("plotly")

claims_data$Initial.Claims <- gsub(",", "", claims_data$Initial.Claims)
claims_data$Initial.Claims <- as.numeric(claims_data$Initial.Claims)
claims_plot <- ggplot(data = claims_data, aes(x = Week, y = Initial.Claims,
                                              group = 1)) +
  geom_point() +
  scale_y_continuous(limits = c(5000, 185000)) +
  labs(
    title = "Amount of Initial Claims of Unemployment Per Week",
    x = "Week of Quarantine",
    y = "Initial Claims"
  )

# The plot is a line plot of initial claims of EVERY industry and EVERY
# county that occurred on a weekly basis from weeks 1-19 of the pandemic.
wa_claims_plot <- ggplotly(claims_plot)


# This script relies on wrapper which is supposed to set environment variable
# R_LIBS that points to a directory with needed modules

library(DNAcopy)
cmd_args=commandArgs(trailingOnly = TRUE)

varscanResults<-cmd_args[1]
sampleID<-cmd_args[2]
varscanSmoothed = paste(varscanResults, "segmented", sep=".")

cn <- read.table(varscanResults,header=T)
CNA.object <-CNA( genomdat = cn[,6], chrom = cn[,1], maploc = cn[,2], data.type = 'logratio', sampleid = sampleID)
CNA.smoothed <- smooth.CNA(CNA.object)
segs <- segment(CNA.smoothed, verbose=0, min.width=2)
segs2 = segs$output
write.table(segs2[,2:6], file=varscanSmoothed, row.names=F, col.names=F, quote=F, sep="\t")

options(bitmapType="cairo")
# Visualizaton 1 of 2
png_plot_w = paste(varscanResults, "w_plot", "png", sep=".")

png(filename=png_plot_w, bg="white", width=600, height=600, units="px")
plot(segs, plot.type="w")
blah<-dev.off()

# Visualizaton 2 of 2
png_plot_s = paste(varscanResults, "s_plot", "png", sep=".")

png(filename=png_plot_s, bg="white", width=600, height=600, units="px")
plot(segs, plot.type="s")
blah<-dev.off()


library(caret)
library(klaR)
data=read.csv("Customer_Churn_Data.csv")
data<-data[complete.cases(data),-c(1,2,3,5)]

#partitioning dataset
trainIndex <- createDataPartition(data$churn, p=0.7, list=FALSE)
train <- data[ trainIndex,]
test <- data[-trainIndex,]

set.seed(54321)

#naive bayes model
naivebayes <- NaiveBayes(churn~., data=train)
# train a decision tree model
ctrl <- trainControl(method = "repeatedcv", number = 10, repeats = 3)
decisiontree <- train(churn~., data =train, method = "rpart",parms = list(split = "information"),trControl=ctrl,tuneLength = 10)
#svm model
svm <- train(churn ~., method = "svmRadial", data = train)
#random forest
abcd$total_day_minutes<-as.factor(abcd$total_day_minutes)
abcd$total_day_calls<-as.factor(abcd$total_day_calls)
abcd$total_day_charge<-as.factor(abcd$total_day_charge)
abcd$total_eve_minutes<-as.factor(abcd$total_eve_minutes)
abcd$total_eve_calls<-as.factor(abcd$total_eve_calls)
abcd$total_eve_charge<-as.factor(abcd$total_eve_charge)
abcd$churn<-as.factor(abcd$churn)
mod.rf <- train(abcd$churn ~ total_day_calls+total_day_charge, method = "rf", data = train,metric=metric, trControl=control,na.action = na.fail)

#training the model
xtest <-test[,1:17]
ytest <-test[,18]
predictionbayes <- predict(naivebayes,xtest)
predictiondt<-predict(decisiontree,xtest)
predictionsvm <- predict(svm, xtest)
predictionrf <- predict(mod.rf, xtest)

#confusion matrix
confusionMatrix(predictionbayes$class, ytest)
confusionMatrix(predictiondt, ytest)
confusionMatrix(predictionsvm, ytest)
confusionMatrix(predictionrf, ytest)

#predicting
datan=read.csv("datacopy.csv")
ntrainIndex <- createDataPartition(data$churn, p=0.7, list=FALSE)
ntrain <- datan[ ntrainIndex,]
ntest <- datan[-ntrainIndex,]
nnaivebayes <- NaiveBayes(churn~., data=ntrain)
nxtest <-test[,1:17]
nytest <-test[,18]
npredictionbayes <- predict(nnaivebayes,nxtest)
confusionMatrix(npredictionbayes$class, nytest)


# data recoded in the "long" format, where each row corresponds to one choice option
# prior: trials where the binomial was replaced with a letter mask
prior <- read.csv("../../Data/Processed/prior_data_long.csv")

# binomial data: trials when an informative phrase was presented
binomial_data <- read.csv("../../Data/Processed/binomial_data_long.csv")

library(mlogit)
size.as.factor <- function(dat) with(dat,ifelse(equal_size==1,"EQUAL",ifelse(left_larger,"LEFT","RIGHT")))
prior$size <- size.as.factor(prior)

dat <- mlogit.data(prior,choice="CHOICE",shape="long",chid.var="custom_id",alt.var="mode_id")
m.prior.mlogit <- mlogit(CHOICE ~ size,dat)
summary(m.prior.mlogit)

binomial_data$size <- size.as.factor(binomial_data)
dat.test <- mlogit.data(binomial_data,choice="CHOICE",shape="long",chid.var="custom_id",alt.var="mode_id")
predictions <- predict(m.prior.mlogit,dat.test)
write.csv(predictions,"../../Data/Processed/predictions-mlogit.csv")