JohMast/rtsVis
Raster Time Series Visualization

Package index
Search the JohMast/rtsVis package
Vignettes
Functions
46
Source code
9
Man pages
8
Home
/
GitHub
/
JohMast/rtsVis
/
R/internal.R

R/internal.R
In JohMast/rtsVis: Raster Time Series Visualization

Defines functions .ts_add_gg .ts_gg_pie .ts_gg_bar_fill .ts_gg_bar_stack .ts_gg_line2 .ts_gg_line .ts_gg_vio .ts_gg_dens2 .ts_gg_dens ceiling_dec floor_dec .ts_extract_from_frames .ts_subset_ts_util .ts_guess_raster_type .blacken_NA_util .ts_makeframes ts_stretch_list ts_stretch ts_get_ts_quantiles ts_get_stack_quantiles ts_get_layer_quantiles .onLoad .rFrames .gg.bmap .int2frames .na.approx out quiet .haveMinMax .lapply 

#' NULL declaration to suppres R CMD CHECK warning related to tidyverse syntax
#' @keywords internal
#' @noRd
aggregate <- time <- name <- band <- dens <- value <- long  <-  lat <-   group <-  hcl.colors <- r_list_extract <-label <- pos <- midpointpos <- midpoint <- cumulative <- n <- frame <-   x <-  minValue <-  maxValue <- quantile <-position_name  <- id <-  n_distinct <- drop_na <- filter <- ungroup <- ..density.. <- first <- n_distinct <- band_colors <- frame <- pull <- mutate <- density <- summarise <- NULL


##From moveVis
#' verbose lapply
#'
#' @importFrom pbapply pblapply
#' @noRd 
.lapply <- function(X, FUN, ..., rtsVis.verbose = NULL, rtsVis.n_cores = NULL, rtsVis.export = NULL){
  if(is.null(rtsVis.verbose)) rtsVis.verbose <- getOption("rtsVis.verbose")
  if(is.null(rtsVis.n_cores)) rtsVis.n_cores <- getOption("rtsVis.n_cores")
  
  # with parallelization
  if(rtsVis.n_cores > 1){
    cl <- parallel::makeCluster(rtsVis.n_cores)
    if(!is.null(rtsVis.export)) parallel::clusterExport(cl, rtsVis.export)
    y <- try(parallel::parLapply(cl = cl, X, FUN, ...)) # ensures that cluster is stopped appropriately
    parallel::stopCluster(cl)
    if(inherits(y, "try-error")) out(y, type = 3) else return(y)
    
    # without parallelization
  }else if(isTRUE(rtsVis.verbose)) pblapply(X, FUN, ...) else lapply(X, FUN, ...)
}

.haveMinMax <- function(x) {
  if (inherits(x, "RasterLayer") || inherits(x, "RasterBrick")) {
    return(x@data@haveminmax)
  } else if (inherits(x, "RasterStack")) {
    return(all(sapply(x@layers, function(y) y@data@haveminmax)))
  } else {
    return(FALSE)
  }
}

#' Suppress messages and warnings
#' @noRd 
quiet <- function(expr){
  #return(expr)
  return(suppressWarnings(suppressMessages(expr)))
}

#' Outputs errors, warnings and messages
#'
#' @param input character
#' @param type numeric, 1 = message/cat, 2 = warning, 3 = error and stop
#' @param msg logical. If \code{TRUE}, \code{message} is used instead of \code{cat}. Default is \code{FALSE}.
#' @param sign character. Defines the prefix string.
#'
#' @keywords internal
#' @noRd
out <- function(input, type = 1, ll = NULL, msg = FALSE, sign = "", verbose = getOption("rtsVis.verbose")){
  if(is.null(ll)) if(isTRUE(verbose)) ll <- 1 else ll <- 2
  if(type == 2 & ll <= 2){warning(paste0(sign,input), call. = FALSE, immediate. = TRUE)}
  else{if(type == 3){stop(input, call. = FALSE)}else{if(ll == 1){
    if(msg == FALSE){ cat(paste0(sign,input),sep="\n")
    } else{message(paste0(sign,input))}}}}
}

#' interpolate NAs
#'
#' @param v vector with NAs to be replaced by interpolated values
#' @param rule see approxfun
#'
#' @keywords internal
#' @noRd
.na.approx <- function(v, rule = 2){
  if(length(which(!is.na(v))) < 2) return(v) else{
    s <- 1:length(v)
    stats::approx(x = s[!is.na(v)], y = v[!is.na(v)], rule = rule, xout = s)$y 
  }
}

#' create interpolated layer by frame position
#' @importFrom raster clusterR overlay brick unstack stack
#' @noRd
.int2frames <- function(r_list, pos, frames, n.rlay, cl){
  
  # get frames outside shoulders not to be interpolated
  r.frames <- rep(list(NULL), length(frames))
  names(r.frames) <- frames
  early <- as.numeric(names(r.frames)) < utils::head(pos, n=1)
  if(any(early)) r.frames[early] <- utils::head(r_list, n=1)
  
  late <- as.numeric(names(r.frames)) > utils::tail(pos, n=1)
  if(any(late)) r.frames[late] <- utils::tail(r_list, n=1)
  
  exist <- match(as.numeric(names(r.frames)), pos)
  if(any(!is.na(exist))){
    r.frames[!is.na(exist)] <- r_list[stats::na.omit(exist)]
  }
  
  # collect remaining frame ids
  i.frames <- as.numeric(names(r.frames)[sapply(r.frames, is.null)])
  
  # between which elements
  i.frames <- lapply(2:length(pos), function(i){
    y <- i.frames > pos[i-1] & i.frames < pos[i]
    if(any(y)) return(i.frames[which(y)])
  })
  i.rasters <- which(!sapply(i.frames, is.null))+1
  i.frames <- i.frames[i.rasters-1]
  
  # interpolation function
  v.fun <- function(v.x, v.y, ...) t(mapply(xx = v.x, yy = v.y, FUN = function(xx, yy, ...) .na.approx(c(xx, v.na, yy))[pos.frames], SIMPLIFY = TRUE))
  #v.fun <- function(v.x, v.y, ...) t(mapply(xx = v.x, yy = v.y, FUN = function(xx, yy, ...) zoo::na.approx(c(xx, v.na, yy), rule = 2)[pos.frames], SIMPLIFY = TRUE))
  #v.fun <- function(v.x, v.y) mapply(xx = v.x, yy = v.y, FUN = function(xx, yy, xx.pos = x.pos, yy.pos = y.pos, xy.frame = frame) zoo::na.approx(c(xx, rep(NA, (yy.pos-xx.pos)-1), yy))[(xy.frame-xx.pos)+1], SIMPLIFY = TRUE)
  #v.fun <- Vectorize(function(x, y, ...) zoo::na.approx(c(x, v.na, y), rule = 2)[pos.frame])
  
  # iterate over shoulder ranges
  for(i in i.rasters){
    
    # rasters
    if(n.rlay > 1){
      x <- unstack(r_list[[i-1]])
      y <- unstack(r_list[[i]])
    } else{
      x <- r_list[i-1] # keep listed using [ instead of [[ to work with lapply
      y <- r_list[i]
    }
    
    # positions
    x.pos <- pos[i-1]
    y.pos <- pos[i]
    v.na <- rep(NA, (y.pos-x.pos)-1)
    pos.frames <- (i.frames[[which(i.rasters == i)]]-x.pos)+1
    if(getOption("rtsVis.n_cores") > 1) parallel::clusterExport(cl, c("v.na", "pos.frames"), envir = environment())
    
    # interpolate layer-wise
    r <- lapply(1:length(x), function(i.layer){
      if(getOption("rtsVis.n_cores") > 1){
        clusterR(stack(x[[i.layer]], y[[i.layer]]), fun = overlay, args = list("fun" = v.fun), cl = cl) # export = c("pos.frames", "v.na"))
      }else overlay(stack(x[[i.layer]], y[[i.layer]]), fun = v.fun)
    })
    
    # disassemble brick time- and layerwise
    if(length(r) > 1){
      for(j in 1:length(i.frames[[which(i.rasters == i)]])){
        r.frames[[match(i.frames[[which(i.rasters == i)]], frames)[j]]] <- brick(lapply(1:n.rlay, function(lay) r[[lay]][[j]]))
      }
    } else{
      r.frames[match(i.frames[[which(i.rasters == i)]], frames)] <- if(inherits(r[[1]], "RasterLayer")) r else unstack(r[[1]])
    }
  }
  return(r.frames)
}


