# Project: Surveyer
# Description: Package of Land and Engineering Surveying utilities
# Authors: Milutin Pejovic, Milan Kilibarda, Branislav Bajat, Aleksandar Sekulic and Petar Bursac

################
# surveynet.xlsx
################

# Parameters:
#    1. points -  Excel file sheet with attributes related to points - geodetic network [Example: Data/Input/xlsx]
#    2. observations - Excel file sheet with attributes related to observations [Example: Data/Input/xlsx]
#    3. dest_crs - destination Coordinate Reference System - set EPSG code [default: 3857 - Web Mercator projection coordinate system]

surveynet.xlsx <- function(points = points, observations = observations, dest_crs = NA){
  # If column "Description" is necessary, delete it;
  j=1
  for(i in names(points)){
    if (i == "NA."){
      points <- subset(points, select = -c(j))
    }
    j=j+1
  }

  j_1=1
  for(i in names(observations)){
    if (i == "NA."){
      observations <- subset(observations, select = -c(j_1))
    }
    j_1 = j_1 + 1
  }

  # TODO Check funkcija ide ovde

  # Check function for point names, that can not be just numbers -> must contain letter
  points$Name <- as.character(points$Name)
  vec <- c(1:99999)
  j = 1
  for(i in points$Name){
    if(i %in% vec){
      points$Name[j] <- paste("T",i, sep = "")
      j = j +1

    }
  }

  observations$from <- as.character(observations$from)
  vec <- c(1:99999)
  j = 1
  for(i in observations$from){
    if(i %in% vec){
      observations$from[j] <- paste("T",i, sep = "")
      j = j +1

    }
  }

  observations$to <- as.character(observations$to)
  vec <- c(1:99999)
  j = 1
  for(i in observations$to){
    if(i %in% vec){
      observations$to[j] <- paste("T",i, sep = "")
      j = j +1

    }
  }

  # Create geometry columns for points
  if (is.na(dest_crs)){
    dest_crs <- 3857
  } else{
    dest_crs = dest_crs
  }

  observations$x_station <- points$x[match(observations$from, points$Name)]
  observations$y_station <- points$y[match(observations$from, points$Name)]
  observations$x_obs.point <- points$x[match(observations$to, points$Name)]
  observations$y_obs.point <- points$y[match(observations$to, points$Name)]

  points <- points %>% as.data.frame %>% sf::st_as_sf(coords = c("x","y")) %>% sf::st_set_crs(dest_crs)

  dt <- as.data.table(observations)
  dt_1 <- dt[
    , {
      geometry <- sf::st_linestring(x = matrix(c(x_station, x_obs.point, y_station, y_obs.point), ncol = 2))
      geometry <- sf::st_sfc(geometry)
      geometry <- sf::st_sf(geometry = geometry)
    }
    , by = id
    ]
  dt_1 <- sf::st_as_sf(dt_1)
  dt_1 %<>% mutate(from = observations$from,
                   to = observations$to,
                   distance = observations$distance,
                   direction = observations$direction,
                   standard_dir = observations$standard_dir,
                   standard_dist = observations$standard_dist
  )

  dt_1 <- dt_1 %>% sf::st_set_crs(dest_crs)
  observations <- dt_1

  # Creating list
  survey_net <- list(points,observations)

  return(survey_net)

}

# Parameters:
#    1. points - updated points tabele releted to 2D net design
#    2. observations - updated observations tabele releted to 2D net design
#    3. dest_crs - destination Coordinate Reference System - set EPSG code [default: 3857 - Web Mercator projection coordinate system]
#    4. raw_points - Excel file sheet with attributes related to points - geodetic network [Example: Data/Input/xlsx]

surveynet.xlsx_updated <- function(points = points, observations = observations, dest_crs = NA, raw_points = raw_points){

  # Check function for point names, that can not be just numbers -> must contain letter
  raw_points$Name <- as.character(raw_points$Name)
  vec <- c(1:99999)
  j = 1
  for(i in raw_points$Name){
    if(i %in% vec){
      raw_points$Name[j] <- paste("T",i, sep = "")
      j = j +1

    }
  }

  # Create geometry columns for points
  if (is.na(dest_crs)){
    dest_crs <- 3857
  }else{
    dest_crs = dest_crs
  }

  points$x <- raw_points$x[match(points$Name, raw_points$Name)]
  points$y <- raw_points$y[match(points$Name, raw_points$Name)]

  observations$x_station <- points$x[match(observations$from, points$Name)]
  observations$y_station <- points$y[match(observations$from, points$Name)]
  observations$x_obs.point <- points$x[match(observations$to, points$Name)]
  observations$y_obs.point <- points$y[match(observations$to, points$Name)]

  points <- points %>% as.data.frame %>% sf::st_as_sf(coords = c("x","y")) %>% sf::st_set_crs(dest_crs)

  dt <- as.data.table(observations)
  dt_1 <- dt[
    , {
      geometry <- sf::st_linestring(x = matrix(c(x_station, x_obs.point, y_station, y_obs.point), ncol = 2))
      geometry <- sf::st_sfc(geometry)
      geometry <- sf::st_sf(geometry = geometry)
    }
    , by = id
    ]
  dt_1 <- sf::st_as_sf(dt_1)
  dt_1 %<>% mutate(from = observations$from,
                   to = observations$to,
                   distance = observations$distance,
                   direction = observations$direction,
                   standard_dir = observations$standard_dir,
                   standard_dist = observations$standard_dist
  )

  dt_1 <- dt_1 %>% sf::st_set_crs(dest_crs)
  observations <- dt_1

  # Creating list
  survey_net <- list(points,observations)

  return(survey_net)

}

###############
# surveynet.shp
###############

# Parameters:
#    1. points -  sf object with geometry type POINT - geodetic network [Example: Data/Input/shp]
#    2. observations - sf object with geometry type LINESTRING [Example: Data/Input/shp]
#    3. fix_x - list with names of points that define datum - X coordinate
#    3. fix_y - list with names of points that define datum - Y coordinate
#    4. st_dir - "a priori" standard deviation for direction observations ["]
#    5. st_dist - "a priori" standard deviation for distance observations [mm]
#    6. dest_crs - destination Coordinate Reference System - set EPSG code [default: 3857 - Web Mercator projection coordinate system]
#    7. points_object - list with names of points that represnt object of interests

surveynet.shp <- function(points, observations, fix_x = list(), fix_y = list(), st_dir, st_dist, dest_crs = NA, points_object = list()){
  for(i in names(points)){
    if(i == "Naziv"){
      points <- points %>% rename("Name" = "Naziv")
    }
  }
  for(i in names(observations)){
    if(i == "Name"){
      observations <- observations %>% rename("id" = "Name")
    }
  }

  # TODO Check funkcija ide ovde

  # Check function for point names, that can not be just numbers -> must contain letter
  points$Name <- as.character(points$Name)
  vec <- c(1:99999)
  j = 1
  for(i in points$Name){
    if(i %in% vec){
      points$Name[j] <- paste("T",i, sep = "")
      j = j +1

    }
  }

  # Transformation to the destination CRS
  if (is.na(dest_crs)){
    dest_crs <- 3857
    points <- points %>% st_transform(dest_crs)
    observations <- observations %>% st_transform(dest_crs)
  }
  if (dest_crs == 3857){
    dest_crs <- 3857
    points <- points %>% st_transform(dest_crs)
    observations <- observations %>% st_transform(dest_crs)
  }
  if (st_crs(points)$epsg == "4326"){
    points <- points %>% st_transform(dest_crs)
  }
  if (st_crs(observations)$epsg == "4326"){
    observations <- observations %>% st_transform(dest_crs)
  }

  if(is.na(observations$id[[1]])){
    observations$id <- (1:length(observations$geometry))
  }

  # Defining datum for points
  points %<>% mutate(FIX_X = FALSE, FIX_Y = FALSE)

  points$FIX_X[points$Name %in% fix_x] <- TRUE
  points$FIX_Y[points$Name %in% fix_y] <- TRUE

  points %<>% mutate(Point_object = FALSE)
  points$Point_object[points$Name %in% points_object] <- TRUE

  # Observational plan - adding new columns
  observations %<>% mutate(from = NA,
                           to = NA,
                           distance = TRUE,
                           direction = TRUE,
                           standard_dir = st_dir,
                           standard_dist = st_dist
  )

  # Observational plan - defining and ading names for first and last points for observations
  # Creating data frame from sf class object observations, with goal to extract names for first and last points
  observations_1 <- data.frame(station = NA, obs.point = NA, x_station = NA,y_station = NA, x_obs.point = NA, y_obs.point = NA)

  # Line string to multipoint
  ob_plan_first_point <- st_line_sample(observations,sample = 0)
  ob_plan_last_point <- st_line_sample(observations,sample = 1)
  coord_1 <- as.data.frame(st_coordinates(ob_plan_first_point))
  coord_2 <- as.data.frame(st_coordinates(ob_plan_last_point))

  # Multipoint to point
  pnts_1 = st_cast(ob_plan_first_point, "POINT")
  pnts_2 = st_cast(ob_plan_last_point, "POINT")
  # X- East Y - North
  observations_1 <- data.frame(station = NA, obs.point = NA, x_station = st_coordinates(pnts_1)[,1], y_station = st_coordinates(pnts_1)[,2], x_obs.point = st_coordinates(pnts_2)[,1], y_obs.point = st_coordinates(pnts_2)[,2])

  # Adding columns Names for stations and observation point with values from constraint exactly match coordinates
  # TODO srediti da radi i za y

  observations_1$station <- points$Name[match(observations_1$x_station, st_coordinates(points)[,1])]
  observations_1$obs.point <- points$Name[match(observations_1$x_obs.point, st_coordinates(points)[,1])]
  observations_1$id <- coord_1$L1

  observations$from <- observations_1$station[match(observations$id, observations_1$id)]
  observations$to <- observations_1$obs.point[match(observations$id, observations_1$id)]

  observations %<>% mutate(
    id = as.numeric(id),
    standard_dir = as.numeric(standard_dir),
    standard_dist = as.numeric(standard_dist),
    from = as.character(from),
    to = as.character(to)
  )

  points %<>% mutate(
    Name = as.character(Name)
  )
  # Creating list
  survey_net <- list(points,observations)

  return(survey_net)
}

###############
# surveynet.kml
###############

# Parameters:
#    1. points -  sf object with geometry type POINT - geodetic network [Example: Data/Input/kml]
#    2. observations - sf object with geometry type LINESTRING [Example: Data/Input/kml]
#    3. fix_x - list with names of points that define datum - X coordinate
#    3. fix_y - list with names of points that define datum - Y coordinate
#    4. st_dir - "a priori" standard deviation for direction observations ["]
#    5. st_dist - "a priori" standard deviation for distance observations [mm]
#    6. dest_crs - destination Coordinate Reference System - set EPSG code [default: 3857 - Web Mercator projection coordinate system]
#    7. points_object - list with names of points that represnt object of interests

surveynet.kml <- function(points, observations, fix_x = list(), fix_y = list(), st_dir, st_dist, dest_crs = NA, points_object = list()){
  for(i in names(points)){
    if(i == "Naziv"){
      points <- points %>% rename("Name" = "Naziv")
    }
  }
  for(i in names(observations)){
    if(i == "Name"){
      observations <- observations %>% rename("id" = "Name")
    }
  }
  # If column "Description" is necessary, delete it;
  j=1
  for(i in names(points)){
    if (i == "Description"){
      points <- subset(points, select = -c(j))
    }
    j=j+1
  }

  j_1=1
  for(i in names(observations)){
    if (i == "Description"){
      observations <- subset(observations, select = -c(j_1))
    }
    j_1 = j_1 + 1
  }

  # TODO Check funkcija ide ovde

  # Check function for point names, that can not be just numbers -> must contain letter
  points$Name <- as.character(points$Name)
  vec <- c(1:99999)
  j = 1
  for(i in points$Name){
    if(i %in% vec){
      points$Name[j] <- paste("T",i, sep = "")
      j = j +1

    }
  }

  # Transformation to the destination CRS
  if (is.na(dest_crs)){
    dest_crs <- 3857
    points <- points %>% st_transform(dest_crs)
    observations <- observations %>% st_transform(dest_crs)
  }
  if (st_crs(points)$epsg == "4326"){
    points <- points %>% st_transform(dest_crs)
    message("\nPoints data are reprojected to the destination Coordinate Reference System!\n")
    message(st_crs(points))
  }
  if (st_crs(observations)$epsg == "4326"){
    observations <- observations %>% st_transform(dest_crs)
    message("\nObservation data are reprojected to the destination Coordinate Reference System!\n")
    message(st_crs(observations))
  }

  # Handling with some columns
  for(i in names(points)){
    if(i == "id"){
      break
    } else {
      points$id <- (1:length(points$geometry))
    }
  }

  for(i in names(observations)){
    if(i == "id"){
      observations$id <- (1:length(observations$geometry))
    }
  }
  # Defining datum for points
  points %<>% mutate(FIX_X = FALSE, FIX_Y = FALSE)

  points$FIX_X[points$Name %in% fix_x] <- TRUE
  points$FIX_Y[points$Name %in% fix_y] <- TRUE

  points %<>% mutate(Point_object = FALSE)
  points$Point_object[points$Name %in% points_object] <- TRUE

  # Observational plan - adding new columns
  observations %<>% mutate(distance = TRUE,
                           direction = TRUE,
                           standard_dir = st_dir,
                           standard_dist = st_dist,
                           from = NA,
                           to = NA)

  # Observational plan - defining and ading names for first and last points for observations
  # Creating data frame from sf class object observations, with goal to extract names for first and last points
  observations_1 <- data.frame(station = NA, obs.point = NA, x_station = NA,y_station = NA, x_obs.point = NA, y_obs.point = NA)

  # Line string to multipoint
  ob_plan_first_point <- st_line_sample(observations,sample = 0)
  ob_plan_last_point <- st_line_sample(observations,sample = 1)
  coord_1 <- as.data.frame(st_coordinates(ob_plan_first_point))
  coord_2 <- as.data.frame(st_coordinates(ob_plan_last_point))

  # Multipoint to point
  pnts_1 = st_cast(ob_plan_first_point, "POINT")
  pnts_2 = st_cast(ob_plan_last_point, "POINT")
  # X- East Y - North
  observations_1 <- data.frame(station = NA, obs.point = NA, x_station = st_coordinates(pnts_1)[,1], y_station = st_coordinates(pnts_1)[,2], x_obs.point = st_coordinates(pnts_2)[,1], y_obs.point = st_coordinates(pnts_2)[,2])

  # Adding columns Names for stations and observation point with values from constraint exactly match coordinates
  # TODO srediti da radi i za y
  observations_1$station <- points$Name[match(observations_1$x_station, st_coordinates(points)[,1])]
  observations_1$obs.point <- points$Name[match(observations_1$x_obs.point, st_coordinates(points)[,1])]
  observations_1$id <- coord_1$L1

  observations$from <- observations_1$station[match(observations$id, observations_1$id)]
  observations$to <- observations_1$obs.point[match(observations$id, observations_1$id)]

  observations %<>% mutate(
    id = as.numeric(id),
    standard_dir = as.numeric(standard_dir),
    standard_dist = as.numeric(standard_dist),
    from = as.character(from),
    to = as.character(to)
  )

  # Creating list
  survey_net <- list(points,observations)

  return(survey_net)
}

