library(shiny)
library(leaflet)
library(leaflet.extras2)
library(dplyr)
library(ggplot2)
library(devtools)
library(shinydashboard)
library(shinyWidgets)
library(plotly)

model_output <- readRDS("Model_output_Anonymised.rds") #created in data prep
fishing_events <- readRDS("Fishing_Anon.rds")  #created in data prep
df <- fishing_events

inshore_grid <- readRDS("Inshore_Grid.rds")  #from inshore team
map_fishing <- readRDS("map_fishing.rds")  #created in data prep
map_mix_transit <- readRDS("map_mixtransit.rds")   #created in data prep
map_transit <- readRDS("map_transit.rds")  #created in data prep
landing_sites <- readRDS("landing_sites.rds")  #from model output/Sophie
source_url("https://raw.githubusercontent.com/iascchen/VisHealth/master/R/calendarHeat.R")
#source(App_with_anonymised_data/calendarHeat.R', echo=TRUE)

ui <- dashboardPage(
  dashboardHeader(title = "iVMS Application"),
  dashboardSidebar(
    sidebarMenu(
      menuItem("Home",tabName = "home", icon = icon("dashboard")),
      menuItem("Map", tabName = "map", icon = icon("map-marker-alt")),
      menuItem("Model details", tabName = "modelling", icon = icon("th"))
      )
    ),
  dashboardBody(
    tabItems(
      tabItem(tabName = "home",
              fluidRow(
                column(12,
                box(
                  background = "olive", width = NULL,
                  h4("Filter data using the widgets below"),
                  br(),
                  column(3,dateRangeInput("dateselector", "Date", start=min(fishing_events$Date),
                                          end = max(fishing_events$Date), separator = " to ")),
                  column(3,selectInput("vesselselector", "Vessels", choices=c(levels(as.factor(fishing_events$ID_anon))),
                                       selected = NULL, multiple=T)),
                  column(3,selectInput("location","ICES Area.Rectangle", choices= c(levels(fishing_events$Area_Rect)),
                                       multiple=T, selectize=T)),
                  column(3,selectInput("gridsquare","Inshore Grid Square", choices= c(levels(as.factor(fishing_events$InshoreGrid_SQ))),
                                       multiple=T))
                  #selectInput("gear","Gear", choices= "All", multiple=T, selectize=T)
                )
                )
              ),
              fluidRow(
                       valueBoxOutput("box1",width = 4),
                       valueBoxOutput("box2",width = 4),
                       valueBoxOutput("box3",width = 4)),
              br(),
              fluidRow(
               # column(7,
                       tabBox(
                         id = "tabset1",width = 12, side = "right",
                         tabPanel("Distance",
                                  #numericInput("cutoff1", label = h3("Input fishing cut off in Km per fishing event"), value = 0),
                                  plotlyOutput("day1"),
                                  plotOutput("heat1"),
                                  ),
                         tabPanel("Duration",
                                  #numericInput("cutoff2", label = h3("Input fishing cut off in minutes"), value = 0),
                                  plotlyOutput("day2"),
                                  plotOutput("heat2"),
                                  ),
                         tabPanel("Number of Pots",
                                  fluidRow(
                                    column(6, numericInput("spacing", label = h4("Enter a spacing parameter to calculate number of pots (Meters)"), value = 2.5)),
                                    column(6, numericInput("cutoff3", label = h4("Enter a cut-off level in pots per fishing event"), value = 4000))
                                  ),
                                  br(),
                                  br(),
                                  br(),
                                  br(),
                                  plotlyOutput("ev3")
                                  )
                         )
                       ),
                #column(5,
              fluidRow(
                br(),
                tabBox(
                  id = "tabset2",width = 12,
                  tabPanel("Time",
                           plotlyOutput("vesselplot")),
                  tabPanel("Km",
                           plotlyOutput("vesselplot2"))
                  )
                )
              ),
      tabItem(tabName = "map",
              h3("Model Output (Note: locations are interpolated)"),
              leafletOutput("map", height='90vh')
              ),
      tabItem(tabName = "modelling",
              tags$b("Model Details"),
              tags$p("The iVMS pings are collected from gps systems on board inshore fishing vessels. These pings are currently being collected at 1min intervals. This data is then cleaned to remve any pings sent while in port (a 500m buffer zone is applied around any port, quay, pier or other landing site). Once cleaned and pepped, a supervised classification model takes as input a file with raw VMS locations of fishing vessels (only potters so far) and uses a Hidden Markov Model (HMM) and a speed filter to classify locations by potential activity, i.e. fishing or not fishing (transit) based on the step length and angles between successive locations. The model is asked to discriminate between 3 modes that are later interpreted as 1-Fishing, 2-Uncertain activity (slow transit or mixture of transit and fishing), 3-Transit. The choice of a 3 states model has been made based on tests.
The model is set as a conservative one so that it is more likely to underestimate fishing locations rather than find false positives.
Because the model needs perfectly regular GPS pings to converge properly, the VMS locations are interpolated. Therefore, the resulting file with VMS locations and modelled activity does not contain the exact REAL VMS locations but a linear interpolation of these locations.
"),
              tags$b("Limitations"),
              tags$p("The program checks for various problems in the file that may impair the model results (number of locations per trip, ping irregularities, duplicated locations) and will remove from the analyse tracks that will compromise the function. A notification with the number of trips removed will appear on the screen.
Despite this automatic checking some exceptions may arise and the model may give unrealistic results for some vessels. For this reason, it is possible to visually check all results by quickly going through the plots provided by the program.
Without validation data the model cannot identify with 100% certainty the fishing location.
"),
              hr(),
              h4("Model output data summary"),
              verbatimTextOutput("Assumptions"),
              hr()
              )
      )
  )
)

server <- function(input, output, session) {

  # Filtering
  fishing_filtered <- reactive({
    fishing_events %>%
    filter(Date >= input$dateselector[1] &  Date <= input$dateselector[2])
  })

  fishing_filtered_v <- reactive({
    if (is.null(input$vesselselector)) {
      fishing_filtered()
    } else {
      fishing_filtered() %>%
    filter(ID_anon == input$vesselselector)
    }
  })

  fishing_filtered1 <- reactive({
    if (is.null(input$location)) {
        fishing_filtered_v()
        } else {
        fishing_filtered_v() %>%
          filter(Area_Rect == input$location)
        }
    })
  fishing_filtered2 <- reactive({
    if (is.null(input$gridsquare)) {
      fishing_filtered1()
    } else {
      fishing_filtered1() %>%
        filter(InshoreGrid_SQ == input$gridsquare)
      }
  })

  observeEvent(
    fishing_filtered_v(), {
    updateSelectInput(session,
                      "location",
                      choices = c(levels(droplevels(as.factor(fishing_filtered1()$Area_Rect)))))
    }
  )

  observeEvent(
    input$location, {
    updateSelectInput(session,
                      "gridsquare",
                      choices = c(levels(droplevels(as.factor(fishing_filtered2()$InshoreGrid_SQ)))))
  }
  )

  ## Box1
  f_events <- reactive({
    unique(fishing_filtered2()$ID_trip_anon)
  })
  f_event_1 <- reactive({
    length(f_events())
  })
  f_event_2 <- reactive({
    formatC(f_event_1(), digits = 1, format= "d",mode = "integer", big.mark = ",")
  })
  output$box1 <- renderValueBox({valueBox(value = f_event_2(), subtitle="Number of fishing events", icon = icon("fas fa-ship"))})#,

   ## Box2
  T_event <- reactive({
    (sum(fishing_filtered2()$Duration))/60
  })
  T_event_2 <- reactive({
    formatC(T_event(), digits = 5, format= "d",mode = "integer", big.mark = ",")
  })
  output$box2 <- renderValueBox({
    valueBox(value = T_event_2(),subtitle="Total fishing time (Hours)", icon = icon("fas fa-clock-o"))
    })

  ## Box3
  D_event <- reactive({
    (sum(fishing_filtered2()$Distance))/1000
  })
  D_event_2 <- reactive({
    formatC(D_event(), digits = 8, format= "d",mode = "integer", big.mark = ",")
  })
  output$box3 <- renderValueBox({
    valueBox(value = D_event_2(),subtitle="Total fishing distance (Km)", icon = icon("fas fa-anchor"))
  })

  output$Assumptions <- renderPrint({
    summary(model_output)
  })

  #plots
  output$day1 <- renderPlotly(
    fishing_filtered2() %>%
      mutate(Day = as.Date(Date, format = "%Y-%m-%d")) %>%
      mutate(DistanceKm = Distance/1000) %>%
      group_by(Day,ID_anon) %>%
      summarise(Sum_dist = sum(DistanceKm)) %>%
      arrange(Day) %>%
      plot_ly(x = ~Day, y = ~Sum_dist, color = ~ID_anon, type="bar") %>%
      layout(title = "Fishing Activity (Km) by Day",
             xaxis = list(title = "Date",type = 'date'),
             yaxis = list(title = "Fishing Activity (Kilometers)"),
             barmode = 'stack')
  )
  output$day2 <- renderPlotly(
    fishing_filtered2() %>%
      mutate(Day = as.Date(Date, format = "%Y-%m-%d")) %>%
      group_by(Day,ID_anon) %>%
      summarise(Sum_Dur = sum(Duration)/60) %>%
      arrange(Day) %>%
      plot_ly(x = ~Day, y = ~Sum_Dur, color = ~ID_anon,type="bar") %>%
      layout(title = "Fishing Activity (Hours) by Day",
             xaxis = list(title = "Date", type = 'date'),
             yaxis = list(title = "Fishing Activity (Hours)"),
             barmode = 'stack')
  )
output$heat1 <- renderPlot(
  calendarHeat(dates = fishing_filtered2()$Date,
               values = fishing_filtered2()$Distance,
               colors=c("#B5E384","#FFFFBD", "#FFAE63","#D61818"),
               ncolors = 99,
               title = "Fishing Activity (Distance (km))")
    )

  fishing_filtered3 <- reactive({
    fishing_filtered2() %>%
     mutate(Duration_hrs = Duration/60)
  })

  output$heat2 <-renderPlot(
    calendarHeat(dates = fishing_filtered3()$Date,
                 values = fishing_filtered3()$Duration_hrs,
                 colors=c("#B5E384","#FFFFBD", "#FFAE63","#D61818"),
                 ncolors = 99,
                 title = "Fishing Activity (Duration (hrs))")
  )

  spacing <- reactive({
    input$spacing
  })

  fishing_filtered4 <- reactive({
    fishing_filtered2() %>%
    mutate(No_of_pots = Distance/spacing()) %>%
    group_by(ID_trip_anon) %>%
    summarise(Sum_Pots = sum(No_of_pots))
  })

    col<-reactive({
      ifelse(fishing_filtered4()$Sum_Pots >= input$cutoff3,"#FF6666","#009933")
  })

  output$ev3 <- renderPlotly(
    plot_ly(fishing_filtered4(), x = ~ID_trip_anon, y = ~Sum_Pots, type = "bar", marker=list(color=col())) %>%
      layout(title = "Estimated Number of Pots laid per Fishing Trip ",
             xaxis = list(title = "Fishing Trip ID (Trip ID number)"),
             yaxis = list(title = "Estimated Number of Pots"),
             showlegend = F)
  )

  output$vesselplot <-  renderPlotly(
    fishing_filtered() %>%
      group_by(ID_anon) %>%
      summarise(Sum_Dur = (sum(Duration))/60) %>%
      plot_ly(x = ~ID_anon, y = ~Sum_Dur, type="bar", color = ~ID_anon) %>%
      layout(title = "Fishing Activity (Hours) by Vessel",
             xaxis = list(title = "Vessel ID"),
             yaxis = list(title = "Total Fishing Activity (Hours)"),
             showlegend = F,
             margin = list(t = 75))
  )
  output$vesselplot2<-  renderPlotly(
    fishing_filtered() %>%
      mutate(DistanceKm = Distance/1000) %>%
      group_by(ID_anon) %>%
      summarise(Sum_dist = sum(DistanceKm)) %>%
      plot_ly(x = ~ID_anon, y = ~Sum_dist, type="bar", color = ~ID_anon) %>%
      layout(title = "Fishing Activity (Km) by Vessel",
             xaxis = list(title = "Vessel ID"),
             yaxis = list(title = "Total Fishing Activity (Km)"),
             showlegend = F,
             margin = list(t = 75))
  )

  output$map <- renderLeaflet({
    leaflet(fishing_filtered()) %>%
      setView(lng = -6.7, lat = 52.15, zoom =10 ) %>%
      addTiles(group = "Basemap") %>%
      addCircleMarkers(data=map_fishing, lat= ~latitude,lng = ~longitude, color = 'red',
                       radius = 5, stroke = TRUE, weight =1, fillOpacity =0.5,
                       popup = ~paste(ID_anon,Date,sep = "
"),
                       group = "Fishing"
      ) %>%
      addCircleMarkers(data=map_mix_transit, lat= ~latitude,lng = ~longitude, color = 'yellow',
                       radius = 3, stroke = FALSE,weight =1, fillOpacity =0.5,
                       popup = ~paste(ID_anon,Date,sep = "
"),
                       group = "Mix Transit"
      ) %>%
      addCircleMarkers(data=map_transit, lat= ~latitude,lng = ~longitude, color = 'green',
                       radius = 3, stroke = FALSE,weight =1, fillOpacity =0.2,
                       popup = ~paste(ID_anon,Date,sep = "
"),
                       group = "Transit"
      ) %>%
      addPolygons(group = "InshoreGrid", data = inshore_grid, weight = 1, opacity = 0.3, fill=FALSE,
                  popup = ~paste(Label)) %>%
      addMarkers(data=landing_sites, lat= ~Latitude,lng = ~Longitude,
                 popup = ~paste(NAME,TYPE,sep = "
"),
                       group = "Landing Sites"
      ) %>%
      addLegend("bottomright", colors = c('red','yellow','green'), labels = c("Fishing","Mix Transit","Transit"),
                title = "Activity type",opacity = 1) %>%
      hideGroup("InshoreGrid") %>%
      hideGroup("Landing Sites") %>%
      addLayersControl(baseGroups = "Basemap",
                       overlayGroups = c("Fishing","Mix Transit","Transit","InshoreGrid","Landing Sites"),
                       options = layersControlOptions(collapsed = FALSE))
  })

}

shinyApp(ui, server)


#!/usr/bin/env Rscript

# Parse the --file= argument out of command line args and
# determine where base directory is so that we can source
# our common sub-routines
arg0 <- sub("--file=(.*)", "\\1", grep("--file=", commandArgs(), value = TRUE))
dir0 <- dirname(arg0)
source(file.path(dir0, "common.r"))

theme_set(theme_grey(base_size = 17))

# Setup parameters for the script
params = matrix(c(
  'help',    'h', 0, "logical",
  'width',   'x', 2, "integer",
  'height',  'y', 2, "integer",
  'outfile', 'o', 2, "character",
  'indir',   'i', 2, "character",
  'tstart',  '1',  2, "integer",
  'tend',    '2',  2, "integer",
  'ylabel1stgraph', 'Y',  2, "character",
  'title', 't',  2, "character"
  ), ncol=4, byrow=TRUE)

# Parse the parameters
opt = getopt(params)

if (!is.null(opt$help))
  {
    cat(paste(getopt(params, command = basename(arg0), usage = TRUE)))
    q(status=1)
  }

# Initialize defaults for opt
if (is.null(opt$width))   { opt$width   = 1500 }
if (is.null(opt$height))  { opt$height  = 2500 }
if (is.null(opt$indir))   { opt$indir  = "current"}
if (is.null(opt$outfile)) { opt$outfile = file.path(opt$indir, "summary.png") }
if (is.null(opt$ylabel1stgraph)) { opt$ylabel1stgraph = "Ops/sec" }
if (is.null(opt$title)) { opt$title = "Throughput" }

# Load the benchmark data, passing the time-index range we're interested in
b = load_benchmark(opt$indir, opt$tstart, opt$tend)

# If there is no actual data available, bail
if (nrow(b$latencies) == 0)
{
  stop("No latency information available to analyze in ", opt$indir)
}

png(file = opt$outfile, width = opt$width, height = opt$height)

# First plot req/sec from summary
thr <- qplot(elapsed,
             successful / window,
             data = b$summary,
             geom = c("smooth", "point"),
             xlab = "Time (secs)",
             ylab = "Transactions / sec",
             main = "Throughput") +

        geom_smooth(aes(y = successful / window, colour = "Committed"), size=0.5) +
        geom_point(aes(y = successful / window, colour = "Committed"), size=4.0) +

        geom_smooth(aes(y = failed / window, colour = "Aborted"), size=0.5) +
        geom_point(aes(y = failed / window, colour = "Aborted"), size=3.0) +

        scale_colour_manual("Response", values = c("#FF665F", "#188125")) +

        # increase legend point size
        guides(colour = guide_legend(override.aes = list(size=5))) +

        # set tick sequence
        # set tick thousand mark
        scale_y_continuous(breaks = seq(0,1000000,by=500),
                           labels=function(x) format(x, big.mark = ",", scientific = FALSE)) +

        theme(plot.title = element_text(size=30),
              plot.margin = margin(t = 10, r = 50, b = 0, l = 20),

              axis.title.x = element_text(size=25),
              axis.title.y = element_text(size=25),

              axis.text.x = element_text(size=20),
              axis.text.y = element_text(size=20),

              legend.justification = c(1,0),
              legend.position = c(1,0),

              legend.box.margin = margin(t = 0, r = 50, b = 100, l = 0),

              legend.title = element_text(size=30),
              legend.text = element_text(size=25),

              legend.key.size = unit(35, 'pt'))

# Setup common elements of the latency plots
latency_plot <- ggplot(b$latencies, aes(x = elapsed)) +

                facet_grid(. ~ op) +

                labs(x = "Time (secs)", y = "Latency (ms)") +

                guides(colour = guide_legend(override.aes = list(size=5))) +

                theme(plot.title = element_text(size=30),
                      plot.margin = margin(t = 10, r = 50, b = 0, l = 20),

                      axis.title.x = element_text(size=25),
                      axis.title.y = element_text(size=25),

                      axis.text.x = element_text(size=20),
                      axis.text.y = element_text(size=20),

                      legend.justification = c(1,1),
                      legend.position = c(1,1),

                      legend.box.margin = margin(t = 50, r = 50, b = 0, l = 0),

                      legend.title = element_text(size=30),
                      legend.text = element_text(size=25),

                      legend.key.size = unit(35, 'pt'))

# Plot median, mean and 95th percentiles
lat_all <- latency_plot +

            labs(title = "Mean, Median, and 95th Percentile Latency") +

            geom_smooth(aes(y = median, color = "median"), size=1) +
            geom_point(aes(y = median, color = "median"), size=4.0) +

            geom_smooth(aes(y = mean, color = "mean"), size=1) +
            geom_point(aes(y = mean, color = "mean"), size=4.0) +

            geom_smooth(aes(y = X95th, color = "95th"), size=1) +
            geom_point(aes(y = X95th, color = "95th"), size=4.0) +

            scale_colour_manual("Percentile", values = c("#FF665F", "#009D91", "#FFA700"))

# Plot 99th percentile
lat_99 <- latency_plot +
            labs(title = "99th Percentile Latency") +

            geom_smooth(aes(y = X99th, color = "99th"), size=1.5) +

            geom_point(aes(y = X99th, color = "99th"), size=4.0) +

            scale_colour_manual("Percentile", values = c("#FF665F", "#009D91", "#FFA700")) +

            theme(plot.margin = margin(t = 10, r = 50, b = 10, l = 20),
                  legend.position="none")

grid.newpage()

pushViewport(viewport(layout = grid.layout(3, 1)))

vplayout <- function(x,y) viewport(layout.pos.row = x, layout.pos.col = y)

print(thr, vp = vplayout(1,1))
print(lat_all, vp = vplayout(2,1))
print(lat_99, vp = vplayout(3,1))

dev.off()


require(reshape)
require(maptools)
require(countrycode)
require(raster)
require(sf)
require(dplyr)
require(rgeos)
require(rgdal)
require(rasterVis)
require(ncdf4)
require(overpass)
memory.limit(size=1e9)

basin = c('Indus')

setwd('P:/is-wel/indus/message_indus')

# Grab the basin boundaries
basin.spdf = readOGR( paste( getwd(), 'input', sep = '/' ), 'Indus_bcu', verbose = FALSE )
basin.spdf = spTransform( basin.spdf, CRS("+proj=longlat") ) # temp[which(as.character(temp$BASIN) == basin | as.character(temp$PID) == '2256'),] for Karachi basin
basin.sp = gUnaryUnion( basin.spdf )
basin.sp = SpatialPolygons(list(Polygons(Filter(function(f){f@ringDir==1},basin.sp@polygons[[1]]@Polygons),ID=1)))
buff.sp = gBuffer( basin.sp, width=2 )
proj4string(basin.sp) = proj4string(basin.spdf)
proj4string(buff.sp) = proj4string(basin.spdf)

### Irrigation in each PID
n_days = c(31,28,31,30,31,30,31,31,30,31,30,31)
nc = nc_open('input/Wada_groundwater_abstraction/pcrglobwb_WFDEI_historical_PIrrWW_monthly_1960_2010.nc4', verbose=FALSE)
irrigation.stack = stack( 'input/Wada_groundwater_abstraction/pcrglobwb_WFDEI_historical_PIrrWW_monthly_1960_2010.nc4' )
extent(irrigation.stack) = extent( min( ncvar_get(nc, "longitude") ), max( ncvar_get(nc, "longitude") ), min( ncvar_get(nc, "latitude") ), max( ncvar_get(nc, "latitude") ) )
proj4string( irrigation.stack ) = proj4string( basin.spdf )
irrigation.stack = crop( irrigation.stack, extent(buff.sp) )
names(irrigation.stack) = c( sapply( 1:(nlayers(irrigation.stack)/12), function(yy){ return( paste( ( as.numeric( unlist( strsplit( as.character( as.Date("1901-01-01") + min( ncvar_get(nc, "time") ) ), '-' ) )[1] ) + yy - 1 ), seq(1,12,by=1), sep='.') ) } ) )
irrigation.stack = irrigation.stack[[ c( which(grepl( 'X2010',names(irrigation.stack) )) ) ]] # keep 2010
nm = names(irrigation.stack)
irrigation.stack = ( 1e6 * irrigation.stack ) / (1e6 * area(irrigation.stack[[1]]) ) # convert to meters
nc_close(nc)
irrigation.stack[irrigation.stack[]<0]=0
names(irrigation.stack) = nm
irrigation.stack = round( 1e6 * irrigation.stack * area( irrigation.stack[[1]] ) / n_days ) # in m3 per day
irrm.raster = mean(irrigation.stack)
irrw.df = data.frame( do.call( cbind, lapply(1:12, function(m){ unlist( lapply( 1:length(basin.spdf), function(x){ sum( unlist( extract( irrigation.stack[[m]], as(basin.spdf[x,],'SpatialPolygons'), na.rm=TRUE ) ) ) } ) ) })) )
names(irrw.df) = nm
row.names(irrw.df) = basin.spdf@data$PID

#### Get irrigation outside basin boundaries

# Canals
canal.sl = spTransform( as( readOGR( paste( getwd(), 'input/indusbasinorg', sep = '/' ), 'canals', verbose = FALSE ), 'SpatialLines' ), crs( basin.spdf ) )

# Remove grid cells included in the basin already
basin_cells = extract( irrm.raster, basin.sp, na.rm=TRUE, cellnumbers = TRUE )[[1]][,'cell']
irrm.raster[ basin_cells ] = NA
irrm.raster[ irrm.raster[] < 0.1 ] = NA
irrm.raster[ !is.na(irrm.raster[]) ] = 1
irrm.sp = as( rasterToPolygons(irrm.raster), 'SpatialPolygons' )

# Intersect to identify irrigated grid cells outside basin
canal.sp = irrm.sp[ c( unique( unlist( apply( gDistance( irrm.sp, canal.sl , byid=TRUE ), 1, function(x){ which( x < 0.3 ) } ) ) ) ) ]

# Get adjacent basin unit in pakistan
basinr.spdf = basin.spdf[ which( as.character( basin.spdf@data$REGION ) == 'pakistan' ) , ]
canal.df = data.frame( adj_pid = unlist( lapply( 1:length(canal.sp), function(i){ return( as.character( basinr.spdf@data$PID[ which.min( gDistance( canal.sp[i], basinr.spdf, byid = TRUE ) ) ] ) ) } ) ), row.names = row.names(canal.sp) )
canal.sp = SpatialPolygonsDataFrame( canal.sp, canal.df )
canal.sp = gUnaryUnion( canal.sp, id = canal.sp@data$adj_pid )
ids = seq(1,length(canal.sp),by=1)
inds = which( gTouches(canal.sp,byid=TRUE)[1:ceiling(length(canal.sp)/2),], arr.ind = TRUE )
if( nrow(inds) > 0 ){ for( j in 1:nrow(inds) ){ ids[ inds[j,2] ] = ids[ inds[j,1] ]  } }
canal.sp = spTransform( gUnaryUnion( canal.sp, id = ids ), crs(basin.spdf) )
canal.sp = disaggregate( canal.sp )
row.names( canal.sp ) = as.character( basin.spdf@data$PID[ apply( gDistance( gCentroid(canal.sp,byid=TRUE), basin.spdf, byid = TRUE ), 2, which.min ) ] )

# Convert to demands
irrw_out.df = 1e-6 * data.frame( do.call( cbind, lapply(1:12, function(m){ unlist( lapply( 1:length(canal.sp), function(x){ sum( unlist( extract( irrigation.stack[[m]], as(canal.sp[x,],'SpatialPolygons'), na.rm=TRUE ) ) ) } ) ) })) )
names(irrw_out.df) = nm
row.names(irrw_out.df) = row.names( canal.sp )

# Indira Ghandi Canal
ig_loc = SpatialPoints( data.frame( x = 74.946981, y = 31.144931 ) )
proj4string( ig_loc ) = proj4string( basin.sp )
ig_loc = spTransform( ig_loc, crs( basin.sp ) )
ig_pid = as.character( over( ig_loc, basin.spdf )$PID )
ig_average_flow = 138 * 60 * 60 * 24 / 1e6  # m3 per second converted to MCM per day

# Sutlej-Yamuna link canal - based on allocation of 3.5 MAF to Haryana
syl_loc = SpatialPoints( data.frame( x = 76.366436, y = 31.380952 ) )
proj4string( syl_loc ) = proj4string( basin.sp )
syl_loc = spTransform( syl_loc, crs( basin.sp ) )
syl_pid = as.character( over( syl_loc, basin.spdf )$PID )
syl_average_flow = 136 * 60 * 60 * 24 / 1e6  # m3 per second converted to MCM per day

# Estimate average seasonality of irrigation demands and apply to canals transfers
ssn = ( colSums( irrw_out.df ) / mean( colSums( irrw_out.df ) ) )

# Output to csv
irrigation_transfers.df = rbind( irrw_out.df, ssn * ig_average_flow, ssn * syl_average_flow )
row.names( irrigation_transfers.df ) = 1:nrow( irrigation_transfers.df )
irrigation_transfers.df$PID = c( row.names( irrw_out.df ), ig_pid, syl_pid	)
irrigation_transfers.df$units = 'MCM/day'
irrigation_transfers.df = irrigation_transfers.df[,c(13,14,1:12)]
irrigation_transfers.df[,3:(3+11)] = round( irrigation_transfers.df[,3:(3+11)], digits = 1 )
irrigation_transfers.df = irrigation_transfers.df[-1*which(rowSums(irrigation_transfers.df[,3:(3+11)]) < 1 ), ]

write.csv( irrigation_transfers.df, 'input/basin_irrigation_transfers.csv', row.names = FALSE)


library(dplyr)
library(ggplot2)
##calculate for 6A
base_dir <- "X:/brintonj/haplotype/whole_genome_mummer/surrounding_seq/"

seq_files <- list.files(base_dir, pattern = "tsv")

length(seq_files)
sample_no <- 10000
hap_blocks <- data.frame(matrix( nrow = length(seq_files)*sample_no, ncol = 6))
colnames(hap_blocks) <- c("P1", "REF_SEQ", "REF", "QUERY", "hap_block", "REF_CPLX")
not_block <- data.frame(matrix(nrow = length(seq_files)*sample_no, ncol = 6))
colnames(not_block) <- c("P1", "REF_SEQ", "REF", "QUERY", "hap_block", "REF_CPLX")

stats <- data.frame(matrix(nrow = length(seq_files), ncol = 13))
colnames(stats) <- c("FILE",
                     "N_HAP",
                     "N_NOT",
                     "MEDIAN_HAP",
                     "MEDIAN_NOT",
                     "MEAN_HAP",
                     "MEAN_NOT",
                     "P_VALUE",
                     "MEDIAN_HAP_SUB",
                     "MEDIAN_NOT_SUB",
                     "MEAN_HAP_SUB",
                     "MEAN_NOT_SUB",
                     "P_VALUE_SUB")

row_start <- 1

for (i in seq(1, length(seq_files))){
  file <- seq_files[i]
  name <- gsub("_snps_ref_complexity.tsv", "", file)
  seqs <- read.table(file = paste0(base_dir, file),
                     sep = "\t",
                     header = TRUE,
                     stringsAsFactors = FALSE)

  seqs$hap_block <- factor(seqs$hap_block, levels = c("Y", "N"))

  distr <- ggplot(seqs, aes(x = REF_CPLX, group = hap_block, fill = hap_block)) +
            geom_density(alpha = 0.5) +
            ggtitle(paste0(file, "\nN_hap: ", nrow(seqs[seqs$hap_block == "Y",]), "; N_not: ", nrow(seqs[seqs$hap_block == "N",]) ))

  pdf(paste0("X:/brintonj/haplotype/whole_genome_mummer/surrounding_seq/combined/", name, "_complexity_distribution.pdf"), height = 3, width = 3.5)
  print(distr)
  dev.off()

  head(seqs)
  nrow(seqs)
  counts <- data.frame(table(seqs$hap_block))

  medians <- data.frame(aggregate(REF_CPLX ~ hap_block, data = seqs, FUN = median))
  means <- data.frame(aggregate(REF_CPLX ~ hap_block, data = seqs, FUN = mean))

  stats[i,"FILE"] <- file
  stats[i,"N_HAP"] <- counts[counts$Var1 == "Y", "Freq"]
  stats[i,"N_NOT"] <- counts[counts$Var1 == "N", "Freq"]

  if (nrow(medians[medians$hap_block == "Y",]) > 0){
  stats[i,"MEDIAN_HAP"] <- medians[medians$hap_block == "Y","REF_CPLX"]
  stats[i,"MEAN_HAP"] <- means[means$hap_block == "Y","REF_CPLX"]
  }
  if (nrow(medians[medians$hap_block == "N",]) > 0){
  stats[i,"MEDIAN_NOT"] <- medians[medians$hap_block == "N","REF_CPLX"]
  stats[i,"MEAN_NOT"] <- means[means$hap_block == "N","REF_CPLX"]
  }

  if ((nrow(medians[medians$hap_block == "N",]) > 0) & (nrow(medians[medians$hap_block == "Y",]) > 0)){
  stats[i,"P_VALUE"] <- (pairwise.wilcox.test(seqs$REF_CPLX,seqs$hap_block,  p.adjust.method = "BH"))$p.value
  }

  row_end <- sample_no*i
  if((nrow(seqs[seqs$hap_block == "Y",]) < sample_no) | (nrow(seqs[seqs$hap_block == "N",]) < sample_no)){
    print("not enough samples")
    hap_blocks[c(row_start:row_end),"REF"] <- file
    not_block[c(row_start:row_end),"REF"] <- file
  } else {
    seqs$hap_block <- as.character(seqs$hap_block)
    hap_samples <- sample_n(seqs[seqs$hap_block == "Y",], sample_no)
    hap_blocks[c(row_start:row_end),] <- hap_samples
    not_samples <- sample_n(seqs[seqs$hap_block == "N",], sample_no)
    not_block[c(row_start:row_end),] <- not_samples

    #also want to calculate the subsampled stats per alignment
    subsamples <- rbind(hap_samples, not_samples)

    medians_sub <- data.frame(aggregate(REF_CPLX ~ hap_block, data = subsamples, FUN = median))
    means_sub <- data.frame(aggregate(REF_CPLX ~ hap_block, data = subsamples, FUN = mean))

    stats[i,"MEDIAN_HAP_SUB"] <- medians_sub[medians_sub$hap_block == "Y","REF_CPLX"]
    stats[i,"MEAN_HAP_SUB"] <- means_sub[means_sub$hap_block == "Y","REF_CPLX"]

    stats[i,"MEDIAN_NOT_SUB"] <- medians_sub[medians_sub$hap_block == "N","REF_CPLX"]
    stats[i,"MEAN_NOT_SUB"] <- means_sub[means_sub$hap_block == "N","REF_CPLX"]

    stats[i,"P_VALUE_SUB"] <- (pairwise.wilcox.test(subsamples$REF_CPLX, subsamples$hap_block,  p.adjust.method = "BH"))$p.value
  }
  row_start <- row_end + 1
}

write.table(stats, file = paste0("X:/brintonj/haplotype/whole_genome_mummer/surrounding_seq/combined/stats_seq_complexity_per_chrom", sample_no, "random.txt"),
            sep = "\t",
            col.names = TRUE,
            row.names = FALSE,
            quote = FALSE)

head(hap_blocks)
head(not_block)

haps_noNA <- hap_blocks[complete.cases(hap_blocks$P1),]
haps_noNA$hap_block <- "Y"
not_noNA <- not_block[complete.cases(not_block$P1),]
not_noNA$hap_block <- "N"

combined <- rbind(haps_noNA, not_noNA)
sink(paste0("X:/brintonj/haplotype/whole_genome_mummer/surrounding_seq/combined/stats_seq_overall_", sample_no, "random.txt"))
median(haps_noNA$REF_CPLX)
median(not_noNA$REF_CPLX)

pairwise.wilcox.test(combined$REF_CPLX, combined$hap_block,  p.adjust.method = "BH")

sink()

ggplot(combined, aes(x = hap_block, y = REF_CPLX, group = hap_block)) +
  geom_boxplot()

ggsave(paste0("X:/brintonj/haplotype/whole_genome_mummer/surrounding_seq/combined/stats_seq_overall_", sample_no, "random_boxplot.png"))

#plot density distribution
combined$hap_block <- factor(combined$hap_block, levels = c("Y", "N"))

distr_dens <- ggplot(combined, aes(x = REF_CPLX, group = hap_block, fill = hap_block)) +
geom_density(alpha = 0.5) +
  ggtitle(paste0("6A random ", sample_no, "\nN_hap: ", nrow(combined[combined$hap_block == "Y",]), "; N_not: ", nrow(combined[combined$hap_block == "N",]) ))

pdf(paste0("X:/brintonj/haplotype/whole_genome_mummer/surrounding_seq/combined/stats_seq_overall_", sample_no, "random_density.pdf"), height = 3, width = 3.5)
print(distr_dens)
dev.off()

##now calculate for 2B
base_dir <- "X:/brintonj/haplotype/whole_genome_mummer/surrounding_seq/2B/complexity/"
out_dir <- paste0(base_dir, "stats/")
dir.create(out_dir)
chrom <- "2B"
seq_files <- list.files(base_dir, pattern = "tsv")

length(seq_files)
sample_no <- 10000
hap_blocks <- data.frame(matrix( nrow = length(seq_files)*sample_no, ncol = 6))
colnames(hap_blocks) <- c("P1", "REF_SEQ", "REF", "QUERY", "hap_block", "REF_CPLX")
not_block <- data.frame(matrix(nrow = length(seq_files)*sample_no, ncol = 6))
colnames(not_block) <- c("P1", "REF_SEQ", "REF", "QUERY", "hap_block", "REF_CPLX")

stats <- data.frame(matrix(nrow = length(seq_files), ncol = 13))
colnames(stats) <- c("FILE",
                     "N_HAP",
                     "N_NOT",
                     "MEDIAN_HAP",
                     "MEDIAN_NOT",
                     "MEAN_HAP",
                     "MEAN_NOT",
                     "P_VALUE",
                     "MEDIAN_HAP_SUB",
                     "MEDIAN_NOT_SUB",
                     "MEAN_HAP_SUB",
                     "MEAN_NOT_SUB",
                     "P_VALUE_SUB")

row_start <- 1

for (i in seq(1, length(seq_files))){
  file <- seq_files[i]
  name <- gsub("_snps_ref_complexity.tsv", "", file)
  seqs <- read.table(file = paste0(base_dir, file),
                     sep = "\t",
                     header = TRUE,
                     stringsAsFactors = FALSE)

    seqs$hap_block <- factor(seqs$hap_block, levels = c("Y", "N"))

  distr <- ggplot(seqs, aes(x = REF_CPLX, group = hap_block, fill = hap_block)) +
    geom_density(alpha = 0.5) +
    ggtitle(paste0(file, "\nN_hap: ", nrow(seqs[seqs$hap_block == "Y",]), "; N_not: ", nrow(seqs[seqs$hap_block == "N",]) ))

  pdf(paste0(out_dir, name, "_", chrom, "_complexity_distribution.pdf"), height = 3, width = 3.5)
  print(distr)
  dev.off()

  #ggsave(distr, file = paste0(out_dir, name, "_", chrom, "_complexity_distribution.png"), height = 5, width = 6)

  head(seqs)
  nrow(seqs)
  counts <- data.frame(table(seqs$hap_block))

  medians <- data.frame(aggregate(REF_CPLX ~ hap_block, data = seqs, FUN = median))
  means <- data.frame(aggregate(REF_CPLX ~ hap_block, data = seqs, FUN = mean))

  stats[i,"FILE"] <- file
  stats[i,"N_HAP"] <- counts[counts$Var1 == "Y", "Freq"]
  stats[i,"N_NOT"] <- counts[counts$Var1 == "N", "Freq"]

  if (nrow(medians[medians$hap_block == "Y",]) > 0){
    stats[i,"MEDIAN_HAP"] <- medians[medians$hap_block == "Y","REF_CPLX"]
    stats[i,"MEAN_HAP"] <- means[means$hap_block == "Y","REF_CPLX"]
  }
  if (nrow(medians[medians$hap_block == "N",]) > 0){
    stats[i,"MEDIAN_NOT"] <- medians[medians$hap_block == "N","REF_CPLX"]
    stats[i,"MEAN_NOT"] <- means[means$hap_block == "N","REF_CPLX"]
  }

  if ((nrow(medians[medians$hap_block == "N",]) > 0) & (nrow(medians[medians$hap_block == "Y",]) > 0)){
    stats[i,"P_VALUE"] <- (pairwise.wilcox.test(seqs$REF_CPLX,seqs$hap_block,  p.adjust.method = "BH"))$p.value
  }

  row_end <- sample_no*i
  if((nrow(seqs[seqs$hap_block == "Y",]) < sample_no) | (nrow(seqs[seqs$hap_block == "N",]) < sample_no)){
    print("not enough samples")
    hap_blocks[c(row_start:row_end),"REF"] <- file
    not_block[c(row_start:row_end),"REF"] <- file
  } else {
    seqs$hap_block <- as.character(seqs$hap_block)
    hap_samples <- sample_n(seqs[seqs$hap_block == "Y",], sample_no)
    hap_blocks[c(row_start:row_end),] <- hap_samples
    not_samples <- sample_n(seqs[seqs$hap_block == "N",], sample_no)
    not_block[c(row_start:row_end),] <- not_samples

    #also want to calculate the subsampled stats per alignment
    subsamples <- rbind(hap_samples, not_samples)

    medians_sub <- data.frame(aggregate(REF_CPLX ~ hap_block, data = subsamples, FUN = median))
    means_sub <- data.frame(aggregate(REF_CPLX ~ hap_block, data = subsamples, FUN = mean))

    stats[i,"MEDIAN_HAP_SUB"] <- medians_sub[medians_sub$hap_block == "Y","REF_CPLX"]
    stats[i,"MEAN_HAP_SUB"] <- means_sub[means_sub$hap_block == "Y","REF_CPLX"]

    stats[i,"MEDIAN_NOT_SUB"] <- medians_sub[medians_sub$hap_block == "N","REF_CPLX"]
    stats[i,"MEAN_NOT_SUB"] <- means_sub[means_sub$hap_block == "N","REF_CPLX"]

    stats[i,"P_VALUE_SUB"] <- (pairwise.wilcox.test(subsamples$REF_CPLX, subsamples$hap_block,  p.adjust.method = "BH"))$p.value
  }
  row_start <- row_end + 1
}

write.table(stats, file = paste0(out_dir, "stats_seq_complexity_per_chrom_", chrom, sample_no, "random.txt"),
            sep = "\t",
            col.names = TRUE,
            row.names = FALSE,
            quote = FALSE)

head(hap_blocks)
head(not_block)

haps_noNA <- hap_blocks[complete.cases(hap_blocks$P1),]
haps_noNA$hap_block <- "Y"
not_noNA <- not_block[complete.cases(not_block$P1),]
not_noNA$hap_block <- "N"

combined <- rbind(haps_noNA, not_noNA)
sink(paste0(out_dir, "stats_seq_overall_", chrom, sample_no, "random.txt"))
median(haps_noNA$REF_CPLX)
median(not_noNA$REF_CPLX)

pairwise.wilcox.test(combined$REF_CPLX, combined$hap_block,  p.adjust.method = "BH")

sink()

ggplot(combined, aes(x = hap_block, y = REF_CPLX, group = hap_block)) +
  geom_boxplot()

ggsave(paste0(out_dir, "stats_seq_overall_", chrom, sample_no, "random_boxplot.png"))
combined$hap_block <- factor(combined$hap_block, levels = c("Y", "N"))

distr_dens <- ggplot(combined, aes(x = REF_CPLX, group = hap_block, fill = hap_block)) +
  geom_density(alpha = 0.5) +
  ggtitle(paste0(file, "\nN_hap: ", nrow(combined[combined$hap_block == "Y",]), "; N_not: ", nrow(combined[combined$hap_block == "N",]) ))

pdf(paste0(out_dir, "stats_seq_overall_", chrom, sample_no, "random_density.pdf"), height = 3, width = 3.5)
print(distr_dens)
dev.off()

#Also want to remove any sequences that have any Ns in them from the calculations
base_dir <- "X:/brintonj/haplotype/whole_genome_mummer/surrounding_seq/2B/complexity/"
out_dir <- paste0(base_dir, "stats/noN_unique/")
dir.create(out_dir)
chrom <- "2B"
seq_files <- list.files(base_dir, pattern = "tsv")

length(seq_files)
sample_no <- 10000
hap_blocks <- data.frame(matrix( nrow = length(seq_files)*sample_no, ncol = 6))
colnames(hap_blocks) <- c("P1", "REF_SEQ", "REF", "QUERY", "hap_block", "REF_CPLX")
not_block <- data.frame(matrix(nrow = length(seq_files)*sample_no, ncol = 6))
colnames(not_block) <- c("P1", "REF_SEQ", "REF", "QUERY", "hap_block", "REF_CPLX")

stats <- data.frame(matrix(nrow = length(seq_files), ncol = 13))
colnames(stats) <- c("FILE",
                     "N_HAP",
                     "N_NOT",
                     "MEDIAN_HAP",
                     "MEDIAN_NOT",
                     "MEAN_HAP",
                     "MEAN_NOT",
                     "P_VALUE",
                     "MEDIAN_HAP_SUB",
                     "MEDIAN_NOT_SUB",
                     "MEAN_HAP_SUB",
                     "MEAN_NOT_SUB",
                     "P_VALUE_SUB")

row_start <- 1

for (i in seq(1, length(seq_files))){
  file <- seq_files[i]
  name <- gsub("_snps_ref_complexity.tsv", "", file)
  seqs_raw <- read.table(file = paste0(base_dir, file),
                     sep = "\t",
                     header = TRUE,
                     stringsAsFactors = FALSE)

  seqs_noN <- seqs_raw[grep("N", seqs_raw$REF_SEQ),]

  seqs <- unique(seqs_noN)

  seqs$hap_block <- factor(seqs$hap_block, levels = c("Y", "N"))

  distr <- ggplot(seqs, aes(x = REF_CPLX, group = hap_block, fill = hap_block)) +
    geom_density(alpha = 0.5) +
    ggtitle(paste0(file, "\nN_hap: ", nrow(seqs[seqs$hap_block == "Y",]), "; N_not: ", nrow(seqs[seqs$hap_block == "N",]) ))

  ggsave(distr, file = paste0(out_dir, name, "_", chrom, "_complexity_distribution_noN_unique.png"), height = 5, width = 6)

  head(seqs)
  nrow(seqs)
  counts <- data.frame(table(seqs$hap_block))

  medians <- data.frame(aggregate(REF_CPLX ~ hap_block, data = seqs, FUN = median))
  means <- data.frame(aggregate(REF_CPLX ~ hap_block, data = seqs, FUN = mean))

  stats[i,"FILE"] <- file
  stats[i,"N_HAP"] <- counts[counts$Var1 == "Y", "Freq"]
  stats[i,"N_NOT"] <- counts[counts$Var1 == "N", "Freq"]

  if (nrow(medians[medians$hap_block == "Y",]) > 0){
    stats[i,"MEDIAN_HAP"] <- medians[medians$hap_block == "Y","REF_CPLX"]
    stats[i,"MEAN_HAP"] <- means[means$hap_block == "Y","REF_CPLX"]
  }
  if (nrow(medians[medians$hap_block == "N",]) > 0){
    stats[i,"MEDIAN_NOT"] <- medians[medians$hap_block == "N","REF_CPLX"]
    stats[i,"MEAN_NOT"] <- means[means$hap_block == "N","REF_CPLX"]
  }

  if ((nrow(medians[medians$hap_block == "N",]) > 0) & (nrow(medians[medians$hap_block == "Y",]) > 0)){
    stats[i,"P_VALUE"] <- (pairwise.wilcox.test(seqs$REF_CPLX,seqs$hap_block,  p.adjust.method = "BH"))$p.value
  }

  row_end <- sample_no*i
  if((nrow(seqs[seqs$hap_block == "Y",]) < sample_no) | (nrow(seqs[seqs$hap_block == "N",]) < sample_no)){
    print("not enough samples")
    hap_blocks[c(row_start:row_end),"REF"] <- file
    not_block[c(row_start:row_end),"REF"] <- file
  } else {
    seqs$hap_block <- as.character(seqs$hap_block)
    hap_samples <- sample_n(seqs[seqs$hap_block == "Y",], sample_no)
    hap_blocks[c(row_start:row_end),] <- hap_samples
    not_samples <- sample_n(seqs[seqs$hap_block == "N",], sample_no)
    not_block[c(row_start:row_end),] <- not_samples

    #also want to calculate the subsampled stats per alignment
    subsamples <- rbind(hap_samples, not_samples)

    medians_sub <- data.frame(aggregate(REF_CPLX ~ hap_block, data = subsamples, FUN = median))
    means_sub <- data.frame(aggregate(REF_CPLX ~ hap_block, data = subsamples, FUN = mean))

    stats[i,"MEDIAN_HAP_SUB"] <- medians_sub[medians_sub$hap_block == "Y","REF_CPLX"]
    stats[i,"MEAN_HAP_SUB"] <- means_sub[means_sub$hap_block == "Y","REF_CPLX"]

    stats[i,"MEDIAN_NOT_SUB"] <- medians_sub[medians_sub$hap_block == "N","REF_CPLX"]
    stats[i,"MEAN_NOT_SUB"] <- means_sub[means_sub$hap_block == "N","REF_CPLX"]

    stats[i,"P_VALUE_SUB"] <- (pairwise.wilcox.test(subsamples$REF_CPLX, subsamples$hap_block,  p.adjust.method = "BH"))$p.value
  }
  row_start <- row_end + 1
}

write.table(stats, file = paste0(out_dir, "stats_seq_complexity_per_chrom_", chrom, sample_no, "random_noN_unique.txt"),
            sep = "\t",
            col.names = TRUE,
            row.names = FALSE,
            quote = FALSE)

head(hap_blocks)
head(not_block)

haps_noNA <- hap_blocks[complete.cases(hap_blocks$P1),]
haps_noNA$hap_block <- "Y"
not_noNA <- not_block[complete.cases(not_block$P1),]
not_noNA$hap_block <- "N"

combined <- rbind(haps_noNA, not_noNA)
sink(paste0(out_dir, "stats_seq_overall_", chrom, sample_no, "random_noN_unique.txt"))
median(haps_noNA$REF_CPLX)
median(not_noNA$REF_CPLX)

pairwise.wilcox.test(combined$REF_CPLX, combined$hap_block,  p.adjust.method = "BH")

sink()

ggplot(combined, aes(x = hap_block, y = REF_CPLX, group = hap_block)) +
  geom_boxplot()

ggsave(paste0(out_dir, "stats_seq_overall_", chrom, sample_no, "random_boxplot_noN_unique.png"))


# process_posnegpop.r
#
# Copyright (c) 2020 VIB (Belgium) & Babraham Institute (United Kingdom)
#
# Software written by Carlos P. Roca, as research funded by the European Union.
#
# This software may be modified and distributed under the terms of the MIT
# license. See the LICENSE file for details.

#' Process data with positive and negative populations
#'
#' Calculates spillover coefficients using positive and negative populations,
#' and the corresponding compensation error.
#'
#' @param marker.spillover.unco.untr List of two matrices, with regressions
#'     intercepts and coefficients, resulting from the initial spillover
#'     calculation in untransformed scale.
#' @param flow.gate List of vectors with ids of gated events per sample.
#' @param flow.control List with data and metadata of a set of controls.
#' @param asp List with AutoSpill parameters.
#'
#' @return List with three elements:
#'     \itemize{
#'         \item{Calculated spillover matrix.}
#'         \item{Calculated compensation matrix.}
#'         \item{Resulting compensation error, a list with four matrices:
#'             intercepts, coefficients, slopes, and skewness.}
#'     }
#'
#' @references Roca \emph{et al}:
#'     AutoSpill: A method for calculating spillover coefficients to compensate
#'     or unmix high-parameter flow cytometry data.
#'     \emph{bioRxiv} 2020.06.29.177196;
#'     \href{https://doi.org/10.1101/2020.06.29.177196}{doi:10.1101/2020.06.29.177196}
#'     (2020).
#'
#' @seealso \code{\link{get.marker.spillover}}, \code{\link{gate.flow.data}},
#'     \code{\link{read.flow.control}}, and \code{\link{get.autospill.param}}.
#'
#' @export

process.posnegpop <- function( marker.spillover.unco.untr, flow.gate,
    flow.control, asp )
{
    # get spillover and compensation matrices

    spillover.posnegpop <- get.marker.spillover.posnegpop( flow.gate,
        flow.control, asp )

    compensation.posnegpop <- solve( spillover.posnegpop )

    spillover.posnegpop.original <- spillover.posnegpop
    rownames( spillover.posnegpop.original ) <- flow.control$marker.original
    colnames( spillover.posnegpop.original ) <- flow.control$marker.original

    compensation.posnegpop.original <- compensation.posnegpop
    rownames( compensation.posnegpop.original ) <- flow.control$marker.original
    colnames( compensation.posnegpop.original ) <- flow.control$marker.original

    # write spillover and compensation matrices

    if ( ! is.null( asp$table.spillover.dir ) )
        write.csv( spillover.posnegpop.original,
            file = file.path( asp$table.spillover.dir,
                sprintf( "%s.csv", asp$spillover.popnegpop.file.name ) ) )

    if ( ! is.null( asp$table.compensation.dir ) )
        write.csv( compensation.posnegpop.original,
            file = file.path( asp$table.compensation.dir,
                sprintf( "%s.csv", asp$compensation.popnegpop.file.name ) ) )

    # plot spillover and compensation matrices, by rows and columns
    # respectively

    if( ! is.null( asp$figure.spillover.dir ) )
    {
        figure.spillover.file.label <- sprintf( "_%s",
            asp$posnegpop.file.label )

        plot.matrix( spillover.posnegpop, TRUE, asp$figure.spillover.dir,
            figure.spillover.file.label, flow.control, asp )
    }

    if( ! is.null( asp$figure.compensation.dir ) )
    {
        figure.compensation.file.label <- sprintf( "_%s",
            asp$posnegpop.file.label )

        plot.matrix( compensation.posnegpop, FALSE,
            asp$figure.compensation.dir, figure.compensation.file.label,
            flow.control, asp )
    }

    # get uncompensated expresion data

    expr.data.unco <- flow.control$expr.data.untr

    # get compensated expression data

    flow.set.comp <- lapply( flow.control$flow.set, compensate,
        compensation( spillover.posnegpop.original ) )

    expr.data.comp <- get.flow.expression.data( flow.set.comp, flow.control )

    check.critical(
        identical( dimnames( expr.data.comp ), dimnames( expr.data.unco ) ),
        "internal error: inconsistent event or dye names in compensated data"
    )

    # get compensation error in compensated data

    compensation.error <- get.compensation.error(
        expr.data.unco, expr.data.comp, marker.spillover.unco.untr,
        TRUE, TRUE, asp$posnegpop.file.label, flow.gate, flow.control, asp
    )

    # get slope error

    slope.error <- compensation.error$slop - diag( flow.control$marker.n )

    if ( asp$verbose )
    {
        posnegpop.delta <- sd( slope.error )
        posnegpop.delta.max <- max( abs( slope.error ) )

        cat( sprintf( "posnegpop, delta %g, delta.max %g\n",
            posnegpop.delta, posnegpop.delta.max ) )
    }

    # save and plot slope error

    if ( ! is.null( asp$table.slope.error.dir ) )
        write.csv( slope.error,
            file = file.path( asp$table.slope.error.dir,
                sprintf( "%s.csv", asp$slope.error.posnegpop.file.name ) ) )

    if ( ! is.null( asp$figure.slope.error.dir ) )
        plot.density.log( slope.error, "compensation error",
            file.path( asp$figure.slope.error.dir,
                sprintf( "%s.png", asp$slope.error.posnegpop.file.name ) ),
            asp )

    # save and plot skewness

    if ( ! is.null( asp$table.skewness.dir ) )
        write.csv( compensation.error$skew,
            file = file.path( asp$table.skewness.dir,
                sprintf( "%s.csv", asp$skewness.posnegpop.file.name ) ) )

    if ( ! is.null( asp$figure.skewness.dir ) )
    {
        if ( ! is.null( flow.control$autof.marker.idx ) )
            spillover.skewness <- compensation.error$skew[
                - flow.control$autof.marker.idx,
                - flow.control$autof.marker.idx ]
        else
            spillover.skewness <- compensation.error$skew

        plot.density.log( spillover.skewness, "spillover skewness",
            file.path( asp$figure.skewness.dir,
                sprintf( "%s.png", asp$skewness.posnegpop.file.name ) ),
            asp )
    }

    list(
        spillover = spillover.posnegpop,
        compensation = compensation.posnegpop,
        error = compensation.error
    )
}


#' hierarchical_dirlichet_jags()
#' Fits a hierarchical dirlichet model with x-values observed at the core, plot and site level.
#'
#' @param y species matrix as a dataframe. Column names are species names.
#' @param core_mu core level observation means as a dataframe. column names are predictor names.
#' @param plot_mu plot level observation means as a dataframe. column names are predictor names.
#' @param site_mu site level observation means as a dataframe. column names are predictor names.
#' @param core_plot factor vector that links core level observations to plot IDs. Must be a factor.
#' @param core_site factor vector that links core level observations to site IDs. Must be a factor.
#' @param plot_site factor vector that links plot level observations to site IDs. Must be a factor.
#' @param plot_plot factor vector of unique plot IDs, same order as plot data. Must be a factor.
#' @param site_site factor vector od unique site IDs, same order as site data. Must be a factor.
#' @param core_sd core level observation sd as a dataframe. column names should match core_mu. optional.
#' @param plot_sd plot level observation sd as a dataframe. column names should match plot_mu. optional.
#' @param site_sd site level observation sd as a dataframe. column names should match site_mu. optional.
#' @param adapt   number of adaptive iterations for JAGS simulation.
#' @param burnin  number of burnin iterations for JAGS simulation.
#' @param sample  number of sample iterations for JAGS simulation.
#' @param n.chains number of chains for JAGS simulation.
#' @param parallel whether or not to run JAGS chains in parallel.
#'
#' @return returns a list with the fitted model, a list of species by parameter tables, and matrices of predicted, observed and residual values on the observation scale (0,1)
#' @export
#'
#' @examples
#' adapt = 50; burnin = 100; sample = 200; n.chains = 3; parallel = F;
hierarchical_dirlichet_jags   <- function(y,
                                          core_mu, plot_mu, site_mu,
                                          core_sd = NA, plot_sd = NA, site_sd = NA,
                                          core_plot, core_site, plot_site, plot_plot, site_site,
                                          adapt = 500, burnin = 1000, sample = 2000, n.chains = 3, parallel = F){
  #Load some important dependencies.
  source('/home/caverill/NEFI_microbe/NEFI_functions/crib_fun.r')
  source('/home/caverill/NEFI_microbe/NEFI_functions/sd_to_precision.r')
  source('/home/caverill/NEFI_microbe/NEFI_functions/precision_matrix_match.r')

  #Some checks before we get started.
  y    <- as.data.frame(y)
  core_mu <- as.data.frame(core_mu)
  plot_mu <- as.data.frame(plot_mu)
  site_mu <- as.data.frame(site_mu)
  #core level. First column needs to be intercept, a vector of 1s.
  if(mean(core_mu[,1]) != 1){stop('First column in core_mu is not a vector of 1s for the intercept. This needs to be or this function doesnt work.')}
  if(ncol(core_mu) < 2){stop('We need an intercept and at least one predictor at the core level for this to work. core_mu has less than 2 columns. Try again buddy.')}

  #grab names
  y.names <- colnames(y)
  core.names <- colnames(core_mu)
  plot.names <- colnames(plot_mu)
  site.names <- colnames(site_mu)

  ###massage your data together.
  #deal with zero relative abundances.
  y <- data.frame(y)
  y <- data.frame(lapply(y, crib_fun))

  #make sd objects if they were not supplied.
  if(is.na(core_sd)){core_sd = data.frame(rep(1,nrow(core_mu)))}
  if(is.na(plot_sd)){plot_sd = data.frame(rep(1,nrow(plot_mu)))}
  if(is.na(site_sd)){site_sd = data.frame(rep(1,nrow(site_mu)))}

  #Match up predictors and their SD. if no SD supplied we assign perfect (really really high) precision.
  core_sd <- precision_matrix_match(core_mu,core_sd)
  plot_sd <- precision_matrix_match(plot_mu,plot_sd)
  site_sd <- precision_matrix_match(site_mu,site_sd)

  #covert sd to precision. output is matrix.
  core_precision <- sd_to_precision(core_sd)
  plot_precision <- sd_to_precision(plot_sd)
  site_precision <- sd_to_precision(site_sd)

  #make sure every else is a matrix.
  y <- as.matrix(y)
  core_mu <- as.matrix(core_mu)
  plot_mu <- as.matrix(plot_mu)
  site_mu <- as.matrix(site_mu)

  #make sure index vectors are factors, drop levels.
  core_plot <- droplevels(as.factor(core_plot))
  core_site <- droplevels(as.factor(core_site))
  plot_plot <- droplevels(as.factor(plot_plot))
  plot_site <- droplevels(as.factor(plot_site))
  site_site <- droplevels(as.factor(site_site))

  ###setup jags data object.
  jags.data <- list(N.core = nrow(core_mu), N.plot = nrow(plot_mu), N.site = nrow(site_mu), N.spp = ncol(y),            #number of c/p/s observations and number of species
                    N.core.preds = ncol(core_mu), N.plot.preds = ncol(plot_mu), N.site.preds = ncol(site_mu),           #number of predictors at c/p/s level
                    core_mu = core_mu, plot_mu = plot_mu, site_mu = site_mu,                                            #x-value mean      matrices c/p/s
                    core_precision = core_precision, plot_precision = plot_precision, site_precision = site_precision,  #x-value precision matrices c/p/s
                    core_plot = core_plot, core_site = core_site,                                                       #vectors that index across  c/p/s
                    plot_plot = plot_plot, plot_site = plot_site, site_site = site_site,                                #vectors that index across  c/p/s
                    y = y)                                                                                #species matrix, y

  ###specify JAGS model.
  jags.model = "
  model {
  #priors for each species*predictor*hierarchical-level.----
  alpha ~ dnorm(0, 1.0E-3)
  #core level priors
  for(i in 1:N.core.preds){
  core.mm[i,1] <- 0
  for (j in 2:N.spp) {core.mm[i,j] ~ dnorm(0, 1.0E-3)}
  }
  #plot level priors
  for(i in 1:N.plot.preds){
  plot.m[i,1] <- 0
  for (j in 2:N.spp) {plot.m[i,j] ~ dnorm(0, 1.0E-3)}
  }
  #site level priors
  for(i in 1:N.site.preds){
  site.m[i,1] <- 0
  for (j in 2:N.spp) {site.m[i,j] ~ dnorm(0, 1.0E-3)}
  }

  ### Begin missing data model ###
  #missing X data priors, core-level.
  for(m in 1:N.core.preds){
      core.global[m] ~ dnorm(0,1.0E-4) #global level parameter prior.
    core.site.tau[m] ~ dgamma(0.1,0.1)
    core.plot.tau[m] ~ dgamma(0.1,0.1)
    core.core.tau[m] ~ dgamma(0.1,0.1)
  }
  #missing X data priors, plot-level.
  for(m in 1:N.plot.preds){
      plot.global[m] ~ dnorm(0,1.0E-4) #global level parameter prior.
    plot.site.tau[m] ~ dgamma(0.1,0.1)
    plot.plot.tau[m] ~ dgamma(0.1,0.1)
  }
  #missing X data priors, site-level.
  for(m in 1:N.site.preds){
      site.global[m] ~ dnorm(0,1.0E-4) #global level parameter prior.
    site.site.tau[m] ~ dgamma(0.1,0.1)
  }

  #fill in any missing X values at core level.
  for(m in 1:N.core.preds){
    for(i in 1:N.site){ site.core[i,m] ~ dnorm(core.global[m], core.site.tau[m])}           ## estimate global mean
    for(j in 1:N.plot){ plot.core[j,m] ~ dnorm(site.core[plot_site[j],m],core.plot.tau[m])} ## estimate site means
    for(k in 1:N.core){   core_mu[k,m] ~ dnorm(plot.core[core_plot[k],m],core.core.tau[m])} ## estimate plot means
  }
  #fill in any missing X values at plot level.
    for(m in 1:N.plot.preds){
    for(i in 1:N.site){ site.plot[i,m] ~ dnorm(plot.global[m], plot.site.tau[m])}           ## estimate global mean
    for(j in 1:N.plot){   plot_mu[j,m] ~ dnorm(site.plot[plot_site[j],m],plot.plot.tau[m])} ## estimate site means
  }
  #fill in any missing X values at site level.
  for(m in 1:N.plot.preds){
    for(i in 1:N.site){   site_mu[i,m] ~ dnorm(site.global[m], site.site.tau[m])}           ## estimate global mean
  }

  #predictor (x) values drawn from distributions.
  for(j in 1:N.core.preds){for(i in 1:N.core){core[i,j] ~ dnorm(core_mu[i,j], core_precision[i,j])}} #core x values
  for(j in 1:N.plot.preds){for(i in 1:N.plot){plot[i,j] ~ dnorm(plot_mu[i,j], plot_precision[i,j])}} #plot x values
  for(j in 1:N.site.preds){for(i in 1:N.site){site[i,j] ~ dnorm(site_mu[i,j], site_precision[i,j])}} #site x values

  #mean center all predictors (except core-level intercept).
  for(i in 1:N.core){
  core.center[i,1] <- 1
  for(j in 2:N.core.preds){
  core.center[i,j] <- core[i,j] - mean(core[,j])
  }
  }
  for(i in 1:N.plot){for(j in 1:N.plot.preds){plot.center[i,j] <- plot[i,j] - mean(plot[,j])}}
  for(i in 1:N.site){for(j in 1:N.site.preds){site.center[i,j] <- site[i,j] - mean(site[,j])}}

  #save mean values for back transforming intercept values.
  for(j in 1:N.core.preds){core.center.save[j] <- mean(core[,j])}
  for(j in 1:N.plot.preds){plot.center.save[j] <- mean(plot[,j])}
  for(j in 1:N.site.preds){site.center.save[j] <- mean(site[,j])}

  #combine core/plot/site (x) values and parameters.
  for(j in 1:N.spp){
  for(i in 1:N.core){core.level[i,j] <- inprod(core.mm[,j], core.center[i,])           } #core level
  for(p in 1:N.plot){plot.level[p,j] <- inprod(plot.m [,j], plot.center[plot_plot[p],])} #plot level
  for(s in 1:N.site){site.level[s,j] <- inprod(site.m [,j], site.center[site_site[s],])} #site level
  }

  #fit species abundances as a linear combination of core, plot and site predictors.
  for(i in 1:N.core){
  for(j in 1:N.spp){
  log(a0[i,j]) <- alpha + core.level[i,j] + plot.level[core_plot[i],j] + site.level[core_site[i],j]
  }
  y[i,1:N.spp] ~ ddirch(a0[i,1:N.spp])
  }

  #map to original parameterization, assuming first column of core level predictors is intercept.
  for(j in 1:N.spp){
  core.norm[j] <- inprod(core.mm[2:N.core.preds,j], core.center.save[2:N.core.preds])
  plot.norm[j] <- inprod(plot.m[,j], plot.center.save)
  site.norm[j] <- inprod(site.m[,j], site.center.save)
  }

  for (j in 1:N.spp) {
  core.m[1,j] <- alpha + core.mm[1,j] - (core.norm[j] + plot.norm[j] + site.norm[j])
  for (i in 2:N.core.preds){
  core.m[i,j] <- core.mm[i,j]
  }
  }

  } #close model loop.
  "

  ###Fit JAGS model.
  #parallel or not parallel.
  run.method <- ifelse(parallel == F,'rjags','rjparallel')
  #run jags model.
  jags.out <- runjags::run.jags(   model = jags.model,
                                   data = jags.data,
                                   adapt = adapt,
                                   burnin = burnin,
                                   sample = sample,
                                   n.chains = n.chains,
                                   method = run.method,
                                   monitor = c('core.m','plot.m','site.m'))
  #summarize output
  out <- summary(jags.out)

  #grab parmeters by species, make a list of species-parameter dataframes
  output.list <- list()
  for(i in 1:ncol(y)){
    z <- out[grep(paste0(',',i,']'),rownames(out)),]
    names <- c(core.names,plot.names,site.names)
    z <- cbind(names,z)
    colnames(z)[1] <- 'predictor'
    output.list[[i]] <- data.frame(z)
  }
  names(output.list) <- y.names

  #get the matrix of predicted y values.
  core.core <- data.frame(cbind(core_plot,core_site,core_mu))
  plot.plot <- data.frame(cbind(plot_plot,plot_mu))
  site.site <- data.frame(cbind(site_site,site_mu))
  super.x <- merge(core.core,plot.plot, by.x = 'core_plot', by.y = 'plot_plot', all.x = T)
  super.x <- merge(  super.x,site.site, by.x = 'core_site', by.y = 'site_site', all.x = T)
  super.x <- super.x[,3:ncol(super.x)]

  pred.list <- list()
  for(i in 1:ncol(y)){
    pred <- exp(as.matrix(super.x) %*% as.numeric(as.character(output.list[[i]][,5])))
    pred.list[[i]] <- pred
  }
  predicted <- do.call('cbind',pred.list)
  predicted <- predicted / rowSums(predicted)
  colnames(predicted) <- colnames(y)
  #get matrix of residuals
  resid <- y - predicted

  #make a super output that also returns model
  super.list <- list(jags.out, output.list,predicted,y,resid)
  names(super.list) <- c('jags_model','species_parameter_output','predicted','observed','residual')

  #return model and output
  return(super.list)

}


#!/usr/bin/env Rscript

#load libraries
library("DESeq2")
library("ggplot2")
library("viridis")
library("RColorBrewer")
library("gplots")
####FUNCTIONS####
parseStatsGetReadCountFile <- function(path){
  full=paste(path,"/Statistics.dat",sep="")
  stats=read.table(full,header=T,sep=" ",stringsAsFactors=FALSE)
  #check if variable is defined then updated Stats values
  if(!is.na(restrictLength)){
    # update reads column in each Stats entry to the sum of the counts
    # in the columns of given read counts
    restrictPattern=gsub(',','|',restrictLength)
    indices=grep(restrictPattern,names(stats))
    if(length(indices) > 0){
        stats$reads=apply(stats[,indices],1,sum)
    }
  }
  dfa=data.frame(stats$region, stats$reads)
  write.table(dfa,paste(path,"/readCounts.txt",sep=""),quote=F,row.names=F, col.names=F, sep="\t")
}
####DONE FUNCTIONS####
args <- commandArgs(trailingOnly = TRUE)

config=args[1]
out=args[2]
ALPHA=as.numeric(args[3])
restrictLength=args[4]

conf=read.table(config,header=T,sep="\t",stringsAsFactors=FALSE)
lapply(conf$location,parseStatsGetReadCountFile)
sampleTable=data.frame(sampleName=conf$sampleName, filename=paste(conf$location,"/readCounts.txt",sep=""), condition=conf$condition)

#This working directory changing is done, because the DESeqDataSetFromHTSeqCount function uses "./" before the location we provide.
actWD<-getwd()
setwd("/")
ddsHTSeq<-DESeqDataSetFromHTSeqCount(sampleTable=sampleTable, design=~condition)
setwd(actWD)

colData(ddsHTSeq)$condition<-factor(colData(ddsHTSeq)$condition, levels=c("untreated","treated"))
dds<-DESeq(ddsHTSeq)
res<-results(dds)
deStats<-as.data.frame(cbind(assay(dds), res$baseMean, res$log2FoldChange, res$lfcSE, res$stat, res$pvalue, res$padj))
colnames(deStats)=t(c(colnames(assay(dds)),colnames(res)))
write.table(deStats,paste(out,"DiffExp_Statistics.csv",sep=""),quote=F,sep=",",col.names=NA)
res<-res[order(res$padj),]

#Making Plots as a PDF file
pdf(paste(out,"DiffExp_Plots.pdf",sep=""))

#MAPlot
print(plotMA(res,main="MAPlot",alpha=ALPHA,colNonSig="blue",colLine=NULL,cex=0.6))
#print(plotMA(dds,main="MAPlot",alpha=ALPHA))

#Data Transformation
vsd <- varianceStabilizingTransformation(dds, blind=TRUE)

#Heatmaps For different transformations
#selection<-rownames(res)[1:NVAL]
selection<-rownames(na.omit(res[(res$padj[complete.cases(res$padj)]<ALPHA),]))
#cpalette<-colorRampPalette(c("red", "yellow", "green"))(n = 128)
cpalette<-colorRampPalette(c("white","green","green4","violet","purple"))(n=92)
#celtextm<-as.data.frame(rep(transform(round(res$padj[1:NVAL],4)),4))
print(heatmap.2(assay(vsd)[selection,], col = cpalette, margin=c(9,9), density.info="none", scale="none", trace="none", srtRow=0, srtCol=30, key.xlab = "Read Count", cexRow = 0.5, cexCol = 0.75))

#PCA Plot
pcaPl<-plotPCA(vsd,intgroup=c("condition"),returnData=TRUE)
print(ggplot(pcaPl,aes(PC1, PC2,color=condition))+geom_point(size=3)+
        scale_color_viridis(discrete = T, option="D"))
dev.off()

print(paste("No. of DE genes w.r.t cut-off:", length(selection), sep=""))