#' plot raster as ggplot
#' @importFrom raster ncell
#' @importFrom ggplot2 ggplot geom_tile geom_raster aes_string scale_fill_identity
#' @noRd 
.gg.bmap <- function(r, r_type, gglayer = FALSE, hillshade_layer=NULL, ...){
  extras <- list(...)
  if(!is.null(extras$maxpixels)) maxpixels <- extras$maxpixels else maxpixels <- 500000
  if(!is.null(extras$alpha)) alpha <- extras$alpha else alpha <- 1
  if(!is.null(extras$maxColorValue)) maxColorValue <- extras$maxColorValue else maxColorValue <- NA
  
  # aggregate raster if too large
  if(maxpixels < ncell(r)) r <- raster::aggregate(r, fact = ceiling(ncell(r)/maxpixels))
  
  # transform into data.frame
  df <- data.frame(raster::as.data.frame(r, xy = TRUE))
  colnames(df) <- c("x", "y", paste0("val", 1:(ncol(df)-2)))
  
  # factor if discrete to show categrocial legend
  df$fill <- df$val1
  if(r_type == "discrete") df$fill <- as.factor(df$fill)
  
  # transform to RGB colours
  if(r_type == "RGB"){
    if(is.na(maxColorValue)) maxColorValue <- max(c(df$val1, df$val2, df$val3), na.rm = TRUE)
    
    if(maxColorValue < max(c(df$val1, df$val2, df$val3), na.rm = TRUE)){
      out("maxColorValue < maximum raster value. maxColorValue is set to maximum raster value.", type = 2)
      maxColorValue <- max(c(df$val1, df$val2, df$val3), na.rm = TRUE)
    }
    
    # remove NAs
    na.sel <- is.na(df$val1) | is.na(df$val2) | is.na(df$val3)
    if(any(na.sel)) df <- df[!na.sel,]
    
    df$fill <- grDevices::rgb(red = df$val1, green = df$val2, blue = df$val3, maxColorValue = maxColorValue)
  } else{
    
    # remove NAs
    na.sel <- is.na(df$val1)
    if(any(na.sel)) df <- df[!na.sel,]
  }
  # if NA gaps are there, use geom_tile, otherwise make it fast using geom_raster
  if(any(na.sel)){
    gg <- geom_tile(aes_string(x = "x", y = "y", fill = "fill"), data = df, alpha = alpha)
  } else{
    gg <- geom_raster(aes_string(x = "x", y = "y", fill = "fill"), data = df, alpha = alpha)
  }
  

  
  if(!is.null(hillshade_layer)){ #if a hillshade layer was provided
    gg <- ggplot()+gg+hillshade_layer+gg  #plot as normal, then the hillshade over it, then plot again (this ensures that we dont take the hillshades layout)
    if(r_type == "RGB") gg <- gg + scale_fill_identity() 
  }else if(isFALSE(gglayer)){
    gg <- ggplot() + gg
    if(r_type == "RGB") gg <- gg + scale_fill_identity() 
  }
  return(gg)
}



#' assign raster to frames
#' @importFrom raster nlayers crop extent brick writeRaster dataType
#' @noRd
.rFrames <- function(r_list, r_times, m.df, gg.ext, fade_raster = TRUE, crop_raster = TRUE, ...){
  
  if(!is.list(r_list)){
    r_list <- list(r_list)
    n <- 1
  } else n <- length(r_list)
  n.rlay <- nlayers(r_list[[1]])
  
  #if(n.rlay > 1) r_list <- lapply(1:n.rlay, function(i) lapply(r_list, "[[", i)) else r_list <- list(r_list) #FRIDAY
  
  if(isTRUE(crop_raster)){
    r_list <- lapply(r_list, crop, y = extent(gg.ext[1], gg.ext[3], gg.ext[2], gg.ext[4]), snap = "out")
  }
  
  if(n > 1){
    
    ## calcualte time differences to r_times
    x <- lapply(1:max(m.df$frame), function(y) max(unique(m.df[m.df$frame == y,]$time)))
    frame_times <- unlist(x)
    attributes(frame_times) <- attributes(x[[1]])
    diff.df <- as.data.frame(sapply(r_times, function(x) abs(difftime(frame_times, x, units = "secs"))))
    
    ## assign r_list positions per frame times
    pos.df <- data.frame(frame = 1:nrow(diff.df), pos_r = apply(diff.df, MARGIN = 1, which.min))
    
    ## interpolate/extrapolate
    if(isTRUE(fade_raster)){
      pos.df <- pos.df[apply(diff.df[,unique(pos.df[,2])], MARGIN = 2, which.min),]
      
      # start cluster and interpolate over all frames or badge-wise
      if(getOption("rtsVis.n_cores") > 1) cl <- parallel::makeCluster(getOption("rtsVis.n_cores"))
      if(isFALSE(getOption("rtsVis.frames_to_disk"))){
        r_list <- .int2frames(r_list, pos = pos.df$frame, frames = unique(m.df$frame), n.rlay = n.rlay, cl = cl)
      } else{
        
        # create frames badge-wise?
        badges <- unique(c(unlist(sapply(2:length(pos.df$frame), function(i){
          c(seq(if(i == 2) 1 else pos.df$frame[i-1], pos.df$frame[i],
                by = if(is.na(getOption("rtsVis.n_memory_frames"))) length(unique(m.df$frame)) else getOption("rtsVis.n_memory_frames")),
            pos.df$frame[i])
        }, simplify = FALSE)), max(m.df$frame)))
        
        # write to drive instead of memory
        files <- unlist(sapply(2:length(badges), function(i){
          frames <- if(i == 2) (badges[i-1]):badges[i] else (badges[i-1]+1):badges[i]
          r <- .int2frames(r_list, pos = pos.df$frame, frames = frames, n.rlay = n.rlay, cl = cl)
          y <- paste0(getOption("rtsVis.dir_frames"), "/rtsVis_frame_", frames, ".tif")
          catch <- sapply(1:length(r), function(j) writeRaster(r[[j]], filename = y[[j]], datatype = dataType(r_list[[1]]), overwrite = TRUE))
          return(y)
        }, USE.NAMES = FALSE))
        
        # link to files
        r_list <- lapply(files, brick)
      }
      if(getOption("rtsVis.n_cores") > 1) parallel::stopCluster(cl)
    }else{
      r_list <- r_list[pos.df$pos_r]
    }
  }else{r_list <- r_list}
  return(r_list)
}

#' package startup
#' @importFrom pbapply pboptions
#' @noRd 
.onLoad <- function(libname, pkgname){
  if(is.null(getOption("rtsVis.verbose")))  options(rtsVis.verbose = FALSE)
  if(is.null(getOption("rtsVis.n_cores")))  options(rtsVis.n_cores = 1)
  if(is.null(getOption("rtsVis.frames_to_disk")))  options(rtsVis.frames_to_disk = FALSE)
  if(is.null(getOption("rtsVis.n_memory_frames")))  options(rtsVis.n_memory_frames = NA)
  if(is.null(getOption("rtsVis.dir_frames"))){
    options(rtsVis.dir_frames = paste0(tempdir(), "/rtsVis"))
    if(!dir.exists(getOption("rtsVis.dir_frames"))) dir.create(getOption("rtsVis.dir_frames"))
  }
}