##################
# net_spatial_view
##################

# Function for spatial data visualisation trough package ggplot2
# Parameters:
#    1. points -  sf object with geometry type POINT and related attributes as product from surveynet.xxx function
#    2. observations - sf object with geometry type LINESTRING and related attributes as product from surveynet.xxx function

net_spatial_view <- function(points, observations){

  points$fill_p <- "red"
  points$fill_p[points$Point_object == TRUE] <- "DeepSkyBlue"

  # Example to add little different type of observations
  # observations$distance[1:3] <- FALSE
  # observations$direction[5:7] <- FALSE
  # observations$fill_o <- "LightGoldenRodYellow"

  observations$fill_o <- ifelse(observations$distance == TRUE & observations$direction == FALSE,"LightGoldenRodYellow", ifelse(observations$distance == FALSE & observations$direction == TRUE, "Khaki","orange"))

  net_view <- ggplot(data=observations) +
    geom_sf(size=1,stroke=1, color = observations$fill_o)+
    geom_sf(data=points, shape = 24, fill = points$fill_p, size=2.5, stroke=2) +
    geom_sf_text(data=points, aes(label=Name,hjust = 1.5, vjust =1.5))+
    xlab("\nLongitude [deg]") +
    ylab("Latitude [deg]\n") +
    ggtitle("Observational plan and points [geodetic network and object points]")+
    guides(col = guide_legend())+
    theme_bw()
  return(net_view)

}

##########################################
# net_spatial_view_web [package:: mapview]
##########################################

# Function for spatial data visualisation at web maps
# Parameters:
#    1. points -  sf object with geometry type POINT and related attributes as product from surveynet.xxx function
#    2. observations - sf object with geometry type LINESTRING and related attributes as product from surveynet.xxx function

net_spatial_view_web <- function(points, observations){
  Points <- st_transform(points, 4326)
  Observations <- st_transform(observations, 4326)

  Points$type <- "Geodetic network"
  Points$type[Points$Point_object == TRUE] <- "Points at object"

  Observations$type[Observations$distance == TRUE & Observations$direction == FALSE] <- "Distance"
  Observations$type[Observations$distance == FALSE & Observations$direction == TRUE] <- "Direction"
  Observations$type[Observations$distance == TRUE & Observations$direction == TRUE] <- "Both"

  web_map_1 <- mapview(Points, zcol = "type", col.regions = c("red","grey")) + mapview(Observations, zcol = "type")

  return(web_map_1)

}

###########
# check_net
###########

# Function for checking input data for errors - geometrical and topological consistency, redudancy etc.
# Parameters:
#    1. points -  sf object with geometry type POINT and related attributes as product from surveynet.xxx function
#    2. observations - sf object with geometry type LINESTRING and related attributes as product from surveynet.xxx function

check_net <- function(points, observations){

  observations_1 <- data.frame(station = NA,obs.point = NA, x_station = NA,y_station = NA,x_obs.point = NA,y_obs.point = NA)

  # Line string to multipoint
  pl_op_pocetne_tac <- st_line_sample(observations,sample=0)
  pl_op_krajnje_tac <- st_line_sample(observations,sample=1)
  koord_1 <- as.data.frame(st_coordinates(pl_op_pocetne_tac))
  koord_2 <- as.data.frame(st_coordinates(pl_op_krajnje_tac))

  # Multipoint to point
  pnts_1 = st_cast(pl_op_pocetne_tac, "POINT")
  pnts_2 = st_cast(pl_op_krajnje_tac, "POINT")
  # X- East Y - North
  observations_1 <- data.frame(station = NA,obs.point = NA, x_station = st_coordinates(pnts_1)[,1],y_station = st_coordinates(pnts_1)[,2],x_obs.point = st_coordinates(pnts_2)[,1],y_obs.point = st_coordinates(pnts_2)[,2])

  x1 <- match(observations_1$x_station, st_coordinates(points)[,1])
  x2 <- match(observations_1$x_obs.point, st_coordinates(points)[,1])
  y1 <- match(observations_1$y_station, st_coordinates(points)[,2])
  y2 <- match(observations_1$y_obs.point, st_coordinates(points)[,2])

  if(any(x1) == FALSE){
    message("\nX koordinate tacaka i tacaka stanica u planu opazanja se ne poklapaju.")
  } else {
    message("\nX koordinate tacaka i tacaka stanica u planu opazanja se poklapaju.")
  }
  if(any(x2) == FALSE){
    message("\nX koordinate tacaka i tacaka opazanja u planu opazanja se ne poklapaju.")
  } else {
    message("\nX koordinate tacaka i tacaka opazanja u planu opazanja se poklapaju.")
  }
  if(any(y1) == FALSE){
    message("\nY koordinate tacaka i tacaka stanica u planu opazanja se ne poklapaju.")
  } else {
    message("\nY koordinate tacaka i tacaka stanica u planu opazanja se poklapaju.")
  }
  if(any(y2) == FALSE){
    message("\nY koordinate tacaka i tacaka opazanja u planu opazanja se ne poklapaju.")
  } else {
    message("\nY koordinate tacaka i tacaka opazanja u planu opazanja se poklapaju.")
  }
  un1 <- data.frame(id = points$id)
  un1$Name <- as.data.frame(unique(points$Name))
  un2 <- as.data.frame(unique(observations$from))
  un3 <- as.data.frame(unique(observations$to))

  un1$station <- TRUE[match(un1$Name, un2)]
  un1$obs <- TRUE[match(un1$Name, un3)]

  if(any(un1$station) == FALSE){
    message("\nKao stanica u planu opazanja nije iskoriscena tacka:")
    return(un1$Name[match(un1$station, FALSE)])
  } else {
    message("\nSve points su iskoriscene kao stanice u planu opazanja.")
  }

  if(any(un1$obs) == FALSE){
    message("\nKao opazana tacka u planu opazanja nije iskoriscena tacka:")
    return(un1$Name[match(un1$obs, FALSE)])
  } else {
    message("\nSve points su opazane u planu opazanja.")
  }

}

###################
# surveynet.mapedit
###################

# Function for interactive adding points on web maps and storage as sf [Simple Feature]
surveynet.mapedit_add <- function(){
  created <- mapview() %>% editMap()
  return(created$finished)
}

# Function for visualisation trough mapview package
# Parameters:
#    1. points -  sf object with geometry type POINT and related attributes as product from function surveynet.mapedit_add

surveynet.mapedit_view <- function(points = points){
  Points <- mapview(points)
  return(Points)
}

# Function for preparing points - sf attribute table check
# Parameters:
#    1. points -  sf object with geometry type POINT and related attributes as product from function surveynet.mapedit_add

surveynet.mapedit_points <- function(points = points){
  j=1
  for(i in names(points)){
    if (i == "_leaflet_id"){
      points <- subset(points, select = -c(j))
    }
    j=j+1
  }
  j=1
  for(i in names(points)){
    if (i == "feature_type"){
      points <- subset(points, select = -c(j))
    }
    j=j+1
  }

  for(i in names(points)){
    if(i == "id"){
      break
    } else {
      points$id <- (1:length(points$geometry))
    }
  }
  points <- points %>% rename("Name" = "id")

  points$Name <- as.character(points$Name)
  vec <- c(1:99999)
  j = 1
  for(i in points$Name){
    if(i %in% vec){
      points$Name[j] <- paste("T",i, sep = "")
      j = j +1

    }
  }
  return(points)
}

# Function for creating observations from points - all
# Parameters:
#    1. points -  sf object with geometry type POINT and related attributes as product from function surveynet.mapedit_points

surveynet.mapedit_observations <- function(points = points){
  res = expand.grid(to = points$Name, from = points$Name) # combine values from two columns in all posible combinations
  res <- as.data.frame(res[!(res$to == res$from), ]) # delete rows with same values in two columns
  rownames(res) <- 1:nrow(res) # reorder index number of rows
  res <- res[ ,c("from","to")] # reorder columns
  return(res)
}

# Function for creating observations from points - edit and interactivly with CRUD [Create, Read, Update and Delete] functionalites edit observations
# Parameters:
#    1. points -  sf object with geometry type POINT and related attributes as product from function surveynet.mapedit_points
#    2. st_dir - "a priori" standard deviation for direction observations ["]
#    3. st_dist - "a priori" standard deviation for distance observations [mm]
#

surveynet.mapedit_observations_edit <- function(points = points, st_dir = st_dir, st_dist = st_dist){
  res = expand.grid(to = points$Name, from = points$Name) # combine values from two columns in all posible combinations
  res <- as.data.frame(res[!(res$to == res$from), ]) # delete rows with same values in two columns
  rownames(res) <- 1:nrow(res) # reorder index number of rows
  res <- res[ ,c("from","to")] # reorder columns
  observations <- res

  points$x <- st_coordinates(points)[,1]
  points$y <- st_coordinates(points)[,2]

  observations$x_station <- points$x[match(observations$from, points$Name)]
  observations$y_station <- points$y[match(observations$from, points$Name)]
  observations$x_obs.point <- points$x[match(observations$to, points$Name)]
  observations$y_obs.point <- points$y[match(observations$to, points$Name)]

  observations$id <- 1:nrow(observations)

  observations %<>% mutate(distance = TRUE,
                           direction = TRUE,
                           standard_dir = st_dir,
                           standard_dist = st_dist
  )
  return(observations)
}

# create complete sf object - points and observations
# Parameters:
#    1. points -  sf object with geometry type POINT and related attributes as product from function surveynet.mapedit_points
#    2. observations - sf object with geometry type LINESTRING and related attributes as product from function surveynet.mapedit_observations
#    3. fix_x - list with names of points that define datum - X coordinate
#    3. fix_y - list with names of points that define datum - Y coordinate
#    4. st_dir - "a priori" standard deviation for direction observations ["]
#    5. st_dist - "a priori" standard deviation for distance observations [mm]
#    6. dest_crs - destination Coordinate Reference System - set EPSG code [default: 3857 - Web Mercator projection coordinate system]
#    7. points_object - list with names of points that represnt object of interests

surveynet.mapedit <- function(points_raw = points_raw, points = points, observations = observations, dest_crs = NA){

  if (is.na(dest_crs)){
    dest_crs <- 3857
    points_raw %<>% st_transform(dest_crs)
  } else{
    points_raw %<>% st_transform(dest_crs)
  }

  #if (st_crs(points)$epsg == 4326){
  #  dest_crs <- 3857
  #  points <- points %>% st_transform(dest_crs)
  #  message("\nPoints data are reprojected to the destination Coordinate Reference System!\n")
  #  message(st_crs(points))
  #}

  #Defining datum for points
  points %<>% mutate(FIX_X = FALSE, FIX_Y = FALSE)

  points$FIX_X[points$Name %in% fix_x] <- TRUE
  points$FIX_Y[points$Name %in% fix_y] <- TRUE

  points %<>% mutate(Point_object = FALSE)
  points$Point_object[points$Name %in% points_object] <- TRUE

  points$FIX_X <- as.logical(points$FIX_X)
  points$FIX_Y <- as.logical(points$FIX_Y)
  points$Point_object <- as.logical(points$Point_object)

  observations$x_station <- points$x[match(observations$from, points$Name)]
  observations$y_station <- points$y[match(observations$from, points$Name)]
  observations$x_obs.point <- points$x[match(observations$to, points$Name)]
  observations$y_obs.point <- points$y[match(observations$to, points$Name)]

  observations$id <- as.numeric(1:nrow(observations))

  observations %<>% mutate(distance = distance,
                           direction = direction,
                           standard_dir = standard_dir,
                           standard_dist = standard_dist
  )

  dt <- as.data.table(observations)
  dt_1 <- dt[
    , {
      geometry <- sf::st_linestring(x = matrix(c(x_station, x_obs.point, y_station, y_obs.point), ncol = 2))
      geometry <- sf::st_sfc(geometry)
      geometry <- sf::st_sf(geometry = geometry)
    }
    , by = id
    ]

  dt_1 <- sf::st_as_sf(dt_1)

  dt_1 %<>% mutate(from = as.character(observations$from),
                   to = as.character(observations$to),
                   distance = observations$distance,
                   direction = observations$direction,
                   standard_dir = observations$standard_dir,
                   standard_dist = observations$standard_dist
  )

  dt_1 <- dt_1 %>% sf::st_set_crs(dest_crs)
  observations <- dt_1

  # Observational plan - adding new columns
  observations %<>% mutate(distance = distance,
                           direction = direction,
                           standard_dir = as.numeric(standard_dir),
                           standard_dist = as.numeric(standard_dist)
  )

  points <- subset(points, select = -c(x,y))
  # Creating list
  survey_net_mapedit <- list(points,observations)

  return(survey_net_mapedit)
}

