1# Note that reg.finalizer does not finalize objects 2# at the end of an R session. This could be a problem. 3.setCollectorFun <- function(object, fun) { 4 5 if (is.null(fun)) fun <- function(obj) obj 6 reg.finalizer(object, fun, onexit=TRUE) 7 8} 9 10assertClass <- function(object, class) { 11 12 if (class %in% is(object)) 13 invisible(object) 14 else 15 stop(paste('Object is not a member of class', class)) 16 17} 18 19.GDALDataTypes <- c('Unknown', 'Byte', 'UInt16', 'Int16', 'UInt32', 20 'Int32', 'Float32', 'Float64', 'CInt16', 'CInt32', 21 'CFloat32', 'CFloat64') 22 23.normalize_if_path <- function(file, mustWork = NA) { 24 if (file.exists(file)) { 25 file <- normalizePath(file, mustWork = mustWork) 26 } 27 file 28} 29 30 31setClass('GDALMajorObject', 32 representation(handle = 'externalptr')) 33 34getDescription <- function(object) { 35 36 assertClass(object, 'GDALMajorObject') 37 38 .Call('RGDAL_GetDescription', object, PACKAGE="rgdal") 39 40} 41 42getGDALVersionInfo <- function(str="--version") { 43 stopifnot(is.character(str)) 44 .Call("RGDAL_GDALVersionInfo", str, PACKAGE="rgdal") 45} 46 47getGDALCheckVersion <- function() { 48 .Call("RGDAL_GDALCheckVersion", PACKAGE="rgdal") 49} 50 51getGDALwithGEOS <- function() { 52 res <- .Call("RGDAL_GDALwithGEOS", PACKAGE="rgdal") 53 if (is.character(res)) { 54 oo <- strsplit(res, "\n")[[1]] 55 res <- "GEOS_ENABLED=YES" %in% oo 56 attr(res, "GEOS_VERSION") <- substring(oo[grep("GEOS_VERSION", oo)], 14) 57 } 58 res 59} 60 61getGDAL_DATA_Path <- function() { 62 res <- .Call("RGDAL_GDAL_DATA_Info", PACKAGE="rgdal") 63 res <- sub("stateplane.csv", "", res) 64 n <- nchar(res) 65 res <- substring(res, 1, n-1) 66 res 67} 68 69version_sp_linkingTo <- function() { 70 .Call("rgdal_sp_linkingTo_version") 71} 72 73 74get_cached_orig_PROJ_LIB <- function() { 75 get(".rgdal_old.PROJ_LIB", envir=.RGDAL_CACHE) 76} 77 78get_cached_orig_GDAL_DATA <- function() { 79 get(".rgdal_old.GDAL_DATA", envir=.RGDAL_CACHE) 80} 81 82get_cached_set_PROJ_LIB <- function() { 83 get(".rgdal_set.PROJ_LIB", envir=.RGDAL_CACHE) 84} 85 86get_cached_set_GDAL_DATA <- function() { 87 get(".rgdal_set.GDAL_DATA", envir=.RGDAL_CACHE) 88} 89 90 91 92 93setClass('GDALDriver', 'GDALMajorObject') 94 95setClass('GDALReadOnlyDataset', 'GDALMajorObject') 96 97setClass('GDALDataset', 'GDALReadOnlyDataset') 98 99setClass('GDALTransientDataset', 'GDALDataset') 100 101setClass('GDALRasterBand', 'GDALMajorObject') 102 103getGDALDriverNames <- function() { 104 res <- .Call('RGDAL_GetDriverNames', PACKAGE="rgdal") 105 has_isRaster <- 0L 106 if (!is.null(attr(res, "isRaster"))) has_isRaster <- 1L 107 if (has_isRaster) res$isRaster <- attr(res, "isRaster") 108 res <- as.data.frame(res, stringsAsFactors=FALSE) 109 if (has_isRaster) res <- res[res$isRaster,] 110 res <- res[order(res$name),] 111 row.names(res) <- NULL 112 res 113} 114 115setMethod('initialize', 'GDALDriver', 116 def = function(.Object, name, handle = NULL) { 117 if (is.null(handle)) { 118 slot(.Object, 'handle') <- { 119 .Call('RGDAL_GetDriver', as.character(name), PACKAGE="rgdal") 120 } 121 } else { 122 slot(.Object, 'handle') <- handle 123 } 124 .Object 125 }) 126 127getDriverName <- function(driver) { 128 129 assertClass(driver, 'GDALDriver') 130 131 .Call('RGDAL_GetDriverShortName', driver, PACKAGE="rgdal") 132 133} 134 135getDriverLongName <- function(driver) { 136 137 assertClass(driver, 'GDALDriver') 138 139 .Call('RGDAL_GetDriverLongName', driver, PACKAGE="rgdal") 140 141} 142 143setMethod('initialize', 'GDALReadOnlyDataset', 144 def = function(.Object, filename, silent=FALSE, handle = NULL, 145 allowedDrivers=NULL, options=NULL) { 146 if (is.null(handle)) { 147 filename <- as.character(filename) 148 if (nchar(filename) == 0) stop("empty file name") 149 silent <- as.logical(silent) 150 if (length(silent) != 1L || is.na(silent) || !is.logical(silent)) 151 stop("options(warn) not set") 152 if (!is.null(options)) options <- as.character(options) 153 if (!is.null(allowedDrivers)) 154 allowedDrivers <- as.character(allowedDrivers) 155 slot(.Object, 'handle') <- { 156 .Call('RGDAL_OpenDataset', 157 .normalize_if_path(filename, mustWork=NA), 158 TRUE, silent, allowedDrivers, options, PACKAGE="rgdal") 159 } 160 } else { 161 slot(.Object, 'handle') <- handle 162 } 163 cfn <- function(handle) .Call('RGDAL_CloseHandle', 164 handle, PACKAGE="rgdal") 165 .setCollectorFun(slot(.Object, 'handle'), cfn) 166 .Object 167 }) 168 169setMethod('initialize', 'GDALDataset', 170 def = function(.Object, filename, silent=FALSE, handle = NULL, 171 allowedDrivers=NULL, options=NULL) { 172 if (is.null(handle)) { 173 filename <- as.character(filename) 174 if (nchar(filename) == 0) stop("empty file name") 175 silent <- as.logical(silent) 176 if (length(silent) != 1L || is.na(silent) || !is.logical(silent)) 177 stop("options(warn) not set") 178 if (!is.null(options)) options <- as.character(options) 179 if (!is.null(allowedDrivers)) 180 allowedDrivers <- as.character(allowedDrivers) 181 slot(.Object, 'handle') <- { 182 .Call('RGDAL_OpenDataset', 183 .normalize_if_path(filename, mustWork=NA), 184 FALSE, silent, allowedDrivers, options, PACKAGE="rgdal") 185 } 186 } else { 187 slot(.Object, 'handle') <- handle 188 } 189 cfn <- function(handle) .Call('RGDAL_CloseHandle', 190 handle, PACKAGE="rgdal") 191 .setCollectorFun(slot(.Object, 'handle'), cfn) 192 .Object 193 }) 194 195setMethod('initialize', 'GDALTransientDataset', 196 def = function(.Object, driver, rows, cols, bands = 1, 197 type = 'Byte', options = NULL, fname = NULL, handle = NULL) { 198 if (is.null(handle)) { 199 typeNum <- match(type, .GDALDataTypes, 1) - 1 200 if (is.null(fname)) { 201 my_tempfile <- tempfile() 202 } else { 203 my_tempfile <- paste(tempdir(), "/", 204 paste(sample(letters, 3), collapse=""), 205 basename(fname[1]), sep="") 206 } 207 if (nchar(my_tempfile) == 0) stop("empty file name") 208 if (!is.null(options)) options <- as.character(options) 209 slot(.Object, 'handle') <- .Call('RGDAL_CreateDataset', driver, 210 as.integer(c(cols, rows, bands)), 211 as.integer(typeNum), 212 options, 213 my_tempfile, PACKAGE="rgdal") 214 } else { 215 slot(.Object, 'handle') <- handle 216 } 217 cfn <- function(handle) .Call('RGDAL_CloseHandle', 218# cfn <- function(handle) .Call('RGDAL_CloseDataset', RSB 081030 219 handle, PACKAGE="rgdal") 220 .setCollectorFun(slot(.Object, 'handle'), cfn) 221 .Object 222 }) 223 224getDriver <- function(dataset) { 225 226 assertClass(dataset, 'GDALReadOnlyDataset') 227 228 new('GDALDriver', 229 handle = .Call('RGDAL_GetDatasetDriver', dataset, PACKAGE="rgdal")) 230 231} 232 233copyDataset <- function(dataset, driver, strict = FALSE, options = NULL, fname = NULL) { 234 235 assertClass(dataset, 'GDALReadOnlyDataset') 236 237 if (missing(driver)) driver <- getDriver(dataset) 238 else if (is.character(driver)) driver <- new("GDALDriver", driver) 239 240 if (is.null(fname)) { 241 my_tempfile <- tempfile() 242 } else { 243 my_tempfile <- paste(tempdir(), "/", 244 paste(sample(letters, 3), collapse=""), 245 basename(fname[1]), sep="") 246 } 247 if (nchar(my_tempfile) == 0) stop("empty file name") 248 if (!is.null(options) && !is.character(options)) 249 stop("options not character") 250 251 new.obj <- new('GDALTransientDataset', 252 handle = .Call('RGDAL_CopyDataset', 253 dataset, driver, 254 as.integer(strict), 255 as.character(options), 256 my_tempfile, PACKAGE="rgdal")) 257 258 new.obj 259 260} 261 262saveDataset <- function(dataset, filename, options=NULL, returnNewObj=FALSE) { 263 264 assertClass(dataset, 'GDALReadOnlyDataset') 265 266 new.class <- ifelse(class(dataset) == 'GDALTransientDataset', 267 'GDALDataset', class(dataset)) 268 if (!is.null(options) && !is.character(options)) 269 stop("options not character") 270 271 filename <- as.character(filename) 272 if (nchar(filename) == 0) stop("empty file name") 273 new.obj <- new(new.class, 274 handle = .Call('RGDAL_CopyDataset', 275 dataset, getDriver(dataset), 276 FALSE, options, normalizePath(filename, mustWork=FALSE), 277 PACKAGE="rgdal")) 278 279 if (returnNewObj) return(new.obj) 280 invisible(GDAL.close(new.obj)) 281} 282 283setGeneric('closeDataset', function(dataset) standardGeneric('closeDataset')) 284 285"closeDataset.default" <- function(dataset) 286 stop("No default method for closeDataset") 287 288setMethod("closeDataset", signature("ANY"), closeDataset.default) 289 290setMethod('closeDataset', 'GDALReadOnlyDataset', 291 def = function(dataset) { 292 .setCollectorFun(slot(dataset, 'handle'), NULL) 293 .Call('RGDAL_CloseDataset', dataset, PACKAGE="rgdal") 294 invisible(gc()) 295 }) 296 297setMethod('closeDataset', 'GDALTransientDataset', 298 def = function(dataset) { 299 driver <- getDriver(dataset) 300# filename <- getDescription(dataset) 301# .Call('RGDAL_CloseDataset', driver, filename, PACKAGE="rgdal") 302 .Call('RGDAL_CloseDataset', driver, PACKAGE="rgdal") 303 invisible(gc()) 304 callNextMethod() 305 }) 306 307 308saveDatasetAs <- function(dataset, filename, driver = NULL, options=NULL) { 309 310 .Deprecated("saveDataset") 311 312 assertClass(dataset, 'GDALReadOnlyDataset') 313 314 filename <- as.character(filename) 315 if (nchar(filename) == 0) stop("empty file name") 316 if (is.null(driver)) driver <- getDriver(dataset) 317 if (!is.null(options) && !is.character(options)) 318 stop("options not character") 319 320 new.obj <- new('GDALReadOnlyDataset', 321 handle = .Call('RGDAL_CopyDataset', 322 dataset, driver, FALSE, options, 323 normalizePath(filename, mustWork=FALSE), PACKAGE="rgdal")) 324 325 closeDataset(new.obj) 326 327 err.opt <- getOption('show.error.messages') 328 329 options(show.error.messages = FALSE) 330 331 new.obj <- try(new('GDALDataset', filename)) 332 333 options(show.error.messages = err.opt) 334 335 if (inherits(new.obj, 'try-error')) 336 new.obj <- new('GDALReadOnlyDataset', filename) 337 338 closeDataset(dataset) 339 340 eval.parent(dataset <- new.obj) 341 342 invisible(new.obj) 343 344} 345 346 347deleteDataset <- function(dataset) { 348 349 assertClass(dataset, 'GDALDataset') 350 351 driver <- getDriver(dataset) 352 353 filename <- getDescription(dataset) 354 355 .Call('RGDAL_DeleteFile', driver, filename, PACKAGE="rgdal") 356 357 closeDataset(dataset) 358 359} 360 361isObjPtrNULL <- function(ptr) { 362 363 stopifnot(is(ptr, "GDALMajorObject")) 364 365 .Call("isGDALObjPtrNULL", ptr, PACKAGE="rgdal") 366 367} 368 369GDAL.open <- function(filename, read.only = TRUE, silent = FALSE, 370 allowedDrivers=NULL, options=NULL) { 371 372 if (!is.null(options) && !is.character(options)) 373 stop("options not character") 374 375 376 res <- if(read.only) 377 new("GDALReadOnlyDataset", filename, silent=silent, 378 allowedDrivers=allowedDrivers, options=options) 379 else 380 new("GDALDataset", filename, silent=silent, 381 allowedDrivers=allowedDrivers, options=options) 382 383 res 384 385} 386 387GDAL.close <- function(dataset) { 388 isTrans <- is(dataset, "GDALTransientDataset") 389 if (isTrans) { 390 if (isObjPtrNULL(dataset)) stop("object already closed") 391# filename <- getDescription(dataset) 392 } 393 .setCollectorFun(slot(dataset, 'handle'), NULL) 394 .Call('RGDAL_CloseDataset', dataset, PACKAGE="rgdal") 395# .Call("RGDAL_CloseHandle", slot(dataset, 'handle'), 396# PACKAGE="rgdal") 397 invisible(NULL) 398# if (isTrans) { 399# basen <- basename(filename) 400# dirn <- dirname(filename) 401# lf <- list.files(path=dirn, pattern=basen) 402# flf <- paste(dirn, lf, sep="/") 403# unlink(flf) 404# } 405# invisible(gc()) 406} 407 408setMethod('dim', 'GDALReadOnlyDataset', 409 def = function(x) { 410 nrows <- .Call('RGDAL_GetRasterYSize', x, PACKAGE="rgdal") 411 ncols <- .Call('RGDAL_GetRasterXSize', x, PACKAGE="rgdal") 412 nbands <- .Call('RGDAL_GetRasterCount', x, PACKAGE="rgdal") 413 if (nbands < 1) warning("no bands in dataset") 414 if (nbands > 1) 415 c(nrows, ncols, nbands) 416 else 417 c(nrows, ncols) 418 }) 419 420getProjectionRef <- function(dataset, OVERRIDE_PROJ_DATUM_WITH_TOWGS84=NULL, enforce_xy=NULL) { 421 422 assertClass(dataset, 'GDALReadOnlyDataset') 423 424 vs <- strsplit(strsplit(getGDALVersionInfo(), ",")[[1]][1], " ")[[1]][2] 425 env_absent <- is.null(getCPLConfigOption("OVERRIDE_PROJ_DATUM_WITH_TOWGS84")) 426 wkt2 <- NULL 427 if (!is.null(enforce_xy)) { 428 stopifnot(is.logical(enforce_xy)) 429 stopifnot(length(enforce_xy) == 1L) 430 stopifnot(!is.na(enforce_xy)) 431 } else { 432 enforce_xy <- get_enforce_xy() 433 } 434 435 if ((vs > "1.8.0") && env_absent) { 436 if (is.null(OVERRIDE_PROJ_DATUM_WITH_TOWGS84)) 437 OVERRIDE_PROJ_DATUM_WITH_TOWGS84 <- get_OVERRIDE_PROJ_DATUM_WITH_TOWGS84() 438 stopifnot(is.logical(OVERRIDE_PROJ_DATUM_WITH_TOWGS84)) 439 stopifnot(length(OVERRIDE_PROJ_DATUM_WITH_TOWGS84) == 1) 440 if (!OVERRIDE_PROJ_DATUM_WITH_TOWGS84) { 441 setCPLConfigOption("OVERRIDE_PROJ_DATUM_WITH_TOWGS84", "NO") 442 res <- .Call('RGDAL_GetProjectionRef', dataset, enforce_xy, PACKAGE="rgdal") 443 setCPLConfigOption("OVERRIDE_PROJ_DATUM_WITH_TOWGS84", NULL) 444 } else { 445 res <- .Call('RGDAL_GetProjectionRef', dataset, enforce_xy, PACKAGE="rgdal") 446 } 447 } else { 448 res <- .Call('RGDAL_GetProjectionRef', dataset, enforce_xy, PACKAGE="rgdal") 449 } 450 no_ellps <- FALSE 451 if (!(is.na(res)) && new_proj_and_gdal()) { 452 no_towgs84 <- all(nchar(attr(res, "towgs84")) == 0) 453 if ((length(grep("towgs84", c(res))) == 0L) && !no_towgs84) 454 warning("TOWGS84 discarded") 455 no_ellps <- (!is.null(attr(res, "ellps"))) && 456 (nchar(attr(res, "ellps")) > 0L) && 457 (length(grep("ellps", c(res))) == 0L) 458 no_ellps <- no_ellps && length(grep("datum", c(res))) == 0L 459 if (no_ellps) { 460 msg <- paste0("Discarded ellps ", attr(res, "ellps"), 461 " in Proj4 definition: ", c(res)) 462 if (get_rgdal_show_exportToProj4_warnings()) { 463 if (!get_thin_PROJ6_warnings()) { 464 warning(msg) 465 } else { 466 if (get("PROJ6_warnings_count", 467 envir=.RGDAL_CACHE) == 0L) { 468 warning(paste0("PROJ/GDAL PROJ string degradation in workflow\n repeated warnings suppressed\n ", msg)) 469 } 470 assign("PROJ6_warnings_count", 471 get("PROJ6_warnings_count", 472 envir=.RGDAL_CACHE) + 1L, envir=.RGDAL_CACHE) 473 } 474 } 475 } 476# warning("Discarded ellps ", attr(res, "ellps"), 477# " in Proj4 definition: ", c(res)) 478 if ((!is.null(attr(res, "datum"))) && (nchar(attr(res, "datum")) > 0L) 479 && (length(grep("datum", c(res))) == 0L)) { 480 msg <- paste0("Discarded datum ", attr(res, "datum"), 481 " in Proj4 definition: ", c(res)) 482 if (!no_towgs84 && (length(grep("towgs84", c(res))) > 0L)) 483 msg <- paste0(msg, ",\n but +towgs84= values preserved") 484 if (get_P6_datum_hard_fail()) stop(msg) 485 else { 486 if (get_rgdal_show_exportToProj4_warnings()) { 487 if (!get_thin_PROJ6_warnings()) { 488 warning(msg) 489 } else { 490 if (get("PROJ6_warnings_count", 491 envir=.RGDAL_CACHE) == 0L) { 492 warning(paste0("PROJ/GDAL PROJ string degradation in workflow\n repeated warnings suppressed\n ", msg)) 493 } 494 assign("PROJ6_warnings_count", 495 get("PROJ6_warnings_count", 496 envir=.RGDAL_CACHE) + 1L, envir=.RGDAL_CACHE) 497 } 498 } 499 } 500#warning(msg) 501 } 502 if (new_proj_and_gdal()) wkt2 <- attr(res, "WKT2_2018") 503 } 504 res <- c(res) 505 if (new_proj_and_gdal()) { 506 if (no_ellps) res <- showSRID(wkt2, "PROJ") 507 comment(res) <- wkt2 508 } 509 res 510} 511 512putRasterData <- function(dataset, 513 rasterData, 514 band = 1, 515 offset = c(0, 0)) { 516 517 assertClass(dataset, 'GDALDataset') 518 519 offset <- rep(offset, length.out = 2) 520 521 raster <- getRasterBand(dataset, band) 522 523 .Call('RGDAL_PutRasterData', raster, rasterData, 524 as.integer(offset), PACKAGE="rgdal") 525 526} 527 528getRasterTable <- function(dataset, 529 band = NULL, 530 offset = c(0, 0), 531 region.dim = dim(dataset)) { 532 533 assertClass(dataset, 'GDALReadOnlyDataset') 534 535 offset <- rep(offset, length.out = 2) 536 region.dim <- rep(region.dim, length.out = 2) 537 538 rasterData <- getRasterData(dataset, band, 539 offset = offset, 540 region.dim = region.dim, list_out=TRUE) 541 542 if (is.null(band)) { 543 544 nbands <- .Call('RGDAL_GetRasterCount', dataset, PACKAGE="rgdal") 545 if (nbands < 1) stop("no bands in dataset") 546 band <- 1:nbands 547 548 } else { 549 550 nbands <- length(band) 551 552 } 553 554# dim(rasterData) <- c(region.dim, nbands) 555 556 geoTrans <- getGeoTransFunc(dataset) 557 558 y.i <- 1:region.dim[1] - 0.5 + offset[1] 559 x.i <- 1:region.dim[2] - 0.5 + offset[2] 560 561 y.i <- rep(y.i, each = length(x.i)) 562 x.i <- rep(x.i, len = prod(region.dim)) 563 564 out <- geoTrans(x.i, y.i) 565 566# out <- cbind(out$x, out$y) 567 out <- data.frame(x=out$x, y=out$y) 568 rasterData <- as.data.frame(rasterData) 569 570# for (b in band) { 571# vec <- as.numeric(rasterData[, , b]) 572# out <- cbind(out, vec) 573# } 574 575# out <- as.data.frame(out) 576 577# names(out) <- c('x', 'y', paste('band', 1:nbands, sep = '')) 578 out <- cbind(out, rasterData) 579 580 out 581 582} 583 584getRasterData <- function(dataset, 585 band = NULL, 586 offset = c(0, 0), 587 region.dim = dim(dataset), 588 output.dim = region.dim, 589 interleave = c(0, 0), 590 as.is = FALSE, list_out=FALSE) { 591 592 assertClass(dataset, 'GDALReadOnlyDataset') 593 594 offset <- rep(offset, length.out = 2) 595 region.dim <- rep(region.dim, length.out = 2) 596 output.dim <- rep(output.dim, length.out = 2) 597 interleave <- rep(interleave, length.out = 2) 598 599 nbands <- .Call('RGDAL_GetRasterCount', dataset, PACKAGE="rgdal") 600 if (nbands < 1) stop("no bands in dataset") 601 602 if (is.null(band)) band <- 1:nbands 603 604 x <- array(dim = as.integer(c(rev(output.dim), length(band)))) 605 for (i in seq(along = band)) { 606 607 raster <- getRasterBand(dataset, band[i]) 608 609 y <- .Call('RGDAL_GetRasterData', raster, 610 as.integer(c(offset, region.dim)), 611 as.integer(output.dim), 612 as.integer(interleave), 613 PACKAGE="rgdal") 614 615 if (length(band) == 1) { 616 # avoid surprisingly expensive slice assignment for 617 # common case of a single band 618 attributes(y) <- attributes(x) 619 x <- y 620 } else { 621 x[,,i] <- y 622 } 623 624 } 625 if (!as.is) { 626 for (i in seq(along = band)) { 627 628 raster <- getRasterBand(dataset, band[i]) 629 scale <- .Call('RGDAL_GetScale', raster, PACKAGE="rgdal") 630 offset <- .Call('RGDAL_GetOffset', raster, PACKAGE="rgdal") 631 632 if (scale != 1) x[,,i] <- x[,,i] * scale 633 if (offset != 0) x[,,i] <- x[,,i] + offset 634 } 635 } 636 if (!list_out) { 637 if (length(band) == 1L) x <- drop(x) 638 return(x) 639 } else { 640 X <- vector(mode="list", length=length(band)) 641 names(X) <- paste("band", 1:length(band), sep="") 642 643 for (i in seq(along = band)) { 644 645 X[[i]] <- as.vector(x[,,i]) 646 647 if (!as.is) { 648 649 raster <- getRasterBand(dataset, band[i]) 650 651 catNames <- .Call('RGDAL_GetCategoryNames', raster, 652 PACKAGE="rgdal") 653 654 if (!is.null(catNames)) { 655 ux <- sort(unique(na.omit(X[[i]]))) 656 lCN <- length(catNames) 657 levels <- ((1:lCN)-1) 658 back_incls <- ux %in% levels 659 if (all(back_incls)) { 660 X[[i]] <- factor(X[[i]], levels=levels, labels=catNames) 661 if (!get("silent", envir=.RGDAL_CACHE)) { 662 cat("Input level values and names\n") 663 cat(paste(levels, " ", catNames, "\n", sep=""), 664 sep="") 665 } 666 } else { 667 warning("Assign CategoryNames manually, level/label mismatch") 668 } 669 } 670 } 671 } 672 return(X) 673 } 674} 675 676getCategoryNames <- function(dataset, band = 1) { 677 678 assertClass(dataset, 'GDALReadOnlyDataset') 679 680 raster <- getRasterBand(dataset, band) 681 682 catNames <- .Call('RGDAL_GetCategoryNames', raster, PACKAGE="rgdal") 683 684 catNames 685} 686 687getBandColorTable <- function(raster) { 688 689 ctab <- .Call('RGDAL_GetColorTable', raster, PACKAGE="rgdal") / 255 690 691 if (length(ctab) == 0L) return(NULL) 692 693 if (.Call('RGDAL_GetColorInterp', raster, PACKAGE="rgdal") == 'Palette') 694 switch(.Call('RGDAL_GetPaletteInterp', raster, PACKAGE="rgdal"), 695 RGB = rgb(ctab[,1], ctab[,2], ctab[,3]), 696 HSV = hsv(ctab[,1], ctab[,2], ctab[,3]), # Doesn't actually exist 697 Gray = gray(ctab[,1]), 698 gray(apply(ctab, 2, mean))) 699 else 700 gray(ctab[,1]) 701 702} 703 704getColorTable <- function(dataset, band = 1) { 705 706 assertClass(dataset, 'GDALReadOnlyDataset') 707 708 raster <- getRasterBand(dataset, band) 709 710 getBandColorTable(raster) 711} 712 713RGB2PCT <- function(x, band, driver.name = 'MEM', 714 ncolors = 256, set.ctab = TRUE) { 715 716 assertClass(x, 'GDALReadOnlyDataset') 717 718 if (ncolors < 2 || ncolors > 256) 719 stop('Number of colors must be between 2 and 256') 720 721 band <- rep(band, length.out = 3) 722 723 dithered <- new('GDALTransientDataset', 724 new('GDALDriver', driver.name), 725 nrow(x), ncol(x)) 726 727 ctab <- .Call('RGDAL_GenCMap', 728 getRasterBand(x, band[1]), 729 getRasterBand(x, band[2]), 730 getRasterBand(x, band[3]), 731 getRasterBand(dithered), 732 as.integer(ncolors), 733 as.logical(set.ctab), 734 PACKAGE = "rgdal") / 255 735 736 if (set.ctab) 737 dithered 738 else 739 list(dataset = dithered, 740 pct = rgb(ctab[,1], ctab[,2], ctab[,3])) 741 742} 743 744displayDataset <- function(x, offset = c(0, 0), region.dim = dim(x), 745 reduction = 1, band = 1, col = NULL, 746 reset.par = TRUE, max.dim = 500, ...) { 747 748 assertClass(x, 'GDALReadOnlyDataset') 749 750 offset <- rep(offset, length.out = 2) 751 region.dim <- rep(region.dim, length.out = 2) 752 reduction <- rep(reduction, length.out = 2) 753 754 offset <- offset %% dim(x)[1:2] 755 756 oob <- (region.dim + offset) > dim(x)[1:2] 757 758 if (any(oob)) region.dim[oob] <- dim(x)[oob] - offset[oob] 759 760 reduction[reduction < 1] <- 1 761 762 plot.dim <- region.dim / reduction 763 764 if (any(plot.dim > max.dim)) 765 plot.dim <- max.dim * plot.dim / max(plot.dim) 766 767 image.data <- getRasterData(x, band[1], offset, 768 region.dim, plot.dim, 769 as.is = TRUE) 770# image.data <- array(image.data[[1]], t(plot.dim)) 771 772 if (is.null(col)) { 773 774 max.val <- max(image.data, na.rm = TRUE) 775 776 if (!is.finite(max.val)) { 777 image.data[] <- 2 778 max.val <- 2 779 } 780 781 col <- getColorTable(x, band)[1:(max.val + 1)] 782 783 } 784 785 if (is.null(col)) col <- gray(seq(0, 1, len = 256)) 786 787 par.in <- par(no.readonly = TRUE) 788 789 if (reset.par) on.exit(par(par.in)) 790 791 par(pin = max(par.in$pin) 792 * par.in$fin / max(par.in$fin) 793 * rev(plot.dim) / max(plot.dim)) 794 795 image.data <- image.data[, ncol(image.data):1] 796 797 image.default(image.data + 1, col = col, axes = FALSE, ...) 798 799 invisible(list(image.data = image.data, col = col, par.in = par.in)) 800 801} 802 803setMethod('initialize', 'GDALRasterBand', 804 def = function(.Object, dataset, band = 1) { 805 slot(.Object, 'handle') <- .Call('RGDAL_GetRasterBand', 806 dataset, as.integer(band), 807 PACKAGE="rgdal") 808 .Object 809 }) 810 811setMethod('dim', 'GDALRasterBand', 812 def = function(x) { 813 c(.Call('RGDAL_GetYSize', x, PACKAGE="rgdal"), 814 .Call('RGDAL_GetXSize', x, PACKAGE="rgdal")) 815 }) 816 817getGeoTransFunc <- function(dataset) { 818 819 assertClass(dataset, 'GDALReadOnlyDataset') 820 821 geoTrans <- .Call('RGDAL_GetGeoTransform', dataset, PACKAGE="rgdal") 822 if (attr(geoTrans, "CE_Failure")) warning("GeoTransform values not available") 823 rotMat <- matrix(geoTrans[c(2, 3, 5, 6)], 2) 824 825 offset <- geoTrans[c(1, 4)] 826 827 function(x, y) { 828 829 x <- cbind(x, y) 830 831 x <- x %*% rotMat 832 833 list(x = x[,1] + offset[1], 834 y = x[,2] + offset[2]) 835 836 } 837 838} 839 840getRasterBand <- function(dataset, band = 1) { 841 842 assertClass(dataset, 'GDALReadOnlyDataset') 843 844 new('GDALRasterBand', dataset, band) 845 846} 847 848getRasterBlockSize <- function(raster) { 849 850 assertClass(raster, 'GDALRasterBand') 851 852 .Call('RGDAL_GetRasterBlockSize', raster, PACKAGE="rgdal") 853 854} 855 856get_OVERRIDE_PROJ_DATUM_WITH_TOWGS84 <- function() { 857 get("OVERRIDE_PROJ_DATUM_WITH_TOWGS84", envir=.RGDAL_CACHE) 858} 859 860set_OVERRIDE_PROJ_DATUM_WITH_TOWGS84 <- function(value) { 861 stopifnot(is.logical(value)) 862 stopifnot(length(value) == 1) 863 stopifnot(!is.na(value)) 864 assign("OVERRIDE_PROJ_DATUM_WITH_TOWGS84", value, envir = .RGDAL_CACHE) 865 get_OVERRIDE_PROJ_DATUM_WITH_TOWGS84() 866} 867 868getCPLConfigOption <- function(ConfigOption) { 869 stopifnot(is.character(ConfigOption)) 870 stopifnot(length(ConfigOption) == 1) 871 .Call("RGDAL_CPLGetConfigOption", ConfigOption, PACKAGE="rgdal") 872} 873 874setCPLConfigOption <- function(ConfigOption, value) { 875 stopifnot(is.character(ConfigOption)) 876 stopifnot(length(ConfigOption) == 1) 877 if (!is.null(value)) { 878 stopifnot(is.character(value)) 879 stopifnot(length(value) == 1) 880 } 881 .Call("RGDAL_CPLSetConfigOption", ConfigOption, value, PACKAGE="rgdal") 882 .Call("RGDAL_CPLGetConfigOption", ConfigOption, PACKAGE="rgdal") 883} 884 885GDAL_iconv <- function() { 886 .Call("RGDAL_CPL_RECODE_ICONV", PACKAGE="rgdal") 887} 888 889