#' @name GWASTrack-class
#' @rdname GWASTrack-class
#' @importFrom methods is new
#' @importFrom utils write.table
#' @keywords GWASTrack_class

#' @exportClass GWASTrack

.GWASTrack <-
  setClass(
    "GWASTrack",
    slots = representation(
      trackName = "character",
      data.mode = "character",
      url = "character",
      chrom.col = "numeric",
      pos.col = "numeric",
      pval.col = "numeric",
      chromosomeColorMap = "list",
      trackHeight = "numeric",
      autoscale = "logical",
      minY = "numeric",
      maxY = "numeric"
    )
  )

setGeneric("display",
           signature = "obj",
           function(obj,
                    session,
                    id,
                    deleteTracksOfSameName = TRUE) {
             standardGeneric("display")
           })

setGeneric("getUrl",
           signature = "obj",
           function(obj) {
             standardGeneric("getUrl")
           })

#-------------------------------------------------------------------------------
#' Check a chromosome color map before it reaches igv.js
#'
#' @param map a named list or character vector of colors, possibly empty
#' @return the map as a named list, empty if nothing was supplied
#' @keywords GWASTrack_class
.sanitizeChromosomeColorMap <- function(map) {
  if (is.null(map) || length(map) == 0) {
    return(list())
  }

  if (!is.list(map) && !is.character(map)) {
    stop("error: chromosomeColorMap must be a named list or character vector")
  }

  map <- as.list(map)
  # anyNA first: with an NA name, any(names == "") is NA and `if` errors
  if (is.null(names(map)) || anyNA(names(map)) || any(names(map) == "")) {
    stop("error: every chromosomeColorMap color needs a chromosome name")
  }

  # a colorTable is a JSON object, so a repeated chromosome keeps whichever
  # color happens to be written last - better to say so than to pick one
  if (anyDuplicated(names(map))) {
    stop(sprintf("error: chromosomeColorMap names one chromosome twice: %s",
                 toString(unique(names(map)[duplicated(names(map))]))))
  }

  valid <- vapply(map, function(color) {
    is.character(color) && length(color) == 1L && !is.na(color)
  }, logical(1))
  if (!all(valid)) {
    stop(sprintf("error: chromosomeColorMap colors must be single strings: %s",
                 toString(names(map)[!valid])))
  }

  map
}
#-------------------------------------------------------------------------------
#' Constructor for GWASTrack
#'
#' \code{GWASTrack} creates an \code{IGV} manhattan track from GWAS data
#'
#' @name GWASTrack
#' @rdname GWASTrack-class
#'
#' @param trackName A character string, used as track label by igv,
#' we recommend unique names per track.
#' @param data a data.frame or a url pointing to one,
#' whose structure is described by chrom.col, pos.col, pval.col
#' @param chrom.col numeric, the column number of the chromosome column
#' @param pos.col numeric, the column number of the position column
#' @param pval.col numeric, the column number of the GWAS pvalue column
#' @param chromosomeColorMap a named list or character vector mapping
#' chromosome names, as they are spelled in the data, to colors,
#' e.g. \code{list("1" = "red", "2" = "blue")}. A \code{"*"} entry colors every
#' chromosome not named explicitly. Empty by default, which leaves the igv.js
#' chromosome palette in place
#' @param trackHeight numeric in pixels
#' @param autoscale logical
#' @param minY numeric for explicit (non-auto) scaling
#' @param maxY numeric for explicit (non-auto) scaling
#'
#' @return A GWASTrack object
#'
#' @examples
#' file <-
#'   # a local gwas file
#'   system.file(package = "igvShiny", "extdata", "gwas-5k.tsv.gz")
#' tbl.gwas <- read.table(file,
#'                        sep = "\t",
#'                        header = TRUE,
#'                        quote = "")
#' dim(tbl.gwas)
#' track <-
#'   GWASTrack(
#'     "gwas 5k",
#'     tbl.gwas,
#'     chrom.col = 12,
#'     pos.col = 13,
#'     pval.col = 28
#'   )
#' getUrl(track)
#'
#' # a remote gwas file: the constructor checks that the url resolves, so this
#' # block reaches the network and stays out of R CMD check
#' \donttest{
#' url <- "https://gladki.pl/igvShiny/gwas_sample.tsv.gz"
#' track <- GWASTrack(
#'   "remote url gwas",
#'   url,
#'   chrom.col = 3,
#'   pos.col = 4,
#'   pval.col = 10,
#'   autoscale = FALSE,
#'   minY = 0,
#'   maxY = 300,
#'   trackHeight = 100
#' )
#' getUrl(track)
#' }
#'
#' # colors picked per chromosome, with "*" covering the rest
#' track <- GWASTrack(
#'   "gwas 5k, custom colors",
#'   tbl.gwas,
#'   chrom.col = 12,
#'   pos.col = 13,
#'   pval.col = 28,
#'   chromosomeColorMap = list("1" = "red", "2" = "blue", "*" = "gray")
#' )
#'
#'
#' @keywords GWASTrack_class
#' @export
#'