##########################################
# adj.net_spatial_view_web [package:: mapview]
##########################################

# Function for adjusted net data visualisation at web maps
# Parameters:
#    1. ellipses -  sf object with geometry type POLYGON and related attributes as product from design.snet function that represents error ellipses
#    2. observations - sf object with geometry type LINESTRING and related attributes as product from design.snet function

adj.net_spatial_view_web <- function(ellipses = ellipses, observations = observations){
  Ellipses <- st_transform(ellipses, 4326)
  Observations <- st_transform(observations, 4326)
  web_map_2 <- mapview(Ellipses, zcol = "sp") + mapview(Observations, zcol = "rii")
  return(web_map_2)
}

######################
# adj.net_spatial_view
######################

# Function for spatial data visualisation trough package ggplot2
# Parameters:
#    1. ellipses -  sf object with geometry type POLYGON and related attributes as product from design.snet function that represents error ellipses
#    2. observations - sf object with geometry type LINESTRING and related attributes as product from design.snet function

#adj.net_spatial_view <- function(ellipses = ellipses, observations = observations){
#  #observations$fill_o <- ifelse(observations$distance == TRUE & observations$direction == FALSE,"LightGoldenRodYellow", ifelse(observations$distance == FALSE & observations$direction == TRUE, "Khaki","orange"))
#  adj.net_view <- ggplot(data=observations) +
#    geom_sf(data = observations)+
#    geom_sf(data=ellipses,aes(fill = sp))+
#    geom_sf_text(data=ellipses, aes(label=Name,hjust = 2.5, vjust =2.5))+
#    xlab("\nLongitude [deg]") +
#    ylab("Latitude [deg]\n") +
#    ggtitle("Adjusted observational plan - net quality")+
#    guides(col = guide_legend())+
#    theme_bw()
#  return(adj.net_view)
#
#}

adj_net_spatial_view <- function(adj.ellipses, adj.observations){
  adj.net_view <- ggplot() +
    geom_sf(data = adj.observations)+
    geom_sf(data=adj.ellipses, aes(fill = sp))+
    geom_sf_text(data=adj.ellipses, aes(label=Name,hjust = 2.5, vjust =2.5))+
    xlab("\nLongitude [deg]") +
    ylab("Latitude [deg]\n") +
    ggtitle("Adjusted observational plan - net quality")+
    #guides(col = guide_legend())+
    theme_bw()
  return(adj.net_view)
}


argot2gaf <- function(in_files,config){
    print("Reading the input file")
    gaf_date = format(Sys.time(),"%Y%m%d")
    tmp_out = lapply(in_files,function(infile){
        tmp_data = fread(infile,sep = "\t",header = T)
        colnames(tmp_data) = gsub("#","",colnames(tmp_data))
        tmp_data
    })
    argot2_data = do.call(rbind,tmp_out)
    argot2_data = argot2_data[!grep("#",`SeqID`)]
    taxon_txt=paste("taxon:",config$input$taxon,sep="")

    gaf_cols=fread(config$data$go$gaf_cols,header = F)$V1
    gaf_cols

    print("Converting to GAF 2.0")
    gaf_data = argot2_data[,.(`SeqID`,`GO ID`,`Int. Confidence`)]
    colnames(gaf_data) = c("db_object_id","term_accession","with")

    gaf_data$with = as.numeric(gaf_data$with)
    min_score=min(gaf_data$with)
    max_score=max(gaf_data$with)
    gaf_data$with = (gaf_data$with - min_score)/(max_score - min_score)

    obo_data = check_obo_data(config$data$go$obo)
    aspect = unlist(obo_data$aspect[gaf_data$term_accession])
    gaf_data[,aspect:=aspect]

    #gaf_data[,db_object_id:=tmp]

    gaf_data[,db_object_symbol:=db_object_id]
    gaf_data[,taxon:=taxon_txt]
    gaf_data[,date:=gaf_date]
    gaf_data[,assigned_by:="Argot2.5"]

    return(gaf_data)
    # print("Writing the outfile")
    # write_gaf(gaf_data,out_file)
}


# Remove variables
rm(list=ls())

# Add some helper functions
source("chartr-FitRoutines.r")
source("chartr-HelperFunctions.r")

# Which job number to run, this tells you the run number
jobnum=1
set.seed(jobnum)
fnam = letters[jobnum];

# source the fitting code files
dirs="caseStudy2"  # directory name of data files to fit
resultDir = "caseStudy2_Fits/"

subjs=dir(dirs);
nsubj=length(subjs)
listOfSubjects = subjs;

# Setup some baseline parameters
contp = list(p=0)  # if estcontp==FALSE, give proportion of contaminant responses
maxits = 750  # number of iterations of DEoptim to run
nparticles = 400  # number of particles/chains for DEoptim
nmc =10000  # number of MC samples for simulating the models at each iteration
estcontp=FALSE  # estimate contaminant mixture probability from data. usually set to false

bailouttime=4  # time after which to bail out of diffusion sims, in seconds
maxTimeStep=as.double(length(seq(0,bailouttime,.001)))   # max iterations for fitting routine, then bail out
pred=F  # generate model predictions from fitting routine (only use this once you have estimtated parameters from data using DEoptim)

nreps = 5;
gub=4

subjnam="Subj1"

load(paste(dirs,"/",subjnam,sep=""))
model= "DDM"
saveFileName=paste(resultDir,subjnam,"-",model,"-",fnam,sep="")

# for simple switching in fitting routine
qps=as.numeric(dimnames(dat$q)[[1]])
ncohs=1:dim(dat$q)[3]

# make parameter vector - different scaling for Stone and Stone+UGM
#    order: drifts (7), eta, upper boundary, Ter
nds=length(ncohs)

actualParams = paramsandlims(model, nds)
fitUGM = unname(actualParams$fitUGM)
lowers = actualParams$lowers
uppers = actualParams$uppers
parnames = actualParams$parnames

stepsize=ifelse(fitUGM < 0,.001,1)  # time step for diffusion process: .001s (Stone), 1ms (UGM)
stoch.s=ifelse(fitUGM < 0,.1,100)   # diffusion constant
timecons=ifelse(fitUGM < 0,0,100)   # time constant for low pass filter
usign=ifelse(fitUGM < 0,0,1)        # scaling value for linear urgency function (usign=1 is linear with time). EAM needs usign=0, timecons=0
# cutoff for very slow RTs
# gub = global upper bound in seconds - no RTs should be slower than this (and none were in data)

print("Starting optimization ...")
library(DEoptim)
system.time({
  tmp=DEoptim(
    fn=obj,
    lower=lowers,
    upper=uppers,
    dat=dat,
    nmc=nmc,
    contp=contp,
    ncohs=ncohs,
    fitUGM=fitUGM,
    gub=gub,
    pred=FALSE,
    qps=qps,
    stepsize=stepsize,
    stoch.s=stoch.s,
    timecons=timecons,
    usign=usign,
    parnames=parnames,
    maxTimeStep=maxTimeStep,
    control=DEoptim.control(itermax=maxits,NP=nparticles,trace=TRUE,
                            parallelType=1,reltol=1e-6,steptol=200,
                            # load objects used for fitting, for parallelType==1
                            parVar=list("dat","lowers","uppers","nmc","contp","ncohs", "fitUGM","pred",
                                        "qps", "stepsize","stoch.s","timecons","usign","parnames","maxTimeStep","maxits","nparticles","gub",
                                        "diffusionC","makeparamlist","contaminantmixresps","qmpouts","getpreds","obj","returnListOfModels")
                            # same again, but for functions
    ))})
cat(paste("\n",dirs,"dataset:",subjnam,", model:",model,fnam,"\n\n",sep=" "))

out=tmp$optim$bestmem
names(out)=parnames
print(round(out,4))

print(round(tmp$optim$bestval,4))
# re-calculate obj for best fitting parameters, to determine amount of noise
# in the obj value for the best fit
mcsforpreds=50000
reobj=obj(x=tmp$optim$bestmem,dat=dat,nmc=mcsforpreds,
          contp=contp,ncohs=ncohs,fitUGM=fitUGM,gub=gub,pred=FALSE,
          qps=qps,stepsize=stepsize,stoch.s=stoch.s,timecons=timecons,usign=usign,
          parnames=parnames,maxTimeStep=maxTimeStep)
print(round(reobj,4))

# Now compute it for each level of quantile. Suspicion is that you go awry for the hardest coherences and you really need to think
# about what goes on there. Life is not easy there :)
mcsforpreds=50000
reobjperpoint=objPerQ(x=tmp$optim$bestmem,dat=dat,nmc=mcsforpreds,
                      contp=contp,ncohs=ncohs,fitUGM=fitUGM,gub=gub,pred=FALSE,
                      qps=qps,stepsize=stepsize,stoch.s=stoch.s,timecons=timecons,usign=usign,
                      parnames=parnames,maxTimeStep=maxTimeStep)
print(round(reobjperpoint,4))
out=list(dataset=subjnam,model=model,ndataset=fnam,pars=out,
         obj=-tmp$optim$bestval,reobj=-reobj, reobjperpoint=reobjperpoint)

save(out,file=saveFileName)


library(parallel)
library(dplyr)

###

source("functions.r")
load("../data/circles.rdata")
load("../data/efficiency_params.rdata")
load("../data/lfd_fit.rdata")
load("../data/containment.rdata")

params <- expand.grid(
	# infection characteristics
	prevalence = c(0.001, 0.01, 0.05),
	spread = c(0.8, 1, 3),
	containment = c("high", "conquest", "scs1"),

	# pooling characteristic
	pool_size = c(2, 3, 4, 5, 10, 15, 20, 25, 30),
	random_pooling = c(TRUE, FALSE),

	# costs
	cost_samplingkit = 3.47,
	cost_test = 12.46,
	replicates = c(1:100)
)

params$ct_max <- efficiency_params$par[1] # maximum ct value
params$ct_min <- efficiency_params$par[2] # minimum ct value
params$ct_alpha <- efficiency_params$par[3] # Beta distribution a parameter for ct
params$ct_beta <- efficiency_params$par[4] # Beta distribution b parameter for ct
params$e_alpha <- efficiency_params$par[5] # Beta distribution a parameter for efficiency
params$e_beta <- efficiency_params$par[6] # Beta distribution b parameter for efficiency
params$e_min <- 0.9 # Minimum PCR efficiency
params$e_max <- 1.4 # Maximum PCR efficiency
params$ctthresh <- 35 # Number cycles for detection
params$rct <- 100000 # Log Rct fluourescence detection value - arbitrary
params$pcr_fp <- 0.005 # Testing false positive rate (per test)
params$lfd_Asym <- lfd_fit$coef[1,1]
params$lfd_xmid <- lfd_fit$coef[2,1]
params$lfd_scal <- lfd_fit$coef[3,1]
params$lfd_fp <- 0.0032
params$lfd_cost <- 5

res <- mclapply(1:nrow(params), function(i) {
	message(i, " of ", nrow(params))
	x <- run_simulation(ids, params[i,], containment)
}, mc.cores=16) %>% bind_rows()

save(res, file="../results/sim.rdata")

i <- which(params$prevalence==0.05)[1]


#' hierarch_core.means_JAGS
#' Get site level means and sd from NEON data observed at the core scale.
#' Also return global mean and sd for a given predictor.
#' depends on the runjags package.
#'
#' @param x_mu         #vector of observations to modeled.
#' @param core_plot    #NEON plot IDs associated with x_mu observations.
#' @param n.adapt      #number of adaptive iterations. default 200.
#' @param n.burnin     #number of burnin iterations. default 1000.
#' @param n.sample     #number of sample iterations. default 1000.
#' @param n.chains     #number of MCMC chains. default 3.
#' @param parallel     #run chains in parallel or not? default F, notsetup to work yet.
#'
#' @return
#' @export
#'
#' @examples
hierarch_core.means_JAGS <- function(x_mu, core_plot,
                                n.adapt = 200, n.burnin = 1000, n.sample = 1000, n.chains = 3, parallel = F){

  #### specify JAGS model ####
  jags.model = "
  model {
  #get plot level means
  for(i in 1:N.core){
  core_mu[i] ~ dnorm(plot_mu[core_plot[i]], tau.plot[core_plot[i]])
  }

  #get site level means.
  for(i in 1:N.plot) {
  plot_mu[i] ~ dnorm(site_mu[plot_site[i]], tau.site[plot_site[i]])
  }

  #get global mean and uncertainty.
  for(i in 1:N.site){
  site_mu[i] ~ dnorm(global_mu, tau.glob)
  }

  #Plot level priors
  for(i in 1:N.plot){
  sigma.plot[i] ~ dunif(0, 100)
  tau.plot[i] <- pow(sigma.plot[i], -2)
  }
  #Site level priors
  for(i in 1:N.site) {
  sigma.site[i] ~ dunif(0, 100)
  tau.site[i] <- pow(sigma.site[i], -2)
  }
  #Global level priors
  global_mu ~ dnorm(0,1E-3)  I(0, ) #itnerval censored to be greater than zero.
  sigma.glob ~ dunif(0,100)
  tau.glob <- pow(sigma.glob, -2)

  }"

  #### setup JAGS data object. ####
  dat <- data.frame(x_mu,core_plot)
  dat <- dat[complete.cases(dat),]
  dat <- dat[order(dat$core_plot),]
  plot_site <- substring(unique(dat$core_plot),1,4)
  plot.names <- unique((dat$core_plot))
  site.names <- unique((plot_site))
  #reorder plot.names and site.names so it matches what they are going to be used as.
  plot.order <- order(plot.names)
  site.order <- order(site.names)
  plot.names <- as.character(plot.names[plot.order])
  site.names <- as.character(site.names[site.order])

  jags.data <- list(N.core = nrow(dat), N.plot = length(plot_site), N.site = length(unique(plot_site)),
                    core_mu = dat$x_mu, core_plot = droplevels(as.factor(dat$core_plot)), plot_site = droplevels(as.factor(plot_site)))

  #### fit JAGS model ####
  #runmode <- ifelse(parallel == T,T,F)
  mod  <- runjags::run.jags(model = jags.model,
                   data = jags.data,
                   monitor = c('plot_mu','site_mu','global_mu'),
                   adapt = n.adapt,
                   burnin = n.burnin,
                   sample = n.sample,
                   n.chains = n.chains)
  out <- summary(mod)
  plot.table <- data.frame(out[grep('plot_mu', rownames(out)),])
  plot.table$plotID <- plot.names
  site.table <- data.frame(out[grep('site_mu', rownames(out)),])
  site.table$siteID <- site.names
  glob.table <- data.frame(t(out[grep('global_mu', rownames(out)),]))

  #### return output ####
  output.list <- list(out,plot.table,site.table,glob.table)
  names(output.list) <- c('jags.summary','plot.table','site.table','glob.table')
  return(output.list)

}


