#' Print a bp length nicely
#'
#' \code{prettybp} returns a string representation of a base pair length with optional rounding
#'
#' @param n base pairs
#' @param round.digits (optional) number of digits to round to. Default is 2. Set
#' to NULL to disable rounding. This value is ignored if signif.digits is not \code{NULL}.
#' @param signif.digits (optional) set this if rounding to significant digits
#' is preferred.
#' @param space Set to false to eliminate the space between the number and unit.
#' @seealso \code{\link{draw.chrom.axis}} for drawing a bp scaled x-axis
#' @export
prettybp <- function (n, round.digits=2, signif.digits=NULL, space=TRUE) {
  if ( space ) {
    use.sep <- ' '
  } else {
    use.sep <- ''
  }
  if ( log10(mean(n)) >= 6 ) {
    if ( !is.null(signif.digits) ) {
      return ( paste(signif(n/1e6, signif.digits), 'Mb', sep=use.sep))
    } else if ( !is.null(round.digits) ) {
      return ( paste(round(n/1e6, round.digits), 'Mb', sep=use.sep))
    }
    return ( paste(n/1e6, 'Mb', sep=use.sep))
  } else if ( log10(n) >= 3) {
    if ( !is.null(signif.digits) ) {
      return ( paste(signif(n/1e3, signif.digits), 'kb', sep=use.sep))
    } else if ( !is.null(round.digits) ) {
      return ( paste(round(n/1e3, round.digits), 'kb', sep=use.sep))
    }
    return ( paste(n/1e3, 'kb', sep=use.sep))
  }
  if ( !is.null(signif.digits) ) {
    return ( paste(signif(n, signif.digits), 'bp', sep=use.sep))
  } else if ( !is.null(round.digits) ) {
    return ( paste(round(n, round.digits), 'bp', sep=use.sep))
  }
  return ( paste(n, 'bp', sep=use.sep) )
}

#' Draw a horizontal chromosome axis
#'
#' \code{draw.chrom.axis} draws a chromosome axis with appropriate scale (Mb, kb, or bp).
#'
#' @param start.pos Starting position on the chromosome (in bp)
#' @param end.pos Ending position on the chromosome (in bp)
#' @param ... (optional) addition options to pass to \code{text} for drawing
#' labels
#' @seealso \code{\link{draw.scale}} for drawing a color scale bar
#' @export
draw.chrom.axis <- function(start.pos, end.pos, chrom=NULL, label.chrom=TRUE,
                            label.scale=TRUE, tick.length=0.1, ...) {
  plot(0, type='n', ylim=c(-1, 1), xlim=c(start.pos, end.pos),
       axes=FALSE, bty='n', xlab='', ylab='', yaxs='i')

  abline(h=0, xpd=FALSE)

  ticks.at <- axTicks(1)
  plot.height <- par('pin')[2]
  sapply(ticks.at, function (x) { lines(c(x, x), c(-tick.length, tick.length)/plot.height)})
  text(ticks.at, rep(0, length(ticks.at)), ticks.at/1e6, pos=1, xpd=NA, ...)
  if ( label.scale ) {
    text(par('usr')[2], 0, 'Mb', pos=4, xpd=NA, ...)
  }
  if ( !is.null(chrom) && label.chrom ) {
    text(par('usr')[1], 0, chrom, pos=2, xpd=NA, ...)
  }
}

#' Assign colors to value according to a scale
#'
#' \code{draw.scale} takes a vector of values, a color vector, and a range
#' vector and returns colors for plotting those values
#'
#'
#' @param x values to be plotted
#' @param scale.colors a vector of colors
#' @param scale.range range for scale (vector with 2 numeric elements)
#' @param all.inside If TRUE, out-of-range points are colored with the ends of
#' the color scale. If FALSE, they will be assigned no color (NA).
#' @seealso \code{\link{draw.scale}} for drawing a color scale
#' @export
assign.scale.colors <- function(x, scale.colors, scale.range, all.inside=TRUE) {
  x.missing <- is.na(x)

  x[x.missing] <- mean(x, na.rm=TRUE)

  if ( missing(scale.range) ) scale.range <- range(x)
  xbins <- seq(min(scale.range), max(scale.range), length.out=length(scale.colors)+1)
  color.idx <- findInterval(x, xbins, rightmost.closed=TRUE, all.inside=all.inside)
  if ( scale.range[1] > scale.range[2] )
    color.idx <- 1+length(scale.colors)-color.idx

  x.colors <- scale.colors[color.idx]
  x.colors[x.missing | color.idx == 0 | color.idx > length(scale.colors)] <- NA
  return ( x.colors )
}

#' Draw a color scale bar
#'
#' Adds a color scale legend to the current plot with specified colors and range.
#'
#'
#' @param scale.colors a vector of colors
#' @param scale.range range for scale (vector with 2 numeric elements, e.g. as returned by \code{range()})
#' @param num.labs (default 6) number of text labels to draw
#' @param pos (default topright)position for scale, either a keyword such as "top", "topleft" or a numeric vector length 2
#' @param adj controls the anchoring of the scale in respect to \code{pos}
#' @param horiz  TRUE for horizontal (default) or FALSE for vertical bar
#' @param outside TRUE to display legend within the plotting area (default) or FALSE to place it outside
#' @param size approximate length in inches
#' @param ratio ratio of scale bar width to height
#' @param tick.length number between 0 and 1, controls how long the ticks are vs the color boxes.
#' @param scale.offset inset (outset) amount for legend that is inside (outside)
#' @param label.offset spacing between ticks and text labels
#' @param box this controls whether a black border is drawn around the colors or not.
#' @param x.shift (optional) adjust x position in units of scale width.
#' @param y.shift (optional) adjust y position in units of scale height.
#'
#' @details This function draws a color scale bar in the current plot. Position argument
#' \code{pos} can be specified by keyword: \code{'center'}, \code{'middle'},
#' \code{'topleft'}, \code{'topright'}, \code{'top'}, \code{'bottomleft'},
#' \code{'bottomright'}, \code{'bottom'}, \code{'left'}, or \code{'right'}.
#' Alternately \code{pos} can be set by specifying a numeric vector of length 2,
#' describing the x and y locations of legend, where each is a number between 0
#' (left/bottom) and 1 (right/top). The \code{adj} argument controls the anchor
#' point for the legend itself relative to the plot. If unspecified, it will
#' match \code{pos}, if \code{outside} is \code{FALSE} (default) or \code{1-pos}
#' if \code{outside} is \code{TRUE}. This alignment is offset by \code{scale.offset}
#' so that the legend does not overlap the plot border.
#'
#' The position can be further tweaked using the \code{x.shift} and \code{y.shift}
#' arguments. 1 will shift the legend right/up by 1 scale width/height.
#'
#' The size and shape of the color legend are controlled by \code{size}, which
#' is the approximate length of the longer dimension in inches, and \code{ratio},
#' which is the ratio between width and height (or vice versa for vertical scale bars)
#' and should generally be > 1.
#'
#' There are several arguments that control how the legend is drawn. The
#' \code{tick.length} (between 0 and 1) argument controls how much of the shorter
#' dimension of the legend is taken up by the color scale vs the ticks. \code{label.offset}
#' controls the spacing between the ticks and the text labels. Parameters to modify
#' text size should be set via \code{par()} prior to calling this function. Setting
#' \code{box = FALSE} will remove the black outline around the colors.
#'
#'
#' @seealso \code{\link{draw.chrom.axis}} for drawing x-axis
#' @examples
#' plot(1:5, 1:5, col=gray(0:4/5), pch=15)
#' # Place a horizontal scale bar a the top, inside the plot.
#' draw.scale(gray(0:4/5), c(0, 1), pos='top')
#' # Place a vertical scale bar to the right, outside the plot.
#' draw.scale(gray(0:4/5), c(76.1, 76.92), pos='right', horiz=FALSE, outside=TRUE)
#' # Place a horizontal  scale bar at the top left, outside the plot, but
#' aligned with the left edge of the plot
#' draw.scale(gray(0:4/5), c(1, 10), pos='topleft', adj=c(0, 0), outside=TRUE)
#' @export
draw.scale <- function(scale.colors, scale.range, num.labs=min(length(scale.colors)+1, 6),
                       pos='topleft', adj=NULL, horiz=TRUE,
                       outside=FALSE, size=2, ratio=12, tick.length=0.25,
                       scale.offset=0.5, label.offset=0.1,
                       box=TRUE, x.shift=0, y.shift=0) {

  if ( outside ) {
    old.par <- par(xpd=NA)
  }

  # recognized keywords and corresponding positions
  pos.key <- list()
  pos.key$middle <- c(0.5, 0.5)
  pos.key$center <- c(0.5, 0.5)
  pos.key$topleft <- c(0, 1)
  pos.key$topright <- c(1, 1)
  pos.key$top <- c(0.5, 1)
  pos.key$bottomleft <- c(0, 0)
  pos.key$bottomright <- c(1, 0)
  pos.key$bottom <- c(0.5, 0)
  pos.key$left <- c(0, 0.5)
  pos.key$right <- c(1, 0.5)
  pos.key <- data.frame(pos.key, row.names=c('x', 'y'))

  if ( is.character(pos) ) pos <- tolower(pos)
  if ( is.character(pos) && length(pos)==1 && pos %in% names(pos.key) ) {
    pos <- pos.key[[pos]]
  }

  if ( !is.numeric(pos) || length(pos) != 2) {
    warning('Invalid pos Please specify a keyword or xy pair.')
    pos <- c(0, 1)
  }

  # If adj is not specified it is the same as pos for inside
  # opposite for outside
  if ( is.null(adj) ) {
    if ( outside )
      adj <- 1-pos
    else
      adj <- pos
  }

  par.usr <- par('usr')
  par.pin <- par('pin')

  plot.width <- par.usr[2]-par.usr[1]
  plot.height <- par.usr[4]-par.usr[3]

  # Calculate dimensions of scale legend
  if ( horiz ) {
    legend.width <- plot.width/par.pin[1]*size
    legend.height <- plot.height/par.pin[2]*size/ratio
  } else {
    legend.height <- plot.height/par.pin[2]*size
    legend.width <- plot.width/par.pin[1]*size/ratio
  }

  x1 <- par.usr[1]+pos[1]*plot.width-adj[1]*legend.width
  y1 <- par.usr[3]+pos[2]*plot.height-adj[2]*legend.height

  # Apply scale.offset
  if ( horiz ) {
    y1 <- y1-scale.offset*legend.height*2*(adj[2]-0.5)
    x1 <- x1-scale.offset*legend.height*plot.width/plot.height*2*(adj[1]-0.5)
  } else {
    x1 <- x1-scale.offset*legend.width*2*(adj[1]-0.5)
    y1 <- y1-scale.offset*legend.width*plot.height/plot.width*2*(adj[2]-0.5)
  }
  x2 <- x1+legend.width
  y2 <- y1+legend.height

  # Flip depending on orientation
  if ( horiz & adj[2] > 0.5 ) {
    tm <- y1
    y1 <- y2
    y2 <- tm
  } else if ( !horiz & adj[1] > 0.5 ) {
    tm <- x1
    x1 <- x2
    x2 <- tm
  }
  #     points(x1, y1, pch=8, col='red')
  #     rect(x1, y1, x2, y2, col='#ff6633')

  if ( !missing(x.shift) ) {
    x1 <- x1 + x.shift*legend.width
    x2 <- x2 + x.shift*legend.width
  }
  if ( !missing(y.shift) ) {
    y1 <- y1 + y.shift*legend.height
    y2 <- y2 + y.shift*legend.height
  }

  if ( horiz ) {
    x.points <- seq(x1, x2, length.out=length(scale.colors)+1)
    y.mid <- y1*tick.length+y2*(1-tick.length)
    y.text <- y2+label.offset*(y2-y1)
    # draw ticks
    x.ticks <- seq(x1, x2, length.out=num.labs)
    segments(x.ticks, rep(y1, num.labs), x.ticks, rep(y2, num.labs))
    # draw colored boxes
    sapply(1:length(scale.colors), function (i) {
      rect(x.points[i], y1, x.points[i+1], y.mid, border=scale.colors[i], col=scale.colors[i])
    })
    if ( box ) rect(x1, y1, x2, y.mid)
  } else {
    y.points <- seq(y1, y2, length.out=length(scale.colors)+1)
    x.mid <- x1*tick.length+x2*(1-tick.length)
    x.text <- x2+label.offset*(x2-x1)
    # draw ticks
    y.ticks <- seq(y1, y2, length.out=num.labs)
    segments(rep(x1, num.labs), y.ticks, rep(x2, num.labs), y.ticks)
    # draw colored boxes
    sapply(1:length(scale.colors), function (i) {
      rect(x1, y.points[i], x.mid, y.points[i+1], border=scale.colors[i], col=scale.colors[i])
    })
    if ( box ) rect(x1, y1, x.mid, y2, border='#000000')
  }

  tick.labels <- seq(scale.range[1], scale.range[2], length.out=num.labs)
  sigdig <- 0
  while ( length(unique(round(tick.labels, sigdig))) < length(tick.labels) ) sigdig <- sigdig + 1
  if ( horiz ) {
    text(x.ticks, rep(y.text, num.labs), format(round(tick.labels, sigdig)),
         adj=c(0.5, round(adj[2])))
  } else {
    text(rep(x.text, num.labs), y.ticks, format(round(tick.labels, sigdig)),
         adj=c(round(adj[1]), 0.5))
  }

  if ( outside ) {
    par(old.par)
  }

  invisible(c(x1, x2, y1, y2))
}