#Could probably be substituted by raster::quantile
#but as raster::stretch uses the method below, we stick with this one
#' ts_get_layer_quantiles
#' @description Takes regular samples from a single rasterlayer and determines the quantiles
#' @param x a raster layer
#' @param minq Lower quantile to be determined
#' @param maxq Upper quantile to be determined
#' @param samplesize Number of samples to take
#' @importFrom raster sampleRegular minValue maxValue
#' @importFrom stats quantile
#' @return a named vector of the minimum and maximum value (corresponding to minq and maxq)
#' @noRd
ts_get_layer_quantiles <- function(x,minq=0.02,maxq=0.98,samplesize=100000){
  #get quantiles for one image
  minq <- max(0,minq)
  maxq <- min(1,maxq)
  stopifnot(minq < maxq)
  
  if ((minq==0 & maxq==1) & .haveMinMax(x)) {
    q <- cbind(minValue(x), maxValue(x)) #old version that works, but requires internal raster function
  } else {
    if (samplesize[1] < ncell(x)) {
      stopifnot(samplesize[1] > 1) 
      y <- sampleRegular(x, samplesize, asRaster=TRUE)
      q <- quantile(y, c(minq, maxq), na.rm=TRUE)
    } else {
      q <- quantile(x, c(minq, maxq), na.rm=TRUE)
    }
  }
}

#could probably be substituted by raster::quantile as in:
#cellStats(x, stat=raster::quantile,ncells=100000,probs=c(0.01,0.99))
#' ts_get_stack_quantiles
#' @description Takes regular samples from a single rasterstack and determines the quantiles for every layer
#' @param x a raster stack
#' @param minq Lower quantile to be determined
#' @param maxq Upper quantile to be determined
#' @param samplesize Number of samples to take
#' @return a matrix of n_layers*2, one min and one max bound for every layer
#' @noRd
ts_get_stack_quantiles <- function(x,minq=0.02,maxq=0.98,samplesize=100000){
  if(nlayers(x)<=1){
    rs_qs <-  ts_get_layer_quantiles(x,minq=minq,maxq=maxq,samplesize=samplesize)
  }else{
    rs_qs <- t(do.call(cbind, lapply(unstack(x),FUN =  ts_get_layer_quantiles,minq=minq,maxq=maxq,samplesize=samplesize)))
  }
  return(rs_qs)
}

#2do: Make this choose ts_get_layer quantiles for single layers (if this is necessary, and ts_get_stack_quantiles breaks for single layers)
#' ts_get_ts_quantiles
#' @param ts a list of raster stacks
#' @param minq Lower quantile to be determined
#' @param maxq Upper quantile to be determined
#' @param samplesize Number of samples to take
#' @return a matrix of n_layers*2, one min and one max bound for every layer, which is the min and the max respectively of all the rasters for that layer index
#' @noRd
ts_get_ts_quantiles <- function(ts,minq=0.02,maxq=0.98,samplesize=100000){
  if(minq==0){minq <- 0.000001} #This prevents weird things from occasionally happening with NAs (unknown cause)
  qs <- sapply(ts,ts_get_stack_quantiles,simplify="array",minq=minq,maxq=maxq,samplesize=samplesize)
  if(nlayers(ts[[1]])<=1){ #for discrete and gradient rasters, we get a 2*n_images matrix, for rgb we get a 2*n_images*n_layers array, which needs to be handles a bit differently
    maxqs <- max(qs[2])
    minqs <- min(qs[1])
  }else{
    maxqs <- apply(qs[,2,], MARGIN = 1,max)
    minqs <- apply(qs[,1,], MARGIN = 1,min)
  }
  return(as.data.frame(cbind(minqs,maxqs)))
}

#' ts_stretch
#' @description Stretch and clips a raster(stack) from within a certain source range determined by min quantile and max quantile to a target range ymin to ymax
#' @param x a raster to be stretched
#' @param minqs Lower quantile 
#' @param maxqs Higher quantile 
#' @param ymin target min value
#' @param ymax target max value
#' @importFrom RStoolbox rescaleImage
#' @importFrom raster clamp
#' @return A raster with values between ymin and ymax
#' @noRd
ts_stretch <- function(x,minqs,maxqs,ymin=0,ymax=0){
  raster::clamp(
    RStoolbox::rescaleImage(x,
                            xmin = minqs,
                            xmax = maxqs,
                            ymin = ymin,
                            ymax = ymax,
                            forceMinMax = TRUE),
    ymin,ymax)
}


#' ts_stretch_list
#' @description Stretch and clips a list of raster(stacks) from within a certain source range determined by min quantile and max quantile to a target range ymin to ymax. The quantiles are determined for each layer individually but across all rasters of the inputlist
#' @param x_list a list of rasters to be stretched
#' @param minqs Lower quantile 
#' @param maxqs Higher quantile 
#' @param ymin target min value
#' @param ymax target max value
#' @return A list of raster(stacks) with values between ymin and ymax
#' @noRd
ts_stretch_list <- function(x_list,minq=0.01,maxq=0.99,ymin=0,ymax=0, samplesize = 10000){
  ts_quantiles <- ts_get_ts_quantiles(ts = x_list,minq = minq,maxq = maxq,samplesize = samplesize)
  out <- lapply(x_list,ts_stretch,minqs = ts_quantiles$minqs,maxqs = ts_quantiles$maxqs,ymin = 0,ymax = 1)
  .ts_set_frametimes(out,.ts_get_frametimes(x_list))
}

#' .ts_makeframes
#' @param x_list a list of rasters
#' @param r_type one of "discrete","gradient", "RGB"
#' @return a list of ggplots, carrying over the "time" attribute of x_list set
#' @noRd
.ts_makeframes <- function(x_list,r_type="RGB",gglayer=FALSE,alpha=1,hillshade_layer=NULL){
  out <- lapply(x_list, .gg.bmap,r_type=r_type,gglayer=gglayer,alpha=alpha,hillshade_layer=hillshade_layer)
  .ts_set_frametimes(out,.ts_get_frametimes(x_list))
}

#' #' .ts_update_NA_util
#' #'
#' #' @param x a raster object
#' #' @param new_na Value to replace the old one as NA
#' #' @return The modified raster object, with the new NA value set
#' #' @importFrom raster NAvalue
#' #' @noRd
#' .ts_update_NA_util <- function(x,new_na){
#'   NAvalue(x) <- new_na
#'   return(x)
#' }
#' 

#' .blacken_NA_util
#' @param x A list of raster objects 
#' @return a raster object with NAs replaced by 0
#' @noRd
.blacken_NA_util <- function(x_list){
  out <- lapply(x_list,FUN = function(y){
    y[is.na(y[])] <- 0 
    return(y)
  })
  #carry over the frame times
  .ts_set_frametimes(out,.ts_get_frametimes(x_list))
}


#' ts_guess_raster_type
#' @description Attempts to determine the raster type of the input raster, to be used for other functions in the rtsVis package.
#' @param x A raster object
#' @return
#' @importFrom raster sampleRandom
#' @noRd
.ts_guess_raster_type <- function(x){
  print("Guessing raster type.")
  if(nlayers(x) >= 3 ){
    r_type <-"RGB"
    print("Detected 3+ layers, choosing raster type 'RGB'")
  }else if(nlayers(x) != 3 && length(unique(sampleRandom(x,100)))>=50){
    r_type <-"gradient"
    print("Detected more than 50/100 unique values, choosing raster type 'gradient'")
  }else if(nlayers(x) != 3 && length(unique(sampleRandom(x,100)))<50){
    r_type <-"discrete"
    print("Detected fewer than 50/100 unique values, choosing raster type 'discrete'")
  }else{
    stop("Could not determine raster type.")
  }
  return(r_type)
}

#' .ts_subset_ts_util
#' @noRd 
#' @param x_list a list of raster objects
#' @param l_indices a vector of indices to select from each object
#' @return a list of raster objects, each subset by l_indices
#' @noRd
.ts_subset_ts_util <- function(x_list,l_indices=1){
  x_list_out <- lapply(x_list, function(x){
    x[[l_indices]]
  }
  )
  
  
  x_list_out <- .ts_set_frametimes(x_list_out,.ts_get_frametimes(x_list)) #reapply the dates
  return(x_list_out)
}


