R/nr-core.R

In nara: Native Raster Image Tools

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Check if object is a native raster image
#' 
#' @param x object to check
#' 
#' @return logical. TRUE if object is a native raster image
#' 
#' @examples
#' is_nativeraster(mtcars)
#' 
#' nr <- nr_new(100, 100)
#' is_nativeraster(nr)
#' 
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
is_nativeraster <- function(x) {
  inherits(x, 'nativeRaster')
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Create a native raster image
#'
#' A native raster image in R looks like an integer matrix, but is interpreted
#' differently by graphics devices:
#'
#' \itemize{
#'   \item{The data should be treated as RGBA pixels in row-major ordering}
#'   \item{Each 32-bit integer should be interpreted as 4-bytes - one for each
#'         of the R, G, B and A color channels}
#' }
#'
#' @param width,height Image dimensions in pixels
#' @param nr native raster image to use as the template for the size of the 
#'        new image in \code{nr_new_from()}
#' @param fill Background fill color as a character string. Either a standard R color
#'        (e.g. 'blue', 'white')
#'        or a hex color of the form \code{#rrggbbaa}, \code{#rrggbb}, \code{#rgba}
#'        or \code{#rgb}
#'
#' @return native raster image
#' 
#' @examples
#' nr <- nr_new(400, 300, 'hotpink')
#' plot(nr)
#' 
#' @import colorfast
#' @family image creation functions
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_new <- function(width, height, fill = 'white') {
  nr <- .Call(nr_new_, width, height)
  .Call(nr_fill_, nr, fill)
  nr
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' @rdname nr_new
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_new_from <- function(nr, fill = 'white') {
  nr_new(width = ncol(nr), height = nrow(nr), fill = fill)
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Create a new native raster image and copy the dimensions and
#' contents from an existing image
#'
#' @inheritParams nr_fill
#' 
#' @return New native raster image
#' 
#' @examples
#' nr1 <- nr_new(200, 200, 'hotpink')
#' nr2 <- nr_copy(nr1)
#' plot(nr2)
#' @family image creation functions
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_copy <- function(nr) {
  .Call(nr_copy_, nr)
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Copy the contents of one native raster image into another.
#'
#' The source and destination native raster images must have the same dimensions.
#'
#' If the native raster images are of different sizes or alpha blending is
#' required, use the \code{\link{nr_blit}()} function.
#'
#' @param src,dst Source and destination native raster images
#'
#' @return Invisibly return the supplied 'dst' native raster image which was been
#'         modified in-place
#' 
#' @examples
#' nr1 <- nr_new(200, 100, 'hotpink')
#' nr2 <- nr_new(200, 100, 'green')
#' nr_copy_into(nr1, nr2)
#' plot(nr1)
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_copy_into <- function(dst, src) {
  invisible(.Call(nr_copy_into_, dst, src))
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Fill a native raster image with the given color
#'
#' @param nr native raster image
#' @param color Color as a character string. Either a standard R color
#'        (e.g. 'blue', 'white')
#'        or a hex color of the form \code{#rrggbbaa}, \code{#rrggbb}, \code{#rgba}
#'        or \code{#rgb}
#'        
#' @return Invisibly return the supplied native raster image which was been
#'         modified in-place       
#' 
#' @examples
#' nr <- nr_new(400, 300, 'hotpink')
#' nr_fill(nr, 'blue')
#' plot(nr)
#' 
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_fill <- function(nr, color) {
  invisible(.Call(nr_fill_, nr, color))
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Crop a section out of a native raster image into a new image
#' 
#' @inheritParams nr_fill
#' @param x,y,w,h dimensions of cropped section
#' @param loc dimensions of cropped section. A vector of 4 values 
#'        i.e. \code{c(x, y, w, h)}
#' 
#' @return New native raster image
#' 
#' @examples
#' nr <- deer[[1]]
#' dim(nr)
#' plot(nr)
#' 
#' nr2 <- nr_crop(nr, 16, 0, 16, 16)
#' dim(nr2)
#' plot(nr2)
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_crop <- function(nr, x, y, w, h) {
  dst <- nr_new(w, h)
  nr_blit(dst = dst, src = nr, 
          x = 0, y = 0, 
          xsrc = x, ysrc = y, 
          w = w, h = h, 
          hjust = 0, vjust = 0,
          use_alpha = FALSE)
  dst
}

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' @rdname nr_crop
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_crop2 <- function(nr, loc) {
  nr_crop(nr, loc[[1]], loc[[2]], loc[[3]], loc[[4]])
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Flip a native raster image vertically
#' 
#' @inheritParams nr_fill
#' 
#' @return Invisibly return the supplied native raster image which was been
#'         modified in-place
#' 
#' @examples
#' nr <- deer[[1]] |> nr_copy()
#' plot(nr)
#' nr_flipv(nr)
#' plot(nr)
#' @family transformation functions
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_flipv <- function(nr) {
  invisible(.Call(nr_flipv_, nr))
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Flip a native raster image horizontally
#' 
#' @inheritParams nr_fill
#' 
#' @return Invisibly return the supplied native raster image which was been
#'         modified in-place
#' 
#' @examples
#' nr <- nr_new(400, 200, 'white')
#' nr_rect(nr, 0, 0, 30, 15)
#' plot(nr)
#' nr_fliph(nr)
#' plot(nr)
#' @family transformation functions
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_fliph <- function(nr) {
  invisible(.Call(nr_fliph_, nr))
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Rotate a native raster image by 90,180,270 degrees
#' @inheritParams nr_fill
#' @param angle one of 0,90,180,270
#' 
#' @return Invisibly return the supplied native raster image which was been
#'         modified in-place
#' 
#' @examples
#' nr <- nr_new(20, 10, 'hotpink')
#' dim(nr)
#' nr_rotate(nr, 90)
#' dim(nr)
#' @family transformation functions
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_rotate <- function(nr, angle) {
  invisible(
    .Call(nr_rotate_, nr, angle)
  )
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Transpose
#' @inheritParams nr_fill
#' @return Invisibly return the supplied native raster image which was been
#'         modified in-place
#' @examples
#' nr <- nr_new(20, 10, 'hotpink')
#' dim(nr)
#' nr_transpose(nr)
#' dim(nr)
#' @family transformation functions
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
nr_transpose <- function(nr) {
  invisible(
    .Call(nr_transpose_, nr)
  )  
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Print method
#' 
#' @param x native raster image
#' @param ... ignored
#' @return None
#' @examples
#' nr <- nr_new(500, 400)
#' print(nr)
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
print.nativeRaster <- function(x, ...) {
  d <- dim(x)
  cat(sprintf("<nativeRaster> object: rows:%i  cols:%i\n", d[1], d[2]))
  invisible(x)
}



#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Plot a native raster image (after first clearning the device)
#' 
#' @param x native raster image
#' @param y ignored
#' @param ... other arguments passed to \code{grid::grid.raster()}
#'
#' @return Invisibly return the supplied native raster image
#' 
#' @examples
#' nr <- nr_new(200, 100, 'hotpink')
#' plot(nr)
#' 
#' @import grid
#' @importFrom grDevices dev.flush dev.hold
#' @export
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
plot.nativeRaster <- function(x, y, ...) {
  grid::grid.newpage()
  grDevices::dev.hold()
  grid::grid.raster(x, interpolate = FALSE, ...)
  grDevices::dev.flush()
  invisible(x)
}