#' Draw a color scale bar (old version)
#'
#' \code{draw.old.scale} adds a color scale to the corner of the current plot
#' with specified colors and range
#'
#'
#' Currently only a horizontal scale bar is supported. To adjust position in
#' plot coordinates use x.offset and y.offset. To adjust relative position use
#' x.shift and y.shift.
#'
#' Keep in mind that if you shift the scale bar away from the plotting area
#' (i.e. into the margins), you may need to specify the additional parameter
#' xpd=NA which will be passed to the plotting commands and allows drawing
#' in the margins.
#'
#' @param scale.colors a vector of colors
#' @param scale.range range for scale (vector with 2 numeric elements)
#' @param num.labs (optional) number of labels to draw
#' @param position (optional) either 'topleft' 'topright' 'bottomleft' or
#' 'bottomright'
#' @param size (optional) approximate length in inches
#' @param width.to.height (optional) ratio of scale bar width to height
#' @param x.offset (optional) adjust x position (uses \code{par('usr')} scale).
#' @param y.offset (optional) adjust y position (uses \code{par('usr')} scale).
#' @param x.shift (optional) adjust x position in units of scale width.
#' @param y.shift (optional) adjust y position in units of scale height.
#' @param ... (optional) addition options to pass to plotting commands for
#' drawing labels, lines and shapes
#'
#' @seealso \code{\link{draw.chrom.axis}} for drawing x-axis
#' @export
draw.old.scale <- function(scale.colors, scale.range, num.labs=6,
                           position='topleft', size=3, width.to.height=20,
                           x.offset, y.offset, x.shift, y.shift, ...) {
  par.usr <- par('usr')
  par.pin <- par('pin')

  if ( substr(position, 1, 3) == 'top' ) {
    y1 <- par.usr[4]
    y2 <- par.usr[4] - (par.usr[4]-par.usr[3])/(par.pin[2])*size/width.to.height
    top <- TRUE
  } else {
    y1 <- par.usr[3]
    y2 <- par.usr[3] + (par.usr[4]-par.usr[3])/(par.pin[2])*size/width.to.height
    top <- FALSE
  }

  if ( substr(position, 7-3*top, 11-3*top) == 'left' ) {
    x1 <- par.usr[1]
    x2 <- par.usr[1] + (par.usr[2]-par.usr[1])/(par.pin[1])*size
  } else {
    x2 <- par.usr[2]
    x1 <- par.usr[2] - (par.usr[2]-par.usr[1])/(par.pin[1])*size
  }

  if ( missing(x.offset) ) x.offset <- 0
  if ( missing(y.offset) ) y.offset <- 0

  if ( !missing(x.shift) ) {
    x.offset <- x.offset + x.shift*(x2-x1)
  }

  if ( !missing(y.shift) ) {
    y.offset <- y.offset + y.shift*(y2-y1)
  }

  y1 <- y1 + y.offset
  y2 <- y2 + y.offset
  x1 <- x1 + x.offset
  x2 <- x2 + x.offset

  x.points <- seq(x1+(x2-x1)*0.1, x1+(x2-x1)*0.9, length.out=length(scale.colors)+1)
  y.mid <- y1+(y2-y1)/2

  x.ticks <- seq(x1+(x2-x1)*0.1, x1+(x2-x1)*0.9, length.out=num.labs)
  arrows(x.ticks, rep(y1, num.labs), x.ticks, rep(y2, num.labs), length=0, ...)

  if ( substr(position, 1, 3) == 'top' ) {
    label.pos = 1
  } else {
    label.pos = 3
  }

  sapply(1:length(scale.colors), function (i) {
    x1 <- x.points[i]
    x2 <- x.points[i+1]
    polygon(c(x1, x1, x2, x2), c(y1, y.mid, y.mid, y1), border=scale.colors[i], col=scale.colors[i], ...)
  })

  tick.labels <- seq(scale.range[1], scale.range[2], length.out=num.labs)
  sigdig <- 1
  while ( length(unique(signif(tick.labels, sigdig))) < length(tick.labels) ) sigdig <- sigdig + 1

  text(x.ticks, rep(y2, num.labs), signif(tick.labels, sigdig),
       pos=label.pos, offset=0.25, ...)

}

#' @export
center.out.order <- function(n) {
  if ( n <= 2 )
    return (1:n)
  if ( n %% 2 == 1 ) {
    odd <- seq(1, n, 2)
    even <- seq((n-1), 2, -2)
  } else {
    odd <- seq(1, (n-1), 2)
    even <- seq(n, 2, -2)
  }
  return ( order(c(even, odd)) )
}

#' Calculate a range with margins (padding)
#'
#' @export
mrange <- function(x, m=0.1) {
  if ( length(x) < 2 || length(unique(x)) < 2 ) {
    warning('expected x with at least 2 unique values.\n')
    return ( x )
  }
  if ( length(x) > 2 ) {
    x <- range(x)
  }

  dx <- diff(x)
  x[1] <- x[1] - m*dx
  x[2] <- x[2] + m*dx

  return ( x )
}

#' Calculate offsets for plotting y ~ x scatter plots where y is continuous and x is categorical
#'
#'
#' @examples
#' rx <- ceiling(runif(250, 0, 5))
#' ry <- rnorm(250, 0, 100)+runif(5, 0, 2000)[rx]
#' offset <- splitter(ry, rx)
#' plot(offset+as.numeric(rx), ry, pch=20, col=rainbow(5)[rx])
#' @export
#' @export
splitter <- function (y, x=NULL, rad=.025, scale=TRUE) {
  zx <- rep(0, length(y))
  if ( length(y) < 2 ) return (zx)

  if ( !is.null(x) ) {
    if ( length(unique(x)) > length(x)/2 ) warning('x does not appear to be categorical')

    if ( scale )
      z <- (y-min(y))/diff(range(y))

    subs <- tapply(z, x, splitter, rad=rad, scale=FALSE, simplify=FALSE)
    subidx <- tapply(1:length(y), x)

    for ( s in 1:length(subs) ) {
      zx[subidx==s] <- subs[[s]]*length(subs)/2
    }
    return (zx)
  }

  y.order <- order(y)
  z <- y[y.order]
  if ( scale )
    z <- (z-min(z))/diff(range(z))

  for  ( i in 2:length(z) ) {

    dz <- z[i]-z[1:(i-1)]
    if ( any(dz < rad) ) {
      nbs <- (1:(i-1))[dz < rad]
      nbd <- sqrt((z[nbs]-z[i])^2+(zx[nbs]-zx[i])^2)
      if ( any(nbd < rad) ) {
        dz <- z[i]-z[nbs]
        ax <- sin(acos(dz/rad))*rad*1.01
        if ( mean(zx[nbs]) < 0 )
          nbx <- zx[nbs]+ax
        else
          nbx <-  zx[nbs]-ax

        for ( j in order(abs(nbx)) ) {
          zx[i] <- nbx[j]
          nbd <- sqrt((z[nbs]-z[i])^2+(zx[nbs]-zx[i])^2)
          if ( all(nbd >= rad) ) {
            break
          }
        }

        if ( any(nbd < rad) )
          cat('!')

      }

      zx[1:i] <- zx[1:i]-mean(zx[1:i])
    }
  }
  zx[y.order] <- zx
  return (zx)
}

#' Integer data binning
#'
#' Sometimes with integer data which is not uniformly distributed, a linear
#' color scale is not ideal. The function \code{bin.ints} converts an integer
#' vector into a factor vector where each level corresponds to a range of
#' integers and the elements of x are evenly distributed (as much as possible)
#' across the factor levels.
#'
#' This is a convenience function that makesuse of \code{find.bins} and
#' \code{label.bins}.
#'
#' @param x data to be binned
#' @param num.bins number of bins to aim for
#'
#'
#' @return
#' \code{bin.ints} returns an ordered factor vector with appropriately
#' labeled levels.
#' @examples
#' x <- rpois(100, 10)
#' x.bin <- bin.ints(x)
#'
#'
#' @seealso \code{\link{find.bins}} for determining bin breakpoints
#' @seealso \code{\link{label.bins}} for bin labels suitable for a legend
#' @export
bin.ints <- function(x, num.bins=10) {
  bps <- find.bins(x, num.bins)
  xbin <- findInterval(x, bps)
  binlab <- label.bins(x, xbin)
  factor(xbin, labels=binlab, ordered=TRUE)
}

#' Find breakpoints for binning numeric values
#'
#' @param x data to be binned
#' @param num.bins number of bins to aim for
#'
#' @examples
#' x <- rpois(100, 10)
#' bins <- find.bins(x)
#' x.bin <- findInterval(x, bins)
#'
#'
#' @seealso \code{\link{label.bins}} for bin labels suitable for a legend
#' @seealso \code{\link{bin.ints}} for generating a factor with labels
#' @export
find.bins <- function(x, num.bins=10) {
  bins <- NULL
  x.table <- table(x)
  names(x.table) <- NULL
  x.levels <- sort(unique(x))
  x.levels <- (x.levels + c(x.levels[-1], 1+max(x)))/2

  i <- 1
  while ( length(bins) < (num.bins-1)  & i <= length(x.table)) {
    if ( sum(x.table[1:i])/sum(x.table) > 1/(num.bins-length(bins)) ) {
      i <- max(1, i - 1)
      bins <- c(bins, x.levels[i])
      x.table <- x.table[-(1:i)]
      x.levels <- x.levels[-(1:i)]
      i <- 1
    } else {
      i <- i + 1
    }
  }
  bins <- c(bins, max(x)+1)
  return (bins)
}

#' Label bins generated by \code{find.bins()}
#'
#' @param x data to be binned
#' @param bin binned data
#' @param greedy (default TRUE) whether to include in labels values of x which
#' may not appear in the data. e.g. instead of \code{0, 1, 2-3, 5-6} we return
#' \code{0, 1, 2-4, 5-6}
#'
#' @examples
#' x <- rpois(100, 10)
#' bins <- find.bins(x)
#' x.bin <- findInterval(x, bins)
#' bin.labels <- label.bins(x, x.bin)
#'
#' @seealso \code{\link{find.bins}} for determining bin breakpoints
#' @seealso \code{\link{bin.ints}} for generating a factor with labels
#' @export
label.bins <- function(x, bins, greedy=TRUE) {
  if ( missing(bins)  ) {
    x.bins <- find.bins(x)
    bins <- findInterval(x, x.bins)
  } else if ( length(bins) == 1 && is.numeric(bins) ) {
    x.bins <- find.bins(x, bins)
    bins <- findInterval(x, x.bins)
  } else if  ( length(bins) != length(x) ) {
    stop('x and bins must have same length.')
  }

  x.ranges <- simplify2array(tapply(x, bins, range))

  if ( greedy && min(diff(sort(unique(x)))) >= 1 )
    x.ranges[2, -ncol(x.ranges)] <- x.ranges[1, -1]-1

  apply(x.ranges, 2, function (r)
    if (diff(r)) paste0(r[1], if (r[2]==max(x)) '+' else paste0('-', r[2])) else r[1]
  )
}

#' @export
gw.snp.pos <- function(chromosome, position, spacing=0.1) {
  chr.order <- gtools::mixedsort(unique(chromosome))
  snp.order <- order(match(chromosome, chr.order), position)

  co <- match(chromosome[snp.order], chr.order)
  po <- position[snp.order]

  chr.ranges <- do.call(rbind, tapply(po, co, range))
  rownames(chr.ranges) <- chr.order
  chr.sizes <- apply(chr.ranges, 1, diff)
  space <- mean(chr.sizes)*spacing
  chr.bounds <- unname(cumsum(c(0, chr.sizes+spacing)))

  chr.offsets <- chr.bounds[1:nrow(chr.ranges)] - chr.ranges[, 1]

  gwpos <- unname(chr.offsets[co] + po)
  gwpos[snp.order] <- gwpos

  attr(gwpos, 'chr.names') <- chr.order
  attr(gwpos, 'chr.bounds') <- chr.bounds

  class(gwpos) <- 'gwpos'

  return (gwpos)
}

#' @export
`[.gwpos` <- function(x, i, ...) {
  attrs <- attributes(x)
  out <- unclass(x)
  out <- out[i]
  attributes(out) <- attrs
  out
}

#' @export
gwaxis <- function(names, bounds, ax=1) {
  midpts <- (bounds[-1] + bounds[-length(bounds)])/2
  axis(ax, bounds, labels=FALSE)
  axis(ax, midpts, labels=names, lwd=0)
}

#' @export
plot.gwpos <- function (x, y=NULL, xlab=NULL, ylab=NULL, xaxt=NULL, ...) {

  if ( missing(xlab) ) xlab <- deparse(substitute(x))
  if ( missing(ylab) ) ylab <- deparse(substitute(y))

  plot.default(x, y, xlab=xlab, ylab=ylab, xaxt='n', ...)
  if ( missing(xaxt) || xaxt != 'n')
    gwaxis(attr(x, 'chr.names'), attr(x, 'chr.bounds'))
}


# Bifidobacterium-Faecalibacterium data from MMODES Config
library(phyloseq)

# read otu and mapping table
phyloObject_datafile <- paste('data.normAndDist_definitiveClustering_BifFae.RData', sep = "")
load(phyloObject_datafile)

# Rename clusters for clarity
levels(sample_data(data.norm)$cluster) <- c("dysbiosis","risky","healthy")

# the set of perturbations
# rename perturbations field, for clarity
sample_data(data.norm)$diet <- as.character(sample_data(data.norm)$Perturbations)
Perturbations <- c('diet') # Only 1 perturbation, with different values

# sample attribute for time points
stepVar <- "time"

# sample attribute for subject
subjectVar <- "subject"

# Associate perturbation to the sample it results in, rather than to the state where it is applied. To be the same than in experimental sampling, where the mapping value of the perturbations is associated to the sample after the perturbation was applied.
for(subject in unique(get_variable(data.norm,subjectVar))){
  subject.data <- phyloSubset(data.norm, subjectVar, subject)
  vectPert <- NULL
  vectPert <- get_variable(subject.data,'diet')
  newVecPert <- c('NA',vectPert[1:(length(vectPert)-1)])
  sample_data(data.norm)[sample_names(subject.data), "diet"] <- newVecPert
} # end-for move perturbation

concMetabolite <- function(phyloObj,subjectVar, subject, met){
  subject.data <- phyloSubset(phyloObj, subjectVar, subject)
  # concentrations <- get_variable(subject.data,met) # vector
  concentrations <- sample_data(subject.data)[,c(met)] # sample_data structure
  return(concentrations)
}

########################################################
### ANALYSIS OF METABOLOME CHANGES DUE TO PERTURBATIONS
########################################################
# Function get_iniMedium
  # What need to know the initial concentration of other metabolites different from butyrate (we do not know if their initial concentration is 0), to substract the initial concentration in the medium. Time=0 is not available (removed in MMODEStoMDPbiome procedure). So, to take from a text file, such as initial_medium.tsv, with column 1: name of metabolite and column 2: initial concentration in mM.
