Merge pull request #968 from OldLipe/dev2

Add Makevars and update sits_segmentation

R/api_supercells.R

@@ -21,10 +21,10 @@
  multicores,
  progress
 ){
- # set start and end dates
- dates <- .cube_timeline(cube)[[1]]
- start_date <- dates[1]
- end_date <- dates[[length(dates)]]
+ # get start and end dates
+ start_date <- .cube_start_date(cube)
+ end_date <- .cube_end_date(cube)
+
  # combine tiles and bands for parallel processing
  tiles_bands <- tidyr::expand_grid(tile = .cube_tiles(cube),
  band = bands) %>%
@@ -33,8 +33,9 @@
  })
  # set output_dir
  output_dir <- tempdir()
- if (Sys.getenv("SITS_SAMPLES_CACHE_DIR") != "")
+ if (nzchar(Sys.getenv("SITS_SAMPLES_CACHE_DIR"))) {
  output_dir <- Sys.getenv("SITS_SAMPLES_CACHE_DIR")
+ }
  # prepare parallelization
  .sits_parallel_start(workers = multicores, log = FALSE)
  on.exit(.sits_parallel_stop(), add = TRUE)
@@ -82,14 +83,15 @@
  polygon_id = seg[["supercells"]]
  )
  # store them in the sample tibble
- sample$time_series <- list(tibble::tibble(Index = dates))
+ sample$time_series <- list(tibble::tibble(Index = .tile_timeline(tile)))
  # return valid row of time series
  return(sample)
  })
  # extract time series per tile and band
  ts <- .supercells_get_ts(
  tile = tile,
  band = band,
+ samples_tbl = samples_tbl,
  segs_tile = segs_tile,
  impute_fn = impute_fn,
  aggreg_fn = aggreg_fn
@@ -135,7 +137,6 @@
  tidyr::nest(time_series = !!c("Index", bands)) %>%
  dplyr::select(-c("tile", "#..id"))
 
-
  # get the first point that intersect more than one tile
  # eg sentinel 2 mgrs grid
  ts_tbl <- ts_tbl %>%
@@ -183,13 +184,15 @@
 #'
 #' @param tile Tile of regular data cube
 #' @param band Band to extract time series
+#' @param samples_tbl Samples tibble
 #' @param segs_tile Polygons produced by sits_supercells for the tile
-#' @param impute_fn Imputation function for NA values.
+#' @param impute_fn  Imputation function for NA values.
 #' @param aggreg_fn Aggregation function to compute a summary of each segment
 #'
 .supercells_get_ts <- function(
  tile,
  band,
+ samples_tbl,
  segs_tile,
  impute_fn,
  aggreg_fn
@@ -213,21 +216,19 @@
  }
  # correct the values using the scale factor
  values <- values * scale_factor + offset_value
-
- # get the time series as a list
- # values_ts <- as.list(as.data.frame(values))
-
- # # now we have to transpose the data
- ts_samples <- values %>%
- purrr::transpose() %>%
- purrr::map(tibble::as_tibble)
- #
- #
- # points$time_series <- purrr::map2(
- # points$time_series,
- # ts_samples,
- # dplyr::bind_cols
- # )
-
- return(values_ts)
+ # now we have to transpose the data
+ values <- purrr::map(seq_len(nrow(values)), function(i) {
+ dfr <- as.data.frame(unname(t(values[i,])))
+ names(dfr) <- band
+ tibble::as_tibble(dfr)
+ })
+ # join each time series with samples tbl
+ samples_tbl$time_series <- purrr::map2(
+ samples_tbl$time_series,
+ values,
+ dplyr::bind_cols
+ )
+ # set sits class
+ class(samples_tbl) <- c("sits", class(samples_tbl))
+ return(samples_tbl)
 }

R/sits_get_data.R

@@ -336,6 +336,7 @@ sits_get_data.data.frame <- function(cube,
  )
  return(data)
 }
