Skip to content

Commit

Permalink
formatting
Browse files Browse the repository at this point in the history
  • Loading branch information
@achubaty
achubaty committed Nov 19, 2018
1 parent d54d7ee commit 443283c
Showing 1 changed file with 105 additions and 107 deletions.
212 changes: 105 additions & 107 deletions R/postProcess.R
View file
Expand Up @@ -453,10 +453,9 @@ projectInputs.Raster <- function(x, targetCRS = NULL, rasterToMatch = NULL, ...)
} else if (is.null(rasterToMatch) & identical(crs(x), targetCRS)) {
message(" no reprojecting because target CRS is same as input CRS.")
} else {

if (is.null(targetCRS)) {
targetCRS <- crs(rasterToMatch)
}
if (is.null(targetCRS)) {
targetCRS <- crs(rasterToMatch)
}

doProjection <- FALSE

Expand All @@ -468,130 +467,129 @@ projectInputs.Raster <- function(x, targetCRS = NULL, rasterToMatch = NULL, ...)
!identical(extent(x), extent(rasterToMatch)))
TRUE

if (doProjection) {
message(" reprojecting ...")
if (doProjection) {
message(" reprojecting ...")

if (!canProcessInMemory(x, 4)) {
if (!canProcessInMemory(x, 4)) {

message(" large raster: reprojecting after writing to temp drive...")
#rasters need to go to same file so it can be unlinked at end without losing other temp files
tmpRasPath <- checkPath(file.path(raster::tmpDir(), "bigRasters"), create = TRUE)
tempSrcRaster <- file.path(tmpRasPath, "bigRasInput.tif")
tempDstRaster <- file.path(tmpRasPath, paste0(x@data@names,"_reproj.tif")) #fails if x = stack
message(" large raster: reprojecting after writing to temp drive...")
#rasters need to go to same file so it can be unlinked at end without losing other temp files
tmpRasPath <- checkPath(file.path(raster::tmpDir(), "bigRasters"), create = TRUE)
tempSrcRaster <- file.path(tmpRasPath, "bigRasInput.tif")
tempDstRaster <- file.path(tmpRasPath, paste0(x@data@names,"_reproj.tif")) #fails if x = stack

if (!is.null(rasterToMatch)) {
tr <- res(rasterToMatch)
} else {
tr <- res(x)
}
# the raster is in memory, but large enough to trigger this function: write it to disk
if (!is.null(rasterToMatch)) {
tr <- res(rasterToMatch)
} else {
tr <- res(x)
}
# the raster is in memory, but large enough to trigger this function: write it to disk

gdalUtils::gdal_setInstallation()
if (.Platform$OS.type == "windows") {
exe <- ".exe"
} else exe <- ""
gdalUtils::gdal_setInstallation()
if (.Platform$OS.type == "windows") {
exe <- ".exe"
} else exe <- ""

if (is.null(dots$method)) {
dots$method <- assessDataType(x, type = "projectRaster")
}
if (is.null(dots$method)) {
dots$method <- assessDataType(x, type = "projectRaster")
}

if (dots$method == "ngb") {
dots$method <- "near"
}
if (dots$method == "ngb") {
dots$method <- "near"
}

if (inMemory(x)) { #must be written to disk
dType <- assessDataType(x, type = "writeRaster")
writeRaster(x, filename = tempSrcRaster, datatype = dType, overwrite = TRUE)
rm(x) #Saves memory if this was a huge raster but be careufl
gc()
} else {
tempSrcRaster <- x@file@name #Keep original raster
}
if (inMemory(x)) { #must be written to disk
dType <- assessDataType(x, type = "writeRaster")
writeRaster(x, filename = tempSrcRaster, datatype = dType, overwrite = TRUE)
rm(x) #Saves memory if this was a huge raster but be careufl
gc()
} else {
tempSrcRaster <- x@file@name #Keep original raster
}

dType <- assessDataType(raster(tempSrcRaster), type = "GDAL")
system(
paste0(paste0(getOption("gdalUtils_gdalPath")[[1]]$path, "gdalwarp", exe, " "),
"-s_srs \"", as.character(raster::crs(raster::raster(tempSrcRaster))), "\"",
" -t_srs \"", as.character(targetCRS), "\"",
" -multi ",
"-ot ", dType,
" -te ", paste0(extent(rasterToMatch)@xmin, " ", extent(rasterToMatch)@ymin, " ",
extent(rasterToMatch)@xmax, " ", extent(rasterToMatch)@ymax, " "),
"-r ", dots$method,
" -overwrite ",
"-tr ", paste(tr, collapse = " "), " ",
"\"", tempSrcRaster, "\"", " ",
"\"", tempDstRaster, "\""),
wait = TRUE)
##
x <- raster(tempDstRaster)
#file exists in temp drive. Can copy to filename2
dType <- assessDataType(raster(tempSrcRaster), type = "GDAL")
system(
paste0(paste0(getOption("gdalUtils_gdalPath")[[1]]$path, "gdalwarp", exe, " "),
"-s_srs \"", as.character(raster::crs(raster::raster(tempSrcRaster))), "\"",
" -t_srs \"", as.character(targetCRS), "\"",
" -multi ",
"-ot ", dType,
" -te ", paste0(extent(rasterToMatch)@xmin, " ", extent(rasterToMatch)@ymin, " ",
extent(rasterToMatch)@xmax, " ", extent(rasterToMatch)@ymax, " "),
"-r ", dots$method,
" -overwrite ",
"-tr ", paste(tr, collapse = " "), " ",
"\"", tempSrcRaster, "\"", " ",
"\"", tempDstRaster, "\""),
wait = TRUE)
##
x <- raster(tempDstRaster)
#file exists in temp drive. Can copy to filename2

} else {
} else {

origDataType <- dataType(x)
origDataType <- dataType(x)

# Capture problems that projectRaster has with objects of class integers,
# which is different than if they are integers (i.e., a numeric class object)
# can be integers, without being classified and stored in R as integer
isInteger <- if (is.integer(x[])) TRUE else FALSE # should be faster than assessDataType, as it
# is a class determination, not a numeric assessment
if (isInteger) {
needWarning <- FALSE
if (is.null(dots$method)) {
needWarning <- TRUE
} else {
if (dots$method != "ngb")
needWarning <- TRUE
}
if (needWarning)
warning("This raster layer has integer values; it will be reprojected to float. ",
"Did you want to pass 'method = \"ngb\"'?")
}
# Capture problems that projectRaster has with objects of class integers,
# which is different than if they are integers (i.e., a numeric class object)
# can be integers, without being classified and stored in R as integer
isInteger <- if (is.integer(x[])) TRUE else FALSE # should be faster than assessDataType, as it
# is a class determination, not a numeric assessment
if (isInteger) {
needWarning <- FALSE
if (is.null(dots$method)) {
dots$method <- assessDataType(x, type = "projectRaster") #not foolproof method of determining reclass method
needWarning <- TRUE
} else {
if (dots$method != "ngb")
needWarning <- TRUE
}
if (needWarning)
warning("This raster layer has integer values; it will be reprojected to float. ",
"Did you want to pass 'method = \"ngb\"'?")
}
if (is.null(dots$method)) {
dots$method <- assessDataType(x, type = "projectRaster") #not foolproof method of determining reclass method
}

if (is.null(rasterToMatch)) {
tempRas <- projectExtent(object = x, crs = targetCRS) ## make a template RTM, with targetCRS
Args <- append(dots, list(from = x, to = tempRas))
warn <- capture_warnings(x <- do.call(projectRaster, args = Args))
if (is.null(rasterToMatch)) {
tempRas <- projectExtent(object = x, crs = targetCRS) ## make a template RTM, with targetCRS
Args <- append(dots, list(from = x, to = tempRas))
warn <- capture_warnings(x <- do.call(projectRaster, args = Args))

} else {
# projectRaster does silly things with integers, i.e., it converts to numeric
tempRas <- projectExtent(object = rasterToMatch, crs = targetCRS) ## make a template RTM, with targetCRS
Args <- append(dots, list(from = x, to = tempRas))
warn <- capture_warnings(x <- do.call(projectRaster, args = Args))

if (identical(crs(x), crs(rasterToMatch)) & any(res(x) != res(rasterToMatch))) {
if (all(res(x) %==% res(rasterToMatch))) {
res(x) <- res(rasterToMatch)
} else {
stop(paste0("Error: input and output resolutions are not similar after using projectRaster.\n",
"You can try increasing error tolerance in options('fpCompare.tolerance')."))
}
} else {
# projectRaster does silly things with integers, i.e., it converts to numeric
tempRas <- projectExtent(object = rasterToMatch, crs = targetCRS) ## make a template RTM, with targetCRS
Args <- append(dots, list(from = x, to = tempRas))
warn <- capture_warnings(x <- do.call(projectRaster, args = Args))

if (identical(crs(x), crs(rasterToMatch)) & any(res(x) != res(rasterToMatch))) {
if (all(res(x) %==% res(rasterToMatch))) {
res(x) <- res(rasterToMatch)
} else {
stop(paste0("Error: input and output resolutions are not similar after using projectRaster.\n",
"You can try increasing error tolerance in options('fpCompare.tolerance')."))
}
}
}

# return the integer class to the data in the raster object
if (isTRUE(isInteger)) {
dataType(x) <- origDataType
x[] <- as.integer(x[])
}
# return the integer class to the data in the raster object
if (isTRUE(isInteger)) {
dataType(x) <- origDataType
x[] <- as.integer(x[])
}

warn <- warn[!grepl("no non-missing arguments to m.*; returning .*Inf", warn)] # This is a bug in raster
warnings(warn)
## projectRaster doesn't always ensure equal res (floating point number issue)
## if resolutions are close enough, re-write res(x)
## note that when useSAcrs = TRUE, the different resolutions may be due to
## the different projections (e.g. degree based and meter based). This should be fine
warn <- warn[!grepl("no non-missing arguments to m.*; returning .*Inf", warn)] # This is a bug in raster
warnings(warn)
## projectRaster doesn't always ensure equal res (floating point number issue)
## if resolutions are close enough, re-write res(x)
## note that when useSAcrs = TRUE, the different resolutions may be due to
## the different projections (e.g. degree based and meter based). This should be fine

}
} else {
message(" no reprojecting because target characteristics same as input Raster.")
}

}
} else {
message(" no reprojecting because target characteristics same as input Raster.")
}
}

if (isFactorRaster) {
levels(x) <- rasterFactorLevels
Expand Down

0 comments on commit 443283c

Please sign in to comment.