#!/usr/bin/env Rscript

#Andrew Burt - a.burt@ucl.ac.uk

args <- commandArgs(trailingOnly=TRUE)
path_to_src <- args[1]
source(paste(path_to_src,"ols.r",sep=""))
source(paste(path_to_src,"bootstrap.r",sep=""))
source(paste(path_to_src,"crossvalidate.r",sep=""))
source(paste(path_to_src,"generateplots.r",sep=""))

caldata <- read.table(args[2],col.names=c("study","d","h","agb","rho"))
runs <- as.numeric(args[3])
ncpus <- as.numeric(args[4])
alpha <- as.numeric(args[5])
func <- log(agb) ~ log(d)
model <- fitOLS(caldata,func)
bresults <- bootOLS(caldata,func,runs,ncpus)
print(summary(model))
for(i in 1:length(coefficients(model)))
{
	b0_ci <- boot.ci(bresults,index=i,conf=0.95,type="perc")
	print(b0_ci)
}
cresults <- crossValidateOLS(caldata,func)
print("CROSS VALIDATION")
print("MSA, SSPBB")
print(cresults[[2]])


library(dplyr)
library(ggplot2)

directory <- "C:/Users/Martin Schonger/source/repos/crep_eval/log/"

timestamp <- "20190720-130621"
events <- read.csv(paste(directory, timestamp, "__events.csv", sep = "")) %>%
  select(c(time, num_nodes_base))

breaks <- seq(0,100000,1000)

events_proc <- events %>%
  mutate(interval = cut(time,
                        breaks,
                        include.lowest = TRUE,
                        right = TRUE)) %>%
  group_by(interval) %>%
  summarise(sum.num_nodes_base = sum(num_nodes_base))

events_proc[90:100,]

breaks_plot <- seq(0,100000,2500)
ploty <- ggplot(data = events_proc, aes(x = interval, y = sum.num_nodes_base)) +
  geom_line(group = 1) +
  theme_minimal()
ploty
ggsave(filename = paste(directory, timestamp, "__events_plot.pdf", sep = ""), plot = ploty)

events_for_plot <- data.frame("tstamp" = 1:100, "num_nodes_base" = events_proc[,2])


### Jitter plots for Case C - not separated by land use.

##### Jitter Plots: ######################################################################################################
  xlimits <- c(0, 4)
  plot(x=c(1:10), y=c(1:10), xlim=xlimits, ylim=ylimits, ylab=ParamList[i], type="n", xaxt="n", xlab="", log="y", xaxs="i",
      yaxs="i", main="\nJitter Plot", las=2, cex.axis=0.8)

  palette(c("violet", "purple", "gray80", "gray60"))

  if (nrow(ParamData) > 0) {
    if (nrow(ParamData) > 2) {
       jitterX <- sample(seq(from=0.05, to=3.95, length.out=nrow(ParamData)))
    } else {
       if (nrow(ParamData) == 2) {
         jitterX <- c(1.5, 2.5)
       } else {
         jitterX <- c(2)
       }
    }

    nonDetects <- ParamData[which(ParamData$nonDetect_Flag == 1),]
    if (nrow(nonDetects) > 0 ) {
      jitterX_ND <- jitterX[1:nrow(nonDetects)]
      segments(y0=rep(min(ylimits),nrow(nonDetects)), x0=jitterX_ND, y1=nonDetects$new_Result_Value,
                x1=jitterX_ND, col=3+nonDetects$WetSeason)
    }

    Detects <- ParamData[which(ParamData$nonDetect_Flag == 0),]
    if (nrow(Detects) >0 ) {
      jitterX_Det <- jitterX[nrow(nonDetects)+1:nrow(Detects)]
      points(y=Detects$new_Result_Value, x=jitterX_Det, pch=16, cex=1.2, col=1+Detects$WetSeason)
    }
  }  ## end if nrow(ParamData)

  box()

  percentCensor <- 100*nrow(nonDetects)/nrow(ParamData)
  percentCensor <- round(percentCensor, 1)
  axislabels <- paste(c("Randomized X"),
                      c("\nDet="),
                      c(nrow(ParamData)-nrow(nonDetects)),
                      c("\n ND="),
                      c(nrow(nonDetects)),
                      c("\n"),
                      percentCensor,
                      c("%"),
                      sep="")
  axis(side=1, at=c(2), labels=c(""))
  mtext(side=1, line=3.5, at=2, text=axislabels, adj=0.5, padj=0, cex=0.6)

  ymax <- par("usr")[4]
  ymin <- par("usr")[3]
  ymin_legend <- 10^(ymax + 0.01*(ymax-ymin))
  ymax_legend <- 10^(ymax + 0.22*(ymax-ymin))

  legend(x=c(2.6,4.3), y=c(ymin_legend, ymax_legend),
            legend=c("Detect-DrySeas", "Detect-WetSeas", "NonDetect-DrySeas", "NonDetect-WetSeas"),
            lty=c("blank", "blank", "solid", "solid"), pch=c(16,16,NA, NA), pt.cex=c(1.2,1.2,1.2,1.2),
            col=c("violet", "purple", "gray80", "gray60"), xpd=NA, cex=0.8, bty="o", bg="white")


rf <- RFclust.SGE ( dat=dat[,1:99], SGE=F, slices=1 )

# rf <- RFclust.SGE ( dat=cellexalObj@data, SGE=F, slices=1 )
#rf <- runRFclust ( rf, nforest=5)
#groups <- createGroups( rf, c( 2,4,6,8), name="RFrun" )

#expect_equal( dim(groups), c(100,6))

#rf <-  RFclust.SGE ( dat=dat, SGE=F, slices=2, name="SLURM", settings = list( A = "lsens2017-3-2", t="00:20:00" , slurm=T) )
rf <- runRFclust ( rf, nforest=500, ntree=500)

#rf <- RFclust.SGE ( dat=dat, SGE=F, slices=2 )
#rf <- runRFclust ( rf, nforest=5 )
g = c( 2,4,6,8,12)
groups <- createGroups( rf, g )
expect_equal( dim(groups), c(99,length(g)+2),label='group dimensions')

expect_equal( as.vector(apply( groups[,3:length(g)+2], 2, function(x) length(unique(x)) )), g, label="group complexity")

rf <- runRFclust ( rf, nforest=500, ntree=500, name="TEST")
groups2 <- createGroups( rf, g, name="TEST")

complexity = 7

A = groups[,complexity]
B = groups2[,complexity]

RandG <- function( a, b , n=1000) {
	lapply( 1:n, function(N){
		max(table( sample(a) ,sample(b)))
	})
}

t=table( A, B )
max = max(t)
randMax = unlist(RandG( A, B ))
p = length(which( randMax  >= max )) / 1000

expect_true( p < 3/1000 ,label="group overlap is fine for random data")

if ( FALSE ){
	rf <- RFclust.SGE ( dat=cellexalObj@data, SGE=F, slices=1 )

	start.time <- Sys.time()
	rf <- runRFclust ( rf, nforest=50, ntree=500, name="TEST")
	end.time <- Sys.time()

	time.taken <- end.time - start.time

	time.taken
	#Time difference of 6.941505 mins

	groups <- createGroups( rf, 40 , name="TEST")

	start.time <- Sys.time()
	rf <- runRFclust ( rf, nforest=50, ntree=500)
	end.time <- Sys.time()

	time.taken <- end.time - start.time

	time.taken
	#3.669606 mins

	groups2 <- createGroups( rf, 40 )

	A= groups[,3]
	B= groups2[,3]

	t=table( A, B )
	max = max(t)
	randMax = unlist(RandG( A, B ))
	p = length(which( randMax  >= max )) / 1000
	expect_true( p < 3/1000 ,label="group overlap is fine for random data")
}


[[[[[
   FUNDAMENTAL DECOMPOSITION
   We prove here that
      H(y|x) <= H_C(x,y) - H(x) + c
]]]]]

define (all-together x*)

let c debug 100 [constant to satisfy Kraft (see lemma)]

let x debug run-utm-on debug x*

let H-of-x debug length x*

[programs we've discovered that calculate pairs
 starting with x]
let programs nil

let (stage n)
    [generate requirements for all new programs we've
     discovered that produce (x y) pairs]
    let programs
        (add-to-set debug (halts? nil debug n) programs)
    (stage + n 1)

[at stage n = 0, 1, 2, 3, ...]
[look at all programs with <=n bits that halt within time n]
[returns list of all of them that produce pairs (x y)]
let (halts? p bits-left)
   let v try n C p [C is eval read-exp if C = U]
   if = success car v (look-at cadr v)
   if = 0 bits-left nil
   append (halts? append p cons 0 nil - bits-left 1)
          (halts? append p cons 1 nil - bits-left 1)

[returns (p) if C(p) = (x y), otherwise ()]
let (look-at v)
   if (and (is-pair v)
            = x car v ) cons p nil
      nil

[logical "and"]
let (and p q)
   if p q false

[is x a pair?]
let (is-pair? x)
   if atom x         false
   if atom cdr x     false
   if atom cdr cdr x true
                     false

[is an element in a set?]
let (is-in-set? element set)
   if atom set          false
   if = element car set true
   (is-in-set? element cdr set)

[forms set union avoiding duplicates,
 and makes requirement for each new find]
let (add-to-set new old)
   if  atom new  old
   let first-new car new
   let rest-new  cdr new
   if (is-in-set? first-new old) (add-to-set rest-new old)
   (do (make-requirement first-new)
       cons first-new (add-to-set rest-new old)
   )

[first argument discarded, done for side-effect only!]
let (do x y) y

[given new p such that C(p) = (x y),
 we produce the requirement for C_x
 that there be a program for y that is |p|-H(x)+c bits long]
let (make-requirement p)
   display cons cadr cadr try no-time-limit C p
           cons - + c length p H-of-x
                nil

let C ' [here eval read-exp gives U]
[test case special-purpose computer C here in place of U:]
[C(00100001) with x-1 and y-1 0's gives pair (x xy)]
[loop function gives number of bits up to next 1 bit]
   let (loop n)
      if = 1 read-bit n
      (loop + n 1)
   let x (loop 1)
   let y (loop 1)
   cons x cons * x y nil

[HERE GOES!]
(stage 0)

define      all-together
value       (lambda (x*) ((' (lambda (c) ((' (lambda (x) ((' (
            lambda (H-of-x) ((' (lambda (programs) ((' (lambda
             (stage) ((' (lambda (halts?) ((' (lambda (look-at
            ) ((' (lambda (and) ((' (lambda (is-pair?) ((' (la
            mbda (is-in-set?) ((' (lambda (add-to-set) ((' (la
            mbda (do) ((' (lambda (make-requirement) ((' (lamb
            da (C) (stage 0))) (' ((' (lambda (loop) ((' (lamb
            da (x) ((' (lambda (y) (cons x (cons (* x y) nil))
            )) (loop 1)))) (loop 1)))) (' (lambda (n) (if (= 1
             (read-bit)) n (loop (+ n 1)))))))))) (' (lambda (
            p) (display (cons (car (cdr (car (cdr (try no-time
            -limit C p))))) (cons (- (+ c (length p)) H-of-x)
            nil)))))))) (' (lambda (x y) y))))) (' (lambda (ne
            w old) (if (atom new) old ((' (lambda (first-new)
            ((' (lambda (rest-new) (if (is-in-set? first-new o
            ld) (add-to-set rest-new old) (do (make-requiremen
            t first-new) (cons first-new (add-to-set rest-new
            old)))))) (cdr new)))) (car new)))))))) (' (lambda
             (element set) (if (atom set) false (if (= element
             (car set)) true (is-in-set? element (cdr set)))))
            )))) (' (lambda (x) (if (atom x) false (if (atom (
            cdr x)) false (if (atom (cdr (cdr x))) true false)
            ))))))) (' (lambda (p q) (if p q false)))))) (' (l
            ambda (v) (if (and (is-pair v) (= x (car v))) (con
            s p nil) nil)))))) (' (lambda (p bits-left) ((' (l
            ambda (v) (if (= success (car v)) (look-at (car (c
            dr v))) (if (= 0 bits-left) nil (append (halts? (a
            ppend p (cons 0 nil)) (- bits-left 1)) (halts? (ap
            pend p (cons 1 nil)) (- bits-left 1))))))) (try n
            C p))))))) (' (lambda (n) ((' (lambda (programs) (
            stage (+ n 1)))) (add-to-set (debug (halts? nil (d
            ebug n))) programs))))))) nil))) (debug (length x*
            ))))) (debug (car (cdr (try no-time-limit (' (eval
             (read-exp))) (debug x*)))))))) (debug 100)))

define x* 3

define      x*
value       3

length bits x*

expression  (length (bits x*))
value       16

[give all-together x*]
try 60 cons cons "'
            cons all-together
            nil
       cons cons "'
            cons bits x*
            nil
       nil
    nil

