################################################################################################################################################
#                                                Script to create vars for the function domain                                                 #
# Vars:                                                                                #
# 1. Anchor stores                                                                                #
# 2. Premium retailers (designers & top department stores)                                                                                #
# 3. Mass (big 20 + mid-range restaurant chains)                                                                                #
# 4. Value (Aldi, Lidl, discount stores, takeaways, charity shops, pawnbrokers)                                                                #
# 5. Ethnic retail                                                                                #
# 6. Kiosks and  (is_concession field)                                                                                #
# 7. Bars                                                                                #
################################################################################################################################################

library(sf)
library(stringr)
library(data.table)
library(parallel)

ru <- st_read("~/Dropbox/liverpool/catchments/catchments2/retail_units/retail_units_all_data_area_id_names_fin.shp", stringsAsFactors = F)
ru2 <- as.data.frame(ru)
setDT(ru2)
ru2[, store_name2 := str_to_lower(str_trim(store_name))]
setkey(ru2, cluster_id)

oas <- st_read("~/Dropbox/liverpool/GIS_Data/OAs_2011/oas11.shp", stringsAsFactors = F)
oas$area <- as.numeric(st_area(oas)) / 1000^2
oas_area <- aggregate(oas$area, by = list(oas$code), sum)
setDT(oas_area)
setnames(oas_area, names(oas_area), c("oa11", "catchment_area"))
setkey(oas_area, oa11)

catch_lookup <- fread("~/Dropbox/liverpool/retail_typology/data/catchments_oa_lookup.csv")
setkey(catch_lookup, oa11)

##### 1. Catchment area ########################################################################################################################

catch_lookup[oas_area, catchment_area := i.catchment_area, on = "oa11"]
catch_area <- catch_lookup[, sum(catchment_area), keyby = "cluster_id"]
setnames(catch_area, "V1", "catchment_area")

##### 2. Size (nr of stores) ###################################################################################################################

cluster_size <- ru2[, .N, by = "cluster_id"]
setnames(cluster_size, "N", "stores_nr")

##### 3. Anchor stores #########################################################################################################################
### a) For convenience the big 5 ###
big5_convenience <- list(asda = c("asda", "asda supercentre"),
                  morrisons = "morrisons",
                  sainsburys = c("sainsbury's", "sainsbury's market"),
                  tesco = c("tesco metro", "tesco", "tesco extra"),
                  waitrose = "waitrose")

big5_lookup_table <- as.data.frame(do.call(rbind, lapply(names(big5_convenience), function(store_name) cbind(store_name, big5_convenience[[store_name]]))), stringsAsFactors = F)
names(big5_lookup_table) <- c("retailer_name", "retailer_store_names")
setDT(big5_lookup_table)

### b) For comparison ###
comparison_stores <- list(john_lewis = c("john lewis at home", "john lewis", "john lewis of hungerford"),
                          debenhams = c("debenhams", "desire by debenhams"),
                          boots = "boots the chemist",
                          primark = "primark",
                          next_ = c("next", "next clearance", "next home", "next furniture"),
                          h_m = c("h&m", "h&m kids", "h&m discounts"),
                          harvey_nichols = "harvey nichols",
                          m_s = c("marks & spencer", "marks & spencer outlet", "marks & spencer home"),
                          zara = "zara",
                          b_q = "b&q",
                          ikea = "ikea",
                          homebase = c("homebase", "homebase design centre")
                          )

comparison_lookup_table <- as.data.frame(do.call(rbind, lapply(names(comparison_stores), function(store_name) cbind(store_name, comparison_stores[[store_name]]))), stringsAsFactors = F)
names(comparison_lookup_table) <- c("retailer_name", "retailer_store_names")
setDT(comparison_lookup_table)

### c)  for leisure ###
leisure_stores <- list(odeon = "odeon cinema",
                       vue_cinema = c("vue", "vue box office"),
                       cineworld = "cineworld"
                       )
leisure_lookup_table <- as.data.frame(do.call(rbind, lapply(names(leisure_stores), function(store_name) cbind(store_name, leisure_stores[[store_name]]))), stringsAsFactors = F)
names(leisure_lookup_table) <- c("retailer_name", "retailer_store_names")
setDT(leisure_lookup_table)

### d) Put everything together ###
anchor_dt <- rbindlist(list(big5_lookup_table, comparison_lookup_table, leisure_lookup_table))
# sanity check
all(anchor_dt$retailer_store_names %in% unique(ru2$store_name2)) # T
ru2[anchor_dt, anchor_stores := i.retailer_name, on = c(store_name2 = "retailer_store_names")]

anchor_pct <- ru2[, 100 * length(unique(anchor_stores)) / length(unique(anchor_dt$retailer_name)), by = "cluster_id"]

##### 2. Premium brands ########################################################################################################################
occur <- sapply(unique(ru2$store_name2), function(x) all(c("fat", "face") %in% unlist(strsplit(gsub(",", "", x), " "))))
ru2[store_name2 %in% names(occur[occur]), sort(table(store_name2), decreasing = T)]

premium_brands_list <- list(waitrose = "waitrose",
                            john_lewis = c("john lewis at home", "john lewis", "john lewis of hungerford"),
                            harvey_nichols = "harvey nichols",
                            laura_ashley = c("laura ashley", "laura ashley home"),
                            ted_baker = c("ted baker", "ted baker factory outlet", "ted baker & friends", "ted baker & moore", "ted baker pashion"),
                            tommy_hilfiger = c("tommy hilfiger", "tommy hilfiger kids"),
                            fat_face = "fat face",
                            superdry = c("superdry", "superdry ladieswear", "superdry menswear"),
                            seasalt = "seasalt",
                            jack_wills = "jack wills",
                            white_stuff = "white stuff",
                            crew_clothing = "crew clothing co.",
                            hugo_boss = "hugo boss",
                            cath_kidston = "cath kidston",
                            joules = "joules",
                            swarovski = "swarovski",
                            lacoste = "lacoste",
                            diesel = c("diesel", "diesel female", "diesel male"),
                            apple_store = "apple store",
                            bose = "bose"
                            )

premium_lookup_table <- as.data.frame(do.call(rbind, lapply(names(premium_brands_list), function(store_name) cbind(store_name, premium_brands_list[[store_name]]))), stringsAsFactors = F)
names(premium_lookup_table) <- c("retailer_name", "retailer_store_names")
setDT(premium_lookup_table)

all(premium_lookup_table$retailer_store_names %in% unique(ru2$store_name2)) # T
ru2[premium_lookup_table, premium_brands := i.retailer_name, on = c(store_name2 = "retailer_store_names")]

premium_brand_pct <- ru2[, 100 * length(unique(premium_brands)) / length(unique(premium_lookup_table$retailer_name)), by = "cluster_id"]

##### 3. Mass brands ###########################################################################################################################

mass_list <- list(asda = c("asda", "asda supercentre"),
                  sainsburys = c("sainsbury's", "sainsbury's market"),
                  tesco = c("tesco metro", "tesco", "tesco extra"),
                  currys = c("currys", "currys megastore", "currys pc world", "currys pc world megastore"),
                  argos = c("argos", "argos extra"),
                  boots = "boots the chemist",
                  next_ = c("next", "next clearance", "next home", "next furniture"),
                  tkmaxx = "tk maxx",
                  whsmith = c("whsmith", "whsmith books", "whsmith bookshop", "whsmith stationery"),
                  zara = "zara",
                  h_m = c("h&m", "h&m kids", "h&m discounts"),
                  jd_sports = "jd sports",
                  river_island = "river island",
                  costa = "costa",
                  caffe_nero = "caffe nero",
                  dominos = "domino's pizza",
                  pizza_express = "pizzaexpress",
                  mcdonalds = "mcdonald's",
                  starbucks = "starbucks coffee",
                  subway = "subway",
                  greggs = c("greggs", "greggs cafe", "greggs bakery outlet", "greggs the bakery"),
                  superdrug = "superdrug",
                  holland_barrett = "holland & barrett",
                  h.samuel = "h.samuel",
                  claires = c("claire's", "claire's outlet"),
                  topshop = "topshop",
                  game = "game",
                  perfume_shop = "the perfume shop",
                  kfc = "kfc",
                  fragrance_shop = "the fragrance shop"
                  )

mass_lookup_table <- as.data.frame(do.call(rbind, lapply(names(mass_list), function(store_name) cbind(store_name, mass_list[[store_name]]))), stringsAsFactors = F)
names(mass_lookup_table) <- c("retailer_name", "retailer_store_names")
setDT(mass_lookup_table)

all(mass_lookup_table$retailer_store_names %in% unique(ru2$store_name2)) # T
ru2[mass_lookup_table, mass_brands := i.retailer_name, on = c(store_name2 = "retailer_store_names")]

mass_brand_pct <- ru2[, 100 * length(unique(mass_brands)) / length(unique(mass_lookup_table$retailer_name)), by = "cluster_id"]

##### 4. Value stores ###########################################################################################################################

value_list <- list(aldi = "aldi",
                   lidl = "lidl",
                   iceland = "iceland",
                   primark = "primark",
                   poundland = "poundland",
                   poundworld = c("poundworld", "poundworld express", "poundworld extra", "poundworld plus"),
                   poundstretcher = "poundstretcher",
                   farmfoods = "farmfoods",
                   p99 = "99p stores",
                   pound_bakery = "pound bakery",
                   savers = "savers health & beauty",
                   b_m = c("b&m bargains", "b&m home store"),
                   home_bargains = "home bargains"
                   )

value_lookup_table <- as.data.frame(do.call(rbind, lapply(names(value_list), function(store_name) cbind(store_name, value_list[[store_name]]))), stringsAsFactors = F)
names(value_lookup_table) <- c("retailer_name", "retailer_store_names")
setDT(value_lookup_table)

all(value_lookup_table$retailer_store_names %in% unique(ru2$store_name2)) # T
ru2[value_lookup_table, value_brands := i.retailer_name, on = c(store_name2 = "retailer_store_names")]

value_brand_pct <- ru2[, 100 * length(unique(value_brands)) / length(unique(value_lookup_table$retailer_name)), by = "cluster_id"]

##### 5. Charity shops, Discount stores #########################################################################################################

charity <- ru2[,  100 * sum(category %in% c("Charity & Secondhand Shops")) / .N, by = "cluster_id"]
setnames(charity, "V1", "charity_pct")

##### 6. Betting + Pawnbrokers ##################################################################################################################

betting <- ru2[,  100 * sum(subcat %in% c("Bookmakers", "Pawnbrokers")) / .N, by = "cluster_id"]
setnames(betting, "V1", "betting_pct")

##### 7. Ethnic retail ##########################################################################################################################
rm_rest <- c("Restaurant - British", "Restaurant - Vegan", "Restaurant - Welsh", "Restaurant - Pizzeria", "Restaurant - Other",
             "Restaurant - Seafood", "Restaurant - Brasserie", "Restaurant - Vegetarian", "Restaurant - American", "Restaurant - English",
             "Restaurant - Creperie", "Restaurant - Scottish")
ethnic_restaurants <- ru2[, setdiff(grep("Restaurant - ", unique(subcat), value = T), rm_rest)]
ethnic_pct <- ru2[, 100 * sum(subcat %in% ethnic_restaurants) / .N, by = "cluster_id"]
setnames(ethnic_pct, "V1", "ethnic_pct")

# anchor_pct, premium_brand_pct, mass_brand_pct, value_brand_pct, betting, charity, ethnic_pct
setnames(anchor_pct, "V1", "anchor_pct")
setnames(premium_brand_pct, "V1", "premium_brand_pct")
setnames(mass_brand_pct, "V1", "mass_brand_pct")
setnames(value_brand_pct, "V1", "value_brand_pct")

out <- anchor_pct[premium_brand_pct, on = "cluster_id"]
out <- mass_brand_pct[out, on = "cluster_id"]
out <- value_brand_pct[out, on = "cluster_id"]
out <- betting[out, on = "cluster_id"]
out <- charity[out, on = "cluster_id"]
out <- ethnic_pct[out, on = "cluster_id"]
out <- cluster_size[out, on = "cluster_id"]
out <- catch_area[out, on = "cluster_id"]
# remove clusters without a catchment
out <- out[!is.na(out$area), ]