get_iniMediumTable <- function(phylo, fileMedium='initial_concentration_metabolites.tsv'){
  firstMet=1
  lastMet=(grep('Perturbations',sample_variables(phylo)))-1
  metNameList=sample_variables(data.norm)[firstMet:lastMet]
  iniMediumTable_file=read.table(fileMedium,sep='\t',header=TRUE,stringsAsFactors=FALSE,row.names = 1)
  iniMediumTableTemp=data.frame(row.names=metNameList, check.names = FALSE, stringsAsFactors = FALSE)
  iniMediumTable=merge(iniMediumTableTemp,iniMediumTable_file,by="row.names",all.x=TRUE)
  iniMediumTable[is.na(iniMediumTable)] <- 0 # Fill-in with initial concentration=0 for metabolites not present in medium list
  row.names(iniMediumTable)=iniMediumTable[,1]
  iniMediumTable=subset(iniMediumTable,select=names(iniMediumTable)[2])
  return(iniMediumTable)
}

# Compute increase in fermentable products
initialMedium <- get_iniMediumTable(data.norm,'initial_concentration_metabolites_BifFae.tsv')
for (met in c('Butyrate','Lactate','Acetate')){
  metName <- sample_variables(data.norm)[grep(paste(met,".*_",sep=''),sample_variables(data.norm))]
  subjects <- unique(get_variable(data.norm,'subject'))
  for (isubject in subjects){
    vecConc <- concMetabolite(data.norm,subjectVar,isubject,metName)
    newVec <- as.numeric(rep(0,nsamples(vecConc)))
    for(pos in 2:(nsamples(vecConc))){
      newVec[pos] <- get_variable(vecConc[pos],metName) - get_variable(vecConc[pos-1],metName)
    } # end-for pos
    #print(vecConc)
    #print(newVec)
    sample_data(data.norm)[sample_names(vecConc), paste(met,'Increase',sep='')] <- newVec
  } # end-for isubject
  # Print computed values about change in metabolite concentration
  for (state in levels(sample_data(data.norm)$cluster)){
    #ss=subset_samples(data.norm,(cluster==state))
    ss=subset_samples(subset_samples(data.norm,(cluster==state)),diet!='NA')
    print(ss)
    #avg=mean(get_variable(ss,paste(met,'Increase',sep='')))
    all=get_variable(ss,paste(met,'Increase',sep=''))
    allPos=all[all>0]
    allNeg=all[all<0]
    avg=(mean(allPos)*length(allPos)/length(all))+(mean(allNeg)*length(allNeg)/length(all))
    print(paste(met,state,':',avg))
  } # end-for state
} # end-for met

# Compute ratio increase/decrease in ALL metabolites
initialMedium <- get_iniMediumTable(data.norm,'initial_concentration_metabolites_BifFae.tsv')
firstMet=1
lastMet=(grep('Perturbations',sample_variables(data.norm)))-1 # Compute position last metabolite in sample_variables
lastMet=lastMet-1 # The last one is Unnamed..129, giving error
for (posMet in seq(firstMet,lastMet)){
  metName <- sample_variables(data.norm)[posMet]
  print(metName)
  subjects <- unique(get_variable(data.norm,'subject'))
  for (isubject in subjects){
    vecConc <- concMetabolite(data.norm,subjectVar,isubject,metName)
    vecAbsInc <- as.numeric(rep(0,nsamples(vecConc)))
    vecRatio <- as.numeric(rep(0,nsamples(vecConc)))
    for(pos in 2:(nsamples(vecConc))){
      oldConc <- get_variable(vecConc[pos-1],metName)
      vecAbsInc[pos] <- get_variable(vecConc[pos],metName) - oldConc
      # When the concentration is the same than before: ratio=1 (conc_t1=conc_t2)
      # When previous oldConc=0: ratio=2.5 (it really increases)
      if(oldConc==0){
        vecRatio[pos] <- 2.5
      }else{
        vecRatio[pos] <- get_variable(vecConc[pos],metName)/oldConc
        if(vecRatio[pos]>2.5){ # To define a maximum
          vecRatio[pos] <- 2.5
        }
      } # if-oldConc
    } # end-for pos
    sample_data(data.norm)[sample_names(vecConc), paste('AbsIncrease_',metName,sep='')] <- vecAbsInc
    sample_data(data.norm)[sample_names(vecConc), paste('RatioIncrease_',metName,sep='')] <- vecRatio
  } # end-for isubject
  save(data.norm,file='data.norm_withAbsAndRatioIncreaseMetabolites.Rdata')
} # end-for met
# Write metabolite increase (abs and ratio) per sample
namesVar=sample_variables(data.norm)[grep('^AbsIncrease_*',sample_variables(data.norm))]
tabMetAbsInc=sample_data(data.norm)[,namesVar]
write.table(tabMetAbsInc,file='table_metaboliteIncrease_perSample_Abs.tsv',sep='\t',col.names=NA)
namesVar=sample_variables(data.norm)[grep('^RatioIncrease_*',sample_variables(data.norm))]
tabMetRatioInc=sample_data(data.norm)[,namesVar]
write.table(tabMetRatioInc,file='table_metaboliteIncrease_perSample_Ratio.tsv',sep='\t',col.names=NA)

# Compute averages (per perturbation and/or state) and write tables
dfAbsIncreasePert=data.frame(row.names=sample_variables(data.norm)[firstMet:lastMet])
dfRatioIncreasePert=data.frame(row.names=sample_variables(data.norm)[firstMet:lastMet])
dfAbsIncreaseState=data.frame(row.names=sample_variables(data.norm)[firstMet:lastMet])
dfRatioIncreaseState=data.frame(row.names=sample_variables(data.norm)[firstMet:lastMet])
dfAbsIncreaseStatePert=data.frame(row.names=sample_variables(data.norm)[firstMet:lastMet])
dfRatioIncreaseStatePert=data.frame(row.names=sample_variables(data.norm)[firstMet:lastMet])
dfRatioIncreaseList=list()
for(countList in 1:length(levels(sample_data(data.norm)$cluster))){
  dfRatioIncreaseList[[countList]]=data.frame(row.names=sample_variables(data.norm)[firstMet:lastMet])}
for (posMet in seq(firstMet,lastMet)){
  metName <- sample_variables(data.norm)[posMet]
  # Print computed values about ratio change in metabolite concentration, per PERTURBATION
  for (pert in unique(sample_data(data.norm)$diet)){
    if(pert!='NA'){
      ss=subset_samples(subset_samples(data.norm,(diet==pert)),diet!='NA')
      avg=mean(get_variable(ss,paste('AbsIncrease_',metName,sep='')))
      dfAbsIncreasePert[metName,pert]=avg
      avg=mean(get_variable(ss,paste('RatioIncrease_',metName,sep='')))
      dfRatioIncreasePert[metName,pert]=avg
      #print(paste(metName,pert,':',avg))
    } # end-if no-NA
  } # end-for pert
  # Print computed values about ratio change in metabolite concentration, per STATE
  for (state in levels(sample_data(data.norm)$cluster)){
    #ss=subset_samples(data.norm,cluster==state)
    ss=subset_samples(subset_samples(data.norm,(cluster==state)),diet!='NA')
    avg=mean(get_variable(ss,paste('AbsIncrease_',metName,sep='')))
    dfAbsIncreaseState[metName,state]=avg
    avg=mean(get_variable(ss,paste('RatioIncrease_',metName,sep='')))
    dfRatioIncreaseState[metName,state]=avg
  } # end-for state
  # Print computed values about ratio change in metabolite concentration, per STATE AND PERTURBATION
  for (pert in unique(sample_data(data.norm)$diet)){
    if(pert!='NA'){
      #ss=subset_samples(data.norm,diet==pert)
      ssp=subset_samples(subset_samples(data.norm,(diet==pert)),diet!='NA')
      for (state in levels(sample_data(ssp)$cluster)){
        label=paste(pert,state,sep='_')
        ss=subset_samples(ssp,cluster==state)
        print(label)
        avg=mean(get_variable(ss,paste('AbsIncrease_',metName,sep='')))
        dfAbsIncreaseStatePert[metName,label]=avg
        avg=mean(get_variable(ss,paste('RatioIncrease_',metName,sep='')))
        dfRatioIncreaseStatePert[metName,label]=avg
      } # end-for state
    } # end-if no-NA
  } # end-for pert
  # Print computed values about ratio change in metabolite concentration, per PERTURBATION, BY INDEPENDENT STATE
  countList=1
  for (state in levels(sample_data(data.norm)$cluster)){
    ssp=subset_samples(subset_samples(data.norm,(cluster==state)),diet!='NA')
    for (pert in unique(sample_data(data.norm)$diet)){
      if(pert!='NA'){
        ss=subset_samples(subset_samples(ssp,(diet==pert)),diet!='NA')
        avg=mean(get_variable(ss,paste('RatioIncrease_',metName,sep='')))
        dfRatioIncreaseList[[countList]][metName,pert] = avg
      } # end-for pert
    } # end-if no-NA
    countList=countList+1
  } # end-for state
} # end-for met
write.table(dfAbsIncreasePert,file='dfMetabolitesAbsIncreasePert.tsv',sep='\t',col.names=NA)
write.table(dfRatioIncreasePert,file='dfMetabolitesRatioIncreasePert.tsv',sep='\t',col.names=NA)
write.table(dfAbsIncreaseState,file='dfMetabolitesAbsIncreaseState.tsv',sep='\t',col.names=NA)
write.table(dfRatioIncreaseState,file='dfMetabolitesRatioIncreaseState.tsv',sep='\t',col.names=NA)
write.table(dfAbsIncreaseStatePert,file='dfMetabolitesAbsIncreaseStatePert.tsv',sep='\t',col.names=NA)
write.table(dfRatioIncreaseStatePert,file='dfMetabolitesRatioIncreaseStatePert.tsv',sep='\t',col.names=NA)
countList=1
for (state in levels(sample_data(data.norm)$cluster)){
  write.table(dfRatioIncreaseList[[countList]],file=paste('dfMetabolitesRatioIncreasePert_',state,'.tsv',sep=''),sep='\t',col.names=NA)
  countList=countList+1
} # end-for
save(dfAbsIncreasePert,dfAbsIncreaseState,dfAbsIncreaseStatePert,dfRatioIncreasePert,dfRatioIncreaseState,dfRatioIncreaseStatePert,dfRatioIncreaseList,file='dfPerPertAndOrState.Rdata')

# PLOT HEATMAPS
############################################################################
### Function plot.heatmap.metabolite.x.perturbation
############################################################################
# Plot a heatmap with metabolite in rows and perturbations in columns, with
# the ratio average of increase of concentration of metabolite.
# Args:
#   dfIn: data frame with average ratios
#   metDelete: vector of metabolite names to not shown in plot
#   title: plot title
plot.heatmap.metabolite.x.perturbation  <- function(dfIn, metDelete,title){
  # Colors: https://cran.r-project.org/web/packages/viridis/vignettes/intro-to-viridis.html
  library(reshape2)
  library(viridis)
  # Remove metabolites
  dfHeatmap=data.frame()
  dfHeatmap=dfIn[!(row.names(dfIn) %in% metDelete),]
  # Rename metabolites
  dfHeatmap$met=unlist(lapply(rownames(dfHeatmap), function(x) gsub('_.*','',x)))
  df=melt(dfHeatmap,id=6,measure.vars=1:5)
  colnames(df)=c('metabolite','perturbation','IncConcRatio')
  pdf(paste('heatmap_',title,'.pdf',sep=''),width=3.5,height=7)
  p <- ggplot(df, aes(x = perturbation, y = metabolite, fill = IncConcRatio)) +
    geom_tile() +
    scale_fill_viridis(discrete=FALSE,option='plasma',direction=-1) +
    #scale_fill_gradient(low="white", high="blue") +
    theme(axis.text.x = element_text(angle = 270, hjust = 1)) +
    theme(legend.position="top") +
    ggtitle(title)
  print(p)
  dev.off()
} # end-function plot.heatmap.metabolite.x.perturbation

############################################################################
### Function plot.heatmap.metabolite.x.perturbation.horizontal
############################################################################
# The same as plot.heatmap.metabolite.x.perturbation but in horizontal
plot.heatmap.metabolite.x.perturbation.horizontal  <- function(dfIn, metDelete,title,legendPosition='top'){
  # Colors: https://cran.r-project.org/web/packages/viridis/vignettes/intro-to-viridis.html
  library(reshape2)
  library(viridis)
  # Remove metabolites
  dfHeatmap=data.frame()
  dfHeatmap=dfIn[!(row.names(dfIn) %in% metDelete),]
  # Rename metabolites
  dfHeatmap$met=unlist(lapply(rownames(dfHeatmap), function(x) gsub('_.*','',x)))
  df=melt(dfHeatmap,id=6,measure.vars=1:5)
  colnames(df)=c('metabolite','perturbation','IncConcRatio')
  pdf(paste('heatmap_',title,'_horizontal.pdf',sep=''),width=7,height=3.5)
  p <- ggplot(df, aes(x = perturbation, y = metabolite, fill = IncConcRatio)) +
    geom_tile() +
    coord_flip() +
    scale_fill_viridis(discrete=FALSE,option='plasma',direction=-1) +
    #scale_fill_gradient(low="white", high="blue") +
    theme(axis.text.x = element_text(angle = 270, hjust = 1)) +
    theme(legend.position=legendPosition) +
    ggtitle(title)
  print(p)
  dev.off()
} # end-function plot.heatmap.metabolite.x.perturbation.horizontal

# 1.- Filtering:
# 1.1.- Metabolites with 0 concentration in all samples --> 2.5 ratio
met0Conc=c()
for (posMet in seq(firstMet,lastMet)){
  metName <- sample_variables(data.norm)[posMet]
  if(sum(get_variable(data.norm, metName))==0){
    met0Conc=c(met0Conc,metName)
  }
} # 72 metabolites
# 1.2.- Metabolites with the same concentration in all samples --> 1 ratio
metConstant=c()
for (posMet in seq(firstMet,lastMet)){
  metName <- sample_variables(data.norm)[posMet]
  if(mean(get_variable(data.norm, metName))==get_variable(data.norm,metName)[1]&&(sd(get_variable(data.norm, metName))==0)){
    metConstant=c(metConstant,metName)
  }
} # 89, including also met0Conc
metDeleteHeatmap=union(met0Conc,metConstant)
metName <- sample_variables(data.norm)[grep(paste(met,".*_",sep=''),sample_variables(data.norm))]