#' .ts_extract_from_frames
#' @noRd 
#' @param r_list_extract A list of rasters to extract values from. Need to have frame times set so they can be extracted by .ts_get_frametimes
#' @param positions Positions from where to extract values. Can be a Two-column matrix, a spatialpoints, or spatialpolygons. If none are provided, values are extracted for the entire raster using raster::cellstats
#' @param position_names (Optional) A vector of length positions, giving the names of the position objects
#' @param FUN A function to apply to summarize the values per position object. Default is mean.
#' @return A dataframe. Columns for the summarized values per layer, position centroid lat & lon, position names, and timestamp and frame indices (integer). Number of rows equals the number of positions in positions multiplied by the number of rasters in r__list_extract
#' @importFrom tidyr pivot_longer
#' @importFrom raster extract 
#' @importFrom sf st_centroid st_coordinates st_geometry st_geometry_type st_buffer st_crs st_contains st_as_sfc st_bbox
#' @importFrom raster buffer intersect
#' @importFrom assertthat assert_that
#' @import sp
#' @noRd
.ts_extract_from_frames <- function(r_list_extract,positions=NULL,position_names=NULL,band_names=NULL,FUN=mean,pbuffer=NULL){
  
  nlay <- nlayers(r_list_extract[[1]])#get the number of layers from a template
  
  frametimes <- .ts_get_frametimes(r_list_extract)
  
  assert_that(length(r_list_extract)==length(frametimes))

  if(!is.null(positions)){
      assert_that(st_crs(r_list_extract[[1]])==st_crs(positions))
    if(inherits(positions, "sf")){
      all(st_contains(st_as_sfc(st_bbox(r_list_extract[[1]])),positions,sparse = FALSE))
    }else if (nrow(positions)==1){  #if there is only one object (point or line) there may be no raster::intersect
      all(st_contains(st_as_sfc(st_bbox(r_list_extract[[1]])),sf::st_as_sf(positions[1,]),sparse = FALSE)) #use the sf version for just the first feature then
    }else{
      assert_that(!is.null(raster::intersect(r_list_extract[[1]],positions)))
      
    }
      if(!is.null(pbuffer)){
        if(inherits(positions, "sf")){
          positions <- st_buffer(positions,dist=pbuffer)
        }else if(inherits(positions,c("matrix","array"))){
          print("Buffering not supported for raw coordinates. Consider converting the coordinates into an sf object.")
        }else{
          positions <- raster::buffer(positions,width=pbuffer,dissolve=FALSE)
        }
    }
  }
  #make names if no names
  if(is.null(names(r_list_extract))){
    names(r_list_extract) <- as.character(1:length(r_list_extract))
  }
  # Check for duplicated Names
  while(anyDuplicated(names(r_list_extract))){
    warning("Duplicated Names found in input raster list")
    print("Creating unique Names")
    names(r_list_extract)[duplicated(names(r_list_extract))] <- paste0(names(r_list_extract)[duplicated(names(r_list_extract))],"_2")
  }
  

  extr_df <-  
    do.call(rbind,lapply(names(r_list_extract),
                         function(x) {
                           if(!is.null(positions)){
                             if(inherits(positions, "sf")){
                               if(all(st_geometry_type(positions) %in% c("MULTIPOLYGON", "POLYGON") )){
                                 if(!is.null(position_names)){
                                   o_name <- position_names
                                 }else{
                                   o_name <-paste("Polygon" ,(1:nrow(positions)))
                                 }
                                 extr_df <- raster::extract(r_list_extract[[x]], positions, df = FALSE,fun=FUN,na.rm=TRUE)
                                 #if we did use a fun to aggregate, the previous step returned a dataframe instead of a list of dataframes
                                 #if so, things get more complicated
                                 # we need make it a list of 1 for consitency
                                 # (Alternatively use df=TRUE to get a df with a sequential ID which we could then recode somehow)
                                 if(!is.list(extr_df)){
                                   if(nlay>1){extr_df <- split(extr_df,1:nrow(extr_df))  #this now is a list of1 containing a vector, otherwise a list of n_objects containing a matrix
                                   }else{
                                     extr_df <- as.list(extr_df)
                                   }
                                 }
                                 #add the object name to the respective list element
                                 for(i in 1:length(extr_df)){
                                   extr_df[[i]] <- data.frame(matrix(extr_df[[i]],ncol = nlay,byrow = FALSE))
                                   extr_df[[i]]$position_name <- o_name[[i]]
                                   extr_df[[i]]$centr_lon <-   st_coordinates(st_centroid(st_geometry(positions)))[,1][i] #sf variant of the above
                                   extr_df[[i]]$centr_lat <-   st_coordinates(st_centroid(st_geometry(positions)))[,2][i] #sf variant of the above
                                 }
                                 #bind the list elements together
                                 extr_df <- do.call("rbind", extr_df)
                                 #ensure that its a data frame
                                 extr_df <- as.data.frame(extr_df)
                               }else if(all(st_geometry_type(positions)=="POINT")){
                                 if(!is.null(position_names)){
                                   o_name <- position_names
                                 }else{
                                   o_name <- paste("Point", 1:nrow(positions))
                                 }
                                 
                                 #Extract the Values, !!suppressing warnings which are currently caused by discarded datums due to Proj4->proj6 switch!!
                                 extr_df <-suppressWarnings(
                                   raster::extract(r_list_extract[[x]], positions, df = FALSE,fun=FUN,na.rm=TRUE)
                                 )
                                 
                                 #if we did use a fun to aggregate, the previous step returned a dataframe instead of a list of dataframes
                                 #if so, things get more complicated
                                 # we need make it a list of 1 for consitency
                                 # (Alternatively use df=TRUE to get a df with a sequential ID which we could then recode somehow)
                                 if(!is.list(extr_df)){
                                      if(nlay>1){extr_df <- split(extr_df,1:nrow(extr_df))  #this now is a list of1 containing a vector, otherwise a list of n_objects containing a matrix
                                      }else{
                                        extr_df <- as.list(extr_df)
                                      }
                                      
                                   }
                                 #add the object name to the respective list element
                                 for(i in 1:length(extr_df)){
                                   extr_df[[i]] <- data.frame(matrix(extr_df[[i]],ncol = nlay,byrow = FALSE))
                                   extr_df[[i]]$position_name <- o_name[i]
                                   extr_df[[i]]$centr_lon <-   st_coordinates(positions)[,1][i] #sf variant of the below
                                   extr_df[[i]]$centr_lat <-   st_coordinates(positions)[,2][i] #sf variant of the below
                                 }
                                 #bind the list elements together
                                 extr_df <- do.call("rbind", extr_df)
                                 #ensure that its a data frame
                                 extr_df <- as.data.frame(extr_df)
                               }
                               
                               
                               
                             }else if(inherits(positions,"SpatialPointsDataFrame")){
                               if(!is.null(position_names)){
                                 o_name <- position_names
                               }else{
                                 o_name <- paste("Point", 1:nrow(positions))
                               }
                               #Extract the Values, !!suppressing warnings which are currently caused by discarded datums due to Proj4->proj6 switch!!
                               extr_df <-suppressWarnings(
                                 raster::extract(r_list_extract[[x]], positions, df = FALSE,fun=FUN,na.rm=TRUE)
                               )
                               #if we did use a fun to aggregate, the previous step returned a dataframe instead of a list of dataframes
                               #if so, things get more complicated
                               # we need make it a list of 1 for consitency
                               # (Alternatively use df=TRUE to get a df with a sequential ID which we could then recode somehow)
                               if(!is.list(extr_df)){
                                 if(nlay>1){extr_df <- split(extr_df,1:nrow(extr_df))  #this now is a list of1 containing a vector, otherwise a list of n_objects containing a matrix
                                 }else{
                                   extr_df <- as.list(extr_df)
                                 }
                                 
                               }
                               #add the object name to the respective list element
                               for(i in 1:length(extr_df)){
                                 extr_df[[i]] <- data.frame(matrix(extr_df[[i]],ncol = nlay,byrow = FALSE))
                                 extr_df[[i]]$position_name <- o_name[[i]]
                                 extr_df[[i]]$centr_lon <- coordinates(positions)[, 1][i]
                                 extr_df[[i]]$centr_lat <- coordinates(positions)[, 2][i]
                               }
                               #bind the list elements together
                               extr_df <- do.call("rbind", extr_df)
                               #ensure that its a data frame
                               extr_df <- as.data.frame(extr_df)
                               
                             }else if(inherits(positions,"SpatialPolygonsDataFrame")){
                               if(!is.null(position_names)){
                                 o_name <- position_names
                               }else{
                                 o_name <-paste("Polygon" ,(1:nrow(positions)))
                               }
                               extr_df <- raster::extract(r_list_extract[[x]], positions, df = FALSE,fun=FUN,na.rm=TRUE)
                               #if we did use a fun to aggregate, the previous step returned a dataframe instead of a list of dataframes
                               #if so, things get more complicated
                               # we need make it a list of 1 for consitency
                               # (Alternatively use df=TRUE to get a df with a sequential ID which we could then recode somehow)
                               if(!is.list(extr_df)){
                                 if(nlay>1){extr_df <- split(extr_df,1:nrow(extr_df))  #this now is a list of1 containing a vector, otherwise a list of n_objects containing a matrix
                                 }else{
                                   extr_df <- as.list(extr_df)
                                 }
                                 
                               }
                               #add the object name to the respective list element
                               for(i in 1:length(extr_df)){
                                 extr_df[[i]] <- data.frame(matrix(extr_df[[i]],ncol = nlay,byrow = FALSE))
                                 extr_df[[i]]$position_name <- o_name[[i]]
                                 extr_df[[i]]$centr_lon <-   coordinates(positions)[,1][i] #sf variant of the above
                                 extr_df[[i]]$centr_lat <-   coordinates(positions)[,2][i] #sf variant of the above
                               }
                               #bind the list elements together
                               extr_df <- do.call("rbind", extr_df)
                               #ensure that its a data frame
                               extr_df <- as.data.frame(extr_df)
                               
                             }else if(inherits(positions,c("matrix","array"))){
                               assert_that(ncol(positions)==2)
                               if(!is.null(position_names)){
                                 o_name <- position_names
                               }else{
                                 o_name <- paste("Point", 1:nrow(positions))
                               }
                               extr_df <- raster::extract(r_list_extract[[x]], positions, df = FALSE,fun=FUN,na.rm=TRUE)
                               #if we did use a fun to aggregate, the previous step returned a dataframe instead of a list of dataframes
                               #if so, things get more complicated
                               # we need make it a list of 1 for consitency
                               # (Alternatively use df=TRUE to get a df with a sequential ID which we could then recode somehow)
                               if(!is.list(extr_df)){
                                 if(nlay>1){extr_df <- split(extr_df,1:nrow(extr_df))  #this now is a list of1 containing a vector, otherwise a list of n_objects containing a matrix
                                 }else{
                                   extr_df <- as.list(extr_df)
                                 }
                                 
                               }
                               #add the object name to the respective list element
                               for(i in 1:length(extr_df)){
                                 extr_df[[i]] <- data.frame(matrix(extr_df[[i]],ncol = nlay,byrow = FALSE))
                                 extr_df[[i]]$position_name <- o_name[[i]]
                                 extr_df[[i]]$centr_lon <- coordinates(positions)[, 1][i]
                                 extr_df[[i]]$centr_lat <- coordinates(positions)[, 2][i]
                               }
                               #bind the list elements together
                               extr_df <- do.call("rbind", extr_df)
                               #ensure that its a data frame
                               extr_df <- as.data.frame(extr_df)
                               
                             }
                           }else if(is.null(positions)){
                             extr_df <- as.data.frame(matrix( raster::cellStats(r_list_extract[[x]],FUN),nrow = 1,byrow = TRUE)) #unpiped
                             extr_df$lon <- mean(extent(r_list_extract[[x]])[1:2])
                             extr_df$lat <- mean(extent(r_list_extract[[x]])[3:4])
                             extr_df$position_name <- "AOI"
                             extr_df$centr_lon <- 0  #2do: add the centroid coords or sth equivalent
                             extr_df$centr_lat <- 0  #2do: add the centroid coords or sth equivalent
                           }
                           names(extr_df)[1:nlay] <- band_names
                           #extr_df$time <- frametimes[as.integer(x)]
                           extr_df$time <- frametimes[names(r_list_extract)==x]
                           return(extr_df)
                         }))
  extr_df$frame <- as.numeric(as.factor(extr_df$time))
  out <- extr_df 
  
  return(out)
}