fwrite(out, "~/Dropbox/liverpool/retail_typology/analysis/indicators/retail_function.csv")


#Comparing R2 density between Tedersoo out-of-sample (OOS) forecast to NEON and NEON cross-validation (CV).

# CURRENTLY JUST INCORPORATING PHYLOGENETIC GROUPS, NOT FUNCTIONAL
# CHANGE for() loops once you re-run the CV

rm(list=ls())
source('paths.r')
#source('NEFI_functions/zero_truncated_density.r')
library(RCurl)
script <- getURL("https://raw.githubusercontent.com/colinaverill/NEFI_microbe/master/NEFI_functions/zero_truncated_density.r", ssl.verifypeer = FALSE)
eval(parse(text = script))

#set figure out put path.----
output.path <- paste0(pecan_gen_16S_dir, 'figures/OOS_vs_CV_16S.png')

#Load calibration and validation predictions and data for OOS and CV.----
#Out of sample Tedersoo calibration, and out of sample predictions for NEON.
oos.cal <- readRDS(bahram_16S_prior_dmulti.ddirch_all.group_JAGSfits)
oos.val <- readRDS(NEON_cps_fcast_dmulti.ddirch_16S.path)

#NEON out of sample observations across scale.
oos.dat <- readRDS(NEON_phylo_fg_plot.site_obs_16S.path)

#Cross validation forecasts
cv.val.core <- readRDS(core.CV_NEON_fcast_16S.path)
cv.val.plot <- readRDS(plot.CV_NEON_fcast_16S.path)

#Cross validation predictions
cv.cal.core <- readRDS(core.CV_NEON_dmulti.ddirch_16S.path)
cv.cal.plot <- readRDS(plot.CV_NEON_dmulti.ddirch_16S.path)

#Cross validation data (calibration and validation)
cv.dat.core <- readRDS(core.CV_NEON_cal.val_data_16S.path)
cv.dat.plot <- readRDS(plot.CV_NEON_cal.val_data_16S.path)
cv.dat.core <- cv.dat.core$val$y.val
cv.dat.plot <- cv.dat.plot$val$y.val

# read in obs table that links deprecatedVialID and geneticSampleID
map <- readRDS(core_obs_data.path)
map <- map[,c("deprecatedVialID", "geneticSampleID")]
map$geneticSampleID <- gsub('-GEN','',map$geneticSampleID)

#Generate Tedersoo out of sample fit statistics.----
oos.stats <- list()
#for(i in 1:length(oos.val)){
for(i in 1:5){
  lev   <- oos.val[[i]]
  lev.y <- oos.dat[[i]]
  x <- list(lev$core.fit$mean, lev$plot.fit$mean, lev$site.fit$mean)
  y <- list(lev.y$core.fit, lev.y$plot.fit$mean, lev.y$site.fit$mean)
  cps.list <- list()
  for(k in 1:length(y)){
    yy <- as.data.frame(y[[k]])
    # fix deprecatedVialID to geneticSampleID
    if (k == 1){
    yy$deprecatedVialID <- rownames(yy)
    yy <- merge(yy, map, by = "deprecatedVialID")
    rownames(yy) <- yy$geneticSampleID
    yy$geneticSampleID <- NULL
    yy$deprecatedVialID <- NULL
    } else if (k == 2){
      rownames(yy) <- gsub('\\.','_', rownames(yy))
    }
    #match row and column names.
    xx <- x[[k]]
    yy <- yy[,order(match(colnames(yy), colnames(xx)))]
    xx <- xx[rownames(xx) %in% rownames(yy),]
    yy <- yy[rownames(yy) %in% rownames(xx),]
    yy <- yy[order(match(rownames(yy), rownames(xx))),]
    #Get R2 for each column.
    lev.stats <- list()
    for(j in 1:ncol(yy)){
      #r square best fit.
      fit <- lm(yy[,j] ~ xx[,j])
      rsq <- summary(fit)$r.squared
      #r square 1:1.
      rss <- sum((xx[,j] -      yy[,j])  ^ 2)  ## residual sum of squares
      tss <- sum((yy[,j] - mean(yy[,j])) ^ 2)  ## total sum of squares
      rsq1 <- 1 - rss/tss
      if(rsq1 < 0){rsq1 <- 0}
      #RMSE.
      rmse <- sqrt(mean(fit$residuals^2))
      return <- c(rsq,rsq1,rmse)
      lev.stats[[j]] <- return
    }
    lev.stats <- do.call(rbind, lev.stats)
    colnames(lev.stats) <- c('rsq','rsq1','rmse')
    rownames(lev.stats) <- colnames(yy)
    cps.list[[k]] <- lev.stats
  }
  names(cps.list) <- c('core','plot','site')
  oos.stats[[i]] <- cps.list
}
names(oos.stats) <- names(oos.val)[1:5]

#reformat tedersoo out of sample forecasts to match cross validation.----
oos.core.list <- list()
oos.plot.list <- list()
for(i in 1:length(oos.stats)){
  oos.core.list[[i]] <- oos.stats[[i]]$core
  oos.plot.list[[i]] <- oos.stats[[i]]$plot
}
names(oos.core.list) <- names(oos.stats)
names(oos.plot.list) <- names(oos.stats)

#Get NEON Cross-validated stats at core and plot level.-----
#core level.
core.list <- list()
#for(i in 1:length(cv.val.core)){
for(i in 1:5){
  x <- cv.val.core[[i]]$core.fit$mean
  y <- cv.dat.core[[i]]$rel.abundances
  #match row and column names.
  y <- y[,order(match(colnames(y), colnames(xx)))]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[order(match(rownames(y), rownames(x))),]
  #Get R2 for each column.
  lev.stats <- list()
  for(j in 1:ncol(y)){
    #r square best fit.
    fit <- lm(y[,j] ~ x[,j])
    rsq <- summary(fit)$r.squared
    #r square 1:1.
    rss <- sum((x[,j] -      y[,j])  ^ 2)  ## residual sum of squares
    tss <- sum((y[,j] - mean(y[,j])) ^ 2)  ##    total sum of squares
    rsq1 <- 1 - rss/tss
    if(rsq1 < 0){rsq1 <- 0}
    #RMSE.
    rmse <- sqrt(mean(fit$residuals^2))
    return <- c(rsq,rsq1,rmse)
    lev.stats[[j]] <- return
  }
  lev.stats <- do.call(rbind, lev.stats)
  colnames(lev.stats) <- c('rsq','rsq1','rmse')
  rownames(lev.stats) <- colnames(y)
  core.list[[i]] <- lev.stats
}
names(core.list) <- names(cv.dat.core)[1:5]

#plot level.
plot.list <- list()
#for(i in 1:length(cv.val.plot)){
for(i in 1:5){
  x <- cv.val.plot[[i]]$plot.fit$mean
  y <- cv.dat.plot[[i]]$mean
  #match row and column names.
  y <- y[,order(match(colnames(y), colnames(x)))]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[order(match(rownames(y), rownames(x))),]
  #Get R2 for each column.
  lev.stats <- list()
  for(j in 1:ncol(y)){
    #r square best fit.
    fit <- lm(y[,j] ~ x[,j])
    rsq <- summary(fit)$r.squared
    #r square 1:1.
    rss <- sum((x[,j] -      y[,j])  ^ 2)  ## residual sum of squares
    tss <- sum((y[,j] - mean(y[,j])) ^ 2)  ## total sum of squares
    rsq1 <- 1 - rss/tss
    if(rsq1 < 0){rsq1 <- 0}
    #RMSE.
    rmse <- sqrt(mean(fit$residuals^2))
    return <- c(rsq,rsq1,rmse)
    lev.stats[[j]] <- return
  }
  lev.stats <- do.call(rbind, lev.stats)
  colnames(lev.stats) <- c('rsq','rsq1','rmse')
  rownames(lev.stats) <- colnames(y)
  plot.list[[i]] <- lev.stats
}
names(plot.list) <- names(cv.val.plot)[1:5]

#Collapse to 6x2 data frames.----
cv.core.r2   <- list()
cv.plot.r2   <- list()
cv.core.r2.1 <- list()
cv.plot.r2.1 <- list()
cv.core.rmse <- list()
cv.plot.rmse <- list()
for(i in 1:length(core.list)){
  cv.core.r2  [[i]] <- core.list[[i]][,1]
  cv.plot.r2  [[i]] <- plot.list[[i]][,1]
  cv.core.r2.1[[i]] <- core.list[[i]][,2]
  cv.plot.r2.1[[i]] <- plot.list[[i]][,2]
  cv.core.rmse[[i]] <- core.list[[i]][,3]
  cv.plot.rmse[[i]] <- plot.list[[i]][,3]
}
cv.core.r2 <- unlist(cv.core.r2)
cv.plot.r2 <- unlist(cv.plot.r2)
cv.core.r2.1 <- unlist(cv.core.r2.1)
cv.plot.r2.1 <- unlist(cv.plot.r2.1)
cv.core.rmse <- unlist(cv.core.rmse)
cv.plot.rmse <- unlist(cv.plot.rmse)

#Same for Tedersoo forecast.
oos.core.r2   <- list()
oos.plot.r2   <- list()
oos.core.r2.1 <- list()
oos.plot.r2.1 <- list()
oos.core.rmse <- list()
oos.plot.rmse <- list()
for(i in 1:length(oos.core.list)){
  oos.core.r2  [[i]] <- oos.core.list[[i]][,1]
  oos.plot.r2  [[i]] <- oos.plot.list[[i]][,1]
  oos.core.r2.1[[i]] <- oos.core.list[[i]][,2]
  oos.plot.r2.1[[i]] <- oos.plot.list[[i]][,2]
  oos.core.rmse[[i]] <- oos.core.list[[i]][,3]
  oos.plot.rmse[[i]] <- oos.plot.list[[i]][,3]
}
oos.core.r2   <- unlist(oos.core.r2)
oos.plot.r2   <- unlist(oos.plot.r2)
oos.core.r2.1 <- unlist(oos.core.r2.1)
oos.plot.r2.1 <- unlist(oos.plot.r2.1)
oos.core.rmse <- unlist(oos.core.rmse)
oos.plot.rmse <- unlist(oos.plot.rmse)

#plot R2, R2-1 and RMSE stats by scale.-----
#png save line.
png(filename=output.path,width=10,height=8,units='in',res=300)

#Global plot settings.
par(mfrow = c(2,2),
    mar = c(4,4,2,2))
limx <- c(0,1)
limy <- c(0, 25)
trans <- 0.2 #shading transparency.
o.cex <- 1.3 #outer label size.
cols <- c('purple','cyan','yellow')
labs <- c('Global Forecast','NEON Cross-Validation')
labs <- c('Global Forecast (a)','NEON Cross-Validation (b)','Global Forecast (c)','NEON Cross-Validation (d)')

#Forecast OOS R2----
a <- oos.core.r2[!is.na(oos.core.r2)]
b <- oos.plot.r2[!is.na(oos.plot.r2)]
main.lab <- labs[1]
limx <- c(0,max(c(a, b))*1.1)
limy <- c(0, max(c(zero_truncated_density(a)$y,zero_truncated_density(b)$y))*1.02)
plot(cv.core.r2,ylim = limy, xlim = limx, bty = 'l', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0)
polygon(zero_truncated_density(a), col = adjustcolor(cols[1],trans))
polygon(zero_truncated_density(b), col = adjustcolor(cols[2],trans))
mtext('Density', side = 2, line = 2.2, cex = o.cex)
mtext(expression(paste("Validation R"^"2")), side = 1, line = 2.5, cex = o.cex)
mtext(main.lab,side = 3, line = -1.5, cex = o.cex)

##Plot legend
legend(x = 0.4, y = 6, legend = c('core','plot'), col ='black', pt.bg=adjustcolor(cols,trans), bty = 'n', pch = 22, pt.cex = 1.5, cex = 1.5)

