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