#Aux function for rounding significant digits, credit to 
#https://stackoverflow.com/a/39611375
floor_dec <- function(x, level=1) round(x - 5*10^(-level-1), level)
ceiling_dec <- function(x, level=1) round(x + 5*10^(-level-1), level)


#' density chart. The positions are mapped to colors, the bands are mapped to facets
#' #' facets are bands, color is position
#' @param edf a dataframe of all extracted values across all frames. Should be continuous, derived from RGB or gradient rasters.
#' @param pl position_legend (Optional) logical. If \code{TRUE}: Add a legend for the positions. Only recommended if \code{aes_by_pos} is also  \code{TRUE}.
#' @param lp legend_position  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param bl band_legend (Optional) logical. If \code{TRUE}: Add a legend for the bands. Default is \code{TRUE}.
#' @param blt band_legend_title  (Ignored) character, title of the band legend. Default is \code{"Positions"}.
#' @param plt position_legend_title  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param ps plot_size (Optional) numeric, size for the ggplot objects. Default is \code{1}.
#' @param position_colors (Optional) character. Colors for the positions. By default, uses rainbow colors.
#' @param vs val_seq (Ignored) Value Sequence for the y axis.
#' @param abp aes_by_pos  (Ignored) logical. If \code{TRUE}: vary the linetype aesthetic to be different for each position? If  \code{FALSE}, this also disables the \code{position_legend}, as no notable classes will be plotted. Default is \code{TRUE}.
#' @importFrom dplyr ungroup summarise desc
#' @noRd
.ts_gg_dens <- function(edf,pl,lp, bl, blt,plt, ps, vs,abp,position_colors=NULL){
  
  if(abp){
    print("Ignoring aes_by_pos argument as grouping is done by position")
  }
  
  if(!((edf %>%  pull(value) %>% class()) %in% c("integer","numeric") )){
    warning("The value you are attempting to plot is not numeric. Are you sure you want to create a distribution plot? ")
  } 
  
  
  min(group_size(group_by(edf,position_name,band,frame))) -> n_value_min
  if(n_value_min<10){
    warning("Some frames contain less than 10 values for some positions. Are you sure you want to plot distribution? ")
  }
  
  
  #Prior: for all frames
  x_min <- edf %>% dplyr::select(value) %>% 
    drop_na() %>% 
    min()
  
  x_max <- edf %>% dplyr::select(value) %>% 
    drop_na() %>% 
    max()
  
  y_min <- 0
  
  y_max <- edf  %>% 
    drop_na() %>% 
    group_by(position_name,band,frame) %>% 
    mutate(dens=max(density((value),na.rm = T,kernel = "gaussian")$y)) %>% 
    ungroup() %>% 
    summarise(ymax=max(dens)) %>%
    pull()
  
  if(is.null(position_colors)){position_colors <- rainbow(length(unique(edf$position_name)))}
  
  #Per frame
  out_frames <- .lapply(1:max(edf$frame), function(i){
    
    x <- edf[edf$frame == i,]
    min(group_size(group_by(x,band,position_name))) -> n_value_min
    
    if(n_value_min<10){
      warning("Some frames contain less than 10 values for some positions. Are you sure you want to plot distribution? ")
    }
    
    if(abp){
      p <- x %>% ggplot(aes(value,..density..,fill=position_name))
    }else{
      p <- x %>% ggplot(aes(value,..density..,fill=position_name))
    }
    
    
    p <- p +
      geom_density(alpha=0.6)+
      facet_wrap(~band,ncol=1,scales = "fixed")+
      theme_bw() + 
      theme(axis.title.x=element_blank(),
            axis.text.x=element_blank(),
            axis.ticks.x=element_blank())+
      theme(legend.position = lp)+
      xlim(c(x_min,x_max))+
      ylim(c(y_min,y_max))
    
    #add the colors
    p <- p +
      scale_fill_manual(values = position_colors,
                        #breaks = unique(position_name),
                        name=plt)
    
    ## add legend
    if(!isTRUE(pl)){
      p <- p + guides(linetype = FALSE)
    }  
    if(!isTRUE(bl)){
      p <- p + guides(colour = FALSE)
    }  
    return(p)
  }
  )
  return(out_frames)
}