#NEON CV R2----
a <- cv.core.r2[!is.na(cv.core.r2)]
b <- cv.plot.r2[!is.na(cv.plot.r2)]
limx <- c(0,max(c(a, b))*1.1)
limy <- c(0, max(c(zero_truncated_density(a)$y,zero_truncated_density(b)$y))*1.02)
main.lab <- labs[2]
plot(cv.core.r2,ylim = limy, xlim = limx, bty = 'l', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0)
polygon(zero_truncated_density(a), col = adjustcolor(cols[1],trans))
polygon(zero_truncated_density(b), col = adjustcolor(cols[2],trans))
mtext('Density', side = 2, line = 2.2, cex = o.cex)
mtext(expression(paste("Validation R"^"2")), side = 1, line = 2.5, cex = o.cex)
mtext(main.lab,side = 3, line = -1.5, cex = o.cex)

#Forecast OOS RMSE----
a <- oos.core.rmse
b <- oos.plot.rmse
limx <- c(0,max(c(a,b))*1.1)
limy <- c(0, max(c(zero_truncated_density(a)$y,zero_truncated_density(b)$y))*1.02)
main.lab <- labs[3]
plot(cv.core.rmse,xlim = limx, ylim = limy, bty = 'l', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0)
polygon(zero_truncated_density(a), col = adjustcolor(cols[1],trans))
polygon(zero_truncated_density(b), col = adjustcolor(cols[2],trans))
mtext('Density', side = 2, line = 2.2, cex = o.cex)
mtext('RMSE', side = 1, line = 2.5, cex = o.cex)
mtext(main.lab,side = 3, line = -1.5, cex = o.cex)

#NEON CV RMSE----
a <- cv.core.rmse
b <- cv.plot.rmse
limx <- c(0,max(c(a,b))*1.1)
limy <- c(0, max(c(zero_truncated_density(a)$y,zero_truncated_density(b)$y))*1.02)
main.lab <- labs[4]
plot(cv.core.rmse,xlim = limx, ylim = limy, bty = 'l', xlab = NA, ylab = NA, main = NA, yaxs='i', xaxs = 'i', las = 1, lwd = 0)
polygon(zero_truncated_density(a), col = adjustcolor(cols[1],trans))
polygon(zero_truncated_density(b), col = adjustcolor(cols[2],trans))
mtext('Density', side = 2, line = 2.2, cex = o.cex)
mtext('RMSE', side = 1, line = 2.5, cex = o.cex)
mtext(main.lab,side = 3, line = -1.5, cex = o.cex)

#end plot.----
dev.off()


myInput <- read.csv("processed_data/processed_1e3_5kingdoms.csv", stringsAsFactors = FALSE) #yours will be different
myInput <- myInput[-3] #remove SpeciesID from ML models #yours will be different

#recode 3 kingdoms (archaea, bacteria, eukaryotes) as factors
# myInput$Kingdom <- factor(myInput$Kingdom, levels = c("arc", "bct", "euk"), labels = c("archaea", "bacteria", "eukaryote"))

#recode 4 kingdoms (archaea, bacteria, eukaryotes, viruses) as factors
# myInput$Kingdom <- factor(myInput$Kingdom, levels = c("arc", "bct", "euk", "vrl"), labels = c("archaea", "bacteria", "eukaryote", "virus"))

#recode 5 kingdoms (archaea, bacteria, eukaryotes, viruses, phages) as factors
myInput$Kingdom <- factor(myInput$Kingdom, levels = c("arc", "bct", "euk", "vrl", "phg"), labels = c("archaea", "bacteria", "eukaryote", "virus", "bacteriophage"))

#inspect
#> table(myInput$Kingdom)

#archaea  bacteria eukaryote
#65      1288      1036

#---------------------random sampling for training/test data---------------------
set.seed(123)
# train_sample <- sample(2389, 1911) #80% training split for 3 kingdoms
# train_sample <- sample(9937, 2485) #80% training split for 4 kingdoms
train_sample <- sample(10406, 8324) #80% training split for 5 kingdoms

myInput_train <- myInput[train_sample, ]
myInput_train_labels <- myInput[train_sample, 1] #Kingdom labels only
myInput_train <- subset(myInput_train, select = -c(Kingdom, DNAtype, Ncodons, SpeciesName))

myInput_test  <- myInput[-train_sample, ]
myInput_test_labels <- myInput[-train_sample, 1] #Kingdom labels only
myInput_test <- subset(myInput_test, select = -c(Kingdom, DNAtype, Ncodons, SpeciesName))

#---------------------k-NN---------------------

#install.packages("class")

# 3 kingdoms (arc, bct, euk) [try different values of k]
myInput_test_pred <- class::knn(train = myInput_train, test = myInput_test, cl = myInput_train_labels, k = 1)

# 4 kingdoms (arc, bct, euk, vrl) [try different values of k]
myInput_test_pred <- class::knn(train = myInput_train, test = myInput_test, cl = myInput_train_labels, k = 4)

# 4 kingdoms (arc, bct, euk, vrl, phg) [try different values of k]
myInput_test_pred <- class::knn(train = myInput_train, test = myInput_test, cl = myInput_train_labels, k = 5, prob = TRUE)

prob <- attr(myInput_test_pred, "prob")
#install.packages("gmodels")

gmodels::CrossTable(x = myInput_test_labels, y = myInput_test_pred, prop.chisq = FALSE)


# @file createTimeSeries
#
# Copyright 2021 Observational Health Data Sciences and Informatics
#
# This file is part of Achilles
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     https://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
# @author Observational Health Data Sciences and Informatics
# @author Martijn Schuemie
# @author Patrick Ryan
# @author Frank DeFalco
# @author Vojtech Huser
# @author Chris Knoll
# @author Ajit Londhe
# @author Taha Abdul-Basser
# @author Anthony Molinaro

#' @title
#' createTimeSeries
#'
#' @description
#' \code{createTimeSeries} Creates a monthly multivariate time series object given a data frame in the
#' proper format.
#'
#' @details
#' \code{createTimeSeries} Requires the following: \preformatted{ 1. The given data frame must contain
#' four columns: START_DATE, COUNT_VALUE, PREVALENCE, and PROPORTION_WITHIN_YEAR. 2. START_DATE must
#' be in the YYYYMMDD format. 3. COUNT_VALUE, PREVALENCE, and PROPORTION_WITHIN_YEAR contain only
#' numeric data. } The individual monthly univariate time series can be extracted by specifying the
#' correct column name (see example).
#'
#'
#' @param temporalData   A data frame from which to create the time series
#'
#' @return
#' A multivariate time series object
#'
#' @examples
#' \dontrun{
#' # Example 1:
#' temporalData <- data.frame(START_DATE = seq.Date(as.Date("20210101", "%Y%m%d"),
#'                                                  as.Date("20231201",
#'   "%Y%m%d"), by = "month"), COUNT_VALUE = round(runif(36, 1, 1000)), PREVALENCE = round(runif(36,
#'   0, 10), 2), PROPORTION_WITHIN_YEAR = round(runif(36, 0, 1), 2), stringsAsFactors = FALSE)
#' dummyTs <- createTimeSeries(temporalData)
#' dummyTs.cv <- dummyTs[, "COUNT_VALUE"]
#' dummyTs.pv <- dummyTs[, "PREVALENCE"]
#' dummyTs.pwy <- dummyTs[, "PROPORTION_WITHIN_YEAR"]
#'
#' # Example 2:
#' pneumonia <- 255848
#' temporalData <- getTemporalData(connectionDetails = connectionDetails, cdmDatabaseSchema = "cdm",
#'   resultsDatabaseSchema = "results", conceptId = pneumonia)
#' pneumoniaTs <- createTimeSeries(temporalData)
#' pneumoniaTs.cv <- pneumoniaTs[, "COUNT_VALUE"]
#' pneumoniaTs.pv <- pneumoniaTs[, "PREVALENCE"]
#' pneumoniaTs.pwy <- pneumoniaTs[, "PROPORTION_WITHIN_YEAR"]
#' }
#'
#' @export

createTimeSeries <- function(temporalData) {

  requiredColumns <- c("START_DATE", "COUNT_VALUE", "PREVALENCE", "PROPORTION_WITHIN_YEAR")

  if (sum(colnames(temporalData) %in% requiredColumns) < 4)
    stop(paste0("ERROR: INVALID DATA FRAME FORMAT. The data frame must contain columns: ",
                paste(requiredColumns,
      collapse = ", ")))

  if (nrow(temporalData) == 0) {
    stop("ERROR: Cannot create time series from an empty data frame")
  }

  resultSetData <- temporalData

  # Convert YYYYMMDD string into a valid date
  resultSetData$START_DATE <- as.Date(resultSetData$START_DATE, "%Y%m%d")

  # Sort the temporal data by START_DATE rather than using an ORDER BY in the SQL
  resultSetData <- resultSetData[order(resultSetData$START_DATE), ]

  # Create a vector of dense dates to capture all dates between the start and end of the time
  # series
  lastRow <- nrow(resultSetData)

  denseDates <- seq.Date(from = as.Date(resultSetData$START_DATE[1], "%Y%m%d"),
                         to = as.Date(resultSetData$START_DATE[lastRow],
    "%Y%m%d"), by = "month")

  # Find gaps, if any, in data (e.g., dates that have no data, give that date a 0 count and 0
  # prevalence)
  denseDatesDf <- data.frame(START_DATE = denseDates, CNT = rep(0, length(denseDates)))

  joinResults <- dplyr::left_join(denseDatesDf, resultSetData, by = c(START_DATE = "START_DATE"))

  joinResults$COUNT_VALUE[which(is.na(joinResults$COUNT_VALUE))] <- 0
  joinResults$PREVALENCE[which(is.na(joinResults$PREVALENCE))] <- 0
  joinResults$PROPORTION_WITHIN_YEAR[which(is.na(joinResults$PROPORTION_WITHIN_YEAR))] <- 0

  # Now that we no longer have sparse dates, keep only necessary columns and build the time series
  joinResults <- joinResults[, c("START_DATE",
                                 "COUNT_VALUE",
                                 "PREVALENCE",
                                 "PROPORTION_WITHIN_YEAR")]

  # Find the end of the dense results
  lastRow <- nrow(joinResults)

  # Create the multivariate time series
  tsData <- data.frame(COUNT_VALUE = joinResults$COUNT_VALUE, PREVALENCE = joinResults$PREVALENCE,
    PROPORTION_WITHIN_YEAR = joinResults$PROPORTION_WITHIN_YEAR)

  resultSetDataTs <- ts(data = tsData, start = c(as.numeric(substring(joinResults$START_DATE[1], 1,
    4)), as.numeric(substring(joinResults$START_DATE[1],
                              6,
                              7))), end = c(as.numeric(substring(joinResults$START_DATE[lastRow],
    1, 4)), as.numeric(substring(joinResults$START_DATE[lastRow], 6, 7))), frequency = 12)

  return(resultSetDataTs)
}