expression  (try 60 (cons (cons ' (cons all-together nil)) (co
            ns (cons ' (cons (bits x*) nil)) nil)) nil)
debug       100
debug       (0 0 1 1 0 0 1 1 0 0 0 0 1 0 1 0)
debug       3
debug       16
debug       0
debug       ()
debug       1
debug       ()
debug       2
debug       ()
debug       3
debug       ()
debug       4
debug       ((0 0 1 1))
debug       5
debug       ((0 0 1 0 1) (0 0 1 1))
debug       6
debug       ((0 0 1 0 0 1) (0 0 1 0 1) (0 0 1 1))
debug       7
debug       ((0 0 1 0 0 0 1) (0 0 1 0 0 1) (0 0 1 0 1) (0 0 1
            1))
debug       8
debug       ((0 0 1 0 0 0 0 1) (0 0 1 0 0 0 1) (0 0 1 0 0 1) (
            0 0 1 0 1) (0 0 1 1))
debug       9
value       (failure out-of-time ((3 88) (6 89) (9 90) (12 91)
             (15 92)))

define x* 4

define      x*
value       4

length bits x*

expression  (length (bits x*))
value       16

[give all-together x*]
try 60 cons cons "'
            cons all-together
            nil
       cons cons "'
            cons bits x*
            nil
       nil
    nil

expression  (try 60 (cons (cons ' (cons all-together nil)) (co
            ns (cons ' (cons (bits x*) nil)) nil)) nil)
debug       100
debug       (0 0 1 1 0 1 0 0 0 0 0 0 1 0 1 0)
debug       4
debug       16
debug       0
debug       ()
debug       1
debug       ()
debug       2
debug       ()
debug       3
debug       ()
debug       4
debug       ()
debug       5
debug       ((0 0 0 1 1))
debug       6
debug       ((0 0 0 1 0 1) (0 0 0 1 1))
debug       7
debug       ((0 0 0 1 0 0 1) (0 0 0 1 0 1) (0 0 0 1 1))
debug       8
debug       ((0 0 0 1 0 0 0 1) (0 0 0 1 0 0 1) (0 0 0 1 0 1) (
            0 0 0 1 1))
debug       9
value       (failure out-of-time ((4 89) (8 90) (12 91) (16 92
            )))


################   visualization  #################
setwd(.WD)
source("functions.r")

n <- nrow(dat); p <- ncol(dat)
.gnum <- length(.ugrou)

cat("The attributes, or chemical parameters are:\n")
for (i in 1:p){ cat(i,.attri[i],'\t', fill=T)};
cat("\n Please press Enter key to continue...\n")
readline()

.stay0 <- 1
while(.stay0){
cat("for data visualization:\n")
cat("1. I want to apply to all columns\n")
cat("2. I want to select a subset of all columns\n")
cat("3. I want to drop a subset of all columns\n")
cat("4. exit\n")
.cho <- .scanf(1,c(1:4))
if(.cho == 4) .stay0 <- 0

else{
.stay1 <- 1
while(.stay1 == 1){
.chosen <- c(1:p)
if(.cho != 1){
cat("Which columns?\n")
.colAttr <- .scanf(1,c(1:p))
if(.cho == 2)  .chosen <- .colAttr
if(.cho == 3)  .chosen <- .chosen[-.colAttr]
}

.stay <- 1
while(.stay){
cat("********************* visualization ********************\n")
cat("\n 1. scattermatrix plot\n")
cat("\n 2. boxplot with outlier detection\n")
cat("\n 3. segment plot\n")
cat("\n 4. 3D scatter plot\n")
cat("\n 5. choose different columns\n")
cat("\n 6. exit\n")

.ans <- .scanf(1,c(1:6))

if(.ans == 5) .stay <- 0
if(.ans == 6) {.stay <- .stay1 <- 0}

if(.ans == 1) {
######################  scatterplot matrix  ##################
#palette(rainbow(.gnum))
.par0()
pairs(dat[.chosen], #panel=panel.smooth,
      diag.panel=.panelhist, #cex.labels = 1.5, font.labels = 2,
      pch = 21, bg = c(2:(length(.ugrou)+1))[unclass(.ngrou)])
if(.colGrou){
.tick <- 1/length(.ugrou)
mtext(.ugrou, side = 3, at = c(.5:(length(.ugrou)-.5))*.tick,
      line= 2.5, col = 2:(length(.ugrou)+1), font = rep(2,length(.ugrou)))
   }
cat("\n Please press Enter key to continue...\n")
readline()
pairs(dat[.chosen], lower.panel=panel.smooth,
       diag.panel=.panelhist, upper.panel=.panelcor)
if(.colGrou){
.tick <- 1/length(.ugrou)
mtext(.ugrou, side = 3, at = c(.5:(length(.ugrou)-.5))*.tick,
      line= 2.5, col = 2:(length(.ugrou)+1), font = rep(2,length(.ugrou)))
   }
.par0()
cat("\n Please press Enter key to continue...\n")
readline()
palette("default")
}

if(.ans == 2){
######################  boxplot  ##################
.subdat <- dat[.chosen]
.subattri <- .attri[.chosen]
.par0()
par(las=3, cex.axis=.7, font.axis=8)
.tmp2 <- range(.subdat); .tick <- (.tmp2[2] - .tmp2[1])/6
.tmp <- boxplot(.subdat,col='light blue',ylim=c(min(.subdat)-.tick,max(.subdat)+.tick))
.y = tapply(.tmp$out, .tmp$group, .maxa); .y <- .y-(1-sign(.y))*.tick*.2
with(.tmp,
     text(x = unique(.tmp$group)+1/length(unique(.tmp$group)), .y,
          labels = round(tapply(out, group, .maxa), 2),
          pos = 3, cex = .8))
.par0()
cat("Outlier detection:\n")
cat("\n Please press Enter key to continue...\n")
readline()
if(length(.tmp$out)==0) cat("No outlier detected!\n")
if(length(.tmp$out)==1) cat("The unique outlier detected is ", .sites[.tmp$out], "for attribute ", .tmp$names[.tmp$group], "\n")
if(length(.tmp$out)>1){
cat(.subattri[.tmp$group[1]],":","\t\t",.sites[dat[,.tmp$group[1]]==.tmp$out[1]])
for(j in 2:length(.tmp$out)){
if(.tmp$group[j]!=.tmp$group[j-1]) cat("\n",.subattri[.tmp$group[j]],":","\t\t")
else cat("\t")
.tmpsite <- .sites[.subdat[,.tmp$group[j]]==.tmp$out[j]]
cat(.tmpsite[1],sep = '\t\t')
}}
cat("\n\n Please press Enter key to continue...\n")
readline()
}

######################  segment plot  ##################
if(.ans == 3){
cat("Segment plots\n")
palette(rainbow(length(.chosen)))
.par0()
stars(dat[.chosen],labels=.sites,draw.segments=T,nrow=floor(sqrt(n))+1,
                                       len=.5, cex=.6, key.loc=c(-1,2.5))
.par0()
cat("\n Please press Enter key to continue...\n")
readline()
palette("default")
}

######################  3D visualization  ##################
if(.ans == 4){
.substay <- "y"
while(.substay == "y"){
cat("3d visualization:\n")
cat("\n Please press Enter key to continue...\n")
readline()
cat("The attributes are:\n")
print(cbind(.attri,c(1:p)))
cat("\n Please press Enter key to continue...\n")
readline()
cat("Please choose 3 attributes: \n")
.colAttr <- .scanf(1,c(1:p))
.gnum <- 2
if(.colGrou) .gnum <- length(.ugrou)
palette(rainbow(.gnum))
open3d()
plot3d(dat[.colAttr],col = .ngrou, size=10)
.rang <- range(dat[.colAttr[3]])[2]-range(dat[.colAttr[3]])[1]
if(.colGrou) text3d(rep(max(dat[.colAttr[1]]),.gnum),rep(max(dat[.colAttr[2]]),.gnum),
         rep(max(dat[.colAttr[3]]),.gnum)-c(1:.gnum)*.rang/20, text=paste(as.vector(.ugrou)),
         adj=c(1,1), color=c(1:.gnum), cex = .8)
cat("Do you want to impose the names of sites? y/n\n")
.sans <- .scanf(2)
if(.sans == "y") text3d(dat[.colAttr],text = paste(.sites),col = .ngrou, cex = .7)
.par0()
palette("default")
cat("Do you want to try other three attributes? y/n\n")
.substay <- .scanf(2)
         }
      }
     }
   }
}
}


library(rstan)
library(loo)
rstan_options(auto_write = TRUE);
options(mc.cores = parallel::detectCores());

plotProfileFit <- function(fit, data, targetSco, numSamples = 10) {
  true_value = extract(fit,'true_value')$true_value;

  samplesToPlot = true_value[sample(1:(dim(true_value)[1]),numSamples),];

  #Add the raw profile
  plotData = t(rbind(subset(data, sco ==targetSco)[,"val"], samplesToPlot));
  defaultWidth = 1;
  lineWidths = rep.int(1, numSamples + 1);
  lineWidths[1] = defaultWidth * 2;
  matplot(plotData, lwd = lineWidths,  type="l")
}

plotNoChangeFit <- function(fit, data, targetSco) {
  relevant_data = subset(data, sco==targetSco);
  minTime = min(relevant_data$time)
  maxTime = max(relevant_data$time)

  smmry = summary(fit)$summary;
  val_mean = smmry["true_value","mean"];
  val_25 = smmry["true_value","25%"];
  val_75 = smmry["true_value","75%"];
  val_2_5 = smmry["true_value","2.5%"];
  val_97_5 = smmry["true_value","97.5%"];

  ribbon1 = data.frame("x" = c(minTime,maxTime),"ymin" = c(val_2_5,val_2_5), "ymax" = c(val_97_5, val_97_5))
  ribbon2 = data.frame("x" = c(minTime,maxTime),"ymin" = c(val_25,val_25), "ymax" = c(val_75, val_75))
  ribbonAes = aes(x = x, ymin = ymin, ymax = ymax)

  ggplot(relevant_data) +
    geom_ribbon(mapping = ribbonAes, data = ribbon1, fill = "red", alpha = 0.3) +
    geom_ribbon(mapping = ribbonAes, data = ribbon2, fill = "darkred", alpha = 0.3) +
    geom_hline(yintercept = val_mean, color = "black", size = 2) +
    geom_ribbon(aes(x=time, ymin = val - sd, ymax = val + sd ), alpha = 0.3, fill = "blue") +
    geom_ribbon(aes(x=time, ymin = val - sd, ymax = val + sd ), alpha = 0.3, fill = "blue") +
    geom_line(aes(x=time, y=val))
}

plotSco <- function(data, targetSco) {
  relevant_data = subset(data, sco==targetSco);

  ggplot(relevant_data, aes(x=time, y=val, ymin = val - sd, ymax = val + sd )) + geom_ribbon(alpha = 0.3, fill = "blue") +  geom_line()
}

fitBySco <- function(long_data, target_sco, model='interpolate.stan', ...) {
  relevant_data = subset(long_data, sco == target_sco);
  relevant_data = relevant_data[sort.list(relevant_data$time),];

  #normalize time
  relevant_data$time = (relevant_data$time - min(relevant_data$time)) / (max(relevant_data$time) - min(relevant_data$time));

  data = list(numData = length(relevant_data$sco), y = relevant_data[,"val"], sigma = relevant_data[,"sd"], time = relevant_data[,"time"]);
  return(stan(file =model, data = data, ...));
}

compareFits <- function(data, target_sco) {
  ow <- options("warn");
  options(warn = 1);

  cat("No change fit\n");
  noChangeFit = fitBySco(data, target_sco, 'no-change.stan');
  print(plotNoChangeFit(noChangeFit, data, target_sco));

  cat("C. synth fit\n");
  csynthFit = fitBySco(data, target_sco, 'constant-synthesis-euler.stan', control=list(adapt_delta = 0.98), iter = 5000);
  print(plotProfileFit(csynthFit, data, target_sco));

  cat("Compare > 0 means csynth better");

  options(ow);
  compare(loo(extract_log_lik(noChangeFit)), loo(extract_log_lik(csynthFit)));
}


#' Plots a power spectrum and time series side-by-side, saving as a
#' PDF.
#'
#' @param power.spectrum Data frame containing freq and power.
#' @param time.series Data frame containing time and signal.
#' @param output Name of PDF output file.
#'
#' @export
plot.spectrum <- function(power.spectrum, time.series,
                          output = "spectrum_plot.pdf") {
    pdf(output)

    par(mfrow = c(1, 2))

    plot(power.spectrum$freq, Mod(power.spectrum$power)^2,
         type = "l", color = "blue")
    plot(time.series$time, time.series$signal,
         type = "l", color = "blue")

    dev.off()
}


library(ggplot2)
library(reshape)
library(rtracklayer)
library(effsize)

args = commandArgs(trailingOnly=TRUE)

in.bins.file <- args[1]
in.iap.file <- args[2]
outfile <- args[3]

df <- read.table(in.bins.file, sep='\t', header=T)
values <- df[, c('chr', 'start', 'end', 'Martire2019.ATAC.H33WT','Martire2019.ATAC.H33KO')]

iap.ranges <- import(in.iap.file)
bins.grang <- makeGRangesFromDataFrame(values, keep.extra.columns = T)
iap.bins <- subsetByOverlaps(bins.grang, iap.ranges, minoverlap=2500)
iap.df <- data.frame(mcols(iap.bins))

df.melted <- melt(values, id.vars=c('chr','start','end'))
iap.melted <- melt(iap.df)

p <- ggplot(df.melted, aes(x=variable, y=value)) +
  geom_violin(fill='#444444') +
  geom_jitter(data=iap.melted, aes(x=variable, y=value, color=variable), alpha=0.7) +
  ylab('ATAC-seq RPGC') +
  xlab('') +
  ggtitle('ATAC-seq 5kb bins H3.3 KO vd WT at IAP') +
  theme_classic() +
  theme(legend.position='none') +
  ylim(0,10)

ggsave(outfile, plot=p, dpi=300)

# Wilcoxon ranked sum test significance for global ATAC H33KO vs WT
wilcox.test(values$Martire2019.ATAC.H33KO, values$Martire2019.ATAC.H33WT)

# Wilcoxon ranked sum test significance for iap ATAC H33KO vs WT
wilcox.test(iap.df$Martire2019.ATAC.H33KO, iap.df$Martire2019.ATAC.H33WT)

# Effect sizes
cohen.d(iap.df$Martire2019.ATAC.H33KO, iap.df$Martire2019.ATAC.H33WT)
cohen.d(values$Martire2019.ATAC.H33KO, values$Martire2019.ATAC.H33WT)


#!/bin/Rscript
library("doParallel")
library("R.utils")
library("dplyr")
library("plyr")
library("ggplot2")
library("dplyr")
library("broom")
library("ggpubr")
library("Amelia")
library("mlbench")
library("corrplot")
library('ANN2')
library('randomForest')
library('tree')
library('caret')
library('party')

df <- read.csv("./data/weatherAUS.csv", header = TRUE, sep = ",", fill = TRUE)

n <- length(df[,1])
index <- sample(1:n,n,replace=FALSE)
df <- df[index,]

df[1:10,]

df[, "Date"] <- as.Date(df[, "Date"])
df[, "Location"] <- as.factor(df[, "Location"])
df[, "WindGustDir"] <- as.factor(df[, "WindGustDir"])
df[, "WindDir9am"] <- as.factor(df[, "WindDir9am"])
df[, "WindDir3pm"] <- as.factor(df[, "WindDir3pm"])
df[, "RainToday"] <- as.factor(df[, "RainToday"])
df[, "RainTomorrow"] <- as.factor(df [, "RainTomorrow"])
df["Cloud9am"][df["Cloud9am"] == 9] <- 8
df["Cloud3pm"][df["Cloud3pm"] == 9] <- 8

# # Deskriptive Analyse

parameters <- names(select_if(df, is.numeric))

dfmin <- subset(df, !is.na(df$RainToday) & !is.na(df$RainTomorrow))

for (x in parameters) {
  dfmin[x][is.na(dfmin[x])] <- mean(dfmin[, x], na.rm = TRUE)
}

levels(dfmin$WindGustDir) <- c(levels(dfmin$WindGustDir), "NOWIND")
levels(dfmin$WindDir9am) <- c(levels(dfmin$WindDir9am), "NOWIND")
levels(dfmin$WindDir3pm) <- c(levels(dfmin$WindDir3pm), "NOWIND")

dfmin$WindGustDir[is.na(dfmin[,"WindGustDir"])] <- "NOWIND"
dfmin$WindDir9am[is.na(dfmin[,"WindDir9am"])] <- "NOWIND"
dfmin$WindDir3pm[is.na(dfmin[,"WindDir3pm"])] <- "NOWIND"
dfmin$WindDir3pm

#Maschinelles Lernen versch. Verfahren

### Daten splitten in Test- und Trainingsdatensätze

## 75% of the sample size
smp_size <- floor(0.75 * nrow(dfmin))  ## set the seed to make your partition reproducible
set.seed(123)
train_ind <- sample(seq_len(nrow(dfmin)), size = smp_size)
train <- dfmin[train_ind, ]
test <- dfmin[-train_ind, ]

train[train$RainTomorrow %in% c("NaN", "NA", "Inf"), ]
summary(train)

x_names = c("Date",
            "Location",
            "MinTemp",
            "MaxTemp",
            "Rainfall",
            "Evaporation",
            "Sunshine",
            "WindGustDir",
            "WindGustSpeed",
            "WindDir9am",
            "WindDir3pm",
            "WindSpeed9am",
            "WindSpeed3pm",
            "Humidity9am",
            "Humidity3pm",
            "Pressure9am",
            "Pressure3pm",
            "Cloud9am",
            "Cloud3pm",
            "Temp9am",
            "Temp3pm",
            "RainToday")
y_names = c("RainTomorrow")

################################ DECISION TREE ################################################

tutData <- train[, !names(train) %in% c("Location","RainToday","Date","WindGustDir","WindDir9am","WindDir3pm")]
dateLess <- test[, !names(test) %in% c("Date")]
nohum <- train[, !names(train) %in% c("Date","Humidity9am","Humidity3pm","Pressure3pm", "Pressure9am","Cloud9am", "Cloud3pm")]
tre <- ctree(RainTomorrow ~ ., data = nohum)
png("nohum.png", res=35, height=1000, width=32767)
plot(tre)
dev.off()

pred <- predict(tre, test)
tPred <- table(pred, test$RainTomorrow)
acc <- (tPred[1,1] + tPred[2,2]) / sum(tPred)

rf.cv <- rfcv(trainx = test[, x_names], trainy = test[, y_names], cv.fold = 2, do.trace=TRUE)
summary(rf.cv)
rf.cv$error.cv


###############################################################################################################################################################
# Timetable Model
# Author Mufy
# Date 24/09/2016
# Description --  This script models the teaching hours per academic based on their teaching load.  The data for the model is extracted from the timetabling
#  spreadsheet.

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

#library(readxl)
library(xlsx)
require(xlsx)
#library(RODBC)
library(hashmap)

home.dr<- getwd()

#Set path to the timetable
setwd("/Users/mufy/Dropbox/teaching/UEL/2015-2016/timetable")

#Change the filename if changes or updated
file.name <- "CSI 2016-17-v10.xlsx"
sheet.name <- "ML"

tAllocation <- read.xlsx(file.name, 4, header=FALSE, keepFormulas=FALSE, startRow = 2, endRow =25)
timetable <- read.xlsx(file.name, 3, header=FALSE, keepFormulas=FALSE, startRow = 2, endRow =207)

# Get the current list of staff names
staffNames <- tAllocation[1]

#get all the teaching allocated staff names
allocatedStaffNamesOnTimetable <- timetable[12];

#List to hold all the calculated values

#TODO - Find a way to initilize
staffAllocationMap <-  hashmap("","")
staffAllocationMap$erase("")

clinicTime <- 2

# Function for calculating the teaching hours
calculateLectureHours <- function(semester, hours, npar=TRUE,print=TRUE){

	hourCalc <- 0

	#cat ("\n calc semester: ", semester, " : hours: ", hours, "\n")

	if (toString(semester) == "1 & 2"){

		hourCalc =	(2* hours * 24)/43
	#	cat ("\n hour calc: ", hourCalc, "\n")
		return (hourCalc)

        #Calculation for blocked mode
    }else if ((toString(semester) == "1B") | (toString(semester) == "2B")){

       cat ("\n calculating blocked mode lect hours : ", hours, "\n")

       hourCalc =	(2* hours * 5)/43
       return (hourCalc)
    }
    else{
		hourCalc =	(2*hours * 12)/43
	#	cat ("\n hour calc: ", hourCalc, "\n")
		return (hourCalc)

	}
}

#Function for calculating the tutorial hours
calculateTutorialHours <- function(semester, hours, npar=TRUE,print=TRUE){

	hourCalc <- 0

	if (semester == "1 & 2"){
		hourCalc <-	(1.5* hours * 24)/43

	}else if ((toString(semester) == "1B") | (toString(semester) == "2B")){

        cat ("\n calculating blocked mode tutorial hours : ", hours, "\n")

        hourCalc <-	(1.5* hours * 5)/43

    }else{
		hourCalc <-	(1.5* hours * 12)/43

	}

	return (hourCalc)
}

#Function to calculate module leadership hours
#TODO - Should take into account the module length, currently only module size
calculateModuleLeadership <- function(semester, moduleSize, npar=TRUE,print=TRUE){

	small <- 25
	medium <- 75

    sHour <- 1
    mHour <- 1.5
    lHour <- 2

    #cat ("\n module size: ", moduleSize, " semester: ", semester , "\n")

	if (as.numeric(moduleSize) < small) {

     if ((semester == "1 & 2") | (semester == "1B") | (semester == "2B")){
            return (sHour * 1)
        }else{

            return (sHour)
        }

	}else if ((as.numeric(moduleSize) >= small) & (as.numeric(moduleSize) < medium)){

    if ((semester == "1 & 2") | (semester == "1B") | (semester == "2B")){
            return (mHour * 1)
        }else{
            return (mHour)
        }
    }else{

        if ((semester == "1 & 2") | (semester == "1B") | (semester == "2B")){
            return (lHour * 1)
        }else{
            return (lHour)
        }
    }
}

#Function for removing leading and trailing spaces from names
#removeLeadingAndTrailingSpaces <- function (name){

#    nameWithoutSpaces < - gsub("^\\s+|\\s+$", "", name)
#    return nameWithoutSpaces
#}

# Funtion to print the teaching load summary
allocationSummary <- function (){

    cat ("\n############################### Summary ########################### \n")

    keys <- staffAllocationMap$keys()

    for (key in keys){

            cat ("staff: ", key, "  ====>  allocation: ", staffAllocationMap$find(key), "\n")
    }

    cat ("\n################################################################### \n")

}

#Main body of the script
#TODO -- Not very efficient algorithm, improve the algorith from 0(N^2) to (NLogN)
#IMPROVEMENT -- consider using HashMAP

for (i in 1: nrow (staffNames)){
	print (toString(staffNames[i,1]))

	totalAllocation <- 0
	totalModuleLeadership <-0

	for (j in 1: nrow(allocatedStaffNamesOnTimetable)) {
		if (toString(staffNames[i,1]) == toString(allocatedStaffNamesOnTimetable[j,1])){
			if (toString(timetable[j:j,4]) == "Lecture"){

				#calculate mornalized teaching time
				normalizedHours <- calculateLectureHours (toString(timetable[j:j,5]), (as.numeric(toString(timetable[j:j,9])))*24)
				totalAllocation <- totalAllocation + normalizedHours

				# calculate module leadership
				moduleLeadership <- calculateModuleLeadership(toString(timetable[j:j,5]), (as.numeric(toString(timetable[j:j,11]))))
				totalModuleLeadership <- totalModuleLeadership+ moduleLeadership;

				cat ("current lec allocation: ", normalizedHours, "total allocation: ",totalAllocation, " module code: ",toString(timetable[j:j,2]), "module size:", (as.numeric(toString(timetable[j:j,11]))),  " ;semester: ", toString(timetable[j:j,5]), "; hours: ", (as.numeric(toString(timetable[j:j,9])))*24, "module leadership: ", moduleLeadership, "\n")
			}else{

				normalizedHours <- calculateLectureHours (toString(timetable[j:j,5]), (as.numeric(toString(timetable[j:j,9])))*24)
				totalAllocation <- totalAllocation + normalizedHours

				cat ("current tut allocation: ", normalizedHours, "total allocation: ",totalAllocation, " module code: ",toString(timetable[j:j,2]), "module size:", (as.numeric(toString(timetable[j:j,11]))), " ;semester: ", toString(timetable[j:j,5]), "; hours: ", (as.numeric(toString(timetable[j:j,9])))*24, "\n")
			}

			#Handle joint module leaders
		}else{

			if (regexpr("/", toString(allocatedStaffNamesOnTimetable[j,1]))[1]!=-1){
				namesList <- unlist(strsplit(toString(allocatedStaffNamesOnTimetable[j,1]), "/"))

				for (k in 1: length(namesList)){

					if (toString(staffNames[i,1]) == namesList[k]){
						if (toString(timetable[j:j,4]) == "Lecture"){

							#calculate mornalized teaching time
							normalizedHours <- calculateLectureHours (toString(timetable[j:j,5]), ((as.numeric(toString(timetable[j:j,9])))*24)/length(namesList))
							totalAllocation <- totalAllocation + normalizedHours

								cat ("Shared current lec allocation: ", normalizedHours, "total allocation: ",totalAllocation, " module code: " , toString(timetable[j:j,2]), "module size:", (as.numeric(toString(timetable[j:j,11]))), " ;semester: ", toString(timetable[j:j,5]), "; hours: ", (as.numeric(toString(timetable[j:j,9])))*24, "\n")

							# calculate module leadership, only the first person is the module leader
							if (k ==1){
								moduleLeadership <- calculateModuleLeadership(toString(timetable[j:j,5]), (as.numeric(toString(timetable[j:j,11]))))
								totalModuleLeadership <- totalModuleLeadership+ moduleLeadership;

								cat ("Shared current lec allocation, with module leadership: ", normalizedHours, "total allocation: ",totalAllocation, " module code: " , toString(timetable[j:j,2]), "module size:", (as.numeric(toString(timetable[j:j,11]))), " ;semester: ", toString(timetable[j:j,5]), "; hours: ", (as.numeric(toString(timetable[j:j,9])))*24, "module leadership: ", moduleLeadership, "\n")
							}
						}else{

							normalizedHours <- calculateLectureHours (toString(timetable[j:j,5]), ((as.numeric(toString(timetable[j:j,9])))*24)/length(namesList))
							totalAllocation <- totalAllocation + normalizedHours

							cat ("Shared current tut allocation: ", normalizedHours, "total allocation: ",totalAllocation, " module code: " ,toString(timetable[j:j,2]),  "module size:", (as.numeric(toString(timetable[j:j,11]))), " ;semester: ", toString(timetable[j:j,5]), "; hours: ", (as.numeric(toString(timetable[j:j,9])))*24, "\n")
						}
                    # match the joint lecturer, not further entries on the list required
					break
					}
				}
			}
		}
	}

	totalAllocation <- totalAllocation + totalModuleLeadership + clinicTime;
    totalAllocationWithoutML <-totalAllocation - totalModuleLeadership;

 	cat (" Total face-to-face time allocation for :'", toString(staffNames[i,1]), "' with module leadership (",totalModuleLeadership, ") and teaching time (",totalAllocationWithoutML,") is: ", totalAllocation, "\n")

    staffAllocationMap$insert(toString(staffNames[i,1]),totalAllocation)

    totalAllocation <- 0
	totalModuleLeadership <-0

}

allocationSummary()

#Set the homedirect to the default working directory
setwd(home.dr)


#' Calculate the total Amazon costs associated with running Snowplow X months ahead
#'
#' @param uniquesPerMonth The number of unique visitors to website(s) per month (integer)
#' @param eventsPerMonth The number of events per month tracked (integer)
#' @param runsPerDay The number of times per day that enrichment process is run (generally 1-24) (integer)
#' @param storageDatabase The type of database used to store Snowplow data. This *MUST* either be 'redshift' or 'postgres'
#' @param numberOfMonths number of months ahead that the model should project costs (e.g. 12 or 36)
#' @param edgeLocations The number of different locations in Amazon's Cloudfront network that each generate an independent log when hit. We believe this number is between 10000 and 100000, but are not sure. (This has an impact on S3 costs)
#'
#' @export
snowplowCostByMonth <- function(uniquesPerMonth, eventsPerMonth, runsPerDay, storageDatabase, numberOfMonths, edgeLocations){

	month <- seq(1, numberOfMonths, by=1)

	# Snowplow cost is made up of Cloudfront, S3, EMR and database (Redshift / storage) costs
	cloudfrontCost <- cfCostPerMonth(eventsPerMonth, uniquesPerMonth)
	s3Cost <- s3CostByMonth(eventsPerMonth, runsPerDay, edgeLocations, numberOfMonths)
	emrCost <- emrCostPerMonth(eventsPerMonth, runsPerDay)
	databaseCost <- databaseCostByMonth(storageDatabase, eventsPerMonth, numberOfMonths)

	# Combine above 4 costs in a single data frame:
	snowplowCost <- data.frame(month, cloudfrontCost, s3Cost, emrCost, databaseCost)
	snowplowCost$totalCost <- snowplowCost$cloudfrontCost + snowplowCost$s3Cost + snowplowCost$emrCost + snowplowCost$databaseCost

	# Now return the completed data frame
	snowplowCost
}


#!/usr/bin/Rscript

# helper functions

nan.to.zero <- function(n) {
    if (is.nan(n)) return(0) else return(n)
}

# get the input VCF tabular format, assert that sites must have AC > 0
vcf <- subset(read.table(pipe('cat /dev/stdin'), header=T), AC > 0)

filename <- commandArgs(TRUE)[1]
tag <- commandArgs(TRUE)[2]

tag.genotypes_count <- paste(tag, '.genotypes.alternate_count', sep='')
tag.genotypes_alternate_count <- paste(tag, '.genotypes.alternate_count', sep='')
tag.non_reference_discrepancy_count <- paste(tag, '.site.non_reference_discrepancy.count', sep='')
tag.non_reference_discrepancy_normalizer <- paste(tag, '.site.non_reference_discrepancy.normalizer', sep='')
tag.non_reference_sensitivity_count <- paste(tag, '.site.non_reference_sensitivity.count', sep='')
tag.non_reference_sensitivity_normalizer <- paste(tag, '.site.non_reference_sensitivity.normalizer', sep='')
tag.alternate_positive_discrepancy <- paste(tag, '.site.alternate_positive_discrepancy', sep='')
tag.alternate_negative_discrepancy <- paste(tag, '.site.alternate_negative_discrepancy', sep='')
tag.has_variant <- paste(tag, '.has_variant', sep='')

vcf.numberOfSites <- length(vcf[, tag.genotypes_alternate_count])
vcf.totalAltAlleles <- sum(vcf[, tag.genotypes_alternate_count])
vcf.positiveDiscrepancy <- sum(vcf[, tag.alternate_positive_discrepancy]) / sum(vcf[, tag.genotypes_alternate_count])
vcf.negativeDiscrepancy <- sum(vcf[, tag.alternate_negative_discrepancy]) / sum(vcf[, tag.genotypes_alternate_count])
vcf.sitesTruePositive <- mean(vcf[, tag.has_variant])

min_sites <- 5  # number of sites required for "simple plotting"

#library(ggplot2)
#vcf2 <- data.frame(QUAL=vcf$QUAL, AC=vcf$AC, has_variant=vcf[, tag.has_variant])
#qplot(AC, has_variant, group=AC, geom="boxplot", data=subset(vcf2, AC <= 20))
#ggsave(paste(filename, '.', tag, '.PD.vs.AC.boxplot.ac_lt_20.pdf', sep=''))

cat('number of sites', vcf.numberOfSites, '\n')
cat('total alternate alleles', vcf.totalAltAlleles, '\n')
cat('positive discrepancy', vcf.positiveDiscrepancy, '\n')
cat('negative discrepancy', vcf.negativeDiscrepancy, '\n')

#x <- cbind(tapply(vcf, as.list(seq(0,max(vcf$AC))),
#    function(x) {
#        sum(x[, tag.alternate_positive_discrepancy]) / sum(x[, tag.genotypes_alternate_count])
#    }))

byac <- data.frame(ac=as.vector(seq(1,max(vcf$AC)))) #, fdr=as.vector(x))

byac$fdr <- as.vector(cbind(by(byac$ac, byac$ac,
    function(x) {
        s <- subset(vcf, AC == x)
        return(nan.to.zero(sum(s[, tag.alternate_positive_discrepancy]) / sum(s[, tag.genotypes_alternate_count])))
    })))

# false detection count
byac$fpc <- as.vector(cbind(by(byac$ac, byac$ac,
    function(x) {
        s <- subset(vcf, AC == x)
        return(sum(s[, tag.alternate_positive_discrepancy]))
    })))

byac$alleles <- as.vector(cbind(by(byac$ac, byac$ac,
    function(x) {
        s <- subset(vcf, AC == x)
        return(sum(s[, tag.genotypes_alternate_count]))
    })))

byac$sites <- as.vector(cbind(by(byac$ac, byac$ac,
    function(x) {
        s <- subset(vcf, AC == x)
        return(length(s$AC))
    })))

# count true positive sites
byac$site_tpc <- as.vector(cbind(by(byac$ac, byac$ac,
    function(x) {
        s <- subset(vcf, AC == x)
        return(sum(s[, tag.has_variant]))
    })))

# fpc == false detection count
byac$site_fpc <- byac$sites - byac$site_tpc
# site detection fpr is 1 - true positive rate
byac$site_fpr <- 1 - ( byac$site_tpc / byac$sites )

summary(byac)

#print(byac$sites)
#print(byac$site_tpc)
#print(byac$site_fpc)
#print(byac$site_fpr)

#byac$site_fpr_gt0 <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) {
#    s <- subset(byac, ac == i, select=c(site_fpr, sites))
#if (s$sites >= min_sites) {
#    return(s$site_fpr)
#} else {
#    return(NA)
#}
#})))

#byac$site_fprlt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) mean(subset(byac, ac <= i, select=site_fpr)))))
byac$site_fprlt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) {
    s <- subset(byac, ac <= i, select=c(site_fpc, sites))
    return(sum(s$site_fpc) / sum(s$sites))
})))

#byac$site_fprgt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) mean(subset(byac, ac >= i, select=site_fpr)))))
byac$site_fprgt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) {
    s <- subset(byac, ac >= i, select=c(site_fpc, sites))
    return(sum(s$site_fpc) / sum(s$sites))
})))