#' density chart. The bands are mapped to colors, the positions are mapped to facets
#' #' color is bands, facets are position
#' @param edf a dataframe of all extracted values across all frames. Should be continuous, derived from RGB or gradient rasters.
#' @param pl position_legend (Optional) logical. If \code{TRUE}: Add a legend for the positions. Only recommended if \code{aes_by_pos} is also  \code{TRUE}.
#' @param lp legend_position  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param bl band_legend (Ignored) logical. If \code{TRUE}: Add a legend for the bands. Default is \code{TRUE}.
#' @param blt band_legend_title  (Ignored) character, title of the band legend. Default is \code{"Positions"}.
#' @param plt position_legend_title  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param ps plot_size (Optional) numeric, size for the ggplot objects. Default is \code{1}.
#' @param position_colors (Optional) character. Colors for the positions. By default, uses rainbow colors.
#' @param vs val_seq (Ignored) Value Sequence for the y axis.
#' @param abp aes_by_pos  (Ignored) logical. If \code{TRUE}: vary the linetype aesthetic to be different for each position? If  \code{FALSE}, this also disables the \code{position_legend}, as no notable classes will be plotted. Default is \code{TRUE}.
#' @noRd
.ts_gg_dens2 <- function(edf,pl,lp, bl, blt,plt, ps, vs,abp){
  if(abp){
    print("Ignoring aes_by_pos argument as faceting is done by position")
  }
  
  
  if(!((edf %>%  pull(value) %>% class()) %in% c("integer","numeric") )){
    warning("The value you are attempting to plot is not numeric. Are you sure you want to plot distribution? ")
  }
  
  
  #Prior: for all frames
  x_min <- edf %>% dplyr::select(value) %>% 
    drop_na() %>% 
    min()
  
  x_max <- edf %>% dplyr::select(value) %>% 
    drop_na() %>% 
    max()
  
  y_min <- 0
  
  y_max <- edf  %>% 
    drop_na() %>% 
    group_by(position_name,band,frame) %>% 
    mutate(dens=max(density((value),na.rm = T,kernel = "gaussian")$y)) %>% 
    ungroup() %>% 
    summarise(ymax=max(dens)) %>%
    pull()
  
  min(group_size(group_by(edf,position_name,band,frame))) -> n_value_min
  if(n_value_min<10){
    warning("Some frames contain less than 10 values for some positions. Are you sure you want to plot distribution? ")
  }
  
  #Per frame
  out_frames <- .lapply(1:max(edf$frame), function(i){
    
    x <- edf[edf$frame == i,]
    min(group_size(group_by(x,position_name,band))) -> n_value_min
    
    if(n_value_min<10){
      warning("Some frames contain less than 10 values for some positions. Are you sure you want to plot distribution? ")
    }
    
    if(abp){
      p <- x %>% ggplot(aes(value,..density..,fill=band))
    }else{
      p <- x %>% ggplot(aes(value,..density..,fill=band))
    }
    
    
    p <- p +
      geom_density(alpha=0.6)+
      facet_wrap(~position_name,ncol=1,scales = "fixed")+
      theme_bw() + 
      theme(axis.title.x=element_blank(),
            axis.text.x=element_blank(),
            axis.ticks.x=element_blank())+
      theme(legend.position = lp)+
      xlim(c(x_min,x_max))+
      ylim(c(y_min,y_max))
    
    #add the colors
    p <- p +
      scale_colour_manual(values = x$band_colors,breaks = x$band, name=blt)
    
    ## add legend
    if(!isTRUE(pl)){
      p <- p + guides(linetype = FALSE)
    }  
    if(!isTRUE(bl)){
      p <- p + guides(colour = FALSE)
    }  
    return(p)
  }
  )
  return(out_frames)
}

#' violin chart
#' #' color is bands, facets are bands~position
#' @description Create a violin plot
#' @param edf a dataframe of all extracted values across all frames.  Should be continuous, derived from RGB or gradient rasters.
#' @param pl position_legend (Optional) logical. If \code{TRUE}: Add a legend for the positions. Only recommended if \code{aes_by_pos} is also  \code{TRUE}.
#' @param lp legend_position  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param bl band_legend (Optional) logical. If \code{TRUE}: Add a legend for the bands. Default is \code{TRUE}.
#' @param blt band_legend_title  (Optional) character, title of the band legend. Default is \code{"Positions"}.
#' @param plt position_legend_title  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param ps plot_size (Optional) numeric, size for the ggplot objects. Default is \code{1}.
#' @param vs val_seq Value Sequence for the y axis.
#' @param abp aes_by_pos  (Optional) logical. If \code{TRUE}: vary the linetype aesthetic to be different for each position? If  \code{FALSE}, this also disables the \code{position_legend}, as no notable classes will be plotted. Default is \code{TRUE}.
#' @return
#' @importFrom dplyr group_size group_by
#' @noRd
.ts_gg_vio <- function(edf,pl,lp, bl, blt,plt, ps, vs,abp){
  
  #Prior: for all frames
  out_frames <- .lapply(1:max(edf$frame), function(i){
    
    x <- edf[edf$frame == i,]
    
    if(!((edf %>%  pull(value) %>% class()) %in% c("integer","numeric") )){
      warning("The value you are attempting to plot is not numeric. Are you sure you want to create a violin plot? ")
    } 
    
    
    min(group_size(group_by(x,position_name,band))) -> n_value_min
    if(n_value_min<10){
      warning("Some frames contain less than 10 values for some positions. Are you sure you want to plot distribution? ")
    }
    
    ## generate base plot, either with position mapped to linetype or without
    if(!isTRUE(abp)){
      p <- ggplot(x, aes(x = 1, y = value,group = interaction(position_name,band),colour=band))
    }else{
      p <- ggplot(x, aes(x = 1, y = value,group = interaction(position_name,band),linetype=position_name,colour=band))+
        scale_linetype_discrete(name=plt)
      
    }
    
    #Style the plot
    p <-p +
      geom_violin( size = ps, show.legend = TRUE)+  
      coord_cartesian(xlim = c(0,2), ylim = c(min(vs, na.rm = TRUE), max(vs, na.rm = TRUE))) +
      theme_bw() + 
      theme(aspect.ratio = 1) +
      theme(axis.title.x=element_blank(),
            axis.text.x=element_blank(),
            axis.ticks.x=element_blank())+
      scale_y_continuous(expand = c(0,max(x$value)/10), breaks = vs)+
      facet_grid(position_name ~ band, scales='free')+
      theme(legend.position = lp)
    
    #add the colors
    p <- p +
      scale_colour_manual(values = x$band_colors,breaks = x$band, name=blt)
    
    
    ## add legend
    if(!isTRUE(pl)){
      p <- p + guides(linetype = FALSE)
    }  
    if(!isTRUE(bl)){
      p <- p + guides(colour = FALSE)
    }  
    
    return(p)
  }
  )
  
  return(out_frames)
}