GWASTrack <- function(trackName,
                      data,
                      chrom.col,
                      pos.col,
                      pval.col,
                      chromosomeColorMap = list(),
                      trackHeight = 50,
                      autoscale = TRUE,
                      minY = 0,
                      maxY = 30) {
  data.class <- class(data)
  stopifnot(data.class %in% c("data.frame", "character"))

  chromosomeColorMap <- .sanitizeChromosomeColorMap(chromosomeColorMap)
  columns <- list(chrom.col = chrom.col, pos.col = pos.col,
                  pval.col = pval.col)
  for (name in names(columns)) {
    value <- columns[[name]]
    if (!is.numeric(value) || length(value) != 1L || is.na(value) ||
        value != round(value) || value < 1) {
      stop(sprintf("error: %s must be a single column number, at least 1",
                   name))
    }
  }

  if (data.class == "data.frame") {
    # a column number past the end of the table silently yields an empty track,
    # so it is worth catching here, where the table is still in hand
    too.big <- vapply(columns, function(value) value > NCOL(data), logical(1))
    if (any(too.big)) {
      stop(sprintf(
        "error: %s beyond the %d columns of the gwas table",
        toString(names(columns)[too.big]), NCOL(data)
      ))
    }

    mode <- "local.url"
    tdir <- .tracksDir()
    x <- NULL
    url <-
      tempfile(tmpdir = tdir, fileext = ".gwas") # expanded in javascript
    write.table(
      data,
      sep = "\t",
      row.names = FALSE,
      quote = FALSE,
      file = url
    )
  }

  if (data.class == "character") {
    if (httr::http_error(data)) {
      # was a legitimate url provided?
      error.message <-
        sprintf("error: putative gwas file url unreachable: '%s'",
                data)
      stop(error.message)
    }
    mode <- "remote.url"
    url <- data
  }

  obj <- .GWASTrack(
    trackName = trackName,
    data.mode = mode,
    url = url,
    chrom.col = chrom.col,
    pos.col = pos.col,
    pval.col = pval.col,
    chromosomeColorMap = chromosomeColorMap,
    trackHeight = trackHeight,
    autoscale = autoscale,
    minY = minY,
    maxY = maxY
  )
  obj

} # GWASTrack
#-------------------------------------------------------------------------------
#' display the already constructed and configured track
#'
#' @rdname display
#' @aliases display
#'
#' @param obj An object of class GWASTrack
#' @param session a Shiny session object
#' @param id character the identifier of the target igv object in the browser
#' @param deleteTracksOfSameName logical to avoid duplications in track names
#'
#' @examples
#' library(igvShiny)
#' demo_app_file <-
#'   system.file(package = "igvShiny", "showcase", "igvShinyDemo.R")
#' if (interactive()) {
#'   shiny::runApp(demo_app_file)
#' }
#'
#' @return nothing
#'
#' @keywords GWASTrack_class
#' @export
#'
setMethod("display",
          "GWASTrack",

          function(obj,
                   session,
                   id,
                   deleteTracksOfSameName = TRUE) {
            if (deleteTracksOfSameName) {
              removeTracksByName(session, id, obj@trackName)
            }

            state[["userAddedTracks"]] <-
              unique(c(state[["userAddedTracks"]], obj@trackName))

            # javascript function consults dataMode,
            # modifies dataUrl if local.url,
            # prepending the http host of the modest RStudio/Shiny webserver
            # make sure the embedded shiny webserver can find it by:
            #   - adding a resource path with a convenient shorthand name,
            #   pointing to the typically long and cryptic actual local host
            #   temporary directory
            #   - adjusting message$dataUrl to use that shorthand directory name

            message <- list(
              elementID = id,
              trackName = obj@trackName,
              dataMode = obj@data.mode,
              dataUrl = obj@url,
              # without an explicit mapping igv.js guesses the columns from the
              # header names, which only works for tables spelled its way
              columns = list(
                chromosome = obj@chrom.col,
                position = obj@pos.col,
                value = obj@pval.col
              ),
              trackHeight = obj@trackHeight,
              autoscale = obj@autoscale,
              min = obj@minY,
              max = obj@maxY
            )

            if (length(obj@chromosomeColorMap) > 0) {
              message$colorTable <- obj@chromosomeColorMap
            }

            if (obj@data.mode == "local.url") {
              directory.name <- dirname(obj@url)
              file.name      <-  basename(obj@url)
              message$dataUrl <- file.path("tracks", file.name)
            }

            session$sendCustomMessage("loadGwasTrackFlexibleSource", message)

          }) # display
