1
2
3setMethod("is.factor", signature(x="SpatRaster"),
4	function(x) {
5		x@ptr$hasCategories()
6	}
7)
8
9setMethod("as.factor", signature(x="SpatRaster"),
10	function(x) {
11		x <- round(x)
12		u <- unique(x)
13		levels(x) <- cbind(u, u)
14		x
15	}
16)
17
18
19setMethod("levels", signature(x="SpatRaster"),
20	function(x) {
21		x <- x@ptr$getCategories()
22		lapply(x, function(i) {
23			d <- .getSpatDF(i$df)
24			if (ncol(d) == 0) return("")
25			d[,max(1, i$index+1)]
26		})
27	}
28)
29
30
31setMethod("levels<-", signature(x="SpatRaster"),
32	function(x, value) {
33		if (is.null(value)) {
34			x@ptr$removeCategories(0)
35			return(messages(x, "levels<-"))
36		} else if (inherits(value, "list")) {
37			for (i in 1:length(value)) {
38				setCats(x, i, value[[i]])
39			}
40		} else {
41			setCats(x, 1, value, 2)
42		}
43		x
44	}
45)
46
47
48setMethod ("setCats" , "SpatRaster",
49	function(x, layer=1, value, index) {
50		layer = layer[1]
51		if (is.character(layer)) {
52			i <- match(layer, names(x))[1]
53			if (length(i) == 0) {
54				error("setLevels", layer, " is not in names(x)")
55			}
56			layer <- i
57		} else {
58			stopifnot(layer > 0 && layer <= nlyr(x))
59		}
60
61		if (missing(value)) {
62			if (missing(index)) {
63				return(x@ptr$getCatIndex(layer-1) + 1)
64			} else {
65				return(invisible(x@ptr$setCatIndex(layer-1, index)))
66			}
67		}
68		if (missing(index)) {
69			index <- 2
70		}
71		if (is.null(value)) {
72			x@ptr$removeCategories(layer-1)
73			return(messages(x, "setCats"))
74		}
75
76
77		if (inherits(value, "list")) {
78			value <- value[[1]]
79		}
80		setname <- FALSE
81		vat <- FALSE
82		if (!is.data.frame(value)) {
83			if (is.vector(value) || is.factor(value)) {
84				if (length(value == 1) && value[1] == "") {
85					return(invisible(""))
86				}
87				value <- data.frame(ID=0:(length(value)-1), category=value)
88			} else {
89				error("setCats", "value should be a data.frame or a vector")
90			}
91		} else {
92			setname <- TRUE
93			if (nrow(value) > 256) {
94				vat <- TRUE
95			}
96			if (ncol(value) == 1) {
97				value <- data.frame(ID=1:nrow(value), value)
98			} else {
99				value[,1] <- round(value[,1])
100				if (length(unique(value[,1])) != nrow(value)) {
101					error("setCats", "duplicate IDs supplied")
102				}
103				r <- range(value[,1])
104				if (r[1] < 0 || r[2] > 255) {
105					vat <- TRUE
106				}
107			}
108		}
109		minv <- min(value[,1])
110		maxv <- max(value[,1])
111		if ((maxv < 256) && (minv >=0)) {
112			v <- data.frame(ID=0:maxv)
113			value <- merge(v, value, by=1, all.x=TRUE)
114		}
115
116		index <- max(1, min(ncol(value), index))
117#		if (is.data.frame(value)) {
118		if (setname) {
119			names(x)[layer] <- colnames(value)[index]
120		}
121
122		if (ncol(value) > 2) vat <- TRUE
123		value <- .makeSpatDF(value)
124		ok <- x@ptr$setCategories(layer-1, value, index-1, vat)
125#		} else {
126#			value <- as.character(value)
127#			x@ptr$setLabels(layer-1, value)
128#		}
129		x <- messages(x, "setCats")
130		invisible(ok)
131	}
132)
133
134
135setMethod ("activeCat" , "SpatRaster",
136	function(x, layer=1) {
137		layer = layer[1]
138		if (is.character(layer)) {
139			layer = which(layer == names(x))[1]
140			if (is.na(layer)) {
141				error("activeCat", "invalid layer name")
142			}
143		}
144		if (!is.factor(x)[layer]) {
145			return(NA)
146		}
147		x@ptr$getCatIndex(layer-1)
148	}
149)
150
151setMethod("activeCat<-" , "SpatRaster",
152	function(x, layer=1, value) {
153		if (missing(value)) {
154			value <- layer[1]
155			layer <- 1
156		} else {
157			layer <- layer[1]
158		}
159		if ((layer < 1) | (layer > nlyr(x))) {
160			error("activeCat", "invalid layer")
161		}
162		if (!is.factor(x)[layer]) {
163			error("activeCat", "layer is not categorical")
164		}
165		if (is.character(value)) {
166			g <- cats(x)[[layer]]
167			value <- which(value == names(g))[1] - 1
168			if (is.na(value)) {
169				error("activeCat", "invalid category name")
170			}
171		}
172		if (!x@ptr$setCatIndex(layer-1, value)) {
173			error("activeCat", "invalid category index")
174		}
175		x
176	}
177)
178
179setMethod("cats" , "SpatRaster",
180	function(x, layer) {
181		x <- x@ptr$getCategories()
182		x <- lapply(x, function(i) {
183			if (is.null(i)) return( NULL)
184			.getSpatDF(i$df)
185		})
186		if (!missing(layer)) {
187			x[[layer]]
188		} else {
189			x
190		}
191	}
192)
193
194
195
196active_cats <- function(x, layer) {
197	ff <- is.factor(x)
198	if (!any(ff)) {
199		return (lapply(ff, function(i)NULL))
200	}
201	cats <- x@ptr$getCategories()
202	x <- lapply(1:length(cats), function(i) {
203		if (cats[[1]]$df$nrow == 0) return(NULL)
204		r <- .getSpatDF(cats[[i]]$df)
205		a <- activeCat(x, i)
206		r[, c(1, a+1)]
207	})
208
209	if (!missing(layer)) {
210		x[[layer]]
211	} else {
212		x
213	}
214}
215
216
217
218
219
220setMethod ("as.numeric", "SpatRaster",
221	function(x, index=NULL, filename="", ...) {
222		stopifnot(nlyr(x) == 1)
223		if (!is.factor(x)) return(x)
224		g <- cats(x)[[1]]
225		if (!is.null(index)) {
226			if (!((index > 1) & (index <= ncol(g)))) {
227				error("as.numeric", "invalid index")
228			}
229		} else {
230			index <- setCats(x, 1)
231		}
232		from <- g[,1]
233		to <- g[,index]
234		if (!is.numeric(to)) {
235			to <- as.integer(as.factor(to))
236		}
237		m <- cbind(from, to)
238		m <- m[!is.na(m[,1]), ,drop=FALSE]
239		classify(x, m, names=names(g)[index], filename, ...)
240	}
241)
242
243
244
245catLayer <- function(x, index, ...) {
246		stopifnot(nlyr(x) == 1)
247		if (!is.factor(x)) return(x)
248		g <- cats(x)[[1]]
249		if (!is.null(index)) {
250			if (!((index > 1) & (index <= ncol(g)))) {
251				error("as.numeric", "invalid index")
252			}
253		} else {
254			index <- setCats(x, 1)
255		}
256		from <- g[,1]
257		toc <- g[,index]
258
259		addFact <- FALSE
260		if (!is.numeric(toc)) {
261			addFact <- TRUE
262			ton <- as.integer(as.factor(toc))
263		} else {
264			ton <- toc
265		}
266		m <- cbind(from, ton)
267		m <- m[!is.na(m[,1]), ,drop=FALSE]
268		x <- classify(x, m, names=names(g)[index], ...)
269		if (addFact) {
270			fact <- unique(data.frame(ton, toc))
271			names(fact) <- c("ID", names(g)[index])
272			fact <- fact[order(fact[,1]), ]
273			setCats(x, 1, fact, 2)
274		}
275		x
276}
277
278
279
280setMethod("catalyze", "SpatRaster",
281	function(x, filename="", ...) {
282		g <- cats(x)
283		out <- list()
284		for (i in 1:nlyr(x)) {
285			y <- x[[i]]
286			gg <- g[[i]]
287			if (nrow(gg) > 0) {
288				for (j in 2:ncol(gg)) {
289					z <- as.numeric(y, index=j)
290					out <- c(out, z)
291				}
292			} else {
293				out <- c(out, y)
294			}
295		}
296		out <- rast(out)
297		if (filename!="") {
298			out <- writeRaster(out, filename, ...)
299		}
300		out
301	}
302)
303
304
305