#' line stats plot function
#' Adapted from moveVis and only lightly changed (to not require a move object and instead a rtsVis extracted dataframe
#' Therefore, maps bands to color and position to linetype
#' #' Color is bands, linetype is position
#' @param edf a dataframe of all extracted values across all frames.  Should be continuous, derived from RGB or gradient rasters.
#' @param pl position_legend (Optional) logical. If \code{TRUE}: Add a legend for the positions. Only recommended if \code{aes_by_pos} is also  \code{TRUE}.
#' @param lp legend_position  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param bl band_legend (Optional) logical. If \code{TRUE}: Add a legend for the bands. Default is \code{TRUE}.
#' @param blt band_legend_title  (Optional) character, title of the band legend. Default is \code{"Positions"}.
#' @param plt position_legend_title  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param ps plot_size (Optional) numeric, size for the ggplot objects. Default is \code{1}.
#' @param vs val_seq Value Sequence for the y axis.
#' @param abp aes_by_pos  (Optional) logical. If \code{TRUE}: vary the linetype aesthetic to be different for each position? If  \code{FALSE}, this also disables the \code{position_legend}, as no notable classes will be plotted. Default is \code{TRUE}.
#' @noRd
#' @importFrom dplyr first
.ts_gg_line <- function(edf , pl,lp, bl, blt,plt, ps, vs,abp){
  
  
  if(!((edf %>%  pull(value) %>% class()) %in% c("integer","numeric") )){
    warning("The value you are attempting to plot is not numeric. Are you sure you want to create a line plot? ")
  } 
  
  #Prior: for all frames
  x_min <- min(edf$time,na.rm = T)
  
  x_max <- max(edf$time,na.rm = T)
  
  if(!is.null(vs)){
    y_min <- min(vs)
  }else{
    min(edf$value,na.rm = T)
  }
  
  if(!is.null(vs)){
    y_max <- max(vs)
  }else{
    max(edf$value,na.rm = T)
  }
  
  
  y_max <- max(vs)
  
  edf <- edf %>% 
    drop_na() %>% 
    group_by(position_name,frame,band) %>% 
    summarise(value=mean(value),
              time=as.POSIXct(first(time)),
              band_colors=first(band_colors))
  
  #Per frame
  out_frames <- .lapply(1:max(edf$frame), function(i){
    
    #The data up to the current frame (this will be plotted)
    x = edf[edf$frame <= i,]
    
    ## generate base plot, either with position mapped to linetype or without
    if(!isTRUE(abp)){
      p <- ggplot(x, aes(x = time, y = value,group = interaction(position_name,band),colour=band))
    }else{
      p <- ggplot(x, aes(x = time, y = value,group = interaction(position_name,band),linetype=position_name,colour=band))+
        scale_linetype_discrete(name=plt)
      
    }
    ## style it
    p <- p +
      geom_path( size = ps, show.legend = TRUE)+  
      coord_cartesian(xlim = c(x_min,x_max), ylim = c(y_min,y_max)) +
      theme_bw() + 
      theme(aspect.ratio = 1) +
      scale_y_continuous(expand = c(0,0), breaks = vs)+
      theme(legend.position = lp)
    
    #add the colors
    p <- p +
      scale_colour_manual(values = x$band_colors,breaks = x$band, name=blt)
    
    
    ## add legend
    if(!isTRUE(pl)){
      p <- p + guides(linetype = FALSE)
    }  
    if(!isTRUE(bl)){
      p <- p + guides(colour = FALSE)
    }  
    return(p)
  }
  )
  return(out_frames)
}

#' line stats plot function
#' Version of the ts_gg_line where mappings for colors and positions are reversed
#' Therefore, maps bands to linetype and position to color
#' #' Linetype is bands, Color is position
#' @param edf a dataframe of all extracted values across all frames
#' @param pl position_legend (Optional) logical. If \code{TRUE}: Add a legend for the positions. Only recommended if \code{aes_by_pos} is also  \code{TRUE}.
#' @param lp legend_position  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param bl band_legend (Optional) logical. If \code{TRUE}: Add a legend for the bands. Default is \code{TRUE}.
#' @param blt band_legend_title  (Optional) character, title of the band legend. Default is \code{"Positions"}.
#' @param plt position_legend_title  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param ps plot_size (Optional) numeric, size for the ggplot objects. Default is \code{1}.
#' @param position_colors (Optional) character. Colors for the positions. By default, uses rainbow colors.
#' @param vs val_seq Value Sequence for the y axis.
#' @param abp aes_by_pos  (Optional) logical. If \code{TRUE}: vary the color aesthetic to be different for each position? If  \code{FALSE}, this also disables the \code{position_legend}, as no notable classes will be plotted. Default is \code{TRUE}.
#' @noRd
#' @importFrom grDevices rainbow
#' @importFrom dplyr select n_distinct
#' @importFrom tidyr drop_na
.ts_gg_line2 <- function(edf , pl,lp, bl, blt,plt, ps, vs,abp,position_colors=NULL){
  
  if(!((edf %>%  pull(value) %>% class()) %in% c("integer","numeric") )){
    warning("The value you are attempting to plot is not numeric. Are you sure you want to create a line plot? ")
  } 
  
  
  
  #Prior: for all frames
  x_min <- min(edf$time,na.rm = T)
  
  x_max <- max(edf$time,na.rm = T)
  
  if(!is.null(vs)){
    y_min <- min(vs)
  }else{
    min(edf$value,na.rm = T)
  }
  
  if(!is.null(vs)){
    y_max <- max(vs)
  }else{
    max(edf$value,na.rm = T)
  }
  
  
  y_max <- max(vs)
  
  edf <- edf %>% 
    drop_na() %>% 
    group_by(position_name,frame,band) %>% 
    summarise(value=mean(value),
              time=as.POSIXct(first(time)),
              band_colors=first(band_colors))
  
  #Per frame
  out_frames <- .lapply(1:max(edf$frame), function(i){
    
    #The data up to the current frame (this will be plotted)
    x = edf[edf$frame <= i,]
    #All data (this sets the frame)
    y=edf
    
    if(is.null(position_colors)){position_colors <- rainbow(length(unique(edf$position_name)))}
    
    ## generate base plot, either with position mapped to linetype or without
    if(!isTRUE(abp)){
      p <- ggplot(x, aes(x = time, y = value,group = interaction(position_name,band),linetype=band))
    }else{
      p <- ggplot(x, aes(x = time, y = value,group = interaction(position_name,band),linetype=band,colour=position_name))+
        scale_linetype_discrete(name=blt)
      
    }
    ## style it
    p <- p +
      geom_path( size = ps, show.legend = TRUE)+  
      coord_cartesian(xlim = c(min(y$time, na.rm = TRUE), max(y$time, na.rm = TRUE)), ylim = c(min(vs, na.rm = TRUE), max(vs, na.rm = TRUE))) +
      theme_bw() + 
      theme(aspect.ratio = 1) +
      scale_y_continuous(expand = c(0,0), breaks = vs)+
      theme(legend.position = lp)
    
    #add the colors
    p <- p +
      scale_colour_manual(values = position_colors,
                          #breaks = unique(position_name),
                          name=plt)
    
    
    ## add legend
    if(!isTRUE(bl)){
      p <- p + guides(linetype = FALSE)
    }
    if(!isTRUE(pl)){
      p <- p + guides(colour = FALSE)
    }
    return(p)
  }
  )
  return(out_frames)
}