# All samples
plot.heatmap.metabolite.x.perturbation(dfRatioIncreasePert, metDeleteHeatmap,'AllSamples')
plot.heatmap.metabolite.x.perturbation(dfRatioIncreaseList[[1]], metDeleteHeatmap,'Dysbiosis')
plot.heatmap.metabolite.x.perturbation(dfRatioIncreaseList[[2]], metDeleteHeatmap,'Risky')
plot.heatmap.metabolite.x.perturbation(dfRatioIncreaseList[[3]], metDeleteHeatmap,'Healthy')

colnames(dfRatioIncreasePert)=c('Inulin','FOS','Starch','Pro-high','Pro-low','met')
plot.heatmap.metabolite.x.perturbation.horizontal(dfRatioIncreasePert, metDeleteHeatmap,'',legendPosition='bottom')
colnames(dfRatioIncreaseList[[1]])=c('Inulin','FOS','Starch','Pro-high','Pro-low')
colnames(dfRatioIncreaseList[[2]])=c('Inulin','FOS','Starch','Pro-high','Pro-low')
colnames(dfRatioIncreaseList[[3]])=c('Inulin','FOS','Starch','Pro-high','Pro-low')
plot.heatmap.metabolite.x.perturbation.horizontal(dfRatioIncreaseList[[1]], metDeleteHeatmap,'A   Dysbiosis',legendPosition='bottom')
plot.heatmap.metabolite.x.perturbation.horizontal(dfRatioIncreaseList[[2]], metDeleteHeatmap,'C   Risky',legendPosition='bottom')
plot.heatmap.metabolite.x.perturbation.horizontal(dfRatioIncreaseList[[3]], metDeleteHeatmap,'B   Healthy',legendPosition='bottom')

#################################################
### FIGURES OF COMPARISON WITH Bauer et al. 2018
#################################################
# Plot to compare experimental vs simulated data
# Fig. 3b from Bauer2018: barplot experimental vs simulated

############################################################################
### Function get.mean.met.conc.state
############################################################################
# Get average concentration of a given metabolite in all samples of a
# given state (not ratio, but concentration in mM)
# Args:
#   physeq: phyloseq object with all samples
#   state: state/cluster to select the samples (e.g. dysbiosis, healthy, etc.)
#   met: metabolite simple name, not complete name with formula
get.mean.met.conc.state <- function(physeq,state,met){
  avg=0
  #ss=subset_samples(physeq,cluster==state)  # subset_samples does not work in a loop (https://github.com/joey711/phyloseq/issues/752)
  ss=prune_samples(sample_data(physeq)$cluster==state,physeq)
  metName <- sample_variables(ss)[grep(paste('^',met,sep=''),sample_variables(ss))]
  if(length(metName)>0){
    avg=mean(get_variable(ss,metName))
  }
  return(avg)
} # end-funcion get.mean.met.conc.state

array3d <- array(0,dim=c(5,3,3),dimnames=list(list('Butyrate','Propionate','Isobutyrate','L.Lactate','Acetate'), list('exp','Bauer','MDPbiomeGEM'), list('control','case','ratio')))

# 1) Experimental values (metabolite concentrations) from: Table2 (control) and Table6/column 2 (disease) from Hove, H. & Mortensen, P. B. Influence of intestinal inflammation (IBD) and small and large bowel length on fecal short-chain fatty acids and lactate. Dig. Dis. Sci. 40, 1372–1380 (1995).
array3d[,'exp','control']=c(11,15,2,2,60)
array3d[,'exp','case']=c(7,11,1,6,38)
array3d[,'exp','ratio']=array3d[,'exp','control']/array3d[,'exp','case']

# 2) Bauer2018 simulated data from Fig.3b, grey bar, by-hand
# Only ratio available.
array3d[,'Bauer','ratio']=c(3.45,3.51,1.45,0.44,1.53)

# 3) MDPbiomeGEM simulated data
for(met in c('Butyrate','Propionate','Isobutyrate','L.Lactate','Acetate')){
  array3d[met,'MDPbiomeGEM','control']=get.mean.met.conc.state(data.norm,'healthy',met)
  array3d[met,'MDPbiomeGEM','case']=get.mean.met.conc.state(data.norm,'dysbiosis',met)
} # end-for
array3d[,'MDPbiomeGEM','ratio']=array3d[,'MDPbiomeGEM','control']/array3d[,'MDPbiomeGEM','case']

df=melt(array3d[,,'ratio'])
colnames(df)=c('metabolite','source','value')
pdf('barplot_expVsSimulated_MetRatioCtrlCase.pdf',height=3.5)
p <- ggplot(df, aes(x = metabolite, y = value, fill = source)) +
  geom_bar(stat='identity', position='dodge', color='black') +
  scale_fill_manual(values = c("#ff9900", "grey", "blue3")) +
  geom_hline(yintercept = 1, linetype=2, size=1) +
  ylab('Controls to CD patients ratio') +
  theme_bw() +
  theme(legend.position="top", legend.direction="horizontal",  legend.title = element_blank())
print(p)
dev.off()

# Only butyrate and Acetate
df2=subset(df,metabolite=='Butyrate' | metabolite=='Acetate')
pdf('barplot_expVsSimulated_MetRatioCtrlCase_onlyButAct.pdf',height=3.5,width=3)
p2 <- ggplot(df2, aes(x = metabolite, y = value, fill = source)) +
  geom_bar(stat='identity', position='dodge', color='black') +
  scale_fill_manual(values = c("#ff9900", "grey", "blue3")) +
  geom_hline(yintercept = 1, linetype=2, size=1) +
  ylab('Controls to CD patients ratio') +
  #ylab('Healthy to Dysbiosis patients ratio') +
  theme_bw() +
  theme(legend.position="top", legend.direction="horizontal",  legend.title = element_blank())
print(p2)
dev.off()

#############################
# Plot to compare metabolite concentration distribution, Bauer vs MDPbiomeGEM, per state and treatment
# boxplot
# To compare with Fig.2e-5e Bauer2018 (concentration (not ratio) in dysbiosis(not inulin), healthy and treatment (dysbiosis-inulin))

# To split which ones are following the treatment (diet='Inulin', cluster='dysbiosis') from those ones do not following it (diet!='Inulin', cluster='dysbiosis')
data.norm.temp=data.norm
ss=subset_samples(subset_samples(data.norm.temp,cluster=='dysbiosis'),diet=='Inulin')
ids=get_variable(ss,'id')
levels(sample_data(data.norm.temp)$cluster)=c(levels(sample_data(data.norm.temp)$cluster),"treatment")
sample_data(data.norm.temp)[sample_names(ss), "cluster"] <- rep("treatment",nsamples(ss))
# Filter out metabolites to not show in the distribution: Constant and Conc=0. Saved above in 'metDeleteHeatmap'
metNames <- sample_variables(data.norm.temp)[seq(firstMet,lastMet)]
metNames <- metNames[!(metNames %in% metDeleteHeatmap)]
data.norm.temp=subset_samples(data.norm.temp,cluster!='risky')
df=as.data.frame(sample_data(data.norm.temp))
df=subset(df,select=c(metNames,'cluster'))
names(df)=unlist(lapply(names(df), function(x) gsub('_.*','',x))) # Rename metabolites
# Convert to ggplot
dfBoxplot=melt(df,id='cluster')
rm(data.norm.temp,df)
colnames(dfBoxplot)=c('state','metabolite','concentration')
stateOrder=c("dysbiosis","treatment","healthy")
dfBoxplot[,'state'] <- factor(dfBoxplot[,'state'], levels = stateOrder)

pdf('boxplot_metabolitePerStateAndTreatment_MDPbiomeGEM.pdf',width=14)
p <- ggplot(dfBoxplot, aes(x=metabolite, y=concentration, color=state)) +
  geom_boxplot(lwd=0.5, outlier.size = 0.3) +
  ylim(0,5) + # limit to metabolite concentration < 5 mM
  scale_color_manual(values = c("red", "purple", "dodgerblue2")) +
  theme_bw() +
  theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
  theme(text = element_text(size=16), legend.position=c(0.95,0.91), legend.title = element_blank())
print(p)
dev.off()

dfBoxplot3=dfBoxplot
dfBoxplot3[,'concentration'] = log(1+dfBoxplot[,'concentration'])
pdf('boxplot_metabolitePerStateAndTreatment_MDPbiomeGEM_logPlus1.pdf',width=14)
p <- ggplot(dfBoxplot3, aes(x=metabolite, y=concentration, color=state)) +
  geom_boxplot(lwd=0.8, outlier.size = 1.2) +
  ylim(0,1) + # limit to metabolite concentration < 1 mM
  scale_color_manual(values = c("red", "purple", "dodgerblue2")) +
  labs(y="log(concentration)+1") +
  theme_bw() +
  theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
  theme(text = element_text(size=24), legend.position=c(0.93,0.89), legend.title = element_blank())
print(p)
dev.off()

# Select a subset of metabolites
dfBoxplot2=subset(dfBoxplot,metabolite %in% c('Butyrate','Acetate'))
pdf('boxplot_metabolitePerStateAndTreatment_MDPbiomeGEM_only2met.pdf',width=5)
p <- ggplot(dfBoxplot2, aes(x=metabolite, y=concentration, color=state)) +
  geom_boxplot(lwd=1) +
  #ylim(0,5) +
  scale_color_manual(values = c("red", "purple", "dodgerblue2")) +
  theme_bw() +
  theme(text = element_text(size=24), legend.position=c(0.8,0.91), legend.title = element_blank())
print(p)
dev.off()

# To compute the ratio of increase per independent state
# Print computed values about ratio change in metabolite concentration, per perturbation
for (state in levels(sample_data(data.norm)$cluster)){
  ss=subset_samples(data.norm,cluster==state)
  dfRatioIncreaseState=data.frame(row.names=sample_variables(data.norm)[firstMet:lastMet])
  for (posMet in seq(firstMet,lastMet-1)){
    # (lastMet-1): Because there isn't RatioIncrease_Unnamed..129 (the last attribute)
    metName <- sample_variables(data.norm)[posMet]
    avg=mean(get_variable(ss,paste('RatioIncrease_',metName,sep='')))
    dfRatioIncreaseState[metName,'RatioIncrease']=avg
    #print(paste(metName,pert,':',avg))
  } # end-for met
  write.table(dfRatioIncreaseState,file=paste('dfRatioIncreaseState_',state,'.tsv',sep=''),sep='\t',col.names=NA)
} # end-for state


##############################################################################
# Get prediction curves under each model
##############################################################################
tmp <- 0
if(tmp){
	chrp_gfasc <- subByModel(chrp, "MU", "GFASC")
	head(chrp_gfasc) %>% data.frame()

	full_auc_dat <- subWrapper(chrp, sim=F)
	full_auc_dat %>%
		arrange(group, Category.x, ntile) %>%
		filter(Category.x=="GC_AT") %>%
		tail() %>%
		data.frame()

	outdat <- chrp %>%
		mutate_(mutmp="MU") %>%
		group_by(Category.x) %>%
		arrange(desc(mutmp)) %>%
		mutate(prop=cumsum(OBS)/sum(OBS)) %>%
		# dplyr::select(-mutmp) %>%
		# arrange_(mucol, "prop") %>%
		# mutate(mutmp=mucol, ntile=dense_rank(mutmp), group=groupname) %>%
		mutate(ntile=min_rank(desc(mutmp)), group="GFASC") %>%
		dplyr::select(-mutmp)
}

pred_curves <- 0
if(pred_curves){
	full_auc_dat <- subWrapper(chrp, sim=T)

	# Get table of AUC for each mutation type/model combo
	full_auc2 <- full_auc_dat %>%
	  group_by(group, Category.x) %>%
	  summarise(AUC=sum(prop)/n()) %>%
	  spread(Category.x, AUC)

	newrow <- c("Relative change in AUC", (full_auc2[5,-1]-0.5)/(full_auc2[3,-1]-0.5))
	full_auc2 <- data.frame(rbind(as.matrix(full_auc2), newrow))

	roc_plotdat <- full_auc_dat[sample(nrow(full_auc_dat), .1*nrow(full_auc_dat)),] %>%
		group_by(group, Category.x, ntile) %>%
		summarise(prop=min(prop), n=mean(n))

	# Plot everything together
	plotROC(roc_plotdat,
		paste0(parentdir, "/images/pseudo_roc_curves_all.png"))

	# Plot 3-mers only
	roc_plotdat_seq <- roc_plotdat %>%
		filter(grepl("^ERV 3", group))
	plotROC(roc_plotdat_seq,
		paste0(parentdir, "/images/pseudo_roc_curves_seq_3.png"))

	# Plot 3-mers vs 5-mers
	roc_plotdat_seq <- roc_plotdat %>%
		filter(grepl("^ERV 5|^ERV 3", group))
	plotROC(roc_plotdat_seq,
		paste0(parentdir, "/images/pseudo_roc_curves_seq_5_3.png"))

	# Plot 7-mers vs 5-mers vs 3-mers
	roc_plotdat_seq <- roc_plotdat %>%
		filter(grepl("^E", group))
	plotROC(roc_plotdat_seq,
		paste0(parentdir, "/images/pseudo_roc_curves_seq.png"))

	# Plot common vs A&V
	fig_a_dat <- roc_plotdat %>%
	  filter(grepl("^A|B", group))
	plotROC(fig_a_dat,
		paste0(parentdir, "/images/av_vs_common_roc.png"))

	# Plot common vs ERVs
	fig_b_dat <- roc_plotdat %>%
	  filter(grepl("^E|B", group))
	plotROC(fig_b_dat,
		paste0(parentdir, "/images/common_vs_erv_roc.png"))

	# Plot ERVs vs logit
	fig_k_dat <- roc_plotdat %>%
		filter(grepl("^G|^E", group))
	plotROC(fig_k_dat,
		paste0(parentdir, "/images/erv_vs_logit_roc.png"))

	# Plot ERVs vs logit vs simulated max
	fig_k2_dat <- roc_plotdat %>%
		filter(grepl("^G|^E|^m", group))
	plotROC(fig_k2_dat,
		paste0(parentdir, "/images/erv_vs_logit_max_roc.png"))
}

