library(reshape2)

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep")
load("COVID19_gene_noise_Figure6A.Rdat")

# Remove outlier genes from analysis with extremely high BCV
gene_noise_COVID$bcv_mild[gene_noise_COVID$bcv_mild >= 10] <- NA
gene_noise_COVID$bcv_severe[gene_noise_COVID$bcv_severe >= 10] <- NA

# data frame BCV mild/severe
dat <- gene_noise_COVID[,c(3:4)]
colnames(dat) <- c("mild", "severe")
dat <- na.omit(dat)

# Mean gene expression BCV +/- std.dev for COVID19
df1_COVID <- melt(dat)
df1_COVID_mu <- aggregate(value ~ variable, df1_COVID, mean)$value
df1_COVID_upp_sd <- aggregate(value ~ variable, data=df1_COVID, function(x) mean(x) + sd(x))$value
df1_COVID_lwr_sd <- aggregate(value ~ variable, data=df1_COVID, function(x) mean(x) - sd(x))$value

# Mean gene expression BCV +/- std.dev for COVID19 for which BCV changes significantly between mild/severe COVID19
dat2 <- gene_noise_COVID[p.adjust(gene_noise_COVID$p_bcv, "BH") < 0.05,c(3:4)]
colnames(dat2) <- c("mild", "severe")
dat2 <- na.omit(dat2)

df2_COVID <- melt(dat2)
df2_COVID_mu <- aggregate(value ~ variable, df2_COVID, mean)$value
df2_COVID_upp_sd <- aggregate(value ~ variable, data=df2_COVID, function(x) mean(x) + sd(x))$value
df2_COVID_lwr_sd <- aggregate(value ~ variable, data=df2_COVID, function(x) mean(x) - sd(x))$value

setwd("/media/yuri/Data/home1/GNI_data/infection/ResultsSciRep/Figures")

pdf("Figure6A.pdf", paper="a4r", width=5.5, height=8)

par(mfrow=c(1,2))

stripchart(value ~ variable, data = df1_COVID, method="jitter", vertical = TRUE,
  col = NULL, pch=NA, cex=0.3, ylab = "bcv", las=1, ylim=c(0.1,0.7))
lines(c(1:2), df1_COVID_mu, col=1, lty=2, lwd=2  )
segments(c(1:2), df1_COVID_upp_sd, c(1:2), df1_COVID_lwr_sd, lwd=3, col = c("#4591CC", "#673AB7")  )
points(c(1:2), df1_COVID_mu, pch=21, col = c("#4591CC", "#673AB7"), bg = "white", cex=3, lwd=3  )
legend("topleft", legend = c(
  paste0("p(1-0) = ", round(t.test(sqrt(gene_noise_COVID$bcv_mild),  sqrt(gene_noise_COVID$bcv_severe))$p.value, 5))
))

stripchart(value ~ variable, data = df2_COVID, method="jitter", vertical = TRUE,
  col = NULL, pch=NA, cex=0.3, ylab = "bcv", las=1, ylim=c(0.1,0.7))
lines(c(1:2), df2_COVID_mu, col=1, lty=2, lwd=2  )
segments(c(1:2), df2_COVID_upp_sd, c(1:2), df2_COVID_lwr_sd, lwd=3, col = c("#4591CC", "#673AB7")  )
points(c(1:2), df2_COVID_mu, pch=21, col = c("#4591CC", "#673AB7"), bg = "white", cex=3, lwd=3  )
legend("topleft", legend = c(
  paste0("p(1-0) = ", round(t.test(sqrt(gene_noise_COVID$bcv_mild),  sqrt(gene_noise_COVID$bcv_severe))$p.value, 5))
))

dev.off()


library(ggplot2)
library(shiny)
library(reshape2)
library(wesanderson)
library(shinythemes)
library(DT)

stat_smooth_func_with_pval <- function(mapping = NULL, data = NULL,
                                       geom = "smooth", position = "identity",
                                       ...,
                                       method = "auto",
                                       formula = y ~ x,
                                       se = TRUE,
                                       n = 80,
                                       span = 0.75,
                                       fullrange = FALSE,
                                       level = 0.95,
                                       method.args = list(),
                                       na.rm = FALSE,
                                       show.legend = NA,
                                       inherit.aes = TRUE,
                                       xpos = NULL,
                                       ypos = NULL,
                                       xpos2 = NULL,
                                       ypos2 = NULL) {
  layer(
    data = data,
    mapping = mapping,
    stat = StatSmoothFunc,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      method = method,
      formula = formula,
      se = se,
      n = n,
      fullrange = fullrange,
      level = level,
      na.rm = na.rm,
      method.args = method.args,
      span = span,
      xpos = xpos,
      ypos = ypos,
      xpos2 = xpos2,
      ypos2 = ypos2,
      ...
    )
  )
}

StatSmoothFunc <- ggproto("StatSmooth", Stat,

                          setup_params = function(data, params) {
                            # Figure out what type of smoothing to do: loess for small datasets,
                            # gam with a cubic regression basis for large data
                            # This is based on the size of the _largest_ group.
                            if (identical(params$method, "auto")) {
                              max_group <- max(table(data$group))

                              if (max_group < 1000) {
                                params$method <- "loess"
                              } else {
                                params$method <- "gam"
                                params$formula <- y ~ s(x, bs = "cs")
                              }
                            }
                            if (identical(params$method, "gam")) {
                              params$method <- mgcv::gam
                            }

                            params
                          },

                          compute_group = function(data, scales, method = "auto", formula = y~x,
                                                   se = TRUE, n = 80, span = 0.75, fullrange = FALSE,
                                                   xseq = NULL, level = 0.95, method.args = list(),
                                                   na.rm = FALSE, xpos=NULL, ypos=NULL,
                                                   xpos2=NULL, ypos2=NULL) {
                            if (length(unique(data$x)) < 2) {
                              # Not enough data to perform fit
                              return(data.frame())
                            }

                            if (is.null(data$weight)) data$weight <- 1

                            if (is.null(xseq)) {
                              if (is.integer(data$x)) {
                                if (fullrange) {
                                  xseq <- scales$x$dimension()
                                } else {
                                  xseq <- sort(unique(data$x))
                                }
                              } else {
                                if (fullrange) {
                                  range <- scales$x$dimension()
                                } else {
                                  range <- range(data$x, na.rm = TRUE)
                                }
                                xseq <- seq(range[1], range[2], length.out = n)
                              }
                            }
                            # Special case span because it's the most commonly used model argument
                            if (identical(method, "loess")) {
                              method.args$span <- span
                            }

                            if (is.character(method)) method <- match.fun(method)

                            base.args <- list(quote(formula), data = quote(data), weights = quote(weight))
                            model <- do.call(method, c(base.args, method.args))

                            m = model
                            eq1 <- substitute(italic(y) == a + b %.% italic(x),
                                              list(a = format(coef(m)[[1]], digits = 3),
                                                   b = format(coef(m)[[2]], digits = 3)))

                            eq2 <- substitute(italic(r)^2~"="~r2*","~~italic(p)~"="~pval,
                                              list(r2 = format(summary(m)$r.squared, digits = 3),
                                                   pval = format(summary(m)$coef[2,4], digits = 3)))

                            func_string1 = as.character(as.expression(eq1))
                            func_string2 = as.character(as.expression(eq2))

                            if(is.null(xpos)) xpos = min(data$x)
                            if(is.null(ypos)) ypos = max(data$y)
                            if(is.null(xpos2)) xpos2 = xpos
                            if(is.null(ypos2)) ypos2 = ypos - (ypos*0.02)

                            data.frame(x = rbind(xpos, xpos2),
                                       y = rbind(ypos, ypos2),
                                       label = rbind(func_string1, func_string2))

                          },

                          required_aes = c("x", "y")
)

# Get lower triangle of the correlation matrix
get_lower_tri<-function(cormat){
  cormat[upper.tri(cormat)] <- NA
  return(cormat)
}
# Get upper triangle of the correlation matrix
get_upper_tri <- function(cormat){
  cormat[lower.tri(cormat)]<- NA
  return(cormat)
}

reorder_cormat <- function(cormat){
  # Use correlation between variables as distance
  dd <- as.dist((1-cormat)/2)
  hc <- hclust(dd)
  cormat <-cormat[hc$order, hc$order]
}

# Read CSV into R, it can take a while.
# Change csv paths to file paths if nessesery, but remeber that you need to use "\" separators instead of "/".
# You can download csv files for yourself on: https://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/
WhiteWines <- read.csv(file=url("https://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-white.csv"), header=TRUE, sep=";")
RedWines <- read.csv(file=url("https://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality-red.csv"), header=TRUE, sep=";")