#' @exportClass GeoSituation
#' @name GeoSituation
#' @rdname GeoSituation
#' @aliases GeoSituation-class
#' @title The GeoSituation class
#'
#'  @description
#' This class is part of the \pkg{HNUORTools}. It can be understood as a scenario-placeholder in an
#' \dfn{Operations-Research (OR)}-context.
#'
#' @details Find here the defined slots for this class.
#' @section Slots defined:
#' \describe{
#'    \item{\code{id}:}{Object of class \code{"character"}, The Id-of the Scenario.}
#'    \item{\code{label}:}{Object of class \code{"character"}, The label-of the Scenario.}
#'    \item{\code{nodes}:}{Objects of class \code{\link{Node}} used in the Scenario.}
#'    \item{\code{links}:}{Objects of class \code{\link{Link}} used in the Scenario.}
#'    \item{\code{warehouses}:}{Objects of class \code{\link{Warehouse}} used in the Scenario.}
#'    \item{\code{customers}:}{Objects of class  \code{\link{Customer}} used in the Scenario.}
#'    \item{\code{spp}:}{Object of class \code{\link{list}}. The items in the list are:
#'      \describe{
#'        \item{\code{iteration}:}{an \code{\link{numeric}} value indicating after which iteration the algorithm terminated.}
#'        \item{\code{Q}:}{A \code{\link{data.frame}} (sorted list) with the reachable nodes.}
#'        \item{\code{tableau}:}{A nx2 \code{\link{matrix}} with the current solution. In Column "p" is the Index(!) of the predecessor (not the id) stored.}
#'        \item{\code{finaltableau}:}{A \code{\link{matrix}} with the results of every iteration. In Column "p" is the Index(!) of the predecessor (not the id) stored.}
#'      }
#'    }
#'    \item{\code{tpp}:}{Object of class \code{\link{list}}. The items in the list are:
#'      \describe{
#'        \item{x}{An object of type \code{\link{matrix}}, representing the Transportation Plan.}
#'        \item{cij}{An object of type \code{\link{matrix}}, representing the Transportation Costs.}
#'        \item{costfactor}{An object of type \code{\link{matrix}}, representing the Transportation Cost factor.}
#'      }
#'    }
#'  }
#'       @section Creating objects of type \code{\link{GeoSituation}}:
#'          \describe{
#'              \item{Creating an \code{S4-Object}}{
#'                  \code{new("GeoSituation", ...)}
#'              }
#'              \item{Using the user-friendly function}{
#'                  \code{new("GeoSituation",...)}
#'              }
#'          }
#'      @section Methods:
#' \describe{
#'    \item{\code{\link{plotGeoSituation}(x=GeoSituation, y=NULL, ...)}}{
#'      Creates a plot the current Situation.
#'    }
#'  }
#' @seealso \code{\link{Node}}, \code{\link{Link}}, \code{\link{Warehouse}}, \code{\link{Customer}}
#' @note
#'      for citing use: Felix Lindemann (2014). HNUORTools: Operations Research Tools. R package version 1.1-0. \url{http://felixlindemann.github.io/HNUORTools/}.
#'
#' @author Dipl. Kfm. Felix Lindemann \email{felix.lindemann@@hs-neu-ulm.de}
#'
#' Wissenschaftlicher Mitarbeiter
#' Kompetenzzentrum Logistik
#' Buro ZWEI, 17
#'
#' Hochschule fur angewandte Wissenschaften
#' Fachhochschule Neu-Ulm | Neu-Ulm University
#' Wileystr. 1
#'
#' D-89231 Neu-Ulm
#'
#'
#' Phone   +49(0)731-9762-1437
#' Web      \url{www.hs-neu-ulm.de/felix-lindemann/}
#'          \url{http://felixlindemann.blogspot.de}
#' @examples
#' # \code{citation("HNUORTools"}
#'
setClass(
  Class = "GeoSituation",
  representation=representation(
    id              = "character",
    label           = "character",
    nodes           = "Node",
    links           = "list",
    warehouses      = "Warehouse",
    customers       = "Customer",
    spp             = "list",
    tpp             = "list",
    tsp             = "list",
    wlp             = "list"
  ),
  prototype=prototype(
    list(
      id            = character(),
      label         = character(),
      nodes         = NULL,
      warehouses    = NULL,
      links         = list(),
      customers     = NULL,
      spp           = list(),
      tpp           = list(),
      tsp           = list(),
      wlp           = list()
    )
  )
)

################################### initialize - Method ###################################################
#' @title initialize Method
#' @name initialize
#' @aliases initialize,GeoSituation-method
#' @rdname initialize-methods
setMethod("initialize", signature="GeoSituation", function(.Object, data=NULL, ...) {

  li <- list(...)
  N<-1
  if(is.null(li$id)) {
    tmp.id <-NULL
    for(i in 1:N){
      tmp.id <- c(tmp.id, UUIDgenerate())
    }
    li$id <- tmp.id
    w <- paste("Random ID (",li$id,") provided. Uniqueness should be given.")

  }
  if(is.null(li$label)) {
    li$label <- li$id
  }
  .Object@id     <- as.character(li$id)
  .Object@label  <- as.character(li$label)

  .Object@nodes$id[1] <-"dummy"
  .Object@customers$id[1] <-"dummy"
  .Object@warehouses$id[1] <-"dummy"
  #.Object@links$id[1] <-"dummy"

  validObject(.Object)

  return(.Object )
})

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

#' @title Extract Methods
#' @name $
#' @rdname Extract-methods-1
#' @aliases $,GeoSituation-method
setMethod("$","GeoSituation",function(x,name) {return(slot(x,name))})

#' @title Extract Methods
#' @name [
#' @aliases [,GeoSituation-method
#' @rdname Extract-methods-2
setMethod("[", "GeoSituation",
          function(x, i, j, drop){
            N <- length(x)
            if(min(i) <=0) stop("Index i out of bound. it must be positive non zero.")
            if(max(i) >N) stop("Index i out of bound. it must not be larger than the total length.")

            if(!missing(j)){
              if(class(j) == "character"){
                return(slot(x,j)[i])
              }
              if(class(j) == "integer"){
                return(slot(x,j)[i])
              }
            }
            df <- as.data.frame(x)[i,]
            return (new("Node", df))
          }
)
################################### Set - Method ###################################################

#' @title Set Methods
#' @name $<-
#' @aliases $<-,GeoSituation-method
#' @rdname Set-methods-1
setMethod("$<-","GeoSituation",function(x,name,value) {
  slot(x,name,check=TRUE) <- value
  valid<-validObject(x)
  return(x)
})

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

#' @title plotGeoSituation
#' @name plotGeoSituation
#' @export
#' @param object the \code{\link{GeoSituation}-Object} to be plotted
#' @param ... list of optional values (see below)
#' @rdname plotGeoSituation
#' @details Optional Parameters for this Methdod.
#'      @section optional arguments:
#'        \describe{
#'
#'              \item{ as used in \code{plot.default}:}{
#'                  The parameters \code{xlim}, \code{ylim}, \code{xlab}, \code{ylab},
#'                  \code{main}, \code{sub}
#'                  recieve a default value, if not given. By default \code{asp=1} is set and should not be changed.
#'              }
#'              \item{\code{plotBorders}:}{
#'                   \code{\link{logical}} default = \code{FALSE}. If \code{TRUE}, the borders from the dataset bordersgermany.polygon will be drawn.
#'              }
#'              \item{\code{plotcities}:}{
#'                  \code{\link{logical}} default = \code{FALSE}. If \code{TRUE}, the cities from the dataset bordersgermany.cities will be drawn.
#'              }
#'              \item{\code{plotGrid}:}{
#'                  \code{\link{logical}} default = \code{FALSE}. If \code{TRUE}, a grid will be drawn using the function \code{\link{grid}}.
#'              }
#'              \item{\code{drawNodes}:}{
#'                  \code{\link{logical}} default = \code{TRUE}. If \code{TRUE}, all \code{\link{Node}s} in \code{x (of type \link{GeoSituation}} will be plotted.
#'              }
#'              \item{\code{drawWarehouses}:}{
#'                  \code{\link{logical}} default = \code{TRUE}. If \code{TRUE}, all \code{\link{Warehouse}s} in \code{x (of type \link{GeoSituation}} will be plotted.
#'              }
#'              \item{\code{drawCustomers}:}{
#'                  \code{\link{logical}} default = \code{TRUE}. If \code{TRUE}, all \code{\link{Customer}s} in \code{x (of type \link{GeoSituation}} will be plotted by calling \code{\link{drawCustomers}}.
#'              }
#'              \item{\code{drawLinks}:}{
#'                  \code{\link{logical}} default = \code{TRUE}. If \code{TRUE}, all \code{\link{Link}s} in \code{x (of type \link{GeoSituation}} will be plotted.
#'              }
#'        }
#'
setGeneric("plotGeoSituation",  function(object,...)  standardGeneric("plotGeoSituation") )
#' @name plotGeoSituation
#' @aliases plotGeoSituation,GeoSituation-method
#' @rdname plotGeoSituation
setMethod("plotGeoSituation", signature = c("GeoSituation"),
          definition = function(object, ...){

            li<-list(...)
            if(is.null(li$asp)) li$asp <- 1
            if(is.null(li$xlab)) li$xlab <- ""
            if(is.null(li$ylab)) li$ylab <- ""
            if(is.null(li$main)) li$main <- ""

            if(is.null(li$plotGrid))    li$plotGrid<- FALSE
            if(is.null(li$plotBorders)) li$plotBorders<- FALSE
            if(is.null(li$plotCities))  li$plotCities <- FALSE
            if(is.null(li$drawVRP))  li$drawVRP <- FALSE
            if(is.null(li$drawTSP))  li$drawTSP <- FALSE
            if(is.null(li$drawTPP))  li$drawTPP <- FALSE
            if(is.null(li$drawWLP))  li$drawWLP <- FALSE

            if(is.null(li$drawNodes)) {
              if(length(object$nodes) ==1 & object$nodes$id[1] == "dummy"){
                li$drawNodes<- FALSE
              }else{
                li$drawNodes<- TRUE
              }
            }
            if(is.null(li$drawLinks)) li$drawLinks<- TRUE
            if(is.null(li$drawCustomers)) {
              if(length(object$customers) ==1 & object$customers$id[1] == "dummy"){
                li$drawCustomers<- FALSE
              }else{
                li$drawCustomers<- TRUE
              }
            }
            if(is.null(li$drawWarehouses)) {
              if(length(object$warehouses) ==1 & object$warehouses$id[1] == "dummy"){
                li$drawWarehouses<- FALSE
              }else{
                li$drawWarehouses<- TRUE
              }
            }

            if(li$plotBorders){

              message("plotGeoSitatuon.bordersgermany\n")
              bordersgermany.polygon <- NULL
              cities <- NULL

              if(is.null(cities)) data(bordersgermany, envir = environment())
              #stop("Cities of Germany not found. Has the data 'bordersgermany' been loaded?")
              if(is.null(bordersgermany.polygon)) stop("Polygons of Germany not found. Has the data 'bordersgermany' been loaded?")

              if(is.null(li$xlim)) li$xlim<- c(0,620)
              if(is.null(li$ylim)) li$ylim<- c(0,850)
              if(is.null(li$polygons.border.color)) li$polygons.border.color<- 1
              if(is.null(li$polygons.fill.color)) li$polygons.fill.color<- "gray98"

              if(is.null(li$plotPolygons)) li$plotPolygons <- 1:length(bordersgermany.polygon)
              if(is.null(li$plotCities))   li$plotCities <- TRUE

              plot(NA, NA, xlim = li$xlim, ylim = li$ylim, asp=li$asp, xlab="", ylab="" )

              for(i in li$plotPolygons){
                l<-bordersgermany.polygon[[i]]
                for(j in 1:length(l)){
                  l.c <-l[[j]]

                  #lines(l.c[,1], l.c[,2], ...)
                  polygon(c(l.c[,1],l.c[1,1]), c(l.c[,2],l.c[1,2]),
                          border = li$polygons.border.color ,
                          col = li$polygons.fill.color )
                }
              }
              if(li$plotCities)
                points(cities$x, cities$y, ...)

            }else{

              if(is.null(li$xlim)){#
                if(li$drawNodes)      li$xlim <- c(li$xlim, object$nodes$x)
                if(li$drawCustomers)  li$xlim <- c(li$xlim, object$customers$x)
                if(li$drawWarehouses) li$xlim <- c(li$xlim, object$warehouses$x)

                li$xlim <- range(li$xlim) + c(-10,10)
              }#
              if(is.null(li$ylim)){#
                if(li$drawNodes)      li$ylim <- c(li$ylim, object$nodes$y)
                if(li$drawCustomers)  li$ylim <- c(li$ylim, object$customers$y)
                if(li$drawWarehouses) li$ylim <- c(li$ylim, object$warehouses$y)
                li$ylim <- range(li$ylim)  + c(-10,10)
              }#
              plot(NULL,NULL, #
                   xlim = li$xlim, #
                   ylim = li$ylim,#
                   xlab = li$xlab,#
                   ylab = li$ylab,#
                   main = li$main,#
                   sub  = li$sub,
                   asp  = li$asp
              )#
            }
            if(li$drawLinks) drawLinks(object,  ...)
            if(li$drawNodes) drawNodes(object,  ...)
            if(li$drawWarehouses) drawWarehouses(object,  ...)
            if(li$drawCustomers) drawCustomers(object,  ...)
            if(li$drawVRP) drawVRP(object,  ...)
            if(li$drawTSP) drawTSP(object,  ...)
            if(li$drawTPP) drawTPP(object,  ...)
            if(li$drawWLP) drawWLP(object,  ...)

          })