+
 #' @rdname sits_get_data
 #' @export
 sits_get_data.segments <- function(
@@ -348,7 +349,6 @@ sits_get_data.segments <- function(
  multicores = 2,
  progress = FALSE) {
 
-
  data <- .supercells_get_data(
  cube = cube,
  supercells = samples,
@@ -360,6 +360,7 @@ sits_get_data.segments <- function(
  )
  return(data)
 }
+
 #' @title Dispatch function to get time series from data cubes and cloud
 #' services
 #' @name .sits_get_ts
@@ -456,11 +457,9 @@ sits_get_data.segments <- function(
  )
 
  if (file.exists(filename)) {
- tryCatch(
- {
+ tryCatch({
  # ensuring that the file is not corrupted
  timeseries <- readRDS(filename)
-
  return(timeseries)
  },
  error = function(e) {

R/sits_machine_learning.R

@@ -120,7 +120,7 @@ sits_rfor <- function(samples = NULL, num_trees = 100, mtry = NULL, ...) {
 #' This function is a front-end to the "svm" method in the "e1071" package.
 #' Please refer to the documentation in that package for more details.
 #'
-#' @param samples  Time series with the training samples.
+#' @param samples Time series with the training samples.
 #' @param formula Symbolic description of the model to be fit.
 #' (default: sits_formula_linear).
 #' @param scale Logical vector indicating the variables to be scaled.

R/sits_plot.R

@@ -26,14 +26,17 @@
 #' \item{"all years": }{Plot all samples from the same location together}
 #' \item{"together": }{Plot all samples of the same band and label together}
 #' }
-#' The plot.sits function makes an educated guess of what plot is required,
-#' based on the input data. If the input data has less than 30 samples, it
-#' will default to "all years". If there are more than 30 samples,
-#' it will default to "together".
-#'
-#' @param x Object of class "sits"
-#' @param y Ignored.
-#' @param ... Further specifications for \link{plot}.
+#' The plot function makes an educated guess of what plot is required
+#' based on the input data. If the input data has less than 30 samples or
+#' the \code{together} parameter is FALSE, it will plot only one randomly
+#' chosen sample. If the \code{together} parameter is set to TRUE or
+#' there are more than 30 samples, it will plot all samples.
+#'
+#' @param x Object of class "sits".
+#' @param y Ignored.
+#' @param together A logical value indicating whether the samples should be
+#' plotted together.
+#' @param ... Further specifications for \link{plot}.
 #'
 #' @return A series of plot objects produced by ggplot2 showing all
 #' time series associated to each combination of band and label,
@@ -49,12 +52,13 @@
 #' }
 #'
 #' @export
-#'
-plot.sits <- function(x, y, ...) {
+plot.sits <- function(x, y, ..., together = FALSE) {
  stopifnot(missing(y))
+ # default value is set to empty char in case null
+ .check_lgl_parameter(together)
 
  # Are there more than 30 samples? Plot them together!
- if (nrow(x) > 30) {
+ if (together || nrow(x) > 30) {
  p <- .plot_together(x)
  } else {
  # otherwise, take "allyears" as the default

R/sits_segmentation.R

@@ -7,38 +7,40 @@
 #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br}
 #'
 #' @description
-#' Apply a segmentation on a data cube based on the "supercells" package. This is an
-#' adaptation and extention to remote sensing data of the SLIC superpixels
-#' algorithm proposed by Achanta et al. (2012). See references for more details.
+#' Apply a segmentation on a data cube based on the "supercells" package.
+#' This is an adaptation and extension to remote sensing data of the
+#' SLIC superpixels algorithm proposed by Achanta et al. (2012).
+#' See references for more details.
 #'
 #' @param cube Regular data cube
 #' @param tiles Tiles to be segmented
 #' @param bands Bands to include in the segmentation
 #' @param date Date to select the image to be segmented
-#' @param step Distance (in number of cells) between initial supercells' centers.
+#' @param step Distance (in number of cells) between initial
+#' supercells' centers.
 #' @param compactness A compactness value. Larger values cause clusters to
 #' be more compact/even (square).
 #' @param iter Number of iterations to create the output.
 #' @param minarea Specifies the minimal size of a supercell (in cells).
-#' @param chunks Should the input (x) be split into chunks before deriving
-#' supercells? Either FALSE,
+#' @param chunks Should the input (x) be split into chunks before
+#' deriving supercells? Either FALSE,
 #' TRUE (default - only large input objects are split),
-#' or a numeric value (representing the side length of the chunk
-#' in the number of cells).
+#' or a numeric value (representing the side length
+#' of the chunk in the number of cells).
 #' @param future Should the future package be used for parallelization
 #' of the calculations?
 #' @param multicores Number of cores for parallel processing
 #'
 #' @references
-#'  Achanta, Radhakrishna, Appu Shaji, Kevin Smith, Aurelien Lucchi,
-#'  Pascal Fua, and Sabine Süsstrunk. 2012. “SLIC Superpixels Compared
-#'  to State-of-the-Art Superpixel Methods.” IEEE Transactions on
-#'  Pattern Analysis and Machine Intelligence 34 (11): 2274–82.
+#' Achanta, Radhakrishna, Appu Shaji, Kevin Smith, Aurelien Lucchi,
+#' Pascal Fua, and Sabine Süsstrunk. 2012. “SLIC Superpixels Compared
+#' to State-of-the-Art Superpixel Methods.” IEEE Transactions on
+#' Pattern Analysis and Machine Intelligence 34 (11): 2274–82.
 #'
-#'  Nowosad, Jakub, and Tomasz F. Stepinski. 2022. “Extended SLIC
-#'  Superpixels Algorithm for Applications to Non-Imagery Geospatial
-#'  Rasters.” International Journal of Applied Earth Observation
-#'  and Geoinformation 112 (August): 102935.
+#' Nowosad, Jakub, and Tomasz F. Stepinski. 2022. “Extended SLIC
+#' Superpixels Algorithm for Applications to Non-Imagery Geospatial
+#' Rasters.” International Journal of Applied Earth Observation
+#' and Geoinformation 112 (August): 102935.
 #'
 #' @examples
 #' # example code
@@ -63,7 +65,7 @@
 #' @export
 sits_supercells <- function(
  cube,
- tiles = cube[1, "tile"],
+ tiles = NULL,
  bands,
  date,
  step = 50,
@@ -80,8 +82,12 @@ sits_supercells <- function(
  # cube is regular
  .check_is_regular(cube)
  # tile belongs to the cube
- .check_chr_within(tiles, .cube_tiles(cube),
- msg = "tiles not available in the cube")
+ tiles <- .default(tiles, .cube_tiles(cube))
+ .check_chr_within(
+ x = tiles,
+ within = .cube_tiles(cube),
+ msg = "tiles not available in the cube"
+ )
  # bands are OK
  .check_chr_within(bands, .cube_bands(cube),
  msg = "bands not available in the cube")
@@ -107,7 +113,7 @@ sits_supercells <- function(
  # get the tile
  tile_rows <- .cube_filter_tiles(cube, tiles)
 
- cells_tile <- slider::slide(tile_rows, function(row){
+ cells_tile <- slider::slide(tile_rows, function(row) {
  # filter tile by band and date
  row <- row %>%
  .tile_filter_bands(bands) %>%

src/Makevars

@@ -0,0 +1,3 @@
+# CXX_STD = CXX11
+PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS)
+PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)