byac$cfa <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) sum(subset(byac, ac <= i, select=alleles)) / sum(byac$alleles))))

byac$cfs <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) sum(subset(byac, ac <= i, select=sites)) / length(vcf$AC))))

# inappropriate collapse via averaging of fdr
#byac$alternate_pdlt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) mean(subset(byac, ac <= i, select=fdr)))))

byac$alternate_pdr <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) {
    s <- subset(byac, ac == i, select=c(fpc, alleles))
    return(sum(s$fpc) / sum(s$alleles))
})))

# use this one
byac$alternate_pdlt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) {
    s <- subset(byac, ac <= i, select=c(fpc, alleles))
    return(sum(s$fpc) / sum(s$alleles))
})))

#byac$alternate_pdgt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) mean(subset(byac, ac >= i, select=fdr)))))
byac$alternate_pdgt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) {
    s <- subset(byac, ac >= i, select=c(fpc, alleles))
    return(sum(s$fpc) / sum(s$alleles))
})))

byac$nrs <- as.vector(cbind(by(byac$ac, byac$ac,
    function(x) {
        s <- subset(vcf, AC == x)
        return(nan.to.zero(sum(s[, tag.non_reference_sensitivity_count]) / sum(s[, tag.non_reference_sensitivity_normalizer])))
    })))

