Skip to content

Commit b370cab

Browse files
gilbertocamaragilbertocamara
committed
closes #1416 
1 parent 5cb6c02 commit b370cab

16 files changed

+334
-31
lines changed

‎NAMESPACE‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -7,8 +7,10 @@ S3method("sits_bands<-",default)
77
S3method("sits_bands<-",raster_cube)
88
S3method("sits_bands<-",sits)
99
S3method("sits_labels<-",class_cube)
10+
S3method("sits_labels<-",class_vector_cube)
1011
S3method("sits_labels<-",default)
1112
S3method("sits_labels<-",probs_cube)
13+
S3method("sits_labels<-",probs_vector_cube)
1214
S3method("sits_labels<-",sits)
1315
S3method(.accuracy_get_validation,csv)
1416
S3method(.accuracy_get_validation,data.frame)
@@ -395,6 +397,8 @@ S3method(sits_clean,class_cube)
395397
S3method(sits_clean,default)
396398
S3method(sits_clean,derived_cube)
397399
S3method(sits_clean,raster_cube)
400+
S3method(sits_colors_qgis,class_cube)
401+
S3method(sits_colors_qgis,class_vector_cube)
398402
S3method(sits_combine_predictions,average)
399403
S3method(sits_combine_predictions,default)
400404
S3method(sits_combine_predictions,uncertainty)

‎R/api_colors.R‎

Lines changed: 100 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -141,7 +141,7 @@
141141
)
142142
}
143143
#'
144-
#' @title Write a color table in QGIS Style format
144+
#' @title Write a raster color table in QGIS Style format
145145
#' @name .colors_qml
146146
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
147147
#' @keywords internal
@@ -154,7 +154,6 @@
154154
.check_chr_contains(colnames(color_table), c("index", "color", "name"))
155155
# open the file connection
156156
con <- file(file, "w")
157-
158157
# read the top part of QGIS style
159158
top_qgis_style <- system.file("extdata/qgis/qgis_style_top.xml",
160159
package = "sits"
@@ -198,6 +197,105 @@
198197
# close the file
199198
on.exit(close(con))
200199
}
200+
#'
201+
#' @title Write a vector color table in GIMP Format to be read by QGIS
202+
#' @name .colors_vector_qml
203+
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
204+
#' @keywords internal
205+
#' @noRd
206+
#' @param color_table color table to write to QGIS
207+
#' @param file the file name to be written to.
208+
#' @return Called for side effects.
209+
.colors_vector_qml <- function(color_table, file) {
210+
# open the file connection
211+
con <- file(file, "w")
212+
# find out how many labels have to be written
213+
nlabels <- nrow(color_table)
214+
# read the top part of QGIS style
215+
top_qgis_style <- system.file("extdata/qgis/qgis_style_vector_top.xml",
216+
package = "sits"
217+
)
218+
top_lines <- readLines(top_qgis_style)
219+
# write the top part of QGIS style in the output file
220+
writeLines(top_lines, con = con)
221+
# write the start of the categories
222+
writeLines("<categories>", con = con)
223+
# write the categories
224+
ncategories <- nlabels - 1
225+
for (i in 0:ncategories) {
226+
color_name <- color_table[i + 1, "name"]
227+
qml_label <- paste0("label=","\"", color_name, "\"")
228+
qml_value <- paste0("value=", "\"", color_name, "\"")
229+
qml_symbol <- paste0("symbol=","\"", as.character(i), "\"")
230+
writeLines(paste("<category render=\"true\"",
231+
qml_label,
232+
"type=\"string\"",
233+
qml_value,
234+
qml_symbol,
235+
"/>"),
236+
con)
237+
}
238+
# write the last line of categories
239+
qml_symbol_extra <- paste0("\"", as.character(nlabels), "\"")
240+
writeLines(paste("<category render=\"false\"",
241+
"label= \"\"",
242+
"type=\"string\"",
243+
"value= \"\"",
244+
"symbol=", qml_symbol_extra, "/>"),
245+
con)
246+
247+
# write the end of the categories
248+
writeLines("</categories>", con = con)
249+
250+
# write the symbols
251+
writeLines("<symbols>", con = con)
252+
for (i in 0:ncategories) {
253+
qml_name <- paste0("name=","\"", as.character(i), "\"")
254+
writeLines(paste("<symbol",
255+
"alpha=\"1\"",
256+
"type=\"fill\"",
257+
qml_name,
258+
">"),
259+
con)
260+
# read data
261+
data_def <- system.file("extdata/qgis/qgis_data_defined_properties.xml",
262+
package = "sits"
263+
)
264+
data_def_lines <- readLines(data_def)
265+
# write the top part of QGIS style in the output file
266+
writeLines(data_def_lines, con = con)
267+
# write the color values
268+
writeLines("<layer enabled=\"1\" class=\"SimpleFill\">",
269+
con)
270+
writeLines("<Option type=\"Map\">", con)
271+
# convert color to RGB and write to XML
272+
hex_color <- color_table[i + 1, "color"]
273+
rgb <- col2rgb(hex_color)
274+
# format RGBA value to be inserted in QML file
275+
color_val <- paste0(paste(as.character(rgb), collapse = ","),",255")
276+
qml_color <- paste0("value=", "\"",color_val,"\"")
277+
# write QML color
278+
writeLines(paste("<Option type=\"QString\"",
279+
qml_color, "name=\"color\"/>"),
280+
con)
281+
writeLines("<Option type=\"QString\" value=\"solid\" name=\"style\"/>",
282+
con)
283+
writeLines("</Option>", con)
284+
writeLines("</layer>", con)
285+
writeLines("</symbol>", con)
286+
}
287+
writeLines("</symbols>", con)
288+
# read the bottom part of QGIS style
289+
bottom_qgis_style <- system.file("extdata/qgis/qgis_style_vector_bottom.xml",
290+
package = "sits"
291+
)
292+
bottom_lines <- readLines(bottom_qgis_style)
293+
# write the bottom part of QGIS style in the output file
294+
writeLines(bottom_lines, con = con)
295+
# close the file
296+
on.exit(close(con))
297+
}
298+
201299
#' @title Transform an RColorBrewer name to cols4all name
202300
#' @name .colors_cols4all_name
203301
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}