ui <- fluidPage(
  theme = shinytheme("sandstone"),

  navbarPage("WineData",
             tabPanel("Plots created from data",
                      h1("Wine data Plots",
                         align="center"),

                      sidebarLayout(

                        position = "right",

                        sidebarPanel(

                          checkboxInput("checkboxTheme",
                                        label = "Dark theme",
                                        value = FALSE),

                          radioButtons("radioPlotStyle",
                                       inline = TRUE,
                                       label = NA,
                                       choices = list("Jiter",
                                                      "Point",
                                                      "Smooth",
                                                      "Column",
                                                      "Violin",
                                                      "Boxplot"),
                                       selected = "Jiter"),

                          radioButtons("radioPlot",
                                       inline = TRUE,
                                       label = NA,
                                       choices = list("Normal plot",
                                                      "Plot for each Quality")),

                          selectInput("selectX",
                                      label = h3("Select X and Y for plot drawing"),
                                      choices = list("Fixed acidity",
                                                     "Volatile acidity",
                                                     "Citric acid",
                                                     "Residual sugar",
                                                     "Chlorides",
                                                     "Free sulfur dioxide",
                                                     "Total sulfur dioxide",
                                                     "Density",
                                                     "pH",
                                                     "Sulphates",
                                                     "Alcohol",
                                                     "Quality"),
                                      selected = "Quality"),

                          selectInput("selectY",
                                      label = NA,
                                      choices = list("Fixed acidity",
                                                     "Volatile acidity",
                                                     "Citric acid",
                                                     "Residual sugar",
                                                     "Chlorides",
                                                     "Free sulfur dioxide",
                                                     "Total sulfur dioxide",
                                                     "Density",
                                                     "pH",
                                                     "Sulphates",
                                                     "Alcohol",
                                                     "Quality")),

                          p("To zoom, please select a zone you want to zoom and double click it.",
                            align = "center"),
                          p("Double click without a zone to return to normal stage.",
                            align = "center"),

                          br(),
                          p("You can download data for yourself ", a("here.", href="https://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/"),
                            align = "center")

                        ),

                        mainPanel(
                          tabsetPanel(
                            tabPanel("White Wines",
                                     plotOutput(outputId = "whitePlot",
                                                height = "900px",
                                                dblclick = "PlotDblclick",
                                                brush = brushOpts(
                                                id = "PlotBrush",
                                                resetOnNew = TRUE)
                                                ),
                                     h4("Selected points",
                                        align = "center"),
                                     verbatimTextOutput("plotWhiteBrushInfo"),
                                     p("Note that only in Point mode, selecting is precise.",
                                       align = "center"),
                                     tags$head(tags$style(HTML("
                                    #plotWhiteBrushInfo {
                                                               font-size: 11.5px;
                                                               }
                                                               ")))),
                            tabPanel("Red Wines",
                                     plotOutput(outputId = "redPlot",
                                                height = "900px",
                                                dblclick = "PlotDblclick",
                                                brush = brushOpts(
                                                id = "PlotBrush",
                                                resetOnNew = TRUE)
                                                ),
                                     h4("Selected points",
                                        align = "center"),
                                     verbatimTextOutput("plotRedBrushInfo"),
                                     p("Note that only in Point mode, selecting is precise.",
                                       align = "center"),
                                    tags$head(tags$style(HTML("
                                    #plotRedBrushInfo {
                                                              font-size: 11.5px;
                                                              }
                                                              ")))),
                            tabPanel("Correlation plot for White wines",
                                     plotOutput(outputId = "colWhitePlot")),
                            tabPanel("Correlation plot for Red wines",
                                     plotOutput(outputId = "colRedPlot"))
                          )
                        )
                      )),

             tabPanel("Info about data",
                      h1("Wine data Info",
                         align="center"),
                      h3("Informations are from ",
                         a("winequality.names.",
                           href="https://archive.ics.uci.edu/ml/machine-learning-databases/wine-quality/winequality.names"),
                         align = "center"),
                      htmlOutput("modelParameters")
                      ),

             tabPanel("Data for view",
                      tabsetPanel(
                        tabPanel("White Wines",
                                 br(),
                                 DT::dataTableOutput("dataToShowWhite")),
                        tabPanel("Red Wines",
                                 br(),
                                 DT::dataTableOutput("dataToShowRed"))
                                )
                      )
             )

  )

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

  observe({
    choicesRadioPlotStyle = if(input$selectX == "Quality"){
      list("Jiter",
           "Point",
           "Column",
           "Violin",
           "Boxplot")
    }
    else{
      list("Jiter",
           "Point",
           "Column",
           "Smooth")
    }

    updateRadioButtons(session, "radioPlotStyle",
                       choices = choicesRadioPlotStyle,
                       inline = TRUE)

  })

  observe({
    choices = list("Fixed acidity",
                   "Volatile acidity",
                   "Citric acid",
                   "Residual sugar",
                   "Chlorides",
                   "Free sulfur dioxide",
                   "Total sulfur dioxide",
                   "Density",
                   "pH",
                   "Sulphates",
                   "Alcohol",
                   "Quality")

    updateSelectInput(session, "selectY",
                      choices = choices[choices != input$selectX],
                      selected = input$selectY)

    updateSelectInput(session, "selectX",
                      choices = choices[choices != input$selectY],
                      selected = input$selectX)
  })

  output$dataToShowWhite = DT::renderDataTable({WhiteWines})

  output$dataToShowRed = DT::renderDataTable({RedWines})

  output$plotWhiteBrushInfo <- renderPrint({

    fixedNamesY <- switch(input$selectY,
                          "Fixed acidity" = "fixed.acidity",
                          "Volatile acidity" = "volatile.acidity",
                          "Citric acid" = "citric.acid",
                          "Residual sugar" = "residual.sugar",
                          "Chlorides" = "chlorides",
                          "Free sulfur dioxide" = "free.sulfur.dioxide",
                          "Total sulfur dioxide" = "total.sulfur.dioxide",
                          "Density" = "density",
                          "pH" = "pH",
                          "Sulphates" = "sulphates",
                          "Alcohol" = "alcohol",
                          "Quality" = "quality")

    fixedNamesX <- switch(input$selectX,
                          "Fixed acidity" = "fixed.acidity",
                          "Volatile acidity" = "volatile.acidity",
                          "Citric acid" = "citric.acid",
                          "Residual sugar" = "residual.sugar",
                          "Chlorides" = "chlorides",
                          "Free sulfur dioxide" = "free.sulfur.dioxide",
                          "Total sulfur dioxide" = "total.sulfur.dioxide",
                          "Density" = "density",
                          "pH" = "pH",
                          "Sulphates" = "sulphates",
                          "Alcohol" = "alcohol",
                          "Quality" = "quality")

    brushedPoints(WhiteWines, input$PlotBrush, fixedNamesX, fixedNamesY)
  })

  output$plotRedBrushInfo <- renderPrint({

    fixedNamesY <- switch(input$selectY,
                          "Fixed acidity" = "fixed.acidity",
                          "Volatile acidity" = "volatile.acidity",
                          "Citric acid" = "citric.acid",
                          "Residual sugar" = "residual.sugar",
                          "Chlorides" = "chlorides",
                          "Free sulfur dioxide" = "free.sulfur.dioxide",
                          "Total sulfur dioxide" = "total.sulfur.dioxide",
                          "Density" = "density",
                          "pH" = "pH",
                          "Sulphates" = "sulphates",
                          "Alcohol" = "alcohol",
                          "Quality" = "quality")

    fixedNamesX <- switch(input$selectX,
                          "Fixed acidity" = "fixed.acidity",
                          "Volatile acidity" = "volatile.acidity",
                          "Citric acid" = "citric.acid",
                          "Residual sugar" = "residual.sugar",
                          "Chlorides" = "chlorides",
                          "Free sulfur dioxide" = "free.sulfur.dioxide",
                          "Total sulfur dioxide" = "total.sulfur.dioxide",
                          "Density" = "density",
                          "pH" = "pH",
                          "Sulphates" = "sulphates",
                          "Alcohol" = "alcohol",
                          "Quality" = "quality")

    brushedPoints(WhiteWines, input$PlotBrush, fixedNamesX, fixedNamesY)
  })

  ranges <- reactiveValues(x = NULL, y = NULL)

  observeEvent(input$PlotDblclick, {
    brush <- input$PlotBrush
    if (!is.null(brush)) {
      ranges$x <- c(brush$xmin, brush$xmax)
      ranges$y <- c(brush$ymin, brush$ymax)

    } else {
      ranges$x <- NULL
      ranges$y <- NULL
    }
  })

  output$brush_info <- renderPrint({
    brushedPoints(mtcars2, input$plot1_brush)
  })

  output$modelParameters <- renderUI(
    HTML(
      paste(
        c("<pre>", "Citation Request:
                        This dataset is public available for research. The details are described in [Cortez et al., 2009].
          Please include this citation if you plan to use this database:

          P. Cortez, A. Cerdeira, F. Almeida, T. Matos and J. Reis.
          Modeling wine preferences by data mining from physicochemical properties.
          In Decision Support Systems, Elsevier, 47(4):547-553. ISSN: 0167-9236.

          Available at: [@Elsevier] http://dx.doi.org/10.1016/j.dss.2009.05.016
          [Pre-press (pdf)] http://www3.dsi.uminho.pt/pcortez/winequality09.pdf
          [bib] http://www3.dsi.uminho.pt/pcortez/dss09.bib

          1. Title: Wine Quality

          2. Sources
          Created by: Paulo Cortez (Univ. Minho), Antonio Cerdeira, Fernando Almeida, Telmo Matos and Jose Reis (CVRVV) @ 2009

          3. Past Usage:

          P. Cortez, A. Cerdeira, F. Almeida, T. Matos and J. Reis.
          Modeling wine preferences by data mining from physicochemical properties.
          In Decision Support Systems, Elsevier, 47(4):547-553. ISSN: 0167-9236.

          In the above reference, two datasets were created, using red and white wine samples.
          The inputs include objective tests (e.g. PH values) and the output is based on sensory data
          (median of at least 3 evaluations made by wine experts). Each expert graded the wine quality
          between 0 (very bad) and 10 (very excellent). Several data mining methods were applied to model
          these datasets under a regression approach. The support vector machine model achieved the
          best results. Several metrics were computed: MAD, confusion matrix for a fixed error tolerance (T),
          etc. Also, we plot the relative importances of the input variables (as measured by a sensitivity
          analysis procedure).

          4. Relevant Information:

          The two datasets are related to red and white variants of the Portuguese Vinho Verde wine.
          For more details, consult: http://www.vinhoverde.pt/en/ or the reference [Cortez et al., 2009].
          Due to privacy and logistic issues, only physicochemical (inputs) and sensory (the output) variables
          are available (e.g. there is no data about grape types, wine brand, wine selling price, etc.).

          These datasets can be viewed as classification or regression tasks.
          The classes are ordered and not balanced (e.g. there are munch more normal wines than
          excellent or poor ones). Outlier detection algorithms could be used to detect the few excellent
          or poor wines. Also, we are not sure if all input variables are relevant. So
          it could be interesting to test feature selection methods.

          5. Number of Instances: red wine - 1599; white wine - 4898.

          6. Number of Attributes: 11 + output attribute

          Note: several of the attributes may be correlated, thus it makes sense to apply some sort of
          feature selection.

          7. Attribute information:

          For more information, read [Cortez et al., 2009].

          Input variables (based on physicochemical tests):
          1 - fixed acidity
          2 - volatile acidity
          3 - citric acid
          4 - residual sugar
          5 - chlorides
          6 - free sulfur dioxide
          7 - total sulfur dioxide
          8 - density
          9 - pH
          10 - sulphates
          11 - alcohol
          Output variable (based on sensory data):
          12 - quality (score between 0 and 10)

          8. Missing Attribute Values: None", "</pre>"),
        collapse = "<br>"
      )
    )
  )

  output$whitePlot <- renderPlot({

    selectY <- switch(input$selectY,
                     "Fixed acidity" = WhiteWines$fixed.acidity,
                     "Volatile acidity" = WhiteWines$volatile.acidity,
                     "Citric acid" = WhiteWines$citric.acid,
                     "Residual sugar" = WhiteWines$residual.sugar,
                     "Chlorides" = WhiteWines$chlorides,
                     "Free sulfur dioxide" = WhiteWines$free.sulfur.dioxide,
                     "Total sulfur dioxide" = WhiteWines$total.sulfur.dioxide,
                     "Density" = WhiteWines$density,
                     "pH" = WhiteWines$pH,
                     "Sulphates" = WhiteWines$sulphates,
                     "Alcohol" = WhiteWines$alcohol,
                     "Quality" = WhiteWines$quality)

    selectX <- switch(input$selectX,
                     "Fixed acidity" = WhiteWines$fixed.acidity,
                     "Volatile acidity" = WhiteWines$volatile.acidity,
                     "Citric acid" = WhiteWines$citric.acid,
                     "Residual sugar" = WhiteWines$residual.sugar,
                     "Chlorides" = WhiteWines$chlorides,
                     "Free sulfur dioxide" = WhiteWines$free.sulfur.dioxide,
                     "Total sulfur dioxide" = WhiteWines$total.sulfur.dioxide,
                     "Density" = WhiteWines$density,
                     "pH" = WhiteWines$pH,
                     "Sulphates" = WhiteWines$sulphates,
                     "Alcohol" = WhiteWines$alcohol,
                     "Quality" = WhiteWines$quality)

    fixedNamesY <- switch(input$selectY,
                         "Fixed acidity" = "fixed.acidity",
                         "Volatile acidity" = "volatile.acidity",
                         "Citric acid" = "citric.acid",
                         "Residual sugar" = "residual.sugar",
                         "Chlorides" = "chlorides",
                         "Free sulfur dioxide" = "free.sulfur.dioxide",
                         "Total sulfur dioxide" = "total.sulfur.dioxide",
                         "Density" = "density",
                         "pH" = "pH",
                         "Sulphates" = "sulphates",
                         "Alcohol" = "alcohol",
                         "Quality" = "quality")

    fixedNamesX <- switch(input$selectX,
                         "Fixed acidity" = "fixed.acidity",
                         "Volatile acidity" = "volatile.acidity",
                         "Citric acid" = "citric.acid",
                         "Residual sugar" = "residual.sugar",
                         "Chlorides" = "chlorides",
                         "Free sulfur dioxide" = "free.sulfur.dioxide",
                         "Total sulfur dioxide" = "total.sulfur.dioxide",
                         "Density" = "density",
                         "pH" = "pH",
                         "Sulphates" = "sulphates",
                         "Alcohol" = "alcohol",
                         "Quality" = "quality")

    normalPlot <- ggplot(WhiteWines, aes(x = selectX, color = quality,  y = selectY)) +
      scale_color_gradientn(colours = wes_palette("Zissou1", 100, type = "continuous"))+
      labs(x=input$selectX, y=input$selectY)+
      coord_cartesian(xlim = ranges$x, ylim = ranges$y)

    radioSwitchPlot <- switch(input$radioPlot,
                              "Normal plot" = normalPlot,
                              "Plot for each Quality" = normalPlot + facet_grid(rows = vars(quality))
    )

    if(input$checkboxTheme == TRUE){
      radioSwitchPlot <- radioSwitchPlot + theme_dark()
    }

    radioSwitchPlot <- switch(input$radioPlotStyle,
                              "Jiter" = radioSwitchPlot + geom_jitter(height = min(selectX)*0.05, width = min(selectX)*0.05) + stat_smooth_func_with_pval(geom="text",method="lm",hjust=0,parse=TRUE) + geom_smooth(method = "lm", se = FALSE),
                              "Point" = radioSwitchPlot + geom_point() + stat_smooth_func_with_pval(geom="text",method="lm",hjust=0,parse=TRUE) + geom_smooth(method = "lm", se = FALSE),
                              "Smooth" = radioSwitchPlot + geom_smooth(),
                              "Column" = radioSwitchPlot + geom_col(),
                              "Violin" = radioSwitchPlot + geom_violin(scale = "area", aes(group = WhiteWines$quality)),
                              "Boxplot" = radioSwitchPlot + geom_boxplot(aes(group = WhiteWines$quality)))

   radioSwitchPlot

  })

  output$redPlot <- renderPlot({

    selectY <- switch(input$selectY,
                      "Fixed acidity" = RedWines$fixed.acidity,
                      "Volatile acidity" = RedWines$volatile.acidity,
                      "Citric acid" = RedWines$citric.acid,
                      "Residual sugar" = RedWines$residual.sugar,
                      "Chlorides" = RedWines$chlorides,
                      "Free sulfur dioxide" = RedWines$free.sulfur.dioxide,
                      "Total sulfur dioxide" = RedWines$total.sulfur.dioxide,
                      "Density" = RedWines$density,
                      "pH" = RedWines$pH,
                      "Sulphates" = RedWines$sulphates,
                      "Alcohol" = RedWines$alcohol,
                      "Quality" = RedWines$quality)

    selectX <- switch(input$selectX,
                      "Fixed acidity" = RedWines$fixed.acidity,
                      "Volatile acidity" = RedWines$volatile.acidity,
                      "Citric acid" = RedWines$citric.acid,
                      "Residual sugar" = RedWines$residual.sugar,
                      "Chlorides" = RedWines$chlorides,
                      "Free sulfur dioxide" = RedWines$free.sulfur.dioxide,
                      "Total sulfur dioxide" = RedWines$total.sulfur.dioxide,
                      "Density" = RedWines$density,
                      "pH" = RedWines$pH,
                      "Sulphates" = RedWines$sulphates,
                      "Alcohol" = RedWines$alcohol,
                      "Quality" = RedWines$quality)

    fixedNamesY <- switch(input$selectY,
                          "Fixed acidity" = "fixed.acidity",
                          "Volatile acidity" = "volatile.acidity",
                          "Citric acid" = "citric.acid",
                          "Residual sugar" = "residual.sugar",
                          "Chlorides" = "chlorides",
                          "Free sulfur dioxide" = "free.sulfur.dioxide",
                          "Total sulfur dioxide" = "total.sulfur.dioxide",
                          "Density" = "density",
                          "pH" = "pH",
                          "Sulphates" = "sulphates",
                          "Alcohol" = "alcohol",
                          "Quality" = "quality")

    fixedNamesX <- switch(input$selectX,
                          "Fixed acidity" = "fixed.acidity",
                          "Volatile acidity" = "volatile.acidity",
                          "Citric acid" = "citric.acid",
                          "Residual sugar" = "residual.sugar",
                          "Chlorides" = "chlorides",
                          "Free sulfur dioxide" = "free.sulfur.dioxide",
                          "Total sulfur dioxide" = "total.sulfur.dioxide",
                          "Density" = "density",
                          "pH" = "pH",
                          "Sulphates" = "sulphates",
                          "Alcohol" = "alcohol",
                          "Quality" = "quality")

    normalPlot <- ggplot(RedWines, aes(x = selectX, color = quality,  y = selectY)) +
      scale_color_gradientn(colours = wes_palette("Zissou1", 100, type = "continuous"))+
      labs(x=input$selectX, y=input$selectY)+
      coord_cartesian(xlim = ranges$x, ylim = ranges$y)

    radioSwitchPlot <- switch(input$radioPlot,
                              "Normal plot" = normalPlot,
                              "Plot for each Quality" = normalPlot + facet_grid(rows = vars(quality))
    )

    if(input$checkboxTheme == TRUE){
      radioSwitchPlot <- radioSwitchPlot + theme_dark()
    }

    radioSwitchPlot <- switch(input$radioPlotStyle,
                              "Jiter" = radioSwitchPlot + geom_jitter(height = min(selectX)*0.05, width = min(selectX)*0.05) + stat_smooth_func_with_pval(geom="text",method="lm",hjust=0,parse=TRUE) + geom_smooth(method = "lm", se = FALSE),
                              "Point" = radioSwitchPlot + geom_point() + stat_smooth_func_with_pval(geom="text",method="lm",hjust=0,parse=TRUE) + geom_smooth(method = "lm", se = FALSE),
                              "Smooth" = radioSwitchPlot + geom_smooth(),
                              "Column" = radioSwitchPlot + geom_col(),
                              "Violin" = radioSwitchPlot + geom_violin(scale = "area", aes(group = RedWines$quality)),
                              "Boxplot" = radioSwitchPlot + geom_boxplot(aes(group = RedWines$quality)))

    radioSwitchPlot

  })

  output$colWhitePlot <- renderPlot({

    cormat <- round(cor(WhiteWines),2)
    cormat <- reorder_cormat(cormat)
    upper_tri <- get_upper_tri(cormat)
    melted_cormat <- melt(upper_tri, na.rm = TRUE)
    ggheatmap <- ggplot(melted_cormat, aes(Var2, Var1, fill = value)) +
      geom_tile(color = "white") +
      scale_fill_gradientn(colours = wes_palette("Zissou1", 100, type = "continuous"), limit = c(-1,1), space = "Lab",
                           name="Pearson\nCorrelation") +
      theme_minimal() +
      geom_text(aes(Var2, Var1, label = value), color = "black", size = 4) +
      theme(
        axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.25),
        axis.title.x = element_blank(),
        axis.title.y = element_blank(),
        panel.grid.major = element_blank(),
        panel.border = element_blank(),
        panel.background = element_blank(),
        axis.ticks = element_blank(),
        legend.justification = c(1, 0),
        legend.position = c(0.6, 0.7),
        legend.direction = "horizontal") +
      guides(fill = guide_colorbar(barwidth = 7, barheight = 1,
                                   title.position = "top", title.hjust = 0.5)) +
      coord_fixed()

    print(ggheatmap)
  })

  output$colRedPlot <- renderPlot({

    cormat <- round(cor(RedWines),2)
    cormat <- reorder_cormat(cormat)
    upper_tri <- get_upper_tri(cormat)
    melted_cormat <- melt(upper_tri, na.rm = TRUE)

    ggheatmap <- ggplot(melted_cormat, aes(Var2, Var1, fill = value)) +
      geom_tile(color = "white") +
      scale_fill_gradientn(colours = wes_palette("Zissou1", 100, type = "continuous"), limit = c(-1,1), space = "Lab",
                           name="Pearson\nCorrelation") +
      theme_minimal() +
      geom_text(aes(Var2, Var1, label = value), color = "black", size = 4) +
      theme(
        axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.25),
        axis.title.x = element_blank(),
        axis.title.y = element_blank(),
        panel.grid.major = element_blank(),
        panel.border = element_blank(),
        panel.background = element_blank(),
        axis.ticks = element_blank(),
        legend.justification = c(1, 0),
        legend.position = c(0.6, 0.7),
        legend.direction = "horizontal") +
      guides(fill = guide_colorbar(barwidth = 7, barheight = 1,
                                   title.position = "top", title.hjust = 0.5)) +
      coord_fixed()

    print(ggheatmap)
  })

}

shinyApp(ui = ui, server = server)


library(tidyverse)
library(data.table)

setwd("~/Public_Policy/Projects/COVID-19")
nordics = c('Japan', 'South Korea', 'Italy', 'Germany', 'United States', 'Sweden')

oxford_stringency_index = read.csv("https://raw.githubusercontent.com/OxCGRT/covid-policy-tracker/master/data/OxCGRT_latest.csv") %>%
  rename(
    country = CountryName
  ) %>%
  mutate(
    entity_name = ifelse(is.na(RegionName) | RegionName == "", country, RegionName),
    stringency_geo_type = ifelse(entity_name == country, 'country', 'region'),
    date = as.Date(Date %>% as.character(), format = '%Y%m%d')
  )
View(oxford_stringency_index)

country_stringency = filter(oxford_stringency_index, stringency_geo_type == 'country')

#### read in mobility data and join everything else on ####
mobility_dataset_df = tibble(
  dsn = list.files('data', pattern = 'applemobilitytrends', full.names = T),
  date = str_extract(dsn, '[0-9]{4}-[0-9]{2}-[0-9]{2}') %>% as.Date()
) %>%
  arrange(date) %>%
  tail(1)

apple_mobility_dat = read_csv(mobility_dataset_df$dsn) %>%
  pivot_longer(cols = matches('^([0-9+]{4})'), names_to = 'date') %>%
  mutate(
    date = as.Date(date),
    week_day = lubridate::wday(date),
    weekend_ind = ifelse(week_day %in% c(7, 1), 'Weekend', "Week Day"),
    entity_name = recode(region,
                         `UK` = 'United Kingdom',
                         `San Francisco - Bay Area` = 'San Francisco',
                         `Republic of Korea` = 'South Korea')
  ) %>%
  left_join(
    country_stringency, by = c('entity_name', 'date')
  ) %>%
  mutate(
    entity_name = recode(entity_name, `Korea, South` = 'South Korea')
  )

nordic_countries_walking = filter(apple_mobility_dat, geo_type == 'country/region',
                                  entity_name %in% nordics, transportation_type == 'walking')
names(nordic_countries_walking)
# install.packages('plotly')
ggplot(nordic_countries_walking, aes(date, GovernmentResponseIndex, colour = entity_name)) +
  geom_step(size = 1) +
  geom_point(aes(size = ConfirmedDeaths))

View(nordic_countries_walking)

group_by(apple_mobility_dat, geo_type, entity_name, transportation_type) %>%
  summarize(
    mean_val = mean(value, na.rm = T),
    mean_stringency = mean(StringencyIndex, na.rm = T)
  ) %>%
  filter(!is.na(mean_stringency))

#


require(pROC)
require(ggplot2)
require(cowplot)

# given a list of roc objects generated by run.cv.datasets(), plots them in a grid
# cols = named vector of colors, names must match roc object vars exactly
# legend.text = readable names of roc comparisons
plot.rocs <- function(roc.list, rown, coln, cols, legend.text, outputfn="roc.pdf")
{
    cols_trans <- alpha(cols, .5)
    names(cols_trans) <- names(cols)

    pdf(outputfn, width=8, height=11.5)
    par(mfrow=c(rown, coln))

    for(i in 1:length(roc.list))
    {
        this.task <- roc.list[[i]]
        par(pty="s")

        # start with empty plot first names(roc.list)[i]
        plot(this.task[[1]]$ROC, type="n", main=i, legacy.axis=T, xlab="", ylab="", cex.main=2)
        for(j in 1:length(this.task))
        {
             plot(this.task[[j]]$ROC, legacy.axis=T, add=T, col=cols_trans[names(this.task)[j]], lwd=6-j)
        }

        aucs <- unlist(lapply(this.task, '[[', 'AUC'))

        legend("bottomright", legend=aucs, text.col = cols[names(aucs)], bty="n", pt.cex = 1, cex=1.25, y.intersp=.7)
    }
    dev.off()

    # plot legend only
    pdf(paste0("legend1.", outputfn), width=8, height=11.5)
    plot(1, axes=FALSE, xlab="", ylab="", type="n")
    legend("topleft", legend=legend.text, text.col = cols, bty="n", pt.cex=1, cex = 1.65)
    dev.off()

    # plot titles separately
    pdf(paste0("legend2.", outputfn), width=8, height=11.5)
    plot(1, axes=FALSE, xlab="", ylab="", type="n")
    legend("center", legend=paste(1:length(roc.list),names(roc.list), sep=": "), bty="n", pt.cex = 1, cex=1.5)
    dev.off()

}


#Accuracy
data <- read.csv("ReduceVariableAccuracy.csv",header = TRUE)
#recall
plot(x = data$Reduce.Feature, y = data$Recall, xlab = "Reducing variable number",
     ylab = "Model performance", type = "b", ylim =c(0.65,0.9), pch = 17)
#precision
lines(x = data$Reduce.Feature, y = data$Precision, type = "b", pch = 16)
#f-measure
lines(x = data$Reduce.Feature, y = data$F.measure, type = "b", pch = 7)

#Gini
data <- read.csv("ReduceVariableGini.csv",header = TRUE)
#recall
plot(x = data$Reduce.Feature, y = data$Recall, xlab = "Reducing variable number",
     ylab = "Model performance", type = "b", ylim =c(0.65,0.9), pch = 17)
#precision
lines(x = data$Reduce.Feature, y = data$Precision, type = "b", pch = 16)
#f-measure
lines(x = data$Reduce.Feature, y = data$F.measure, type = "b", pch = 7)


data<-read.csv("F:/Thesis/New/Data/GSE6919_GPL92/GSE6919_GPL92_PCAData.csv",row.names = 1)
data2<-read.csv("F:/Thesis/New/Data/GSE6919_GPL92/GSE6919_GPL92_SelectedFeatures.csv",row.names = 1)
data2<-t(data2)
#library(mlbench)
library(caret)

# define the control using a random forest selection function
control <- rfeControl(functions=rfFuncs, method="cv", number=10)
# run the RFE algorithm
system.time(results <- rfe(data[,1:168], as.factor(data[,169]), sizes=c(1:5), rfeControl=control))
# summarize the results
print(results)
# list the chosen features
rfeRanked = predictors(results)
# plot the results
#plot(results, type=c("g", "o"))


#script to generate the histogram of length for loop and stem of the motifs in Fig. 2E

args <- commandArgs(trailingOnly = TRUE)
library(ggplot2)
library(extrafont)
library(reshape2)
filehtselex=args[1]
#filehtselex="motif_SL_length.tsv"
outprefix="SL-length_dist"
tstring=gsub(" .*$","",Sys.time(),perl=TRUE)
outname=paste(outprefix,tstring,".pdf",sep="")
rhtselex=read.table(filehtselex,sep="\t")
colnames(rhtselex)=c("motif","Stem","Loop")
nrhtselex=melt(rhtselex)
colnames(nrhtselex)=c("motif","tag","Length")

  ggplot(nrhtselex,aes(Length,fill=tag))+geom_histogram(alpha=0.5,stat="bin",binwidth=1,position="identity",linetype=0)+scale_fill_brewer(palette="Pastel1",direction = -1)+scale_y_continuous("Counts")+ggtitle("Length distribution of stem and loop")+
  theme(legend.position=c(0.8,0.9),legend.direction = "vertical",legend.title=element_blank(),panel.background=element_blank(),axis.line.y=element_line(size=1,colour="grey",linetype="solid"),axis.line.x=element_line(size=1,colour="grey",linetype="solid"),axis.text=element_text(size=12),axis.title=element_text(size=14),legend.text=element_text(size=12),legend.background=element_blank(),title=element_text(size=14),plot.title=element_text(hjust=0.5),text=element_text(family = "Arial Narrow"))
ggsave(filename = outname,plot = p,units = "cm",width = 10,height = 10)
#dev.off()


###### knn algorithm
#setwd("F:/Stevens/CS 513 - Knowledge Discovery & Data Mining/Project/Flight Delay Prediction/")

######
###### 2013, 2014 and 2015
######
rm(list = ls());

# reading test dataset
test_dataset_13_14_15 <- read.csv("Datasets/Test_Dataset_NY_June_2013_2014_2015.csv");
View(test_dataset_13_14_15);

# reading train dataset
train_dataset_13_14_15 <- read.csv("Datasets/Train_Dataset_NY_June_2013_2014_2015.csv");
View(train_dataset_13_14_15);

# preparing datasets for knn
test_set <- test_dataset_13_14_15[, -2];
train_set <- train_dataset_13_14_15[, -2];
classified_set <- train_dataset_13_14_15[, 2];

### knn
# output for k = 1
output_k1 <- knn(train_set, test_set, classified_set, k=1);
prediction_k1 <- table(output_k1, test_set[, 2])

# output for k = 2
output_k2 <- knn(train_set, test_set, classified_set, k=2);
prediction_k2 <- table(output_k2, test_set[, 2]);

# output for k = 5
output_k5 <- knn(train_set, test_set, classified_set, k=5);
prediction_k5 <- table(output_k5, test_set[, 2]);

# output for k = 10
output_k10 <- knn(train_set, test_set, classified_set, k=10);
prediction_k10 <- table(output_k10, test_set[, 2]);

# output for k = 15
output_k15 <- knn(train_set, test_set, classified_set, k=15);
prediction_k15 <- table(output_k15, test_set[, 2]);

# output for k = 20
output_k20 <- knn(train_set, test_set, classified_set, k=20);
prediction_k20 <- table(output_k20, test_set[, 2]);

# output for k = 25
output_k25 <- knn(train_set, test_set, classified_set, k=25);
prediction_k25 <- table(output_k25, test_set[, 2])

### predictions
prediction_k1
prediction_k2
prediction_k5
prediction_k10
prediction_k15
prediction_k20
prediction_k25

######
###### 2016
######

# reading test dataset
test_dataset_16 <- read.csv("Datasets/Test_Dataset_NY_June_2016.csv");
View(test_dataset_16);

# reading train dataset
train_dataset_16 <- read.csv("Datasets/Train_Dataset_NY_June_2016.csv");
View(train_dataset_16);

# preparing datasets for knn
test_set_16 <- test_dataset_16[, -2];
train_set_16 <- train_dataset_16[, -2];
classified_set_16 <- train_dataset_16[, 2];

### knn
# output for k = 1
output_16_k1 <- knn(train_set_16, test_set_16, classified_set_16, k=1);
prediction_16_k1 <- table(output_16_k1, test_set_16[, 2])

# output for k = 2
output_16_k2 <- knn(train_set_16, test_set_16, classified_set_16, k=2);
prediction_16_k2 <- table(output_16_k2, test_set_16[, 2])

# output for k = 5
output_16_k5 <- knn(train_set_16, test_set_16, classified_set_16, k=5);
prediction_16_k5 <- table(output_16_k5, test_set_16[, 2])

# output for k = 10
output_16_k10 <- knn(train_set_16, test_set_16, classified_set_16, k=10);
prediction_16_k10 <- table(output_16_k10, test_set_16[, 2])

# output for k = 15
output_16_k15 <- knn(train_set_16, test_set_16, classified_set_16, k=15);
prediction_16_k15 <- table(output_16_k15, test_set_16[, 2])

# output for k = 20
output_16_k20 <- knn(train_set_16, test_set_16, classified_set_16, k=20);
prediction_16_k20 <- table(output_16_k20, test_set_16[, 2])

# output for k = 25
output_16_k25 <- knn(train_set_16, test_set_16, classified_set_16, k=25);
prediction_16_k25 <- table(output_16_k25, test_set_16[, 2])

### predictions
prediction_16_k1
prediction_16_k2
prediction_16_k5
prediction_16_k10
prediction_16_k15
prediction_16_k20
prediction_16_k25

CS 513 - Knowledge Discovery & Data Mining/Project/R/8_knn.r


#' Subset variables in data frame
#'
#' Get subset of variables in data frame based on type, regexp pattern and specified exclusions.
#'
#' @param df Data frame to be used
#' @param type One of "numeric", "factor", "character" or any combination as vector
#' @param pattern Regexp pattern used to filter variables
#' @param exclude List of variables to be excluded
#' @export
#' @examples
#' # All variable starting with cred
#' varlist(german_data,pattern="^cred")
#'
#' # All numeric variable
#' varlist(german_data,type="numeric")
#'
#' # All factor variable except variable gb and variables starting with c
#' varlist(german_data,type="factor",exclude=c("gb",varlist(german_data,pattern="^c")))
#'
#' # Same as previous, only using pattern instead of c()
#' varlist(german_data,type="factor",exclude=varlist(german_data,pattern="^c|gb"))
#'
#' # Everything but factors
#' varlist(german_data,exclude=varlist(german_data,"factor"))
#'
#' # Use sapply to apply function for variables
#' sapply(german_data[,varlist(german_data,type="numeric",pattern="credit")], summary)
#' sapply(german_data[,varlist(german_data,type="numeric",pattern="credit")],
#'    function (x) length(unique(x)))

varlist <- function (df=NULL,type=c("numeric","factor","character"), pattern="", exclude=NULL) {

  vars <- character(0)

  if (any(type %in% "numeric")) {
    vars <- c(vars,names(df)[sapply(df,is.numeric)])
  }
  if (any(type %in% "factor")) {
    vars <- c(vars,names(df)[sapply(df,is.factor)])
  }
  if (any(type %in% "character")) {
    vars <- c(vars,names(df)[sapply(df,is.character)])
  }

  vars[(!vars %in% exclude) & grepl(vars,pattern=pattern)]
}


# Test for gwloggeR detect_drift() with KNMI as reference.

logger.names <- tools::file_path_sans_ext(grep('barometer/', gwloggeR.data::enumerate(), value = TRUE))
#logger.names <- 'BAOL079X_177936.csv' # all timestamps are NA
#logger.names <- 'BAOL528X_B_B2152.csv' # has less than 5 matching observations with KNMI data
#logger.names <- 'BAOL544X_B_002A6.csv' # has NA values in x

df.ref <- gwloggeR.data::read('KNMI_20201103_hourly_Westdorpe')$df

ref <- list(list(x = df.ref[!is.na(PRESSURE_VALUE), PRESSURE_VALUE], timestamps = df.ref[!is.na(PRESSURE_VALUE), TIMESTAMP_UTC]))

save.output <- function(f) {

  print(Sys.time())
  print(basename(f))

  ROOT.PATH <- './drifts/analysis_32/'

  df <- gwloggeR.data::read(f)$df
  df <- df[!is.na(TIMESTAMP_UTC),]
  df <- df[!is.na(PRESSURE_VALUE),]
  data.table::setkey(df, TIMESTAMP_UTC)

  if (nrow(df) == 0L) {
    print('Skipping...')
    return()
  }

  gwloggeR:::test.detect_function(
    fun = gwloggeR::detect_drift,
    x = df$PRESSURE_VALUE,
    timestamps = df$TIMESTAMP_UTC,
    reference = ref,
    apriori = gwloggeR::Apriori(data_type = 'air pressure', units = 'cmH2O'),
    verbose = TRUE,
    plot = TRUE,
    title = paste0(basename(f), ' - v0.01'),
    alpha = 1,
    RESULT.PATH = paste0(ROOT.PATH, basename(f), '.result'),
    ATTRIB.PATH = paste0(ROOT.PATH, basename(f), '.attribs'),
    IMG.PATH = paste0(ROOT.PATH, basename(f), '.png'),
    LOG.PATH = paste0(ROOT.PATH, basename(f), '.log')
  )

}

# parallel::setDefaultCluster(parallel::makeCluster(spec = 5L))
# parallel::clusterExport(varlist = c('ref'))
# results <- setNames(parallel::clusterApplyLB(x = logger.names, fun = save.output), logger.names)
# names(results) <- logger.names
# parallel::stopCluster(cl = parallel::getDefaultCluster())

results <- sapply(logger.names, save.output, USE.NAMES = TRUE, simplify = FALSE)

results.df <- data.table::rbindlist(lapply(names(results), function(ln) {
  c(list('name' = basename(ln)),
    attributes(results[[ln]])[c('mu', 'sigma', 'timestamp', 'rate', 'significance')])
}), use.names = TRUE, fill = TRUE)

write.csv(results.df, file = './drifts/analysis_32/results.csv', row.names = FALSE)

plot(x = results.df$significance, y = results.df$rate,
     ylim = quantile(results.df$rate, probs = c(0.025, 0.975), na.rm = TRUE))

plot(x = results.df$significance, y = results.df$rate,
     ylim = quantile(results.df$rate, probs = c(0.025, 0.975), na.rm = TRUE),
     xlim = c(0, 1/1000))

hist(results.df$significance, breaks = 100)
hist(results.df$significance[results.df$significance < 0.05], breaks = 100)
quantile(results.df$significance, probs = c(0.05, 0.1, 0.2, 0.5), na.rm = TRUE)
plot(ecdf(results.df$significance))


###############################################################################
#  Copyright (C) 1994 - 2009, Performance Dynamics Company                    #
#                                                                             #
#  This software is licensed as described in the file COPYING, which          #
#  you should have received as part of this distribution. The terms           #
#  are also available at http://www.perfdynamics.com/Tools/copyright.html.    #
#                                                                             #
#  You may opt to use, copy, modify, merge, publish, distribute and/or sell   #
#  copies of the Software, and permit persons to whom the Software is         #
#  furnished to do so, under the terms of the COPYING file.                   #
#                                                                             #
#  This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY  #
#  KIND, either express or implied.                                           #
###############################################################################

library(pdq)

arrivRate    = 0.75
service_time = 1.0

#---- Initialize --------------------------------------------------------------

Init("OpenCircuit")
SetComment("A simple M/M/1 queue")

#---- Define the queueing center ----------------------------------------------

CreateNode("server", CEN, FCFS)

#---- Define the workload and circuit type ------------------------------------

CreateOpen("work", arrivRate)

SetWUnit("Customers")
SetTUnit("Seconds")

#---- Define service demand due to workload on the queueing center ------------

SetDemand("server", "work", service_time)

#---- Solve the model ---------------------------------------------------------
#  Must use the CANONical method for an open circuit

Solve(CANON)

#---- Generate a report -------------------------------------------------------

Report()


# load packages ----
library(dplyr)
library(gdistance)
library(ggplot2)
library(here)
library(purrr)
library(raster)
library(readr)
library(sf)
library(sp)
library(tibble)
library(tidyr)

#### GOAL - Create shortest distance between Acoustic Telemetry Receivers -----

# bring in shapefile ----
# replace sissabagma_lake with your shapefile
# I choose Big Siss as an example as this is the lake I grew up fishing on
# back in Wisco
lake <- st_read(dsn = here("Data",
                           "shapefile",
                           "."),
                layer = "sissabagama_lake")

# create spatialploygondataframe
lake_spd <- as_Spatial(lake)

# bring in rec location sf ----
# replace EXAMPLE with your receiver locations as RDS or csv whatever you use

rl_sum_sf <- read_rds(here("Data",
                           "receiver locations",
                           "rl_sum_sf.rds"))
# change rec_group to factor
rl_sum_sf <- rl_sum_sf %>%
  mutate(rec_group = factor(rec_group,
                            levels = c("Head",
                                       "Neck",
                                       "Body",
                                       "Arm",
                                       "Legs")))
# create spatialpointsdataframe
rl_sum_spd <- as_Spatial(rl_sum_sf)

# rasterize shapefile  -----
# transform spatialpolygonsdataframe into UTMS
# You will need to replace zone with the correct UTM ZONE
r <- spTransform(lake_spd, CRS("+proj=utm +zone=15 +ellps=WGS84 +datum=WGS84 +units=m +no_defs"))

# plot them
plot(r)
plot(lake_spd)

# determine the extent of the spatialpoloygonsdataframe
ext <- extent(r)

# create raster and change the resolution to 5 m
# Depending on the system this can be adjusted to whatever resolution you desire
# if in a large system res could be less fine scaled
s <- raster(r, res = 5)

# remove and change NA values to fit within the extent
s <- rasterize(x = r, y = s, field = 1)

# plot raster to make sure it looks appropriate
plot(s)

# create transition layer with directions being queens space
# if in larger systems direction could be reduced from queens space to
# rook or king, 4 or 8
trans <- transition(x = s, transitionFunction = mean, directions = 16)

# transform rec points to utms -----
# You will need to replace zone with the correct UTM ZONE
# need to arrange receiver name as factor for metadata based on the same order of
# lon. Do the same with receiver groupings
rec_sum <- spTransform(rl_sum_spd, CRS("+proj=utm +zone=15 +ellps=WGS84 +datum=WGS84 +units=m +no_defs")) %>%
  as_tibble() %>%
  rename(lon = coords.x1,
         lat = coords.x2) %>%
  arrange(lon) %>%
  mutate(rec_name = factor(rec_name,
                           levels = c("2", "1", "11", "3",
                                      "4", "10", "5", "9",
                                      "8", "12", "6", "7",
                                      "13", "14", "15")))

# create a to and from list using rec group names
from_to <- rec_sum %>%
  arrange(lon) %>%
  mutate(from = rec_name,
         to = rec_name) %>%
  expand(from, to) %>%
  mutate(from_to = paste0(from, "-", to)) %>%
  rownames_to_column("id") %>%
  mutate(id = as.numeric(id))

# create rec lat and long compare tibble -----
rec_compare <- rec_sum %>%
  mutate(llon = lon,
         llat = lat,
         lonlat = paste0(lon, ",", lat),
         llonllat = paste0(llon, ",", llat)) %>%
  dplyr::select(-lon, -lat, -llon, -llat) %>%
  expand(lonlat, llonllat) %>%
  separate(lonlat, c("lon", "lat"), ",") %>%
  separate(llonllat, c("llon", "llat"), ",") %>%
  rownames_to_column("id") %>%
  mutate_if(is.character, function(x) as.numeric(x))

# create a subset to test map function -----
# rec_5 <- rec_compare %>%
#   filter(id < 5)

# calculate the distance between every receiver and create  sf object -----
rec_dist_sf <- rec_compare %>%
  split(.$id) %>%
  map(possibly(~ shortestPath(trans,
                              c(.$llon, .$llat),
                              c(.$lon, .$lat),
                              output = "SpatialLines"), NA)) %>%
  map(possibly(~ st_as_sf(., crs = 32615), NA)) %>% # u will need to replace CRS
  bind_rows() %>%
  mutate(id = c(1:nrow(.)),
         cost_dist = as.numeric(st_length(.)))# st_length determines path length

# add in the additional columns to know where the linestrings are going to

rec_dist_sf <- rec_dist_sf %>%
  mutate(from = from_to$from,
         to = from_to$to,
         from_to = from_to$from_to,
         from_lon = rec_compare$lon,
         from_lat = rec_compare$lat,
         to_lon = rec_compare$llon,
         to_lat = rec_compare$llat,) %>%
  dplyr::select(id, from:to_lat, cost_dist, geometry)

rec_dist_sf

# covert sf objects from Lat Long to UTM ----
# You will need to replace zone with the correct UTM ZONE
lake_utm <- st_transform(lake, crs = 32615)
rl_sum_utm <- st_transform(rl_sum_sf, crs = 32615)

# plot -----
ggplot() +
  geom_sf(data = lake_utm) +
  geom_sf(data = rec_dist_sf, aes(colour = cost_dist), size = 1) +
  geom_sf(data = rl_sum_utm, size = 4) +
  scale_colour_viridis_c(name = "Cost Distance (m)", option = "B") +
  theme_bw() +
  theme(panel.grid = element_blank()) +
  labs(x = "Longitude",
       y = "Latitude")


pdf("output.GC_plot.pdf")
gc=rep(c(60.78,41.18,47.06,56.86,29.41,27.45,37.25,78.43,58.82,50.98,49.02,62.75,68.63,54.90,52.94,35.29,43.14,39.22),times=c(3,3,5,7,1,2,2,1,1,3,2,1,1,1,3,1,2,1))
hist(gc,probability=T,breaks=100,xlab="GC content (%)",ylab="Density of Reads",border="blue",main="")
dev.off()


#' Random diffnet network
#'
#' Simulates a diffusion network by creating a random dynamic network and
#' adoption threshold levels.
#'
#' @param n Integer scalar. Number of vertices.
#' @param t Integer scalar. Time length.
#' @param seed.nodes Either a character scalar or a vector. Type of seed nodes (see details).
#' @param seed.p.adopt Numeric scalar. Proportion of early adopters.
#' @param seed.graph Baseline graph used for the simulation (see details).
#' @param rgraph.args List. Arguments to be passed to rgraph.
#' @param rewire Logical scalar. When TRUE, network slices are generated by rewiring
#' (see \code{\link{rewire_graph}}).
#' @param rewire.args List. Arguments to be passed to \code{\link{rewire_graph}}.
#' @param threshold.dist Either a function to be applied via \code{\link{sapply}},
#' a numeric scalar, or a vector/matrix with \eqn{n} elements. Sets the adoption
#' threshold for each node.
#' @param exposure.args List. Arguments to be passed to \code{\link{exposure}}.
#' @param name Character scalar. Passed to \code{\link{as_diffnet}}.
#' @param behavior Character scalar. Passed to \code{\link{as_diffnet}}.
#' @param stop.no.diff Logical scalar. When \code{TRUE}, the function will return
#' with error if there was no diffusion. Otherwise it throws a warning.
#' @return A random \code{\link{diffnet}} class object.
#' @family simulation functions
#' @details
#'
#' Instead of randomizing whether an individual adopts the innovation or not, this
#' toy model randomizes threshold levels, seed adopters and network structure, so
#' an individual adopts the innovation in time \eqn{T} iff his exposure is above or
#' equal to his threshold. The simulation is done in the following steps:
#'
#' \enumerate{
#'  \item Using \code{seed.graph}, a baseline graph is created.
#'  \item Given the baseline graph, the set of initial adopters is defined
#'  using \code{seed.nodes}.
#'  \item Afterwards, if \code{rewire=TRUE} \eqn{t-1} slices of the network are created
#'  by iteratively rewiring the baseline graph.
#'  \item The \code{threshold.dist} function is applied to each node in the graph.
#'  \item Simulation starts at \eqn{t=2} assigning adopters in each time period
#'  accordingly to each vertex's threshold and exposure.
#' }
#'
#' When \code{seed.nodes} is a character scalar it can be \code{"marginal"}, \code{"central"} or \code{"random"},
#' So each of these values sets the initial adopters using the vertices with lowest
#' degree, with highest degree or completely randomly. The number of early adoptes
#' is set as \code{seed.p.adopt * n}. Please note that when marginal nodes are
#' set as seed it may be the case that no diffusion process is attained as the
#' chosen set of first adopters can be isolated. Any other case will be considered
#' as an index (via \code{\link{[<-}} methods), hence the user can manually set the set of initial adopters, for example
#' if the user sets \code{seed.nodes=c(1, 4, 7)} then nodes 1, 4 and 7 will be
#' selected as initial adopters.
#'
#' The argument \code{seed.graph} can be either a function that generates a graph
#' (Any class of accepted graph format (see \code{\link{netdiffuseR-graphs}})), a
#' graph itself or a character scalar in which the user sets the algorithm used to
#' generate the first network (network in t=1), this can be either "scale-free"
#' (Barabasi-Albert model using the \code{\link{rgraph_ba}} function, the default),
#' \code{"bernoulli"} (Erdos-Renyi model using the \code{\link{rgraph_er}} function),
#' or \code{"small-world"} (Watts-Strogatz model using the \code{\link{rgraph_ws}}
#' function). The list \code{rgraph.args} passes arguments to the chosen algorithm.
#'
#' When \code{rewire=TRUE}, the networks that follow t=1 will be generated using the
#' \code{\link{rewire_graph}} function as \eqn{G(t) = R(G(t-1))}, where \eqn{R}
#' is the rewiring algorithm.
#'
#' If a function, the argument \code{threshold.dist} sets the threshold for each vertex in the graph.
#' It is applied using \code{sapply} as follows
#'
#' \preformatted{
#' sapply(1:n, threshold.dist)
#' }
#'
#' By default sets the threshold to be random for each node in the graph.
#'
#' If \code{seed.graph} is provided, no random graph is generated and the simulation
#' is applied using that graph instead.
#'
#' \code{rewire.args} has the following default options:
#'
#' \tabular{ll}{
#'   \code{p}          \tab \code{.1} \cr
#'   \code{undirected} \tab \code{getOption("diffnet.undirected", FALSE)} \cr
#'   \code{self}       \tab \code{getOption("diffnet.self", FALSE)}
#' }
#'
#' \code{exposure.args} has the following default options:
#'
#' \tabular{ll}{
#'   \code{outgoing} \tab \code{TRUE} \cr
#'   \code{valued} \tab \code{getOption("diffnet.valued", FALSE)} \cr
#'   \code{normalized} \tab \code{TRUE}
#' }
#'
#' @examples
#' # Asimple example -----------------------------------------------------------
#' set.seed(123)
#' z <- rdiffnet(100,10)
#' z
#' summary(z)
#'
#' # A more complex example: Adopt if at least one neighbor has adopted --------
#' y <- rdiffnet(100, 10, threshold.dist=function(x) 1,
#'     exposure.args=list(valued=FALSE, normalized=FALSE))
#'
#' # Re thinking the Adoption of Tetracycline ----------------------------------
#' newMI <- rdiffnet(seed.graph = medInnovationsDiffNet$graph,
#'  threshold.dist = threshold(medInnovationsDiffNet), rewire=FALSE)
#'
#'
#' @author George G. Vega Yon
#' @name rdiffnet
NULL

rdiffnet_make_threshold <- function(x, n) {

  # Using sapply to compute the threshold
  if (inherits(x, "function")) {

    thr <- sapply(1:n, x)

  } else if ((length(x)==1) && is.numeric(x)) {

    thr <- rep(x, n)

  } else {
    # Setting depending on class
    if (any(class(x) %in% c("data.frame", "matrix"))) {

      thr <- as.vector(as.matrix(x))

      # Must match the length of n
      if (length(thr) != n)
        stop("Incorrect length for -threshold.dist- (",length(x),")",
             ". It should be a vector of length ",n,".")

    } else if (is.vector(x)) {

      thr <- x

      # Must match the length of n
      if (length(thr) != n)
        stop("Incorrect length for -threshold.dist- (",length(x),")",
             ". It should be a vector of length ",n,".")

    } else {

      stop("-threshold.dist- must be either a numeric vector of length -n-, a numeric scalar, or a function.")

    }
  }

  thr
}

rdiffnet_check_seed_graph <- function(seed.graph, rgraph.args, t, n) {
  test <- class(seed.graph)

  if ("function" %in% test) {

    # Does it returns a graph
    test <- seed.graph()
    # Coercing into appropiate type
    if (inherits(test, "dgCMatrix")) {
      sgraph <- test
    } else if (inherits(test, "matrix")) {
      sgraph <- methods::as(test, "dgCMatrix")
    } else if (inherits(test, "array")) {
      sgraph <- apply(test, 3, function(x) methods::as(x, "dgCMatrix"))
    } else if (inherits(test, "diffnet")) {
      sgraph <- test$graph
    } else if (inherits(test, "list")) {

      sgraph <- test

    }

    # In the case of calling a function
  } else if ("character" %in% test) {

    # Scale-free networks ------------------------------------------------------
    if (seed.graph == "scale-free") {

      if (!length(rgraph.args$m0))
        rgraph.args$t <- n-1L

      sgraph <- do.call(rgraph_ba, rgraph.args)

      # Bernoulli graphs ---------------------------------------------------------
    } else if (seed.graph == "bernoulli") {

      rgraph.args$n <- n

      sgraph <- do.call(rgraph_er, rgraph.args)

      # Small-world network ------------------------------------------------------
    } else if (seed.graph == "small-world") {

      rgraph.args$n <- n
      if (!length(rgraph.args$k)) rgraph.args$k <- 2L
      if (!length(rgraph.args$p)) rgraph.args$p <- .1

      sgraph <- do.call(rgraph_ws, rgraph.args)

    } else
      stop("Invalid -seed.graph-. It should be either ",
           "'scale-free\', \'bernoulli\' or \'small-world\'.")

    # Creating t duplicates
    graph <- rep(list(sgraph), t)

  } else if (any(c("matrix", "dgCMatrix", "array") %in% test)) {

    # If not dgCMatrix
    if (("array" %in% test) & !("matrix" %in% test))
      sgraph <- apply(seed.graph, 3, function(x) methods::as(x, "dgCMatrix"))
    else
      sgraph <- methods::as(seed.graph, "dgCMatrix")

  } else if ("list" %in% test) {

    sgraph <- seed.graph

  } else if ("diffnet" %in% test) {

    sgraph <- seed.graph$graph

  } else
    stop("Invalid argument for -seed.graph-. No support for objects of class -",test,"-.")

  sgraph
}

#' @rdname rdiffnet
#' @export
#' @param R Integer scalar. Number of simulations to be done.
#' @param statistic A Function to be applied to each simulated diffusion network.
#' @param ... Further arguments to be passed to \code{rdiffnet}.
#' @param ncpus Integer scalar. Number of processors to be used (see details).
#' @param cl An object of class \code{\link[parallel:makeCluster]{c("SOCKcluster", "cluster")}}
#' (see details).
#' @details
#' The function \code{rdiffnet_multiple} is a wrapper of \code{rdiffnet} wich allows
#' simulating multiple diffusion networks with the same parameters and apply
#' the same function to all of them. This function is designed to allow the user
#' to perform larger simulation studies in which the distribution of a particular
#' statistic is observed.
#'
#' When \code{cl} is provided, then simulations are done via
#' \code{\link[parallel:parSapply]{parSapply}}. If \code{ncpus} is greater than
#' 1, then the function creates a cluster via \code{\link[parallel:makeCluster]{makeCluster}}
#' which is stopped (removed) once the process is complete.
#'
#' @return \code{rdiffnet_multiple} returns either a vector or an array depending
#' on what \code{statistic} is (see \code{\link{sapply}} and
#' \code{\link[parallel:parSapply]{parSapply}}).
#'
#' @examples
#' # Simulation study comparing the diffusion with diff sets of seed nodes -----
#'
#' # Random seed nodes
#' set.seed(1)
#' ans0 <- rdiffnet_multiple(R=50, statistic=function(x) sum(!is.na(x$toa)),
#'     n = 100, t = 4, seed.nodes = "random", stop.no.diff=FALSE)
#'
#' # Central seed nodes
#' set.seed(1)
#' ans1 <- rdiffnet_multiple(R=50, statistic=function(x) sum(!is.na(x$toa)),
#'     n = 100, t = 4, seed.nodes = "central", stop.no.diff=FALSE)
#'
#' boxplot(cbind(Random = ans0, Central = ans1), main="Number of adopters")
rdiffnet_multiple <- function(
  R,
  statistic,
  ...,
  ncpus = 1L,
  cl    = NULL
) {

  # Checking the type of answer that it returns

  # Calling parallel
  if ((ncpus > 1) | length(cl)) {

    # Creating the cluster
    if (!length(cl)) {
      cl <- parallel::makeCluster(ncpus)
      on.exit(parallel::stopCluster(cl))

      # Loading R packages
      parallel::clusterEvalQ(cl, library(netdiffuseR))
    }

    # Calling the function
    parallel::parSapply(cl, X=seq_len(R), function(i, statistic, ...) {
      statistic(netdiffuseR::rdiffnet(...))
    }, statistic = statistic, ...)

  } else {

    # If no parallel apply
    sapply(X=seq_len(R), function(i, statistic, ...) {
      statistic(netdiffuseR::rdiffnet(...))
    }, statistic = statistic, ...)
  }

}

#' @rdname rdiffnet
#' @export
rdiffnet <- function(
  n,
  t,
  seed.nodes     = "random",
  seed.p.adopt   = 0.05,
  seed.graph     = "scale-free",
  rgraph.args    = list(),
  rewire         = TRUE,
  rewire.args    = list(),
  threshold.dist = runif(n),
  exposure.args  = list(),
  name           = "A diffusion network",
  behavior       = "Random contagion",
  stop.no.diff   = TRUE
  ) {

  # Checking options
  if (!length(rewire.args[["p"]])) rewire.args[["p"]] <- .1
  if (!length(rewire.args[["undirected"]])) rewire.args[["undirected"]] <- getOption("diffnet.undirected", FALSE)
  if (!length(rewire.args[["self"]])) rewire.args[["self"]] <- getOption("diffnet.self", FALSE)

  if (!length(exposure.args[["outgoing"]])) exposure.args[["outgoing"]] <- TRUE
  if (!length(exposure.args[["valued"]])) exposure.args[["valued"]] <- getOption("diffnet.valued", FALSE)
  if (!length(exposure.args[["normalized"]])) exposure.args[["normalized"]] <- TRUE

  # Step 0.0: Creating the network seed ----------------------------------------
  # Checking the class of the seed.graph
  sgraph <- rdiffnet_check_seed_graph(seed.graph, rgraph.args, t, n)

  # Checking baseline graph --------------------------------------------------
  meta <- classify_graph(sgraph)

  # Was n set?
  if (!missing(n) && n != meta$n) {
    warning("While the user set n=",n,", nnodes(seed.graph)=", meta$n,". The later will be used.")
    n <- meta$n
  }
  if (missing(n)) n <- meta$n

  # If static, t must be provided, otherwise t should be missing
  if (meta$nper == 1) {

    if (missing(t))
      stop("When -seed.graph- is static, -t- must be provided.")
    else
      sgraph <- rep(list(sgraph), t)

  } else {

    if (!missing(t))
      warning("When -seed.graph- is dynamic, -t- shouldn't be provided.")

    t <- meta$nper

  }

  # Step 0.1: Rewiring or not ------------------------------------------------

  # Rewiring
  if (rewire)
    sgraph <- do.call(rewire_graph, c(list(graph=sgraph), rewire.args))

  sgraph <- lapply(sgraph, `attr<-`, which="undirected", value=NULL)

  # Number of initial adopters
  if ((seed.p.adopt > 1) | (seed.p.adopt < 0)) {
    stop("The proportion of initial adopters should be a number in [0,1]")
  }
  if (n*seed.p.adopt < 1)
    warning("Set of initial adopters set to 1.")

  n0 <- max(1, n*seed.p.adopt)

  # Step 0.1: Setting the seed nodes -------------------------------------------
  cumadopt <- matrix(0L, ncol=t, nrow=n)
  toa      <- matrix(NA, ncol=1, nrow= n)

  if (length(seed.nodes) == 1) {

    if (seed.nodes %in% c("central","marginal")) {

      # Creating a degree ranking
      d <- dgr(sgraph)[,1,drop=FALSE]
      decre <- ifelse(seed.nodes == "central", TRUE, FALSE)
      d <- rownames(d[order(d, decreasing = decre),,drop=FALSE])
      d <- d[1:floor(n0)]
      d <- as.numeric(d)

    } else if (seed.nodes == "random") {

      d <- sample.int(n, floor(n0))

    } else
      stop("Unsupported -seed.nodes- value. It must be either \"central\", \"marginal\", or \"random\"")

  } else if (!inherits(seed.nodes, "character")) {

    d <- seed.nodes

  } else
    stop("Unsupported -seed.nodes- value. See the manual for references.")

  # Setting seed nodes via vector
  toa[d]       <- 1L
  cumadopt[d,] <- 1L

  # Step 3.0: Thresholds -------------------------------------------------------
  thr <- rdiffnet_make_threshold(threshold.dist, n)

  # Running the simulation
  for (i in 2:t) {

    # Computing exposure
    exposure.args[c("graph", "cumadopt")] <- list(sgraph[i], cumadopt[,i,drop=FALSE])
    expo <- do.call(exposure, exposure.args)

    whoadopts <- which( (expo >= thr) & is.na(toa))
    toa[whoadopts] <- i
    cumadopt[whoadopts, i:t] <- 1L
  }
  reachedt <- max(toa, na.rm=TRUE)

  # Checking the result
  if (reachedt == 1) {
    if (stop.no.diff)
      stop("No diffusion in this network (Ups!) try changing the seed or the parameters.")
    else
      warning("No diffusion in this network.")
  }

  # Checking attributes
  isself <- any(sapply(sgraph, function(x) any(Matrix::diag(x) != 0) ))

  # Creating diffnet object
  new_diffnet(
    graph      = sgraph,
    toa        = as.integer(toa),
    self       = isself,
    t0         = 1,
    t1         = t,
    vertex.static.attrs = data.frame(real_threshold=thr),
    name       = name,
    behavior   = behavior
  )
}


#' Lag/Lead (Shift) Function for Univariate Series
#'
#' @param x given vector
#' @param shift_by lag or lead parameter
#' @param fill a value to be used to fill the rows
#'
#' @return Generating a lag/lead variables
#' @importFrom utils head tail
#' @export
ATA.Shift <- function(x, shift_by, fill = NA){
  stopifnot(is.numeric(shift_by))
  stopifnot(is.numeric(x))
  if (length(shift_by) > 1)
    return(sapply(shift_by, ATA.Shift, x=x))
  out <- NULL
  abs_shift_by <- abs(shift_by)
  if (shift_by > 0 )
    out <- c(tail(x,-abs_shift_by),rep(fill,abs_shift_by))
  else if (shift_by < 0 )
    out <- c(rep(fill,abs_shift_by), utils::head(x,-abs_shift_by))
  else
    out <- x
  return(out)
}

#' Lag/Lead (Shift) Function for Multivariate Series
#'
#' @param X given matrice
#' @param direction direction of shifting. Default is "down".
#' @param shift_by number of rows to be shifed upwards/downwards
#' @param fill a value to be used to fill the rows
#'
#' @return Generating a lag/lead matrice
#'
#' @export
ATA.Shift_Mat <- function(X, direction = "down", shift_by = 1, fill = NA)
{
  if (direction != "down" & direction != "up"){
    stop("'direction' is not a 'down' or 'up'")
  }
  if (!is.matrix(X)) {
    stop("X is not a matrix")
  }
  if (!is.numeric(X)) {
    stop("X is not a numeric matrix")
  }
  if (shift_by < 0)
    stop("'rows' is not positive")
  if (shift_by != trunc(shift_by))
    stop("'rows' is not an integer")
  if (direction == "down"){
    if (shift_by > 0)
      return(ATA.Shift_Mat(rbind(rep(fill, ncol(X)), X[1:nrow(X)-1,]), direction = "down", shift_by - 1, fill))
  }else {
    if (shift_by > 0)
      return(ATA.Shift_Mat(rbind(X[2:nrow(X),], rep(fill, ncol(X))), direction = "up", shift_by - 1, fill))
  }
  return(X)
}


library(tidyverse)
library(ggplot2)
library(dplyr)
library(patchwork)
library(ggalt)
#Load data
main_data <- read_csv("conv.csv")

#changing percentage resistance into numeric class and rounding off
main_data$percent_resistant <- as.numeric(as.character
                                          (main_data$percent_resistant))

main_data$percent_resistant <- round(main_data$percent_resistant, digits = 2)

conv_data <- main_data %>%
group_by(country) %>%
  filter(farm_type == "Conventional") %>%
  select("country",
        "sampling_start_date",
         "sampling_end_date",
         "percent_resistant") %>%
    rename(start_year = "sampling_start_date",
           end_year = "sampling_end_date",) %>%
  drop_na()

conv_data1 <- conv_data %>%
  pivot_longer(cols = c("start_year",
               "end_year"), names_to = "year",
               values_to = "year_name")
 conv_data1

 conv_data2 <- aggregate(percent_resistant~country+year+year_name,conv_data1, mean)

 conv_data2 %>%
   ggplot(aes(x= percent_resistant, y= country, color= year)) +
   geom_line(color= "black")+
   geom_point()

 ##finding means
  aggregate(percent_resistant~country+year+year_name,conv_data1, mean)%>%
view()

  aggregate(percent_resistant~year+country+year_name,conv_data1, mean)%>%
    view()

  aggregate(percent_resistant~year_name+country+year,conv_data1, mean)%>%
    view()
  ##extracting data
usa <- conv_data1 %>%
  filter(country == "United States of America" & year_name == "2000" |
           year_name == "2015")

  us_data <- aggregate(percent_resistant~year_name+country+year,usa, mean)

  us_data

  ## USA dumbbell plot(2000-2015)
  us_data %>%
    ggplot(aes(x= percent_resistant, y= country, color= year)) +
    geom_line(color= "black")+
    geom_point()+
    geom_text(aes(label= percent_resistant))+
    labs(title = "AMR percentages in the USA at the beginning of 2000 and at the end of 2015")


#' Plot SPR table
#'
#' Plot table of values associated with spawners per recruit and compute a number of per recruit reference points.
#' @param asap name of the variable that read in the asap.rdat file
#' @param a1 list file produced by grab.aux.files function
#' @param nyrs.ave number of years to average for calculating Reference Points
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotSPRtable <- function(asap,a1,nyrs.ave,save.plots,od,plotf){

  asap.name <- a1$asap.name
  spr.targ.values <- seq(0.2, 0.8, by=0.05)
  n.spr <- length(spr.targ.values)
  nages<- asap$parms$nages
  years <- seq(asap$parms$styr,asap$parms$endyr)
  nyears <- asap$parms$nyears
  if (asap$options$isfecund == 1){
    fec.age <- rep(1, nages)
  }else{
    fec.age <- apply(asap$WAA.mats$WAA.ssb[(nyears-nyrs.ave+1):nyears,],2,mean)
  }
  mat.age <- apply(asap$maturity[(nyears-nyrs.ave+1):nyears,],2,mean)
  wgt.age <- apply(asap$WAA.mats$WAA.catch.all[(nyears-nyrs.ave+1):nyears,],2,mean)
  M.age <- apply(asap$M.age[(nyears-nyrs.ave+1):nyears,],2,mean)
  sel.mat <- asap$F.age[(nyears-nyrs.ave+1):nyears,]/apply(asap$F.age[(nyears-nyrs.ave+1):nyears,],1,max)
  sel.age1<- apply(sel.mat,2,mean)
  sel.age <- sel.age1/max(sel.age1)
  spawn.time <- asap$options$frac.yr.spawn
  jan1.age <- apply(asap$WAA.mats$WAA.jan1[(nyears-nyrs.ave+1):nyears,],2,mean)

  ave.pars.mat <- matrix(NA, nrow= 12 , ncol=nages)
  rownames(ave.pars.mat) <- c("M.age", "mat.age", "SSB.waa", "catch.waa",
                              "jan1.waa" , "sel.age", "spawn.time", "F30%", "F35%", "F40%","F45%","F50%")
  colnames(ave.pars.mat) <- (paste0("age",seq(1,nages) ) )
  ave.pars.mat[1,] <- M.age
  ave.pars.mat[2,] <- mat.age
  ave.pars.mat[3,] <- fec.age
  ave.pars.mat[4,] <- wgt.age
  ave.pars.mat[5,] <- jan1.age
  ave.pars.mat[6,] <- sel.age
  ave.pars.mat[7,] <- c(spawn.time, rep(NA, (nages-1))   )

  spr0<- s.per.recr(nages=nages, fec.age=fec.age, mat.age=mat.age, M.age= M.age, F.mult=0, sel.age=sel.age, spawn.time=spawn.time)
  F.start <-0.11  # starting guess for optimization routine to find F_SPR%

  f.spr.vals <- rep(NA, n.spr)
  ypr.spr.vals <- rep(NA, n.spr)
  ssb.spr.vals <- rep(NA, n.spr)
  conv.vals <- rep(NA, n.spr)

  for (i in 1:n.spr) {
    t.spr <- spr.targ.values[i]

    spr.f <- function(F.start) {
      abs(s.per.recr(nages=nages, fec.age=fec.age, mat.age=mat.age, M.age= M.age, F.mult=F.start, sel.age=sel.age, spawn.time=spawn.time)/spr0 - t.spr )
    }
    yyy <- nlminb(start=F.start, objective=spr.f, lower=0, upper=3)
    f.spr.vals[i] <- yyy$par
    ypr.spr.vals[i] <- ypr(nages, wgt.age=wgt.age, M.age=M.age,  F.mult=f.spr.vals[i], sel.age=sel.age )
    ssb.spr.vals[i] <- s.per.recr(nages=nages, fec.age=fec.age, mat.age=mat.age, M.age= M.age, F.mult=f.spr.vals[i], sel.age=sel.age, spawn.time=spawn.time)

  }  #end i-loop over SPR values

  ave.pars.mat[8,] <- c(f.spr.vals[3], rep(NA, (nages-1))   )    #F30%
  ave.pars.mat[9,] <- c(f.spr.vals[4], rep(NA, (nages-1))   )    #F35%
  ave.pars.mat[10,] <- c(f.spr.vals[5], rep(NA, (nages-1))   )    #F40%
  ave.pars.mat[11,] <- c(f.spr.vals[6], rep(NA, (nages-1))   )    #F45%
  ave.pars.mat[12,] <- c(f.spr.vals[7], rep(NA, (nages-1))   )    #F50%
  write.csv(ave.pars.mat, file=paste0(od, "AGEPRO_ave_params_",asap.name,".csv"), row.names=T)

  par(mfrow=c(1,1), mar=c(4,4,2,4) )

  plot(spr.targ.values, ypr.spr.vals, type='n', xlab="% SPR Target", ylab="Yield per Recruit", lwd=2,
       col="blue3", ylim=c(0,1.2*max(ypr.spr.vals)) )
  abline(v=seq(0.2,0.8, by=0.05), col="grey85")
  lines(spr.targ.values, ypr.spr.vals, lwd=2, col="blue3" )
  points(spr.targ.values, ypr.spr.vals, pch=19, col="blue3" )
  scale.f.spr <- max(f.spr.vals)/max(ypr.spr.vals)

  lines(spr.targ.values, f.spr.vals/scale.f.spr, col="red", lwd=2 )
  axis(side=4, at=seq(0,1,by=0.1)/scale.f.spr, lab=seq(0,1,by=0.1), las=2,
       col='black', col.axis="black")
  mtext(side=4, "F (%SPR)", line=3, col="red")

  title (paste0("SPR Target Reference Points (Years Avg = ", nyrs.ave,")"), outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "SPR.Target.Curves.", plotf), type=plotf)

  par(mfrow=c(1,1), mar=c(2,2,2,2))
  plot(seq(1,15), seq(1,15), type='n', axes=F, bty='n',xlab="",ylab="")

  text(x=2,y=14, labels="% SPR", font=2, pos=4)
  text(x=5, y=14, labels="F(%SPR)" , font=2, pos=4)
  text(x=9, y=14, labels="YPR", font=2, pos=4 )
  for (i in 1:n.spr) {
    text(x=2, y=seq(n.spr,1, by=-1), labels=round(spr.targ.values,2), cex=1.0, pos=4, font=1)
    text(x=5, y=seq(n.spr,1, by=-1), labels=round(f.spr.vals,4), cex=1.0, pos=4, font=1)
    text(x=9, y=seq(n.spr,1, by=-1), labels=round(ypr.spr.vals,4), cex=1.0, pos=4, font=1)
  }
  title (paste0("SPR Target Reference Points (Years Avg = ", nyrs.ave,")"), outer=T, line=-1 )

  if (save.plots) savePlot(paste0(od, "SPR.Target.Table.", plotf), type=plotf)

  frep1 <-asap$options$Freport.agemin
  frep2 <-asap$options$Freport.agemax
  if (frep1==frep2) freport <-f.spr.vals*sel.age[frep1:frep2]
  if (frep2>frep1) freport <-f.spr.vals*mean(sel.age[frep1:frep2])

  spr.target.table<- as.data.frame(cbind(spr.targ.values, f.spr.vals, ypr.spr.vals, ssb.spr.vals, freport))
  colnames(spr.target.table) <- c("%SPR", "F(%SPR)", "YPR", "SSB.PR", paste0("Freport_",frep1,"-",frep2))

  write.csv( spr.target.table, file=paste0(od,"SPR.Target.Table_",asap.name,".csv"),  row.names=F )
  return()
} # end function