##############################################################################
# ROC on 7-mers with max contrast between ERVs and polymorphisms
##############################################################################
maxc_roc <- 0
if(maxc_roc){
	maxc <- read.table(paste0(parentdir, "/maxc_7bp.txt"), header=T, stringsAsFactors=F)
	maxc$Category <- gsub("cpg_", "", maxc$Category2)
	chrp_maxc <- chrp %>%
	  dplyr::filter(paste0(SEQ, ".", Category.x) %in%
									paste0(maxc$Sequence, ".", maxc$Category))

	maxc_auc_dat <- subWrapper(chrp_maxc, sim=F)

	maxc_auc <- maxc_auc_dat %>%
	  group_by(group, Category.x) %>%
		# filter(grepl("^B|^E", group)) %>%
	  summarise(AUC=sum(prop)/n()) %>%
	  spread(Category.x, AUC)

	newrow<-c("Relative change in AUC", (maxc_auc[2,-1]-0.5)/(maxc_auc[1,-1]-0.5))
	maxc_auc <- data.frame(rbind(as.matrix(maxc_auc), newrow))

	maxc_plotdat <- maxc_auc_dat[sample(nrow(maxc_auc_dat), .1*nrow(maxc_auc_dat)),]

	# fig_max_dat <- maxc_plotdat %>%
	# 	filter(grepl("^E|B", group))
	# Plot all models under max contrast
	fig_max_dat <- maxc_auc_dat %>%
		filter(grepl("^E|^B", group))
	plotROC(fig_max_dat, paste0(parentdir, "/images/pseudo_roc_curves_maxc.png"))
}

# Additional max contrast analyses, with features
maxc_extra1 <- 0
if(maxc_extra1){
	coefs <- read.table(
		paste0(parentdir, "/output/logmod_data/coefs/coefs_full.txt"),
		header=F, stringsAsFactors=F)

	names(coefs) <- c("Cov", "Est", "SE", "Z", "pval", "Sequence", "Category")

	# coefs$qval <- p.adjust(coefs$pval)
	splitCoefs <- function(x){
	  coefs %>%
	    # filter(Cov==x, pval<1e-08) %>%
			filter(Cov==x) %>%
			# mutate(qval=p.adjust(pval)) %>%
			# filter(qval<0.1) %>%
			mutate(ntile=ntile(pval, 100)) %>%
			filter(ntile<=10) %>%
			# filter(ntile<=25 | ntile>=75) %>%
			# filter(exp(Est)>1.5 | exp(Est)<0.67) %>%
	    dplyr::select(Sequence, Category)
	}

	coef_split <- lapply(unique(coefs$Cov), function(x) splitCoefs(x))
	names(coef_split) <- unique(coefs$Cov)

	matchMotifs <- function(x) {
	  chrp %>%
			# ungroup() %>%
			# mutate(Category.x=as.character(Category.x)) %>%
	    dplyr::filter((substr(SEQ,1,7) %in% x$Sequence) & (Category.x %in% x$Category))
	}

	maxc_feat <- data.frame(Sequence=plotdat$Sequence,
		Category=as.character(gsub("cpg_", "", plotdat$Category)))
	chrp_maxc_features<-matchMotifs(maxc_feat)
	maxc_auc_feat <- subWrapper(chrp_maxc_features, sim=F)
	cov_auc<-aucCalc(maxc_auc_feat)

	chrp_maxc_features <- lapply(maxc_feat, function(x) matchMotifs(x))

	maxc_auc_feat <- lapply(chrp_maxc_features, function(x) subWrapper(x, sim=F))
	# test <- bind_rows(maxc_auc_feat, .id="id")

	aucCalc <- function(x){
	  x %>%
	    dplyr::filter(grepl("^E|^G", group)) %>%
	    group_by(group, Category.x) %>%
	    summarise(AUC=1-sum(prop)/n())
	    # spread(Category.x, AUC)
	}

	cov_auc <- lapply(maxc_auc_feat, function(x) aucCalc(x))
	cov_auc_dat <- bind_rows(cov_auc, .id="id")
	cov_auc_dat <- cov_auc_dat[complete.cases(cov_auc_dat),]

	cov_auc_dat <- cov_auc_dat %>% filter(!grepl("Intercept|DP", id))

	ggplot(cov_auc_dat, aes(x=id, y=AUC, colour=group, fill=group, group=group))+
	  geom_bar(stat="identity", position="dodge")+
		# geom_point()+
	  facet_wrap(~Category.x)+
	  coord_cartesian(ylim=c(0.5, 0.85))+
		coord_flip()+
		# theme_bw()
	ggsave(paste0(parentdir, "/images/test_bar.png"))

	cov_erv <- cov_auc_dat %>% filter(grepl("^E", group))
	cov_logit <- cov_auc_dat %>% filter(!grepl("^E", group))
	cov_logit$diff <- (cov_logit$AUC-0.5)/(cov_erv$AUC-0.5)-1
	# t.test(cov_logit$diff)

	cov_logit$dir <- ifelse(cov_logit$diff<=0, "lower", "higher")
	ggplot(cov_logit, aes(x=id, y=diff, colour=dir, fill=dir))+
		geom_bar(stat="identity", position="dodge")+
		scale_fill_brewer(palette="Set1")+
		scale_colour_brewer(palette="Set1")+
		# geom_point()+
	  facet_wrap(~Category.x)+
	  coord_cartesian(ylim=c(-0.15, 0.15))+
		coord_flip()+
		geom_hline(yintercept=0, linetype="dashed")+
		# xlab("AUC_[]")+
		theme_bw()
	ggsave(paste0(parentdir, "/images/diff_bar.png"), height=6, width=12)
}

maxc_extra2 <- 0
if(maxc_extra2){
	maxc_sum <- maxc_auc_dat %>%
		# mutate(SEQ3=substr(SEQ,3,5))%>%
		# group_by(Category.x) %>%
		group_by(Category.x, SEQ) %>%
		summarise(n=sum(OBS)) %>%
		dplyr::filter(n>0)

	# chrp_maxc2 <- merge(maxc_sum[,1:2], chrp_maxc, by=c("Category.x"))
	chrp_maxc$SEQ3 <- substr(chrp_maxc$SEQ, 3, 5)

	chrp_maxc2 <- merge(maxc_sum[,1:2], chrp_maxc, by=c("Category.x", "SEQ"))
	# chrp_maxc2 <- merge(maxc_sum[,1:2],
		# chrp_maxc[!grepl("^gonl", chrp_maxc$ID),], by=c("Category.x", "SEQ"))
	maxc_auc_dat2 <- subWrapper(chrp_maxc2, sim=F)

	maxc_auc2 <- maxc_auc_dat2 %>%
	  # group_by(group, Category.x) %>%
		group_by(group, Category.x, SEQ) %>%
	  summarise(AUC=1-sum(prop)/n()) #%>%
	  #spread(Category.x, AUC)

	# maxc_auc2 %>% arrange(Category.x, group) %>% data.frame()
	maxc_auc2 %>% arrange(Category.x, SEQ, group) %>% head(20)
	maxc_auc2 %>% group_by(group) %>% summarise(AUC=mean(AUC))
	maxc_test<-maxc_auc2 %>%
		group_by(group, Category.x) %>%
		# summarise(AUC=mean(AUC)) %>%
		arrange(Category.x) %>%
		spread(group, AUC) %>%
		data.frame()

	names(maxc_test) <- c("Category.x", "SEQ", "AV", "BP", "ERV", "GFASC")
	maxc_test$diff <- maxc_test$ERV-maxc_test$BP
	maxc_test %>% group_by(Category.x)%>% summarise(diff=mean(diff), n=n())
	# not by seq
	# maxc_auc <- maxc_auc_dat %>%
	#   group_by(group, Category.x) %>%
	#   summarise(AUC=1-sum(prop)/n()) %>%
	#   spread(Category.x, AUC)
}

##############################################################################
# ROC by GoNL individual
##############################################################################
gonl_ind <- 0
if(gonl_ind){
	nperm<-258
	# aucperm<-rep(0,nperm)
	# aucperm3<-aucperm

	ids <- unique(chrpfdnm$ID)[grepl("gonl", unique(chrpfdnm$ID))]
	numind <- length(ids)
	# aucind<-rep(0, numind)
	aucind3 <- aucind

	auc_ind<-data.frame()
	for(i in 1:nperm){
		### Run permutations
		# cat("Permuting AUC", "(", i, "of", nperm, ")...\n")
		ndnms<-round(rnorm(1, 42.7, 10.3), 0)
		nsamp<-1000000

		curid<-ids[i]
		### Get empirical AUC
		cat("Calculating AUC for", curid, "(", i, "of", numind, ")...\n")
		datid<-chrpfdnm %>% filter(ID==curid)

		tmpdat<-rbind(datid, chrpfa) %>% arrange(MU)
		tmp_auc_dat <- subWrapper(tmpdat, sim=F)

		tmp_auc <- tmp_auc_dat %>%
		  group_by(group, Category.x) %>%
		  summarise(AUC=1-sum(prop)/n()) %>%
		  spread(Category.x, AUC)
		tmp_auc$ID <- curid

		auc_ind<-rbind(auc_ind, data.frame(tmp_auc))
	}

	# ggplot(auc_ind, aes(x=group, y=))
	# mapply(plotROC, maxc_auc_feat,
		# paste0(parentdir, "/images/", seq_along(max_auc_feat), "_roc.png"))
}


p_local <- function(press, topo, temp) {
    .Call('biometeoR_p_local', PACKAGE = 'biometeoR', press, topo, temp)
}


#Emera Tagging

p = bio.snowcrab::load.environment()

dn = file.path(project.datadirectory('bio.snowcrab'),'data','tagging','Emera')

if(redo.base.data) {}
        a = dir(dn)
        a = a[grep('crab',a)]

        out = NULL
                for(i in a) {
                         h = read.csv(file.path(dn,i),header=T)
                         out = rbind(h,out)
                        }

        names(out) = tolower(names(out))
        out$dt = strptime(out$datetime, format= "%m/%d/%Y %H:%M")

        #N Animals detects
                        b= unique(out$transmitter) #58
                         lonlat2planar(oo)
        #N Detects per anmimal
                        a = aggregate(detectedid~transmitter,data=out,FUN=length)

        #each animal Filter to reasonable speeds
        filt.data = NULL
        #hpe is the error of the data points <8 is good #need to implement
        for(i in 1:length(b)) {
                                oo = out[which(out$transmitter==b[i]),]
                        oo = oo[order(oo$dt),]
                        dt=1
                        thres = 15
                        oo1 = oo
                        while(dt==1) {
                                oo1$dist = c(NA,distVincentyEllipsoid(p1=oo1[1:(nrow(oo1)-1),c('lon','lat')],p2=oo1[2:(nrow(oo1)),c('lon','lat')]))
                                oo1$time = c(NA,oo1[2:(nrow(oo1)),'dt']-oo1[1:(nrow(oo1)-1),'dt'])
                                oo1$speed  = oo1$dist/oo1$time # m / min
                                if(any(oo1$speed>thres,na.rm=T)) {
                                        io = which.max(oo1$speed)
                                        oo1 = oo1[-io,]
                                } else {
                                 dt=0
                                }
                            }
                hist(oo1$speed,'fd',main=b[i])
        savePlot(file.path(dn,paste('hist.of.speed',b[i],"png",sep=".")),type='png')

        filt.data = rbind(filt.data,oo1)

        project.library( 'aegis')

        xx = range(oo$lon)
        yy = range(oo$lat)
        xx[1] = xx[1]-0.02; xx[2] = xx[2] +0.02
        yy[1] = yy[1]-0.02; yy[2] = yy[2] +0.02

        makeMap(xlim=xx,ylim=yy,addEmera=T,addSummerStrata=F)
                        with(oo,lines(lon,lat,type='l',lwd=0.6))
                        with(oo1,lines(lon,lat,type='l',lwd=0.6,col='green'))

        title(paste(b[i],'N days =', round(as.numeric(max(oo$dt)-min(oo$dt)[1]),1)        ))
        savePlot(file.path(dn,paste('tag',b[i],"png",sep=".")),type='png')
            }
     save(filt.data,file=file.path(dn,'filtered.movement.data.2015.rdata'))
        }
load(file=file.path(dn,'filtered.movement.data.2015.rdata'))

#Cumulative weighted distribution of movements
plot(1,1,xlim=c(0,15),ylim=c(0,1),type='n')
filt.data$round.speed = round(filt.data$speed*100)/100
ff = aggregate(time~round.speed+transmitter,data=filt.data,FUN=length)
ui = unique(ff$transmitter)
for(j in ui){
        w = ff[which(ff$transmitter == j),]
        w$cspeed = cumsum(w$time) / sum(w$time)
        lines(w$round.speed,w$cspeed,col=1)
}
hist()

#build a polygon covering the data
 ch = filt.data[chull(filt.data$lon,filt.data$lat),c('lon','lat')]
 fd = makePBS(filt.data[,c(-4,-5)],polygon=F)
 bdpoly = data.frame(PID=1,POS=1:4,X=c(min(ch$lon),min(ch$lon),max(ch$lon),max(ch$lon)),Y=c(min(ch$lat),max(ch$lat),max(ch$lat),min(ch$lat)))
 pp = data.frame(PID=rep(1:100,each=4),POS=rep(1:4,times=100),Y=rep(c(bdpoly[1,'Y'],bdpoly[2,'Y'],bdpoly[2,'Y'],bdpoly[1,'Y']),times=100),X=c(min(ch$lon),min(ch$lon)),Xinc = c(0,0, rep(0.00023392,198)),XX = c(0,0,rep(1:99,each=4),100,100))
pp$X = pp$X+pp$Xinc*pp$XX

a = findPolys(fd,pp,maxRows=1300000)
 ff=  merge(fd,a,by='EID')
 a = unique(cbind(ff$transmitter,ff$PID))
 a = aggregate(transmitter~PID,data=a,FUN=length)
 barplot(a$transmitter)


# script can be executed with

library(readr)
library(ggplot2)
library(dplyr)
library(lubridate)
library(gganimate)

temps = read_csv("saxony-monthly-temperature.csv")

glimpse(temps)

temp_median_year = temps %>%
    mutate(yr= as.integer(year(ymd(MESS_DATUM_BEGINN))), mo= month(ymd(MESS_DATUM_BEGINN))) %>%
    #filter(mo == 2)%>%
    group_by(yr,STATIONS_ID)

glimpse(temp_median_year)

anplot = ggplot(temp_median_year,aes(MO_TT)) +
    geom_histogram() +
    facet_wrap(~ mo) +
    theme_minimal() +
    xlab("Temperatur")

ggsave("histo_monthly.png",anplot)

