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