#' Horizontal bar charts, where facets are bands, and bars are stacked 
#' #' facet is bands, y is position, fill is distinct, x is count
#' @param edf a dataframe of all extracted values across all frames. Should be categorical, derived from discrete rasters.
#' @param pl position_legend (Optional) logical. If \code{TRUE}: Add a legend for the positions. Only recommended if \code{aes_by_pos} is also  \code{TRUE}.
#' @param lp legend_position  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param bl band_legend (Optional) logical. If \code{TRUE}: Add a legend for the bands. Default is \code{TRUE}.
#' @param blt band_legend_title  (Optional) character, title of the band legend. Default is \code{"Positions"}.
#' @param plt position_legend_title  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param ps plot_size (Optional) numeric, size for the ggplot objects. Default is \code{1}.
#' @param position_colors (Ignored) character. Colors for the positions. By default, uses rainbow colors.
#' @param vs val_seq Value Sequence for the y axis.
#' @param abp aes_by_pos  (Ignored) logical. If \code{TRUE}: vary the linetype aesthetic to be different for each position? If  \code{FALSE}, this also disables the \code{position_legend}, as no notable classes will be plotted. Default is \code{TRUE}.
#' @noRd
#' @importFrom dplyr select n_distinct
.ts_gg_bar_stack <- function(i,edf,pl,lp, bl, blt,plt, ps, vs,abp){
  
  if(edf %>% dplyr::select(value) %>% n_distinct() > 10 ){
    warning("The variable to visualise has more than 10 distinct values. Are you sure you want to plot counts by value?")
  } 
  
  out_frames <- .lapply(1:max(edf$frame), function(i){
    
    x <- edf %>% dplyr::filter(frame==i) %>% drop_na()
    
    ## generate base plot
    p <- ggplot(x, aes(x = position_name,fill=value,col=value))+
      facet_wrap(~band)+
      theme_bw() + 
      theme(aspect.ratio = 1) +
      theme(legend.position = lp)+
      coord_flip()
    p <- p+geom_bar(position="stack",stat="count")
    return(p)
  }
  )
  return(out_frames)
}

#' Horizontal bar charts, where facets are bands, and bars are stacked. Fills so that proportions are more easily visible.
#' #' facet is bands, y is position, fill is distinct, x is proportion
#' @param edf a dataframe of all extracted values across all frames. Should be categorical, derived from discrete rasters.
#' @param pl position_legend (Optional) logical. If \code{TRUE}: Add a legend for the positions. Only recommended if \code{aes_by_pos} is also  \code{TRUE}.
#' @param lp legend_position  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param bl band_legend (Optional) logical. If \code{TRUE}: Add a legend for the bands. Default is \code{TRUE}.
#' @param blt band_legend_title  (Optional) character, title of the band legend. Default is \code{"Positions"}.
#' @param plt position_legend_title  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param ps plot_size (Optional) numeric, size for the ggplot objects. Default is \code{1}.
#' @param position_colors (Ignored) character. Colors for the positions. By default, uses rainbow colors.
#' @param vs val_seq Value Sequence for the y axis.
#' @param abp aes_by_pos  (Ignored) logical. If \code{TRUE}: vary the linetype aesthetic to be different for each position? If  \code{FALSE}, this also disables the \code{position_legend}, as no notable classes will be plotted. Default is \code{TRUE}.
#' @noRd
#' @importFrom dplyr select  

.ts_gg_bar_fill <- function(i,edf,pl,lp, bl, blt,plt, ps, vs,abp){
  
  if(edf %>% dplyr::select(value) %>% n_distinct() > 10 ){
    warning("The variable to visualise has more than 10 distinct values. Are you sure you want to plot counts by value?")
  } 
  
  out_frames <- .lapply(1:max(edf$frame), function(i){
    
    x <- edf %>% dplyr::filter(frame==i) %>% drop_na()
    
    ## generate base plot
    p <- ggplot(x, aes(x = position_name,fill=value,col=value))+
      facet_wrap(~band)+
      theme_bw() + 
      theme(aspect.ratio = 1) +
      theme(legend.position = lp)+
      coord_flip()+
      xlab("proportion")
    p <- p+geom_bar(position="fill",stat="count")
    return(p)
  }
  )
  return(out_frames)
}

#' pie chart for plotting proportions among categorical values
#' facet is bands vs position, angle is proportion
#' @param edf a dataframe of all extracted values across all frames. Should be categorical, derived from discrete rasters.
#' @param pl position_legend (Optional) logical. If \code{TRUE}: Add a legend for the positions. Only recommended if \code{aes_by_pos} is also  \code{TRUE}.
#' @param lp legend_position  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param bl band_legend (Optional) logical. If \code{TRUE}: Add a legend for the bands. Default is \code{TRUE}.
#' @param blt band_legend_title  (Optional) character, title of the band legend. Default is \code{"Positions"}.
#' @param plt position_legend_title  (Optional) character, position of the legend. Use \code{"none"} to disable all legends. Default is \code{"right"}.
#' @param ps plot_size (Optional) numeric, size for the ggplot objects. Default is \code{1}.
#' @param position_colors (Optional) character. Colors for the positions. By default, uses rainbow colors.
#' @param vs val_seq Value Sequence for the y axis.
#' @param abp aes_by_pos  (Optional) logical. If \code{TRUE}: vary the linetype aesthetic to be different for each position? If  \code{FALSE}, this also disables the \code{position_legend}, as no notable classes will be plotted. Default is \code{TRUE}.
#' @noRd
#' @importFrom dplyr select arrange tally pull mutate group_by desc
.ts_gg_pie <- function(edf,pl,lp, bl, blt,plt, ps, vs,abp){
  
  if(edf %>% dplyr::select(value) %>% n_distinct() > 10 ){
    stop("The variable to visualise has more than 10 distinct values. Are you sure you want to plot proportions by value?")
  } 
  
  out_frames <- .lapply(1:max(edf$frame), function(i){
    
    x <- edf %>% dplyr::filter(frame==i) %>% drop_na()
    
    #pie labels
    labels <- x %>% 
      group_by(band,position_name,value) %>%
      tally() %>%
      dplyr::arrange(desc(value)) %>% 
      mutate(cumulative=cumsum(n),
             midpoint=cumulative-n/2,
             label = paste0(value, " ", round(n / sum(n) * 100, 1), "%"),
             pos=(n / sum(n)),
             midpointpos=midpoint/sum(n))
    labels
    ## generate base plot
    
    p <- ggplot(labels, aes(x = "",fill=factor(value)))+
      facet_grid(band~position_name)+
      theme_bw() + 
      theme(aspect.ratio = 1) +
      theme(legend.position = lp)+
      theme(axis.line = element_blank(),
            axis.text = element_blank(),
            plot.title = element_text(hjust=0.5)) +
      coord_polar(theta = "y", start=0) + 
      labs(fill="", 
           x=NULL, 
           y=NULL)+
      geom_col(aes(y=pos),width=1) 
    
    #add labels
    p <-  p+geom_text(data = labels,mapping = aes(x=1,y=midpointpos,label=label))
    p
    return(p)
  }
  )
  return(out_frames)
}




#' Add \code{ggplot2} function to frames
#' @import ggplot2 
#' @noRd 
.ts_add_gg <- function(frames, gg, data = NULL, ..., verbose = TRUE){
  
  ## check data and replicate if necessary
  if(inherits(data, "list")){
    if(length(data) != length(frames)) out("Argument 'data' is a list und thus must be of same length as 'frames'.", type = 3)
  } else{
    data <- rep(list(data), length(frames))
  }
  
  ## gg is not a list, make it one
  if(inherits(gg, "list")){
    if(length(gg) != length(frames)) out("Argument 'gg' is a list und thus must be of same length as 'frames'.", type = 3)
  } else{
    if(length(gg) != length(frames)) gg <- rep(list(gg), length(frames))
  }
  if(!is.call(gg[[1]])) out("Argument 'gg' must be an expression or a list of expressions (see ?moveVis::add_gg and ?ggplot2::expr).", type = 3)
  
  mapply(.frame = frames, .gg = gg, data = data, function(.frame, .gg, data, arg = list(...)){
    if(length(arg) > 0) for(i in 1:length(arg)) assign(names(arg)[[i]], arg[[i]])
    return(.frame + eval(.gg)) #parse(text = paste0(y, collapse = " + ")))
  }, USE.NAMES = FALSE, SIMPLIFY = FALSE)
}
JohMast/rtsVis documentation built on Oct. 24, 2023, 8:31 p.m.

R Package Documentation

rdrr.io home R language documentation Run R code online

Browse R Packages

CRAN packages Bioconductor packages R-Forge packages GitHub packages

We want your feedback!

Note that we can't provide technical support on individual packages. You should contact the package authors for that.
GitHub issue tracker
ian@mutexlabs.com
Personal blog

 
Embedding an R snippet on your website

Add the following code to your website.

For more information on customizing the embed code, read Embedding Snippets.

Close