hplot = ggplot(temp_median_year,aes(height)) +
    geom_histogram() +
    theme_minimal() +
    xlab("Hoehe")

ggsave("histo_heights.png",hplot)


#' Epigenome-wide association study
#'
#' Test association with each CpG site.
#'
#' @param beta Methylation levels matrix, one row per CpG site, one column per sample.
#' @param variable Independent variable vector.
#' @param covariates Covariates data frame to include in regression model,
#' one row per sample, one column per covariate (Default: NULL).
#' @param batch Batch vector to be included as a random effect (Default: NULL).
#' @param weights Non-negative observation weights.
#' Can be a numeric matrix of individual weights of same dimension as \code{beta},
#' or a numeric vector of weights with length \code{ncol(beta)},
#' or a numeric vector of weights with length \code{nrow(beta)}.
#' @param cell.counts Proportion of cell counts for one cell type in cases
#' where the samples are mainly composed of two cell types (e.g. saliva) (Default: NULL).
#' @param isva Apply Independent Surrogate Variable Analysis (ISVA) to the
#' methylation levels and include the resulting variables as covariates in a
#' regression model (Default: TRUE).
#' @param sva Apply Surrogate Variable Analysis (SVA) to the
#' methylation levels and covariates and include
#' the resulting variables as covariates in a regression model (Default: TRUE).
#' @param n.sv Number of surrogate variables to calculate (Default: NULL).
#' @param winsorize.pct Apply all regression models to methylation levels
#' winsorized to the given level. Set to NA to avoid winsorizing (Default: 0.05).
#' @param robust Test associations with the 'robust' option when \code{\link{limma::eBayes}}
#' is called (Default: TRUE).
#' @param rlm Test assocaitions with the 'robust' option when \code{\link{limma:lmFit}}
#' is called (Default: FALSE).
#' @param outlier.iqr.factor For each CpG site, prior to fitting regression models,
#' set methylation levels less than
#' \code{Q1 - outlier.iqr.factor * IQR} or more than
#' \code{Q3 + outlier.iqr.factor * IQR} to NA. Here IQR is the inter-quartile
#' range of the methylation levels at the CpG site, i.e. Q3-Q1.
#' Set to NA to skip this step (Default: NA).
#' @param most.variable Apply (Independent) Surrogate Variable Analysis to the
#' given most variable CpG sites (Default: 50000).
#' @param featureset Name from \code{\link{meffil.list.featuresets}()}  (Default: NA).
#' @param verbose Set to TRUE if status updates to be printed (Default: FALSE).
#'
#' @export
meffil.ewas <- function(beta, variable,
                        covariates=NULL, batch=NULL, weights=NULL,
                        cell.counts=NULL,
                        isva=T, sva=T, ## cate?
                        n.sv=NULL,
                        isva0=F,isva1=F, ## deprecated
                        winsorize.pct=0.05,
                        robust=TRUE,
                        rlm=FALSE,
                        outlier.iqr.factor=NA, ## typical value = 3
                        most.variable=min(nrow(beta), 50000),
                        featureset=NA,
                        random.seed=20161123,
                        verbose=F) {

    if (isva0 || isva1)
        stop("isva0 and isva1 are deprecated and superceded by isva and sva")

    if (is.na(featureset))
        featureset <- guess.featureset(rownames(beta))
    features <- meffil.get.features(featureset)

    stopifnot(length(rownames(beta)) > 0 && all(rownames(beta) %in% features$name))
    stopifnot(ncol(beta) == length(variable))
    stopifnot(is.null(covariates) || is.data.frame(covariates) && nrow(covariates) == ncol(beta))
    stopifnot(is.null(batch) || length(batch) == ncol(beta))
    stopifnot(is.null(weights)
              || is.numeric(weights) && (is.matrix(weights) && nrow(weights) == nrow(beta) && ncol(weights) == ncol(beta)
                                         || is.vector(weights) && length(weights) == nrow(beta)
                                         || is.vector(weights) && length(weights) == ncol(beta)))
    stopifnot(most.variable > 1 && most.variable <= nrow(beta))
    stopifnot(!is.numeric(winsorize.pct) || winsorize.pct > 0 && winsorize.pct < 0.5)

    original.variable <- variable
    original.covariates <- covariates
    if (is.character(variable))
        variable <- as.factor(variable)

    stopifnot(!is.factor(variable) || is.ordered(variable) || length(levels(variable)) == 2)

    msg("Simplifying any categorical variables.", verbose=verbose)
    variable <- simplify.variable(variable)
    if (!is.null(covariates))
        covariates <- do.call(cbind, lapply(covariates, simplify.variable))

    sample.idx <- which(!is.na(variable))
    if (!is.null(covariates))
        sample.idx <- intersect(sample.idx, which(apply(!is.na(covariates), 1, all)))

    msg("Removing", ncol(beta) - length(sample.idx), "missing case(s).", verbose=verbose)

    if (is.matrix(weights))
        weights <- weights[,sample.idx]
    if (is.vector(weights) && length(weights) == ncol(beta))
        weights <- weights[sample.idx]

    beta <- beta[,sample.idx]
    variable <- variable[sample.idx]

    if (!is.null(covariates))
        covariates <- covariates[sample.idx,,drop=F]

    if (!is.null(batch))
        batch <- batch[sample.idx]

    if (!is.null(cell.counts))
        cell.counts <- cell.counts[sample.idx]

    if (!is.null(covariates)) {
        pos.var.idx <- which(apply(covariates, 2, var, na.rm=T) > 0)
        msg("Removing", ncol(covariates) - length(pos.var.idx), "covariates with no variance.",
            verbose=verbose)
        covariates <- covariates[,pos.var.idx, drop=F]
    }

    covariate.sets <- list(none=NULL)
    if (!is.null(covariates))
        covariate.sets$all <- covariates

    if (is.numeric(winsorize.pct))  {
        msg(winsorize.pct, "- winsorizing the beta matrix.", verbose=verbose)
        beta <- winsorize(beta, pct=winsorize.pct)
    }

    too.hi <- too.lo <- NULL
    if (is.numeric(outlier.iqr.factor)) {
        q <- rowQuantiles(beta, probs = c(0.25, 0.75), na.rm = T)
        iqr <- q[,2] - q[,1]
        too.hi <- which(beta > q[,2] + outlier.iqr.factor * iqr, arr.ind=T)
        too.lo <- which(beta < q[,1] - outlier.iqr.factor * iqr, arr.ind=T)
        if (nrow(too.hi) > 0) beta[too.hi] <- NA
        if (nrow(too.lo) > 0) beta[too.lo] <- NA
    }

    if (isva || sva) {
        beta.sva <- beta

        autosomal.sites <- meffil.get.autosomal.sites(featureset)
        autosomal.sites <- intersect(autosomal.sites, rownames(beta.sva))
        if (length(autosomal.sites) < most.variable) {
          warning("Probes from the sex chromosomes will be used to calculate surrogate variables.")
        } else {
          beta.sva <- beta.sva[autosomal.sites,]
        }
        var.idx <- order(rowVars(beta.sva, na.rm=T), decreasing=T)[1:most.variable]
        beta.sva <- impute.matrix(beta.sva[var.idx,,drop=F])

        if (!is.null(covariates)) {
            cov.frame <- model.frame(~., data.frame(covariates, stringsAsFactors=F), na.action=na.pass)
            mod0 <- model.matrix(~., cov.frame)
        }
        else
            mod0 <- matrix(1, ncol=1, nrow=length(variable))
        mod <- cbind(mod0, variable)

        if (isva) {
            msg("ISVA.", verbose=verbose)
            set.seed(random.seed)
            isva.ret <- isva(beta.sva, mod, ncomp=n.sv, verbose=verbose)
            if (!is.null(covariates))
                covariate.sets$isva <- data.frame(covariates, isva.ret$isv, stringsAsFactors=F)
            else
                covariate.sets$isva <- as.data.frame(isva.ret$isv)
            cat("\n")
        }

        if (sva) {
            msg("SVA.", verbose=verbose)
            set.seed(random.seed)
            sva.ret <- sva(beta.sva, mod=mod, mod0=mod0, n.sv=n.sv)
            if (!is.null(covariates))
                covariate.sets$sva <- data.frame(covariates, sva.ret$sv, stringsAsFactors=F)
            else
                covariate.sets$sva <- as.data.frame(sva.ret$sv)
            cat("\n")
        }
    }

    analyses <- sapply(names(covariate.sets), function(name) {
        msg("EWAS for covariate set", name, verbose=verbose)
        covariates <- covariate.sets[[name]]
        ewas(variable,
             beta=beta,
             covariates=covariates,
             batch=batch,
             weights=weights,
             cell.counts=cell.counts,
             winsorize.pct=winsorize.pct,
             robust=robust,
             rlm=rlm)
    }, simplify=F)

    p.values <- sapply(analyses, function(analysis) analysis$table$p.value)
    coefficients <- sapply(analyses, function(analysis) analysis$table$coefficient)
    rownames(p.values) <- rownames(coefficients) <- rownames(analyses[[1]]$table)

    for (name in names(analyses)) {
        idx <- match(rownames(analyses[[name]]$table), features$name)
        analyses[[name]]$table$chromosome <- features$chromosome[idx]
        analyses[[name]]$table$position <- features$position[idx]
    }

    list(class="ewas",
         version=packageVersion("meffil"),
         samples=sample.idx,
         variable=original.variable[sample.idx],
         covariates=original.covariates[sample.idx,,drop=F],
         winsorize.pct=winsorize.pct,
         robust=robust,
         rlm=rlm,
         outlier.iqr.factor=outlier.iqr.factor,
         most.variable=most.variable,
         p.value=p.values,
         coefficient=coefficients,
         analyses=analyses,
         random.seed=random.seed,
         too.hi=too.hi,
         too.lo=too.lo)
}

is.ewas.object <- function(object)
    is.list(object) && "class" %in% names(object) && object$class == "ewas"

# Test associations between \code{variable} and each row of \code{beta}
# while adjusting for \code{covariates} (fixed effects) and \code{batch} (random effect).
# If \code{cell.counts} is not \code{NULL}, then it is assumed that
# the methylation data is derived from samples with two cell types.
# \code{cell.counts} should then be a vector of numbers
# between 0 and 1 of length equal to \code{variable} corresponding
# to the proportions of cell of a selected cell type in each sample.
# The regression model is then modified in order to identify
# associations specifically in the selected cell type (PMID: 24000956).
ewas <- function(variable, beta, covariates=NULL, batch=NULL, weights=NULL, cell.counts=NULL, winsorize.pct=0.05,
                 robust=TRUE, rlm=FALSE, verbose=F) {
    stopifnot(all(!is.na(variable)))
    stopifnot(length(variable) == ncol(beta))
    stopifnot(is.null(covariates) || nrow(covariates) == ncol(beta))
    stopifnot(is.null(batch) || length(batch) == ncol(beta))
    stopifnot(is.null(cell.counts)
              || length(cell.counts) == ncol(beta)
              && all(cell.counts >= 0 & cell.counts <= 1))

    method <- "ls"
    if (rlm) method <- "robust"

    if (is.null(covariates))
        design <- data.frame(intercept=1, variable=variable)
    else
        design <- data.frame(intercept=1, variable=variable, covariates)
    rownames(design) <- colnames(beta)

    if (!is.null(cell.counts)) {
        ## Irizarray method: Measuring cell-type specific differential methylation
        ##      in human brain tissue
        ## Mi is methylation level for sample i
        ## Xi is the value of the variable of interest for sample i
        ## pi is the proportion of the target cell type for sample i
        ## thus: Mi ~ target cell methylation * pi + other cell methylation * (1-pi)
        ## and target cell methylation = base target methylation + effect of Xi value
        ## and other cell methylation = base other methylation + effect of Xi value
        ## thus:
        ## Mi = (T + U Xi)pi + (O + P Xi)(1-pi) + e
        ##    = C + A Xi pi + B Xi (1-pi) + e
        design <- design[,-which(colnames(design) == "intercept")]

        design <- cbind(design * cell.counts,
                        typeB=design * (1-cell.counts))
    }

    msg("Linear regression with limma::lmFit", verbose=verbose)
    fit <- NULL
    batch.cor <- NULL
    if (!is.null(batch)) {
        msg("Adjusting for batch effect", verbose=verbose)
        corfit <- duplicateCorrelation(beta, design, block=batch, ndups=1)
        batch.cor <- corfit$consensus
        msg("Linear regression with batch as random effect", verbose=verbose)
        tryCatch(fit <- lmFit(beta, design, method=method, block=batch, cor=batch.cor, weights=weights),
                 error=function(e) {
                     print(e)
                     msg("lmFit failed with random effect batch variable, omitting", verbose=verbose)
                 })
    }
    if (is.null(fit)) {
        msg("Linear regression with only fixed effects", verbose=verbose)
        batch <- NULL
        fit <- lmFit(beta, design, method=method, weights=weights)
    }

    msg("Empirical Bayes", verbose=verbose)
    if (is.numeric(winsorize.pct) && robust) {
      fit.ebayes <- eBayes(fit, robust=T, winsor.tail.p=c(winsorize.pct, winsorize.pct))
    } else {
      fit.ebayes <- eBayes(fit, robust=robust)
    }

    alpha <- 0.975
    std.error <- (sqrt(fit.ebayes$s2.post) * fit.ebayes$stdev.unscaled[,"variable"])
    margin.error <- (std.error * qt(alpha, df=fit.ebayes$df.total))
    n <- rowSums(!is.na(beta))

    list(design=design,
         batch=batch,
         batch.cor=batch.cor,
         cell.counts=cell.counts,
         table=data.frame(p.value=fit.ebayes$p.value[,"variable"],
             fdr=p.adjust(fit.ebayes$p.value[,"variable"], "fdr"),
             p.holm=p.adjust(fit.ebayes$p.value[,"variable"], "holm"),
             t.statistic=fit.ebayes$t[,"variable"],
             coefficient=fit.ebayes$coefficient[,"variable"],
             coefficient.ci.high=fit.ebayes$coefficient[,"variable"] + margin.error,
             coefficient.ci.low=fit.ebayes$coefficient[,"variable"] - margin.error,
             coefficient.se=std.error,
             n=n))
}