#' @title drawCustomers
#' @name drawCustomers
#' @aliases drawCustomers
#' @rdname drawCustomers
#' @param object the \code{\link{GeoSituation}-Object(s)} to be plotted
#' @param ... list of optional values (see below)
#' @export
#' @details Optional Parameters for this Methdod.
#'      @section optional arguments:
#'        \describe{
#'              \item{\code{zoom}:}{
#'                  \code{\link{numeric}} default = \code{0.1}. Used as a scale for the House-Polygons.
#'              }
#'              \item{\code{withlabels}:}{
#'                  \code{\link{logical}} default = \code{TRUE}. If \code{TRUE}, labels will be printed for each customer.
#'              }
#'              \item{\code{customer.font.cex}:}{
#'                  \code{\link{numeric}} default = 1. Defines with which font-size the labels will be printed.
#'              }
#'              \item{\code{customer.font.col}:}{
#'                  \code{\link{numeric} or \link{character}} default = \code{"black"}. The color the labels should be printed in.
#'                  Can be an Array of length of Customers to provide different colors. By default, the provided value will be
#'                  copied.
#'              }
#'              \item{\code{customer.bg.col}:}{
#'                  \code{\link{numeric} or \link{character}} default = \code{"gray"}. The color the warehouses-background should be printed in.
#'                  Can be an Array of length of Customers to provide different colors. By default, the provided value will be
#'                  copied.
#'              }
#'              \item{\code{customer.borders.col}:}{
#'                  \code{\link{numeric} or \link{character}} default = \code{"black"}. The color the warehouses-outline should be printed in.
#'                  Can be an Array of length of Customers to provide different colors. By default, the provided value will be
#'                  copied.
#'              }
#'              \item{\code{customer.point.pch}:}{
#'                  \code{\link{numeric}} default = \code{20}. defines the pch of the customers. can be an array of length of customers.
#'                  By default, the provided value will be copied.
#'              }
#'              \item{\code{customer.point.cex}:}{
#'                  \code{\link{numeric}} default = \code{1}. defines the cex of the customers. can be an array of length of customers.
#'                  By default, the provided value will be copied.
#'              }
#'        }
setGeneric("drawCustomers",  function(object,...)  standardGeneric("drawCustomers") )
#' @name drawCustomers
#' @aliases drawCustomers,GeoSituation-method
#' @rdname drawCustomers
setMethod("drawCustomers", signature = c("GeoSituation"),
          definition = function(object, ...){
            li<-list(...)
            n<-length(object$customers)
            if(n>0){
              if(is.null(li$zoom )) li$zoom <- .5
              if(is.null(li$withlabels)) li$withlabels<- TRUE

              if(is.null(li$customer.font.cex )) li$customer.font.cex <- 1
              if(is.null(li$customer.font.col )) li$customer.font.col <- "black"

              if(is.null(li$customer.bg.col )) li$customer.bg.col <- "gray"
              if(is.null(li$customer.border.col )) li$customer.border.col <- "black"

              if(is.null(li$customer.point.pch )) li$customer.point.pch <- 20
              if(is.null(li$customer.point.cex )) li$customer.point.cex <- 1#

              # Copy, if not of length n
              if(length(li$customer.font.col) != n) li$customer.font.col <- rep(li$customer.font.col, n)
              if(length(li$customer.bg.col) != n)   li$customer.bg.col   <- rep(li$customer.bg.col, n)
              if(length(li$customer.point.pch) != n) li$customer.point.pch <- rep(li$customer.point.pch, n)
              if(length(li$customer.border.col) != n) li$customer.border.col <- rep(li$customer.border.col, n)

              if(n == 1 && object$customers$id[1]=="dummy"){
                #don't plot --> its the intial value
              }else{
                for(i in 1:n){
                  customer <- object$customers[i]

                  dx<-(c(0,0,-0.5,1,2.5,2,2,0)-1)*li$zoom + customer$x#
                  dy<-(c(0,2,2,3.5,2,2,0,0)-1.5) *li$zoom + customer$y#

                  polygon(dx, dy, col=li$customer.bg.col[i], border = li$customer.border.col[i])#

                  if(li$withlabels){
                    text(max(dx),min(dy)-1.5*li$zoom, customer$id,
                         cex=li$customer.font.cex[i],
                         col=li$customer.font.col[i])#
                  }
                }
                points(object$customers$x,object$customers$y,
                       pch=li$customer.point.pch,
                       cex=li$customer.point.cex
                )#
              }
              #message("hier2")
              li$withlabels <-li$withlabels
            }
          }
)

#' @title drawWarehouses
#' @name drawWarehouses
#' @rdname drawWarehouses
#' @param object the \code{\link{GeoSituation}-Object(s)} to be plotted
#' @param ... list of optional values (see below)
#' @export
#' @details Optional Parameters for this Methdod.
#'      @section optional arguments:
#'        \describe{
#'              \item{\code{zoom}:}{
#'                  \code{\link{numeric}} default = \code{0.1}. Used as a scale for the House-Polygons.
#'              }
#'              \item{\code{withlabels}:}{
#'                  \code{\link{logical}} default = \code{TRUE}. If \code{TRUE}, labels will be printed for each warehouse.
#'              }
#'              \item{\code{isWLP}:}{
#'                  \code{\link{logical}} default = \code{FALSE}. If \code{TRUE}, closed Warehouses will be printed blank.
#'              }
#'              \item{\code{warehouse.font.cex}:}{
#'                  \code{\link{numeric}} default = 1. Defines with which font-size the labels will be printed.
#'              }
#'              \item{\code{warehouse.font.col}:}{
#'                  \code{\link{numeric} or \link{character}} default = \code{"black"}. The color the labels should be printed in.
#'                  Can be an Array of length of Warehouses to provide different colors. By default, the provided value will be
#'                  copied.
#'              }
#'              \item{\code{warehouse.bg.col}:}{
#'                  \code{\link{numeric} or \link{character}} default = \code{"gray"}. The color the warehouses-background should be printed in.
#'                  Can be an Array of length of Warehouses to provide different colors. By default, the provided value will be
#'                  copied.
#'              }
#'              \item{\code{warehouse.borders.col}:}{
#'                  \code{\link{numeric} or \link{character}} default = \code{"black"}. The color the warehouses-outline should be printed in.
#'                  Can be an Array of length of Warehouses to provide different colors. By default, the provided value will be
#'                  copied.
#'              }
#'              \item{\code{warehouse.point.pch}:}{
#'                  \code{\link{numeric}} default = \code{20}. defines the pch of the warehouses. can be an array of length of warehouses.
#'                  By default, the provided value will be copied.
#'              }
#'              \item{\code{warehouse.point.cex}:}{
#'                  \code{\link{numeric}} default = \code{1}. defines the cex of the warehouses. can be an array of length of warehouses.
#'                  By default, the provided value will be copied.
#'              }
#'        }
setGeneric("drawWarehouses",  function(object,...)  standardGeneric("drawWarehouses") )
#' @name drawWarehouses
#' @aliases drawWarehouses,GeoSituation-method
#' @rdname drawWarehouses
setMethod("drawWarehouses", signature = c("GeoSituation"),
          ## alt. declaration setMethod("drawWarehouses", signature = "GeoSituation"
          ## missing Arguments will be handled as "ANY" by default
          definition = function(object, ...){
            li<-list(...)
            n<-length(object$warehouses)
            if(n>0){
              if(is.null(li$zoom )) li$zoom <- .5
              if(is.null(li$withlabels)) li$withlabels<- TRUE
              if(is.null(li$isWLP)) li$isWLP<- FALSE

              if(is.null(li$warehouse.font.cex )) li$warehouse.font.cex <- 1
              if(is.null(li$warehouse.font.col )) li$warehouse.font.col <- "black"

              if(is.null(li$warehouse.bg.col )) li$warehouse.bg.col <- "gray"
              if(is.null(li$warehouse.border.col )) li$warehouse.border.col <- "black"

              if(is.null(li$warehouse.point.pch )) li$warehouse.point.pch <- 20
              if(is.null(li$warehouse.point.cex )) li$warehouse.point.cex <- 1#

              # Copy, if not of length n
              if(length(li$warehouse.font.col) != n) li$warehouse.font.col <- rep(li$warehouse.font.col, n)
              if(length(li$warehouse.bg.col) != n)   li$warehouse.bg.col   <- rep(li$warehouse.bg.col, n)
              if(length(li$warehouse.point.pch) != n) li$warehouse.point.pch <- rep(li$warehouse.point.pch, n)
              if(length(li$warehouse.border.col) != n) li$warehouse.border.col <- rep(li$warehouse.border.col, n)

              for(i in 1:n){
                warehouse <- object$warehouses[i]

                if(li$isWLP & warehouse$open == 0) li$warehouse.bg.col <- "white"

                dx<-(c(0,0,1,1,2,2,3,3,4,4,5,5,0)-2.5)*li$zoom + warehouse$x#
                dy<-(c(0,3.5,2,3.5,2,3.5,2,3.5,2,5,5,0,0)-1.5) *li$zoom + warehouse$y#

                polygon(dx, dy, col=li$warehouse.bg.col[i], border = li$warehouse.border.col[i])#

                if(li$withlabels){
                  text(max(dx),min(dy)-1.5*li$zoom, warehouse$id,
                       cex=li$warehouse.font.cex[i],
                       col=li$warehouse.font.col[i])#
                }
              }
              points(object$warehouses$x,object$warehouses$y,
                     pch=li$warehouse.point.pch,
                     cex=li$warehouse.point.cex
              )#
            }
          }
)

#' @title drawNodes
#' @name drawNodes
#' @rdname drawNodes
#' @export
#' @param object the \code{\link{GeoSituation}-Object(s)} to be plotted
#' @param ... list of optional values (see below)
#' @export
#' @details Optional Parameters for this Methdod.
#'      @section optional arguments:
#'        \describe{
#'              \item{\code{withlabels}:}{
#'                  \code{\link{logical}} default = \code{TRUE}. If \code{TRUE}, labels will be printed for each Node.
#'              }
#'              \item{\code{pch}:}{
#'                  \code{\link{numeric}} default = 21. Defines the point-Type to be used.
#'              }
#'              \item{\code{point.cex}:}{
#'                  \code{\link{numeric}} default = 3. Defines the size of the points.
#'              }
#'              \item{\code{font.cex}:}{
#'                  \code{\link{numeric}} default = 3. Defines the size of the font.
#'              }
#'              \item{\code{bg}:}{
#'                  \code{\link{numeric} or \link{character}} default = \code{"white"}. The background-color the node-background should be printed in.
#'              }
#'              \item{\code{col}:}{
#'                  \code{\link{numeric} or \link{character}} default = \code{"black"}. The foreground-color the node-outline should be printed in.
#'              }
#'        }
setGeneric("drawNodes",  function(object,...)  standardGeneric("drawNodes") )

#' @name drawNodes
#' @aliases drawNodes,GeoSituation-method
#' @rdname drawNodes
setMethod("drawNodes",signature(object="GeoSituation"),
  function(object,...){
    li<-list(...)
    n<-length(object$nodes)
    if(n>0){

      if(is.null(li$withlabels)) li$withlabels<- TRUE

      if(is.null(li$pch)) li$pch<- 21
      if(is.null(li$point.cex)) li$point.cex<- 3
      if(is.null(li$font.cex)) li$font.cex<- 0.75

      if(is.null(li$bg))  li$bg<- "white"
      if(is.null(li$col)) li$col<- 1

      x <- object$nodes$x#
      y <- object$nodes$y#
      points(x,y,pch = li$pch, bg = li$bg , cex=li$point.cex)#

      if(li$withlabels){
        text(x,y, object$nodes$id, cex=li$font.cex,col=li$col)#
      }
    }
  }
)