‎R/sits_colors.R‎

Lines changed: 29 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -216,9 +216,13 @@ sits_colors_reset <- function() {
216216
#' @export
217217
#'
218218
sits_colors_qgis <- function(cube, file) {
219-
.check_set_caller("sits_colors_qgis")
220-
# check if cube is a class cube
221-
.check_is_class_cube(cube)
219+
UseMethod("sits_colors_qgis", cube)
220+
221+
}
222+
#' @rdname sits_colors_qgis
223+
#' @export
224+
sits_colors_qgis.class_cube <- function(cube, file) {
225+
.check_set_caller("sits_colors_qgis_raster")
222226
# check if the file name is valid
223227
.check_file(file, file_exists = FALSE)
224228
# retrieve the labels of the cube
@@ -239,3 +243,25 @@ sits_colors_qgis <- function(cube, file) {
239243
# create a QGIS XML file
240244
.colors_qml(color_table, file)
241245
}
246+
#' @rdname sits_colors_qgis
247+
#' @export
248+
sits_colors_qgis.class_vector_cube <- function(cube, file){
249+
# check if the file name is valid
250+
.check_file(file, file_exists = FALSE)
251+
# retrieve the labels of the cube
252+
labels <- .cube_labels(cube)
253+
# select the colors for the labels of the cube
254+
color_table <- .conf_colors()
255+
# check all labels are in the color table
256+
.check_chr_within(labels, color_table[["name"]])
257+
# filter the color table
258+
color_table <- color_table |>
259+
dplyr::filter(.data[["name"]] %in% labels)
260+
# order the colors to match the order of the labels
261+
color_table <- color_table[
262+
match(labels, color_table[["name"]]),
263+
]
264+
# create a QGIS-readable GPL file
265+
.colors_vector_qml(color_table, file)
266+
invisible(TRUE)
267+
}

‎R/sits_labels.R‎

Lines changed: 108 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -117,7 +117,7 @@ sits_labels.default <- function(data) {
117117
UseMethod("sits_labels<-", data)
118118
}
119119
#' @title Change the labels of a set of time series
120-
#' @param data Data cube or time series.
120+
#' @param data Time series.
121121
#' @param value A character vector used to convert labels. Labels will
122122
#' be renamed to the respective value positioned at the
123123
#' labels order returned by \code{\link{sits_labels}}.
@@ -139,8 +139,8 @@ sits_labels.default <- function(data) {
139139
data[["label"]] <- value[data[["label"]]]
140140
data
141141
}
142-
#' @title Change the labels of a set of time series
143-
#' @param data Data cube or time series.
142+
#' @title Change the labels of a probs raster cube
143+
#' @param data Raster cube with probability values.
144144
#' @param value A character vector used to convert labels. Labels will
145145
#' be renamed to the respective value positioned at the
146146
#' labels order returned by \code{\link{sits_labels}}.
@@ -156,8 +156,8 @@ sits_labels.default <- function(data) {
156156
data[["labels"]] <- list(value)
157157
data
158158
}
159-
#' @title Change the labels of a set of time series
160-
#' @param data Data cube or time series.
159+
#' @title Change the labels of a classified raster cube
160+
#' @param data Classified raster data cube.
161161
#' @param value A character vector used to convert labels. Labels will
162162
#' be renamed to the respective value positioned at the
163163
#' labels order returned by \code{\link{sits_labels}}.
@@ -178,7 +178,109 @@ sits_labels.default <- function(data) {
178178
row
179179
})
180180
}
181-
#' @title Change the labels of a set of time series
181+
#' @title Change the labels of a probs vector data cube
182+
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
183+
#' @param data Probs vector data cube.
184+
#' @param value A character vector used to convert labels.
185+
#'
186+
#' @description
187+
#' A "probs_vector_cube" is a data cube with a set of segments that
188+
#' contain the probability values of each class for each polygon.
189+
#' When a user changes the labels of the class, this function
190+
#' modifies the labels associated to the cube's metadata and
191+
#' also changes the names in the segments file. The GPKG file
192+
#' containing the segments and the probability values is replace
193+
#' with a new file with the desired labels.
194+
#'
195+
#' @export
196+
`sits_labels<-.probs_vector_cube` <- function(data, value) {
197+
198+
# get the labels for the vector cube
199+
labels_orig <- .cube_labels(data)
200+
# check if value and labels match
201+
.check_chr_parameter(value,
202+
len_max = length(labels_orig),
203+
len_min = length(labels_orig)
204+
)
205+
# check if there are no NA
206+
.check_that(!anyNA(value))
207+
# check if there are empty strings
208+
.check_that(any(trimws(value) != ""))
209+
# name the conversion vector with the original labels
210+
names(labels_orig) <- value
211+
212+
# run for each tile of the cube
213+
slider::slide_dfr(data, function(row){
214+
# change the labels in the tile
215+
row[["labels"]] <- list(value)
216+
# read the segments for the tile
217+
.segments <- .segments_read_vec(row)
218+
# rename column names
219+
.segments <- dplyr::rename(.segments, dplyr::all_of(labels_orig))
220+
# Prepare and save results as vector
221+
.vector_write_vec(
222+
v_obj = .segments,
223+
file_path = .segments_path(row),
224+
append = FALSE
225+
)
226+
row
227+
})
228+
}
229+
#' @title Change the labels of a class vector data cube
230+
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
231+
#' @param data Class vector data cube.
232+
#' @param value A character vector used to convert labels.
233+
#'
234+
#' @description
235+
#' A "class_vector_cube" is a data cube with a set of segments that
236+
#' contain the probability values of each class for each polygon
237+
#' and also list the most probable class.
238+
#' When a user changes the labels of the class, this function
239+
#' modifies the labels associated to the cube's metadata and
240+
#' also changes the names in the segments file. The GPKG file
241+
#' containing the segments and the probability values is replace
242+
#' with a new file with the desired labels.
243+
#'
244+
#' @export
245+
`sits_labels<-.class_vector_cube` <- function(data, value) {
246+
247+
# get the labels for the vector cube
248+
labels_orig <- .cube_labels(data)
249+
# check if value and labels match
250+
.check_chr_parameter(value,
251+
len_max = length(labels_orig),
252+
len_min = length(labels_orig)
253+
)
254+
# check if there are no NA
255+
.check_that(!anyNA(value))
256+
# check if there are empty strings
257+
.check_that(any(trimws(value) != ""))
258+
# name the conversion vector with the original labels
259+
names(labels_orig) <- value
260+
# create a named vector to map the class values
261+
names(value) <- unname(labels_orig)
262+
263+
# run for each tile of the cube
264+
slider::slide_dfr(data, function(row){
265+
# change the labels in the tile
266+
row[["labels"]] <- list(value)
267+
# read the segments for the tile
268+
# rename column names
269+
# rename values in "class" column
270+
.segments <- .segments_read_vec(row) |>
271+
dplyr::rename(dplyr::all_of(labels_orig)) |>
272+
dplyr::mutate(class = value[.data[["class"]]] )
273+
274+
# Save results in the segments file
275+
.vector_write_vec(
276+
v_obj = .segments,
277+
file_path = .segments_path(row),
278+
append = FALSE
279+
)
280+
row
281+
})
282+
}
283+
#' @title Change the labels of other data structures
182284
#' @param data Data cube or time series.
183285
#' @param value A character vector used to convert labels. Labels will
184286
#' be renamed to the respective value positioned at the