byac$nrd <- as.vector(cbind(by(byac$ac, byac$ac,
    function(x) {
        s <- subset(vcf, AC == x)
        return(nan.to.zero(sum(s[, tag.non_reference_discrepancy_count]) / sum(s[, tag.non_reference_discrepancy_normalizer])))
    })))

byac$nrslt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) {
    s <- subset(vcf, AC <= i, select=c(tag.non_reference_sensitivity_count, tag.non_reference_sensitivity_normalizer))
    return(nan.to.zero(sum(s[, tag.non_reference_sensitivity_count]) / sum(s[, tag.non_reference_sensitivity_normalizer])))
})))

byac$nrdlt <- as.vector(cbind(tapply(byac$ac, byac$ac, function(i) {
    s <- subset(vcf, AC <= i, select=c(tag.non_reference_discrepancy_count, tag.non_reference_discrepancy_normalizer))
    return(nan.to.zero(sum(s[, tag.non_reference_discrepancy_count]) / sum(s[, tag.non_reference_discrepancy_normalizer])))
})))

byac_gtsites <- subset(byac, sites >= min_sites)

if (FALSE) {
pdf(paste(filename, '.', tag, '.PD.vs.AC.smooth.pdf', sep=''))
par(cex=0.75)
par(mar=c(5,4,4,5) + 0.1)
plot(byac$cfa, ylim=c(0,1.0),
    xlab='alternate allele count (AC)', xaxt='n',
    ylab='', yaxt='n', type='l', col='red')
axis(2, at=seq(0,1,0.1), labels=seq(0,1,0.1))
axis(1, at=seq(0,max(byac$ac),10), labels=seq(0,max(byac$ac),10), cex=0.75)
grid(lty=5)
par(new=T)
title(paste(filename, 'positive discrepancy versus', tag, '(smoothed)'))
par(new=T)
countTicks <- seq(0,1,0.1) * vcf.numberOfSites
axis(4, at=seq(0,1,0.1), labels=round(countTicks))
mtext("number of sites", side=4, line=3, cex=0.75)
par(new=T)
#plot(byac$alternate_pdlt, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='green')
plot(byac$site_fpr, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n')
par(new=T)
lines(byac$ac, predict(loess(byac$alternate_pdr ~ byac$ac, span=0.5)), col="green")
par(new=T)
plot(byac$cfa, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='red')
par(new=T)
plot(byac$cfs, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='purple')
par(new=T)
lines(byac$ac, predict(loess(byac$site_fpr ~ byac$ac, span=0.5)), col="blue")
par(new=T)
lines(byac$ac, predict(loess(byac$nrs ~ byac$ac, span=0.5)), col="magenta")
par(new=T)
lines(byac$ac, predict(loess(byac$nrd ~ byac$ac, span=0.5)), col="brown")
par(new=T, cex=0.65)
mtext(paste("alternate genotype PD: ", round(vcf.positiveDiscrepancy, digits=4), ", site PD: ", round(1 - vcf.sitesTruePositive, digits=4), sep=''))
par(new=T, cex=0.65)
legend('topleft', c('cumulative fraction of alt alleles', 'cumulative fraction of sites', 'alt genotypes PD', 'site PD', 'non-ref sensitivity', 'non-ref discrepancy', 'site PD at AC'),
    fill=c('red', 'purple', 'green', 'blue', 'magenta', 'brown', 'black'))
garbage <- dev.off()
}

pdf(paste(filename, '.', tag, '.PD.vs.AC.cumulative.pdf', sep=''))
par(cex=0.75)
par(mar=c(5,4,4,5) + 0.1)
plot(byac$cfa, ylim=c(0,1.0),
    xlab='alternate allele count (AC)', xaxt='n',
    ylab='', yaxt='n', type='l', col='red')
axis(2, at=seq(0,1,0.1), labels=seq(0,1,0.1))
axis(1, at=seq(0,max(byac$ac),10), labels=seq(0,max(byac$ac),10), cex=0.75)
grid(lty=5)
par(new=T)
title(paste(filename, 'positive discrepancy versus', tag, '(cumulative)'))
par(new=T)
countTicks <- seq(0,1,0.1) * vcf.numberOfSites
axis(4, at=seq(0,1,0.1), labels=round(countTicks))
mtext("number of sites", side=4, line=3, cex=0.75)
par(new=T)
#plot(byac_gtsites$ac, byac_gtsites$site_fpr, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n')
plot(byac$site_fpr, ylim=c(0,1.0),  xlab='', xaxt='n', ylab='', yaxt='n')
par(new=T)
plot(byac$alternate_pdlt, ylim=c(0,1.0),  xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='green')
par(new=T)
plot(byac$cfa, ylim=c(0,1.0),  xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='red')
par(new=T)
plot(byac$cfs, ylim=c(0,1.0),  xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='purple')
par(new=T)
plot(byac$site_fprlt, ylim=c(0,1.0),  xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='blue')
par(new=T)
plot(byac$nrslt, ylim=c(0,1.0),  xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='magenta')
par(new=T)
plot(byac$nrdlt, ylim=c(0,1.0),  xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='brown')
par(new=T, cex=0.65)
mtext(paste("alternate genotype PD: ", round(vcf.positiveDiscrepancy, digits=4), ", site PD: ", round(1 - vcf.sitesTruePositive, digits=4), sep=''))
par(new=T, cex=0.65)
legend('topleft', c('cumulative fraction of alt alleles', 'cumulative fraction of sites', 'alt genotypes PD', 'site PD', 'non-ref sensitivity', 'non-ref discrepancy', 'site PD at AC'),
    fill=c('red', 'purple', 'green', 'blue', 'magenta', 'brown', 'black'))
garbage <- dev.off()

pdf(paste(filename, '.', tag, '.PD.vs.AC.cumulative.simple.pdf', sep=''))
par(cex=0.75)
par(mar=c(5,4,4,5) + 0.1)
plot(byac$cfs, ylim=c(0,1.0), xlim=c(0,max(vcf$AC)),
    xlab='alternate allele count (AC)', xaxt='n',
    ylab='', yaxt='n', type='l', col='purple')
axis(2, at=seq(0,1,0.1), labels=seq(0,1,0.1))
axis(1, at=seq(0,max(byac$ac),10), labels=seq(0,max(byac$ac),10), cex=0.75)
grid(lty=5)
par(new=T)
title(paste(filename, 'positive discrepancy versus', tag, '(cumulative)'))
par(new=T)
countTicks <- seq(0,1,0.1) * vcf.numberOfSites
axis(4, at=seq(0,1,0.1), labels=round(countTicks))
mtext("number of sites", side=4, line=3, cex=0.75)
par(new=T)
plot(byac$site_fprlt, ylim=c(0,1.0), xlim=c(0,max(vcf$AC)), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='blue')
par(new=T)
plot(byac_gtsites$ac, byac_gtsites$site_fpr, ylim=c(0,1.0), xlim=c(0,max(vcf$AC)),   xlab='', xaxt='n', ylab='', yaxt='n')
par(new=T, cex=0.65)
mtext(paste("site PD: ", round(1 - vcf.sitesTruePositive, digits=4), sep=''))
par(new=T, cex=0.65)
legend('topleft', c('cumulative fraction of sites', 'cumulative site PD', paste('site PD at AC (>=', min_sites, 'sites)')),
    fill=c('purple', 'blue', 'black'))
garbage <- dev.off()

pdf(paste(filename, '.', tag, '.PD.vs.AC.instantaneous.ac_lt_20.pdf', sep=''))
#par(cex=0.75)
par(mar=c(5,4,4,5) + 0.1)
plot(byac$sites, ylim=c(0,max(byac$sites)), xlim=c(0,20),
    xlab='alternate allele count (AC)', xaxt='n',
    ylab='number of sites', type='l', pch=19, col='blue')
#axis(2, at=seq(0,1,0.1), labels=seq(0,1,0.1))
#countTicks <- round(seq(0,1,0.1) * max(byac$sites))
#axis(2, at=countTicks, labels=countTicks)
par(new=T)
axis(1, at=seq(0,max(byac$ac),1), labels=seq(0,max(byac$ac),1))
grid(lty=5)
par(new=T)
plot(byac$sites, ylim=c(0,max(byac$sites)), xlim=c(0,20), type='o', pch=19, col='blue', xlab='', xaxt='n', ylab='', yaxt='n')
par(new=T)
title(paste(filename, 'positive discrepancy versus', tag, '(instantaneous)'))
par(new=T)
mtext("number of sites", side=2, line=3) #, cex=0.75)
#par(new=T)
#plot(byac$site_fprlt, ylim=c(0,1.0), xlim=c(0,20),  xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='blue')
par(new=T)
plot(byac_gtsites$ac, byac_gtsites$site_tpc, ylim=c(0,max(byac$sites)), xlim=c(0,20), xlab='', xaxt='n', ylab='', yaxt='n', col='red', pch=19, type='o')
par(new=T) #, cex=0.65)
mtext(paste("site PD: ", round(1 - vcf.sitesTruePositive, digits=4), sep=''))
par(new=T) #, cex=0.65)
#legend('topright', c('number of sites', 'site PD count'),
#    fill=c('blue', 'red'))
garbage <- dev.off()

# stratifying by QUAL

if (FALSE) {

x <- cbind(by(vcf, vcf$QUAL,
    function(x) {
        sum(x[, tag.alternate_positive_discrepancy]) / sum(x[, tag.genotypes_alternate_count])
    }))

byqual <- data.frame(qual=as.numeric(rownames(x)), fdr=as.vector(x))

# false detection count
byqual$fpc <- as.vector(cbind(by(vcf, vcf$QUAL,
    function(i) { sum(i[, tag.alternate_positive_discrepancy]) } )))

byqual$alleles <- as.vector(cbind(by(vcf, vcf$QUAL,
    function(i) {
        sum(i[, tag.genotypes_alternate_count])
    })))

byqual$sites <- as.vector(cbind(by(vcf$QUAL, vcf$QUAL, function(i) length(i))))

# count true positive sites
byqual$site_tpc <- as.vector(cbind(by(vcf[, tag.has_variant], vcf$QUAL, function(i) sum(i))))
# fpc == false detection count
byqual$site_fpc <- byqual$sites - byqual$site_tpc
# site detection fpr is 1 - true positive rate
byqual$site_fpr <- 1 - ( byqual$site_tpc / byqual$sites )

#byqual$site_fpr_gt0 <- as.vector(cbind(tapply(byqual$ac, byqual$ac, function(i) {
#    s <- subset(byqual, ac == i, select=c(site_fpr, sites))
#if (s$sites >= min_sites) {
#    return(s$site_fpr)
#} else {
#    return(NA)
#}
#})))

#byqual$site_fprlt <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) mean(subset(byqual, qual <= i, select=site_fpr)))))
byqual$site_fprlt <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) {
    s <- subset(byqual, qual <= i, select=c(site_fpc, sites))
    return(sum(s$site_fpc) / sum(s$sites))
})))