#' @title drawLinks
#' @name drawLinks
#' @rdname drawLinks
#' @export
#' @param object the \code{\link{GeoSituation}-Object(s)} to be plotted
#' @param ... list of optional values (see below)
#' @export
#' @details Optional Parameters for this Methdod.
#'      @section optional arguments:
#'        \describe{
#'              \item{\code{withlabels}:}{
#'                  \code{\link{logical}} default = \code{TRUE}. If \code{TRUE}, labels will be printed for each Node.
#'              }
#'              \item{\code{pch}:}{
#'                  \code{\link{numeric}} default = 21. Defines the point-Type to be used.
#'              }
#'              \item{\code{point.cex}:}{
#'                  \code{\link{numeric}} default = 3. Defines the size of the points.
#'              }
#'              \item{\code{font.cex}:}{
#'                  \code{\link{numeric}} default = 3. Defines the size of the font.
#'              }
#'              \item{\code{bg}:}{
#'                  \code{\link{numeric} or \link{character}} default = \code{"white"}. The background-color the node-background should be printed in.
#'              }
#'              \item{\code{col}:}{
#'                  \code{\link{numeric} or \link{character}} default = \code{"black"}. The foreground-color the node-outline should be printed in.
#'              }
#'        }
setGeneric("drawLinks",  function(object,...)  standardGeneric("drawLinks") )

#' @name drawLinks
#' @aliases drawLinks,GeoSituation-method
#' @rdname drawLinks
setMethod("drawLinks",signature(object="GeoSituation"),
  function(object,...){
    li<-list(...)
    n<-length(object$links)
    if(n>0){

      if(is.null(li$pch)) li$pch<- 21
      if(is.null(li$p.cex)) li$lines.p.cex<- 2
      if(is.null(li$t.cex)) li$lines.t.cex<- 0.5
      if(is.null(li$lwd)) li$lwd<- 1
      if(is.null(li$bg))  li$bg<- "white"
      if(is.null(li$lines.markused)) li$lines.markused<- TRUE
      if(is.null(li$lines.plotlength)) li$lines.plotlength<- FALSE
      if(is.null(li$lines.plotcosts)) li$lines.plotcosts<- FALSE
      if(is.null(li$lwd.used)) li$lwd.used<- li$lwd*3
      if(is.null(li$lty)) li$lty<- 1
      if(is.null(li$col)) li$col<- 1
      if(is.null(li$colused)) li$colused<- "red"

      for(i in 1:n){
        link <- object$links[[i]]
        x<- c(link$origin$x, link$destination$x)
        y<- c(link$origin$y, link$destination$y)
        if(link$used & li$lines.markused){
          lines(x,y,lty=li$lty, lwd=li$lwd.used, col=li$colused)#
        }
        lines(x,y,lty=li$lty, lwd=li$lwd, col=li$col)#
        if(li$lines.plotlength){
          x <- sum(x)/2
          y <- sum(y)/2
          points(x,y,pch = li$pch, bg = li$bg , cex=li$lines.p.cex)#
          if(li$lines.plotcosts){
            text(x,y, link$costs, cex=li$lines.t.cex,col=li$col)#
          }else{
            text(x,y, link$distance, cex=li$lines.t.cex,col=li$col)#
          }
        }
      }
    }
  }
)

#' @title drawVRP
#' @name drawVRP
#' @rdname drawVRP-method
#' @export
#' @param object the \code{\link{GeoSituation}-Object(s)} to be plotted
#' @param ... list of optional values (see below)
#' @export
#' @details Optional Parameters for this Methdod.
#'      @section optional arguments:
#'        \describe{
#'              \item{\code{drawroutingtowarehouse}:}{
#'                  \code{\link{logical}} default = \code{TRUE}. If \code{TRUE}, routes will be connected to the delivering \code{\link{Warehouse}}.
#'              }
#'              \item{\code{arrow.bg.col}:}{
#'                  \code{\link{numeric}} or \code{\link{character}} default = 1. A vector of length 1 or M (=number of \code{\link{Warehouse}s}). Colornames are accepted as well
#'              }
#'        }
#'      @section arguments are forwarded to the following functions:
#'        \describe{
#'              \item{\code{arrows}:}{ the routing will be drawn using this functions. attributes \code{x1},\code{y1},\code{col} are blocked }
#'        }
setGeneric("drawVRP",  function(object,...)  standardGeneric("drawVRP") )

#' @aliases drawVRP,GeoSituation
#' @rdname drawVRP-method
setMethod("drawVRP",signature(object="GeoSituation"),
          function(object, ...){
           # message("drawVRP\n")
            li <- list(...)
            #check if is VRP
            M<- length(object$warehouses)
            if(M < 1) stop("This is not a VRP - no warehouse has been found.")
            # set default values
            if(is.null(li$drawroutingtowarehouse)) li$drawroutingtowarehouse <- TRUE

            if(is.null(li$log ))     li$log   		<- FALSE
            if(is.null(li$arrow.Tips ))     li$arrow.Tips   		<- .15
            if(is.null(li$arrow.Code )) 		li$arrow.Code 			<- 2
            if(is.null(li$arrow.lwd ))  		li$arrow.lwd 			<- 2
            if(is.null(li$arrow.bg.col ))    	li$arrow.bg.col 		<- 1
            if(length(li$arrow.bg.col)!=M) li$arrow.bg.col <- rep(li$arrow.bg.col, M)

            #iterate over all warehouses (multiwarehouse vrp.)
            for(m in 1:M){
              #get Current Warehouse
              w <- object$warehouses[m]

              vrp<- object$warehouses$vrp[[m]]
              # if tours exists
              if(!is.null(vrp$tours)){
                #iterate over all tours
                for(t in 1:length(vrp$tours)){
                  #select current tour
                  tour <- vrp$tours[[t]]

                  if(length(tour)>1){
                    #get the number of stops
                    n<-tour$stops

                    if (n==0){
                      # do nothing - if no stops are assigned.
                    }else if(n ==1){
                      # if it's a "pendeltour", draw both ways
                      # code = 3 doesn't work for generality reasons,
                      # if code=3 is assigned as default,
                      # users will not be able to define the arrows-code-attribute
                      # without getting errors.
                      n1<- tour$stops.list[[1]]
                      arrows(
                        w$x, w$y, x1 = n1$x, y1 = n1$y,
                        code  = li$arrow.Code,
                        length	= li$arrow.Tips,
                        lwd		= li$arrow.lwd,
                        col		= li$arrow.bg.col[m]
                      )
                      arrows(
                        n1$x, n1$y, x1 = w$x, y1 = w$y,
                        code  = li$arrow.Code,
                        length	= li$arrow.Tips,
                        lwd		= li$arrow.lwd,
                        col		= li$arrow.bg.col[m]
                      )
                    } else{
                      # more than one stop is assigned
                      for(i in 1:(n-1)){
                        # get first stop
                        n1<- tour$stops.list[[i]]

                        if(li$drawroutingtowarehouse & i==1){
                          # draw connection of depot,
                          # if this variable is set
                          # draw the connection from the depot to the first stop
                          arrows(
                            w$x, w$y, x1 = n1$x, y1 = n1$y,
                            code  = li$arrow.Code,
                            length  = li$arrow.Tips,
                            lwd		= li$arrow.lwd,
                            col		= li$arrow.bg.col[m]
                          )
                          # draw the connection from the last stop to depot
                          n2 <- tour$stops.list[[n]]
                          arrows(
                            n2$x, n2$y, x1 = w$x, y1 = w$y,
                            code  = li$arrow.Code,
                            length  = li$arrow.Tips,
                            lwd  	= li$arrow.lwd,
                            col		= li$arrow.bg.col[m]
                          )
                        }
                        # get following node of n1 and draw the connection
                        n2<-tour$stops.list[[i+1]]
                        arrows(
                          n1$x, n1$y, x1 = n2$x, y1 = n2$y,
                          code  = li$arrow.Code,
                          length  = li$arrow.Tips,
                          lwd    = li$arrow.lwd,
                          col		= li$arrow.bg.col[m]
                        )
                      }
                    }
                  }
                }
              }
            }
          }
)

#' @title drawTSP
#' @name drawTSP
#' @rdname drawTSP-method
#' @export
#' @param object the \code{\link{GeoSituation}-Object(s)} to be plotted
#' @param ... list of optional values (see below)
#' @export
#' @details Optional Parameters for this Methdod.
#'      @section optional arguments:
#'        \describe{
#'            \item{startnode.bg.col}{\emph{Optional Parameter} Defines the background-color of the start-node. Default value is 2.}
#'            \item{startnode.bg.pch}{\emph{Optional Parameter} Defines the background-point-Style of the start-node. Default value is 20.}
#'            \item{startnode.bg.cex}{\emph{Optional Parameter} Defines the background-size of the start-node. Default value is 3.}
#'            \item{startnode.fg.col}{\emph{Optional Parameter} Defines the foreground-color of the start-node. Default value is 1.}
#'            \item{startnode.fg.pch}{\emph{Optional Parameter} Defines the foreground-point-Style of the start-node. Default value is 20.}
#'            \item{startnode.fg.cex}{\emph{Optional Parameter} Defines the foreground-size of the start-node. Default value is 1.}
#'        }
#'      @section arguments are forwarded to the following functions:
#'        \describe{
#'              \item{\code{arrows}:}{ the routing will be drawn using this functions. attributes \code{x1},\code{y1}  are blocked }
#'        }
setGeneric("drawTSP",  function(object,...)  standardGeneric("drawTSP") )

#' @aliases drawTSP,GeoSituation
#' @rdname drawTSP-method
setMethod("drawTSP",signature(object="GeoSituation"),
          function(object, ...){
            message("TSP.drawrouting\n")
            li <- list(...)

            if(is.null(li$arrow.Tips ))   	li$arrow.Tips 			<- .15
            if(is.null(li$arrow.Code )) 		li$arrow.Code 			<- 2
            if(is.null(li$arrow.lwd ))  		li$arrow.lwd 			<- 2
            if(is.null(li$arrow.bg.col ))    	li$arrow.bg.col 		<- 1

            if(is.null(li$startnode.bg.col)) li$startnode.bg.col <- 2
            if(is.null(li$startnode.bg.pch)) li$startnode.bg.pch <- 20
            if(is.null(li$startnode.bg.cex)) li$startnode.bg.cex <- 3

            if(is.null(li$startnode.fg.col)) li$startnode.fg.col <- 1
            if(is.null(li$startnode.fg.pch)) li$startnode.fg.pch <- 20
            if(is.null(li$startnode.fg.cex)) li$startnode.fg.cex <- 1

            n<- length(object$tsp$nodes)
            if(n <=1) stop("This is not a TSP.")
            if(nrow(object$tsp$x) != n) stop("Error. TSP not correctly initalized")

            n1 <- object$tsp$nodes[object$tsp$StartNode ]
            points(n1$x, n1$y, cex=li$startnode.bg.cex, pch=li$startnode.bg.pch, col=li$startnode.bg.col)
            points(n1$x, n1$y, cex=li$startnode.fg.cex, pch=li$startnode.fg.pch, col=li$startnode.fg.col)
            for(i in 1:n){
              n1<- object$tsp$nodes[i]
              for(j in 1:n){
                if(object$tsp$x[i,j] == 1){
                  n2<-object$tsp$nodes[j]
                  arrows(
                    n1$x, n1$y, x1 = n2$x, y1 = n2$y,
                    code	= li$arrow.Code,
                    length	= li$arrow.Tips,
                    lwd		= li$arrow.lwd,
                    col		= li$arrow.bg.col
                  )
                }
              }
            }
          }
)

#' @title drawWLP
#' @name drawWLP
#' @rdname drawWLP
#' @export
#' @param object the \code{\link{GeoSituation}-Object(s)} to be plotted
#' @param ... list of optional values (see below)
#' @export
#' @details Optional Parameters for this Methdod.
#'      @section optional arguments:
#'        \describe{
#'              \item{\code{...}:}{
#'                  Is forwarded to \code{\link{drawTPP}}.
#'              }
#'        }
setGeneric("drawWLP",  function(object,...)  standardGeneric("drawWLP") )

#' @name drawWLP
#' @aliases drawWLP,GeoSituation-method
#' @rdname drawWLP
setMethod("drawWLP",signature(object="GeoSituation"),
  function(object,...){
    drawTPP(object, isWLP=TRUE, ...)
  }
)

