server.R
In poppr: Genetic Analysis of Populations with Mixed Reproduction

library("shiny")
library("poppr")
source("../utils.R", local = TRUE)
#------------------------------------------------------------------------------#
# Here, we query the user's R session to find all of the genind and genclone 
# objects
#------------------------------------------------------------------------------#
globals <- get_globals(c("genind", "genclone", "genlight", "snpclone"))
#==============================================================================|
# The Server side of things has to balance several things going on at once from
# the user's side. Many things are dependent on user selections. Most of the
# plotting is controlled by the three input buttons on the UI side, but some of
# the UI elements automatically trigger a response from the server. By default,
# the server does nothing but plot a single plot that gives the user
# instructions. It is only until the user hits the "Go!" button does everything
# begin.
#
# The Job of the server is split up into two main tasks:
#
# 1. Get the data and calculate the minimum spanning network
#   a. get the data
#   b. subset it
#   c. parse the distance function with its arguments.
#   d. calculate the distance matrix (this is done simultaneously with e if the
#      distance is bruvo)
#   e. calculate the minimum spanning network
# 2. Add the aesthetics to the minimum spanning network and plot it
#   a. assemble the commands necessary to replicate the plot on the user's end
#   b. plot the data
#   c. show the user the session information
#==============================================================================|
shinyServer(function(input, output, session) {
  
  #----------------------------------------------------------------------------#
  # Data Processing -----------------------------------------------------------|
  # ---------------------------------------------------------------------------|
  #
  # These first steps are necessary to make sure that the user has submitted the
  # data properly and that the custom functions work. 
  #============================================================================#
  
  #-------------------------------------
  # The first task is for the User to 
  # choose a data set. Since the user can 
  # choose a data set that exists within 
  # their R session, this has to be made
  # dynamically.
  #-------------------------------------
  output$selectUI <- renderUI({
    selectInput("dataset", 
                "choose dataset",
                choices = c(globals,
                            "Example: Pinf",
                            "Example: partial_clone",
                            "Example: Aeut",
                            "Example: nancycats",
                            "Example: microbov",
                            "Example: H3N2"),
                selected = "Example: partial_clone"
    )
  })

  #-------------------------------------
  # If the data set is an example, load 
  # and return it, otherwise, get the
  # data set from the user's environment
  #-------------------------------------
  in_dataset <- reactive({
    if (!is.null(input$dataset) && !grepl("<choose>", input$dataset)){
      if(grepl("Example: ", input$dataset)){
        env <- new.env()
        if (input$dataset == "Example: microbov"){ 
          data("microbov", package="adegenet", envir = env) 
        }
        else if (input$dataset == "Example: nancycats"){ 
          data("nancycats", package="adegenet", envir = env) 
        }
        else if (input$dataset == "Example: H3N2"){ 
          data("H3N2", package="adegenet", envir = env) 
        }
        else if (input$dataset == "Example: partial_clone"){ 
          data("partial_clone", package="poppr", envir = env) 
        }
        else if (input$dataset == "Example: Aeut"){ 
          data("Aeut", package="poppr", envir = env) 
        }
        else if (input$dataset == "Example: Pinf"){ 
          data("Pinf", package="poppr", envir = env) 
        }
        exam <- substr(input$dataset, start = 10, stop = nchar(input$dataset))
        dat <- get(exam, envir = env)
      } else {
        dat <- get(input$dataset, envir = .GlobalEnv)
      }
    } else {
      dat <- new("genind")
    }
    if (input$genclone) {
      if (inherits(dat, "genlight")){
        dat <- as.snpclone(dat)
      } else if(!inherits(dat, "genclone")) {
        dat <- as.genclone(dat)
      } else {
        # it already is a genclone object
      }
    }
    return(dat)
  })
  
  #-------------------------------------
  # This is the first field to change
  # dynamically with user input. It will
  # show the user a series of checkboxes
  # representing the populations 
  # available.
  #-------------------------------------
  output$selectPops <- renderUI({
    input$dataset
    checkboxGroupInput("sublist",
                "choose populations",
                choices = popNames(in_dataset()),
                inline = TRUE,
                selected = popNames(in_dataset()))
  })
  #-------------------------------------
  # Simply a reactive for the input above.
  #-------------------------------------
  sub_list <- reactive({
    if (is.null(input$sublist)) NA else input$sublist
  })
  #-------------------------------------
  # This parses the data according to 
  # the selected populations. Notice that
  # it is only controlled by the 
  # buttons and not the data set. If this
  # were controlled by the data set, it
  # would throw an error every time the
  # user switches data sets. 
  #-------------------------------------
  dataset <- reactive({
    input$`update-data`
    input$submit
    isolate({
      popsub(in_dataset(), sub_list(), drop = FALSE)
    })
  })
  #-------------------------------------
  # This grabs the name of the data set
  # for the command tab.
  #-------------------------------------
  dataname <- reactive({
    if (!grepl("<choose>", input$dataset)){
      if(grepl("Example: ", input$dataset)){
        dat <- substr(input$dataset, start = 10, stop = nchar(input$dataset))
      } else {
        dat <- input$dataset
      }
    } else {
      dat <- "no data"
    }
    return(dat)
  })
  
  #-------------------------------------
  # If the user selects "Custom" for the
  # distance function, they must supply
  # the name of the function. By default
  # an example of euclidean distance is
  # displayed.
  #-------------------------------------
  output$customDist <- renderUI({
    textInput("custom_distance", label = "Custom Distance Function", "function(x) dist(tab(x))")
  })
  #-------------------------------------
  # If the distance is a custom function,
  # it must be treated, otherwise it must
  # be translated.
  #-------------------------------------
  distfun <- reactive({ 
    if (input$distance == "Custom"){
      the_dist <- parse_distfun(input$custom_distance)
    } else {
      the_dist <- get_dist(input$distance) 
      if (inherits(in_dataset(), "genlight") && the_dist == "diss.dist"){
        the_dist <- "bitwise.dist"
      }
    }
    return(the_dist)
  })

  #-------------------------------------
  # All the functions have arguments 
  # associated with them. This displays
  # the arguments as text that can be
  # later parsed as proper R code.
  #-------------------------------------
  output$distargsUI <- renderUI({
    the_fun <- eval(parse(text = distfun()))
    the_args <- formals(the_fun)[-1]
    the_args <- paste(names(the_args), the_args, sep = " = ", 
                      collapse = ", ")
    textInput("distargs", label = "Distance arguments", the_args)
  })
  #-------------------------------------
  # Distance Arguments from above.
  #-------------------------------------
  distargs <- reactive({
    input$distargs     
  })
  #-------------------------------------
  # Should the minimum spanning network
  # contain reticulate nodes?
  #-------------------------------------
  reticulation <- reactive({
    input$reticulate        
  })
  
  #-------------------------------------
  # The below reactives represent the
  # situation in which the user chooses
  # Bruvo's distance. When this is the
  # case, since we know the specific
  # combination of the different models
  # is not immediately inherent, we give
  # them the choice. 
  #-------------------------------------
  addloss <- reactive({
    switch(input$bruvo_model,
           "Genome Addition" = "add = TRUE, loss = FALSE",
           "Genome Loss" = "add = FALSE, loss = TRUE",
           "Infinite" = "add = FALSE, loss = FALSE",
           "Average Addition/Loss" = "add = TRUE, loss = TRUE")
  })
  #-------------------------------------
  # The repeat lengths can be comma
  # separated numbers or any R expression
  # or object that's valid. 
  #-------------------------------------
  replen <- reactive({
    if (!grepl("\\(", input$replen)){
      paste0("replen = c(", input$replen, ")")
    } else {
      paste0("replen = ", input$replen)
    }
  })

  #----------------------------------------------------------------------------#
  # Distance Matrix and Minimum Spanning Network Construction -----------------|
  # ---------------------------------------------------------------------------|
  # 
  # This single reactive controls the generation of both the distance matrix and
  # the minimum spanning network. This is controlled by the two buttons, reData
  # and submit, but it's also controlled by the "reticulate" checkbox. 
  #
  # The reason why this is in one function is because it's much more efficient
  # to process the minimum spanning network with bruvo's distance using
  # bruvo.msn. One thing to note about this function is that missing data is
  # always treated with "mean".
  #============================================================================#

  #-------------------------------------
  # If the user selects "Custom" for the
  # distance function, they must supply
  # the name of the function. By default
  # an example of euclidean distance is
  # displayed.
  #-------------------------------------
  output$customLayout <- renderUI({
    textInput("custom_layout", label = "Custom Layout Function", "function(x) matrix(rnorm(igraph::vcount(x)*2), ncol = 2)")
  })
  
  layfun <- reactive({ 
    if (input$layout == "Custom"){
      the_lay <- parse_distfun(input$custom_layout)
    } else {
      the_lay <- paste0("igraph::", input$layout)
    }
    return(the_lay)
  })
  #-------------------------------------
  # This reactive calculates the distance
  # by parsing the distance and then
  # running the minimum spanning network
  # on that matrix.
  #-------------------------------------
  minspan <- reactive({
    # input$dataset
    input$`update-data`
    input$reticulate
    input$submit
    isolate({
      indist <- distfun()
      ret    <- reticulation()
      args   <- distargs()
      if (input$distance == "Bruvo"){
        args <- paste(replen(), addloss(), sep = ", ")
        fun <- paste0("bruvo.msn(dataset(), ", args, ", showplot = FALSE, include.ties = ret)")
        out <- eval(parse(text = fun))
      } else {
        if (indist != "diss.dist" && inherits(dataset(), "genind")){
          dat <- missingno(dataset(), "mean")
        } else {
          dat <- dataset()
        }
        if (length(args) == 1 && args == ""){
          fun <- paste0(indist, "(dat)")
        } else {
          fun <- paste0(indist, "(dat, ", args, ")")
        }
        dist <- eval(parse(text = fun))
        out <- poppr.msn(dataset(), dist, showplot = FALSE, include.ties = ret)
      }
      return(out)
    })
  })

  #----------------------------------------------------------------------------#
  # Aesthetic Processing ------------------------------------------------------|
  # ---------------------------------------------------------------------------|
  # 
  # This section contains all of the reactive functions to return basic values
  # for plotting. They do not affect how the minimum spanning network is
  # constructed. I will not comment on the ones that are simply one-line
  # reactive functions.
  #============================================================================#
  slide <- reactive({
    input$greyslide
  })
  
  seed <- reactive({
    input$seed 
  })

  nodescale <- reactive({
    input$nodescale
  })

  #-------------------------------------
  # plot_poppr_msn allows the user to
  # display what node a specific sample
  # lies. This will take the user input
  # as a comma separated list of sample
  # names and pass them on.
  #-------------------------------------
  inds <- reactive({
    inds <- strsplit(input$inds, "[[:blank:]]*,[[:blank:]]*")[[1]]
    if (input$ind_or_mlg == "sample names" || inds == "ALL" || inds == ""){
      return(inds)
    } else {
      return(as.numeric(inds))
    }
  })
  
  #-------------------------------------
  # The user palette can be a custom
  # palette. I'm not sure why this is
  # protected by the reactive here...
  #-------------------------------------
  usrPal <- reactive({
    input$`update-data`
    input$`update-graph`
    input$submit
    isolate({
      if (input$pal == 'custom'){
        eval(parse(text = input$custom_pal))
      } else {
        input$pal
      }
    })
  })

  popLeg <- reactive({
    input$pop.leg
  })

  sizeLeg <- reactive({
    input$size.leg
  })
  
  scaleLeg <- reactive({
    input$scale.leg
  })

  cutoff <- reactive({
    cutoff <- as.numeric(input$cutoff)
    if (is.na(cutoff)) cutoff <- NULL
    cutoff      
  })

  bcut <- reactive({
    input$beforecut
  })

  #----------------------------------------------------------------------------#
  # User-facing Command Construction ------------------------------------------|
  # ---------------------------------------------------------------------------|
  # 
  # The following reactives construct the command the user needs to recreate the
  # minimum spanning network that has been created. 
  #============================================================================#

  #-------------------------------------
  # This constructs the command that
  # Processes the data, constructs the
  # distance, and constructs the minimum
  # spanning network. 
  #-------------------------------------
  distcmd <- reactive({
    dat      <- dataname()
    distfunk <- distfun()
    args     <- distargs()
    the_pops <- popNames(in_dataset())
    match_pops <- the_pops %in% input$sublist

    # If the number of population selected is greater than half the total
    # populations, place the unselected populations in the exclude argument.
    half <- ceiling(length(the_pops)/2)
    if (sum(match_pops) < half){
      first_dat <- paste0(dat, "_sub <- popsub(", dat, ", sublist = ", make_dput(input$sublist), ")\n")
    } else {
      first_dat <- paste0(dat, "_sub <- popsub(", dat, ", exclude = ", make_dput(the_pops[!match_pops]), ")\n")
    }
    closer   <- paste0("showplot = FALSE, include.ties = ", reticulation(), ")")
    has_no_args <- length(args) == 1 && args == ""
    if (distfunk == "bruvo.dist"){
      args <- paste(replen(), addloss(), sep = ", ")
      distfunk <- "min_span_net <- bruvo.msn"
      closer <- paste0(", ", args, ", ", closer)
      return_cmd <- paste0(distfunk, "(", dat, "_sub", closer)
    } else { 
      if (distfunk == "diss.dist"){
        missfunk <- character(0)
        distfunk <- paste0(distfunk, "(", dat, "_sub, ", args, ")\n")        
      } else {
        missfunk <- paste0(dat, "_nomiss <- ", "missingno(", dat, 
                           ", type = 'mean')\n")
        args <- ifelse(has_no_args, "", paste0(", ", args))
        distfunk <- paste0(distfunk, "(", dat, "_nomiss", args, ")\n")        
      }
      msnfunk <- paste0("poppr.msn(", dat, "_sub, ", dat, "_dist, ", closer, "\n")
      return_cmd <- paste0(missfunk, 
                           dat, "_dist <- ", distfunk,
                           "min_span_net <- ", msnfunk)
    }
    return(paste0(first_dat, return_cmd))
  })

  #-------------------------------------
  # This one is relatively easy as it
  # simply just constructs the plotting
  # function with it's uncomplicated
  # processing.
  #-------------------------------------
  cmd <- reactive({
    dat <- dataname()
    pal <- ifelse(input$pal == 'custom', input$custom_pal, input$pal)
    padding <- paste(rep(" ", 15), collapse = "")
    paste0("plot_poppr_msn(", dat, 
           ",\n", padding, "min_span_net", 
           ",\n", padding, "inds = ", make_dput(inds()), 
           ",\n", padding, "mlg = ", input$mlgs,
           ",\n", padding, "gadj = ", input$greyslide,
           ",\n", padding, "nodescale = ", input$nodescale,
           ",\n", padding, "palette = ", pal,
           ",\n", padding, "cutoff = ", ifelse(is.null(cutoff()), "NULL", cutoff()),
           ",\n", padding, "quantiles = FALSE",
           ",\n", padding, "beforecut = ", bcut(), 
           ",\n", padding, "pop.leg = ", popLeg(), 
           ",\n", padding, "size.leg = ", sizeLeg(),
           ",\n", padding, "scale.leg = ", scaleLeg(),
           ",\n", padding, "layfun = ", layfun(), 
           ")")
  })

  #-------------------------------------
  # This simply shows the data set.
  #-------------------------------------
  output$summary <- renderPrint({
    dat <- dataset()
    show(dat)
  })

  #----------------------------------------------------------------------------#
  # Output --------------------------------------------------------------------|
  # ---------------------------------------------------------------------------|
  # 
  # Below are all the tabs for output.
  #============================================================================#

  #-------------------------------------
  # The first thing the user sees is the
  # plot, so it's important to check if
  # the user has hit "submit" or not.
  #-------------------------------------
  output$plot <- renderPlot({
    input$pop.leg
    input$scale.leg
    input$beforecut
    input$nodescale
    input$inds
    input$mlgs
    input$`update-graph`
    if(!input$submit) {
      plot.new() 
      rect(0, 1, 1, 0.8, col = "indianred2", border = 'transparent' ) + 
      text(x = 0.5, y = 0.9, "Please select data and click\nthe 'Go!' button.", 
           cex = 1.6, col = "white")
    } else {
      set.seed(seed())
      plot_poppr_msn(dataset(), 
                     minspan(), 
                     ind = inds(), 
                     gadj = slide(), 
                     mlg = input$mlgs,
                     palette = usrPal(), 
                     cutoff = cutoff(), 
                     quantiles = FALSE, 
                     beforecut = bcut(), 
                     nodescale = nodescale(),
                     pop.leg = popLeg(), 
                     size.leg = sizeLeg(),
                     scale.leg = scaleLeg(),
                     layfun = eval(parse(text = layfun()))
                    )      
    }
  })
  
  #-------------------------------------
  # For all the lines it took to create
  # the user-facing commands, three 
  # lines to print them seem pretty pithy
  #-------------------------------------
  output$cmd <- renderPrint({
    cat(paste0(distcmd(), "\n"))
    cat(paste0("set.seed(", seed(),")\n"))
    cat(cmd())
  })

  #-------------------------------------
  # Saving output as PDF
  #-------------------------------------
  output$save_pdf <- downloadHandler(
    filename = function() paste0('msn-', Sys.Date(), '.pdf'),
    content = function(file) {
      isolate({
        # Generate a pdf
        pdf(file, width = input$pdf_plot_width, height = input$pdf_plot_height)
        set.seed(seed())
        plot_poppr_msn(dataset(),
                       minspan(),
                       ind = inds(),
                       gadj = slide(),
                       mlg = input$mlgs,
                       palette = usrPal(),
                       cutoff = cutoff(),
                       quantiles = FALSE, 
                       beforecut = bcut(),
                       nodescale = nodescale(),
                       pop.leg = popLeg(),
                       size.leg = sizeLeg(),
                       scale.leg = scaleLeg(),
                       layfun = eval(parse(text = layfun()))
                      )
        dev.off()
      })      
    }
  )

  #-------------------------------------
  # Saving output as PNG
  #-------------------------------------
  output$save_png <- downloadHandler(
    filename = function() paste0('msn-', Sys.Date(), '.png'),
    content = function(file) {
      isolate({
        # Generate a png
        png(file, width = input$png_plot_width, height = input$png_plot_height)
        set.seed(seed())
        plot_poppr_msn(dataset(),
                       minspan(),
                       ind = inds(),
                       gadj = slide(),
                       mlg = input$mlgs,
                       palette = usrPal(),
                       cutoff = cutoff(),
                       quantiles = FALSE, 
                       beforecut = bcut(),
                       nodescale = nodescale(),
                       pop.leg = popLeg(),
                       size.leg = sizeLeg(),
                       scale.leg = scaleLeg(),
                       layfun = eval(parse(text = layfun()))
                      )
        dev.off()
      })      
    }
  )
  #-------------------------------------
  # Printing the user's session info.
  #-------------------------------------
  output$infoRmation <- renderPrint({
    sessionInfo()
  })
})