#byqual$site_fprgt <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) mean(subset(byqual, qual >= i, select=site_fpr)))))
byqual$site_fprgt <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) {
    s <- subset(byqual, qual >= i, select=c(site_fpc, sites))
    return(sum(s$site_fpc) / sum(s$sites))
})))

byqual$cfa <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) sum(subset(byqual, qual <= i, select=alleles)) / sum(byqual$alleles))))

byqual$cfs <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) sum(subset(byqual, qual <= i, select=sites)) / length(vcf$QUAL))))

# inappropriate collapse via averaging of fdr
#byqual$alternate_pdlt <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) mean(subset(byqual, qual <= i, select=fdr)))))

byqual$alternate_pdr <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) {
    s <- subset(byqual, qual == i, select=c(fpc, alleles))
    return(sum(s$fpc) / sum(s$alleles))
})))

# use this one
byqual$alternate_pdlt <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) {
    s <- subset(byqual, qual <= i, select=c(fpc, alleles))
    return(sum(s$fpc) / sum(s$alleles))
})))

#byqual$alternate_pdgt <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) mean(subset(byqual, qual >= i, select=fdr)))))
byqual$alternate_pdgt <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) {
    s <- subset(byqual, qual >= i, select=c(fpc, alleles))
    return(sum(s$fpc) / sum(s$alleles))
})))

nan.to.zero <- function(n) {
    if (is.nan(n)) return(0) else return(n)
}

byqual$nrs <- as.vector(cbind(by(vcf, vcf$QUAL, function(i) {
    return(nan.to.zero(sum(i[, tag.non_reference_sensitivity_count]) / sum(i[, tag.non_reference_sensitivity_normalizer])))
})))

byqual$nrd <- as.vector(cbind(by(vcf, vcf$QUAL, function(i) {
    return(nan.to.zero(sum(i[, tag.non_reference_discrepancy_count]) / sum(i[, tag.non_reference_discrepancy_normalizer])))
})))

byqual$nrslt <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) {
    s <- subset(vcf, QUAL <= i, select=c(tag.non_reference_sensitivity_count, tag.non_reference_sensitivity_normalizer))
    return(nan.to.zero(sum(s[, tag.non_reference_sensitivity_count]) / sum(s[, tag.non_reference_sensitivity_normalizer])))
})))

byqual$nrdlt <- as.vector(cbind(tapply(byqual$qual, byqual$qual, function(i) {
    s <- subset(vcf, QUAL <= i, select=c(tag.non_reference_discrepancy_count, tag.non_reference_discrepancy_normalizer))
    return(nan.to.zero(sum(s[, tag.non_reference_discrepancy_count]) / sum(s[, tag.non_reference_discrepancy_normalizer])))
})))

byqual_gt10 <- subset(byqual, sites >= min_sites)

if (FALSE) {
pdf(paste(filename, '.', tag, '.PD.vs.QUAL.smooth.pdf', sep=''))
par(cex=0.75)
par(mar=c(5,4,4,5) + 0.1)
plot(byqual$cfa, ylim=c(0,1.0),
    xlab='QUAL', xaxt='n',
    ylab='', yaxt='n', type='l', col='red')
axis(2, at=seq(0,1,0.1), labels=seq(0,1,0.1))
axis(1, at=seq(0,max(byqual$qual),10), labels=seq(0,max(byqual$qual),10), cex=0.75)
grid(lty=5)
par(new=T)
title(paste(filename, 'positive discrepancy versus', tag, '(smoothed)'))
par(new=T)
countTicks <- seq(0,1,0.1) * vcf.numberOfSites
axis(4, at=seq(0,1,0.1), labels=round(countTicks))
mtext("number of sites", side=4, line=3, cex=0.75)
par(new=T)
#plot(byqual$alternate_pdlt, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='green')
plot(byqual$site_fpr, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n')
par(new=T)
lines(byqual$qual, predict(loess(byqual$alternate_pdr ~ byqual$qual, span=0.5)), col="green")
par(new=T)
plot(byqual$cfa, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='red')
par(new=T)
plot(byqual$cfs, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='purple')
par(new=T)
lines(byqual$qual, predict(loess(byqual$site_fpr ~ byqual$qual, span=0.5)), col="blue")
par(new=T)
lines(byqual$qual, predict(loess(byqual$nrs ~ byqual$qual, span=0.5)), col="magenta")
par(new=T)
lines(byqual$qual, predict(loess(byqual$nrd ~ byqual$qual, span=0.5)), col="brown")
par(new=T, cex=0.65)
mtext(paste("alternate genotype PD: ", round(vcf.positiveDiscrepancy, digits=4), ", site PD: ", round(1 - vcf.sitesTruePositive, digits=4), sep=''))
par(new=T, cex=0.65)
legend('topleft', c('cumulative fraction of alt alleles', 'cumulative fraction of sites', 'alt genotypes PD', 'site PD', 'non-ref sensitivity', 'non-ref discrepancy', 'site PD at QUAL'),
    fill=c('red', 'purple', 'green', 'blue', 'magenta', 'brown', 'black'))
garbage <- dev.off()
}

pdf(paste(filename, '.', tag, '.PD.vs.QUAL.cumulative.pdf', sep=''))
par(cex=0.75)
par(mar=c(5,4,4,5) + 0.1)
plot(byqual$cfa, ylim=c(0,1.0),
    xlab='QUAL', xaxt='n',
    ylab='', yaxt='n', type='l', col='red')
axis(2, at=seq(0,1,0.1), labels=seq(0,1,0.1))
axis(1, at=seq(0,max(byqual$qual),10), labels=seq(0,max(byqual$qual),10), cex=0.75)
grid(lty=5)
par(new=T)
title(paste(filename, 'positive discrepancy versus', tag, '(cumulative)'))
par(new=T)
countTicks <- seq(0,1,0.1) * vcf.numberOfSites
axis(4, at=seq(0,1,0.1), labels=round(countTicks))
mtext("number of sites", side=4, line=3, cex=0.75)
par(new=T)
plot(byqual_gt10$qual, byqual_gt10$site_fpr, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n')
#plot(byqual$site_fpr, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n')
par(new=T)
plot(byqual$alternate_pdlt, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='green')
par(new=T)
plot(byqual$cfa, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='red')
par(new=T)
plot(byqual$cfs, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='purple')
par(new=T)
plot(byqual$site_fprlt, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='blue')
par(new=T)
plot(byqual$nrslt, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='magenta')
par(new=T)
plot(byqual$nrdlt, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='brown')
par(new=T, cex=0.65)
mtext(paste("alternate genotype PD: ", round(vcf.positiveDiscrepancy, digits=4), ", site PD: ", round(1 - vcf.sitesTruePositive, digits=4), sep=''))
par(new=T, cex=0.65)
legend('topleft', c('cumulative fraction of alt alleles', 'cumulative fraction of sites', 'alt genotypes PD', 'site PD', 'non-ref sensitivity', 'non-ref discrepancy', 'site PD at QUAL (>= 10 sites)'),
    fill=c('red', 'purple', 'green', 'blue', 'magenta', 'brown', 'black'))
garbage <- dev.off()

pdf(paste(filename, '.', tag, '.PD.vs.QUAL.cumulative.simple.pdf', sep=''))
par(cex=0.75)
par(mar=c(5,4,4,5) + 0.1)
plot(byqual$cfs, ylim=c(0,1.0),
    xlab='QUAL', xaxt='n',
    ylab='', yaxt='n', type='l', col='purple')
axis(2, at=seq(0,1,0.1), labels=seq(0,1,0.1))
axis(1, at=seq(0,max(byqual$qual),10), labels=seq(0,max(byqual$qual),10), cex=0.75)
grid(lty=5)
par(new=T)
title(paste(filename, 'positive discrepancy versus', tag, '(cumulative)'))
par(new=T)
countTicks <- seq(0,1,0.1) * vcf.numberOfSites
axis(4, at=seq(0,1,0.1), labels=round(countTicks))
mtext("number of sites", side=4, line=3, cex=0.75)
par(new=T)
plot(byqual$site_fprlt, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n', type='l', col='blue')
par(new=T)
plot(byqual_gt10$qual, byqual_gt10$site_fpr, ylim=c(0,1.0), xlab='', xaxt='n', ylab='', yaxt='n')
par(new=T, cex=0.65)
mtext(paste("site PD: ", round(1 - vcf.sitesTruePositive, digits=4), sep=''))
par(new=T, cex=0.65)
legend('topleft', c('cumulative fraction of sites', 'site PD', 'site PD at QUAL (>= 10 sites)'),
    fill=c('purple', 'blue', 'black'))
garbage <- dev.off()

}