#' @title drawTPP
#' @name drawTPP
#' @rdname drawTPP
#' @export
#' @param object the \code{\link{GeoSituation}-Object(s)} to be plotted
#' @param ... list of optional values (see below)
#' @export
#' @details Optional Parameters for this Methdod.
#'      @section optional arguments:
#'        \describe{
#'              \item{\code{withlabels}:}{
#'                  \code{\link{logical}} default = \code{TRUE}. If \code{TRUE}, labels will be printed for each Node.
#'              }
#'        }
setGeneric("drawTPP",  function(object,...)  standardGeneric("drawTPP") )

#' @name drawTPP
#' @aliases drawTPP,GeoSituation-method
#' @rdname drawTPP
setMethod("drawTPP",signature(object="GeoSituation"),
  function(object,...){
    li<-list(...)
    x<- NA
    if(is.null(li$isWLP)) li$isWLP <- FALSE

    if(li$isWLP){
      x <- object$wlp$x		# store transportplan locally
    }else{
      x <- object$tpp$x		# store transportplan locally
    }
    I <- length(object$warehouses)
    J <- length(object$customers)
    if(length(x) == I * J){

      if(is.null(li$arrow.textposition )) li$arrow.textposition 	<- 2/3
      if(is.null(li$arrow.Tips )) 		li$arrow.Tips 			<- .15
      if(is.null(li$arrow.Code )) 		li$arrow.Code 			<- 2
      if(is.null(li$arrow.lwd ))  		li$arrow.lwd 			<- 2
      if(is.null(li$arrow.bg.col ))  		li$arrow.bg.col 		<- 1
      if(is.null(li$arrow.font.col )) 	li$arrow.font.col 		<- 1
      if(is.null(li$arrow.font.cex )) 	li$arrow.font.cex 		<- .75
      if(is.null(li$arrow.point.col )) 	li$arrow.point.col 		<- 1
      if(is.null(li$arrow.point.pch )) 	li$arrow.point.pch 		<- 21
      if(is.null(li$arrow.point.bg )) 	li$arrow.point.bg 		<- "white"
      if(is.null(li$arrow.point.cex )) 	li$arrow.point.cex 		<- 4
      if(is.null(li$arrow.cex )) 			li$arrow.cex 			<- 1

      if(length(li$arrow.bg.col	)!=I) 	li$arrow.bg.col 		<- rep(li$arrow.bg.col, I)
      if(length(li$arrow.font.col )!=I) 	li$arrow.font.col 		<- rep(li$arrow.font.col, I)
      if(length(li$arrow.point.bg )!=I) 	li$arrow.point.bg 		<- rep(li$arrow.point.bg, I)

      for(i in 1:I){
        warehouse <- object$warehouses[i]
        for(j in 1:J){
          customer <- object$customers[j]
          if(x[i,j]> 0) {
            arrows(
              warehouse$x,warehouse$y, 	# From
              customer$x,customer$y, 		# TO
              code	= li$arrow.Code,
              length	= li$arrow.Tips,
              lwd		= li$arrow.lwd,
              col		= li$arrow.bg.col[i]
            )
            if(!li$isWLP){

              points( warehouse$x + li$arrow.textposition *(customer$x-warehouse$x),
                      warehouse$y + li$arrow.textposition *(customer$y-warehouse$y),
                      pch=li$arrow.point.pch,
                      cex=li$arrow.point.cex,
                      bg =li$arrow.point.bg[i],
                      col=li$arrow.point.col
              )
              text(warehouse$x + li$arrow.textposition *(customer$x-warehouse$x),
                   warehouse$y + li$arrow.textposition *(customer$y-warehouse$y),
                   x[i,j],
                   cex=li$arrow.font.cex,
                   col=li$arrow.font.col
              )

            }
          }
        }
      }
    }
  }
)
##############################################################
#' @name add
#' @docType methods
#' @export
#' @rdname GeoSituation-Add-method
#'
#' @title Add an Object to a \code{\link{GeoSituation}}
#' @description This method should simplify the use of HNUORTools.
#'
#' @param object an object of class \code{\link{GeoSituation}}
#' @param value an object of class \code{\link{Node}}, \code{\link{Link}}, \code{\link{Customer}} or \code{\link{Warehouse}}
#' @param ... Additional argument list that might not ever be used.
#' @return The updated object of class \code{\link{GeoSituation}}.
#' @note
#'      for citing use: Felix Lindemann (2014). HNUORTools: Operations Research Tools. R package version 1.1-0. \url{http://felixlindemann.github.io/HNUORTools/}.
#'
#' @author Dipl. Kfm. Felix Lindemann \email{felix.lindemann@@hs-neu-ulm.de}
#'
#' Wissenschaftlicher Mitarbeiter
#' Kompetenzzentrum Logistik
#' Buro ZWEI, 17
#'
#' Hochschule fur angewandte Wissenschaften
#' Fachhochschule Neu-Ulm | Neu-Ulm University
#' Wileystr. 1
#'
#' D-89231 Neu-Ulm
#'
#'
#' Phone   +49(0)731-9762-1437
#' Web      \url{www.hs-neu-ulm.de/felix-lindemann/}
#'      \url{http://felixlindemann.blogspot.de}
setGeneric("add",  function(object,value,...)  standardGeneric("add") )

#' @aliases add,GeoSituation,Node-method
#' @rdname GeoSituation-Add-method
setMethod("add",signature(object="GeoSituation", value="Node"),
          function(object,value,...){
            if(validObject(value) & is.Node(value)){
              n<- length(object@nodes)
              if(n==1 & object@nodes$id[1] == "dummy"){
                object@nodes<- value
              }else{

                df<-as.data.frame(object@nodes)
                df<-rbind(df,as.data.frame(value))
                object@nodes <- as.Node(df)
              }
            }
            return(object)
          }
)

#' @aliases add,GeoSituation,Customer-method
#' @rdname GeoSituation-Add-method
setMethod("add",signature(object="GeoSituation", value="Customer"),
          function(object,value,...){
            if(validObject(value) & is.Customer(value)){
              n<- length(object@customers)
              if(n==1 & object@customers$id[1] == "dummy"){
                object@customers<- value
              }else{

                df<-as.data.frame(object@customers)
                df<-rbind(df,as.data.frame(value))
                object@customers <- as.Customer(df)
              }
            }
            return(object)
          }
)

#' @aliases add,GeoSituation,Warehouse-method
#' @rdname GeoSituation-Add-method
setMethod("add",signature(object="GeoSituation", value="Warehouse"),
          function(object,value,...){
            if(validObject(value) & is.Warehouse(value)){
              n<- length(object@warehouses)
              if(n==1 & object@warehouses$id[1] == "dummy"){

                object@warehouses$id <- value$id
                object@warehouses$label <- value@label
                object@warehouses$x     <- value@x
                object@warehouses$y     <- value@y
                object@warehouses$supply     <- value@supply
                object@warehouses$fixcosts     <- value@fixcosts
                object@warehouses$open     <- value@open
                object@warehouses$isDummy     <- value@isDummy
                object@warehouses$vrp     <- value@vrp

              }else{
                id <- c( object@warehouses$id , value$id )
                label <- c( object@warehouses$label ,  value@label )
                x <- c( object@warehouses$x ,  value@x )
                y <- c( object@warehouses$y ,  value@y)
                supply <- c( object@warehouses$supply ,  value@supply)
                fixcosts <- c( object@warehouses$fixcosts ,  value@fixcosts)
                open <- c( object@warehouses$open ,  value@open)
                isDummy <- c( object@warehouses$isDummy ,  value@isDummy)

                vrp <- object@warehouses@vrp
                for(i in 1:length(value@vrp)){
                  n<-length(vrp)
                  vrp[[n+1]] <- value@vrp[[i]]
                }
                object@warehouses <- new("Warehouse", id=id,
                         label = label,
                         x = x,
                         y = y,
                         supply = supply,
                         fixcosts = fixcosts,
                         open = open,
                         isDummy = isDummy)
                object@warehouses@vrp <- vrp
              }
            }
            return(object)
          }
)

#' @aliases add,GeoSituation,Link-method
#' @rdname GeoSituation-Add-method
setMethod("add",signature(object="GeoSituation", value="Link"),
          function(object,value,...){
            if(validObject(value) & is.Link(value)){
              n<- length(object@links)

                for(l in object$links){

                  if(l$origin$id == value$origin$id &
                        l$destination$id == value$destination$id){
                    # same link found
                    warning(paste("The link with id (",value$id,") was not added. The nodes n1(id=",
                                  value$origin$id,") and n2(id=",value$destination$id,
                                  ") are already connected. Please modify the existing link (id=",l$id,") if required."))
                    return(object)
                  } #end 1. if

                  if(l$origin$id == value$destination$id &
                        l$destination$id == value$origin$id
                        ){
                    if(l$oneway == FALSE){
                      # same link found
                      warning(paste("The link with id (",value$id,") was not added. The nodes n1(id=",
                                    value$origin$id,") and n2(id=",value$destination$id,
                                    ") are already connected. Please modify the existing link (id=",l$id,") if required."))
                      return(object)
                    }else{
                      #existing is marked as oneway
                      if (value$oneway == FALSE){

                        # same link found
                        warning(paste("The link with id (",value$id,") was not added. The nodes n1(id=",
                                      value$origin$id,") and n2(id=",value$destination$id,
                                      ") are already connected by a link that is marked as one-way.",
                                      "Adding this link would violate the existing setup.",
                                      "Please modify the link if (id=",l$id,") required or mark the new link as oneway, too."))
                        return(object)
                      }
                    } #end else

                  }# end 2nd if

                } # end for
              object$links[[n+1]] <- value

            }
            return(object)
          }
)


pdf("output.splice_events.pdf")
events=c(25.0,25.0,25.0)
pie(events,col=c(2,3,4),init.angle=30,angle=c(60,120,150),density=c(70,70,70),main="splicing events",labels=c("partial_novel 25%","complete_novel 25%","known 25%"))
dev.off()
pdf("output.splice_junction.pdf")
junction=c(33.3333333333,33.3333333333,33.3333333333)
pie(junction,col=c(2,3,4),init.angle=30,angle=c(60,120,150),density=c(70,70,70),main="splicing junctions",labels=c("partial_novel 33%","complete_novel 33%","known 33%"))
dev.off()


# Functions for performing permutations/bootstraps

# ====================================================================
# Exported Functions