‎inst/extdata/config_colors.yml‎

Lines changed: 10 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -368,10 +368,11 @@ legends:
368368

369369

370370
PRODES: ["Forest", "Mountainside_Forest", "Riparian_Forest",
371-
"Seasonally_Flooded", "Secondary_Vegetation", "Degradation",
371+
"Seasonally_Flooded", "Secondary_Vegetation",
372372
"Deforestation_Mask", "Clear_Cut_Trees", "Clear_Cut_Vegetation",
373373
"Clear_Cut_Bare_Soil", "Clear_Cut_Burned_Area",
374-
"Water", "Wetland", "Natural_Non_Forested",
374+
"Degraded_Forest", "Degradation_Fire",
375+
"Water", "Wetlands", "Natural_Non_Forested",
375376
"Urban_Area", "Cropland", "Pasture",
376377
"Cerradao", "Cerrado", "Campo_Cerrado"]
377378

@@ -603,31 +604,31 @@ colors:
603604
Secondary_Vegetation : &sec_vec "#40C772"
604605
# Deforestation, Degradation, Mining
605606
# Based on "Alizarin" palette from Flat Design Color Chart "#afc97f"
606-
Degradation : &degradation "#B0AC61" #"B8750B" # "#9BE1B5"
607+
Degradation : &degradation "#9DA676"
607608
Degraded_Forest : *degradation
608-
Degradation_Fire : "#D98B2B"
609+
Degradation_Fire : "#E6B0AA"
609610
# PRODES
610611
# Based on "Alizarin" palette from Flat Design Color Chart
611-
Burned_Area : &burned_area "#EC7063"
612+
Burned_Area : &burned_area "#CD6155"
612613
Clear_Cut_Burn : *burned_area
613614
Clear_Cut_Burned_Area : *burned_area
614615
# Color 52 - grama-tobosa shrubsteppe
615-
Cleared_Area : &clear_cut_soil "#D7C49C" # "#CCCBAB" #
616+
Cleared_Area : &clear_cut_soil "#F39C12" # "#CCCBAB" #
616617
Clear_Cut_Soil : *clear_cut_soil
617618
Clear_Cut_Bare_Soil : *clear_cut_soil
618619
Bare_Soil : *clear_cut_soil
619620
# Based on "nephritis" palette of Flat Design Color Chart
620621
Highly_Degraded : &clear_cut_deg "#BFD9BD"
621622
Clear_Cut_Veg : *clear_cut_deg
622-
Clear_Cut_Vegetation : "#D8DA83"
623-
Clear_Cut_Trees : "#B4B56D" # "#91D990"
623+
Clear_Cut_Vegetation : "#E0DB34"
624+
Clear_Cut_Trees : "#A19C0A" # "#91D990"
624625
# Based on "amethyst" palette from Flat Design Color Chart
625626
Mining : &mining "#CEB4D4"
626627
# Deforestation_Mask #FDEBD0 "#C9D6AE"
627628
Deforestation : &deforestation "#DBE6DA"
628629
Deforestation_Mask : *deforestation
629630
# Based on "silver" palette from Flat Design Color Chart
630-
Non_Forest : &non_forest "#C0D665"
631+
Non_Forest : &non_forest "#E6D793"
631632
Natural_Non_Forested : *non_forest
632633