#' Metacell colustering object
#'
#' Represent coclustering data derived by resmapling iteration and graph cover (or any other coverage/clustering heuristic)
#'
#' @slot graph_id id of the scdb similairty graph object
#' @slot coclust tidy format matrix with co-occurence stats
#' @slot n_samp number of times each node was sampled
#'
#'
#' @export tgCoClust
#' @exportClass tgCoClust
tgCoClust <- setClass(
   "tgCoClust",
	slots = c(
	  graph_id = "character",
	  coclust = "data.frame",
	  n_samp = "vector")
)

#' Construct a coclust object
#'
#'
#' @param graph_id just cahce the grpah id
#' @param coclust data frame with fields node1, node2, count
#' @param n_samp vector with statistics on number of time each node was sampled
#' @export

setMethod(
  "initialize",
  signature = "tgCoClust",
  definition =
    function(.Object, graph_id, coclust, n_samp) {
		if(is.null(scdb_cgraph(graph_id))) {
			stop("initlaizing coclust using graph id ", graph_id, " that is missing from scdb")
		}
		if(class(coclust)[1] != "data.frame") {
			stop("initializing coclust with non data frame coclust parameter")
		}
		cc_nms = colnames(coclust)
		if(!"node1" %in% cc_nms | !"node2" %in% cc_nms | !"cnt" %in% cc_nms) {
			stop("bad fields in coclust parameter")
		}
		.Object@graph_id= graph_id
		.Object@coclust = coclust
		.Object@n_samp = n_samp
      return(.Object)
    }
)

#' Return a filter (boolean vector) selecting only coclust edges that are nearly as frequent as a user defined K-nn parameter
#'
#' @param coc_id coclust object id
#' @param K the number of top-coclustering neighbors to consider per node
#' @param alpha the relexation paramter to apply for filtering coclustering neighbors below the ttop K ones. A pair (n1,n2) with weight w will be filtered if knn(n1,K) > w*alpha or knn(n2,K) > w*alpha
#'
#' @export

mcell_coclust_filt_by_k_deg = function(coc_id, K, alpha)
{
	coc = scdb_coclust(coc_id)
	if(is.null(coc)) {
		stop("MC-ERR: coclust ", coc_id , " is missing when trying to derive K-deg filter")
	}

	edges = coc@coclust

	deg_wgt = as.matrix(table(c(edges$node1, edges$node2), c(edges$cnt,edges$cnt)))
	deg_cum = t(apply(deg_wgt, 1, function(x) cumsum(rev(x))))
	thresh_Kr = rowSums(deg_cum > K)
	lev2int = 1:length(levels(edges$node1))
	thresh_K = rep(NA, length(levels(edges$node1)))
	names(thresh_K) = levels(edges$node1)
	if (is.na(sum(as.numeric(names(thresh_Kr))))){
		thresh_K[names(thresh_Kr)] = thresh_Kr
	}
	else {
		thresh_K[as.numeric(names(thresh_Kr))] = thresh_Kr
	}

	filt_edges = thresh_K[edges$node1] < edges$cnt * alpha |
							thresh_K[edges$node2] < edges$cnt * alpha

	return(filt_edges)
}


#script to classify MapBiomas maps to new classification (from an Excel file)
#write produced maps to file

rm(list=ls())

library(raster)

cls <- c("PastureA", "PastureB", "PastureC")

yrls <- seq(2000,2015,1)

for(i in seq_along(cls)){

  classification <- read_excel("MapBiomas_CRAFTY_classifications.xlsx", sheet = cls[i], range="B2:C21", col_names=F)

  #loop over years
  for(j in seq_along(yrls)){

    map <- raster(paste0("ASCII/brazillc_",yrls[j],"_5km_int.txt"))
    map <- reclassify(map, rcl=as.matrix(classification))

    writeRaster(map, paste0("ASCII/brazillc_",yrls[j],"_",cls[i],".asc"))
  }
}


#' Extract the information from the simulation data frame to analyse the dose response effects
#'
#' @param allsim dataset with all simulations values
#' @param dataset dataset with all variables
#' @param exposures a vector with exposures
#' @param dr a vector with dose response values
#' @param ic_dis choose between ic (interval confidences) and dis (distribution)
#' @param st summary table from general function
#' @return a data frame with dose response values
#' @examples
#' data(expose_data)
#' data(simu)
#' data(gen)
#' delta=c(1,0)
#' seku <- seq(0,1,0.05)
#' Exposures<- c('Var1','Var2','Var3','Var4','Var5')
#' summary_table_lines <- gen[[2]]
#' drr.grp <- dose_resp (allsim = simu[[1]], dataset = expose_data, st = summary_table_lines,
#'                       dr = seku, exposures = Exposures)
#' @export

dose_resp <- function(allsim, dataset, exposures, dr, ic_dis = "IC", st) {
  dataset <- data.frame(dataset)
    st2 <- as.character(st[, 1])
    un_dr <- unique(grep("DR_", st2, value = TRUE))
    len_exp <- length(exposures)
    len_dr <- length(un_dr)
    df_ace <- data.frame(matrix(NA, len_exp * len_dr, 4))
    names(df_ace) <- c("Group", "Mean", "ICa", "ICb")
    b2 <- data.frame(matrix(NA, 1, 4))
    names(b2) <- c("Quantile", "Mean", "SE", "Exp")
    h <- 0
    for (ex in 1:len_exp) {
        h <- h + 1
        stp <- st[st$Case == exposures[ex], c(4, 5)]
        from <- as.numeric(stp[3, 1])
        to <- as.numeric(stp[dim(stp)[1], 2])
        mdata <- allsim[from:to, ]
        b <- dose_resp_ind(allsim = mdata, dataset = dataset, dr = dr)
        b$Exp <- exposures[ex]
        b2 <- rbind(b2, b)
    }
    b2 <- b2[-1, ]
    return(b2)
}


#######################################################################################################
#
#             DETECCIÓN DE INSULTOS USANDO UN CLASIFICADOR DE MÁXIMA ENTROPÍA
#
# Este código se divide en dos partes:
#
#     [1]: Predicción de un comentario
#          - Se entrena el modelo usando toda la data de train.csv
#          - Se usa una función que recibe como argumento un comentario ingresado por teclado
#          - La función devuelve la probabilidad de que el comentario sea insulto
#
#     [2]: Validación Cruzada
#          - Se entrena el modelo usando una muestra aleatoria igual a la mitad de train.csv
#          - Se predice usando la otra mitad de la data
#          - Se calcula la precisión
#
# Observaciones: - Precisión aproximada: 0.75 ~ Sin preprocesar la data
#                - Solo considera la frecuencia de las palabras (por ahora)
#                - Información de la sesión:
#                                             R version 3.2.1 (2015-06-18)
#                                             Platform: i686-pc-linux-gnu (32-bit)
#                                             Running under: Ubuntu precise (12.04.5 LTS)
#
######################################################################################################

#library(RTextTools)  # RTextTools_1.4.0
#library(tm)          # tm_0.5-10
#library(maxent)      # maxent_1.3.3.1
#library(caret)       # caret_6.0-52

### Gets the data

# load("/data/data.Rdata")

#####---------- [1] Predicts just a comment ----------#####

### Makes corpora
# Function to predict a comment ~ it needs the dtm used to calculate the max-ent model and the max-ent model itself
maxent_predict <-function(comm){
  ### Training model
  #corpus <- Corpus(VectorSource(train$Comment))

  ### Builds a term-document matrix

  #matrix <- DocumentTermMatrix(corpus)
  # 10 most frequent words
  #findFreqTerms(matrix, 10)

  ### Creates a MAXENT model [package: 'maxent']

  #sparse <- as.compressed.matrix(matrix)
  #modelMAXENT <- maxent(sparse[1:nrow(train),], as.factor(train$Insult)[1:nrow(train)])
  #save(modelMAXENT,file = "maxentFit.Rdata")
  ### Predicts
  testdata <- comm
  predCorpus <- Corpus(VectorSource(testdata))
  predMatrix <- DocumentTermMatrix(predCorpus, list(dictionary = Terms(matrix)))
  predSparse <- as.compressed.matrix(predMatrix)

  # Predicts
  resultModel <- predict(modelMAXENT, predSparse[1,])
  result <- as.numeric(resultModel[,3])

  if(result > 0.9){
    return(1)
  } else {
    return(0)
  }
}

 r <- c()
 for(i in 1:length(train$Comment)){
	 r[i]=maxent_predict(train$Comment[i])
 }
 train1 <-cbind(train,maxent =r)
 table(train1$Insult,train1$maxent)
 library("caret")
 confusionMatrix(train1$Insult,train1$maxent)


#' Estimate number of MCMC samples necessary for convergence
#'
#' This function is a wrapper for the \code{\link[coda]{raftery.diag}} function in the \pck{coda} package which estimates the number iterations (plus burnin) and thinning interval for MCMC samples necessary for sufficient convergence. This function adds some automation to the process by allowing the user to lower their standards.
#' @param comp A compiled MCMC object produced by \code{\link[nimble]{compileNimble}} of class \code{MCMC_refClass}.
#' @param inits A list of initialization values for the NIMBLE model in \code{mcmc}.
#' @param niter Number of iterations to use for the MCMC used to implement the RL method.
#' @param nburnin Number of burn-in iterations.
#' @param nsamples Number of samples desired in final model (used to determine \code{thin}).
#' @param thin Amount by which to thin MCMC chain used to implement the RL method.
#' @param minIter Minimum number of iterations to require (not including burn-in).
#' @param maxIter Maximum number of iterations to allow in output. The final number of recommended iterations will be \code{min(maxIter, rl)} where \code{rl} is the number recommend by the RL method, rounded up to the nearest 1000. If \code{rl} is > \code{maxIter} a warning will be issued.
#' @param propInsufficient Proportion of coefficients that do not need to be sufficiently sampled when deciding number of iterations. To ensure all are (in theory), this should be 0.
#' @param exact A character list or vector of characters with variable names to ignore when assessing convergence. These names will be matched exactly, so, for example, \code{'p'} will only match a variable named \code{'p'}. If \code{NULL} (default), all monitored variables are used.
#' @param pattern A character list or vector of characters with variable names to ignore when assessing convergence. These names will be matched by pattern, so, for example, \code{'p'} will match \code{'p'}, \code{'p[1]'}, and \code{'psi'}. To ignore series of variables (i.e., with indices), use something like \code{'p[[]'} to remove \code{'p[1]'}, \code{'p[2]'}, \code{'p[3]'}... If \code{NULL} (default), all monitored variables are used.
#' @param retry Logical, if \code{TRUE} (default), and the RF method indicates that the number of samples was insufficient to conduct a reliable RF test, the MCMC is run again with \code{increment} times more samples, repeatedly, until the RF method can be implemented.
#' @param increment Proportion by which to increase number of iterations each attempt. A value of 0.2, for example, will increase iterations by 20% each attempt (with no burn-in).
#' @param inflate Proportion by which to increase recommended number of iterations. A value of 0.2, for example, will increase the recommedned number of iterations by 20% (before burn-in is added).
#' @param verbose If \code{TRUE} display messages. If this is \code{FALSE}, warnings will still be displayed.
#' @param ... arguments to pass to \code{\link[coda]{raftery.diag}}.
#' @return List with these elements:
#' \itemize{
#'		\item{mcmc} Object of class \code{mcmc} with one chain. You can keep this as a chain, if you want to.
#'		\item{sufficient}: \code{TRUE} or \code{FALSE}, indicating if the trial MCMC chain was long enough to implement the RL method.
#'		\item{rlIter}: Number of iterations suggested by the RL method.
#'		\item{recThin}: Thin value if using the \code{rlIter} iterations assuming \code{nsamples} is desired.
#'		\item{rRec}: Number of iterations recommended using the settings in this function.
#' }
#' @examples
#' @export

rafLewis <- function(
	comp,
	inits,
	niter = 2000,
	nburnin = 1000,
	nsamples = 1000,
	thin = 1,
	minIter = 1000,
	maxIter = 11000,
	propInsufficient = 0,
	exact = NULL,
	pattern = NULL,
	retry = TRUE,
	increment = 0.2,
	inflate = 0.2,
	verbose = FALSE,
	...
) {

	if (verbose) omnibus::say('Estimating necessary number of iterations using Raftery-Lewis method...')

	# MCMC
	mcmc <- nimble::runMCMC(
		comp,
		niter = niter,
		nburnin = nburnin,
		thin = thin,
		nchains = 1,
		inits = inits,
		progressBar = verbose,
		samplesAsCodaMCMC = TRUE,
		summary = FALSE,
		WAIC = FALSE,
		...
	)
	flush.console()

	mcmc <- as.matrix(mcmc)

	rand <- round(1E6 * runif(1))
	tempFile <- paste0('./temp/temp', rand, '.rda')
	save(mcmc, file=tempFile)
	rm(mcmc)
	gc()
	load(tempFile)
	file.remove(tempFile)

	# RL method
	args <- list(data = mcmc, ...)
	dotNames <- omnibus::ellipseNames(...)
	if (any(dotNames == 'q')) args <- c(args, q=dots$q)
	if (any(dotNames == 'r')) args <- c(args, r=dots$r)
	if (any(dotNames == 's')) args <- c(args, s=dots$s)
	if (any(dotNames == 'converge.eps')) args <- c(args, converge.eps=dots$converge.eps)

	rafStats <- do.call(coda::raftery.diag, args=args)
	sufficient <- (rafStats$resmatrix[1] != 'Error')

	rm(args); gc()

	# repeat if insufficient
	if (!sufficient) {

		rlIter <- recIter <- recThin <- NA
		if (!retry) warning('Too few iterations were used for a reliable implementation of the Raftery-Lewis method.')

	}

	mcmc <- as.mcmc(mcmc)

	save(mcmc, file=tempFile)
	rm(mcmc)
	gc()
	load(tempFile)
	file.remove(tempFile)

	if (!sufficient & retry) {

		while (!sufficient & niter <= maxIter & niter < minIter) {

			add <- round(increment * niter) * thin
			niter <- add + niter

			if (verbose) omnibus::say('Increasing iterations to ', niter, ' (before thinning, including burn-in)...')
			mcmc <- addToMcmc(comp = comp, mcmc = mcmc, inits = inits, add = add, thin = thin)

			save(mcmc, file=tempFile)
			rm(mcmc)
			gc()
			load(tempFile)

			mcmc <- .removeVariablesFromMcmc(mcmc, exact=exact, pattern=pattern)

			save(mcmc, file=tempFile)
			rm(mcmc)
			gc()
			load(tempFile)

			args <- list(data=as.matrix(mcmc))
			rafStats <- do.call(coda::raftery.diag, args=args)
			sufficient <- (rafStats$resmatrix[1] != 'Error')
			rm(args); gc()

		}

	}

	# # thin
	# if (coda::niter(mcmc) > nsamples & thin > 1) {

		# keeps <- seq(1, coda::niter(mcmc), by=thin)
		# mcmc <- mcmc[keeps, ]
		# mcmc <- as.mcmc(mcmc)

		# save(mcmc, file=tempFile)
		# rm(mcmc)
		# gc()
		# load(tempFile)

	# }

	if (sufficient) {

		rafIters <- rafStats$resmatrix[ , 'N']

		rlIter <- max(rafIters, na.rm=TRUE) + nburnin
		recIter <- (1 + inflate) * quantile(rafIters, probs=1 - propInsufficient, na.rm=TRUE)

		recIter <- 1000 * ceiling(recIter / 1000)

		recIter <- max(minIter, min(maxIter, recIter))
		if (maxIter < recIter) warning('Number of iterations necessary to achieve desired precision is < maximum desired (maxIter).')

		recIter <- recIter + nburnin
		recThin <- max(1, floor((recIter - nburnin) / nsamples))

		if (verbose) {
			omnibus::say('Number of iterations + burn-in recommended for adequate sampling ............ ', rlIter)
			omnibus::say('Number of iterations + burn-in recommended based sufficiency ................ ', recIter)
			omnibus::say('Thin interval necessary desired number of samples and degree of precision ... ', recThin)
		}

	}

	out <- list(
		mcmc = mcmc,
		sufficient = sufficient,
		rlIter = rlIter,
		recIter = recIter,
		recThin = recThin
	)

	rm(mcmc)
	gc()

	out

}


