#' Raster and 'ff' file-backed arrays
#'
#' Create an file-backed 'ff' object from a raster, or a raster-enabled file.
#'
#' When the object is created from a filename, `raster::brick` is used. The 'dim'ension
#' for raster and for ff in this context always keeps degenerate singletons. Please
#' get in touch if this causes you problems.
#'
#' @param x raster or raster-able file
#' @param ... arguments to methods
#' @param readonly open in read-only mode (TRUE by default)
#' @param filename path to file to create
#'
#' @return `ff` object
#' @export
#'
#' @examples
#' f <- system.file("extdata", "raster", "sst.grd", package = "ffraster")
#' ff_object(raster::brick(f))
#' if (interactive()) {
#' arr <- ff_object(f, filename = "afile.grd")
#' }
ff_object <- function(x, readonly = TRUE, filename = NULL, ...) {
UseMethod("ff_object")
}
#' @name ff_object
#' @export
#' @importFrom raster filename
ff_object.BasicRaster <- function(x, readonly = TRUE, filename = NULL, ...) {
ini <- try(ini_file(x))
if (inherits(ini, "try-error")) {
print("cannot interpret backing file for this object")
print(x)
stop("\n\n--end--")
}
# set up data dimensions and order
vdim <- dim(x)
dimo <- dim_order(x)
ff_out <- ff(dim = dim(x),
vmode = ff_type(x),
dimorder = dimo,
readonly = readonly,
filename = gri_filename(x))
## now the virtual dim order must always be column-
#ff::dimorder(ff_out) <- seq_along(dimo)
ff_out
}
#' @name ff_object
#' @export
#' @importFrom yesno yesno
ff_object.character <- function(x, readonly = TRUE, filename = NULL, ...) {
if (is.null(filename)) {
stop("please specify a filename, must end in \".grd\"")
}
answer <- yesno::yesno("do you want to create a raster and write this object to a new file?",
"\n", filename)
if (!answer) {return(invisible(NULL))}
ff_object(raster::brick(x, filename = filename), readonly = readonly, ...)
}
#' ffraster
#'
#' Build a ff array to be used as a raster.
##
#' For mapping between raster and ff types, see \code{\link[ff]{vmode}} and \code{\link[raster]{dataType}}
##
#' @param dim dimensions in Raster order (nrow, ncol, nlayer)
#' @param mode ff data mode see details
#' @param readonly open in readonly mode (TRUE is default)
#' @param filename file name as per \code{\link{writeRaster}}
#' @importFrom ff ff
#' @importFrom raster raster
#' @return ff
#' @export
#' @examples
#' mat <- volcano
#' library(raster)
#' b <- brick(raster(mat), raster(mat), raster(mat))
#' fn <- rasterTmpFile()
#' dt <- "byte"
#' ffraster:::.writeGRD(b, dataType = dt, filename = fn)
#' a <- ffrarr(dim(b), mode = dt, filename = fn, readonly = FALSE)
ffrarr <- function(dim, mode, filename, readonly = TRUE) {
# set up data dimensions and order
vdim <- dim
vm <- c(INT1U = "ubyte", FLT4S = "single", FLT8S = "double")[mode]
vm <- mode
# bit of overkill to work with n-D
if(vdim[length(vdim)] < 2) vdim <- vdim[length(vdim)-1]
dimo <- seq_along(vdim)[c(seq_along(vdim)[-1], 1)]
# dimo <- c(3, 1, 2)
ff(dim = vdim, vmode = vm, dimorder = dimo, readonly = readonly, filename = gsub("grd$", "gri", filename))
}
raster_.nodatavalue <-
function (object)
{
if (inherits(object, "RasterStack")) {
return(sapply(object@layers, function(x) x@file@nodatavalue))
}
return(object@file@nodatavalue)
}
#' @importFrom raster extension<-
raster_.setFileExtensionHeader <-
function (fname, type = "raster")
{
if (type == "raster") {
extension(fname) <- ".grd"
}
else if (type == "SAGA") {
extension(fname) <- "sgrd"
}
else if (type == "IDRISI") {
extension(fname) <- ".rdc"
}
else if (type == "IDRISIold") {
extension(fname) <- ".doc"
}
else if (type %in% c("BIL", "BSQ", "BIP")) {
extension(fname) <- ".hdr"
}
else if (type == "big.matrix") {
extension(fname) <- ".brd"
}
else {
stop("unknown file format")
}
return(fname)
}
#' @importFrom raster xmin ymin xmax ymax projection nlayers trim minValue maxValue getZ
.writeGRD <- function (x, type = "raster", filename = NULL, dataType = NULL, byteorder = "little", bandorder = "BIL",
nbands = NULL, dates = NULL, overwrite = FALSE)
{
if (file.exists(filename) && !overwrite) stop("'filename' exists, use a different file or set 'overwrite = TRUE'")
if (overwrite) {
unlink(filename)
binfilename <- gsub("grd$", "gri", filename)
if (file.exists(binfilename)) unlink(binfilename)
}
rastergrd <- raster_.setFileExtensionHeader(filename, type)
thefile <- file(rastergrd, "w")
cat("[general]", "\n", file = thefile, sep = "")
cat("creator=R package 'raster'", "\n", file = thefile, sep = "")
cat("created=", format(Sys.time(), "%Y-%m-%d %H:%M:%S"),
"\n", file = thefile, sep = "")
cat("[georeference]", "\n", file = thefile, sep = "")
cat("nrows=", nrow(x), "\n", file = thefile, sep = "")
cat("ncols=", ncol(x), "\n", file = thefile, sep = "")
cat("xmin=", as.character(xmin(x)), "\n", file = thefile,
sep = "")
cat("ymin=", as.character(ymin(x)), "\n", file = thefile,
sep = "")
cat("xmax=", as.character(xmax(x)), "\n", file = thefile,
sep = "")
cat("ymax=", as.character(ymax(x)), "\n", file = thefile,
sep = "")
cat("projection=", projection(x), "\n", file = thefile, sep = "")
cat("[data]", "\n", file = thefile, sep = "")
cat("datatype=", dataType, "\n", file = thefile,
sep = "")
cat("byteorder=", byteorder, "\n", file = thefile,
sep = "")
if (is.null(nbands)) {
nl <- nlayers(x)
miv <- paste(minValue(x, -1, warn = FALSE), collapse = ":")
mav <- paste(maxValue(x, -1, warn = FALSE), collapse = ":")
ln <- gsub(":", ".", names(x))
ln <- paste(ln, collapse = ":")
} else {
nl <- nbands
miv <- paste(rep(minValue(x, -1, warn = FALSE), nbands), collapse = ":")
mav <- paste(rep(maxValue(x, -1, warn = FALSE), nbands), collapse = ":")
ln <- gsub(":", ".", names(x))
ln <- paste(paste(ln, seq(nbands), sep = "."), collapse = ":")
}
cat("nbands=", nl, "\n", file = thefile, sep = "")
cat("bandorder=", bandorder, "\n", file = thefile,
sep = "")
if (nl == 1) {
fact <- is.factor(x)[1]
cat("categorical=", paste(fact, collapse = ":"), "\n",
file = thefile, sep = "")
if (any(fact)) {
r <- x@data@attributes[[1]]
cat("ratnames=", paste(colnames(r), collapse = ":"),
"\n", file = thefile, sep = "")
cat("rattypes=", paste(sapply(r, class), collapse = ":"),
"\n", file = thefile, sep = "")
cat("ratvalues=", paste(trim(as.character(as.matrix(r))),
collapse = ":"), "\n", file = thefile, sep = "")
}
if (length(x@legend@colortable) > 1) {
cat("colortable=", paste(x@legend@colortable, collapse = ":"),
"\n", file = thefile, sep = "")
}
}
cat("minvalue=", miv,
"\n", file = thefile, sep = "")
cat("maxvalue=", mav,
"\n", file = thefile, sep = "")
cat("nodatavalue=", raster_.nodatavalue(x), "\n", file = thefile,
sep = "")
cat("[legend]", "\n", file = thefile, sep = "")
# cat("legendtype=", x@legend@type, "\n", file = thefile, sep = "")
# cat("values=", paste(x@legend@values, collapse = ":"), "\n",
# file = thefile, sep = "")
# cat("color=", paste(x@legend@color, collapse = ":"), "\n",
# file = thefile, sep = "")
cat("[description]", "\n", file = thefile, sep = "")
cat("layername=", ln, "\n", file = thefile,
sep = "")
z <- getZ(x)
if (!is.null(nbands)) {
if (is.null(dates)) dates <- seq_len(nbands)
z <- dates
}
if (!is.null(z)) {
zname <- names(x@z)[1]
if (is.null(zname)) {
zname <- "z-value"
}
zclass <- class(z)
if (inherits(z, "POSIXct")) {
z <- format(z, "%Y-%m-%d %H:%M:%S", tz = "UTC")
}
else {
z <- as.character(z)
}
cat("zvalues=", paste(c(zname, z), collapse = ":"), "\n",
file = thefile, sep = "")
cat("zclass=", zclass, "\n", file = thefile, sep = "")
}
a <- NULL
try(a <- unlist(x@history), silent = TRUE)
if (!is.null(a)) {
cat("history=", a, "\n", file = thefile, sep = "")
}
a <- NULL
try(a <- rapply(x@history, function(x) paste(as.character(x),
collapse = "#,#")), silent = TRUE)
if (!is.null(a)) {
a <- gsub("\n", "#NL#", a)
type <- rapply(x@history, class)
type_value <- apply(cbind(type, a), 1, function(x) paste(x,
collapse = ":"))
name_type_value <- apply(cbind(names(a), type_value),
1, function(x) paste(x, collapse = "="))
name_type_value <- paste(name_type_value, "\n", sep = "")
cat("[metadata]", "\n", file = thefile, sep = "")
cat(name_type_value, file = thefile, sep = "")
}
close(thefile)
return(TRUE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.