633634
# Urban Areas

‎inst/extdata/config_messages.yml‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -406,7 +406,7 @@ sits_cluster_dendro_default: "input should be a valid training set"
406406
sits_colors_legend_not_available: "legend not available in sits colors set"
407407
sits_colors_legends: "available legends are"
408408
sits_colors_not_legend: "no legend provided, returning all available colors"
409-
sits_colors_qgis: "some labels are not in the color table - please run "
409+
sits_colors_qgis_raster: "some labels are not in the color table"
410410
sits_colors_set: "wrong input parameters - see example in documentation"
411411
sits_combine_predictions: "wrong input parameters - input should be a list of probs cube - see example in documentation"
412412
sits_combine_predictions_uncert_cubes: "uncertainty cubes must have same length of prob cubes"
@@ -460,7 +460,7 @@ sits_labels_assign_default: "invalid input data - should be a valid set of sampl
460460
sits_labels_default: "invalid input data - should be a valid set of samples or a probs or classified data cube"
461461
sits_labels_assign_class_cube: "not enough new labels to replace current ones"
462462
sits_labels_assign_probs_cube: "number of new labels dos not match current labels"
463-
sits_labels_raster_cube: "input should be a set of time seriesor probs, class or variance cube"
463+
sits_labels_raster_cube: "input should be a set of time series or probs, class or variance cube"
464464
sits_labels_summary: "this function is deprecated; please use summary()"
465465
sits_lighttae: "wrong input parameters - see example in documentation"
466466
sits_list_collections: "invalid source parameter as data provider"

0 commit comments

Comments
 (0)