#-------------------------------------------------------------------------------
#' the url of the gwas table
#'
#' @rdname getUrl
#' @aliases getUrl
#'
#' @param obj An object of class GWASTrack
#'
#' @examples
#' file <-
#'   # a local gwas file
#'   system.file(package = "igvShiny", "extdata", "gwas-5k.tsv.gz")
#' tbl.gwas <- read.table(file,
#'                        sep = "\t",
#'                        header = TRUE,
#'                        quote = "")
#' track <-
#'   GWASTrack(
#'     "gwas 5k",
#'     tbl.gwas,
#'     chrom.col = 12,
#'     pos.col = 13,
#'     pval.col = 28
#'   )
#' getUrl(track)
#'
#' @return character
#'
#' @keywords GWASTrack_class
#' @export
#'
setMethod("getUrl",
          "GWASTrack",
          function(obj) {
            obj@url
          })
#-------------------------------------------------------------------------------
#' Display a short summary of a GWASTrack object
#'
#' @rdname show
#' @aliases show,GWASTrack-method
#'
#' @importFrom methods show
#'
#' @param object An object of class GWASTrack
#'
#' @examples
#' file <-
#'   system.file(package = "igvShiny", "extdata", "gwas-5k.tsv.gz")
#' tbl.gwas <- read.table(file, sep = "\t", header = TRUE, quote = "")
#' track <-
#'   GWASTrack("gwas 5k", tbl.gwas, chrom.col = 12, pos.col = 13, pval.col = 28)
#' track
#'
#' @return nothing; called for the side effect of printing a summary
#'
#' @keywords GWASTrack_class
#' @export
#'
setMethod("show",
          "GWASTrack",
          function(object) {
            cat("GWASTrack object\n")
            cat("  trackName:  ", object@trackName, "\n", sep = "")
            cat("  dataMode:   ", object@data.mode, "\n", sep = "")
            cat("  url:        ", object@url, "\n", sep = "")
            cat("  columns:    chrom=", object@chrom.col,
                " pos=", object@pos.col,
                " pval=", object@pval.col, "\n", sep = "")
            if (length(object@chromosomeColorMap) > 0) {
              cat("  colors:     ", length(object@chromosomeColorMap),
                  " chromosomes\n", sep = "")
            }
            cat("  trackHeight:", object@trackHeight, "\n")
            cat("  autoscale:  ", object@autoscale, "\n", sep = "")
            if (isFALSE(object@autoscale)) {
              cat("  yRange:     [", object@minY, ", ", object@maxY, "]\n",
                  sep = "")
            }
          })