# --------------------------------------------------------------------
#' Permute or Bootstrap DMR Detection
#'
#' Will perform permutations or bootstraps after methylaction() has been called. See also maPermMerge() and maPermFdr().
#' @param ma Output object from methylaction()
#' @param reads Preprocessed reads/fragments data from getReads()
#' @param nperms Number of permutation (or bootstrap) iterations to perform
#' @param combos A matrix of pre-set combinations to use. Useful for smaller sample sizes where there are only a limited number of possible combinations. The row should have ncols = number of samples, and each row represents a re-ordering of samples into groups (where the groups will be set in the order they appear in the "samp" given to methylaction())
#' @param save If true, save an RData file of the permutations. These can be merged using maPermMerge(). Useful for running permutations across multiple computers or in a cluster environment. If FALSE, will return the permutation results.
#' @param perm.boot If nperms > 0 and if TRUE, perform bootstrapping (sampling with replacement). Otherwise, perform permutations (sampling without permutations)
#' @param ncore Number of parallel processes to use
#' @return A list of DMRs arising from each permutation or bootstrap. Will save as an RData if save==TRUE.
#' @export
maPerm <- function(ma,reads,nperms,combos=NULL,save=T,perm.boot=F,ncore=1)
{
	perm.combo <- F
	args <- ma$args
	test.two <- ma$data$test.two
	samp <- ma$args$samp
	adjust.var <- ma$args$adjust.var
	windows <- ma$data$windows
	sizefactors <- ma$data$sizefactors
	stagetwo.method <- ma$args$stagetwo.method
	anodev.p <- ma$args$anodev.p
	post.p <- ma$args$post.p
	fdr.filter <- ma$data$fdr.filter
	fragsize <- ma$args$fragsize
	winsize <- ma$args$winsize
	dmrcalled <- ma$dmr
	freq <- ma$args$freq

	if(!is.null(combos))
	{
		nperms <- nrow(combos)
		perm.boot <- F
		perm.combo <- F
		stopifnot(ncol(combos)==nrow(samp))
	}

	doperm <- function(perm)
	{
		message("Permutation number ",perm)
		#host <- system2("hostname",stdout=TRUE)
		#write(paste0("Started permutation ",perm," on ",host," at ",date()),file=paste0(host,".txt"),append=TRUE)
		if(perm.combo==TRUE)
		{
			message("Drawing permutation order from combination space")
			ss <- as.vector(table(samp$groupcode))
			rand <- getComboSpacePerms(an=ss[1],bn=ss[2],cn=ss[3],nperms=1,ncore=ncore)[[1]]
		} else if (!is.null(combos)) {
			rand <- combos[perm,]
			message("Using pre-set combination vector:")
			print(rand)
		} else {
			rand <- sample(1:nrow(samp),nrow(samp),replace=perm.boot)
		}

		mysamp <- samp
		mysamp$sample <- samp$sample[rand]
		mysamp$bam <- samp$bam[rand]
		if(!is.null(adjust.var))
		{
			mysamp[[adjust.var]] <- samp[[adjust.var]][rand]
		}

		mybins <- windows$signal
		values(mybins) <- values(mybins)[,rand]
		mysig <- windows$signal.norm
		values(mysig) <- values(mysig)[,rand]
		mysizes <- sizefactors[rand]

		# rename samples so there are no identical names in the bootstrap case
		mysamp$sample <- paste0("BS",1:nrow(samp),mysamp$sample)
		names(mysizes) <- mysamp$sample
		colnames(values(mybins)) <- mysamp$sample
		colnames(values(mysig)) <- mysamp$sample

		# need to check for and randomize cov/reads here too
		mycov <- NULL
		myreads <- NULL

		if(stagetwo.method=="co")
		{
			# shuffle reads
			myreads <- reads[rand]
			names(myreads) <- mysamp$sample
		} else if(stagetwo.method=="ac")
		{
			# shuffle cov
			mycov <- cov[rand]
		}
		#message("T1")
		test.one <- methylaction:::testOne(samp=mysamp,bins=mybins,signal.norm=mysig,chrs=unique(as.vector(seqnames(mybins))),sizefactors=mysizes,stageone.p=ma$args$stageone.p,joindist=ma$args$joindist,minsize=ma$args$minsize,ncore=ncore)
		#message("T2")
		test.two <- methylaction:::testTwo(samp=mysamp, cov=mycov, reads=myreads, stagetwo.method=stagetwo.method, regions=test.one$regions, freq=freq, sizefactors=mysizes, fragsize=fragsize, winsize=winsize, anodev.p=anodev.p, post.p=post.p, adjust.var=adjust.var, fdr.filter=fdr.filter,ncore=ncore)
		if(is.list(test.two))
		{
			ret <- test.two$dmrcalled
		} else
		{
			ret <- test.two
		}

		rm(test.one,test.two,mybins,mysig)
		gc()
		#maperm2[[perm]] <<- ret
		#save(rand,file="permdump.rd",compress=T)
		return(ret)
	}

	deathproof <- function(x)
	{
		ret <- tryCatch(
			doperm(x),
			error = function(e)
			{
				message("Permutation ",x," had error: ",e$message)
				character()
			}
		)
		return(ret)
	}

	maperm <- lapply(1:nperms, deathproof)

	#ma$fdr <- fdr
	#ma$data$maperm <- maperm

	if(save==T)
	{
		# save Rd to disk that can be loaded using maPermMerge
		file <- paste0("maperm_",R.utils::getHostname.System(),"_",as.integer(as.POSIXct(Sys.time())),".rd")
		save(maperm,file=file,compress=T)
		message("Saved maperm object in ",file)
	} else
	{
		return(maperm)
	}
}
# --------------------------------------------------------------------

# --------------------------------------------------------------------
#' Merge permutations generated and saved by maPerm()
#'
#' The function maPerm() with save=TRUE will save permutations into RData files. Move all these RData files into the same directory, and indicate this directory using "dir". The output from maPermMerge() will be a list of DMRs detected in all permutations, and can be given to maPermFdr() to compute false discovery rates (FDRs).
#' @param dir Directory containing RData files saved by maPerm() where save was equal to TRUE
#' @return A list of DMRs arising from each permutation or bootstrap, merged across all the detected RData files.
#' @export
maPermMerge <- function(dir=".")
{
	rds <- dir(dir,pattern="maperm_",full.names=T)

	mas <- list()
	idx <- 1
	for(i in rds)
	{
		message("Loading: ",i)
		load(i)
		mas[[idx]] <- maperm
		message("Found ",length(maperm)," perms")
		idx <- idx + 1
		rm(maperm)
	}

	mas <- do.call(c,mas)
	message("Loaded ",length(mas)," permutations from ",length(rds)," maPerm() .rd files")

	return(mas)
}
# --------------------------------------------------------------------

# --------------------------------------------------------------------
#' Compute false discovery rates (FDRs) from permuted DMR lists
#'
#' Using DMRs arising from permutations saved using maPerm(), compute FDRs for each pattern.
#' @param ma Output object from methylaction()
#' @param maperm Output object from maPerm()
#' @param recut.p ANODEV p-value cutoff to use
#' @param wide Produce a more readable "wide" format summary table, sorted by "frequent" FDR
#' @return A table of FDRs for each pattern, stratified by "frequent" status
#' @export
maPermFdr <- function(ma,maperm,recut.p=0.05,wide=FALSE)
{
	samp <- ma$args$samp
	#maperm <- ma$data$maperm
	nperms <- length(maperm)
	dmrcalled <- ma$dmr

	checkdead <- sapply(maperm,class)
	dead <- (checkdead != "GRanges")&(maperm!="NoDmrs")
	message("Out of ",nperms," perms, ",sum(dead)," died and were ignored")
	maperm <- maperm[!dead]

	nodmr <- maperm=="NoDmrs"
	message("Out of ",nperms," perms, ",sum(nodmr)," found no DMRs of any pattern")

	ma$args$permerrors <- sum(dead)
	ma$args$permnodmrs <- sum(nodmr)

	# make observed event table
	gettab <- function(dmrcalled)
	{
		dmrcalled <- dmrcalled[dmrcalled$anodev.padj<recut.p]
		dmrcalled$frequent <- factor(dmrcalled$frequent,levels=c("FALSE","TRUE"))
		matab <- as.matrix(table(dmrcalled$pattern,dmrcalled$frequent))
		matab <- cbind(matab,rowSums(matab))
		colnames(matab) <- c("other","frequent","all")
		matab <- rbind(matab,colSums(matab))
		rownames(matab)[nrow(matab)] <- "all"
		return(matab)
	}

	# make expected event table - mean of all permutations
	realtab <- gettab(dmrcalled)
	allone <- paste(as.character(rep(1,length(unique(samp$group)))),collapse="")
	realtab <- realtab[!rownames(realtab) %in% c("000or111","ambig","1111",allone),]

	# If no DMR, put out a blank table
	#mapermout <- maperm #this one won't be subsetted
	maperm <- maperm[!nodmr]

	if(sum(nodmr)>0)
	{
		notabs <- lapply(1:sum(nodmr),function(x) {k<-realtab; apply(k,c(1,2),function(x) 0);})
	}

	# Make perm tables
	# make sure the perms report missing levels so table() gives same output for everything
	maperm <- lapply(maperm,function(x){
		x$pattern <- factor(x$pattern,levels=levels(dmrcalled$pattern));
		return(x);
	})

	permtab <- lapply(maperm,gettab)
	allone <- paste(as.character(rep(1,length(unique(samp$group)))),collapse="")
	permtab <- lapply(permtab,function(x) x[!(rownames(x) %in% c("000or111","ambig","1111",allone)),])

	# Need to make sure they are ordered right before doing the division
	permtab <- lapply(permtab,function(x) x[rownames(realtab),])

	# Add the blanks back in if they're there
	if(sum(nodmr)>0)
	{
		permtab <- c(permtab, notabs)
	}

	permmeans <- apply(simplify2array(permtab), c(1,2), mean)
	permmeans <- permmeans[rownames(realtab),]
	permsds <- apply(simplify2array(permtab), c(1,2), sd)
	permsds <- permsds[rownames(realtab),]
	permcv <- permsds/permmeans
	permcv <- permcv[rownames(realtab),]

	# calculate FDR by pattern and overall
	#expected <- Reduce("+",permtab2)/nperms
	fdrpercents <- (permmeans/realtab)*100

	# Make neat summary tables
	real.m <- reshape::melt.matrix(realtab)
	colnames(real.m) <- c("pattern","type","value")
	real.m$var <- "nDMRs"
	mean.m <- reshape::melt.matrix(permmeans)
	colnames(mean.m) <- c("pattern","type","value")
	mean.m$var <- "permMean"
	sd.m <- reshape::melt.matrix(permsds)
	colnames(sd.m) <- c("pattern","type","value")
	sd.m$var <- "permSD"
	cv.m <- reshape::melt.matrix(permcv)
	colnames(cv.m) <- c("pattern","type","value")
	cv.m$var <- "permCV"
	fdr.m <- reshape::melt.matrix(fdrpercents)
	colnames(fdr.m) <- c("pattern","type","value")
	fdr.m$var <- "FDRpercent"
	longdf <- rbind(real.m,mean.m,sd.m,cv.m,fdr.m)
	longdf$var <- factor(longdf$var,levels=unique(longdf$var))
	fdr <- reshape::cast(longdf,formula="pattern+type~var",value="value")

	if(wide==TRUE)
	{
		tab <- fdr
		tab <- tab[tab$type %in% c("frequent","other"),c("pattern","type","nDMRs","FDRpercent")]
		tab <- tab[tab$pattern!="all",]
		c1 <- reshape::cast(tab,formula=pattern~type,value="nDMRs")
		c2 <- reshape::cast(tab,formula=pattern~type,value="FDRpercent")
		stopifnot(c1$pattern==c2$pattern)
		df <- data.frame(frequent_dmrs=c1$frequent,frequent_fdr=c2$frequent,other_dmrs=c1$other,other_fdr=c2$other)
		df <- cbind(pattern=c1$pattern,df)
		out <- df[order(df$frequent_fdr,decreasing=F),]
		out$frequent_fdr <- round(out$frequent_fdr,digits=1)
		out$other_fdr <- round(out$other_fdr,digits=1)
		fdr <- out
	}
	return(fdr)
}
# --------------------------------------------------------------------
# ====================================================================

# ====================================================================
# Internal Functions

# --------------------------------------------------------------------
# Draws permutation orders out of combination space by running a series of chooses
# This may be preferable to simply shuffling the sample label list because it ensures each permutation ends up with distinct configurations of groups
# a: size of group 1
# b: size of group 2
# c: size of group 3
# nperms: how many permutations to provide
getComboSpacePerms <- function(an,bn,cn,nperms,ncore=1)
{
	nn <- an+bn+cn
	totalperms <- choose(nn,an)*choose(nn-an,bn)
	#message("There are ",formatC(totalperms,format="d",big.mark=",")," total possible combinations")
	samples <- 1:nn

	# Generate all possible ways to draw the first group
	co1 <- gtools::combinations(n=nn,r=an,v=samples)

	# Want to pick one at random, then pick one of the next possible choices at random up to the number of permutations
	rand <- sample(1:nrow(co1),nperms,replace=F)

	dorow <- function(x)
	{
		#message(x)
		# Get one draw of the first round
		a <- co1[x,]

		# Get everything that's left after the first draw
		nota <- samples[!(samples %in% a)]

		# Get all combos for the second draw
		b <- gtools::combinations(n=22-7,r=6,v=nota)

		# Get the remainder for group 3
		c <- t(apply(b,1,function(x) samples[!(samples %in% a) & !(samples %in% x)]))

		# Build Output table
		tab <- cbind(t(replicate(nrow(b),a)),b,c)
		colnames(tab) <- c(rep("a",7),rep("b",6),rep("c",9))

		# Report one at random
		ret <- tab[sample(1:nrow(tab),1),]
		return(ret)
	}
	permcos <- mclapply(rand,dorow,mc.cores=ncore)
	#out <- do.call(rbind,permcos)
	#return(out)
	return(permcos)
}
# --------------------------------------------------------------------
# ====================================================================