# recieve the parameters
raw_mat_file <- commandArgs(trailingOnly = T)[1]
dr_npc <- commandArgs(trailingOnly = T)[2]
cluster_resolution <- commandArgs(trailingOnly = T)[3]
output_dir <- commandArgs(trailingOnly = T)[4]
experiment_name <- commandArgs(trailingOnly = T)[5]
path_to_rscript <- commandArgs(trailingOnly = T)[6]
pythonbin <- commandArgs(trailingOnly = T)[7]

setwd(output_dir)
source(paste0(path_to_rscript, "/filter_cells.r"))
source(paste0(path_to_rscript, "/filter_features.r"))
source(paste0(path_to_rscript, "/dim_reduction.r"))
source(paste0(path_to_rscript, "/do_pca.r"))
source(paste0(path_to_rscript, "/fast_tfidf.r"))
source(paste0(path_to_rscript, "/tfidf.r"))
source(paste0(path_to_rscript, "/multiplot.r"))
message(date(), " [info] All the function scripts were loaded ...")

# load package
message(date(), " [info] Load packages")
suppressPackageStartupMessages({
    library(reticulate)
    use_python(pythonbin, required=T)
    reticulate::import("leidenalg")
    reticulate::import("igraph")
    library(leiden)
    library(data.table)
    library(Matrix)
    library(irlba)
    library(Rtsne)
    library(RANN)
    library(igraph)
    library(uwot)
    library(ggplot2)
    })

# convert character parameter to numberic
dr_npc = as.numeric(dr_npc)
cluster_resolution = as.numeric(cluster_resolution)
message(date(), " [info] The countMatrix file ", raw_mat_file, " will be loaded ...")
raw_mat <- fread(raw_mat_file, header=T, sep="\t", showProgress=T)
binary_mat <- as.matrix(raw_mat[, -1])
rownames(binary_mat) <- as.data.frame(raw_mat[, 1])[, 1]
message(date(), " [info] The countMatrix has ", nrow(binary_mat), " features and ", ncol(binary_mat), " cells ...")
message(date(), " [info] The matrix is binarized and converted to sparseMatrix format")
binary_mat <- as(binary_mat, "sparseMatrix")
binary_mat@x[binary_mat@x >0] <- 1

# filter_cell_num=5
message(date(), " [info] The rare and ubiquitous features will be discarded for further analysis ")
rare_threshold <- max(2, floor(ncol(binary_mat)/1000))
ubiq_threshold <- floor(ncol(binary_mat)*0.8)
feature_detected <- rowSums(binary_mat)
feature_idx <- (feature_detected >= rare_threshold) & (feature_detected <= ubiq_threshold)
binary_mat <- binary_mat[feature_idx, ]

# message(date(), "[info] The matrix is filtered, ", nrow(binary_mat), " features and ", ncol(binary_mat), " cells were retained")
# message(date(), "[info] The matrix is normalized by TF-IDF method")
# tfidf2 <- tfidf(binary_mat)

# cv_filter = T
# threshold_cv = 20000
# if(cv_filter){
#     if(nrow(tfidf2)>=threshold_cv){
#         message(date(), " [info] Features were further filtered based on CV to ensure high signal noise ratio and reduce calculation complexity")
#         meantfidf2 <- rowMeans(tfidf2)
#         sdtfidf2 <- apply(tfidf2, 1, sd)
#         cv2tfidf2 <- sdtfidf2/meantfidf2
#         tfidf2 = tfidf2[order(cv2tfidf2, decreasing=TRUE), ][1:threshold_cv, ]
#         message(date(), " [info] Top ", threshold_cv, " Features were retained")
#     } else {
#         message(date(), " [info] Number of features less than ", threshold_cv)
#         message(date(), " [info] All features were retained")
#     }
# }
cv_filter = F
threshold_cv = 20000
if(cv_filter){
    if(nrow(binary_mat)>=threshold_cv){
        message(date(), " [info] Features were further filtered based on CV to ensure high signal noise ratio and reduce calculation complexity")
        meanbinary_mat <- rowMeans(binary_mat)
        sdbinary_mat <- apply(binary_mat, 1, sd)
        cv2binary_mat <- sdbinary_mat/meanbinary_mat
        binary_mat <- binary_mat[order(cv2binary_mat, decreasing=TRUE), ][1:threshold_cv, ]
        message(date(), " [info] Top ", threshold_cv, " Features were retained")
    } else {
        message(date(), " [info] Number of features less than ", threshold_cv)
        message(date(), " [info] All features were retained")
    }
}

# head(apply(binary_mat, 1, quantile))
# any(is.na(binary_mat[, 1370]))
message(date(), " [info] The matrix is filtered: ", nrow(binary_mat), " features and ", ncol(binary_mat), " cells were retained")
message(date(), " [info] The matrix is normalized by TF-IDF method")
# tfidf2 <- tfidf(binary_mat, log_TF=F)
tfidf2 <- tfidf(binary_mat)
# write.table(as.matrix(tfidf2), paste0("normlized_countMat_", experiment_name, ".txt"), row.names=T, col.names=T, quote=F, sep="\t")
message(date(), " [info] Dimensionality reduction method PCA is performed")
save(tfidf2, file="tfidf2.rda")
print(dr_npc)
pca_mat <- do_pca(tfidf2, dims=dr_npc)
message(date(), " [info] Dimensionality reduction method tSNE is performed")
tsne_mat = Rtsne(pca_mat, check_duplicates = FALSE, verbose = TRUE, max_iter = 1000, is_distance = FALSE, theta = 0.5, pca = FALSE)
message(date(), " [info] Dimensionality reduction method UMAP is performed")
umap_mat <- umap(pca_mat)

colnames(pca_mat) = paste0("PCA", 1:ncol(pca_mat))
colnames(tsne_mat$Y) = c("tSNE1", "tSNE2")
colnames(umap_mat) = c("UMAP1", "UMAP2")

## leiden cluster
knn.info<- nn2(pca_mat, k=dr_npc)
## convert to adjacancy matrix
knn <- knn.info$nn.idx
adj <- matrix(0, nrow(pca_mat), nrow(pca_mat))
rownames(adj) <- colnames(adj) <- rownames(pca_mat)
for(i in seq_len(nrow(pca_mat))){
    adj[i, rownames(pca_mat)[knn[i, ]]] <- 1
    }
xx <- graph_from_adjacency_matrix(adj)
adjacency_matrix <- igraph::as_adjacency_matrix(xx)
partition <- leiden(adjacency_matrix, resolution_parameter=cluster_resolution)
message(date(), " [info] The cluster number and cell distribution showed as follow")
print(table(partition))
cluster_num <- length(table(partition))
myColor = c("#0000FF", "#FF0000", "#00FF00", "#000033", "#FF00B6", "#005300", "#FFD300", "#009FFF", "#9A4D42", "#00FFBE", "#783FC1", "#1F9698", "#FFACFD", "#B1CC71", "#F1085C", "#FE8F42", "#DD00FF", "#201A01", "#720055", "#766C95", "#02AD24", "#C8FF00", "#886C00", "#FFB79F", "#858567", "#A10300", "#14F9FF", "#00479E", "#DC5E93", "#93D4FF")
message(date(), " [info] Dimensionality reduction plots generating")
pdf(paste0("Dimension reduction (PCA) of ", experiment_name, ".pdf"))
plot(pca_mat[, 1], pca_mat[, 2], pch=20, main="pca", cex=0.8, cex.main=1.5, frame.plot=FALSE, col=rev(myColor)[1:cluster_num][partition])
legend("topleft", pch=c(20, 20), col=rev(myColor)[1:cluster_num], legend=paste0("Cluster", unique(partition)), bty="o",  box.col="darkgreen", cex=.8)
invisible(dev.off())
pdf(paste0("Dimension reduction (tSNE) of ", experiment_name, ".pdf"))
plot(tsne_mat$Y, pch=20, main="tsne", cex=0.8, cex.main=1.5, frame.plot=FALSE, col=rev(myColor)[1:cluster_num][partition])
legend("topleft", pch=c(20, 20), col=rev(myColor)[1:cluster_num], legend=paste0("Cluster", unique(partition)), bty="o",  box.col="darkgreen", cex=.8)
invisible(dev.off())
pdf(paste0("Dimension reduction (UMAP) of ", experiment_name, ".pdf"))
plot(umap_mat[, 1], umap_mat[, 2], pch=20, main="umap", cex=0.8,  cex.main=1.5, frame.plot=FALSE, col=rev(myColor)[1:cluster_num][partition])
legend("topleft", pch=c(20, 20), col=rev(myColor)[1:cluster_num], legend=paste0("Cluster", unique(partition)), bty="o",  box.col="darkgreen", cex=.8)
invisible(dev.off())
message(date(), " [info] Output the normalized matrix and annotation files")
write.table(as.matrix(tfidf2), paste0("normlized_countMat_", experiment_name, ".txt"), row.names=T, col.names=T, quote=F, sep="\t")
cell_anno <- data.frame(colnames(binary_mat),partition)
colnames(cell_anno) <- c("cell_name", "leiden_cluster")
write.table(cell_anno, paste0("leiden_cluster_annotation.txt"), row.names=F, col.names=T, quote=F, sep="\t")


#' bnamR
#' Read in and reshape the bnam model output file. This currentely requires a specific format of bnam output (from Brickman Oct 2019).
#' This file needs to be requested annually to include past year. Remove BNAM .mat file and replace with new
#' @param redo = if redo = T redo the reshape, else load in the previously reshaped file
#' @param bnam_location = location of the file (Brickman Oct 2019 structure)
#' @param outfile = where you want the output to live
#' @value list of three objects. locP = locations of bottom temperature data with the pertient model info. bTs = predicted bottom temperatures one row per location (rownames for matrix match the locP EID. timeS = time steps for each column of the bTs matrix.)
#' @author Adam Cook
#' @examples
#' anc = bnam(redo = T)
#' @export

bnamR = function(redo=F , x, bnam_location = file.path(project.datadirectory('bio.snowcrab'),'data','bnam','raw.matlab'),
                 outfile= file.path(project.datadirectory('bio.snowcrab'),'data','bnam','bnams.reshape.rds')) {

  if(redo){
    require(R.matlab)
    x=list.files(bnam_location)[1] #should only be one, don't need to change file name annually
    a = readMat(paste(bnam_location, x, sep="/"))
    #a=merge(a, b)

    plot(a$nav.lon,a$nav.lat,pch=ifelse(a$land.mask==0,'','.'))

    locs = data.frame(X=c(a$nav.lon), Y=c(a$nav.lat),Depth=c(a$Bathy.depth), land=c(a$land.mask),EID = 1:length(a$nav.lon))
    g = names(a)
    gI = grep('Tbtm',g)
    m = 0
    bTs = list()
    for(i in gI){
      m=m+1
      out = c()
      for(j in 1:12){
        out = cbind(out,c(a[[i]][j,,]))
      }
      if(m==1)	out = cbind(1:length(a$nav.lon),out)
      out = na.omit(out)
      bTs[[m]] = out
      names(bTs[[m]]) = g[i]
    }

    #bottom temperatures pruned to ocean only transformed to one location per row with full time series
    bTs = do.call(cbind,bTs)
    ocean = unique(bTs[,1])
    locsP = subset(locs, EID %in% ocean)
    timeS = seq(as.numeric(a[['yr0']]), as.numeric(a[['yr1']]+11/12), by=1/12)
    locsP = locsP[order(locsP$EID),]
    bTs = bTs[order(bTs[,1]),]
    locsP$EID = 1:nrow(locsP)
    bTs[,1] = 1:nrow(bTs)
    saveRDS(list(locsP = locsP,bTs = bTs,timeS = timeS),file=outfile)
    }

  return(readRDS(outfile))
}


pdf()
files <- dir(pattern="metrics.*csv")

s_script <- vector(mode="integer")
s_ins <- vector(mode="integer")
s_del <- vector(mode="integer")
s_up <- vector(mode="integer")
s_mov <- vector(mode="integer")
t_total <- vector(mode="integer")

for (file in files) {
	d <- read.csv(file, header=T, sep=";")
	length(d[[3]])
	s_script <- cbind(s_script, d[[3]])
	s_ins <- cbind(s_ins, d[[3]])
	s_del <- cbind(s_del, d[[4]])
	s_up <- cbind(s_up, d[[5]])
	s_mov <- cbind(s_mov, d[[6]])
	t_total <- cbind(t_total, d[[11]])
}
boxplot(s_script, main="Edit script size")
boxplot(s_ins, main="Insert actions")
boxplot(s_del, main="Delete actions")
boxplot(s_up, main="Update actions")
boxplot(s_mov, main="Move actions")
boxplot(t_total, main="Total time")