From 021e120294aaf4cae1e9aff5731d00561c4ce0a5 Mon Sep 17 00:00:00 2001 From: Felipe Date: Mon, 27 Jan 2025 01:02:41 +0000 Subject: [PATCH 001/122] add glcm matrix --- src/glcm_fns.cpp | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 46 insertions(+) create mode 100644 src/glcm_fns.cpp diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp new file mode 100644 index 000000000..6779d0188 --- /dev/null +++ b/src/glcm_fns.cpp @@ -0,0 +1,46 @@ +//[[Rcpp::depends(RcppArmadillo)]] +#include +#include +#include + +using namespace Rcpp; +using namespace std; + +//[[Rcpp::export]] +arma::mat glcm_calc(const arma::mat& x, + const int window_size, + const arma::vec& angles, + const int n_bits = 16) { + arma::mat out(n_bits, n_bits, arma::fill::zeros); + + int nrows = x.n_rows; + int ncols = x.n_cols; + int offset_row, offset_col, start_row, end_row, start_col, end_col, + v_i, v_j, row, col = 0; + + // For each angle + for (arma::uword i = 0; i < angles.size(); i++) { + float angle = angles(i); + offset_row = std::round(std::sin(angle) * window_size); + offset_col = std::round(std::cos(angle) * window_size); + // row + start_row = std::max(0, -offset_row); + end_row = std::min(nrows, nrows - offset_row); + // col + start_col = std::max(0, -offset_col); + end_col = std::min(ncols, ncols - offset_col); + + for (arma::uword r = start_row; r < end_row; r++) { + for (arma::uword c = start_col; c < end_col; c++) { + v_i = x(r,c); + row = r + offset_row; + col = c + offset_col; + v_j = x(row, col); + if (v_i < n_bits && v_j < n_bits) { + out(v_i, v_j) += 1; + } + } + } + } + return out; +} From 6d01f19e10df111a18b713da435cf64cb079e59c Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 29 Jan 2025 01:08:17 +0000 Subject: [PATCH 002/122] add initial version of glcm --- R/RcppExports.R | 52 +++++++++ src/RcppExports.cpp | 174 ++++++++++++++++++++++++++++ src/glcm_fns.cpp | 277 +++++++++++++++++++++++++++++++++++++++----- 3 files changed, 475 insertions(+), 28 deletions(-) diff --git a/R/RcppExports.R b/R/RcppExports.R index 8cb07d08e..960e1e258 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -29,6 +29,58 @@ dtw_distance <- function(ts1, ts2) { .Call(`_sits_dtw_distance`, ts1, ts2) } +glcm_tabulate <- function(x, window_size, angle, n_bits = 16L) { + .Call(`_sits_glcm_tabulate`, x, window_size, angle, n_bits) +} + +glcm_calc_new <- function(x, nrows, ncols, window_size, angles, n_bits = 16L) { + .Call(`_sits_glcm_calc_new`, x, nrows, ncols, window_size, angles, n_bits) +} + +glcm_contrast <- function(glcm, n_levels) { + .Call(`_sits_glcm_contrast`, glcm, n_levels) +} + +glcm_dissimilarity <- function(glcm, n_levels) { + .Call(`_sits_glcm_dissimilarity`, glcm, n_levels) +} + +glcm_homogeneity <- function(glcm, n_levels) { + .Call(`_sits_glcm_homogeneity`, glcm, n_levels) +} + +glcm_energy <- function(glcm, n_levels) { + .Call(`_sits_glcm_energy`, glcm, n_levels) +} + +glcm_asm <- function(glcm, n_levels) { + .Call(`_sits_glcm_asm`, glcm, n_levels) +} + +glcm_mean <- function(glcm, n_levels) { + .Call(`_sits_glcm_mean`, glcm, n_levels) +} + +glcm_variance <- function(glcm, n_levels) { + .Call(`_sits_glcm_variance`, glcm, n_levels) +} + +glcm_std <- function(glcm, n_levels) { + .Call(`_sits_glcm_std`, glcm, n_levels) +} + +glcm_entropy <- function(glcm, n_levels) { + .Call(`_sits_glcm_entropy`, glcm, n_levels) +} + +glcm_correlation <- function(glcm, n_levels) { + .Call(`_sits_glcm_correlation`, glcm, n_levels) +} + +C_create_glcm_weights <- function(n_levels) { + .Call(`_sits_C_create_glcm_weights`, n_levels) +} + C_kernel_median <- function(x, ncols, nrows, band, window_size) { .Call(`_sits_C_kernel_median`, x, ncols, nrows, band, window_size) } diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index a373830f1..ebe9b3b6d 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -104,6 +104,167 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// glcm_tabulate +arma::mat glcm_tabulate(const arma::mat& x, const arma::uword window_size, const float& angle, const int n_bits); +RcppExport SEXP _sits_glcm_tabulate(SEXP xSEXP, SEXP window_sizeSEXP, SEXP angleSEXP, SEXP n_bitsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::mat& >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type window_size(window_sizeSEXP); + Rcpp::traits::input_parameter< const float& >::type angle(angleSEXP); + Rcpp::traits::input_parameter< const int >::type n_bits(n_bitsSEXP); + rcpp_result_gen = Rcpp::wrap(glcm_tabulate(x, window_size, angle, n_bits)); + return rcpp_result_gen; +END_RCPP +} +// glcm_calc_new +NumericMatrix glcm_calc_new(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_bits); +RcppExport SEXP _sits_glcm_calc_new(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_bitsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type n_bits(n_bitsSEXP); + rcpp_result_gen = Rcpp::wrap(glcm_calc_new(x, nrows, ncols, window_size, angles, n_bits)); + return rcpp_result_gen; +END_RCPP +} +// glcm_contrast +double glcm_contrast(const arma::mat glcm, const arma::uword n_levels); +RcppExport SEXP _sits_glcm_contrast(SEXP glcmSEXP, SEXP n_levelsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); + rcpp_result_gen = Rcpp::wrap(glcm_contrast(glcm, n_levels)); + return rcpp_result_gen; +END_RCPP +} +// glcm_dissimilarity +double glcm_dissimilarity(const arma::mat glcm, const arma::uword n_levels); +RcppExport SEXP _sits_glcm_dissimilarity(SEXP glcmSEXP, SEXP n_levelsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); + rcpp_result_gen = Rcpp::wrap(glcm_dissimilarity(glcm, n_levels)); + return rcpp_result_gen; +END_RCPP +} +// glcm_homogeneity +double glcm_homogeneity(const arma::mat glcm, const arma::uword n_levels); +RcppExport SEXP _sits_glcm_homogeneity(SEXP glcmSEXP, SEXP n_levelsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); + rcpp_result_gen = Rcpp::wrap(glcm_homogeneity(glcm, n_levels)); + return rcpp_result_gen; +END_RCPP +} +// glcm_energy +double glcm_energy(const arma::mat glcm, const arma::uword n_levels); +RcppExport SEXP _sits_glcm_energy(SEXP glcmSEXP, SEXP n_levelsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); + rcpp_result_gen = Rcpp::wrap(glcm_energy(glcm, n_levels)); + return rcpp_result_gen; +END_RCPP +} +// glcm_asm +double glcm_asm(const arma::mat glcm, const arma::uword n_levels); +RcppExport SEXP _sits_glcm_asm(SEXP glcmSEXP, SEXP n_levelsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); + rcpp_result_gen = Rcpp::wrap(glcm_asm(glcm, n_levels)); + return rcpp_result_gen; +END_RCPP +} +// glcm_mean +double glcm_mean(const arma::mat glcm, const arma::uword n_levels); +RcppExport SEXP _sits_glcm_mean(SEXP glcmSEXP, SEXP n_levelsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); + rcpp_result_gen = Rcpp::wrap(glcm_mean(glcm, n_levels)); + return rcpp_result_gen; +END_RCPP +} +// glcm_variance +double glcm_variance(const arma::mat glcm, const arma::uword n_levels); +RcppExport SEXP _sits_glcm_variance(SEXP glcmSEXP, SEXP n_levelsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); + rcpp_result_gen = Rcpp::wrap(glcm_variance(glcm, n_levels)); + return rcpp_result_gen; +END_RCPP +} +// glcm_std +double glcm_std(const arma::mat glcm, const arma::uword n_levels); +RcppExport SEXP _sits_glcm_std(SEXP glcmSEXP, SEXP n_levelsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); + rcpp_result_gen = Rcpp::wrap(glcm_std(glcm, n_levels)); + return rcpp_result_gen; +END_RCPP +} +// glcm_entropy +double glcm_entropy(const arma::mat glcm, const arma::uword n_levels); +RcppExport SEXP _sits_glcm_entropy(SEXP glcmSEXP, SEXP n_levelsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); + rcpp_result_gen = Rcpp::wrap(glcm_entropy(glcm, n_levels)); + return rcpp_result_gen; +END_RCPP +} +// glcm_correlation +double glcm_correlation(const arma::mat glcm, const arma::uword n_levels); +RcppExport SEXP _sits_glcm_correlation(SEXP glcmSEXP, SEXP n_levelsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); + rcpp_result_gen = Rcpp::wrap(glcm_correlation(glcm, n_levels)); + return rcpp_result_gen; +END_RCPP +} +// C_create_glcm_weights +arma::mat C_create_glcm_weights(const arma::uword n_levels); +RcppExport SEXP _sits_C_create_glcm_weights(SEXP n_levelsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); + rcpp_result_gen = Rcpp::wrap(C_create_glcm_weights(n_levels)); + return rcpp_result_gen; +END_RCPP +} // C_kernel_median NumericVector C_kernel_median(const NumericMatrix& x, int ncols, int nrows, int band, int window_size); RcppExport SEXP _sits_C_kernel_median(SEXP xSEXP, SEXP ncolsSEXP, SEXP nrowsSEXP, SEXP bandSEXP, SEXP window_sizeSEXP) { @@ -756,6 +917,19 @@ static const R_CallMethodDef CallEntries[] = { {"_sits_weighted_probs", (DL_FUNC) &_sits_weighted_probs, 2}, {"_sits_weighted_uncert_probs", (DL_FUNC) &_sits_weighted_uncert_probs, 2}, {"_sits_dtw_distance", (DL_FUNC) &_sits_dtw_distance, 2}, + {"_sits_glcm_tabulate", (DL_FUNC) &_sits_glcm_tabulate, 4}, + {"_sits_glcm_calc_new", (DL_FUNC) &_sits_glcm_calc_new, 6}, + {"_sits_glcm_contrast", (DL_FUNC) &_sits_glcm_contrast, 2}, + {"_sits_glcm_dissimilarity", (DL_FUNC) &_sits_glcm_dissimilarity, 2}, + {"_sits_glcm_homogeneity", (DL_FUNC) &_sits_glcm_homogeneity, 2}, + {"_sits_glcm_energy", (DL_FUNC) &_sits_glcm_energy, 2}, + {"_sits_glcm_asm", (DL_FUNC) &_sits_glcm_asm, 2}, + {"_sits_glcm_mean", (DL_FUNC) &_sits_glcm_mean, 2}, + {"_sits_glcm_variance", (DL_FUNC) &_sits_glcm_variance, 2}, + {"_sits_glcm_std", (DL_FUNC) &_sits_glcm_std, 2}, + {"_sits_glcm_entropy", (DL_FUNC) &_sits_glcm_entropy, 2}, + {"_sits_glcm_correlation", (DL_FUNC) &_sits_glcm_correlation, 2}, + {"_sits_C_create_glcm_weights", (DL_FUNC) &_sits_C_create_glcm_weights, 1}, {"_sits_C_kernel_median", (DL_FUNC) &_sits_C_kernel_median, 5}, {"_sits_C_kernel_mean", (DL_FUNC) &_sits_C_kernel_mean, 5}, {"_sits_C_kernel_sd", (DL_FUNC) &_sits_C_kernel_sd, 5}, diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index 6779d0188..338d1422c 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -1,46 +1,267 @@ //[[Rcpp::depends(RcppArmadillo)]] #include #include +#include #include using namespace Rcpp; using namespace std; //[[Rcpp::export]] -arma::mat glcm_calc(const arma::mat& x, - const int window_size, - const arma::vec& angles, - const int n_bits = 16) { +arma::mat glcm_tabulate(const arma::mat& x, + const arma::uword window_size, + const float& angle, + const int n_bits = 16) { + + arma::mat out(n_bits, n_bits, arma::fill::zeros); int nrows = x.n_rows; int ncols = x.n_cols; - int offset_row, offset_col, start_row, end_row, start_col, end_col, - v_i, v_j, row, col = 0; - - // For each angle - for (arma::uword i = 0; i < angles.size(); i++) { - float angle = angles(i); - offset_row = std::round(std::sin(angle) * window_size); - offset_col = std::round(std::cos(angle) * window_size); - // row - start_row = std::max(0, -offset_row); - end_row = std::min(nrows, nrows - offset_row); - // col - start_col = std::max(0, -offset_col); - end_col = std::min(ncols, ncols - offset_col); - - for (arma::uword r = start_row; r < end_row; r++) { - for (arma::uword c = start_col; c < end_col; c++) { - v_i = x(r,c); - row = r + offset_row; - col = c + offset_col; - v_j = x(row, col); - if (v_i < n_bits && v_j < n_bits) { - out(v_i, v_j) += 1; - } + + arma::uword start_row, end_row, start_col, end_col = 0; + int offset_row, offset_col, v_i, v_j, row, col = 0; + + offset_row = std::round(std::sin(angle) * window_size); + offset_col = std::round(std::cos(angle) * window_size); + // row + start_row = std::max(0, -offset_row); + end_row = std::min(nrows, nrows - offset_row); + // col + start_col = std::max(0, -offset_col); + end_col = std::min(ncols, ncols - offset_col); + + for (arma::uword r = start_row; r < end_row; r++) { + for (arma::uword c = start_col; c < end_col; c++) { + v_i = x(r,c); + row = r + offset_row; + col = c + offset_col; + v_j = x(row, col); + if (v_i < n_bits && v_j < n_bits) { + out(v_i, v_j) += 1; } } } return out; } + +// compute outside indices of a vector as a mirror +IntegerVector locus_neigh2(int size, int leg) { + IntegerVector res(size + 2 * leg); + for (int i = 0; i < res.length(); ++i) { + if (i < leg) + res(i) = leg - i - 1; + else if (i < size + leg) + res(i) = i - leg; + else + res(i) = 2 * size + leg - i - 1; + } + return res; +} + +// [[Rcpp::export]] +NumericMatrix glcm_calc_new(const arma::vec& x, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::vec& angles, + const arma::uword& n_bits = 16) { + // initialize result values + NumericMatrix res(nrows, ncols); + arma::mat neigh(window_size, window_size); + arma::mat glcm(n_bits, n_bits, arma::fill::zeros); + double sum = 0; + + // compute window leg + int leg = window_size / 2; + // compute locus mirror + IntegerVector loci = locus_neigh2(nrows, leg); + IntegerVector locj = locus_neigh2(ncols, leg); + // compute values for each pixel + for (int i = 0; i < nrows; ++i) { + for (int j = 0; j < ncols; ++j) { + // for all bands + for (int angle = 0; angle < angles.size(); ++angle) { + // compute the neighborhood + for (int wi = 0; wi < window_size; ++wi) { + for (int wj = 0; wj < window_size; ++wj) { + neigh(wi, wj) = + x(loci(wi + i) * ncols + locj(wj + j)); + } + } + Rcpp::Rcout << neigh << "\n"; + + glcm = glcm_tabulate(neigh, 1, 0, n_bits); + sum = arma::accu(glcm); + glcm /= sum; + Rcpp::Rcout << glcm << "\n"; + // remove NA + //NumericVector neigh2 = na_omit(neigh); + res(i * ncols + j, angle) = 1; + } + } + } + return res; +} + +// [[Rcpp::export]] +double glcm_contrast(const arma::mat glcm, + const arma::uword n_levels) { + arma::mat j(n_levels, n_levels, arma::fill::zeros); + arma::mat i(n_levels, n_levels, arma::fill::zeros); + double res = 0; + + for (arma::uword r = 0; r < n_levels; r++) { + for (arma::uword c = 0; c < n_levels; c++) { + i(r, c) = r; + j(r, c) = c; + } + } + res = arma::accu(glcm % pow(i - j, 2)); + return(res); +} + +// [[Rcpp::export]] +double glcm_dissimilarity(const arma::mat glcm, + const arma::uword n_levels) { + arma::mat j(n_levels, n_levels, arma::fill::zeros); + arma::mat i(n_levels, n_levels, arma::fill::zeros); + double res = 0; + + for (arma::uword r = 0; r < n_levels; r++) { + for (arma::uword c = 0; c < n_levels; c++) { + i(r, c) = r; + j(r, c) = c; + } + } + res = arma::accu(glcm % abs(i - j)); + return(res); +} + +// [[Rcpp::export]] +double glcm_homogeneity(const arma::mat glcm, + const arma::uword n_levels) { + arma::mat j(n_levels, n_levels, arma::fill::zeros); + arma::mat i(n_levels, n_levels, arma::fill::zeros); + double res = 0; + + for (arma::uword r = 0; r < n_levels; r++) { + for (arma::uword c = 0; c < n_levels; c++) { + i(r, c) = r; + j(r, c) = c; + } + } + res = arma::accu(glcm / (1 + (pow(i - j, 2)))); + return(res); +} + +// [[Rcpp::export]] +double glcm_energy(const arma::mat glcm, + const arma::uword n_levels) { + double res = 0; + + res = std::sqrt(arma::accu(pow(glcm, 2))); + return(res); +} + +// [[Rcpp::export]] +double glcm_asm(const arma::mat glcm, + const arma::uword n_levels) { + double res = 0; + + res = arma::accu(pow(glcm, 2)); + return(res); +} + +// [[Rcpp::export]] +double glcm_mean(const arma::mat glcm, + const arma::uword n_levels) { + arma::mat i(n_levels, n_levels, arma::fill::zeros); + double res = 0; + + for (arma::uword r = 0; r < n_levels; r++) { + for (arma::uword c = 0; c < n_levels; c++) { + i(r, c) = r; + } + } + + res = arma::accu(glcm % i); + return(res); +} + +// [[Rcpp::export]] +double glcm_variance(const arma::mat glcm, + const arma::uword n_levels) { + arma::mat i(n_levels, n_levels, arma::fill::zeros); + double res = 0; + + for (arma::uword r = 0; r < n_levels; r++) { + for (arma::uword c = 0; c < n_levels; c++) { + i(r, c) = r; + } + } + res = arma::accu(glcm % i); + + res = arma::accu(glcm % pow(i - res, 2)); + return(res); +} + +// [[Rcpp::export]] +double glcm_std(const arma::mat glcm, + const arma::uword n_levels) { + + double res = glcm_variance(glcm, n_levels); + + res = sqrt(res); + return(res); +} + +// [[Rcpp::export]] +double glcm_entropy(const arma::mat glcm, + const arma::uword n_levels) { + double res = 0; + + arma::mat glcm_entropy = glcm % ((-1) * log(glcm)); + glcm_entropy.replace(arma::datum::nan, 0); + + res = accu(glcm_entropy); + return(res); +} + +// [[Rcpp::export]] +double glcm_correlation(const arma::mat glcm, + const arma::uword n_levels) { + double res = 0; + double res_mean = glcm_mean(glcm, n_levels); + double res_var = glcm_variance(glcm, n_levels); + + arma::mat j(n_levels, n_levels, arma::fill::zeros); + arma::mat i(n_levels, n_levels, arma::fill::zeros); + + for (arma::uword r = 0; r < n_levels; r++) { + for (arma::uword c = 0; c < n_levels; c++) { + i(r, c) = r; + j(r, c) = c; + } + } + + res = accu(glcm % (((i - res_mean) % (j - res_mean)) / (res_var))); + return(res); +} + +// [[Rcpp::export]] +arma::mat C_create_glcm_weights(const arma::uword n_levels) { + arma::mat j(n_levels, n_levels); + arma::mat i(n_levels, n_levels); + + for (arma::uword r = 0; r < n_levels; r++) { + for (arma::uword c = 0; c < n_levels; c++) { + i(r, c) = r; + j(r, c) = c; + } + } + Rcpp::Rcout << i << "\n"; + Rcpp::Rcout << j << "\n"; + + return (i - j); +} From 193261280df9c8b914b319404173b33bb7b8c852 Mon Sep 17 00:00:00 2001 From: Felipe Date: Thu, 30 Jan 2025 14:10:56 +0000 Subject: [PATCH 003/122] update smooth documentation --- R/api_smooth.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/api_smooth.R b/R/api_smooth.R index cd5390afe..c51f03ae4 100644 --- a/R/api_smooth.R +++ b/R/api_smooth.R @@ -4,7 +4,7 @@ #' @noRd #' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} #' -#' @param tile. Subset of a data cube containing one tile +#' @param tile Subset of a data cube containing one tile #' @param band Band to be processed #' @param block Individual block that will be processed #' @param overlap Overlap between tiles (if required) From 457ee1f3574bde06ec9632dbff4d19578f168111 Mon Sep 17 00:00:00 2001 From: Felipe Date: Mon, 3 Feb 2025 14:25:36 +0000 Subject: [PATCH 004/122] update glcm code --- R/api_apply.R | 6 ++ src/glcm_fns.cpp | 177 +++++++++++++++++++++++++++++++++++++---------- 2 files changed, 145 insertions(+), 38 deletions(-) diff --git a/R/api_apply.R b/R/api_apply.R index 1960d3e79..a5299df68 100644 --- a/R/api_apply.R +++ b/R/api_apply.R @@ -317,6 +317,12 @@ x = as.matrix(m), ncols = img_ncol, nrows = img_nrow, band = 0, window_size = window_size ) + }, + glcm_contrast = function(m, shifts = c(0, pi/2, 3*pi/4, pi/4)) { + C_glcm_contrast( + x = as.matrix(m), ncols = img_ncol, nrows = img_nrow, + band = 0, window_size = window_size + ) } ), parent = parent.env(environment()), hash = TRUE) diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index 338d1422c..555d74c89 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -7,14 +7,31 @@ using namespace Rcpp; using namespace std; + +typedef double _glcm_fun(const arma::vec&, arma::mat&, arma::mat&); + +// compute outside indices of a vector as a mirror +IntegerVector locus_neigh2(int size, int leg) { + IntegerVector res(size + 2 * leg); + for (int i = 0; i < res.length(); ++i) { + if (i < leg) + res(i) = leg - i - 1; + else if (i < size + leg) + res(i) = i - leg; + else + res(i) = 2 * size + leg - i - 1; + } + return res; +} + //[[Rcpp::export]] arma::mat glcm_tabulate(const arma::mat& x, - const arma::uword window_size, const float& angle, const int n_bits = 16) { - - arma::mat out(n_bits, n_bits, arma::fill::zeros); + // is this the best approach? + arma::mat out(2^n_bits, 2^n_bits, arma::fill::zeros); + int pixels_to_move = 1; int nrows = x.n_rows; int ncols = x.n_cols; @@ -22,8 +39,8 @@ arma::mat glcm_tabulate(const arma::mat& x, arma::uword start_row, end_row, start_col, end_col = 0; int offset_row, offset_col, v_i, v_j, row, col = 0; - offset_row = std::round(std::sin(angle) * window_size); - offset_col = std::round(std::cos(angle) * window_size); + offset_row = std::round(std::sin(angle) * pixels_to_move); + offset_col = std::round(std::cos(angle) * pixels_to_move); // row start_row = std::max(0, -offset_row); end_row = std::min(nrows, nrows - offset_row); @@ -45,31 +62,19 @@ arma::mat glcm_tabulate(const arma::mat& x, return out; } -// compute outside indices of a vector as a mirror -IntegerVector locus_neigh2(int size, int leg) { - IntegerVector res(size + 2 * leg); - for (int i = 0; i < res.length(); ++i) { - if (i < leg) - res(i) = leg - i - 1; - else if (i < size + leg) - res(i) = i - leg; - else - res(i) = 2 * size + leg - i - 1; - } - return res; -} // [[Rcpp::export]] -NumericMatrix glcm_calc_new(const arma::vec& x, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, - const arma::vec& angles, - const arma::uword& n_bits = 16) { +NumericMatrix glcm_fun(const arma::vec& x, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::vec& angles, + const arma::uword& n_bits = 16, + _glcm_fun _fun) { // initialize result values - NumericMatrix res(nrows, ncols); arma::mat neigh(window_size, window_size); arma::mat glcm(n_bits, n_bits, arma::fill::zeros); + arma::mat out(2^n_bits, 2^n_bits, arma::fill::zeros); double sum = 0; // compute window leg @@ -89,7 +94,6 @@ NumericMatrix glcm_calc_new(const arma::vec& x, x(loci(wi + i) * ncols + locj(wj + j)); } } - Rcpp::Rcout << neigh << "\n"; glcm = glcm_tabulate(neigh, 1, 0, n_bits); sum = arma::accu(glcm); @@ -104,23 +108,35 @@ NumericMatrix glcm_calc_new(const arma::vec& x, return res; } -// [[Rcpp::export]] -double glcm_contrast(const arma::mat glcm, - const arma::uword n_levels) { - arma::mat j(n_levels, n_levels, arma::fill::zeros); - arma::mat i(n_levels, n_levels, arma::fill::zeros); + +inline double _glcm_contrast(const arma::vec x, + const arma::mat i, + const arma::mat j) { double res = 0; - for (arma::uword r = 0; r < n_levels; r++) { - for (arma::uword c = 0; c < n_levels; c++) { - i(r, c) = r; - j(r, c) = c; - } - } - res = arma::accu(glcm % pow(i - j, 2)); + res = arma::accu(x % pow(i - j, 2)); return(res); } +// [[Rcpp::export]] +double C_glcm_contrast(const arma::vec& x, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::uword& n_levels, + const arma::vec& angles, + const arma::uword& n_bits = 16) { + + + return glcm_fun(x, nrows, ncols, window_size, angles, n_bits, _glcm_contrast); +} + + + + + + + // [[Rcpp::export]] double glcm_dissimilarity(const arma::mat glcm, const arma::uword n_levels) { @@ -265,3 +281,88 @@ arma::mat C_create_glcm_weights(const arma::uword n_levels) { return (i - j); } + + +// kernel functions +inline double _median(const NumericVector& neigh) { + return median(neigh, true); +} +inline double _mean(const NumericVector& neigh) { + return mean(na_omit(neigh)); +} +inline double _sd(const NumericVector& neigh) { + return sd(na_omit(neigh)); +} +inline double _min(const NumericVector& neigh) { + return min(na_omit(neigh)); +} +inline double _max(const NumericVector& neigh) { + return max(na_omit(neigh)); +} +inline double _var(const NumericVector& neigh) { + return var(na_omit(neigh)); +} + +NumericVector kernel_fun(const NumericMatrix& x, int ncols, int nrows, + int band, int window_size, _kernel_fun _fun) { + // initialize result vectors + NumericVector res(x.nrow()); + NumericVector neigh(window_size * window_size); + if (window_size < 1) { + res = x(_, band); + return res; + } + // compute window leg + int leg = window_size / 2; + // compute locus mirror + IntegerVector loci = locus_mirror(nrows, leg); + IntegerVector locj = locus_mirror(ncols, leg); + // compute values for each pixel + for (int i = 0; i < nrows; ++i) { + for (int j = 0; j < ncols; ++j) { + // window + for (int wi = 0; wi < window_size; ++wi) + for (int wj = 0; wj < window_size; ++wj) + neigh(wi * window_size + wj) = + x(loci(wi + i) * ncols + locj(wj + j), band); + // call specific function + res(i * ncols + j) = _fun(neigh); + } + } + return res; +} +// [[Rcpp::export]] +NumericVector C_kernel_median(const NumericMatrix& x, int ncols, + int nrows, int band, int window_size) { + return kernel_fun(x, ncols, nrows, band, window_size, _median); +} +// [[Rcpp::export]] +NumericVector C_kernel_mean(const NumericMatrix& x, int ncols, + int nrows, int band, int window_size) { + return kernel_fun(x, ncols, nrows, band, window_size, _mean); +} +// [[Rcpp::export]] +NumericVector C_kernel_sd(const NumericMatrix& x, int ncols, + int nrows, int band, int window_size) { + return kernel_fun(x, ncols, nrows, band, window_size, _sd); +} +// [[Rcpp::export]] +NumericVector C_kernel_min(const NumericMatrix& x, int ncols, + int nrows, int band, int window_size) { + return kernel_fun(x, ncols, nrows, band, window_size, _min); +} +// [[Rcpp::export]] +NumericVector C_kernel_max(const NumericMatrix& x, int ncols, + int nrows, int band, int window_size) { + return kernel_fun(x, ncols, nrows, band, window_size, _max); +} +// [[Rcpp::export]] +NumericVector C_kernel_var(const NumericMatrix& x, int ncols, + int nrows, int band, int window_size) { + return kernel_fun(x, ncols, nrows, band, window_size, _var); +} +// [[Rcpp::export]] +NumericVector C_kernel_modal(const NumericMatrix& x, int ncols, + int nrows, int band, int window_size) { + return kernel_fun(x, ncols, nrows, band, window_size, _modal); +} From e28a0e65b30f8c77bcdddbc9a8aacf252abab9fd Mon Sep 17 00:00:00 2001 From: Felipe Date: Thu, 6 Feb 2025 21:43:31 +0000 Subject: [PATCH 005/122] update glcm code --- R/RcppExports.R | 52 ---- src/RcppExports.cpp | 174 ----------- src/glcm_fns.cpp | 737 ++++++++++++++++++++++---------------------- 3 files changed, 369 insertions(+), 594 deletions(-) diff --git a/R/RcppExports.R b/R/RcppExports.R index 960e1e258..8cb07d08e 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -29,58 +29,6 @@ dtw_distance <- function(ts1, ts2) { .Call(`_sits_dtw_distance`, ts1, ts2) } -glcm_tabulate <- function(x, window_size, angle, n_bits = 16L) { - .Call(`_sits_glcm_tabulate`, x, window_size, angle, n_bits) -} - -glcm_calc_new <- function(x, nrows, ncols, window_size, angles, n_bits = 16L) { - .Call(`_sits_glcm_calc_new`, x, nrows, ncols, window_size, angles, n_bits) -} - -glcm_contrast <- function(glcm, n_levels) { - .Call(`_sits_glcm_contrast`, glcm, n_levels) -} - -glcm_dissimilarity <- function(glcm, n_levels) { - .Call(`_sits_glcm_dissimilarity`, glcm, n_levels) -} - -glcm_homogeneity <- function(glcm, n_levels) { - .Call(`_sits_glcm_homogeneity`, glcm, n_levels) -} - -glcm_energy <- function(glcm, n_levels) { - .Call(`_sits_glcm_energy`, glcm, n_levels) -} - -glcm_asm <- function(glcm, n_levels) { - .Call(`_sits_glcm_asm`, glcm, n_levels) -} - -glcm_mean <- function(glcm, n_levels) { - .Call(`_sits_glcm_mean`, glcm, n_levels) -} - -glcm_variance <- function(glcm, n_levels) { - .Call(`_sits_glcm_variance`, glcm, n_levels) -} - -glcm_std <- function(glcm, n_levels) { - .Call(`_sits_glcm_std`, glcm, n_levels) -} - -glcm_entropy <- function(glcm, n_levels) { - .Call(`_sits_glcm_entropy`, glcm, n_levels) -} - -glcm_correlation <- function(glcm, n_levels) { - .Call(`_sits_glcm_correlation`, glcm, n_levels) -} - -C_create_glcm_weights <- function(n_levels) { - .Call(`_sits_C_create_glcm_weights`, n_levels) -} - C_kernel_median <- function(x, ncols, nrows, band, window_size) { .Call(`_sits_C_kernel_median`, x, ncols, nrows, band, window_size) } diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index ebe9b3b6d..a373830f1 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -104,167 +104,6 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } -// glcm_tabulate -arma::mat glcm_tabulate(const arma::mat& x, const arma::uword window_size, const float& angle, const int n_bits); -RcppExport SEXP _sits_glcm_tabulate(SEXP xSEXP, SEXP window_sizeSEXP, SEXP angleSEXP, SEXP n_bitsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type x(xSEXP); - Rcpp::traits::input_parameter< const arma::uword >::type window_size(window_sizeSEXP); - Rcpp::traits::input_parameter< const float& >::type angle(angleSEXP); - Rcpp::traits::input_parameter< const int >::type n_bits(n_bitsSEXP); - rcpp_result_gen = Rcpp::wrap(glcm_tabulate(x, window_size, angle, n_bits)); - return rcpp_result_gen; -END_RCPP -} -// glcm_calc_new -NumericMatrix glcm_calc_new(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_bits); -RcppExport SEXP _sits_glcm_calc_new(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_bitsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); - Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type n_bits(n_bitsSEXP); - rcpp_result_gen = Rcpp::wrap(glcm_calc_new(x, nrows, ncols, window_size, angles, n_bits)); - return rcpp_result_gen; -END_RCPP -} -// glcm_contrast -double glcm_contrast(const arma::mat glcm, const arma::uword n_levels); -RcppExport SEXP _sits_glcm_contrast(SEXP glcmSEXP, SEXP n_levelsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); - Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); - rcpp_result_gen = Rcpp::wrap(glcm_contrast(glcm, n_levels)); - return rcpp_result_gen; -END_RCPP -} -// glcm_dissimilarity -double glcm_dissimilarity(const arma::mat glcm, const arma::uword n_levels); -RcppExport SEXP _sits_glcm_dissimilarity(SEXP glcmSEXP, SEXP n_levelsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); - Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); - rcpp_result_gen = Rcpp::wrap(glcm_dissimilarity(glcm, n_levels)); - return rcpp_result_gen; -END_RCPP -} -// glcm_homogeneity -double glcm_homogeneity(const arma::mat glcm, const arma::uword n_levels); -RcppExport SEXP _sits_glcm_homogeneity(SEXP glcmSEXP, SEXP n_levelsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); - Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); - rcpp_result_gen = Rcpp::wrap(glcm_homogeneity(glcm, n_levels)); - return rcpp_result_gen; -END_RCPP -} -// glcm_energy -double glcm_energy(const arma::mat glcm, const arma::uword n_levels); -RcppExport SEXP _sits_glcm_energy(SEXP glcmSEXP, SEXP n_levelsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); - Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); - rcpp_result_gen = Rcpp::wrap(glcm_energy(glcm, n_levels)); - return rcpp_result_gen; -END_RCPP -} -// glcm_asm -double glcm_asm(const arma::mat glcm, const arma::uword n_levels); -RcppExport SEXP _sits_glcm_asm(SEXP glcmSEXP, SEXP n_levelsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); - Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); - rcpp_result_gen = Rcpp::wrap(glcm_asm(glcm, n_levels)); - return rcpp_result_gen; -END_RCPP -} -// glcm_mean -double glcm_mean(const arma::mat glcm, const arma::uword n_levels); -RcppExport SEXP _sits_glcm_mean(SEXP glcmSEXP, SEXP n_levelsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); - Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); - rcpp_result_gen = Rcpp::wrap(glcm_mean(glcm, n_levels)); - return rcpp_result_gen; -END_RCPP -} -// glcm_variance -double glcm_variance(const arma::mat glcm, const arma::uword n_levels); -RcppExport SEXP _sits_glcm_variance(SEXP glcmSEXP, SEXP n_levelsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); - Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); - rcpp_result_gen = Rcpp::wrap(glcm_variance(glcm, n_levels)); - return rcpp_result_gen; -END_RCPP -} -// glcm_std -double glcm_std(const arma::mat glcm, const arma::uword n_levels); -RcppExport SEXP _sits_glcm_std(SEXP glcmSEXP, SEXP n_levelsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); - Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); - rcpp_result_gen = Rcpp::wrap(glcm_std(glcm, n_levels)); - return rcpp_result_gen; -END_RCPP -} -// glcm_entropy -double glcm_entropy(const arma::mat glcm, const arma::uword n_levels); -RcppExport SEXP _sits_glcm_entropy(SEXP glcmSEXP, SEXP n_levelsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); - Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); - rcpp_result_gen = Rcpp::wrap(glcm_entropy(glcm, n_levels)); - return rcpp_result_gen; -END_RCPP -} -// glcm_correlation -double glcm_correlation(const arma::mat glcm, const arma::uword n_levels); -RcppExport SEXP _sits_glcm_correlation(SEXP glcmSEXP, SEXP n_levelsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat >::type glcm(glcmSEXP); - Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); - rcpp_result_gen = Rcpp::wrap(glcm_correlation(glcm, n_levels)); - return rcpp_result_gen; -END_RCPP -} -// C_create_glcm_weights -arma::mat C_create_glcm_weights(const arma::uword n_levels); -RcppExport SEXP _sits_C_create_glcm_weights(SEXP n_levelsSEXP) { -BEGIN_RCPP - Rcpp::RObject rcpp_result_gen; - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::uword >::type n_levels(n_levelsSEXP); - rcpp_result_gen = Rcpp::wrap(C_create_glcm_weights(n_levels)); - return rcpp_result_gen; -END_RCPP -} // C_kernel_median NumericVector C_kernel_median(const NumericMatrix& x, int ncols, int nrows, int band, int window_size); RcppExport SEXP _sits_C_kernel_median(SEXP xSEXP, SEXP ncolsSEXP, SEXP nrowsSEXP, SEXP bandSEXP, SEXP window_sizeSEXP) { @@ -917,19 +756,6 @@ static const R_CallMethodDef CallEntries[] = { {"_sits_weighted_probs", (DL_FUNC) &_sits_weighted_probs, 2}, {"_sits_weighted_uncert_probs", (DL_FUNC) &_sits_weighted_uncert_probs, 2}, {"_sits_dtw_distance", (DL_FUNC) &_sits_dtw_distance, 2}, - {"_sits_glcm_tabulate", (DL_FUNC) &_sits_glcm_tabulate, 4}, - {"_sits_glcm_calc_new", (DL_FUNC) &_sits_glcm_calc_new, 6}, - {"_sits_glcm_contrast", (DL_FUNC) &_sits_glcm_contrast, 2}, - {"_sits_glcm_dissimilarity", (DL_FUNC) &_sits_glcm_dissimilarity, 2}, - {"_sits_glcm_homogeneity", (DL_FUNC) &_sits_glcm_homogeneity, 2}, - {"_sits_glcm_energy", (DL_FUNC) &_sits_glcm_energy, 2}, - {"_sits_glcm_asm", (DL_FUNC) &_sits_glcm_asm, 2}, - {"_sits_glcm_mean", (DL_FUNC) &_sits_glcm_mean, 2}, - {"_sits_glcm_variance", (DL_FUNC) &_sits_glcm_variance, 2}, - {"_sits_glcm_std", (DL_FUNC) &_sits_glcm_std, 2}, - {"_sits_glcm_entropy", (DL_FUNC) &_sits_glcm_entropy, 2}, - {"_sits_glcm_correlation", (DL_FUNC) &_sits_glcm_correlation, 2}, - {"_sits_C_create_glcm_weights", (DL_FUNC) &_sits_C_create_glcm_weights, 1}, {"_sits_C_kernel_median", (DL_FUNC) &_sits_C_kernel_median, 5}, {"_sits_C_kernel_mean", (DL_FUNC) &_sits_C_kernel_mean, 5}, {"_sits_C_kernel_sd", (DL_FUNC) &_sits_C_kernel_sd, 5}, diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index 555d74c89..40923bd7c 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -1,368 +1,369 @@ -//[[Rcpp::depends(RcppArmadillo)]] -#include -#include -#include -#include - -using namespace Rcpp; -using namespace std; - - -typedef double _glcm_fun(const arma::vec&, arma::mat&, arma::mat&); - -// compute outside indices of a vector as a mirror -IntegerVector locus_neigh2(int size, int leg) { - IntegerVector res(size + 2 * leg); - for (int i = 0; i < res.length(); ++i) { - if (i < leg) - res(i) = leg - i - 1; - else if (i < size + leg) - res(i) = i - leg; - else - res(i) = 2 * size + leg - i - 1; - } - return res; -} - -//[[Rcpp::export]] -arma::mat glcm_tabulate(const arma::mat& x, - const float& angle, - const int n_bits = 16) { - - // is this the best approach? - arma::mat out(2^n_bits, 2^n_bits, arma::fill::zeros); - int pixels_to_move = 1; - - int nrows = x.n_rows; - int ncols = x.n_cols; - - arma::uword start_row, end_row, start_col, end_col = 0; - int offset_row, offset_col, v_i, v_j, row, col = 0; - - offset_row = std::round(std::sin(angle) * pixels_to_move); - offset_col = std::round(std::cos(angle) * pixels_to_move); - // row - start_row = std::max(0, -offset_row); - end_row = std::min(nrows, nrows - offset_row); - // col - start_col = std::max(0, -offset_col); - end_col = std::min(ncols, ncols - offset_col); - - for (arma::uword r = start_row; r < end_row; r++) { - for (arma::uword c = start_col; c < end_col; c++) { - v_i = x(r,c); - row = r + offset_row; - col = c + offset_col; - v_j = x(row, col); - if (v_i < n_bits && v_j < n_bits) { - out(v_i, v_j) += 1; - } - } - } - return out; -} - - -// [[Rcpp::export]] -NumericMatrix glcm_fun(const arma::vec& x, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, - const arma::vec& angles, - const arma::uword& n_bits = 16, - _glcm_fun _fun) { - // initialize result values - arma::mat neigh(window_size, window_size); - arma::mat glcm(n_bits, n_bits, arma::fill::zeros); - arma::mat out(2^n_bits, 2^n_bits, arma::fill::zeros); - double sum = 0; - - // compute window leg - int leg = window_size / 2; - // compute locus mirror - IntegerVector loci = locus_neigh2(nrows, leg); - IntegerVector locj = locus_neigh2(ncols, leg); - // compute values for each pixel - for (int i = 0; i < nrows; ++i) { - for (int j = 0; j < ncols; ++j) { - // for all bands - for (int angle = 0; angle < angles.size(); ++angle) { - // compute the neighborhood - for (int wi = 0; wi < window_size; ++wi) { - for (int wj = 0; wj < window_size; ++wj) { - neigh(wi, wj) = - x(loci(wi + i) * ncols + locj(wj + j)); - } - } - - glcm = glcm_tabulate(neigh, 1, 0, n_bits); - sum = arma::accu(glcm); - glcm /= sum; - Rcpp::Rcout << glcm << "\n"; - // remove NA - //NumericVector neigh2 = na_omit(neigh); - res(i * ncols + j, angle) = 1; - } - } - } - return res; -} - - -inline double _glcm_contrast(const arma::vec x, - const arma::mat i, - const arma::mat j) { - double res = 0; - - res = arma::accu(x % pow(i - j, 2)); - return(res); -} - -// [[Rcpp::export]] -double C_glcm_contrast(const arma::vec& x, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, - const arma::uword& n_levels, - const arma::vec& angles, - const arma::uword& n_bits = 16) { - - - return glcm_fun(x, nrows, ncols, window_size, angles, n_bits, _glcm_contrast); -} - - - - - - - -// [[Rcpp::export]] -double glcm_dissimilarity(const arma::mat glcm, - const arma::uword n_levels) { - arma::mat j(n_levels, n_levels, arma::fill::zeros); - arma::mat i(n_levels, n_levels, arma::fill::zeros); - double res = 0; - - for (arma::uword r = 0; r < n_levels; r++) { - for (arma::uword c = 0; c < n_levels; c++) { - i(r, c) = r; - j(r, c) = c; - } - } - res = arma::accu(glcm % abs(i - j)); - return(res); -} - -// [[Rcpp::export]] -double glcm_homogeneity(const arma::mat glcm, - const arma::uword n_levels) { - arma::mat j(n_levels, n_levels, arma::fill::zeros); - arma::mat i(n_levels, n_levels, arma::fill::zeros); - double res = 0; - - for (arma::uword r = 0; r < n_levels; r++) { - for (arma::uword c = 0; c < n_levels; c++) { - i(r, c) = r; - j(r, c) = c; - } - } - res = arma::accu(glcm / (1 + (pow(i - j, 2)))); - return(res); -} - -// [[Rcpp::export]] -double glcm_energy(const arma::mat glcm, - const arma::uword n_levels) { - double res = 0; - - res = std::sqrt(arma::accu(pow(glcm, 2))); - return(res); -} - -// [[Rcpp::export]] -double glcm_asm(const arma::mat glcm, - const arma::uword n_levels) { - double res = 0; - - res = arma::accu(pow(glcm, 2)); - return(res); -} - -// [[Rcpp::export]] -double glcm_mean(const arma::mat glcm, - const arma::uword n_levels) { - arma::mat i(n_levels, n_levels, arma::fill::zeros); - double res = 0; - - for (arma::uword r = 0; r < n_levels; r++) { - for (arma::uword c = 0; c < n_levels; c++) { - i(r, c) = r; - } - } - - res = arma::accu(glcm % i); - return(res); -} - -// [[Rcpp::export]] -double glcm_variance(const arma::mat glcm, - const arma::uword n_levels) { - arma::mat i(n_levels, n_levels, arma::fill::zeros); - double res = 0; - - for (arma::uword r = 0; r < n_levels; r++) { - for (arma::uword c = 0; c < n_levels; c++) { - i(r, c) = r; - } - } - res = arma::accu(glcm % i); - - res = arma::accu(glcm % pow(i - res, 2)); - return(res); -} - -// [[Rcpp::export]] -double glcm_std(const arma::mat glcm, - const arma::uword n_levels) { - - double res = glcm_variance(glcm, n_levels); - - res = sqrt(res); - return(res); -} - -// [[Rcpp::export]] -double glcm_entropy(const arma::mat glcm, - const arma::uword n_levels) { - double res = 0; - - arma::mat glcm_entropy = glcm % ((-1) * log(glcm)); - glcm_entropy.replace(arma::datum::nan, 0); - - res = accu(glcm_entropy); - return(res); -} - -// [[Rcpp::export]] -double glcm_correlation(const arma::mat glcm, - const arma::uword n_levels) { - double res = 0; - double res_mean = glcm_mean(glcm, n_levels); - double res_var = glcm_variance(glcm, n_levels); - - arma::mat j(n_levels, n_levels, arma::fill::zeros); - arma::mat i(n_levels, n_levels, arma::fill::zeros); - - for (arma::uword r = 0; r < n_levels; r++) { - for (arma::uword c = 0; c < n_levels; c++) { - i(r, c) = r; - j(r, c) = c; - } - } - - res = accu(glcm % (((i - res_mean) % (j - res_mean)) / (res_var))); - return(res); -} - -// [[Rcpp::export]] -arma::mat C_create_glcm_weights(const arma::uword n_levels) { - arma::mat j(n_levels, n_levels); - arma::mat i(n_levels, n_levels); - - for (arma::uword r = 0; r < n_levels; r++) { - for (arma::uword c = 0; c < n_levels; c++) { - i(r, c) = r; - j(r, c) = c; - } - } - Rcpp::Rcout << i << "\n"; - Rcpp::Rcout << j << "\n"; - - return (i - j); -} - - -// kernel functions -inline double _median(const NumericVector& neigh) { - return median(neigh, true); -} -inline double _mean(const NumericVector& neigh) { - return mean(na_omit(neigh)); -} -inline double _sd(const NumericVector& neigh) { - return sd(na_omit(neigh)); -} -inline double _min(const NumericVector& neigh) { - return min(na_omit(neigh)); -} -inline double _max(const NumericVector& neigh) { - return max(na_omit(neigh)); -} -inline double _var(const NumericVector& neigh) { - return var(na_omit(neigh)); -} - -NumericVector kernel_fun(const NumericMatrix& x, int ncols, int nrows, - int band, int window_size, _kernel_fun _fun) { - // initialize result vectors - NumericVector res(x.nrow()); - NumericVector neigh(window_size * window_size); - if (window_size < 1) { - res = x(_, band); - return res; - } - // compute window leg - int leg = window_size / 2; - // compute locus mirror - IntegerVector loci = locus_mirror(nrows, leg); - IntegerVector locj = locus_mirror(ncols, leg); - // compute values for each pixel - for (int i = 0; i < nrows; ++i) { - for (int j = 0; j < ncols; ++j) { - // window - for (int wi = 0; wi < window_size; ++wi) - for (int wj = 0; wj < window_size; ++wj) - neigh(wi * window_size + wj) = - x(loci(wi + i) * ncols + locj(wj + j), band); - // call specific function - res(i * ncols + j) = _fun(neigh); - } - } - return res; -} -// [[Rcpp::export]] -NumericVector C_kernel_median(const NumericMatrix& x, int ncols, - int nrows, int band, int window_size) { - return kernel_fun(x, ncols, nrows, band, window_size, _median); -} -// [[Rcpp::export]] -NumericVector C_kernel_mean(const NumericMatrix& x, int ncols, - int nrows, int band, int window_size) { - return kernel_fun(x, ncols, nrows, band, window_size, _mean); -} -// [[Rcpp::export]] -NumericVector C_kernel_sd(const NumericMatrix& x, int ncols, - int nrows, int band, int window_size) { - return kernel_fun(x, ncols, nrows, band, window_size, _sd); -} -// [[Rcpp::export]] -NumericVector C_kernel_min(const NumericMatrix& x, int ncols, - int nrows, int band, int window_size) { - return kernel_fun(x, ncols, nrows, band, window_size, _min); -} -// [[Rcpp::export]] -NumericVector C_kernel_max(const NumericMatrix& x, int ncols, - int nrows, int band, int window_size) { - return kernel_fun(x, ncols, nrows, band, window_size, _max); -} -// [[Rcpp::export]] -NumericVector C_kernel_var(const NumericMatrix& x, int ncols, - int nrows, int band, int window_size) { - return kernel_fun(x, ncols, nrows, band, window_size, _var); -} -// [[Rcpp::export]] -NumericVector C_kernel_modal(const NumericMatrix& x, int ncols, - int nrows, int band, int window_size) { - return kernel_fun(x, ncols, nrows, band, window_size, _modal); -} +// //[[Rcpp::depends(RcppArmadillo)]] +// #include +// #include +// #include +// #include +// +// using namespace Rcpp; +// using namespace std; +// +// +// typedef double _glcm_fun(const arma::vec&, arma::mat&, arma::mat&); +// +// // compute outside indices of a vector as a mirror +// IntegerVector locus_neigh2(int size, int leg) { +// IntegerVector res(size + 2 * leg); +// for (int i = 0; i < res.length(); ++i) { +// if (i < leg) +// res(i) = leg - i - 1; +// else if (i < size + leg) +// res(i) = i - leg; +// else +// res(i) = 2 * size + leg - i - 1; +// } +// return res; +// } +// +// //[[Rcpp::export]] +// arma::mat glcm_tabulate(const arma::mat& x, +// const float& angle, +// const int n_bits = 16) { +// +// // is this the best approach? +// arma::mat out(2^n_bits, 2^n_bits, arma::fill::zeros); +// int pixels_to_move = 1; +// +// int nrows = x.n_rows; +// int ncols = x.n_cols; +// +// arma::uword start_row, end_row, start_col, end_col = 0; +// int offset_row, offset_col, v_i, v_j, row, col = 0; +// +// offset_row = std::round(std::sin(angle) * pixels_to_move); +// offset_col = std::round(std::cos(angle) * pixels_to_move); +// // row +// start_row = std::max(0, -offset_row); +// end_row = std::min(nrows, nrows - offset_row); +// // col +// start_col = std::max(0, -offset_col); +// end_col = std::min(ncols, ncols - offset_col); +// +// for (arma::uword r = start_row; r < end_row; r++) { +// for (arma::uword c = start_col; c < end_col; c++) { +// v_i = x(r,c); +// row = r + offset_row; +// col = c + offset_col; +// v_j = x(row, col); +// if (v_i < n_bits && v_j < n_bits) { +// out(v_i, v_j) += 1; +// } +// } +// } +// return out; +// } +// +// +// // [[Rcpp::export]] +// NumericMatrix glcm_fun(const arma::vec& x, +// const arma::uword& nrows, +// const arma::uword& ncols, +// const arma::uword& window_size, +// const arma::vec& angles, +// const arma::uword& n_bits = 16, +// _glcm_fun _fun) { +// // initialize result values +// arma::mat neigh(window_size, window_size); +// arma::mat glcm(n_bits, n_bits, arma::fill::zeros); +// arma::mat out(2^n_bits, 2^n_bits, arma::fill::zeros); +// double sum = 0; +// +// // compute window leg +// int leg = window_size / 2; +// // compute locus mirror +// IntegerVector loci = locus_neigh2(nrows, leg); +// IntegerVector locj = locus_neigh2(ncols, leg); +// // compute values for each pixel +// for (int i = 0; i < nrows; ++i) { +// for (int j = 0; j < ncols; ++j) { +// // for all bands +// for (int angle = 0; angle < angles.size(); ++angle) { +// // compute the neighborhood +// for (int wi = 0; wi < window_size; ++wi) { +// for (int wj = 0; wj < window_size; ++wj) { +// neigh(wi, wj) = +// x(loci(wi + i) * ncols + locj(wj + j)); +// } +// } +// +// glcm = glcm_tabulate(neigh, 1, 0, n_bits); +// sum = arma::accu(glcm); +// glcm /= sum; +// Rcpp::Rcout << glcm << "\n"; +// // remove NA +// //NumericVector neigh2 = na_omit(neigh); +// res(i * ncols + j, angle) = 1; +// } +// } +// } +// return res; +// } +// +// +// inline double _glcm_contrast(const arma::vec x, +// const arma::mat i, +// const arma::mat j) { +// double res = 0; +// +// res = arma::accu(x % pow(i - j, 2)); +// return(res); +// } +// +// // [[Rcpp::export]] +// double C_glcm_contrast(const arma::vec& x, +// const arma::uword& nrows, +// const arma::uword& ncols, +// const arma::uword& window_size, +// const arma::uword& n_levels, +// const arma::vec& angles, +// const arma::uword& n_bits = 16) { +// +// +// return glcm_fun(x, nrows, ncols, window_size, angles, n_bits, _glcm_contrast); +// } +// +// +// +// +// +// +// +// // [[Rcpp::export]] +// double glcm_dissimilarity(const arma::mat glcm, +// const arma::uword n_levels) { +// arma::mat j(n_levels, n_levels, arma::fill::zeros); +// arma::mat i(n_levels, n_levels, arma::fill::zeros); +// double res = 0; +// +// for (arma::uword r = 0; r < n_levels; r++) { +// for (arma::uword c = 0; c < n_levels; c++) { +// i(r, c) = r; +// j(r, c) = c; +// } +// } +// res = arma::accu(glcm % abs(i - j)); +// return(res); +// } +// +// // [[Rcpp::export]] +// double glcm_homogeneity(const arma::mat glcm, +// const arma::uword n_levels) { +// arma::mat j(n_levels, n_levels, arma::fill::zeros); +// arma::mat i(n_levels, n_levels, arma::fill::zeros); +// double res = 0; +// +// for (arma::uword r = 0; r < n_levels; r++) { +// for (arma::uword c = 0; c < n_levels; c++) { +// i(r, c) = r; +// j(r, c) = c; +// } +// } +// res = arma::accu(glcm / (1 + (pow(i - j, 2)))); +// return(res); +// } +// +// // [[Rcpp::export]] +// double glcm_energy(const arma::mat glcm, +// const arma::uword n_levels) { +// double res = 0; +// +// res = std::sqrt(arma::accu(pow(glcm, 2))); +// return(res); +// } +// +// // [[Rcpp::export]] +// double glcm_asm(const arma::mat glcm, +// const arma::uword n_levels) { +// double res = 0; +// +// res = arma::accu(pow(glcm, 2)); +// return(res); +// } +// +// // [[Rcpp::export]] +// double glcm_mean(const arma::mat glcm, +// const arma::uword n_levels) { +// arma::mat i(n_levels, n_levels, arma::fill::zeros); +// double res = 0; +// +// for (arma::uword r = 0; r < n_levels; r++) { +// for (arma::uword c = 0; c < n_levels; c++) { +// i(r, c) = r; +// } +// } +// +// res = arma::accu(glcm % i); +// return(res); +// } +// +// // [[Rcpp::export]] +// double glcm_variance(const arma::mat glcm, +// const arma::uword n_levels) { +// arma::mat i(n_levels, n_levels, arma::fill::zeros); +// double res = 0; +// +// for (arma::uword r = 0; r < n_levels; r++) { +// for (arma::uword c = 0; c < n_levels; c++) { +// i(r, c) = r; +// } +// } +// res = arma::accu(glcm % i); +// +// res = arma::accu(glcm % pow(i - res, 2)); +// return(res); +// } +// +// // [[Rcpp::export]] +// double glcm_std(const arma::mat glcm, +// const arma::uword n_levels) { +// +// double res = glcm_variance(glcm, n_levels); +// +// res = sqrt(res); +// return(res); +// } +// +// // [[Rcpp::export]] +// double glcm_entropy(const arma::mat glcm, +// const arma::uword n_levels) { +// double res = 0; +// +// arma::mat glcm_entropy = glcm % ((-1) * log(glcm)); +// glcm_entropy.replace(arma::datum::nan, 0); +// +// res = accu(glcm_entropy); +// return(res); +// } +// +// // [[Rcpp::export]] +// double glcm_correlation(const arma::mat glcm, +// const arma::uword n_levels) { +// double res = 0; +// double res_mean = glcm_mean(glcm, n_levels); +// double res_var = glcm_variance(glcm, n_levels); +// +// arma::mat j(n_levels, n_levels, arma::fill::zeros); +// arma::mat i(n_levels, n_levels, arma::fill::zeros); +// +// for (arma::uword r = 0; r < n_levels; r++) { +// for (arma::uword c = 0; c < n_levels; c++) { +// i(r, c) = r; +// j(r, c) = c; +// } +// } +// +// res = accu(glcm % (((i - res_mean) % (j - res_mean)) / (res_var))); +// return(res); +// } +// +// // [[Rcpp::export]] +// arma::mat C_create_glcm_weights(const arma::uword n_levels) { +// arma::mat j(n_levels, n_levels); +// arma::mat i(n_levels, n_levels); +// +// for (arma::uword r = 0; r < n_levels; r++) { +// for (arma::uword c = 0; c < n_levels; c++) { +// i(r, c) = r; +// j(r, c) = c; +// } +// } +// Rcpp::Rcout << i << "\n"; +// Rcpp::Rcout << j << "\n"; +// +// return (i - j); +// } +// +// +// // kernel functions +// inline double _median(const NumericVector& neigh) { +// return median(neigh, true); +// } +// inline double _mean(const NumericVector& neigh) { +// return mean(na_omit(neigh)); +// } +// inline double _sd(const NumericVector& neigh) { +// return sd(na_omit(neigh)); +// } +// inline double _min(const NumericVector& neigh) { +// return min(na_omit(neigh)); +// } +// inline double _max(const NumericVector& neigh) { +// return max(na_omit(neigh)); +// } +// inline double _var(const NumericVector& neigh) { +// return var(na_omit(neigh)); +// } +// +// NumericVector kernel_fun(const NumericMatrix& x, int ncols, int nrows, +// int band, int window_size, _kernel_fun _fun) { +// // initialize result vectors +// NumericVector res(x.nrow()); +// NumericVector neigh(window_size * window_size); +// if (window_size < 1) { +// res = x(_, band); +// return res; +// } +// // compute window leg +// int leg = window_size / 2; +// // compute locus mirror +// IntegerVector loci = locus_mirror(nrows, leg); +// IntegerVector locj = locus_mirror(ncols, leg); +// // compute values for each pixel +// for (int i = 0; i < nrows; ++i) { +// for (int j = 0; j < ncols; ++j) { +// // window +// for (int wi = 0; wi < window_size; ++wi) +// for (int wj = 0; wj < window_size; ++wj) +// neigh(wi * window_size + wj) = +// x(loci(wi + i) * ncols + locj(wj + j), band); +// // call specific function +// res(i * ncols + j) = _fun(neigh); +// } +// } +// return res; +// } +// // [[Rcpp::export]] +// NumericVector C_kernel_median(const NumericMatrix& x, int ncols, +// int nrows, int band, int window_size) { +// return kernel_fun(x, ncols, nrows, band, window_size, _median); +// } +// // [[Rcpp::export]] +// NumericVector C_kernel_mean(const NumericMatrix& x, int ncols, +// int nrows, int band, int window_size) { +// return kernel_fun(x, ncols, nrows, band, window_size, _mean); +// } +// // [[Rcpp::export]] +// NumericVector C_kernel_sd(const NumericMatrix& x, int ncols, +// int nrows, int band, int window_size) { +// return kernel_fun(x, ncols, nrows, band, window_size, _sd); +// } +// // [[Rcpp::export]] +// NumericVector C_kernel_min(const NumericMatrix& x, int ncols, +// int nrows, int band, int window_size) { +// return kernel_fun(x, ncols, nrows, band, window_size, _min); +// } +// // [[Rcpp::export]] +// NumericVector C_kernel_max(const NumericMatrix& x, int ncols, +// int nrows, int band, int window_size) { +// return kernel_fun(x, ncols, nrows, band, window_size, _max); +// } +// // [[Rcpp::export]] +// NumericVector C_kernel_var(const NumericMatrix& x, int ncols, +// int nrows, int band, int window_size) { +// return kernel_fun(x, ncols, nrows, band, window_size, _var); +// } +// // [[Rcpp::export]] +// NumericVector C_kernel_modal(const NumericMatrix& x, int ncols, +// int nrows, int band, int window_size) { +// return kernel_fun(x, ncols, nrows, band, window_size, _modal); +// } +// From 672a615bb7a24cd93b41b40c9d21e50b4ab36490 Mon Sep 17 00:00:00 2001 From: Gilberto Camara Date: Thu, 13 Feb 2025 18:20:33 -0300 Subject: [PATCH 006/122] simplify DESCRIPTION --- DESCRIPTION | 30 +++++++----------------------- 1 file changed, 7 insertions(+), 23 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 425a86ef5..b33d37f87 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,36 +16,20 @@ Authors@R: c(person('Rolf', 'Simoes', role = c('aut'), email = 'rolf.simoes@inpe ) Maintainer: Gilberto Camara Description: An end-to-end toolkit for land use and land cover classification - using big Earth observation data, based on machine learning methods - applied to satellite image data cubes, as described in Simoes et al (2021) . - Builds regular data cubes from collections in AWS, Microsoft Planetary Computer, - Brazil Data Cube, Copernicus Data Space Environment (CDSE), Digital Earth Africa, Digital Earth Australia, - NASA HLS using the Spatio-temporal Asset Catalog (STAC) - protocol () and the 'gdalcubes' R package - developed by Appel and Pebesma (2019) . + using big Earth observation data. Builds satellite image data cubes from cloud collections. Supports visualization methods for images and time series and smoothing filters for dealing with noisy time series. - Includes functions for quality assessment of training samples using self-organized maps - as presented by Santos et al (2021) . - Includes methods to reduce training samples imbalance proposed by - Chawla et al (2002) . - Provides machine learning methods including support vector machines, + Includes functions for quality assessment of training samples using self-organized maps and + to reduce training samples imbalance. Provides machine learning algorithms including support vector machines, random forests, extreme gradient boosting, multi-layer perceptrons, - temporal convolutional neural networks proposed - by Pelletier et al (2019) , - and temporal attention encoders by Garnot and Landrieu (2020) . - Supports GPU processing of deep learning models using torch . + temporal convolution neural networks, and temporal attention encoders. Performs efficient classification of big Earth observation data cubes and includes - functions for post-classification smoothing based on Bayesian inference - as described by Camara et al (2024) , and - methods for active learning and uncertainty assessment. Supports region-based - time series analysis using package supercells . - Enables best practices for estimating area and assessing accuracy of land change as - recommended by Olofsson et al (2014) . + functions for post-classification smoothing based on Bayesian inference. + Enables best practices for estimating area and assessing accuracy of land change. Minimum recommended requirements: 16 GB RAM and 4 CPU dual-core. Encoding: UTF-8 Language: en-US -Depends: R (>= 4.0.0) +Depends: R (>= 4.1.0) URL: https://github.com/e-sensing/sits/, https://e-sensing.github.io/sitsbook/ BugReports: https://github.com/e-sensing/sits/issues License: GPL-2 From 4f01255df89ddf82b5ec8f792a39a7490901151c Mon Sep 17 00:00:00 2001 From: Felipe Date: Sat, 15 Feb 2025 23:52:02 +0000 Subject: [PATCH 007/122] update glcm cpp function --- src/glcm_fns.cpp | 481 +++++++++++++++++++++-------------------------- 1 file changed, 219 insertions(+), 262 deletions(-) diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index 40923bd7c..90f89d3ec 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -1,142 +1,187 @@ -// //[[Rcpp::depends(RcppArmadillo)]] -// #include -// #include -// #include -// #include -// -// using namespace Rcpp; -// using namespace std; -// -// -// typedef double _glcm_fun(const arma::vec&, arma::mat&, arma::mat&); -// -// // compute outside indices of a vector as a mirror -// IntegerVector locus_neigh2(int size, int leg) { -// IntegerVector res(size + 2 * leg); -// for (int i = 0; i < res.length(); ++i) { -// if (i < leg) -// res(i) = leg - i - 1; -// else if (i < size + leg) -// res(i) = i - leg; -// else -// res(i) = 2 * size + leg - i - 1; -// } -// return res; -// } -// -// //[[Rcpp::export]] -// arma::mat glcm_tabulate(const arma::mat& x, -// const float& angle, -// const int n_bits = 16) { -// -// // is this the best approach? -// arma::mat out(2^n_bits, 2^n_bits, arma::fill::zeros); -// int pixels_to_move = 1; -// -// int nrows = x.n_rows; -// int ncols = x.n_cols; -// -// arma::uword start_row, end_row, start_col, end_col = 0; -// int offset_row, offset_col, v_i, v_j, row, col = 0; -// -// offset_row = std::round(std::sin(angle) * pixels_to_move); -// offset_col = std::round(std::cos(angle) * pixels_to_move); -// // row -// start_row = std::max(0, -offset_row); -// end_row = std::min(nrows, nrows - offset_row); -// // col -// start_col = std::max(0, -offset_col); -// end_col = std::min(ncols, ncols - offset_col); -// -// for (arma::uword r = start_row; r < end_row; r++) { -// for (arma::uword c = start_col; c < end_col; c++) { -// v_i = x(r,c); -// row = r + offset_row; -// col = c + offset_col; -// v_j = x(row, col); -// if (v_i < n_bits && v_j < n_bits) { -// out(v_i, v_j) += 1; -// } -// } -// } -// return out; -// } -// -// -// // [[Rcpp::export]] -// NumericMatrix glcm_fun(const arma::vec& x, -// const arma::uword& nrows, -// const arma::uword& ncols, -// const arma::uword& window_size, -// const arma::vec& angles, -// const arma::uword& n_bits = 16, -// _glcm_fun _fun) { -// // initialize result values -// arma::mat neigh(window_size, window_size); -// arma::mat glcm(n_bits, n_bits, arma::fill::zeros); -// arma::mat out(2^n_bits, 2^n_bits, arma::fill::zeros); -// double sum = 0; -// -// // compute window leg -// int leg = window_size / 2; -// // compute locus mirror -// IntegerVector loci = locus_neigh2(nrows, leg); -// IntegerVector locj = locus_neigh2(ncols, leg); -// // compute values for each pixel -// for (int i = 0; i < nrows; ++i) { -// for (int j = 0; j < ncols; ++j) { -// // for all bands -// for (int angle = 0; angle < angles.size(); ++angle) { -// // compute the neighborhood -// for (int wi = 0; wi < window_size; ++wi) { -// for (int wj = 0; wj < window_size; ++wj) { -// neigh(wi, wj) = -// x(loci(wi + i) * ncols + locj(wj + j)); -// } -// } -// -// glcm = glcm_tabulate(neigh, 1, 0, n_bits); -// sum = arma::accu(glcm); -// glcm /= sum; -// Rcpp::Rcout << glcm << "\n"; -// // remove NA -// //NumericVector neigh2 = na_omit(neigh); -// res(i * ncols + j, angle) = 1; -// } -// } -// } -// return res; -// } -// -// -// inline double _glcm_contrast(const arma::vec x, -// const arma::mat i, -// const arma::mat j) { -// double res = 0; -// -// res = arma::accu(x % pow(i - j, 2)); -// return(res); -// } -// -// // [[Rcpp::export]] -// double C_glcm_contrast(const arma::vec& x, -// const arma::uword& nrows, -// const arma::uword& ncols, -// const arma::uword& window_size, -// const arma::uword& n_levels, -// const arma::vec& angles, -// const arma::uword& n_bits = 16) { -// -// -// return glcm_fun(x, nrows, ncols, window_size, angles, n_bits, _glcm_contrast); -// } -// -// -// -// -// -// -// +//[[Rcpp::depends(RcppArmadillo)]] +#include +#include +#include +#include + +using namespace Rcpp; +using namespace std; + +typedef double _glcm_fun(const arma::mat&, const arma::mat&, const arma::mat&); + +// compute outside indices of a vector as a mirror +IntegerVector locus_neigh2(int size, int leg) { + IntegerVector res(size + 2 * leg); + for (int i = 0; i < res.length(); ++i) { + if (i < leg) + res(i) = leg - i - 1; + else if (i < size + leg) + res(i) = i - leg; + else + res(i) = 2 * size + leg - i - 1; + } + return res; +} + +// [[Rcpp::export]] +arma::mat glcm_tabulate(const arma::mat& x, + arma::mat glcm, + const float& angle, + const arma::uword& n_grey) { + + int pixels_to_move = 1; + + int nrows = x.n_rows; + int ncols = x.n_cols; + + arma::uword start_row, end_row, start_col, end_col = 0; + int offset_row, offset_col, v_i, v_j, row, col = 0; + + offset_row = std::round(std::sin(angle) * pixels_to_move); + offset_col = std::round(std::cos(angle) * pixels_to_move); + // row + start_row = std::max(0, -offset_row); + end_row = std::min(nrows, nrows - offset_row); + // col + start_col = std::max(0, -offset_col); + end_col = std::min(ncols, ncols - offset_col); + // for (arma::uword r = start_row; r < end_row; r++) { + // for (arma::uword c = start_col; c < end_col; c++) { + // + // // v_i = x(r,c); + // // row = r + offset_row; + // // col = c + offset_col; + // // v_j = x(row, col); + // // //if (v_i < n_grey && v_j < n_grey) { + // // //glcm(v_i, v_j) += 1; + // // glcm(v_i, v_j) = 1; + // //} + // } + // } + return glcm; +} + +arma::mat glcm_fn(const arma::vec& x, + const arma::vec& angles, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::uword& n_grey, + _glcm_fun _fun) { + // initialize output values + arma::mat glcm_co(n_grey, n_grey, arma::fill::zeros); + // initialize result matrix + arma::mat res(x.size(), angles.size(), arma::fill::zeros); + // initialize co-occurrence matrix + arma::mat co_occur(n_grey, n_grey, arma::fill::zeros); + // initialize neighborhood matrix + arma::mat neigh(window_size, window_size); + arma::mat pos_window(window_size, window_size, arma::fill::zeros); + + double sum = 0; + + arma::uword angle_ith = 0; + + // Initialize auxiliary matrices they are needed in some metrics + arma::mat i_aux(n_grey, n_grey, arma::fill::zeros); + arma::mat j_aux(n_grey, n_grey, arma::fill::zeros); + + i_aux = arma::repmat( + arma::linspace(1, n_grey, n_grey), 1, n_grey + ); + j_aux = arma::trans(i_aux); + arma::uvec a; + + + // compute window leg + int leg = window_size / 2; + // compute locus mirror + IntegerVector loci = locus_neigh2(nrows, leg); + IntegerVector locj = locus_neigh2(ncols, leg); + // compute values for each pixel + for (arma::uword i = 0; i < nrows; ++i) { + for (arma::uword j = 0; j < ncols; ++j) { + // for all angles + //for (arma::uword angle = 0; angle < angles.size(); ++angle) { + // compute the neighborhood + for (int wi = 0; wi < window_size; ++wi) { + for (int wj = 0; wj < window_size; ++wj) { + neigh(wi, wj) = + x(loci(wi + i) * ncols + locj(wj + j)); + } + } + + //Rcpp::Rcout << "test1" << "\n"; + //glcm_co = glcm_tabulate(neigh, glcm_co, angles(0), n_grey); + //Rcpp::Rcout << "test2" << "\n"; + // calculate co-occurrence probabilities + //sum = arma::accu(glcm_co); + //glcm_co /= sum; + + int pixels_to_move = 1; + + + arma::uword start_row, end_row, start_col, end_col = 0; + int offset_row, offset_col, v_i, v_j, row, col = 0; + + offset_row = std::round(std::sin(0) * pixels_to_move); + offset_col = std::round(std::cos(0) * pixels_to_move); + // row + start_row = std::max(0, -offset_row); + end_row = std::min(neigh.n_rows, neigh.n_rows - offset_row); + // col + start_col = std::max(0, -offset_col); + end_col = std::min(neigh.n_cols, neigh.n_cols - offset_col); + for (arma::uword r = start_row; r < end_row; r++) { + for (arma::uword c = start_col; c < end_col; c++) { + v_i = neigh(r,c); + row = r + offset_row; + col = c + offset_col; + v_j = neigh(row, col); + if (v_i < n_grey && v_j < n_grey) { + glcm_co(v_i, v_j) += 1; + } + } + } + + // remove NA + //NumericVector neigh2 = na_omit(neigh); + //res(i * ncols + j, 0) = _fun(glcm_co, i_aux, j_aux); + res(i * ncols + j, 0) = 1; + + + //} + //angle_ith++; + //glcm_co.clear(); + //glcm_co = aux; + //glcm_co = 0; + } + } + return res; +} + + +inline double _glcm_contrast(const arma::mat& x, + const arma::mat& i, + const arma::mat& j) { + double res = 0; + + res = arma::accu(x % pow(i - j, 2)); + return(res); +} + +// [[Rcpp::export]] +arma::mat C_glcm_contrast(const arma::vec& x, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::vec& angles, + const arma::uword& n_grey) { + + return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_contrast); +} + + // // [[Rcpp::export]] // double glcm_dissimilarity(const arma::mat glcm, // const arma::uword n_levels) { @@ -172,36 +217,39 @@ // } // // // [[Rcpp::export]] -// double glcm_energy(const arma::mat glcm, -// const arma::uword n_levels) { +// double glcm_mean(const arma::mat glcm, +// const arma::uword n_levels) { +// arma::mat i(n_levels, n_levels, arma::fill::zeros); // double res = 0; // -// res = std::sqrt(arma::accu(pow(glcm, 2))); +// for (arma::uword r = 0; r < n_levels; r++) { +// for (arma::uword c = 0; c < n_levels; c++) { +// i(r, c) = r; +// } +// } +// +// res = arma::accu(glcm % i); // return(res); // } // // // [[Rcpp::export]] -// double glcm_asm(const arma::mat glcm, -// const arma::uword n_levels) { +// double glcm_correlation(const arma::mat glcm, +// const arma::uword n_levels) { // double res = 0; +// double res_mean = glcm_mean(glcm, n_levels); +// double res_var = glcm_variance(glcm, n_levels); // -// res = arma::accu(pow(glcm, 2)); -// return(res); -// } -// -// // [[Rcpp::export]] -// double glcm_mean(const arma::mat glcm, -// const arma::uword n_levels) { +// arma::mat j(n_levels, n_levels, arma::fill::zeros); // arma::mat i(n_levels, n_levels, arma::fill::zeros); -// double res = 0; // // for (arma::uword r = 0; r < n_levels; r++) { // for (arma::uword c = 0; c < n_levels; c++) { // i(r, c) = r; +// j(r, c) = c; // } // } // -// res = arma::accu(glcm % i); +// res = accu(glcm % (((i - res_mean) % (j - res_mean)) / (res_var))); // return(res); // } // @@ -223,6 +271,24 @@ // } // // // [[Rcpp::export]] +// double glcm_energy(const arma::mat glcm, +// const arma::uword n_levels) { +// double res = 0; +// +// res = std::sqrt(arma::accu(pow(glcm, 2))); +// return(res); +// } +// +// // [[Rcpp::export]] +// double glcm_asm(const arma::mat glcm, +// const arma::uword n_levels) { +// double res = 0; +// +// res = arma::accu(pow(glcm, 2)); +// return(res); +// } +// +// // [[Rcpp::export]] // double glcm_std(const arma::mat glcm, // const arma::uword n_levels) { // @@ -245,27 +311,6 @@ // } // // // [[Rcpp::export]] -// double glcm_correlation(const arma::mat glcm, -// const arma::uword n_levels) { -// double res = 0; -// double res_mean = glcm_mean(glcm, n_levels); -// double res_var = glcm_variance(glcm, n_levels); -// -// arma::mat j(n_levels, n_levels, arma::fill::zeros); -// arma::mat i(n_levels, n_levels, arma::fill::zeros); -// -// for (arma::uword r = 0; r < n_levels; r++) { -// for (arma::uword c = 0; c < n_levels; c++) { -// i(r, c) = r; -// j(r, c) = c; -// } -// } -// -// res = accu(glcm % (((i - res_mean) % (j - res_mean)) / (res_var))); -// return(res); -// } -// -// // [[Rcpp::export]] // arma::mat C_create_glcm_weights(const arma::uword n_levels) { // arma::mat j(n_levels, n_levels); // arma::mat i(n_levels, n_levels); @@ -276,94 +321,6 @@ // j(r, c) = c; // } // } -// Rcpp::Rcout << i << "\n"; -// Rcpp::Rcout << j << "\n"; // // return (i - j); // } -// -// -// // kernel functions -// inline double _median(const NumericVector& neigh) { -// return median(neigh, true); -// } -// inline double _mean(const NumericVector& neigh) { -// return mean(na_omit(neigh)); -// } -// inline double _sd(const NumericVector& neigh) { -// return sd(na_omit(neigh)); -// } -// inline double _min(const NumericVector& neigh) { -// return min(na_omit(neigh)); -// } -// inline double _max(const NumericVector& neigh) { -// return max(na_omit(neigh)); -// } -// inline double _var(const NumericVector& neigh) { -// return var(na_omit(neigh)); -// } -// -// NumericVector kernel_fun(const NumericMatrix& x, int ncols, int nrows, -// int band, int window_size, _kernel_fun _fun) { -// // initialize result vectors -// NumericVector res(x.nrow()); -// NumericVector neigh(window_size * window_size); -// if (window_size < 1) { -// res = x(_, band); -// return res; -// } -// // compute window leg -// int leg = window_size / 2; -// // compute locus mirror -// IntegerVector loci = locus_mirror(nrows, leg); -// IntegerVector locj = locus_mirror(ncols, leg); -// // compute values for each pixel -// for (int i = 0; i < nrows; ++i) { -// for (int j = 0; j < ncols; ++j) { -// // window -// for (int wi = 0; wi < window_size; ++wi) -// for (int wj = 0; wj < window_size; ++wj) -// neigh(wi * window_size + wj) = -// x(loci(wi + i) * ncols + locj(wj + j), band); -// // call specific function -// res(i * ncols + j) = _fun(neigh); -// } -// } -// return res; -// } -// // [[Rcpp::export]] -// NumericVector C_kernel_median(const NumericMatrix& x, int ncols, -// int nrows, int band, int window_size) { -// return kernel_fun(x, ncols, nrows, band, window_size, _median); -// } -// // [[Rcpp::export]] -// NumericVector C_kernel_mean(const NumericMatrix& x, int ncols, -// int nrows, int band, int window_size) { -// return kernel_fun(x, ncols, nrows, band, window_size, _mean); -// } -// // [[Rcpp::export]] -// NumericVector C_kernel_sd(const NumericMatrix& x, int ncols, -// int nrows, int band, int window_size) { -// return kernel_fun(x, ncols, nrows, band, window_size, _sd); -// } -// // [[Rcpp::export]] -// NumericVector C_kernel_min(const NumericMatrix& x, int ncols, -// int nrows, int band, int window_size) { -// return kernel_fun(x, ncols, nrows, band, window_size, _min); -// } -// // [[Rcpp::export]] -// NumericVector C_kernel_max(const NumericMatrix& x, int ncols, -// int nrows, int band, int window_size) { -// return kernel_fun(x, ncols, nrows, band, window_size, _max); -// } -// // [[Rcpp::export]] -// NumericVector C_kernel_var(const NumericMatrix& x, int ncols, -// int nrows, int band, int window_size) { -// return kernel_fun(x, ncols, nrows, band, window_size, _var); -// } -// // [[Rcpp::export]] -// NumericVector C_kernel_modal(const NumericMatrix& x, int ncols, -// int nrows, int band, int window_size) { -// return kernel_fun(x, ncols, nrows, band, window_size, _modal); -// } -// From c1f9bc0bc30e11317c44a0cbbe9aa1f8a520ba49 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 16 Feb 2025 19:44:26 +0000 Subject: [PATCH 008/122] implement first version of glcm --- src/RcppExports.cpp | 166 +++++++++++++++++ src/glcm_fns.cpp | 423 ++++++++++++++++++++++++-------------------- 2 files changed, 395 insertions(+), 194 deletions(-) diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index a373830f1..bc41f31dd 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -104,6 +104,162 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// glcm_tabulate +void glcm_tabulate(const arma::mat& x, const float& angle, const arma::uword& n_grey); +RcppExport SEXP _sits_glcm_tabulate(SEXP xSEXP, SEXP angleSEXP, SEXP n_greySEXP) { +BEGIN_RCPP + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::mat& >::type x(xSEXP); + Rcpp::traits::input_parameter< const float& >::type angle(angleSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); + glcm_tabulate(x, angle, n_grey); + return R_NilValue; +END_RCPP +} +// C_glcm_contrast +arma::mat C_glcm_contrast(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); +RcppExport SEXP _sits_C_glcm_contrast(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_contrast(x, nrows, ncols, window_size, angles, n_grey)); + return rcpp_result_gen; +END_RCPP +} +// C_glcm_dissimilarity +arma::mat C_glcm_dissimilarity(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); +RcppExport SEXP _sits_C_glcm_dissimilarity(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_dissimilarity(x, nrows, ncols, window_size, angles, n_grey)); + return rcpp_result_gen; +END_RCPP +} +// C_glcm_homogeneity +arma::mat C_glcm_homogeneity(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); +RcppExport SEXP _sits_C_glcm_homogeneity(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_homogeneity(x, nrows, ncols, window_size, angles, n_grey)); + return rcpp_result_gen; +END_RCPP +} +// C_glcm_energy +arma::mat C_glcm_energy(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); +RcppExport SEXP _sits_C_glcm_energy(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_energy(x, nrows, ncols, window_size, angles, n_grey)); + return rcpp_result_gen; +END_RCPP +} +// C_glcm_asm +arma::mat C_glcm_asm(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); +RcppExport SEXP _sits_C_glcm_asm(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_asm(x, nrows, ncols, window_size, angles, n_grey)); + return rcpp_result_gen; +END_RCPP +} +// C_glcm_mean +arma::mat C_glcm_mean(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); +RcppExport SEXP _sits_C_glcm_mean(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_mean(x, nrows, ncols, window_size, angles, n_grey)); + return rcpp_result_gen; +END_RCPP +} +// C_glcm_variance +arma::mat C_glcm_variance(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); +RcppExport SEXP _sits_C_glcm_variance(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_variance(x, nrows, ncols, window_size, angles, n_grey)); + return rcpp_result_gen; +END_RCPP +} +// C_glcm_std +arma::mat C_glcm_std(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); +RcppExport SEXP _sits_C_glcm_std(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_std(x, nrows, ncols, window_size, angles, n_grey)); + return rcpp_result_gen; +END_RCPP +} +// C_glcm_correlation +arma::mat C_glcm_correlation(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); +RcppExport SEXP _sits_C_glcm_correlation(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); + Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); + Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_correlation(x, nrows, ncols, window_size, angles, n_grey)); + return rcpp_result_gen; +END_RCPP +} // C_kernel_median NumericVector C_kernel_median(const NumericMatrix& x, int ncols, int nrows, int band, int window_size); RcppExport SEXP _sits_C_kernel_median(SEXP xSEXP, SEXP ncolsSEXP, SEXP nrowsSEXP, SEXP bandSEXP, SEXP window_sizeSEXP) { @@ -756,6 +912,16 @@ static const R_CallMethodDef CallEntries[] = { {"_sits_weighted_probs", (DL_FUNC) &_sits_weighted_probs, 2}, {"_sits_weighted_uncert_probs", (DL_FUNC) &_sits_weighted_uncert_probs, 2}, {"_sits_dtw_distance", (DL_FUNC) &_sits_dtw_distance, 2}, + {"_sits_glcm_tabulate", (DL_FUNC) &_sits_glcm_tabulate, 3}, + {"_sits_C_glcm_contrast", (DL_FUNC) &_sits_C_glcm_contrast, 6}, + {"_sits_C_glcm_dissimilarity", (DL_FUNC) &_sits_C_glcm_dissimilarity, 6}, + {"_sits_C_glcm_homogeneity", (DL_FUNC) &_sits_C_glcm_homogeneity, 6}, + {"_sits_C_glcm_energy", (DL_FUNC) &_sits_C_glcm_energy, 6}, + {"_sits_C_glcm_asm", (DL_FUNC) &_sits_C_glcm_asm, 6}, + {"_sits_C_glcm_mean", (DL_FUNC) &_sits_C_glcm_mean, 6}, + {"_sits_C_glcm_variance", (DL_FUNC) &_sits_C_glcm_variance, 6}, + {"_sits_C_glcm_std", (DL_FUNC) &_sits_C_glcm_std, 6}, + {"_sits_C_glcm_correlation", (DL_FUNC) &_sits_C_glcm_correlation, 6}, {"_sits_C_kernel_median", (DL_FUNC) &_sits_C_kernel_median, 5}, {"_sits_C_kernel_mean", (DL_FUNC) &_sits_C_kernel_mean, 5}, {"_sits_C_kernel_sd", (DL_FUNC) &_sits_C_kernel_sd, 5}, diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index 90f89d3ec..83ed0c480 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -7,7 +7,7 @@ using namespace Rcpp; using namespace std; -typedef double _glcm_fun(const arma::mat&, const arma::mat&, const arma::mat&); +typedef double _glcm_fun(const arma::sp_mat&, const arma::mat&, const arma::mat&); // compute outside indices of a vector as a mirror IntegerVector locus_neigh2(int size, int leg) { @@ -24,12 +24,22 @@ IntegerVector locus_neigh2(int size, int leg) { } // [[Rcpp::export]] -arma::mat glcm_tabulate(const arma::mat& x, - arma::mat glcm, - const float& angle, - const arma::uword& n_grey) { +void glcm_tabulate(const arma::mat& x, + const float& angle, + const arma::uword& n_grey) { + + arma::sp_mat glcm(n_grey, n_grey); + + arma::mat i_aux(n_grey, n_grey); + arma::mat j_aux(n_grey, n_grey); + // fill auxiliary matrices with a sequence of 1 to n_grey levels + i_aux = arma::repmat( + arma::linspace(0, n_grey - 1, n_grey), 1, n_grey + ); + j_aux = arma::trans(i_aux); int pixels_to_move = 1; + double sum; int nrows = x.n_rows; int ncols = x.n_cols; @@ -45,20 +55,23 @@ arma::mat glcm_tabulate(const arma::mat& x, // col start_col = std::max(0, -offset_col); end_col = std::min(ncols, ncols - offset_col); - // for (arma::uword r = start_row; r < end_row; r++) { - // for (arma::uword c = start_col; c < end_col; c++) { - // - // // v_i = x(r,c); - // // row = r + offset_row; - // // col = c + offset_col; - // // v_j = x(row, col); - // // //if (v_i < n_grey && v_j < n_grey) { - // // //glcm(v_i, v_j) += 1; - // // glcm(v_i, v_j) = 1; - // //} - // } - // } - return glcm; + + for (arma::uword r = start_row; r < end_row; r++) { + for (arma::uword c = start_col; c < end_col; c++) { + v_i = x(r,c); + row = r + offset_row; + col = c + offset_col; + v_j = x(row, col); + if (v_i < n_grey && v_j < n_grey) { + glcm(v_i, v_j) += 1; + } + } + } + + glcm += glcm.t(); + sum = arma::accu(glcm); + glcm /= sum; + Rcpp::Rcout << glcm << "\n"; } arma::mat glcm_fn(const arma::vec& x, @@ -68,36 +81,35 @@ arma::mat glcm_fn(const arma::vec& x, const arma::uword& window_size, const arma::uword& n_grey, _glcm_fun _fun) { - // initialize output values - arma::mat glcm_co(n_grey, n_grey, arma::fill::zeros); + // initialize sparse matrix to store co-occurrence values + arma::sp_mat glcm_co(n_grey, n_grey); // initialize result matrix arma::mat res(x.size(), angles.size(), arma::fill::zeros); - // initialize co-occurrence matrix - arma::mat co_occur(n_grey, n_grey, arma::fill::zeros); // initialize neighborhood matrix arma::mat neigh(window_size, window_size); - arma::mat pos_window(window_size, window_size, arma::fill::zeros); - - double sum = 0; - - arma::uword angle_ith = 0; - // Initialize auxiliary matrices they are needed in some metrics - arma::mat i_aux(n_grey, n_grey, arma::fill::zeros); - arma::mat j_aux(n_grey, n_grey, arma::fill::zeros); + // auxiliary variables + double sum; + arma::u8 pixels_to_move = 1; + arma::u8 angle_ith = 0; + arma::uword start_row, end_row, start_col, end_col = 0; + int offset_row, offset_col, v_i, v_j, row, col = 0; + // initialize auxiliary matrices needed in some metrics + arma::mat i_aux(n_grey, n_grey); + arma::mat j_aux(n_grey, n_grey); + // fill auxiliary matrices with a sequence of 1 to n_grey levels i_aux = arma::repmat( - arma::linspace(1, n_grey, n_grey), 1, n_grey + arma::linspace(0, n_grey - 1, n_grey), 1, n_grey ); j_aux = arma::trans(i_aux); - arma::uvec a; - // compute window leg - int leg = window_size / 2; + arma::u8 leg = window_size / 2; // compute locus mirror IntegerVector loci = locus_neigh2(nrows, leg); IntegerVector locj = locus_neigh2(ncols, leg); + // compute values for each pixel for (arma::uword i = 0; i < nrows; ++i) { for (arma::uword j = 0; j < ncols; ++j) { @@ -111,19 +123,6 @@ arma::mat glcm_fn(const arma::vec& x, } } - //Rcpp::Rcout << "test1" << "\n"; - //glcm_co = glcm_tabulate(neigh, glcm_co, angles(0), n_grey); - //Rcpp::Rcout << "test2" << "\n"; - // calculate co-occurrence probabilities - //sum = arma::accu(glcm_co); - //glcm_co /= sum; - - int pixels_to_move = 1; - - - arma::uword start_row, end_row, start_col, end_col = 0; - int offset_row, offset_col, v_i, v_j, row, col = 0; - offset_row = std::round(std::sin(0) * pixels_to_move); offset_col = std::round(std::cos(0) * pixels_to_move); // row @@ -143,25 +142,23 @@ arma::mat glcm_fn(const arma::vec& x, } } } + // calculate co-occurrence probabilities + sum = arma::accu(glcm_co); + glcm_co /= sum; // remove NA //NumericVector neigh2 = na_omit(neigh); - //res(i * ncols + j, 0) = _fun(glcm_co, i_aux, j_aux); - res(i * ncols + j, 0) = 1; - - - //} - //angle_ith++; - //glcm_co.clear(); - //glcm_co = aux; - //glcm_co = 0; + // calculate metric + res(i * ncols + j, 0) = _fun(glcm_co, i_aux, j_aux); + // clear and reset co-occurrence matrix + glcm_co.clear(); + glcm_co.set_size(n_grey, n_grey); } } return res; } - -inline double _glcm_contrast(const arma::mat& x, +inline double _glcm_contrast(const arma::sp_mat& x, const arma::mat& i, const arma::mat& j) { double res = 0; @@ -170,6 +167,87 @@ inline double _glcm_contrast(const arma::mat& x, return(res); } +inline double _glcm_dissimilarity(const arma::sp_mat& x, + const arma::mat& i, + const arma::mat& j) { + double res = 0; + res = arma::accu(x % arma::abs(i - j)); + return(res); +} + +inline double _glcm_homogeneity(const arma::sp_mat& x, + const arma::mat& i, + const arma::mat& j) { + double res = 0; + + res = arma::accu(x / (1 + (arma::pow(i - j, 2)))); + return(res); +} + +inline double _glcm_energy(const arma::sp_mat& glcm, + const arma::mat& i, + const arma::mat& j) { + double res = 0; + res = std::sqrt(arma::accu(glcm % glcm)); + return(res); +} + +inline double _glcm_asm(const arma::sp_mat& glcm, + const arma::mat& i, + const arma::mat& j) { + double res = 0; + + res = arma::accu(glcm % glcm); + return(res); +} + +inline double _glcm_mean(const arma::sp_mat& glcm, + const arma::mat& i, + const arma::mat& j) { + double res = 0; + + res = arma::accu(glcm % i); + return(res); +} + +inline double _glcm_variance(const arma::sp_mat& glcm, + const arma::mat& i, + const arma::mat& j) { + double res = 0; + double mean = 0; + + mean = arma::accu(glcm % i); + + res = arma::accu(glcm % pow(i - mean, 2)); + return(res); +} + + +inline double _glcm_std(const arma::sp_mat& glcm, + const arma::mat& i, + const arma::mat& j) { + + double res = _glcm_variance(glcm, i, j); + + res = sqrt(res); + return(res); +} + +inline double _glcm_correlation(const arma::sp_mat& glcm, + const arma::mat& i, + const arma::mat& j) { + double res = 0; + double mean_i = arma::accu(glcm % i); + double mean_j = arma::accu(glcm % j); + + double var_i = sqrt(arma::accu(glcm % pow(i - mean_i, 2))); + double var_j = sqrt(arma::accu(glcm % pow(j - mean_j, 2))); + + + res = accu(glcm % (( (i - mean_i) % (j - mean_j) ) / (var_i * var_j))); + return(res); +} + // [[Rcpp::export]] arma::mat C_glcm_contrast(const arma::vec& x, const arma::uword& nrows, @@ -181,146 +259,103 @@ arma::mat C_glcm_contrast(const arma::vec& x, return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_contrast); } +// [[Rcpp::export]] +arma::mat C_glcm_dissimilarity(const arma::vec& x, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::vec& angles, + const arma::uword& n_grey) { -// // [[Rcpp::export]] -// double glcm_dissimilarity(const arma::mat glcm, -// const arma::uword n_levels) { -// arma::mat j(n_levels, n_levels, arma::fill::zeros); -// arma::mat i(n_levels, n_levels, arma::fill::zeros); -// double res = 0; -// -// for (arma::uword r = 0; r < n_levels; r++) { -// for (arma::uword c = 0; c < n_levels; c++) { -// i(r, c) = r; -// j(r, c) = c; -// } -// } -// res = arma::accu(glcm % abs(i - j)); -// return(res); -// } -// -// // [[Rcpp::export]] -// double glcm_homogeneity(const arma::mat glcm, -// const arma::uword n_levels) { -// arma::mat j(n_levels, n_levels, arma::fill::zeros); -// arma::mat i(n_levels, n_levels, arma::fill::zeros); -// double res = 0; -// -// for (arma::uword r = 0; r < n_levels; r++) { -// for (arma::uword c = 0; c < n_levels; c++) { -// i(r, c) = r; -// j(r, c) = c; -// } -// } -// res = arma::accu(glcm / (1 + (pow(i - j, 2)))); -// return(res); -// } -// -// // [[Rcpp::export]] -// double glcm_mean(const arma::mat glcm, -// const arma::uword n_levels) { -// arma::mat i(n_levels, n_levels, arma::fill::zeros); -// double res = 0; -// -// for (arma::uword r = 0; r < n_levels; r++) { -// for (arma::uword c = 0; c < n_levels; c++) { -// i(r, c) = r; -// } -// } -// -// res = arma::accu(glcm % i); -// return(res); -// } -// -// // [[Rcpp::export]] -// double glcm_correlation(const arma::mat glcm, -// const arma::uword n_levels) { -// double res = 0; -// double res_mean = glcm_mean(glcm, n_levels); -// double res_var = glcm_variance(glcm, n_levels); -// -// arma::mat j(n_levels, n_levels, arma::fill::zeros); -// arma::mat i(n_levels, n_levels, arma::fill::zeros); -// -// for (arma::uword r = 0; r < n_levels; r++) { -// for (arma::uword c = 0; c < n_levels; c++) { -// i(r, c) = r; -// j(r, c) = c; -// } -// } -// -// res = accu(glcm % (((i - res_mean) % (j - res_mean)) / (res_var))); -// return(res); -// } -// -// // [[Rcpp::export]] -// double glcm_variance(const arma::mat glcm, -// const arma::uword n_levels) { -// arma::mat i(n_levels, n_levels, arma::fill::zeros); -// double res = 0; -// -// for (arma::uword r = 0; r < n_levels; r++) { -// for (arma::uword c = 0; c < n_levels; c++) { -// i(r, c) = r; -// } -// } -// res = arma::accu(glcm % i); -// -// res = arma::accu(glcm % pow(i - res, 2)); -// return(res); -// } -// -// // [[Rcpp::export]] -// double glcm_energy(const arma::mat glcm, -// const arma::uword n_levels) { -// double res = 0; -// -// res = std::sqrt(arma::accu(pow(glcm, 2))); -// return(res); -// } -// -// // [[Rcpp::export]] -// double glcm_asm(const arma::mat glcm, -// const arma::uword n_levels) { -// double res = 0; -// -// res = arma::accu(pow(glcm, 2)); -// return(res); -// } -// -// // [[Rcpp::export]] -// double glcm_std(const arma::mat glcm, -// const arma::uword n_levels) { -// -// double res = glcm_variance(glcm, n_levels); -// -// res = sqrt(res); -// return(res); -// } -// -// // [[Rcpp::export]] -// double glcm_entropy(const arma::mat glcm, -// const arma::uword n_levels) { + return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_dissimilarity); +} + +// [[Rcpp::export]] +arma::mat C_glcm_homogeneity(const arma::vec& x, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::vec& angles, + const arma::uword& n_grey) { + + return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_homogeneity); +} + +// [[Rcpp::export]] +arma::mat C_glcm_energy(const arma::vec& x, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::vec& angles, + const arma::uword& n_grey) { + + return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_energy); +} + +// [[Rcpp::export]] +arma::mat C_glcm_asm(const arma::vec& x, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::vec& angles, + const arma::uword& n_grey) { + + return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_asm); +} + +// [[Rcpp::export]] +arma::mat C_glcm_mean(const arma::vec& x, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::vec& angles, + const arma::uword& n_grey) { + + return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_mean); +} + +// [[Rcpp::export]] +arma::mat C_glcm_variance(const arma::vec& x, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::vec& angles, + const arma::uword& n_grey) { + + return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_variance); +} + +// [[Rcpp::export]] +arma::mat C_glcm_std(const arma::vec& x, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::vec& angles, + const arma::uword& n_grey) { + + return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_std); +} + +// [[Rcpp::export]] +arma::mat C_glcm_correlation(const arma::vec& x, + const arma::uword& nrows, + const arma::uword& ncols, + const arma::uword& window_size, + const arma::vec& angles, + const arma::uword& n_grey) { + + return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_correlation); +} + +// double glcm_entropy(const arma::sp_mat& glcm, +// const arma::mat& i, +// const arma::mat& j) { // double res = 0; // -// arma::mat glcm_entropy = glcm % ((-1) * log(glcm)); +// arma::mat glcm_entropy = glcm % ((-1) * arma::logmat(glcm)); // glcm_entropy.replace(arma::datum::nan, 0); // // res = accu(glcm_entropy); // return(res); // } -// -// // [[Rcpp::export]] -// arma::mat C_create_glcm_weights(const arma::uword n_levels) { -// arma::mat j(n_levels, n_levels); -// arma::mat i(n_levels, n_levels); -// -// for (arma::uword r = 0; r < n_levels; r++) { -// for (arma::uword c = 0; c < n_levels; c++) { -// i(r, c) = r; -// j(r, c) = c; -// } -// } -// -// return (i - j); -// } + From 3609fad7e47c802b7ab3ebe649d5c9507ed2e56d Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 16 Feb 2025 19:44:48 +0000 Subject: [PATCH 009/122] update support for glcm in sits_apply --- R/RcppExports.R | 40 ++++++++++++++++++++++++++++++++++++++++ R/api_apply.R | 6 +++--- 2 files changed, 43 insertions(+), 3 deletions(-) diff --git a/R/RcppExports.R b/R/RcppExports.R index 8cb07d08e..2441a8de2 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -29,6 +29,46 @@ dtw_distance <- function(ts1, ts2) { .Call(`_sits_dtw_distance`, ts1, ts2) } +glcm_tabulate <- function(x, angle, n_grey) { + invisible(.Call(`_sits_glcm_tabulate`, x, angle, n_grey)) +} + +C_glcm_contrast <- function(x, nrows, ncols, window_size, angles, n_grey) { + .Call(`_sits_C_glcm_contrast`, x, nrows, ncols, window_size, angles, n_grey) +} + +C_glcm_dissimilarity <- function(x, nrows, ncols, window_size, angles, n_grey) { + .Call(`_sits_C_glcm_dissimilarity`, x, nrows, ncols, window_size, angles, n_grey) +} + +C_glcm_homogeneity <- function(x, nrows, ncols, window_size, angles, n_grey) { + .Call(`_sits_C_glcm_homogeneity`, x, nrows, ncols, window_size, angles, n_grey) +} + +C_glcm_energy <- function(x, nrows, ncols, window_size, angles, n_grey) { + .Call(`_sits_C_glcm_energy`, x, nrows, ncols, window_size, angles, n_grey) +} + +C_glcm_asm <- function(x, nrows, ncols, window_size, angles, n_grey) { + .Call(`_sits_C_glcm_asm`, x, nrows, ncols, window_size, angles, n_grey) +} + +C_glcm_mean <- function(x, nrows, ncols, window_size, angles, n_grey) { + .Call(`_sits_C_glcm_mean`, x, nrows, ncols, window_size, angles, n_grey) +} + +C_glcm_variance <- function(x, nrows, ncols, window_size, angles, n_grey) { + .Call(`_sits_C_glcm_variance`, x, nrows, ncols, window_size, angles, n_grey) +} + +C_glcm_std <- function(x, nrows, ncols, window_size, angles, n_grey) { + .Call(`_sits_C_glcm_std`, x, nrows, ncols, window_size, angles, n_grey) +} + +C_glcm_correlation <- function(x, nrows, ncols, window_size, angles, n_grey) { + .Call(`_sits_C_glcm_correlation`, x, nrows, ncols, window_size, angles, n_grey) +} + C_kernel_median <- function(x, ncols, nrows, band, window_size) { .Call(`_sits_C_kernel_median`, x, ncols, nrows, band, window_size) } diff --git a/R/api_apply.R b/R/api_apply.R index a5299df68..e9e29674a 100644 --- a/R/api_apply.R +++ b/R/api_apply.R @@ -318,10 +318,10 @@ band = 0, window_size = window_size ) }, - glcm_contrast = function(m, shifts = c(0, pi/2, 3*pi/4, pi/4)) { + glcm_contrast = function(m) { C_glcm_contrast( - x = as.matrix(m), ncols = img_ncol, nrows = img_nrow, - band = 0, window_size = window_size + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = 0, n_grey = 10000 ) } ), parent = parent.env(environment()), hash = TRUE) From 552a2d6753d3935ad1d383884baf27388f453535 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 16 Feb 2025 22:51:32 +0000 Subject: [PATCH 010/122] working in progress on sits_glcm --- R/api_glcm.R | 192 ++++++++++++++++++++++++++++++++++++++++++++++++++ R/sits_glcm.R | 181 +++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 373 insertions(+) create mode 100644 R/api_glcm.R create mode 100644 R/sits_glcm.R diff --git a/R/api_glcm.R b/R/api_glcm.R new file mode 100644 index 000000000..afcd78bd9 --- /dev/null +++ b/R/api_glcm.R @@ -0,0 +1,192 @@ +#' @title Apply an expression to block of a set of input bands +#' @name .apply_feature +#' @keywords internal +#' @noRd +#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Felipe Carvalho, \email{rolf.simoes@@inpe.br} +#' +#' @param feature Subset of a data cube containing the input bands +#' used in the expression +#' @param block Individual block that will be processed +#' @param window_size Size of the neighbourhood (if required) +#' @param angles ... +#' @param expr Expression to be applied +#' @param out_band Output band +#' @param in_bands Input bands +#' @param overlap Overlap between tiles (if required) +#' @param normalized Produce normalized band? +#' @param output_dir Directory where image will be save +#' +#' @return A feature compose by a combination of tile and band. +.glcm_feature <- function(feature, block, window_size, angles, expr, + out_band, in_bands, overlap, output_dir) { + # Output file + out_file <- .file_eo_name( + tile = feature, band = out_band, + date = .tile_start_date(feature), output_dir = output_dir + ) + # Resume feature + if (.raster_is_valid(out_file, output_dir = output_dir)) { + # recovery message + .check_recovery(out_file) + + # Create tile based on template + feature <- .tile_eo_from_files( + files = out_file, fid = .fi_fid(.fi(feature)), + bands = out_band, date = .tile_start_date(feature), + base_tile = feature, update_bbox = FALSE + ) + return(feature) + } + # Remove remaining incomplete fractions files + unlink(out_file) + # Create chunks as jobs + chunks <- .tile_chunks_create( + tile = feature, overlap = overlap, block = block + ) + # Get band configuration + band_conf <- .tile_band_conf(tile = feature, band = out_band) + if (.has_not(band_conf)) { + band_conf <- .conf("default_values", "INT4S") + } + # Process jobs sequentially + block_files <- .jobs_map_sequential(chunks, function(chunk) { + # Get job block + block <- .block(chunk) + # Block file name for each fraction + block_files <- .file_block_name( + pattern = .file_pattern(out_file), + block = block, + output_dir = output_dir + ) + # Resume processing in case of failure + if (.raster_is_valid(block_files)) { + return(block_files) + } + # Read bands data + # TODO: create glcm data read + values <- .apply_data_read( + tile = feature, block = block, in_bands = in_bands + ) + # ... + values <- values * 10000 + values <- .as_int(c(values)[[1]]) + + # Evaluate expression here + # Band and kernel evaluation + # values <- eval( + # expr = expr[[out_band]], + # envir = values, + # enclos = .glcm_functions( + # window_size = window_size, + # angles = angles, + # img_nrow = block[["nrows"]], + # img_ncol = block[["ncols"]] + # ) + # ) + # TODO: rescale value + values <- C_glcm_variance( + x = values, nrows = block[["nrows"]], ncols = block[["ncols"]], + window_size = window_size, angles = 0 + ) + # Prepare fractions to be saved + offset <- .offset(band_conf) + if (.has(offset) && offset != 0) { + values <- values - offset + } + # Job crop block + crop_block <- .block(.chunks_no_overlap(chunk)) + # Prepare and save results as raster + .raster_write_block( + files = block_files, block = block, bbox = .bbox(chunk), + values = values, data_type = .data_type(band_conf), + missing_value = .miss_value(band_conf), + crop_block = crop_block + ) + # Free memory + gc() + # Returned block files for each fraction + block_files + }) + # Merge blocks into a new eo_cube tile + band_tile <- .tile_eo_merge_blocks( + files = out_file, + bands = out_band, + band_conf = band_conf, + base_tile = feature, + block_files = block_files, + multicores = 1, + update_bbox = FALSE + ) + # Return a feature tile + band_tile +} + +#' @title Kernel function for window operations in spatial neighbourhoods +#' @name .glcm_functions +#' @noRd +#' @param windows size of local window +#' @param img_nrow image size in rows +#' @param img_ncol image size in cols +#' @return operations on local kernels +#' +.glcm_functions <- function(window_size, angles, img_nrow, img_ncol) { + result_env <- list2env(list( + glcm_contrast = function(m) { + C_glcm_contrast( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = angles + ) + }, + glcm_dissimilarity = function(m) { + C_glcm_dissimilarity( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = angles + ) + }, + glcm_homogeneity = function(m) { + C_glcm_homogeneity( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = angles + ) + }, + glcm_energy = function(m) { + C_glcm_energy( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = angles + ) + }, + glcm_asm = function(m) { + C_glcm_asm( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = angles + ) + }, + glcm_mean = function(m) { + C_glcm_mean( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = angles + ) + }, + glcm_variance = function(m) { + C_glcm_variance( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = angles + ) + }, + glcm_std = function(m) { + C_glcm_std( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = angles + ) + }, + glcm_correlation = function(m) { + C_glcm_correlation( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = angles + ) + } + ), parent = parent.env(environment()), hash = TRUE) + + return(result_env) +} diff --git a/R/sits_glcm.R b/R/sits_glcm.R new file mode 100644 index 000000000..be06c4e1d --- /dev/null +++ b/R/sits_glcm.R @@ -0,0 +1,181 @@ +#' @title Apply a GLCM metric on a data cube +#' +#' @name sits_glcm +#' +#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' +#' @description ... +#' +#' @param data Valid sits tibble or cube +#' @param window_size An odd number representing the size of the +#' sliding window of sits kernel functions +#' used in expressions (for a list of supported +#' kernel functions, please see details). +#' @param angles ... +#' @param memsize Memory available for classification (in GB). +#' @param multicores Number of cores to be used for classification. +#' @param output_dir Directory where files will be saved. +#' @param progress Show progress bar? +#' @param ... Named expressions to be evaluated (see details). +#' +#' @section Summarizing GLCM functions: +#' \itemize{ +#' \item{\code{glcm_contrast()}: ...} +#' \item{\code{glcm_dissimilarity()}: ...} +#' \item{\code{glcm_homogeneity()}: ...} +#' \item{\code{glcm_energy()}: ...} +#' \item{\code{glcm_asm()}: ...} +#' \item{\code{glcm_mean()}: ...} +#' \item{\code{glcm_variance()}: ...} +#' \item{\code{glcm_std()}: ...} +#' \item{\code{glcm_correlation()}: ...} +#' } +#' +#' @return A sits cube with new bands, produced +#' according to the requested expression. +#' +#' @examples +#' if (sits_run_examples()) { +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' +#' # Generate a texture images with variance in NDVI images +#' cube_texture <- sits_apply( +#' data = cube, +#' NDVIMEAN = glcm_mean(NDVI), +#' window_size = 5, +#' angles = 0, +#' output_dir = tempdir() +#' ) +#' } +#' @rdname sits_glcm +#' @export +sits_glcm <- function(data, ...) { + .check_set_caller("sits_glcm") + .check_na_null_parameter(data) + UseMethod("sits_glcm", data) +} + +#' @rdname sits_glcm +#' @export +sits_glcm.raster_cube <- function(data, ..., + window_size = 3L, + angles = c(0, pi/2, pi/4, 3*pi/4), + memsize = 4L, + multicores = 2L, + output_dir, + progress = FALSE) { + # Check cube + .check_is_raster_cube(data) + .check_that(.cube_is_regular(data)) + # Check window size + .check_int_parameter(window_size, min = 1, is_odd = TRUE) + # Check normalized index + .check_num_parameter(angles) + # Check memsize + .check_int_parameter(memsize, min = 1, max = 16384) + # Check multicores + .check_int_parameter(multicores, min = 1, max = 2048) + # Check output_dir + .check_output_dir(output_dir) + + # Get cube bands + bands <- .cube_bands(data) + # Get output band expression + expr <- .apply_capture_expression(...) + out_band <- names(expr) + # Check if band already exists in cube + if (out_band %in% bands) { + if (.check_messages()) { + warning(.conf("messages", "sits_apply_out_band"), + call. = FALSE + ) + } + return(data) + } + # Get all input bands in cube data + in_bands <- .apply_input_bands( + cube = data, + bands = bands, + expr = expr + ) + # Overlapping pixels + overlap <- ceiling(window_size / 2) - 1 + # Get block size + block <- .raster_file_blocksize(.raster_open_rast(.tile_path(data))) + # Check minimum memory needed to process one block + job_memsize <- .jobs_memsize( + job_size = .block_size(block = block, overlap = overlap), + npaths = length(in_bands) + 1, + nbytes = 8, + proc_bloat = .conf("processing_bloat_cpu") + ) + # Update block parameter + block <- .jobs_optimal_block( + job_memsize = job_memsize, + block = block, + image_size = .tile_size(.tile(data)), + memsize = memsize, + multicores = multicores + ) + # adjust for blocks of size 1 + block <- .block_regulate_size(block) + # Update multicores parameter + multicores <- .jobs_max_multicores( + job_memsize = job_memsize, + memsize = memsize, + multicores = multicores + ) + # Prepare parallelization + .parallel_start(workers = multicores) + on.exit(.parallel_stop(), add = TRUE) + + # Create features as jobs + features_cube <- .cube_split_features(data) + + # Process each feature in parallel + features_band <- .jobs_map_parallel_dfr(features_cube, function(feature) { + # Process the data + output_feature <- .glcm_feature( + feature = feature, + block = block, + expr = expr, + window_size = window_size, + angles = angles, + out_band = out_band, + in_bands = in_bands, + overlap = overlap, + output_dir = output_dir + ) + return(output_feature) + }, progress = progress) + # Join output features as a cube and return it + .cube_merge_tiles(dplyr::bind_rows(list(features_cube, features_band))) +} + +#' @rdname sits_glcm +#' @export +sits_glcm.derived_cube <- function(data, ...) { + stop(.conf("messages", "sits_glcm_derived_cube")) +} +#' @rdname sits_glcm +#' @export +sits_glcm.default <- function(data, ...) { + data <- tibble::as_tibble(data) + if (all(.conf("sits_cube_cols") %in% colnames(data))) { + data <- .cube_find_class(data) + } else if (all(.conf("sits_tibble_cols") %in% colnames(data))) { + class(data) <- c("sits", class(data)) + } else { + stop(.conf("messages", "sits_glcm_default")) + } + + acc <- sits_glcm(data, ...) + return(acc) +} From 09a17a191569203a43804017b5c37e8b369ed29a Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 16 Feb 2025 22:51:53 +0000 Subject: [PATCH 011/122] remove glcm metrics from sits_apply --- R/RcppExports.R | 40 +++++++++++++++++--------------------- R/api_apply.R | 51 ++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 68 insertions(+), 23 deletions(-) diff --git a/R/RcppExports.R b/R/RcppExports.R index 2441a8de2..733845ad3 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -29,44 +29,40 @@ dtw_distance <- function(ts1, ts2) { .Call(`_sits_dtw_distance`, ts1, ts2) } -glcm_tabulate <- function(x, angle, n_grey) { - invisible(.Call(`_sits_glcm_tabulate`, x, angle, n_grey)) +C_glcm_contrast <- function(x, nrows, ncols, window_size, angles) { + .Call(`_sits_C_glcm_contrast`, x, nrows, ncols, window_size, angles) } -C_glcm_contrast <- function(x, nrows, ncols, window_size, angles, n_grey) { - .Call(`_sits_C_glcm_contrast`, x, nrows, ncols, window_size, angles, n_grey) +C_glcm_dissimilarity <- function(x, nrows, ncols, window_size, angles) { + .Call(`_sits_C_glcm_dissimilarity`, x, nrows, ncols, window_size, angles) } -C_glcm_dissimilarity <- function(x, nrows, ncols, window_size, angles, n_grey) { - .Call(`_sits_C_glcm_dissimilarity`, x, nrows, ncols, window_size, angles, n_grey) +C_glcm_homogeneity <- function(x, nrows, ncols, window_size, angles) { + .Call(`_sits_C_glcm_homogeneity`, x, nrows, ncols, window_size, angles) } -C_glcm_homogeneity <- function(x, nrows, ncols, window_size, angles, n_grey) { - .Call(`_sits_C_glcm_homogeneity`, x, nrows, ncols, window_size, angles, n_grey) +C_glcm_energy <- function(x, nrows, ncols, window_size, angles) { + .Call(`_sits_C_glcm_energy`, x, nrows, ncols, window_size, angles) } -C_glcm_energy <- function(x, nrows, ncols, window_size, angles, n_grey) { - .Call(`_sits_C_glcm_energy`, x, nrows, ncols, window_size, angles, n_grey) +C_glcm_asm <- function(x, nrows, ncols, window_size, angles) { + .Call(`_sits_C_glcm_asm`, x, nrows, ncols, window_size, angles) } -C_glcm_asm <- function(x, nrows, ncols, window_size, angles, n_grey) { - .Call(`_sits_C_glcm_asm`, x, nrows, ncols, window_size, angles, n_grey) +C_glcm_mean <- function(x, nrows, ncols, window_size, angles) { + .Call(`_sits_C_glcm_mean`, x, nrows, ncols, window_size, angles) } -C_glcm_mean <- function(x, nrows, ncols, window_size, angles, n_grey) { - .Call(`_sits_C_glcm_mean`, x, nrows, ncols, window_size, angles, n_grey) +C_glcm_variance <- function(x, nrows, ncols, window_size, angles) { + .Call(`_sits_C_glcm_variance`, x, nrows, ncols, window_size, angles) } -C_glcm_variance <- function(x, nrows, ncols, window_size, angles, n_grey) { - .Call(`_sits_C_glcm_variance`, x, nrows, ncols, window_size, angles, n_grey) +C_glcm_std <- function(x, nrows, ncols, window_size, angles) { + .Call(`_sits_C_glcm_std`, x, nrows, ncols, window_size, angles) } -C_glcm_std <- function(x, nrows, ncols, window_size, angles, n_grey) { - .Call(`_sits_C_glcm_std`, x, nrows, ncols, window_size, angles, n_grey) -} - -C_glcm_correlation <- function(x, nrows, ncols, window_size, angles, n_grey) { - .Call(`_sits_C_glcm_correlation`, x, nrows, ncols, window_size, angles, n_grey) +C_glcm_correlation <- function(x, nrows, ncols, window_size, angles) { + .Call(`_sits_C_glcm_correlation`, x, nrows, ncols, window_size, angles) } C_kernel_median <- function(x, ncols, nrows, band, window_size) { diff --git a/R/api_apply.R b/R/api_apply.R index e9e29674a..d79b64320 100644 --- a/R/api_apply.R +++ b/R/api_apply.R @@ -104,6 +104,7 @@ values <- .apply_data_read( tile = feature, block = block, in_bands = in_bands ) + values <- values * 10000 # Evaluate expression here # Band and kernel evaluation values <- eval( @@ -122,7 +123,7 @@ } scale <- .scale(band_conf) if (.has(scale) && scale != 1) { - values <- values / scale + values <- values * scale } # Job crop block crop_block <- .block(.chunks_no_overlap(chunk)) @@ -323,6 +324,54 @@ x = m, nrows = img_nrow, ncols = img_ncol, window_size = window_size, angles = 0, n_grey = 10000 ) + }, + glcm_dissimilarity = function(m) { + C_glcm_dissimilarity( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = 0, n_grey = 10000 + ) + }, + glcm_homogeneity = function(m) { + C_glcm_homogeneity( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = 0, n_grey = 10000 + ) + }, + glcm_energy = function(m) { + C_glcm_energy( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = 0, n_grey = 10000 + ) + }, + glcm_asm = function(m) { + C_glcm_asm( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = 0, n_grey = 10000 + ) + }, + glcm_mean = function(m) { + C_glcm_mean( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = 0, n_grey = 10000 + ) + }, + glcm_variance = function(m) { + C_glcm_variance( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = 0, n_grey = 10000 + ) + }, + glcm_std = function(m) { + C_glcm_std( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = 0, n_grey = 10000 + ) + }, + glcm_correlation = function(m) { + C_glcm_correlation( + x = m, nrows = img_nrow, ncols = img_ncol, + window_size = window_size, angles = 0, n_grey = 10000 + ) } ), parent = parent.env(environment()), hash = TRUE) From c9d88d59988e09247ba99629d7751168dcafcdd2 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 16 Feb 2025 22:52:09 +0000 Subject: [PATCH 012/122] update glcm cpp --- src/RcppExports.cpp | 94 +++++++++++++++------------------------ src/glcm_fns.cpp | 104 ++++++++++---------------------------------- 2 files changed, 58 insertions(+), 140 deletions(-) diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index bc41f31dd..5f1cfe1f2 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -104,21 +104,9 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } -// glcm_tabulate -void glcm_tabulate(const arma::mat& x, const float& angle, const arma::uword& n_grey); -RcppExport SEXP _sits_glcm_tabulate(SEXP xSEXP, SEXP angleSEXP, SEXP n_greySEXP) { -BEGIN_RCPP - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::mat& >::type x(xSEXP); - Rcpp::traits::input_parameter< const float& >::type angle(angleSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); - glcm_tabulate(x, angle, n_grey); - return R_NilValue; -END_RCPP -} // C_glcm_contrast -arma::mat C_glcm_contrast(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); -RcppExport SEXP _sits_C_glcm_contrast(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +arma::mat C_glcm_contrast(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); +RcppExport SEXP _sits_C_glcm_contrast(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -127,14 +115,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_contrast(x, nrows, ncols, window_size, angles, n_grey)); + rcpp_result_gen = Rcpp::wrap(C_glcm_contrast(x, nrows, ncols, window_size, angles)); return rcpp_result_gen; END_RCPP } // C_glcm_dissimilarity -arma::mat C_glcm_dissimilarity(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); -RcppExport SEXP _sits_C_glcm_dissimilarity(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +arma::mat C_glcm_dissimilarity(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); +RcppExport SEXP _sits_C_glcm_dissimilarity(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -143,14 +130,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_dissimilarity(x, nrows, ncols, window_size, angles, n_grey)); + rcpp_result_gen = Rcpp::wrap(C_glcm_dissimilarity(x, nrows, ncols, window_size, angles)); return rcpp_result_gen; END_RCPP } // C_glcm_homogeneity -arma::mat C_glcm_homogeneity(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); -RcppExport SEXP _sits_C_glcm_homogeneity(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +arma::mat C_glcm_homogeneity(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); +RcppExport SEXP _sits_C_glcm_homogeneity(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -159,14 +145,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_homogeneity(x, nrows, ncols, window_size, angles, n_grey)); + rcpp_result_gen = Rcpp::wrap(C_glcm_homogeneity(x, nrows, ncols, window_size, angles)); return rcpp_result_gen; END_RCPP } // C_glcm_energy -arma::mat C_glcm_energy(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); -RcppExport SEXP _sits_C_glcm_energy(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +arma::mat C_glcm_energy(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); +RcppExport SEXP _sits_C_glcm_energy(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -175,14 +160,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_energy(x, nrows, ncols, window_size, angles, n_grey)); + rcpp_result_gen = Rcpp::wrap(C_glcm_energy(x, nrows, ncols, window_size, angles)); return rcpp_result_gen; END_RCPP } // C_glcm_asm -arma::mat C_glcm_asm(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); -RcppExport SEXP _sits_C_glcm_asm(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +arma::mat C_glcm_asm(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); +RcppExport SEXP _sits_C_glcm_asm(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -191,14 +175,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_asm(x, nrows, ncols, window_size, angles, n_grey)); + rcpp_result_gen = Rcpp::wrap(C_glcm_asm(x, nrows, ncols, window_size, angles)); return rcpp_result_gen; END_RCPP } // C_glcm_mean -arma::mat C_glcm_mean(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); -RcppExport SEXP _sits_C_glcm_mean(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +arma::mat C_glcm_mean(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); +RcppExport SEXP _sits_C_glcm_mean(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -207,14 +190,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_mean(x, nrows, ncols, window_size, angles, n_grey)); + rcpp_result_gen = Rcpp::wrap(C_glcm_mean(x, nrows, ncols, window_size, angles)); return rcpp_result_gen; END_RCPP } // C_glcm_variance -arma::mat C_glcm_variance(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); -RcppExport SEXP _sits_C_glcm_variance(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +arma::mat C_glcm_variance(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); +RcppExport SEXP _sits_C_glcm_variance(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -223,14 +205,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_variance(x, nrows, ncols, window_size, angles, n_grey)); + rcpp_result_gen = Rcpp::wrap(C_glcm_variance(x, nrows, ncols, window_size, angles)); return rcpp_result_gen; END_RCPP } // C_glcm_std -arma::mat C_glcm_std(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); -RcppExport SEXP _sits_C_glcm_std(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +arma::mat C_glcm_std(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); +RcppExport SEXP _sits_C_glcm_std(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -239,14 +220,13 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_std(x, nrows, ncols, window_size, angles, n_grey)); + rcpp_result_gen = Rcpp::wrap(C_glcm_std(x, nrows, ncols, window_size, angles)); return rcpp_result_gen; END_RCPP } // C_glcm_correlation -arma::mat C_glcm_correlation(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles, const arma::uword& n_grey); -RcppExport SEXP _sits_C_glcm_correlation(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP, SEXP n_greySEXP) { +arma::mat C_glcm_correlation(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); +RcppExport SEXP _sits_C_glcm_correlation(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; @@ -255,8 +235,7 @@ BEGIN_RCPP Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type n_grey(n_greySEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_correlation(x, nrows, ncols, window_size, angles, n_grey)); + rcpp_result_gen = Rcpp::wrap(C_glcm_correlation(x, nrows, ncols, window_size, angles)); return rcpp_result_gen; END_RCPP } @@ -912,16 +891,15 @@ static const R_CallMethodDef CallEntries[] = { {"_sits_weighted_probs", (DL_FUNC) &_sits_weighted_probs, 2}, {"_sits_weighted_uncert_probs", (DL_FUNC) &_sits_weighted_uncert_probs, 2}, {"_sits_dtw_distance", (DL_FUNC) &_sits_dtw_distance, 2}, - {"_sits_glcm_tabulate", (DL_FUNC) &_sits_glcm_tabulate, 3}, - {"_sits_C_glcm_contrast", (DL_FUNC) &_sits_C_glcm_contrast, 6}, - {"_sits_C_glcm_dissimilarity", (DL_FUNC) &_sits_C_glcm_dissimilarity, 6}, - {"_sits_C_glcm_homogeneity", (DL_FUNC) &_sits_C_glcm_homogeneity, 6}, - {"_sits_C_glcm_energy", (DL_FUNC) &_sits_C_glcm_energy, 6}, - {"_sits_C_glcm_asm", (DL_FUNC) &_sits_C_glcm_asm, 6}, - {"_sits_C_glcm_mean", (DL_FUNC) &_sits_C_glcm_mean, 6}, - {"_sits_C_glcm_variance", (DL_FUNC) &_sits_C_glcm_variance, 6}, - {"_sits_C_glcm_std", (DL_FUNC) &_sits_C_glcm_std, 6}, - {"_sits_C_glcm_correlation", (DL_FUNC) &_sits_C_glcm_correlation, 6}, + {"_sits_C_glcm_contrast", (DL_FUNC) &_sits_C_glcm_contrast, 5}, + {"_sits_C_glcm_dissimilarity", (DL_FUNC) &_sits_C_glcm_dissimilarity, 5}, + {"_sits_C_glcm_homogeneity", (DL_FUNC) &_sits_C_glcm_homogeneity, 5}, + {"_sits_C_glcm_energy", (DL_FUNC) &_sits_C_glcm_energy, 5}, + {"_sits_C_glcm_asm", (DL_FUNC) &_sits_C_glcm_asm, 5}, + {"_sits_C_glcm_mean", (DL_FUNC) &_sits_C_glcm_mean, 5}, + {"_sits_C_glcm_variance", (DL_FUNC) &_sits_C_glcm_variance, 5}, + {"_sits_C_glcm_std", (DL_FUNC) &_sits_C_glcm_std, 5}, + {"_sits_C_glcm_correlation", (DL_FUNC) &_sits_C_glcm_correlation, 5}, {"_sits_C_kernel_median", (DL_FUNC) &_sits_C_kernel_median, 5}, {"_sits_C_kernel_mean", (DL_FUNC) &_sits_C_kernel_mean, 5}, {"_sits_C_kernel_sd", (DL_FUNC) &_sits_C_kernel_sd, 5}, diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index 83ed0c480..92aa85b33 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -23,64 +23,14 @@ IntegerVector locus_neigh2(int size, int leg) { return res; } -// [[Rcpp::export]] -void glcm_tabulate(const arma::mat& x, - const float& angle, - const arma::uword& n_grey) { - - arma::sp_mat glcm(n_grey, n_grey); - - arma::mat i_aux(n_grey, n_grey); - arma::mat j_aux(n_grey, n_grey); - // fill auxiliary matrices with a sequence of 1 to n_grey levels - i_aux = arma::repmat( - arma::linspace(0, n_grey - 1, n_grey), 1, n_grey - ); - j_aux = arma::trans(i_aux); - - int pixels_to_move = 1; - double sum; - - int nrows = x.n_rows; - int ncols = x.n_cols; - - arma::uword start_row, end_row, start_col, end_col = 0; - int offset_row, offset_col, v_i, v_j, row, col = 0; - - offset_row = std::round(std::sin(angle) * pixels_to_move); - offset_col = std::round(std::cos(angle) * pixels_to_move); - // row - start_row = std::max(0, -offset_row); - end_row = std::min(nrows, nrows - offset_row); - // col - start_col = std::max(0, -offset_col); - end_col = std::min(ncols, ncols - offset_col); - - for (arma::uword r = start_row; r < end_row; r++) { - for (arma::uword c = start_col; c < end_col; c++) { - v_i = x(r,c); - row = r + offset_row; - col = c + offset_col; - v_j = x(row, col); - if (v_i < n_grey && v_j < n_grey) { - glcm(v_i, v_j) += 1; - } - } - } - - glcm += glcm.t(); - sum = arma::accu(glcm); - glcm /= sum; - Rcpp::Rcout << glcm << "\n"; -} - arma::mat glcm_fn(const arma::vec& x, const arma::vec& angles, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, - const arma::uword& n_grey, _glcm_fun _fun) { + // get the value of grey values + int n_grey = x.max(); // initialize sparse matrix to store co-occurrence values arma::sp_mat glcm_co(n_grey, n_grey); // initialize result matrix @@ -143,12 +93,11 @@ arma::mat glcm_fn(const arma::vec& x, } } // calculate co-occurrence probabilities + glcm_co += glcm_co.t(); sum = arma::accu(glcm_co); glcm_co /= sum; - // remove NA - //NumericVector neigh2 = na_omit(neigh); - // calculate metric + // calculate glcm metric res(i * ncols + j, 0) = _fun(glcm_co, i_aux, j_aux); // clear and reset co-occurrence matrix glcm_co.clear(); @@ -253,10 +202,9 @@ arma::mat C_glcm_contrast(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, - const arma::vec& angles, - const arma::uword& n_grey) { + const arma::vec& angles) { - return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_contrast); + return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_contrast); } // [[Rcpp::export]] @@ -264,10 +212,9 @@ arma::mat C_glcm_dissimilarity(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, - const arma::vec& angles, - const arma::uword& n_grey) { + const arma::vec& angles) { - return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_dissimilarity); + return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_dissimilarity); } // [[Rcpp::export]] @@ -275,10 +222,9 @@ arma::mat C_glcm_homogeneity(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, - const arma::vec& angles, - const arma::uword& n_grey) { + const arma::vec& angles) { - return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_homogeneity); + return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_homogeneity); } // [[Rcpp::export]] @@ -286,10 +232,9 @@ arma::mat C_glcm_energy(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, - const arma::vec& angles, - const arma::uword& n_grey) { + const arma::vec& angles) { - return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_energy); + return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_energy); } // [[Rcpp::export]] @@ -297,10 +242,9 @@ arma::mat C_glcm_asm(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, - const arma::vec& angles, - const arma::uword& n_grey) { + const arma::vec& angles) { - return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_asm); + return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_asm); } // [[Rcpp::export]] @@ -308,10 +252,9 @@ arma::mat C_glcm_mean(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, - const arma::vec& angles, - const arma::uword& n_grey) { + const arma::vec& angles) { - return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_mean); + return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_mean); } // [[Rcpp::export]] @@ -319,10 +262,9 @@ arma::mat C_glcm_variance(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, - const arma::vec& angles, - const arma::uword& n_grey) { + const arma::vec& angles) { - return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_variance); + return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_variance); } // [[Rcpp::export]] @@ -330,10 +272,9 @@ arma::mat C_glcm_std(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, - const arma::vec& angles, - const arma::uword& n_grey) { + const arma::vec& angles) { - return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_std); + return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_std); } // [[Rcpp::export]] @@ -341,10 +282,9 @@ arma::mat C_glcm_correlation(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, - const arma::vec& angles, - const arma::uword& n_grey) { + const arma::vec& angles) { - return glcm_fn(x, angles, nrows, ncols, window_size, n_grey, _glcm_correlation); + return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_correlation); } // double glcm_entropy(const arma::sp_mat& glcm, From b51158cbdfefd83f045ad8024dd4ef054dda0138 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 16 Feb 2025 22:52:21 +0000 Subject: [PATCH 013/122] update docs --- DESCRIPTION | 2 ++ NAMESPACE | 4 +++ man/sits_glcm.Rd | 94 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 100 insertions(+) create mode 100644 man/sits_glcm.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 00e2ad1f9..ad85a847c 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -144,6 +144,7 @@ Collate: 'api_file.R' 'api_gdal.R' 'api_gdalcubes.R' + 'api_glcm.R' 'api_grid.R' 'api_jobs.R' 'api_kohonen.R' @@ -239,6 +240,7 @@ Collate: 'sits_get_data.R' 'sits_get_class.R' 'sits_get_probs.R' + 'sits_glcm.R' 'sits_histogram.R' 'sits_imputation.R' 'sits_labels.R' diff --git a/NAMESPACE b/NAMESPACE index d63f82971..16c2c8682 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -425,6 +425,9 @@ S3method(sits_get_probs,default) S3method(sits_get_probs,sf) S3method(sits_get_probs,shp) S3method(sits_get_probs,sits) +S3method(sits_glcm,default) +S3method(sits_glcm,derived_cube) +S3method(sits_glcm,raster_cube) S3method(sits_label_classification,default) S3method(sits_label_classification,derived_cube) S3method(sits_label_classification,probs_cube) @@ -541,6 +544,7 @@ export(sits_geo_dist) export(sits_get_class) export(sits_get_data) export(sits_get_probs) +export(sits_glcm) export(sits_impute) export(sits_kfold_validate) export(sits_label_classification) diff --git a/man/sits_glcm.Rd b/man/sits_glcm.Rd new file mode 100644 index 000000000..42dcad71f --- /dev/null +++ b/man/sits_glcm.Rd @@ -0,0 +1,94 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_glcm.R +\name{sits_glcm} +\alias{sits_glcm} +\alias{sits_glcm.raster_cube} +\alias{sits_glcm.derived_cube} +\alias{sits_glcm.default} +\title{Apply a GLCM metric on a data cube} +\usage{ +sits_glcm(data, ...) + +\method{sits_glcm}{raster_cube}( + data, + ..., + window_size = 3L, + angles = c(0, pi/2, pi/4, 3 * pi/4), + memsize = 4L, + multicores = 2L, + output_dir, + progress = FALSE +) + +\method{sits_glcm}{derived_cube}(data, ...) + +\method{sits_glcm}{default}(data, ...) +} +\arguments{ +\item{data}{Valid sits tibble or cube} + +\item{...}{Named expressions to be evaluated (see details).} + +\item{window_size}{An odd number representing the size of the +sliding window of sits kernel functions +used in expressions (for a list of supported +kernel functions, please see details).} + +\item{angles}{...} + +\item{memsize}{Memory available for classification (in GB).} + +\item{multicores}{Number of cores to be used for classification.} + +\item{output_dir}{Directory where files will be saved.} + +\item{progress}{Show progress bar?} +} +\value{ +A sits cube with new bands, produced + according to the requested expression. +} +\description{ +... +} +\section{Summarizing GLCM functions}{ + +\itemize{ +\item{\code{glcm_contrast()}: ...} +\item{\code{glcm_dissimilarity()}: ...} +\item{\code{glcm_homogeneity()}: ...} +\item{\code{glcm_energy()}: ...} +\item{\code{glcm_asm()}: ...} +\item{\code{glcm_mean()}: ...} +\item{\code{glcm_variance()}: ...} +\item{\code{glcm_std()}: ...} +\item{\code{glcm_correlation()}: ...} +} +} + +\examples{ +if (sits_run_examples()) { + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + + # Generate a texture images with variance in NDVI images + cube_texture <- sits_apply( + data = cube, + NDVIMEAN = glcm_mean(NDVI), + window_size = 5, + angles = 0, + output_dir = tempdir() + ) +} +} +\author{ +Rolf Simoes, \email{rolf.simoes@inpe.br} + +Felipe Carvalho, \email{felipe.carvalho@inpe.br} + +Gilberto Camara, \email{gilberto.camara@inpe.br} +} From e411f8844d668442e5714c2071ff7a9da85c7887 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 19 Feb 2025 00:59:53 +0000 Subject: [PATCH 014/122] update glcm api --- R/api_glcm.R | 53 +++++++++++++++++++++++++-------------------------- R/sits_glcm.R | 2 +- 2 files changed, 27 insertions(+), 28 deletions(-) diff --git a/R/api_glcm.R b/R/api_glcm.R index afcd78bd9..db5c127f9 100644 --- a/R/api_glcm.R +++ b/R/api_glcm.R @@ -64,31 +64,31 @@ return(block_files) } # Read bands data - # TODO: create glcm data read values <- .apply_data_read( tile = feature, block = block, in_bands = in_bands ) - # ... - values <- values * 10000 - values <- .as_int(c(values)[[1]]) + # Scale band values + scale <- .scale(band_conf) + if (.has(scale) && scale != 1) { + values <- values / scale + } # Evaluate expression here # Band and kernel evaluation - # values <- eval( - # expr = expr[[out_band]], - # envir = values, - # enclos = .glcm_functions( - # window_size = window_size, - # angles = angles, - # img_nrow = block[["nrows"]], - # img_ncol = block[["ncols"]] - # ) - # ) - # TODO: rescale value - values <- C_glcm_variance( - x = values, nrows = block[["nrows"]], ncols = block[["ncols"]], - window_size = window_size, angles = 0 + values <- eval( + expr = expr[[out_band]], + envir = values, + enclos = .glcm_functions( + window_size = window_size, + angles = angles, + img_nrow = block[["nrows"]], + img_ncol = block[["ncols"]] + ) ) + + from <- range(values, na.rm = TRUE, finite = TRUE) + to <- c(1, 10000) + values <- (values - from[1])/diff(from) * diff(to) + to[1] # Prepare fractions to be saved offset <- .offset(band_conf) if (.has(offset) && offset != 0) { @@ -129,42 +129,41 @@ #' @param img_nrow image size in rows #' @param img_ncol image size in cols #' @return operations on local kernels -#' .glcm_functions <- function(window_size, angles, img_nrow, img_ncol) { result_env <- list2env(list( glcm_contrast = function(m) { C_glcm_contrast( - x = m, nrows = img_nrow, ncols = img_ncol, + x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, window_size = window_size, angles = angles ) }, glcm_dissimilarity = function(m) { C_glcm_dissimilarity( - x = m, nrows = img_nrow, ncols = img_ncol, + x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, window_size = window_size, angles = angles ) }, glcm_homogeneity = function(m) { C_glcm_homogeneity( - x = m, nrows = img_nrow, ncols = img_ncol, + x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, window_size = window_size, angles = angles ) }, glcm_energy = function(m) { C_glcm_energy( - x = m, nrows = img_nrow, ncols = img_ncol, + x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, window_size = window_size, angles = angles ) }, glcm_asm = function(m) { C_glcm_asm( - x = m, nrows = img_nrow, ncols = img_ncol, + x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, window_size = window_size, angles = angles ) }, glcm_mean = function(m) { C_glcm_mean( - x = m, nrows = img_nrow, ncols = img_ncol, + x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, window_size = window_size, angles = angles ) }, @@ -176,13 +175,13 @@ }, glcm_std = function(m) { C_glcm_std( - x = m, nrows = img_nrow, ncols = img_ncol, + x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, window_size = window_size, angles = angles ) }, glcm_correlation = function(m) { C_glcm_correlation( - x = m, nrows = img_nrow, ncols = img_ncol, + x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, window_size = window_size, angles = angles ) } diff --git a/R/sits_glcm.R b/R/sits_glcm.R index be06c4e1d..4d745ef09 100644 --- a/R/sits_glcm.R +++ b/R/sits_glcm.R @@ -46,7 +46,7 @@ #' ) #' #' # Generate a texture images with variance in NDVI images -#' cube_texture <- sits_apply( +#' cube_texture <- sits_glcm( #' data = cube, #' NDVIMEAN = glcm_mean(NDVI), #' window_size = 5, From ed7366625c99ce5b70f4c64e6f1ac818df81f475 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 19 Feb 2025 01:00:05 +0000 Subject: [PATCH 015/122] update docs --- man/sits_glcm.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/sits_glcm.Rd b/man/sits_glcm.Rd index 42dcad71f..1a4143257 100644 --- a/man/sits_glcm.Rd +++ b/man/sits_glcm.Rd @@ -76,7 +76,7 @@ if (sits_run_examples()) { ) # Generate a texture images with variance in NDVI images - cube_texture <- sits_apply( + cube_texture <- sits_glcm( data = cube, NDVIMEAN = glcm_mean(NDVI), window_size = 5, From 5b0ad69ed695c5a9de27bb2853958554177b47d2 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 19 Feb 2025 01:00:16 +0000 Subject: [PATCH 016/122] update cpp code --- src/glcm_fns.cpp | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index 92aa85b33..8cfd6fe79 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -129,7 +129,8 @@ inline double _glcm_homogeneity(const arma::sp_mat& x, const arma::mat& j) { double res = 0; - res = arma::accu(x / (1 + (arma::pow(i - j, 2)))); + //res = arma::accu(x / (1 + (pow(i - j, 2)))); + res = arma::accu(x / (1 + (i - j))); return(res); } @@ -186,14 +187,14 @@ inline double _glcm_correlation(const arma::sp_mat& glcm, const arma::mat& i, const arma::mat& j) { double res = 0; - double mean_i = arma::accu(glcm % i); - double mean_j = arma::accu(glcm % j); + double diff_i = arma::accu(glcm % i); + double diff_j = arma::accu(glcm % j); - double var_i = sqrt(arma::accu(glcm % pow(i - mean_i, 2))); - double var_j = sqrt(arma::accu(glcm % pow(j - mean_j, 2))); + double std_i = sqrt(arma::accu(glcm % pow(i - diff_i, 2))); + double std_j = sqrt(arma::accu(glcm % pow(j - diff_j, 2))); + double cov = arma::accu(glcm * (diff_i * diff_j)); - - res = accu(glcm % (( (i - mean_i) % (j - mean_j) ) / (var_i * var_j))); + res = cov / (std_i * std_j); return(res); } From f6eaba50661abd4f09d1cd134b7fcd59ee806940 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 19 Feb 2025 17:58:31 +0000 Subject: [PATCH 017/122] update DESCRIPTION --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index b33d37f87..f2f31f89f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: sits Type: Package -Version: 1.5.2 +Version: 1.5.3 Title: Satellite Image Time Series Analysis for Earth Observation Data Cubes Authors@R: c(person('Rolf', 'Simoes', role = c('aut'), email = 'rolf.simoes@inpe.br'), person('Gilberto', 'Camara', role = c('aut', 'cre', 'ths'), email = 'gilberto.camara.inpe@gmail.com'), From b1ad312594bdb86ca3d82eb97757a50a9dd3f674 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 19 Feb 2025 17:59:35 +0000 Subject: [PATCH 018/122] fix vector cube classification --- R/api_chunks.R | 4 +++- R/api_segments.R | 8 +++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/R/api_chunks.R b/R/api_chunks.R index 99fc77165..84890da02 100644 --- a/R/api_chunks.R +++ b/R/api_chunks.R @@ -195,6 +195,8 @@ NULL dplyr::group_by(.data[["id"]]) |> tidyr::nest() |> tibble::deframe() + idx_positions <- as.integer(names(idx_intersects)) + chunks <- chunks[idx_positions, ] chunks[["segments"]] <- purrr::map(seq_along(idx_intersects), function(i) { idx <- unname(as.vector(idx_intersects[[i]])) idx <- idx[[1]] @@ -204,7 +206,7 @@ NULL output_dir = output_dir, ext = "gpkg" ) - .vector_write_vec(segments[idx, ], block_file) + .vector_write_vec(segments[idx, ], block_file, append = TRUE) return(block_file) }) return(chunks) diff --git a/R/api_segments.R b/R/api_segments.R index 6105807aa..46949c822 100755 --- a/R/api_segments.R +++ b/R/api_segments.R @@ -391,7 +391,13 @@ segments <- segments |> dplyr::filter( .data[["pol_id"]] %in% unique(ts_bands[["polygon_id"]]) ) - lat_long <- .proj_to_latlong(segments[["x"]], segments[["y"]], .crs(tile)) + if (.has_column(segments, "x") && .has_column(segments, "y")) { + lat_long <- .proj_to_latlong(segments[["x"]], segments[["y"]], .crs(tile)) + } else { + lat_long <- tibble::tibble("longitude" = rep(0, nrow(segments)), + "latitude" = rep(0, nrow(segments))) + } + # create metadata for the polygons samples <- tibble::tibble( longitude = lat_long[, "longitude"], From 1917f551b365b797b6a64cd2c24b133acb9180a8 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 19 Feb 2025 21:08:29 +0000 Subject: [PATCH 019/122] fix error in .classify_vector_tile --- R/api_classify.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/R/api_classify.R b/R/api_classify.R index 62b85e0c5..3d816a314 100755 --- a/R/api_classify.R +++ b/R/api_classify.R @@ -371,6 +371,10 @@ n_sam_pol = n_sam_pol, impute_fn = impute_fn ) + # In some cases, the chunk doesn't have data (e.g., cloudy areas) + if (nrow(segments_ts) == 0) { + return("") + } # Classify segments segments_ts <- .classify_ts( samples = segments_ts, @@ -396,6 +400,8 @@ # Return block file return(block_file) }, progress = progress) + # Remove empty block files + block_files <- purrr::discard(block_files, Negate(nzchar)) # Read all segments segments_ts <- purrr::map(block_files, .vector_read_vec) segments_ts <- dplyr::bind_rows(segments_ts) From fa138ca75f2bc4f5bee61bd35d2b53c6e223b6b4 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Thu, 20 Feb 2025 11:17:01 -0300 Subject: [PATCH 020/122] plot legends in som map --- R/api_check.R | 33 ++++++++++++++++++++++++++++++++ R/api_colors.R | 16 ++++++++++++++++ R/api_som.R | 20 +++++++++++-------- R/sits_plot.R | 27 ++++++++++++++++++++++---- R/sits_som.R | 4 ---- inst/extdata/config_messages.yml | 2 ++ man/plot.som_map.Rd | 6 ++++-- sits.Rproj | 1 + 8 files changed, 91 insertions(+), 18 deletions(-) diff --git a/R/api_check.R b/R/api_check.R index 76708ec7b..e983939b4 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -2459,6 +2459,22 @@ discriminator = "any_of") return(invisible(NULL)) } +#' @title Check legend defined as tibble +#' @name .check_legend +#' @param legend Legend (as tibble) +#' @return Called for side effects +#' @keywords internal +#' @noRd +.check_legend <- function(legend) { + .check_set_caller(".check_legend") + .check_chr_contains( + x = colnames(legend), + contains = c("name", "color"), + discriminator = "all_of", + msg = .conf("messages", ".check_legend") + ) + return(invisible(NULL)) +} #' @title Checks legend_position #' @name .check_legend_position #' @param legend_position Character vector with legend position @@ -2475,6 +2491,23 @@ ) return(invisible(NULL)) } +#' @title Checks if band is in list of bands +#' @name .check_band_in_bands +#' @param band Name of band +#' @param bands List of bands +#' @return Called for side effects +#' @keywords internal +#' @noRd +.check_band_in_bands <- function(band, bands) { + .check_set_caller("check_band_in_bands") + .check_chr_contains( + x = bands, + contains = band, + discriminator = "one_of", + msg = .conf("messages", ".check_band_in_bands") + ) + return(invisible(NULL)) +} #' @title Checks shapefile attribute #' @name .check_shp_attribute #' @param sf_shape sf object read from a shapefile diff --git a/R/api_colors.R b/R/api_colors.R index d05bf2df5..ac41dc75a 100644 --- a/R/api_colors.R +++ b/R/api_colors.R @@ -217,3 +217,19 @@ } return(c4a_pal_name) } +#' @title Transform an legend from tibble to vector +#' @name .colors_legend_set +#' @keywords internal +#' @noRd +#' @param legend A legend in tibble format +#' @return A valid legend as vector +#' +.colors_legend_set <- function(legend){ + if ("tbl_df" %in% class(legend)) { + .check_legend(legend) + legend_vec <- legend[["color"]] + names(legend_vec) <- legend[["name"]] + return(legend_vec) + } + return(legend) +} diff --git a/R/api_som.R b/R/api_som.R index 184126ff6..55122b414 100644 --- a/R/api_som.R +++ b/R/api_som.R @@ -145,24 +145,28 @@ #' of the last iteration of SOM #' in function sits_cluster_som #' -#' @param kohonen_obj Object kohonen +#' @param koh Object kohonen #' provided by package Kohonen +#' @param legend Legend (optional) #' @return kohonen_obj with a new parameter with the #' colour of the neuron. #' -.som_paint_neurons <- function(kohonen_obj) { - # assign one color per unique label +.som_paint_neurons <- function(koh, legend = NULL) { + # convert legend from tibble to vector + if (.has(legend)) + legend <- .colors_legend_set(legend) + # assign one color per unique label colors <- .colors_get( - labels = kohonen_obj[["neuron_label"]], - legend = NULL, + labels = unique(koh[["som_properties"]][["neuron_label"]]), + legend = legend, palette = "Set3", rev = TRUE ) - labels <- kohonen_obj[["neuron_label"]] - kohonen_obj[["paint_map"]] <- unname(colors[labels]) + labels <- koh[["som_properties"]][["neuron_label"]] + koh[["som_properties"]][["paint_map"]] <- unname(colors[labels]) - return(kohonen_obj) + return(koh) } #' @title Adjacency matrix diff --git a/R/sits_plot.R b/R/sits_plot.R index e53ee13d8..21af26b0f 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -1420,6 +1420,8 @@ plot.class_cube <- function(x, y, ..., .check_int_parameter(max_cog_size, min = 512) # check legend position .check_legend_position(legend_position) + # check legend - convert to vector if legend is tibble + legend <- .colors_legend_set(legend) # check for color_palette parameter (sits 1.4.1) dots <- list(...) # get tmap params from dots @@ -1747,7 +1749,8 @@ plot.som_evaluate_cluster <- function(x, y, ..., #' @param ... Further specifications for \link{plot}. #' @param type Type of plot: "codes" for neuron weight (time series) and #' "mapping" for the number of samples allocated in a neuron. -#' @param band What band will be plotted. +#' @param legend Legend with colors to be plotted +#' @param band What band will be plotted (character) #' #' @return Called for side effects. #' @@ -1764,23 +1767,39 @@ plot.som_evaluate_cluster <- function(x, y, ..., #' } #' @export #' -plot.som_map <- function(x, y, ..., type = "codes", band = 1) { +plot.som_map <- function(x, y, ..., type = "codes", legend = NULL, band = NULL) { stopifnot(missing(y)) koh <- x if (!inherits(koh, "som_map")) { message(.conf("messages", ".plot_som_map")) return(invisible(NULL)) } + # set band + bands <- names(koh[["som_properties"]][["codes"]]) + # check if band name is available + if (.has(band)) { + .check_band_in_bands(band, bands) + # create a numeric vector for plotting + bands_koh <- seq_len(length(bands)) + names(bands_koh) <- bands + whatmap <- bands_koh[[band]] + } else { + whatmap <- 1 + } + + + # paint neurons + koh <- .som_paint_neurons(koh, legend) if (type == "mapping") { graphics::plot(koh[["som_properties"]], bgcol = koh[["som_properties"]][["paint_map"]], - "mapping", whatmap = band, + "mapping", whatmap = whatmap, codeRendering = "lines" ) } else if (type == "codes") { graphics::plot(koh[["som_properties"]], bgcol = koh[["som_properties"]][["paint_map"]], - "codes", whatmap = band, + "codes", whatmap = whatmap, codeRendering = "lines" ) } diff --git a/R/sits_som.R b/R/sits_som.R index da4384326..6cabf0a10 100644 --- a/R/sits_som.R +++ b/R/sits_som.R @@ -192,10 +192,6 @@ sits_som_map <- function(data, labels_max <- unlist(lab_max) # prepare a color assignment to the SOM map kohonen_obj[["neuron_label"]] <- labels_max - # only paint neurons if number of labels is greater than one - if (length(unique(labels_max)) > 1) { - kohonen_obj <- .som_paint_neurons(kohonen_obj) - } # return the som_map object som_map <- list( diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index d17948476..2cfb530da 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -2,6 +2,7 @@ # .check_apply: "invalid function provided to be applied" .check_available_bands: 'requested band(s) not available in the cube' +.check_band_in_bands: "requested band(s) not available" .check_bbox: "input is not a valid bbox" .check_bw_rgb_bands: "either 'band' parameter or 'red', 'green', and 'blue' parameters should be informed" .check_crs: "invalid crs information in image files" @@ -54,6 +55,7 @@ .check_labels: "missing labels in some or all of reference data" .check_labels_class_cube: "labels do not match number of classes in cube" .check_labels_probs_cube: "labels are not available in probs cube" +.check_legend: "when defined as a tibble, legend needs name and color columns" .check_legend_position: "legend position is either inside or outside" .check_length: "invalid length for parameter" .check_lgl: "invalid logical value" diff --git a/man/plot.som_map.Rd b/man/plot.som_map.Rd index 298c80377..c97f04e7e 100644 --- a/man/plot.som_map.Rd +++ b/man/plot.som_map.Rd @@ -4,7 +4,7 @@ \alias{plot.som_map} \title{Plot a SOM map} \usage{ -\method{plot}{som_map}(x, y, ..., type = "codes", band = 1) +\method{plot}{som_map}(x, y, ..., type = "codes", legend = NULL, band = 1) } \arguments{ \item{x}{Object of class "som_map".} @@ -16,7 +16,9 @@ \item{type}{Type of plot: "codes" for neuron weight (time series) and "mapping" for the number of samples allocated in a neuron.} -\item{band}{What band will be plotted.} +\item{legend}{Legend with colors to be plotted} + +\item{band}{What band will be plotted (character)} } \value{ Called for side effects. diff --git a/sits.Rproj b/sits.Rproj index c1d6889aa..867683c7b 100644 --- a/sits.Rproj +++ b/sits.Rproj @@ -1,4 +1,5 @@ Version: 1.0 +ProjectId: 30147940-5ac6-4daa-88b6-6d66533383e5 RestoreWorkspace: Default SaveWorkspace: Ask From 20a236046675dab8441e41639229de365a694354 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Thu, 20 Feb 2025 11:49:02 -0300 Subject: [PATCH 021/122] fix docs for plotting of som_map --- man/plot.som_map.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/plot.som_map.Rd b/man/plot.som_map.Rd index c97f04e7e..bf5528b36 100644 --- a/man/plot.som_map.Rd +++ b/man/plot.som_map.Rd @@ -4,7 +4,7 @@ \alias{plot.som_map} \title{Plot a SOM map} \usage{ -\method{plot}{som_map}(x, y, ..., type = "codes", legend = NULL, band = 1) +\method{plot}{som_map}(x, y, ..., type = "codes", legend = NULL, band = NULL) } \arguments{ \item{x}{Object of class "som_map".} From 12e0f1fa4715bb9793b9d3c80e715be040b32515 Mon Sep 17 00:00:00 2001 From: Felipe Carlos Date: Thu, 20 Feb 2025 21:29:37 -0300 Subject: [PATCH 022/122] enable openmp in cpp code --- src/Makevars | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 src/Makevars diff --git a/src/Makevars b/src/Makevars new file mode 100644 index 000000000..d8f13901c --- /dev/null +++ b/src/Makevars @@ -0,0 +1,4 @@ +## Armadillo requires it +# CXX_STD = CXX11 +PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) +PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) From dd99d183b3a2c7ec26a42870b0ed7bc00240ff1c Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Fri, 21 Feb 2025 13:51:35 -0300 Subject: [PATCH 023/122] fix error in sits_mosaic --- R/api_file.R | 18 ++++++++++++++++-- R/api_mosaic.R | 25 +++++++++++++++++++------ 2 files changed, 35 insertions(+), 8 deletions(-) diff --git a/R/api_file.R b/R/api_file.R index 2c534539c..f51c97bdf 100644 --- a/R/api_file.R +++ b/R/api_file.R @@ -127,20 +127,34 @@ ) } -#' @title Build a file path for a mosaic +#' @title Build a file path for a mosaic of derived cubes #' @noRd #' @param tile Tile of data cube #' @param band Spectral band #' @param version Version name #' @param output_dir Directory where file will be saved #' @returns File path for mosaic -.file_mosaic_name <- function(tile, band, version, output_dir) { +.file_mosaic_name_derived <- function(tile, band, version, output_dir) { .file_path( tile[["satellite"]], tile[["sensor"]], "MOSAIC", .tile_start_date(tile), .tile_end_date(tile), band, version, ext = "tif", output_dir = output_dir ) } +#' @title Build a file path for a mosaic of raster cubes +#' @noRd +#' @param tile Tile of data cube +#' @param band Spectral band +#' @param version Version name +#' @param output_dir Directory where file will be saved +#' @returns File path for mosaic +.file_mosaic_name_raster <- function(tile, band, version, output_dir) { + .file_path( + tile[["satellite"]], tile[["sensor"]], "MOSAIC", + .tile_start_date(tile), band, version, + ext = "tif", output_dir = output_dir + ) +} #' @title Build a file path for a cropped file #' @noRd #' @param tile Tile of data cube diff --git a/R/api_mosaic.R b/R/api_mosaic.R index 85f775994..07845b650 100644 --- a/R/api_mosaic.R +++ b/R/api_mosaic.R @@ -92,6 +92,11 @@ multicores, version, progress) { + # check if cube is derived + if ("derived_cube" %in% class(cube)) + derived_cube <- TRUE + else + derived_cube <- FALSE # Create band date as jobs band_date_cube <- .mosaic_split_band_date(cube) # Get band configs from tile @@ -109,12 +114,20 @@ base_tile <- .tile(cube) # Update tile name .tile_name(base_tile) <- "MOSAIC" - out_file <- .file_mosaic_name( - tile = base_tile, - band = .tile_bands(base_tile), - version = version, - output_dir = output_dir - ) + if (derived_cube) + out_file <- .file_mosaic_name_derived( + tile = base_tile, + band = .tile_bands(base_tile), + version = version, + output_dir = output_dir + ) + else + out_file <- .file_mosaic_name_raster( + tile = base_tile, + band = .tile_bands(base_tile), + version = version, + output_dir = output_dir + ) # Resume feature if (.raster_is_valid(out_file, output_dir = output_dir)) { if (.check_messages()) { From c83c3b0347e101999c6b40329564e3baaf45f6ae Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Fri, 21 Feb 2025 16:22:15 -0300 Subject: [PATCH 024/122] add legend to plot som_evaluate_cluster --- R/sits_plot.R | 7 ++++++- man/plot.som_evaluate_cluster.Rd | 11 ++++++++++- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/R/sits_plot.R b/R/sits_plot.R index 21af26b0f..9f5506b18 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -1670,6 +1670,7 @@ plot.sits_accuracy <- function(x, y, ..., title = "Confusion matrix") { #' @param x Object of class "plot.som_evaluate_cluster". #' @param y Ignored. #' @param ... Further specifications for \link{plot}. +#' @param legend Legend with colors to be plotted. #' @param name_cluster Choose the cluster to plot. #' @param title Title of plot. #' @return A plot object produced by the ggplot2 package @@ -1690,6 +1691,7 @@ plot.sits_accuracy <- function(x, y, ..., title = "Confusion matrix") { #' @export #' plot.som_evaluate_cluster <- function(x, y, ..., + legend = NULL, name_cluster = NULL, title = "Confusion by cluster") { stopifnot(missing(y)) @@ -1704,11 +1706,14 @@ plot.som_evaluate_cluster <- function(x, y, ..., data <- dplyr::filter(data, .data[["cluster"]] %in% name_cluster) } # configure plot colors + # convert legend from tibble to vector + if (.has(legend)) + legend <- .colors_legend_set(legend) # get labels from cluster table labels <- unique(data[["class"]]) colors <- .colors_get( labels = labels, - legend = NULL, + legend = legend, palette = "Set3", rev = TRUE ) diff --git a/man/plot.som_evaluate_cluster.Rd b/man/plot.som_evaluate_cluster.Rd index e5cda3233..144d1e051 100644 --- a/man/plot.som_evaluate_cluster.Rd +++ b/man/plot.som_evaluate_cluster.Rd @@ -4,7 +4,14 @@ \alias{plot.som_evaluate_cluster} \title{Plot confusion between clusters} \usage{ -\method{plot}{som_evaluate_cluster}(x, y, ..., name_cluster = NULL, title = "Confusion by cluster") +\method{plot}{som_evaluate_cluster}( + x, + y, + ..., + legend = NULL, + name_cluster = NULL, + title = "Confusion by cluster" +) } \arguments{ \item{x}{Object of class "plot.som_evaluate_cluster".} @@ -13,6 +20,8 @@ \item{...}{Further specifications for \link{plot}.} +\item{legend}{Legend with colors to be plotted.} + \item{name_cluster}{Choose the cluster to plot.} \item{title}{Title of plot.} From cbb3f5923707b5984652b9d8b43e65a963863f37 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Fri, 21 Feb 2025 16:56:19 -0300 Subject: [PATCH 025/122] fix error in creation of raster mosaic --- R/api_file.R | 5 ++--- R/api_mosaic.R | 1 - 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/R/api_file.R b/R/api_file.R index f51c97bdf..b483482c5 100644 --- a/R/api_file.R +++ b/R/api_file.R @@ -145,13 +145,12 @@ #' @noRd #' @param tile Tile of data cube #' @param band Spectral band -#' @param version Version name #' @param output_dir Directory where file will be saved #' @returns File path for mosaic -.file_mosaic_name_raster <- function(tile, band, version, output_dir) { +.file_mosaic_name_raster <- function(tile, band, output_dir) { .file_path( tile[["satellite"]], tile[["sensor"]], "MOSAIC", - .tile_start_date(tile), band, version, + .tile_start_date(tile), band, ext = "tif", output_dir = output_dir ) } diff --git a/R/api_mosaic.R b/R/api_mosaic.R index 07845b650..7e5d0cd85 100644 --- a/R/api_mosaic.R +++ b/R/api_mosaic.R @@ -125,7 +125,6 @@ out_file <- .file_mosaic_name_raster( tile = base_tile, band = .tile_bands(base_tile), - version = version, output_dir = output_dir ) # Resume feature From 09df62b7c3ddabf7bbfd6c9e8aab3bbbf058ff21 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sat, 22 Feb 2025 18:25:19 +0000 Subject: [PATCH 026/122] add support to multiple angles in cpp code --- src/RcppExports.cpp | 11 +++++ src/glcm_fns.cpp | 104 ++++++++++++++++++++++++-------------------- 2 files changed, 68 insertions(+), 47 deletions(-) diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 5f1cfe1f2..df87b37a5 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -104,6 +104,16 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// test +void test(const arma::vec& angles); +RcppExport SEXP _sits_test(SEXP anglesSEXP) { +BEGIN_RCPP + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); + test(angles); + return R_NilValue; +END_RCPP +} // C_glcm_contrast arma::mat C_glcm_contrast(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); RcppExport SEXP _sits_C_glcm_contrast(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { @@ -891,6 +901,7 @@ static const R_CallMethodDef CallEntries[] = { {"_sits_weighted_probs", (DL_FUNC) &_sits_weighted_probs, 2}, {"_sits_weighted_uncert_probs", (DL_FUNC) &_sits_weighted_uncert_probs, 2}, {"_sits_dtw_distance", (DL_FUNC) &_sits_dtw_distance, 2}, + {"_sits_test", (DL_FUNC) &_sits_test, 1}, {"_sits_C_glcm_contrast", (DL_FUNC) &_sits_C_glcm_contrast, 5}, {"_sits_C_glcm_dissimilarity", (DL_FUNC) &_sits_C_glcm_dissimilarity, 5}, {"_sits_C_glcm_homogeneity", (DL_FUNC) &_sits_C_glcm_homogeneity, 5}, diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index 8cfd6fe79..40559572d 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -23,6 +23,18 @@ IntegerVector locus_neigh2(int size, int leg) { return res; } + +// [[Rcpp::export]] +void test(const arma::vec& angles) { + double angle_value = angles(0); + + Rcpp::Rcout << "sin: "<< std::sin(angle_value) << " cos: " << std::cos(angle_value) << "\n"; + Rcpp::Rcout << "sin: "<< std::sin(3.14/2) << " cos: " << std::cos(3.14/2) << "\n"; + Rcpp::Rcout << "sin: "<< std::sin(3.14/4) << " cos: " << std::cos(3.14/4) << "\n"; + Rcpp::Rcout << "sin: "<< std::sin(3*3.14/4) << " cos: " << std::cos(3*3.14/4) << "\n"; + +} + arma::mat glcm_fn(const arma::vec& x, const arma::vec& angles, const arma::uword& nrows, @@ -39,11 +51,11 @@ arma::mat glcm_fn(const arma::vec& x, arma::mat neigh(window_size, window_size); // auxiliary variables - double sum; - arma::u8 pixels_to_move = 1; - arma::u8 angle_ith = 0; + double sum, ang_v = 0; + arma::u8 offset_row, offset_col = 1; + arma::u16 row, col = 0; arma::uword start_row, end_row, start_col, end_col = 0; - int offset_row, offset_col, v_i, v_j, row, col = 0; + int v_i, v_j = 0; // initialize auxiliary matrices needed in some metrics arma::mat i_aux(n_grey, n_grey); @@ -64,45 +76,48 @@ arma::mat glcm_fn(const arma::vec& x, for (arma::uword i = 0; i < nrows; ++i) { for (arma::uword j = 0; j < ncols; ++j) { // for all angles - //for (arma::uword angle = 0; angle < angles.size(); ++angle) { - // compute the neighborhood - for (int wi = 0; wi < window_size; ++wi) { - for (int wj = 0; wj < window_size; ++wj) { - neigh(wi, wj) = - x(loci(wi + i) * ncols + locj(wj + j)); + for (arma::uword ang = 0; ang < angles.size(); ++ang) { + ang_v = angles(ang); + // compute the neighborhood + for (arma::uword wi = 0; wi < window_size; ++wi) { + for (arma::uword wj = 0; wj < window_size; ++wj) { + neigh(wi, wj) = + x(loci(wi + i) * ncols + locj(wj + j)); + } } - } - offset_row = std::round(std::sin(0) * pixels_to_move); - offset_col = std::round(std::cos(0) * pixels_to_move); - // row - start_row = std::max(0, -offset_row); - end_row = std::min(neigh.n_rows, neigh.n_rows - offset_row); - // col - start_col = std::max(0, -offset_col); - end_col = std::min(neigh.n_cols, neigh.n_cols - offset_col); - for (arma::uword r = start_row; r < end_row; r++) { - for (arma::uword c = start_col; c < end_col; c++) { - v_i = neigh(r,c); - row = r + offset_row; - col = c + offset_col; - v_j = neigh(row, col); - if (v_i < n_grey && v_j < n_grey) { - glcm_co(v_i, v_j) += 1; + offset_row = std::round(std::sin(ang_v)); + offset_col = std::round(std::cos(ang_v)); + // row + start_row = std::max(0, -offset_row); + end_row = std::min(neigh.n_rows, neigh.n_rows - offset_row); + // col + start_col = std::max(0, -offset_col); + end_col = std::min(neigh.n_cols, neigh.n_cols - offset_col); + for (arma::uword r = start_row; r < end_row; r++) { + for (arma::uword c = start_col; c < end_col; c++) { + v_i = neigh(r,c); + row = r + offset_row; + col = c + offset_col; + v_j = neigh(row, col); + if (v_i < n_grey && v_j < n_grey) { + glcm_co(v_i, v_j) += 1; + } } } + // calculate co-occurrence probabilities + glcm_co += glcm_co.t(); + sum = arma::accu(glcm_co); + glcm_co /= sum; + + // calculate glcm metric + res(i * ncols + j, ang) = _fun(glcm_co, i_aux, j_aux); + // clear and reset co-occurrence matrix + glcm_co.clear(); + glcm_co.set_size(n_grey, n_grey); } - // calculate co-occurrence probabilities - glcm_co += glcm_co.t(); - sum = arma::accu(glcm_co); - glcm_co /= sum; - - // calculate glcm metric - res(i * ncols + j, 0) = _fun(glcm_co, i_aux, j_aux); - // clear and reset co-occurrence matrix - glcm_co.clear(); - glcm_co.set_size(n_grey, n_grey); } + } return res; } @@ -129,8 +144,7 @@ inline double _glcm_homogeneity(const arma::sp_mat& x, const arma::mat& j) { double res = 0; - //res = arma::accu(x / (1 + (pow(i - j, 2)))); - res = arma::accu(x / (1 + (i - j))); + res = arma::accu(x % (1 / (1 + pow(i - j, 2)))); return(res); } @@ -164,9 +178,8 @@ inline double _glcm_variance(const arma::sp_mat& glcm, const arma::mat& i, const arma::mat& j) { double res = 0; - double mean = 0; - mean = arma::accu(glcm % i); + double mean = arma::accu(glcm % i); res = arma::accu(glcm % pow(i - mean, 2)); return(res); @@ -187,14 +200,11 @@ inline double _glcm_correlation(const arma::sp_mat& glcm, const arma::mat& i, const arma::mat& j) { double res = 0; - double diff_i = arma::accu(glcm % i); - double diff_j = arma::accu(glcm % j); + double mean = arma::accu(glcm % i); + double var = _glcm_variance(glcm, i, j); - double std_i = sqrt(arma::accu(glcm % pow(i - diff_i, 2))); - double std_j = sqrt(arma::accu(glcm % pow(j - diff_j, 2))); - double cov = arma::accu(glcm * (diff_i * diff_j)); + res = arma::accu(glcm % (( (i-mean) % (j-mean) ) / (var))); - res = cov / (std_i * std_j); return(res); } From b436dffb24d54cc8b3672ac5781e1fcc641662de Mon Sep 17 00:00:00 2001 From: Felipe Date: Sat, 22 Feb 2025 18:25:31 +0000 Subject: [PATCH 027/122] update glcm internal api --- R/RcppExports.R | 4 ++++ R/api_glcm.R | 9 ++++++--- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/R/RcppExports.R b/R/RcppExports.R index 733845ad3..72437a29b 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -29,6 +29,10 @@ dtw_distance <- function(ts1, ts2) { .Call(`_sits_dtw_distance`, ts1, ts2) } +test <- function(angles) { + invisible(.Call(`_sits_test`, angles)) +} + C_glcm_contrast <- function(x, nrows, ncols, window_size, angles) { .Call(`_sits_C_glcm_contrast`, x, nrows, ncols, window_size, angles) } diff --git a/R/api_glcm.R b/R/api_glcm.R index db5c127f9..0e49a7b7d 100644 --- a/R/api_glcm.R +++ b/R/api_glcm.R @@ -47,7 +47,7 @@ # Get band configuration band_conf <- .tile_band_conf(tile = feature, band = out_band) if (.has_not(band_conf)) { - band_conf <- .conf("default_values", "INT4S") + band_conf <- .conf("default_values", "INT2S") } # Process jobs sequentially block_files <- .jobs_map_sequential(chunks, function(chunk) { @@ -86,9 +86,12 @@ ) ) + # Re-scale values between 1 and maximum + # code from scales package from <- range(values, na.rm = TRUE, finite = TRUE) - to <- c(1, 10000) - values <- (values - from[1])/diff(from) * diff(to) + to[1] + to <- c(1, .max_value(band_conf)) + values <- (values - from[1]) / diff(from) * diff(to) + to[1] + # Prepare fractions to be saved offset <- .offset(band_conf) if (.has(offset) && offset != 0) { From f85d0d682dc3c7e2727a6e3b46f7d4df945d3961 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sat, 22 Feb 2025 19:14:31 +0000 Subject: [PATCH 028/122] optimize glcm tabulate --- src/glcm_fns.cpp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index 40559572d..d8fcf73a4 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -102,11 +102,11 @@ arma::mat glcm_fn(const arma::vec& x, v_j = neigh(row, col); if (v_i < n_grey && v_j < n_grey) { glcm_co(v_i, v_j) += 1; + glcm_co(v_j, v_i) += 1; } } } // calculate co-occurrence probabilities - glcm_co += glcm_co.t(); sum = arma::accu(glcm_co); glcm_co /= sum; From 6074e446a0b579d7411d8b60512bf3b13afad2d9 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Sat, 22 Feb 2025 18:22:04 -0300 Subject: [PATCH 029/122] update documentation --- DESCRIPTION | 2 +- R/api_accessors.R | 4 +- R/api_apply.R | 4 +- R/api_band.R | 1 + R/api_bayts.R | 1 + R/api_bbox.R | 2 +- R/api_block.R | 4 +- R/api_chunks.R | 2 +- R/api_classify.R | 6 +- R/api_cluster.R | 6 +- R/api_combine_predictions.R | 8 +- R/api_comp.R | 2 +- R/api_conf.R | 10 +- R/api_cube.R | 8 +- R/api_debug.R | 4 +- R/api_factory.R | 2 +- R/api_file_info.R | 2 +- R/api_mixture_model.R | 9 +- R/api_ml_model.R | 25 ++-- R/api_parallel.R | 14 +- R/api_point.R | 4 +- R/api_raster.R | 188 +++++++++++++++++++++------ R/api_reclassify.R | 6 +- R/api_samples.R | 2 +- R/api_smooth.R | 2 +- R/api_space_time_operations.R | 6 +- R/api_tibble.R | 9 +- R/api_tile.R | 2 +- R/api_torch.R | 20 +-- R/api_torch_psetae.R | 12 +- R/api_ts.R | 30 ++--- R/api_utils.R | 4 +- R/api_values.R | 2 +- R/api_variance.R | 6 +- R/api_vector_info.R | 2 +- R/sits_accuracy.R | 2 +- R/sits_add_base_cube.R | 2 + R/sits_apply.R | 2 +- R/sits_bands.R | 2 +- R/sits_bayts.R | 2 - R/sits_bbox.R | 2 +- R/sits_classify.R | 4 +- R/sits_cluster.R | 6 +- R/sits_combine_predictions.R | 2 +- R/sits_config.R | 2 +- R/sits_cube.R | 4 + R/sits_cube_copy.R | 2 + R/sits_detect_change.R | 1 - R/sits_detect_change_method.R | 2 +- R/sits_dtw.R | 2 - R/sits_factory.R | 2 +- R/sits_filters.R | 4 +- R/sits_geo_dist.R | 2 +- R/sits_get_class.R | 2 +- R/sits_get_data.R | 6 +- R/sits_get_probs.R | 3 +- R/sits_label_classification.R | 2 +- R/sits_labels.R | 6 +- R/sits_lighttae.R | 2 +- R/sits_machine_learning.R | 9 +- R/sits_merge.R | 3 +- R/sits_mixture_model.R | 4 +- R/sits_model_export.R | 2 +- R/sits_mosaic.R | 3 +- R/sits_patterns.R | 2 +- R/sits_plot.R | 8 +- R/sits_predictors.R | 1 + R/sits_reclassify.R | 2 +- R/sits_reduce.R | 3 +- R/sits_regularize.R | 3 +- R/sits_sample_functions.R | 8 +- R/sits_segmentation.R | 7 +- R/sits_select.R | 4 +- R/sits_smooth.R | 2 +- R/sits_som.R | 26 +++- R/sits_summary.R | 2 +- R/sits_tae.R | 3 +- R/sits_tempcnn.R | 2 +- R/sits_train.R | 2 +- R/sits_tuning.R | 2 +- R/sits_uncertainty.R | 2 +- R/sits_validate.R | 4 +- R/sits_variance.R | 2 +- man/plot.geo_distances.Rd | 2 +- man/plot.sits_cluster.Rd | 2 +- man/plot.torch_model.Rd | 4 +- man/sits-package.Rd | 2 +- man/sits_accuracy.Rd | 2 +- man/sits_add_base_cube.Rd | 4 + man/sits_apply.Rd | 2 +- man/sits_bands.Rd | 2 +- man/sits_bbox.Rd | 2 +- man/sits_classify.Rd | 6 +- man/sits_cluster_clean.Rd | 2 +- man/sits_cluster_dendro.Rd | 2 +- man/sits_cluster_frequency.Rd | 2 +- man/sits_combine_predictions.Rd | 2 +- man/sits_confidence_sampling.Rd | 2 +- man/sits_config.Rd | 2 +- man/sits_cube.Rd | 9 ++ man/sits_cube_copy.Rd | 5 + man/sits_factory_function.Rd | 2 +- man/sits_formula_linear.Rd | 2 +- man/sits_formula_logref.Rd | 2 +- man/sits_geo_dist.Rd | 2 +- man/sits_get_class.Rd | 2 +- man/sits_get_data.Rd | 8 +- man/sits_get_probs.Rd | 2 +- man/sits_kfold_validate.Rd | 2 +- man/sits_label_classification.Rd | 2 +- man/sits_labels.Rd | 2 +- man/sits_labels_summary.Rd | 2 +- man/sits_lighttae.Rd | 2 +- man/sits_merge.Rd | 4 +- man/sits_mixture_model.Rd | 6 +- man/sits_model_export.Rd | 2 +- man/sits_mosaic.Rd | 4 +- man/sits_patterns.Rd | 2 +- man/sits_reclassify.Rd | 2 +- man/sits_reduce.Rd | 4 +- man/sits_regularize.Rd | 5 + man/sits_rfor.Rd | 2 +- man/sits_sample.Rd | 4 +- man/sits_segment.Rd | 4 +- man/sits_select.Rd | 4 +- man/sits_sgolay.Rd | 2 +- man/sits_slic.Rd | 6 +- man/sits_smooth.Rd | 2 +- man/sits_som_clean_samples.Rd | 22 +++- man/{sits_som.Rd => sits_som_map.Rd} | 7 +- man/sits_som_remove_samples.Rd | 5 + man/sits_svm.Rd | 2 +- man/sits_tae.Rd | 4 +- man/sits_tempcnn.Rd | 2 +- man/sits_train.Rd | 2 +- man/sits_tuning.Rd | 2 +- man/sits_uncertainty.Rd | 2 +- man/sits_uncertainty_sampling.Rd | 2 +- man/sits_validate.Rd | 2 +- man/sits_variance.Rd | 2 +- man/sits_whittaker.Rd | 2 +- man/sits_xgboost.Rd | 2 - man/summary.sits.Rd | 2 +- man/tick-sits_labels-set-tick.Rd | 2 +- 144 files changed, 498 insertions(+), 284 deletions(-) rename man/{sits_som.Rd => sits_som_map.Rd} (96%) diff --git a/DESCRIPTION b/DESCRIPTION index f2f31f89f..98c91c771 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Package: sits Type: Package Version: 1.5.3 Title: Satellite Image Time Series Analysis for Earth Observation Data Cubes -Authors@R: c(person('Rolf', 'Simoes', role = c('aut'), email = 'rolf.simoes@inpe.br'), +Authors@R: c(person('Rolf', 'Simoes', role = c('aut'), email = 'rolfsimoes@gmail.com'), person('Gilberto', 'Camara', role = c('aut', 'cre', 'ths'), email = 'gilberto.camara.inpe@gmail.com'), person('Felipe', 'Souza', role = c('aut'), email = 'felipe.carvalho@inpe.br'), person('Felipe', 'Carlos', role = c('aut'), email = "efelipecarlos@gmail.com"), diff --git a/R/api_accessors.R b/R/api_accessors.R index 80176d94d..c259f1c11 100644 --- a/R/api_accessors.R +++ b/R/api_accessors.R @@ -1,7 +1,7 @@ #' @title Bouding box accessors #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' These functions are accessors of raster data and bbox structures. @@ -153,7 +153,7 @@ #' @title Resolution accessors #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' These functions are read-only accessors of chunk fields diff --git a/R/api_apply.R b/R/api_apply.R index 1960d3e79..0bff87cfb 100644 --- a/R/api_apply.R +++ b/R/api_apply.R @@ -2,7 +2,7 @@ #' @name .apply #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param data Tibble. #' @param col Column where function should be applied @@ -38,7 +38,7 @@ #' @name .apply_feature #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param feature Subset of a data cube containing the input bands #' used in the expression diff --git a/R/api_band.R b/R/api_band.R index c12ace0b6..f3f0df97f 100644 --- a/R/api_band.R +++ b/R/api_band.R @@ -1,5 +1,6 @@ #' @title Rename bands (S3 Generic function) #' @name .band_rename +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param x sits object (time series or cube) #' @param bands new bands for the object diff --git a/R/api_bayts.R b/R/api_bayts.R index d734bd737..177125d19 100644 --- a/R/api_bayts.R +++ b/R/api_bayts.R @@ -1,6 +1,7 @@ #' @title Create statistics for BAYTS algorithm #' @name .bayts_create_stats #' @keywords internal +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @noRd #' @param samples Samples #' @param stats Tibble with statistics diff --git a/R/api_bbox.R b/R/api_bbox.R index 074c624e1..536841cc5 100644 --- a/R/api_bbox.R +++ b/R/api_bbox.R @@ -17,7 +17,7 @@ #' @title Bounding box API #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' A bounding box represents a rectangular geographical region in a certain diff --git a/R/api_block.R b/R/api_block.R index 1e5cab118..2624fd1a1 100644 --- a/R/api_block.R +++ b/R/api_block.R @@ -1,7 +1,7 @@ #' @title Block API #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param x Any object to extract a block. #' @@ -42,7 +42,7 @@ NULL #' @title Block accessors #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' These functions are accessors of block fields in a vector. diff --git a/R/api_chunks.R b/R/api_chunks.R index 84890da02..632866a67 100644 --- a/R/api_chunks.R +++ b/R/api_chunks.R @@ -1,7 +1,7 @@ #' @title Chunks API #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' A chunk is a tibble of rectangular regions defining a matrix and diff --git a/R/api_classify.R b/R/api_classify.R index 3d816a314..9dfe9f9e9 100755 --- a/R/api_classify.R +++ b/R/api_classify.R @@ -2,7 +2,7 @@ #' @name .classify_tile #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description Classifies a block of data using multicores. It breaks @@ -251,7 +251,7 @@ #' @name .classify_tile #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description Classifies a block of data using multicores. It breaks @@ -427,7 +427,7 @@ #' @keywords internal #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param tile Input tile to read data. #' @param block Bounding box in (col, row, ncols, nrows). diff --git a/R/api_cluster.R b/R/api_cluster.R index a776039bb..f78384c2e 100644 --- a/R/api_cluster.R +++ b/R/api_cluster.R @@ -2,7 +2,7 @@ #' @name .cluster_validity #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Compute different cluster validity indices. This function needs #' as input a sits tibble with `cluster` column. @@ -38,7 +38,7 @@ #' @name .cluster_dendrogram #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description Cluster time series in hierarchical mode. @@ -95,7 +95,7 @@ #' @name .cluster_dendro_bestcut #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Reads a dendrogram object and its corresponding sits tibble and #' computes the best number of clusters that maximizes the adjusted Rand index. diff --git a/R/api_combine_predictions.R b/R/api_combine_predictions.R index d3ae9692d..34bcaa7fe 100644 --- a/R/api_combine_predictions.R +++ b/R/api_combine_predictions.R @@ -3,7 +3,7 @@ #' @name .comb #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param probs_cubes List of probability data cubes. #' @param uncert_cubes List of uncertainty cubes to be used as local weights. @@ -77,7 +77,7 @@ #' @name .comb_tiles #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param probs_tiles List of probability tiles. #' @param uncert_cubes List of uncertainty tiles. @@ -210,7 +210,7 @@ #' @name .comb_fn_average #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param cubes List of probability cubes. #' @param weights Weights for weigthed average @@ -236,7 +236,7 @@ #' @name .comb_fn_uncertainty #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param cubes List of probability cubes. #' @return A combined tile-band-block raster object diff --git a/R/api_comp.R b/R/api_comp.R index 8e48b08c6..6ea2fdb5e 100644 --- a/R/api_comp.R +++ b/R/api_comp.R @@ -1,7 +1,7 @@ #' @title Comparison functions #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' #' @description diff --git a/R/api_conf.R b/R/api_conf.R index 43d561f66..b492b49de 100644 --- a/R/api_conf.R +++ b/R/api_conf.R @@ -1,7 +1,7 @@ #' @title Set configuration parameters #' @name .conf_set_options #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param processing_bloat Estimated growth size of R memory relative #' to block size. @@ -963,7 +963,7 @@ #' @title Basic access config functions #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' These are basic functions to access config options. @@ -1005,7 +1005,7 @@ NULL #' @title Config functions eo_cube #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' These are syntactic sugar functions to easily access config options for @@ -1076,7 +1076,7 @@ NULL #' @title Config functions for derived_cube #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' These are syntactic sugar functions to easily access config options for @@ -1143,7 +1143,7 @@ NULL #' @title Band configuration accessors #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' These functions are read-only accessors of band_conf objects. A diff --git a/R/api_cube.R b/R/api_cube.R index af448784f..c693176b3 100644 --- a/R/api_cube.R +++ b/R/api_cube.R @@ -596,7 +596,7 @@ NULL #' @name .cube_s3class #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param cube input data cube #' @return class of the cube @@ -654,7 +654,7 @@ NULL #' @name .cube_ncols #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param cube input data cube #' @return integer @@ -676,7 +676,7 @@ NULL #' @name .cube_nrows #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param cube input data cube #' @return integer @@ -698,7 +698,7 @@ NULL #' @name .cube_source #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #'@param cube input data cube #' diff --git a/R/api_debug.R b/R/api_debug.R index 637a26bd5..b2087811e 100644 --- a/R/api_debug.R +++ b/R/api_debug.R @@ -1,7 +1,7 @@ #' @title Log functions #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' logs to a CSV file the following values: @@ -81,7 +81,7 @@ #' @title Log functions #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' When called without parameters retrieves the current debug flag value. diff --git a/R/api_factory.R b/R/api_factory.R index 29e1704ea..06443f0f6 100644 --- a/R/api_factory.R +++ b/R/api_factory.R @@ -1,6 +1,6 @@ #' @title Create a closure for calling functions with and without data #' @name .factory_function -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd diff --git a/R/api_file_info.R b/R/api_file_info.R index 8392487fd..374355854 100644 --- a/R/api_file_info.R +++ b/R/api_file_info.R @@ -1,6 +1,6 @@ #' @title File info API #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' Set of functions for handling `file_info`. diff --git a/R/api_mixture_model.R b/R/api_mixture_model.R index 5e149aac4..f88eb1eb7 100644 --- a/R/api_mixture_model.R +++ b/R/api_mixture_model.R @@ -2,7 +2,8 @@ #' @title Apply a mixture model to a set of time series #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param samples Time series #' @param em Endmembers bands @@ -25,7 +26,8 @@ #' @title Apply a mixture model to a raster feature #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param feature Raster feature where mixture is to be applied #' @param block Image block @@ -120,7 +122,8 @@ #' @title Read data to compute a mixture model #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param tile Raster tile #' @param block Image block diff --git a/R/api_ml_model.R b/R/api_ml_model.R index 0f768ff5a..72bc02999 100644 --- a/R/api_ml_model.R +++ b/R/api_ml_model.R @@ -1,7 +1,7 @@ #' @title Return machine learning model inside a closure #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param ml_model Closure that contains ML model and its environment #' @return ML model as specified by the original ML function @@ -17,7 +17,7 @@ #' @title Return statistics of ML model inside a closure (old version) #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param ml_model Closure that contains ML model and its environment #' @return Data statistics contained in the model closure @@ -28,7 +28,7 @@ #' @title Return statistics of ML model inside a closure (new version) #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param ml_model Closure that contains ML model and its environment #' @return Data statistics contained in the model closure @@ -39,7 +39,7 @@ #' @title Return samples of ML model inside a closure #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param ml_model Closure that contains ML model and its environment #' @return Samples used for ML construction .ml_samples <- function(ml_model) { @@ -48,7 +48,7 @@ #' @title Return class of ML model inside a closure #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param ml_model Closure that contains ML model and its environment #' @return ML model class .ml_class <- function(ml_model) { @@ -57,7 +57,7 @@ #' @title Return names of features used to train ML model #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param ml_model Closure that contains ML model and its environment #' @return Features used to build the model .ml_features_name <- function(ml_model) { @@ -67,7 +67,7 @@ #' @title Return names of bands used to train ML model #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param ml_model Closure that contains ML model and its environment #' @return Bands used to build the model .ml_bands <- function(ml_model) { @@ -76,7 +76,7 @@ #' @title Return labels of samples of used to train ML model #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param ml_model Closure that contains ML model and its environment #' @return Sample labels used to build the model .ml_labels <- function(ml_model) { @@ -85,7 +85,7 @@ #' @title Return codes of sample labels of used to train ML model #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param ml_model Closure that contains ML model and its environment #' @return Codes of sample labels used to build the model .ml_labels_code <- function(ml_model) { @@ -96,6 +96,8 @@ #' @title Clean GPU memory allocation #' @keywords internal #' @noRd +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @param ml_model Closure that contains ML model and its environment #' @return Called for side effects .ml_gpu_clean <- function(ml_model) { @@ -108,6 +110,7 @@ #' @title normalize the probability results #' @keywords internal +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param ml_model Closure that contains ML model and its environment #' @param values Values to be normalized @@ -134,6 +137,8 @@ #' @title Update multicores for models that do internal multiprocessing #' @keywords internal #' @noRd +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @param ml_model Closure that contains ML model and its environment #' @param multicores Current multicores setting #' @return Updated multicores @@ -151,6 +156,8 @@ #' @title Is the ML model a torch model? #' @keywords internal #' @noRd +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @param ml_model Closure that contains ML model and its environment #' @return TRUE/FALSE #' diff --git a/R/api_parallel.R b/R/api_parallel.R index dc819b419..305149272 100644 --- a/R/api_parallel.R +++ b/R/api_parallel.R @@ -2,7 +2,7 @@ #' @name .parallel_stop #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @return No value, called for side effect. #' .parallel_stop <- function() { @@ -22,7 +22,7 @@ #' @name .parallel_is_open #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @return No value, called for side effect. #' .parallel_is_open <- function() { @@ -40,7 +40,7 @@ #' @name .parallel_start #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param workers number of cluster to instantiate #' @param log a logical indicating if log files must be written @@ -90,7 +90,7 @@ #' @name .parallel_reset_node #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param worker_id id of the cluster work to be recreated #' @return No value, called for side effect. @@ -111,7 +111,7 @@ #' @keywords internal #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' These internal functions are a reimplementation of a fault tolerant @@ -173,6 +173,7 @@ #' @name .parallel_recv_one_result #' @keywords internal #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @return List with values and nodes .parallel_recv_one_result <- function() { # fault tolerant version of parallel:::recvOneData @@ -186,6 +187,7 @@ #' @rdname .parallel_cluster_apply #' @keywords internal #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @return No value, called for side effect. .parallel_cluster_apply <- function(x, fn, ..., pb = NULL) { # fault tolerant version of parallel::clusterApplyLB @@ -248,7 +250,7 @@ #' @name .parallel_map #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param x List to be passed to a function. #' @param fn Function to be applied to each list element. diff --git a/R/api_point.R b/R/api_point.R index 96f1fdeb3..87517f3e8 100644 --- a/R/api_point.R +++ b/R/api_point.R @@ -1,7 +1,7 @@ #' @title Points accessors #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' These functions are accessors of `point` fields in a object tibble. @@ -56,7 +56,7 @@ NULL #' @title Point API #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' A point represents a dimensionless geographical location in a given diff --git a/R/api_raster.R b/R/api_raster.R index 91d2fe94a..0bdd19a8e 100644 --- a/R/api_raster.R +++ b/R/api_raster.R @@ -9,7 +9,7 @@ #' @name .raster_check_block #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @return No value, called for side effects. .raster_check_block <- function(block) { # set caller to show in errors @@ -30,7 +30,7 @@ #' @name .raster_check_bbox #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @return No value, called for side effects. .raster_check_bbox <- function(bbox) { # set caller to show in errors @@ -50,7 +50,7 @@ #' @name .raster_gdal_datatype #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @return GDAL datatype associated to internal data type used by sits .raster_gdal_datatype <- function(data_type) { @@ -70,6 +70,7 @@ #' @title Match sits data types to GDAL data types #' @name .raster_gdal_datatypes #' @keywords internal +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param sits_names a \code{logical} indicating whether the types are supported #' by sits. @@ -93,7 +94,7 @@ #' @name .raster_get_values #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object #' @param ... additional parameters to be passed to raster package @@ -111,7 +112,7 @@ #' @name .raster_set_values #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object #' @param values Numeric matrix to copy to raster object @@ -127,7 +128,7 @@ #' @name .raster_set_na #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object #' @param na_value Numeric matrix to copy to raster object @@ -142,6 +143,8 @@ #' @title Get top values of a raster. #' #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@gmail.com} #' @keywords internal #' @noRd #' @description @@ -226,7 +229,7 @@ #' @name .raster_extract #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object #' @param xy numeric matrix with coordinates @@ -236,11 +239,12 @@ .raster_extract <- function(r_obj, xy, ...) { terra::extract(x = r_obj, y = xy, ...) } - +#' #' @title Return sample of values from terra object #' @keywords internal +#' @name .raster_sample #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster object #' @param size size of sample @@ -249,10 +253,11 @@ .raster_sample <- function(r_obj, size, ...) { terra::spatSample(r_obj, size, ...) } +#' @title Return block size of a raster #' @name .raster_file_blocksize #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object #' @@ -267,7 +272,7 @@ #' @name .raster_rast #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object to be cloned #' @param nlayers number of raster layers @@ -284,7 +289,7 @@ #' @name .raster_open_rast #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param file raster file to be opened #' @param ... additional parameters to be passed to raster package @@ -306,7 +311,7 @@ #' @name .raster_write_rast #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object to be written #' @param file file path to save raster file @@ -348,8 +353,7 @@ #' @name .raster_new_rast #' @keywords internal #' @noRd -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param nrows Number of rows in the raster #' @param ncols Number of columns in the raster @@ -415,7 +419,7 @@ #' @name .raster_read_rast #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param file path to raster file(s) to be read #' @param block a valid block with (\code{col}, \code{row}, @@ -462,7 +466,7 @@ #' @name .raster_crop #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj Raster package object to be written #' @param file File name to save cropped raster. @@ -544,7 +548,7 @@ #' @name .raster_crop_metadata #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object to be written #' @param block a valid block with (\code{col}, \code{row}, @@ -602,78 +606,111 @@ ) } -#' @title Raster package internal object properties -#' @name .raster_properties +#' @title Return number of rows in a raster +#' @name .raster_nrows #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object #' @param ... additional parameters to be passed to raster package #' -#' @return Raster object spatial properties +#' @return number of rows in raster object .raster_nrows <- function(r_obj, ...) { terra::nrow(x = r_obj) } +#' @title Return number of columns in a raster #' @name .raster_ncols +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return number of columns in a raster object .raster_ncols <- function(r_obj, ...) { terra::ncol(x = r_obj) } - +#' @title Return number of layers in a raster #' @name .raster_nlayers +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return number of layers in a raster object .raster_nlayers <- function(r_obj, ...) { terra::nlyr(x = r_obj) } - #' @name .raster_xmax +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return maximum x coord of raster object .raster_xmax <- function(r_obj, ...) { terra::xmax(x = r_obj) } #' @name .raster_xmin +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return minimum x coord of raster object .raster_xmin <- function(r_obj, ...) { terra::xmin(x = r_obj) } - #' @name .raster_ymax +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return maximum y coord of raster object .raster_ymax <- function(r_obj, ...) { terra::ymax(x = r_obj) } #' @name .raster_ymin +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return minimum y coord of raster object .raster_ymin <- function(r_obj, ...) { terra::ymin(x = r_obj) } - #' @name .raster_xres +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return resolution of raster object in x direction .raster_xres <- function(r_obj, ...) { terra::xres(x = r_obj) } - #' @name .raster_yres +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return resolution of raster object in y direction .raster_yres <- function(r_obj, ...) { terra::yres(x = r_obj) } #' @name .raster_scale +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return scale of values in raster object .raster_scale <- function(r_obj, ...) { # check value i <- 1 @@ -688,8 +725,12 @@ return(scale_factor) } #' @name .raster_crs +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return crs of raster object .raster_crs <- function(r_obj, ...) { crs <- suppressWarnings( terra::crs(x = r_obj, describe = TRUE) @@ -701,10 +742,13 @@ as.character(terra::crs(x = r_obj)) ) } - #' @name .raster_bbox +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return bounding box of raster object .raster_bbox <- function(r_obj, ..., block = NULL) { if (is.null(block)) { @@ -727,8 +771,12 @@ } #' @name .raster_res +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return resolution of raster object in x and y dimensions .raster_res <- function(r_obj, ...) { # return a named resolution res <- list( @@ -738,10 +786,13 @@ return(res) } - #' @name .raster_size +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd +#' @param r_obj raster package object +#' @param ... additional parameters to be passed to raster package +#' @return number of rows and cols of raster object .raster_size <- function(r_obj, ...) { # return a named size size <- list( @@ -751,12 +802,11 @@ return(size) } - #' @title Raster package internal frequency values function #' @name .raster_freq #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object to count values #' @param ... additional parameters to be passed to raster package @@ -785,7 +835,7 @@ #' @name .raster_summary #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' #' @param r_obj raster package object to count values @@ -799,7 +849,7 @@ #' @title Return col value given an X coordinate #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object #' @param x X coordinate in raster projection @@ -812,7 +862,7 @@ #' @name .raster_cell_from_rowcol #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object #' @param row row @@ -825,7 +875,7 @@ #' @title Return XY values given a cell #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object #' @param cell cell in raster object @@ -836,7 +886,7 @@ #' @title Return quantile value given an raster #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster package object #' @param quantile quantile value @@ -851,7 +901,7 @@ #' @title Return row value given an Y coordinate #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param r_obj raster object #' @param y Y coordinate in raster projection @@ -864,7 +914,7 @@ #' @name .raster_extract_polygons #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param r_obj terra raster object #' @param dissolve should the polygons be dissolved? #' @return A set of polygons @@ -877,7 +927,7 @@ #' @keywords internal #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Based on the R object associated to a raster object, #' determine its spatial parameters @@ -907,8 +957,20 @@ ) return(params) } - - +#' @title Template for creating a new raster +#' @name .raster_template +#' @keywords internal +#' @noRd +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' +#' @param base_file File to use for template +#' @param out_file Name of output file +#' @param nlayers Number of layers in output file +#' @param data_type Data type of output +#' @param missing_value Missing values in output file +#' +#' @return name of output file .raster_template <- function(base_file, out_file, nlayers, data_type, missing_value) { @@ -935,7 +997,7 @@ #' @name .raster_merge #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param out_files Output raster files path. #' @param base_file Raster file path to be used as template. If \code{NULL}, @@ -1037,6 +1099,18 @@ } return(invisible(out_files)) } +#' @title Clone an existing raster +#' @name .raster_clone +#' @keywords internal +#' @noRd +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' +#' @param file Raster file to use for template +#' @param nlayers Number of layers in output file +#' +#' @return cloned raster object +#' .raster_clone <- function(file, nlayers = NULL) { r_obj <- .raster_open_rast(file = file) @@ -1047,6 +1121,18 @@ return(r_obj) } +#' @title Check if raster is valid +#' @name .raster_is_valid +#' @keywords internal +#' @noRd +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' +#' @param files Raster files +#' @param output_dir Output file +#' +#' @return boolean value +#' .raster_is_valid <- function(files, output_dir = NULL) { # resume processing in case of failure if (!all(file.exists(files))) { @@ -1103,7 +1189,23 @@ # Return check check } - +#' @title Write block of raster +#' @name .raster_write_block +#' @keywords internal +#' @noRd +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' +#' @param files Raster files to written +#' @param block Block to be written to file +#' @param bbox Bounding box of block +#' @param values Values to be written +#' @param data_type Data type of output +#' @param missing_value Missing value for output file +#' @param crop_block Cropped area of block +#' +#' @return file paths +#' .raster_write_block <- function(files, block, bbox, values, data_type, missing_value, crop_block = NULL) { .check_set_caller(".raster_write_block") diff --git a/R/api_reclassify.R b/R/api_reclassify.R index 347cf49ac..6d4f64363 100644 --- a/R/api_reclassify.R +++ b/R/api_reclassify.R @@ -1,7 +1,7 @@ #' @title Reclassify tile #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param tile. Subset of a data cube #' @param mask Reclassification mask @@ -135,7 +135,7 @@ #' @title Reclassify function #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param rules Rules to be applied #' @param labels_cube Labels of input cube #' @param labels_mask Labels of reclassification mask @@ -201,7 +201,7 @@ #' @title Obtain new labels on reclassification operation #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param cube Labelled data cube #' @param rules Rules to be applied #' @return new labels to be applied to the cube diff --git a/R/api_samples.R b/R/api_samples.R index e82460b18..3397ea0c3 100644 --- a/R/api_samples.R +++ b/R/api_samples.R @@ -46,7 +46,7 @@ } #' @title Create partitions of a data set #' @name .samples_create_folds -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Alexandre Ywata, \email{alexandre.ywata@@ipea.gov.br} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @description Split a sits tibble into k groups, based on the label. diff --git a/R/api_smooth.R b/R/api_smooth.R index cd5390afe..3b138fabe 100644 --- a/R/api_smooth.R +++ b/R/api_smooth.R @@ -2,7 +2,7 @@ #' @name .smooth_tile #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param tile. Subset of a data cube containing one tile #' @param band Band to be processed diff --git a/R/api_space_time_operations.R b/R/api_space_time_operations.R index fbc8a8755..2f585b5c5 100644 --- a/R/api_space_time_operations.R +++ b/R/api_space_time_operations.R @@ -48,7 +48,7 @@ #' @title Spatial intersects #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' This function is based on sf::st_intersects(). It projects y @@ -77,7 +77,7 @@ #' @title Spatial within #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' This function is based on sf::st_within(). It projects y @@ -105,7 +105,7 @@ #' @title Spatial contains #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' #' @description diff --git a/R/api_tibble.R b/R/api_tibble.R index 3345b174f..970b7bcdb 100644 --- a/R/api_tibble.R +++ b/R/api_tibble.R @@ -37,7 +37,7 @@ #' @keywords internal #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' #' @description Create a tibble to store the results of predictions. @@ -75,7 +75,8 @@ #' @keywords internal #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' #' @description Create a tibble to store the results of predictions. #' @param data Tibble with the input data. @@ -286,6 +287,7 @@ } #' @title Returns a time series +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @name .tibble_time_series #' @noRd #' @param data a tibble with time series @@ -296,6 +298,9 @@ #' @title Split a sits tibble #' @name .tibble_samples_split +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @description Add a column to sits tibble indicating if a sample is diff --git a/R/api_tile.R b/R/api_tile.R index 92ac29405..8730ef571 100644 --- a/R/api_tile.R +++ b/R/api_tile.R @@ -1,7 +1,7 @@ #' @title Tile API #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' A cube consists of multiple tiles stacked together as rows of a diff --git a/R/api_torch.R b/R/api_torch.R index b0d455437..845a347a7 100644 --- a/R/api_torch.R +++ b/R/api_torch.R @@ -57,7 +57,7 @@ } #' @title Serialize torch model #' @name .torch_serialize_model -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @description Serializes a torch model to be used in parallel processing @@ -75,7 +75,7 @@ } #' @title Unserialize torch model #' @name .torch_unserialize_model -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @description Unserializes a torch model @@ -94,7 +94,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd @@ -140,7 +140,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd @@ -183,7 +183,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd @@ -226,7 +226,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd @@ -267,7 +267,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd @@ -311,7 +311,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd @@ -345,7 +345,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd @@ -383,7 +383,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd diff --git a/R/api_torch_psetae.R b/R/api_torch_psetae.R index 845f442b2..9c5d54e19 100644 --- a/R/api_torch_psetae.R +++ b/R/api_torch_psetae.R @@ -3,7 +3,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd @@ -101,7 +101,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd @@ -198,7 +198,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd @@ -384,7 +384,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd @@ -523,7 +523,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd @@ -595,7 +595,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd diff --git a/R/api_ts.R b/R/api_ts.R index 1152c0674..623c613c3 100644 --- a/R/api_ts.R +++ b/R/api_ts.R @@ -3,7 +3,7 @@ .ts_cols <- c("sample_id", "label") #' @title Check if data is a time series -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param x R object @@ -12,7 +12,7 @@ "Index" %in% names(x) && is.data.frame(x) } #' @title Check if data includes a time series -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param x R object @@ -21,7 +21,7 @@ "time_series" %in% names(x) && .is_ts(x[["time_series"]][[1]]) } #' @title Return the time series for a SITS tibble -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param x R object @@ -41,7 +41,7 @@ ts } #' @title Assigns a new time series for a SITS tibble -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param x R object @@ -58,7 +58,7 @@ x } #' @title Return the index of a time series -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param ts Time series @@ -67,7 +67,7 @@ .as_date(ts[["Index"]]) } #' @title Return the sample id of a time series -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param ts Time series @@ -76,7 +76,7 @@ ts[["sample_id"]] } #' @title Return the bands of a time series -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param ts Time series @@ -85,7 +85,7 @@ setdiff(colnames(ts), c(.ts_cols, "Index")) } #' @title Select the bands of a time series -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param ts Time series @@ -101,7 +101,7 @@ ts } #' @title Start date of a time series -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param ts Time series @@ -113,7 +113,7 @@ )))) } #' @title Minimum date of a time series -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param ts Time series @@ -122,7 +122,7 @@ min(.ts_index(ts)) } #' @title End date of a time series -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param ts Time series @@ -134,7 +134,7 @@ )))) } #' @title Minimum date of a time series -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param ts Time series @@ -143,7 +143,7 @@ max(.ts_index(ts)) } #' @title Filter time series by interval -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param ts Time series @@ -163,7 +163,7 @@ ts } #' @title Values of a time series -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param ts Time series @@ -178,7 +178,7 @@ ts[bands] } #' @title Assigns new values to a time-series -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param ts Time series diff --git a/R/api_utils.R b/R/api_utils.R index f1a0117c2..431d8f39b 100644 --- a/R/api_utils.R +++ b/R/api_utils.R @@ -1,7 +1,7 @@ #' @title Data type functions #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' These are a short named version of data type functions. @@ -123,7 +123,7 @@ NULL #' @title Handling error #' @noRd #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' This is a implementation of \code{tryCatch()}. It diff --git a/R/api_values.R b/R/api_values.R index 2221d46c7..648716f80 100644 --- a/R/api_values.R +++ b/R/api_values.R @@ -1,7 +1,7 @@ #' @title Return the values of a set of time series #' @name .values_ts #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description This function returns the values of a sits tibble #' (according a specified format). diff --git a/R/api_variance.R b/R/api_variance.R index 99e390ba3..09f3389c7 100644 --- a/R/api_variance.R +++ b/R/api_variance.R @@ -1,7 +1,7 @@ #' @title Calculate the variance of a tile #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Takes a probability cube and estimate the local variance #' of the logit of the probability, @@ -107,7 +107,7 @@ #' @title Calculate the variance of a probability cube #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Takes a probability cube and estimate the local variance #' of the logit of the probability, @@ -160,7 +160,7 @@ #' @title Calculate the variance smoothing function #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param window_size Size of the neighborhood. #' @param neigh_fraction Fraction of neighbors with highest probability diff --git a/R/api_vector_info.R b/R/api_vector_info.R index 215e57ebe..1feb5119a 100644 --- a/R/api_vector_info.R +++ b/R/api_vector_info.R @@ -1,6 +1,6 @@ #' @title Vector info API #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' #' @description diff --git a/R/sits_accuracy.R b/R/sits_accuracy.R index b5000b35f..30ee31ff7 100644 --- a/R/sits_accuracy.R +++ b/R/sits_accuracy.R @@ -1,6 +1,6 @@ #' @title Assess classification accuracy (area-weighted method) #' @name sits_accuracy -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} #' @description This function calculates the accuracy of the classification #' result. For a set of time series, it creates a confusion matrix and then diff --git a/R/sits_add_base_cube.R b/R/sits_add_base_cube.R index 1c3e2ab76..e44f2ae70 100644 --- a/R/sits_add_base_cube.R +++ b/R/sits_add_base_cube.R @@ -1,5 +1,7 @@ #' @title Add base maps to a time series data cube #' @name sits_add_base_cube +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description This function add base maps to time series data cube. diff --git a/R/sits_apply.R b/R/sits_apply.R index 617d7e520..b76d5840a 100644 --- a/R/sits_apply.R +++ b/R/sits_apply.R @@ -2,7 +2,7 @@ #' #' @name sits_apply #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' diff --git a/R/sits_bands.R b/R/sits_bands.R index 86159b4a0..bd8d6a986 100644 --- a/R/sits_bands.R +++ b/R/sits_bands.R @@ -3,7 +3,7 @@ #' @name sits_bands #' #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' Finds the names of the bands of a set of time series or of a data cube diff --git a/R/sits_bayts.R b/R/sits_bayts.R index 32cb75270..a7d7e5b50 100644 --- a/R/sits_bayts.R +++ b/R/sits_bayts.R @@ -2,8 +2,6 @@ #' @name sits_bayts #' @author Felipe Carvalho, \email{lipecaso@@gmail.com} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} #' #' @description #' This function implements the algorithm described by Johanes Reiche diff --git a/R/sits_bbox.R b/R/sits_bbox.R index 8b4332bde..1b30a25cc 100644 --- a/R/sits_bbox.R +++ b/R/sits_bbox.R @@ -3,7 +3,7 @@ #' @name sits_bbox #' #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Obtain a vector of limits (either on lat/long for time series #' or in projection coordinates in the case of cubes) diff --git a/R/sits_classify.R b/R/sits_classify.R index 96ac39f83..4d417d1cf 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -1,7 +1,9 @@ #' @title Classify time series or data cubes #' @name sits_classify -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Felipe Carvalho, \email{lipecaso@@gmail.com} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description #' This function classifies a set of time series or data cube given diff --git a/R/sits_cluster.R b/R/sits_cluster.R index c0e352beb..e47b20fe2 100644 --- a/R/sits_cluster.R +++ b/R/sits_cluster.R @@ -1,6 +1,6 @@ #' @title Find clusters in time series samples #' @name sits_cluster_dendro -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description These functions support hierarchical agglomerative clustering in #' sits. They provide support from creating a dendrogram and using it for @@ -122,7 +122,7 @@ sits_cluster_dendro <- function(samples, #' #' @title Show label frequency in each cluster produced by dendrogram analysis #' @name sits_cluster_frequency -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param samples Tibble with input set of time series with additional #' cluster information produced #' by \code{link[sits]{sits_cluster_dendro}}. @@ -152,7 +152,7 @@ sits_cluster_frequency <- function(samples) { #' @title Removes labels that are minority in each cluster. #' @name sits_cluster_clean -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @description Takes a tibble with time series #' that has an additional `cluster` produced by #' \code{link[sits]{sits_cluster_dendro()}} diff --git a/R/sits_combine_predictions.R b/R/sits_combine_predictions.R index efd17b022..2e4f03803 100644 --- a/R/sits_combine_predictions.R +++ b/R/sits_combine_predictions.R @@ -3,7 +3,7 @@ #' @name sits_combine_predictions #' #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param cubes List of probability data cubes (class "probs_cube") #' @param type Method to measure uncertainty. One of "average" or diff --git a/R/sits_config.R b/R/sits_config.R index 32b6de06b..8aa480f89 100644 --- a/R/sits_config.R +++ b/R/sits_config.R @@ -1,6 +1,6 @@ #' @title Configure parameters for sits package #' @name sits_config -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description These functions load and show sits configurations. #' diff --git a/R/sits_cube.R b/R/sits_cube.R index 4a8372d90..9f775d9d2 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -1,5 +1,9 @@ #' @title Create data cubes from image collections #' @name sits_cube +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Creates a data cube based on spatial and temporal restrictions #' in collections available in cloud services or local repositories. diff --git a/R/sits_cube_copy.R b/R/sits_cube_copy.R index a2b780073..f08c8bdf7 100644 --- a/R/sits_cube_copy.R +++ b/R/sits_cube_copy.R @@ -1,5 +1,7 @@ #' @title Copy the images of a cube to a local directory #' @name sits_cube_copy +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @description #' #' This function downloads the images of a cube in parallel. diff --git a/R/sits_detect_change.R b/R/sits_detect_change.R index 45d4678e3..b401106f7 100644 --- a/R/sits_detect_change.R +++ b/R/sits_detect_change.R @@ -1,7 +1,6 @@ #' @title Detect changes in time series #' @name sits_detect_change #' -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' diff --git a/R/sits_detect_change_method.R b/R/sits_detect_change_method.R index 9c29b5c84..b4a6e0d61 100644 --- a/R/sits_detect_change_method.R +++ b/R/sits_detect_change_method.R @@ -1,8 +1,8 @@ #' @title Create detect change method. #' @name sits_detect_change_method #' -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' #' @description Prepare detection change method. Currently, sits supports the #' following methods: 'dtw' (see \code{\link[sits]{sits_dtw}}) diff --git a/R/sits_dtw.R b/R/sits_dtw.R index bfdb44f4c..6d3bfb722 100644 --- a/R/sits_dtw.R +++ b/R/sits_dtw.R @@ -3,8 +3,6 @@ #' #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} #' #' @description Create a Dynamic Time Warping (DTW) method for the #' \code{\link[sits]{sits_detect_change_method}}. diff --git a/R/sits_factory.R b/R/sits_factory.R index b5bd57bc1..6d77d40c3 100644 --- a/R/sits_factory.R +++ b/R/sits_factory.R @@ -1,6 +1,6 @@ #' @title Create a closure for calling functions with and without data #' @name sits_factory_function -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description This function implements the factory method pattern. diff --git a/R/sits_filters.R b/R/sits_filters.R index 688de6676..807ff3e84 100644 --- a/R/sits_filters.R +++ b/R/sits_filters.R @@ -30,7 +30,7 @@ sits_filter <- function(data, filter = sits_whittaker()) { #' @title Filter time series with whittaker filter #' @name sits_whittaker #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @@ -87,7 +87,7 @@ sits_whittaker <- function(data = NULL, lambda = 0.5) { #' @title Filter time series with Savitzky-Golay filter #' @name sits_sgolay #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' diff --git a/R/sits_geo_dist.R b/R/sits_geo_dist.R index c34de37a5..7510063ea 100644 --- a/R/sits_geo_dist.R +++ b/R/sits_geo_dist.R @@ -3,7 +3,7 @@ #' @name sits_geo_dist #' #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' diff --git a/R/sits_get_class.R b/R/sits_get_class.R index c689222ad..1b02fda7b 100644 --- a/R/sits_get_class.R +++ b/R/sits_get_class.R @@ -1,6 +1,6 @@ #' @title Get values from classified maps #' @name sits_get_class -#' @author Gilberto Camara +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description Given a set of lat/long locations and a classified cube, #' retrieve the class of each point. diff --git a/R/sits_get_data.R b/R/sits_get_data.R index 0c7d2b4ef..52c79cfc1 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -1,6 +1,10 @@ #' @title Get time series from data cubes and cloud services #' @name sits_get_data -#' @author Gilberto Camara +#' +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Retrieve a set of time series from a data cube or from #' a time series service. Data cubes and puts it in a "sits tibble". diff --git a/R/sits_get_probs.R b/R/sits_get_probs.R index 34eb4b3ad..87cb14551 100644 --- a/R/sits_get_probs.R +++ b/R/sits_get_probs.R @@ -1,6 +1,7 @@ #' @title Get values from probability maps #' @name sits_get_probs -#' @author Gilberto Camara +#' +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description Given a set of lat/long locations and a probability cube, #' retrieve the prob values of each point. diff --git a/R/sits_label_classification.R b/R/sits_label_classification.R index 0525a7f84..1ac0b0022 100644 --- a/R/sits_label_classification.R +++ b/R/sits_label_classification.R @@ -1,7 +1,7 @@ #' @title Build a labelled image from a probability cube #' #' @name sits_label_classification -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{felipe.souza@@inpe.br} #' #' @description Takes a set of classified raster layers with probabilities, diff --git a/R/sits_labels.R b/R/sits_labels.R index fe462159a..fda2295a4 100644 --- a/R/sits_labels.R +++ b/R/sits_labels.R @@ -1,6 +1,6 @@ #' @title Get labels associated to a data set #' @name sits_labels -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @description Finds labels in a sits tibble or data cube #' #' @param data Time series (tibble of class "sits"), @@ -93,7 +93,7 @@ sits_labels.default <- function(data) { } #' @title Change the labels of a set of time series #' @name `sits_labels<-` -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Given a sits tibble with a set of labels, renames the labels #' to the specified in value. @@ -188,7 +188,7 @@ sits_labels.default <- function(data) { } #' @title Inform label distribution of a set of time series #' @name sits_labels_summary -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @description Describes labels in a sits tibble #' #' @param data Data.frame - Valid sits tibble diff --git a/R/sits_lighttae.R b/R/sits_lighttae.R index 20a9649b6..c94dd2dde 100644 --- a/R/sits_lighttae.R +++ b/R/sits_lighttae.R @@ -2,7 +2,7 @@ #' @name sits_lighttae #' #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' #' @description Implementation of Light Temporal Attention Encoder (L-TAE) diff --git a/R/sits_machine_learning.R b/R/sits_machine_learning.R index 5992ae653..0244004c5 100644 --- a/R/sits_machine_learning.R +++ b/R/sits_machine_learning.R @@ -2,7 +2,7 @@ #' @name sits_rfor #' #' @author Alexandre Ywata de Carvalho, \email{alexandre.ywata@@ipea.gov.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description Use Random Forest algorithm to classify samples. @@ -106,7 +106,7 @@ sits_rfor <- function(samples = NULL, num_trees = 100, mtry = NULL, ...) { #' @title Train support vector machine models #' @name sits_svm #' @author Alexandre Ywata de Carvalho, \email{alexandre.ywata@@ipea.gov.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description This function receives a tibble with a set of attributes X @@ -226,7 +226,6 @@ sits_svm <- function(samples = NULL, formula = sits_formula_linear(), } #' @title Train extreme gradient boosting models #' @name sits_xgboost -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description This function uses the extreme gradient boosting algorithm. @@ -368,7 +367,7 @@ sits_xgboost <- function(samples = NULL, learning_rate = 0.15, #' @name sits_formula_logref #' #' @author Alexandre Ywata de Carvalho, \email{alexandre.ywata@@ipea.gov.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description A function to be used as a symbolic description #' of some fitting models such as svm and random forest. @@ -436,7 +435,7 @@ sits_formula_logref <- function(predictors_index = -2:0) { #' @name sits_formula_linear #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @author Alexandre Ywata de Carvalho, \email{alexandre.ywata@@ipea.gov.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Provides a symbolic description of a fitting model. #' Tells the model to do a linear transformation of the input values. diff --git a/R/sits_merge.R b/R/sits_merge.R index eed286de0..9da19c024 100644 --- a/R/sits_merge.R +++ b/R/sits_merge.R @@ -1,6 +1,7 @@ #' @title Merge two data sets (time series or cubes) #' @name sits_merge -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description To merge two series, we consider that they contain different #' attributes but refer to the same data cube and spatiotemporal location. diff --git a/R/sits_mixture_model.R b/R/sits_mixture_model.R index d94475c74..5ddc63402 100644 --- a/R/sits_mixture_model.R +++ b/R/sits_mixture_model.R @@ -4,9 +4,7 @@ #' #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Alber Sanchez, \email{alber.ipia@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Create a multiple endmember spectral mixture analyses fractions #' images. We use the non-negative least squares (NNLS) solver to calculate the diff --git a/R/sits_model_export.R b/R/sits_model_export.R index 306057c65..193a3c555 100644 --- a/R/sits_model_export.R +++ b/R/sits_model_export.R @@ -1,6 +1,6 @@ #' @title Export classification models #' @name sits_model_export -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Given a trained machine learning or deep learning model, #' exports the model as an object for further exploration outside the diff --git a/R/sits_mosaic.R b/R/sits_mosaic.R index 46fc05269..d002e9ffe 100644 --- a/R/sits_mosaic.R +++ b/R/sits_mosaic.R @@ -2,7 +2,8 @@ #' @name sits_mosaic #' #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description Creates a mosaic of all tiles of a sits cube. #' Mosaics can be created from EO cubes and derived cubes. diff --git a/R/sits_patterns.R b/R/sits_patterns.R index 191236b23..fabd4ce6f 100644 --- a/R/sits_patterns.R +++ b/R/sits_patterns.R @@ -2,7 +2,7 @@ #' @name sits_patterns #' @author Victor Maus, \email{vwmaus1@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description This function takes a set of time series samples as input #' estimates a set of patterns. The patterns are calculated using a GAM model. diff --git a/R/sits_plot.R b/R/sits_plot.R index 9f5506b18..48e74c9d4 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -1976,8 +1976,8 @@ plot.xgb_model <- function(x, ..., } #' @title Plot Torch (deep learning) model #' @name plot.torch_model -#' @author Felipe Souza, \email{lipecaso@@gmail.com} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Felipe Carvalho, \email{lipecaso@@gmail.com} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} #' #' @description Plots a deep learning model developed using torch. @@ -2065,7 +2065,7 @@ plot.torch_model <- function(x, y, ...) { #' #' @name plot.geo_distances #' @author Felipe Souza, \email{lipecaso@@gmail.com} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} #' #' @description Make a kernel density plot of samples distances. @@ -2127,7 +2127,7 @@ plot.geo_distances <- function(x, y, ...) { #' @title Plot a dendrogram cluster #' @name plot.sits_cluster -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Plot a dendrogram #' diff --git a/R/sits_predictors.R b/R/sits_predictors.R index 8d7d6156e..cc528692a 100644 --- a/R/sits_predictors.R +++ b/R/sits_predictors.R @@ -1,6 +1,7 @@ #' @title Obtain predictors for time series samples #' @name sits_predictors #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' #' @description Predictors are X-Y values required for machine learning #' algorithms, organized as a data table where each row corresponds #' to a training sample. The first two columns of the predictors table diff --git a/R/sits_reclassify.R b/R/sits_reclassify.R index 59169dd8f..ce2b51563 100644 --- a/R/sits_reclassify.R +++ b/R/sits_reclassify.R @@ -1,7 +1,7 @@ #' @title Reclassify a classified cube #' @name sits_reclassify #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description diff --git a/R/sits_reduce.R b/R/sits_reduce.R index d856f1329..31e6e0a50 100644 --- a/R/sits_reduce.R +++ b/R/sits_reduce.R @@ -3,8 +3,7 @@ #' @name sits_reduce #' #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description #' Apply a temporal reduction from a named expression in cube or sits tibble. diff --git a/R/sits_regularize.R b/R/sits_regularize.R index 806ce39ca..6f4b68438 100644 --- a/R/sits_regularize.R +++ b/R/sits_regularize.R @@ -1,5 +1,6 @@ #' @title Build a regular data cube from an irregular one -#' +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @name sits_regularize #' #' @description Produces regular data cubes for analysis-ready data (ARD) diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R index d5634361a..1ca3922ca 100644 --- a/R/sits_sample_functions.R +++ b/R/sits_sample_functions.R @@ -1,6 +1,6 @@ #' @title Sample a percentage of a time series #' @name sits_sample -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Takes a sits tibble with different labels and #' returns a new tibble. For a given field as a group criterion, @@ -8,7 +8,7 @@ #' of the total number of samples per group. #' If frac > 1 , all sampling will be done with replacement. #' -#' @param data Sits time series tibble (class = "sits") +#' @param data Sits time series tibble #' @param frac Percentage of samples to extract #' (range: 0.0 to 2.0, default = 0.2) #' @param oversample Logical: oversample classes with small number of samples? @@ -53,7 +53,7 @@ sits_sample <- function(data, #' @name sits_uncertainty_sampling #' #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @@ -215,7 +215,7 @@ sits_uncertainty_sampling <- function(uncert_cube, #' @name sits_confidence_sampling #' #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' diff --git a/R/sits_segmentation.R b/R/sits_segmentation.R index 925a76441..dceaeb842 100644 --- a/R/sits_segmentation.R +++ b/R/sits_segmentation.R @@ -2,8 +2,9 @@ #' @name sits_segment #' #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description #' Apply a spatial-temporal segmentation on a data cube based on a user defined @@ -166,9 +167,9 @@ sits_segment <- function(cube, #' @title Segment an image using SLIC #' @name sits_slic #' -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description #' Apply a segmentation on a data cube based on the \code{supercells} package. diff --git a/R/sits_select.R b/R/sits_select.R index 94ea189f3..20519120e 100644 --- a/R/sits_select.R +++ b/R/sits_select.R @@ -1,6 +1,6 @@ -#' @title Filter bands on a data set (tibble or cube) +#' @title Filter a data set (tibble or cube) for bands, tiles, and dates #' @name sits_select -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param data Tibble with time series or data cube. #' @param bands Character vector with the names of the bands. diff --git a/R/sits_smooth.R b/R/sits_smooth.R index 81d2e8b2c..0865c03bb 100644 --- a/R/sits_smooth.R +++ b/R/sits_smooth.R @@ -3,7 +3,7 @@ #' @name sits_smooth #' #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Takes a set of classified raster layers with probabilities, #' whose metadata is]created by \code{\link[sits]{sits_cube}}, diff --git a/R/sits_som.R b/R/sits_som.R index 6cabf0a10..d050fc07b 100644 --- a/R/sits_som.R +++ b/R/sits_som.R @@ -1,8 +1,9 @@ -#' @title Use SOM for quality analysis of time series samples -#' @name sits_som +#' @title Build a SOM for quality analysis of time series samples +#' @name sits_som_map #' #' @author Lorena Alves, \email{lorena.santos@@inpe.br} #' @author Karine Ferreira. \email{karine.ferreira@@inpe.br} +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description These function use self-organized maps to perform #' quality analysis in satellite image time series @@ -205,6 +206,25 @@ sits_som_map <- function(data, #' @title Cleans the samples based on SOM map information #' @name sits_som_clean_samples +#' @author Lorena Alves, \email{lorena.santos@@inpe.br} +#' @author Karine Ferreira. \email{karine.ferreira@@inpe.br} +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @description +#' \code{sits_som_clean_samples()} evaluates the quality of the samples +#' based on the results of the SOM map. The algorithm identifies noisy samples, +#' using `prior_threshold` for the prior probability +#' and `posterior_threshold` for the posterior probability. +#' Each sample receives an evaluation tag, according to the following rule: +#' (a) If the prior probability is < `prior_threshold`, the sample is tagged +#' as "remove"; +#' (b) If the prior probability is >= `prior_threshold` and the posterior +#' probability is >=`posterior_threshold`, the sample is tagged as "clean"; +#' (c) If the prior probability is >= `posterior_threshold` and +#' the posterior probability is < `posterior_threshold`, the sample is tagged as +#' "analyze" for further inspection. +#' The user can define which tagged samples will be returned using the "keep" +#' parameter, with the following options: "clean", "analyze", "remove". +#' #' @param som_map Returned by \code{\link[sits]{sits_som_map}}. #' @param prior_threshold Threshold of conditional probability #' (frequency of samples assigned to the @@ -373,6 +393,8 @@ sits_som_evaluate_cluster <- function(som_map) { } #' @title Evaluate cluster #' @name sits_som_remove_samples +#' @author Lorena Alves, \email{lorena.santos@@inpe.br} +#' @author Karine Ferreira. \email{karine.ferreira@@inpe.br} #' @description #' Remove samples from a given class inside a neuron of another class #' @param som_map A SOM map produced by the som_map() function diff --git a/R/sits_summary.R b/R/sits_summary.R index 3379ff8b4..510dd5c12 100644 --- a/R/sits_summary.R +++ b/R/sits_summary.R @@ -2,7 +2,7 @@ #' @method summary sits #' @name summary.sits #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Felipe Souza, \email{felipe.souza@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @description This is a generic function. Parameters depend on the specific #' type of input. #' diff --git a/R/sits_tae.R b/R/sits_tae.R index 52ba7d4f8..38dffc502 100644 --- a/R/sits_tae.R +++ b/R/sits_tae.R @@ -3,7 +3,8 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Souza, \email{lipecaso@@gmail.com} #' #' @description Implementation of Temporal Attention Encoder (TAE) #' for satellite image time series classification. diff --git a/R/sits_tempcnn.R b/R/sits_tempcnn.R index 28245b1ef..a2d26907e 100644 --- a/R/sits_tempcnn.R +++ b/R/sits_tempcnn.R @@ -3,7 +3,7 @@ #' #' @author Charlotte Pelletier, \email{charlotte.pelletier@@univ-ubs.fr} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{lipecaso@@gmail.com} #' #' @description Use a TempCNN algorithm to classify data, which has diff --git a/R/sits_train.R b/R/sits_train.R index 4aa5be786..5471240a2 100644 --- a/R/sits_train.R +++ b/R/sits_train.R @@ -1,7 +1,7 @@ #' @title Train classification models #' @name sits_train #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @author Alexandre Ywata de Carvalho, \email{alexandre.ywata@@ipea.gov.br} #' diff --git a/R/sits_tuning.R b/R/sits_tuning.R index f2b47d657..53df60fc7 100644 --- a/R/sits_tuning.R +++ b/R/sits_tuning.R @@ -1,7 +1,7 @@ #' @title Tuning machine learning models hyper-parameters #' @name sits_tuning #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @description #' Machine learning models use stochastic gradient descent (SGD) techniques to #' find optimal solutions. To perform SGD, models use optimization diff --git a/R/sits_uncertainty.R b/R/sits_uncertainty.R index 9635b8e62..3e5650108 100644 --- a/R/sits_uncertainty.R +++ b/R/sits_uncertainty.R @@ -3,7 +3,7 @@ #' @name sits_uncertainty #' #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} #' #' @param cube Probability data cube. diff --git a/R/sits_validate.R b/R/sits_validate.R index d1d0ac093..375d07ecd 100644 --- a/R/sits_validate.R +++ b/R/sits_validate.R @@ -1,6 +1,6 @@ #' @title Cross-validate time series samples #' @name sits_kfold_validate -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description Splits the set of time series into training and validation and @@ -133,7 +133,7 @@ sits_kfold_validate <- function(samples, } #' @title Validate time series samples #' @name sits_validate -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description diff --git a/R/sits_variance.R b/R/sits_variance.R index 721c04f2e..c9bd3fcfb 100644 --- a/R/sits_variance.R +++ b/R/sits_variance.R @@ -1,7 +1,7 @@ #' @title Calculate the variance of a probability cube #' #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Takes a probability cube and estimate the local variance #' of the logit of the probability, diff --git a/man/plot.geo_distances.Rd b/man/plot.geo_distances.Rd index 6450b6efe..abd90d38a 100644 --- a/man/plot.geo_distances.Rd +++ b/man/plot.geo_distances.Rd @@ -47,7 +47,7 @@ DOI: 10.1038/s41467-022-29838-9. \author{ Felipe Souza, \email{lipecaso@gmail.com} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Alber Sanchez, \email{alber.ipia@inpe.br} } diff --git a/man/plot.sits_cluster.Rd b/man/plot.sits_cluster.Rd index 4853ecdfd..d227cf797 100644 --- a/man/plot.sits_cluster.Rd +++ b/man/plot.sits_cluster.Rd @@ -32,5 +32,5 @@ if (sits_run_examples()) { } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/plot.torch_model.Rd b/man/plot.torch_model.Rd index 13402a335..753820abe 100644 --- a/man/plot.torch_model.Rd +++ b/man/plot.torch_model.Rd @@ -37,9 +37,9 @@ if (sits_run_examples()) { } } \author{ -Felipe Souza, \email{lipecaso@gmail.com} +Felipe Carvalho, \email{lipecaso@gmail.com} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Alber Sanchez, \email{alber.ipia@inpe.br} } diff --git a/man/sits-package.Rd b/man/sits-package.Rd index 3cdcd8a68..d53ac1c03 100644 --- a/man/sits-package.Rd +++ b/man/sits-package.Rd @@ -32,7 +32,7 @@ Useful links: Authors: \itemize{ - \item Rolf Simoes \email{rolf.simoes@inpe.br} + \item Rolf Simoes \email{rolfsimoes@gmail.com} \item Felipe Souza \email{felipe.carvalho@inpe.br} \item Felipe Carlos \email{efelipecarlos@gmail.com} } diff --git a/man/sits_accuracy.Rd b/man/sits_accuracy.Rd index a41d7f518..ee98d123e 100644 --- a/man/sits_accuracy.Rd +++ b/man/sits_accuracy.Rd @@ -121,7 +121,7 @@ Remote Sensing of Environment, 148, pp. 42-57. National forest monitoring assessment working paper No.46/E, 2016. } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Alber Sanchez, \email{alber.ipia@inpe.br} } diff --git a/man/sits_add_base_cube.Rd b/man/sits_add_base_cube.Rd index 1bfc9fc1c..224d062f9 100644 --- a/man/sits_add_base_cube.Rd +++ b/man/sits_add_base_cube.Rd @@ -63,5 +63,9 @@ if (sits_run_examples()) { } } \author{ +Felipe Carlos, \email{efelipecarlos@gmail.com} + +Felipe Carvalho, \email{felipe.carvalho@inpe.br} + Gilberto Camara, \email{gilberto.camara@inpe.br} } diff --git a/man/sits_apply.Rd b/man/sits_apply.Rd index 31c56df24..cd019b33f 100644 --- a/man/sits_apply.Rd +++ b/man/sits_apply.Rd @@ -134,7 +134,7 @@ if (sits_run_examples()) { } } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Felipe Carvalho, \email{felipe.carvalho@inpe.br} diff --git a/man/sits_bands.Rd b/man/sits_bands.Rd index e4c5051ba..8ab153853 100644 --- a/man/sits_bands.Rd +++ b/man/sits_bands.Rd @@ -71,5 +71,5 @@ if (sits_run_examples()) { \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_bbox.Rd b/man/sits_bbox.Rd index 7b1a6b788..e64478e45 100644 --- a/man/sits_bbox.Rd +++ b/man/sits_bbox.Rd @@ -49,5 +49,5 @@ if (sits_run_examples()) { \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_classify.Rd b/man/sits_classify.Rd index d9030f75a..589429147 100644 --- a/man/sits_classify.Rd +++ b/man/sits_classify.Rd @@ -268,7 +268,11 @@ if (sits_run_examples()) { } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Gilberto Camara, \email{gilberto.camara@inpe.br} + +Felipe Carvalho, \email{lipecaso@gmail.com} + +Felipe Carlos, \email{efelipecarlos@gmail.com} } diff --git a/man/sits_cluster_clean.Rd b/man/sits_cluster_clean.Rd index 6129743c8..24fd46547 100644 --- a/man/sits_cluster_clean.Rd +++ b/man/sits_cluster_clean.Rd @@ -31,5 +31,5 @@ if (sits_run_examples()) { } } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_cluster_dendro.Rd b/man/sits_cluster_dendro.Rd index 891ecee17..cc1384354 100644 --- a/man/sits_cluster_dendro.Rd +++ b/man/sits_cluster_dendro.Rd @@ -80,5 +80,5 @@ if (sits_run_examples()) { "dtwclust" package (https://CRAN.R-project.org/package=dtwclust) } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_cluster_frequency.Rd b/man/sits_cluster_frequency.Rd index a1db3c4a8..9ee348881 100644 --- a/man/sits_cluster_frequency.Rd +++ b/man/sits_cluster_frequency.Rd @@ -26,5 +26,5 @@ if (sits_run_examples()) { } } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_combine_predictions.Rd b/man/sits_combine_predictions.Rd index 37460fb34..b2a9bdd93 100644 --- a/man/sits_combine_predictions.Rd +++ b/man/sits_combine_predictions.Rd @@ -106,5 +106,5 @@ if (sits_run_examples()) { \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_confidence_sampling.Rd b/man/sits_confidence_sampling.Rd index b02db19d5..18bcad54a 100644 --- a/man/sits_confidence_sampling.Rd +++ b/man/sits_confidence_sampling.Rd @@ -79,7 +79,7 @@ if (sits_run_examples()) { \author{ Alber Sanchez, \email{alber.ipia@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Felipe Carvalho, \email{felipe.carvalho@inpe.br} diff --git a/man/sits_config.Rd b/man/sits_config.Rd index f8044e6a3..5a3b0cf87 100644 --- a/man/sits_config.Rd +++ b/man/sits_config.Rd @@ -38,5 +38,5 @@ yaml_user_file <- system.file("extdata/config_user_example.yml", sits_config(config_user_file = yaml_user_file) } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_cube.Rd b/man/sits_cube.Rd index feccf13f5..38fa66a57 100644 --- a/man/sits_cube.Rd +++ b/man/sits_cube.Rd @@ -479,3 +479,12 @@ if (sits_run_examples()) { } } +\author{ +Felipe Carlos, \email{efelipecarlos@gmail.com} + +Felipe Carvalho, \email{felipe.carvalho@inpe.br} + +Gilberto Camara, \email{gilberto.camara@inpe.br} + +Rolf Simoes, \email{rolfsimoes@gmail.com} +} diff --git a/man/sits_cube_copy.Rd b/man/sits_cube_copy.Rd index a5f22d5ff..5892a2ab3 100644 --- a/man/sits_cube_copy.Rd +++ b/man/sits_cube_copy.Rd @@ -78,3 +78,8 @@ if (sits_run_examples()) { } } +\author{ +Felipe Carlos, \email{efelipecarlos@gmail.com} + +Felipe Carvalho, \email{felipe.carvalho@inpe.br} +} diff --git a/man/sits_factory_function.Rd b/man/sits_factory_function.Rd index 042067cb3..e72ea1170 100644 --- a/man/sits_factory_function.Rd +++ b/man/sits_factory_function.Rd @@ -82,7 +82,7 @@ if (sits_run_examples()) { } } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Gilberto Camara, \email{gilberto.camara@inpe.br} } diff --git a/man/sits_formula_linear.Rd b/man/sits_formula_linear.Rd index a032e53b4..37909b01e 100644 --- a/man/sits_formula_linear.Rd +++ b/man/sits_formula_linear.Rd @@ -42,5 +42,5 @@ Gilberto Camara, \email{gilberto.camara@inpe.br} Alexandre Ywata de Carvalho, \email{alexandre.ywata@ipea.gov.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_formula_logref.Rd b/man/sits_formula_logref.Rd index 134ae4ca6..f0b407f16 100644 --- a/man/sits_formula_logref.Rd +++ b/man/sits_formula_logref.Rd @@ -42,5 +42,5 @@ if (sits_run_examples()) { \author{ Alexandre Ywata de Carvalho, \email{alexandre.ywata@ipea.gov.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_geo_dist.Rd b/man/sits_geo_dist.Rd index 57f31a9dc..5a43b590d 100644 --- a/man/sits_geo_dist.Rd +++ b/man/sits_geo_dist.Rd @@ -51,7 +51,7 @@ https://doi.org/10.1038/s41467-022-29838-9 \author{ Alber Sanchez, \email{alber.ipia@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Felipe Carvalho, \email{felipe.carvalho@inpe.br} diff --git a/man/sits_get_class.Rd b/man/sits_get_class.Rd index 895b6e596..921964b58 100644 --- a/man/sits_get_class.Rd +++ b/man/sits_get_class.Rd @@ -51,5 +51,5 @@ There are four ways of specifying data to be retrieved using the (e) data.frame: A data.frame with \code{longitude} and \code{latitude}. } \author{ -Gilberto Camara +Gilberto Camara, \email{gilberto.camara@inpe.br} } diff --git a/man/sits_get_data.Rd b/man/sits_get_data.Rd index e3742b1a5..a64d58ac5 100644 --- a/man/sits_get_data.Rd +++ b/man/sits_get_data.Rd @@ -200,5 +200,11 @@ if (sits_run_examples()) { } \author{ -Gilberto Camara +Felipe Carlos, \email{efelipecarlos@gmail.com} + +Felipe Carvalho, \email{felipe.carvalho@inpe.br} + +Gilberto Camara, \email{gilberto.camara@inpe.br} + +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_get_probs.Rd b/man/sits_get_probs.Rd index dc9e132d3..6173e31ae 100644 --- a/man/sits_get_probs.Rd +++ b/man/sits_get_probs.Rd @@ -55,5 +55,5 @@ There are four ways of specifying data to be retrieved using the (e) data.frame: A data.frame with \code{longitude} and \code{latitude}. } \author{ -Gilberto Camara +Gilberto Camara, \email{gilberto.camara@inpe.br} } diff --git a/man/sits_kfold_validate.Rd b/man/sits_kfold_validate.Rd index cbf78d9f0..c1f54ccce 100644 --- a/man/sits_kfold_validate.Rd +++ b/man/sits_kfold_validate.Rd @@ -89,7 +89,7 @@ if (sits_run_examples()) { } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Gilberto Camara, \email{gilberto.camara@inpe.br} } diff --git a/man/sits_label_classification.Rd b/man/sits_label_classification.Rd index b5cc307ab..ce66d0679 100644 --- a/man/sits_label_classification.Rd +++ b/man/sits_label_classification.Rd @@ -95,7 +95,7 @@ if (sits_run_examples()) { } } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Felipe Souza, \email{felipe.souza@inpe.br} } diff --git a/man/sits_labels.Rd b/man/sits_labels.Rd index a1b2cb952..4b5d0a0dc 100644 --- a/man/sits_labels.Rd +++ b/man/sits_labels.Rd @@ -65,5 +65,5 @@ if (sits_run_examples()) { } } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_labels_summary.Rd b/man/sits_labels_summary.Rd index ed8c0d848..fb76bc67d 100644 --- a/man/sits_labels_summary.Rd +++ b/man/sits_labels_summary.Rd @@ -25,5 +25,5 @@ data(cerrado_2classes) sits_labels_summary(cerrado_2classes) } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_lighttae.Rd b/man/sits_lighttae.Rd index 8cd8e0e20..0dbe3a5a4 100644 --- a/man/sits_lighttae.Rd +++ b/man/sits_lighttae.Rd @@ -127,7 +127,7 @@ DOI: 10.5281/zenodo.4835356 \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Charlotte Pelletier, \email{charlotte.pelletier@univ-ubs.fr} } diff --git a/man/sits_merge.Rd b/man/sits_merge.Rd index 82a823fa7..1e2c65365 100644 --- a/man/sits_merge.Rd +++ b/man/sits_merge.Rd @@ -70,5 +70,7 @@ if (sits_run_examples()) { } } \author{ -Gilberto Camara, \email{gilberto.camara@inpe.br} +Felipe Carvalho, \email{felipe.carvalho@inpe.br} + +Felipe Carlos, \email{efelipecarlos@gmail.com} } diff --git a/man/sits_mixture_model.Rd b/man/sits_mixture_model.Rd index 51380ba26..a37c7da92 100644 --- a/man/sits_mixture_model.Rd +++ b/man/sits_mixture_model.Rd @@ -139,9 +139,5 @@ Felipe Carvalho, \email{felipe.carvalho@inpe.br} Felipe Carlos, \email{efelipecarlos@gmail.com} -Rolf Simoes, \email{rolf.simoes@inpe.br} - -Gilberto Camara, \email{gilberto.camara@inpe.br} - -Alber Sanchez, \email{alber.ipia@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_model_export.Rd b/man/sits_model_export.Rd index 49fb428d9..0647ab560 100644 --- a/man/sits_model_export.Rd +++ b/man/sits_model_export.Rd @@ -31,5 +31,5 @@ if (sits_run_examples()) { } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_mosaic.Rd b/man/sits_mosaic.Rd index 4b39f0264..21fc6e23e 100644 --- a/man/sits_mosaic.Rd +++ b/man/sits_mosaic.Rd @@ -105,5 +105,7 @@ if (sits_run_examples()) { \author{ Felipe Carvalho, \email{felipe.carvalho@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} + +Felipe Carlos, \email{efelipecarlos@gmail.com} } diff --git a/man/sits_patterns.Rd b/man/sits_patterns.Rd index c495a978a..4278fa0e9 100644 --- a/man/sits_patterns.Rd +++ b/man/sits_patterns.Rd @@ -50,5 +50,5 @@ Victor Maus, \email{vwmaus1@gmail.com} Gilberto Camara, \email{gilberto.camara@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_reclassify.Rd b/man/sits_reclassify.Rd index 990259bd8..1d67ea2f5 100644 --- a/man/sits_reclassify.Rd +++ b/man/sits_reclassify.Rd @@ -133,7 +133,7 @@ ro_mask <- sits_reclassify( } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Gilberto Camara, \email{gilberto.camara@inpe.br} } diff --git a/man/sits_reduce.Rd b/man/sits_reduce.Rd index df0ebde1e..f440dbedd 100644 --- a/man/sits_reduce.Rd +++ b/man/sits_reduce.Rd @@ -122,7 +122,5 @@ if (sits_run_examples()) { \author{ Felipe Carvalho, \email{felipe.carvalho@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} - -Gilberto Camara, \email{gilberto.camara@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_regularize.Rd b/man/sits_regularize.Rd index 5bb9e8e83..fd7e61563 100644 --- a/man/sits_regularize.Rd +++ b/man/sits_regularize.Rd @@ -209,3 +209,8 @@ Appel, Marius; Pebesma, Edzer. On-demand processing of data cubes from satellite image collections with the gdalcubes library. Data, v. 4, n. 3, p. 92, 2019. DOI: 10.3390/data4030092. } +\author{ +Felipe Carvalho, \email{felipe.carvalho@inpe.br} + +Rolf Simoes, \email{rolfsimoes@gmail.com} +} diff --git a/man/sits_rfor.Rd b/man/sits_rfor.Rd index 4ae672af1..9a2e36012 100644 --- a/man/sits_rfor.Rd +++ b/man/sits_rfor.Rd @@ -52,7 +52,7 @@ if (sits_run_examples()) { \author{ Alexandre Ywata de Carvalho, \email{alexandre.ywata@ipea.gov.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Gilberto Camara, \email{gilberto.camara@inpe.br} } diff --git a/man/sits_sample.Rd b/man/sits_sample.Rd index 75a36106e..6fecb6f03 100644 --- a/man/sits_sample.Rd +++ b/man/sits_sample.Rd @@ -7,7 +7,7 @@ sits_sample(data, frac = 0.2, oversample = TRUE) } \arguments{ -\item{data}{Sits time series tibble (class = "sits")} +\item{data}{Sits time series tibble} \item{frac}{Percentage of samples to extract (range: 0.0 to 2.0, default = 0.2)} @@ -36,5 +36,5 @@ data_02 <- sits_sample(cerrado_2classes, frac = 0.2) summary(data_02) } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_segment.Rd b/man/sits_segment.Rd index 90ae0af4a..9c2612519 100644 --- a/man/sits_segment.Rd +++ b/man/sits_segment.Rd @@ -104,7 +104,9 @@ if (sits_run_examples()) { \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Felipe Carvalho, \email{felipe.carvalho@inpe.br} + +Felipe Carlos, \email{efelipecarlos@gmail.com} } diff --git a/man/sits_select.Rd b/man/sits_select.Rd index 4ce5acc3f..96486e376 100644 --- a/man/sits_select.Rd +++ b/man/sits_select.Rd @@ -5,7 +5,7 @@ \alias{sits_select.sits} \alias{sits_select.raster_cube} \alias{sits_select.default} -\title{Filter bands on a data set (tibble or cube)} +\title{Filter a data set (tibble or cube) for bands, tiles, and dates} \usage{ sits_select(data, ...) @@ -61,5 +61,5 @@ point_2010 <- sits_select(point_mt_6bands, } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_sgolay.Rd b/man/sits_sgolay.Rd index 73728cc9a..61f0c9e82 100644 --- a/man/sits_sgolay.Rd +++ b/man/sits_sgolay.Rd @@ -44,7 +44,7 @@ of Data by Simplified Least Squares Procedures". Analytical Chemistry, 36 (8): 1627–39, 1964. } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Gilberto Camara, \email{gilberto.camara@inpe.br} diff --git a/man/sits_slic.Rd b/man/sits_slic.Rd index 8072e80ce..2268c7178 100644 --- a/man/sits_slic.Rd +++ b/man/sits_slic.Rd @@ -96,9 +96,9 @@ Achanta, Radhakrishna, Appu Shaji, Kevin Smith, Aurelien Lucchi, and Geoinformation 112 (August): 102935. } \author{ -Gilberto Camara, \email{gilberto.camara@inpe.br} - -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Felipe Carvalho, \email{felipe.carvalho@inpe.br} + +Felipe Carlos, \email{efelipecarlos@gmail.com} } diff --git a/man/sits_smooth.Rd b/man/sits_smooth.Rd index 486459dd8..1d86ab079 100644 --- a/man/sits_smooth.Rd +++ b/man/sits_smooth.Rd @@ -105,5 +105,5 @@ if (sits_run_examples()) { \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_som_clean_samples.Rd b/man/sits_som_clean_samples.Rd index 6896730fb..4ab7c3245 100644 --- a/man/sits_som_clean_samples.Rd +++ b/man/sits_som_clean_samples.Rd @@ -29,7 +29,20 @@ The first indicates if each sample is clean, should be analyzed or should be removed. The second is the posterior probability of the sample. } \description{ -Cleans the samples based on SOM map information +\code{sits_som_clean_samples()} evaluates the quality of the samples +based on the results of the SOM map. The algorithm identifies noisy samples, +using `prior_threshold` for the prior probability +and `posterior_threshold` for the posterior probability. +Each sample receives an evaluation tag, according to the following rule: +(a) If the prior probability is < `prior_threshold`, the sample is tagged +as "remove"; +(b) If the prior probability is >= `prior_threshold` and the posterior +probability is >=`posterior_threshold`, the sample is tagged as "clean"; +(c) If the prior probability is >= `posterior_threshold` and +the posterior probability is < `posterior_threshold`, the sample is tagged as +"analyze" for further inspection. +The user can define which tagged samples will be returned using the "keep" +parameter, with the following options: "clean", "analyze", "remove". } \examples{ if (sits_run_examples()) { @@ -46,3 +59,10 @@ if (sits_run_examples()) { } } +\author{ +Lorena Alves, \email{lorena.santos@inpe.br} + +Karine Ferreira. \email{karine.ferreira@inpe.br} + +Gilberto Camara, \email{gilberto.camara@inpe.br} +} diff --git a/man/sits_som.Rd b/man/sits_som_map.Rd similarity index 96% rename from man/sits_som.Rd rename to man/sits_som_map.Rd index e2d732157..83ff828c8 100644 --- a/man/sits_som.Rd +++ b/man/sits_som_map.Rd @@ -1,9 +1,8 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/sits_som.R -\name{sits_som} -\alias{sits_som} +\name{sits_som_map} \alias{sits_som_map} -\title{Use SOM for quality analysis of time series samples} +\title{Build a SOM for quality analysis of time series samples} \usage{ sits_som_map( data, @@ -116,4 +115,6 @@ vol. 177, pp 75-88, 2021. https://doi.org/10.1016/j.isprsjprs.2021.04.014. Lorena Alves, \email{lorena.santos@inpe.br} Karine Ferreira. \email{karine.ferreira@inpe.br} + +Gilberto Camara, \email{gilberto.camara@inpe.br} } diff --git a/man/sits_som_remove_samples.Rd b/man/sits_som_remove_samples.Rd index b0cfc65c6..6f7cfd152 100644 --- a/man/sits_som_remove_samples.Rd +++ b/man/sits_som_remove_samples.Rd @@ -31,3 +31,8 @@ if (sits_run_examples()) { new_samples <- sits_som_remove_samples(som_map, som_eval, "Pasture", "Cerrado") } } +\author{ +Lorena Alves, \email{lorena.santos@inpe.br} + +Karine Ferreira. \email{karine.ferreira@inpe.br} +} diff --git a/man/sits_svm.Rd b/man/sits_svm.Rd index 0627e7810..84864eb16 100644 --- a/man/sits_svm.Rd +++ b/man/sits_svm.Rd @@ -87,7 +87,7 @@ if (sits_run_examples()) { \author{ Alexandre Ywata de Carvalho, \email{alexandre.ywata@ipea.gov.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Gilberto Camara, \email{gilberto.camara@inpe.br} } diff --git a/man/sits_tae.Rd b/man/sits_tae.Rd index 7bb63cf29..0580a5d77 100644 --- a/man/sits_tae.Rd +++ b/man/sits_tae.Rd @@ -120,5 +120,7 @@ Charlotte Pelletier, \email{charlotte.pelletier@univ-ubs.fr} Gilberto Camara, \email{gilberto.camara@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} + +Felipe Souza, \email{lipecaso@gmail.com} } diff --git a/man/sits_tempcnn.Rd b/man/sits_tempcnn.Rd index 5fde7b0c7..b77aff574 100644 --- a/man/sits_tempcnn.Rd +++ b/man/sits_tempcnn.Rd @@ -133,7 +133,7 @@ Charlotte Pelletier, \email{charlotte.pelletier@univ-ubs.fr} Gilberto Camara, \email{gilberto.camara@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Felipe Souza, \email{lipecaso@gmail.com} } diff --git a/man/sits_train.Rd b/man/sits_train.Rd index f6d71bda3..61940f7bb 100644 --- a/man/sits_train.Rd +++ b/man/sits_train.Rd @@ -39,7 +39,7 @@ if (sits_run_examples()) { } } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Gilberto Camara, \email{gilberto.camara@inpe.br} diff --git a/man/sits_tuning.Rd b/man/sits_tuning.Rd index f6ca72eda..5b26fb894 100644 --- a/man/sits_tuning.Rd +++ b/man/sits_tuning.Rd @@ -113,5 +113,5 @@ James Bergstra, Yoshua Bengio, Journal of Machine Learning Research. 13: 281–305, 2012. } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_uncertainty.Rd b/man/sits_uncertainty.Rd index 3c3bf5f1c..c64563323 100644 --- a/man/sits_uncertainty.Rd +++ b/man/sits_uncertainty.Rd @@ -91,7 +91,7 @@ Active learning and annotation for human-centered AI. Simon and Schuster, \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Alber Sanchez, \email{alber.ipia@inpe.br} } diff --git a/man/sits_uncertainty_sampling.Rd b/man/sits_uncertainty_sampling.Rd index 2fae2be17..d20a5500e 100644 --- a/man/sits_uncertainty_sampling.Rd +++ b/man/sits_uncertainty_sampling.Rd @@ -89,7 +89,7 @@ and annotation for human-centered AI". Manning Publications, 2021. \author{ Alber Sanchez, \email{alber.ipia@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Felipe Carvalho, \email{felipe.carvalho@inpe.br} diff --git a/man/sits_validate.Rd b/man/sits_validate.Rd index b7c2a1471..6c8751d53 100644 --- a/man/sits_validate.Rd +++ b/man/sits_validate.Rd @@ -87,7 +87,7 @@ if (sits_run_examples()) { } } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Gilberto Camara, \email{gilberto.camara@inpe.br} } diff --git a/man/sits_variance.Rd b/man/sits_variance.Rd index 52ee44e9d..66f878cad 100644 --- a/man/sits_variance.Rd +++ b/man/sits_variance.Rd @@ -116,5 +116,5 @@ if (sits_run_examples()) { \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } diff --git a/man/sits_whittaker.Rd b/man/sits_whittaker.Rd index 3f6fe8d7b..791d98efd 100644 --- a/man/sits_whittaker.Rd +++ b/man/sits_whittaker.Rd @@ -44,7 +44,7 @@ vol. 57, pg. 202-213, 2107. \link[sits]{sits_apply} } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} Gilberto Camara, \email{gilberto.camara@inpe.br} diff --git a/man/sits_xgboost.Rd b/man/sits_xgboost.Rd index 78a00dacc..1de9ee00c 100644 --- a/man/sits_xgboost.Rd +++ b/man/sits_xgboost.Rd @@ -95,7 +95,5 @@ Tianqi Chen, Carlos Guestrin, SIG KDD 2016. } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} - Gilberto Camara, \email{gilberto.camara@inpe.br} } diff --git a/man/summary.sits.Rd b/man/summary.sits.Rd index 5f8f4acbf..302bc8db8 100644 --- a/man/summary.sits.Rd +++ b/man/summary.sits.Rd @@ -27,5 +27,5 @@ if (sits_run_examples()) { \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} -Felipe Souza, \email{felipe.souza@inpe.br} +Felipe Carvalho, \email{felipe.carvalho@inpe.br} } diff --git a/man/tick-sits_labels-set-tick.Rd b/man/tick-sits_labels-set-tick.Rd index dae04b844..c3448da15 100644 --- a/man/tick-sits_labels-set-tick.Rd +++ b/man/tick-sits_labels-set-tick.Rd @@ -44,5 +44,5 @@ sits_labels(cerrado_2classes) <- c("Savanna", "Grasslands") sits_labels(cerrado_2classes) } \author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +Rolf Simoes, \email{rolfsimoes@gmail.com} } From 219805e2387eb8d4848a18e1f487328e54df9ab8 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 23 Feb 2025 19:50:55 +0000 Subject: [PATCH 030/122] update angles parameter --- R/RcppExports.R | 4 ---- R/sits_glcm.R | 4 ++-- man/sits_glcm.Rd | 2 +- 3 files changed, 3 insertions(+), 7 deletions(-) diff --git a/R/RcppExports.R b/R/RcppExports.R index 72437a29b..733845ad3 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -29,10 +29,6 @@ dtw_distance <- function(ts1, ts2) { .Call(`_sits_dtw_distance`, ts1, ts2) } -test <- function(angles) { - invisible(.Call(`_sits_test`, angles)) -} - C_glcm_contrast <- function(x, nrows, ncols, window_size, angles) { .Call(`_sits_C_glcm_contrast`, x, nrows, ncols, window_size, angles) } diff --git a/R/sits_glcm.R b/R/sits_glcm.R index 4d745ef09..ca8d296d1 100644 --- a/R/sits_glcm.R +++ b/R/sits_glcm.R @@ -66,7 +66,7 @@ sits_glcm <- function(data, ...) { #' @export sits_glcm.raster_cube <- function(data, ..., window_size = 3L, - angles = c(0, pi/2, pi/4, 3*pi/4), + angles = 0, memsize = 4L, multicores = 2L, output_dir, @@ -77,7 +77,7 @@ sits_glcm.raster_cube <- function(data, ..., # Check window size .check_int_parameter(window_size, min = 1, is_odd = TRUE) # Check normalized index - .check_num_parameter(angles) + .check_num_parameter(angles, len_min = 1, len_max = 4) # Check memsize .check_int_parameter(memsize, min = 1, max = 16384) # Check multicores diff --git a/man/sits_glcm.Rd b/man/sits_glcm.Rd index 1a4143257..61cccb655 100644 --- a/man/sits_glcm.Rd +++ b/man/sits_glcm.Rd @@ -13,7 +13,7 @@ sits_glcm(data, ...) data, ..., window_size = 3L, - angles = c(0, pi/2, pi/4, 3 * pi/4), + angles = 0, memsize = 4L, multicores = 2L, output_dir, From fcb0add2a4d7afde0779a3349a87a75490874fa3 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 23 Feb 2025 19:51:17 +0000 Subject: [PATCH 031/122] optimize glcm cpp func --- src/RcppExports.cpp | 11 ----------- src/glcm_fns.cpp | 26 ++++++++++++++------------ 2 files changed, 14 insertions(+), 23 deletions(-) diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index df87b37a5..5f1cfe1f2 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -104,16 +104,6 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } -// test -void test(const arma::vec& angles); -RcppExport SEXP _sits_test(SEXP anglesSEXP) { -BEGIN_RCPP - Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - test(angles); - return R_NilValue; -END_RCPP -} // C_glcm_contrast arma::mat C_glcm_contrast(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); RcppExport SEXP _sits_C_glcm_contrast(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { @@ -901,7 +891,6 @@ static const R_CallMethodDef CallEntries[] = { {"_sits_weighted_probs", (DL_FUNC) &_sits_weighted_probs, 2}, {"_sits_weighted_uncert_probs", (DL_FUNC) &_sits_weighted_uncert_probs, 2}, {"_sits_dtw_distance", (DL_FUNC) &_sits_dtw_distance, 2}, - {"_sits_test", (DL_FUNC) &_sits_test, 1}, {"_sits_C_glcm_contrast", (DL_FUNC) &_sits_C_glcm_contrast, 5}, {"_sits_C_glcm_dissimilarity", (DL_FUNC) &_sits_C_glcm_dissimilarity, 5}, {"_sits_C_glcm_homogeneity", (DL_FUNC) &_sits_C_glcm_homogeneity, 5}, diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index d8fcf73a4..c3acc7d16 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -3,6 +3,8 @@ #include #include #include +#define ARMA_DONT_USE_WRAPPER +#define ARMA_USE_OPENMP using namespace Rcpp; using namespace std; @@ -23,16 +25,14 @@ IntegerVector locus_neigh2(int size, int leg) { return res; } - // [[Rcpp::export]] -void test(const arma::vec& angles) { - double angle_value = angles(0); - - Rcpp::Rcout << "sin: "<< std::sin(angle_value) << " cos: " << std::cos(angle_value) << "\n"; - Rcpp::Rcout << "sin: "<< std::sin(3.14/2) << " cos: " << std::cos(3.14/2) << "\n"; - Rcpp::Rcout << "sin: "<< std::sin(3.14/4) << " cos: " << std::cos(3.14/4) << "\n"; - Rcpp::Rcout << "sin: "<< std::sin(3*3.14/4) << " cos: " << std::cos(3*3.14/4) << "\n"; - +void test() { + arma::mat i_aux(n_grey, n_grey); + arma::mat j_aux(n_grey, n_grey); + // fill auxiliary matrices with a sequence of 1 to n_grey levels + i_aux = arma::repmat( + arma::linspace(0, n_grey - 1, n_grey), 1, n_grey + ); } arma::mat glcm_fn(const arma::vec& x, @@ -51,11 +51,11 @@ arma::mat glcm_fn(const arma::vec& x, arma::mat neigh(window_size, window_size); // auxiliary variables - double sum, ang_v = 0; + double ang_v = 0; arma::u8 offset_row, offset_col = 1; arma::u16 row, col = 0; arma::uword start_row, end_row, start_col, end_col = 0; - int v_i, v_j = 0; + int v_i, v_j, sum = 0; // initialize auxiliary matrices needed in some metrics arma::mat i_aux(n_grey, n_grey); @@ -117,7 +117,9 @@ arma::mat glcm_fn(const arma::vec& x, glcm_co.set_size(n_grey, n_grey); } } - + } + if (angles.size() > 1) { + res = arma::mean(res, 1); } return res; } From 77a159d3396c685668a77579c7bd1145cc5e3b12 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 23 Feb 2025 22:58:38 +0000 Subject: [PATCH 032/122] update cpp glcm --- src/glcm_fns.cpp | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index c3acc7d16..002e86ca3 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -25,16 +25,6 @@ IntegerVector locus_neigh2(int size, int leg) { return res; } -// [[Rcpp::export]] -void test() { - arma::mat i_aux(n_grey, n_grey); - arma::mat j_aux(n_grey, n_grey); - // fill auxiliary matrices with a sequence of 1 to n_grey levels - i_aux = arma::repmat( - arma::linspace(0, n_grey - 1, n_grey), 1, n_grey - ); -} - arma::mat glcm_fn(const arma::vec& x, const arma::vec& angles, const arma::uword& nrows, From 798baef074296341dc93b8499405f489712dcf37 Mon Sep 17 00:00:00 2001 From: Felipe Date: Tue, 25 Feb 2025 22:54:49 +0000 Subject: [PATCH 033/122] update glcm api --- R/api_glcm.R | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/R/api_glcm.R b/R/api_glcm.R index 0e49a7b7d..aeb369d55 100644 --- a/R/api_glcm.R +++ b/R/api_glcm.R @@ -47,10 +47,10 @@ # Get band configuration band_conf <- .tile_band_conf(tile = feature, band = out_band) if (.has_not(band_conf)) { - band_conf <- .conf("default_values", "INT2S") + band_conf <- .conf("default_values", "INT4S") } # Process jobs sequentially - block_files <- .jobs_map_sequential(chunks, function(chunk) { + block_files <- .jobs_map_parallel(chunks, function(chunk) { # Get job block block <- .block(chunk) # Block file name for each fraction @@ -72,7 +72,6 @@ if (.has(scale) && scale != 1) { values <- values / scale } - # Evaluate expression here # Band and kernel evaluation values <- eval( @@ -85,13 +84,6 @@ img_ncol = block[["ncols"]] ) ) - - # Re-scale values between 1 and maximum - # code from scales package - from <- range(values, na.rm = TRUE, finite = TRUE) - to <- c(1, .max_value(band_conf)) - values <- (values - from[1]) / diff(from) * diff(to) + to[1] - # Prepare fractions to be saved offset <- .offset(band_conf) if (.has(offset) && offset != 0) { @@ -121,7 +113,6 @@ multicores = 1, update_bbox = FALSE ) - # Return a feature tile band_tile } From cac9befb95c0b6629572ec8a8c99b5e7a69408e1 Mon Sep 17 00:00:00 2001 From: Felipe Date: Tue, 25 Feb 2025 22:55:49 +0000 Subject: [PATCH 034/122] update sits_glcm multicores --- R/sits_glcm.R | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/R/sits_glcm.R b/R/sits_glcm.R index ca8d296d1..75cfb4ca0 100644 --- a/R/sits_glcm.R +++ b/R/sits_glcm.R @@ -110,28 +110,26 @@ sits_glcm.raster_cube <- function(data, ..., # Get block size block <- .raster_file_blocksize(.raster_open_rast(.tile_path(data))) # Check minimum memory needed to process one block - job_memsize <- .jobs_memsize( - job_size = .block_size(block = block, overlap = overlap), + job_block_memsize <- .jobs_block_memsize( + block_size = .block_size(block = block, overlap = overlap), npaths = length(in_bands) + 1, nbytes = 8, proc_bloat = .conf("processing_bloat_cpu") ) + # Update multicores parameter + multicores <- .jobs_max_multicores( + job_block_memsize = job_block_memsize, + memsize = memsize, + multicores = multicores + ) # Update block parameter block <- .jobs_optimal_block( - job_memsize = job_memsize, + job_block_memsize = job_block_memsize, block = block, image_size = .tile_size(.tile(data)), memsize = memsize, multicores = multicores ) - # adjust for blocks of size 1 - block <- .block_regulate_size(block) - # Update multicores parameter - multicores <- .jobs_max_multicores( - job_memsize = job_memsize, - memsize = memsize, - multicores = multicores - ) # Prepare parallelization .parallel_start(workers = multicores) on.exit(.parallel_stop(), add = TRUE) @@ -140,7 +138,7 @@ sits_glcm.raster_cube <- function(data, ..., features_cube <- .cube_split_features(data) # Process each feature in parallel - features_band <- .jobs_map_parallel_dfr(features_cube, function(feature) { + features_band <- .jobs_map_sequential_dfr(features_cube, function(feature) { # Process the data output_feature <- .glcm_feature( feature = feature, @@ -154,7 +152,7 @@ sits_glcm.raster_cube <- function(data, ..., output_dir = output_dir ) return(output_feature) - }, progress = progress) + }) # Join output features as a cube and return it .cube_merge_tiles(dplyr::bind_rows(list(features_cube, features_band))) } From ea63f04f24d4b7a0baa4b693e59756f45ade2db0 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 26 Feb 2025 12:55:02 +0000 Subject: [PATCH 035/122] back to original code in api_apply.R --- R/api_apply.R | 61 +++------------------------------------------------ 1 file changed, 3 insertions(+), 58 deletions(-) diff --git a/R/api_apply.R b/R/api_apply.R index d79b64320..0bff87cfb 100644 --- a/R/api_apply.R +++ b/R/api_apply.R @@ -2,7 +2,7 @@ #' @name .apply #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param data Tibble. #' @param col Column where function should be applied @@ -38,7 +38,7 @@ #' @name .apply_feature #' @keywords internal #' @noRd -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param feature Subset of a data cube containing the input bands #' used in the expression @@ -104,7 +104,6 @@ values <- .apply_data_read( tile = feature, block = block, in_bands = in_bands ) - values <- values * 10000 # Evaluate expression here # Band and kernel evaluation values <- eval( @@ -123,7 +122,7 @@ } scale <- .scale(band_conf) if (.has(scale) && scale != 1) { - values <- values * scale + values <- values / scale } # Job crop block crop_block <- .block(.chunks_no_overlap(chunk)) @@ -318,60 +317,6 @@ x = as.matrix(m), ncols = img_ncol, nrows = img_nrow, band = 0, window_size = window_size ) - }, - glcm_contrast = function(m) { - C_glcm_contrast( - x = m, nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = 0, n_grey = 10000 - ) - }, - glcm_dissimilarity = function(m) { - C_glcm_dissimilarity( - x = m, nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = 0, n_grey = 10000 - ) - }, - glcm_homogeneity = function(m) { - C_glcm_homogeneity( - x = m, nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = 0, n_grey = 10000 - ) - }, - glcm_energy = function(m) { - C_glcm_energy( - x = m, nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = 0, n_grey = 10000 - ) - }, - glcm_asm = function(m) { - C_glcm_asm( - x = m, nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = 0, n_grey = 10000 - ) - }, - glcm_mean = function(m) { - C_glcm_mean( - x = m, nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = 0, n_grey = 10000 - ) - }, - glcm_variance = function(m) { - C_glcm_variance( - x = m, nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = 0, n_grey = 10000 - ) - }, - glcm_std = function(m) { - C_glcm_std( - x = m, nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = 0, n_grey = 10000 - ) - }, - glcm_correlation = function(m) { - C_glcm_correlation( - x = m, nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = 0, n_grey = 10000 - ) } ), parent = parent.env(environment()), hash = TRUE) From 5994cc89cdba93851a31ab3487d8a0ee3041e7c2 Mon Sep 17 00:00:00 2001 From: Felipe Date: Fri, 28 Feb 2025 23:43:39 +0000 Subject: [PATCH 036/122] update GLCM docs --- R/sits_glcm.R | 99 ++++++++++++++++++++++++++++++++++++++---------- man/sits_glcm.Rd | 99 ++++++++++++++++++++++++++++++++++++++---------- 2 files changed, 159 insertions(+), 39 deletions(-) diff --git a/R/sits_glcm.R b/R/sits_glcm.R index 75cfb4ca0..76ef01158 100644 --- a/R/sits_glcm.R +++ b/R/sits_glcm.R @@ -2,39 +2,100 @@ #' #' @name sits_glcm #' -#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' -#' @description ... +#' @description A set of texture measures based on the Grey Level Co-occurrence +#' Matrix (GLCM) described by Haralick (referenced below). Our implementation +#' follows the guidelines and equations described by Hall-Beyer +#' (referenced below). +#' +#' @references +#' Robert M. Haralick, K. Shanmugam, Its'Hak Dinstein, +#' "Textural Features for Image Classification", +#' IEEE Transactions on Systems, Man, and Cybernetics, +#' SMC-3, 6, 610-621, 1973, DOI: 10.1109/TSMC.1973.4309314. +#' +#' Hall-Beyer, M., "GLCM Texture Tutorial", +#' 2007, http://www.fp.ucalgary.ca/mhallbey/tutorial.htm. +#' +#' Hall-Beyer, M., "Practical guidelines for choosing GLCM textures to use +#' in landscape classification tasks over a range of moderate spatial scales", +#' International Journal of Remote Sensing, 38, 1312–1338, 2017, +#' DOI: 10.1080/01431161.2016.1278314. +#' +#' A. Baraldi and F. Panniggiani, "An investigation of the textural +#' characteristics associated with gray level cooccurrence matrix statistical +#' parameters," IEEE Transactions on Geoscience and Remote Sensing, 33, 2, +#' 293-304, 1995, DOI: 10.1109/TGRS.1995.8746010. +#' +#' Shokr, M. E., "Evaluation of second-order texture parameters for sea ice +#' classification from radar images", +#' J. Geophys. Res., 96, 10625–10640, 1991, DOI:10.1029/91JC00693. +#' +#' Peng Gong, Danielle J. Marceau, Philip J. Howarth, "A comparison of +#' spatial feature extraction algorithms for land-use classification +#' with SPOT HRV data", Remote Sensing of Environment, 40, 2, 1992, 137-151, +#' DOI: 10.1016/0034-4257(92)90011-8. +#' #' #' @param data Valid sits tibble or cube #' @param window_size An odd number representing the size of the -#' sliding window of sits kernel functions -#' used in expressions (for a list of supported -#' kernel functions, please see details). -#' @param angles ... +#' sliding window. +#' @param angles The direction angles in radians related to the +#' central pixel and its neighbor (See details). +#' Default is 0. #' @param memsize Memory available for classification (in GB). #' @param multicores Number of cores to be used for classification. #' @param output_dir Directory where files will be saved. #' @param progress Show progress bar? -#' @param ... Named expressions to be evaluated (see details). +#' @param ... GLCM function (see details). +#' +#' @details +#' The spatial relation between the central pixel and its neighbor is expressed +#' in radians values, where: +#' #' \itemize{ +#' \item{\code{0}: corresponds to the neighbor on right-side} +#' \item{\code{pi/4}: corresponds to the neighbor on the top-right diagonals} +#' \item{\code{pi/2}: corresponds to the neighbor on above} +#' \item{\code{3*pi/4}: corresponds to the neighbor on the top-left diagonals} +#' } #' -#' @section Summarizing GLCM functions: +#' Our implementation relies on a symmetric co-occurrence matrix, which +#' considers the opposite directions of an angle. For example, the neighbor +#' pixels based on \code{0} angle rely on the left and right direction; the +#' neighbor pixels of \code{pi/2} are above and below the central pixel, and +#' so on. If more than one angle is provided, we compute their average. +#' +#' @section GLCM functions: #' \itemize{ -#' \item{\code{glcm_contrast()}: ...} -#' \item{\code{glcm_dissimilarity()}: ...} -#' \item{\code{glcm_homogeneity()}: ...} -#' \item{\code{glcm_energy()}: ...} -#' \item{\code{glcm_asm()}: ...} -#' \item{\code{glcm_mean()}: ...} -#' \item{\code{glcm_variance()}: ...} -#' \item{\code{glcm_std()}: ...} -#' \item{\code{glcm_correlation()}: ...} +#' \item{\code{glcm_contrast()}: measures the contrast or the amount of local +#' variations present in an image. Low contrast values indicate regions with +#' low spatial frequency.} +#' \item{\code{glcm_homogeneity()}: also known as the Inverse Difference +#' Moment, it measures image homogeneity by assuming larger values for +#' smaller gray tone differences in pair elements.} +#' \item{\code{glcm_asm()}: the Angular Second Moment (ASM) measures textural +#' uniformity. High ASM values indicate a constant or a periodic form in the +#' window values.} +#' \item{\code{glcm_energy()}: measures textural uniformity. Energy is +#' defined as the square root of the ASM. } +#' \item{\code{glcm_mean()}: measures the mean of the probability of +#' co-occurrence of specific pixel values within the neighborhood.} +#' \item{\code{glcm_variance()}: measures the heterogeneity and is strongly +#' correlated to first order statistical variables such as standard deviation. +#' Variance values increase as the gray-level values deviate from their mean.} +#' \item{\code{glcm_std()}: measures the heterogeneity and is strongly +#' correlated to first order statistical variables such as standard deviation. +#' STD is defined as the square root of the variance.} +#' \item{\code{glcm_correlation()}: measures the gray-tone linear dependencies +#' of the image. Low correlation values indicate homogeneous region edges.} #' } #' -#' @return A sits cube with new bands, produced -#' according to the requested expression. +#' +#' @return A sits cube with new bands, produced according to the requested +#' measure. #' #' @examples #' if (sits_run_examples()) { diff --git a/man/sits_glcm.Rd b/man/sits_glcm.Rd index 61cccb655..108e0a5ac 100644 --- a/man/sits_glcm.Rd +++ b/man/sits_glcm.Rd @@ -27,14 +27,14 @@ sits_glcm(data, ...) \arguments{ \item{data}{Valid sits tibble or cube} -\item{...}{Named expressions to be evaluated (see details).} +\item{...}{GLCM function (see details).} \item{window_size}{An odd number representing the size of the -sliding window of sits kernel functions -used in expressions (for a list of supported -kernel functions, please see details).} +sliding window.} -\item{angles}{...} +\item{angles}{The direction angles in radians related to the +central pixel and its neighbor (See details). +Default is 0.} \item{memsize}{Memory available for classification (in GB).} @@ -45,24 +45,55 @@ kernel functions, please see details).} \item{progress}{Show progress bar?} } \value{ -A sits cube with new bands, produced - according to the requested expression. +A sits cube with new bands, produced according to the requested +measure. } \description{ -... +A set of texture measures based on the Grey Level Co-occurrence +Matrix (GLCM) described by Haralick (referenced below). Our implementation +follows the guidelines and equations described by Hall-Beyer +(referenced below). } -\section{Summarizing GLCM functions}{ +\details{ +The spatial relation between the central pixel and its neighbor is expressed +in radians values, where: +#' \itemize{ +\item{\code{0}: corresponds to the neighbor on right-side} +\item{\code{pi/4}: corresponds to the neighbor on the top-right diagonals} +\item{\code{pi/2}: corresponds to the neighbor on above} +\item{\code{3*pi/4}: corresponds to the neighbor on the top-left diagonals} +} + +Our implementation relies on a symmetric co-occurrence matrix, which +considers the opposite directions of an angle. For example, the neighbor +pixels based on \code{0} angle rely on the left and right direction; the +neighbor pixels of \code{pi/2} are above and below the central pixel, and +so on. If more than one angle is provided, we compute their average. +} +\section{GLCM functions}{ \itemize{ -\item{\code{glcm_contrast()}: ...} -\item{\code{glcm_dissimilarity()}: ...} -\item{\code{glcm_homogeneity()}: ...} -\item{\code{glcm_energy()}: ...} -\item{\code{glcm_asm()}: ...} -\item{\code{glcm_mean()}: ...} -\item{\code{glcm_variance()}: ...} -\item{\code{glcm_std()}: ...} -\item{\code{glcm_correlation()}: ...} +\item{\code{glcm_contrast()}: measures the contrast or the amount of local +variations present in an image. Low contrast values indicate regions with +low spatial frequency.} +\item{\code{glcm_homogeneity()}: also known as the Inverse Difference +Moment, it measures image homogeneity by assuming larger values for +smaller gray tone differences in pair elements.} +\item{\code{glcm_asm()}: the Angular Second Moment (ASM) measures textural +uniformity. High ASM values indicate a constant or a periodic form in the +window values.} +\item{\code{glcm_energy()}: measures textural uniformity. Energy is +defined as the square root of the ASM. } +\item{\code{glcm_mean()}: measures the mean of the probability of +co-occurrence of specific pixel values within the neighborhood.} +\item{\code{glcm_variance()}: measures the heterogeneity and is strongly +correlated to first order statistical variables such as standard deviation. +Variance values increase as the gray-level values deviate from their mean.} +\item{\code{glcm_std()}: measures the heterogeneity and is strongly +correlated to first order statistical variables such as standard deviation. +STD is defined as the square root of the variance.} +\item{\code{glcm_correlation()}: measures the gray-tone linear dependencies +of the image. Low correlation values indicate homogeneous region edges.} } } @@ -85,10 +116,38 @@ if (sits_run_examples()) { ) } } -\author{ -Rolf Simoes, \email{rolf.simoes@inpe.br} +\references{ +Robert M. Haralick, K. Shanmugam, Its'Hak Dinstein, +"Textural Features for Image Classification", +IEEE Transactions on Systems, Man, and Cybernetics, +SMC-3, 6, 610-621, 1973, DOI: 10.1109/TSMC.1973.4309314. + +Hall-Beyer, M., "GLCM Texture Tutorial", +2007, http://www.fp.ucalgary.ca/mhallbey/tutorial.htm. + +Hall-Beyer, M., "Practical guidelines for choosing GLCM textures to use +in landscape classification tasks over a range of moderate spatial scales", +International Journal of Remote Sensing, 38, 1312–1338, 2017, +DOI: 10.1080/01431161.2016.1278314. +A. Baraldi and F. Panniggiani, "An investigation of the textural +characteristics associated with gray level cooccurrence matrix statistical +parameters," IEEE Transactions on Geoscience and Remote Sensing, 33, 2, +293-304, 1995, DOI: 10.1109/TGRS.1995.8746010. + +Shokr, M. E., "Evaluation of second-order texture parameters for sea ice +classification from radar images", +J. Geophys. Res., 96, 10625–10640, 1991, DOI:10.1029/91JC00693. + +Peng Gong, Danielle J. Marceau, Philip J. Howarth, "A comparison of +spatial feature extraction algorithms for land-use classification +with SPOT HRV data", Remote Sensing of Environment, 40, 2, 1992, 137-151, +DOI: 10.1016/0034-4257(92)90011-8. +} +\author{ Felipe Carvalho, \email{felipe.carvalho@inpe.br} +Felipe Carlos, \email{efelipecarlos@gmail.com} + Gilberto Camara, \email{gilberto.camara@inpe.br} } From f64996fb69782ebc1788e8ce49cc0b9cd1178f66 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 2 Mar 2025 00:13:03 +0000 Subject: [PATCH 037/122] update GLCM documentation --- R/api_glcm.R | 8 ++++---- R/sits_glcm.R | 8 +++----- man/sits_glcm.Rd | 7 ++++--- 3 files changed, 11 insertions(+), 12 deletions(-) diff --git a/R/api_glcm.R b/R/api_glcm.R index aeb369d55..4c345f473 100644 --- a/R/api_glcm.R +++ b/R/api_glcm.R @@ -1,5 +1,5 @@ -#' @title Apply an expression to block of a set of input bands -#' @name .apply_feature +#' @title Apply a glcm measure to a raster block +#' @name .glcm_feature #' @keywords internal #' @noRd #' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} @@ -9,12 +9,12 @@ #' used in the expression #' @param block Individual block that will be processed #' @param window_size Size of the neighbourhood (if required) -#' @param angles ... +#' @param angles The direction angles in radians related to the +#' central pixel and its neighbor. #' @param expr Expression to be applied #' @param out_band Output band #' @param in_bands Input bands #' @param overlap Overlap between tiles (if required) -#' @param normalized Produce normalized band? #' @param output_dir Directory where image will be save #' #' @return A feature compose by a combination of tile and band. diff --git a/R/sits_glcm.R b/R/sits_glcm.R index 76ef01158..dd4b228ab 100644 --- a/R/sits_glcm.R +++ b/R/sits_glcm.R @@ -1,9 +1,10 @@ -#' @title Apply a GLCM metric on a data cube +#' @title Apply a GLCM texture on a data cube #' #' @name sits_glcm #' #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description A set of texture measures based on the Grey Level Co-occurrence @@ -39,7 +40,6 @@ #' with SPOT HRV data", Remote Sensing of Environment, 40, 2, 1992, 137-151, #' DOI: 10.1016/0034-4257(92)90011-8. #' -#' #' @param data Valid sits tibble or cube #' @param window_size An odd number representing the size of the #' sliding window. @@ -93,7 +93,6 @@ #' of the image. Low correlation values indicate homogeneous region edges.} #' } #' -#' #' @return A sits cube with new bands, produced according to the requested #' measure. #' @@ -109,9 +108,8 @@ #' # Generate a texture images with variance in NDVI images #' cube_texture <- sits_glcm( #' data = cube, -#' NDVIMEAN = glcm_mean(NDVI), +#' NDVIVAR = glcm_variance(NDVI), #' window_size = 5, -#' angles = 0, #' output_dir = tempdir() #' ) #' } diff --git a/man/sits_glcm.Rd b/man/sits_glcm.Rd index 108e0a5ac..387b50b26 100644 --- a/man/sits_glcm.Rd +++ b/man/sits_glcm.Rd @@ -5,7 +5,7 @@ \alias{sits_glcm.raster_cube} \alias{sits_glcm.derived_cube} \alias{sits_glcm.default} -\title{Apply a GLCM metric on a data cube} +\title{Apply a GLCM texture on a data cube} \usage{ sits_glcm(data, ...) @@ -109,9 +109,8 @@ if (sits_run_examples()) { # Generate a texture images with variance in NDVI images cube_texture <- sits_glcm( data = cube, - NDVIMEAN = glcm_mean(NDVI), + NDVIVAR = glcm_variance(NDVI), window_size = 5, - angles = 0, output_dir = tempdir() ) } @@ -149,5 +148,7 @@ Felipe Carvalho, \email{felipe.carvalho@inpe.br} Felipe Carlos, \email{efelipecarlos@gmail.com} +Rolf Simoes, \email{rolf.simoes@inpe.br} + Gilberto Camara, \email{gilberto.camara@inpe.br} } From e169f318b3c3d0eeb2b07332f510ad27ea89637b Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 2 Mar 2025 00:13:16 +0000 Subject: [PATCH 038/122] update GLCM cpp api --- src/glcm_fns.cpp | 32 ++++++-------------------------- 1 file changed, 6 insertions(+), 26 deletions(-) diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index 002e86ca3..3b93861da 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -31,12 +31,12 @@ arma::mat glcm_fn(const arma::vec& x, const arma::uword& ncols, const arma::uword& window_size, _glcm_fun _fun) { - // get the value of grey values + // get the maximum value of grey values int n_grey = x.max(); // initialize sparse matrix to store co-occurrence values arma::sp_mat glcm_co(n_grey, n_grey); // initialize result matrix - arma::mat res(x.size(), angles.size(), arma::fill::zeros); + arma::mat res(x.size(), angles.size()); // initialize neighborhood matrix arma::mat neigh(window_size, window_size); @@ -66,11 +66,11 @@ arma::mat glcm_fn(const arma::vec& x, for (arma::uword i = 0; i < nrows; ++i) { for (arma::uword j = 0; j < ncols; ++j) { // for all angles - for (arma::uword ang = 0; ang < angles.size(); ++ang) { + for (arma::u8 ang = 0; ang < angles.size(); ++ang) { ang_v = angles(ang); // compute the neighborhood - for (arma::uword wi = 0; wi < window_size; ++wi) { - for (arma::uword wj = 0; wj < window_size; ++wj) { + for (arma::u8 wi = 0; wi < window_size; ++wi) { + for (arma::u8 wj = 0; wj < window_size; ++wj) { neigh(wi, wj) = x(loci(wi + i) * ncols + locj(wj + j)); } @@ -100,7 +100,7 @@ arma::mat glcm_fn(const arma::vec& x, sum = arma::accu(glcm_co); glcm_co /= sum; - // calculate glcm metric + // calculate glcm measure res(i * ncols + j, ang) = _fun(glcm_co, i_aux, j_aux); // clear and reset co-occurrence matrix glcm_co.clear(); @@ -135,7 +135,6 @@ inline double _glcm_homogeneity(const arma::sp_mat& x, const arma::mat& i, const arma::mat& j) { double res = 0; - res = arma::accu(x % (1 / (1 + pow(i - j, 2)))); return(res); } @@ -152,7 +151,6 @@ inline double _glcm_asm(const arma::sp_mat& glcm, const arma::mat& i, const arma::mat& j) { double res = 0; - res = arma::accu(glcm % glcm); return(res); } @@ -161,7 +159,6 @@ inline double _glcm_mean(const arma::sp_mat& glcm, const arma::mat& i, const arma::mat& j) { double res = 0; - res = arma::accu(glcm % i); return(res); } @@ -170,9 +167,7 @@ inline double _glcm_variance(const arma::sp_mat& glcm, const arma::mat& i, const arma::mat& j) { double res = 0; - double mean = arma::accu(glcm % i); - res = arma::accu(glcm % pow(i - mean, 2)); return(res); } @@ -183,7 +178,6 @@ inline double _glcm_std(const arma::sp_mat& glcm, const arma::mat& j) { double res = _glcm_variance(glcm, i, j); - res = sqrt(res); return(res); } @@ -194,7 +188,6 @@ inline double _glcm_correlation(const arma::sp_mat& glcm, double res = 0; double mean = arma::accu(glcm % i); double var = _glcm_variance(glcm, i, j); - res = arma::accu(glcm % (( (i-mean) % (j-mean) ) / (var))); return(res); @@ -289,16 +282,3 @@ arma::mat C_glcm_correlation(const arma::vec& x, return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_correlation); } - -// double glcm_entropy(const arma::sp_mat& glcm, -// const arma::mat& i, -// const arma::mat& j) { -// double res = 0; -// -// arma::mat glcm_entropy = glcm % ((-1) * arma::logmat(glcm)); -// glcm_entropy.replace(arma::datum::nan, 0); -// -// res = accu(glcm_entropy); -// return(res); -// } - From 19206994b8befd22cfdaeb033889cd91f64861d2 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 5 Mar 2025 22:22:41 +0000 Subject: [PATCH 039/122] update glcm api in cpp --- src/RcppExports.cpp | 135 +++++++++++++++++++++++--------------------- src/glcm_fns.cpp | 128 ++++++++++++++++++++--------------------- 2 files changed, 134 insertions(+), 129 deletions(-) diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 5f1cfe1f2..b9d480e12 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -105,137 +105,146 @@ BEGIN_RCPP END_RCPP } // C_glcm_contrast -arma::mat C_glcm_contrast(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); -RcppExport SEXP _sits_C_glcm_contrast(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { +arma::mat C_glcm_contrast(const arma::vec& x, const arma::vec& angles, const arma::uword nrows, const arma::uword ncols, const arma::uword n_grey, const arma::u8 window_size); +RcppExport SEXP _sits_C_glcm_contrast(SEXP xSEXP, SEXP anglesSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP n_greySEXP, SEXP window_sizeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_contrast(x, nrows, ncols, window_size, angles)); + Rcpp::traits::input_parameter< const arma::uword >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_grey(n_greySEXP); + Rcpp::traits::input_parameter< const arma::u8 >::type window_size(window_sizeSEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_contrast(x, angles, nrows, ncols, n_grey, window_size)); return rcpp_result_gen; END_RCPP } // C_glcm_dissimilarity -arma::mat C_glcm_dissimilarity(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); -RcppExport SEXP _sits_C_glcm_dissimilarity(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { +arma::mat C_glcm_dissimilarity(const arma::vec& x, const arma::vec& angles, const arma::uword nrows, const arma::uword ncols, const arma::uword n_grey, const arma::u8 window_size); +RcppExport SEXP _sits_C_glcm_dissimilarity(SEXP xSEXP, SEXP anglesSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP n_greySEXP, SEXP window_sizeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_dissimilarity(x, nrows, ncols, window_size, angles)); + Rcpp::traits::input_parameter< const arma::uword >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_grey(n_greySEXP); + Rcpp::traits::input_parameter< const arma::u8 >::type window_size(window_sizeSEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_dissimilarity(x, angles, nrows, ncols, n_grey, window_size)); return rcpp_result_gen; END_RCPP } // C_glcm_homogeneity -arma::mat C_glcm_homogeneity(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); -RcppExport SEXP _sits_C_glcm_homogeneity(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { +arma::mat C_glcm_homogeneity(const arma::vec& x, const arma::vec& angles, const arma::uword nrows, const arma::uword ncols, const arma::uword n_grey, const arma::u8 window_size); +RcppExport SEXP _sits_C_glcm_homogeneity(SEXP xSEXP, SEXP anglesSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP n_greySEXP, SEXP window_sizeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_homogeneity(x, nrows, ncols, window_size, angles)); + Rcpp::traits::input_parameter< const arma::uword >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_grey(n_greySEXP); + Rcpp::traits::input_parameter< const arma::u8 >::type window_size(window_sizeSEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_homogeneity(x, angles, nrows, ncols, n_grey, window_size)); return rcpp_result_gen; END_RCPP } // C_glcm_energy -arma::mat C_glcm_energy(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); -RcppExport SEXP _sits_C_glcm_energy(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { +arma::mat C_glcm_energy(const arma::vec& x, const arma::vec& angles, const arma::uword nrows, const arma::uword ncols, const arma::uword n_grey, const arma::u8 window_size); +RcppExport SEXP _sits_C_glcm_energy(SEXP xSEXP, SEXP anglesSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP n_greySEXP, SEXP window_sizeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_energy(x, nrows, ncols, window_size, angles)); + Rcpp::traits::input_parameter< const arma::uword >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_grey(n_greySEXP); + Rcpp::traits::input_parameter< const arma::u8 >::type window_size(window_sizeSEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_energy(x, angles, nrows, ncols, n_grey, window_size)); return rcpp_result_gen; END_RCPP } // C_glcm_asm -arma::mat C_glcm_asm(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); -RcppExport SEXP _sits_C_glcm_asm(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { +arma::mat C_glcm_asm(const arma::vec& x, const arma::vec& angles, const arma::uword nrows, const arma::uword ncols, const arma::uword n_grey, const arma::u8 window_size); +RcppExport SEXP _sits_C_glcm_asm(SEXP xSEXP, SEXP anglesSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP n_greySEXP, SEXP window_sizeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_asm(x, nrows, ncols, window_size, angles)); + Rcpp::traits::input_parameter< const arma::uword >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_grey(n_greySEXP); + Rcpp::traits::input_parameter< const arma::u8 >::type window_size(window_sizeSEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_asm(x, angles, nrows, ncols, n_grey, window_size)); return rcpp_result_gen; END_RCPP } // C_glcm_mean -arma::mat C_glcm_mean(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); -RcppExport SEXP _sits_C_glcm_mean(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { +arma::mat C_glcm_mean(const arma::vec& x, const arma::vec& angles, const arma::uword nrows, const arma::uword ncols, const arma::uword n_grey, const arma::u8 window_size); +RcppExport SEXP _sits_C_glcm_mean(SEXP xSEXP, SEXP anglesSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP n_greySEXP, SEXP window_sizeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_mean(x, nrows, ncols, window_size, angles)); + Rcpp::traits::input_parameter< const arma::uword >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_grey(n_greySEXP); + Rcpp::traits::input_parameter< const arma::u8 >::type window_size(window_sizeSEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_mean(x, angles, nrows, ncols, n_grey, window_size)); return rcpp_result_gen; END_RCPP } // C_glcm_variance -arma::mat C_glcm_variance(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); -RcppExport SEXP _sits_C_glcm_variance(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { +arma::mat C_glcm_variance(const arma::vec& x, const arma::vec& angles, const arma::uword nrows, const arma::uword ncols, const arma::uword n_grey, const arma::u8 window_size); +RcppExport SEXP _sits_C_glcm_variance(SEXP xSEXP, SEXP anglesSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP n_greySEXP, SEXP window_sizeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_variance(x, nrows, ncols, window_size, angles)); + Rcpp::traits::input_parameter< const arma::uword >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_grey(n_greySEXP); + Rcpp::traits::input_parameter< const arma::u8 >::type window_size(window_sizeSEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_variance(x, angles, nrows, ncols, n_grey, window_size)); return rcpp_result_gen; END_RCPP } // C_glcm_std -arma::mat C_glcm_std(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); -RcppExport SEXP _sits_C_glcm_std(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { +arma::mat C_glcm_std(const arma::vec& x, const arma::vec& angles, const arma::uword nrows, const arma::uword ncols, const arma::uword n_grey, const arma::u8 window_size); +RcppExport SEXP _sits_C_glcm_std(SEXP xSEXP, SEXP anglesSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP n_greySEXP, SEXP window_sizeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_std(x, nrows, ncols, window_size, angles)); + Rcpp::traits::input_parameter< const arma::uword >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_grey(n_greySEXP); + Rcpp::traits::input_parameter< const arma::u8 >::type window_size(window_sizeSEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_std(x, angles, nrows, ncols, n_grey, window_size)); return rcpp_result_gen; END_RCPP } // C_glcm_correlation -arma::mat C_glcm_correlation(const arma::vec& x, const arma::uword& nrows, const arma::uword& ncols, const arma::uword& window_size, const arma::vec& angles); -RcppExport SEXP _sits_C_glcm_correlation(SEXP xSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP window_sizeSEXP, SEXP anglesSEXP) { +arma::mat C_glcm_correlation(const arma::vec& x, const arma::vec& angles, const arma::uword nrows, const arma::uword ncols, const arma::uword n_grey, const arma::u8 window_size); +RcppExport SEXP _sits_C_glcm_correlation(SEXP xSEXP, SEXP anglesSEXP, SEXP nrowsSEXP, SEXP ncolsSEXP, SEXP n_greySEXP, SEXP window_sizeSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< const arma::vec& >::type x(xSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type nrows(nrowsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type ncols(ncolsSEXP); - Rcpp::traits::input_parameter< const arma::uword& >::type window_size(window_sizeSEXP); Rcpp::traits::input_parameter< const arma::vec& >::type angles(anglesSEXP); - rcpp_result_gen = Rcpp::wrap(C_glcm_correlation(x, nrows, ncols, window_size, angles)); + Rcpp::traits::input_parameter< const arma::uword >::type nrows(nrowsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type ncols(ncolsSEXP); + Rcpp::traits::input_parameter< const arma::uword >::type n_grey(n_greySEXP); + Rcpp::traits::input_parameter< const arma::u8 >::type window_size(window_sizeSEXP); + rcpp_result_gen = Rcpp::wrap(C_glcm_correlation(x, angles, nrows, ncols, n_grey, window_size)); return rcpp_result_gen; END_RCPP } @@ -891,15 +900,15 @@ static const R_CallMethodDef CallEntries[] = { {"_sits_weighted_probs", (DL_FUNC) &_sits_weighted_probs, 2}, {"_sits_weighted_uncert_probs", (DL_FUNC) &_sits_weighted_uncert_probs, 2}, {"_sits_dtw_distance", (DL_FUNC) &_sits_dtw_distance, 2}, - {"_sits_C_glcm_contrast", (DL_FUNC) &_sits_C_glcm_contrast, 5}, - {"_sits_C_glcm_dissimilarity", (DL_FUNC) &_sits_C_glcm_dissimilarity, 5}, - {"_sits_C_glcm_homogeneity", (DL_FUNC) &_sits_C_glcm_homogeneity, 5}, - {"_sits_C_glcm_energy", (DL_FUNC) &_sits_C_glcm_energy, 5}, - {"_sits_C_glcm_asm", (DL_FUNC) &_sits_C_glcm_asm, 5}, - {"_sits_C_glcm_mean", (DL_FUNC) &_sits_C_glcm_mean, 5}, - {"_sits_C_glcm_variance", (DL_FUNC) &_sits_C_glcm_variance, 5}, - {"_sits_C_glcm_std", (DL_FUNC) &_sits_C_glcm_std, 5}, - {"_sits_C_glcm_correlation", (DL_FUNC) &_sits_C_glcm_correlation, 5}, + {"_sits_C_glcm_contrast", (DL_FUNC) &_sits_C_glcm_contrast, 6}, + {"_sits_C_glcm_dissimilarity", (DL_FUNC) &_sits_C_glcm_dissimilarity, 6}, + {"_sits_C_glcm_homogeneity", (DL_FUNC) &_sits_C_glcm_homogeneity, 6}, + {"_sits_C_glcm_energy", (DL_FUNC) &_sits_C_glcm_energy, 6}, + {"_sits_C_glcm_asm", (DL_FUNC) &_sits_C_glcm_asm, 6}, + {"_sits_C_glcm_mean", (DL_FUNC) &_sits_C_glcm_mean, 6}, + {"_sits_C_glcm_variance", (DL_FUNC) &_sits_C_glcm_variance, 6}, + {"_sits_C_glcm_std", (DL_FUNC) &_sits_C_glcm_std, 6}, + {"_sits_C_glcm_correlation", (DL_FUNC) &_sits_C_glcm_correlation, 6}, {"_sits_C_kernel_median", (DL_FUNC) &_sits_C_kernel_median, 5}, {"_sits_C_kernel_mean", (DL_FUNC) &_sits_C_kernel_mean, 5}, {"_sits_C_kernel_sd", (DL_FUNC) &_sits_C_kernel_sd, 5}, diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index 3b93861da..12c45209e 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -1,10 +1,6 @@ //[[Rcpp::depends(RcppArmadillo)]] #include #include -#include -#include -#define ARMA_DONT_USE_WRAPPER -#define ARMA_USE_OPENMP using namespace Rcpp; using namespace std; @@ -25,14 +21,16 @@ IntegerVector locus_neigh2(int size, int leg) { return res; } +// This code is inspired by some existing libraries: glcm and +// GLCMTextures R packages. Both are licensed by GPL (>= 3); and the +// Python library scikit-image is licensed by BSD-3-Clause. arma::mat glcm_fn(const arma::vec& x, const arma::vec& angles, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, + const arma::uword nrows, + const arma::uword ncols, + const arma::uword n_grey, + const arma::u8 window_size, _glcm_fun _fun) { - // get the maximum value of grey values - int n_grey = x.max(); // initialize sparse matrix to store co-occurrence values arma::sp_mat glcm_co(n_grey, n_grey); // initialize result matrix @@ -45,7 +43,7 @@ arma::mat glcm_fn(const arma::vec& x, arma::u8 offset_row, offset_col = 1; arma::u16 row, col = 0; arma::uword start_row, end_row, start_col, end_col = 0; - int v_i, v_j, sum = 0; + arma::uword v_i, v_j, sum = 0; // initialize auxiliary matrices needed in some metrics arma::mat i_aux(n_grey, n_grey); @@ -118,7 +116,6 @@ inline double _glcm_contrast(const arma::sp_mat& x, const arma::mat& i, const arma::mat& j) { double res = 0; - res = arma::accu(x % pow(i - j, 2)); return(res); } @@ -176,7 +173,6 @@ inline double _glcm_variance(const arma::sp_mat& glcm, inline double _glcm_std(const arma::sp_mat& glcm, const arma::mat& i, const arma::mat& j) { - double res = _glcm_variance(glcm, i, j); res = sqrt(res); return(res); @@ -195,90 +191,90 @@ inline double _glcm_correlation(const arma::sp_mat& glcm, // [[Rcpp::export]] arma::mat C_glcm_contrast(const arma::vec& x, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, - const arma::vec& angles) { - - return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_contrast); + const arma::vec& angles, + const arma::uword nrows, + const arma::uword ncols, + const arma::uword n_grey, + const arma::u8 window_size) { + return glcm_fn(x, angles, nrows, ncols, n_grey, window_size, _glcm_contrast); } // [[Rcpp::export]] arma::mat C_glcm_dissimilarity(const arma::vec& x, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, - const arma::vec& angles) { - - return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_dissimilarity); + const arma::vec& angles, + const arma::uword nrows, + const arma::uword ncols, + const arma::uword n_grey, + const arma::u8 window_size) { + return glcm_fn(x, angles, nrows, ncols, n_grey, window_size, _glcm_dissimilarity); } // [[Rcpp::export]] arma::mat C_glcm_homogeneity(const arma::vec& x, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, - const arma::vec& angles) { - - return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_homogeneity); + const arma::vec& angles, + const arma::uword nrows, + const arma::uword ncols, + const arma::uword n_grey, + const arma::u8 window_size) { + return glcm_fn(x, angles, nrows, ncols, n_grey, window_size, _glcm_homogeneity); } // [[Rcpp::export]] arma::mat C_glcm_energy(const arma::vec& x, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, - const arma::vec& angles) { - - return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_energy); + const arma::vec& angles, + const arma::uword nrows, + const arma::uword ncols, + const arma::uword n_grey, + const arma::u8 window_size) { + return glcm_fn(x, angles, nrows, ncols, n_grey, window_size, _glcm_energy); } // [[Rcpp::export]] arma::mat C_glcm_asm(const arma::vec& x, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, - const arma::vec& angles) { - - return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_asm); + const arma::vec& angles, + const arma::uword nrows, + const arma::uword ncols, + const arma::uword n_grey, + const arma::u8 window_size) { + return glcm_fn(x, angles, nrows, ncols, n_grey, window_size, _glcm_asm); } // [[Rcpp::export]] arma::mat C_glcm_mean(const arma::vec& x, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, - const arma::vec& angles) { - - return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_mean); + const arma::vec& angles, + const arma::uword nrows, + const arma::uword ncols, + const arma::uword n_grey, + const arma::u8 window_size) { + return glcm_fn(x, angles, nrows, ncols, n_grey, window_size, _glcm_mean); } // [[Rcpp::export]] arma::mat C_glcm_variance(const arma::vec& x, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, - const arma::vec& angles) { - - return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_variance); + const arma::vec& angles, + const arma::uword nrows, + const arma::uword ncols, + const arma::uword n_grey, + const arma::u8 window_size) { + return glcm_fn(x, angles, nrows, ncols, n_grey, window_size, _glcm_variance); } // [[Rcpp::export]] arma::mat C_glcm_std(const arma::vec& x, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, - const arma::vec& angles) { - - return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_std); + const arma::vec& angles, + const arma::uword nrows, + const arma::uword ncols, + const arma::uword n_grey, + const arma::u8 window_size) { + return glcm_fn(x, angles, nrows, ncols, n_grey, window_size, _glcm_std); } // [[Rcpp::export]] arma::mat C_glcm_correlation(const arma::vec& x, - const arma::uword& nrows, - const arma::uword& ncols, - const arma::uword& window_size, - const arma::vec& angles) { - - return glcm_fn(x, angles, nrows, ncols, window_size, _glcm_correlation); + const arma::vec& angles, + const arma::uword nrows, + const arma::uword ncols, + const arma::uword n_grey, + const arma::u8 window_size) { + return glcm_fn(x, angles, nrows, ncols, n_grey, window_size, _glcm_correlation); } From 60dcb3cbc4f63776823f5df54102ca64dcfac4a3 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 5 Mar 2025 22:23:46 +0000 Subject: [PATCH 040/122] add default configs in glcm --- R/RcppExports.R | 36 ++++++++--------- R/api_glcm.R | 100 ++++++++++++++++++++++++++++++++---------------- R/sits_glcm.R | 44 +++++++++------------ 3 files changed, 102 insertions(+), 78 deletions(-) diff --git a/R/RcppExports.R b/R/RcppExports.R index 733845ad3..fb19d608c 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -29,40 +29,40 @@ dtw_distance <- function(ts1, ts2) { .Call(`_sits_dtw_distance`, ts1, ts2) } -C_glcm_contrast <- function(x, nrows, ncols, window_size, angles) { - .Call(`_sits_C_glcm_contrast`, x, nrows, ncols, window_size, angles) +C_glcm_contrast <- function(x, angles, nrows, ncols, n_grey, window_size) { + .Call(`_sits_C_glcm_contrast`, x, angles, nrows, ncols, n_grey, window_size) } -C_glcm_dissimilarity <- function(x, nrows, ncols, window_size, angles) { - .Call(`_sits_C_glcm_dissimilarity`, x, nrows, ncols, window_size, angles) +C_glcm_dissimilarity <- function(x, angles, nrows, ncols, n_grey, window_size) { + .Call(`_sits_C_glcm_dissimilarity`, x, angles, nrows, ncols, n_grey, window_size) } -C_glcm_homogeneity <- function(x, nrows, ncols, window_size, angles) { - .Call(`_sits_C_glcm_homogeneity`, x, nrows, ncols, window_size, angles) +C_glcm_homogeneity <- function(x, angles, nrows, ncols, n_grey, window_size) { + .Call(`_sits_C_glcm_homogeneity`, x, angles, nrows, ncols, n_grey, window_size) } -C_glcm_energy <- function(x, nrows, ncols, window_size, angles) { - .Call(`_sits_C_glcm_energy`, x, nrows, ncols, window_size, angles) +C_glcm_energy <- function(x, angles, nrows, ncols, n_grey, window_size) { + .Call(`_sits_C_glcm_energy`, x, angles, nrows, ncols, n_grey, window_size) } -C_glcm_asm <- function(x, nrows, ncols, window_size, angles) { - .Call(`_sits_C_glcm_asm`, x, nrows, ncols, window_size, angles) +C_glcm_asm <- function(x, angles, nrows, ncols, n_grey, window_size) { + .Call(`_sits_C_glcm_asm`, x, angles, nrows, ncols, n_grey, window_size) } -C_glcm_mean <- function(x, nrows, ncols, window_size, angles) { - .Call(`_sits_C_glcm_mean`, x, nrows, ncols, window_size, angles) +C_glcm_mean <- function(x, angles, nrows, ncols, n_grey, window_size) { + .Call(`_sits_C_glcm_mean`, x, angles, nrows, ncols, n_grey, window_size) } -C_glcm_variance <- function(x, nrows, ncols, window_size, angles) { - .Call(`_sits_C_glcm_variance`, x, nrows, ncols, window_size, angles) +C_glcm_variance <- function(x, angles, nrows, ncols, n_grey, window_size) { + .Call(`_sits_C_glcm_variance`, x, angles, nrows, ncols, n_grey, window_size) } -C_glcm_std <- function(x, nrows, ncols, window_size, angles) { - .Call(`_sits_C_glcm_std`, x, nrows, ncols, window_size, angles) +C_glcm_std <- function(x, angles, nrows, ncols, n_grey, window_size) { + .Call(`_sits_C_glcm_std`, x, angles, nrows, ncols, n_grey, window_size) } -C_glcm_correlation <- function(x, nrows, ncols, window_size, angles) { - .Call(`_sits_C_glcm_correlation`, x, nrows, ncols, window_size, angles) +C_glcm_correlation <- function(x, angles, nrows, ncols, n_grey, window_size) { + .Call(`_sits_C_glcm_correlation`, x, angles, nrows, ncols, n_grey, window_size) } C_kernel_median <- function(x, ncols, nrows, band, window_size) { diff --git a/R/api_glcm.R b/R/api_glcm.R index 4c345f473..887e0f12f 100644 --- a/R/api_glcm.R +++ b/R/api_glcm.R @@ -2,8 +2,10 @@ #' @name .glcm_feature #' @keywords internal #' @noRd +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @author Rolf Simoes, \email{rolf.simoes@@inpe.br} -#' @author Felipe Carvalho, \email{rolf.simoes@@inpe.br} +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @param feature Subset of a data cube containing the input bands #' used in the expression @@ -47,8 +49,10 @@ # Get band configuration band_conf <- .tile_band_conf(tile = feature, band = out_band) if (.has_not(band_conf)) { - band_conf <- .conf("default_values", "INT4S") + band_conf <- .conf("default_values", "INT2S") } + # Get the default grey level + n_grey <- .conf(c("glcm_options", "max_grey_level")) # Process jobs sequentially block_files <- .jobs_map_parallel(chunks, function(chunk) { # Get job block @@ -67,11 +71,10 @@ values <- .apply_data_read( tile = feature, block = block, in_bands = in_bands ) - # Scale band values - scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { - values <- values / scale - } + # Fill with zeros remaining NA pixels + values[[1]] <- C_fill_na(as.matrix(values[[1]]), 0) + # Scale values + values <- .glcm_scale(values, band_conf) # Evaluate expression here # Band and kernel evaluation values <- eval( @@ -81,7 +84,8 @@ window_size = window_size, angles = angles, img_nrow = block[["nrows"]], - img_ncol = block[["ncols"]] + img_ncol = block[["ncols"]], + n_grey = n_grey ) ) # Prepare fractions to be saved @@ -98,8 +102,6 @@ missing_value = .miss_value(band_conf), crop_block = crop_block ) - # Free memory - gc() # Returned block files for each fraction block_files }) @@ -113,70 +115,100 @@ multicores = 1, update_bbox = FALSE ) - band_tile + return(band_tile) +} + +#' @title Scale values based on a grey level range +#' @name .glcm_scale +#' @noRd +#' @param cube sits cube +#' @return a vector with the adjusted block size +.glcm_scale <- function(values, band_conf) { + glcm_min <- .conf(c("glcm_options", "min_grey_level")) + glcm_max <- .conf(c("glcm_options", "max_grey_level")) + scale <- .scale(band_conf) + values <- values / scale + from <- c(.min_value(band_conf), .max_value(band_conf)) + to <- c(glcm_min, glcm_max) + + values <- (values - from[1]) / diff(from) * diff(to) + to[1] + return(values) +} + +#' @title Get block size +#' @name .glcm_get_blocksize +#' @noRd +#' @param cube sits cube +#' @return a vector with the adjusted block size +.glcm_get_blocksize <- function(cube) { + block <- .raster_file_blocksize(.raster_open_rast(.tile_path(cube))) + glcm_block_size <- .conf(c("glcm_options", "block_size")) + block[["nrows"]] <- min(block[["nrows"]], glcm_block_size) + block[["ncols"]] <- min(block[["ncols"]], glcm_block_size) + return(block) } #' @title Kernel function for window operations in spatial neighbourhoods #' @name .glcm_functions #' @noRd -#' @param windows size of local window -#' @param img_nrow image size in rows -#' @param img_ncol image size in cols -#' @return operations on local kernels -.glcm_functions <- function(window_size, angles, img_nrow, img_ncol) { +#' @param window_size size of local window +#' @param img_nrow image size in rows +#' @param img_ncol image size in cols +#' @return glcm measures +.glcm_functions <- function(window_size, angles, img_nrow, img_ncol, n_grey) { result_env <- list2env(list( glcm_contrast = function(m) { C_glcm_contrast( - x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = angles + x = .as_int(unlist(m)), angles = angles, nrows = img_nrow, + ncols = img_ncol, window_size = window_size, n_grey = n_grey ) }, glcm_dissimilarity = function(m) { C_glcm_dissimilarity( - x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = angles + x = .as_int(unlist(m)), angles = angles, nrows = img_nrow, + ncols = img_ncol, window_size = window_size, n_grey = n_grey ) }, glcm_homogeneity = function(m) { C_glcm_homogeneity( - x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = angles + x = .as_int(unlist(m)), angles = angles, nrows = img_nrow, + ncols = img_ncol, window_size = window_size, n_grey = n_grey ) }, glcm_energy = function(m) { C_glcm_energy( - x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = angles + x = .as_int(unlist(m)), angles = angles, nrows = img_nrow, + ncols = img_ncol, window_size = window_size, n_grey = n_grey ) }, glcm_asm = function(m) { C_glcm_asm( - x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = angles + x = .as_int(unlist(m)), angles = angles, nrows = img_nrow, + ncols = img_ncol, window_size = window_size, n_grey = n_grey ) }, glcm_mean = function(m) { C_glcm_mean( - x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = angles + x = .as_int(unlist(m)), angles = angles, nrows = img_nrow, + ncols = img_ncol, window_size = window_size, n_grey = n_grey ) }, glcm_variance = function(m) { C_glcm_variance( - x = m, nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = angles + x = .as_int(unlist(m)), angles = angles, nrows = img_nrow, + ncols = img_ncol, window_size = window_size, n_grey = n_grey ) }, glcm_std = function(m) { C_glcm_std( - x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = angles + x = .as_int(unlist(m)), angles = angles, nrows = img_nrow, + ncols = img_ncol, window_size = window_size, n_grey = n_grey ) }, glcm_correlation = function(m) { C_glcm_correlation( - x = .as_int(unlist(m)), nrows = img_nrow, ncols = img_ncol, - window_size = window_size, angles = angles + x = .as_int(unlist(m)), angles = angles, nrows = img_nrow, + ncols = img_ncol, window_size = window_size, n_grey = n_grey ) } ), parent = parent.env(environment()), hash = TRUE) diff --git a/R/sits_glcm.R b/R/sits_glcm.R index dd4b228ab..d0ac4b9db 100644 --- a/R/sits_glcm.R +++ b/R/sits_glcm.R @@ -1,4 +1,4 @@ -#' @title Apply a GLCM texture on a data cube +#' @title Apply a GLCM texture on a data cube. #' #' @name sits_glcm #' @@ -8,9 +8,9 @@ #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description A set of texture measures based on the Grey Level Co-occurrence -#' Matrix (GLCM) described by Haralick (referenced below). Our implementation +#' Matrix (GLCM) described by Haralick. Our implementation #' follows the guidelines and equations described by Hall-Beyer -#' (referenced below). +#' (both are referenced below). #' #' @references #' Robert M. Haralick, K. Shanmugam, Its'Hak Dinstein, @@ -40,7 +40,7 @@ #' with SPOT HRV data", Remote Sensing of Environment, 40, 2, 1992, 137-151, #' DOI: 10.1016/0034-4257(92)90011-8. #' -#' @param data Valid sits tibble or cube +#' @param cube Valid sits cube #' @param window_size An odd number representing the size of the #' sliding window. #' @param angles The direction angles in radians related to the @@ -105,9 +105,9 @@ #' data_dir = data_dir #' ) #' -#' # Generate a texture images with variance in NDVI images +#' # Compute the NDVI variance #' cube_texture <- sits_glcm( -#' data = cube, +#' cube = cube, #' NDVIVAR = glcm_variance(NDVI), #' window_size = 5, #' output_dir = tempdir() @@ -115,15 +115,15 @@ #' } #' @rdname sits_glcm #' @export -sits_glcm <- function(data, ...) { +sits_glcm <- function(cube, ...) { .check_set_caller("sits_glcm") - .check_na_null_parameter(data) - UseMethod("sits_glcm", data) + .check_na_null_parameter(cube) + UseMethod("sits_glcm", cube) } #' @rdname sits_glcm #' @export -sits_glcm.raster_cube <- function(data, ..., +sits_glcm.raster_cube <- function(cube, ..., window_size = 3L, angles = 0, memsize = 4L, @@ -131,8 +131,8 @@ sits_glcm.raster_cube <- function(data, ..., output_dir, progress = FALSE) { # Check cube - .check_is_raster_cube(data) - .check_that(.cube_is_regular(data)) + .check_is_raster_cube(cube) + .check_that(.cube_is_regular(cube)) # Check window size .check_int_parameter(window_size, min = 1, is_odd = TRUE) # Check normalized index @@ -145,29 +145,29 @@ sits_glcm.raster_cube <- function(data, ..., .check_output_dir(output_dir) # Get cube bands - bands <- .cube_bands(data) + bands <- .cube_bands(cube) # Get output band expression expr <- .apply_capture_expression(...) out_band <- names(expr) # Check if band already exists in cube if (out_band %in% bands) { if (.check_messages()) { - warning(.conf("messages", "sits_apply_out_band"), + warning(.conf("messages", "sits_glcm_out_band"), call. = FALSE ) } - return(data) + return(cube) } # Get all input bands in cube data in_bands <- .apply_input_bands( - cube = data, + cube = cube, bands = bands, expr = expr ) # Overlapping pixels overlap <- ceiling(window_size / 2) - 1 # Get block size - block <- .raster_file_blocksize(.raster_open_rast(.tile_path(data))) + block <- .glcm_get_blocksize(cube) # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( block_size = .block_size(block = block, overlap = overlap), @@ -181,20 +181,12 @@ sits_glcm.raster_cube <- function(data, ..., memsize = memsize, multicores = multicores ) - # Update block parameter - block <- .jobs_optimal_block( - job_block_memsize = job_block_memsize, - block = block, - image_size = .tile_size(.tile(data)), - memsize = memsize, - multicores = multicores - ) # Prepare parallelization .parallel_start(workers = multicores) on.exit(.parallel_stop(), add = TRUE) # Create features as jobs - features_cube <- .cube_split_features(data) + features_cube <- .cube_split_features(cube) # Process each feature in parallel features_band <- .jobs_map_sequential_dfr(features_cube, function(feature) { From 41fce662e7faa693600c698d7df63babda0219eb Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 5 Mar 2025 22:24:06 +0000 Subject: [PATCH 041/122] add tests for glcm --- tests/testthat/test-glcm.R | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) create mode 100644 tests/testthat/test-glcm.R diff --git a/tests/testthat/test-glcm.R b/tests/testthat/test-glcm.R new file mode 100644 index 000000000..32f4d2ee5 --- /dev/null +++ b/tests/testthat/test-glcm.R @@ -0,0 +1,38 @@ +test_that("Testing glcm generation", { + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + # Create a MODIS cube + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + dir_images <- paste0(tempdir(), "/images/") + if (!dir.exists(dir_images)) { + suppressWarnings(dir.create(dir_images)) + } + unlink(list.files(dir_images, + pattern = "\\.tif$", + full.names = TRUE + )) + feature <- sits_select(cube, bands = "NDVI", dates = "2013-09-14") + # Compute the NDVI variance + texture <- sits_glcm( + cube = feature, + NDVIVAR = glcm_variance(NDVI), + window_size = 5, + output_dir = dir_images + ) + + # Test NDVIVAR + expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIVAR"))) + + timeline <- sits_timeline(texture) + expect_true(timeline == "2013-09-14") + + file_info_ndvivar <- .fi(texture) |> .fi_filter_bands(bands = "NDVIVAR") + ndvivar_band_1 <- .raster_open_rast(file_info_ndvivar$path[[1]]) + rast_freq <- .raster_freq(ndvivar_band_1) + expect_true(mean(a[,"value"]) > 7000) + + unlink(dir_images, recursive = TRUE) +}) From 1105fa12eb8de596ace1ed4225f84934859e364c Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 5 Mar 2025 22:24:28 +0000 Subject: [PATCH 042/122] add internal configs for glcm --- inst/extdata/config_internals.yml | 6 ++++++ inst/extdata/config_messages.yml | 3 +++ 2 files changed, 9 insertions(+) diff --git a/inst/extdata/config_internals.yml b/inst/extdata/config_internals.yml index e9654c6dd..c252c64c6 100644 --- a/inst/extdata/config_internals.yml +++ b/inst/extdata/config_internals.yml @@ -274,6 +274,12 @@ som_outcomes: ["clean", "analyze", "remove"] metadata_search_strategies: ["tile", "feature"] +# GLCM metadata +glcm_options: + block_size: 512 + min_grey_level: 0 + max_grey_level: 1000 + # Colours and plots # # color table mandatory collumns diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index d17948476..31e1ea0c2 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -399,6 +399,9 @@ sits_get_data_sf: "sf objects need a column with an id for each polygon\n please sits_get_data_shp: "shp objects need a column with an id for each polygon\n please include this column name in the 'pol_id' parameter" sits_get_probs: "unable to retrieve data from probability cube - check input parameters" sits_get_probs_not_point: "samples should have POINT geometry type" +sits_glcm_out_band: "output band already exists in data cube and will be replaced" +sits_glcm_derived_cube: "input data should be a non-classified cube" +sits_glcm_default: "input should be a valid set of training samples or a non-classified data cube" sits_hist_raster_cube: "invalid input data to compute histogram" sits_hist_tile: "tile is not part of the cube" sits_hist_label: "labels is not one of cube labels" From 95bbc9298d57ad779bf08ea0ce809488d975f751 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 5 Mar 2025 22:24:36 +0000 Subject: [PATCH 043/122] update docs --- man/sits_glcm.Rd | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/man/sits_glcm.Rd b/man/sits_glcm.Rd index 387b50b26..24099d97b 100644 --- a/man/sits_glcm.Rd +++ b/man/sits_glcm.Rd @@ -5,12 +5,12 @@ \alias{sits_glcm.raster_cube} \alias{sits_glcm.derived_cube} \alias{sits_glcm.default} -\title{Apply a GLCM texture on a data cube} +\title{Apply a GLCM texture on a data cube.} \usage{ -sits_glcm(data, ...) +sits_glcm(cube, ...) \method{sits_glcm}{raster_cube}( - data, + cube, ..., window_size = 3L, angles = 0, @@ -25,7 +25,7 @@ sits_glcm(data, ...) \method{sits_glcm}{default}(data, ...) } \arguments{ -\item{data}{Valid sits tibble or cube} +\item{cube}{Valid sits cube} \item{...}{GLCM function (see details).} @@ -50,9 +50,9 @@ measure. } \description{ A set of texture measures based on the Grey Level Co-occurrence -Matrix (GLCM) described by Haralick (referenced below). Our implementation +Matrix (GLCM) described by Haralick. Our implementation follows the guidelines and equations described by Hall-Beyer -(referenced below). +(both are referenced below). } \details{ The spatial relation between the central pixel and its neighbor is expressed @@ -106,9 +106,9 @@ if (sits_run_examples()) { data_dir = data_dir ) - # Generate a texture images with variance in NDVI images + # Compute the NDVI variance cube_texture <- sits_glcm( - data = cube, + cube = cube, NDVIVAR = glcm_variance(NDVI), window_size = 5, output_dir = tempdir() From 7f9eb9f5045d68f80809832dbba6728e3496312f Mon Sep 17 00:00:00 2001 From: Felipe Date: Thu, 6 Mar 2025 21:14:57 +0000 Subject: [PATCH 044/122] add a function to normalize glcm values --- R/api_glcm.R | 37 +++++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 16 deletions(-) diff --git a/R/api_glcm.R b/R/api_glcm.R index 887e0f12f..5608c6185 100644 --- a/R/api_glcm.R +++ b/R/api_glcm.R @@ -51,8 +51,8 @@ if (.has_not(band_conf)) { band_conf <- .conf("default_values", "INT2S") } - # Get the default grey level - n_grey <- .conf(c("glcm_options", "max_grey_level")) + # Get gclm options + glcm_conf <- .conf("glcm_options") # Process jobs sequentially block_files <- .jobs_map_parallel(chunks, function(chunk) { # Get job block @@ -74,7 +74,14 @@ # Fill with zeros remaining NA pixels values[[1]] <- C_fill_na(as.matrix(values[[1]]), 0) # Scale values - values <- .glcm_scale(values, band_conf) + scale <- .scale(band_conf) + values <- values / scale + # Normalize input values + values <- .glcm_normalize( + values = values, + source = c(.min_value(band_conf), .max_value(band_conf)), + dest = c(.min_value(glcm_conf), .max_value(glcm_conf)) + ) # Evaluate expression here # Band and kernel evaluation values <- eval( @@ -85,7 +92,7 @@ angles = angles, img_nrow = block[["nrows"]], img_ncol = block[["ncols"]], - n_grey = n_grey + n_grey = .max_value(glcm_conf) ) ) # Prepare fractions to be saved @@ -118,20 +125,18 @@ return(band_tile) } -#' @title Scale values based on a grey level range -#' @name .glcm_scale +#' @title Normalize values based on a min and max range +#' @name .glcm_normalize +#' @description This code is based on scales package. #' @noRd -#' @param cube sits cube +#' @param values Numeric matrix or vector +#' @param source A vector with the minimum and maximum values of the +#' source values. +#' @param dest A vector with the minimum and maximum of the destination +#' values. #' @return a vector with the adjusted block size -.glcm_scale <- function(values, band_conf) { - glcm_min <- .conf(c("glcm_options", "min_grey_level")) - glcm_max <- .conf(c("glcm_options", "max_grey_level")) - scale <- .scale(band_conf) - values <- values / scale - from <- c(.min_value(band_conf), .max_value(band_conf)) - to <- c(glcm_min, glcm_max) - - values <- (values - from[1]) / diff(from) * diff(to) + to[1] +.glcm_normalize <- function(values, source, dest) { + values <- (values - source[1]) / diff(source) * diff(dest) + dest[1] return(values) } From 42fd224d8df3f57bec3c7aee613ada95d3e757f8 Mon Sep 17 00:00:00 2001 From: Felipe Date: Thu, 6 Mar 2025 21:15:08 +0000 Subject: [PATCH 045/122] update glcm tests --- tests/testthat/test-glcm.R | 89 ++++++++++++++++++++++++++++++++++---- 1 file changed, 80 insertions(+), 9 deletions(-) diff --git a/tests/testthat/test-glcm.R b/tests/testthat/test-glcm.R index 32f4d2ee5..d9c854d92 100644 --- a/tests/testthat/test-glcm.R +++ b/tests/testthat/test-glcm.R @@ -6,6 +6,7 @@ test_that("Testing glcm generation", { collection = "MOD13Q1-6.1", data_dir = data_dir ) + feature <- sits_select(cube, bands = "NDVI", dates = "2013-09-14") dir_images <- paste0(tempdir(), "/images/") if (!dir.exists(dir_images)) { suppressWarnings(dir.create(dir_images)) @@ -14,25 +15,95 @@ test_that("Testing glcm generation", { pattern = "\\.tif$", full.names = TRUE )) - feature <- sits_select(cube, bands = "NDVI", dates = "2013-09-14") # Compute the NDVI variance texture <- sits_glcm( cube = feature, NDVIVAR = glcm_variance(NDVI), window_size = 5, + multicores = 1, output_dir = dir_images ) - - # Test NDVIVAR expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIVAR"))) - timeline <- sits_timeline(texture) - expect_true(timeline == "2013-09-14") + # Compute the NDVI mean + texture <- sits_glcm( + cube = feature, + NDVIMEAN = glcm_mean(NDVI), + window_size = 5, + multicores = 1, + output_dir = dir_images + ) + expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIMEAN"))) - file_info_ndvivar <- .fi(texture) |> .fi_filter_bands(bands = "NDVIVAR") - ndvivar_band_1 <- .raster_open_rast(file_info_ndvivar$path[[1]]) - rast_freq <- .raster_freq(ndvivar_band_1) - expect_true(mean(a[,"value"]) > 7000) + # Compute the NDVI contrast + texture <- sits_glcm( + cube = feature, + NDVICONTRAST = glcm_contrast(NDVI), + window_size = 5, + multicores = 1, + output_dir = dir_images + ) + expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVICONTRAST"))) + + # Compute the NDVI dissimilarity + texture <- sits_glcm( + cube = feature, + NDVIDISSIMILARITY = glcm_dissimilarity(NDVI), + window_size = 5, + multicores = 1, + output_dir = dir_images + ) + expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIDISSIMILARITY"))) + + # Compute the NDVI homogeneity + texture <- sits_glcm( + cube = feature, + NDVIHOMOGEINEITY = glcm_homogeneity(NDVI), + window_size = 5, + multicores = 1, + output_dir = dir_images + ) + expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIHOMOGEINEITY"))) + + # Compute the NDVI energy + texture <- sits_glcm( + cube = feature, + NDVIENERGY = glcm_energy(NDVI), + window_size = 5, + multicores = 1, + output_dir = dir_images + ) + expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIENERGY"))) + + # Compute the NDVI asm + texture <- sits_glcm( + cube = feature, + NDVIASM = glcm_asm(NDVI), + window_size = 5, + multicores = 1, + output_dir = dir_images + ) + expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIASM"))) + + # Compute the NDVI std + texture <- sits_glcm( + cube = feature, + NDVISTD = glcm_std(NDVI), + window_size = 5, + multicores = 1, + output_dir = dir_images + ) + expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVISTD"))) + + # Compute the NDVI correlation + texture <- sits_glcm( + cube = feature, + NDVICORRELATION = glcm_correlation(NDVI), + window_size = 5, + multicores = 1, + output_dir = dir_images + ) + expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVICORRELATION"))) unlink(dir_images, recursive = TRUE) }) From 58cc58a125b37d439cd28f5e38038bd0ee21ec9b Mon Sep 17 00:00:00 2001 From: Felipe Date: Thu, 6 Mar 2025 21:15:23 +0000 Subject: [PATCH 046/122] update internal config --- inst/extdata/config_internals.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/inst/extdata/config_internals.yml b/inst/extdata/config_internals.yml index c252c64c6..0dc38902a 100644 --- a/inst/extdata/config_internals.yml +++ b/inst/extdata/config_internals.yml @@ -277,8 +277,8 @@ metadata_search_strategies: ["tile", "feature"] # GLCM metadata glcm_options: block_size: 512 - min_grey_level: 0 - max_grey_level: 1000 + minimum_value: 0 + maximum_value: 1000 # Colours and plots # From 1e09be10bb1b211d70002b7de147f7f0786d8230 Mon Sep 17 00:00:00 2001 From: Felipe Date: Mon, 10 Mar 2025 23:50:29 +0000 Subject: [PATCH 047/122] change glcm to texture --- R/{api_glcm.R => api_texture.R} | 26 ++++++++--------- R/{sits_glcm.R => sits_texture.R} | 48 +++++++++++++++---------------- 2 files changed, 37 insertions(+), 37 deletions(-) rename R/{api_glcm.R => api_texture.R} (92%) rename R/{sits_glcm.R => sits_texture.R} (88%) diff --git a/R/api_glcm.R b/R/api_texture.R similarity index 92% rename from R/api_glcm.R rename to R/api_texture.R index 5608c6185..74951836e 100644 --- a/R/api_glcm.R +++ b/R/api_texture.R @@ -1,5 +1,5 @@ -#' @title Apply a glcm measure to a raster block -#' @name .glcm_feature +#' @title Apply a set of texture measure to a raster block +#' @name .texture_feature #' @keywords internal #' @noRd #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} @@ -20,7 +20,7 @@ #' @param output_dir Directory where image will be save #' #' @return A feature compose by a combination of tile and band. -.glcm_feature <- function(feature, block, window_size, angles, expr, +.texture_feature <- function(feature, block, window_size, angles, expr, out_band, in_bands, overlap, output_dir) { # Output file out_file <- .file_eo_name( @@ -52,7 +52,7 @@ band_conf <- .conf("default_values", "INT2S") } # Get gclm options - glcm_conf <- .conf("glcm_options") + glcm_conf <- .conf("texture_options") # Process jobs sequentially block_files <- .jobs_map_parallel(chunks, function(chunk) { # Get job block @@ -77,7 +77,7 @@ scale <- .scale(band_conf) values <- values / scale # Normalize input values - values <- .glcm_normalize( + values <- .texture_normalize( values = values, source = c(.min_value(band_conf), .max_value(band_conf)), dest = c(.min_value(glcm_conf), .max_value(glcm_conf)) @@ -87,7 +87,7 @@ values <- eval( expr = expr[[out_band]], envir = values, - enclos = .glcm_functions( + enclos = .texture_functions( window_size = window_size, angles = angles, img_nrow = block[["nrows"]], @@ -126,7 +126,7 @@ } #' @title Normalize values based on a min and max range -#' @name .glcm_normalize +#' @name .texture_normalize #' @description This code is based on scales package. #' @noRd #' @param values Numeric matrix or vector @@ -135,32 +135,32 @@ #' @param dest A vector with the minimum and maximum of the destination #' values. #' @return a vector with the adjusted block size -.glcm_normalize <- function(values, source, dest) { +.texture_normalize <- function(values, source, dest) { values <- (values - source[1]) / diff(source) * diff(dest) + dest[1] return(values) } #' @title Get block size -#' @name .glcm_get_blocksize +#' @name .texture_blocksize #' @noRd #' @param cube sits cube #' @return a vector with the adjusted block size -.glcm_get_blocksize <- function(cube) { +.texture_blocksize <- function(cube) { block <- .raster_file_blocksize(.raster_open_rast(.tile_path(cube))) - glcm_block_size <- .conf(c("glcm_options", "block_size")) + glcm_block_size <- .conf(c("texture_options", "block_size")) block[["nrows"]] <- min(block[["nrows"]], glcm_block_size) block[["ncols"]] <- min(block[["ncols"]], glcm_block_size) return(block) } #' @title Kernel function for window operations in spatial neighbourhoods -#' @name .glcm_functions +#' @name .texture_functions #' @noRd #' @param window_size size of local window #' @param img_nrow image size in rows #' @param img_ncol image size in cols #' @return glcm measures -.glcm_functions <- function(window_size, angles, img_nrow, img_ncol, n_grey) { +.texture_functions <- function(window_size, angles, img_nrow, img_ncol, n_grey) { result_env <- list2env(list( glcm_contrast = function(m) { C_glcm_contrast( diff --git a/R/sits_glcm.R b/R/sits_texture.R similarity index 88% rename from R/sits_glcm.R rename to R/sits_texture.R index d0ac4b9db..761dd408a 100644 --- a/R/sits_glcm.R +++ b/R/sits_texture.R @@ -1,6 +1,6 @@ -#' @title Apply a GLCM texture on a data cube. +#' @title Apply a set texture measures on a data cube. #' -#' @name sits_glcm +#' @name sits_texture #' #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} @@ -106,30 +106,30 @@ #' ) #' #' # Compute the NDVI variance -#' cube_texture <- sits_glcm( +#' cube_texture <- sits_texture( #' cube = cube, #' NDVIVAR = glcm_variance(NDVI), #' window_size = 5, #' output_dir = tempdir() #' ) #' } -#' @rdname sits_glcm +#' @rdname sits_texture #' @export -sits_glcm <- function(cube, ...) { - .check_set_caller("sits_glcm") +sits_texture <- function(cube, ...) { + .check_set_caller("sits_texture") .check_na_null_parameter(cube) - UseMethod("sits_glcm", cube) + UseMethod("sits_texture", cube) } -#' @rdname sits_glcm +#' @rdname sits_texture #' @export -sits_glcm.raster_cube <- function(cube, ..., - window_size = 3L, - angles = 0, - memsize = 4L, - multicores = 2L, - output_dir, - progress = FALSE) { +sits_texture.raster_cube <- function(cube, ..., + window_size = 3L, + angles = 0, + memsize = 4L, + multicores = 2L, + output_dir, + progress = FALSE) { # Check cube .check_is_raster_cube(cube) .check_that(.cube_is_regular(cube)) @@ -167,7 +167,7 @@ sits_glcm.raster_cube <- function(cube, ..., # Overlapping pixels overlap <- ceiling(window_size / 2) - 1 # Get block size - block <- .glcm_get_blocksize(cube) + block <- .texture_blocksize(cube) # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( block_size = .block_size(block = block, overlap = overlap), @@ -191,7 +191,7 @@ sits_glcm.raster_cube <- function(cube, ..., # Process each feature in parallel features_band <- .jobs_map_sequential_dfr(features_cube, function(feature) { # Process the data - output_feature <- .glcm_feature( + output_feature <- .texture_feature( feature = feature, block = block, expr = expr, @@ -208,23 +208,23 @@ sits_glcm.raster_cube <- function(cube, ..., .cube_merge_tiles(dplyr::bind_rows(list(features_cube, features_band))) } -#' @rdname sits_glcm +#' @rdname sits_texture #' @export -sits_glcm.derived_cube <- function(data, ...) { - stop(.conf("messages", "sits_glcm_derived_cube")) +sits_texture.derived_cube <- function(data, ...) { + stop(.conf("messages", "sits_texture_derived_cube")) } -#' @rdname sits_glcm +#' @rdname sits_texture #' @export -sits_glcm.default <- function(data, ...) { +sits_texture.default <- function(data, ...) { data <- tibble::as_tibble(data) if (all(.conf("sits_cube_cols") %in% colnames(data))) { data <- .cube_find_class(data) } else if (all(.conf("sits_tibble_cols") %in% colnames(data))) { class(data) <- c("sits", class(data)) } else { - stop(.conf("messages", "sits_glcm_default")) + stop(.conf("messages", "sits_texture_default")) } - acc <- sits_glcm(data, ...) + acc <- sits_texture(data, ...) return(acc) } From 169f442a5789f4a7f390960f2b18bfa3dc095887 Mon Sep 17 00:00:00 2001 From: Felipe Date: Mon, 10 Mar 2025 23:50:45 +0000 Subject: [PATCH 048/122] update docs --- DESCRIPTION | 4 ++-- NAMESPACE | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index ae175d240..8836521d0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -130,7 +130,6 @@ Collate: 'api_file.R' 'api_gdal.R' 'api_gdalcubes.R' - 'api_glcm.R' 'api_grid.R' 'api_jobs.R' 'api_kohonen.R' @@ -184,6 +183,7 @@ Collate: 'api_stac.R' 'api_stats.R' 'api_summary.R' + 'api_texture.R' 'api_tibble.R' 'api_tile.R' 'api_timeline.R' @@ -227,7 +227,6 @@ Collate: 'sits_get_data.R' 'sits_get_class.R' 'sits_get_probs.R' - 'sits_glcm.R' 'sits_histogram.R' 'sits_imputation.R' 'sits_labels.R' @@ -255,6 +254,7 @@ Collate: 'sits_summary.R' 'sits_tae.R' 'sits_tempcnn.R' + 'sits_texture.R' 'sits_timeline.R' 'sits_train.R' 'sits_tuning.R' diff --git a/NAMESPACE b/NAMESPACE index 50f86558d..087371571 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -386,9 +386,6 @@ S3method(sits_get_probs,default) S3method(sits_get_probs,sf) S3method(sits_get_probs,shp) S3method(sits_get_probs,sits) -S3method(sits_glcm,default) -S3method(sits_glcm,derived_cube) -S3method(sits_glcm,raster_cube) S3method(sits_label_classification,default) S3method(sits_label_classification,derived_cube) S3method(sits_label_classification,probs_cube) @@ -430,6 +427,9 @@ S3method(sits_smooth,derived_cube) S3method(sits_smooth,probs_cube) S3method(sits_smooth,probs_vector_cube) S3method(sits_smooth,raster_cube) +S3method(sits_texture,default) +S3method(sits_texture,derived_cube) +S3method(sits_texture,raster_cube) S3method(sits_timeline,default) S3method(sits_timeline,derived_cube) S3method(sits_timeline,raster_cube) @@ -500,7 +500,6 @@ export(sits_geo_dist) export(sits_get_class) export(sits_get_data) export(sits_get_probs) -export(sits_glcm) export(sits_impute) export(sits_kfold_validate) export(sits_label_classification) @@ -544,6 +543,7 @@ export(sits_stratified_sampling) export(sits_svm) export(sits_tae) export(sits_tempcnn) +export(sits_texture) export(sits_tiles_to_roi) export(sits_timeline) export(sits_timeseries_to_csv) From 831799ba60b1fedcc5ca1af68ed2ca2503043e7e Mon Sep 17 00:00:00 2001 From: Felipe Date: Mon, 10 Mar 2025 23:51:15 +0000 Subject: [PATCH 049/122] update correlation output --- src/glcm_fns.cpp | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/glcm_fns.cpp b/src/glcm_fns.cpp index 12c45209e..fad9fd40a 100644 --- a/src/glcm_fns.cpp +++ b/src/glcm_fns.cpp @@ -182,10 +182,15 @@ inline double _glcm_correlation(const arma::sp_mat& glcm, const arma::mat& i, const arma::mat& j) { double res = 0; - double mean = arma::accu(glcm % i); + double mean = _glcm_mean(glcm, i, j); double var = _glcm_variance(glcm, i, j); - res = arma::accu(glcm % (( (i-mean) % (j-mean) ) / (var))); - + // handle the special case of standard deviations near zero + // reference: skimage + if (var < 1e-15) { + res = 1; + } else { + res = arma::accu(glcm % (( (i-mean) % (j-mean) ) / (var))); + } return(res); } From bb0bde7850d302253f2d79683ff4b5c6449dfd4e Mon Sep 17 00:00:00 2001 From: Felipe Date: Mon, 10 Mar 2025 23:51:34 +0000 Subject: [PATCH 050/122] update texture function --- .../testthat/{test-glcm.R => test-texture.R} | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) rename tests/testthat/{test-glcm.R => test-texture.R} (90%) diff --git a/tests/testthat/test-glcm.R b/tests/testthat/test-texture.R similarity index 90% rename from tests/testthat/test-glcm.R rename to tests/testthat/test-texture.R index d9c854d92..734466abd 100644 --- a/tests/testthat/test-glcm.R +++ b/tests/testthat/test-texture.R @@ -1,4 +1,4 @@ -test_that("Testing glcm generation", { +test_that("Testing texture generation", { data_dir <- system.file("extdata/raster/mod13q1", package = "sits") # Create a MODIS cube cube <- sits_cube( @@ -16,7 +16,7 @@ test_that("Testing glcm generation", { full.names = TRUE )) # Compute the NDVI variance - texture <- sits_glcm( + texture <- sits_texture( cube = feature, NDVIVAR = glcm_variance(NDVI), window_size = 5, @@ -26,7 +26,7 @@ test_that("Testing glcm generation", { expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIVAR"))) # Compute the NDVI mean - texture <- sits_glcm( + texture <- sits_texture( cube = feature, NDVIMEAN = glcm_mean(NDVI), window_size = 5, @@ -36,7 +36,7 @@ test_that("Testing glcm generation", { expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIMEAN"))) # Compute the NDVI contrast - texture <- sits_glcm( + texture <- sits_texture( cube = feature, NDVICONTRAST = glcm_contrast(NDVI), window_size = 5, @@ -46,7 +46,7 @@ test_that("Testing glcm generation", { expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVICONTRAST"))) # Compute the NDVI dissimilarity - texture <- sits_glcm( + texture <- sits_texture( cube = feature, NDVIDISSIMILARITY = glcm_dissimilarity(NDVI), window_size = 5, @@ -56,7 +56,7 @@ test_that("Testing glcm generation", { expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIDISSIMILARITY"))) # Compute the NDVI homogeneity - texture <- sits_glcm( + texture <- sits_texture( cube = feature, NDVIHOMOGEINEITY = glcm_homogeneity(NDVI), window_size = 5, @@ -66,7 +66,7 @@ test_that("Testing glcm generation", { expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIHOMOGEINEITY"))) # Compute the NDVI energy - texture <- sits_glcm( + texture <- sits_texture( cube = feature, NDVIENERGY = glcm_energy(NDVI), window_size = 5, @@ -76,7 +76,7 @@ test_that("Testing glcm generation", { expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIENERGY"))) # Compute the NDVI asm - texture <- sits_glcm( + texture <- sits_texture( cube = feature, NDVIASM = glcm_asm(NDVI), window_size = 5, @@ -86,7 +86,7 @@ test_that("Testing glcm generation", { expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVIASM"))) # Compute the NDVI std - texture <- sits_glcm( + texture <- sits_texture( cube = feature, NDVISTD = glcm_std(NDVI), window_size = 5, @@ -96,7 +96,7 @@ test_that("Testing glcm generation", { expect_true(all(sits_bands(texture) %in% c("NDVI", "NDVISTD"))) # Compute the NDVI correlation - texture <- sits_glcm( + texture <- sits_texture( cube = feature, NDVICORRELATION = glcm_correlation(NDVI), window_size = 5, From cae2c8ffa06e82cf83f84d8449a3493ff90c70c0 Mon Sep 17 00:00:00 2001 From: Felipe Date: Mon, 10 Mar 2025 23:51:44 +0000 Subject: [PATCH 051/122] update docs --- inst/extdata/config_internals.yml | 12 ++++++------ man/{sits_glcm.Rd => sits_texture.Rd} | 24 ++++++++++++------------ 2 files changed, 18 insertions(+), 18 deletions(-) rename man/{sits_glcm.Rd => sits_texture.Rd} (92%) diff --git a/inst/extdata/config_internals.yml b/inst/extdata/config_internals.yml index 0dc38902a..b7f2f3048 100644 --- a/inst/extdata/config_internals.yml +++ b/inst/extdata/config_internals.yml @@ -99,6 +99,12 @@ grid_systems: # configuration for probability cubes probs_cube_scale_factor : 0.0001 +# configuration for texture cubes +texture_options: + block_size: 512 + minimum_value: 0 + maximum_value: 1000 + # Default values for non-registered bands default_values : INT2S : &conf_default_int2s @@ -274,12 +280,6 @@ som_outcomes: ["clean", "analyze", "remove"] metadata_search_strategies: ["tile", "feature"] -# GLCM metadata -glcm_options: - block_size: 512 - minimum_value: 0 - maximum_value: 1000 - # Colours and plots # # color table mandatory collumns diff --git a/man/sits_glcm.Rd b/man/sits_texture.Rd similarity index 92% rename from man/sits_glcm.Rd rename to man/sits_texture.Rd index 24099d97b..3cfb1e459 100644 --- a/man/sits_glcm.Rd +++ b/man/sits_texture.Rd @@ -1,15 +1,15 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sits_glcm.R -\name{sits_glcm} -\alias{sits_glcm} -\alias{sits_glcm.raster_cube} -\alias{sits_glcm.derived_cube} -\alias{sits_glcm.default} -\title{Apply a GLCM texture on a data cube.} +% Please edit documentation in R/sits_texture.R +\name{sits_texture} +\alias{sits_texture} +\alias{sits_texture.raster_cube} +\alias{sits_texture.derived_cube} +\alias{sits_texture.default} +\title{Apply a set texture measures on a data cube.} \usage{ -sits_glcm(cube, ...) +sits_texture(cube, ...) -\method{sits_glcm}{raster_cube}( +\method{sits_texture}{raster_cube}( cube, ..., window_size = 3L, @@ -20,9 +20,9 @@ sits_glcm(cube, ...) progress = FALSE ) -\method{sits_glcm}{derived_cube}(data, ...) +\method{sits_texture}{derived_cube}(data, ...) -\method{sits_glcm}{default}(data, ...) +\method{sits_texture}{default}(data, ...) } \arguments{ \item{cube}{Valid sits cube} @@ -107,7 +107,7 @@ if (sits_run_examples()) { ) # Compute the NDVI variance - cube_texture <- sits_glcm( + cube_texture <- sits_texture( cube = cube, NDVIVAR = glcm_variance(NDVI), window_size = 5, From f4f4947203fbfedb42ce708a12bcaeeb9166a7bf Mon Sep 17 00:00:00 2001 From: Felipe Date: Tue, 11 Mar 2025 00:09:57 +0000 Subject: [PATCH 052/122] update docs --- R/api_texture.R | 12 ++++++------ R/sits_texture.R | 6 +++--- inst/extdata/config_messages.yml | 7 ++++--- man/sits_texture.Rd | 4 ++-- 4 files changed, 15 insertions(+), 14 deletions(-) diff --git a/R/api_texture.R b/R/api_texture.R index 74951836e..d5fd87ba4 100644 --- a/R/api_texture.R +++ b/R/api_texture.R @@ -1,4 +1,4 @@ -#' @title Apply a set of texture measure to a raster block +#' @title Apply a set of texture measure to a raster tile #' @name .texture_feature #' @keywords internal #' @noRd @@ -21,7 +21,7 @@ #' #' @return A feature compose by a combination of tile and band. .texture_feature <- function(feature, block, window_size, angles, expr, - out_band, in_bands, overlap, output_dir) { + out_band, in_bands, overlap, output_dir) { # Output file out_file <- .file_eo_name( tile = feature, band = out_band, @@ -51,8 +51,8 @@ if (.has_not(band_conf)) { band_conf <- .conf("default_values", "INT2S") } - # Get gclm options - glcm_conf <- .conf("texture_options") + # Get texture options + texture_conf <- .conf("texture_options") # Process jobs sequentially block_files <- .jobs_map_parallel(chunks, function(chunk) { # Get job block @@ -80,7 +80,7 @@ values <- .texture_normalize( values = values, source = c(.min_value(band_conf), .max_value(band_conf)), - dest = c(.min_value(glcm_conf), .max_value(glcm_conf)) + dest = c(.min_value(texture_conf), .max_value(texture_conf)) ) # Evaluate expression here # Band and kernel evaluation @@ -92,7 +92,7 @@ angles = angles, img_nrow = block[["nrows"]], img_ncol = block[["ncols"]], - n_grey = .max_value(glcm_conf) + n_grey = .max_value(texture_conf) ) ) # Prepare fractions to be saved diff --git a/R/sits_texture.R b/R/sits_texture.R index 761dd408a..fb64a5dab 100644 --- a/R/sits_texture.R +++ b/R/sits_texture.R @@ -1,4 +1,4 @@ -#' @title Apply a set texture measures on a data cube. +#' @title Apply a set of texture measures on a data cube. #' #' @name sits_texture #' @@ -68,7 +68,7 @@ #' neighbor pixels of \code{pi/2} are above and below the central pixel, and #' so on. If more than one angle is provided, we compute their average. #' -#' @section GLCM functions: +#' @section Available texture functions: #' \itemize{ #' \item{\code{glcm_contrast()}: measures the contrast or the amount of local #' variations present in an image. Low contrast values indicate regions with @@ -152,7 +152,7 @@ sits_texture.raster_cube <- function(cube, ..., # Check if band already exists in cube if (out_band %in% bands) { if (.check_messages()) { - warning(.conf("messages", "sits_glcm_out_band"), + warning(.conf("messages", "sits_texture_out_band"), call. = FALSE ) } diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index 31e1ea0c2..43ced9f8a 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -399,9 +399,6 @@ sits_get_data_sf: "sf objects need a column with an id for each polygon\n please sits_get_data_shp: "shp objects need a column with an id for each polygon\n please include this column name in the 'pol_id' parameter" sits_get_probs: "unable to retrieve data from probability cube - check input parameters" sits_get_probs_not_point: "samples should have POINT geometry type" -sits_glcm_out_band: "output band already exists in data cube and will be replaced" -sits_glcm_derived_cube: "input data should be a non-classified cube" -sits_glcm_default: "input should be a valid set of training samples or a non-classified data cube" sits_hist_raster_cube: "invalid input data to compute histogram" sits_hist_tile: "tile is not part of the cube" sits_hist_label: "labels is not one of cube labels" @@ -477,6 +474,10 @@ sits_stratified_sampling_shp_save: "saved allocation in shapefile" sits_svm: "wrong input parameters - see example in documentation" sits_tae: "wrong input parameters - see example in documentation" sits_tempcnn: "wrong input parameters - see example in documentation" +sits_texture_out_band: "output band already exists in data cube and will be replaced" +sits_texture_derived_cube: "input data should be a non-classified cube" +sits_texture_default: "input should be a valid set of training samples or a non-classified data cube" + sits_train_base_data: "training samples with DEM or other base data is only supported by random forest and xgboost methods" sits_timeline_raster_cube: "cube is not regular, returning all timelines" sits_timeline_default: "input should be a set of training samples or a data cube" diff --git a/man/sits_texture.Rd b/man/sits_texture.Rd index 3cfb1e459..377e0d80e 100644 --- a/man/sits_texture.Rd +++ b/man/sits_texture.Rd @@ -5,7 +5,7 @@ \alias{sits_texture.raster_cube} \alias{sits_texture.derived_cube} \alias{sits_texture.default} -\title{Apply a set texture measures on a data cube.} +\title{Apply a set of texture measures on a data cube.} \usage{ sits_texture(cube, ...) @@ -70,7 +70,7 @@ pixels based on \code{0} angle rely on the left and right direction; the neighbor pixels of \code{pi/2} are above and below the central pixel, and so on. If more than one angle is provided, we compute their average. } -\section{GLCM functions}{ +\section{Available texture functions}{ \itemize{ \item{\code{glcm_contrast()}: measures the contrast or the amount of local From d3c8a10785b8ff95b6670b4ad2586e0e3794109e Mon Sep 17 00:00:00 2001 From: Felipe Date: Tue, 11 Mar 2025 00:19:54 +0000 Subject: [PATCH 053/122] adjust focs --- R/sits_texture.R | 16 ++++++++-------- man/sits_texture.Rd | 4 ++-- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/R/sits_texture.R b/R/sits_texture.R index fb64a5dab..9d22feee4 100644 --- a/R/sits_texture.R +++ b/R/sits_texture.R @@ -210,21 +210,21 @@ sits_texture.raster_cube <- function(cube, ..., #' @rdname sits_texture #' @export -sits_texture.derived_cube <- function(data, ...) { +sits_texture.derived_cube <- function(cube, ...) { stop(.conf("messages", "sits_texture_derived_cube")) } #' @rdname sits_texture #' @export -sits_texture.default <- function(data, ...) { - data <- tibble::as_tibble(data) - if (all(.conf("sits_cube_cols") %in% colnames(data))) { - data <- .cube_find_class(data) - } else if (all(.conf("sits_tibble_cols") %in% colnames(data))) { - class(data) <- c("sits", class(data)) +sits_texture.default <- function(cube, ...) { + cube <- tibble::as_tibble(cube) + if (all(.conf("sits_cube_cols") %in% colnames(cube))) { + cube <- .cube_find_class(cube) + } else if (all(.conf("sits_tibble_cols") %in% colnames(cube))) { + class(cube) <- c("sits", class(cube)) } else { stop(.conf("messages", "sits_texture_default")) } - acc <- sits_texture(data, ...) + acc <- sits_texture(cube, ...) return(acc) } diff --git a/man/sits_texture.Rd b/man/sits_texture.Rd index 377e0d80e..dc0db78cb 100644 --- a/man/sits_texture.Rd +++ b/man/sits_texture.Rd @@ -20,9 +20,9 @@ sits_texture(cube, ...) progress = FALSE ) -\method{sits_texture}{derived_cube}(data, ...) +\method{sits_texture}{derived_cube}(cube, ...) -\method{sits_texture}{default}(data, ...) +\method{sits_texture}{default}(cube, ...) } \arguments{ \item{cube}{Valid sits cube} From bdebbd9580fcb2d8a9f0f597ec64df6619f40bd6 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Tue, 11 Mar 2025 14:30:49 -0300 Subject: [PATCH 054/122] fix authorship --- NAMESPACE | 1 + R/api_accuracy.R | 14 +++- R/api_apply.R | 18 ++++- R/api_bbox.R | 2 +- R/api_check.R | 108 +++++++++++++++++++------- R/api_classify.R | 23 +++++- R/api_colors.R | 5 ++ R/api_crop.R | 8 ++ R/api_csv.R | 8 +- R/api_data.R | 42 +++++++++- R/api_detect_change.R | 16 ++++ R/api_download.R | 2 + R/api_dtw.R | 6 ++ R/api_environment.R | 6 +- R/api_file.R | 35 +++++++++ R/api_file_info.R | 2 + R/api_gdal.R | 36 +++++++++ R/api_gdalcubes.R | 27 +++++-- R/api_grid.R | 24 +++++- R/api_jobs.R | 14 ++++ R/api_kohonen.R | 14 +++- R/api_label_class.R | 9 +++ R/api_mask.R | 8 +- R/api_merge.R | 127 +++++++++++++++++++++++++++---- R/api_mosaic.R | 27 +++---- R/api_opensearch.R | 20 +++-- R/api_period.R | 3 + R/api_plot_time_series.R | 12 +-- R/api_predictors.R | 11 ++- R/api_raster_sub_image.R | 1 + R/api_reduce.R | 5 +- R/api_roi.R | 20 +++-- R/sits_accuracy.R | 44 +++++++++-- R/sits_cube.R | 3 +- R/sits_som.R | 4 + inst/extdata/config_messages.yml | 1 + man/sits_accuracy.Rd | 15 +++- man/sits_cube.Rd | 2 + man/sits_som_evaluate_cluster.Rd | 7 ++ man/sits_som_remove_samples.Rd | 2 + 40 files changed, 621 insertions(+), 111 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 1ff78b0f3..c0b08030f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -328,6 +328,7 @@ S3method(plot,xgb_model) S3method(print,sits_accuracy) S3method(print,sits_area_accuracy) S3method(sits_accuracy,class_cube) +S3method(sits_accuracy,class_vector_cube) S3method(sits_accuracy,default) S3method(sits_accuracy,derived_cube) S3method(sits_accuracy,raster_cube) diff --git a/R/api_accuracy.R b/R/api_accuracy.R index 808113a86..f5eef0e5b 100644 --- a/R/api_accuracy.R +++ b/R/api_accuracy.R @@ -132,7 +132,19 @@ class(acc_area) <- c("sits_area_accuracy", class(acc_area)) return(acc_area) } - +#' @title Support for pixel-based post-classification accuracy +#' @name .accuracy_pixel_assess +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @keywords internal +#' @noRd +#' @param cube Data cube. +#' @param pred Integer vector with predicted values. +#' @param ref Integer vector with reference values. +#' +#' @return +#' A list of lists: The error_matrix, the class_areas, the unbiased +#' estimated areas, the standard error areas, confidence interval 95% areas, +#' and the accuracy (user, producer, and overall). .accuracy_pixel_assess <- function(cube, pred, ref) { # Create factor vectors for caret unique_ref <- unique(ref) diff --git a/R/api_apply.R b/R/api_apply.R index 0bff87cfb..9d06ad187 100644 --- a/R/api_apply.R +++ b/R/api_apply.R @@ -151,7 +151,17 @@ # Return a feature tile band_tile } - +#' @title Read data for the apply operation +#' @name .apply_data_read +#' @keywords internal +#' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' +#' @param tile Subset of a data cube containing the input bands +#' @param block Individual block that will be processed +#' @param in_bands Input bands +#' +#' @return Values read from the block .apply_data_read <- function(tile, block, in_bands) { # for cubes that have a time limit to expire - mpc cubes only tile <- .cube_token_generator(tile) @@ -177,6 +187,7 @@ #' @title Apply an expression across all bands #' @name .apply_across +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @@ -201,6 +212,7 @@ } #' @title Captures a band expression #' @name .apply_capture_expression +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @@ -225,6 +237,7 @@ } #' @title Finds out all existing bands in an expression #' @name .apply_input_bands +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @@ -249,8 +262,8 @@ return(bands) } #' @title Returns all names in an expression -#' #' @name .apply_get_all_names +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param expr Expression. @@ -268,6 +281,7 @@ } #' @title Kernel function for window operations in spatial neighbourhoods #' @name .kern_functions +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param windows size of local window #' @param img_nrow image size in rows diff --git a/R/api_bbox.R b/R/api_bbox.R index 536841cc5..099a63758 100644 --- a/R/api_bbox.R +++ b/R/api_bbox.R @@ -2,7 +2,7 @@ #' @name .bbox_equal #' @keywords internal #' @noRd -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @param bbox1 Bounding box for a region of interest. #' @param bbox2 Bounding box for a region of interest. diff --git a/R/api_check.R b/R/api_check.R index e983939b4..d4f396f0a 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -1,7 +1,7 @@ #' @title Check functions #' #' @name check_functions -#' +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @description #' Functions used to check parameters in a systematic way. #' @@ -662,30 +662,6 @@ } return(invisible(x)) } -#' @title Prepare default message for invalid parameter -#' @name .check_param_message -#' @param param parameter name -#' @param msg message to be issued -#' @return A valid message -#' @keywords internal -#' @noRd -.check_param_message <- function(param) { - # make default message - msg <- paste0("invalid ", param, " parameter") - return(msg) -} -#' @title Prepare default message for variable -#' @name .check_var_message -#' @param var parameter name -#' @param msg message to be issued -#' @return A valid message -#' @keywords internal -#' @noRd -.check_var_message <- function(var) { - # make default message - msg <- paste0("invalid ", var, " variable") - return(msg) -} #' @rdname check_functions #' #' @details @@ -1405,6 +1381,32 @@ .check_set_caller(".check_processed_labels") .check_that(ncol(values) == n_labels) } +#' @title Prepare default message for invalid parameter +#' @name .check_param_message +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @param param parameter name +#' @param msg message to be issued +#' @return A valid message +#' @keywords internal +#' @noRd +.check_param_message <- function(param) { + # make default message + msg <- paste0("invalid ", param, " parameter") + return(msg) +} +#' @title Prepare default message for variable +#' @name .check_var_message +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @param var parameter name +#' @param msg message to be issued +#' @return A valid message +#' @keywords internal +#' @noRd +.check_var_message <- function(var) { + # make default message + msg <- paste0("invalid ", var, " variable") + return(msg) +} #' @title Does the input data contain a set of predicted values? #' @name .check_predicted #' @param data a sits tibble @@ -1954,6 +1956,8 @@ } #' @title Check if grid system is supported #' @name .check_grid_system +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @param grid_system Requested grid system #' @return Called for side effects. #' @keywords internal @@ -1989,6 +1993,7 @@ } #' @title Check if tiles are part of a data cube #' @name .check_cube_tiles +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param cube Data cube #' @param tiles Tile to be check #' @param add_cloud Include the cloud band? @@ -2003,6 +2008,7 @@ } #' @title Check if all rows in a cube has the same bands #' @name .check_cube_row_same_bands +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param cube Data cube #' @return Called for side effects. #' @keywords internal @@ -2015,6 +2021,7 @@ } #' @title Check if cubes have the same bbox #' @name .check_cubes_same_bbox +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param cube1 input data cube @@ -2042,6 +2049,7 @@ } #' @title Check if cubes have the same size #' @name .check_cubes_same_size +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param cube1 input data cube @@ -2058,6 +2066,7 @@ #' @title Check if cubes have the same tiles #' @name .check_cubes_same_tiles +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param cube1 input data cube @@ -2070,6 +2079,7 @@ } #' @title Check if cubes have the same labels #' @name .check_cubes_same_labels +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param cube1 input data cube @@ -2085,6 +2095,7 @@ } #' @title Check if cubes have the same timeline #' @name .check_cubes_same_timeline +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param cube1 input data cube @@ -2097,6 +2108,7 @@ } #' @title Check if two cubes have the same organization #' @name .check_cubes_match +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param cube1 input data cube @@ -2114,6 +2126,7 @@ } #' @title Check if list of probs cubes have the same organization #' @name .check_probs_cube_lst +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param cubes list of input data cubes @@ -2133,6 +2146,7 @@ } #' @title Check if list of uncertainty cubes have the same organization #' @name .check_uncert_cube_lst +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param uncert_cubes list of input data cubes @@ -2152,6 +2166,7 @@ } #' @title Check if errox matrix and area are cosrrect #' @name .check_error_matrix_area +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param error_matrix Error matrix for classification #' @param area Area of each class #' @return Called for side effects. @@ -2184,6 +2199,7 @@ } #' @title Checks if the required packages are installed #' @name .check_require_packages +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param x the name of the required package #' @return Called for side effects #' @keywords internal @@ -2203,6 +2219,7 @@ } #' @title Checks if the tibble/data.frame is empty #' @name .check_empty_data_frame +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param x a data frame #' @return Called for side effects. #' @keywords internal @@ -2214,6 +2231,7 @@ } #' @title Checks if the endmembers parameter is valid #' @name .check_endmembers_parameter +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @param em Endmembers description (data.frame) @@ -2225,6 +2243,7 @@ } #' @title Checks if the endmembers data is in a valid parameter #' @name .check_endmembers_tbl +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @param em Reference spectra endmembers. @@ -2246,6 +2265,7 @@ } #' @title Checks if the endmembers data is in a valid parameter #' @name .check_endmembers_fracs +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @param em Reference spectra endmembers. @@ -2259,6 +2279,7 @@ } #' @title Checks if the bands required by endmembers exist #' @name .check_endmembers_bands +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @param em Reference spectra endmembers. @@ -2271,6 +2292,7 @@ } #' @title Checks if working in documentation mode #' @name .check_documentation +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param progress flag set to show progress bar #' @return TRUE/FALSE #' @keywords internal @@ -2285,6 +2307,7 @@ } #' @title Checks if messages should be displayed #' @name .check_messages +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @return TRUE/FALSE #' @keywords internal #' @noRd @@ -2299,6 +2322,7 @@ } #' @title Checks if warnings should be displayed #' @name .check_warnings +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @return TRUE/FALSE #' @keywords internal #' @noRd @@ -2312,7 +2336,8 @@ } } #' @title Checks if STAC items are correct -#' @name .check_warnings +#' @name .check_stac_items +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @param items STAC items #' @return Called for side effects #' @keywords internal @@ -2338,6 +2363,7 @@ } #' @title Checks discriminators #' @name .check_discriminator +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param discriminator discriminator for within and contains #' @return Called for side effects #' @keywords internal @@ -2362,6 +2388,7 @@ } #' @title Checks view bands are defined #' @name .check_bw_rgb_bands +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param band B/W band for view #' @param red Red band for view #' @param green Green band for view @@ -2376,6 +2403,7 @@ } #' @title Check available bands #' @name .check_available_bands +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param cube Data cube #' @param band B/W band for view #' @param red Red band for view @@ -2400,6 +2428,7 @@ #' @title Check if the provided object is a vector #' @name .check_vector_object +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @param v_obj a sf, sfc or sfg object #' @return No return value, called for side effects. #' @keywords internal @@ -2416,6 +2445,7 @@ } #' @title Checks local items #' @name .check_local_items +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @param items Items with information on local cube #' @return Called for side effects #' @keywords internal @@ -2429,6 +2459,7 @@ } #' @title Checks tiles #' @name .check_tiles +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param tiles vector with tile names #' @return Called for side effects #' @keywords internal @@ -2441,6 +2472,7 @@ } #' @title Checks palette #' @name .check_palette +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param palette Character vector with palette name #' @return Called for side effects #' @keywords internal @@ -2461,6 +2493,7 @@ } #' @title Check legend defined as tibble #' @name .check_legend +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param legend Legend (as tibble) #' @return Called for side effects #' @keywords internal @@ -2477,6 +2510,7 @@ } #' @title Checks legend_position #' @name .check_legend_position +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param legend_position Character vector with legend position #' @return Called for side effects #' @keywords internal @@ -2493,6 +2527,7 @@ } #' @title Checks if band is in list of bands #' @name .check_band_in_bands +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param band Name of band #' @param bands List of bands #' @return Called for side effects @@ -2509,6 +2544,7 @@ return(invisible(NULL)) } #' @title Checks shapefile attribute +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @name .check_shp_attribute #' @param sf_shape sf object read from a shapefile #' @param shp_attr name of attribute param in shapefile @@ -2525,6 +2561,7 @@ return(invisible(sf_shape)) } #' @title Checks validation file +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @name .check_validation_file #' @param validation Path to a CSV file #' @param shp_attr name of attribute param in shapefile @@ -2539,6 +2576,7 @@ return(invisible(validation)) } #' @title Checks filter function +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @description #' Checks if the paramter is a function #' @param filter_fn Filter function @@ -2552,6 +2590,7 @@ return(invisible(NULL)) } #' @title Checks distance method +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @description #' Checks if the parameter is a valid distance method for a dendrogram #' @param dist_method Distance method @@ -2564,6 +2603,8 @@ return(invisible(NULL)) } #' @title Checks linkage method +#' @name .check_linkage_method +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @description #' Checks if the parameter is a valid linkage method for a dendrogram #' @param linkage Linkage method @@ -2576,6 +2617,9 @@ return(invisible(NULL)) } #' @title Check netrc file +#' @name .check_netrc_gdal +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @description #' Check if netrc file exists and if its content is correct #' @param attributes Attributes required from the netrc file @@ -2624,9 +2668,9 @@ ) return(invisible(NULL)) } - #' @title Check torch hyperparameters -#' +#' @name .check_opt_hparams +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param opt_hparams Hyperparameters. #' @param optim_params_function Function used for optimization. #' @return Called for side effects @@ -2644,7 +2688,13 @@ ) return(invisible(NULL)) } - +#' @title Check that cube period is unique +#' @name .check_unique_period +#' @param cube Data cube. +#' @return Called for side effects +#' @keywords internal +#' @noRd +# .check_unique_period <- function(cube) { .check_that( x = length(.cube_period(cube)) == 1, diff --git a/R/api_classify.R b/R/api_classify.R index 9dfe9f9e9..5206ad615 100755 --- a/R/api_classify.R +++ b/R/api_classify.R @@ -4,6 +4,8 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description Classifies a block of data using multicores. It breaks #' the data into horizontal blocks and divides them between the available cores. @@ -248,11 +250,13 @@ } #' @title Classify a chunk of raster data using multicores -#' @name .classify_tile +#' @name .classify_vector_tile #' @keywords internal #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description Classifies a block of data using multicores. It breaks #' the data into horizontal blocks and divides them between the available cores. @@ -426,8 +430,10 @@ #' @name .classify_data_read #' @keywords internal #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @param tile Input tile to read data. #' @param block Bounding box in (col, row, ncols, nrows). @@ -525,7 +531,10 @@ #' @name .classify_ts #' @keywords internal #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description Returns a sits tibble with the results of the ML classifier. #' @@ -631,7 +640,10 @@ #' @name .classify_ts_cpu #' @keywords internal #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description Returns a sits tibble with the results of the ML classifier. #' @@ -677,7 +689,10 @@ #' @name .classify_ts_gpu #' @keywords internal #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description Returns a sits tibble with the results of the ML classifier. #' @@ -725,7 +740,7 @@ #' @name .classify_verbose_start #' @keywords internal #' @noRd -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @description Prints the block size and computes #' start time for processing #' @@ -745,7 +760,7 @@ #' @name .classify_verbose_end #' @keywords internal #' @noRd -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @description Prints the processing time #' @param verbose TRUE/FALSE #' @param start_time initial processing time diff --git a/R/api_colors.R b/R/api_colors.R index ac41dc75a..f3bd09cec 100644 --- a/R/api_colors.R +++ b/R/api_colors.R @@ -1,5 +1,6 @@ #' @title Get colors associated to the labels #' @name .colors_get +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param labels labels associated to the training classes #' @param palette palette from `grDevices::hcl.pals()` #' replaces default colors @@ -72,6 +73,7 @@ } #' @title Show color table #' @name .colors_show +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param color_tb A SITS color table @@ -143,6 +145,7 @@ #' #' @title Write a color table in QGIS Style format #' @name .colors_qml +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param color_table color table to write to QGIS @@ -197,6 +200,7 @@ } #' @title Transform an RColorBrewer name to cols4all name #' @name .colors_cols4all_name +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param palette An RColorBrewer palette name @@ -219,6 +223,7 @@ } #' @title Transform an legend from tibble to vector #' @name .colors_legend_set +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param legend A legend in tibble format diff --git a/R/api_crop.R b/R/api_crop.R index f895a946a..721b652b9 100644 --- a/R/api_crop.R +++ b/R/api_crop.R @@ -1,4 +1,8 @@ #' @title Crop cube +#' @name .crop +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param cube Data cube @@ -64,6 +68,10 @@ cube } #' @title Crop asset +#' @name .crop_asset +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param asset Data cube diff --git a/R/api_csv.R b/R/api_csv.R index 8f5d6a9fa..4b502b750 100644 --- a/R/api_csv.R +++ b/R/api_csv.R @@ -1,6 +1,6 @@ #' @title Transform a CSV into a samples file #' @name .csv_get_samples -#' @author Gilberto Camara +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param csv_file CSV that describes the data to be retrieved. @@ -34,7 +34,7 @@ #' @title Transform a CSV with labelled points for accuracy assessment #' into a samples file #' @name .csv_get_validation_samples -#' @author Gilberto Camara +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param csv_file CSV that describes the data to be retrieved. @@ -60,7 +60,7 @@ } #' @title Transform a CSV with lat/long into samples #' @name .csv_get_lat_lon -#' @author Gilberto Camara +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param csv_file CSV that describes the data to be retrieved. @@ -83,7 +83,7 @@ } #' @title Get samples metadata as CSV #' @name .csv_metadata_from_samples -#' @author Gilberto Camara +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param data A sits tibble. diff --git a/R/api_data.R b/R/api_data.R index 31d4a7dd6..5b149b650 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -1,7 +1,10 @@ #' @title Dispatch function to get time series from data cubes and cloud #' services #' @name .data_get_ts -#' @author Gilberto Camara +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param cube Data cube from where data is to be retrieved. @@ -375,6 +378,8 @@ #' @title get time series from data cubes on tile by tile bassis #' @name .data_by_tile +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param cube Data cube from where data is to be retrieved. @@ -576,7 +581,9 @@ return(ts_tbl) } #' @title get time series from data cubes using chunks -#' @name .data_by_tile +#' @name .data_by_chunks +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param cube Data cube from where data is to be retrieved. @@ -780,6 +787,8 @@ } #' @title get time series from base tiles #' @name .data_base_tiles +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param cube Data cube from where data is to be retrieved. @@ -839,7 +848,7 @@ #' @title function to get class for point in a classified cube #' @name .data_get_class -#' @author Gilberto Camara +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param cube Classified data cube from where data is to be retrieved. @@ -897,7 +906,7 @@ #' @title function to get probability values for a set of given locations #' @name .data_get_probs -#' @author Gilberto Camara +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param cube Probability cube from where data is to be retrieved. @@ -953,6 +962,18 @@ }) return(data) } +#' @title function to get probability values for a pixel +#' @name .data_get_probs_pixel +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @keywords internal +#' @noRd +#' @param tile Probability cube from where data is to be retrieved. +#' @param samples Samples to be retrieved. +#' @param xy Pixel position in the image +#' @param band_conf Configuration parameters for the raster data +#' +#' @return A tibble with a list of lat/long and respective probs +#' .data_get_probs_pixel <- function(tile, samples, xy, band_conf){ # open spatial raster object rast <- .raster_open_rast(.tile_path(tile)) @@ -974,6 +995,19 @@ samples <- dplyr::bind_cols(samples, values) return(samples) } +#' @title function to get probability values for a window +#' @name .data_get_probs_window +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @keywords internal +#' @noRd +#' @param tile Probability cube from where data is to be retrieved. +#' @param samples Samples to be retrieved. +#' @param xy Pixel position in the image +#' @param band_conf Configuration parameters for the raster data +#' @param window_size Size of window around a pixel +#' +#' @return A tibble with a list of lat/long and respective probs +#' .data_get_probs_window <- function(tile, samples, xy, band_conf, window_size){ # open spatial raster object rast <- .raster_open_rast(.tile_path(tile)) diff --git a/R/api_detect_change.R b/R/api_detect_change.R index 12e8d23b4..5a8ae1950 100644 --- a/R/api_detect_change.R +++ b/R/api_detect_change.R @@ -1,5 +1,7 @@ #' @title Detect changes in time-series using various methods. #' @name .detect_change_ts +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd .detect_change_ts <- function(samples, @@ -41,6 +43,8 @@ #' @title Detect changes from a chunk of raster data using multicores #' @name .detect_change_tile +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param tile Single tile of a data cube. @@ -232,6 +236,7 @@ #' @param tile Single tile of a data cube. #' @param ... Additional parameters #' @param impute_fn Imputation function +#' @return Scaled values for detect change method .detect_change_tile_prep <- function(dc_method, tile, ...) { UseMethod(".detect_change_tile_prep", dc_method) } @@ -276,12 +281,15 @@ } #' @title Pre-process tile to run detect_change method (bayts) #' @name .detect_change_create_timeline +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param dc_method Detect change method #' @param tile Single tile of a data cube. #' @param ... Additional parameters #' @param impute_fn Imputation function +#' @return Timeline organized as sequence of values .detect_change_create_timeline <- function(tile) { # Get the number of dates in the timeline tile_tl <- .as_chr(.tile_timeline(tile)) @@ -291,8 +299,16 @@ ) tile_tl } +#' @title Detect change as a polygon #' @name .detect_change_as_polygon +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @keywords internal #' @noRd +#' @param values Matrix of values for a raster (time series) +#' @param block Data block that is being processed +#' @param bbox Bounding box of the block +#' @return Vector object with polygons .detect_change_as_polygon <- function(values, block, bbox) { # Create a template raster template_raster <- .raster_new_rast( diff --git a/R/api_download.R b/R/api_download.R index ae9c87e39..fbec926ce 100644 --- a/R/api_download.R +++ b/R/api_download.R @@ -2,6 +2,8 @@ #' @keywords internal #' @noRd #' @name .download_asset +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @param asset A data cube #' @param roi Region of interest. #' Either an sf_object, a shapefile, diff --git a/R/api_dtw.R b/R/api_dtw.R index 1cf0ebad8..9108562ad 100644 --- a/R/api_dtw.R +++ b/R/api_dtw.R @@ -1,6 +1,8 @@ # ---- Distances ---- #' @title Calculate the DTW distance between temporal patterns and time-series. #' @name .dtw_distance_windowed +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @description This function calculates the DTW distance between label patterns #' and real data (e.g., sample data, data cube data). The distance is calculated #' using windows. @@ -25,6 +27,8 @@ # ---- Operation mode ---- #' @title Search for events in data cube. #' @name .dtw_cube +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @description This function searches for events in data cubes. #' @keywords internal #' @noRd @@ -73,6 +77,8 @@ } #' @title Search for events in time-series. #' @name .dtw_ts +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @description This function searches for events in time-series #' @keywords internal #' @noRd diff --git a/R/api_environment.R b/R/api_environment.R index 95ace0b60..cac419473 100644 --- a/R/api_environment.R +++ b/R/api_environment.R @@ -1,6 +1,8 @@ # ---- Environment operations ---- #' @title Function to patch environment variables (Developer only). +#' @name .environment_patch +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @@ -49,7 +51,7 @@ #' @title Function to rollback patch in environment variables (Developer only). #' @keywords internal #' @noRd -#' +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @description #' This function rollback patches in environment variables created with the #' function `.environment_patch`. @@ -90,6 +92,8 @@ # ---- Environment configurations ---- #' @title Function to create patch configuration for the CDSE source. +#' @name .environment_cdse +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' diff --git a/R/api_file.R b/R/api_file.R index b483482c5..d0696882d 100644 --- a/R/api_file.R +++ b/R/api_file.R @@ -1,5 +1,6 @@ #' @title Get file base name #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param file File name #' @returns File base name .file_base <- function(file) { @@ -7,6 +8,7 @@ } #' @title Get file base name #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @param file File name #' @returns File base name .file_dir <- function(file) { @@ -14,6 +16,7 @@ gsub("[?].*$", "", gsub("^(.*/).*$", "\\1", file)) } #' @title Get file name without extension +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param file File name #' @returns File name without extension @@ -21,6 +24,7 @@ gsub("(.*)\\..+$", "\\1", .file_base(file)) } #' @title Get file name extension +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param file File name #' @returns File name extension @@ -28,6 +32,7 @@ gsub(".*\\.(.+)$", "\\1", .file_base(file)) } #' @title Apply a pattern to the file +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param file File name #' @param suffix File suffix @@ -36,6 +41,7 @@ paste0(.file_sans_ext(.file_base(file)), suffix) } #' @title Expand the file path +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param file File name #' @returns File base name with path expanded @@ -43,6 +49,7 @@ path.expand(file) } #' @title Build a file path +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param ... File name #' @param ext File extension @@ -70,6 +77,9 @@ filenames } #' @title Is the file local? +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param file File name #' @returns TRUE/FALSE @@ -77,6 +87,10 @@ !all(grepl(pattern = "^(http[s]?|s3)://", x = file)) } #' @title Remove vsi preamble for remote files +#' +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param file File path #' @returns File path without vsi designators @@ -85,6 +99,9 @@ } #' @title Create a file path for a block +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param pattern Pattern to be used #' @param block Block (first row, first col, nrows, ncols) @@ -100,6 +117,9 @@ } #' @title Create a log file +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param output_dir Directory where the log will be saved #' @returns File path for the log @@ -113,6 +133,9 @@ #' @title Build a file path for a derived file #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @param tile Tile of data cube #' @param band Spectral band #' @param version Version name @@ -128,6 +151,9 @@ } #' @title Build a file path for a mosaic of derived cubes +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param tile Tile of data cube #' @param band Spectral band @@ -143,6 +169,9 @@ } #' @title Build a file path for a mosaic of raster cubes #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @param tile Tile of data cube #' @param band Spectral band #' @param output_dir Directory where file will be saved @@ -156,6 +185,9 @@ } #' @title Build a file path for a cropped file #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @param tile Tile of data cube #' @param band Spectral band #' @param version Version name @@ -171,6 +203,9 @@ ) } #' @title Build a file path for a file in an eo_cube +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param tile Tile of data cube #' @param band Spectral band diff --git a/R/api_file_info.R b/R/api_file_info.R index 374355854..06e4c97a5 100644 --- a/R/api_file_info.R +++ b/R/api_file_info.R @@ -1,6 +1,8 @@ #' @title File info API #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description #' Set of functions for handling `file_info`. diff --git a/R/api_gdal.R b/R/api_gdal.R index 726af281c..9ee502a24 100644 --- a/R/api_gdal.R +++ b/R/api_gdal.R @@ -6,6 +6,9 @@ FLT8S = "Float64" ) #' @title Get GDAL parameters +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param params Params used to describe GDAL file #' @returns Cleaned GDAL parameters @@ -32,6 +35,9 @@ } #' @title Format GDAL parameters #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @param asset File to be accessed (with path) #' @param roi Region of interest (sf object) #' @param res Spatial resolution @@ -54,6 +60,9 @@ } #' @title Format GDAL block parameters for data access #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @param asset File to be accessed (with path) #' @param roi Region of interest (sf object) #' @returns Formatted GDAL block parameters for data access @@ -67,6 +76,9 @@ ) } #' @title Run gdal_translate +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param file File to be created (with path) #' @param base_file File to be copied from (with path) @@ -83,6 +95,9 @@ return(invisible(file)) } #' @title Run gdal_warp +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param file File to be created (with path) #' @param base_files Files to be copied from (with path) @@ -126,6 +141,9 @@ return(temp_file) } #' @title Run gdal_addo +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param base_file Base file to be processed #' @returns Called for side effects @@ -143,6 +161,9 @@ } #' @title Run gdal_translate from a block to a file #' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @param block Block with #' @param bbox Bounding box for file #' @param file Files to be written to (with path) @@ -196,6 +217,9 @@ return(file) } #' @title Merge files into a single file +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param file Files to be written to (with path) #' @param base_files Files to be copied from (with path) @@ -256,6 +280,9 @@ } #' @title Crop an image and save to file +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param file Input file (with path) #' @param out_file Output files (with path) @@ -298,6 +325,9 @@ return(invisible(out_file)) } #' @title Rescale image values and save to file +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param file Input file (with path) #' @param out_file Output files (with path) @@ -331,6 +361,9 @@ return(invisible(file)) } #' @title Change the projection of an image and save to file +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param file Input file (with path) #' @param out_file Output files (with path) @@ -361,6 +394,9 @@ return(invisible(out_file)) } #' @title Get GDAL Version +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @returns GDAL Version .gdal_version <- function() { diff --git a/R/api_gdalcubes.R b/R/api_gdalcubes.R index 898f42af3..e9f9ec414 100644 --- a/R/api_gdalcubes.R +++ b/R/api_gdalcubes.R @@ -1,6 +1,7 @@ #' @title Images arrangement in sits cube #' @name .gc_arrange_images -#' +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @param cube Data cube. @@ -53,6 +54,8 @@ #' @title Create a cube_view object #' @name .gc_create_cube_view +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @@ -121,6 +124,8 @@ #' @title Create an gdalcubes::image_mask object #' @name .gc_create_cloud_mask +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @@ -166,6 +171,8 @@ #' @title Create an image_collection object #' @name .gc_create_database_stac +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' #' @keywords internal #' @noRd @@ -263,6 +270,8 @@ } #' @title Create a gdalcubes::pack object +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @name .gc_create_pack #' @keywords internal #' @noRd @@ -288,6 +297,8 @@ #' @title Create an gdalcubes::raster_cube object #' @name .gc_create_raster_cube +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @param cube_view \code{gdalcubes::cube_view} object. @@ -329,7 +340,8 @@ #' @title Get the timeline of intersection in all tiles #' @name .gc_get_valid_timeline -#' +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @param cube Data cube. @@ -390,6 +402,8 @@ #' @title Saves the images of a raster cube. #' @name .gc_save_raster_cube +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @param raster_cube \code{gdalcubes::raster_cube} object. @@ -437,8 +451,9 @@ } #' @title Build a regular data cube from an irregular one -#' #' @name .gc_regularize +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @description Creates cubes with regular time intervals @@ -686,8 +701,9 @@ } #' @title Detect the type of cube crs -#' #' @name .gc_detect_crs_type +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @param cube_crs A vector of characters with cube crs. @@ -703,8 +719,9 @@ } #' @title Finds the missing tiles in a regularized cube -#' #' @name .gc_missing_tiles +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @keywords internal #' @noRd #' @param cube Original cube to be regularized. diff --git a/R/api_grid.R b/R/api_grid.R index a4e16a4f5..6df95c379 100644 --- a/R/api_grid.R +++ b/R/api_grid.R @@ -1,5 +1,8 @@ #' @title Create all MGRS Sentinel-2 tiles #' @name .grid_filter_mgrs +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @return a simple feature containing all Sentinel-2 tiles @@ -80,6 +83,16 @@ return(s2_tiles) } +#' @title Filter data in the Brazil Data Cube grid system +#' @name .grid_filter_bdc +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @keywords internal +#' @noRd +#' @param grid_system Grid system in use (BDC) +#' @param roi Region of interest +#' @param tiles Tiles to be retrieved +#' @return Tiles from the BDC system .grid_filter_bdc <- function(grid_system, roi, tiles) { # check @@ -137,7 +150,16 @@ ) return(bdc_tiles) } - +#' @title Filter tiles in different grid system +#' @name .grid_filter_tiles +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @keywords internal +#' @noRd +#' @param grid_system Grid system in use (BDC) +#' @param roi Region of interest +#' @param tiles Tiles to be retrieved +#' @return Tiles in the desired grid system .grid_filter_tiles <- function(grid_system, roi, tiles) { switch( grid_system, diff --git a/R/api_jobs.R b/R/api_jobs.R index 0d070b425..754784aad 100644 --- a/R/api_jobs.R +++ b/R/api_jobs.R @@ -1,4 +1,6 @@ #' @title Estimate the minimum memory need to process a job +#' @name .jobs_block_memsize +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param block_size Size of the each block to be processed #' @param npaths Number of inputs (n_bands * n_times) @@ -10,6 +12,8 @@ block_size * npaths * nbytes * proc_bloat * 1e-09 } #' @title Update block parameter +#' @name .jobs_optimal_block +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param job_block_memsize Total memory required for to process one block #' @param block Initial estimate of block size @@ -59,6 +63,8 @@ return(block) } #' @title Estimate the number of multicores to be used +#' @name .job_max_multicore +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param job_block_memsize Total memory required to process one block #' @param memsize Memory available (in GB) @@ -75,12 +81,14 @@ min(multicores, max_blocks) } #' @title Return the number of multicores used +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @returns Number of multicores .jobs_multicores <- function() { length(sits_env[["cluster"]]) } #' @title Return list of jobs +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param jobs Jobs to be processed #' @returns List of jobs @@ -88,6 +96,7 @@ list(jobs) } #' @title Run a sequential function for all jobs +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param jobs Jobs to be processed #' @param fn Function to be run sequentially @@ -96,6 +105,7 @@ slider::slide(jobs, fn, ...) } #' @title Run a sequential function for all jobs and return vector +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param jobs Jobs to be processed #' @param fn Function to be run sequentially @@ -104,6 +114,7 @@ slider::slide_chr(jobs, fn, ...) } #' @title Run a sequential function for all jobs and return data.frame +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param jobs Jobs to be processed #' @param fn Function to be run sequentially @@ -112,6 +123,7 @@ slider::slide_dfr(jobs, fn, ...) } #' @title Run a parallel function for all jobs +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param jobs Jobs to be processed #' @param fn Function to be run in parallel @@ -132,6 +144,7 @@ }), recursive = FALSE) } #' @title Run a parallel function for all jobs and return vector +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param jobs Jobs to be processed #' @param fn Function to be run in parallel @@ -143,6 +156,7 @@ vapply(values_lst, c, NA_character_) } #' @title Run a parallel function for all jobs and return data.frame +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd #' @param jobs Jobs to be processed #' @param fn Function to be run in parallel diff --git a/R/api_kohonen.R b/R/api_kohonen.R index a11315702..990e01fb3 100644 --- a/R/api_kohonen.R +++ b/R/api_kohonen.R @@ -1,6 +1,8 @@ # ---- kohonen utilities ---- #' @title Get a shared pointer of a distance function. +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @keywords internal #' @note @@ -26,6 +28,8 @@ } #' @title Get number of NA values in a given data matrix. +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @keywords internal #' @note @@ -52,6 +56,8 @@ } #' @title Transform a Kohonen classes vector in a compatible classes matrix +#' @author Lorena Alves, \email{lorena.santos@@inpe.br} +#' @author Karine Ferreira. \email{karine.ferreira@@inpe.br} #' @noRd #' @keywords internal #' @note @@ -81,6 +87,8 @@ } #' @title Calculate distances between Kohonen objects weights. +#' @author Lorena Alves, \email{lorena.santos@@inpe.br} +#' @author Karine Ferreira. \email{karine.ferreira@@inpe.br} #' @noRd #' @keywords internal #' @note @@ -147,7 +155,9 @@ } # ---- kohonen operations ---- -#' @title Create SOM Map. +#' @title Create SOM Map +#' @author Lorena Alves, \email{lorena.santos@@inpe.br} +#' @author Karine Ferreira. \email{karine.ferreira@@inpe.br} #' @noRd #' @keywords internal #' @note @@ -235,6 +245,8 @@ } #' @title Self- and super-organizing maps +#' @author Lorena Alves, \email{lorena.santos@@inpe.br} +#' @author Karine Ferreira. \email{karine.ferreira@@inpe.br} #' @noRd #' @keywords internal #' @note diff --git a/R/api_label_class.R b/R/api_label_class.R index f3c9ea69c..099115fc4 100644 --- a/R/api_label_class.R +++ b/R/api_label_class.R @@ -1,4 +1,6 @@ #' @title Build a classified map from a tile +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @noRd #' @param tile Tile of data cube #' @param band Spectral band @@ -88,6 +90,8 @@ #' @title Build a classified vector segments from a tile #' @noRd +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @param tile Tile of data cube #' @param band Spectral band #' @param output_dir Directory where file will be saved @@ -146,7 +150,10 @@ return(class_tile) } +#' @title Label the probs maps with the most probable class #' @name .label_fn_majority +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @description Build a classified map from probs cube #' based on maximal probability #' @noRd @@ -164,7 +171,9 @@ # Return closure label_fn } +#' @title Label a classified vector cube #' @name .label_gpkg_file +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @description Extract the labels required by sits from GPKG file #' @param gpkg_file File in GPKG format #' @noRd diff --git a/R/api_mask.R b/R/api_mask.R index 37cafce6b..c1a5508f6 100644 --- a/R/api_mask.R +++ b/R/api_mask.R @@ -1,5 +1,9 @@ -#' @describeIn mask_api Converts \code{mask} to an \code{sf} object. -#' @returns \code{.roi_as_sf()}: \code{sf}. +#' @title Convert an exclusion mask to an sf object +#' @name .mask_as_sf +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @param mask Exclusion mask +#' @returns sf object with simplified geometries #' @noRd .mask_as_sf <- function(mask) { # load sf diff --git a/R/api_merge.R b/R/api_merge.R index f3cc32790..26ccb0bac 100644 --- a/R/api_merge.R +++ b/R/api_merge.R @@ -1,4 +1,12 @@ # ---- General utilities ---- +#' @title Check if two cube have the same bands +#' @name .merge_has_equal_bands +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return TRUE/FALSE .merge_has_equal_bands <- function(data1, data2) { # get cube bands data1_bands <- .cube_bands(data1) @@ -17,7 +25,14 @@ # return has_same_bands } - +#' @title Check if two cube have common tiles +#' @name .merge_get_common_tiles +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return Tiles that are part of both cubes .merge_get_common_tiles <- function(data1, data2) { # Extract common tiles d1_tiles <- .cube_tiles(data1) @@ -25,8 +40,14 @@ # Extract overlaps intersect(d1_tiles, d2_tiles) } - -# ---- Adjust timeline strategies strategies ---- +#' @title Adjust timeline strategies strategies +#' @name .merge_zipper_strategy +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param t1 Timeline of data cube 1 +#' @param t2 Timeline of data cube 2 +#' @return Common timeline for both cubes .merge_zipper_strategy <- function(t1, t2) { # define vector to store overlapping dates t_overlap <- c() @@ -62,6 +83,14 @@ } # ---- Merge strategies ---- +#' @title Define merge strategy based on combining files +#' @name .merge_strategy_file +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return Merged data cube .merge_strategy_file <- function(data1, data2) { # extract tiles tiles <- .merge_get_common_tiles(data1, data2) @@ -91,13 +120,27 @@ }) }) } - +#' @title Define merge strategy based on binding tiles +#' @name .merge_strategy_bind +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return Merged data cube .merge_strategy_bind <- function(data1, data2) { # Merge dplyr::bind_rows(data1, data2) } -# ---- Merge operations - Densify cube ---- +#' @title Define merge strategy based on densifying the cube +#' @name .merge_strategy_densify +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return Merged data cube .merge_cube_densify <- function(data1, data2) { # get tile overlaps common_tiles <- .merge_get_common_tiles(data1, data2) @@ -120,7 +163,14 @@ merged_cube } -# ---- Merge operations - Temporal overlaps ---- +#' @title Define merge strategy based on increasing the timeline +#' @name .merge_strategy_compactify +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return Merged data cube .merge_cube_compactify <- function(data1, data2) { # extract tiles tiles <- .merge_get_common_tiles(data1, data2) @@ -173,7 +223,14 @@ # return merged_cube } - +#' @title Define merge strategy based on intersecting the timeline +#' @name .merge_strategy_intersects +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return Merged data cube .merge_strategy_intersects <- function(data1, data2) { # Get data cubes timeline t1 <- .cube_timeline(data1)[[1]] @@ -238,7 +295,14 @@ return(data1) } -# ---- Merge operation: DEM case ---- +#' @title Define merge strategy when one of the cubes is a DEM +#' @name .merge_dem +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return Merged data cube .merge_dem <- function(data1, data2) { # define cubes dem_cube <- data1 @@ -270,7 +334,14 @@ .merge_strategy_file(other_cube, dem_cube) } -# ---- Merge operation: HLS case ---- +#' @title Define merge strategy for Harmonized Landsat-Sentinel data +#' @name .merge_hls +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return Merged data cube .merge_hls <- function(data1, data2) { if ((.cube_collection(data1) == "HLSS30" || .cube_collection(data2) == "HLSS30")) { @@ -281,8 +352,14 @@ .merge_strategy_file(data1, data2) } - -# ---- Merge operation: Regular case ---- +#' @title Define merge strategy for regular cubes +#' @name .merge_regular +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return Merged data cube .merge_regular <- function(data1, data2) { # Rule 1: Do the cubes have same tiles? .check_cube_tiles(data1, .cube_tiles(data2)) @@ -308,7 +385,14 @@ # Return merged cube return(merged_cube) } - +#' @title Define merge strategy for irregular cubes +#' @name .merge_irregular +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return Merged data cube .merge_irregular <- function(data1, data2) { # verify if cube has the same bands has_same_bands <- .merge_has_equal_bands(data1, data2) @@ -323,13 +407,28 @@ merged_cube <- .merge_cube_compactify(data1, data2) } } - +#' @title Chooses strategy based on input data +#' @name .merge_switch +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @param ... Additional params for operations +#' @return Merged data cube .merge_switch <- function(data1, data2, ...) { switch(.merge_type(data1, data2), ... ) } - +#' @title Chooses strategy type +#' @name .merge_type +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return Strategy to be used .merge_type <- function(data1, data2) { # Special cases if (any(inherits(data1, "dem_cube"), inherits(data2, "dem_cube"))) { diff --git a/R/api_mosaic.R b/R/api_mosaic.R index 7e5d0cd85..aaf2d59cd 100644 --- a/R/api_mosaic.R +++ b/R/api_mosaic.R @@ -1,4 +1,6 @@ #' @title Split data cube by band and date +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param cube Data cube @@ -77,6 +79,8 @@ data } #' @title Merge tiles to get mosaic +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param cube Data cube @@ -170,6 +174,8 @@ .cube_merge_tiles(mosaic_cube) } #' @title Crop asset as a part of mosaicking +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param asset Data cube @@ -268,22 +274,9 @@ ) return(asset) } -#' @title Delete ROI -#' @keywords internal -#' @noRd -#' @param roi Region of interest -#' @return Called for side effects -.roi_delete <- function(roi) { - if (is.null(roi)) { - return(roi) - } - dir_name <- dirname(roi) - file_name <- .file_sans_ext(roi) - shp_exts <- c(".shp", ".shx", ".dbf", ".prj") - unlink(paste0(file.path(dir_name, file_name), shp_exts)) - return(invisible(roi)) -} #' @title Get type of mosaic +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param tile Tile of data cube @@ -295,6 +288,8 @@ return("RASTER") } #' @title Switch based on mosaic type +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param tile Tile of data cube @@ -303,6 +298,8 @@ switch(.mosaic_type(tile), ...) } #' @title Get mosaic CRS +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param tile Tile of data cube diff --git a/R/api_opensearch.R b/R/api_opensearch.R index e7f1f62a2..59fdca32d 100644 --- a/R/api_opensearch.R +++ b/R/api_opensearch.R @@ -1,5 +1,5 @@ -# ---- open search utilities ---- #' @title Prepare Open Search feature as STAC Item (Compatible with `rstac`). +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @@ -26,6 +26,7 @@ } #' @title Prepare Open Search features as STAC Items (Compatible with `rstac`). +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @@ -51,6 +52,7 @@ } #' @title Query scenes available in the CDSE Open Search. +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @@ -143,9 +145,8 @@ } .opensearch_as_stac_items(features_result) } - -# ---- open search specializations ---- #' @title Extract `tile` from Open Search Items. +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @description @@ -159,6 +160,8 @@ UseMethod(".opensearch_cdse_extract_tile") } +#' @title Extract `tile` from Open Search Items for Sentinel-2 +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @export @@ -170,7 +173,8 @@ tile_name }) } - +#' @title Extract `tile` from Open Search Items for Sentinel-1 RTC +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @export @@ -178,7 +182,8 @@ "NoTilingSystem" } -#' @title Search data using CDSE Open Search. +#' @title Search data using CDSE Open Search +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @description @@ -214,6 +219,8 @@ UseMethod(".opensearch_cdse_search") } +#' @title Search data using CDSE Open Search for Sentinel-2 +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @export @@ -242,7 +249,8 @@ processingLevel = "S2MSI2A" ) } - +#' @title Search data using CDSE Open Search for Sentinel-1 RTC +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @export diff --git a/R/api_period.R b/R/api_period.R index 0cf94d99a..632cb7132 100644 --- a/R/api_period.R +++ b/R/api_period.R @@ -1,5 +1,8 @@ #' Period API #' +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{lipecaso@@gmail.com} +#' #' According to ISO-8601 a duration is the amount of intervening time #' in a time interval. Here, we use a simplified representation of a duration #' that we call \code{period}. diff --git a/R/api_plot_time_series.R b/R/api_plot_time_series.R index 2fd6235b1..4c8e71bfd 100644 --- a/R/api_plot_time_series.R +++ b/R/api_plot_time_series.R @@ -1,5 +1,6 @@ #' @title Plot all intervals of one time series for the same lat/long together #' @name .plot_allyears +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @description For each lat/long location in the data, join temporal @@ -27,8 +28,8 @@ } #' @title Plot a set of time series for the same spatiotemporal reference -#' #' @name .plot_together +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @description Plots all time series for the same label together. @@ -103,8 +104,8 @@ } #' @title Plot one time series using ggplot -#' #' @name .plot_ggplot_series +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @description Plots a set of time series using ggplot. This function is used @@ -123,8 +124,8 @@ return(g) } #' @title Plot one time series using ggplot (no NAs present) -#' #' @name .plot_ggplot_series_no_na +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @description Plots a set of time series using ggplot in the case the series @@ -165,8 +166,8 @@ return(g) } #' @title Plot one time series with NAs using ggplot -#' #' @name .plot_ggplot_series_na +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @description Plots a set of time series using ggplot, showing where NAs are. @@ -232,8 +233,8 @@ } #' @title Plot many time series together using ggplot -#' #' @name .plot_ggplot_together +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @description Plots a set of time series together. @@ -273,6 +274,7 @@ #' @title Create a plot title to use with ggplot #' @name .plot_title +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @description Creates a plot title from row information. diff --git a/R/api_predictors.R b/R/api_predictors.R index 779028b2f..5fff68beb 100644 --- a/R/api_predictors.R +++ b/R/api_predictors.R @@ -3,6 +3,7 @@ .pred_cols <- c("sample_id", "label") #' @title Get predictors from samples +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param samples Training samples @@ -86,6 +87,7 @@ pred } #' @title Get predictors names with timeline +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param bands Character vector with bands of training samples @@ -101,6 +103,7 @@ )) } #' @title Get features from predictors +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param pred Predictors @@ -113,6 +116,7 @@ } } #' @title Set features from predictors +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param pred Predictors @@ -127,6 +131,7 @@ pred } #' @title Get reference labels from predictors +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param pred Predictors @@ -135,6 +140,7 @@ if (all(.pred_cols %in% names(pred))) .as_chr(pred[["label"]]) else NULL } #' @title Normalize predictors +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param pred Predictors @@ -150,6 +156,7 @@ pred } #' @title Create partitions in predictors data.frame +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param pred Predictors @@ -160,6 +167,7 @@ tidyr::nest(pred, predictors = -"part_id") } #' @title Sample predictors +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param pred Predictors @@ -172,6 +180,7 @@ return(frac) } #' @title Convert predictors to ts +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param data Predictor data to be converted. @@ -196,8 +205,8 @@ .before = 1 ) } -# ---- Partitions ---- #' @title Get predictors of a given partition +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd #' @param part Predictors partition diff --git a/R/api_raster_sub_image.R b/R/api_raster_sub_image.R index e49c46436..74c505c76 100644 --- a/R/api_raster_sub_image.R +++ b/R/api_raster_sub_image.R @@ -1,5 +1,6 @@ #' @title Find the dimensions and location of a spatial ROI in a data cube #' @name .raster_sub_image +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd #' @param tile tile of data cube. diff --git a/R/api_reduce.R b/R/api_reduce.R index 1d1be2002..ac0f823da 100644 --- a/R/api_reduce.R +++ b/R/api_reduce.R @@ -1,5 +1,6 @@ #' @title Reduce tile into one image #' @name .reduce_tile +#' @author Felipe Carvalho, \email{lipecaso@@gmail.com} #' #' @param tile Single tile of a data cube. #' @param block Optimized block to be read into memory. @@ -136,6 +137,7 @@ #' @title Reduce samples #' @name .reduce_samples +#' @author Felipe Carvalho, \email{lipecaso@@gmail.com} #' #' @param data A sits tibble #' @param expr An expression to be evaluated. @@ -189,6 +191,7 @@ #' @title Temporal functions for reduce operations #' @name .reduce_fns +#' @author Felipe Carvalho, \email{lipecaso@@gmail.com} #' @noRd #' @return operations on reduce function .reduce_fns <- function() { @@ -242,7 +245,7 @@ #' @title Output datatypes for a defined reduce function #' @name .reduce_datatypes -#' +#' @author Felipe Carvalho, \email{lipecaso@@gmail.com} #' @param fn_name a character with a reduce function name. #' #' @noRd diff --git a/R/api_roi.R b/R/api_roi.R index 7c5604e61..2743e0f07 100644 --- a/R/api_roi.R +++ b/R/api_roi.R @@ -145,10 +145,20 @@ NULL sf::st_write(obj = roi, dsn = output_file, quiet = quiet, ...) output_file } - -.roi_delete <- function(output_file) { - dir <- .file_dir(output_file) - file_name <- .file_sans_ext(output_file) +#' @title Delete ROI +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @keywords internal +#' @noRd +#' @param roi Region of interest +#' @return Called for side effects +.roi_delete <- function(roi) { + if (is.null(roi)) { + return(roi) + } + dir_name <- dirname(roi) + file_name <- .file_sans_ext(roi) shp_exts <- c(".shp", ".shx", ".dbf", ".prj") - unlink(paste0(dir, file_name, shp_exts)) + unlink(paste0(file.path(dir_name, file_name), shp_exts)) + return(invisible(roi)) } diff --git a/R/sits_accuracy.R b/R/sits_accuracy.R index 30ee31ff7..b89b2dbb8 100644 --- a/R/sits_accuracy.R +++ b/R/sits_accuracy.R @@ -37,9 +37,15 @@ #' a set of time series #' @param \dots Specific parameters #' @param validation Samples for validation (see below) -#' Only required when data is a class cube. +#' Only required when data is a raster class cube. #' @param method A character with 'olofsson' or 'pixel' to compute -#' accuracy. +#' accuracy (only for raster class cubes) +#' @param prediction_attr Name of the column of the segments object +#' that contains the predicted values +#' (only for vector class cubes) +#' @param reference_attr Name of the column of the segments object +#' that contains the reference values +#' (only for vector class cubes) #' #' @return #' A list of lists: The error_matrix, the class_areas, the unbiased @@ -133,6 +139,33 @@ sits_accuracy.sits <- function(data, ...) { # return caret confusion matrix return(acc) } +#' @title Accuracy assessment for vector class cubes +#' @rdname sits_accuracy +#' @export +sits_accuracy.class_vector_cube <- function(data, ..., + prediction_attr, + reference_attr) { + .check_set_caller("sits_accuracy_class_vector_cube") + segments <- .segments_read_vec(data) + .check_chr_contains(colnames(segments), + c(prediction_attr, reference_attr)) + + # create prediction and reference data frames + pred <- segments[[prediction_attr]] + ref <- segments[[reference_attr]] + # Create factor vectors for caret + unique_ref <- unique(ref) + pred_fac <- factor(pred, levels = unique_ref) + ref_fac <- factor(ref, levels = unique_ref) + + # Call caret package to the classification statistics + acc <- caret::confusionMatrix(pred_fac, ref_fac) + + # Assign class to result + class(acc) <- c("sits_accuracy", class(acc)) + # return caret confusion matrix + return(acc) +} #' @title Area-weighted post-classification accuracy for data cubes #' @rdname sits_accuracy #' @export @@ -355,9 +388,7 @@ print.sits_accuracy <- function(x, ..., digits = NULL) { pattern_format <- paste( c( "(Sensitivity)", - "(Specificity)", "(Pos Pred Value)", - "(Neg Pred Value)", "(F1)" ), collapse = "|" @@ -367,8 +398,9 @@ print.sits_accuracy <- function(x, ..., digits = NULL) { ] measures <- t(x[["by_class"]]) rownames(measures) <- c( - "Prod Acc (Sensitivity)", "Specificity", - "User Acc (Pos Pred Value)", "Neg Pred Value", "F1 score" + "Prod Acc (Recall)", + "User Acc (Precision)", + "F1 score" ) print(measures, digits = digits) } else { diff --git a/R/sits_cube.R b/R/sits_cube.R index 9f775d9d2..55e46a1fb 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -41,7 +41,6 @@ #' Use \code{\link{sits_list_collections}()} to find out #' the bands available for each collection. #' @param orbit Orbit name ("ascending", "descending") for SAR cubes. -#' @param vector_band Band for vector cube ("segments", "probs", "class") #' @param start_date,end_date Initial and final dates to include #' images from the collection in the cube (optional). #' (Date in YYYY-MM-DD format). @@ -49,6 +48,8 @@ #' (for local cubes - character vector of length 1). #' @param vector_dir Local director where vector files are stored #' (for local vector cubes - character vector of length 1). +#' @param vector_band Band for vector cube ("segments", "probs", "class") +#' @param polygons A file with polygons (optional to vector_band) #' @param parse_info Parsing information for local files #' (for local cubes - character vector). #' @param version Version of the classified and/or labelled files. diff --git a/R/sits_som.R b/R/sits_som.R index d050fc07b..23e358d45 100644 --- a/R/sits_som.R +++ b/R/sits_som.R @@ -310,6 +310,9 @@ sits_som_clean_samples <- function(som_map, #' @title Evaluate cluster #' @name sits_som_evaluate_cluster +#' @author Lorena Alves, \email{lorena.santos@@inpe.br} +#' @author Karine Ferreira. \email{karine.ferreira@@inpe.br} +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @description #' \code{sits_som_evaluate_cluster()} produces a tibble with the clusters #' found by the SOM map. For each cluster, it provides the percentage @@ -395,6 +398,7 @@ sits_som_evaluate_cluster <- function(som_map) { #' @name sits_som_remove_samples #' @author Lorena Alves, \email{lorena.santos@@inpe.br} #' @author Karine Ferreira. \email{karine.ferreira@@inpe.br} +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @description #' Remove samples from a given class inside a neuron of another class #' @param som_map A SOM map produced by the som_map() function diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index 2cfb530da..a4476a888 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -338,6 +338,7 @@ sits_accuracy: "unable to extract values to measure accuracy - check input" sits_accuracy_sits: "unable to extract predicted and reference data from samples\n have the samples been classified?" sits_accuracy_class_cube: "invalid validation data" sits_accuracy_raster_cube: "input should be a classified cube" +sits_accuracy_class_vector_cube: "attributes for predicted and reference values should be contained in the segments object" sits_accuracy_tbl_df: "input should be a classified sits tibble or a classified data cube" sits_as_sf: "input should be a valid set of training samples or a non-classified data cube" sits_apply: "invalid input data and/or function to be applied" diff --git a/man/sits_accuracy.Rd b/man/sits_accuracy.Rd index ee98d123e..19e9e5127 100644 --- a/man/sits_accuracy.Rd +++ b/man/sits_accuracy.Rd @@ -3,6 +3,7 @@ \name{sits_accuracy} \alias{sits_accuracy} \alias{sits_accuracy.sits} +\alias{sits_accuracy.class_vector_cube} \alias{sits_accuracy.class_cube} \alias{sits_accuracy.raster_cube} \alias{sits_accuracy.derived_cube} @@ -14,6 +15,8 @@ sits_accuracy(data, ...) \method{sits_accuracy}{sits}(data, ...) +\method{sits_accuracy}{class_vector_cube}(data, ..., prediction_attr, reference_attr) + \method{sits_accuracy}{class_cube}(data, ..., validation, method = "olofsson") \method{sits_accuracy}{raster_cube}(data, ...) @@ -30,11 +33,19 @@ a set of time series} \item{\dots}{Specific parameters} +\item{prediction_attr}{Name of the column of the segments object +that contains the predicted values +(only for vector class cubes)} + +\item{reference_attr}{Name of the column of the segments object +that contains the reference values +(only for vector class cubes)} + \item{validation}{Samples for validation (see below) -Only required when data is a class cube.} +Only required when data is a raster class cube.} \item{method}{A character with 'olofsson' or 'pixel' to compute -accuracy.} +accuracy (only for raster class cubes)} } \value{ A list of lists: The error_matrix, the class_areas, the unbiased diff --git a/man/sits_cube.Rd b/man/sits_cube.Rd index 38fa66a57..42925585c 100644 --- a/man/sits_cube.Rd +++ b/man/sits_cube.Rd @@ -125,6 +125,8 @@ classes "probs_cube" or "class_cube").} \item{delim}{Delimiter for parsing local files (single character)} + +\item{polygons}{A file with polygons (optional to vector_band)} } \value{ A \code{tibble} describing the contents of a data cube. diff --git a/man/sits_som_evaluate_cluster.Rd b/man/sits_som_evaluate_cluster.Rd index 199835c32..28262cf52 100644 --- a/man/sits_som_evaluate_cluster.Rd +++ b/man/sits_som_evaluate_cluster.Rd @@ -31,3 +31,10 @@ if (sits_run_examples()) { new_samples <- sits_som_clean_samples(som_map) } } +\author{ +Lorena Alves, \email{lorena.santos@inpe.br} + +Karine Ferreira. \email{karine.ferreira@inpe.br} + +Gilberto Camara, \email{gilberto.camara@inpe.br} +} diff --git a/man/sits_som_remove_samples.Rd b/man/sits_som_remove_samples.Rd index 6f7cfd152..c95d29ea2 100644 --- a/man/sits_som_remove_samples.Rd +++ b/man/sits_som_remove_samples.Rd @@ -35,4 +35,6 @@ if (sits_run_examples()) { Lorena Alves, \email{lorena.santos@inpe.br} Karine Ferreira. \email{karine.ferreira@inpe.br} + +Gilberto Camara, \email{gilberto.camara@inpe.br} } From 55d6c1ab75cb7a1e2bb3e61e225297fbf0177384 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Tue, 11 Mar 2025 16:26:59 -0300 Subject: [PATCH 055/122] fix documentation of sits_cube --- R/sits_cube.R | 1 - man/sits_cube.Rd | 2 -- 2 files changed, 3 deletions(-) diff --git a/R/sits_cube.R b/R/sits_cube.R index 55e46a1fb..a991b5289 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -49,7 +49,6 @@ #' @param vector_dir Local director where vector files are stored #' (for local vector cubes - character vector of length 1). #' @param vector_band Band for vector cube ("segments", "probs", "class") -#' @param polygons A file with polygons (optional to vector_band) #' @param parse_info Parsing information for local files #' (for local cubes - character vector). #' @param version Version of the classified and/or labelled files. diff --git a/man/sits_cube.Rd b/man/sits_cube.Rd index 42925585c..38fa66a57 100644 --- a/man/sits_cube.Rd +++ b/man/sits_cube.Rd @@ -125,8 +125,6 @@ classes "probs_cube" or "class_cube").} \item{delim}{Delimiter for parsing local files (single character)} - -\item{polygons}{A file with polygons (optional to vector_band)} } \value{ A \code{tibble} describing the contents of a data cube. From 0d1bbbaffecf06f076bd861912dcef225a4b3997 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Thu, 13 Mar 2025 19:31:43 -0300 Subject: [PATCH 056/122] improve sits_as_sf --- R/sits_sf.R | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/R/sits_sf.R b/R/sits_sf.R index 8757f8cad..c419e2225 100644 --- a/R/sits_sf.R +++ b/R/sits_sf.R @@ -38,7 +38,7 @@ sits_as_sf.sits <- function(data, ..., crs = "EPSG:4326", as_crs = NULL) { # Convert samples to sf geom <- .point_as_sf(.point(data, crs = crs), as_crs = as_crs) # Bind columns - data <- dplyr::bind_cols(geom, .discard(data, "time_series")) + data <- dplyr::bind_cols(geom, data) return(data) } @@ -50,6 +50,18 @@ sits_as_sf.raster_cube <- function(data, ..., as_crs = NULL) { # Convert cube bbox to sf data_sf <- .cube_as_sf(data, as_crs = as_crs) # Bind columns - data <- dplyr::bind_cols(data_sf, .discard(data, "file_info")) + data <- dplyr::bind_cols(data_sf, "file_info") + return(data) +} +#' @export +#' @rdname sits_as_sf +sits_as_sf.vector_cube <- function(data, ..., as_crs = NULL) { + # Pre-conditions + .check_is_raster_cube(data) + # Convert cube bbox to sf + data_sf <- .cube_as_sf(data, as_crs = as_crs) + # Bind columns + data <- dplyr::bind_cols(data_sf, "file_info") + data <- dplyr::bind_cols(data_sf, "vector_info") return(data) } From c503b0e4978854ccb9534df8c4ae7d8c3e9d89da Mon Sep 17 00:00:00 2001 From: Gilberto Camara Date: Sun, 16 Mar 2025 17:06:02 -0300 Subject: [PATCH 057/122] update documentation of sits_as_sf --- NAMESPACE | 1 + man/sits_as_sf.Rd | 3 +++ 2 files changed, 4 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index c0b08030f..5364e4009 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -340,6 +340,7 @@ S3method(sits_apply,raster_cube) S3method(sits_apply,sits) S3method(sits_as_sf,raster_cube) S3method(sits_as_sf,sits) +S3method(sits_as_sf,vector_cube) S3method(sits_bands,default) S3method(sits_bands,patterns) S3method(sits_bands,raster_cube) diff --git a/man/sits_as_sf.Rd b/man/sits_as_sf.Rd index 509d13592..488042da5 100644 --- a/man/sits_as_sf.Rd +++ b/man/sits_as_sf.Rd @@ -4,6 +4,7 @@ \alias{sits_as_sf} \alias{sits_as_sf.sits} \alias{sits_as_sf.raster_cube} +\alias{sits_as_sf.vector_cube} \title{Return a sits_tibble or raster_cube as an sf object.} \usage{ sits_as_sf(data, ...) @@ -11,6 +12,8 @@ sits_as_sf(data, ...) \method{sits_as_sf}{sits}(data, ..., crs = "EPSG:4326", as_crs = NULL) \method{sits_as_sf}{raster_cube}(data, ..., as_crs = NULL) + +\method{sits_as_sf}{vector_cube}(data, ..., as_crs = NULL) } \arguments{ \item{data}{A sits tibble or sits cube.} From b83b4dd646954465c9c84ecede1b75231538a864 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Tue, 18 Mar 2025 17:14:29 -0300 Subject: [PATCH 058/122] fix documentation --- NAMESPACE | 3 + R/api_bbox.R | 5 +- R/api_check.R | 107 +++++- R/api_colors.R | 9 +- R/api_conf.R | 3 +- R/api_data.R | 4 +- R/api_environment.R | 4 +- R/api_gdal.R | 8 +- R/api_kohonen.R | 39 +- R/api_merge.R | 3 +- R/api_plot_raster.R | 9 +- R/api_predictors.R | 3 +- R/api_regularize.R | 35 +- R/api_segments.R | 3 +- R/api_sf.R | 6 +- R/api_som.R | 4 +- R/api_source_cdse.R | 2 +- R/api_tile.R | 2 +- R/api_tmap.R | 9 +- R/api_view.R | 176 ++++++--- R/sits_accuracy.R | 18 +- R/sits_add_base_cube.R | 2 +- R/sits_apply.R | 39 +- R/sits_bbox.R | 20 +- R/sits_classify.R | 32 +- R/sits_config.R | 2 +- R/sits_cube.R | 188 +++++----- R/sits_get_class.R | 3 +- R/sits_get_probs.R | 3 +- R/sits_histogram.R | 2 +- R/sits_plot.R | 44 +-- R/sits_regularize.R | 26 +- R/sits_sample_functions.R | 5 +- R/sits_sf.R | 2 +- R/sits_som.R | 23 +- R/sits_timeline.R | 7 +- R/sits_tuning.R | 2 +- R/sits_view.R | 11 +- demo/dl_comparison.R | 3 +- .../sample_size_stratified_simple_random.xlsx | Bin 14251 -> 0 bytes inst/extdata/cran/check_package_cran.R | 3 +- inst/extdata/cran/pkg_size_functions.R | 3 +- inst/extdata/cran/sits_codecov.R | 3 +- inst/extdata/scripts/bayes_smooth.R | 19 - inst/extdata/scripts/plot_som_clean_samples.R | 65 ---- inst/extdata/tmap/api_tmap_v3.R | 274 -------------- inst/extdata/tmap/api_tmap_v4.R | 352 ------------------ inst/extdata/torch/download_new_torch.R | 8 - man/plot.Rd | 3 +- man/plot.class_cube.Rd | 2 +- man/plot.dem_cube.Rd | 2 +- man/plot.raster_cube.Rd | 9 +- man/plot.sar_cube.Rd | 5 +- man/plot.uncertainty_cube.Rd | 2 +- man/plot.vector_cube.Rd | 2 +- man/sits_accuracy.Rd | 15 +- man/sits_apply.Rd | 39 +- man/sits_as_sf.Rd | 5 +- man/sits_bbox.Rd | 21 +- man/sits_classify.Rd | 34 +- man/sits_cube.Rd | 180 ++++----- man/sits_get_class.Rd | 3 +- man/sits_get_probs.Rd | 3 +- man/sits_som_remove_samples.Rd | 5 +- man/sits_tuning.Rd | 2 +- tests/testthat/test-apply.R | 3 +- tests/testthat/test-bands.R | 2 +- tests/testthat/test-check.R | 18 +- tests/testthat/test-config.R | 4 +- tests/testthat/test-cube-bdc.R | 2 +- tests/testthat/test-cube-mpc.R | 6 +- tests/testthat/test-get_probs_class.R | 10 +- tests/testthat/test-merge.R | 38 +- tests/testthat/test-plot.R | 3 +- 74 files changed, 785 insertions(+), 1226 deletions(-) delete mode 100644 inst/extdata/accuracy/sample_size_stratified_simple_random.xlsx delete mode 100644 inst/extdata/scripts/bayes_smooth.R delete mode 100644 inst/extdata/scripts/plot_som_clean_samples.R delete mode 100644 inst/extdata/tmap/api_tmap_v3.R delete mode 100644 inst/extdata/tmap/api_tmap_v4.R delete mode 100644 inst/extdata/torch/download_new_torch.R diff --git a/NAMESPACE b/NAMESPACE index c0b08030f..4a9238e04 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -298,6 +298,8 @@ S3method(.tile_yres,raster_cube) S3method(.values_ts,bands_cases_dates) S3method(.values_ts,bands_dates_cases) S3method(.values_ts,cases_dates_bands) +S3method(.view_image_raster,bw) +S3method(.view_image_raster,rgb) S3method(hist,probs_cube) S3method(hist,raster_cube) S3method(hist,sits) @@ -340,6 +342,7 @@ S3method(sits_apply,raster_cube) S3method(sits_apply,sits) S3method(sits_as_sf,raster_cube) S3method(sits_as_sf,sits) +S3method(sits_as_sf,vector_cube) S3method(sits_bands,default) S3method(sits_bands,patterns) S3method(sits_bands,raster_cube) diff --git a/R/api_bbox.R b/R/api_bbox.R index 099a63758..31fc4e5a7 100644 --- a/R/api_bbox.R +++ b/R/api_bbox.R @@ -177,10 +177,7 @@ NULL .check_bbox(bbox) # Check if there are multiple CRS in bbox if (length(.crs(bbox)) > 1 && is.null(as_crs)) { - if (.check_warnings()) { - msg <- .conf("messages", ".bbox_as_sf") - warning(msg, call. = FALSE) - } + .check_warnings_bbox_as_sf() as_crs <- "EPSG:4326" } # Convert to sf object and return it diff --git a/R/api_check.R b/R/api_check.R index d4f396f0a..aee5b8759 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -2320,21 +2320,7 @@ return(TRUE) } } -#' @title Checks if warnings should be displayed -#' @name .check_warnings -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @return TRUE/FALSE -#' @keywords internal -#' @noRd -.check_warnings <- function() { - # if working on sits documentation mode, no progress bar - if (Sys.getenv("SITS_DOCUMENTATION_MODE") == "true" || - Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") { - return(FALSE) - } else { - return(TRUE) - } -} + #' @title Checks if STAC items are correct #' @name .check_stac_items #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} @@ -2409,7 +2395,7 @@ #' @param red Red band for view #' @param green Green band for view #' @param blue Blue band for view -#' @return "BW" or "RGB" +#' @return band for B/W and "RGB" for color images #' @keywords internal #' @noRd .check_available_bands <- function(cube, band, red, green, blue) { @@ -2417,12 +2403,12 @@ if (.has(band)) { # check band is available .check_that(band %in% .cube_bands(cube)) - return(invisible(TRUE)) + return(band) } else if (.has(red) && .has(green) && .has(blue)) { bands <- c(red, green, blue) # check bands are available .check_that(all(bands %in% .cube_bands(cube))) - return(invisible(TRUE)) + return("RGB") } } @@ -2701,3 +2687,88 @@ msg = .conf("messages", ".check_unique_period") ) } +#' @title Checks if warnings should be displayed +#' @name .check_warnings +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @return TRUE/FALSE +#' @keywords internal +#' @noRd +.check_warnings <- function() { + # if working on sits documentation mode, no progress bar + if (Sys.getenv("SITS_DOCUMENTATION_MODE") == "true" || + Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") { + return(FALSE) + } else { + return(TRUE) + } +} +#' @title Warning when converting a bbox into a sf object +#' @name .check_warnings_bbox_as_sf +#' @noRd +#' @returns Called for side effects +.check_warnings_bbox_as_sf <- function() { + if (.check_warnings()) + warning(.conf("messages", ".bbox_as_sf"), call. = FALSE) + return(invisible(NULL)) +} +#' @title Warning when labels have no colors preset +#' @name .check_warnings_colors_get +#' @noRd +#' @returns Called for side effects +.check_warnings_colors_get <- function(missing, palette){ + if (.check_warnings()) { + warning(.conf("messages", ".colors_get_missing"), toString(missing)) + warning(.conf("messages", ".colors_get_missing_palette"), palette) + # grDevices does not work with one color missing + } + return(invisible(NULL)) +} +#' @title Warning when cube has no CLOUD band +#' @name .check_warnings_regularize_cloud +#' @noRd +#' @returns Called for side effects +.check_warnings_regularize_cloud <- function(cube){ + if (!all(.cube_contains_cloud(cube))) { + if (.check_warnings()) + warning(.conf("messages", "sits_regularize_cloud"), + call. = FALSE, + immediate. = TRUE + ) + } + return(invisible(NULL)) +} +#' @title Warning when cube has multiple values of CRS +#' @name .check_warnings_regularize_crs +#' @noRd +#' @returns Called for side effects +.check_warnings_regularize_crs <- function(){ + if (.check_warnings()) + warning(.conf("messages", "sits_regularize_crs"), + call. = FALSE, + immediate. = TRUE + ) + return(invisible(NULL)) +} +#' @title Warning when cube is being regularized directly from STAC files +#' @name .check_warnings_regularize_local +#' @noRd +#' @returns Called for side effects +.check_warnings_regularize_local <- function(cube){ + if (!.cube_is_local(cube) && .check_warnings()) { + warning(.conf("messages", "sits_regularize_local"), + call. = FALSE, immediate. = TRUE + ) + } + return(invisible(NULL)) +} +#' @title Warning when cube has more than one timeline +#' @name .check_warnings_timeline_cube +#' @noRd +#' @returns Called for side effects +.check_warnings_timeline_cube <- function(){ + if (.check_warnings()) + warning(.conf("messages", "sits_timeline_raster_cube"), + call. = FALSE + ) + return(invisible(NULL)) +} diff --git a/R/api_colors.R b/R/api_colors.R index f3bd09cec..803fd6fcf 100644 --- a/R/api_colors.R +++ b/R/api_colors.R @@ -43,12 +43,11 @@ } # are there any colors missing? if (!all(labels %in% names(colors))) { + # find out the missing colors missing <- labels[!labels %in% names(colors)] - if (.check_warnings()) { - warning(.conf("messages", ".colors_get_missing"), toString(missing)) - warning(.conf("messages", ".colors_get_missing_palette"), palette) - # grDevices does not work with one color missing - } + # issue a warning + .check_warnings_colors_get(missing, palette) + # assume colors for the missing labels colors_pal <- grDevices::hcl.colors( n = length(missing), palette = palette, diff --git a/R/api_conf.R b/R/api_conf.R index b492b49de..59fb40f3d 100644 --- a/R/api_conf.R +++ b/R/api_conf.R @@ -34,7 +34,8 @@ .check_int_parameter(rstac_pagination_limit, min = 1, len_min = 1, len_max = 1, max = 500 ) - sits_env[["config"]][["rstac_pagination_limit"]] <- rstac_pagination_limit + sits_env[["config"]][["rstac_pagination_limit"]] <- + rstac_pagination_limit } # process gdal_creation_options if (!is.null(gdal_creation_options)) { diff --git a/R/api_data.R b/R/api_data.R index 5b149b650..98f80aef4 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -851,10 +851,10 @@ #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @keywords internal #' @noRd -#' @param cube Classified data cube from where data is to be retrieved. +#' @param cube Classified data cube #' @param samples Samples to be retrieved. #' -#' @return A tibble with a list of lat/long and respective classes. +#' @return A tibble with a lat/long and respective classes. #' .data_get_class <- function(cube, samples){ data <- slider::slide_dfr(cube, function(tile) { diff --git a/R/api_environment.R b/R/api_environment.R index cac419473..fdc349aa7 100644 --- a/R/api_environment.R +++ b/R/api_environment.R @@ -20,7 +20,7 @@ env_prefix <- env_config[["name"]] env_variables <- env_config[["variables"]] - purrr::map(1:length(env_variables), function(var_idx) { + purrr::map(seq_len(env_variables), function(var_idx) { var_source <- names(env_variables)[[var_idx]] var_target <- unname(env_variables)[[var_idx]] # Get current value of the target variable @@ -64,7 +64,7 @@ env_prefix <- env_config[["name"]] env_variables <- env_config[["variables"]] - purrr::map(1:length(env_variables), function(var_idx) { + purrr::map(seq_len(env_variables), function(var_idx) { var_source <- names(env_variables)[[var_idx]] var_target <- unname(env_variables)[[var_idx]] # Get current value of the target variable diff --git a/R/api_gdal.R b/R/api_gdal.R index 9ee502a24..104177281 100644 --- a/R/api_gdal.R +++ b/R/api_gdal.R @@ -86,7 +86,8 @@ #' @param conf_opts GDAL global configuration options #' @param quiet TRUE/FALSE #' @returns Called for side effects -.gdal_translate <- function(file, base_file, params, conf_opts = character(0), quiet) { +.gdal_translate <- function(file, base_file, params, + conf_opts = character(0), quiet) { sf::gdal_utils( util = "translate", source = base_file[[1]], destination = file[[1]], options = .gdal_params(params), config_options = conf_opts, @@ -105,7 +106,8 @@ #' @param conf_opts GDAL global configuration options #' @param quiet TRUE/FALSE #' @returns Called for side effects -.gdal_warp <- function(file, base_files, params, quiet, conf_opts = character(0)) { +.gdal_warp <- function(file, base_files, params, + quiet, conf_opts = character(0)) { sf::gdal_utils( util = "warp", source = base_files, destination = file[[1]], options = .gdal_params(params), config_options = conf_opts, @@ -123,7 +125,7 @@ # create a temporary file temp_file <- tempfile(fileext = ".tif") # basic parameters - params = list( + params <- list( "-ts" = list(sizes[["xsize"]], sizes[["ysize"]]), "-multi" = FALSE, "-q" = TRUE, diff --git a/R/api_kohonen.R b/R/api_kohonen.R index 990e01fb3..b9c7ad313 100644 --- a/R/api_kohonen.R +++ b/R/api_kohonen.R @@ -47,17 +47,24 @@ #' `data matrix`. .kohonen_get_n_na <- function(data, max_na_fraction, nobjects) { if (max_na_fraction > 0L) { - t(sapply(data, function(x) - apply(x, 1, function(y) - sum(is.na(y))))) + res <- data |> + purrr::map(function(x){ + apply(x, 1, function(y) + sum(is.na(y)) + ) + }) |> + dplyr::bind_rows() |> + as.matrix() |> + t() } else { - matrix(0, length(data), nobjects) + res <- matrix(0, length(data), nobjects) } + return(res) } #' @title Transform a Kohonen classes vector in a compatible classes matrix -#' @author Lorena Alves, \email{lorena.santos@@inpe.br} -#' @author Karine Ferreira. \email{karine.ferreira@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @keywords internal #' @note @@ -87,8 +94,8 @@ } #' @title Calculate distances between Kohonen objects weights. -#' @author Lorena Alves, \email{lorena.santos@@inpe.br} -#' @author Karine Ferreira. \email{karine.ferreira@@inpe.br} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @keywords internal #' @note @@ -101,7 +108,7 @@ #' @param kohobj Kohonen object. #' @param type Kohonen object type. The possible values are `data` and #' `codes` -#' @param whatmap What data layers to use. If unspecified all layers are used. +#' @param whatmap Data layers to use. If unspecified all layers are used. #' @return Distances objects containing the weight distances, and #' related metadata. .kohonen_object_distances <- function(kohobj, @@ -124,12 +131,8 @@ weights <- kohobj$user_weights[whatmap] * kohobj$distance_weights[whatmap] # get data data <- kohobj[[type]][whatmap] - # transform data to matrix, if required - if (any(factor_idx <- sapply(data, is.factor))) { - data[factor_idx] <- lapply(data[factor_idx], .kohonen_classvec2classmat) - } # calculate the number of variables, objects and, NA values in the map data - nvars <- sapply(data, ncol) + nvars <- purrr::map_int(data, ncol) nobjects <- nrow(data[[1]]) n_na <- .kohonen_get_n_na(data, max_na_fraction, nobjects) # prepare data matrix @@ -215,7 +218,7 @@ } } # calculate the number of variables and codes in the codes data - nvars <- sapply(codes, ncol) + nvars <- purrr::map_int(codes, ncol) ncodes <- nrow(codes[[1]]) # calculate the number of objects and NA values in the map data nobjects <- nrow(newdata[[1]]) @@ -313,7 +316,7 @@ } # calculate the number of variables, objects and, NA values in the map data nobjects <- nrow(data[[1]]) - nvar <- sapply(data, ncol) + nvar <- purrr::map_int(data, ncol) n_na <- .kohonen_get_n_na(data, max_na_fraction, nobjects) # transform the user-defined data in a matrix data_matrix <- matrix(unlist(data), ncol = nobjects, byrow = TRUE) @@ -369,7 +372,7 @@ ) ) - if (any(sapply(meanDistances, mean) < .Machine$double.eps)) { + if (any(purrr::map_dbl(meanDistances, mean) < .Machine$double.eps)) { stop("Non-informative layers present: mean distance between objects zero") } @@ -378,7 +381,7 @@ ## the distance weights are then the reciprocal values of the mean ## distances per layer. We no longer use median distances since ## there is a real chance that for factor data the median equals zero - distance_weights[whatmap] <- 1 / sapply(meanDistances, mean) + distance_weights[whatmap] <- 1 / purrr::map_dbl(meanDistances, mean) weights <- user_weights * distance_weights[whatmap] weights <- weights / sum(weights) diff --git a/R/api_merge.R b/R/api_merge.R index 26ccb0bac..513ff9a08 100644 --- a/R/api_merge.R +++ b/R/api_merge.R @@ -453,7 +453,8 @@ .cube_has_unique_period(data2)) { "regular_case" } else if (!.cube_is_regular(data1) || !.cube_is_regular(data2) || - !.cube_has_unique_period(data1) || !.cube_has_unique_period(data2)) { + !.cube_has_unique_period(data1) || + !.cube_has_unique_period(data2)) { "irregular_case" } else { stop(.conf("messages", ".merge_type"), class(data1)) diff --git a/R/api_plot_raster.R b/R/api_plot_raster.R index c3f38b884..e8d21cb82 100644 --- a/R/api_plot_raster.R +++ b/R/api_plot_raster.R @@ -36,6 +36,11 @@ last_quantile, tmap_params) { + # check palette + .check_palette(palette) + # check rev + .check_lgl_parameter(rev) + # crop using ROI if (.has(roi)) { tile <- tile |> @@ -108,8 +113,6 @@ #' @param roi Spatial extent to plot in WGS 84 - named vector #' with either (lon_min, lon_max, lat_min, lat_max) or #' (xmin, xmax, ymin, ymax) -#' @param palette A sequential RColorBrewer palette -#' @param rev Reverse the color palette? #' @param scale Scale to plot map (0.4 to 1.0) #' @param max_cog_size Maximum size of COG overviews (lines or columns) #' @param first_quantile First quantile for stretching images @@ -122,8 +125,6 @@ band, dates, roi, - palette, - rev, scale, max_cog_size, first_quantile, diff --git a/R/api_predictors.R b/R/api_predictors.R index 5fff68beb..0a209a9a5 100644 --- a/R/api_predictors.R +++ b/R/api_predictors.R @@ -199,7 +199,8 @@ ) ) |> dplyr::mutate( - sample_id = rep( seq_len(nrow(data)), each = dplyr::n() / nrow(data) ), + sample_id = rep(seq_len(nrow(data)), + each = dplyr::n() / nrow(data)), label = "NoClass", Index = rep(timeline, nrow(data)), .before = 1 diff --git a/R/api_regularize.R b/R/api_regularize.R index 120a1888e..268192210 100644 --- a/R/api_regularize.R +++ b/R/api_regularize.R @@ -75,10 +75,11 @@ empty_files <- purrr::map_dfr(empty_dates, function(date) { temp_df <- assets[assets[["feature"]] == temp_date,] temp_df[["feature"]] <- date - temp_df[["file_info"]] <- purrr::map(temp_df[["file_info"]], function(fi) { - fi[["path"]] <- NA - fi - }) + temp_df[["file_info"]] <- + purrr::map(temp_df[["file_info"]], function(fi) { + fi[["path"]] <- NA + fi + }) temp_df }) assets <- dplyr::arrange( @@ -180,7 +181,8 @@ #' @noRd #' @export -.reg_tile_convert.raster_cube <- function(cube, grid_system, roi = NULL, tiles = NULL) { +.reg_tile_convert.raster_cube <- function(cube, grid_system, + roi = NULL, tiles = NULL) { # for consistency, check if the grid is already in place if (grid_system == .cube_grid_system(cube)) { return(cube) @@ -265,7 +267,8 @@ #' @noRd #' @export -.reg_tile_convert.grd_cube <- function(cube, grid_system, roi = NULL, tiles = NULL) { +.reg_tile_convert.grd_cube <- function(cube, grid_system, + roi = NULL, tiles = NULL) { # generate system grid tiles and intersects it with doi tiles_filtered <- .grid_filter_tiles( grid_system = grid_system, tiles = tiles, roi = roi @@ -311,7 +314,10 @@ #' @noRd #' @export -.reg_tile_convert.rtc_cube <- function(cube, grid_system, roi = NULL, tiles = NULL) { +.reg_tile_convert.rtc_cube <- function(cube, + grid_system, + roi = NULL, + tiles = NULL) { # generate system grid tiles and intersects it with doi tiles_filtered <- .grid_filter_tiles( grid_system = grid_system, tiles = tiles, roi = roi @@ -370,7 +376,10 @@ #' @noRd #' @export -.reg_tile_convert.dem_cube <- function(cube, grid_system, roi = NULL, tiles = NULL) { +.reg_tile_convert.dem_cube <- function(cube, + grid_system, + roi = NULL, + tiles = NULL) { # generate system grid tiles and intersects it with doi tiles_filtered <- .grid_filter_tiles( grid_system = grid_system, tiles = tiles, roi = roi @@ -429,7 +438,10 @@ #' @noRd #' @export #' -.reg_tile_convert.rainfall_cube <- function(cube, grid_system, roi = NULL, tiles = NULL) { +.reg_tile_convert.rainfall_cube <- function(cube, + grid_system, + roi = NULL, + tiles = NULL) { # generate system grid tiles and intersects it with doi tiles_filtered <- .grid_filter_tiles( grid_system = grid_system, tiles = tiles, roi = roi @@ -482,6 +494,9 @@ .cube_set_class(cube, cube_class) } -.reg_tile_convert.default <- function(cube, grid_system, roi = NULL, tiles = NULL) { +.reg_tile_convert.default <- function(cube, + grid_system, + roi = NULL, + tiles = NULL) { return(cube) } diff --git a/R/api_segments.R b/R/api_segments.R index 46949c822..76b3e2912 100755 --- a/R/api_segments.R +++ b/R/api_segments.R @@ -392,7 +392,8 @@ .data[["pol_id"]] %in% unique(ts_bands[["polygon_id"]]) ) if (.has_column(segments, "x") && .has_column(segments, "y")) { - lat_long <- .proj_to_latlong(segments[["x"]], segments[["y"]], .crs(tile)) + lat_long <- .proj_to_latlong( + segments[["x"]], segments[["y"]], .crs(tile)) } else { lat_long <- tibble::tibble("longitude" = rep(0, nrow(segments)), "latitude" = rep(0, nrow(segments))) diff --git a/R/api_sf.R b/R/api_sf.R index 92b7ab254..1f3382a3e 100644 --- a/R/api_sf.R +++ b/R/api_sf.R @@ -280,8 +280,10 @@ #' .sf_from_window <- function(window) { df <- data.frame( - lon = c(window[["xmin"]], window[["xmin"]], window[["xmax"]], window[["xmax"]]), - lat = c(window[["ymin"]], window[["ymax"]], window[["ymax"]], window[["ymin"]]) + lon = c(window[["xmin"]], window[["xmin"]], + window[["xmax"]], window[["xmax"]]), + lat = c(window[["ymin"]], window[["ymax"]], + window[["ymax"]], window[["ymin"]]) ) polygon <- df |> sf::st_as_sf(coords = c("lon", "lat"), crs = 4326) |> diff --git a/R/api_som.R b/R/api_som.R index 55122b414..1a5f179cc 100644 --- a/R/api_som.R +++ b/R/api_som.R @@ -202,7 +202,7 @@ grid_idx <- 0 neuron_ids <- koh$grid$pts - neuron_pols <- purrr::map(1:nrow(neuron_ids), function(id) { + neuron_pols <- purrr::map(seq_len(neuron_ids), function(id) { x <- neuron_ids[id,"x"] y <- neuron_ids[id,"y"] pol <- rbind(c((x - 1), (y - 1)), @@ -210,7 +210,7 @@ c(x, y), c((x - 1), y), c((x - 1), (y - 1))) - pol = sf::st_polygon(list(pol)) + pol <- sf::st_polygon(list(pol)) return(pol) }) neuron_attr <- as.data.frame(koh$codes) diff --git a/R/api_source_cdse.R b/R/api_source_cdse.R index dccc94d61..5a5f099a0 100644 --- a/R/api_source_cdse.R +++ b/R/api_source_cdse.R @@ -76,7 +76,7 @@ band_path_s3 <- paste0(s3_protocol, s3_bucket, band_item[["Key"]]) # Prepare result and return it # As this auxiliary function only needs to provide the right content - # to other parts of `sits`, only the `href` of the image is returned. + # to other parts of `sits`, only the `href` is returned. # The other necessary actions are managed by `sits.` stats::setNames(list(band = list(href = band_path_s3)), band) }) diff --git a/R/api_tile.R b/R/api_tile.R index 8730ef571..c0e810cf9 100644 --- a/R/api_tile.R +++ b/R/api_tile.R @@ -1622,7 +1622,7 @@ NULL while (i < length(cog_sizes)) { if (cog_sizes[[i]][["xsize"]] < max_size || cog_sizes[[i]][["ysize"]] < max_size) - break; + break i <- i + 1 } # determine the best COG size diff --git a/R/api_tmap.R b/R/api_tmap.R index 8b615054b..929ee59dc 100644 --- a/R/api_tmap.R +++ b/R/api_tmap.R @@ -461,10 +461,10 @@ #' @param dots params passed on dots #' @param legend_position position of legend ("inside", "outside")) #' @param legend_title title of legend -#' @description The following optional parameters are available to allow for detailed -#' control over the plot output: +#' @description The following optional parameters are available +#' to allow for detailed control over the plot output: #' \itemize{ -#' \item \code{graticules_labels_size}: size of coordinates labels (default = 0.8) +#' \item \code{graticules_labels_size}: size of coord labels (default = 0.8) #' \item \code{legend_title_size}: relative size of legend title (default = 1.0) #' \item \code{legend_text_size}: relative size of legend text (default = 1.0) #' \item \code{legend_bg_color}: color of legend background (default = "white") @@ -473,7 +473,8 @@ .tmap_params_set <- function(dots, legend_position, legend_title = NULL){ # tmap params - graticules_labels_size <- as.numeric(.conf("plot", "graticules_labels_size")) + graticules_labels_size <- as.numeric(.conf("plot", + "graticules_labels_size")) legend_bg_color <- .conf("plot", "legend_bg_color") legend_bg_alpha <- as.numeric(.conf("plot", "legend_bg_alpha")) legend_title_size <- as.numeric(.conf("plot", "legend_title_size")) diff --git a/R/api_view.R b/R/api_view.R index 98f5570d8..df1708321 100644 --- a/R/api_view.R +++ b/R/api_view.R @@ -352,53 +352,139 @@ idx_date <- which.min(abs(date - tile_dates)) date <- tile_dates[idx_date] } - # create a leaflet for RGB bands - if (band == "RGB") { - # scale and offset - band_conf <- .tile_band_conf(tile, red) + # define which method is used + if (band == "RGB") + class(band) <- c("rgb", class(band)) + else + class(band) <- c("bw", class(band)) - # filter by date and band - # if there is only one band, RGB files will be the same - red_file <- .tile_path(tile, red, date) - green_file <- .tile_path(tile, green, date) - blue_file <- .tile_path(tile, blue, date) + UseMethod(".view_image_raster", band) +} +#' View RGB image +#' @title Include leaflet to view RGB images +#' @name .view_image_raster.rgb +#' @keywords internal +#' @noRd +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' +#' @param leaf_map Leaflet map to be added to +#' @param group Group to which map will be assigned +#' @param tile Tile to be plotted. +#' @param date Date to be plotted. +#' @param band For plotting grey images. +#' @param red Band for red color. +#' @param green Band for green color. +#' @param blue Band for blue color. +#' @param legend Named vector that associates labels to colors. +#' @param palette Palette provided in the configuration file +#' @param rev Reverse the color palette? +#' @param opacity Opacity to be applied to map layer +#' @param max_cog_size Maximum size of COG overviews (lines or columns) +#' @param first_quantile First quantile for stretching images +#' @param last_quantile Last quantile for stretching images +#' @param leaflet_megabytes Maximum size for leaflet (in MB) +#' +#' @return A leaflet object. +#' @export +.view_image_raster.rgb <- function(leaf_map, + group, + tile, + date, + band, + red, + green, + blue, + palette, + rev, + opacity, + max_cog_size, + first_quantile, + last_quantile, + leaflet_megabytes) { + # scale and offset + band_conf <- .tile_band_conf(tile, red) - # create a leaflet for RGB bands - leaf_map <- leaf_map |> - .view_rgb_bands( - group = group, - tile = tile, - red_file = red_file, - green_file = green_file, - blue_file = blue_file, - band_conf = band_conf, - opacity = opacity, - max_cog_size = max_cog_size, - first_quantile = first_quantile, - last_quantile = last_quantile, - leaflet_megabytes = leaflet_megabytes - ) - } else { - # filter by date and band - band_file <- .tile_path(tile, band, date) - # scale and offset - band_conf <- .tile_band_conf(tile, band) - leaf_map <- leaf_map |> - .view_bw_band( - group = group, - tile = tile, - band_file = band_file, - band_conf = band_conf, - palette = palette, - rev = rev, - opacity = opacity, - max_cog_size = max_cog_size, - first_quantile = first_quantile, - last_quantile = last_quantile, - leaflet_megabytes = leaflet_megabytes - ) - } - return(leaf_map) + # filter by date and band + # if there is only one band, RGB files will be the same + red_file <- .tile_path(tile, red, date) + green_file <- .tile_path(tile, green, date) + blue_file <- .tile_path(tile, blue, date) + + # create a leaflet for RGB bands + leaf_map <- leaf_map |> + .view_rgb_bands( + group = group, + tile = tile, + red_file = red_file, + green_file = green_file, + blue_file = blue_file, + band_conf = band_conf, + opacity = opacity, + max_cog_size = max_cog_size, + first_quantile = first_quantile, + last_quantile = last_quantile, + leaflet_megabytes = leaflet_megabytes + ) +} +#' View BW image +#' @title Include leaflet to view BW images +#' @name .view_image_raster.bw +#' @keywords internal +#' @noRd +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' +#' @param leaf_map Leaflet map to be added to +#' @param group Group to which map will be assigned +#' @param tile Tile to be plotted. +#' @param date Date to be plotted. +#' @param band For plotting grey images. +#' @param red Band for red color. +#' @param green Band for green color. +#' @param blue Band for blue color. +#' @param legend Named vector that associates labels to colors. +#' @param palette Palette provided in the configuration file +#' @param rev Reverse the color palette? +#' @param opacity Opacity to be applied to map layer +#' @param max_cog_size Maximum size of COG overviews (lines or columns) +#' @param first_quantile First quantile for stretching images +#' @param last_quantile Last quantile for stretching images +#' @param leaflet_megabytes Maximum size for leaflet (in MB) +#' +#' @return A leaflet object. +#' @export +.view_image_raster.bw <- function(leaf_map, + group, + tile, + date, + band, + red, + green, + blue, + palette, + rev, + opacity, + max_cog_size, + first_quantile, + last_quantile, + leaflet_megabytes) { + # filter by date and band + band_file <- .tile_path(tile, band, date) + # scale and offset + band_conf <- .tile_band_conf(tile, band) + leaf_map <- leaf_map |> + .view_bw_band( + group = group, + tile = tile, + band_file = band_file, + band_conf = band_conf, + palette = palette, + rev = rev, + opacity = opacity, + max_cog_size = max_cog_size, + first_quantile = first_quantile, + last_quantile = last_quantile, + leaflet_megabytes = leaflet_megabytes + ) } #' @title Include leaflet to view B/W band #' @name .view_bw_band diff --git a/R/sits_accuracy.R b/R/sits_accuracy.R index b89b2dbb8..4236b785d 100644 --- a/R/sits_accuracy.R +++ b/R/sits_accuracy.R @@ -3,14 +3,18 @@ #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} #' @description This function calculates the accuracy of the classification -#' result. For a set of time series, it creates a confusion matrix and then -#' calculates the resulting statistics using package \code{caret}. The time -#' series needs to be classified using \code{\link[sits]{sits_classify}}. +#' result. The input is either a set of classified time series or a classified +#' data cube. #' +#' Classified time series are produced by \code{\link[sits]{sits_classify}}. #' Classified images are generated using \code{\link[sits]{sits_classify}} #' followed by \code{\link[sits]{sits_label_classification}}. +#' +#' For a set of time series, \code{sits_accuracy} creates a confusion matrix and +#' calculates the resulting statistics using package \code{caret}. +#' #' For a classified image, the function uses an area-weighted technique -#' proposed by Olofsson et al. according to [1-3] to produce more reliable +#' proposed by Olofsson et al. according to referenes [1-3] to produce reliable #' accuracy estimates at 95% confidence level. #' #' In both cases, it provides an accuracy assessment of the classified, @@ -51,7 +55,8 @@ #' A list of lists: The error_matrix, the class_areas, the unbiased #' estimated areas, the standard error areas, confidence interval 95% areas, #' and the accuracy (user, producer, and overall), or NULL if the data is empty. -#' A confusion matrix assessment produced by the caret package. +#' The result is assigned to class "sits_accuracy" and can be visualised +#' directly on the screen. # #' @note #' The `validation` data needs to contain the following columns: "latitude", @@ -109,6 +114,7 @@ sits_accuracy <- function(data, ...) { } #' @rdname sits_accuracy #' @export +#' sits_accuracy.sits <- function(data, ...) { .check_set_caller("sits_accuracy_sits") # Require package @@ -394,7 +400,7 @@ print.sits_accuracy <- function(x, ..., digits = NULL) { collapse = "|" ) x[["by_class"]] <- x[["by_class"]][, - grepl(pattern_format, colnames(x[["by_class"]])) + grepl(pattern_format, colnames(x[["by_class"]])) ] measures <- t(x[["by_class"]]) rownames(measures) <- c( diff --git a/R/sits_add_base_cube.R b/R/sits_add_base_cube.R index e44f2ae70..3822637f8 100644 --- a/R/sits_add_base_cube.R +++ b/R/sits_add_base_cube.R @@ -76,7 +76,7 @@ sits_add_base_cube <- function(cube1, cube2) { tile_cube1_tl <- .tile_timeline(tile_cube1) tile_cube2_tl <- .tile_timeline(tile_cube2) # align timelines - fi_cube2[["date"]] <- tile_cube1_tl[1:length(tile_cube2_tl)] + fi_cube2[["date"]] <- tile_cube1_tl[seq_len(tile_cube2_tl)] # update 2nd cube files .fi(tile_cube2) <- fi_cube2 # append cube to base info diff --git a/R/sits_apply.R b/R/sits_apply.R index b76d5840a..2afcc3503 100644 --- a/R/sits_apply.R +++ b/R/sits_apply.R @@ -9,8 +9,7 @@ #' @description #' Apply a named expression to a sits cube or a sits tibble #' to be evaluated and generate new bands (indices). In the case of sits -#' cubes, it materializes a new band in \code{output_dir} using -#' \code{gdalcubes}. +#' cubes, it creates a new band in \code{output_dir}. #' #' @param data Valid sits tibble or cube #' @param window_size An odd number representing the size of the @@ -20,45 +19,57 @@ #' @param memsize Memory available for classification (in GB). #' @param multicores Number of cores to be used for classification. #' @param output_dir Directory where files will be saved. -#' @param normalized Produce normalized band? +#' @param normalized Does the expression produces a normalized band? #' @param progress Show progress bar? #' @param ... Named expressions to be evaluated (see details). #' #' @details -#' \code{sits_apply()} allow any valid R expression to compute new bands. +#' \code{sits_apply()} allows any valid R expression to compute new bands. #' Use R syntax to pass an expression to this function. #' Besides arithmetic operators, you can use virtually any R function #' that can be applied to elements of a matrix (functions that are #' unaware of matrix sizes, e.g. \code{sqrt()}, \code{sin()}, #' \code{log()}). #' -#' Also, \code{sits_apply()} accepts a predefined set of kernel functions +#' Examples of valid expressions: +#' \enumerate{ +#' \item \code{NDVI = (B08 - B04/(B08 + B04))} for Sentinel-2 images. +#' \item \code{EVI = 2.5 * (B05 – B04) / (B05 + 6 * B04 – 7.5 * B02 + 1)} for +#' Landsat-8/9 images. +#' \item \code{VV_VH_RATIO = VH/VV} for Sentinel-1 images. In this case, +#' set the \code{normalized} parameter to FALSE. +#' \item \code{VV_DB = 10 * log10(VV)} to convert Sentinel-1 RTC images +#' available in Planetary Computer to decibels. Also, set the +#' \code{normalized} parameter to FALSE. +#' } +#' +#' \code{sits_apply()} accepts a predefined set of kernel functions #' (see below) that can be applied to pixels considering its #' neighborhood. \code{sits_apply()} considers a neighborhood of a -#' pixel as a set of pixels equidistant to it (including itself) -#' according the Chebyshev distance. This neighborhood form a -#' square window (also known as kernel) around the central pixel +#' pixel as a set of pixels equidistant to it (including itself). +#' This neighborhood forms a square window (also known as kernel) +#' around the central pixel #' (Moore neighborhood). Users can set the \code{window_size} #' parameter to adjust the size of the kernel window. #' The image is conceptually mirrored at the edges so that neighborhood #' including a pixel outside the image is equivalent to take the #' 'mirrored' pixel inside the edge. -#' #' \code{sits_apply()} applies a function to the kernel and its result #' is assigned to a corresponding central pixel on a new matrix. #' The kernel slides throughout the input image and this process #' generates an entire new matrix, which is returned as a new band #' to the cube. The kernel functions ignores any \code{NA} values -#' inside the kernel window. Central pixel is \code{NA} just only -#' all pixels in the window are \code{NA}. +#' inside the kernel window. If all pixels in the window are \code{NA} +#' que result will be \code{NA}. #' -#' By default, the indexes generated by the \code{sits_apply()} function are +#' By default, the indexes generated by \code{sits_apply()} function are #' normalized between -1 and 1, scaled by a factor of 0.0001. #' Normalized indexes are saved as INT2S (Integer with sign). #' If the \code{normalized} parameter is FALSE, no scaling factor will be -#' applied and the index will be saved as FLT4S (Float with sign). +#' applied and the index will be saved as FLT4S (signed float) and +#' the values will vary between -3.4e+38 and 3.4e+38. #' -#' @section Summarizing kernel functions: +#' @section Kernel functions available: #' \itemize{ #' \item{\code{w_median()}: returns the median of the neighborhood's values.} #' \item{\code{w_sum()}: returns the sum of the neighborhood's values.} diff --git a/R/sits_bbox.R b/R/sits_bbox.R index 1b30a25cc..936dbf13e 100644 --- a/R/sits_bbox.R +++ b/R/sits_bbox.R @@ -9,11 +9,19 @@ #' or in projection coordinates in the case of cubes) #' #' @param data samples (class "sits") or \code{cube}. -#' @param crs CRS of the samples points (single char) +#' @param ... parameters for specific types +#' @param crs CRS of the time series. #' @param as_crs CRS to project the resulting \code{bbox}. #' #' @return A \code{bbox}. #' +#' @note +#' Time series in \code{sits} are associated with lat/long +#' values in WGS84, while each data cubes is associated to a +#' cartographic projection. To obtain the bounding box +#' of a data cube in a different projection than the original, +#' use the \code{as_crs} parameter. +#' #' @examples #' if (sits_run_examples()) { #' # get the bbox of a set of samples @@ -28,14 +36,14 @@ #' sits_bbox(cube, as_crs = "EPSG:4326") #' } #' @export -sits_bbox <- function(data, crs = "EPSG:4326", as_crs = NULL) { +sits_bbox <- function(data, ..., crs = "EPSG:4326", as_crs = NULL) { # set caller to show in errors .check_set_caller("sits_bbox") UseMethod("sits_bbox", data) } #' @rdname sits_bbox #' @export -sits_bbox.sits <- function(data, crs = "EPSG:4326", as_crs = NULL) { +sits_bbox.sits <- function(data, ..., crs = "EPSG:4326", as_crs = NULL) { # Pre-conditions data <- .check_samples(data) # Convert to bbox @@ -44,7 +52,7 @@ sits_bbox.sits <- function(data, crs = "EPSG:4326", as_crs = NULL) { } #' @rdname sits_bbox #' @export -sits_bbox.raster_cube <- function(data, crs = "EPSG:4326", as_crs = NULL) { +sits_bbox.raster_cube <- function(data, ..., as_crs = NULL) { # Pre-condition .check_is_raster_cube(data) # Convert to bbox @@ -53,7 +61,7 @@ sits_bbox.raster_cube <- function(data, crs = "EPSG:4326", as_crs = NULL) { } #' @rdname sits_bbox #' @export -sits_bbox.tbl_df <- function(data, crs = "EPSG:4326", as_crs = NULL) { +sits_bbox.tbl_df <- function(data, ..., crs = "EPSG:4326", as_crs = NULL) { data <- tibble::as_tibble(data) if (all(.conf("sits_cube_cols") %in% colnames(data))) { data <- .cube_find_class(data) @@ -67,7 +75,7 @@ sits_bbox.tbl_df <- function(data, crs = "EPSG:4326", as_crs = NULL) { } #' @rdname sits_bbox #' @export -sits_bbox.default <- function(data, crs = "EPSG:4326", as_crs = NULL) { +sits_bbox.default <- function(data, ..., crs = "EPSG:4326", as_crs = NULL) { data <- tibble::as_tibble(data) if (all(.conf("sits_cube_cols") %in% colnames(data))) { data <- .cube_find_class(data) diff --git a/R/sits_classify.R b/R/sits_classify.R index 4d417d1cf..05db37133 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -23,19 +23,19 @@ #' (closure of class "sits_model") #' @param ... Other parameters for specific functions. #' @param roi Region of interest (either an sf object, shapefile, -#' or a numeric vector with named XY values +#' or a numeric vector in WGS 84 with named XY values #' ("xmin", "xmax", "ymin", "ymax") or #' named lat/long values #' ("lon_min", "lat_min", "lon_max", "lat_max"). #' @param exclusion_mask Areas to be excluded from the classification -#' process. It can be defined as a sf object or a +#' process. It can be defined by a sf object or by a #' shapefile. #' @param filter_fn Smoothing filter to be applied - optional #' (closure containing object of class "function"). #' @param impute_fn Imputation function to remove NA. -#' @param start_date Start date for the classification +#' @param start_date Starting date for the classification #' (Date in YYYY-MM-DD format). -#' @param end_date End date for the classification +#' @param end_date Ending date for the classification #' (Date in YYYY-MM-DD format). #' @param memsize Memory available for classification in GB #' (integer, min = 1, max = 16384). @@ -45,10 +45,8 @@ #' @param batch_size Batch size for GPU classification. #' @param n_sam_pol Number of time series per segment to be classified #' (integer, min = 10, max = 50). -#' @param output_dir Valid directory for output file. -#' (character vector of length 1). -#' @param version Version of the output -#' (character vector of length 1). +#' @param output_dir Directory for output file. +#' @param version Version of the output. #' @param verbose Logical: print information about processing time? #' @param progress Logical: Show progress bar? #' @@ -58,8 +56,24 @@ #' (tibble of class "probs_cube"). #' #' @note +#' The \code{sits_classify} function takes three types of data as input +#' and produce there types of output: +#' \enumerate{ +#' \item{A set of time series. The output is the same set +#' with the additional column \code{predicted}.} +#' \item{A raster data cube. The output is a probability cube, +#' which has the same tiles as the raster cube. Each tile contains +#' a multiband image; each band contains the probability that +#' each pixel belongs to a given class.} +#' \item{A vector data cube. Vector data cubes are produced when +#' closed regions are obtained from raster data cubes using +#' \code{\link[sits]{sits_segment}}. Classification of a vector +#' data cube produces a vector data structure with additional +#' columns expressing the class probabilities for each object.} +#' } +#' #' The \code{roi} parameter defines a region of interest. It can be -#' an sf_object, a shapefile, or a bounding box vector with +#' an sf_object, a shapefile, or a bounding box vector in WGS84 with #' named XY values (\code{xmin}, \code{xmax}, \code{ymin}, \code{ymax}) or #' named lat/long values (\code{lon_min}, \code{lon_max}, #' \code{lat_min}, \code{lat_max}) diff --git a/R/sits_config.R b/R/sits_config.R index 8aa480f89..223337dc9 100644 --- a/R/sits_config.R +++ b/R/sits_config.R @@ -83,7 +83,7 @@ sits_config_show <- function() { cat("Data sources available in sits\n") cat(toString(.sources())) cat("\n\n") - cat("Use sits_list_collections() to get details for each source\n\n") + cat("Use sits_list_collections() to get info for each source\n\n") cat("User configurable parameters for plotting\n") config_plot <- sits_env[["config"]][["plot"]] diff --git a/R/sits_cube.R b/R/sits_cube.R index a991b5289..22a332f49 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -11,33 +11,33 @@ #' Amazon Web Services (AWS), Brazil Data Cube (BDC), #' Copernicus Data Space Ecosystem (CDSE), Digital Earth Africa (DEAFRICA), #' Digital Earth Australia (DEAUSTRALIA), Microsoft Planetary Computer (MPC), -#' Nasa Harmonized Landsat/Sentinel (HLS), Swiss Data Cube (SDC), TERRASCOPE or +#' Nasa Harmonized Landsat/Sentinel (HLS), Swiss Data Cube (SDC), TERRASCOPE and #' USGS Landsat (USGS). Data cubes can also be created using local files. #' -#' @param source Data source (one of \code{"AWS"}, \code{"BDC"}, -#' \code{"DEAFRICA"}, \code{"MPC"}, \code{"SDC"}, -#' \code{"USGS"} - character vector of length 1). -#' @param collection Image collection in data source -#' (character vector of length 1). +#' @param source Data source: one of \code{"AWS"}, \code{"BDC"}, +#' \code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, +#' \code{"HLS"}, \code{"PLANETSCOPE"}, \code{"MPC"}, +#' \code{"SDC"} or \code{"USGS"}. +#' @param collection Image collection in data source. #' To find out the supported collections, #' use \code{\link{sits_list_collections}()}). #' @param ... Other parameters to be passed for specific types. #' @param platform Optional parameter specifying the platform in case -#' of collections that include more than one satellite -#' (character vector of length 1). +#' of collections that include more than one satellite. #' @param tiles Tiles from the collection to be included in -#' the cube (see details below) -#' (character vector of length 1). -#' @param roi Region of interest (either an sf object, shapefile, -#' \code{SpatExtent}, or a numeric vector with named XY -#' values ("xmin", "xmax", "ymin", "ymax") or -#' named lat/long values +#' the cube (see details below). +#' @param roi Region of interest. Either an sf object, a shapefile, +#' a \code{SpatExtent} from \code{terra}, +#' a vector with named XY +#' values ("xmin", "xmax", "ymin", "ymax"), or +#' a vector with named lat/long values #' ("lon_min", "lat_min", "lon_max", "lat_max"). #' @param crs The Coordinate Reference System (CRS) of the roi. It -#' must be specified when roi is named XY values -#' ("xmin", "xmax", "ymin", "ymax") or \code{SpatExtent} +#' must be specified when roi is defined by XY values +#' ("xmin", "xmax", "ymin", "ymax") or by +#' a \code{SpatExtent} from \code{terra}. #' @param bands Spectral bands and indices to be included -#' in the cube (optional - character vector). +#' in the cube (optional). #' Use \code{\link{sits_list_collections}()} to find out #' the bands available for each collection. #' @param orbit Orbit name ("ascending", "descending") for SAR cubes. @@ -45,16 +45,16 @@ #' images from the collection in the cube (optional). #' (Date in YYYY-MM-DD format). #' @param data_dir Local directory where images are stored -#' (for local cubes - character vector of length 1). +#' (for local cubes only). #' @param vector_dir Local director where vector files are stored -#' (for local vector cubes - character vector of length 1). +#' (for local vector cubes only). #' @param vector_band Band for vector cube ("segments", "probs", "class") #' @param parse_info Parsing information for local files -#' (for local cubes - character vector). +#' (for local cubes - see notes below). #' @param version Version of the classified and/or labelled files. -#' (for local cubes - character vector of length 1). +#' (for local cubes). #' @param delim Delimiter for parsing local files -#' (single character) +#' (default = "_") #' @param labels Labels associated to the classes #' (Named character vector for cubes of #' classes "probs_cube" or "class_cube"). @@ -64,10 +64,43 @@ #' @return A \code{tibble} describing the contents of a data cube. #' #' @note{ +#' +#' In \code{sits}, a data cube is represented a tibble with metadata +#' describing a set of image files obtained from cloud providers. +#' It contains information about each individual file. +#' +#' In conceptual terms, \code{sits} defines a data cube as: +#' \enumerate{ +#' \item{A set of images organized in tiles of a grid system (e.g., MGRS).} +#' \item{Each tile contains single-band images in a +#' unique zone of the coordinate system (e.g, tile 20LMR in MGRS grid) +#' covering a user-specified time period.} +#' \item{Each image of a tile is associated to a temporal interval. +#' All intervals share the same spectral bands.} +#' \item{Different tiles may cover different zones of the same grid system.} +#' } +#' In \code{sits}, a regular data cube is a data cube where: +#' \enumerate{ +#' \item{All tiles share the same set of regular temporal intervals.} +#' \item{All tiles share the same set of spectral bands and indices.} +#' \item{All images of all tiles have the same spatial resolution.} +#' \item{Each location in a tile is associated a set of multi-band time series.} +#' \item{For each interval and band, the cube is associated to a 2D image.} +#' } +#' +#' Data cubes are identified on cloud providers using \code{sits_cube}. +#' The result of \code{sits_cube} is only a description of the location +#' of the required data in the cloud provider. No download is done. +#' +#' To obtain regular data cubes, use \code{\link[sits]{sits_regularize}}. +#' For faster performance, we suggest users +#' copy data from cloud providers to local disk using \code{sits_cube_copy} +#' before regularization. +#' #' To create cubes from cloud providers, users need to inform: #' \enumerate{ #' \item \code{source}: One of "AWS", "BDC", "CDSE", "DEAFRICA", "DEAUSTRALIA", -#' "HLS", "MPC", "SDC", "TERRASCOPE", or "USGS"; +#' "HLS", "PLANETSCOPE", "MPC", "SDC", "TERRASCOPE", or "USGS"; #' \item \code{collection}: Collection available in the cloud provider. #' Use \code{\link{sits_list_collections}()} to see which #' collections are supported; @@ -78,60 +111,39 @@ #' \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84, a #' \code{sfc} or \code{sf} object from sf package in WGS84 projection. #' A named \code{vector} (\code{"xmin"}, \code{"xmax"}, -#' \code{"ymin"}, \code{"ymax"}) or a \code{SpatExtent} can also -#' be used, requiring only the specification of the \code{crs} parameter. +#' \code{"ymin"}, \code{"ymax"}) +#' or a \code{SpatExtent} from \code{terra}. XY vectors and +#' \code{SpatExtent} require the specification of parameter \code{crs}. #' } #' #' The parameter \code{bands}, \code{start_date}, and \code{end_date} are #' optional for cubes created from cloud providers. #' -#' Either \code{tiles} or \code{roi} must be informed. The \code{roi} parameter -#' is used to select images. This parameter does not crop a region; it only +#' Either \code{tiles} or \code{roi} must be informed. The \code{tiles} +#' should specify a set of valid tiles for the ARD collection. +#' For example, Landsat data has tiles in \code{WRS2} tiling system +#' and Sentinel-2 data uses the \code{MGRS} tiling system. +#' The \code{roi} parameter is used to select all types of images. +#' This parameter does not crop a region; it only #' selects images that intersect it. #' -#' If you want to use GeoJSON geometries (RFC 7946) as value \code{roi}, you -#' can convert it to sf object and then use it. -#' -#' \code{sits} can access data from multiple providers, including -#' \code{Amazon Web Services} (AWS), \code{Microsoft Planetary Computer} (MPC), -#' \code{Brazil Data Cube} (BDC), \code{Copernicus Data Space Ecosystem} (CDSE), -#' \code{Digital Earth Africa}, \code{Digital Earth Australia}, -#' \code{NASA EarthData}, \code{Terrascope} and more. -#' -#' In each provider, \code{sits} can access multiple collections. For example, -#' in MPC \code{sits} can access multiple open data collections, including -#' \code{"SENTINEL-2-L2A"} for Sentinel-2/2A images, and -#' \code{"LANDSAT-C2-L2"} for the Landsat-4/5/7/8/9 collection. -#' -#' In AWS, there are two types of collections: open data and -#' requester-pays. Currently, \code{sits} supports collections -#' \code{"SENTINEL-2-L2A"}, \code{"SENTINEL-S2-L2A-COGS"} (open data) and -#' \code{"LANDSAT-C2-L2"} (requester-pays). There is no need to provide AWS -#' credentials to access open data collections. For requester-pays data, you -#' need to provide your AWS access codes as environment variables, as follows: -#' \code{ -#' Sys.setenv( -#' AWS_ACCESS_KEY_ID = , -#' AWS_SECRET_ACCESS_KEY = -#' )} -#' -#' In BDC, there are many collections, including \code{"LANDSAT-OLI-16D"} -#' (Landsat-8 OLI, 30 m resolution, 16-day intervals), \code{"SENTINEL-2-16D"} -#' (Sentinel-2A and 2B MSI images at 10 m resolution, 16-day intervals), -#' \code{"CBERS-WFI-16D"} (CBERS 4 WFI, 64 m resolution, 16-day intervals), and -#' others. All BDC collections are regularized. -#' -#' To explore providers and collections \code{sits} supports, use the -#' \code{\link{sits_list_collections}()} function. -#' -#' If you want to learn more details about each provider and collection +#' To use GeoJSON geometries (RFC 7946) as value \code{roi}, please +#' convert it to sf object and then use it. +#' +#' To get more details about each provider and collection #' available in \code{sits}, please read the online sits book #' (e-sensing.github.io/sitsbook). The chapter #' \code{Earth Observation data cubes} provides a detailed description of all #' collections you can use with \code{sits} #' (e-sensing.github.io/sitsbook/earth-observation-data-cubes.html). #' -#' To create a cube from local files, you need to inform: +#' Data cubes created from ARD image collection are objects of class +#' \code{"raster_cube"}. Users can extract segments from raster data cubes +#' using \code{\link[sits]{sits_segment}} creating vector data cubes. +#' The segments are stored in a \code{geopackage} file and information +#' about its location is stored in the data cube object. +#' +#' To create a cube from local files, please inform: #' \enumerate{ #' \item \code{source}: The data provider from which the data was #' downloaded (e.g, "BDC", "MPC"); @@ -150,33 +162,24 @@ #' the file names. Default is \code{"_"}. #' } #' -#' Note that if you are working with local data cubes created by \code{sits}, -#' you do not need to specify \code{parse_info} and \code{delim}. These elements -#' are automatically identified. This is particularly useful when you have -#' downloaded or created data cubes using \code{sits}. -#' -#' For example, if you downloaded a data cube from the Microsoft Planetary -#' Computer (MPC) using the function \code{\link{sits_cube_copy}()}, you do -#' not need to provide \code{parse_info} and \code{delim}. -#' -#' If you are using a data cube from a source supported by \code{sits} -#' (e.g., AWS, MPC) but downloaded / managed with an external tool, you will -#' need to specify the \code{parse_info} and \code{delim} parameters manually. -#' For this case, you first need to ensure that the local files meet some -#' critical requirements: +#' When working with local data cubes downloaded or created by \code{sits}, +#' there is no need to specify \code{parse_info} and \code{delim}. +#' To use a data cube from a source supported by \code{sits} +#' (e.g., AWS, MPC) that has been obtained with an external tool, please +#' specify the \code{parse_info} and \code{delim} parameters manually. +#' For this case, to ensure that the local files meet the +#' following requirements: #' #' \itemize{ #' \item All image files must have the same spatial resolution and projection; -#' #' \item Each file should represent a single image band for a single date; -#' #' \item File names must include information about the \code{"tile"}, #' \code{"date"}, and \code{"band"} in the file. #' } #' #' For example, if you are creating a Sentinel-2 data cube on your local #' machine, and the files have the same spatial resolution and projection, with -#' each file containing a single band and date, an acceptable file name could be: +#' each file containing a single band and date, an acceptable file name is: #' \itemize{ #' \item \code{"SENTINEL-2_MSI_20LKP_B02_2018-07-18.jp2"} #' } @@ -185,12 +188,11 @@ #' used by \code{sits}: #' \itemize{ #' \item Tile: "20LKP"; -#' #' \item Band: "B02"; -#' #' \item Date: "2018-07-18" #' } -#' +#' In this case the \code{"parse_info"} parameter should be +#' \code{c("satellite", "sensor", "tile", "band", "date")} #' Other example of supported file names are: #' \itemize{ #' \item \code{"CBERS-4_WFI_022024_B13_2021-05-15.tif"}; @@ -204,20 +206,19 @@ #' metadata from file names. It defines the sequence of components in the #' file name, assigning each part a label such as \code{"tile"}, \code{"band"}, #' and \code{"date"}. For parts of the file name that are irrelevant to -#' \code{sits}, you can use dummy labels like \code{"X1"}, \code{"X2"}, and so -#' on. +#' \code{sits}, you can use dummy labels like \code{"X1"} and \code{"X2"}. #' #' For example, consider the file name: #' \itemize{ #' \item \code{"SENTINEL-2_MSI_20LKP_B02_2018-07-18.jp2"} #' } #' -#' With \code{parse_info = c("X1", "X2", "tile", "band", "date")} and +#' With \code{parse_info = c("satellite", "sensor", "tile", "band", "date")} and #' \code{delim = "_"}, the extracted metadata would be: #' #' \itemize{ -#' \item X1: "SENTINEL-2" (ignored) -#' \item X2: "MSI" (ignored) +#' \item satellite: "SENTINEL-2" (ignored) +#' \item sensor: "MSI" (ignored) #' \item tile: "20LKP" (used) #' \item band: "B02" (used) #' \item date: "2018-07-18" (used) @@ -398,8 +399,7 @@ #' data_dir = data_dir, #' parse_info = c("satellite", "sensor", "tile", "band", "date") #' ) -#' -#' } +#'} #' @export sits_cube <- function(source, collection, ...) { # set caller to show in errors @@ -577,7 +577,7 @@ sits_cube.local_cube <- function(source, ) } .check_chr_parameter(vector_band, - msg = .conf("messages", "sits_cube_local_cube_vector_band") + msg = .conf("messages", "sits_cube_local_cube_vector_band") ) .check_that( vector_band %in% c("segments", "class", "probs"), @@ -647,6 +647,8 @@ sits_mgrs_to_roi <- function(tiles) { #' @export sits_tiles_to_roi <- function(tiles, grid_system = "MGRS") { # retrieve the ROI - roi <- .grid_filter_tiles(grid_system = grid_system, roi = NULL, tiles = tiles) + roi <- .grid_filter_tiles(grid_system = grid_system, + roi = NULL, + tiles = tiles) sf::st_bbox(roi) } diff --git a/R/sits_get_class.R b/R/sits_get_class.R index 1b02fda7b..10c9b595a 100644 --- a/R/sits_get_class.R +++ b/R/sits_get_class.R @@ -14,8 +14,7 @@ #' (e) data.frame: A data.frame with \code{longitude} and \code{latitude}. #' #' -#' @param cube Classified data cube from where data is to be retrieved. -#' (class "class_cube"). +#' @param cube Classified data cube. #' @param samples Location of the samples to be retrieved. #' Either a tibble of class "sits", an "sf" object, #' the name of a shapefile or csv file, or diff --git a/R/sits_get_probs.R b/R/sits_get_probs.R index 87cb14551..1cb0a2bdd 100644 --- a/R/sits_get_probs.R +++ b/R/sits_get_probs.R @@ -15,8 +15,7 @@ #' (e) data.frame: A data.frame with \code{longitude} and \code{latitude}. #' #' -#' @param cube Probability data cube from where data is to be retrieved. -#' (class "class_cube"). +#' @param cube Probability data cube. #' @param samples Location of the samples to be retrieved. #' Either a tibble of class "sits", an "sf" object, #' the name of a shapefile or csv file, or diff --git a/R/sits_histogram.R b/R/sits_histogram.R index 807187cfb..34aa57975 100644 --- a/R/sits_histogram.R +++ b/R/sits_histogram.R @@ -215,7 +215,7 @@ hist.probs_cube <- function(x, ..., ggplot2::xlab("Probability") + ggplot2::ylab("") + ggplot2::theme(legend.title = ggplot2::element_blank()) + - ggplot2::ggtitle(paste("Distribution of probabilities for label", label)) + ggplot2::ggtitle(paste("Probabilities for label", label)) return(suppressWarnings(density_plot)) } diff --git a/R/sits_plot.R b/R/sits_plot.R index 48e74c9d4..44487920d 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -15,7 +15,8 @@ #' \item vector cube: see \code{\link{plot.vector_cube}} #' \item classification probabilities: see \code{\link{plot.probs_cube}} #' \item classification uncertainty: see \code{\link{plot.uncertainty_cube}} -#' \item uncertainty of vector cubes: see \code{\link{plot.uncertainty_vector_cube}} +#' \item uncertainty of vector cubes: +#' see \code{\link{plot.uncertainty_vector_cube}} #' \item classified cube: see \code{\link{plot.class_cube}} #' \item classified vector cube: see \code{\link{plot.class_vector_cube}} #' \item dendrogram cluster: see \code{\link{plot.sits_cluster}} @@ -343,7 +344,8 @@ plot.predicted <- function(x, y, ..., #' #' @note #' Use \code{scale} parameter for general output control. -#' The \code{dates} parameter indicates the date allows plotting of different dates when +#' The \code{dates} parameter indicates +#' the date allows plotting of different dates when #' a single band and three dates are provided, `sits` will plot a #' multi-temporal RGB image for a single band (useful in the case of #' SAR data). For RGB bands with multi-dates, multiple plots will be @@ -352,9 +354,9 @@ plot.predicted <- function(x, y, ..., #' @note The following optional parameters are available to allow for detailed #' control over the plot output: #' \itemize{ -#' \item \code{graticules_labels_size}: size of coordinates labels (default = 0.7) -#' \item \code{legend_title_size}: relative size of legend title (default = 0.7) -#' \item \code{legend_text_size}: relative size of legend text (default = 0.7) +#' \item \code{graticules_labels_size}: size of coord labels (default = 0.7) +#' \item \code{legend_title_size}: size of legend title (default = 0.7) +#' \item \code{legend_text_size}: size of legend text (default = 0.7) #' \item \code{legend_bg_color}: color of legend background (default = "white") #' \item \code{legend_bg_alpha}: legend opacity (default = 0.3) #' } @@ -395,15 +397,9 @@ plot.raster_cube <- function(x, ..., .check_cube_tiles(x, tile) # precondition for bands .check_bw_rgb_bands(band, red, green, blue) - .check_available_bands(x, band, red, green, blue) + check_band <- .check_available_bands(x, band, red, green, blue) # check roi .check_roi(roi) - if (.has(band)) { - # check palette - .check_palette(palette) - # check rev - .check_lgl_parameter(rev) - } # check scale parameter .check_num_parameter(scale, min = 0.2) # check quantiles @@ -437,8 +433,6 @@ plot.raster_cube <- function(x, ..., band = band, dates = dates, roi = roi, - palette = palette, - rev = rev, scale = scale, max_cog_size = max_cog_size, first_quantile = first_quantile, @@ -447,10 +441,6 @@ plot.raster_cube <- function(x, ..., ) return(p) } - # sits does not plot RGB for different dates - if (length(dates) > 1) { - warning(.conf("messages", ".plot_raster_cube_single_date")) - } # single date - either false color (one band) or RGB if (.has(band)) { p <- .plot_false_color( @@ -520,7 +510,8 @@ plot.raster_cube <- function(x, ..., #' #' @note #' Use \code{scale} parameter for general output control. -#' The \code{dates} parameter indicates the date allows plotting of different dates when +#' The \code{dates} parameter indicates the date +#' allows plotting of different dates when #' a single band and three dates are provided, `sits` will plot a #' multi-temporal RGB image for a single band (useful in the case of #' SAR data). For RGB bands with multi-dates, multiple plots will be @@ -529,7 +520,7 @@ plot.raster_cube <- function(x, ..., #' @note The following optional parameters are available to allow for detailed #' control over the plot output: #' \itemize{ -#' \item \code{graticules_labels_size}: size of coordinates labels (default = 0.7) +#' \item \code{graticules_labels_size}: size of coord labels (default = 0.7) #' \item \code{legend_title_size}: relative size of legend title (default = 0.7) #' \item \code{legend_text_size}: relative size of legend text (default = 0.7) #' \item \code{legend_bg_color}: color of legend background (default = "white") @@ -615,7 +606,7 @@ plot.sar_cube <- function(x, ..., #' @note The following optional parameters are available to allow for detailed #' control over the plot output: #' \itemize{ -#' \item \code{graticules_labels_size}: size of coordinates labels (default = 0.7) +#' \item \code{graticules_labels_size}: size of coord labels (default = 0.7) #' \item \code{legend_title_size}: relative size of legend title (default = 0.7) #' \item \code{legend_text_size}: relative size of legend text (default = 0.7) #' \item \code{legend_bg_color}: color of legend background (default = "white") @@ -738,7 +729,7 @@ plot.dem_cube <- function(x, ..., #' @note The following optional parameters are available to allow for detailed #' control over the plot output: #' \itemize{ -#' \item \code{graticules_labels_size}: size of coordinates labels (default = 0.7) +#' \item \code{graticules_labels_size}: size of coord labels (default = 0.7) #' \item \code{legend_title_size}: relative size of legend title (default = 0.7) #' \item \code{legend_text_size}: relative size of legend text (default = 0.7) #' \item \code{legend_bg_color}: color of legend background (default = "white") @@ -1169,7 +1160,7 @@ plot.variance_cube <- function(x, ..., #' @note The following optional parameters are available to allow for detailed #' control over the plot output: #' \itemize{ -#' \item \code{graticules_labels_size}: size of coordinates labels (default = 0.7) +#' \item \code{graticules_labels_size}: size of coord labels (default = 0.7) #' \item \code{legend_title_size}: relative size of legend title (default = 1.0) #' \item \code{legend_text_size}: relative size of legend text (default = 1.0) #' \item \code{legend_bg_color}: color of legend background (default = "white") @@ -1365,7 +1356,7 @@ plot.uncertainty_vector_cube <- function(x, ..., #' @note The following optional parameters are available to allow for detailed #' control over the plot output: #' \itemize{ -#' \item \code{graticules_labels_size}: size of coordinates labels (default = 0.8) +#' \item \code{graticules_labels_size}: size of coord labels (default = 0.8) #' \item \code{legend_title_size}: relative size of legend title (default = 1.0) #' \item \code{legend_text_size}: relative size of legend text (default = 1.0) #' \item \code{legend_bg_color}: color of legend background (default = "white") @@ -1772,7 +1763,10 @@ plot.som_evaluate_cluster <- function(x, y, ..., #' } #' @export #' -plot.som_map <- function(x, y, ..., type = "codes", legend = NULL, band = NULL) { +plot.som_map <- function(x, y, ..., + type = "codes", + legend = NULL, + band = NULL) { stopifnot(missing(y)) koh <- x if (!inherits(koh, "som_map")) { diff --git a/R/sits_regularize.R b/R/sits_regularize.R index 6f4b68438..9aeeea695 100644 --- a/R/sits_regularize.R +++ b/R/sits_regularize.R @@ -156,23 +156,14 @@ sits_regularize.raster_cube <- function(cube, ..., .check_num_parameter(multicores, min = 1, max = 2048) # check progress .check_progress(progress) - # Does cube contain cloud band? - if (!all(.cube_contains_cloud(cube)) && .check_warnings()) { - warning(.conf("messages", "sits_regularize_cloud"), - call. = FALSE, - immediate. = TRUE - ) - } + # Does cube contain cloud band? If not, issue a warning + .check_warnings_regularize_cloud(cube) if (.has(roi)) { crs <- NULL if (.roi_type(roi) == "bbox" && !.has(roi[["crs"]])) { crs <- .crs(cube) - if (length(crs) > 1 && .check_warnings()) { - warning(.conf("messages", "sits_regularize_crs"), - call. = FALSE, - immediate. = TRUE - ) - } + if (length(crs) > 1) + .check_warnings_regularize_crs() } roi <- .roi_as_sf(roi, default_crs = crs[[1]]) } @@ -191,12 +182,9 @@ sits_regularize.raster_cube <- function(cube, ..., msg = .conf("messages", "sits_regularize_roi") ) } - # Display warning message in case STAC cube - if (!.cube_is_local(cube) && .check_warnings()) { - warning(.conf("messages", "sits_regularize_local"), - call. = FALSE, immediate. = TRUE - ) - } + # Display warning message in case regularization is done via STAC + # We prefer to regularize local files + .check_warnings_regularize_local(cube) # Regularize .gc_regularize( cube = cube, diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R index 1ca3922ca..b70eb19d8 100644 --- a/R/sits_sample_functions.R +++ b/R/sits_sample_functions.R @@ -621,7 +621,7 @@ sits_stratified_sampling <- function(cube, # check samples by class samples_by_class <- unlist(sampling_design[, alloc]) .check_int_parameter(samples_by_class, is_named = TRUE, - msg = .conf("messages", "sits_stratified_sampling_samples") + msg = .conf("messages", "sits_stratified_sampling_samples") ) # check multicores .check_int_parameter(multicores, min = 1, max = 2048) @@ -661,7 +661,8 @@ sits_stratified_sampling <- function(cube, msg = .conf("messages", "sits_stratified_sampling_shp") ) sf::st_write(samples, shp_file, append = FALSE) - message(.conf("messages", "sits_stratified_sampling_shp_save"), shp_file) + message(.conf("messages", + "sits_stratified_sampling_shp_save"), shp_file) } return(samples) } diff --git a/R/sits_sf.R b/R/sits_sf.R index c419e2225..5def3a6f5 100644 --- a/R/sits_sf.R +++ b/R/sits_sf.R @@ -3,7 +3,7 @@ #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} #' -#' @description Return a sits_tibble or raster_cube as an sf object. +#' @description Converts a sits_tibble or raster_cube as an sf object. #' #' @param data A sits tibble or sits cube. #' @param as_crs Output coordinate reference system. diff --git a/R/sits_som.R b/R/sits_som.R index 23e358d45..11b9bee50 100644 --- a/R/sits_som.R +++ b/R/sits_som.R @@ -404,7 +404,7 @@ sits_som_evaluate_cluster <- function(som_map) { #' @param som_map A SOM map produced by the som_map() function #' @param som_eval An evaluation produced by the som_eval() function #' @param class_cluster Dominant class of a set of neurons -#' @param class_remove Class to be removed from the neurons of the "class_cluster" +#' @param class_remove Class to be removed from the neurons of "class_cluster" #' @return A new set of samples with the desired class neurons remove #' @examples #' if (sits_run_examples()) { @@ -413,26 +413,33 @@ sits_som_evaluate_cluster <- function(som_map) { #' # evaluate the som map and create clusters #' som_eval <- sits_som_evaluate_cluster(som_map) #' # clean the samples -#' new_samples <- sits_som_remove_samples(som_map, som_eval, "Pasture", "Cerrado") +#' new_samples <- sits_som_remove_samples(som_map, som_eval, +#' "Pasture", "Cerrado") #' } #' @export -sits_som_remove_samples <- function(som_map, som_eval, class_cluster, class_remove){ +sits_som_remove_samples <- function(som_map, + som_eval, + class_cluster, + class_remove){ # get the samples with id_neuron data <- som_map$data # get the samples by neurons neurons <- som_map$labelled_neurons - neurons_class_1 <- dplyr::filter(neurons, .data[["label_samples"]] == class_cluster - & .data[["prior_prob"]] > 0.50) + neurons_class_1 <- dplyr::filter(neurons, + .data[["label_samples"]] == class_cluster & + .data[["prior_prob"]] > 0.50) id_neurons_class_1 <- neurons_class_1[["id_neuron"]] # find samples of class2 in neurons of class1 - samples_remove <- dplyr::filter(data, .data[["label"]] == class_remove & - .data[["id_neuron"]] %in% id_neurons_class_1) + samples_remove <- dplyr::filter(data, + .data[["label"]] == class_remove & + .data[["id_neuron"]] %in% id_neurons_class_1) # get the id of the samples to be removed id_samples_remove <- samples_remove[["id_sample"]] # obtain the new samples - new_samples <- dplyr::filter(data, !(.data[["id_sample"]] %in% id_samples_remove)) + new_samples <- dplyr::filter(data, + !(.data[["id_sample"]] %in% id_samples_remove)) # return the new samples return(new_samples) } diff --git a/R/sits_timeline.R b/R/sits_timeline.R index 660546077..65520b4f0 100644 --- a/R/sits_timeline.R +++ b/R/sits_timeline.R @@ -44,11 +44,8 @@ sits_timeline.raster_cube <- function(data) { if (length(timeline_unique) == 1) { return(timeline_unique[[1]]) } else { - if (.check_warnings()) { - warning(.conf("messages", "sits_timeline_raster_cube"), - call. = FALSE - ) - } + # warning if there is more than one timeline + .check_warnings_timeline_cube() return(timelines_lst) } } diff --git a/R/sits_tuning.R b/R/sits_tuning.R index 53df60fc7..88d8fb736 100644 --- a/R/sits_tuning.R +++ b/R/sits_tuning.R @@ -51,7 +51,7 @@ #' \code{ml_method}. User can use \code{uniform}, \code{choice}, #' \code{randint}, \code{normal}, \code{lognormal}, \code{loguniform}, #' and \code{beta} distribution functions to randomize parameters. -#' @param trials Number of random trials to perform the random search. +#' @param trials Number of random trials to perform the search. #' @param progress Show progress bar? #' @param multicores Number of cores to process in parallel. #' @param gpu_memory Memory available in GPU in GB (default = 4) diff --git a/R/sits_view.R b/R/sits_view.R index ee37adc81..2bd234723 100644 --- a/R/sits_view.R +++ b/R/sits_view.R @@ -300,11 +300,10 @@ sits_view.raster_cube <- function(x, ..., # check logical control .check_lgl_parameter(add) # pre-condition for bands - # no band? take a default - if (!(.has(band) || (.has(red) && .has(green) && .has(blue)))) - band <- .cube_bands(x)[[1]] .check_bw_rgb_bands(band, red, green, blue) - .check_available_bands(x, band, red, green, blue) + # adjust band name for "RGB" if red, green, blue bands are defined + # else keep the name of B/W band + band <- .check_available_bands(x, band, red, green, blue) # retrieve dots dots <- list(...) # deal with wrong parameter "date" @@ -319,10 +318,6 @@ sits_view.raster_cube <- function(x, ..., # recover global leaflet info overlay_groups <- sits_env[["leaflet"]][["overlay_groups"]] leaf_map <- sits_env[["leaflet"]][["leaf_map"]] - - # adjust band name for RGB - if (.has(red) && .has(green) && .has(blue)) - band <- "RGB" # convert tiles names to tile objects cube <- dplyr::filter(x, .data[["tile"]] %in% tiles) # obtain dates vector diff --git a/demo/dl_comparison.R b/demo/dl_comparison.R index 9b8dda58b..ea6f573d2 100644 --- a/demo/dl_comparison.R +++ b/demo/dl_comparison.R @@ -39,4 +39,5 @@ acc_tc[["name"]] <- "TempCNN" results[[length(results) + 1]] <- acc_tc -sits_to_xlsx(results, file = file.path(tempdir(), "/accuracy_mato_grosso_dl.xlsx")) +sits_to_xlsx(results, file = file.path(tempdir(), + "/accuracy_mato_grosso_dl.xlsx")) diff --git a/inst/extdata/accuracy/sample_size_stratified_simple_random.xlsx b/inst/extdata/accuracy/sample_size_stratified_simple_random.xlsx deleted file mode 100644 index 0e587f1fbb729470a126653890ff069e05a65821..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 14251 zcmeIZg8_gT?y9cps<#!Sfl%lG7yujq03ZgqaA+0zK>z?j&;S4$01i@H#NN)u z)Xqg;#nZvmS(m}X)`ln#3X&=Z0Qp+~|BnB~Jy4M(YuC$!5`3HN6*{~cf!$hC7SSEp zIED%D1u#bL@2#bu65P7U3?ftwL(Q#|Oya!kyv;bj3QZq1wU)5>#3;&m76EF1Gx#7z z+*x#%X&z5ZZJ&flfKUsK-q-W2>(?6X|4!YTPE-NE!OMvDR?O zl@h%mzgwHU60H1YsYpWz_LaV2m0C<)6H?bYSDGec-OOnljw&2Re!bRP++=HeIigIa zY;7cpAF2bhT!T=f2JnK(W5#tdGH68G22{J6W{{zaLbs((RW?zEmZba+R|0U?qZ_3+ zuGvpK3G8vvs(Hw&j&3cE7d!=fbU~&cHFsAkEgPw-ldfSmuBENf}#k8j0`4kLM zi|&@jZ+ZbkNww77Nf3od5Qjv(s+MC#3Ah%4@-T0|u}=7N^`%UJ@Sk2q?&SptQ1~ys zZBS(*y?!l`c~wiqSH0DDGPQALWccIyfBO2rSV{k*=}`$&a(zso!83_=k=@55I|;bl z!ZsO+HewZmZn9IthUk1U!P}c4V4#%o>dei-lz{g7>As~3A)XPVTwg1dP%W#G_o9_Y zWwsh}juDBuCHfFf44$F-+PaOtM?q4$(c)uCU1TIqYtj>`5gWcdI^y|>Q(-)l;;5m; zOyau|)9*=pd?8%~3iQ15JyvkA-mqo-54`tvO>DCE9*q0GMyYa9f>~%hV{UsQW{9Oz zt0iBA$0R>tTxQI@9eE@%24+#L=*VBaG;%tUNQX~LY+mwiL^ul`9|tgGTa?~)O!96Q z2W`ok+!^)^Agk#At(GLfCY?aNS~me80DuF4gYd9n{D-2r+dEks+1p$HVc-6xG!U;w z?zQg!?xP}M%&MOWBz7D8>(fl9Ba5#>h@;tz(r4TBkNyrxoH9nRW4^m*)=JzX-Enqx z%sTKJ-eg}_{oE_>$fly}5$edGh1A;WY8wJ?xA*qnLcx9|Z=6gB48Xp*zn(u$)&iZQ zr5BmM)up3lBEHh5*2F!ELt9LY&K$jeBa+ma!goZvK=$79f#~@=@Pbv|kqYBZ#1kW5_q4(1`v*=s>2H4~VsW>3LUYx0g zot6+LWc6o_ID{s4pfS06`PrKSLor9}=7vjeKt_upC2_HoibRivaV(;RU(qr_UPTo_ z?u?xd@Ndv8p&a^4Prz8lU|P2K1^pAy1m7c&(XP{~&FaL<9V0(^T4f2eKEV8)t@|(} zoFel&0`;#Wfc}pWaJDdXGBr_lak8{Ccm6|(U6f?yA(_$J)9(oNZni%_Ld!%kw@HUV z$a`tR9n?MgQ>-;!H9$RG^Y`Q&9@VnWrFm9Q427!o5%5u4N7yV8n)nwrMzf@oXpftB z6oaTF<|J&9Fqhv_I(-XNiBDQQz{s{QluFeFL7rJ zSIr381%WL{O2wN&k%26m-yqlvPn6cwX`sugHP&;!;h5-tU_3Ua(WGhiO`J3YPHLO` zZn|z1mMIf6)#~QLw!tJ+&Mi?Z*1nUUl;6g+aH!tRwnI#jMSgSKT^c{VFj zQHl&Tbco&#s+GmvW^hx#VO2~`|6zE5sgnxMpwS>Atl>2JaeUS=4~NSLnNhYB`U-qr=nl z#u?5rbbbNK$w`F|#c5z5)&?t*J!AKM>|d^pfiI2Y-(Qvt_hcHmkHnp>D6_J?(1-oX zDA#aCx9h9^iJMPJ^Vdm?FCnj8e%GYL#Z-_aSDXQVo&?vh*v|`pBcWsWn=EVJH&8{k z<71aM@PF3>k4A;INw1PwjQhtL>CYL!#lqCql=08&pUpnel(%2yK<`3cawl@Jx20^v zg>{Wss!gwy#qGBXC9q6O(NNA4oR##&UD@%6=xa4hg=qW9WJ5a*+2)c>p&eQYe89Mo zkgCHTlb(gaU6>CQCGqol+1MdRb6nT1b#FZiT*cdM{^SEqtSWTe%Ta`gb zLWs36)rGQoGxA=x8-*xRB5!Y&Tz(-D+1b_6uv_f*L8&8%?C<~z*$fOAo~#8n;Yrg} zc$YBERUp6dM>aC#q)_Y>1d0{C`KR{Lg?WT^87$@oBU?k=ji*`H!@zTw2{3vOmATgO zqPDu5(*sQRH9jIP$5} zE4j}frT9W+I9KU|?EyadUwW~q!a{gk*&^X%=gTxA!M+R+fN8-HjOh3;lqP|`VcQHb z;(*M9cIo6(sX8+4WA7$6mlP4Dniv{saBxCl|&B;h) zHUIN-+YmX}HsFKUU7WaRp7t&rJ{Zo0HN=selGL#iqYp*d9QsXw8~kAw0{&(tmzinv z8^>sOb-{BgpkDTxy9s`fQIQ4w0j}XL;Fi-IpFs-ALFAG~!-F&OlheMDT0g#lkH%nI zr14NghbE*dE27lU%~~9%(J3n)EneJbs)B>Nq&U={r;0~QuCWh+()@})2*mJZq-9wO zNGanmBi$^aKBlD}f~wqX>fNziIcev-Lh)K9B;dxSf(TLfKc91FQR5}Y<86mwAbmtD zuaOz<(YX`Tk*5K>2x5QeV2-b|nXrX;z|8mv6zQOGeI!W#z@S9MO`q?H=By`r3buUT zuc#D)Kg~&JBoLd;y-Rv-_XgQyl%SXNp%s=glO z_wbFL3|S^-RT!yOp^iyB zZpn`*(!w6!(m)_Q9ike|Pf+TFiWqN%GXyvEF4^J*iwc0@s0>@}79rA>*1T80Mzc6@ zAMlK5L;I~_V}F8M2_|E3x!#eg8ccqDm+vaOSuws)T_7sdv}mX{C!Cq4JrQOWk=IAB zu9?1+G1jx&V#V}X8;u(m>KR3&1%Bw`1kNPS=lI&jwrj)vRLrf=K9s0uu3F?0+Rl#w%v ztJdrbI0P4tvo{nDDj`Eu5Y^IaGDeu)zKPXANRP^i%O>}|>6J3f@8PW+9u0qX7St%i zq7u))Ny$Y*VoeSKM6y%TzGwl*y%Z6WRPyU3Ydax&z}1ovZZ5jg6lmM!dG&~-D{eRJ z^o2e}Vc0=Cq-;j4j{ZH*+$uuZ%*hTrhBSd61CF_DZCUp)57-VPQjK8DhnS^>Gg7oO z^E4^6o2eyQK>L+M1V7Yh+7wTp%04G`5vfKPJ_#s`ol!bK*YYnAfVbQ<3<_8ae>&z0 zzfq-vFWtbJ=KQ<@F$1aI&V(cc?fz}QizxJ=Yl2Ips7 zgSy}9aNSh0E-5a&B(RyK)+lzE*ib|lnC@kNs{og4S0D3aOBO3!E8Z=<=ld#HvMV^WAog^eHK$=$_d>s{^Hup{c+QS-EA=(o`xD@ zYo5m0Z=1`B)CeMpCq%}0#+^wR0%qqkz7AJ!d^kQclgl#o6w?Ich7x?{_1|s6o0zTa zdNoo1(~R2=$yo6r006C;007cIjF_{Fr;X{K-qSZ7+t}^lx4#IeUwZ12V(a~xfl(n` z^y8eGmi6wla!Eey24)%Oh%9FI6pFtd`PM#`!{9bW=e`fMgT-~9SC&^*cTfG<`Lefm z`;}1ct8<@05ijb>o)(VoI*@Hkb8yFTa6 zE^fIBA<>%j!)nL&j^k^$a`mAm_w3$Ew9Qmm?0dJUz8{56tKu;o>$T#Yi>wdNt6BDK z0a+5wm+CCSK0IEl_V#MIT@A+WhhBD1J*J0Wx>_GEP=n$-t^n7*1}o(<90HuEXKm$F z--FZd(E6`?CkA!7hNy}=ERhokPTw1%oPAYoM&3@d^QU3BKBb5AL#DgI#g<|8Zr*tQ z@M!4G$vW+gd|N(^NJWvE6&hnWBgck8=t|k1V3r!m3h|7;Z`@~ zPv%fnY(6q=!Xb+d>M0`T5wX26Oqh_%Y8?6H9xfYLrPxvBe23=ZNGrEGpH{Wg%()H5 z(`~5^%lcu;HAjz#Z$Ev;s#V&@P+-&gLu6w_U{IH~zF|n_ z%Ey@P2a@HO?@kN#mI*SVM4-d7IJ`ZGrKiAw*tekrd5yTTt9Oas40UhzRqA}w{n26_ zvTfQ^{QeMJ*X&z|DX+sQL=l-MTw+Q;h=uaNmd()mq4l#|8>W@UoeSO7WtcBFrqx!L zn0ZDK{NM?K34?s3E=S~r zly6ZzRSgu3SBHlb)5CYq2pAge__JInXSlpQX3kJwtU=+t`QNWHW%=hoy#JyJwDxA# zRjUnmRTAgSN>iPRy_b4pJ!FbqsklE?zF47}hn;{#eYP8$gUf1Q=JkT}96r+gl z*R0=mBaOX8(0Nmbxx9f!@3;zZhcokfI;vXFktr#o@Ib>zosBamNt^&r)GiaIlkRY6 zinf+Gm#5-!+b8ayWCl_ofpnH0aBbGjrX*;Mp%S&?z%9s!nFXtiR zMg|sFL>B~SL>B}UyxuFKe{h>-(i%JApE?d5P4}d*AKuhFlRT& zN?}*pl8#x56I_fbZhXc)=`*h&Pg(fN*;rpB6rRjZZ(@tSQ}k`SJ)?Wp89o8n89Zic zm_)-MMJmZsP5JU37v$0RyAsFUj+|_|MeU=R}9X3G@hc zZwCtg}JNg`jP{wdq!U7nWFgr2D0+poU4CE9*9sKKWO} zh`M<*{JFzR=S*OS{rx%CcfamF@sr%_6WY_OLjA;K4JSa5YBcC8qkX~hYUS;@?HOa{ z@HVowqwN!2TfPR~#64;q=dY6%#(*>MDwP+>eiKzxrs_B$#m;-{axjP%3{nze@tB;k zSNj1gKkJi`PiXp}2$gg^*=2N_h1 z07d0w3Wt&d4cX207USUR6NI#lrI9cQohJ81i6-7yN>y)qwCoBoQC`Cm{_vLWi)5!* z4i?+aCX|1@idvzDDs@ORK3`=H0G5)E)XPVlpZX8YLtMha^Fw7;GvWKUnlnd2c_9f662NEQ~U^NqYl-1aGLI76jpu zbQNKg#e^arMLR1`HYggafeHV}EhrsfZhu=e8jQO1;sF-c^N52nM!f zdpTVzWRhq_Uz_{W5JpsU(It3PW*js~Whf;E&?NiZ7Jt>6J~wLjlCet8ET147S39;z zMuN_4SNXIJ^86<2GfmI9XJJzgYOG(-|BCzb(kl4F*oA0+YroT(mq$n3yoE-ZZNtVE z{TELsmNnJmqzc|bY#TlqlU!x?WU-1L{x(Z?&41yoHBgqqq4pC8zDy&i`7 z;S96r>g(kpB)6oJrxPp!7upig3}$s82AXm(>1R?7mc;Z?nkTp+MNOub(u&?#K?##I zg;^D~tq&dnqr%Ov{2yn6cET#+$!?npKcX8a&wHCXC~5{14rt&@4bmj5-YG_@nmH-! z1QQY`gH5+Xi|P;rB0PJO#?ihF_QwACS!C8S?DG(leo7^TjV;`*unCX}r&IyD9$G%$ z^&^ZDf?xQ#t<<1;{%2Y81}PYs1UUV94+)myhSnkwMPoK|<-f zejn3;M3TX#0?hPA4I(uM=X|$xZya{trx2ryPNLa90t>4^m`XG@qo>+ZO*CeU%&@nK zH0c5(VfUyuw=JRlI-??iqSPI!OyGnh)CUPgC(iyK2x zhVuKc$}XxYuwITX%%H}^fj89A zkQ-3~K}2a#;3t(qhuDu+SY|ClMaNXk`j>0(^FYJ{KC{QG3w8aAYe1M553cvwz|?&# zYscL$_g|fSfz%yG?{7a~JHP$oO|q?tzg`p%yTp5acMmQCzXspk$*ULsiJ`e6%CY9O ztAj*b=O0maMfvwT6T>>=goKrr8$TF-!7eNp4Z1IF-bTrOy5Ar4pfopF|H*4Zk5@QY zwAqDqV8+e$8h~#~g}|-8HWR;cyDu6;{`+t#+uGGByK5mpfBh!o`$0);?g(#a+lMD9CZR7Dfbr`~Hs*vSE+fY6pHyr?kq;DR; zpU8dZeC7^hrW~&JZ=Gh^WFuL|)Pd1IiWa2R6Meo^R>7|9iTV7n?5LAcn=^^8o(;I6 zq;GiN*Y(2PIu@zF$17V-z*I3Bz)@Z1y1_I$!mCSBm{mQ85jB2cl%@i%Z{`?vji*pP zpLQ}-m~)9TO{ioWnPw#Di=Q%ECX2opnPAaXO(>ASl7xOpy|mF?uo)XM{*fYier)E; zIg)Cf(>#i)dHo^Is$;LfZHa@PvN?S(>(rL<)rmj1z%gZhFcTa|nIozjeLx^Lfm ze@hRxiEhZ#8@>2Rn3b@r55%?X#vWw6SM1VfqYJls$vTEIG&mCEem_m;_S4D?(Et)Fk_iK({ zbf;)PFTqec=wB84<$cW%L@}_+L>QpFhosu{vrjv>fuyA9Dy&=n`URQo=;&L0_)mY{ zf_cJI&A3*nF`7xvwuSWXNvfSs6npTC4O{sU$oyyMg!8&a597XX@ReP_r9a@tUrb(u zI>2mpqIC>?5Y@`?XWe*JU}&wcErMN?(bFy`Sf+WgPyv({f!6?S=B0JB{gSO7S z<;EQ*+&!I=q5z-F@UK~vV%+m48)z%f%!E^-u%r}l15jH#lwqf7f(gA@{jT3D#*Lsc z5(9r~luoiH`75T_xAX@iWwz)w5v-4TzIWsr?1qO~H{9fd;WyYs2NE)a;epxAU}&H@ zHs??`GzF-(*gAGL3QF^JK>IXxqE`>+|a_0yy9jRcKT14DX7RIY4 z>86}~r1;G4IgBSUon4UYP0(C7kLBtO!x>$yvCuD(*~|=~wb>}_pKY+L`mRdld0|t< z+ZBVc2piH4J%dmhfIGqov*~bz#+y*UGbS(rkdVnCA|Mv~E+}9M`z|nm6_jDT2?FnLu4v;s6DCs`G> znCJNER_uT8+9!<+Pb$YUU13Iv%!Fb@)Z48A32I;Y9F)MJM)Ks~#N$Gz+?0m2XIX}4 ze-jZC@N{==1mqeKOfVgkYd~y%Xz0PJhTZsyyt^6vkr*8`!2R+{i!g(N;kaD(GEW+Qw2+{YapDsHv z-heo(!=L>*YgAbFy^CaLC{P#V&&5A}Fcy{YqZ2h?^snqvZgi{?4LtVr?KVG z(E(BAOrAVdqHLIzN~a5i0%8KhRY%in;k2DdTem{(ris$E(Qn3caWH?i;BRl0@bTiF zo(*`fZ|MmxZ4vO^9~lU&Ep`29aNMxEQxYa z0iF9s@$!^6t~STFxH!HilSmsE9;+pp=!mx3Ae{I?_Dsde!v*m=xgmlIoduKPKtYiq zBJ35A0ipRfV7Krd2Z1tY6o#=cf||Sv3mpMYC8wMz$0(_aLwT6oTQP)L7$Lbes{5Z- zo6OhnC7O?Ja-Q8~_M68Ciw3P`hX&5KVuYy{V|MD_@C8Ckm8^kLzV$;l#DN$K)aQ0e z*1kMS(u>xNZ92Z|c*LZsRqazw$rphTwCqWTj9pZ7M|~IdD1q0~qqs3kpDw7YH1=sH zJlf5sB?aj#*1dkGXuSLP<6Uk(*@$Bs)f>!1kQTIZXi8I@y=?z2jXol}k4v&TI3fQR zduWpp^%b4Nhumv3PrZ48oD8lrPp!2I?_-lp%!B1F@F)~_QTy=be5A)u_UQ#rMGQ%` z9-n6$?&*lc(jP%l`{Zk2fxnGU(SQ63q41hw@_9}2y?ss9o7fvGIN3WmGaB1Fnf?=o z_J0}r*RD%S_#@$rE_y5RB(jSkK_;i9rI1vBnp0IGm=`uQS!X{Nc1OG#cXQ^L1(l2> z?Y&PhrNgCr>bd6|z)^_)E+P=clc>a`kc#E1UGsi%m^B4XoQ9f61eVDnEjz0~g@mlqHGaXLr+X(11nh^FJ=jnj=v3M*1h}LKhyDk&!Xa( zyTsfUlq%3$ef(J5Sf(FgrjD+V#qvb~sb4CyS_&e#Vk!7`p9OI{vyx!pfI3U#i>q4y zQp4&~Bb1x-u=g1gF9;uZP1&~ol+Pe*?2F3;%$}*6cavr=@0A>mFRL$}GEx_-3qZ9-E>vpWS1F?SqXn@W%>7B|4`k1Y0qR|M*!L ztANhExG2Ya5>_GVQNKze)5`Gzw(Lk*7$KH6d!soGea>L|4S`wOB^&r(uPcc!k zhlrXB$fffycQ;S%S9iYhNmNG$or^F&R3~SE}rCqE9Sh^V*2De9IE664R@fJN! zBPoDF#oL@abMpJUV!!VrXXDFfr)N+5ZRP^?-uu%4Bs|D$AU_HKa})Bd!@L%&k_(gSBVQD!GuZ##NFia^D>4gP{l<- z^0>sQ;G3cYYpcQi@UQe0e|XLS3g)pAv(Q37w#{5V6NQazJ3@dDE(SW~BTZ4pSO+*05Gw}sgn`X^K**5U zoES>??6R=L`)znQUYLFuY+(xkkst^&lVnT8f2ydy*@Zy_ASRi&gaSN4i~L%>-M0%R_wBYU=jkR`SzS1*@9-1r$AVXn6mY7SF7CafcnwFUqE$Es7#B zOos;H2U$9cYFMf;?8tEw0pefv98({&rsQdjJ>BbRqHRb+e$2)%1cmab(L*W z?+F~s}H-UGgtsL`b_&xhcnC#vwW`CE}N$-4)`>_X!R?$dZqT=UPU9j4>5o5Wve)Zm5U~= z9+QI8e_FDt*>z-&z@goVSr|gp;rUT6Epswy=d4iTg+p7J?#nw)X(V&RJ>RhEWe)TM~VeZ|#fqKEQp3@$)?6?cQb3 z;Pkh+iT6}{+hFFWa~r%Dr@21Pa~4jP`IVhwmoY*+K7@5K(S{0A-W&BP)!{;_|!Iu#u+Z#rF{MxU1O*gmRv0j@YSaEBYU zdo@uHY#b$hpS)ebo!T>`A3*c^eE>iG1$qH%)-PWIP2imeWjbL9!6MQhZh-ewn{FEsd;z8H+waM`~>={3M zI4lTXV#EKWfjN0n636mm=Io1}hxOGZ2AaaLs8n>@W7E!AGTLe zf1STDAzS_K4Qn^`M4h;v(h-#o^+Q2&7y ztMX1gJP}h|;gPP@Slq?tvFJIC)KfY(T)yIL)r3v6;?A_B$zg}?Vmtmkjg45Zg{qH% z16rlB)#ccJt0-GkUhvNo;IIF;zQxLLr%>!`3Dzqb73Du&Ttf$k|MPHPy@-Dv83{u6 zt4yHaGvEy&XbqQ3ml+gLk!SJ#s>To^!EH!5`B0;T4xYrC?D0C^w!m>A(~XocyjWgd zY4LFqi_gS`S;eS@N(`cBa3xrmoS<=op)(9}BxvOhI|mh3(6LhBqrx#Bnu(J?v^G?Q zsC1H=Ql4!tYxAb#rX-rPdDv=uVy$IHaGQlb4;&fe*hPI1pHN9|r-Xfok(18#RacSg zS0Ew39ddX;L#yNnk9C-RsUK%L>0n4iwKt;P$h`vd8qA5co6B@z!ljyR#ks@SU@J3$ z&`4s=X%8s3GJ32;Rlb~nZa^pJaiUf?Vtbhg#F_j<){O$i7|B|hb%CGQ^qF=a%LW22 zc{f-RZ|wfG-A&z#i^0LMlM`Eph?n!jckT;+f%JxvE9C9H3=fmf9+Y@&x))$Jozw6% zuBAbtiD#+<_f2EWDDYzLhOS3X=+|iXkWK8PmJ*K25rs=0yaP(1HRr5lWQwLrc%G72 zo-^1!ERT#|EqZ$Nqw?fkr!vYHSNYe3ufy>V903F*{VVYD@3##7Yta66|C#x4(|2Me%cRs&EdjH}?@(KX_4dDAb@$YEV zzlaN7;T5mM{{x%)JBQy9m49&{0sZ^)|9|+(-x>Z6Q2dJ_*(=oJ^_PB!EB?;lcW}sG z3=UrbkAJl3-%yd?Nq>*`|3#`u@OxwaivIu3<-b?|fAIhS!YKfN{}BuLo&5Jz+g}V& zsQ>(l|60TSPW}60<}d2^G=Eb6wv_qXrOoe5|9i6kizNVH!~7pD`sdWIAPxO0!G9og PkN_sHO2Ewa$J74Ct diff --git a/inst/extdata/cran/check_package_cran.R b/inst/extdata/cran/check_package_cran.R index 8af7acf16..b300e1858 100644 --- a/inst/extdata/cran/check_package_cran.R +++ b/inst/extdata/cran/check_package_cran.R @@ -39,7 +39,8 @@ usethis::use_build_ignore("revdep/") devtools::revdep() library(revdepcheck) # In another session -id <- rstudioapi::terminalExecute("Rscript -e 'revdepcheck::revdep_check(num_workers = 4)'") +id <- rstudioapi::terminalExecute + ("Rscript -e 'revdepcheck::revdep_check(num_workers = 4)'") rstudioapi::terminalKill(id) # See outputs revdep_details(revdep = "pkg") diff --git a/inst/extdata/cran/pkg_size_functions.R b/inst/extdata/cran/pkg_size_functions.R index 6ce622ed5..3e99b5980 100644 --- a/inst/extdata/cran/pkg_size_functions.R +++ b/inst/extdata/cran/pkg_size_functions.R @@ -13,7 +13,8 @@ pkg_size <- function(pkg) { } pkg_size_recursive <- function(pkg) { - deps <- c(pkg, unlist(tools::package_dependencies(pkg, which = "all", recursive = TRUE))) + deps <- c(pkg, unlist(tools::package_dependencies(pkg, which = "all", + recursive = TRUE))) size <- pkg_size(deps) total_size <- sum(size) diff --git a/inst/extdata/cran/sits_codecov.R b/inst/extdata/cran/sits_codecov.R index bad4ef414..a9813a846 100644 --- a/inst/extdata/cran/sits_codecov.R +++ b/inst/extdata/cran/sits_codecov.R @@ -1,2 +1,3 @@ -withr::with_envvar(new = c("SITS_RUN_TESTS" = "YES"), covr::codecov(token = "53fbd031-6dab-40a4-98a5-84885b45531e")) +withr::with_envvar(new = c("SITS_RUN_TESTS" = "YES"), + covr::codecov(token = "53fbd031-6dab-40a4-98a5-84885b45531e")) diff --git a/inst/extdata/scripts/bayes_smooth.R b/inst/extdata/scripts/bayes_smooth.R deleted file mode 100644 index 16377aea1..000000000 --- a/inst/extdata/scripts/bayes_smooth.R +++ /dev/null @@ -1,19 +0,0 @@ -samples <- "~/Downloads/Amostras_Valida_Bayes_0711.gpkg" -samples.sf <- sf::st_read(samples) -samples.sf - -# Create factor vectors for caret -unique_ref <- unique(samples.sf$label) -pred_fac <- factor(pred, levels = unique_ref) - -ref_fac <- factor(samples.sf$label, levels = unique_ref) -no_smooth_fac <- factor(samples.sf[["no_smooth"]], levels = unique_ref) -bayes_fac <- factor(samples.sf$bayes, levels = unique_ref) -gauss_fac <- factor(samples.sf$gauss, levels = unique_ref) -# Call caret package to the classification statistics - -acc_bayes <- caret::confusionMatrix(bayes_fac, ref_fac) -acc_gauss <- caret::confusionMatrix(gauss_fac, ref_fac) -acc_no_smooth <- caret::confusionMatrix(no_smooth_fac, ref_fac) - - diff --git a/inst/extdata/scripts/plot_som_clean_samples.R b/inst/extdata/scripts/plot_som_clean_samples.R deleted file mode 100644 index e692574f1..000000000 --- a/inst/extdata/scripts/plot_som_clean_samples.R +++ /dev/null @@ -1,65 +0,0 @@ -library(sits) - -som_map <- sits_som_map(samples_modis_ndvi) -# evaluate the SOM cluster -som_clusters <- sits_som_evaluate_cluster(som_map) -plot(som_clusters) - -eval <- sits_som_clean_samples( - som_map = som_map, - prior_threshold = 0.5, - posterior_threshold = 0.5, - keep = c("clean", "analyze", "remove") -) - -plot_eval <- function(eval){ - eval <- eval |> - dplyr::group_by(label, eval) |> - dplyr::summarise(n = dplyr::n()) |> - dplyr::mutate(n_class = sum(n)) |> - dplyr::ungroup() |> - dplyr::mutate(percentage = (n/n_class)*100) |> - dplyr::select(label, eval, percentage) |> - tidyr::pivot_wider(names_from = eval, values_from = percentage) |> - dplyr::select(label, clean, remove, analyze) |> - tidyr::replace_na(list(clean = 0, remove = 0, analyze = 0)) - - - pivot <- tidyr::pivot_longer(eval, cols = c(clean, remove, analyze), - names_to = "Eval", values_to = "value") - labels <- unique(pivot[["label"]]) - pivot$label <- factor(pivot$label, levels = labels) - - colores_eval <- c("gold", "#009ACD", "red2") - - # Stacked bar graphs for Noise Detection - g <- ggplot2::ggplot(pivot, ggplot2::aes(x = value, - y = factor(label, levels = rev(levels(label))), - fill = Eval)) + - ggplot2::geom_bar(stat = "identity", color = "white", width = 0.9) + - ggplot2::geom_text(ggplot2::aes(label = scales::percent(value/100, 1)), - position = ggplot2::position_stack(vjust = 0.5), - color = "black", size = 3,fontface = "bold", - check_overlap = TRUE) + - ggplot2::theme_classic() + - ggplot2::theme(axis.title.y = ggplot2::element_blank(), - legend.title = ggplot2::element_text(size = 11), - legend.text = ggplot2::element_text(size = 9), - legend.key.size = ggplot2::unit(0.5, "cm"), - legend.spacing.y = ggplot2::unit(0.5, "cm"), - legend.position = "right", - legend.justification = "center") + - ggplot2::xlab("%") + - ggplot2::scale_fill_manual(values = colores_eval, - name = "Evaluation") + - ggplot2::ggtitle("Class noise detection") - - return(g) -} - -ggsave( - filename = "Paper_Quality/Images/som_noise_detection.png", - plot = last_plot(), - scale = 1.1, - width = 8, - height = 4) diff --git a/inst/extdata/tmap/api_tmap_v3.R b/inst/extdata/tmap/api_tmap_v3.R deleted file mode 100644 index 0f9d08013..000000000 --- a/inst/extdata/tmap/api_tmap_v3.R +++ /dev/null @@ -1,274 +0,0 @@ -#' @export -.tmap_false_color.tmap_v3 <- function(rast, - band, - sf_seg, - seg_color, - line_width, - palette, - rev, - scale, - tmap_params){ - if (rev || palette == "Greys") - cols4all_name <- paste0("-", palette) - - # generate plot - p <- tmap::tm_shape(rast) + - tmap::tm_raster( - palette = palette, - title = band, - midpoint = NA, - style = "cont", - style.args = list(na.rm = TRUE) - ) + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_compass() + - tmap::tm_layout( - legend.bg.color = tmap_params[["legend_bg_color"]], - legend.bg.alpha = tmap_params[["legend_bg_alpha"]], - legend.title.size = tmap_params[["legend_title_size"]], - legend.text.size = tmap_params[["legend_text_size"]], - scale = scale - ) - # include segments - if (.has(sf_seg)) { - p <- p + tmap::tm_shape(sf_seg) + - tmap::tm_borders(col = seg_color, lwd = line_width) - } - return(p) -} -# -#' @export -.tmap_dem_map.tmap_v3 <- function(r, band, - palette, rev, - scale, tmap_params){ - # reverse the color palette? - if (rev || palette == "Greys") - cols4all_name <- paste0("-", palette) - # generate plot - p <- tmap::tm_shape(r, raster.downsample = FALSE) + - tmap::tm_raster( - palette = palette, - title = band, - midpoint = NA, - style = "cont", - style.args = list(na.rm = TRUE) - ) + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_compass() + - tmap::tm_layout( - legend.bg.color = tmap_params[["legend_bg_color"]], - legend.bg.alpha = tmap_params[["legend_bg_alpha"]], - legend.title.size = tmap_params[["legend_title_size"]], - legend.text.size = tmap_params[["legend_text_size"]], - scale = scale - ) - return(p) -} -#' @export -.tmap_rgb_color.tmap_v3 <- function(red_file, - green_file, - blue_file, - scale, - max_value, - first_quantile, - last_quantile, - tmap_params, - sf_seg, - seg_color, - line_width, - sizes) { - - # open red, green and blue file as a stars object - rgb_st <- stars::read_stars( - c(red_file, green_file, blue_file), - along = "band", - RasterIO = list( - nBufXSize = sizes[["xsize"]], - nBufYSize = sizes[["ysize"]] - ), - proxy = FALSE - ) - - # open RGB stars - rgb_st <- stars::st_rgb(rgb_st[, , , 1:3], - dimension = "band", - maxColorValue = max_value, - use_alpha = FALSE, - probs = c(first_quantile, last_quantile), - stretch = TRUE - ) - # tmap params - labels_size <- tmap_params[["graticules_labels_size"]] - - p <- tmap::tm_shape(rgb_st, raster.downsample = FALSE) + - tmap::tm_raster() + - tmap::tm_graticules( - labels.size = labels_size - ) + - tmap::tm_layout( - scale = scale - ) + - tmap::tm_compass() - - # include segments - if (.has(sf_seg)) { - p <- p + tmap::tm_shape(sf_seg) + - tmap::tm_borders(col = seg_color, lwd = line_width) - } - - return(p) -} -#' @export -#' -.tmap_probs_map.tmap_v3 <- function(probs_rast, - labels, - labels_plot, - palette, - rev, - scale, - tmap_params){ - # reverse the color palette? - if (rev || palette == "Greys") - cols4all_name <- paste0("-", palette) - - # select stars bands to be plotted - bds <- as.numeric(names(labels[labels %in% labels_plot])) - - p <- tmap::tm_shape(probs_rast[[bds]]) + - tmap::tm_raster( - style = "cont", - palette = palette, - midpoint = NA, - title = labels[labels %in% labels_plot] - ) + - tmap::tm_facets(sync = FALSE) + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_compass() + - tmap::tm_layout( - legend.show = TRUE, - legend.outside = FALSE, - legend.bg.color = tmap_params[["legend_bg_color"]], - legend.bg.alpha = tmap_params[["legend_bg_alpha"]], - legend.title.size = tmap_params[["legend_title_size"]], - legend.text.size = tmap_params[["legend_text_size"]], - scale = scale - ) - return(p) -} -#' @export -.tmap_class_map.tmap_v3 <- function(st, colors, scale, tmap_params) { - - # plot using tmap - p <- tmap::tm_shape(st, raster.downsample = FALSE) + - tmap::tm_raster( - style = "cat", - labels = colors[["label"]], - palette = colors[["color"]] - ) + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]], - ndiscr = 50 - ) + - tmap::tm_compass() + - tmap::tm_layout( - legend.bg.color = tmap_params[["legend_bg_color"]], - legend.bg.alpha = tmap_params[["legend_bg_alpha"]], - legend.title.size = tmap_params[["legend_title_size"]], - legend.text.size = tmap_params[["legend_text_size"]], - scale = scale - ) - return(p) -} -#' @export -.tmap_vector_probs.tmap_v3 <- function(sf_seg, palette, rev, - labels, labels_plot, - scale, tmap_params){ - if (rev || palette == "Greys") - cols4all_name <- paste0("-", palette) - - # plot the segments - p <- tmap::tm_shape(sf_seg) + - tmap::tm_fill( - labels_plot, - style = "cont", - palette = palette, - midpoint = NA, - title = labels[labels %in% labels_plot]) + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_compass() + - tmap::tm_layout( - legend.show = TRUE, - legend.bg.color = tmap_params[["legend_bg_color"]], - legend.bg.alpha = tmap_params[["legend_bg_alpha"]], - legend.title.size = tmap_params[["legend_title_size"]], - legend.text.size = tmap_params[["legend_text_size"]], - legend.position = tmap_params[["legend_position"]], - scale = scale - ) + - tmap::tm_borders(lwd = 0.1) - - return(p) -} -# -#' @export -.tmap_vector_class.tmap_v3 <- function(sf_seg, - colors, - scale, - tmap_params){ - # plot the data using tmap - p <- tmap::tm_shape(sf_seg) + - tmap::tm_fill( - col = "class", - palette = colors - ) + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_compass() + - tmap::tm_layout( - legend.bg.color = tmap_params[["legend_bg_color"]], - legend.bg.alpha = tmap_params[["legend_bg_alpha"]], - legend.title.size = tmap_params[["legend_title_size"]], - legend.text.size = tmap_params[["legend_text_size"]], - legend.position = tmap_params[["legend_position"]], - scale = scale - ) + - tmap::tm_borders(lwd = 0.2) - - return(p) -} -.tmap_vector_uncert.tmap_v3 <- function(sf_seg, palette, rev, - type, scale, tmap_params){ - # revert the palette - if (rev) { - palette <- paste0("-", palette) - } - # plot - p <- tmap::tm_shape(sf_seg) + - tmap::tm_fill( - col = type, - palette = palette - ) + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_compass() + - tmap::tm_layout( - legend.bg.color = tmap_params[["legend_bg_color"]], - legend.bg.alpha = tmap_params[["legend_bg_alpha"]], - legend.title.size = tmap_params[["legend_title_size"]], - legend.text.size = tmap_params[["legend_text_size"]], - scale = scale - ) + - tmap::tm_borders(lwd = 0.2) - - return(suppressWarnings(p)) -} diff --git a/inst/extdata/tmap/api_tmap_v4.R b/inst/extdata/tmap/api_tmap_v4.R deleted file mode 100644 index 7bb0ff056..000000000 --- a/inst/extdata/tmap/api_tmap_v4.R +++ /dev/null @@ -1,352 +0,0 @@ -#' @export -.tmap_false_color.tmap_v4 <- function(rast, - band, - sf_seg, - seg_color, - line_width, - palette, - rev, - scale, - tmap_params){ - - # recover palette name used by cols4all - cols4all_name <- .colors_cols4all_name(palette) - # reverse order of colors? - if (rev) - cols4all_name <- paste0("-", cols4all_name) - legend_position <- tmap_params[["legend_position"]] - if (legend_position == "outside") - position <- tmap::tm_pos_out() - else - position <- tmap::tm_pos_in("left", "bottom") - - p <- tmap::tm_shape(rast) + - tmap::tm_raster( - col.scale = tmap::tm_scale_continuous( - values = cols4all_name, - midpoint = NA), - col.legend = tmap::tm_legend( - title = band, - title.size = tmap_params[["legend_title_size"]], - text.size = tmap_params[["legend_text_size"]], - bg.color = tmap_params[["legend_bg_color"]], - bg.alpha = tmap_params[["legend_bg_alpha"]], - position = position, - frame = TRUE - ) - ) + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_compass() + - tmap::tm_layout( - scale = scale - ) - # include segments - if (.has(sf_seg)) { - p <- p + tmap::tm_shape(sf_seg) + - tmap::tm_borders(col = seg_color, lwd = line_width) - } - - return(p) -} -#' @export -#' -.tmap_dem_map.tmap_v4 <- function(r, band, - palette, rev, - scale, tmap_params){ - cols4all_name <- .colors_cols4all_name(palette) - # reverse order of colors? - if (rev) - cols4all_name <- paste0("-", cols4all_name) - # position - legend_position <- tmap_params[["legend_position"]] - if (legend_position == "outside") - position <- tmap::tm_pos_out() - else - position <- tmap::tm_pos_in("left", "bottom") - # generate plot - p <- tmap::tm_shape(r, raster.downsample = FALSE) + - tmap::tm_raster( - col.scale = tmap::tm_scale_continuous( - values = cols4all_name, - midpoint = NA - ), - col.legend = tmap::tm_legend( - title = band, - position = position, - frame = TRUE, - bg.color = tmap_params[["legend_bg_color"]], - bg.alpha = tmap_params[["legend_bg_alpha"]], - title.size = tmap_params[["legend_title_size"]], - text.size = tmap_params[["legend_text_size"]] - ) - ) + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_compass() + - tmap::tm_layout( - scale = scale - ) - return(p) -} -#' @export -.tmap_rgb_color.tmap_v4 <- function(red_file, - green_file, - blue_file, - scale, - max_value, - first_quantile, - last_quantile, - tmap_params, - sf_seg, - seg_color, - line_width, - sizes) { - - # open RGB file - rast <- .raster_open_rast(c(red_file, green_file, blue_file)) - names(rast) <- c("red", "green", "blue") - - p <- tmap::tm_shape(rast, raster.downsample = FALSE) + - tmap::tm_rgb( - col = tmap::tm_vars(n = 3, multivariate = TRUE), - col.scale = tmap::tm_scale_rgb( - value.na = NA, - stretch = TRUE, - probs = c(first_quantile, last_quantile), - max_color_value = max_value - ) - ) + - tmap::tm_graticules( - labels_size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_layout( - scale = scale - ) + - tmap::tm_compass() - - # include segments - if (.has(sf_seg)) { - p <- p + tmap::tm_shape(sf_seg) + - tmap::tm_borders(col = seg_color, lwd = line_width) - } - return(p) -} -# -#' @export -#' -.tmap_probs_map.tmap_v4 <- function(probs_rast, - labels, - labels_plot, - palette, - rev, - scale, - tmap_params){ - - # recover palette name used by cols4all - cols4all_name <- .colors_cols4all_name(palette) - # reverse order of colors? - if (rev) - cols4all_name <- paste0("-", cols4all_name) - - # select stars bands to be plotted - bds <- as.numeric(names(labels[labels %in% labels_plot])) - - # by default legend position for probs maps is outside - legend_position <- tmap_params[["legend_position"]] - if (legend_position == "inside") { - cols_free <- TRUE - position <- tmap::tm_pos_in() - } else { - cols_free <- FALSE - position <- tmap::tm_pos_out(pos.h = "right", pos.v = "top") - } - - p <- tmap::tm_shape(probs_rast[[bds]]) + - tmap::tm_raster( - col.scale = tmap::tm_scale_continuous( - values = cols4all_name, - midpoint = NA), - col.free = cols_free, - col.legend = tmap::tm_legend( - title = tmap_params[["legend_title"]], - show = TRUE, - frame = TRUE, - position = position, - title.size = tmap_params[["legend_title_size"]], - text.size = tmap_params[["legend_text_size"]], - bg.color = tmap_params[["legend_bg_color"]], - bg.alpha = tmap_params[["legend_bg_alpha"]], - ) - ) + - tmap::tm_facets() + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_layout( - scale = scale - ) -} -#' @export -.tmap_vector_probs.tmap_v4 <- function(sf_seg, palette, rev, - labels, labels_plot, - scale, tmap_params){ - - cols4all_name <- .colors_cols4all_name(palette) - # reverse order of colors? - if (rev) - cols4all_name <- paste0("-", cols4all_name) - # position - legend_position <- tmap_params[["legend_position"]] - if (legend_position == "outside") - position <- tmap::tm_pos_out() - else - position <- tmap::tm_pos_in("left", "bottom") - - # plot the segments - p <- tmap::tm_shape(sf_seg) + - tmap::tm_polygons( - fill = labels_plot, - fill.scale = tmap::tm_scale_continuous( - values = cols4all_name, - midpoint = NA), - fill.legend = tmap::tm_legend( - frame = TRUE, - position = position, - title.size = tmap_params[["legend_title_size"]], - text.size = tmap_params[["legend_text_size"]], - bg.color = tmap_params[["legend_bg_color"]], - bg.alpha = tmap_params[["legend_bg_alpha"]] - ) - ) + - tmap::tm_facets() + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_compass() + - tmap::tm_layout( - scale = scale - ) - return(p) -} -#' @export -.tmap_class_map.tmap_v4 <- function(st, colors, scale, tmap_params) { - - # position - legend_position <- tmap_params[["legend_position"]] - if (legend_position == "outside") - position <- tmap::tm_pos_out() - else - position <- tmap::tm_pos_in("left", "bottom") - - # plot using tmap - p <- tmap::tm_shape(st, raster.downsample = FALSE) + - tmap::tm_raster( - col.scale = tmap::tm_scale_categorical( - values = colors[["color"]], - labels = colors[["label"]] - ), - col.legend = tmap::tm_legend( - position = position, - frame = TRUE, - text.size = tmap_params[["legend_text_size"]], - bg.color = tmap_params[["legend_bg_color"]], - bg.alpha = tmap_params[["legend_bg_alpha"]] - ) - ) + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]], - ndiscr = 50 - ) + - tmap::tm_compass() + - tmap::tm_layout( - scale = scale - ) - return(p) -} -#' @export -.tmap_vector_class.tmap_v4 <- function(sf_seg, - colors, - scale, - tmap_params){ - - # position - legend_position <- tmap_params[["legend_position"]] - if (legend_position == "outside") - position <- tmap::tm_pos_out() - else - position <- tmap::tm_pos_in("left", "bottom") - # sort the color vector - colors <- colors[sort(names(colors))] - # plot the data using tmap - p <- tmap::tm_shape(sf_seg) + - tmap::tm_polygons( - fill = "class", - fill.scale = tmap::tm_scale_categorical( - values = unname(colors), - labels = names(colors) - ), - fill.legend = tmap::tm_legend( - frame = TRUE, - title = "class", - title.size = tmap_params[["legend_title_size"]], - text.size = tmap_params[["legend_text_size"]], - position = position, - bg.color = tmap_params[["legend_bg_color"]], - bg.alpha = tmap_params[["legend_bg_alpha"]] - ) - ) + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_compass() + - tmap::tm_layout( - scale = scale - ) + - tmap::tm_borders(lwd = 0.2) - - return(p) -} -#' @export -.tmap_vector_uncert.tmap_v4 <- function(sf_seg, palette, rev, - type, scale, tmap_params){ - # recover palette name used by cols4all - cols4all_name <- .colors_cols4all_name(palette) - # reverse order of colors? - if (rev) - cols4all_name <- paste0("-", cols4all_name) - - # position - legend_position <- tmap_params[["legend_position"]] - if (legend_position == "outside") - position <- tmap::tm_pos_out() - else - position <- tmap::tm_pos_in("left", "bottom") - - # plot - p <- tmap::tm_shape(sf_seg) + - tmap::tm_polygons( - col.scale = tmap::tm_scale_continuous( - values = cols4all_name, - midpoint = NA), - col.legend = tmap::tm_legend( - title = type, - position = position, - frame = TRUE, - bg.color = tmap_params[["legend_bg_color"]], - bg.alpha = tmap_params[["legend_bg_alpha"]], - title.size = tmap_params[["legend_title_size"]], - text.size = tmap_params[["legend_text_size"]] - ) - ) + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_compass() + - tmap::tm_layout( - scale = scale - ) + - tmap::tm_borders(lwd = 0.2) -} diff --git a/inst/extdata/torch/download_new_torch.R b/inst/extdata/torch/download_new_torch.R deleted file mode 100644 index a10cabc0a..000000000 --- a/inst/extdata/torch/download_new_torch.R +++ /dev/null @@ -1,8 +0,0 @@ -options(timeout = 600) -kind <- "cpu-intel" -version <- "0.13.0.9001" -options(repos = c( - torch = sprintf("https://torch-cdn.mlverse.org/packages/%s/%s/", kind, version), - CRAN = "https://cloud.r-project.org" # or any other from which you want to install the other R dependencies. -)) -install.packages("torch", type = "binary") diff --git a/man/plot.Rd b/man/plot.Rd index d57a582ae..d682a1f8e 100644 --- a/man/plot.Rd +++ b/man/plot.Rd @@ -36,7 +36,8 @@ required parameters. \item vector cube: see \code{\link{plot.vector_cube}} \item classification probabilities: see \code{\link{plot.probs_cube}} \item classification uncertainty: see \code{\link{plot.uncertainty_cube}} -\item uncertainty of vector cubes: see \code{\link{plot.uncertainty_vector_cube}} +\item uncertainty of vector cubes: + see \code{\link{plot.uncertainty_vector_cube}} \item classified cube: see \code{\link{plot.class_cube}} \item classified vector cube: see \code{\link{plot.class_vector_cube}} \item dendrogram cluster: see \code{\link{plot.sits_cluster}} diff --git a/man/plot.class_cube.Rd b/man/plot.class_cube.Rd index 105101b97..fb668035f 100644 --- a/man/plot.class_cube.Rd +++ b/man/plot.class_cube.Rd @@ -55,7 +55,7 @@ plots a classified raster using ggplot. The following optional parameters are available to allow for detailed control over the plot output: \itemize{ -\item \code{graticules_labels_size}: size of coordinates labels (default = 0.8) +\item \code{graticules_labels_size}: size of coord labels (default = 0.8) \item \code{legend_title_size}: relative size of legend title (default = 1.0) \item \code{legend_text_size}: relative size of legend text (default = 1.0) \item \code{legend_bg_color}: color of legend background (default = "white") diff --git a/man/plot.dem_cube.Rd b/man/plot.dem_cube.Rd index f7ee0ff94..7da544dab 100644 --- a/man/plot.dem_cube.Rd +++ b/man/plot.dem_cube.Rd @@ -53,7 +53,7 @@ Use \code{scale} parameter for general output control. The following optional parameters are available to allow for detailed control over the plot output: \itemize{ -\item \code{graticules_labels_size}: size of coordinates labels (default = 0.7) +\item \code{graticules_labels_size}: size of coord labels (default = 0.7) \item \code{legend_title_size}: relative size of legend title (default = 0.7) \item \code{legend_text_size}: relative size of legend text (default = 0.7) \item \code{legend_bg_color}: color of legend background (default = "white") diff --git a/man/plot.raster_cube.Rd b/man/plot.raster_cube.Rd index 287dade82..623d56c8e 100644 --- a/man/plot.raster_cube.Rd +++ b/man/plot.raster_cube.Rd @@ -67,7 +67,8 @@ Plot RGB raster cube } \note{ Use \code{scale} parameter for general output control. - The \code{dates} parameter indicates the date allows plotting of different dates when + The \code{dates} parameter indicates + the date allows plotting of different dates when a single band and three dates are provided, `sits` will plot a multi-temporal RGB image for a single band (useful in the case of SAR data). For RGB bands with multi-dates, multiple plots will be @@ -76,9 +77,9 @@ Use \code{scale} parameter for general output control. The following optional parameters are available to allow for detailed control over the plot output: \itemize{ -\item \code{graticules_labels_size}: size of coordinates labels (default = 0.7) -\item \code{legend_title_size}: relative size of legend title (default = 0.7) -\item \code{legend_text_size}: relative size of legend text (default = 0.7) +\item \code{graticules_labels_size}: size of coord labels (default = 0.7) +\item \code{legend_title_size}: size of legend title (default = 0.7) +\item \code{legend_text_size}: size of legend text (default = 0.7) \item \code{legend_bg_color}: color of legend background (default = "white") \item \code{legend_bg_alpha}: legend opacity (default = 0.3) } diff --git a/man/plot.sar_cube.Rd b/man/plot.sar_cube.Rd index 8046ba036..3fb1e3c8c 100644 --- a/man/plot.sar_cube.Rd +++ b/man/plot.sar_cube.Rd @@ -67,7 +67,8 @@ Plot SAR raster cube } \note{ Use \code{scale} parameter for general output control. - The \code{dates} parameter indicates the date allows plotting of different dates when + The \code{dates} parameter indicates the date + allows plotting of different dates when a single band and three dates are provided, `sits` will plot a multi-temporal RGB image for a single band (useful in the case of SAR data). For RGB bands with multi-dates, multiple plots will be @@ -76,7 +77,7 @@ Use \code{scale} parameter for general output control. The following optional parameters are available to allow for detailed control over the plot output: \itemize{ -\item \code{graticules_labels_size}: size of coordinates labels (default = 0.7) +\item \code{graticules_labels_size}: size of coord labels (default = 0.7) \item \code{legend_title_size}: relative size of legend title (default = 0.7) \item \code{legend_text_size}: relative size of legend text (default = 0.7) \item \code{legend_bg_color}: color of legend background (default = "white") diff --git a/man/plot.uncertainty_cube.Rd b/man/plot.uncertainty_cube.Rd index 18e56f29f..5b11a5d45 100644 --- a/man/plot.uncertainty_cube.Rd +++ b/man/plot.uncertainty_cube.Rd @@ -54,7 +54,7 @@ plots a uncertainty cube The following optional parameters are available to allow for detailed control over the plot output: \itemize{ -\item \code{graticules_labels_size}: size of coordinates labels (default = 0.7) +\item \code{graticules_labels_size}: size of coord labels (default = 0.7) \item \code{legend_title_size}: relative size of legend title (default = 1.0) \item \code{legend_text_size}: relative size of legend text (default = 1.0) \item \code{legend_bg_color}: color of legend background (default = "white") diff --git a/man/plot.vector_cube.Rd b/man/plot.vector_cube.Rd index 4a35b971c..340a3d1f2 100644 --- a/man/plot.vector_cube.Rd +++ b/man/plot.vector_cube.Rd @@ -71,7 +71,7 @@ Plot RGB raster cube The following optional parameters are available to allow for detailed control over the plot output: \itemize{ -\item \code{graticules_labels_size}: size of coordinates labels (default = 0.7) +\item \code{graticules_labels_size}: size of coord labels (default = 0.7) \item \code{legend_title_size}: relative size of legend title (default = 0.7) \item \code{legend_text_size}: relative size of legend text (default = 0.7) \item \code{legend_bg_color}: color of legend background (default = "white") diff --git a/man/sits_accuracy.Rd b/man/sits_accuracy.Rd index 19e9e5127..2e1fb989e 100644 --- a/man/sits_accuracy.Rd +++ b/man/sits_accuracy.Rd @@ -51,18 +51,23 @@ accuracy (only for raster class cubes)} A list of lists: The error_matrix, the class_areas, the unbiased estimated areas, the standard error areas, confidence interval 95% areas, and the accuracy (user, producer, and overall), or NULL if the data is empty. -A confusion matrix assessment produced by the caret package. +The result is assigned to class "sits_accuracy" and can be visualised +directly on the screen. } \description{ This function calculates the accuracy of the classification -result. For a set of time series, it creates a confusion matrix and then -calculates the resulting statistics using package \code{caret}. The time -series needs to be classified using \code{\link[sits]{sits_classify}}. +result. The input is either a set of classified time series or a classified +data cube. +Classified time series are produced by \code{\link[sits]{sits_classify}}. Classified images are generated using \code{\link[sits]{sits_classify}} followed by \code{\link[sits]{sits_label_classification}}. + +For a set of time series, \code{sits_accuracy} creates a confusion matrix and +calculates the resulting statistics using package \code{caret}. + For a classified image, the function uses an area-weighted technique -proposed by Olofsson et al. according to [1-3] to produce more reliable +proposed by Olofsson et al. according to referenes [1-3] to produce reliable accuracy estimates at 95% confidence level. In both cases, it provides an accuracy assessment of the classified, diff --git a/man/sits_apply.Rd b/man/sits_apply.Rd index cd019b33f..1329dd71e 100644 --- a/man/sits_apply.Rd +++ b/man/sits_apply.Rd @@ -41,7 +41,7 @@ kernel functions, please see details).} \item{multicores}{Number of cores to be used for classification.} -\item{normalized}{Produce normalized band?} +\item{normalized}{Does the expression produces a normalized band?} \item{output_dir}{Directory where files will be saved.} @@ -54,44 +54,55 @@ A sits tibble or a sits cube with new bands, produced \description{ Apply a named expression to a sits cube or a sits tibble to be evaluated and generate new bands (indices). In the case of sits -cubes, it materializes a new band in \code{output_dir} using -\code{gdalcubes}. +cubes, it creates a new band in \code{output_dir}. } \details{ -\code{sits_apply()} allow any valid R expression to compute new bands. +\code{sits_apply()} allows any valid R expression to compute new bands. Use R syntax to pass an expression to this function. Besides arithmetic operators, you can use virtually any R function that can be applied to elements of a matrix (functions that are unaware of matrix sizes, e.g. \code{sqrt()}, \code{sin()}, \code{log()}). -Also, \code{sits_apply()} accepts a predefined set of kernel functions +Examples of valid expressions: +\enumerate{ +\item \code{NDVI = (B08 - B04/(B08 + B04))} for Sentinel-2 images. +\item \code{EVI = 2.5 * (B05 – B04) / (B05 + 6 * B04 – 7.5 * B02 + 1)} for +Landsat-8/9 images. +\item \code{VV_VH_RATIO = VH/VV} for Sentinel-1 images. In this case, +set the \code{normalized} parameter to FALSE. +\item \code{VV_DB = 10 * log10(VV)} to convert Sentinel-1 RTC images +available in Planetary Computer to decibels. Also, set the +\code{normalized} parameter to FALSE. +} + +\code{sits_apply()} accepts a predefined set of kernel functions (see below) that can be applied to pixels considering its neighborhood. \code{sits_apply()} considers a neighborhood of a -pixel as a set of pixels equidistant to it (including itself) -according the Chebyshev distance. This neighborhood form a -square window (also known as kernel) around the central pixel +pixel as a set of pixels equidistant to it (including itself). +This neighborhood forms a square window (also known as kernel) +around the central pixel (Moore neighborhood). Users can set the \code{window_size} parameter to adjust the size of the kernel window. The image is conceptually mirrored at the edges so that neighborhood including a pixel outside the image is equivalent to take the 'mirrored' pixel inside the edge. - \code{sits_apply()} applies a function to the kernel and its result is assigned to a corresponding central pixel on a new matrix. The kernel slides throughout the input image and this process generates an entire new matrix, which is returned as a new band to the cube. The kernel functions ignores any \code{NA} values -inside the kernel window. Central pixel is \code{NA} just only -all pixels in the window are \code{NA}. +inside the kernel window. If all pixels in the window are \code{NA} +que result will be \code{NA}. -By default, the indexes generated by the \code{sits_apply()} function are +By default, the indexes generated by \code{sits_apply()} function are normalized between -1 and 1, scaled by a factor of 0.0001. Normalized indexes are saved as INT2S (Integer with sign). If the \code{normalized} parameter is FALSE, no scaling factor will be -applied and the index will be saved as FLT4S (Float with sign). +applied and the index will be saved as FLT4S (signed float) and +the values will vary between -3.4e+38 and 3.4e+38. } -\section{Summarizing kernel functions}{ +\section{Kernel functions available}{ \itemize{ \item{\code{w_median()}: returns the median of the neighborhood's values.} diff --git a/man/sits_as_sf.Rd b/man/sits_as_sf.Rd index 509d13592..6d1996bf3 100644 --- a/man/sits_as_sf.Rd +++ b/man/sits_as_sf.Rd @@ -4,6 +4,7 @@ \alias{sits_as_sf} \alias{sits_as_sf.sits} \alias{sits_as_sf.raster_cube} +\alias{sits_as_sf.vector_cube} \title{Return a sits_tibble or raster_cube as an sf object.} \usage{ sits_as_sf(data, ...) @@ -11,6 +12,8 @@ sits_as_sf(data, ...) \method{sits_as_sf}{sits}(data, ..., crs = "EPSG:4326", as_crs = NULL) \method{sits_as_sf}{raster_cube}(data, ..., as_crs = NULL) + +\method{sits_as_sf}{vector_cube}(data, ..., as_crs = NULL) } \arguments{ \item{data}{A sits tibble or sits cube.} @@ -25,7 +28,7 @@ sits_as_sf(data, ...) An sf object of point or polygon geometry. } \description{ -Return a sits_tibble or raster_cube as an sf object. +Converts a sits_tibble or raster_cube as an sf object. } \examples{ if (sits_run_examples()) { diff --git a/man/sits_bbox.Rd b/man/sits_bbox.Rd index e64478e45..383023655 100644 --- a/man/sits_bbox.Rd +++ b/man/sits_bbox.Rd @@ -8,20 +8,22 @@ \alias{sits_bbox.default} \title{Get the bounding box of the data} \usage{ -sits_bbox(data, crs = "EPSG:4326", as_crs = NULL) +sits_bbox(data, ..., crs = "EPSG:4326", as_crs = NULL) -\method{sits_bbox}{sits}(data, crs = "EPSG:4326", as_crs = NULL) +\method{sits_bbox}{sits}(data, ..., crs = "EPSG:4326", as_crs = NULL) -\method{sits_bbox}{raster_cube}(data, crs = "EPSG:4326", as_crs = NULL) +\method{sits_bbox}{raster_cube}(data, ..., as_crs = NULL) -\method{sits_bbox}{tbl_df}(data, crs = "EPSG:4326", as_crs = NULL) +\method{sits_bbox}{tbl_df}(data, ..., crs = "EPSG:4326", as_crs = NULL) -\method{sits_bbox}{default}(data, crs = "EPSG:4326", as_crs = NULL) +\method{sits_bbox}{default}(data, ..., crs = "EPSG:4326", as_crs = NULL) } \arguments{ \item{data}{samples (class "sits") or \code{cube}.} -\item{crs}{CRS of the samples points (single char)} +\item{...}{parameters for specific types} + +\item{crs}{CRS of the time series.} \item{as_crs}{CRS to project the resulting \code{bbox}.} } @@ -32,6 +34,13 @@ A \code{bbox}. Obtain a vector of limits (either on lat/long for time series or in projection coordinates in the case of cubes) } +\note{ +Time series in \code{sits} are associated with lat/long +values in WGS84, while each data cubes is associated to a +cartographic projection. To obtain the bounding box +of a data cube in a different projection than the original, +use the \code{as_crs} parameter. +} \examples{ if (sits_run_examples()) { # get the bbox of a set of samples diff --git a/man/sits_classify.Rd b/man/sits_classify.Rd index 589429147..fe705ff26 100644 --- a/man/sits_classify.Rd +++ b/man/sits_classify.Rd @@ -93,29 +93,27 @@ sits_classify(data, ml_model, ...) \item{progress}{Logical: Show progress bar?} \item{roi}{Region of interest (either an sf object, shapefile, -or a numeric vector with named XY values +or a numeric vector in WGS 84 with named XY values ("xmin", "xmax", "ymin", "ymax") or named lat/long values ("lon_min", "lat_min", "lon_max", "lat_max").} \item{exclusion_mask}{Areas to be excluded from the classification -process. It can be defined as a sf object or a +process. It can be defined by a sf object or by a shapefile.} -\item{start_date}{Start date for the classification +\item{start_date}{Starting date for the classification (Date in YYYY-MM-DD format).} -\item{end_date}{End date for the classification +\item{end_date}{Ending date for the classification (Date in YYYY-MM-DD format).} \item{memsize}{Memory available for classification in GB (integer, min = 1, max = 16384).} -\item{output_dir}{Valid directory for output file. -(character vector of length 1).} +\item{output_dir}{Directory for output file.} -\item{version}{Version of the output -(character vector of length 1).} +\item{version}{Version of the output.} \item{verbose}{Logical: print information about processing time?} @@ -142,8 +140,24 @@ SITS supports the following models: \code{\link[sits]{sits_tae}} } \note{ -The \code{roi} parameter defines a region of interest. It can be - an sf_object, a shapefile, or a bounding box vector with +The \code{sits_classify} function takes three types of data as input + and produce there types of output: + \enumerate{ + \item{A set of time series. The output is the same set + with the additional column \code{predicted}.} + \item{A raster data cube. The output is a probability cube, + which has the same tiles as the raster cube. Each tile contains + a multiband image; each band contains the probability that + each pixel belongs to a given class.} + \item{A vector data cube. Vector data cubes are produced when + closed regions are obtained from raster data cubes using + \code{\link[sits]{sits_segment}}. Classification of a vector + data cube produces a vector data structure with additional + columns expressing the class probabilities for each object.} + } + + The \code{roi} parameter defines a region of interest. It can be + an sf_object, a shapefile, or a bounding box vector in WGS84 with named XY values (\code{xmin}, \code{xmax}, \code{ymin}, \code{ymax}) or named lat/long values (\code{lon_min}, \code{lon_max}, \code{lat_min}, \code{lat_max}) diff --git a/man/sits_cube.Rd b/man/sits_cube.Rd index 38fa66a57..89dd1f91a 100644 --- a/man/sits_cube.Rd +++ b/man/sits_cube.Rd @@ -60,12 +60,12 @@ sits_cube(source, collection, ...) ) } \arguments{ -\item{source}{Data source (one of \code{"AWS"}, \code{"BDC"}, -\code{"DEAFRICA"}, \code{"MPC"}, \code{"SDC"}, -\code{"USGS"} - character vector of length 1).} +\item{source}{Data source: one of \code{"AWS"}, \code{"BDC"}, +\code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, +\code{"HLS"}, \code{"PLANETSCOPE"}, \code{"MPC"}, +\code{"SDC"} or \code{"USGS"}.} -\item{collection}{Image collection in data source -(character vector of length 1). +\item{collection}{Image collection in data source. To find out the supported collections, use \code{\link{sits_list_collections}()}).} @@ -74,31 +74,31 @@ use \code{\link{sits_list_collections}()}).} \item{orbit}{Orbit name ("ascending", "descending") for SAR cubes.} \item{bands}{Spectral bands and indices to be included -in the cube (optional - character vector). +in the cube (optional). Use \code{\link{sits_list_collections}()} to find out the bands available for each collection.} \item{tiles}{Tiles from the collection to be included in -the cube (see details below) -(character vector of length 1).} +the cube (see details below).} -\item{roi}{Region of interest (either an sf object, shapefile, -\code{SpatExtent}, or a numeric vector with named XY -values ("xmin", "xmax", "ymin", "ymax") or -named lat/long values +\item{roi}{Region of interest. Either an sf object, a shapefile, +a \code{SpatExtent} from \code{terra}, +a vector with named XY +values ("xmin", "xmax", "ymin", "ymax"), or +a vector with named lat/long values ("lon_min", "lat_min", "lon_max", "lat_max").} \item{crs}{The Coordinate Reference System (CRS) of the roi. It -must be specified when roi is named XY values -("xmin", "xmax", "ymin", "ymax") or \code{SpatExtent}} +must be specified when roi is defined by XY values +("xmin", "xmax", "ymin", "ymax") or by +a \code{SpatExtent} from \code{terra}.} \item{start_date, end_date}{Initial and final dates to include images from the collection in the cube (optional). (Date in YYYY-MM-DD format).} \item{platform}{Optional parameter specifying the platform in case -of collections that include more than one satellite -(character vector of length 1).} +of collections that include more than one satellite.} \item{multicores}{Number of workers for parallel processing (integer, min = 1, max = 2048).} @@ -106,10 +106,10 @@ of collections that include more than one satellite \item{progress}{Logical: show a progress bar?} \item{data_dir}{Local directory where images are stored -(for local cubes - character vector of length 1).} +(for local cubes only).} \item{vector_dir}{Local director where vector files are stored -(for local vector cubes - character vector of length 1).} +(for local vector cubes only).} \item{vector_band}{Band for vector cube ("segments", "probs", "class")} @@ -118,13 +118,13 @@ of collections that include more than one satellite classes "probs_cube" or "class_cube").} \item{parse_info}{Parsing information for local files -(for local cubes - character vector).} +(for local cubes - see notes below).} \item{version}{Version of the classified and/or labelled files. -(for local cubes - character vector of length 1).} +(for local cubes).} \item{delim}{Delimiter for parsing local files -(single character)} +(default = "_")} } \value{ A \code{tibble} describing the contents of a data cube. @@ -136,15 +136,48 @@ The following cloud providers are supported, based on the STAC protocol: Amazon Web Services (AWS), Brazil Data Cube (BDC), Copernicus Data Space Ecosystem (CDSE), Digital Earth Africa (DEAFRICA), Digital Earth Australia (DEAUSTRALIA), Microsoft Planetary Computer (MPC), -Nasa Harmonized Landsat/Sentinel (HLS), Swiss Data Cube (SDC), TERRASCOPE or +Nasa Harmonized Landsat/Sentinel (HLS), Swiss Data Cube (SDC), TERRASCOPE and USGS Landsat (USGS). Data cubes can also be created using local files. } \note{ { + +In \code{sits}, a data cube is represented a tibble with metadata +describing a set of image files obtained from cloud providers. +It contains information about each individual file. + +In conceptual terms, \code{sits} defines a data cube as: +\enumerate{ +\item{A set of images organized in tiles of a grid system (e.g., MGRS).} +\item{Each tile contains single-band images in a + unique zone of the coordinate system (e.g, tile 20LMR in MGRS grid) + covering a user-specified time period.} +\item{Each image of a tile is associated to a temporal interval. +All intervals share the same spectral bands.} +\item{Different tiles may cover different zones of the same grid system.} +} +In \code{sits}, a regular data cube is a data cube where: +\enumerate{ +\item{All tiles share the same set of regular temporal intervals.} +\item{All tiles share the same set of spectral bands and indices.} +\item{All images of all tiles have the same spatial resolution.} +\item{Each location in a tile is associated a set of multi-band time series.} +\item{For each interval and band, the cube is associated to a 2D image.} +} + +Data cubes are identified on cloud providers using \code{sits_cube}. +The result of \code{sits_cube} is only a description of the location +of the required data in the cloud provider. No download is done. + +To obtain regular data cubes, use \code{\link[sits]{sits_regularize}}. +For faster performance, we suggest users +copy data from cloud providers to local disk using \code{sits_cube_copy} +before regularization. + To create cubes from cloud providers, users need to inform: \enumerate{ \item \code{source}: One of "AWS", "BDC", "CDSE", "DEAFRICA", "DEAUSTRALIA", - "HLS", "MPC", "SDC", "TERRASCOPE", or "USGS"; + "HLS", "PLANETSCOPE", "MPC", "SDC", "TERRASCOPE", or "USGS"; \item \code{collection}: Collection available in the cloud provider. Use \code{\link{sits_list_collections}()} to see which collections are supported; @@ -155,60 +188,39 @@ To create cubes from cloud providers, users need to inform: \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84, a \code{sfc} or \code{sf} object from sf package in WGS84 projection. A named \code{vector} (\code{"xmin"}, \code{"xmax"}, - \code{"ymin"}, \code{"ymax"}) or a \code{SpatExtent} can also - be used, requiring only the specification of the \code{crs} parameter. + \code{"ymin"}, \code{"ymax"}) + or a \code{SpatExtent} from \code{terra}. XY vectors and + \code{SpatExtent} require the specification of parameter \code{crs}. } The parameter \code{bands}, \code{start_date}, and \code{end_date} are optional for cubes created from cloud providers. -Either \code{tiles} or \code{roi} must be informed. The \code{roi} parameter -is used to select images. This parameter does not crop a region; it only +Either \code{tiles} or \code{roi} must be informed. The \code{tiles} +should specify a set of valid tiles for the ARD collection. +For example, Landsat data has tiles in \code{WRS2} tiling system +and Sentinel-2 data uses the \code{MGRS} tiling system. +The \code{roi} parameter is used to select all types of images. +This parameter does not crop a region; it only selects images that intersect it. -If you want to use GeoJSON geometries (RFC 7946) as value \code{roi}, you -can convert it to sf object and then use it. - -\code{sits} can access data from multiple providers, including -\code{Amazon Web Services} (AWS), \code{Microsoft Planetary Computer} (MPC), -\code{Brazil Data Cube} (BDC), \code{Copernicus Data Space Ecosystem} (CDSE), -\code{Digital Earth Africa}, \code{Digital Earth Australia}, -\code{NASA EarthData}, \code{Terrascope} and more. - -In each provider, \code{sits} can access multiple collections. For example, -in MPC \code{sits} can access multiple open data collections, including -\code{"SENTINEL-2-L2A"} for Sentinel-2/2A images, and -\code{"LANDSAT-C2-L2"} for the Landsat-4/5/7/8/9 collection. - -In AWS, there are two types of collections: open data and -requester-pays. Currently, \code{sits} supports collections -\code{"SENTINEL-2-L2A"}, \code{"SENTINEL-S2-L2A-COGS"} (open data) and -\code{"LANDSAT-C2-L2"} (requester-pays). There is no need to provide AWS -credentials to access open data collections. For requester-pays data, you -need to provide your AWS access codes as environment variables, as follows: -\code{ -Sys.setenv( - AWS_ACCESS_KEY_ID = , - AWS_SECRET_ACCESS_KEY = -)} - -In BDC, there are many collections, including \code{"LANDSAT-OLI-16D"} -(Landsat-8 OLI, 30 m resolution, 16-day intervals), \code{"SENTINEL-2-16D"} -(Sentinel-2A and 2B MSI images at 10 m resolution, 16-day intervals), -\code{"CBERS-WFI-16D"} (CBERS 4 WFI, 64 m resolution, 16-day intervals), and -others. All BDC collections are regularized. - -To explore providers and collections \code{sits} supports, use the -\code{\link{sits_list_collections}()} function. - -If you want to learn more details about each provider and collection +To use GeoJSON geometries (RFC 7946) as value \code{roi}, please +convert it to sf object and then use it. + +To get more details about each provider and collection available in \code{sits}, please read the online sits book (e-sensing.github.io/sitsbook). The chapter \code{Earth Observation data cubes} provides a detailed description of all collections you can use with \code{sits} (e-sensing.github.io/sitsbook/earth-observation-data-cubes.html). -To create a cube from local files, you need to inform: +Data cubes created from ARD image collection are objects of class +\code{"raster_cube"}. Users can extract segments from raster data cubes +using \code{\link[sits]{sits_segment}} creating vector data cubes. +The segments are stored in a \code{geopackage} file and information +about its location is stored in the data cube object. + +To create a cube from local files, please inform: \enumerate{ \item \code{source}: The data provider from which the data was downloaded (e.g, "BDC", "MPC"); @@ -227,33 +239,24 @@ To create a cube from local files, you need to inform: the file names. Default is \code{"_"}. } -Note that if you are working with local data cubes created by \code{sits}, -you do not need to specify \code{parse_info} and \code{delim}. These elements -are automatically identified. This is particularly useful when you have -downloaded or created data cubes using \code{sits}. - -For example, if you downloaded a data cube from the Microsoft Planetary -Computer (MPC) using the function \code{\link{sits_cube_copy}()}, you do -not need to provide \code{parse_info} and \code{delim}. - -If you are using a data cube from a source supported by \code{sits} -(e.g., AWS, MPC) but downloaded / managed with an external tool, you will -need to specify the \code{parse_info} and \code{delim} parameters manually. -For this case, you first need to ensure that the local files meet some -critical requirements: +When working with local data cubes downloaded or created by \code{sits}, +there is no need to specify \code{parse_info} and \code{delim}. +To use a data cube from a source supported by \code{sits} +(e.g., AWS, MPC) that has been obtained with an external tool, please +specify the \code{parse_info} and \code{delim} parameters manually. +For this case, to ensure that the local files meet the +following requirements: \itemize{ \item All image files must have the same spatial resolution and projection; - \item Each file should represent a single image band for a single date; - \item File names must include information about the \code{"tile"}, \code{"date"}, and \code{"band"} in the file. } For example, if you are creating a Sentinel-2 data cube on your local machine, and the files have the same spatial resolution and projection, with -each file containing a single band and date, an acceptable file name could be: +each file containing a single band and date, an acceptable file name is: \itemize{ \item \code{"SENTINEL-2_MSI_20LKP_B02_2018-07-18.jp2"} } @@ -262,12 +265,11 @@ This file name works because it encodes the three key pieces of information used by \code{sits}: \itemize{ \item Tile: "20LKP"; - \item Band: "B02"; - \item Date: "2018-07-18" } - +In this case the \code{"parse_info"} parameter should be +\code{c("satellite", "sensor", "tile", "band", "date")} Other example of supported file names are: \itemize{ \item \code{"CBERS-4_WFI_022024_B13_2021-05-15.tif"}; @@ -281,20 +283,19 @@ The \code{parse_info} parameter tells \code{sits} how to extract essential metadata from file names. It defines the sequence of components in the file name, assigning each part a label such as \code{"tile"}, \code{"band"}, and \code{"date"}. For parts of the file name that are irrelevant to -\code{sits}, you can use dummy labels like \code{"X1"}, \code{"X2"}, and so -on. +\code{sits}, you can use dummy labels like \code{"X1"} and \code{"X2"}. For example, consider the file name: \itemize{ \item \code{"SENTINEL-2_MSI_20LKP_B02_2018-07-18.jp2"} } -With \code{parse_info = c("X1", "X2", "tile", "band", "date")} and +With \code{parse_info = c("satellite", "sensor", "tile", "band", "date")} and \code{delim = "_"}, the extracted metadata would be: \itemize{ - \item X1: "SENTINEL-2" (ignored) - \item X2: "MSI" (ignored) + \item satellite: "SENTINEL-2" (ignored) + \item sensor: "MSI" (ignored) \item tile: "20LKP" (used) \item band: "B02" (used) \item date: "2018-07-18" (used) @@ -476,7 +477,6 @@ if (sits_run_examples()) { data_dir = data_dir, parse_info = c("satellite", "sensor", "tile", "band", "date") ) - } } \author{ diff --git a/man/sits_get_class.Rd b/man/sits_get_class.Rd index 921964b58..9392c12f9 100644 --- a/man/sits_get_class.Rd +++ b/man/sits_get_class.Rd @@ -25,8 +25,7 @@ sits_get_class(cube, samples) \method{sits_get_class}{data.frame}(cube, samples) } \arguments{ -\item{cube}{Classified data cube from where data is to be retrieved. -(class "class_cube").} +\item{cube}{Classified data cube.} \item{samples}{Location of the samples to be retrieved. Either a tibble of class "sits", an "sf" object, diff --git a/man/sits_get_probs.Rd b/man/sits_get_probs.Rd index 6173e31ae..15c96083d 100644 --- a/man/sits_get_probs.Rd +++ b/man/sits_get_probs.Rd @@ -25,8 +25,7 @@ sits_get_probs(cube, samples, window_size = NULL) \method{sits_get_probs}{default}(cube, samples, window_size = NULL) } \arguments{ -\item{cube}{Probability data cube from where data is to be retrieved. -(class "class_cube").} +\item{cube}{Probability data cube.} \item{samples}{Location of the samples to be retrieved. Either a tibble of class "sits", an "sf" object, diff --git a/man/sits_som_remove_samples.Rd b/man/sits_som_remove_samples.Rd index c95d29ea2..db5d17f16 100644 --- a/man/sits_som_remove_samples.Rd +++ b/man/sits_som_remove_samples.Rd @@ -13,7 +13,7 @@ sits_som_remove_samples(som_map, som_eval, class_cluster, class_remove) \item{class_cluster}{Dominant class of a set of neurons} -\item{class_remove}{Class to be removed from the neurons of the "class_cluster"} +\item{class_remove}{Class to be removed from the neurons of "class_cluster"} } \value{ A new set of samples with the desired class neurons remove @@ -28,7 +28,8 @@ if (sits_run_examples()) { # evaluate the som map and create clusters som_eval <- sits_som_evaluate_cluster(som_map) # clean the samples - new_samples <- sits_som_remove_samples(som_map, som_eval, "Pasture", "Cerrado") + new_samples <- sits_som_remove_samples(som_map, som_eval, + "Pasture", "Cerrado") } } \author{ diff --git a/man/sits_tuning.Rd b/man/sits_tuning.Rd index 5b26fb894..709b73b64 100644 --- a/man/sits_tuning.Rd +++ b/man/sits_tuning.Rd @@ -33,7 +33,7 @@ for validation (if samples_validation is NULL)} \code{randint}, \code{normal}, \code{lognormal}, \code{loguniform}, and \code{beta} distribution functions to randomize parameters.} -\item{trials}{Number of random trials to perform the random search.} +\item{trials}{Number of random trials to perform the search.} \item{multicores}{Number of cores to process in parallel.} diff --git a/tests/testthat/test-apply.R b/tests/testthat/test-apply.R index d1c4866f9..2c40df9f6 100644 --- a/tests/testthat/test-apply.R +++ b/tests/testthat/test-apply.R @@ -89,7 +89,8 @@ test_that("Testing index generation", { multicores = 1, output_dir = dir_images ) - expect_true(all(sits_bands(gc_cube_new) %in% c("CIRE", "EVI", "B05", "B8A"))) + expect_true(all(sits_bands(gc_cube_new) %in% + c("CIRE", "EVI", "B05", "B8A"))) file_info_cire <- .fi(gc_cube_new) |> .fi_filter_bands(bands = "CIRE") cire_band_1 <- .raster_open_rast(file_info_cire$path[[1]]) diff --git a/tests/testthat/test-bands.R b/tests/testthat/test-bands.R index d292ce0ac..e58506a11 100644 --- a/tests/testthat/test-bands.R +++ b/tests/testthat/test-bands.R @@ -1,7 +1,7 @@ test_that("band rename", { bands <- sits_bands(point_mt_6bands) point_mt_6bands <- .band_rename(point_mt_6bands, - c("SWIR", "BLUE", "NIR08", "RED2", "EVI2", "NDVI2")) + c("SWIR", "BLUE", "NIR08", "RED2", "EVI2", "NDVI2")) new_bands <- sits_bands(point_mt_6bands) expect_true(all(new_bands %in% c("SWIR", "BLUE", "NIR08", "RED2", "EVI2", "NDVI2"))) diff --git a/tests/testthat/test-check.R b/tests/testthat/test-check.R index ea7463fc7..653a358e5 100644 --- a/tests/testthat/test-check.R +++ b/tests/testthat/test-check.R @@ -10,13 +10,15 @@ test_that("Caller", { input <- NULL expect_error( .check_null_parameter(input), - ".test_check: NULL value not allowed for input - expected error during testing" + ".test_check: NULL value not allowed for input + - expected error during testing" ) # .check_na input <- c(1, NA, 3) expect_error( .check_na_parameter(input), - ".test_check: NA value not allowed for input - expected error during testing" + ".test_check: NA value not allowed for input + - expected error during testing" ) # .check_num_paramter @@ -36,7 +38,8 @@ test_that("Caller", { ) expect_error( .check_date_parameter("2023-301-01"), - ".check_date_parameter: invalid date format - dates should follow year-month-day: YYYY-MM-DD" + ".check_date_parameter: invalid date format + - dates should follow year-month-day: YYYY-MM-DD" ) legends <- c("Pasture", "Cerrado", "Soy") expect_error( @@ -51,7 +54,8 @@ test_that("Caller", { period <- "P2Y6M" expect_error( .check_period(period), - ".check_period: invalid period format - valid examples are P16D, P1M, P1Y" + ".check_period: invalid period format + - valid examples are P16D, P1M, P1Y" ) crs <- "EPSG:9999" expect_error( @@ -61,12 +65,14 @@ test_that("Caller", { output_dir <- paste0("/mydir/123/test") expect_error( .check_output_dir(output_dir), - ".check_output_dir: invalid output_dir variable - file does not exist: '/mydir/123/test'" + ".check_output_dir: invalid output_dir variable + - file does not exist: '/mydir/123/test'" ) version <- c("1", "2") expect_error( .check_version(version), - ".check_version: version should a lower case character vector with no underlines" + ".check_version: version should be + lower case character vector with no underlines" ) progress <- "TRUE" expect_error( diff --git a/tests/testthat/test-config.R b/tests/testthat/test-config.R index c4e3fec3d..9762bafbf 100644 --- a/tests/testthat/test-config.R +++ b/tests/testthat/test-config.R @@ -113,7 +113,9 @@ test_that("User functions", { expect_error( .source_collection_check(source = "TEST", collection = "ZZZ"), - ".source_collection_check: invalid collection variable - collection is not available in data provider or sits is not configured to access it" + ".source_collection_check: invalid collection variable + - collection is not available in data provider + or sits is not configured to access it" ) expect_equal( diff --git a/tests/testthat/test-cube-bdc.R b/tests/testthat/test-cube-bdc.R index 86b52fa4c..6adb6826d 100644 --- a/tests/testthat/test-cube-bdc.R +++ b/tests/testthat/test-cube-bdc.R @@ -71,7 +71,7 @@ test_that("Creating cubes from BDC - CBERS-WFI-8D", { expect_true(.raster_nrows(r_obj) == cube_nrows) }) -test_that("Creating cubes from BDC - MOD13Q1-6.1 based on ROI using sf object", { +test_that("Creating cubes from BDC - MOD13Q1-6.1 based on ROI using sf", { shp_file <- system.file( "extdata/shapefiles/mato_grosso/mt.shp", package = "sits" diff --git a/tests/testthat/test-cube-mpc.R b/tests/testthat/test-cube-mpc.R index 8a8f448d2..95650400c 100644 --- a/tests/testthat/test-cube-mpc.R +++ b/tests/testthat/test-cube-mpc.R @@ -220,7 +220,7 @@ test_that("Creating LANDSAT cubes from MPC with WRS", { ) ) }) -test_that("Creating cubes from MPC - MOD13Q1-6.1 based on ROI using sf object", { +test_that("Creating cubes from MPC - MOD13Q1-6.1 based on ROI using sf", { shp_file <- system.file( "extdata/shapefiles/mato_grosso/mt.shp", package = "sits" @@ -255,7 +255,7 @@ test_that("Creating cubes from MPC - MOD13Q1-6.1 based on ROI using sf object", expect_true(all(intersects)) }) -test_that("Creating cubes from MPC - MOD09A1-6.1 based on ROI using sf object", { +test_that("Creating cubes from MPC - MOD09A1-6.1 based on ROI using sf", { shp_file <- system.file( "extdata/shapefiles/mato_grosso/mt.shp", package = "sits" @@ -293,7 +293,7 @@ test_that("Creating cubes from MPC - MOD09A1-6.1 based on ROI using sf object", expect_equal(nrow(tile_h13v10), 1) }) -test_that("Creating cubes from MPC - MOD10A1-6.1 based on ROI using sf object", { +test_that("Creating cubes from MPC - MOD10A1-6.1 based on ROI using sf", { shp_file <- system.file( "extdata/shapefiles/switzerland/ch.shp", package = "sits" diff --git a/tests/testthat/test-get_probs_class.R b/tests/testthat/test-get_probs_class.R index fa727f0b7..a9121a8e9 100644 --- a/tests/testthat/test-get_probs_class.R +++ b/tests/testthat/test-get_probs_class.R @@ -18,14 +18,16 @@ test_that("Getting data for probs and classified cube", { version = "probs_get", progress = FALSE ) - samples_sinop <- paste0(system.file("extdata/samples/samples_sinop_crop.csv", - package = "sits")) + samples_sinop <- paste0(system.file( + "extdata/samples/samples_sinop_crop.csv", + package = "sits")) probs_values <- sits_get_probs( cube = probs_cube, samples = samples_sinop ) - expect_true(all(c("longitude", "latitude", "X", "Y", "Cerrado", - "Forest", "Pasture", "Soy_Corn") %in% colnames(probs_values))) + expect_true(all(c("longitude", "latitude", + "X", "Y", "Cerrado", "Forest", "Pasture", + "Soy_Corn") %in% colnames(probs_values))) probs <- probs_values[1, c(5:8)] expect_true(sum(probs) > 0.99) probs2 <- probs_values[2, c(5:8)] diff --git a/tests/testthat/test-merge.R b/tests/testthat/test-merge.R index 68abd1c1c..d34036efb 100644 --- a/tests/testthat/test-merge.R +++ b/tests/testthat/test-merge.R @@ -1,4 +1,4 @@ -test_that("same bands (1) | same interval | same tiles (1) | regular -> regular | General case", { +test_that("same bands (1), interval, tiles (1) | regular -> regular", { modis_cube <- suppressWarnings( .try( { @@ -29,7 +29,8 @@ test_that("same bands (1) | same interval | same tiles (1) | regular -> regular nrow(modis_cube[["file_info"]][[1]]) ) }) -test_that("same bands (1) | diff interval | same tiles (1) | regular -> error | General case", { +test_that("same bands (1) | diff interval | same tiles (1) | + regular -> error | General case", { modis_cube_a <- suppressWarnings( .try( { @@ -70,7 +71,8 @@ test_that("same bands (1) | diff interval | same tiles (1) | regular -> error expect_error(sits_merge(modis_cube_a, modis_cube_b)) }) -test_that("diff bands (1) | diff interval | same tiles (1) | regular -> regular | General case", { +test_that("diff bands (1) | diff interval | same tiles (1) | + regular -> regular | General case", { modis_cube_a <- suppressWarnings( .try( { @@ -120,7 +122,8 @@ test_that("diff bands (1) | diff interval | same tiles (1) | regular -> regular sits_bands(merged_cube), c("EVI", "NDVI") ) }) -test_that("same bands (1) | diff interval | diff tiles (1) | regular -> error | General case", { +test_that("same bands (1) | diff interval | diff tiles (1) | + regular -> error | General case", { modis_cube_a <- suppressWarnings( .try( { @@ -161,7 +164,8 @@ test_that("same bands (1) | diff interval | diff tiles (1) | regular -> error expect_error(sits_merge(modis_cube_a, modis_cube_b)) }) -test_that("diff bands (1) | diff interval | diff tiles (1) | regular -> error | General case", { +test_that("diff bands (1) | diff interval | diff tiles (1) | + regular -> error | General case", { modis_cube_a <- suppressWarnings( .try( { @@ -202,7 +206,8 @@ test_that("diff bands (1) | diff interval | diff tiles (1) | regular -> error expect_error(sits_merge(modis_cube_a, modis_cube_b)) }) -test_that("same bands (1) | same interval | diff tiles (2) | irregular -> irregular | DEAustralia case", { +test_that("same bands (1) | same interval | diff tiles (2) | + irregular -> irregular | DEAustralia case", { s2a_cube <- .try( { sits_cube( @@ -245,7 +250,8 @@ test_that("same bands (1) | same interval | diff tiles (2) | irregular -> irregu expect_true(length(merged_cube_timeline) > 1) }) -test_that("diff bands (1) | same interval | diff tiles (1) | irregular -> error | General case", { +test_that("diff bands (1) | same interval | diff tiles (1) | + irregular -> error | General case", { s2_cube_a <- suppressWarnings( .try( { @@ -287,7 +293,8 @@ test_that("diff bands (1) | same interval | diff tiles (1) | irregular -> error # merge expect_error(sits_merge(s2_cube_a, s2_cube_b)) }) -test_that("same bands (1) | diff interval | same tiles (1) | irregular -> irregular | General case", { +test_that("same bands (1) | diff interval | same tiles (1) | + irregular -> irregular | General case", { s2_cube_a <- suppressWarnings( .try( { @@ -337,7 +344,8 @@ test_that("same bands (1) | diff interval | same tiles (1) | irregular -> irregu sits_bands(merged_cube), "B02" ) }) -test_that("same bands (1) | diff interval | diff tiles (1) | irregular -> irregular | General case", { +test_that("same bands (1) | diff interval | diff tiles (1) | + irregular -> irregular | General case", { s2_cube_a <- suppressWarnings( .try( { @@ -391,7 +399,8 @@ test_that("same bands (1) | diff interval | diff tiles (1) | irregular -> irregu max(merged_tl[[2]]) <= max(merged_tl[[2]]) ) }) -test_that("same bands (1) | same interval | diff tiles (1) | irregular -> irregular | General case", { +test_that("same bands (1) | same interval | diff tiles (1) | + irregular -> irregular | General case", { s2_cube_a <- suppressWarnings( .try( { @@ -444,7 +453,8 @@ test_that("same bands (1) | same interval | diff tiles (1) | irregular -> irregu max(merged_tl[[2]]) <= max(merged_tl[[2]]) ) }) -test_that("diff bands (1) | same interval | same tiles (1) | irregular -> irregular | General case", { +test_that("diff bands (1) | same interval | same tiles (1) | + irregular -> irregular | General case", { s2_cube <- suppressWarnings( .try( { @@ -501,7 +511,8 @@ test_that("diff bands (1) | same interval | same tiles (1) | irregular -> irregu max(merged_tl[[2]]) <= max(merged_tl[[2]]) ) }) -test_that("diff bands (1) | same interval | same tiles (1) | irregular -> irregular | Rainfall case", { +test_that("diff bands (1) | same interval | same tiles (1) | + irregular -> irregular | Rainfall case", { rainfall <- suppressWarnings( .try( { @@ -552,7 +563,8 @@ test_that("diff bands (1) | same interval | same tiles (1) | irregular -> irregu ) }) -test_that("diff bands (1) | same interval | same tiles (1) | irregular -> irregular | HLS case", { +test_that("diff bands (1) | same interval | same tiles (1) | + irregular -> irregular | HLS case", { roi <- c( lon_min = -45.6422, lat_min = -24.0335, lon_max = -45.0840, lat_max = -23.6178 diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 18f873d25..eff9e3521 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -116,7 +116,8 @@ test_that("Plot Models", { set.seed(290356) rfor_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor()) p_model <- plot(rfor_model) - expect_equal(p_model$labels$title, "Distribution of minimal depth and its mean") + expect_equal(p_model$labels$title, + "Distribution of minimal depth and its mean") }) test_that("Dendrogram Plot", { From e5f8dc0b3c7b33964af247867a237dd98443a14c Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Thu, 20 Mar 2025 13:29:24 -0300 Subject: [PATCH 059/122] improve documentation --- R/api_check.R | 2 +- R/api_dtw.R | 2 +- R/api_environment.R | 4 +- R/api_merge.R | 4 +- R/api_plot_raster.R | 2 +- R/api_plot_vector.R | 2 +- R/api_regularize.R | 2 +- R/sits_accuracy.R | 18 +++--- R/sits_add_base_cube.R | 2 +- R/sits_classify.R | 44 ++++++++------ R/sits_clean.R | 4 +- R/sits_colors.R | 10 +++- R/sits_combine_predictions.R | 21 ++++++- R/sits_cube.R | 59 +++++++++++-------- R/sits_cube_copy.R | 17 ++++-- R/sits_get_class.R | 4 +- R/sits_get_data.R | 4 +- R/sits_histogram.R | 2 +- R/sits_plot.R | 2 +- R/sits_view.R | 2 +- inst/extdata/config_messages.yml | 3 +- inst/extdata/sources/config_source_aws.yml | 6 +- inst/extdata/sources/config_source_bdc.yml | 6 +- inst/extdata/sources/config_source_cdse.yml | 2 +- inst/extdata/sources/config_source_chile.yml | 2 +- .../sources/config_source_deafrica.yml | 10 ++-- .../sources/config_source_deaustralia.yml | 12 ++-- inst/extdata/sources/config_source_hls.yml | 4 +- inst/extdata/sources/config_source_mpc.yml | 6 +- inst/extdata/sources/config_source_sdc.yml | 2 +- inst/extdata/sources/config_source_usgs.yml | 2 +- man/sits_accuracy.Rd | 18 +++--- man/sits_classify.Rd | 43 ++++++++------ man/sits_clean.Rd | 4 +- man/sits_colors.Rd | 10 +++- man/sits_combine_predictions.Rd | 20 ++++++- man/sits_cube.Rd | 59 +++++++++++-------- man/sits_cube_copy.Rd | 17 ++++-- man/sits_get_class.Rd | 3 +- man/sits_get_data.Rd | 4 +- tests/testthat/test-check.R | 29 ++++----- tests/testthat/test-color.R | 13 +++- tests/testthat/test-config.R | 8 +-- 43 files changed, 290 insertions(+), 200 deletions(-) diff --git a/R/api_check.R b/R/api_check.R index aee5b8759..8bbbafb79 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -201,7 +201,7 @@ if (is.null(local_msg)) msg <- paste0(caller, ": ", msg) else - msg <- paste0(caller, ": ", local_msg, " - ", msg) + msg <- paste0(caller, ": ", local_msg) # process message stop(msg, call. = FALSE) } diff --git a/R/api_dtw.R b/R/api_dtw.R index 9108562ad..e5fcc7c25 100644 --- a/R/api_dtw.R +++ b/R/api_dtw.R @@ -123,7 +123,7 @@ detections_name <- names(detections_idx) # For each label, extract the metadata where they had # minimal distance - purrr::map_df(seq_len(length(detections_idx)), function(idx) { + purrr::map_df(seq_along(detections_idx), function(idx) { # Extract detection name and inced detection_name <- detections_name[idx] detection_idx <- detections_idx[idx] diff --git a/R/api_environment.R b/R/api_environment.R index fdc349aa7..5173a83fa 100644 --- a/R/api_environment.R +++ b/R/api_environment.R @@ -20,7 +20,7 @@ env_prefix <- env_config[["name"]] env_variables <- env_config[["variables"]] - purrr::map(seq_len(env_variables), function(var_idx) { + purrr::map(seq_along(env_variables), function(var_idx) { var_source <- names(env_variables)[[var_idx]] var_target <- unname(env_variables)[[var_idx]] # Get current value of the target variable @@ -64,7 +64,7 @@ env_prefix <- env_config[["name"]] env_variables <- env_config[["variables"]] - purrr::map(seq_len(env_variables), function(var_idx) { + purrr::map(seq_along(env_variables), function(var_idx) { var_source <- names(env_variables)[[var_idx]] var_target <- unname(env_variables)[[var_idx]] # Get current value of the target variable diff --git a/R/api_merge.R b/R/api_merge.R index 513ff9a08..0e2344a9a 100644 --- a/R/api_merge.R +++ b/R/api_merge.R @@ -245,11 +245,11 @@ t2_date <- list() # Get overlapped dates - for (i in seq_len(length(t2))) { + for (i in seq_along(t2)) { t2_int <- lubridate::interval( lubridate::ymd(t2[i]), lubridate::ymd(t2[i]) + t2_period - 1 ) - overlapped_dates <- lapply(seq_len(length(t1)), function(j) { + overlapped_dates <- lapply(seq_along(t1), function(j) { t1_int <- lubridate::interval( lubridate::ymd(t1[j]), lubridate::ymd(t1[j]) + t1_period - 1 ) diff --git a/R/api_plot_raster.R b/R/api_plot_raster.R index e8d21cb82..de8009e61 100644 --- a/R/api_plot_raster.R +++ b/R/api_plot_raster.R @@ -354,7 +354,7 @@ .check_set_caller(".plot_probs") # get all labels to be plotted labels <- .tile_labels(tile) - names(labels) <- seq_len(length(labels)) + names(labels) <- seq_along(labels) # check the labels to be plotted # if NULL, use all labels if (.has_not(labels_plot)) { diff --git a/R/api_plot_vector.R b/R/api_plot_vector.R index 63f3b1de0..6d8a533ef 100644 --- a/R/api_plot_vector.R +++ b/R/api_plot_vector.R @@ -77,7 +77,7 @@ .check_palette(palette) # get all labels to be plotted labels <- .tile_labels(tile) - names(labels) <- seq_len(length(labels)) + names(labels) <- seq_along(labels) # check the labels to be plotted # if NULL, use all labels if (.has_not(labels_plot)) { diff --git a/R/api_regularize.R b/R/api_regularize.R index 268192210..c33eca636 100644 --- a/R/api_regularize.R +++ b/R/api_regularize.R @@ -69,7 +69,7 @@ .discard(assets, "tile") ) # Compare to original timeline - origin_tl <- timeline[seq_len(length(timeline) - 1)] + origin_tl <- timeline[seq_along(timeline) - 1] empty_dates <- as.Date(setdiff(origin_tl, unique(assets[["feature"]]))) temp_date <- assets[1, "feature"][[1]] empty_files <- purrr::map_dfr(empty_dates, function(date) { diff --git a/R/sits_accuracy.R b/R/sits_accuracy.R index 4236b785d..9e25332c3 100644 --- a/R/sits_accuracy.R +++ b/R/sits_accuracy.R @@ -1,25 +1,21 @@ -#' @title Assess classification accuracy (area-weighted method) +#' @title Assess classification accuracy #' @name sits_accuracy #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} #' @description This function calculates the accuracy of the classification #' result. The input is either a set of classified time series or a classified -#' data cube. -#' -#' Classified time series are produced by \code{\link[sits]{sits_classify}}. +#' data cube. Classified time series are produced by \code{\link[sits]{sits_classify}}. #' Classified images are generated using \code{\link[sits]{sits_classify}} #' followed by \code{\link[sits]{sits_label_classification}}. #' #' For a set of time series, \code{sits_accuracy} creates a confusion matrix and -#' calculates the resulting statistics using package \code{caret}. -#' -#' For a classified image, the function uses an area-weighted technique +#' calculates the resulting statistics using package \code{caret}. For a +#' classified image, the function uses an area-weighted technique #' proposed by Olofsson et al. according to referenes [1-3] to produce reliable -#' accuracy estimates at 95% confidence level. -#' -#' In both cases, it provides an accuracy assessment of the classified, +#' accuracy estimates at 95\% confidence level. In both cases, it provides +#' an accuracy assessment of the classified, #' including Overall Accuracy, Kappa, User's Accuracy, Producer's Accuracy -#' and error matrix (confusion matrix) +#' and error matrix (confusion matrix). #' #' @references #' [1] Olofsson, P., Foody, G.M., Stehman, S.V., Woodcock, C.E. (2013). diff --git a/R/sits_add_base_cube.R b/R/sits_add_base_cube.R index 3822637f8..2fcb692c0 100644 --- a/R/sits_add_base_cube.R +++ b/R/sits_add_base_cube.R @@ -76,7 +76,7 @@ sits_add_base_cube <- function(cube1, cube2) { tile_cube1_tl <- .tile_timeline(tile_cube1) tile_cube2_tl <- .tile_timeline(tile_cube2) # align timelines - fi_cube2[["date"]] <- tile_cube1_tl[seq_len(tile_cube2_tl)] + fi_cube2[["date"]] <- tile_cube1_tl[seq_along(tile_cube2_tl)] # update 2nd cube files .fi(tile_cube2) <- fi_cube2 # append cube to base info diff --git a/R/sits_classify.R b/R/sits_classify.R index 05db37133..2f64f2741 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -8,15 +8,17 @@ #' @description #' This function classifies a set of time series or data cube given #' a trained model prediction model created by \code{\link[sits]{sits_train}}. -#' #' SITS supports the following models: -#' (a) support vector machines: \code{\link[sits]{sits_svm}}; -#' (b) random forests: \code{\link[sits]{sits_rfor}}; -#' (c) extreme gradient boosting: \code{\link[sits]{sits_xgboost}}; -#' (d) multi-layer perceptrons: \code{\link[sits]{sits_mlp}}; -#' (e) 1D CNN: \code{\link[sits]{sits_tempcnn}}; -#' (f) self-attention encoders: \code{\link[sits]{sits_lighttae}} and -#' \code{\link[sits]{sits_tae}} +#' \enumerate{ +#' \item{support vector machines: \code{\link[sits]{sits_svm}};} +#' \item{random forests: \code{\link[sits]{sits_rfor}};} +#' \item{extreme gradient boosting: \code{\link[sits]{sits_xgboost}};} +#' \item{multi-layer perceptrons: \code{\link[sits]{sits_mlp}};} +#' \item{temporal CNN: \code{\link[sits]{sits_tempcnn}};} +#' \item{temporal self-attention encoders: \code{\link[sits]{sits_lighttae}} and +#' \code{\link[sits]{sits_tae}}.} +#' } + #' #' @param data Data cube (tibble of class "raster_cube") #' @param ml_model R model trained by \code{\link[sits]{sits_train}} @@ -61,22 +63,29 @@ #' \enumerate{ #' \item{A set of time series. The output is the same set #' with the additional column \code{predicted}.} -#' \item{A raster data cube. The output is a probability cube, +#' \item{A regularized raster data cube. The output is a probability cube, #' which has the same tiles as the raster cube. Each tile contains #' a multiband image; each band contains the probability that -#' each pixel belongs to a given class.} +#' each pixel belongs to a given class. +#' Probability cubes are objects of class "probs_cube".} #' \item{A vector data cube. Vector data cubes are produced when #' closed regions are obtained from raster data cubes using #' \code{\link[sits]{sits_segment}}. Classification of a vector #' data cube produces a vector data structure with additional -#' columns expressing the class probabilities for each object.} +#' columns expressing the class probabilities for each object. +#' Probability cubes for vector data cubes +#' are objects of class "probs_vector_cube".} #' } #' -#' The \code{roi} parameter defines a region of interest. It can be -#' an sf_object, a shapefile, or a bounding box vector in WGS84 with -#' named XY values (\code{xmin}, \code{xmax}, \code{ymin}, \code{ymax}) or -#' named lat/long values (\code{lon_min}, \code{lon_max}, -#' \code{lat_min}, \code{lat_max}) +#' The \code{roi} parameter defines a region of interest. Either: +#' \enumerate{ +#' \item{A path to a shapefile with polygons;} +#' \item{An \code{sf} object with POLYGON or MULTIPOLYGON geometry;} +#' \item{A named XY vector (\code{xmin}, \code{xmax}, \code{ymin}, +#' \code{ymax}) in WGS84;} +#' \item{A name lat/long vector (\code{lon_min}, \code{lon_max}, +#' \code{lat_min}, \code{lat_max}); } +#' } #' #' Parameter \code{filter_fn} parameter specifies a smoothing filter #' to be applied to each time series for reducing noise. Currently, options @@ -94,7 +103,8 @@ #' #' Parameter \code{exclusion_mask} defines a region that will not be #' classify. The region can be defined by multiple polygons. -#' Use an sf object or a shapefile to define it. +#' Either a path to a shapefile with polygons or +#' a \code{sf} object with POLYGON or MULTIPOLYGON geometry; #' #' When using a GPU for deep learning, \code{gpu_memory} indicates the #' memory of the graphics card which is available for processing. diff --git a/R/sits_clean.R b/R/sits_clean.R index e9dd9b25a..f04cd62b3 100644 --- a/R/sits_clean.R +++ b/R/sits_clean.R @@ -7,7 +7,9 @@ #' @description #' Applies a modal function to clean up possible noisy pixels keeping #' the most frequently values within the neighborhood. -#' In a tie, the first value of the vector is considered. +#' In a tie, the first value of the vector is considered. Modal functions +#' applied to classified cubes are useful to remove salt-and-pepper noise +#' in the result. #' #' @param cube Classified data cube (tibble of class "class_cube"). #' @param window_size An odd integer representing the size of the diff --git a/R/sits_colors.R b/R/sits_colors.R index 1907287b6..3bdc6a607 100644 --- a/R/sits_colors.R +++ b/R/sits_colors.R @@ -2,9 +2,17 @@ #' @name sits_colors #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @param legend One of the accepted legends in sits -#' @description Returns a color table +#' @description Returns the default color table. #' @return A tibble with color names and values #' +#' @note +#' SITS has a predefined color palette with 238 class names. +#' These colors are grouped by typical legends used by the Earth observation +#' community, which include “IGBP”, “UMD”, “ESA_CCI_LC”, and “WORLDCOVER”. +#' Use \code{\link[sits]{sits_colors_show()}} to see a specific palette. +#' The default color table can be extended using +#' \code{\link[sits]{sits_colors_set()}}. +#' #' #' @examples #' if (sits_run_examples()) { diff --git a/R/sits_combine_predictions.R b/R/sits_combine_predictions.R index 2e4f03803..bc814e634 100644 --- a/R/sits_combine_predictions.R +++ b/R/sits_combine_predictions.R @@ -24,10 +24,25 @@ #' @return A combined probability cube (tibble of class "probs_cube"). #' #' @description Calculate an ensemble predictor based a list of probability -#' cubes. The function combines the output of two or more classifier -#' to derive a value which is based on weights assigned to each model. +#' cubes. The function combines the output of two or more models +#' to derive a weighted average. #' The supported types of ensemble predictors are 'average' and -#' 'uncertainty'. +#' 'uncertainty'. In the latter case, the uncertainty cubes need to +#' be provided using param \code{uncert_cubes}. +#' +#' @note +#' The distribution of class probabilities produced by machine learning +#' models such as random forest +#' is quite different from that produced by deep learning models +#' such as temporal CNN. Combining the result of two different models +#' is recommended to remove possible bias induced by a single model. +#' +#' By default, the function takes the average of the class probabilities +#' of two or more model results. If desired, users can use the uncertainty +#' estimates for each results to compute the weights for each pixel. +#' In this case, the uncertainities produced by the models for each pixel +#' are used to compute the weights for producing the combined result. +#' #' #' @examples #' if (sits_run_examples()) { diff --git a/R/sits_cube.R b/R/sits_cube.R index 22a332f49..1412956c3 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -65,58 +65,65 @@ #' #' @note{ #' -#' In \code{sits}, a data cube is represented a tibble with metadata +#' In \code{sits}, a data cube is represented as a tibble with metadata #' describing a set of image files obtained from cloud providers. #' It contains information about each individual file. #' -#' In conceptual terms, \code{sits} defines a data cube as: +#' A data cube in \code{sits} is: #' \enumerate{ #' \item{A set of images organized in tiles of a grid system (e.g., MGRS).} #' \item{Each tile contains single-band images in a #' unique zone of the coordinate system (e.g, tile 20LMR in MGRS grid) -#' covering a user-specified time period.} -#' \item{Each image of a tile is associated to a temporal interval. +#' covering the period between \code{start_date} and \code{end_date}.} +#' \item{Each image of a tile is associated to a unique temporal interval. #' All intervals share the same spectral bands.} #' \item{Different tiles may cover different zones of the same grid system.} #' } -#' In \code{sits}, a regular data cube is a data cube where: +#' A regular data cube is a data cube where: #' \enumerate{ #' \item{All tiles share the same set of regular temporal intervals.} -#' \item{All tiles share the same set of spectral bands and indices.} -#' \item{All images of all tiles have the same spatial resolution.} +#' \item{All tiles share the same spectral bands and indices.} +#' \item{All images have the same spatial resolution.} #' \item{Each location in a tile is associated a set of multi-band time series.} -#' \item{For each interval and band, the cube is associated to a 2D image.} +#' \item{For each tile, interval and band, the cube is associated to a 2D image.} #' } #' #' Data cubes are identified on cloud providers using \code{sits_cube}. -#' The result of \code{sits_cube} is only a description of the location -#' of the required data in the cloud provider. No download is done. +#' The result of \code{sits_cube} is a description of the location +#' of the requested data in the cloud provider. No download is done. #' #' To obtain regular data cubes, use \code{\link[sits]{sits_regularize}}. #' For faster performance, we suggest users #' copy data from cloud providers to local disk using \code{sits_cube_copy} #' before regularization. #' -#' To create cubes from cloud providers, users need to inform: +#' To create data cube objects from cloud providers, users need to inform: #' \enumerate{ -#' \item \code{source}: One of "AWS", "BDC", "CDSE", "DEAFRICA", "DEAUSTRALIA", -#' "HLS", "PLANETSCOPE", "MPC", "SDC", "TERRASCOPE", or "USGS"; -#' \item \code{collection}: Collection available in the cloud provider. +#' \item{\code{source}: Name of the cloud provider. +#' One of "AWS", "BDC", "CDSE", "DEAFRICA", "DEAUSTRALIA", +#' "HLS", "PLANETSCOPE", "MPC", "SDC", "TERRASCOPE", or "USGS";} +#' \item{\code{collection}: Name of an image collection available +#' in the cloud provider (e.g, "SENTINEL-1-RTC" in MPC). #' Use \code{\link{sits_list_collections}()} to see which -#' collections are supported; -#' \item \code{tiles}: A set of tiles defined according to the collection -#' tiling grid; -#' \item \code{roi}: Region of interest. Either -#' a shapefile, a named \code{vector} (\code{"lon_min"}, -#' \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84, a -#' \code{sfc} or \code{sf} object from sf package in WGS84 projection. -#' A named \code{vector} (\code{"xmin"}, \code{"xmax"}, -#' \code{"ymin"}, \code{"ymax"}) -#' or a \code{SpatExtent} from \code{terra}. XY vectors and -#' \code{SpatExtent} require the specification of parameter \code{crs}. +#' collections are supported;} +#' \item{ \code{tiles}: A set of tiles defined according to the collection +#' tiling grid (e.g, c("20LMR", "20LMP") in MGRS);} +#' \item{\code{roi}: Region of interest. Either: +#' \enumerate{ +#' \item{A path to a shapefile with polygons;} +#' \item{A \code{sfc} or \code{sf} object from \code{sf} package;} +#' \item{A \code{SpatExtent} object from \code{terra} package;} +#' \item{A named \code{vector} (\code{"lon_min"}, +#' \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84;} +#' \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, +#' \code{"ymin"}, \code{"ymax"}) with XY coordinates in WGS84.} +#' } +#' Defining a region of interest using \code{SpatExtent} +#' requires the \code{crs} parameter to be specified. +#' } #' } #' -#' The parameter \code{bands}, \code{start_date}, and \code{end_date} are +#' The parameters \code{bands}, \code{start_date}, and \code{end_date} are #' optional for cubes created from cloud providers. #' #' Either \code{tiles} or \code{roi} must be informed. The \code{tiles} diff --git a/R/sits_cube_copy.R b/R/sits_cube_copy.R index f08c8bdf7..7887d6d82 100644 --- a/R/sits_cube_copy.R +++ b/R/sits_cube_copy.R @@ -10,12 +10,17 @@ #' bands. #' #' @param cube A data cube (class "raster_cube") -#' @param roi Region of interest. -#' Either an sf_object, a shapefile, -#' or a bounding box vector with -#' named XY values ("xmin", "xmax", "ymin", "ymax") or -#' named lat/long values -#' ("lon_min", "lat_min", "lon_max", "lat_max"). +#' @param roi Region of interest. Either: +#' \enumerate{ +#' \item{A path to a shapefile with polygons;} +#' \item{A \code{sf} object from \code{sf} package;} +#' \item{A named \code{vector} (\code{"lon_min"}, +#' \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) +#' in WGS84;} +#' \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, +#' \code{"ymin"}, \code{"ymax"}) with XY coordinates +#' in WGS84.} +#' } #' @param res An integer value corresponds to the output #' spatial resolution of the images. Default is NULL. #' @param crs Reference system for output cube (by default, diff --git a/R/sits_get_class.R b/R/sits_get_class.R index 10c9b595a..df2e8cb7d 100644 --- a/R/sits_get_class.R +++ b/R/sits_get_class.R @@ -3,7 +3,9 @@ #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description Given a set of lat/long locations and a classified cube, -#' retrieve the class of each point. +#' retrieve the class of each point. This function is useful to obtian +#' values from classified cubes for accuracy estimates. +#' #' @note #' There are four ways of specifying data to be retrieved using the #' \code{samples} parameter: diff --git a/R/sits_get_data.R b/R/sits_get_data.R index 52c79cfc1..842e33dcb 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -6,8 +6,8 @@ #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @description Retrieve a set of time series from a data cube or from -#' a time series service. Data cubes and puts it in a "sits tibble". +#' @description Retrieve a set of time series from a data cube and +#' and puts the result in a "sits tibble". #' Sits tibbles are the main structures of sits package. #' They contain both the satellite image time series and their metadata. #' diff --git a/R/sits_histogram.R b/R/sits_histogram.R index 34aa57975..3b84659d0 100644 --- a/R/sits_histogram.R +++ b/R/sits_histogram.R @@ -190,7 +190,7 @@ hist.probs_cube <- function(x, ..., # recover all labels all_labels <- .tile_labels(tile) - layers <- seq_len(length(all_labels)) + layers <- seq_along(all_labels) names(layers) <- all_labels # read file r <- .raster_open_rast(probs_file) diff --git a/R/sits_plot.R b/R/sits_plot.R index 44487920d..43a7a9b77 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -1779,7 +1779,7 @@ plot.som_map <- function(x, y, ..., if (.has(band)) { .check_band_in_bands(band, bands) # create a numeric vector for plotting - bands_koh <- seq_len(length(bands)) + bands_koh <- seq_along(bands) names(bands_koh) <- bands whatmap <- bands_koh[[band]] } else { diff --git a/R/sits_view.R b/R/sits_view.R index 2bd234723..6bfc2db64 100644 --- a/R/sits_view.R +++ b/R/sits_view.R @@ -574,7 +574,7 @@ sits_view.probs_cube <- function(x, ..., # get all labels to be plotted labels <- .tile_labels(cube) - names(labels) <- seq_len(length(labels)) + names(labels) <- seq_along(labels) # create a new layer in the leaflet for (i in seq_len(nrow(cube))) { diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index 11cffeb16..52da8be90 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -105,7 +105,7 @@ .check_window_size: "window_size must be an odd number" .check_validation_file: "invalid or missing CSV validation file for accuracy assessment" .check_vector_object: "segmentation did not produce a valid vector object" -.check_version: "version should a lower case character vector with no underlines" +.check_version: "version should be a lower case character vector with no underlines" .accuracy_area_assess: "validation data has more classes than labelled cube" .apply: "invalid column name" .as_crs: "invalid CRS value" @@ -515,3 +515,4 @@ summary_raster_cube: "check that input is regular data cube" summary_derived_cube: "check that input is probability data cube" summary_class_cube: "check that input is classified data cube" summary_class_cube_area: "some classes have no area: " +expect_error: "called from expect_error" diff --git a/inst/extdata/sources/config_source_aws.yml b/inst/extdata/sources/config_source_aws.yml index 23de9dfe2..5307411b7 100644 --- a/inst/extdata/sources/config_source_aws.yml +++ b/inst/extdata/sources/config_source_aws.yml @@ -80,7 +80,7 @@ sources: 9 : "cloud high" 10 : "thin cirrus" 11 : "snow or ice" - interp_values: [0, 1, 2, 3, 8, 9, 10, 11] + interp_values: [0, 1, 2, 3, 8, 9, 10] resolution : 20 data_type : "INT1U" satellite : "SENTINEL-2" @@ -171,7 +171,7 @@ sources: 9 : "cloud high" 10 : "thin cirrus" 11 : "snow or ice" - interp_values: [0, 1, 2, 3, 7, 8, 9, 10, 11] + interp_values: [0, 1, 2, 3, 7, 8, 9, 10] resolution : 20 data_type : "INT1U" satellite : "SENTINEL-2" @@ -238,7 +238,7 @@ sources: 13 : "Medium/High confidence of snow" 14 : "Low/High confidence of cirrus" 15 : "Medium/High confidence of cirrus" - interp_values : [0, 1, 2, 3, 4, 5, 9, 11, 13, 15] + interp_values : [0, 1, 2, 3, 4, 9, 11, 14, 15] resampling : "near" resolution : 30 data_type : "INT2U" diff --git a/inst/extdata/sources/config_source_bdc.yml b/inst/extdata/sources/config_source_bdc.yml index 0b6194dac..45783c3e6 100644 --- a/inst/extdata/sources/config_source_bdc.yml +++ b/inst/extdata/sources/config_source_bdc.yml @@ -216,7 +216,7 @@ sources: 13 : "Medium/High confidence of snow" 14 : "Low/High confidence of cirrus" 15 : "Medium/High confidence of cirrus" - interp_values : [0, 1, 2, 3, 4, 5, 9, 11, 13, 15] + interp_values : [0, 1, 2, 3, 4, 9, 11, 15] resolution : 30 resampling : "near" data_type : "INT2U" @@ -276,7 +276,7 @@ sources: 2 : "Target covered with snow/ice" 3 : "Target not visible, covered with cloud" 255 : "Fill/No Data-Not Processed" - interp_values : [2, 3, 255] + interp_values : [3, 255] resolution : 231.656 data_type : "INT1U" satellite : "TERRA" @@ -375,7 +375,7 @@ sources: 9 : "cloud high" 10 : "thin cirrus" 11 : "snow or ice" - interp_values: [0, 1, 2, 3, 8, 9, 10, 11] + interp_values: [0, 1, 2, 3, 8, 9, 10] resolution : 10 data_type : "INT1U" satellite : "SENTINEL-2" diff --git a/inst/extdata/sources/config_source_cdse.yml b/inst/extdata/sources/config_source_cdse.yml index 89c55a0f2..c2ee58dee 100644 --- a/inst/extdata/sources/config_source_cdse.yml +++ b/inst/extdata/sources/config_source_cdse.yml @@ -123,7 +123,7 @@ sources: 9 : "cloud high" 10 : "thin cirrus" 11 : "snow or ice" - interp_values : [0, 1, 2, 3, 8, 9, 10, 11] + interp_values : [0, 1, 2, 3, 8, 9, 10] resolution : 20 data_type : "INT1U" pattern : ".*SCL_20m\\.jp2$" diff --git a/inst/extdata/sources/config_source_chile.yml b/inst/extdata/sources/config_source_chile.yml index bb25409e0..d04ee2d0b 100644 --- a/inst/extdata/sources/config_source_chile.yml +++ b/inst/extdata/sources/config_source_chile.yml @@ -80,7 +80,7 @@ sources: 9 : "cloud high" 10 : "thin cirrus" 11 : "snow or ice" - interp_values: [0, 1, 2, 3, 8, 9, 10, 11] + interp_values: [0, 1, 2, 3, 8, 9, 10] resolution : 20 data_type : "INT1U" satellite : "SENTINEL-2" diff --git a/inst/extdata/sources/config_source_deafrica.yml b/inst/extdata/sources/config_source_deafrica.yml index 02c4557b7..7191d2fb1 100644 --- a/inst/extdata/sources/config_source_deafrica.yml +++ b/inst/extdata/sources/config_source_deafrica.yml @@ -124,7 +124,7 @@ sources: 13 : "Snow/Ice Confidence" 14 : "Unused" 15 : "Unused" - interp_values: [0, 1, 3, 4, 5] + interp_values: [0, 1, 3, 4] satellite : "LANDSAT-5" sensor : "TM-MSS" collection_name : "ls5_sr" @@ -187,7 +187,7 @@ sources: 13 : "Snow/Ice Confidence" 14 : "Unused" 15 : "Unused" - interp_values: [0, 1, 3, 4, 5] + interp_values: [0, 1, 3, 4] satellite : "LANDSAT-7" sensor : "ETM" collection_name : "ls7_sr" @@ -246,7 +246,7 @@ sources: 11 : "High confidence of cloud shadow" 13 : "High confidence of snow" 15 : "High confidence of cirrus" - interp_values : [0, 1, 2, 3, 4, 5] + interp_values : [0, 1, 2, 3, 4] resampling : "near" resolution : 30 data_type : "INT2U" @@ -315,7 +315,7 @@ sources: 13 : "Snow/Ice Confidence" 14 : "Cirrus Confidence" 15 : "Cirrus Confidence" - interp_values : [0, 1, 2, 3, 4, 5] + interp_values : [0, 1, 2, 3, 4, 9, 11, 15] satellite : "LANDSAT-9" sensor : "OLI" collection_name : "ls9_sr" @@ -513,7 +513,7 @@ sources: 9 : "cloud high" 10 : "thin cirrus" 11 : "snow or ice" - interp_values : [0, 1, 2, 3, 8, 9, 10, 11] + interp_values : [0, 1, 2, 3, 8, 9, 10] resolution : 20 data_type : "INT1U" satellite : "SENTINEL-2" diff --git a/inst/extdata/sources/config_source_deaustralia.yml b/inst/extdata/sources/config_source_deaustralia.yml index 9d7a0d61a..5eed7384d 100644 --- a/inst/extdata/sources/config_source_deaustralia.yml +++ b/inst/extdata/sources/config_source_deaustralia.yml @@ -45,7 +45,7 @@ sources: 3 : "Shadow" 4 : "Snow" 5 : "Water" - interp_values : [0, 2, 3, 4] + interp_values : [0, 2, 3] resampling : "near" resolution : 30 data_type : "INT2U" @@ -103,7 +103,7 @@ sources: 3 : "Shadow" 4 : "Snow" 5 : "Water" - interp_values : [0, 2, 3, 4] + interp_values : [0, 2, 3] resampling : "near" resolution : 30 data_type : "INT2U" @@ -165,7 +165,7 @@ sources: 3 : "Shadow" 4 : "Snow" 5 : "Water" - interp_values : [0, 2, 3, 4] + interp_values : [0, 2, 3] resampling : "near" resolution : 30 data_type : "INT2U" @@ -226,7 +226,7 @@ sources: 3 : "Shadow" 4 : "Snow" 5 : "Water" - interp_values : [0, 2, 3, 4] + interp_values : [0, 2, 3] resampling : "near" resolution : 30 data_type : "INT2U" @@ -307,7 +307,7 @@ sources: 3 : "Shadow" 4 : "Snow" 5 : "Water" - interp_values : [0, 2, 3, 4] + interp_values : [0, 2, 3] resampling : "near" resolution : 10 data_type : "INT2U" @@ -389,7 +389,7 @@ sources: 3 : "Shadow" 4 : "Snow" 5 : "Water" - interp_values : [0, 2, 3, 4] + interp_values : [0, 2, 3] resampling : "near" resolution : 10 data_type : "INT2U" diff --git a/inst/extdata/sources/config_source_hls.yml b/inst/extdata/sources/config_source_hls.yml index c03e8ddbd..64ca7a90e 100644 --- a/inst/extdata/sources/config_source_hls.yml +++ b/inst/extdata/sources/config_source_hls.yml @@ -67,7 +67,7 @@ sources: 5 : "Water" 6 : "Aerosol level (low)" 7 : "Aerosol level (moderate or high)" - interp_values : [1, 2, 3, 4, 7] + interp_values : [1, 2, 3, 7] resampling : "near" resolution : 30 data_type : "INT1U" @@ -125,7 +125,7 @@ sources: 5 : "Water" 6 : "Aerosol level (low)" 7 : "Aerosol level (moderate or high)" - interp_values : [1, 2, 3, 4, 7] + interp_values : [1, 2, 3, 7] resampling : "near" resolution : 30 data_type : "INT1U" diff --git a/inst/extdata/sources/config_source_mpc.yml b/inst/extdata/sources/config_source_mpc.yml index 5de374364..6055cd7de 100644 --- a/inst/extdata/sources/config_source_mpc.yml +++ b/inst/extdata/sources/config_source_mpc.yml @@ -51,7 +51,7 @@ sources: 2 : "Target covered with snow/ice" 3 : "Target not visible, covered with cloud" 255 : "Fill/No Data-Not Processed" - interp_values : [2, 3, 255] + interp_values : [3, 255] resolution : 231.656 data_type : "INT1U" satellite : "TERRA" @@ -193,7 +193,7 @@ sources: 13 : "Medium/High confidence of snow" 14 : "Low/High confidence of cirrus" 15 : "Medium/High confidence of cirrus" - interp_values : [0, 1, 2, 3, 4, 5, 9, 11, 13, 15] + interp_values : [0, 1, 2, 3, 4, 9, 11, 15] resampling : "near" resolution : 30 data_type : "INT2U" @@ -284,7 +284,7 @@ sources: 9 : "cloud high" 10 : "thin cirrus" 11 : "snow or ice" - interp_values : [0, 1, 2, 3, 8, 9, 10, 11] + interp_values : [0, 1, 2, 3, 8, 9, 10] resolution : 20 data_type : "INT1U" satellite : "SENTINEL-2" diff --git a/inst/extdata/sources/config_source_sdc.yml b/inst/extdata/sources/config_source_sdc.yml index cc4a1106f..c6e3b7526 100644 --- a/inst/extdata/sources/config_source_sdc.yml +++ b/inst/extdata/sources/config_source_sdc.yml @@ -68,7 +68,7 @@ sources: 9 : "cloud high" 10 : "thin cirrus" 11 : "snow or ice" - interp_values : [0, 1, 2, 3, 8, 9, 10, 11] + interp_values : [0, 1, 2, 3, 8, 9, 10] resolution : 20 data_type : "INT1U" satellite : "SENTINEL-2" diff --git a/inst/extdata/sources/config_source_usgs.yml b/inst/extdata/sources/config_source_usgs.yml index 930bb53f6..a9ffd3c16 100644 --- a/inst/extdata/sources/config_source_usgs.yml +++ b/inst/extdata/sources/config_source_usgs.yml @@ -56,7 +56,7 @@ sources: 13 : "Medium/High confidence of snow" 14 : "Low/High confidence of cirrus" 15 : "Medium/High confidence of cirrus" - interp_values : [0, 1, 2, 3, 4, 5, 9, 11, 13, 15] + interp_values : [0, 1, 2, 3, 4, 9, 11, 15] resampling : "near" resolution : 30 data_type : "INT2U" diff --git a/man/sits_accuracy.Rd b/man/sits_accuracy.Rd index 2e1fb989e..37f0d62c6 100644 --- a/man/sits_accuracy.Rd +++ b/man/sits_accuracy.Rd @@ -9,7 +9,7 @@ \alias{sits_accuracy.derived_cube} \alias{sits_accuracy.tbl_df} \alias{sits_accuracy.default} -\title{Assess classification accuracy (area-weighted method)} +\title{Assess classification accuracy} \usage{ sits_accuracy(data, ...) @@ -57,22 +57,18 @@ directly on the screen. \description{ This function calculates the accuracy of the classification result. The input is either a set of classified time series or a classified -data cube. - -Classified time series are produced by \code{\link[sits]{sits_classify}}. +data cube. Classified time series are produced by \code{\link[sits]{sits_classify}}. Classified images are generated using \code{\link[sits]{sits_classify}} followed by \code{\link[sits]{sits_label_classification}}. For a set of time series, \code{sits_accuracy} creates a confusion matrix and -calculates the resulting statistics using package \code{caret}. - -For a classified image, the function uses an area-weighted technique +calculates the resulting statistics using package \code{caret}. For a +classified image, the function uses an area-weighted technique proposed by Olofsson et al. according to referenes [1-3] to produce reliable -accuracy estimates at 95% confidence level. - -In both cases, it provides an accuracy assessment of the classified, +accuracy estimates at 95\% confidence level. In both cases, it provides +an accuracy assessment of the classified, including Overall Accuracy, Kappa, User's Accuracy, Producer's Accuracy -and error matrix (confusion matrix) +and error matrix (confusion matrix). } \note{ The `validation` data needs to contain the following columns: "latitude", diff --git a/man/sits_classify.Rd b/man/sits_classify.Rd index fe705ff26..eade0c2d0 100644 --- a/man/sits_classify.Rd +++ b/man/sits_classify.Rd @@ -129,15 +129,16 @@ Time series with predicted labels for \description{ This function classifies a set of time series or data cube given a trained model prediction model created by \code{\link[sits]{sits_train}}. - SITS supports the following models: -(a) support vector machines: \code{\link[sits]{sits_svm}}; -(b) random forests: \code{\link[sits]{sits_rfor}}; -(c) extreme gradient boosting: \code{\link[sits]{sits_xgboost}}; -(d) multi-layer perceptrons: \code{\link[sits]{sits_mlp}}; -(e) 1D CNN: \code{\link[sits]{sits_tempcnn}}; -(f) self-attention encoders: \code{\link[sits]{sits_lighttae}} and - \code{\link[sits]{sits_tae}} +\enumerate{ +\item{support vector machines: \code{\link[sits]{sits_svm}};} +\item{random forests: \code{\link[sits]{sits_rfor}};} +\item{extreme gradient boosting: \code{\link[sits]{sits_xgboost}};} +\item{multi-layer perceptrons: \code{\link[sits]{sits_mlp}};} +\item{temporal CNN: \code{\link[sits]{sits_tempcnn}};} +\item{temporal self-attention encoders: \code{\link[sits]{sits_lighttae}} and + \code{\link[sits]{sits_tae}}.} +} } \note{ The \code{sits_classify} function takes three types of data as input @@ -145,22 +146,29 @@ The \code{sits_classify} function takes three types of data as input \enumerate{ \item{A set of time series. The output is the same set with the additional column \code{predicted}.} - \item{A raster data cube. The output is a probability cube, + \item{A regularized raster data cube. The output is a probability cube, which has the same tiles as the raster cube. Each tile contains a multiband image; each band contains the probability that - each pixel belongs to a given class.} + each pixel belongs to a given class. + Probability cubes are objects of class "probs_cube".} \item{A vector data cube. Vector data cubes are produced when closed regions are obtained from raster data cubes using \code{\link[sits]{sits_segment}}. Classification of a vector data cube produces a vector data structure with additional - columns expressing the class probabilities for each object.} + columns expressing the class probabilities for each object. + Probability cubes for vector data cubes + are objects of class "probs_vector_cube".} } - The \code{roi} parameter defines a region of interest. It can be - an sf_object, a shapefile, or a bounding box vector in WGS84 with - named XY values (\code{xmin}, \code{xmax}, \code{ymin}, \code{ymax}) or - named lat/long values (\code{lon_min}, \code{lon_max}, - \code{lat_min}, \code{lat_max}) + The \code{roi} parameter defines a region of interest. Either: + \enumerate{ + \item{A path to a shapefile with polygons;} + \item{An \code{sf} object with POLYGON or MULTIPOLYGON geometry;} + \item{A named XY vector (\code{xmin}, \code{xmax}, \code{ymin}, + \code{ymax}) in WGS84;} + \item{A name lat/long vector (\code{lon_min}, \code{lon_max}, + \code{lat_min}, \code{lat_max}); } + } Parameter \code{filter_fn} parameter specifies a smoothing filter to be applied to each time series for reducing noise. Currently, options @@ -178,7 +186,8 @@ The \code{sits_classify} function takes three types of data as input Parameter \code{exclusion_mask} defines a region that will not be classify. The region can be defined by multiple polygons. - Use an sf object or a shapefile to define it. + Either a path to a shapefile with polygons or + a \code{sf} object with POLYGON or MULTIPOLYGON geometry; When using a GPU for deep learning, \code{gpu_memory} indicates the memory of the graphics card which is available for processing. diff --git a/man/sits_clean.Rd b/man/sits_clean.Rd index ba638b50f..2097cc437 100644 --- a/man/sits_clean.Rd +++ b/man/sits_clean.Rd @@ -84,7 +84,9 @@ A tibble with an classified map (class = "class_cube"). \description{ Applies a modal function to clean up possible noisy pixels keeping the most frequently values within the neighborhood. -In a tie, the first value of the vector is considered. +In a tie, the first value of the vector is considered. Modal functions +applied to classified cubes are useful to remove salt-and-pepper noise +in the result. } \examples{ if (sits_run_examples()) { diff --git a/man/sits_colors.Rd b/man/sits_colors.Rd index f82b8869f..4626e0bb2 100644 --- a/man/sits_colors.Rd +++ b/man/sits_colors.Rd @@ -13,7 +13,15 @@ sits_colors(legend = NULL) A tibble with color names and values } \description{ -Returns a color table +Returns the default color table. +} +\note{ +SITS has a predefined color palette with 238 class names. +These colors are grouped by typical legends used by the Earth observation +community, which include “IGBP”, “UMD”, “ESA_CCI_LC”, and “WORLDCOVER”. +Use \code{\link[sits]{sits_colors_show()}} to see a specific palette. +The default color table can be extended using +\code{\link[sits]{sits_colors_set()}}. } \examples{ if (sits_run_examples()) { diff --git a/man/sits_combine_predictions.Rd b/man/sits_combine_predictions.Rd index b2a9bdd93..9c4193bcd 100644 --- a/man/sits_combine_predictions.Rd +++ b/man/sits_combine_predictions.Rd @@ -64,10 +64,24 @@ A combined probability cube (tibble of class "probs_cube"). } \description{ Calculate an ensemble predictor based a list of probability -cubes. The function combines the output of two or more classifier -to derive a value which is based on weights assigned to each model. +cubes. The function combines the output of two or more models +to derive a weighted average. The supported types of ensemble predictors are 'average' and -'uncertainty'. +'uncertainty'. In the latter case, the uncertainty cubes need to +be provided using param \code{uncert_cubes}. +} +\note{ +The distribution of class probabilities produced by machine learning +models such as random forest +is quite different from that produced by deep learning models +such as temporal CNN. Combining the result of two different models +is recommended to remove possible bias induced by a single model. + +By default, the function takes the average of the class probabilities +of two or more model results. If desired, users can use the uncertainty +estimates for each results to compute the weights for each pixel. +In this case, the uncertainities produced by the models for each pixel +are used to compute the weights for producing the combined result. } \examples{ if (sits_run_examples()) { diff --git a/man/sits_cube.Rd b/man/sits_cube.Rd index 89dd1f91a..62816b99e 100644 --- a/man/sits_cube.Rd +++ b/man/sits_cube.Rd @@ -142,58 +142,65 @@ USGS Landsat (USGS). Data cubes can also be created using local files. \note{ { -In \code{sits}, a data cube is represented a tibble with metadata +In \code{sits}, a data cube is represented as a tibble with metadata describing a set of image files obtained from cloud providers. It contains information about each individual file. -In conceptual terms, \code{sits} defines a data cube as: +A data cube in \code{sits} is: \enumerate{ \item{A set of images organized in tiles of a grid system (e.g., MGRS).} \item{Each tile contains single-band images in a unique zone of the coordinate system (e.g, tile 20LMR in MGRS grid) - covering a user-specified time period.} -\item{Each image of a tile is associated to a temporal interval. + covering the period between \code{start_date} and \code{end_date}.} +\item{Each image of a tile is associated to a unique temporal interval. All intervals share the same spectral bands.} \item{Different tiles may cover different zones of the same grid system.} } -In \code{sits}, a regular data cube is a data cube where: +A regular data cube is a data cube where: \enumerate{ \item{All tiles share the same set of regular temporal intervals.} -\item{All tiles share the same set of spectral bands and indices.} -\item{All images of all tiles have the same spatial resolution.} +\item{All tiles share the same spectral bands and indices.} +\item{All images have the same spatial resolution.} \item{Each location in a tile is associated a set of multi-band time series.} -\item{For each interval and band, the cube is associated to a 2D image.} +\item{For each tile, interval and band, the cube is associated to a 2D image.} } Data cubes are identified on cloud providers using \code{sits_cube}. -The result of \code{sits_cube} is only a description of the location -of the required data in the cloud provider. No download is done. +The result of \code{sits_cube} is a description of the location +of the requested data in the cloud provider. No download is done. To obtain regular data cubes, use \code{\link[sits]{sits_regularize}}. For faster performance, we suggest users copy data from cloud providers to local disk using \code{sits_cube_copy} before regularization. -To create cubes from cloud providers, users need to inform: +To create data cube objects from cloud providers, users need to inform: \enumerate{ - \item \code{source}: One of "AWS", "BDC", "CDSE", "DEAFRICA", "DEAUSTRALIA", - "HLS", "PLANETSCOPE", "MPC", "SDC", "TERRASCOPE", or "USGS"; - \item \code{collection}: Collection available in the cloud provider. + \item{\code{source}: Name of the cloud provider. + One of "AWS", "BDC", "CDSE", "DEAFRICA", "DEAUSTRALIA", + "HLS", "PLANETSCOPE", "MPC", "SDC", "TERRASCOPE", or "USGS";} + \item{\code{collection}: Name of an image collection available + in the cloud provider (e.g, "SENTINEL-1-RTC" in MPC). Use \code{\link{sits_list_collections}()} to see which - collections are supported; - \item \code{tiles}: A set of tiles defined according to the collection - tiling grid; - \item \code{roi}: Region of interest. Either - a shapefile, a named \code{vector} (\code{"lon_min"}, - \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84, a - \code{sfc} or \code{sf} object from sf package in WGS84 projection. - A named \code{vector} (\code{"xmin"}, \code{"xmax"}, - \code{"ymin"}, \code{"ymax"}) - or a \code{SpatExtent} from \code{terra}. XY vectors and - \code{SpatExtent} require the specification of parameter \code{crs}. + collections are supported;} + \item{ \code{tiles}: A set of tiles defined according to the collection + tiling grid (e.g, c("20LMR", "20LMP") in MGRS);} + \item{\code{roi}: Region of interest. Either: + \enumerate{ + \item{A path to a shapefile with polygons;} + \item{A \code{sfc} or \code{sf} object from \code{sf} package;} + \item{A \code{SpatExtent} object from \code{terra} package;} + \item{A named \code{vector} (\code{"lon_min"}, + \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84;} + \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, + \code{"ymin"}, \code{"ymax"}) with XY coordinates in WGS84.} + } + Defining a region of interest using \code{SpatExtent} + requires the \code{crs} parameter to be specified. + } } -The parameter \code{bands}, \code{start_date}, and \code{end_date} are +The parameters \code{bands}, \code{start_date}, and \code{end_date} are optional for cubes created from cloud providers. Either \code{tiles} or \code{roi} must be informed. The \code{tiles} diff --git a/man/sits_cube_copy.Rd b/man/sits_cube_copy.Rd index 5892a2ab3..0b618eb32 100644 --- a/man/sits_cube_copy.Rd +++ b/man/sits_cube_copy.Rd @@ -18,12 +18,17 @@ sits_cube_copy( \arguments{ \item{cube}{A data cube (class "raster_cube")} -\item{roi}{Region of interest. -Either an sf_object, a shapefile, -or a bounding box vector with -named XY values ("xmin", "xmax", "ymin", "ymax") or -named lat/long values -("lon_min", "lat_min", "lon_max", "lat_max").} +\item{roi}{Region of interest. Either: +\enumerate{ +\item{A path to a shapefile with polygons;} +\item{A \code{sf} object from \code{sf} package;} +\item{A named \code{vector} (\code{"lon_min"}, + \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) + in WGS84;} +\item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, + \code{"ymin"}, \code{"ymax"}) with XY coordinates + in WGS84.} + }} \item{res}{An integer value corresponds to the output spatial resolution of the images. Default is NULL.} diff --git a/man/sits_get_class.Rd b/man/sits_get_class.Rd index 9392c12f9..a6319a618 100644 --- a/man/sits_get_class.Rd +++ b/man/sits_get_class.Rd @@ -38,7 +38,8 @@ A tibble of with columns } \description{ Given a set of lat/long locations and a classified cube, -retrieve the class of each point. +retrieve the class of each point. This function is useful to obtian +values from classified cubes for accuracy estimates. } \note{ There are four ways of specifying data to be retrieved using the diff --git a/man/sits_get_data.Rd b/man/sits_get_data.Rd index a64d58ac5..bbc22576e 100644 --- a/man/sits_get_data.Rd +++ b/man/sits_get_data.Rd @@ -140,8 +140,8 @@ A tibble of class "sits" with set of time series . } \description{ -Retrieve a set of time series from a data cube or from -a time series service. Data cubes and puts it in a "sits tibble". +Retrieve a set of time series from a data cube and +and puts the result in a "sits tibble". Sits tibbles are the main structures of sits package. They contain both the satellite image time series and their metadata. } diff --git a/tests/testthat/test-check.R b/tests/testthat/test-check.R index 653a358e5..274ff27db 100644 --- a/tests/testthat/test-check.R +++ b/tests/testthat/test-check.R @@ -5,57 +5,52 @@ test_that("Caller", { error_msg <- .conf("messages", ".test_check") expect_equal(error_msg, "expected error during testing") - # .check_null input <- NULL expect_error( .check_null_parameter(input), - ".test_check: NULL value not allowed for input - - expected error during testing" + ".test_check: NULL value not allowed for input" ) # .check_na input <- c(1, NA, 3) expect_error( .check_na_parameter(input), - ".test_check: NA value not allowed for input - - expected error during testing" + ".test_check: NA value not allowed for input" ) # .check_num_paramter input <- c(1, "MPC") expect_error( .check_num_parameter(input), - ".test_check: invalid input parameter - expected error during testing" + ".test_check: invalid input parameter" ) expect_error( .check_int_parameter(input), - ".test_check: invalid input parameter - expected error during testing" + ".test_check: invalid input parameter" ) input <- "TRUE" expect_error( .check_lgl_parameter(input), - ".test_check: invalid input parameter - expected error during testing" + ".test_check: invalid input parameter" ) expect_error( .check_date_parameter("2023-301-01"), - ".check_date_parameter: invalid date format - - dates should follow year-month-day: YYYY-MM-DD" + ".check_date_parameter: invalid date format - dates should follow year-month-day: YYYY-MM-DD" ) legends <- c("Pasture", "Cerrado", "Soy") expect_error( .check_chr_parameter(legends, len_max = 2), - ".test_check: invalid legends parameter - expected error during testing" + ".test_check: invalid legends parameter" ) sources <- .conf("sources") expect_error( .check_lst_parameter(sources, len_max = 4), - ".test_check: invalid sources parameter - expected error during testing" + ".test_check: invalid sources parameter" ) period <- "P2Y6M" expect_error( .check_period(period), - ".check_period: invalid period format - - valid examples are P16D, P1M, P1Y" + ".check_period: invalid period format - valid examples are P16D, P1M, P1Y" ) crs <- "EPSG:9999" expect_error( @@ -65,14 +60,12 @@ test_that("Caller", { output_dir <- paste0("/mydir/123/test") expect_error( .check_output_dir(output_dir), - ".check_output_dir: invalid output_dir variable - - file does not exist: '/mydir/123/test'" + ".check_output_dir: invalid output_dir variable" ) version <- c("1", "2") expect_error( .check_version(version), - ".check_version: version should be - lower case character vector with no underlines" + ".check_version: version should be a lower case character vector with no underlines" ) progress <- "TRUE" expect_error( diff --git a/tests/testthat/test-color.R b/tests/testthat/test-color.R index b647b0b54..0c5a54011 100644 --- a/tests/testthat/test-color.R +++ b/tests/testthat/test-color.R @@ -73,14 +73,25 @@ test_that("legend", { "Forest" = "forestgreen", "Cerrado" = "lightgreen", "Pasture" = "bisque2" ) + labels_2 <- c("Forest", "Cerrado", "Pasture", "Label") + + if (Sys.getenv("SITS_DOCUMENTATION_MODE") == "true" || + Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") { + doc_mode <- TRUE + Sys.setenv("SITS_DOCUMENTATION_MODE" = "FALSE") + } else + doc_mode <- FALSE + expect_warning({ expect_warning({ - .colors_get(labels, + .colors_get(labels_2, legend = def_legend_2, palette = "Set3", rev = TRUE ) }) }) + if (doc_mode) + Sys.setenv("SITS_DOCUMENTATION_MODE" = "TRUE") }) diff --git a/tests/testthat/test-config.R b/tests/testthat/test-config.R index 9762bafbf..628c39836 100644 --- a/tests/testthat/test-config.R +++ b/tests/testthat/test-config.R @@ -88,7 +88,7 @@ test_that("User functions", { expect_error( .source_check(source = "ZZZ"), - "invalid source parameter" + ".source_check: invalid source variable" ) expect_equal( @@ -108,14 +108,12 @@ test_that("User functions", { expect_error( .source_collection_check(source = "ZZZ", collection = "ZZZ"), - ".source_check: invalid source variable - invalid source parameter" + ".source_check: invalid source variable" ) expect_error( .source_collection_check(source = "TEST", collection = "ZZZ"), - ".source_collection_check: invalid collection variable - - collection is not available in data provider - or sits is not configured to access it" + ".source_collection_check: invalid collection variable" ) expect_equal( From b85d7efadaa927ee0b8a146b4a96fcf93d218d1c Mon Sep 17 00:00:00 2001 From: Gilberto Camara Date: Thu, 20 Mar 2025 14:29:02 -0300 Subject: [PATCH 060/122] fix sits_colors documentation --- R/sits_colors.R | 4 ++-- man/sits_colors.Rd | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/R/sits_colors.R b/R/sits_colors.R index 3bdc6a607..2c0920498 100644 --- a/R/sits_colors.R +++ b/R/sits_colors.R @@ -9,9 +9,9 @@ #' SITS has a predefined color palette with 238 class names. #' These colors are grouped by typical legends used by the Earth observation #' community, which include “IGBP”, “UMD”, “ESA_CCI_LC”, and “WORLDCOVER”. -#' Use \code{\link[sits]{sits_colors_show()}} to see a specific palette. +#' Use \code{\link[sits]{sits_colors_show}} to see a specific palette. #' The default color table can be extended using -#' \code{\link[sits]{sits_colors_set()}}. +#' \code{\link[sits]{sits_colors_set}}. #' #' #' @examples diff --git a/man/sits_colors.Rd b/man/sits_colors.Rd index 4626e0bb2..f45aa2921 100644 --- a/man/sits_colors.Rd +++ b/man/sits_colors.Rd @@ -19,9 +19,9 @@ Returns the default color table. SITS has a predefined color palette with 238 class names. These colors are grouped by typical legends used by the Earth observation community, which include “IGBP”, “UMD”, “ESA_CCI_LC”, and “WORLDCOVER”. -Use \code{\link[sits]{sits_colors_show()}} to see a specific palette. +Use \code{\link[sits]{sits_colors_show}} to see a specific palette. The default color table can be extended using -\code{\link[sits]{sits_colors_set()}}. +\code{\link[sits]{sits_colors_set}}. } \examples{ if (sits_run_examples()) { From 23ba4e43e109da22851b3b49e4912635e6a44ee8 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Thu, 20 Mar 2025 16:55:21 -0300 Subject: [PATCH 061/122] fix #1300 --- R/sits_classify.R | 2 +- R/sits_get_data.R | 5 ++--- man/sits_classify.Rd | 2 +- man/sits_get_data.Rd | 5 ++--- 4 files changed, 6 insertions(+), 8 deletions(-) diff --git a/R/sits_classify.R b/R/sits_classify.R index 2f64f2741..6d1e71717 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -400,7 +400,7 @@ sits_classify.segs_cube <- function(data, batch_size = 2^gpu_memory, output_dir, version = "v1", - n_sam_pol = NULL, + n_sam_pol = 15, verbose = FALSE, progress = TRUE) { diff --git a/R/sits_get_data.R b/R/sits_get_data.R index 842e33dcb..21fdb3cc0 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -7,9 +7,8 @@ #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Retrieve a set of time series from a data cube and -#' and puts the result in a "sits tibble". -#' Sits tibbles are the main structures of sits package. -#' They contain both the satellite image time series and their metadata. +#' and puts the result in a "sits tibble", which +#' contain both the satellite image time series and their metadata. #' #' @note #' There are four ways of specifying data to be retrieved using the diff --git a/man/sits_classify.Rd b/man/sits_classify.Rd index eade0c2d0..9be0d85be 100644 --- a/man/sits_classify.Rd +++ b/man/sits_classify.Rd @@ -59,7 +59,7 @@ sits_classify(data, ml_model, ...) batch_size = 2^gpu_memory, output_dir, version = "v1", - n_sam_pol = NULL, + n_sam_pol = 15, verbose = FALSE, progress = TRUE ) diff --git a/man/sits_get_data.Rd b/man/sits_get_data.Rd index bbc22576e..e0dc1b8f3 100644 --- a/man/sits_get_data.Rd +++ b/man/sits_get_data.Rd @@ -141,9 +141,8 @@ A tibble of class "sits" with set of time series } \description{ Retrieve a set of time series from a data cube and -and puts the result in a "sits tibble". -Sits tibbles are the main structures of sits package. -They contain both the satellite image time series and their metadata. +and puts the result in a "sits tibble", which +contain both the satellite image time series and their metadata. } \note{ There are four ways of specifying data to be retrieved using the From ba16ca7f2b4275be8f8c7dd36e728923b18d64fd Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Sat, 22 Mar 2025 16:58:52 -0300 Subject: [PATCH 062/122] first version of sits_as_stars --- DESCRIPTION | 2 + NAMESPACE | 1 + R/api_sf.R | 38 +--- R/api_shp.R | 4 - R/sits_get_data.R | 63 ++++--- R/sits_mixture_model.R | 2 +- R/sits_regularize.R | 5 - R/sits_sample_functions.R | 162 ------------------ R/sits_stars.R | 88 ++++++++++ R/sits_uncertainty.R | 162 ++++++++++++++++++ ...NETSCOPE_MOSAIC_604-1043_B1_2022-08-01.tif | Bin 0 -> 221 bytes ...NETSCOPE_MOSAIC_604-1043_B1_2022-09-01.tif | Bin 0 -> 221 bytes ...NETSCOPE_MOSAIC_604-1043_B1_2022-10-01.tif | Bin 0 -> 221 bytes ...NETSCOPE_MOSAIC_604-1043_B2_2022-08-01.tif | Bin 0 -> 221 bytes ...NETSCOPE_MOSAIC_604-1043_B2_2022-09-01.tif | Bin 0 -> 221 bytes ...NETSCOPE_MOSAIC_604-1043_B2_2022-10-01.tif | Bin 0 -> 221 bytes ...NETSCOPE_MOSAIC_604-1043_B3_2022-08-01.tif | Bin 0 -> 221 bytes ...NETSCOPE_MOSAIC_604-1043_B3_2022-09-01.tif | Bin 0 -> 221 bytes ...NETSCOPE_MOSAIC_604-1043_B3_2022-10-01.tif | Bin 0 -> 221 bytes ...NETSCOPE_MOSAIC_604-1043_B4_2022-08-01.tif | Bin 0 -> 221 bytes ...NETSCOPE_MOSAIC_604-1043_B4_2022-09-01.tif | Bin 0 -> 221 bytes ...NETSCOPE_MOSAIC_604-1043_B4_2022-10-01.tif | Bin 0 -> 221 bytes inst/extdata/config_messages.yml | 10 +- man/sits_as_stars.Rd | 57 ++++++ man/sits_get_data.Rd | 60 +++++-- man/sits_mixture_model.Rd | 2 +- man/sits_regularize.Rd | 12 +- man/sits_uncertainty_sampling.Rd | 2 +- tests/testthat/test-data.R | 24 +-- tests/testthat/test-sf.R | 2 - 30 files changed, 421 insertions(+), 275 deletions(-) create mode 100644 R/sits_stars.R create mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-08-01.tif create mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-09-01.tif create mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-10-01.tif create mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-08-01.tif create mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-09-01.tif create mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-10-01.tif create mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-08-01.tif create mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-09-01.tif create mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-10-01.tif create mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-08-01.tif create mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-09-01.tif create mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-10-01.tif create mode 100644 man/sits_as_stars.Rd diff --git a/DESCRIPTION b/DESCRIPTION index a034b8036..fc0e18f8f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -87,6 +87,7 @@ Suggests: RcppArmadillo (>= 0.12), scales, spdep, + stars, stringr, supercells (>= 1.0.0), testthat (>= 3.1.3), @@ -251,6 +252,7 @@ Collate: 'sits_sf.R' 'sits_smooth.R' 'sits_som.R' + 'sits_stars.R' 'sits_summary.R' 'sits_tae.R' 'sits_tempcnn.R' diff --git a/NAMESPACE b/NAMESPACE index 2eb534d73..f1d341e05 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -477,6 +477,7 @@ export(sits_accuracy_summary) export(sits_add_base_cube) export(sits_apply) export(sits_as_sf) +export(sits_as_stars) export(sits_bands) export(sits_bbox) export(sits_classify) diff --git a/R/api_sf.R b/R/api_sf.R index 1f3382a3e..6cacb5acd 100644 --- a/R/api_sf.R +++ b/R/api_sf.R @@ -9,8 +9,6 @@ #' @param start_date Start date for the data set. #' @param end_date End date for the data set. #' @param n_sam_pol Number of samples per polygon to be read. -#' @param pol_id ID attribute which contains label -#' (for POLYGON or MULTIPOLYGON shapefile). #' @param sampling_type Spatial sampling type: random, hexagonal, #' regular, or Fibonacci. #' @return A tibble with information the samples to be retrieved. @@ -21,7 +19,6 @@ start_date, end_date, n_sam_pol, - pol_id, sampling_type) { # set caller to show in errors .check_set_caller(".sf_get_samples") @@ -37,7 +34,6 @@ label_attr = label_attr, label = label, n_sam_pol = n_sam_pol, - pol_id = pol_id, sampling_type = sampling_type, start_date = start_date, end_date = end_date @@ -59,7 +55,6 @@ #' @param label Label to be assigned to points. #' @param n_sam_pol Number of samples per polygon to be read #' (for POLYGON or MULTIPOLYGON shapes). -#' @param pol_id ID attribute for polygons which contains the label #' @param sampling_type Spatial sampling type: random, hexagonal, #' regular, or Fibonacci. #' @param start_date Start of the interval for the time series @@ -71,7 +66,6 @@ label_attr, label, n_sam_pol, - pol_id, sampling_type, start_date, end_date) { @@ -96,7 +90,6 @@ label_attr = label_attr, label = label, n_sam_pol = n_sam_pol, - pol_id = pol_id, sampling_type = sampling_type ) ) @@ -178,7 +171,6 @@ #' @param label_attr Attribute in the shapefile used as a polygon label #' @param label Label to be assigned to points #' @param n_sam_pol Number of samples per polygon to be read -#' @param pol_id ID attribute for polygons containing the label #' @param sampling_type Spatial sampling type: random, hexagonal, #' regular, or Fibonacci. #' @return A tibble with latitude/longitude points from POLYGON geometry @@ -187,7 +179,6 @@ label_attr, label, n_sam_pol, - pol_id, sampling_type) { .check_set_caller(".sf_polygon_to_tibble") # get the db file @@ -199,30 +190,21 @@ within = colnames(sf_df) ) } - if (.has(pol_id)) { - .check_chr_within( - x = pol_id, - within = colnames(sf_df) - ) - } points_tab <- seq_len(nrow(sf_object)) |> - .map_dfr(function(i) { + .map_dfr(function(row_id) { # retrieve the class from the shape attribute if ("label" %in% colnames(sf_df)) { label <- as.character( - unlist(sf_df[i, "label"], use.names = FALSE) + unlist(sf_df[row_id, "label"], use.names = FALSE) ) } else if (.has(label_attr) && label_attr %in% colnames(sf_df)) { label <- as.character( - unlist(sf_df[i, label_attr], use.names = FALSE) + unlist(sf_df[row_id, label_attr], use.names = FALSE) ) } - if (.has(pol_id) && pol_id %in% colnames(sf_df)) { - polygon_id <- unname(as.character(sf_df[i, pol_id])) - } # obtain a set of samples based on polygons - points <- list(sf::st_sample(sf_object[i, ], + points <- list(sf::st_sample(sf_object[row_id, ], type = sampling_type, size = n_sam_pol)) # get one time series per sample @@ -232,17 +214,9 @@ row <- tibble::tibble( longitude = pll[[1]], latitude = pll[[2]], - label = label + label = label, + polygon_id = row_id ) - - if (.has(pol_id) && - pol_id %in% colnames(sf_df)) { - row <- tibble::add_column( - row, - polygon_id = polygon_id - ) - } - return(row) }) return(pts_tab) diff --git a/R/api_shp.R b/R/api_shp.R index 35bdefeaf..c76a5765c 100644 --- a/R/api_shp.R +++ b/R/api_shp.R @@ -9,8 +9,6 @@ #' @param start_date Start date for the data set. #' @param end_date End date for the data set. #' @param n_shp_pol Number of samples per polygon to be read. -#' @param shp_id ID attribute which contains the label -#' (for POLYGON or MULTIPOLYGON shapefile). #' @param sampling_type Spatial sampling type: random, hexagonal, #' regular, or Fibonacci. #' @return A sits tibble with samples to be retrieved. @@ -21,7 +19,6 @@ start_date, end_date, n_shp_pol, - shp_id, sampling_type) { # set caller to show in errors .check_set_caller(".shp_get_samples") @@ -38,7 +35,6 @@ label_attr = shp_attr, label = label, n_sam_pol = n_shp_pol, - pol_id = shp_id, sampling_type = sampling_type, start_date = start_date, end_date = end_date diff --git a/R/sits_get_data.R b/R/sits_get_data.R index 21fdb3cc0..97de7d6d3 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -7,22 +7,53 @@ #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Retrieve a set of time series from a data cube and -#' and puts the result in a "sits tibble", which -#' contain both the satellite image time series and their metadata. +#' and put the result in a "sits tibble", which +#' contains both the satellite image time series and their metadata. #' #' @note -#' There are four ways of specifying data to be retrieved using the +#' +#' To be able to build a machine learning model to classify a data cube, +#' one needs to use a set of labelled time series. These time series +#' are created by taking a set of known samples, expressed as +#' labelled points or polygons. +#' This \code{sits_get_data} function uses these samples to +#' extract time series from a data cube. Thus, it needs a \code{cube} parameter +#' which points to a regularized data cube, and a \code{samples} parameter +#' that describes the locations of the training set. +#' +#' There are five ways of specifying the #' \code{samples} parameter: -#' (a) CSV file: a CSV file with columns +#' \enumerate{ +#' \item{A CSV file with columns +#' \code{longitude}, \code{latitude}, +#' \code{start_date}, \code{end_date} and \code{label} for each sample. +#' The parameter must point to a file with extension ".csv";} +#' \item{A shapefile in POINT or POLYGON geometry +#' containing the location of the samples. +#' The parameter must point to a file with extension ".shp";} +#' \item{A sits tibble, which contains columns +#' \code{longitude}, \code{latitude}, +#' \code{start_date}, \code{end_date} and \code{label} for each sample.} +#' \item{A \code{link[sf]{sf}} object with POINT or POLYGON geometry;} +#' \item{A data.frame with with mandatory columns #' \code{longitude}, \code{latitude}, -#' \code{start_date}, \code{end_date} and \code{label} for each sample; -#' (b) SHP file: a shapefile in POINT or POLYGON geometry -#' containing the location of the samples and an attribute to be -#' used as label. Also, provide start and end date for the time series; -#' (c) sits object: A sits tibble; -#' (d) sf object: An \code{link[sf]{sf}} object with POINT or POLYGON geometry; -#' (e) data.frame: A data.frame with with mandatory columns -#' \code{longitude} and \code{latitude}. +#' \code{start_date}, \code{end_date} and \code{label} for each row.} +#' } +#' +#' For shapefiles and sf objects, the following parameters are relevant: +#' \enumerate{ +#' \item{\code{label}: label to be assigned to the samples. +#' Should only be used if all geometries have a single label.} +#' \item{\code{label_attr}: defines which attribute should be +#' used as a label, required for POINT and POLYGON geometries if +#' \code{label} has not been set.} +#' \item{\code{n_sam_pol}: indicates how many points are +#' extracted from each polygon, required for POLYGON geometry (default = 15).} +#' \item{\code{sampling_type}: defines how sampling is done, required +#' for POLYGON geometry (default = "random").} +#' \item{\code{pol_avg}: indicates if average of values for POLYGON +#' geometry should be computed (default = "FALSE").} +#' } # #' @param cube Data cube from where data is to be retrieved. #' (tibble of class "raster_cube"). @@ -49,7 +80,6 @@ #' for POLYGON or MULTIPOLYGON shapefiles or sf objects #' (single integer). #' @param pol_avg Logical: summarize samples for each polygon? -#' @param pol_id ID attribute for polygons #' (character vector of length 1) #' @param sampling_type Spatial sampling type: random, hexagonal, #' regular, or Fibonacci. @@ -162,7 +192,6 @@ sits_get_data.shp <- function(cube, label_attr = NULL, n_sam_pol = 30, pol_avg = FALSE, - pol_id = NULL, sampling_type = "random", multicores = 2, progress = FALSE) { @@ -175,8 +204,6 @@ sits_get_data.shp <- function(cube, end_date <- .default(end_date, .cube_end_date(cube)) .check_int_parameter(multicores, min = 1, max = 2048) .check_progress(progress) - # Pre-condition - shapefile should have an id parameter - .check_that(!(pol_avg && .has_not(pol_id))) # Extract a data frame from shapefile samples <- .shp_get_samples( @@ -186,7 +213,6 @@ sits_get_data.shp <- function(cube, start_date = start_date, end_date = end_date, n_shp_pol = n_sam_pol, - shp_id = pol_id, sampling_type = sampling_type ) # Extract time series from a cube given a data.frame @@ -217,12 +243,10 @@ sits_get_data.sf <- function(cube, label_attr = NULL, n_sam_pol = 30, pol_avg = FALSE, - pol_id = NULL, sampling_type = "random", multicores = 2, progress = FALSE) { .check_set_caller("sits_get_data_sf") - .check_that(!(pol_avg && .has_not(pol_id))) if (!.has(bands)) bands <- .cube_bands(cube) .check_cube_bands(cube, bands = bands) @@ -243,7 +267,6 @@ sits_get_data.sf <- function(cube, start_date = start_date, end_date = end_date, n_sam_pol = n_sam_pol, - pol_id = pol_id, sampling_type = sampling_type ) # Extract time series from a cube given a data.frame diff --git a/R/sits_mixture_model.R b/R/sits_mixture_model.R index 5ddc63402..eeff7ce8a 100644 --- a/R/sits_mixture_model.R +++ b/R/sits_mixture_model.R @@ -32,7 +32,7 @@ #' will be returned. The sum of all fractions is restricted #' to 1 (scaled from 0 to 10000), corresponding to the abundance of #' the endmembers in the pixels. -#' In case of a tibble sits, the time series will be returned with the +#' In case of a sits tibble, the time series will be returned with the #' values corresponding to each fraction. #' #' @details diff --git a/R/sits_regularize.R b/R/sits_regularize.R index 9aeeea695..6533f4d52 100644 --- a/R/sits_regularize.R +++ b/R/sits_regularize.R @@ -47,7 +47,6 @@ #' dates which are compatible with the input cube. #' #' -#' @note #' The optional "roi" parameter defines a region of interest. It can be #' an sf_object, a shapefile, or a bounding box vector with #' named XY values ("xmin", "xmax", "ymin", "ymax") or @@ -55,23 +54,19 @@ #' \code{sits_regularize()} function will crop the images #' that contain the region of interest(). #' -#' @note #' The optional "tiles" parameter indicates which tiles of the #' input cube will be used for regularization. #' -#' @note #' The "grid_system" parameters allows the choice of grid system #' for the regularized cube. Currently, the package supports #' the use of MGRS grid system and those used by the Brazil #' Data Cube ("BDC_LG_V2" "BDC_MD_V2" "BDC_SM_V2"). #' -#' @note #' The aggregation method used in \code{sits_regularize} #' sorts the images based on cloud cover, where images with the fewest #' clouds at the top of the stack. Once #' the stack of images is sorted, the method uses the first valid value to #' create the temporal aggregation. -#' @note #' The input (non-regular) ARD cube needs to include the cloud band for #' the regularization to work. #' diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R index b70eb19d8..ddeb2466c 100644 --- a/R/sits_sample_functions.R +++ b/R/sits_sample_functions.R @@ -48,168 +48,6 @@ sits_sample <- function(data, }) return(result) } -#' @title Suggest samples for enhancing classification accuracy -#' -#' @name sits_uncertainty_sampling -#' -#' @author Alber Sanchez, \email{alber.ipia@@inpe.br} -#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} -#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' -#' @description -#' Suggest samples for regions of high uncertainty as predicted by the model. -#' The function selects data points that have confused an algorithm. -#' These points don't have labels and need be manually labelled by experts -#' and then used to increase the classification's training set. -#' -#' This function is best used in the following context: -#' 1. Select an initial set of samples. -#' 2. Train a machine learning model. -#' 3. Build a data cube and classify it using the model. -#' 4. Run a Bayesian smoothing in the resulting probability cube. -#' 5. Create an uncertainty cube. -#' 6. Perform uncertainty sampling. -#' -#' The Bayesian smoothing procedure will reduce the classification outliers -#' and thus increase the likelihood that the resulting pixels with high -#' uncertainty have meaningful information. -#' -#' @param uncert_cube An uncertainty cube. -#' See \code{\link[sits]{sits_uncertainty}}. -#' @param n Number of suggested points to be sampled per tile. -#' @param min_uncert Minimum uncertainty value to select a sample. -#' @param sampling_window Window size for collecting points (in pixels). -#' The minimum window size is 10. -#' @param multicores Number of workers for parallel processing -#' (integer, min = 1, max = 2048). -#' @param memsize Maximum overall memory (in GB) to run the -#' function. -#' -#' @return -#' A tibble with longitude and latitude in WGS84 with locations -#' which have high uncertainty and meet the minimum distance -#' criteria. -#' -#' -#' @references -#' Robert Monarch, "Human-in-the-Loop Machine Learning: Active learning -#' and annotation for human-centered AI". Manning Publications, 2021. -#' -#' @examples -#' if (sits_run_examples()) { -#' # create a data cube -#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") -#' cube <- sits_cube( -#' source = "BDC", -#' collection = "MOD13Q1-6.1", -#' data_dir = data_dir -#' ) -#' # build a random forest model -#' rfor_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor()) -#' # classify the cube -#' probs_cube <- sits_classify( -#' data = cube, ml_model = rfor_model, output_dir = tempdir() -#' ) -#' # create an uncertainty cube -#' uncert_cube <- sits_uncertainty(probs_cube, -#' type = "entropy", -#' output_dir = tempdir() -#' ) -#' # obtain a new set of samples for active learning -#' # the samples are located in uncertain places -#' new_samples <- sits_uncertainty_sampling( -#' uncert_cube, -#' n = 10, min_uncert = 0.4 -#' ) -#' } -#' -#' @export -sits_uncertainty_sampling <- function(uncert_cube, - n = 100L, - min_uncert = 0.4, - sampling_window = 10L, - multicores = 1L, - memsize = 1L) { - .check_set_caller("sits_uncertainty_sampling") - # Pre-conditions - .check_is_uncert_cube(uncert_cube) - .check_int_parameter(n, min = 1) - .check_num_parameter(min_uncert, min = 0.0, max = 1.0) - .check_int_parameter(sampling_window, min = 1L) - .check_int_parameter(multicores, min = 1) - .check_int_parameter(memsize, min = 1) - # Slide on cube tiles - samples_tb <- slider::slide_dfr(uncert_cube, function(tile) { - # open spatial raster object - rast <- .raster_open_rast(.tile_path(tile)) - # get the values - values <- .raster_get_values(rast) - # sample the maximum values - samples_tile <- C_max_sampling( - x = values, - nrows = nrow(rast), - ncols = ncol(rast), - window_size = sampling_window - ) - # get the top most values - samples_tile <- samples_tile |> - # randomly shuffle the rows of the dataset - dplyr::sample_frac() |> - dplyr::slice_max( - .data[["value"]], - n = n, - with_ties = FALSE - ) - # transform to tibble - tb <- rast |> - .raster_xy_from_cell( - cell = samples_tile[["cell"]] - ) |> - tibble::as_tibble() - # find NA - na_rows <- which(is.na(tb)) - # remove NA - if (length(na_rows) > 0) { - tb <- tb[-na_rows, ] - samples_tile <- samples_tile[-na_rows, ] - } - # Get the values' positions. - result_tile <- tb |> - sf::st_as_sf( - coords = c("x", "y"), - crs = .raster_crs(rast), - dim = "XY", - remove = TRUE - ) |> - sf::st_transform(crs = "EPSG:4326") |> - sf::st_coordinates() - - colnames(result_tile) <- c("longitude", "latitude") - result_tile <- result_tile |> - dplyr::bind_cols(samples_tile) |> - dplyr::mutate( - value = .data[["value"]] * - .conf("probs_cube_scale_factor") - ) |> - dplyr::filter( - .data[["value"]] >= min_uncert - ) |> - dplyr::select(dplyr::matches( - c("longitude", "latitude", "value") - )) |> - tibble::as_tibble() - - # All the cube's uncertainty images have the same start & end dates. - result_tile[["start_date"]] <- .tile_start_date(uncert_cube) - result_tile[["end_date"]] <- .tile_end_date(uncert_cube) - result_tile[["label"]] <- "NoClass" - return(result_tile) - }) - samples_tb <- dplyr::rename(samples_tb, uncertainty = value) - - return(samples_tb) -} #' @title Suggest high confidence samples to increase the training set. #' #' @name sits_confidence_sampling diff --git a/R/sits_stars.R b/R/sits_stars.R new file mode 100644 index 000000000..583bd4829 --- /dev/null +++ b/R/sits_stars.R @@ -0,0 +1,88 @@ +#' @title Convert a data cube into a stars object +#' @name sits_as_stars +#' @author Gilberto Camara, \email{gilberto.camara.inpe@@gmail.com} +#' +#' @description Uses the information about files, bands and dates +#' in a data cube to produce an object of class \code{stars}. +#' User has to select a tile from the data cube. By default, +#' all bands and dates are included in the \code{stars} object. +#' Users can select bands and dates. +#' +#' @param cube A sits cube. +#' @param tile Tile of the data cube. +#' @param bands Bands of the data cube to be part of \code{stars} object. +#' @param dates Bands of the data cube to be part of \code{stars} object. +#' @param proxy Produce a stars proxy object. +#' @return An space-time stars object. +#' +#' @note +#' By default, the \code{stars} object will be loaded in memory. This +#' can result in heavy memory usage. To produce a \code{stars.proxy} object, +#' uses have to select a single date, since \code{stars} does not allow +#' proxy objects to be created with two dimensions. +#' @examples +#' if (sits_run_examples()) { +#' +#' # convert sits cube to an sf object (polygon) +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' stars_object <- sits_as_stars(cube) +#' } +#' @export +sits_as_stars <- function(cube, + tile = cube[1,]$tile, + bands = NULL, + dates = NULL, + proxy = FALSE){ + # Pre-conditions + .check_set_caller("sits_as_stars") + .check_is_raster_cube(cube) + .check_chr_parameter(tile, len_max = 1) + .check_chr_contains(cube[["tile"]], contains = tile, + discriminator = "any_of", + msg = .conf("messages", "sits_as_stars_tile")) + .check_lgl_parameter(proxy) + + # extract tile from cube + tile_cube <- .cube_filter_tiles(cube, tile) + # get file info for tile + fi <- .fi(tile_cube) + # filter bands + if (.has(bands)) { + .check_cube_bands(tile_cube, bands) + fi <- .fi_filter_bands(fi, bands) + } else + bands <- .tile_bands(tile_cube) + + # filter dates + if (.has(dates)) { + # proxy? only one date is retrieved + if (proxy) + dates <- dates[[1]] + .check_dates_timeline(dates, tile_cube) + fi <- .fi_filter_dates(fi, dates) + } else + dates <- as.Date(.tile_timeline(tile_cube)) + + # retrieve files + image_files <- .fi_paths(fi) + + # proxy? only one dimension (bands) + if (proxy) + stars_obj <- stars::read_stars( + image_files, + along = "band", + proxy = TRUE + ) + else + stars_obj <- stars::read_stars( + image_files, + along = list(band = bands, + time = dates) + ) + return(stars_obj) +} diff --git a/R/sits_uncertainty.R b/R/sits_uncertainty.R index 3e5650108..2d145aea1 100644 --- a/R/sits_uncertainty.R +++ b/R/sits_uncertainty.R @@ -150,3 +150,165 @@ sits_uncertainty.probs_vector_cube <- function( sits_uncertainty.default <- function(cube, ...) { stop(.conf("messages", "sits_uncertainty_default")) } +#' @title Suggest samples for enhancing classification accuracy +#' +#' @name sits_uncertainty_sampling +#' +#' @author Alber Sanchez, \email{alber.ipia@@inpe.br} +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' +#' @description +#' Suggest samples for regions of high uncertainty as predicted by the model. +#' The function selects data points that have confused an algorithm. +#' These points don't have labels and need be manually labelled by experts +#' and then used to increase the classification's training set. +#' +#' This function is best used in the following context: +#' 1. Select an initial set of samples. +#' 2. Train a machine learning model. +#' 3. Build a data cube and classify it using the model. +#' 4. Run a Bayesian smoothing in the resulting probability cube. +#' 5. Create an uncertainty cube. +#' 6. Perform uncertainty sampling. +#' +#' The Bayesian smoothing procedure will reduce the classification outliers +#' and thus increase the likelihood that the resulting pixels with high +#' uncertainty have meaningful information. +#' +#' @param uncert_cube An uncertainty cube. +#' See \code{\link[sits]{sits_uncertainty}}. +#' @param n Number of suggested points to be sampled per tile. +#' @param min_uncert Minimum uncertainty value to select a sample. +#' @param sampling_window Window size for collecting points (in pixels). +#' The minimum window size is 10. +#' @param multicores Number of workers for parallel processing +#' (integer, min = 1, max = 2048). +#' @param memsize Maximum overall memory (in GB) to run the +#' function. +#' +#' @return +#' A tibble with longitude and latitude in WGS84 with locations +#' which have high uncertainty and meet the minimum distance +#' criteria. +#' +#' +#' @references +#' Robert Monarch, "Human-in-the-Loop Machine Learning: Active learning +#' and annotation for human-centered AI". Manning Publications, 2021. +#' +#' @examples +#' if (sits_run_examples()) { +#' # create a data cube +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' # build a random forest model +#' rfor_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor()) +#' # classify the cube +#' probs_cube <- sits_classify( +#' data = cube, ml_model = rfor_model, output_dir = tempdir() +#' ) +#' # create an uncertainty cube +#' uncert_cube <- sits_uncertainty(probs_cube, +#' type = "entropy", +#' output_dir = tempdir() +#' ) +#' # obtain a new set of samples for active learning +#' # the samples are located in uncertain places +#' new_samples <- sits_uncertainty_sampling( +#' uncert_cube, +#' n = 10, min_uncert = 0.4 +#' ) +#' } +#' +#' @export +sits_uncertainty_sampling <- function(uncert_cube, + n = 100L, + min_uncert = 0.4, + sampling_window = 10L, + multicores = 1L, + memsize = 1L) { + .check_set_caller("sits_uncertainty_sampling") + # Pre-conditions + .check_is_uncert_cube(uncert_cube) + .check_int_parameter(n, min = 1) + .check_num_parameter(min_uncert, min = 0.0, max = 1.0) + .check_int_parameter(sampling_window, min = 1L) + .check_int_parameter(multicores, min = 1) + .check_int_parameter(memsize, min = 1) + # Slide on cube tiles + samples_tb <- slider::slide_dfr(uncert_cube, function(tile) { + # open spatial raster object + rast <- .raster_open_rast(.tile_path(tile)) + # get the values + values <- .raster_get_values(rast) + # sample the maximum values + samples_tile <- C_max_sampling( + x = values, + nrows = nrow(rast), + ncols = ncol(rast), + window_size = sampling_window + ) + # get the top most values + samples_tile <- samples_tile |> + # randomly shuffle the rows of the dataset + dplyr::sample_frac() |> + dplyr::slice_max( + .data[["value"]], + n = n, + with_ties = FALSE + ) + # transform to tibble + tb <- rast |> + .raster_xy_from_cell( + cell = samples_tile[["cell"]] + ) |> + tibble::as_tibble() + # find NA + na_rows <- which(is.na(tb)) + # remove NA + if (length(na_rows) > 0) { + tb <- tb[-na_rows, ] + samples_tile <- samples_tile[-na_rows, ] + } + # Get the values' positions. + result_tile <- tb |> + sf::st_as_sf( + coords = c("x", "y"), + crs = .raster_crs(rast), + dim = "XY", + remove = TRUE + ) |> + sf::st_transform(crs = "EPSG:4326") |> + sf::st_coordinates() + + colnames(result_tile) <- c("longitude", "latitude") + result_tile <- result_tile |> + dplyr::bind_cols(samples_tile) |> + dplyr::mutate( + value = .data[["value"]] * + .conf("probs_cube_scale_factor") + ) |> + dplyr::filter( + .data[["value"]] >= min_uncert + ) |> + dplyr::select(dplyr::matches( + c("longitude", "latitude", "value") + )) |> + tibble::as_tibble() + + # All the cube's uncertainty images have the same start & end dates. + result_tile[["start_date"]] <- .tile_start_date(uncert_cube) + result_tile[["end_date"]] <- .tile_end_date(uncert_cube) + result_tile[["label"]] <- "NoClass" + return(result_tile) + }) + samples_tb <- dplyr::rename(samples_tb, uncertainty = value) + + return(samples_tb) +} diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-08-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-08-01.tif new file mode 100644 index 0000000000000000000000000000000000000000..dbbd4f11b899b58b6173bec0a1d8c99413b96310 GIT binary patch literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBVLSqn(f5umS+gKPA5a literal 0 HcmV?d00001 diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-09-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-09-01.tif new file mode 100644 index 0000000000000000000000000000000000000000..0457edd26139a88a6cfdeba9395898fe2481b2e5 GIT binary patch literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBVja?~PZlvjPCjXC<-# literal 0 HcmV?d00001 diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-10-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-10-01.tif new file mode 100644 index 0000000000000000000000000000000000000000..48516691a6fb200d1f3f186521bbbe69fe4ba837 GIT binary patch literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae pBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBVXWg_S+CSOLm6B>eyY literal 0 HcmV?d00001 diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-08-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-08-01.tif new file mode 100644 index 0000000000000000000000000000000000000000..ef246caae6e2ec67c0b7bda27ef51461bf7c974e GIT binary patch literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBT+$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae pBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBTw*tFD!ocmT@wB~btX literal 0 HcmV?d00001 diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-10-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-10-01.tif new file mode 100644 index 0000000000000000000000000000000000000000..ce95efac82cdcb37dfab40d3639b4f9e19437cd6 GIT binary patch literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae pBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBT|@=caitc>v2SC1L;o literal 0 HcmV?d00001 diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-08-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-08-01.tif new file mode 100644 index 0000000000000000000000000000000000000000..4c0ed0ee4ea6f108288f52df44fbb7d8808ec9ef GIT binary patch literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBU|K_0MmXa{~a(m?gUa literal 0 HcmV?d00001 diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-09-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-09-01.tif new file mode 100644 index 0000000000000000000000000000000000000000..bf842b4c4e5b98c88f542ed3d282ef2e09010388 GIT binary patch literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBU+GpVwPoaRUI&E+yyy literal 0 HcmV?d00001 diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-10-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-10-01.tif new file mode 100644 index 0000000000000000000000000000000000000000..03896ee0be6bcaedc269e328c761be761b4bf23c GIT binary patch literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae pBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590b4jp3+su89EC9(MB*Opz literal 0 HcmV?d00001 diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-08-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-08-01.tif new file mode 100644 index 0000000000000000000000000000000000000000..97034e79dc0db85e493474f25011cfbe058203ea GIT binary patch literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBUY4+Y2Y(GXVh1pC!ux literal 0 HcmV?d00001 diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-09-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-09-01.tif new file mode 100644 index 0000000000000000000000000000000000000000..0d0fde4db30ca1adc6e1d89e21a7fadde2636c68 GIT binary patch literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBUM0u@e&(F#!O|lO-Ae literal 0 HcmV?d00001 diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-10-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-10-01.tif new file mode 100644 index 0000000000000000000000000000000000000000..f75f83dc069521724b58d9a9431df5993af2f3d0 GIT binary patch literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590b4iH6(oJhV@d5zK+a+WG literal 0 HcmV?d00001 diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index 52da8be90..a4e43fe94 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -249,7 +249,7 @@ .samples_ts: "time_series column not found in samples" .sf_clean: "invalid geometries detected - these geometries have been removed" .sf_get_samples: "invalid sf object - only POINT, POLYGON and MULTIPOLYGON objects are supported" -.sf_polygon_to_tibble: "unable to extract data from polygon - check 'label_attr' and 'pol_id' parameters" +.sf_polygon_to_tibble: "unable to extract data from polygon - check 'label_attr' parameter" .shp_transform_to_sf: "invalid shapefile - missing data or invalid geometry types" .shp_get_samples: "either a label or shape attribute should be provided to read shapefiles" .signal_odd_filter_length: "sgolay needs an odd filter length n" @@ -341,6 +341,10 @@ sits_accuracy_raster_cube: "input should be a classified cube" sits_accuracy_class_vector_cube: "attributes for predicted and reference values should be contained in the segments object" sits_accuracy_tbl_df: "input should be a classified sits tibble or a classified data cube" sits_as_sf: "input should be a valid set of training samples or a non-classified data cube" +sits_as_stars: "invalid parameters in sits_as_stars" +sits_as_stars_tile: "tile is not part of the cube" +sits_as_stars_bands: "bands are not included in the cube" +sits_as_stars_dates: "dates are not included in the cube" sits_apply: "invalid input data and/or function to be applied" sits_apply_out_band: "output band already exists in data cube and will be replaced" sits_apply_derived_cube: "input data should be a non-classified cube" @@ -398,8 +402,8 @@ sits_get_class_not_point: "samples should have POINT geometry type" sits_get_data: "unable to retrieve data - check input parameters" sits_get_data_default: "invalid samples - check documentation" sits_get_data_data_frame: "missing lat/long information in data frame" -sits_get_data_sf: "sf objects need a column with an id for each polygon\n please include this column name in the 'pol_id' parameter" -sits_get_data_shp: "shp objects need a column with an id for each polygon\n please include this column name in the 'pol_id' parameter" +sits_get_data_sf: "unable to retrieve points - please check parameters" +sits_get_data_shp: "unable to retrieve points - please check parameters" sits_get_probs: "unable to retrieve data from probability cube - check input parameters" sits_get_probs_not_point: "samples should have POINT geometry type" sits_hist_raster_cube: "invalid input data to compute histogram" diff --git a/man/sits_as_stars.Rd b/man/sits_as_stars.Rd new file mode 100644 index 000000000..152e7ef6e --- /dev/null +++ b/man/sits_as_stars.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_stars.R +\name{sits_as_stars} +\alias{sits_as_stars} +\title{Convert a data cube into a stars object} +\usage{ +sits_as_stars( + cube, + tile = cube[1, ]$tile, + bands = NULL, + dates = NULL, + proxy = FALSE +) +} +\arguments{ +\item{cube}{A sits cube.} + +\item{tile}{Tile of the data cube.} + +\item{bands}{Bands of the data cube to be part of \code{stars} object.} + +\item{dates}{Bands of the data cube to be part of \code{stars} object.} + +\item{proxy}{Produce a stars proxy object.} +} +\value{ +An space-time stars object. +} +\description{ +Uses the information about files, bands and dates +in a data cube to produce an object of class \code{stars}. +User has to select a tile from the data cube. By default, +all bands and dates are included in the \code{stars} object. +Users can select bands and dates. +} +\note{ +By default, the \code{stars} object will be loaded in memory. This +can result in heavy memory usage. To produce a \code{stars.proxy} object, +uses have to select a single date, since \code{stars} does not allow +proxy objects to be created with two dimensions. +} +\examples{ +if (sits_run_examples()) { + + # convert sits cube to an sf object (polygon) + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + stars_object <- sits_as_stars(cube) +} +} +\author{ +Gilberto Camara, \email{gilberto.camara.inpe@gmail.com} +} diff --git a/man/sits_get_data.Rd b/man/sits_get_data.Rd index e0dc1b8f3..5ed2847df 100644 --- a/man/sits_get_data.Rd +++ b/man/sits_get_data.Rd @@ -37,7 +37,6 @@ sits_get_data(cube, samples, ...) label_attr = NULL, n_sam_pol = 30, pol_avg = FALSE, - pol_id = NULL, sampling_type = "random", multicores = 2, progress = FALSE @@ -55,7 +54,6 @@ sits_get_data(cube, samples, ...) label_attr = NULL, n_sam_pol = 30, pol_avg = FALSE, - pol_id = NULL, sampling_type = "random", multicores = 2, progress = FALSE @@ -127,9 +125,7 @@ as a polygon label. for POLYGON or MULTIPOLYGON shapefiles or sf objects (single integer).} -\item{pol_avg}{Logical: summarize samples for each polygon?} - -\item{pol_id}{ID attribute for polygons +\item{pol_avg}{Logical: summarize samples for each polygon? (character vector of length 1)} \item{sampling_type}{Spatial sampling type: random, hexagonal, @@ -141,22 +137,52 @@ A tibble of class "sits" with set of time series } \description{ Retrieve a set of time series from a data cube and -and puts the result in a "sits tibble", which -contain both the satellite image time series and their metadata. +and put the result in a "sits tibble", which +contains both the satellite image time series and their metadata. } \note{ -There are four ways of specifying data to be retrieved using the +To be able to build a machine learning model to classify a data cube, +one needs to use a set of labelled time series. These time series +are created by taking a set of known samples, expressed as +labelled points or polygons. +This \code{sits_get_data} function uses these samples to +extract time series from a data cube. Thus, it needs a \code{cube} parameter +which points to a regularized data cube, and a \code{samples} parameter +that describes the locations of the training set. + +There are five ways of specifying the \code{samples} parameter: -(a) CSV file: a CSV file with columns +\enumerate{ +\item{A CSV file with columns +\code{longitude}, \code{latitude}, +\code{start_date}, \code{end_date} and \code{label} for each sample. +The parameter must point to a file with extension ".csv";} +\item{A shapefile in POINT or POLYGON geometry +containing the location of the samples. +The parameter must point to a file with extension ".shp";} +\item{A sits tibble, which contains columns +\code{longitude}, \code{latitude}, +\code{start_date}, \code{end_date} and \code{label} for each sample.} +\item{A \code{link[sf]{sf}} object with POINT or POLYGON geometry;} +\item{A data.frame with with mandatory columns \code{longitude}, \code{latitude}, -\code{start_date}, \code{end_date} and \code{label} for each sample; -(b) SHP file: a shapefile in POINT or POLYGON geometry -containing the location of the samples and an attribute to be -used as label. Also, provide start and end date for the time series; -(c) sits object: A sits tibble; -(d) sf object: An \code{link[sf]{sf}} object with POINT or POLYGON geometry; -(e) data.frame: A data.frame with with mandatory columns -\code{longitude} and \code{latitude}. +\code{start_date}, \code{end_date} and \code{label} for each row.} +} + +For shapefiles and sf objects, the following parameters are relevant: +\enumerate{ +\item{\code{label}: label to be assigned to the samples. +Should only be used if all geometries have a single label.} +\item{\code{label_attr}: defines which attribute should be +used as a label, required for POINT and POLYGON geometries if +\code{label} has not been set.} +\item{\code{n_sam_pol}: indicates how many points are +extracted from each polygon, required for POLYGON geometry (default = 15).} +\item{\code{sampling_type}: defines how sampling is done, required +for POLYGON geometry (default = "random").} +\item{\code{pol_avg}: indicates if average of values for POLYGON +geometry should be computed (default = "FALSE").} +} } \examples{ if (sits_run_examples()) { diff --git a/man/sits_mixture_model.Rd b/man/sits_mixture_model.Rd index a37c7da92..969e9ec5c 100644 --- a/man/sits_mixture_model.Rd +++ b/man/sits_mixture_model.Rd @@ -65,7 +65,7 @@ In case of a cube, a sits cube with the fractions of each endmember will be returned. The sum of all fractions is restricted to 1 (scaled from 0 to 10000), corresponding to the abundance of the endmembers in the pixels. - In case of a tibble sits, the time series will be returned with the + In case of a sits tibble, the time series will be returned with the values corresponding to each fraction. } \description{ diff --git a/man/sits_regularize.Rd b/man/sits_regularize.Rd index fd7e61563..2f462b899 100644 --- a/man/sits_regularize.Rd +++ b/man/sits_regularize.Rd @@ -136,28 +136,28 @@ The "period" parameter is mandatory, and defines the time interval The "timeline" parameter, if used, must contain a set of dates which are compatible with the input cube. -The optional "roi" parameter defines a region of interest. It can be + + The optional "roi" parameter defines a region of interest. It can be an sf_object, a shapefile, or a bounding box vector with named XY values ("xmin", "xmax", "ymin", "ymax") or named lat/long values ("lat_min", "lat_max", "long_min", "long_max"). \code{sits_regularize()} function will crop the images that contain the region of interest(). -The optional "tiles" parameter indicates which tiles of the + The optional "tiles" parameter indicates which tiles of the input cube will be used for regularization. -The "grid_system" parameters allows the choice of grid system + The "grid_system" parameters allows the choice of grid system for the regularized cube. Currently, the package supports the use of MGRS grid system and those used by the Brazil Data Cube ("BDC_LG_V2" "BDC_MD_V2" "BDC_SM_V2"). -The aggregation method used in \code{sits_regularize} + The aggregation method used in \code{sits_regularize} sorts the images based on cloud cover, where images with the fewest clouds at the top of the stack. Once the stack of images is sorted, the method uses the first valid value to create the temporal aggregation. - -The input (non-regular) ARD cube needs to include the cloud band for + The input (non-regular) ARD cube needs to include the cloud band for the regularization to work. } \examples{ diff --git a/man/sits_uncertainty_sampling.Rd b/man/sits_uncertainty_sampling.Rd index d20a5500e..a04fd87f3 100644 --- a/man/sits_uncertainty_sampling.Rd +++ b/man/sits_uncertainty_sampling.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sits_sample_functions.R +% Please edit documentation in R/sits_uncertainty.R \name{sits_uncertainty_sampling} \alias{sits_uncertainty_sampling} \title{Suggest samples for enhancing classification accuracy} diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index 56c12f536..25dce8e6c 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -94,7 +94,7 @@ test_that("Retrieving points from BDC using POLYGON shapefiles", { modis_cube <- .try( { sits_cube( - source = "BDC", + source = "MPC", collection = "MOD13Q1-6.1", bands = c("NDVI", "EVI"), roi = sf_mt, @@ -107,7 +107,7 @@ test_that("Retrieving points from BDC using POLYGON shapefiles", { .default = NULL ) testthat::skip_if(purrr::is_null(modis_cube), - message = "MPC is not accessible" + message = "BDC is not accessible" ) # get the timeline cube_timeline <- sits_timeline(modis_cube) @@ -146,30 +146,13 @@ test_that("Retrieving points from BDC using POLYGON shapefiles", { ) expect_true(nrow(points_shp_in_bbox) == nrow(points_shp)) - # test for errors in get_data syntax - expect_error( - sits_get_data(modis_cube, - samples = shp_file, - pol_avg = TRUE, - progress = FALSE - ) - ) - # test for errors in get_data syntax - expect_error( - sits_get_data(modis_cube, - samples = shp_file, - pol_avg = TRUE, - pol_id = "iddddddd", - progress = FALSE - ) - ) + # retrieve labelled points from BDC cube points_shp_avg <- sits_get_data(modis_cube, samples = shp_file, n_sam_pol = 5, label_attr = "NM_ESTADO", pol_avg = TRUE, - pol_id = "CD_GEOCUF", progress = FALSE ) @@ -183,7 +166,6 @@ test_that("Retrieving points from BDC using POLYGON shapefiles", { samples = shp_file, n_sam_pol = 5, pol_avg = TRUE, - pol_id = "CD_GEOCUF", progress = FALSE ) diff --git a/tests/testthat/test-sf.R b/tests/testthat/test-sf.R index 472f94941..e91d4de7e 100644 --- a/tests/testthat/test-sf.R +++ b/tests/testthat/test-sf.R @@ -18,7 +18,6 @@ test_that("sf", { label_attr = "label", label = "Crop", n_sam_pol = 10, - pol_id = NULL, start_date = "2020-01-01", end_date = "2020-12-31" ) @@ -58,7 +57,6 @@ test_that("sf", { label_attr = NULL, label = NULL, n_sam_pol = 10, - pol_id = "CD_GEOCUF", sampling_type = "random") expect_equal(nrow(tbp), 10) expect_true(all(tbp$label == "MatoGrosso")) From 640adb2f17ef927f0ea40142972a13f55cf1ca7f Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Sat, 22 Mar 2025 16:59:29 -0300 Subject: [PATCH 063/122] first version of sits_as_stars --- ..._PLANETSCOPE_MOSAIC_604-1043_B1_2022-08-01.tif | Bin 221 -> 0 bytes ..._PLANETSCOPE_MOSAIC_604-1043_B1_2022-09-01.tif | Bin 221 -> 0 bytes ..._PLANETSCOPE_MOSAIC_604-1043_B1_2022-10-01.tif | Bin 221 -> 0 bytes ..._PLANETSCOPE_MOSAIC_604-1043_B2_2022-08-01.tif | Bin 221 -> 0 bytes ..._PLANETSCOPE_MOSAIC_604-1043_B2_2022-09-01.tif | Bin 221 -> 0 bytes ..._PLANETSCOPE_MOSAIC_604-1043_B2_2022-10-01.tif | Bin 221 -> 0 bytes ..._PLANETSCOPE_MOSAIC_604-1043_B3_2022-08-01.tif | Bin 221 -> 0 bytes ..._PLANETSCOPE_MOSAIC_604-1043_B3_2022-09-01.tif | Bin 221 -> 0 bytes ..._PLANETSCOPE_MOSAIC_604-1043_B3_2022-10-01.tif | Bin 221 -> 0 bytes ..._PLANETSCOPE_MOSAIC_604-1043_B4_2022-08-01.tif | Bin 221 -> 0 bytes ..._PLANETSCOPE_MOSAIC_604-1043_B4_2022-09-01.tif | Bin 221 -> 0 bytes ..._PLANETSCOPE_MOSAIC_604-1043_B4_2022-10-01.tif | Bin 221 -> 0 bytes 12 files changed, 0 insertions(+), 0 deletions(-) delete mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-08-01.tif delete mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-09-01.tif delete mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-10-01.tif delete mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-08-01.tif delete mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-09-01.tif delete mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-10-01.tif delete mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-08-01.tif delete mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-09-01.tif delete mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-10-01.tif delete mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-08-01.tif delete mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-09-01.tif delete mode 100644 __MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-10-01.tif diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-08-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-08-01.tif deleted file mode 100644 index dbbd4f11b899b58b6173bec0a1d8c99413b96310..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBVLSqn(f5umS+gKPA5a diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-09-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-09-01.tif deleted file mode 100644 index 0457edd26139a88a6cfdeba9395898fe2481b2e5..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBVja?~PZlvjPCjXC<-# diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-10-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B1_2022-10-01.tif deleted file mode 100644 index 48516691a6fb200d1f3f186521bbbe69fe4ba837..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae pBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBVXWg_S+CSOLm6B>eyY diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-08-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-08-01.tif deleted file mode 100644 index ef246caae6e2ec67c0b7bda27ef51461bf7c974e..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBT+$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae pBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBTw*tFD!ocmT@wB~btX diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-10-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B2_2022-10-01.tif deleted file mode 100644 index ce95efac82cdcb37dfab40d3639b4f9e19437cd6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae pBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBT|@=caitc>v2SC1L;o diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-08-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-08-01.tif deleted file mode 100644 index 4c0ed0ee4ea6f108288f52df44fbb7d8808ec9ef..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBU|K_0MmXa{~a(m?gUa diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-09-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-09-01.tif deleted file mode 100644 index bf842b4c4e5b98c88f542ed3d282ef2e09010388..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBU+GpVwPoaRUI&E+yyy diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-10-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B3_2022-10-01.tif deleted file mode 100644 index 03896ee0be6bcaedc269e328c761be761b4bf23c..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae pBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590b4jp3+su89EC9(MB*Opz diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-08-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-08-01.tif deleted file mode 100644 index 97034e79dc0db85e493474f25011cfbe058203ea..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBUY4+Y2Y(GXVh1pC!ux diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-09-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-09-01.tif deleted file mode 100644 index 0d0fde4db30ca1adc6e1d89e21a7fadde2636c68..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590bBUM0u@e&(F#!O|lO-Ae diff --git a/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-10-01.tif b/__MACOSX/._PLANETSCOPE_MOSAIC_604-1043_B4_2022-10-01.tif deleted file mode 100644 index f75f83dc069521724b58d9a9431df5993af2f3d0..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 221 zcmZQz6=P>$Vqox1Ojhs@R)|o50+1L3ClDI}@oFFj@$UjL5x_AdBnYYuq+ae qBqIYu)~_Q?ho;I{aS3q=lqOovn7aO40Z590b4iH6(oJhV@d5zK+a+WG From cb9fc84738c1786d361fdf6f147b2e16beb3040a Mon Sep 17 00:00:00 2001 From: Felipe Carlos Date: Sun, 23 Mar 2025 10:32:59 -0300 Subject: [PATCH 064/122] enhance sits_view with webgl-enabled geometries rendering --- DESCRIPTION | 1 + R/api_view.R | 10 +++++----- R/sits_view.R | 4 ++-- man/sits_view.Rd | 4 ++-- 4 files changed, 10 insertions(+), 9 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a034b8036..521dd1e24 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,6 +40,7 @@ Imports: dplyr (>= 1.1.0), grDevices, graphics, + leafgl, leaflet (>= 2.2.2), lubridate, luz (>= 0.4.0), diff --git a/R/api_view.R b/R/api_view.R index df1708321..d2fea585e 100644 --- a/R/api_view.R +++ b/R/api_view.R @@ -98,9 +98,9 @@ lng2 = samples_bbox[["xmax"]], lat2 = samples_bbox[["ymax"]] ) |> - leaflet::addCircleMarkers( + leafgl::addGlPoints( data = samples, - color = ~ factpal(label), + fillColor = ~ factpal(label), radius = radius, stroke = FALSE, fillOpacity = 1, @@ -176,9 +176,9 @@ lng2 = samples_bbox[["xmax"]], lat2 = samples_bbox[["ymax"]] ) |> - leaflet::addCircleMarkers( + leafgl::addGlPoints( data = samples, - color = ~ factpal(label), + fillColor = ~ factpal(label), radius = radius, stroke = FALSE, fillOpacity = 1, @@ -229,7 +229,7 @@ ) # create a layer with the segment borders leaf_map <- leaf_map |> - leaflet::addPolygons( + leafgl::addGlPolygons( data = sf_seg, color = seg_color, opacity = 1, diff --git a/R/sits_view.R b/R/sits_view.R index 2bd234723..28c443fe6 100644 --- a/R/sits_view.R +++ b/R/sits_view.R @@ -151,7 +151,7 @@ sits_view <- function(x, ...) { sits_view.sits <- function(x, ..., legend = NULL, palette = "Set3", - radius = 5, + radius = 10, add = FALSE) { .check_set_caller("sits_view_sits") # precondition @@ -207,7 +207,7 @@ sits_view.som_map <- function(x, ..., id_neurons, legend = NULL, palette = "Harmonic", - radius = 5, + radius = 10, add = FALSE) { .check_set_caller("sits_view_som_map") # check id_neuron diff --git a/man/sits_view.Rd b/man/sits_view.Rd index 310b167a1..83d58b1ad 100644 --- a/man/sits_view.Rd +++ b/man/sits_view.Rd @@ -16,7 +16,7 @@ \usage{ sits_view(x, ...) -\method{sits_view}{sits}(x, ..., legend = NULL, palette = "Set3", radius = 5, add = FALSE) +\method{sits_view}{sits}(x, ..., legend = NULL, palette = "Set3", radius = 10, add = FALSE) \method{sits_view}{data.frame}(x, ..., legend = NULL, palette = "Harmonic", add = FALSE) @@ -26,7 +26,7 @@ sits_view(x, ...) id_neurons, legend = NULL, palette = "Harmonic", - radius = 5, + radius = 10, add = FALSE ) From ce1559835fae6da31a5a6ba7214a8ce63e1a6247 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Mon, 24 Mar 2025 10:20:11 -0300 Subject: [PATCH 065/122] improve function documentation --- DESCRIPTION | 1 + NAMESPACE | 5 ++ R/sits_apply.R | 26 ++++++- R/sits_classify.R | 23 ++++++ R/sits_clean.R | 6 ++ R/sits_cube.R | 23 ++++++ R/sits_cube_copy.R | 27 ++++++- R/sits_geo_dist.R | 13 ++++ R/sits_get_class.R | 37 +++++++++- R/sits_get_data.R | 23 ++++++ R/sits_get_probs.R | 28 ++++++- R/sits_label_classification.R | 32 +++++++- R/sits_lighttae.R | 8 ++ R/sits_mixture_model.R | 12 ++- R/sits_mlp.R | 8 ++ R/sits_mosaic.R | 16 ++-- R/sits_plot.R | 1 + R/sits_reclassify.R | 11 ++- R/sits_reduce_imbalance.R | 27 ++++++- R/sits_regularize.R | 64 +++++++++++----- R/sits_segmentation.R | 77 ++++++++++++++----- R/sits_smooth.R | 43 +++++++++++ R/sits_som.R | 70 ++++++++++-------- R/sits_stars.R | 41 ++++++++++- R/sits_tae.R | 8 ++ R/sits_tempcnn.R | 8 ++ R/sits_terra.R | 122 +++++++++++++++++++++++++++++++ R/sits_train.R | 38 ++++++++++ R/sits_tuning.R | 18 +++-- R/sits_uncertainty.R | 28 +++++-- R/sits_validate.R | 2 + R/sits_view.R | 1 + inst/extdata/config_messages.yml | 2 + man/sits_apply.Rd | 26 ++++++- man/sits_as_stars.Rd | 2 +- man/sits_as_terra.Rd | 54 ++++++++++++++ man/sits_classify.Rd | 25 ++++++- man/sits_clean.Rd | 6 ++ man/sits_cube.Rd | 23 ++++++ man/sits_cube_copy.Rd | 27 ++++++- man/sits_geo_dist.Rd | 13 ++++ man/sits_get_class.Rd | 37 +++++++++- man/sits_get_data.Rd | 24 ++++++ man/sits_get_probs.Rd | 28 ++++++- man/sits_kfold_validate.Rd | 5 +- man/sits_label_classification.Rd | 27 ++++++- man/sits_lighttae.Rd | 8 ++ man/sits_mixture_model.Rd | 13 +++- man/sits_mlp.Rd | 7 ++ man/sits_mosaic.Rd | 16 ++-- man/sits_reclassify.Rd | 10 ++- man/sits_reduce_imbalance.Rd | 26 ++++++- man/sits_regularize.Rd | 68 ++++++++++++----- man/sits_segment.Rd | 48 ++++++++++-- man/sits_slic.Rd | 8 ++ man/sits_smooth.Rd | 43 +++++++++++ man/sits_som_clean_samples.Rd | 5 +- man/sits_som_map.Rd | 20 ++--- man/sits_tae.Rd | 8 ++ man/sits_tempcnn.Rd | 11 ++- man/sits_train.Rd | 38 ++++++++++ man/sits_tuning.Rd | 21 ++++-- man/sits_uncertainty.Rd | 28 +++++-- man/sits_view.Rd | 3 +- man/st_as_stars.raster_cube.Rd | 45 ++++++++++++ 65 files changed, 1397 insertions(+), 175 deletions(-) create mode 100644 R/sits_terra.R create mode 100644 man/sits_as_terra.Rd create mode 100644 man/st_as_stars.raster_cube.Rd diff --git a/DESCRIPTION b/DESCRIPTION index fc0e18f8f..70af6cb48 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -256,6 +256,7 @@ Collate: 'sits_summary.R' 'sits_tae.R' 'sits_tempcnn.R' + 'sits_terra.R' 'sits_texture.R' 'sits_timeline.R' 'sits_train.R' diff --git a/NAMESPACE b/NAMESPACE index f1d341e05..3b3fd658f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -343,6 +343,9 @@ S3method(sits_apply,sits) S3method(sits_as_sf,raster_cube) S3method(sits_as_sf,sits) S3method(sits_as_sf,vector_cube) +S3method(sits_as_terra,class_cube) +S3method(sits_as_terra,probs_cube) +S3method(sits_as_terra,raster_cube) S3method(sits_bands,default) S3method(sits_bands,patterns) S3method(sits_bands,raster_cube) @@ -478,6 +481,7 @@ export(sits_add_base_cube) export(sits_apply) export(sits_as_sf) export(sits_as_stars) +export(sits_as_terra) export(sits_bands) export(sits_bbox) export(sits_classify) @@ -564,6 +568,7 @@ export(sits_variance) export(sits_view) export(sits_whittaker) export(sits_xgboost) +export(st_as_stars.raster_cube) importFrom(Rcpp,sourceCpp) importFrom(dplyr,.data) importFrom(lubridate,"%m+%") diff --git a/R/sits_apply.R b/R/sits_apply.R index 2afcc3503..23705320d 100644 --- a/R/sits_apply.R +++ b/R/sits_apply.R @@ -23,7 +23,31 @@ #' @param progress Show progress bar? #' @param ... Named expressions to be evaluated (see details). #' -#' @details +#' @note +#' The main \code{sits} classification workflow has the following steps: +#' \enumerate{ +#' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from +#' a cloud provider.} +#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' from a cloud provider to a local directory for faster processing.} +#' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube +#' from an ARD image collection.} +#' \item{\code{\link[sits]{sits_apply}}: create new indices by combining +#' bands of a regular data cube (optional).} +#' \item{\code{\link[sits]{sits_get_data}}: extract time series +#' from a regular data cube based on user-provided labelled samples.} +#' \item{\code{\link[sits]{sits_train}}: train a machine learning +#' model based on image time series.} +#' \item{\code{\link[sits]{sits_classify}}: classify a data cube +#' using a machine learning model and obtain a probability cube.} +#' \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube +#' using a spatial smoother to remove outliers and +#' increase spatial consistency.} +#' \item{\code{\link[sits]{sits_label_classification}}: produce a +#' classified map by selecting the label with the highest probability +#' from a smoothed cube.} +#' } +#' #' \code{sits_apply()} allows any valid R expression to compute new bands. #' Use R syntax to pass an expression to this function. #' Besides arithmetic operators, you can use virtually any R function diff --git a/R/sits_classify.R b/R/sits_classify.R index 6d1e71717..3372db9a0 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -58,6 +58,29 @@ #' (tibble of class "probs_cube"). #' #' @note +#' The main \code{sits} classification workflow has the following steps: +#' \enumerate{ +#' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from +#' a cloud provider.} +#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' from a cloud provider to a local directory for faster processing.} +#' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube +#' from an ARD image collection.} +#' \item{\code{\link[sits]{sits_apply}}: create new indices by combining +#' bands of a regular data cube (optional).} +#' \item{\code{\link[sits]{sits_get_data}}: extract time series +#' from a regular data cube based on user-provided labelled samples.} +#' \item{\code{\link[sits]{sits_train}}: train a machine learning +#' model based on image time series.} +#' \item{\code{\link[sits]{sits_classify}}: classify a data cube +#' using a machine learning model and obtain a probability cube.} +#' \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube +#' using a spatial smoother to remove outliers and +#' increase spatial consistency.} +#' \item{\code{\link[sits]{sits_label_classification}}: produce a +#' classified map by selecting the label with the highest probability +#' from a smoothed cube.} +#' } #' The \code{sits_classify} function takes three types of data as input #' and produce there types of output: #' \enumerate{ diff --git a/R/sits_clean.R b/R/sits_clean.R index f04cd62b3..af1460e47 100644 --- a/R/sits_clean.R +++ b/R/sits_clean.R @@ -26,6 +26,12 @@ #' #' @return A tibble with an classified map (class = "class_cube"). #' +#' @note +#' The \code{sits_clean} function is useful to further remove +#' classification noise which has not been detected by +#' \code{\link[sits]{sits_smooth}}. It improves the spatial consistency +#' of the classified maps. +#' #' @examples #' if (sits_run_examples()) { #' rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) diff --git a/R/sits_cube.R b/R/sits_cube.R index 1412956c3..996d4ece1 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -64,6 +64,29 @@ #' @return A \code{tibble} describing the contents of a data cube. #' #' @note{ +#' The main \code{sits} classification workflow has the following steps: +#' \enumerate{ +#' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from +#' a cloud provider.} +#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' from a cloud provider to a local directory for faster processing.} +#' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube +#' from an ARD image collection.} +#' \item{\code{\link[sits]{sits_apply}}: create new indices by combining +#' bands of a regular data cube (optional).} +#' \item{\code{\link[sits]{sits_get_data}}: extract time series +#' from a regular data cube based on user-provided labelled samples.} +#' \item{\code{\link[sits]{sits_train}}: train a machine learning +#' model based on image time series.} +#' \item{\code{\link[sits]{sits_classify}}: classify a data cube +#' using a machine learning model and obtain a probability cube.} +#' \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube +#' using a spatial smoother to remove outliers and +#' increase spatial consistency.} +#' \item{\code{\link[sits]{sits_label_classification}}: produce a +#' classified map by selecting the label with the highest probability +#' from a smoothed cube.} +#' } #' #' In \code{sits}, a data cube is represented as a tibble with metadata #' describing a set of image files obtained from cloud providers. diff --git a/R/sits_cube_copy.R b/R/sits_cube_copy.R index 7887d6d82..5050b1a47 100644 --- a/R/sits_cube_copy.R +++ b/R/sits_cube_copy.R @@ -7,7 +7,8 @@ #' This function downloads the images of a cube in parallel. #' A region of interest (\code{roi}) can be provided to crop #' the images and a resolution (\code{res}) to resample the -#' bands. +#' bands. \code{sits_cube_copy} is useful to improve processing time in the +#' regularization operation. #' #' @param cube A data cube (class "raster_cube") #' @param roi Region of interest. Either: @@ -32,8 +33,32 @@ #' @param output_dir Output directory where images will be saved. #' (character vector of length 1). #' @param progress Logical: show progress bar? +#' #' @return Copy of input data cube (class "raster cube"). #' +#' The main \code{sits} classification workflow has the following steps: +#' \enumerate{ +#' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from +#' a cloud provider.} +#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' from a cloud provider to a local directory for faster processing.} +#' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube +#' from an ARD image collection.} +#' \item{\code{\link[sits]{sits_apply}}: create new indices by combining +#' bands of a regular data cube (optional).} +#' \item{\code{\link[sits]{sits_get_data}}: extract time series +#' from a regular data cube based on user-provided labelled samples.} +#' \item{\code{\link[sits]{sits_train}}: train a machine learning +#' model based on image time series.} +#' \item{\code{\link[sits]{sits_classify}}: classify a data cube +#' using a machine learning model and obtain a probability cube.} +#' \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube +#' using a spatial smoother to remove outliers and +#' increase spatial consistency.} +#' \item{\code{\link[sits]{sits_label_classification}}: produce a +#' classified map by selecting the label with the highest probability +#' from a smoothed cube.} +#' } #' @examples #' if (sits_run_examples()) { #' # Creating a sits cube from BDC diff --git a/R/sits_geo_dist.R b/R/sits_geo_dist.R index 7510063ea..b7330af6a 100644 --- a/R/sits_geo_dist.R +++ b/R/sits_geo_dist.R @@ -11,6 +11,19 @@ #' Compute the minimum distances among samples and samples to prediction #' points, following the approach proposed by Meyer and Pebesma(2022). #' +#' @note +#' As pointed out by Meyer and Pebesma, many classifications using machine +#' learning assume that the reference data are independent and +#' well-distributed in space. In practice, many traninng samples are strongly +#' concentrated in some areas, and many large areas have no samples. +#' This function compares two distributions: +#' \enumerate{ +#' \item{The distribution of the spatial distances of reference data +#' to their nearest neighbor (sample-to-sample.} +#' \item{The distribution of distances from all points of study area +#' to the nearest reference data point (sample-to-prediction).} +#' } +#' #' @references #' Meyer, H., Pebesma, E. "Machine learning-based global maps of #' ecological variables and the challenge of assessing them", diff --git a/R/sits_get_class.R b/R/sits_get_class.R index df2e8cb7d..b1f1238cd 100644 --- a/R/sits_get_class.R +++ b/R/sits_get_class.R @@ -3,7 +3,7 @@ #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description Given a set of lat/long locations and a classified cube, -#' retrieve the class of each point. This function is useful to obtian +#' retrieve the class of each point. This function is useful to obtain #' values from classified cubes for accuracy estimates. #' #' @note @@ -16,6 +16,7 @@ #' (e) data.frame: A data.frame with \code{longitude} and \code{latitude}. #' #' +#' #' @param cube Classified data cube. #' @param samples Location of the samples to be retrieved. #' Either a tibble of class "sits", an "sf" object, @@ -23,6 +24,40 @@ #' a data.frame with columns "longitude" and "latitude" #' @return A tibble of with columns #' . +#' @examples +#' if (sits_run_examples()) { +#' # create a random forest model +#' rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) +#' # create a data cube from local files +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' # classify a data cube +#' probs_cube <- sits_classify( +#' data = cube, ml_model = rfor_model, output_dir = tempdir() +#' ) +#' # plot the probability cube +#' plot(probs_cube) +#' # smooth the probability cube using Bayesian statistics +#' bayes_cube <- sits_smooth(probs_cube, output_dir = tempdir()) +#' # plot the smoothed cube +#' plot(bayes_cube) +#' # label the probability cube +#' label_cube <- sits_label_classification( +#' bayes_cube, +#' output_dir = tempdir() +#' ) +#' # obtain the a set of points for sampling +#' ground_truth <- system.file("extdata/samples/samples_sinop_crop.csv", +#' package = "sits" +#' ) +#' # get the classification values for a selected set of locations +#' labels_samples <- sits_get_class(label_cube, ground_truth) +#' } +#' #' @export sits_get_class <- function(cube, samples){ .check_set_caller("sits_get_data") diff --git a/R/sits_get_data.R b/R/sits_get_data.R index 97de7d6d3..7517daa2e 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -11,6 +11,29 @@ #' contains both the satellite image time series and their metadata. #' #' @note +#' The main \code{sits} classification workflow has the following steps: +#' \enumerate{ +#' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from +#' a cloud provider.} +#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' from a cloud provider to a local directory for faster processing.} +#' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube +#' from an ARD image collection.} +#' \item{\code{\link[sits]{sits_apply}}: create new indices by combining +#' bands of a regular data cube (optional).} +#' \item{\code{\link[sits]{sits_get_data}}: extract time series +#' from a regular data cube based on user-provided labelled samples.} +#' \item{\code{\link[sits]{sits_train}}: train a machine learning +#' model based on image time series.} +#' \item{\code{\link[sits]{sits_classify}}: classify a data cube +#' using a machine learning model and obtain a probability cube.} +#' \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube +#' using a spatial smoother to remove outliers and +#' increase spatial consistency.} +#' \item{\code{\link[sits]{sits_label_classification}}: produce a +#' classified map by selecting the label with the highest probability +#' from a smoothed cube.} +#' } #' #' To be able to build a machine learning model to classify a data cube, #' one needs to use a set of labelled time series. These time series diff --git a/R/sits_get_probs.R b/R/sits_get_probs.R index 1cb0a2bdd..5287b1a3d 100644 --- a/R/sits_get_probs.R +++ b/R/sits_get_probs.R @@ -4,7 +4,10 @@ #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description Given a set of lat/long locations and a probability cube, -#' retrieve the prob values of each point. +#' retrieve the prob values of each point. This function is useful +#' to estimate probability distributions and to assess the differences +#' between classifiers. +#' #' @note #' There are four ways of specifying data to be retrieved using the #' \code{samples} parameter: @@ -25,6 +28,29 @@ #' in case no windows #' are requested and #' in case windows are requested +#' @examples +#' if (sits_run_examples()) { +#' # create a random forest model +#' rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) +#' # create a data cube from local files +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' # classify a data cube +#' probs_cube <- sits_classify( +#' data = cube, ml_model = rfor_model, output_dir = tempdir() +#' ) +#' # obtain the a set of points for sampling +#' ground_truth <- system.file("extdata/samples/samples_sinop_crop.csv", +#' package = "sits" +#' ) +#' # get the classification values for a selected set of locations +#' probs_samples <- sits_get_probs(probs_cube, ground_truth) +#' } +#' #' @export sits_get_probs <- function(cube, samples, window_size = NULL){ .check_set_caller("sits_get_probs") diff --git a/R/sits_label_classification.R b/R/sits_label_classification.R index 1ac0b0022..71723a0e8 100644 --- a/R/sits_label_classification.R +++ b/R/sits_label_classification.R @@ -4,8 +4,11 @@ #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Souza, \email{felipe.souza@@inpe.br} #' -#' @description Takes a set of classified raster layers with probabilities, -#' and label them based on the maximum probability for each pixel. +#' @description +#' Takes a set of classified raster layers with probabilities, +#' and labels them based on the maximum probability for each pixel. +#' This function is the final step of main the land classification workflow. +#' #' #' @param cube Classified image data cube. #' @param ... Other parameters for specific functions. @@ -18,7 +21,32 @@ #' (in the case of multiple runs). #' @param progress Show progress bar? #' @return A data cube with an image with the classified map. +#' #' @note +#' The main \code{sits} classification workflow has the following steps: +#' \enumerate{ +#' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from +#' a cloud provider.} +#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' from a cloud provider to a local directory for faster processing.} +#' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube +#' from an ARD image collection.} +#' \item{\code{\link[sits]{sits_apply}}: create new indices by combining +#' bands of a regular data cube (optional).} +#' \item{\code{\link[sits]{sits_get_data}}: extract time series +#' from a regular data cube based on user-provided labelled samples.} +#' \item{\code{\link[sits]{sits_train}}: train a machine learning +#' model based on image time series.} +#' \item{\code{\link[sits]{sits_classify}}: classify a data cube +#' using a machine learning model and obtain a probability cube.} +#' \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube +#' using a spatial smoother to remove outliers and +#' increase spatial consistency.} +#' \item{\code{\link[sits]{sits_label_classification}}: produce a +#' classified map by selecting the label with the highest probability +#' from a smoothed cube.} +#' } +#' #' Please refer to the sits documentation available in #' for detailed examples. #' diff --git a/R/sits_lighttae.R b/R/sits_lighttae.R index c94dd2dde..5770c01f0 100644 --- a/R/sits_lighttae.R +++ b/R/sits_lighttae.R @@ -8,6 +8,14 @@ #' @description Implementation of Light Temporal Attention Encoder (L-TAE) #' for satellite image time series #' +#' @note +#' \code{sits} provides a set of default values for all classification models. +#' These settings have been chosen based on testing by the authors. +#' Nevertheless, users can control all parameters for each model. +#' Novice users can rely on the default values, +#' while experienced ones can fine-tune deep learning models +#' using \code{\link[sits]{sits_tuning}}. +#' #' This function is based on the paper by Vivien Garnot referenced below #' and code available on github at #' https://github.com/VSainteuf/lightweight-temporal-attention-pytorch diff --git a/R/sits_mixture_model.R b/R/sits_mixture_model.R index eeff7ce8a..bf4af64e6 100644 --- a/R/sits_mixture_model.R +++ b/R/sits_mixture_model.R @@ -35,7 +35,17 @@ #' In case of a sits tibble, the time series will be returned with the #' values corresponding to each fraction. #' -#' @details +#' @note +#' Many pixels in images of medium-resolution satellites +#' such as Landsat or Sentinel-2 contain a mixture of +#' spectral responses of different land cover types. +#' In many applications, it is desirable to obtain the proportion +#' of a given class inside a mixed pixel. For this purpose, +#' the literature proposes mixture models; these models represent +#' pixel values as a combination of multiple pure land cover types. +#' Assuming that the spectral response of pure land cover classes +#' (called endmembers) is known, spectral mixture analysis +#' derives new bands containing the proportion of each endmember inside a pixel. #' #' The \code{endmembers} parameter should be a tibble, csv or #' a shapefile. \code{endmembers} parameter must have the following columns: diff --git a/R/sits_mlp.R b/R/sits_mlp.R index fa040c264..89718cee4 100644 --- a/R/sits_mlp.R +++ b/R/sits_mlp.R @@ -36,6 +36,14 @@ #' #' #' @note +#' +#' \code{sits} provides a set of default values for all classification models. +#' These settings have been chosen based on testing by the authors. +#' Nevertheless, users can control all parameters for each model. +#' Novice users can rely on the default values, +#' while experienced ones can fine-tune deep learning models +#' using \code{\link[sits]{sits_tuning}}. +#' #' The default parameters for the MLP have been chosen based on the work by #' Wang et al. 2017 that takes multilayer perceptrons as the baseline #' for time series classifications: diff --git a/R/sits_mosaic.R b/R/sits_mosaic.R index d002e9ffe..c4de5a61b 100644 --- a/R/sits_mosaic.R +++ b/R/sits_mosaic.R @@ -6,11 +6,10 @@ #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description Creates a mosaic of all tiles of a sits cube. -#' Mosaics can be created from EO cubes and derived cubes. -#' In sits EO cubes, the mosaic will be generated for each band and date. -#' It is recommended to filter the image with the less cloud cover to create -#' a mosaic for the EO cubes. -#' It is possible to provide a \code{roi} to crop the mosaic. +#' Mosaics can be created from both regularized ARD images or from classified +#' maps. In the case of ARD images, a mosaic will be produce for each band/date +#' combination. It is better to first regularize the data cubes and then +#' use \code{sits_mosaic}. #' #' @param cube A sits data cube. #' @param crs A target coordinate reference system of raster mosaic. @@ -35,10 +34,9 @@ #' named lat/long values (\code{lon_min}, \code{lon_max}, #' \code{lat_min}, \code{lat_max}). #' -#' The user should specify the crs of the mosaic since in many cases the -#' input images will be in different coordinate systems. For example, -#' when mosaicking Sentinel-2 images the inputs will be in general in -#' different UTM grid zones. +#' When the data cube has tiles that cover different UTM grid zones, +#' the user should specify the CRS of the mosaic. We use +#' "EPSG:3857" (Pseudo-Mercator) as the default. #' #' @examples #' if (sits_run_examples()) { diff --git a/R/sits_plot.R b/R/sits_plot.R index 43a7a9b77..d5a852a79 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -38,6 +38,7 @@ #' time series associated to each combination of band and label, #' and including the median, and first and third quartile ranges. #' +#' #' @examples #' if (sits_run_examples()) { #' # plot sets of time series diff --git a/R/sits_reclassify.R b/R/sits_reclassify.R index ce2b51563..4dd850068 100644 --- a/R/sits_reclassify.R +++ b/R/sits_reclassify.R @@ -22,7 +22,16 @@ #' (character vector of length 1 with valid location). #' @param version Version of resulting image (character). #' -#' @details +#' @note +#' +#' Reclassification of a remote sensing map refers +#' to changing the classes assigned to different pixels in the image. +#' Reclassification involves assigning new classes to pixels based +#' on additional information from a reference map. +#' Users define rules according to the desired outcome. +#' These rules are then applied to the classified map to produce +#' a new map with updated classes. +#' #' \code{sits_reclassify()} allow any valid R expression to compute #' reclassification. User should refer to \code{cube} and \code{mask} #' to construct logical expressions. diff --git a/R/sits_reduce_imbalance.R b/R/sits_reduce_imbalance.R index 9f1f31e07..057c37a88 100644 --- a/R/sits_reduce_imbalance.R +++ b/R/sits_reduce_imbalance.R @@ -19,15 +19,36 @@ #' #' @return A sits tibble with reduced sample imbalance. #' +#' +#' @note +#' Many training samples for Earth observation data analysis are imbalanced. +#' This situation arises when the distribution of samples associated +#' with each label is uneven. +#' Sample imbalance is an undesirable property of a training set. +#' Reducing sample imbalance improves classification accuracy. +#' +#' The function \code{sits_reduce_imbalance} increases the number of samples +#' of least frequent labels, and reduces the number of samples of most +#' frequent labels. To generate new samples, \code{sits} +#' uses the SMOTE method that estimates new samples by considering +#' the cluster formed by the nearest neighbors of each minority label. +#' +#' To perform undersampling, \code{sits_reduce_imbalance}) builds a SOM map +#' for each majority label based on the required number of samples. +#' Each dimension of the SOM is set to ceiling(sqrt(new_number_samples/4)) +#' to allow a reasonable number of neurons to group similar samples. +#' After calculating the SOM map, the algorithm extracts four samples +#' per neuron to generate a reduced set of samples that approximates +#' the variation of the original one. +#' See also \code{\link[sits]{sits_som_map}}. +#' #' @references #' The reference paper on SMOTE is #' N. V. Chawla, K. W. Bowyer, L. O.Hall, W. P. Kegelmeyer, #' “SMOTE: synthetic minority over-sampling technique,” #' Journal of artificial intelligence research, 321-357, 2002. #' -#' Undersampling uses the SOM map developed by Lorena Santos and co-workers -#' and used in the sits_som_map() function. -#' The SOM map technique is described in the paper: +#' The SOM map technique for time series is described in the paper: #' Lorena Santos, Karine Ferreira, Gilberto Camara, Michelle Picoli, #' Rolf Simoes, “Quality control and class noise reduction of satellite #' image time series”. ISPRS Journal of Photogrammetry and Remote Sensing, diff --git a/R/sits_regularize.R b/R/sits_regularize.R index 6533f4d52..3ad398ebc 100644 --- a/R/sits_regularize.R +++ b/R/sits_regularize.R @@ -11,7 +11,7 @@ #' For this reason, subsets of these collection need to be converted to #' regular data cubes before further processing and data analysis. #' This function requires users to include the cloud band in their ARD-based -#' data cubes. +#' data cubes. This function uses the \code{gdalcubes} package. #' #' @references Appel, Marius; Pebesma, Edzer. On-demand processing of data cubes #' from satellite image collections with the gdalcubes library. Data, v. 4, @@ -27,26 +27,61 @@ #' @param res Spatial resolution of regularized images (in meters). #' @param output_dir Valid directory for storing regularized images. #' @param timeline User-defined timeline for regularized cube. -#' @param roi A named \code{numeric} vector with a region of interest. +#' @param roi Region of interest (see notes below). #' @param tiles Tiles to be produced. #' @param grid_system Grid system to be used for the output images. #' @param multicores Number of cores used for regularization; #' used for parallel processing of input (integer) -#' @param grid_system A character with the grid system that images will be -#' cropped. #' @param progress show progress bar? #' #' #' @note +#' The main \code{sits} classification workflow has the following steps: +#' \enumerate{ +#' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from +#' a cloud provider.} +#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' from a cloud provider to a local directory for faster processing.} +#' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube +#' from an ARD image collection.} +#' \item{\code{\link[sits]{sits_apply}}: create new indices by combining +#' bands of a regular data cube (optional).} +#' \item{\code{\link[sits]{sits_get_data}}: extract time series +#' from a regular data cube based on user-provided labelled samples.} +#' \item{\code{\link[sits]{sits_train}}: train a machine learning +#' model based on image time series.} +#' \item{\code{\link[sits]{sits_classify}}: classify a data cube +#' using a machine learning model and obtain a probability cube.} +#' \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube +#' using a spatial smoother to remove outliers and +#' increase spatial consistency.} +#' \item{\code{\link[sits]{sits_label_classification}}: produce a +#' classified map by selecting the label with the highest probability +#' from a smoothed cube.} +#' } +#' The regularization operation converts subsets of image collections +#' available in cloud providers into regular data cubes. It is an essential +#' part of the \code{sits} workflow. +#' The input to \code{sits_regularize} should be an ARD cube +#' which includes the cloud band. The aggregation method used in +#' \code{sits_regularize} sorts the images based on cloud cover, +#' putting images with the least clouds at the top of the stack. Once +#' the stack of images is sorted, the method uses the first valid value to +#' create the temporal aggregation. +#' #' The "period" parameter is mandatory, and defines the time interval -#' between two images of the regularized cube. By default, the date -#' of the first image of the input cube is taken as the starting +#' between two images of the regularized cube. When combining +#' Sentinel-1A and Sentinel-1B images, experiments show that a +#' 16-day period ("P16D") are a good default. Landsat images require +#' a longer period of one to three months. +#' +#' By default, the date of the first image of the input cube +#' is taken as the starting #' date for the regular cube. In many situations, users may want #' to pre-define the required times using the "timeline" parameter. #' The "timeline" parameter, if used, must contain a set of #' dates which are compatible with the input cube. #' -#' #' The optional "roi" parameter defines a region of interest. It can be #' an sf_object, a shapefile, or a bounding box vector with #' named XY values ("xmin", "xmax", "ymin", "ymax") or @@ -54,21 +89,16 @@ #' \code{sits_regularize()} function will crop the images #' that contain the region of interest(). #' -#' The optional "tiles" parameter indicates which tiles of the +#' The optional \code{tiles} parameter indicates which tiles of the #' input cube will be used for regularization. #' -#' The "grid_system" parameters allows the choice of grid system -#' for the regularized cube. Currently, the package supports +#' The \code{grid_system} parameter allows the user to +#' reproject the files to a grid system which is +#' different from that used in the ARD image collection of +#' the could provider. Currently, the package supports #' the use of MGRS grid system and those used by the Brazil #' Data Cube ("BDC_LG_V2" "BDC_MD_V2" "BDC_SM_V2"). #' -#' The aggregation method used in \code{sits_regularize} -#' sorts the images based on cloud cover, where images with the fewest -#' clouds at the top of the stack. Once -#' the stack of images is sorted, the method uses the first valid value to -#' create the temporal aggregation. -#' The input (non-regular) ARD cube needs to include the cloud band for -#' the regularization to work. #' #' @return A \code{raster_cube} object with aggregated images. #' diff --git a/R/sits_segmentation.R b/R/sits_segmentation.R index dceaeb842..41b86fe66 100644 --- a/R/sits_segmentation.R +++ b/R/sits_segmentation.R @@ -9,23 +9,8 @@ #' @description #' Apply a spatial-temporal segmentation on a data cube based on a user defined #' segmentation function. The function applies the segmentation algorithm -#' "seg_fn" to each tile. -#' -#' Segmentation uses the following steps: -#' \enumerate{ -#' \item Create a regular data cube with \code{\link[sits]{sits_cube}} and -#' \code{\link[sits]{sits_regularize}}; -#' \item Run \code{\link[sits]{sits_segment}} to obtain a vector data cube -#' with polygons that define the boundary of the segments; -#' \item Classify the time series associated to the segments -#' with \code{\link[sits]{sits_classify}}, to get obtain -#' a vector probability cube; -#' \item Use \code{\link[sits]{sits_label_classification}} to label the -#' vector probability cube; -#' \item Display the results with \code{\link[sits]{plot}} or -#' \code{\link[sits]{sits_view}}. -#'} -#' +#' "seg_fn" to each tile. The output is a vector data cube, which is a data cube +#' with an additional vector file in "geopackage" format. #' #' @param cube Regular data cube #' @param seg_fn Function to apply the segmentation @@ -44,10 +29,50 @@ #' segmentation. #' #' @note +#' Segmentation requires the following steps: +#' \enumerate{ +#' \item Create a regular data cube with \code{\link[sits]{sits_cube}} and +#' \code{\link[sits]{sits_regularize}}; +#' \item Run \code{\link[sits]{sits_segment}} to obtain a vector data cube +#' with polygons that define the boundary of the segments; +#' \item Classify the time series associated to the segments +#' with \code{\link[sits]{sits_classify}}, to get obtain +#' a vector probability cube; +#' \item Use \code{\link[sits]{sits_label_classification}} to label the +#' vector probability cube; +#' \item Display the results with \code{\link[sits]{plot}} or +#' \code{\link[sits]{sits_view}}. +#'} #' The "roi" parameter defines a region of interest. It can be #' an sf_object, a shapefile, or a bounding box vector with #' named XY values ("xmin", "xmax", "ymin", "ymax") or -#' named lat/long values ("lon_min", "lat_min", "lon_max", "lat_max") +#' named lat/long values ("lon_min", "lat_min", "lon_max", "lat_max"). +#' +#' As of version 1.5.3, the only \code{seg_fn} function available is +#' \code{\link[sits]{sits_slic}}, which uses the Simple Linear +#' Iterative Clustering (SLIC) algorithm that clusters pixels to +#' generate compact, nearly uniform superpixels. This algorithm has been +#' adapted by Nowosad and Stepinski to work with multispectral and +#' multitemporal images. SLIC uses spectral similarity and +#' proximity in the spectral and temporal space to +#' segment the image into superpixels. Superpixels are clusters of pixels +#' with similar spectral and temporal responses that are spatially close. +#' +#' The result of \code{sits_segment} is a data cube tibble with an additional +#' vector file in the \code{geopackage} format. The location of the vector +#' file is included in the data cube tibble in a new column, called +#' \code{vector_info}. +#' +#' @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. +#' +#' 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 #' if (sits_run_examples()) { @@ -61,6 +86,14 @@ #' # segment the vector cube #' segments <- sits_segment( #' cube = cube, +#' seg_fn = sits_slic( +#' step = 10, +#' compactness = 1, +#' dist_fun = "euclidean", +#' avg_fun = "median", +#' iter = 30, +#' minarea = 10 +#' ), #' output_dir = tempdir() #' ) #' # create a classification model @@ -222,6 +255,14 @@ sits_segment <- function(cube, #' # segment the vector cube #' segments <- sits_segment( #' cube = cube, +#' seg_fn = sits_slic( +#' step = 10, +#' compactness = 1, +#' dist_fun = "euclidean", +#' avg_fun = "median", +#' iter = 30, +#' minarea = 10 +#' ), #' output_dir = tempdir(), #' version = "slic-demo" #' ) diff --git a/R/sits_smooth.R b/R/sits_smooth.R index 0865c03bb..37ca986dd 100644 --- a/R/sits_smooth.R +++ b/R/sits_smooth.R @@ -33,6 +33,49 @@ #' #' @return A data cube. #' +#' @note +#' The main \code{sits} classification workflow has the following steps: +#' \enumerate{ +#' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from +#' a cloud provider.} +#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' from a cloud provider to a local directory for faster processing.} +#' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube +#' from an ARD image collection.} +#' \item{\code{\link[sits]{sits_apply}}: create new indices by combining +#' bands of a regular data cube (optional).} +#' \item{\code{\link[sits]{sits_get_data}}: extract time series +#' from a regular data cube based on user-provided labelled samples.} +#' \item{\code{\link[sits]{sits_train}}: train a machine learning +#' model based on image time series.} +#' \item{\code{\link[sits]{sits_classify}}: classify a data cube +#' using a machine learning model and obtain a probability cube.} +#' \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube +#' using a spatial smoother to remove outliers and +#' increase spatial consistency.} +#' \item{\code{\link[sits]{sits_label_classification}}: produce a +#' classified map by selecting the label with the highest probability +#' from a smoothed cube.} +#' } +#' Machine learning algorithms rely on training samples that are +#' derived from “pure” pixels, hand-picked by users to represent +#' the desired output classes. +#' Given the presence of mixed pixels in images regardless of resolution, +#' and the considerable data variability within each class, +#' these classifiers often produce results with misclassified pixels. +#' +#' Post-processing the results of \code{\link[sits]{sits_classify}} +#' using \code{sits_smooth} reduces salt-and-pepper and border effects. +#' By minimizing noise, \code{sits_smooth} brings a significant gain +#' in the overall accuracy and interpretability of the final output. +#' +#' @references +#' Gilberto Camara, Renato Assunção, Alexandre Carvalho, Rolf Simões, +#' Felipe Souza, Felipe Carlos, Anielli Souza, Ana Rorato, +#' Ana Paula Del’Asta, “Bayesian inference +#' for post-processing of remote sensing image classification”. +#' Remote Sensing, 16(23), 4572, 2024. DOI: https://doi.org/10.3390/rs16234572. +#' #' @examples #' if (sits_run_examples()) { #' # create am xgboost model diff --git a/R/sits_som.R b/R/sits_som.R index 11b9bee50..f1c6a8ba8 100644 --- a/R/sits_som.R +++ b/R/sits_som.R @@ -6,20 +6,40 @@ #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @description These function use self-organized maps to perform -#' quality analysis in satellite image time series +#' quality analysis in satellite image time series. #' -#' \code{sits_som_map()} creates a SOM map, where high-dimensional data -#' is mapped into a two dimensional map, keeping the topological relations +#' +#' +#' @param data A tibble with samples to be clustered. +#' @param grid_xdim X dimension of the SOM grid (default = 25). +#' @param grid_ydim Y dimension of the SOM grid. +#' @param alpha Starting learning rate +#' (decreases according to number of iterations). +#' @param distance The type of similarity measure (distance). The +#' following similarity measurements are supported: +#' \code{"euclidean"} and \code{"dtw"}. The default +#' similarity measure is \code{"dtw"}. +#' @param rlen Number of iterations to produce the SOM. +#' @param som_radius Radius of SOM neighborhood. +#' @param mode Type of learning algorithm. The +#' following learning algorithm are available: +#' \code{"online"}, \code{"batch"}, and \code{"pbatch"}. +#' The default learning algorithm is \code{"online"}. +#' +#' @note +#' \code{\link[sits]{sits_som_map}} creates a SOM map, where +#' high-dimensional data is mapped into a two dimensional map, +#' keeping the topological relations #' between data patterns. Each sample is assigned to a neuron, #' and neurons are placed in the grid based on similarity. #' -#' \code{sits_som_evaluate_cluster()} analyses the neurons of the SOM map, -#' and builds clusters based on them. Each cluster is a neuron +#' \code{\link[sits]{sits_som_evaluate_cluster}} analyses the neurons of +#' the SOM map, and builds clusters based on them. Each cluster is a neuron #' or a set of neuron categorized with same label. #' It produces a tibble with the percentage of mixture of classes #' in each cluster. #' -#' \code{sits_som_clean_samples()} evaluates the quality of the samples +#' \code{\link[sits]{sits_som_clean_samples}} evaluates sample quality #' based on the results of the SOM map. The algorithm identifies noisy samples, #' using `prior_threshold` for the prior probability #' and `posterior_threshold` for the posterior probability. @@ -31,9 +51,18 @@ #' (c) If the prior probability is >= `posterior_threshold` and #' the posterior probability is < `posterior_threshold`, the sample is tagged as #' "analyze" for further inspection. +#' #' The user can define which tagged samples will be returned using the "keep" #' parameter, with the following options: "clean", "analyze", "remove". #' +#' To learn more about the learning algorithms, check the +#' \code{\link[kohonen:supersom]{kohonen::supersom}} function. +#' +#' The \code{sits} package implements the \code{"dtw"} (Dynamic Time +#' Warping) similarity measure. The \code{"euclidean"} similarity +#' measurement come from the +#' \code{\link[kohonen:supersom]{kohonen::supersom (dist.fcts)}} function. +#' #' @references #' Lorena Santos, Karine Ferreira, Gilberto Camara, Michelle Picoli, #' Rolf Simoes, “Quality control and class noise reduction of satellite @@ -41,30 +70,6 @@ #' vol. 177, pp 75-88, 2021. https://doi.org/10.1016/j.isprsjprs.2021.04.014. #' #' -#' @param data A tibble with samples to be clustered. -#' @param grid_xdim X dimension of the SOM grid (default = 25). -#' @param grid_ydim Y dimension of the SOM grid. -#' @param alpha Starting learning rate -#' (decreases according to number of iterations). -#' @param distance The type of similarity measure (distance). The -#' following similarity measurements are supported: -#' \code{"euclidean"} and \code{"dtw"}. The default -#' similarity measure is \code{"dtw"}. -#' @param rlen Number of iterations to produce the SOM. -#' @param som_radius Radius of SOM neighborhood. -#' @param mode Type of learning algorithm. The -#' following learning algorithm are available: -#' \code{"online"}, \code{"batch"}, and \code{"pbatch"}. -#' The default learning algorithm is \code{"online"}. -#' -#' @note To learn more about the learning algorithms, check the -#' \code{\link[kohonen:supersom]{kohonen::supersom}} function. -#' -#' @note The \code{sits} package implements the \code{"dtw"} (Dynamic Time -#' Warping) similarity measure. The \code{"euclidean"} similarity -#' measurement come from the -#' \code{\link[kohonen:supersom]{kohonen::supersom (dist.fcts)}} function. -#' #' @return #' \code{sits_som_map()} produces a list with three members: #' (1) the samples tibble, with one additional column indicating @@ -211,7 +216,10 @@ sits_som_map <- function(data, #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @description #' \code{sits_som_clean_samples()} evaluates the quality of the samples -#' based on the results of the SOM map. The algorithm identifies noisy samples, +#' based on the results of the SOM map. +#' +#' @note +#' The algorithm identifies noisy samples, #' using `prior_threshold` for the prior probability #' and `posterior_threshold` for the posterior probability. #' Each sample receives an evaluation tag, according to the following rule: diff --git a/R/sits_stars.R b/R/sits_stars.R index 583bd4829..8cdff1b01 100644 --- a/R/sits_stars.R +++ b/R/sits_stars.R @@ -11,7 +11,7 @@ #' @param cube A sits cube. #' @param tile Tile of the data cube. #' @param bands Bands of the data cube to be part of \code{stars} object. -#' @param dates Bands of the data cube to be part of \code{stars} object. +#' @param dates Dates of the data cube to be part of \code{stars} object. #' @param proxy Produce a stars proxy object. #' @return An space-time stars object. #' @@ -86,3 +86,42 @@ sits_as_stars <- function(cube, ) return(stars_obj) } +#' @title Extension to stars for exporting sits cubes as stars objects +#' @name st_as_stars.raster_cube +#' @author Gilberto Camara, \email{gilberto.camara.inpe@@gmail.com} +#' +#' @description Uses the information about files, bands and dates +#' in a data cube to produce an object of class \code{stars}. +#' User has to select a tile from the data cube. By default, +#' all bands and dates are included in the \code{stars} object. +#' Users can select bands and dates. +#' +#' @param .x A sits cube. +#' @param ... Other parameters for st_as_stars +#' @return A space-time stars object. +#' +#' @note +#' By default, the \code{stars} object will be loaded in memory. This +#' can result in heavy memory usage. To produce a \code{stars.proxy} object, +#' uses have to select a single date, since \code{stars} does not allow +#' proxy objects to be created with two dimensions. +#' @examples +#' if (sits_run_examples()) { +#' library(stars) +#' # convert sits cube to an sf object (polygon) +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' stars_object <- st_as_stars(cube) +#' } +#' @export +st_as_stars.raster_cube <- function(.x, ...){ + stars_obj <- sits_as_stars(.x, + tile = .x[1,]$tile, + bands = NULL, + dates = NULL, + proxy = FALSE) +} diff --git a/R/sits_tae.R b/R/sits_tae.R index 38dffc502..e5af9c07a 100644 --- a/R/sits_tae.R +++ b/R/sits_tae.R @@ -9,6 +9,14 @@ #' @description Implementation of Temporal Attention Encoder (TAE) #' for satellite image time series classification. #' +#' @note +#' \code{sits} provides a set of default values for all classification models. +#' These settings have been chosen based on testing by the authors. +#' Nevertheless, users can control all parameters for each model. +#' Novice users can rely on the default values, +#' while experienced ones can fine-tune deep learning models +#' using \code{\link[sits]{sits_tuning}}. +#' #' This function is based on the paper by Vivien Garnot referenced below #' and code available on github at #' https://github.com/VSainteuf/pytorch-psetae. diff --git a/R/sits_tempcnn.R b/R/sits_tempcnn.R index a2d26907e..448093a5c 100644 --- a/R/sits_tempcnn.R +++ b/R/sits_tempcnn.R @@ -11,6 +11,14 @@ #' Users can define the depth of the 1D network, as well as #' the number of perceptron layers. #' +#' @note +#' \code{sits} provides a set of default values for all classification models. +#' These settings have been chosen based on testing by the authors. +#' Nevertheless, users can control all parameters for each model. +#' Novice users can rely on the default values, +#' while experienced ones can fine-tune deep learning models +#' using \code{\link[sits]{sits_tuning}}. +#' #' This function is based on the paper by Charlotte Pelletier referenced below. #' If you use this method, please cite the original tempCNN paper. #' diff --git a/R/sits_terra.R b/R/sits_terra.R new file mode 100644 index 000000000..5fc6f44bb --- /dev/null +++ b/R/sits_terra.R @@ -0,0 +1,122 @@ +#' @title Convert a data cube into a Spatial Raster object from terra +#' @name sits_as_terra +#' @author Gilberto Camara, \email{gilberto.camara.inpe@@gmail.com} +#' +#' @description Uses the information about files, bands and dates +#' in a data cube to produce an object of class \code{terra}. +#' User has to select a tile and a date from the data cube. By default, +#' all bands are included in the \code{terra} object. +#' Users can select bands. +#' +#' @param cube A sits cube. +#' @param tile Tile of the data cube. +#' @param ... Other parameters for specific types of data cubes. +#' @param bands Bands of the data cube to be part of \code{terra} object. +#' @param date Date of the data cube to be part of \code{terra} object. +#' @return An Spatial Raster object from \code{terra}. +#' +#' @examples +#' if (sits_run_examples()) { +#' +#' # convert sits cube to an sf object (polygon) +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' spat_raster <- sits_as_terra(cube) +#' } +#' @export +sits_as_terra <- function(cube, + tile = cube[1,]$tile, + ...){ + # Pre-conditions + .check_set_caller("sits_as_terra") + .check_is_raster_cube(cube) + .check_chr_parameter(tile, len_max = 1) + .check_chr_contains(cube[["tile"]], contains = tile, + discriminator = "any_of", + msg = .conf("messages", "sits_as_terra_tile")) + + UseMethod("sits_as_terra", cube) +} +#' @rdname sits_as_terra +#' @export +sits_as_terra.raster_cube <- function(cube, + tile = cube[1,]$tile, + ..., + bands = NULL, + date = NULL){ + # extract tile from cube + tile_cube <- .cube_filter_tiles(cube, tile) + # get file info for tile + fi <- .fi(tile_cube) + + # filter bands + if (.has(bands)) { + .check_cube_bands(tile_cube, bands) + fi <- .fi_filter_bands(fi, bands) + } else + bands <- .tile_bands(tile_cube) + + # filter dates + if (.has(date)) + .check_dates_timeline(date, tile_cube) + else + date <- as.Date(.tile_timeline(tile_cube)[[1]]) + + fi <- .fi_filter_dates(fi, date) + + # retrieve files + image_files <- .fi_paths(fi) + + # export spatial raster + spatial_raster <- terra::rast(image_files) + + return(spatial_raster) +} +#' @rdname sits_as_terra +#' @export +sits_as_terra.probs_cube <- function(cube, + tile = cube[1,]$tile, + ...){ + # extract tile from cube + tile_cube <- .cube_filter_tiles(cube, tile) + # get file info for tile + fi <- .fi(tile_cube) + # retrieve file + image_file <- .fi_paths(fi) + # export spatial raster + spatial_raster <- terra::rast(image_file) + # get all labels + labels <- .tile_labels(tile_cube) + # save names in terra object + names(spatial_raster) <- labels + # return + return(spatial_raster) +} +#' @rdname sits_as_terra +#' @export +sits_as_terra.class_cube <- function(cube, + tile = cube[1,]$tile, + ...){ + # extract tile from cube + tile_cube <- .cube_filter_tiles(cube, tile) + # get file info for tile + fi <- .fi(tile_cube) + # retrieve file + image_file <- .fi_paths(fi) + # create spatial raster + spatial_raster <- terra::rast(image_file) + # get all labels + labels <- .tile_labels(tile_cube) + # set levels for raster + terra_levels <- data.frame( + id = as.numeric(names(labels)), + cover = unname(labels) + ) + levels(spatial_raster) <- terra_levels + # return + return(spatial_raster) +} diff --git a/R/sits_train.R b/R/sits_train.R index 5471240a2..533ae2f99 100644 --- a/R/sits_train.R +++ b/R/sits_train.R @@ -20,6 +20,44 @@ #' @return Model fitted to input data #' to be passed to \code{\link[sits]{sits_classify}} #' +#' @note +#' The main \code{sits} classification workflow has the following steps: +#' \enumerate{ +#' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from +#' a cloud provider.} +#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' from a cloud provider to a local directory for faster processing.} +#' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube +#' from an ARD image collection.} +#' \item{\code{\link[sits]{sits_apply}}: create new indices by combining +#' bands of a regular data cube (optional).} +#' \item{\code{\link[sits]{sits_get_data}}: extract time series +#' from a regular data cube based on user-provided labelled samples.} +#' \item{\code{\link[sits]{sits_train}}: train a machine learning +#' model based on image time series.} +#' \item{\code{\link[sits]{sits_classify}}: classify a data cube +#' using a machine learning model and obtain a probability cube.} +#' \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube +#' using a spatial smoother to remove outliers and +#' increase spatial consistency.} +#' \item{\code{\link[sits]{sits_label_classification}}: produce a +#' classified map by selecting the label with the highest probability +#' from a smoothed cube.} +#' } +#' +#' \code{sits_train} provides a standard interface to all machine learning models. +#' It takes two mandatory parameters: the training data (\code{samples}) +#' and the ML algorithm (\code{ml_method}). The output is a model that +#' can be used to classify individual time series or data cubes +#' with \code{\link[sits]{sits_classify}}. +#' +#' \code{sits} provides a set of default values for all classification models. +#' These settings have been chosen based on testing by the authors. +#' Nevertheless, users can control all parameters for each model. +#' Novice users can rely on the default values, +#' while experienced ones can fine-tune deep learning models +#' using \code{\link[sits]{sits_tuning}}. +#' #' @examples #' if (sits_run_examples()) { #' # Retrieve the set of samples for Mato Grosso diff --git a/R/sits_tuning.R b/R/sits_tuning.R index 88d8fb736..a14847f3d 100644 --- a/R/sits_tuning.R +++ b/R/sits_tuning.R @@ -3,19 +3,25 @@ #' #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @description +#' This function performs a random search on values of selected hyperparameters, +#' and produces a data frame with the accuracy and kappa values produced +#' by a validation procedure. The result allows users to select appropriate +#' hyperparameters for deep learning models. +#' +#' @note #' Machine learning models use stochastic gradient descent (SGD) techniques to #' find optimal solutions. To perform SGD, models use optimization #' algorithms which have hyperparameters that have to be adjusted #' to achieve best performance for each application. -#' -#' This function performs a random search on values of selected hyperparameters. +# #' Instead of performing an exhaustive test of all parameter combinations, -#' it selecting them randomly. Validation is done using an independent set +#' \code{sits_tuning} selects them randomly. +#' Validation is done using an independent set #' of samples or by a validation split. The function returns the #' best hyper-parameters in a list. Hyper-parameters passed to \code{params} -#' parameter should be passed by calling \code{sits_tuning_hparams()}. +#' parameter should be passed by calling +#' \code{\link[sits]{sits_tuning_hparams}}. #' -#' @note #' When using a GPU for deep learning, \code{gpu_memory} indicates the #' memory of the graphics card which is available for processing. #' The parameter \code{batch_size} defines the size of the matrix @@ -59,7 +65,7 @@ #' #' @return #' A tibble containing all parameters used to train on each trial -#' ordered by accuracy +#' ordered by accuracy. #' #' @examples #' if (sits_run_examples()) { diff --git a/R/sits_uncertainty.R b/R/sits_uncertainty.R index 2d145aea1..71f1e04b9 100644 --- a/R/sits_uncertainty.R +++ b/R/sits_uncertainty.R @@ -17,15 +17,31 @@ #' @return An uncertainty data cube #' #' @description Calculate the uncertainty cube based on the probabilities -#' produced by the classifier. Takes a probability cube as input. +#' produced by the classifier. Takes a \code{probability cube} as input and +#' produces a \code{uncertainty cube}. +#' +#' @note +#' The output of \code{\link[sits]{sits_classify}} and +#' \code{\link[sits]{sits_smooth}} is a \code{probability cube} containing +#' the class probability for all pixels, which are generated by the +#' machine learning model. The \code{sits_uncertainty} function takes +#' a \code{probability cube} and produces a \code{uncertainty code} which +#' contains a measure of uncertainty for each pixel, based on the +#' class probabilities. +#' #' The uncertainty measure is relevant in the context of active leaning, #' and helps to increase the quantity and quality of training samples by #' providing information about the confidence of the model. -#' The supported types of uncertainty are 'entropy', 'least', and 'margin'. -#' 'entropy' is the difference between all predictions expressed as -#' entropy, 'least' is the difference between 1.0 and most confident -#' prediction, and 'margin' is the difference between the two most confident -#' predictions. +#' +#' The supported types of uncertainty are: +#' \enumerate{ +#' \item{\code{entropy}: the difference between all predictions expressed a +#' Shannon measure of entropy.} +#' \item{\code{least}: the difference between 1.0 and most confident +#' prediction.} +#' \item{\code{margin}: the difference between the two most confident +#' predictions.} +#' } #' #' @references Monarch, Robert Munro. Human-in-the-Loop Machine Learning: #' Active learning and annotation for human-centered AI. Simon and Schuster, diff --git a/R/sits_validate.R b/R/sits_validate.R index 375d07ecd..f6c26ba69 100644 --- a/R/sits_validate.R +++ b/R/sits_validate.R @@ -5,6 +5,8 @@ #' #' @description Splits the set of time series into training and validation and #' perform k-fold cross-validation. +#' +#' @note #' Cross-validation is a technique for assessing how the results #' of a statistical analysis will generalize to an independent data set. #' It is mainly used in settings where the goal is prediction, diff --git a/R/sits_view.R b/R/sits_view.R index 6bfc2db64..ac8af21b7 100644 --- a/R/sits_view.R +++ b/R/sits_view.R @@ -5,6 +5,7 @@ #' @description Uses leaflet to visualize time series, raster cube and #' classified images. #' +#' @note #' To show a false color image, use "band" to chose one #' of the bands, "tiles" to select tiles, #' "first_quantile" and "last_quantile" to set the cutoff points. Choose diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index a4e43fe94..215797669 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -345,6 +345,8 @@ sits_as_stars: "invalid parameters in sits_as_stars" sits_as_stars_tile: "tile is not part of the cube" sits_as_stars_bands: "bands are not included in the cube" sits_as_stars_dates: "dates are not included in the cube" +sits_as_terra: "invalid parameters" +sits_as_terra_tile: "tile is not part of the cube" sits_apply: "invalid input data and/or function to be applied" sits_apply_out_band: "output band already exists in data cube and will be replaced" sits_apply_derived_cube: "input data should be a non-classified cube" diff --git a/man/sits_apply.Rd b/man/sits_apply.Rd index 1329dd71e..43f717268 100644 --- a/man/sits_apply.Rd +++ b/man/sits_apply.Rd @@ -56,7 +56,31 @@ Apply a named expression to a sits cube or a sits tibble to be evaluated and generate new bands (indices). In the case of sits cubes, it creates a new band in \code{output_dir}. } -\details{ +\note{ +The main \code{sits} classification workflow has the following steps: +\enumerate{ + \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from + a cloud provider.} + \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + from a cloud provider to a local directory for faster processing.} + \item{\code{\link[sits]{sits_regularize}}: create a regular data cube + from an ARD image collection.} + \item{\code{\link[sits]{sits_apply}}: create new indices by combining + bands of a regular data cube (optional).} + \item{\code{\link[sits]{sits_get_data}}: extract time series + from a regular data cube based on user-provided labelled samples.} + \item{\code{\link[sits]{sits_train}}: train a machine learning + model based on image time series.} + \item{\code{\link[sits]{sits_classify}}: classify a data cube + using a machine learning model and obtain a probability cube.} + \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube + using a spatial smoother to remove outliers and + increase spatial consistency.} + \item{\code{\link[sits]{sits_label_classification}}: produce a + classified map by selecting the label with the highest probability + from a smoothed cube.} +} + \code{sits_apply()} allows any valid R expression to compute new bands. Use R syntax to pass an expression to this function. Besides arithmetic operators, you can use virtually any R function diff --git a/man/sits_as_stars.Rd b/man/sits_as_stars.Rd index 152e7ef6e..ec41cbfd0 100644 --- a/man/sits_as_stars.Rd +++ b/man/sits_as_stars.Rd @@ -19,7 +19,7 @@ sits_as_stars( \item{bands}{Bands of the data cube to be part of \code{stars} object.} -\item{dates}{Bands of the data cube to be part of \code{stars} object.} +\item{dates}{Dates of the data cube to be part of \code{stars} object.} \item{proxy}{Produce a stars proxy object.} } diff --git a/man/sits_as_terra.Rd b/man/sits_as_terra.Rd new file mode 100644 index 000000000..e5832bb70 --- /dev/null +++ b/man/sits_as_terra.Rd @@ -0,0 +1,54 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_terra.R +\name{sits_as_terra} +\alias{sits_as_terra} +\alias{sits_as_terra.raster_cube} +\alias{sits_as_terra.probs_cube} +\alias{sits_as_terra.class_cube} +\title{Convert a data cube into a Spatial Raster object from terra} +\usage{ +sits_as_terra(cube, tile = cube[1, ]$tile, ...) + +\method{sits_as_terra}{raster_cube}(cube, tile = cube[1, ]$tile, ..., bands = NULL, date = NULL) + +\method{sits_as_terra}{probs_cube}(cube, tile = cube[1, ]$tile, ...) + +\method{sits_as_terra}{class_cube}(cube, tile = cube[1, ]$tile, ...) +} +\arguments{ +\item{cube}{A sits cube.} + +\item{tile}{Tile of the data cube.} + +\item{...}{Other parameters for specific types of data cubes.} + +\item{bands}{Bands of the data cube to be part of \code{terra} object.} + +\item{date}{Date of the data cube to be part of \code{terra} object.} +} +\value{ +An Spatial Raster object from \code{terra}. +} +\description{ +Uses the information about files, bands and dates +in a data cube to produce an object of class \code{terra}. +User has to select a tile and a date from the data cube. By default, +all bands are included in the \code{terra} object. +Users can select bands. +} +\examples{ +if (sits_run_examples()) { + + # convert sits cube to an sf object (polygon) + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + spat_raster <- sits_as_terra(cube) +} +} +\author{ +Gilberto Camara, \email{gilberto.camara.inpe@gmail.com} +} diff --git a/man/sits_classify.Rd b/man/sits_classify.Rd index 9be0d85be..e73d911ad 100644 --- a/man/sits_classify.Rd +++ b/man/sits_classify.Rd @@ -141,7 +141,30 @@ SITS supports the following models: } } \note{ -The \code{sits_classify} function takes three types of data as input +The main \code{sits} classification workflow has the following steps: +\enumerate{ + \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from + a cloud provider.} + \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + from a cloud provider to a local directory for faster processing.} + \item{\code{\link[sits]{sits_regularize}}: create a regular data cube + from an ARD image collection.} + \item{\code{\link[sits]{sits_apply}}: create new indices by combining + bands of a regular data cube (optional).} + \item{\code{\link[sits]{sits_get_data}}: extract time series + from a regular data cube based on user-provided labelled samples.} + \item{\code{\link[sits]{sits_train}}: train a machine learning + model based on image time series.} + \item{\code{\link[sits]{sits_classify}}: classify a data cube + using a machine learning model and obtain a probability cube.} + \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube + using a spatial smoother to remove outliers and + increase spatial consistency.} + \item{\code{\link[sits]{sits_label_classification}}: produce a + classified map by selecting the label with the highest probability + from a smoothed cube.} +} + The \code{sits_classify} function takes three types of data as input and produce there types of output: \enumerate{ \item{A set of time series. The output is the same set diff --git a/man/sits_clean.Rd b/man/sits_clean.Rd index 2097cc437..b89af4075 100644 --- a/man/sits_clean.Rd +++ b/man/sits_clean.Rd @@ -88,6 +88,12 @@ In a tie, the first value of the vector is considered. Modal functions applied to classified cubes are useful to remove salt-and-pepper noise in the result. } +\note{ +The \code{sits_clean} function is useful to further remove +classification noise which has not been detected by +\code{\link[sits]{sits_smooth}}. It improves the spatial consistency +of the classified maps. +} \examples{ if (sits_run_examples()) { rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) diff --git a/man/sits_cube.Rd b/man/sits_cube.Rd index 62816b99e..69c1ce4c6 100644 --- a/man/sits_cube.Rd +++ b/man/sits_cube.Rd @@ -141,6 +141,29 @@ USGS Landsat (USGS). Data cubes can also be created using local files. } \note{ { +The main \code{sits} classification workflow has the following steps: +\enumerate{ + \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from + a cloud provider.} + \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + from a cloud provider to a local directory for faster processing.} + \item{\code{\link[sits]{sits_regularize}}: create a regular data cube + from an ARD image collection.} + \item{\code{\link[sits]{sits_apply}}: create new indices by combining + bands of a regular data cube (optional).} + \item{\code{\link[sits]{sits_get_data}}: extract time series + from a regular data cube based on user-provided labelled samples.} + \item{\code{\link[sits]{sits_train}}: train a machine learning + model based on image time series.} + \item{\code{\link[sits]{sits_classify}}: classify a data cube + using a machine learning model and obtain a probability cube.} + \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube + using a spatial smoother to remove outliers and + increase spatial consistency.} + \item{\code{\link[sits]{sits_label_classification}}: produce a + classified map by selecting the label with the highest probability + from a smoothed cube.} +} In \code{sits}, a data cube is represented as a tibble with metadata describing a set of image files obtained from cloud providers. diff --git a/man/sits_cube_copy.Rd b/man/sits_cube_copy.Rd index 0b618eb32..1535571b3 100644 --- a/man/sits_cube_copy.Rd +++ b/man/sits_cube_copy.Rd @@ -49,12 +49,37 @@ Default is 3.} } \value{ Copy of input data cube (class "raster cube"). + +The main \code{sits} classification workflow has the following steps: +\enumerate{ + \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from + a cloud provider.} + \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + from a cloud provider to a local directory for faster processing.} + \item{\code{\link[sits]{sits_regularize}}: create a regular data cube + from an ARD image collection.} + \item{\code{\link[sits]{sits_apply}}: create new indices by combining + bands of a regular data cube (optional).} + \item{\code{\link[sits]{sits_get_data}}: extract time series + from a regular data cube based on user-provided labelled samples.} + \item{\code{\link[sits]{sits_train}}: train a machine learning + model based on image time series.} + \item{\code{\link[sits]{sits_classify}}: classify a data cube + using a machine learning model and obtain a probability cube.} + \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube + using a spatial smoother to remove outliers and + increase spatial consistency.} + \item{\code{\link[sits]{sits_label_classification}}: produce a + classified map by selecting the label with the highest probability + from a smoothed cube.} +} } \description{ This function downloads the images of a cube in parallel. A region of interest (\code{roi}) can be provided to crop the images and a resolution (\code{res}) to resample the -bands. +bands. \code{sits_cube_copy} is useful to improve processing time in the +regularization operation. } \examples{ if (sits_run_examples()) { diff --git a/man/sits_geo_dist.Rd b/man/sits_geo_dist.Rd index 5a43b590d..9e385164b 100644 --- a/man/sits_geo_dist.Rd +++ b/man/sits_geo_dist.Rd @@ -25,6 +25,19 @@ A tibble with sample-to-sample and sample-to-prediction distances Compute the minimum distances among samples and samples to prediction points, following the approach proposed by Meyer and Pebesma(2022). } +\note{ +As pointed out by Meyer and Pebesma, many classifications using machine +learning assume that the reference data are independent and +well-distributed in space. In practice, many traninng samples are strongly +concentrated in some areas, and many large areas have no samples. +This function compares two distributions: +\enumerate{ +\item{The distribution of the spatial distances of reference data +to their nearest neighbor (sample-to-sample.} +\item{The distribution of distances from all points of study area +to the nearest reference data point (sample-to-prediction).} +} +} \examples{ if (sits_run_examples()) { # read a shapefile for the state of Mato Grosso, Brazil diff --git a/man/sits_get_class.Rd b/man/sits_get_class.Rd index a6319a618..47bfdfcbe 100644 --- a/man/sits_get_class.Rd +++ b/man/sits_get_class.Rd @@ -38,7 +38,7 @@ A tibble of with columns } \description{ Given a set of lat/long locations and a classified cube, -retrieve the class of each point. This function is useful to obtian +retrieve the class of each point. This function is useful to obtain values from classified cubes for accuracy estimates. } \note{ @@ -49,6 +49,41 @@ There are four ways of specifying data to be retrieved using the (c) sits object: A sits tibble; (d) sf object: An \code{link[sf]{sf}} object with POINT or geometry; (e) data.frame: A data.frame with \code{longitude} and \code{latitude}. +} +\examples{ +if (sits_run_examples()) { + # create a random forest model + rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) + # create a data cube from local files + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + # classify a data cube + probs_cube <- sits_classify( + data = cube, ml_model = rfor_model, output_dir = tempdir() + ) + # plot the probability cube + plot(probs_cube) + # smooth the probability cube using Bayesian statistics + bayes_cube <- sits_smooth(probs_cube, output_dir = tempdir()) + # plot the smoothed cube + plot(bayes_cube) + # label the probability cube + label_cube <- sits_label_classification( + bayes_cube, + output_dir = tempdir() + ) + # obtain the a set of points for sampling + ground_truth <- system.file("extdata/samples/samples_sinop_crop.csv", + package = "sits" + ) + # get the classification values for a selected set of locations + labels_samples <- sits_get_class(label_cube, ground_truth) +} + } \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} diff --git a/man/sits_get_data.Rd b/man/sits_get_data.Rd index 5ed2847df..6a830e165 100644 --- a/man/sits_get_data.Rd +++ b/man/sits_get_data.Rd @@ -141,6 +141,30 @@ and put the result in a "sits tibble", which contains both the satellite image time series and their metadata. } \note{ +The main \code{sits} classification workflow has the following steps: +\enumerate{ + \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from + a cloud provider.} + \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + from a cloud provider to a local directory for faster processing.} + \item{\code{\link[sits]{sits_regularize}}: create a regular data cube + from an ARD image collection.} + \item{\code{\link[sits]{sits_apply}}: create new indices by combining + bands of a regular data cube (optional).} + \item{\code{\link[sits]{sits_get_data}}: extract time series + from a regular data cube based on user-provided labelled samples.} + \item{\code{\link[sits]{sits_train}}: train a machine learning + model based on image time series.} + \item{\code{\link[sits]{sits_classify}}: classify a data cube + using a machine learning model and obtain a probability cube.} + \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube + using a spatial smoother to remove outliers and + increase spatial consistency.} + \item{\code{\link[sits]{sits_label_classification}}: produce a + classified map by selecting the label with the highest probability + from a smoothed cube.} +} + To be able to build a machine learning model to classify a data cube, one needs to use a set of labelled time series. These time series are created by taking a set of known samples, expressed as diff --git a/man/sits_get_probs.Rd b/man/sits_get_probs.Rd index 15c96083d..be92c2046 100644 --- a/man/sits_get_probs.Rd +++ b/man/sits_get_probs.Rd @@ -42,7 +42,9 @@ A tibble of with columns } \description{ Given a set of lat/long locations and a probability cube, -retrieve the prob values of each point. +retrieve the prob values of each point. This function is useful +to estimate probability distributions and to assess the differences +between classifiers. } \note{ There are four ways of specifying data to be retrieved using the @@ -52,6 +54,30 @@ There are four ways of specifying data to be retrieved using the (c) sits object: A sits tibble; (d) sf object: An \code{link[sf]{sf}} object with POINT or geometry; (e) data.frame: A data.frame with \code{longitude} and \code{latitude}. +} +\examples{ +if (sits_run_examples()) { + # create a random forest model + rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) + # create a data cube from local files + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + # classify a data cube + probs_cube <- sits_classify( + data = cube, ml_model = rfor_model, output_dir = tempdir() + ) + # obtain the a set of points for sampling + ground_truth <- system.file("extdata/samples/samples_sinop_crop.csv", + package = "sits" + ) + # get the classification values for a selected set of locations + probs_samples <- sits_get_probs(probs_cube, ground_truth) +} + } \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} diff --git a/man/sits_kfold_validate.Rd b/man/sits_kfold_validate.Rd index c1f54ccce..c9f7e4175 100644 --- a/man/sits_kfold_validate.Rd +++ b/man/sits_kfold_validate.Rd @@ -43,6 +43,8 @@ A \code{caret::confusionMatrix} object to be used for \description{ Splits the set of time series into training and validation and perform k-fold cross-validation. +} +\note{ Cross-validation is a technique for assessing how the results of a statistical analysis will generalize to an independent data set. It is mainly used in settings where the goal is prediction, @@ -59,8 +61,7 @@ is determine for each instance in the dataset, and an overall accuracy estimate is provided. This function returns the confusion matrix, and Kappa values. -} -\note{ + Please refer to the sits documentation available in for detailed examples. } diff --git a/man/sits_label_classification.Rd b/man/sits_label_classification.Rd index ce66d0679..9d40ed786 100644 --- a/man/sits_label_classification.Rd +++ b/man/sits_label_classification.Rd @@ -58,9 +58,34 @@ A data cube with an image with the classified map. } \description{ Takes a set of classified raster layers with probabilities, - and label them based on the maximum probability for each pixel. +and labels them based on the maximum probability for each pixel. +This function is the final step of main the land classification workflow. } \note{ +The main \code{sits} classification workflow has the following steps: +\enumerate{ + \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from + a cloud provider.} + \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + from a cloud provider to a local directory for faster processing.} + \item{\code{\link[sits]{sits_regularize}}: create a regular data cube + from an ARD image collection.} + \item{\code{\link[sits]{sits_apply}}: create new indices by combining + bands of a regular data cube (optional).} + \item{\code{\link[sits]{sits_get_data}}: extract time series + from a regular data cube based on user-provided labelled samples.} + \item{\code{\link[sits]{sits_train}}: train a machine learning + model based on image time series.} + \item{\code{\link[sits]{sits_classify}}: classify a data cube + using a machine learning model and obtain a probability cube.} + \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube + using a spatial smoother to remove outliers and + increase spatial consistency.} + \item{\code{\link[sits]{sits_label_classification}}: produce a + classified map by selecting the label with the highest probability + from a smoothed cube.} +} + Please refer to the sits documentation available in for detailed examples. } diff --git a/man/sits_lighttae.Rd b/man/sits_lighttae.Rd index 0dbe3a5a4..f3fc0466c 100644 --- a/man/sits_lighttae.Rd +++ b/man/sits_lighttae.Rd @@ -63,6 +63,14 @@ A fitted model to be used for classification of data cubes. \description{ Implementation of Light Temporal Attention Encoder (L-TAE) for satellite image time series +} +\note{ +\code{sits} provides a set of default values for all classification models. +These settings have been chosen based on testing by the authors. +Nevertheless, users can control all parameters for each model. +Novice users can rely on the default values, +while experienced ones can fine-tune deep learning models +using \code{\link[sits]{sits_tuning}}. This function is based on the paper by Vivien Garnot referenced below and code available on github at diff --git a/man/sits_mixture_model.Rd b/man/sits_mixture_model.Rd index 969e9ec5c..b447c92f8 100644 --- a/man/sits_mixture_model.Rd +++ b/man/sits_mixture_model.Rd @@ -74,7 +74,18 @@ images. We use the non-negative least squares (NNLS) solver to calculate the fractions of each endmember. The NNLS was implemented by Jakob Schwalb-Willmann in RStoolbox package (licensed as GPL>=3). } -\details{ +\note{ +Many pixels in images of medium-resolution satellites +such as Landsat or Sentinel-2 contain a mixture of +spectral responses of different land cover types. +In many applications, it is desirable to obtain the proportion +of a given class inside a mixed pixel. For this purpose, +the literature proposes mixture models; these models represent +pixel values as a combination of multiple pure land cover types. +Assuming that the spectral response of pure land cover classes +(called endmembers) is known, spectral mixture analysis +derives new bands containing the proportion of each endmember inside a pixel. + The \code{endmembers} parameter should be a tibble, csv or a shapefile. \code{endmembers} parameter must have the following columns: \code{type}, which defines the endmembers that will be diff --git a/man/sits_mlp.Rd b/man/sits_mlp.Rd index 608ae4de1..fe2e4d0db 100644 --- a/man/sits_mlp.Rd +++ b/man/sits_mlp.Rd @@ -66,6 +66,13 @@ This function uses the R "torch" and "luz" packages. Please refer to the documentation of those package for more details. } \note{ +\code{sits} provides a set of default values for all classification models. +These settings have been chosen based on testing by the authors. +Nevertheless, users can control all parameters for each model. +Novice users can rely on the default values, +while experienced ones can fine-tune deep learning models +using \code{\link[sits]{sits_tuning}}. + The default parameters for the MLP have been chosen based on the work by Wang et al. 2017 that takes multilayer perceptrons as the baseline for time series classifications: diff --git a/man/sits_mosaic.Rd b/man/sits_mosaic.Rd index 21fc6e23e..b6916aef1 100644 --- a/man/sits_mosaic.Rd +++ b/man/sits_mosaic.Rd @@ -40,11 +40,10 @@ a sits cube with only one tile. } \description{ Creates a mosaic of all tiles of a sits cube. -Mosaics can be created from EO cubes and derived cubes. -In sits EO cubes, the mosaic will be generated for each band and date. -It is recommended to filter the image with the less cloud cover to create -a mosaic for the EO cubes. -It is possible to provide a \code{roi} to crop the mosaic. +Mosaics can be created from both regularized ARD images or from classified +maps. In the case of ARD images, a mosaic will be produce for each band/date +combination. It is better to first regularize the data cubes and then +use \code{sits_mosaic}. } \note{ The "roi" parameter defines a region of interest. It can be @@ -53,10 +52,9 @@ The "roi" parameter defines a region of interest. It can be named lat/long values (\code{lon_min}, \code{lon_max}, \code{lat_min}, \code{lat_max}). - The user should specify the crs of the mosaic since in many cases the - input images will be in different coordinate systems. For example, - when mosaicking Sentinel-2 images the inputs will be in general in - different UTM grid zones. + When the data cube has tiles that cover different UTM grid zones, + the user should specify the CRS of the mosaic. We use + "EPSG:3857" (Pseudo-Mercator) as the default. } \examples{ if (sits_run_examples()) { diff --git a/man/sits_reclassify.Rd b/man/sits_reclassify.Rd index 1d67ea2f5..beda0b9dd 100644 --- a/man/sits_reclassify.Rd +++ b/man/sits_reclassify.Rd @@ -50,7 +50,15 @@ Apply a set of named expressions to reclassify a classified image. The expressions should use character values to refer to labels in logical expressions. } -\details{ +\note{ +Reclassification of a remote sensing map refers +to changing the classes assigned to different pixels in the image. +Reclassification involves assigning new classes to pixels based +on additional information from a reference map. +Users define rules according to the desired outcome. +These rules are then applied to the classified map to produce +a new map with updated classes. + \code{sits_reclassify()} allow any valid R expression to compute reclassification. User should refer to \code{cube} and \code{mask} to construct logical expressions. diff --git a/man/sits_reduce_imbalance.Rd b/man/sits_reduce_imbalance.Rd index 7a02d52c1..2a5a27769 100644 --- a/man/sits_reduce_imbalance.Rd +++ b/man/sits_reduce_imbalance.Rd @@ -35,6 +35,28 @@ using the synthetic minority oversampling technique (SMOTE) for oversampling. Undersampling is done using the SOM methods available in the sits package. } +\note{ +Many training samples for Earth observation data analysis are imbalanced. +This situation arises when the distribution of samples associated +with each label is uneven. +Sample imbalance is an undesirable property of a training set. +Reducing sample imbalance improves classification accuracy. + +The function \code{sits_reduce_imbalance} increases the number of samples +of least frequent labels, and reduces the number of samples of most +frequent labels. To generate new samples, \code{sits} +uses the SMOTE method that estimates new samples by considering +the cluster formed by the nearest neighbors of each minority label. + +To perform undersampling, \code{sits_reduce_imbalance}) builds a SOM map +for each majority label based on the required number of samples. +Each dimension of the SOM is set to ceiling(sqrt(new_number_samples/4)) +to allow a reasonable number of neurons to group similar samples. +After calculating the SOM map, the algorithm extracts four samples +per neuron to generate a reduced set of samples that approximates +the variation of the original one. +See also \code{\link[sits]{sits_som_map}}. +} \examples{ if (sits_run_examples()) { # print the labels summary for a sample set @@ -55,9 +77,7 @@ N. V. Chawla, K. W. Bowyer, L. O.Hall, W. P. Kegelmeyer, “SMOTE: synthetic minority over-sampling technique,” Journal of artificial intelligence research, 321-357, 2002. -Undersampling uses the SOM map developed by Lorena Santos and co-workers -and used in the sits_som_map() function. -The SOM map technique is described in the paper: +The SOM map technique for time series is described in the paper: Lorena Santos, Karine Ferreira, Gilberto Camara, Michelle Picoli, Rolf Simoes, “Quality control and class noise reduction of satellite image time series”. ISPRS Journal of Photogrammetry and Remote Sensing, diff --git a/man/sits_regularize.Rd b/man/sits_regularize.Rd index 2f462b899..8cdd04ac9 100644 --- a/man/sits_regularize.Rd +++ b/man/sits_regularize.Rd @@ -101,12 +101,11 @@ data cubes, with number and unit, where \item{timeline}{User-defined timeline for regularized cube.} -\item{roi}{A named \code{numeric} vector with a region of interest.} +\item{roi}{Region of interest (see notes below).} \item{tiles}{Tiles to be produced.} -\item{grid_system}{A character with the grid system that images will be -cropped.} +\item{grid_system}{Grid system to be used for the output images.} \item{multicores}{Number of cores used for regularization; used for parallel processing of input (integer)} @@ -125,18 +124,55 @@ images may not cover the entire time, and time intervals are not regular. For this reason, subsets of these collection need to be converted to regular data cubes before further processing and data analysis. This function requires users to include the cloud band in their ARD-based -data cubes. +data cubes. This function uses the \code{gdalcubes} package. } \note{ -The "period" parameter is mandatory, and defines the time interval - between two images of the regularized cube. By default, the date - of the first image of the input cube is taken as the starting +The main \code{sits} classification workflow has the following steps: +\enumerate{ + \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from + a cloud provider.} + \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + from a cloud provider to a local directory for faster processing.} + \item{\code{\link[sits]{sits_regularize}}: create a regular data cube + from an ARD image collection.} + \item{\code{\link[sits]{sits_apply}}: create new indices by combining + bands of a regular data cube (optional).} + \item{\code{\link[sits]{sits_get_data}}: extract time series + from a regular data cube based on user-provided labelled samples.} + \item{\code{\link[sits]{sits_train}}: train a machine learning + model based on image time series.} + \item{\code{\link[sits]{sits_classify}}: classify a data cube + using a machine learning model and obtain a probability cube.} + \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube + using a spatial smoother to remove outliers and + increase spatial consistency.} + \item{\code{\link[sits]{sits_label_classification}}: produce a + classified map by selecting the label with the highest probability + from a smoothed cube.} +} + The regularization operation converts subsets of image collections + available in cloud providers into regular data cubes. It is an essential + part of the \code{sits} workflow. + The input to \code{sits_regularize} should be an ARD cube + which includes the cloud band. The aggregation method used in + \code{sits_regularize} sorts the images based on cloud cover, + putting images with the least clouds at the top of the stack. Once + the stack of images is sorted, the method uses the first valid value to + create the temporal aggregation. + + The "period" parameter is mandatory, and defines the time interval + between two images of the regularized cube. When combining + Sentinel-1A and Sentinel-1B images, experiments show that a + 16-day period ("P16D") are a good default. Landsat images require + a longer period of one to three months. + + By default, the date of the first image of the input cube + is taken as the starting date for the regular cube. In many situations, users may want to pre-define the required times using the "timeline" parameter. The "timeline" parameter, if used, must contain a set of dates which are compatible with the input cube. - The optional "roi" parameter defines a region of interest. It can be an sf_object, a shapefile, or a bounding box vector with named XY values ("xmin", "xmax", "ymin", "ymax") or @@ -144,21 +180,15 @@ The "period" parameter is mandatory, and defines the time interval \code{sits_regularize()} function will crop the images that contain the region of interest(). - The optional "tiles" parameter indicates which tiles of the + The optional \code{tiles} parameter indicates which tiles of the input cube will be used for regularization. - The "grid_system" parameters allows the choice of grid system - for the regularized cube. Currently, the package supports + The \code{grid_system} parameter allows the user to + reproject the files to a grid system which is + different from that used in the ARD image collection of + the could provider. Currently, the package supports the use of MGRS grid system and those used by the Brazil Data Cube ("BDC_LG_V2" "BDC_MD_V2" "BDC_SM_V2"). - - The aggregation method used in \code{sits_regularize} - sorts the images based on cloud cover, where images with the fewest - clouds at the top of the stack. Once - the stack of images is sorted, the method uses the first valid value to - create the temporal aggregation. - The input (non-regular) ARD cube needs to include the cloud band for - the regularization to work. } \examples{ if (sits_run_examples()) { diff --git a/man/sits_segment.Rd b/man/sits_segment.Rd index 9c2612519..25d8c2935 100644 --- a/man/sits_segment.Rd +++ b/man/sits_segment.Rd @@ -49,9 +49,11 @@ segmentation. \description{ Apply a spatial-temporal segmentation on a data cube based on a user defined segmentation function. The function applies the segmentation algorithm -"seg_fn" to each tile. - -Segmentation uses the following steps: +"seg_fn" to each tile. The output is a vector data cube, which is a data cube +with an additional vector file in "geopackage" format. +} +\note{ +Segmentation requires the following steps: \enumerate{ \item Create a regular data cube with \code{\link[sits]{sits_cube}} and \code{\link[sits]{sits_regularize}}; @@ -65,12 +67,25 @@ Segmentation uses the following steps: \item Display the results with \code{\link[sits]{plot}} or \code{\link[sits]{sits_view}}. } -} -\note{ -The "roi" parameter defines a region of interest. It can be + The "roi" parameter defines a region of interest. It can be an sf_object, a shapefile, or a bounding box vector with named XY values ("xmin", "xmax", "ymin", "ymax") or - named lat/long values ("lon_min", "lat_min", "lon_max", "lat_max") + named lat/long values ("lon_min", "lat_min", "lon_max", "lat_max"). + + As of version 1.5.3, the only \code{seg_fn} function available is + \code{\link[sits]{sits_slic}}, which uses the Simple Linear + Iterative Clustering (SLIC) algorithm that clusters pixels to + generate compact, nearly uniform superpixels. This algorithm has been + adapted by Nowosad and Stepinski to work with multispectral and + multitemporal images. SLIC uses spectral similarity and + proximity in the spectral and temporal space to + segment the image into superpixels. Superpixels are clusters of pixels + with similar spectral and temporal responses that are spatially close. + + The result of \code{sits_segment} is a data cube tibble with an additional + vector file in the \code{geopackage} format. The location of the vector + file is included in the data cube tibble in a new column, called + \code{vector_info}. } \examples{ if (sits_run_examples()) { @@ -84,6 +99,14 @@ if (sits_run_examples()) { # segment the vector cube segments <- sits_segment( cube = cube, + seg_fn = sits_slic( + step = 10, + compactness = 1, + dist_fun = "euclidean", + avg_fun = "median", + iter = 30, + minarea = 10 + ), output_dir = tempdir() ) # create a classification model @@ -101,6 +124,17 @@ if (sits_run_examples()) { ) } } +\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. + + 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. +} \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} diff --git a/man/sits_slic.Rd b/man/sits_slic.Rd index 2268c7178..aee4dfb8b 100644 --- a/man/sits_slic.Rd +++ b/man/sits_slic.Rd @@ -64,6 +64,14 @@ if (sits_run_examples()) { # segment the vector cube segments <- sits_segment( cube = cube, + seg_fn = sits_slic( + step = 10, + compactness = 1, + dist_fun = "euclidean", + avg_fun = "median", + iter = 30, + minarea = 10 + ), output_dir = tempdir(), version = "slic-demo" ) diff --git a/man/sits_smooth.Rd b/man/sits_smooth.Rd index 1d86ab079..5dab324b7 100644 --- a/man/sits_smooth.Rd +++ b/man/sits_smooth.Rd @@ -72,6 +72,42 @@ Takes a set of classified raster layers with probabilities, whose metadata is]created by \code{\link[sits]{sits_cube}}, and applies a Bayesian smoothing function. } +\note{ +The main \code{sits} classification workflow has the following steps: +\enumerate{ + \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from + a cloud provider.} + \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + from a cloud provider to a local directory for faster processing.} + \item{\code{\link[sits]{sits_regularize}}: create a regular data cube + from an ARD image collection.} + \item{\code{\link[sits]{sits_apply}}: create new indices by combining + bands of a regular data cube (optional).} + \item{\code{\link[sits]{sits_get_data}}: extract time series + from a regular data cube based on user-provided labelled samples.} + \item{\code{\link[sits]{sits_train}}: train a machine learning + model based on image time series.} + \item{\code{\link[sits]{sits_classify}}: classify a data cube + using a machine learning model and obtain a probability cube.} + \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube + using a spatial smoother to remove outliers and + increase spatial consistency.} + \item{\code{\link[sits]{sits_label_classification}}: produce a + classified map by selecting the label with the highest probability + from a smoothed cube.} +} +Machine learning algorithms rely on training samples that are +derived from “pure” pixels, hand-picked by users to represent +the desired output classes. +Given the presence of mixed pixels in images regardless of resolution, +and the considerable data variability within each class, +these classifiers often produce results with misclassified pixels. + +Post-processing the results of \code{\link[sits]{sits_classify}} +using \code{sits_smooth} reduces salt-and-pepper and border effects. +By minimizing noise, \code{sits_smooth} brings a significant gain +in the overall accuracy and interpretability of the final output. +} \examples{ if (sits_run_examples()) { # create am xgboost model @@ -102,6 +138,13 @@ if (sits_run_examples()) { plot(label_cube) } } +\references{ +Gilberto Camara, Renato Assunção, Alexandre Carvalho, Rolf Simões, +Felipe Souza, Felipe Carlos, Anielli Souza, Ana Rorato, +Ana Paula Del’Asta, “Bayesian inference +for post-processing of remote sensing image classification”. +Remote Sensing, 16(23), 4572, 2024. DOI: https://doi.org/10.3390/rs16234572. +} \author{ Gilberto Camara, \email{gilberto.camara@inpe.br} diff --git a/man/sits_som_clean_samples.Rd b/man/sits_som_clean_samples.Rd index 4ab7c3245..76af9e6c3 100644 --- a/man/sits_som_clean_samples.Rd +++ b/man/sits_som_clean_samples.Rd @@ -30,7 +30,10 @@ should be removed. The second is the posterior probability of the sample. } \description{ \code{sits_som_clean_samples()} evaluates the quality of the samples -based on the results of the SOM map. The algorithm identifies noisy samples, +based on the results of the SOM map. +} +\note{ +The algorithm identifies noisy samples, using `prior_threshold` for the prior probability and `posterior_threshold` for the posterior probability. Each sample receives an evaluation tag, according to the following rule: diff --git a/man/sits_som_map.Rd b/man/sits_som_map.Rd index 83ff828c8..5f317c706 100644 --- a/man/sits_som_map.Rd +++ b/man/sits_som_map.Rd @@ -53,20 +53,22 @@ using data for the neighbours on the SOM map. } \description{ These function use self-organized maps to perform -quality analysis in satellite image time series - -\code{sits_som_map()} creates a SOM map, where high-dimensional data -is mapped into a two dimensional map, keeping the topological relations +quality analysis in satellite image time series. +} +\note{ +\code{\link[sits]{sits_som_map}} creates a SOM map, where +high-dimensional data is mapped into a two dimensional map, +keeping the topological relations between data patterns. Each sample is assigned to a neuron, and neurons are placed in the grid based on similarity. -\code{sits_som_evaluate_cluster()} analyses the neurons of the SOM map, -and builds clusters based on them. Each cluster is a neuron +\code{\link[sits]{sits_som_evaluate_cluster}} analyses the neurons of +the SOM map, and builds clusters based on them. Each cluster is a neuron or a set of neuron categorized with same label. It produces a tibble with the percentage of mixture of classes in each cluster. -\code{sits_som_clean_samples()} evaluates the quality of the samples +\code{\link[sits]{sits_som_clean_samples}} evaluates sample quality based on the results of the SOM map. The algorithm identifies noisy samples, using `prior_threshold` for the prior probability and `posterior_threshold` for the posterior probability. @@ -78,10 +80,10 @@ probability is >=`posterior_threshold`, the sample is tagged as "clean"; (c) If the prior probability is >= `posterior_threshold` and the posterior probability is < `posterior_threshold`, the sample is tagged as "analyze" for further inspection. + The user can define which tagged samples will be returned using the "keep" parameter, with the following options: "clean", "analyze", "remove". -} -\note{ + To learn more about the learning algorithms, check the \code{\link[kohonen:supersom]{kohonen::supersom}} function. diff --git a/man/sits_tae.Rd b/man/sits_tae.Rd index 0580a5d77..487481ae1 100644 --- a/man/sits_tae.Rd +++ b/man/sits_tae.Rd @@ -58,6 +58,14 @@ A fitted model to be used for classification. \description{ Implementation of Temporal Attention Encoder (TAE) for satellite image time series classification. +} +\note{ +\code{sits} provides a set of default values for all classification models. +These settings have been chosen based on testing by the authors. +Nevertheless, users can control all parameters for each model. +Novice users can rely on the default values, +while experienced ones can fine-tune deep learning models +using \code{\link[sits]{sits_tuning}}. This function is based on the paper by Vivien Garnot referenced below and code available on github at diff --git a/man/sits_tempcnn.Rd b/man/sits_tempcnn.Rd index b77aff574..9b0cbf508 100644 --- a/man/sits_tempcnn.Rd +++ b/man/sits_tempcnn.Rd @@ -76,6 +76,14 @@ Use a TempCNN algorithm to classify data, which has two stages: a 1D CNN and a multi-layer perceptron. Users can define the depth of the 1D network, as well as the number of perceptron layers. +} +\note{ +\code{sits} provides a set of default values for all classification models. +These settings have been chosen based on testing by the authors. +Nevertheless, users can control all parameters for each model. +Novice users can rely on the default values, +while experienced ones can fine-tune deep learning models +using \code{\link[sits]{sits_tuning}}. This function is based on the paper by Charlotte Pelletier referenced below. If you use this method, please cite the original tempCNN paper. @@ -84,8 +92,7 @@ The torch version is based on the code made available by the BreizhCrops team: Marc Russwurm, Charlotte Pelletier, Marco Korner, Maximilian Zollner. The original python code is available at the website https://github.com/dl4sits/BreizhCrops. This code is licensed as GPL-3. -} -\note{ + Please refer to the sits documentation available in for detailed examples. } diff --git a/man/sits_train.Rd b/man/sits_train.Rd index 61940f7bb..e85a6890a 100644 --- a/man/sits_train.Rd +++ b/man/sits_train.Rd @@ -26,6 +26,44 @@ and different deep learning functions, including multi-layer perceptrons networks \code{\link[sits]{sits_tempcnn}}, self-attention encoders \code{\link[sits]{sits_lighttae}} } +\note{ +The main \code{sits} classification workflow has the following steps: +\enumerate{ + \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from + a cloud provider.} + \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + from a cloud provider to a local directory for faster processing.} + \item{\code{\link[sits]{sits_regularize}}: create a regular data cube + from an ARD image collection.} + \item{\code{\link[sits]{sits_apply}}: create new indices by combining + bands of a regular data cube (optional).} + \item{\code{\link[sits]{sits_get_data}}: extract time series + from a regular data cube based on user-provided labelled samples.} + \item{\code{\link[sits]{sits_train}}: train a machine learning + model based on image time series.} + \item{\code{\link[sits]{sits_classify}}: classify a data cube + using a machine learning model and obtain a probability cube.} + \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube + using a spatial smoother to remove outliers and + increase spatial consistency.} + \item{\code{\link[sits]{sits_label_classification}}: produce a + classified map by selecting the label with the highest probability + from a smoothed cube.} +} + +\code{sits_train} provides a standard interface to all machine learning models. +It takes two mandatory parameters: the training data (\code{samples}) +and the ML algorithm (\code{ml_method}). The output is a model that +can be used to classify individual time series or data cubes +with \code{\link[sits]{sits_classify}}. + +\code{sits} provides a set of default values for all classification models. +These settings have been chosen based on testing by the authors. +Nevertheless, users can control all parameters for each model. +Novice users can rely on the default values, +while experienced ones can fine-tune deep learning models +using \code{\link[sits]{sits_tuning}}. +} \examples{ if (sits_run_examples()) { # Retrieve the set of samples for Mato Grosso diff --git a/man/sits_tuning.Rd b/man/sits_tuning.Rd index 709b73b64..584b8d068 100644 --- a/man/sits_tuning.Rd +++ b/man/sits_tuning.Rd @@ -45,23 +45,28 @@ and \code{beta} distribution functions to randomize parameters.} } \value{ A tibble containing all parameters used to train on each trial - ordered by accuracy + ordered by accuracy. } \description{ +This function performs a random search on values of selected hyperparameters, +and produces a data frame with the accuracy and kappa values produced +by a validation procedure. The result allows users to select appropriate +hyperparameters for deep learning models. +} +\note{ Machine learning models use stochastic gradient descent (SGD) techniques to find optimal solutions. To perform SGD, models use optimization algorithms which have hyperparameters that have to be adjusted to achieve best performance for each application. - -This function performs a random search on values of selected hyperparameters. Instead of performing an exhaustive test of all parameter combinations, -it selecting them randomly. Validation is done using an independent set +\code{sits_tuning} selects them randomly. +Validation is done using an independent set of samples or by a validation split. The function returns the best hyper-parameters in a list. Hyper-parameters passed to \code{params} -parameter should be passed by calling \code{sits_tuning_hparams()}. -} -\note{ -When using a GPU for deep learning, \code{gpu_memory} indicates the +parameter should be passed by calling +\code{\link[sits]{sits_tuning_hparams}}. + + When using a GPU for deep learning, \code{gpu_memory} indicates the memory of the graphics card which is available for processing. The parameter \code{batch_size} defines the size of the matrix (measured in number of rows) which is sent to the GPU for classification. diff --git a/man/sits_uncertainty.Rd b/man/sits_uncertainty.Rd index c64563323..97511af86 100644 --- a/man/sits_uncertainty.Rd +++ b/man/sits_uncertainty.Rd @@ -52,15 +52,31 @@ An uncertainty data cube } \description{ Calculate the uncertainty cube based on the probabilities -produced by the classifier. Takes a probability cube as input. +produced by the classifier. Takes a \code{probability cube} as input and +produces a \code{uncertainty cube}. +} +\note{ +The output of \code{\link[sits]{sits_classify}} and +\code{\link[sits]{sits_smooth}} is a \code{probability cube} containing +the class probability for all pixels, which are generated by the +machine learning model. The \code{sits_uncertainty} function takes +a \code{probability cube} and produces a \code{uncertainty code} which +contains a measure of uncertainty for each pixel, based on the +class probabilities. + The uncertainty measure is relevant in the context of active leaning, and helps to increase the quantity and quality of training samples by providing information about the confidence of the model. -The supported types of uncertainty are 'entropy', 'least', and 'margin'. -'entropy' is the difference between all predictions expressed as -entropy, 'least' is the difference between 1.0 and most confident -prediction, and 'margin' is the difference between the two most confident -predictions. + +The supported types of uncertainty are: +\enumerate{ +\item{\code{entropy}: the difference between all predictions expressed a +Shannon measure of entropy.} +\item{\code{least}: the difference between 1.0 and most confident +prediction.} +\item{\code{margin}: the difference between the two most confident +predictions.} +} } \examples{ if (sits_run_examples()) { diff --git a/man/sits_view.Rd b/man/sits_view.Rd index 310b167a1..63f3d115b 100644 --- a/man/sits_view.Rd +++ b/man/sits_view.Rd @@ -174,7 +174,8 @@ A leaflet object containing either samples or \description{ Uses leaflet to visualize time series, raster cube and classified images. - +} +\note{ To show a false color image, use "band" to chose one of the bands, "tiles" to select tiles, "first_quantile" and "last_quantile" to set the cutoff points. Choose diff --git a/man/st_as_stars.raster_cube.Rd b/man/st_as_stars.raster_cube.Rd new file mode 100644 index 000000000..a7d7f96bd --- /dev/null +++ b/man/st_as_stars.raster_cube.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_stars.R +\name{st_as_stars.raster_cube} +\alias{st_as_stars.raster_cube} +\title{Extension to stars for exporting sits cubes as stars objects} +\usage{ +st_as_stars.raster_cube(.x, ...) +} +\arguments{ +\item{.x}{A sits cube.} + +\item{...}{Other parameters for st_as_stars} +} +\value{ +A space-time stars object. +} +\description{ +Uses the information about files, bands and dates +in a data cube to produce an object of class \code{stars}. +User has to select a tile from the data cube. By default, +all bands and dates are included in the \code{stars} object. +Users can select bands and dates. +} +\note{ +By default, the \code{stars} object will be loaded in memory. This +can result in heavy memory usage. To produce a \code{stars.proxy} object, +uses have to select a single date, since \code{stars} does not allow +proxy objects to be created with two dimensions. +} +\examples{ +if (sits_run_examples()) { + library(stars) + # convert sits cube to an sf object (polygon) + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + stars_object <- st_as_stars(cube) +} +} +\author{ +Gilberto Camara, \email{gilberto.camara.inpe@gmail.com} +} From 2bb4b82650e17ea98bd242ff63a288f0c3ea9064 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Sat, 29 Mar 2025 10:38:53 -0300 Subject: [PATCH 066/122] improve documentation of sits_cube --- DESCRIPTION | 1 + NAMESPACE | 4 +- R/api_source.R | 21 +- R/api_source_local.R | 2 +- R/sits_cube.R | 562 ++++++++++--------------------- R/sits_cube_local.R | 377 +++++++++++++++++++++ R/sits_get_data.R | 344 +++++++++++++++---- R/sits_get_probs.R | 20 +- R/sits_plot.R | 8 +- R/sits_stars.R | 39 --- inst/extdata/config_messages.yml | 1 + man/plot.Rd | 4 +- man/plot.patterns.Rd | 2 - man/sits_cube.Rd | 417 ++--------------------- man/sits_cube.local_cube.Rd | 122 +++++++ man/sits_cube.results_cube.Rd | 94 ++++++ man/sits_cube.stac_cube.Rd | 238 +++++++++++++ man/sits_cube.vector_cube.Rd | 118 +++++++ man/sits_get_data.Rd | 165 +-------- man/sits_get_data.csv.Rd | 65 ++++ man/sits_get_data.data.frame.Rd | 77 +++++ man/sits_get_data.sf.Rd | 113 +++++++ man/sits_get_data.shp.Rd | 112 ++++++ man/sits_get_data.sits.Rd | 53 +++ man/sits_get_probs.Rd | 19 +- man/st_as_stars.raster_cube.Rd | 45 --- 26 files changed, 1917 insertions(+), 1106 deletions(-) create mode 100644 R/sits_cube_local.R create mode 100644 man/sits_cube.local_cube.Rd create mode 100644 man/sits_cube.results_cube.Rd create mode 100644 man/sits_cube.stac_cube.Rd create mode 100644 man/sits_cube.vector_cube.Rd create mode 100644 man/sits_get_data.csv.Rd create mode 100644 man/sits_get_data.data.frame.Rd create mode 100644 man/sits_get_data.sf.Rd create mode 100644 man/sits_get_data.shp.Rd create mode 100644 man/sits_get_data.sits.Rd delete mode 100644 man/st_as_stars.raster_cube.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 70af6cb48..34be89df7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -217,6 +217,7 @@ Collate: 'sits_csv.R' 'sits_cube.R' 'sits_cube_copy.R' + 'sits_cube_local.R' 'sits_clean.R' 'sits_cluster.R' 'sits_detect_change.R' diff --git a/NAMESPACE b/NAMESPACE index 3b3fd658f..800d85f55 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -370,8 +370,9 @@ S3method(sits_combine_predictions,default) S3method(sits_combine_predictions,uncertainty) S3method(sits_cube,default) S3method(sits_cube,local_cube) -S3method(sits_cube,sar_cube) +S3method(sits_cube,results_cube) S3method(sits_cube,stac_cube) +S3method(sits_cube,vector_cube) S3method(sits_detect_change,default) S3method(sits_detect_change,raster_cube) S3method(sits_detect_change,sits) @@ -568,7 +569,6 @@ export(sits_variance) export(sits_view) export(sits_whittaker) export(sits_xgboost) -export(st_as_stars.raster_cube) importFrom(Rcpp,sourceCpp) importFrom(dplyr,.data) importFrom(lubridate,"%m+%") diff --git a/R/api_source.R b/R/api_source.R index ae3cc5851..6994b7c90 100644 --- a/R/api_source.R +++ b/R/api_source.R @@ -41,17 +41,34 @@ NULL return(invisible(NULL)) } -#' @rdname source_functions +#' @name .source_new +#' #' @noRd #' @description creates an object with a corresponding #' S3 class defined in a given source and collection. #' +#' @param source A \code{character} value referring to a valid data source. +#' @param collection A valid collection in a source provider +#' @param is_local Are we using local files to create the cube? +#' @param is_results Are the local files results produced by sits classification +#' operations? +#' @param is_vector Are we dealing with vector data cubes? +#' #' @return returns the S3 class for the source #' -.source_new <- function(source, collection = NULL, is_local = FALSE) { +.source_new <- function(source, + collection = NULL, + is_local = FALSE, + is_result = FALSE, + is_vector = FALSE) { # if local, return local cube if (is_local) { class(source) <- c("local_cube", class(source)) + if (is_vector) { + class(source) <- c("vector_cube", class(source)) + } else if (is_result) { + class(source) <- c("result_cube", class(source)) + } return(source) } # source name is upper case diff --git a/R/api_source_local.R b/R/api_source_local.R index 7f50988c3..3511f6ce4 100644 --- a/R/api_source_local.R +++ b/R/api_source_local.R @@ -20,7 +20,7 @@ #' @param start_date,end_date Initial and final dates to include #' images from the collection in the cube (optional). #' @param multicores Number of workers for parallel processing -#' @param progress Show a progress bar? +#' @param progress Show a progress bar?z #' @param ... Other parameters to be passed for specific types. #' @return A \code{tibble} describing the contents of a local data cube. .local_cube <- function(source, diff --git a/R/sits_cube.R b/R/sits_cube.R index 996d4ece1..31a77eeda 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -7,12 +7,19 @@ #' #' @description Creates a data cube based on spatial and temporal restrictions #' in collections available in cloud services or local repositories. -#' The following cloud providers are supported, based on the STAC protocol: -#' Amazon Web Services (AWS), Brazil Data Cube (BDC), -#' Copernicus Data Space Ecosystem (CDSE), Digital Earth Africa (DEAFRICA), -#' Digital Earth Australia (DEAUSTRALIA), Microsoft Planetary Computer (MPC), -#' Nasa Harmonized Landsat/Sentinel (HLS), Swiss Data Cube (SDC), TERRASCOPE and -#' USGS Landsat (USGS). Data cubes can also be created using local files. +#' Two options are avaliable: +#' \itemize{ +#' \item{To create data cubes from cloud providers which support the STAC protocol, +#' use \code{\link[sits]{sits_cube.stac_cube}}.} +#' \item{To create raster data cubes from local image files, +#' use \code{\link[sits]{sits_cube.local_cube}}.} +#' \item{To create vector data cubes from local image and vector files, +#' use \code{\link[sits]{sits_cube.vector_cube}}.} +#' \item{To create raster data cubes from local image files +#' which have been classified or labelled, +#' use \code{\link[sits]{sits_cube.results_cube}}.} +#' } +#' #' #' @param source Data source: one of \code{"AWS"}, \code{"BDC"}, #' \code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, @@ -22,48 +29,10 @@ #' To find out the supported collections, #' use \code{\link{sits_list_collections}()}). #' @param ... Other parameters to be passed for specific types. -#' @param platform Optional parameter specifying the platform in case -#' of collections that include more than one satellite. -#' @param tiles Tiles from the collection to be included in -#' the cube (see details below). -#' @param roi Region of interest. Either an sf object, a shapefile, -#' a \code{SpatExtent} from \code{terra}, -#' a vector with named XY -#' values ("xmin", "xmax", "ymin", "ymax"), or -#' a vector with named lat/long values -#' ("lon_min", "lat_min", "lon_max", "lat_max"). -#' @param crs The Coordinate Reference System (CRS) of the roi. It -#' must be specified when roi is defined by XY values -#' ("xmin", "xmax", "ymin", "ymax") or by -#' a \code{SpatExtent} from \code{terra}. -#' @param bands Spectral bands and indices to be included -#' in the cube (optional). -#' Use \code{\link{sits_list_collections}()} to find out -#' the bands available for each collection. -#' @param orbit Orbit name ("ascending", "descending") for SAR cubes. -#' @param start_date,end_date Initial and final dates to include -#' images from the collection in the cube (optional). -#' (Date in YYYY-MM-DD format). -#' @param data_dir Local directory where images are stored -#' (for local cubes only). -#' @param vector_dir Local director where vector files are stored -#' (for local vector cubes only). -#' @param vector_band Band for vector cube ("segments", "probs", "class") -#' @param parse_info Parsing information for local files -#' (for local cubes - see notes below). -#' @param version Version of the classified and/or labelled files. -#' (for local cubes). -#' @param delim Delimiter for parsing local files -#' (default = "_") -#' @param labels Labels associated to the classes -#' (Named character vector for cubes of -#' classes "probs_cube" or "class_cube"). -#' @param multicores Number of workers for parallel processing -#' (integer, min = 1, max = 2048). -#' @param progress Logical: show a progress bar? +#' #' @return A \code{tibble} describing the contents of a data cube. #' -#' @note{ +#' @note #' The main \code{sits} classification workflow has the following steps: #' \enumerate{ #' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from @@ -88,12 +57,19 @@ #' from a smoothed cube.} #' } #' +#' The following cloud providers are supported, based on the STAC protocol: +#' Amazon Web Services (AWS), Brazil Data Cube (BDC), +#' Copernicus Data Space Ecosystem (CDSE), Digital Earth Africa (DEAFRICA), +#' Digital Earth Australia (DEAUSTRALIA), Microsoft Planetary Computer (MPC), +#' Nasa Harmonized Landsat/Sentinel (HLS), Swiss Data Cube (SDC), TERRASCOPE and +#' USGS Landsat (USGS). Data cubes can also be created using local files. +#' #' In \code{sits}, a data cube is represented as a tibble with metadata #' describing a set of image files obtained from cloud providers. #' It contains information about each individual file. #' #' A data cube in \code{sits} is: -#' \enumerate{ +#' \itemize{ #' \item{A set of images organized in tiles of a grid system (e.g., MGRS).} #' \item{Each tile contains single-band images in a #' unique zone of the coordinate system (e.g, tile 20LMR in MGRS grid) @@ -103,25 +79,122 @@ #' \item{Different tiles may cover different zones of the same grid system.} #' } #' A regular data cube is a data cube where: -#' \enumerate{ +#' \itemize{ #' \item{All tiles share the same set of regular temporal intervals.} #' \item{All tiles share the same spectral bands and indices.} #' \item{All images have the same spatial resolution.} #' \item{Each location in a tile is associated a set of multi-band time series.} #' \item{For each tile, interval and band, the cube is associated to a 2D image.} #' } +# +#' @examples +#' if (sits_run_examples()) { +#' # --- Access to the Brazil Data Cube +#' # create a raster cube file based on the information in the BDC +#' cbers_tile <- sits_cube( +#' source = "BDC", +#' collection = "CBERS-WFI-16D", +#' bands = c("NDVI", "EVI"), +#' tiles = "007004", +#' start_date = "2018-09-01", +#' end_date = "2019-08-28" +#' ) +#' # --- Access to Digital Earth Africa +#' # create a raster cube file based on the information about the files +#' # DEAFRICA does not support definition of tiles +#' cube_deafrica <- sits_cube( +#' source = "DEAFRICA", +#' collection = "SENTINEL-2-L2A", +#' bands = c("B04", "B08"), +#' roi = c( +#' "lat_min" = 17.379, +#' "lon_min" = 1.1573, +#' "lat_max" = 17.410, +#' "lon_max" = 1.1910 +#' ), +#' start_date = "2019-01-01", +#' end_date = "2019-10-28" +#' ) +#' # --- Create a cube based on a local MODIS data +#' # MODIS local files have names such as +#' # "TERRA_MODIS_012010_NDVI_2013-09-14.jp2" +#' # see the parse info parameter as an example on how to +#' # decode local files +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' modis_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir, +#' parse_info = c("satellite", "sensor", "tile", "band", "date") +#' ) +#' } +#' @export +sits_cube <- function(source, collection, ...) { + # set caller to show in errors + .check_set_caller("sits_cube") + # capture elipsis + dots <- list(...) + # if "data_dir" parameters is provided, assumes local cube + if ("data_dir" %in% names(dots)) { + if ("bands" %in% names(dots) && bands %in% .conf("sits_results_bands")){ + source <- .source_new(source = source, + is_local = TRUE, is_result = TRUE) + } + if ("vector_dir" %in% names(dots) && "vector_band" %in% names(dots) + && vector_band %in% .conf("sits_results_bands")) { + source <- .source_new(source = source, is_vector = TRUE, + is_local = TRUE) + } + source <- .source_new(source = source, is_local = TRUE) + } else { + source <- .source_new(source = source, collection = collection) + } + # Dispatch + UseMethod("sits_cube", source) +} +#' @title Create data cubes from image collections acessible by STAC +#' @name sits_cube.stac_cube +#' +#' @description Creates a data cube based on spatial and temporal restrictions +#' in collections accesible by the STAC protocol +#' +#' @param source Data source: one of \code{"AWS"}, \code{"BDC"}, +#' \code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, +#' \code{"HLS"}, \code{"PLANETSCOPE"}, \code{"MPC"}, +#' \code{"SDC"} or \code{"USGS"}. +#' @param collection Image collection in data source. +#' To find out the supported collections, +#' use \code{\link{sits_list_collections}()}). +#' @param ... Other parameters to be passed for specific types. +#' @param platform Optional parameter specifying the platform in case +#' of "LANDSAT" collection. Options: \code{Landsat-5, +#' Landsat-7, Landsat-8, Landsat-9}. +#' @param tiles Tiles from the collection to be included in +#' the cube (see details below). +#' @param roi Region of interest (see below). +#' @param crs The Coordinate Reference System (CRS) of the roi. +#' (see details below). +#' @param bands Spectral bands and indices to be included +#' in the cube (optional). +#' Use \code{\link{sits_list_collections}()} to find out +#' the bands available for each collection. +#' @param start_date,end_date Initial and final dates to include +#' images from the collection in the cube (optional). +#' (Date in YYYY-MM-DD format). +#' @param orbit Orbit name ("ascending", "descending") for SAR cubes. +#' @param multicores Number of workers for parallel processing +#' (integer, min = 1, max = 2048). +#' @param progress Logical: show a progress bar? +#' @return A \code{tibble} describing the contents of a data cube. +#' +#' @note #' #' Data cubes are identified on cloud providers using \code{sits_cube}. #' The result of \code{sits_cube} is a description of the location #' of the requested data in the cloud provider. No download is done. #' -#' To obtain regular data cubes, use \code{\link[sits]{sits_regularize}}. -#' For faster performance, we suggest users -#' copy data from cloud providers to local disk using \code{sits_cube_copy} -#' before regularization. -#' #' To create data cube objects from cloud providers, users need to inform: -#' \enumerate{ +#' \itemize{ #' \item{\code{source}: Name of the cloud provider. #' One of "AWS", "BDC", "CDSE", "DEAFRICA", "DEAUSTRALIA", #' "HLS", "PLANETSCOPE", "MPC", "SDC", "TERRASCOPE", or "USGS";} @@ -131,23 +204,11 @@ #' collections are supported;} #' \item{ \code{tiles}: A set of tiles defined according to the collection #' tiling grid (e.g, c("20LMR", "20LMP") in MGRS);} -#' \item{\code{roi}: Region of interest. Either: -#' \enumerate{ -#' \item{A path to a shapefile with polygons;} -#' \item{A \code{sfc} or \code{sf} object from \code{sf} package;} -#' \item{A \code{SpatExtent} object from \code{terra} package;} -#' \item{A named \code{vector} (\code{"lon_min"}, -#' \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84;} -#' \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, -#' \code{"ymin"}, \code{"ymax"}) with XY coordinates in WGS84.} -#' } -#' Defining a region of interest using \code{SpatExtent} -#' requires the \code{crs} parameter to be specified. -#' } +#' \item{\code{roi}: Region of interest (see below)} #' } #' #' The parameters \code{bands}, \code{start_date}, and \code{end_date} are -#' optional for cubes created from cloud providers. +#' optional for cubes created from cloud providers. #' #' Either \code{tiles} or \code{roi} must be informed. The \code{tiles} #' should specify a set of valid tiles for the ARD collection. @@ -157,145 +218,65 @@ #' This parameter does not crop a region; it only #' selects images that intersect it. #' -#' To use GeoJSON geometries (RFC 7946) as value \code{roi}, please -#' convert it to sf object and then use it. +#' To define a \code{roi} use one of: +#' \itemize{ +#' \item{A path to a shapefile with polygons;} +#' \item{A \code{sfc} or \code{sf} object from \code{sf} package;} +#' \item{A \code{SpatExtent} object from \code{terra} package;} +#' \item{A named \code{vector} (\code{"lon_min"}, +#' \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84;} +#' \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, +#' \code{"ymin"}, \code{"ymax"}) with XY coordinates.} +#' } +#' Defining a region of interest using \code{SpatExtent} or XY values not in +#' WGS84 requires the \code{crs} parameter to be specified. #' #' To get more details about each provider and collection -#' available in \code{sits}, please read the online sits book +#' available in \code{sits}, please read the online sits book #' (e-sensing.github.io/sitsbook). The chapter #' \code{Earth Observation data cubes} provides a detailed description of all #' collections you can use with \code{sits} #' (e-sensing.github.io/sitsbook/earth-observation-data-cubes.html). #' -#' Data cubes created from ARD image collection are objects of class -#' \code{"raster_cube"}. Users can extract segments from raster data cubes -#' using \code{\link[sits]{sits_segment}} creating vector data cubes. -#' The segments are stored in a \code{geopackage} file and information -#' about its location is stored in the data cube object. -#' -#' To create a cube from local files, please inform: -#' \enumerate{ -#' \item \code{source}: The data provider from which the data was -#' downloaded (e.g, "BDC", "MPC"); -#' -#' \item \code{collection}: The collection from which the data comes from. -#' (e.g., \code{"SENTINEL-2-L2A"} for the Sentinel-2 MPC collection level 2A); -#' -#' \item \code{data_dir}: The local directory where the image files are stored. -#' -#' \item \code{parse_info}: Defines how to extract metadata from file names -#' by specifying the order and meaning of each part, separated by the -#' \code{"delim"} character. Default value is -#' \code{c("X1", "X2", "tile", "band", "date")}. -#' -#' \item \code{delim}: The delimiter character used to separate components in -#' the file names. Default is \code{"_"}. -#' } -#' -#' When working with local data cubes downloaded or created by \code{sits}, -#' there is no need to specify \code{parse_info} and \code{delim}. -#' To use a data cube from a source supported by \code{sits} -#' (e.g., AWS, MPC) that has been obtained with an external tool, please -#' specify the \code{parse_info} and \code{delim} parameters manually. -#' For this case, to ensure that the local files meet the -#' following requirements: -#' -#' \itemize{ -#' \item All image files must have the same spatial resolution and projection; -#' \item Each file should represent a single image band for a single date; -#' \item File names must include information about the \code{"tile"}, -#' \code{"date"}, and \code{"band"} in the file. -#' } -#' -#' For example, if you are creating a Sentinel-2 data cube on your local -#' machine, and the files have the same spatial resolution and projection, with -#' each file containing a single band and date, an acceptable file name is: -#' \itemize{ -#' \item \code{"SENTINEL-2_MSI_20LKP_B02_2018-07-18.jp2"} -#' } -#' -#' This file name works because it encodes the three key pieces of information -#' used by \code{sits}: -#' \itemize{ -#' \item Tile: "20LKP"; -#' \item Band: "B02"; -#' \item Date: "2018-07-18" -#' } -#' In this case the \code{"parse_info"} parameter should be -#' \code{c("satellite", "sensor", "tile", "band", "date")} -#' Other example of supported file names are: -#' \itemize{ -#' \item \code{"CBERS-4_WFI_022024_B13_2021-05-15.tif"}; #' -#' \item \code{"SENTINEL-1_GRD_30TXL_VV_2023-03-10.tif"}; -#' -#' \item \code{"LANDSAT-8_OLI_198030_B04_2020-09-12.tif"}. -#' } -#' -#' The \code{parse_info} parameter tells \code{sits} how to extract essential -#' metadata from file names. It defines the sequence of components in the -#' file name, assigning each part a label such as \code{"tile"}, \code{"band"}, -#' and \code{"date"}. For parts of the file name that are irrelevant to -#' \code{sits}, you can use dummy labels like \code{"X1"} and \code{"X2"}. -#' -#' For example, consider the file name: -#' \itemize{ -#' \item \code{"SENTINEL-2_MSI_20LKP_B02_2018-07-18.jp2"} -#' } -#' -#' With \code{parse_info = c("satellite", "sensor", "tile", "band", "date")} and -#' \code{delim = "_"}, the extracted metadata would be: -#' -#' \itemize{ -#' \item satellite: "SENTINEL-2" (ignored) -#' \item sensor: "MSI" (ignored) -#' \item tile: "20LKP" (used) -#' \item band: "B02" (used) -#' \item date: "2018-07-18" (used) -#' } -#' -#' The \code{delim} parameter specifies the character that separates components -#' in the file name. The default delimiter is \code{"_"}. -#' -#' Note that when you load a local data cube specifying the \code{source} -#' (e.g., AWS, MPC) and \code{collection}, \code{sits} assumes that the data -#' properties (e.g., scale factor, minimum, and maximum values) match those -#' defined for the selected provider. However, if you are working with -#' custom data from an unsupported source or data that does not follow the -#' standard definitions of providers in sits, refer to the Technical Annex of -#' the \code{sits} online book for guidance on handling such cases -#' (e-sensing.github.io/sitsbook/technical-annex.html). -#' -#' It is also possible to create result cubes from local files produced by -#' classification or post-classification algorithms. In this case, the -#' \code{parse_info} is specified differently, and other additional parameters -#' are required: +#' @examples +#' if (sits_run_examples()) { +#' # --- Creating Sentinel cube from MPC +#' s2_cube <- sits_cube( +#' source = "MPC", +#' collection = "SENTINEL-2-L2A", +#' tiles = "20LKP", +#' bands = c("B05", "CLOUD"), +#' start_date = "2018-07-18", +#' end_date = "2018-08-23" +#' ) #' -#' \itemize{ +#' # --- Creating Landsat cube from MPC +#' roi <- c("lon_min" = -50.410, "lon_max" = -50.379, +#' "lat_min" = -10.1910 , "lat_max" = -10.1573) +#' mpc_cube <- sits_cube( +#' source = "MPC", +#' collection = "LANDSAT-C2-L2", +#' bands = c("BLUE", "RED", "CLOUD"), +#' roi = roi, +#' start_date = "2005-01-01", +#' end_date = "2006-10-28" +#' ) #' -#' \item \code{band}: Band name associated to the type of result. Use -#' \code{"probs"}, for probability cubes produced by -#' \code{\link{sits_classify}()}; -#' \code{"bayes"}, for smoothed cubes produced by \code{\link{sits_smooth}()}; -#' \code{"segments"}, for vector cubes produced by -#' \code{\link{sits_segment}()}; -#' \code{"entropy"} when using \code{\link{sits_uncertainty}()}, and -#' \code{"class"} for cubes produced by -#' \code{\link{sits_label_classification}()}; -#' -#' \item \code{labels}: Labels associated to the classification results; -#' -#' \item \code{parse_info}: File name parsing information -#' to deduce the values of \code{"tile"}, \code{"start_date"}, -#' \code{"end_date"} from the file name. Unlike non-classified image files, -#' cubes with results have both \code{"start_date"} and \code{"end_date"}. -#' Default is c("X1", "X2", "tile", "start_date", "end_date", "band"). -#' } +#' ## Sentinel-1 SAR from MPC +#' roi_sar <- c("lon_min" = -50.410, "lon_max" = -50.379, +#' "lat_min" = -10.1910, "lat_max" = -10.1573) #' -#' } -#' @examples -#' if (sits_run_examples()) { -#' # --- Access to the Brazil Data Cube +#' s1_cube_open <- sits_cube( +#' source = "MPC", +#' collection = "SENTINEL-1-GRD", +#' bands = c("VV", "VH"), +#' orbit = "descending", +#' roi = roi_sar, +#' start_date = "2020-06-01", +#' end_date = "2020-09-28" +#' ) +#' #' # --- Access to the Brazil Data Cube #' # create a raster cube file based on the information in the BDC #' cbers_tile <- sits_cube( #' source = "BDC", @@ -349,6 +330,8 @@ #' #' ## --- Sentinel-1 SAR from CDSE #' # --- remember to set the appropriate environmental variables +#' # --- Obtain a AWS_ACCESS_KEY_ID and AWS_ACCESS_SECRET_KEY_ID +#' # --- from CDSE #' roi_sar <- c("lon_min" = 33.546, "lon_max" = 34.999, #' "lat_min" = 1.427, "lat_max" = 3.726) #' s1_cube_open <- sits_cube( @@ -359,54 +342,10 @@ #' roi = roi_sar, #' start_date = "2020-01-01", #' end_date = "2020-06-10" -#' ) -#' -#' # --- Access to AWS open data Sentinel 2/2A level 2 collection -#' s2_cube <- sits_cube( -#' source = "AWS", -#' collection = "SENTINEL-S2-L2A-COGS", -#' tiles = c("20LKP", "20LLP"), -#' bands = c("B04", "B08", "B11"), -#' start_date = "2018-07-18", -#' end_date = "2019-07-23" -#' ) -#' -#' # --- Creating Sentinel cube from MPC -#' s2_cube <- sits_cube( -#' source = "MPC", -#' collection = "SENTINEL-2-L2A", -#' tiles = "20LKP", -#' bands = c("B05", "CLOUD"), -#' start_date = "2018-07-18", -#' end_date = "2018-08-23" -#' ) -#' -#' # --- Creating Landsat cube from MPC -#' roi <- c("lon_min" = -50.410, "lon_max" = -50.379, -#' "lat_min" = -10.1910 , "lat_max" = -10.1573) -#' mpc_cube <- sits_cube( -#' source = "MPC", -#' collection = "LANDSAT-C2-L2", -#' bands = c("BLUE", "RED", "CLOUD"), -#' roi = roi, -#' start_date = "2005-01-01", -#' end_date = "2006-10-28" -#' ) +#' ) #' -#' ## Sentinel-1 SAR from MPC -#' roi_sar <- c("lon_min" = -50.410, "lon_max" = -50.379, -#' "lat_min" = -10.1910, "lat_max" = -10.1573) #' -#' s1_cube_open <- sits_cube( -#' source = "MPC", -#' collection = "SENTINEL-1-GRD", -#' bands = c("VV", "VH"), -#' orbit = "descending", -#' roi = roi_sar, -#' start_date = "2020-06-01", -#' end_date = "2020-09-28" -#' ) -#' # --- Access to World Cover data (2021) via Terrascope +#' -- Access to World Cover data (2021) via Terrascope #' cube_terrascope <- sits_cube( #' source = "TERRASCOPE", #' collection = "WORLD-COVER-2021", @@ -417,67 +356,8 @@ #' lat_max = -8.70 #' ) #' ) -#' # --- Create a cube based on a local MODIS data -#' # MODIS local files have names such as -#' # "TERRA_MODIS_012010_NDVI_2013-09-14.jp2" -#' # see the parse info parameter as an example on how to -#' # decode local files -#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") -#' modis_cube <- sits_cube( -#' source = "BDC", -#' collection = "MOD13Q1-6.1", -#' data_dir = data_dir, -#' parse_info = c("satellite", "sensor", "tile", "band", "date") -#' ) -#'} -#' @export -sits_cube <- function(source, collection, ...) { - # set caller to show in errors - .check_set_caller("sits_cube") - # capture elipsis - dots <- list(...) - # if "data_dir" parameters is provided, assumes local cube - if ("data_dir" %in% names(dots)) { - source <- .source_new(source = source, is_local = TRUE) - } else { - source <- .source_new(source = source, collection = collection) - } - # Dispatch - UseMethod("sits_cube", source) -} -#' @rdname sits_cube -#' +#' } #' @export -sits_cube.sar_cube <- function(source, - collection, ..., - orbit = "ascending", - bands = NULL, - tiles = NULL, - roi = NULL, - crs = NULL, - start_date = NULL, - end_date = NULL, - platform = NULL, - multicores = 2, - progress = TRUE) { - - sits_cube.stac_cube( - source = source, - collection = collection, - bands = bands, - tiles = tiles, - roi = roi, - crs = crs, - start_date = start_date, - end_date = end_date, - platform = platform, - multicores = multicores, - progress = progress, - orbit = orbit, - ... - ) -} -#' @rdname sits_cube #' #' @export sits_cube.stac_cube <- function(source, @@ -488,6 +368,7 @@ sits_cube.stac_cube <- function(source, crs = NULL, start_date = NULL, end_date = NULL, + orbit = "descending", platform = NULL, multicores = 2, progress = TRUE) { @@ -563,83 +444,6 @@ sits_cube.stac_cube <- function(source, # adjust crs of the cube before return .cube_adjust_crs(cube) } -#' @rdname sits_cube -#' -#' @export -sits_cube.local_cube <- function(source, - collection, ..., - data_dir, - vector_dir = NULL, - tiles = NULL, - bands = NULL, - vector_band = NULL, - start_date = NULL, - end_date = NULL, - labels = NULL, - parse_info = NULL, - version = "v1", - delim = "_", - multicores = 2L, - progress = TRUE) { - # set caller for error messages - .check_set_caller("sits_cube_local_cube") - # precondition - data directory must be provided - .check_file(data_dir) - # expanding the shortened paths since gdal functions do not work with them - data_dir <- path.expand(data_dir) - # deal with wrong parameter "band" in dots - dots <- list(...) - if ("band" %in% names(dots) && missing(bands)) { - message("please, use 'bands' instead of 'band' as parameter") - bands <- as.character(dots[["band"]]) - } - # precondition - check source and collection for eo_cubes only - # is this a cube with results? - if (.has(bands) && all(bands %in% .conf("sits_results_bands"))) - results_cube <- TRUE - else - results_cube <- FALSE - if (.has(vector_dir)) { - if (.has(bands)) { - .check_that( - !(all(bands %in% .conf("sits_results_bands"))), - msg = .conf("messages", "sits_cube_local_cube_vector_band") - ) - } - .check_chr_parameter(vector_band, - msg = .conf("messages", "sits_cube_local_cube_vector_band") - ) - .check_that( - vector_band %in% c("segments", "class", "probs"), - msg = .conf("messages", "sits_cube_local_cube_vector_band") - ) - } - if (!results_cube) { - .source_check(source = source) - .source_collection_check(source = source, collection = collection) - } - # builds a sits data cube - cube <- .local_cube( - source = source, - collection = collection, - data_dir = data_dir, - vector_dir = vector_dir, - parse_info = parse_info, - version = version, - delim = delim, - tiles = tiles, - bands = bands, - vector_band = vector_band, - labels = labels, - start_date = start_date, - end_date = end_date, - multicores = multicores, - progress = progress, ... - ) - # fix tile system name - cube <- .cube_revert_tile_name(cube) - return(cube) -} #' @export sits_cube.default <- function(source, collection, ...) { stop(.conf("messages", "sits_cube_default")) diff --git a/R/sits_cube_local.R b/R/sits_cube_local.R new file mode 100644 index 000000000..43991fb51 --- /dev/null +++ b/R/sits_cube_local.R @@ -0,0 +1,377 @@ +#' @title Create sits cubes from cubes in flat files in a local +#' @name sits_cube.local_cube +#' @description +#' Creates data cubes based on files on local directory. Assumes users +#' have downloaded the data from a known cloud collection or the data +#' has been created by \code{sits}. +#' +#' +#' @param source Data source: one of \code{"AWS"}, \code{"BDC"}, +#' \code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, +#' \code{"HLS"}, \code{"PLANETSCOPE"}, \code{"MPC"}, +#' \code{"SDC"} or \code{"USGS"}. This is the source +#' from which the data has been downloaded. +#' @param collection Image collection in data source. +#' To find out the supported collections, +#' use \code{\link{sits_list_collections}()}). +#' @param ... Other parameters to be passed for specific types. +#' @param tiles Tiles from the collection to be included in +#' the cube (see details below). +#' @param bands Spectral bands and indices to be included +#' in the cube (optional). +#' @param start_date,end_date Initial and final dates to include +#' images from the collection in the cube (optional). +#' (Date in YYYY-MM-DD format). +#' @param data_dir Local directory where images are stored. +#' @param parse_info Parsing information for local files. +#' @param delim Delimiter for parsing local files (default = "_") +#' @param multicores Number of workers for parallel processing +#' (integer, min = 1, max = 2048). +#' @param progress Logical: show a progress bar? +#' @return A \code{tibble} describing the contents of a data cube. + +#' @note +#' To create a cube from local files, please inform: +#' \itemize{ +#' \item \code{source}: The data provider from which the data was +#' downloaded (e.g, "BDC", "MPC"); +#' \item \code{collection}: The collection from which the data comes from. +#' (e.g., \code{"SENTINEL-2-L2A"} for the Sentinel-2 MPC collection level 2A); +#' \item \code{data_dir}: The local directory where the image files are stored. +#' \item \code{parse_info}: Defines how to extract metadata from file names +#' by specifying the order and meaning of each part, separated by the +#' \code{"delim"} character. Default value is +#' \code{c("X1", "X2", "tile", "band", "date")}. +#' \item \code{delim}: The delimiter character used to separate components in +#' the file names. Default is \code{"_"}. +#' } +#' Please ensure that local files meet the following requirements: +#' +#' \itemize{ +#' \item All image files must have the same spatial resolution and projection; +#' \item Each file should represent a single image band for a single date; +#' \item File names must include information about the \code{tile}, +#' \code{date}, and \code{band} in their names. +#' \item{The \code{parse_info} parameter tells \code{sits} how to extract +#' metadata from file names.} +#' \item{By default the \code{parse_info} parameter is +#' \code{c(satellite, sensor, tile, band, date)}.} +#' } +#' Example of supported file names are: +#' \itemize{ +#' \item \code{"CBERS-4_WFI_022024_B13_2021-05-15.tif"}; +#' \item \code{"SENTINEL-1_GRD_30TXL_VV_2023-03-10.tif"}; +#' \item \code{"LANDSAT-8_OLI_198030_B04_2020-09-12.tif"}. +#' } +#' +#' When you load a local data cube specifying the \code{source} +#' (e.g., AWS, MPC) and \code{collection}, \code{sits} assumes that the data +#' properties (e.g., scale factor, minimum, and maximum values) match those +#' defined for the selected provider. If you are working with +#' custom data from an unsupported source or data that does not follow the +#' standard definitions of providers in sits, refer to the Technical Annex of +#' the \code{sits} online book for guidance on handling such cases +#' (e-sensing.github.io/sitsbook/technical-annex.html). +#' +#' @examples +#' if (sits_run_examples()) { +#' # --- Create a cube based on a local MODIS data +#' # MODIS local files have names such as +#' # "TERRA_MODIS_012010_NDVI_2013-09-14.jp2" +#' # see the parse info parameter as an example on how to +#' # decode local files +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' modis_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir, +#' parse_info = c("satellite", "sensor", "tile", "band", "date") +#' ) +#'} +#' @export +sits_cube.local_cube <- function( + source, + collection, ..., + bands = NULL, + tiles = NULL, + start_date = NULL, + end_date = NULL, + data_dir, + parse_info = c("X1", "X2", "tile", "band", "date"), + delim = "_", + multicores = 2L, + progress = TRUE) { + # set caller for error messages + .check_set_caller("sits_cube_local_cube") + # precondition - data directory must be provided + .check_file(data_dir) + # expanding the shortened paths since gdal functions do not work with them + data_dir <- path.expand(data_dir) + # deal with wrong parameter "band" in dots + dots <- list(...) + if ("band" %in% names(dots) && missing(bands)) { + message("please, use 'bands' instead of 'band' as parameter") + bands <- as.character(dots[["band"]]) + } + .source_check(source = source) + .source_collection_check(source = source, collection = collection) + + # builds a sits data cube + cube <- .local_cube( + source = source, + collection = collection, + data_dir = data_dir, + parse_info = parse_info, + delim = delim, + tiles = tiles, + bands = bands, + start_date = start_date, + end_date = end_date, + vector_dir = NULL, + vector_band = NULL, + labels = NULL, + multicores = multicores, + progress = progress, ... + ) + .local_cube <- function(source, + collection, + data_dir, + vector_dir, + parse_info, + version, + delim, + tiles, + bands, + vector_band, + labels, + start_date, + end_date, + multicores, + progress, ...) + # fix tile system name + cube <- .cube_revert_tile_name(cube) + return(cube) +} +#' @title Create a vector cube from local files +#' @name sits_cube.vector_cube +#' @description +#' Creates a data cube from local files which include a vector file +#' produced by a segmentation algorithm. +#' +#' @param source Data source: one of \code{"AWS"}, \code{"BDC"}, +#' \code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, +#' \code{"HLS"}, \code{"PLANETSCOPE"}, \code{"MPC"}, +#' \code{"SDC"} or \code{"USGS"}. This is the source +#' from which the data has been downloaded. +#' @param collection Image collection in data source. +#' To find out the supported collections, +#' use \code{\link{sits_list_collections}()}). +#' @param ... Other parameters to be passed for specific types. +#' @param data_dir Local directory where images are stored +#' (for local cubes only). +#' @param vector_dir Local directory where vector files are stored +#' @param vector_band Band for vector cube ("segments", "probs", "class") +#' @param parse_info Parsing information for local image files +#' @param delim Delimiter for parsing local files +#' (default = "_") +#' @param version Version of the classified and/or labelled files. +#' @param multicores Number of workers for parallel processing +#' (integer, min = 1, max = 2048). +#' @param progress Logical: show a progress bar? +#' @return A \code{tibble} describing the contents of a data cube. +#' +#' @note +#' This function creates vector cubes from local files produced by +#' \code{\link[sits]{sits_segment}}, +#' \code{\link[sits]{sits_classify.vector_cube}} +#' or \code{\link[sits]{sits_label_classification.vector_cube}}. In this case, +#' \code{parse_info} is specified differently as \code{c("X1", "X2", "tile", +#' "start_date", "end_date", "band")}. +#' The parameter \code{vector_dir} is the directory where the vector file is +#' stored. +#' Parameter \code{vector_band} is band name of the type of vector cube: +#' \itemize{ +#' \item{\code{"segments"}, for vector cubes produced by +#' \code{\link{sits_segment}}.} +#' \item{\code{"probs"}, for probability cubes produced by +#' \code{\link{sits_classify.vector_cube}}.} +#' \item{\code{"entropy"} when using +#' \code{\link{sits_uncertainty.probs_vector_cube}}.} +#' \item{\code{"class"} for cubes produced by +#' \code{\link{sits_label_classification}}.} +#' } +#' +#'@examples +#' if (sits_run_examples()) { +#' # --- Create a cube based on a local MODIS data +#' # MODIS local files have names such as +#' # "TERRA_MODIS_012010_NDVI_2013-09-14.jp2" +#' # see the parse info parameter as an example on how to +#' # decode local files +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' modis_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir, +#' parse_info = c("satellite", "sensor", "tile", "band", "date") +#' ) +#' # segment the vector cube +#' segments <- sits_segment( +#' cube = cube, +#' seg_fn = sits_slic( +#' step = 10, +#' compactness = 1, +#' dist_fun = "euclidean", +#' avg_fun = "median", +#' iter = 30, +#' minarea = 10 +#' ), +#' output_dir = tempdir() +#' ) +#' # recover the local segmented cube +#' segment_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = system.file("extdata/raster/mod13q1", package = "sits"), +#' vector_dir = tempdir(), +#' vector_band = "segments" +#' ) +#'} +#' +#' @export +sits_cube.vector_cube <- function( + source, + collection, ..., + data_dir, + vector_dir, + vector_band, + parse_info = c("X1", "X2", "tile", "date", "band", "version"), + version = "v1", + delim = "_", + multicores = 2L, + progress = TRUE) { + + # builds a sits data cube + cube <- .local_cube( + source = source, + collection = collection, + data_dir = data_dir, + vector_dir = vector_dir, + vector_band = vector_band, + parse_info = parse_info, + version = version, + delim = delim, + tiles = NULL, + bands = NULL, + vector_band = NULL, + labels = NULL, + start_date = NULL, + end_date = NULL, + multicores = multicores, + progress = progress, ... + ) + +} +#' @title Create a results cube from local files +#' @name sits_cube.results_cube +#' @description +#' Creates a data cube from local files produced by sits operations +#' that produces results (such as probs_cubs and class_cubes) +#' +#' @param source Data source: one of \code{"AWS"}, \code{"BDC"}, +#' \code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, +#' \code{"HLS"}, \code{"PLANETSCOPE"}, \code{"MPC"}, +#' \code{"SDC"} or \code{"USGS"}. This is the source +#' from which the data has been downloaded. +#' @param collection Image collection in data source. +#' To find out the supported collections, +#' use \code{\link{sits_list_collections}()}). +#' @param ... Other parameters to be passed for specific types. +#' @param data_dir Local directory where images are stored +#' @param bands Results bands to be retrieved +#' ("probs", "bayes", "variance", "class", "uncertainty") +#' @param labels Labels associated to the classes +#' (Named character vector for cubes of +#' classes "probs_cube" or "class_cube") +#' @param parse_info Parsing information for local files +#' (see notes below). +#' @param version Version of the classified and/or labelled files. +#' @param delim Delimiter for parsing local files +#' (default = "_") +#' @param multicores Number of workers for parallel processing +#' (integer, min = 1, max = 2048). +#' @param progress Logical: show a progress bar? +#' @return A \code{tibble} describing the contents of a data cube. +#' +#' @note +#' This function creates result cubes from local files produced by +#' classification or post-classification algorithms. In this case, the +#' \code{parse_info} is specified differently, and additional parameters +#' are required. +#' The parameter \code{bands} should be a single character vector with +#' the name associated to the type of result: +#' \itemize{ +#' \item{\code{"probs"}, for probability cubes produced by +#' \code{\link[sits]{sits_classify}}.} +#' \item{\code{"bayes"}, for smoothed cubes produced by +#' \code{\link[sits]{sits_smooth}}.} +#' \item{\code{"entropy"} when using \code{\link[sits]{sits_uncertainty}} to measure +#' entropy in pixel classification.} +#' \item{\code{"margin"} when using \code{\link[sits]{sits_uncertainty}} to measure +#' probability margin in pixel classification.} +#' \item{\code{"least"} when using \code{\link[sits]{sits_uncertainty}} to measure +#' difference between 100\% and most probable class in pixel classification.} +#' \item{\code{"class"} for cubes produced by +#' \code{\link[sits]{sits_label_classification}}.} +#' } +#' For cubes of type \code{"probs"}, \code{"bayes"}, \code{"class"}, the +#' \code{labels} parameter should be named vector associated to the +#' classification results. For \code{"class"} cubes, its names should be +#' integers associated to the values of the raster files that represent +#' the classified cube. +#' +#' Parameter \code{parse_info} should contain parsing information +#' to deduce the values of \code{tile}, \code{start_date}, +#' \code{end_date} and \code{band} from the file name. +#' Default is c("X1", "X2", "tile", "start_date", "end_date", "band"). +#' +#' @export +sits_cube.results_cube <- function( + source, + collection, ..., + data_dir, + bands = NULL, + labels, + parse_info = c("X1", "X2", "tile", "start_date", + "end_date", "band", "version"), + version = "v1", + delim = "_", + multicores = 2L, + progress = TRUE) { + + # check if cube is results cube + .check_chr_contains(bands, + contains = .conf("sits_results_bands"), + discriminator = "one_of", + msg = .conf("messages", "sits_cube_results_cube")) + + # builds a sits data cube + cube <- .local_cube( + source = source, + collection = collection, + data_dir = data_dir, + vector_dir = NULL, + parse_info = parse_info, + version = version, + delim = delim, + tiles = NULL, + bands = bands, + vector_band = NULL, + labels = labels, + start_date = NULL, + end_date = NULL, + multicores = multicores, + progress = progress, ... + ) + +} diff --git a/R/sits_get_data.R b/R/sits_get_data.R index 7517daa2e..981a3f427 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -7,9 +7,19 @@ #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' #' @description Retrieve a set of time series from a data cube and -#' and put the result in a "sits tibble", which +#' and put the result in a \code{sits tibble}, which #' contains both the satellite image time series and their metadata. #' +#' There are five options for the specifying the input +#' \code{samples} parameter: +#' \itemize{ +#' \item{A CSV file: see \code{\link[sits]{sits_get_data.csv}}.} +#' \item{A \code{sits} tibble: see \code{\link[sits]{sits_get_data.sits}}. } +#' \item{A shapefile: see \code{\link[sits]{sits_get_data.shp}}. } +#' \item{An \code{sf} object: see \code{\link[sits]{sits_get_data.sf}}.} +#' \item{A data.frame: see see \code{\link[sits]{sits_get_data.data.frame}}.} +#' } +#' #' @note #' The main \code{sits} classification workflow has the following steps: #' \enumerate{ @@ -38,77 +48,19 @@ #' To be able to build a machine learning model to classify a data cube, #' one needs to use a set of labelled time series. These time series #' are created by taking a set of known samples, expressed as -#' labelled points or polygons. -#' This \code{sits_get_data} function uses these samples to -#' extract time series from a data cube. Thus, it needs a \code{cube} parameter +#' labelled points or polygons. This \code{sits_get_data} function +#' uses these samples to +#' extract time series from a data cube. It needs a \code{cube} parameter #' which points to a regularized data cube, and a \code{samples} parameter #' that describes the locations of the training set. #' -#' There are five ways of specifying the -#' \code{samples} parameter: -#' \enumerate{ -#' \item{A CSV file with columns -#' \code{longitude}, \code{latitude}, -#' \code{start_date}, \code{end_date} and \code{label} for each sample. -#' The parameter must point to a file with extension ".csv";} -#' \item{A shapefile in POINT or POLYGON geometry -#' containing the location of the samples. -#' The parameter must point to a file with extension ".shp";} -#' \item{A sits tibble, which contains columns -#' \code{longitude}, \code{latitude}, -#' \code{start_date}, \code{end_date} and \code{label} for each sample.} -#' \item{A \code{link[sf]{sf}} object with POINT or POLYGON geometry;} -#' \item{A data.frame with with mandatory columns -#' \code{longitude}, \code{latitude}, -#' \code{start_date}, \code{end_date} and \code{label} for each row.} -#' } -#' -#' For shapefiles and sf objects, the following parameters are relevant: -#' \enumerate{ -#' \item{\code{label}: label to be assigned to the samples. -#' Should only be used if all geometries have a single label.} -#' \item{\code{label_attr}: defines which attribute should be -#' used as a label, required for POINT and POLYGON geometries if -#' \code{label} has not been set.} -#' \item{\code{n_sam_pol}: indicates how many points are -#' extracted from each polygon, required for POLYGON geometry (default = 15).} -#' \item{\code{sampling_type}: defines how sampling is done, required -#' for POLYGON geometry (default = "random").} -#' \item{\code{pol_avg}: indicates if average of values for POLYGON -#' geometry should be computed (default = "FALSE").} -#' } -# #' @param cube Data cube from where data is to be retrieved. #' (tibble of class "raster_cube"). #' @param samples Location of the samples to be retrieved. #' Either a tibble of class "sits", an "sf" object, #' the name of a shapefile or csv file, or #' a data.frame with columns "longitude" and "latitude". -#' @param ... Specific parameters for specific cases. -#' @param start_date Start of the interval for the time series - optional -#' (Date in "YYYY-MM-DD" format). -#' @param end_date End of the interval for the time series - optional -#' (Date in "YYYY-MM-DD" format). -#' @param label Label to be assigned to the time series (optional) -#' (character vector of length 1). -#' @param bands Bands to be retrieved - optional -#' (character vector). -#' @param crs Default crs for the samples -#' (character vector of length 1). -#' @param impute_fn Imputation function to remove NA. -#' @param label_attr Attribute in the shapefile or sf object to be used -#' as a polygon label. -#' (character vector of length 1). -#' @param n_sam_pol Number of samples per polygon to be read -#' for POLYGON or MULTIPOLYGON shapefiles or sf objects -#' (single integer). -#' @param pol_avg Logical: summarize samples for each polygon? -#' (character vector of length 1) -#' @param sampling_type Spatial sampling type: random, hexagonal, -#' regular, or Fibonacci. -#' @param multicores Number of threads to process the time series -#' (integer, with min = 1 and max = 2048). -#' @param progress Logical: show progress bar? +#' @param ... Specific parameters for each input. #' #' @return A tibble of class "sits" with set of time series #' . @@ -173,7 +125,45 @@ sits_get_data.default <- function(cube, samples, ...) { stop(.conf("messages", "sits_get_data_default")) } -#' @rdname sits_get_data +#' @title Get time series using CSV files +#' @name sits_get_data.csv +#' +#' @description Retrieve a set of time series from a data cube and +#' and put the result in a "sits tibble", which +#' contains both the satellite image time series and their metadata. +#' The \code{samples} parameter must point to a file with extension ".csv", +#' with mandatory columns \code{longitude}, \code{latitude}, \code{label}, +#' \code{start_date} and \code{end_date}. +#' +#' @param cube Data cube from where data is to be retrieved. +#' (tibble of class "raster_cube"). +#' @param samples Location of a csv file. +#' @param ... Specific parameters for each kind of input. +#' @param bands Bands to be retrieved - optional. +#' @param crs Default crs for the samples. +#' @param impute_fn Imputation function to remove NA. +#' @param multicores Number of threads to process the time series +#' (integer, with min = 1 and max = 2048). +#' @param progress Logical: show progress bar? +#' +#' @return A tibble of class "sits" with set of time series and metadata with +#' . +#' @examples +#' if (sits_run_examples()) { +#' # reading a lat/long from a local cube +#' # create a cube from local files +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' raster_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' # reading samples from a cube based on a CSV file +#' csv_file <- system.file("extdata/samples/samples_sinop_crop.csv", +#' package = "sits" +#' ) +#' points <- sits_get_data(cube = raster_cube, samples = csv_file) +#' } #' @export sits_get_data.csv <- function(cube, samples, ..., @@ -203,15 +193,88 @@ sits_get_data.csv <- function(cube, ) return(data) } -#' @rdname sits_get_data +#' @title Get time series using shapefiles +#' @name sits_get_data.shp +#' +#' @description Retrieve a set of time series from a data cube and +#' and put the result in a \code{sits tibble}, which +#' contains both the satellite image time series and their metadata. +#' The \code{samples} parameter must point to a file with extension ".shp" +#' which should be a valid shapefile in POINT or POLYGON geometry. +#' If \code{start_date} and \code{end_date} are not informed, the function +#' uses these data from the cube. +#' +#' @param cube Data cube from where data is to be retrieved. +#' (tibble of class "raster_cube"). +#' @param samples The name of a shapefile. +#' @param ... Specific parameters for specific cases. +#' @param start_date Start of the interval for the time series - optional +#' (Date in "YYYY-MM-DD" format). +#' @param end_date End of the interval for the time series - optional +#' (Date in "YYYY-MM-DD" format). +#' @param bands Bands to be retrieved - optional +#' @param impute_fn Imputation function to remove NA. +#' @param label Label to be assigned to all time series - optional +#' @param label_attr Attribute in the shapefile to be used +#' as a polygon label. +#' @param n_sam_pol Number of samples per polygon to be read +#' for POLYGON or MULTIPOLYGON shapefiles. +#' @param pol_avg Logical: summarize samples for each polygon? +#' @param sampling_type Spatial sampling type: random, hexagonal, +#' regular, or Fibonacci. +#' @param multicores Number of threads to process the time series +#' (integer, with min = 1 and max = 2048). +#' @param progress Logical: show progress bar? +#' +#' @return A tibble of class "sits" with set of time series and metadata +#' . +#' +#' @note +#' For shapefiles, the following parameters are relevant: +#' \itemize{ +#' \item{\code{label}: label to be assigned to the samples. +#' Should only be used if all geometries have a single label.} +#' \item{\code{label_attr}: defines which attribute should be +#' used as a label, required for POINT and POLYGON geometries if +#' \code{label} has not been set.} +#' \item{\code{n_sam_pol}: indicates how many points are +#' extracted from each polygon, required for POLYGON geometry (default = 15).} +#' \item{\code{sampling_type}: defines how sampling is done, required +#' for POLYGON geometry (default = "random").} +#' \item{\code{pol_avg}: indicates if average of values for POLYGON +#' geometry should be computed (default = "FALSE").} +#' } +#' @examples +#' if (sits_run_examples()) { +#' +#' # reading a shapefile from BDC (Brazil Data Cube) +#' bdc_cube <- sits_cube( +#' source = "BDC", +#' collection = "CBERS-WFI-16D", +#' bands = c("NDVI", "EVI"), +#' tiles = c("007004", "007005"), +#' start_date = "2018-09-01", +#' end_date = "2018-10-28" +#' ) +#' # define a shapefile to be read from the cube +#' shp_file <- system.file("extdata/shapefiles/bdc-test/samples.shp", +#' package = "sits" +#' ) +#' # get samples from the BDC based on the shapefile +#' time_series_bdc <- sits_get_data( +#' cube = bdc_cube, +#' samples = shp_file +#' ) +#' } +#' #' @export sits_get_data.shp <- function(cube, samples, ..., - label = "NoClass", start_date = NULL, end_date = NULL, bands = NULL, impute_fn = impute_linear(), + label = "NoClass", label_attr = NULL, n_sam_pol = 30, pol_avg = FALSE, @@ -253,7 +316,81 @@ sits_get_data.shp <- function(cube, return(data) } -#' @rdname sits_get_data +#' @title Get time series using sf objects +#' @name sits_get_data.sf +#' +#' @description Retrieve a set of time series from a data cube and +#' and put the result in a "sits tibble", which +#' contains both the satellite image time series and their metadata. +#' The \code{samples} parameter must be a \code{sf} object +#' in POINT or POLYGON geometry. +#' If \code{start_date} and \code{end_date} are not informed, the function +#' uses these data from the cube. +#' +#' @param cube Data cube from where data is to be retrieved. +#' (tibble of class "raster_cube"). +#' @param samples The name of a shapefile. +#' @param ... Specific parameters for specific cases. +#' @param start_date Start of the interval for the time series - optional +#' (Date in "YYYY-MM-DD" format). +#' @param end_date End of the interval for the time series - optional +#' (Date in "YYYY-MM-DD" format). +#' @param bands Bands to be retrieved - optional +#' (character vector). +#' @param impute_fn Imputation function to remove NA. +#' @param label Label to be assigned to all time series - optional +#' @param label_attr Attribute in the sf object to be used +#' as a polygon label. +#' @param n_sam_pol Number of samples per polygon to be read +#' for POLYGON or MULTIPOLYGON objects. +#' @param pol_avg Logical: summarize samples for each polygon? +#' @param sampling_type Spatial sampling type: random, hexagonal, +#' regular, or Fibonacci. +#' @param multicores Number of threads to process the time series +#' (integer, with min = 1 and max = 2048). +#' @param progress Logical: show progress bar? +#' +#' @return A tibble of class "sits" with set of time series +#' . +#' +#' @note +#' #' For sf objects, the following parameters are relevant: +#' \itemize{ +#' \item{\code{label}: label to be assigned to the samples. +#' Should only be used if all geometries have a single label.} +#' \item{\code{label_attr}: defines which attribute should be +#' used as a label, required for POINT and POLYGON geometries if +#' \code{label} has not been set.} +#' \item{\code{n_sam_pol}: indicates how many points are +#' extracted from each polygon, required for POLYGON geometry (default = 15).} +#' \item{\code{sampling_type}: defines how sampling is done, required +#' for POLYGON geometry (default = "random").} +#' \item{\code{pol_avg}: indicates if average of values for POLYGON +#' geometry should be computed (default = "FALSE").} +#' } +#' @examples +#' if (sits_run_examples()) { +#' # reading a shapefile from BDC (Brazil Data Cube) +#' bdc_cube <- sits_cube( +#' source = "BDC", +#' collection = "CBERS-WFI-16D", +#' bands = c("NDVI", "EVI"), +#' tiles = c("007004", "007005"), +#' start_date = "2018-09-01", +#' end_date = "2018-10-28" +#' ) +#' # define a shapefile to be read from the cube +#' shp_file <- system.file("extdata/shapefiles/bdc-test/samples.shp", +#' package = "sits" +#' ) +#' # read a shapefile into an sf object +#' sf_object <- sf::st_read(shp_file) +#' # get samples from the BDC using an sf object +#' time_series_bdc <- sits_get_data( +#' cube = bdc_cube, +#' samples = sf_object +#' ) +#' } #' @export sits_get_data.sf <- function(cube, samples, @@ -307,7 +444,33 @@ sits_get_data.sf <- function(cube, } return(data) } -#' @rdname sits_get_data +#' @title Get time series using sits objects +#' @name sits_get_data.sits +#' +#' @description Retrieve a set of time series from a data cube and +#' and put the result in a \code{sits tibble}. The \code{samples} +#' parameter should be a valid \code{sits tibble} which +#' which contains columns +#' \code{longitude}, \code{latitude}, +#' \code{start_date}, \code{end_date} and \code{label} for each sample. +#' +#' @param cube Data cube from where data is to be retrieved. +#' (tibble of class "raster_cube"). +#' @param samples Location of the samples to be retrieved. +#' Either a tibble of class "sits", an "sf" object, +#' the name of a shapefile or csv file, or +#' a data.frame with columns "longitude" and "latitude". +#' @param ... Specific parameters for specific cases. +#' @param start_date Start of the interval for the time series - optional +#' (Date in "YYYY-MM-DD" format). +#' @param end_date End of the interval for the time series - optional +#' (Date in "YYYY-MM-DD" format). +#' @param bands Bands to be retrieved - optional. +#' @param crs Default crs for the samples. +#' @param impute_fn Imputation function to remove NA. +#' @param multicores Number of threads to process the time series +#' (integer, with min = 1 and max = 2048). +#' @param progress Logical: show progress bar? #' @export sits_get_data.sits <- function(cube, samples, @@ -330,8 +493,51 @@ sits_get_data.sits <- function(cube, ) return(data) } -#' @rdname sits_get_data +#' @title Get time series using sits objects +#' @name sits_get_data.data.frame +#' +#' @description Retrieve a set of time series from a data cube and +#' and put the result in a \code{sits tibble}. The \code{samples} +#' parameter should be a \code{data.frame} which +#' which contains mandatory columns +#' \code{longitude} and \code{latitude}, and optional columns +#' \code{start_date}, \code{end_date} and \code{label} for each sample. +#' +#' @param cube Data cube from where data is to be retrieved. +#' (tibble of class "raster_cube"). +#' @param samples A data.frame with mandatory columns \code{longitude}, +#' and \code{latitude}, and optional columns +#' \code{start_date}, \code{end_date}, \code{label}. +#' @param ... Specific parameters for specific cases. +#' @param start_date Start of the interval for the time series - optional +#' (Date in "YYYY-MM-DD" format). +#' @param end_date End of the interval for the time series - optional +#' (Date in "YYYY-MM-DD" format). +#' @param bands Bands to be retrieved - optional. +#' @param label Label to be assigned to all time series if +#' column \code{label} is not provided in the +#' data.frame. +#' @param crs Default crs for the samples. +#' @param impute_fn Imputation function to remove NA. +#' @param multicores Number of threads to process the time series +#' (integer, with min = 1 and max = 2048). +#' @param progress Logical: show progress bar? #' +#' @return A sits tibble with the time series for each +#' sample. +#' @examples +#' if (sits_run_examples()) { +#' # create a cube from local files +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' raster_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' # read a lat/long from a local cube +#' samples <- data.frame(longitude = -55.66738, latitude = -11.76990) +#' point_ndvi <- sits_get_data(raster_cube, samples) +#' } #' @export #' sits_get_data.data.frame <- function(cube, diff --git a/R/sits_get_probs.R b/R/sits_get_probs.R index 5287b1a3d..ee6f0bf00 100644 --- a/R/sits_get_probs.R +++ b/R/sits_get_probs.R @@ -11,17 +11,21 @@ #' @note #' There are four ways of specifying data to be retrieved using the #' \code{samples} parameter: -#' (a) CSV file: a CSV file with columns \code{longitude}, \code{latitude}; -#' (b) SHP file: a shapefile in POINT geometry; -#' (c) sits object: A sits tibble; -#' (d) sf object: An \code{link[sf]{sf}} object with POINT or geometry; -#' (e) data.frame: A data.frame with \code{longitude} and \code{latitude}. -#' +#' \itemize{ +#' \item{CSV: a CSV file with columns \code{longitude}, \code{latitude}.} +#' \item{SHP: a shapefile in POINT geometry.} +#' \item{sf object: An \code{link[sf]{sf}} object with POINT geometry.} +#' \item{sits object: A valid tibble with \code{sits} timeseries.} +#' \item{data.frame: A data.frame with \code{longitude} and \code{latitude}.} +#' } #' #' @param cube Probability data cube. #' @param samples Location of the samples to be retrieved. -#' Either a tibble of class "sits", an "sf" object, -#' the name of a shapefile or csv file, or +#' Either a tibble of class "sits", +#' an "sf" object with POINT geometry, +#' the location of a POINT shapefile, +#' the location of csv file with columns +#' "longitude" and "latitude", or #' a data.frame with columns "longitude" and "latitude" #' @param window_size Size of window around pixel (optional) #' @return A tibble of with columns diff --git a/R/sits_plot.R b/R/sits_plot.R index d5a852a79..fac3faef5 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -1,6 +1,5 @@ -#' @title Plot time series -#' @method plot sits -#' @name plot +#' @title Plot time series and data cubes +#' @name plot #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @description This is a generic function. Parameters depend on the specific #' type of input. See each function description for the @@ -27,7 +26,7 @@ #' \item xgboost model: see \code{\link{plot.xgb_model}} #' \item torch ML model: see \code{\link{plot.torch_model}} #' } -#' +#' @description Plots the time series to be used for classification #' @param x Object of class "sits". #' @param y Ignored. #' @param together A logical value indicating whether @@ -67,7 +66,6 @@ plot.sits <- function(x, y, ..., together = FALSE) { #' @author Victor Maus, \email{vwmaus1@@gmail.com} #' @description Plots the patterns to be used for classification #' -#' @description Given a sits tibble with a set of patterns, plot them. #' #' @param x Object of class "patterns". #' @param y Ignored. diff --git a/R/sits_stars.R b/R/sits_stars.R index 8cdff1b01..eebd79ab1 100644 --- a/R/sits_stars.R +++ b/R/sits_stars.R @@ -86,42 +86,3 @@ sits_as_stars <- function(cube, ) return(stars_obj) } -#' @title Extension to stars for exporting sits cubes as stars objects -#' @name st_as_stars.raster_cube -#' @author Gilberto Camara, \email{gilberto.camara.inpe@@gmail.com} -#' -#' @description Uses the information about files, bands and dates -#' in a data cube to produce an object of class \code{stars}. -#' User has to select a tile from the data cube. By default, -#' all bands and dates are included in the \code{stars} object. -#' Users can select bands and dates. -#' -#' @param .x A sits cube. -#' @param ... Other parameters for st_as_stars -#' @return A space-time stars object. -#' -#' @note -#' By default, the \code{stars} object will be loaded in memory. This -#' can result in heavy memory usage. To produce a \code{stars.proxy} object, -#' uses have to select a single date, since \code{stars} does not allow -#' proxy objects to be created with two dimensions. -#' @examples -#' if (sits_run_examples()) { -#' library(stars) -#' # convert sits cube to an sf object (polygon) -#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") -#' cube <- sits_cube( -#' source = "BDC", -#' collection = "MOD13Q1-6.1", -#' data_dir = data_dir -#' ) -#' stars_object <- st_as_stars(cube) -#' } -#' @export -st_as_stars.raster_cube <- function(.x, ...){ - stars_obj <- sits_as_stars(.x, - tile = .x[1,]$tile, - bands = NULL, - dates = NULL, - proxy = FALSE) -} diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index 215797669..b369aa1bf 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -389,6 +389,7 @@ sits_cube_copy: "wrong input parameters - see example in documentation" sits_cube_copy_different_resolutions: "Cube has multiple resolutions. Please, provide a valid resolution in 'res' parameter." sits_cube_local_cube: "wrong input parameters - see example in documentation" sits_cube_local_cube_vector_band: "one vector_band must be provided (either segments, class, or probs)" +sits_cube_results_cube: "one results band must be provided (either class or probs)" sits_detect_change_method: "wrong input parameters - see example in documentation" sits_detect_change_method_model: "dc_method is not a valid function" sits_detect_change_method_timeline: "samples have different timeline lengths" diff --git a/man/plot.Rd b/man/plot.Rd index d682a1f8e..76f0f1083 100644 --- a/man/plot.Rd +++ b/man/plot.Rd @@ -3,7 +3,7 @@ \name{plot} \alias{plot} \alias{plot.sits} -\title{Plot time series} +\title{Plot time series and data cubes} \usage{ \method{plot}{sits}(x, y, ..., together = FALSE) } @@ -48,6 +48,8 @@ required parameters. \item xgboost model: see \code{\link{plot.xgb_model}} \item torch ML model: see \code{\link{plot.torch_model}} } + +Plots the time series to be used for classification } \examples{ if (sits_run_examples()) { diff --git a/man/plot.patterns.Rd b/man/plot.patterns.Rd index 13c2f5ba6..1d084c78d 100644 --- a/man/plot.patterns.Rd +++ b/man/plot.patterns.Rd @@ -24,8 +24,6 @@ A plot object produced by ggplot2 } \description{ Plots the patterns to be used for classification - -Given a sits tibble with a set of patterns, plot them. } \note{ This code is reused from the dtwSat package by Victor Maus. diff --git a/man/sits_cube.Rd b/man/sits_cube.Rd index 69c1ce4c6..4f36e4f9b 100644 --- a/man/sits_cube.Rd +++ b/man/sits_cube.Rd @@ -2,62 +2,9 @@ % Please edit documentation in R/sits_cube.R \name{sits_cube} \alias{sits_cube} -\alias{sits_cube.sar_cube} -\alias{sits_cube.stac_cube} -\alias{sits_cube.local_cube} \title{Create data cubes from image collections} \usage{ sits_cube(source, collection, ...) - -\method{sits_cube}{sar_cube}( - source, - collection, - ..., - orbit = "ascending", - bands = NULL, - tiles = NULL, - roi = NULL, - crs = NULL, - start_date = NULL, - end_date = NULL, - platform = NULL, - multicores = 2, - progress = TRUE -) - -\method{sits_cube}{stac_cube}( - source, - collection, - ..., - bands = NULL, - tiles = NULL, - roi = NULL, - crs = NULL, - start_date = NULL, - end_date = NULL, - platform = NULL, - multicores = 2, - progress = TRUE -) - -\method{sits_cube}{local_cube}( - source, - collection, - ..., - data_dir, - vector_dir = NULL, - tiles = NULL, - bands = NULL, - vector_band = NULL, - start_date = NULL, - end_date = NULL, - labels = NULL, - parse_info = NULL, - version = "v1", - delim = "_", - multicores = 2L, - progress = TRUE -) } \arguments{ \item{source}{Data source: one of \code{"AWS"}, \code{"BDC"}, @@ -70,61 +17,6 @@ To find out the supported collections, use \code{\link{sits_list_collections}()}).} \item{...}{Other parameters to be passed for specific types.} - -\item{orbit}{Orbit name ("ascending", "descending") for SAR cubes.} - -\item{bands}{Spectral bands and indices to be included -in the cube (optional). -Use \code{\link{sits_list_collections}()} to find out -the bands available for each collection.} - -\item{tiles}{Tiles from the collection to be included in -the cube (see details below).} - -\item{roi}{Region of interest. Either an sf object, a shapefile, -a \code{SpatExtent} from \code{terra}, -a vector with named XY -values ("xmin", "xmax", "ymin", "ymax"), or -a vector with named lat/long values -("lon_min", "lat_min", "lon_max", "lat_max").} - -\item{crs}{The Coordinate Reference System (CRS) of the roi. It -must be specified when roi is defined by XY values -("xmin", "xmax", "ymin", "ymax") or by -a \code{SpatExtent} from \code{terra}.} - -\item{start_date, end_date}{Initial and final dates to include -images from the collection in the cube (optional). -(Date in YYYY-MM-DD format).} - -\item{platform}{Optional parameter specifying the platform in case -of collections that include more than one satellite.} - -\item{multicores}{Number of workers for parallel processing -(integer, min = 1, max = 2048).} - -\item{progress}{Logical: show a progress bar?} - -\item{data_dir}{Local directory where images are stored -(for local cubes only).} - -\item{vector_dir}{Local director where vector files are stored -(for local vector cubes only).} - -\item{vector_band}{Band for vector cube ("segments", "probs", "class")} - -\item{labels}{Labels associated to the classes -(Named character vector for cubes of -classes "probs_cube" or "class_cube").} - -\item{parse_info}{Parsing information for local files -(for local cubes - see notes below).} - -\item{version}{Version of the classified and/or labelled files. -(for local cubes).} - -\item{delim}{Delimiter for parsing local files -(default = "_")} } \value{ A \code{tibble} describing the contents of a data cube. @@ -132,15 +24,20 @@ A \code{tibble} describing the contents of a data cube. \description{ Creates a data cube based on spatial and temporal restrictions in collections available in cloud services or local repositories. -The following cloud providers are supported, based on the STAC protocol: -Amazon Web Services (AWS), Brazil Data Cube (BDC), -Copernicus Data Space Ecosystem (CDSE), Digital Earth Africa (DEAFRICA), -Digital Earth Australia (DEAUSTRALIA), Microsoft Planetary Computer (MPC), -Nasa Harmonized Landsat/Sentinel (HLS), Swiss Data Cube (SDC), TERRASCOPE and -USGS Landsat (USGS). Data cubes can also be created using local files. +Two options are avaliable: +\itemize{ +\item{To create data cubes from cloud providers which support the STAC protocol, +use \code{\link[sits]{sits_cube.stac_cube}}.} +\item{To create raster data cubes from local image files, +use \code{\link[sits]{sits_cube.local_cube}}.} +\item{To create vector data cubes from local image and vector files, +use \code{\link[sits]{sits_cube.vector_cube}}.} +\item{To create raster data cubes from local image files +which have been classified or labelled, +use \code{\link[sits]{sits_cube.results_cube}}.} +} } \note{ -{ The main \code{sits} classification workflow has the following steps: \enumerate{ \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from @@ -165,12 +62,19 @@ The main \code{sits} classification workflow has the following steps: from a smoothed cube.} } +The following cloud providers are supported, based on the STAC protocol: +Amazon Web Services (AWS), Brazil Data Cube (BDC), +Copernicus Data Space Ecosystem (CDSE), Digital Earth Africa (DEAFRICA), +Digital Earth Australia (DEAUSTRALIA), Microsoft Planetary Computer (MPC), +Nasa Harmonized Landsat/Sentinel (HLS), Swiss Data Cube (SDC), TERRASCOPE and +USGS Landsat (USGS). Data cubes can also be created using local files. + In \code{sits}, a data cube is represented as a tibble with metadata describing a set of image files obtained from cloud providers. It contains information about each individual file. A data cube in \code{sits} is: -\enumerate{ +\itemize{ \item{A set of images organized in tiles of a grid system (e.g., MGRS).} \item{Each tile contains single-band images in a unique zone of the coordinate system (e.g, tile 20LMR in MGRS grid) @@ -180,195 +84,12 @@ All intervals share the same spectral bands.} \item{Different tiles may cover different zones of the same grid system.} } A regular data cube is a data cube where: -\enumerate{ +\itemize{ \item{All tiles share the same set of regular temporal intervals.} \item{All tiles share the same spectral bands and indices.} \item{All images have the same spatial resolution.} \item{Each location in a tile is associated a set of multi-band time series.} \item{For each tile, interval and band, the cube is associated to a 2D image.} -} - -Data cubes are identified on cloud providers using \code{sits_cube}. -The result of \code{sits_cube} is a description of the location -of the requested data in the cloud provider. No download is done. - -To obtain regular data cubes, use \code{\link[sits]{sits_regularize}}. -For faster performance, we suggest users -copy data from cloud providers to local disk using \code{sits_cube_copy} -before regularization. - -To create data cube objects from cloud providers, users need to inform: -\enumerate{ - \item{\code{source}: Name of the cloud provider. - One of "AWS", "BDC", "CDSE", "DEAFRICA", "DEAUSTRALIA", - "HLS", "PLANETSCOPE", "MPC", "SDC", "TERRASCOPE", or "USGS";} - \item{\code{collection}: Name of an image collection available - in the cloud provider (e.g, "SENTINEL-1-RTC" in MPC). - Use \code{\link{sits_list_collections}()} to see which - collections are supported;} - \item{ \code{tiles}: A set of tiles defined according to the collection - tiling grid (e.g, c("20LMR", "20LMP") in MGRS);} - \item{\code{roi}: Region of interest. Either: - \enumerate{ - \item{A path to a shapefile with polygons;} - \item{A \code{sfc} or \code{sf} object from \code{sf} package;} - \item{A \code{SpatExtent} object from \code{terra} package;} - \item{A named \code{vector} (\code{"lon_min"}, - \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84;} - \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, - \code{"ymin"}, \code{"ymax"}) with XY coordinates in WGS84.} - } - Defining a region of interest using \code{SpatExtent} - requires the \code{crs} parameter to be specified. - } -} - -The parameters \code{bands}, \code{start_date}, and \code{end_date} are -optional for cubes created from cloud providers. - -Either \code{tiles} or \code{roi} must be informed. The \code{tiles} -should specify a set of valid tiles for the ARD collection. -For example, Landsat data has tiles in \code{WRS2} tiling system -and Sentinel-2 data uses the \code{MGRS} tiling system. -The \code{roi} parameter is used to select all types of images. -This parameter does not crop a region; it only -selects images that intersect it. - -To use GeoJSON geometries (RFC 7946) as value \code{roi}, please -convert it to sf object and then use it. - -To get more details about each provider and collection -available in \code{sits}, please read the online sits book -(e-sensing.github.io/sitsbook). The chapter -\code{Earth Observation data cubes} provides a detailed description of all -collections you can use with \code{sits} -(e-sensing.github.io/sitsbook/earth-observation-data-cubes.html). - -Data cubes created from ARD image collection are objects of class -\code{"raster_cube"}. Users can extract segments from raster data cubes -using \code{\link[sits]{sits_segment}} creating vector data cubes. -The segments are stored in a \code{geopackage} file and information -about its location is stored in the data cube object. - -To create a cube from local files, please inform: -\enumerate{ - \item \code{source}: The data provider from which the data was - downloaded (e.g, "BDC", "MPC"); - - \item \code{collection}: The collection from which the data comes from. - (e.g., \code{"SENTINEL-2-L2A"} for the Sentinel-2 MPC collection level 2A); - - \item \code{data_dir}: The local directory where the image files are stored. - - \item \code{parse_info}: Defines how to extract metadata from file names - by specifying the order and meaning of each part, separated by the - \code{"delim"} character. Default value is - \code{c("X1", "X2", "tile", "band", "date")}. - - \item \code{delim}: The delimiter character used to separate components in - the file names. Default is \code{"_"}. -} - -When working with local data cubes downloaded or created by \code{sits}, -there is no need to specify \code{parse_info} and \code{delim}. -To use a data cube from a source supported by \code{sits} -(e.g., AWS, MPC) that has been obtained with an external tool, please -specify the \code{parse_info} and \code{delim} parameters manually. -For this case, to ensure that the local files meet the -following requirements: - -\itemize{ - \item All image files must have the same spatial resolution and projection; - \item Each file should represent a single image band for a single date; - \item File names must include information about the \code{"tile"}, - \code{"date"}, and \code{"band"} in the file. -} - -For example, if you are creating a Sentinel-2 data cube on your local -machine, and the files have the same spatial resolution and projection, with -each file containing a single band and date, an acceptable file name is: -\itemize{ - \item \code{"SENTINEL-2_MSI_20LKP_B02_2018-07-18.jp2"} -} - -This file name works because it encodes the three key pieces of information -used by \code{sits}: -\itemize{ - \item Tile: "20LKP"; - \item Band: "B02"; - \item Date: "2018-07-18" -} -In this case the \code{"parse_info"} parameter should be -\code{c("satellite", "sensor", "tile", "band", "date")} -Other example of supported file names are: -\itemize{ - \item \code{"CBERS-4_WFI_022024_B13_2021-05-15.tif"}; - - \item \code{"SENTINEL-1_GRD_30TXL_VV_2023-03-10.tif"}; - - \item \code{"LANDSAT-8_OLI_198030_B04_2020-09-12.tif"}. -} - -The \code{parse_info} parameter tells \code{sits} how to extract essential -metadata from file names. It defines the sequence of components in the -file name, assigning each part a label such as \code{"tile"}, \code{"band"}, -and \code{"date"}. For parts of the file name that are irrelevant to -\code{sits}, you can use dummy labels like \code{"X1"} and \code{"X2"}. - -For example, consider the file name: -\itemize{ - \item \code{"SENTINEL-2_MSI_20LKP_B02_2018-07-18.jp2"} -} - -With \code{parse_info = c("satellite", "sensor", "tile", "band", "date")} and -\code{delim = "_"}, the extracted metadata would be: - -\itemize{ - \item satellite: "SENTINEL-2" (ignored) - \item sensor: "MSI" (ignored) - \item tile: "20LKP" (used) - \item band: "B02" (used) - \item date: "2018-07-18" (used) -} - -The \code{delim} parameter specifies the character that separates components -in the file name. The default delimiter is \code{"_"}. - -Note that when you load a local data cube specifying the \code{source} -(e.g., AWS, MPC) and \code{collection}, \code{sits} assumes that the data -properties (e.g., scale factor, minimum, and maximum values) match those -defined for the selected provider. However, if you are working with -custom data from an unsupported source or data that does not follow the -standard definitions of providers in sits, refer to the Technical Annex of -the \code{sits} online book for guidance on handling such cases -(e-sensing.github.io/sitsbook/technical-annex.html). - -It is also possible to create result cubes from local files produced by -classification or post-classification algorithms. In this case, the -\code{parse_info} is specified differently, and other additional parameters -are required: - -\itemize{ - -\item \code{band}: Band name associated to the type of result. Use - \code{"probs"}, for probability cubes produced by - \code{\link{sits_classify}()}; - \code{"bayes"}, for smoothed cubes produced by \code{\link{sits_smooth}()}; - \code{"segments"}, for vector cubes produced by - \code{\link{sits_segment}()}; - \code{"entropy"} when using \code{\link{sits_uncertainty}()}, and - \code{"class"} for cubes produced by - \code{\link{sits_label_classification}()}; - -\item \code{labels}: Labels associated to the classification results; - -\item \code{parse_info}: File name parsing information - to deduce the values of \code{"tile"}, \code{"start_date"}, - \code{"end_date"} from the file name. Unlike non-classified image files, - cubes with results have both \code{"start_date"} and \code{"end_date"}. - Default is c("X1", "X2", "tile", "start_date", "end_date", "band"). -} - } } \examples{ @@ -399,102 +120,6 @@ if (sits_run_examples()) { start_date = "2019-01-01", end_date = "2019-10-28" ) - # --- Access to Digital Earth Australia - cube_deaustralia <- sits_cube( - source = "DEAUSTRALIA", - collection = "GA_LS8CLS9C_GM_CYEAR_3", - bands = c("RED", "GREEN", "BLUE"), - roi = c( - lon_min = 137.15991, - lon_max = 138.18467, - lat_min = -33.85777, - lat_max = -32.56690 - ), - start_date = "2018-01-01", - end_date = "2018-12-31" - ) - # --- Access to CDSE open data Sentinel 2/2A level 2 collection - # --- remember to set the appropriate environmental variables - # It is recommended that `multicores` be used to accelerate the process. - s2_cube <- sits_cube( - source = "CDSE", - collection = "SENTINEL-2-L2A", - tiles = c("20LKP"), - bands = c("B04", "B08", "B11"), - start_date = "2018-07-18", - end_date = "2019-01-23" - ) - - ## --- Sentinel-1 SAR from CDSE - # --- remember to set the appropriate environmental variables - roi_sar <- c("lon_min" = 33.546, "lon_max" = 34.999, - "lat_min" = 1.427, "lat_max" = 3.726) - s1_cube_open <- sits_cube( - source = "CDSE", - collection = "SENTINEL-1-RTC", - bands = c("VV", "VH"), - orbit = "descending", - roi = roi_sar, - start_date = "2020-01-01", - end_date = "2020-06-10" - ) - - # --- Access to AWS open data Sentinel 2/2A level 2 collection - s2_cube <- sits_cube( - source = "AWS", - collection = "SENTINEL-S2-L2A-COGS", - tiles = c("20LKP", "20LLP"), - bands = c("B04", "B08", "B11"), - start_date = "2018-07-18", - end_date = "2019-07-23" - ) - - # --- Creating Sentinel cube from MPC - s2_cube <- sits_cube( - source = "MPC", - collection = "SENTINEL-2-L2A", - tiles = "20LKP", - bands = c("B05", "CLOUD"), - start_date = "2018-07-18", - end_date = "2018-08-23" - ) - - # --- Creating Landsat cube from MPC - roi <- c("lon_min" = -50.410, "lon_max" = -50.379, - "lat_min" = -10.1910 , "lat_max" = -10.1573) - mpc_cube <- sits_cube( - source = "MPC", - collection = "LANDSAT-C2-L2", - bands = c("BLUE", "RED", "CLOUD"), - roi = roi, - start_date = "2005-01-01", - end_date = "2006-10-28" - ) - - ## Sentinel-1 SAR from MPC - roi_sar <- c("lon_min" = -50.410, "lon_max" = -50.379, - "lat_min" = -10.1910, "lat_max" = -10.1573) - - s1_cube_open <- sits_cube( - source = "MPC", - collection = "SENTINEL-1-GRD", - bands = c("VV", "VH"), - orbit = "descending", - roi = roi_sar, - start_date = "2020-06-01", - end_date = "2020-09-28" - ) - # --- Access to World Cover data (2021) via Terrascope - cube_terrascope <- sits_cube( - source = "TERRASCOPE", - collection = "WORLD-COVER-2021", - roi = c( - lon_min = -62.7, - lon_max = -62.5, - lat_min = -8.83, - lat_max = -8.70 - ) - ) # --- Create a cube based on a local MODIS data # MODIS local files have names such as # "TERRA_MODIS_012010_NDVI_2013-09-14.jp2" diff --git a/man/sits_cube.local_cube.Rd b/man/sits_cube.local_cube.Rd new file mode 100644 index 000000000..341acef3d --- /dev/null +++ b/man/sits_cube.local_cube.Rd @@ -0,0 +1,122 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_cube_local.R +\name{sits_cube.local_cube} +\alias{sits_cube.local_cube} +\title{Create sits cubes from cubes in flat files in a local} +\usage{ +\method{sits_cube}{local_cube}( + source, + collection, + ..., + bands = NULL, + tiles = NULL, + start_date = NULL, + end_date = NULL, + data_dir, + parse_info = c("X1", "X2", "tile", "band", "date"), + delim = "_", + multicores = 2L, + progress = TRUE +) +} +\arguments{ +\item{source}{Data source: one of \code{"AWS"}, \code{"BDC"}, +\code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, +\code{"HLS"}, \code{"PLANETSCOPE"}, \code{"MPC"}, +\code{"SDC"} or \code{"USGS"}. This is the source +from which the data has been downloaded.} + +\item{collection}{Image collection in data source. +To find out the supported collections, +use \code{\link{sits_list_collections}()}).} + +\item{...}{Other parameters to be passed for specific types.} + +\item{bands}{Spectral bands and indices to be included +in the cube (optional).} + +\item{tiles}{Tiles from the collection to be included in +the cube (see details below).} + +\item{start_date, end_date}{Initial and final dates to include +images from the collection in the cube (optional). +(Date in YYYY-MM-DD format).} + +\item{data_dir}{Local directory where images are stored.} + +\item{parse_info}{Parsing information for local files.} + +\item{delim}{Delimiter for parsing local files (default = "_")} + +\item{multicores}{Number of workers for parallel processing +(integer, min = 1, max = 2048).} + +\item{progress}{Logical: show a progress bar?} +} +\value{ +A \code{tibble} describing the contents of a data cube. +} +\description{ +Creates data cubes based on files on local directory. Assumes users +have downloaded the data from a known cloud collection or the data +has been created by \code{sits}. +} +\note{ +To create a cube from local files, please inform: +\itemize{ + \item \code{source}: The data provider from which the data was + downloaded (e.g, "BDC", "MPC"); + \item \code{collection}: The collection from which the data comes from. + (e.g., \code{"SENTINEL-2-L2A"} for the Sentinel-2 MPC collection level 2A); + \item \code{data_dir}: The local directory where the image files are stored. + \item \code{parse_info}: Defines how to extract metadata from file names + by specifying the order and meaning of each part, separated by the + \code{"delim"} character. Default value is + \code{c("X1", "X2", "tile", "band", "date")}. + \item \code{delim}: The delimiter character used to separate components in + the file names. Default is \code{"_"}. +} +Please ensure that local files meet the following requirements: + +\itemize{ + \item All image files must have the same spatial resolution and projection; + \item Each file should represent a single image band for a single date; + \item File names must include information about the \code{tile}, + \code{date}, and \code{band} in their names. + \item{The \code{parse_info} parameter tells \code{sits} how to extract + metadata from file names.} + \item{By default the \code{parse_info} parameter is + \code{c(satellite, sensor, tile, band, date)}.} +} +Example of supported file names are: +\itemize{ + \item \code{"CBERS-4_WFI_022024_B13_2021-05-15.tif"}; + \item \code{"SENTINEL-1_GRD_30TXL_VV_2023-03-10.tif"}; + \item \code{"LANDSAT-8_OLI_198030_B04_2020-09-12.tif"}. +} + +When you load a local data cube specifying the \code{source} +(e.g., AWS, MPC) and \code{collection}, \code{sits} assumes that the data +properties (e.g., scale factor, minimum, and maximum values) match those +defined for the selected provider. If you are working with +custom data from an unsupported source or data that does not follow the +standard definitions of providers in sits, refer to the Technical Annex of +the \code{sits} online book for guidance on handling such cases +(e-sensing.github.io/sitsbook/technical-annex.html). +} +\examples{ +if (sits_run_examples()) { + # --- Create a cube based on a local MODIS data + # MODIS local files have names such as + # "TERRA_MODIS_012010_NDVI_2013-09-14.jp2" + # see the parse info parameter as an example on how to + # decode local files + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + modis_cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir, + parse_info = c("satellite", "sensor", "tile", "band", "date") + ) +} +} diff --git a/man/sits_cube.results_cube.Rd b/man/sits_cube.results_cube.Rd new file mode 100644 index 000000000..710e20e5b --- /dev/null +++ b/man/sits_cube.results_cube.Rd @@ -0,0 +1,94 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_cube_local.R +\name{sits_cube.results_cube} +\alias{sits_cube.results_cube} +\title{Create a results cube from local files} +\usage{ +\method{sits_cube}{results_cube}( + source, + collection, + ..., + data_dir, + bands = NULL, + labels, + parse_info = c("X1", "X2", "tile", "start_date", "end_date", "band", "version"), + version = "v1", + delim = "_", + multicores = 2L, + progress = TRUE +) +} +\arguments{ +\item{source}{Data source: one of \code{"AWS"}, \code{"BDC"}, +\code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, +\code{"HLS"}, \code{"PLANETSCOPE"}, \code{"MPC"}, +\code{"SDC"} or \code{"USGS"}. This is the source +from which the data has been downloaded.} + +\item{collection}{Image collection in data source. +To find out the supported collections, +use \code{\link{sits_list_collections}()}).} + +\item{...}{Other parameters to be passed for specific types.} + +\item{data_dir}{Local directory where images are stored} + +\item{bands}{Results bands to be retrieved +("probs", "bayes", "variance", "class", "uncertainty")} + +\item{labels}{Labels associated to the classes +(Named character vector for cubes of +classes "probs_cube" or "class_cube")} + +\item{parse_info}{Parsing information for local files +(see notes below).} + +\item{version}{Version of the classified and/or labelled files.} + +\item{delim}{Delimiter for parsing local files +(default = "_")} + +\item{multicores}{Number of workers for parallel processing +(integer, min = 1, max = 2048).} + +\item{progress}{Logical: show a progress bar?} +} +\value{ +A \code{tibble} describing the contents of a data cube. +} +\description{ +Creates a data cube from local files produced by sits operations +that produces results (such as probs_cubs and class_cubes) +} +\note{ +This function creates result cubes from local files produced by +classification or post-classification algorithms. In this case, the +\code{parse_info} is specified differently, and additional parameters +are required. +The parameter \code{bands} should be a single character vector with +the name associated to the type of result: +\itemize{ +\item{\code{"probs"}, for probability cubes produced by + \code{\link[sits]{sits_classify}}.} +\item{\code{"bayes"}, for smoothed cubes produced by + \code{\link[sits]{sits_smooth}}.} +\item{\code{"entropy"} when using \code{\link[sits]{sits_uncertainty}} to measure + entropy in pixel classification.} +\item{\code{"margin"} when using \code{\link[sits]{sits_uncertainty}} to measure + probability margin in pixel classification.} +\item{\code{"least"} when using \code{\link[sits]{sits_uncertainty}} to measure + difference between 100\% and most probable class in pixel classification.} +\item{\code{"class"} for cubes produced by + \code{\link[sits]{sits_label_classification}}.} +} +For cubes of type \code{"probs"}, \code{"bayes"}, \code{"class"}, the + \code{labels} parameter should be named vector associated to the + classification results. For \code{"class"} cubes, its names should be + integers associated to the values of the raster files that represent + the classified cube. + +Parameter \code{parse_info} should contain parsing information + to deduce the values of \code{tile}, \code{start_date}, + \code{end_date} and \code{band} from the file name. + Default is c("X1", "X2", "tile", "start_date", "end_date", "band"). +} diff --git a/man/sits_cube.stac_cube.Rd b/man/sits_cube.stac_cube.Rd new file mode 100644 index 000000000..fd01f738b --- /dev/null +++ b/man/sits_cube.stac_cube.Rd @@ -0,0 +1,238 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_cube.R +\name{sits_cube.stac_cube} +\alias{sits_cube.stac_cube} +\title{Create data cubes from image collections acessible by STAC} +\usage{ +\method{sits_cube}{stac_cube}( + source, + collection, + ..., + bands = NULL, + tiles = NULL, + roi = NULL, + crs = NULL, + start_date = NULL, + end_date = NULL, + orbit = "descending", + platform = NULL, + multicores = 2, + progress = TRUE +) +} +\arguments{ +\item{source}{Data source: one of \code{"AWS"}, \code{"BDC"}, +\code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, +\code{"HLS"}, \code{"PLANETSCOPE"}, \code{"MPC"}, +\code{"SDC"} or \code{"USGS"}.} + +\item{collection}{Image collection in data source. +To find out the supported collections, +use \code{\link{sits_list_collections}()}).} + +\item{...}{Other parameters to be passed for specific types.} + +\item{bands}{Spectral bands and indices to be included +in the cube (optional). +Use \code{\link{sits_list_collections}()} to find out +the bands available for each collection.} + +\item{tiles}{Tiles from the collection to be included in +the cube (see details below).} + +\item{roi}{Region of interest (see below).} + +\item{crs}{The Coordinate Reference System (CRS) of the roi. +(see details below).} + +\item{start_date, end_date}{Initial and final dates to include +images from the collection in the cube (optional). +(Date in YYYY-MM-DD format).} + +\item{orbit}{Orbit name ("ascending", "descending") for SAR cubes.} + +\item{platform}{Optional parameter specifying the platform in case +of "LANDSAT" collection. Options: \code{Landsat-5, +Landsat-7, Landsat-8, Landsat-9}.} + +\item{multicores}{Number of workers for parallel processing +(integer, min = 1, max = 2048).} + +\item{progress}{Logical: show a progress bar?} +} +\value{ +A \code{tibble} describing the contents of a data cube. +} +\description{ +Creates a data cube based on spatial and temporal restrictions +in collections accesible by the STAC protocol +} +\note{ +Data cubes are identified on cloud providers using \code{sits_cube}. +The result of \code{sits_cube} is a description of the location +of the requested data in the cloud provider. No download is done. + +To create data cube objects from cloud providers, users need to inform: +\itemize{ + \item{\code{source}: Name of the cloud provider. + One of "AWS", "BDC", "CDSE", "DEAFRICA", "DEAUSTRALIA", + "HLS", "PLANETSCOPE", "MPC", "SDC", "TERRASCOPE", or "USGS";} + \item{\code{collection}: Name of an image collection available + in the cloud provider (e.g, "SENTINEL-1-RTC" in MPC). + Use \code{\link{sits_list_collections}()} to see which + collections are supported;} + \item{ \code{tiles}: A set of tiles defined according to the collection + tiling grid (e.g, c("20LMR", "20LMP") in MGRS);} + \item{\code{roi}: Region of interest (see below)} +} + +The parameters \code{bands}, \code{start_date}, and \code{end_date} are + optional for cubes created from cloud providers. + +Either \code{tiles} or \code{roi} must be informed. The \code{tiles} +should specify a set of valid tiles for the ARD collection. +For example, Landsat data has tiles in \code{WRS2} tiling system +and Sentinel-2 data uses the \code{MGRS} tiling system. +The \code{roi} parameter is used to select all types of images. +This parameter does not crop a region; it only +selects images that intersect it. + +To define a \code{roi} use one of: + \itemize{ + \item{A path to a shapefile with polygons;} + \item{A \code{sfc} or \code{sf} object from \code{sf} package;} + \item{A \code{SpatExtent} object from \code{terra} package;} + \item{A named \code{vector} (\code{"lon_min"}, + \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84;} + \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, + \code{"ymin"}, \code{"ymax"}) with XY coordinates.} + } +Defining a region of interest using \code{SpatExtent} or XY values not in +WGS84 requires the \code{crs} parameter to be specified. + +To get more details about each provider and collection + available in \code{sits}, please read the online sits book +(e-sensing.github.io/sitsbook). The chapter +\code{Earth Observation data cubes} provides a detailed description of all +collections you can use with \code{sits} +(e-sensing.github.io/sitsbook/earth-observation-data-cubes.html). +} +\examples{ +if (sits_run_examples()) { +# --- Creating Sentinel cube from MPC + s2_cube <- sits_cube( + source = "MPC", + collection = "SENTINEL-2-L2A", + tiles = "20LKP", + bands = c("B05", "CLOUD"), + start_date = "2018-07-18", + end_date = "2018-08-23" + ) + + # --- Creating Landsat cube from MPC + roi <- c("lon_min" = -50.410, "lon_max" = -50.379, + "lat_min" = -10.1910 , "lat_max" = -10.1573) + mpc_cube <- sits_cube( + source = "MPC", + collection = "LANDSAT-C2-L2", + bands = c("BLUE", "RED", "CLOUD"), + roi = roi, + start_date = "2005-01-01", + end_date = "2006-10-28" + ) + + ## Sentinel-1 SAR from MPC + roi_sar <- c("lon_min" = -50.410, "lon_max" = -50.379, + "lat_min" = -10.1910, "lat_max" = -10.1573) + + s1_cube_open <- sits_cube( + source = "MPC", + collection = "SENTINEL-1-GRD", + bands = c("VV", "VH"), + orbit = "descending", + roi = roi_sar, + start_date = "2020-06-01", + end_date = "2020-09-28" + ) + #' # --- Access to the Brazil Data Cube + # create a raster cube file based on the information in the BDC + cbers_tile <- sits_cube( + source = "BDC", + collection = "CBERS-WFI-16D", + bands = c("NDVI", "EVI"), + tiles = "007004", + start_date = "2018-09-01", + end_date = "2019-08-28" + ) + # --- Access to Digital Earth Africa + # create a raster cube file based on the information about the files + # DEAFRICA does not support definition of tiles + cube_deafrica <- sits_cube( + source = "DEAFRICA", + collection = "SENTINEL-2-L2A", + bands = c("B04", "B08"), + roi = c( + "lat_min" = 17.379, + "lon_min" = 1.1573, + "lat_max" = 17.410, + "lon_max" = 1.1910 + ), + start_date = "2019-01-01", + end_date = "2019-10-28" + ) + # --- Access to Digital Earth Australia + cube_deaustralia <- sits_cube( + source = "DEAUSTRALIA", + collection = "GA_LS8CLS9C_GM_CYEAR_3", + bands = c("RED", "GREEN", "BLUE"), + roi = c( + lon_min = 137.15991, + lon_max = 138.18467, + lat_min = -33.85777, + lat_max = -32.56690 + ), + start_date = "2018-01-01", + end_date = "2018-12-31" + ) + # --- Access to CDSE open data Sentinel 2/2A level 2 collection + # --- remember to set the appropriate environmental variables + # It is recommended that `multicores` be used to accelerate the process. + s2_cube <- sits_cube( + source = "CDSE", + collection = "SENTINEL-2-L2A", + tiles = c("20LKP"), + bands = c("B04", "B08", "B11"), + start_date = "2018-07-18", + end_date = "2019-01-23" + ) + + ## --- Sentinel-1 SAR from CDSE + # --- remember to set the appropriate environmental variables + # --- Obtain a AWS_ACCESS_KEY_ID and AWS_ACCESS_SECRET_KEY_ID + # --- from CDSE + roi_sar <- c("lon_min" = 33.546, "lon_max" = 34.999, + "lat_min" = 1.427, "lat_max" = 3.726) + s1_cube_open <- sits_cube( + source = "CDSE", + collection = "SENTINEL-1-RTC", + bands = c("VV", "VH"), + orbit = "descending", + roi = roi_sar, + start_date = "2020-01-01", + end_date = "2020-06-10" + ) + + + -- Access to World Cover data (2021) via Terrascope + cube_terrascope <- sits_cube( + source = "TERRASCOPE", + collection = "WORLD-COVER-2021", + roi = c( + lon_min = -62.7, + lon_max = -62.5, + lat_min = -8.83, + lat_max = -8.70 + ) + ) +} +} diff --git a/man/sits_cube.vector_cube.Rd b/man/sits_cube.vector_cube.Rd new file mode 100644 index 000000000..868775cd2 --- /dev/null +++ b/man/sits_cube.vector_cube.Rd @@ -0,0 +1,118 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_cube_local.R +\name{sits_cube.vector_cube} +\alias{sits_cube.vector_cube} +\title{Create a vector cube from local files} +\usage{ +\method{sits_cube}{vector_cube}( + source, + collection, + ..., + data_dir, + vector_dir, + vector_band, + parse_info = c("X1", "X2", "tile", "date", "band", "version"), + version = "v1", + delim = "_", + multicores = 2L, + progress = TRUE +) +} +\arguments{ +\item{source}{Data source: one of \code{"AWS"}, \code{"BDC"}, +\code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, +\code{"HLS"}, \code{"PLANETSCOPE"}, \code{"MPC"}, +\code{"SDC"} or \code{"USGS"}. This is the source +from which the data has been downloaded.} + +\item{collection}{Image collection in data source. +To find out the supported collections, +use \code{\link{sits_list_collections}()}).} + +\item{...}{Other parameters to be passed for specific types.} + +\item{data_dir}{Local directory where images are stored +(for local cubes only).} + +\item{vector_dir}{Local directory where vector files are stored} + +\item{vector_band}{Band for vector cube ("segments", "probs", "class")} + +\item{parse_info}{Parsing information for local image files} + +\item{version}{Version of the classified and/or labelled files.} + +\item{delim}{Delimiter for parsing local files +(default = "_")} + +\item{multicores}{Number of workers for parallel processing +(integer, min = 1, max = 2048).} + +\item{progress}{Logical: show a progress bar?} +} +\value{ +A \code{tibble} describing the contents of a data cube. +} +\description{ +Creates a data cube from local files which include a vector file +produced by a segmentation algorithm. +} +\note{ +This function creates vector cubes from local files produced by +\code{\link[sits]{sits_segment}}, +\code{\link[sits]{sits_classify.vector_cube}} +or \code{\link[sits]{sits_label_classification.vector_cube}}. In this case, +\code{parse_info} is specified differently as \code{c("X1", "X2", "tile", +"start_date", "end_date", "band")}. +The parameter \code{vector_dir} is the directory where the vector file is +stored. +Parameter \code{vector_band} is band name of the type of vector cube: +\itemize{ +\item{\code{"segments"}, for vector cubes produced by + \code{\link{sits_segment}}.} + \item{\code{"probs"}, for probability cubes produced by + \code{\link{sits_classify.vector_cube}}.} +\item{\code{"entropy"} when using + \code{\link{sits_uncertainty.probs_vector_cube}}.} +\item{\code{"class"} for cubes produced by + \code{\link{sits_label_classification}}.} +} +} +\examples{ +if (sits_run_examples()) { + # --- Create a cube based on a local MODIS data + # MODIS local files have names such as + # "TERRA_MODIS_012010_NDVI_2013-09-14.jp2" + # see the parse info parameter as an example on how to + # decode local files + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + modis_cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir, + parse_info = c("satellite", "sensor", "tile", "band", "date") + ) + # segment the vector cube + segments <- sits_segment( + cube = cube, + seg_fn = sits_slic( + step = 10, + compactness = 1, + dist_fun = "euclidean", + avg_fun = "median", + iter = 30, + minarea = 10 + ), + output_dir = tempdir() + ) + # recover the local segmented cube + segment_cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = system.file("extdata/raster/mod13q1", package = "sits"), + vector_dir = tempdir(), + vector_band = "segments" + ) +} + +} diff --git a/man/sits_get_data.Rd b/man/sits_get_data.Rd index 6a830e165..afaedfc20 100644 --- a/man/sits_get_data.Rd +++ b/man/sits_get_data.Rd @@ -3,86 +3,11 @@ \name{sits_get_data} \alias{sits_get_data} \alias{sits_get_data.default} -\alias{sits_get_data.csv} -\alias{sits_get_data.shp} -\alias{sits_get_data.sf} -\alias{sits_get_data.sits} -\alias{sits_get_data.data.frame} \title{Get time series from data cubes and cloud services} \usage{ sits_get_data(cube, samples, ...) \method{sits_get_data}{default}(cube, samples, ...) - -\method{sits_get_data}{csv}( - cube, - samples, - ..., - bands = NULL, - crs = "EPSG:4326", - impute_fn = impute_linear(), - multicores = 2, - progress = FALSE -) - -\method{sits_get_data}{shp}( - cube, - samples, - ..., - label = "NoClass", - start_date = NULL, - end_date = NULL, - bands = NULL, - impute_fn = impute_linear(), - label_attr = NULL, - n_sam_pol = 30, - pol_avg = FALSE, - sampling_type = "random", - multicores = 2, - progress = FALSE -) - -\method{sits_get_data}{sf}( - cube, - samples, - ..., - start_date = NULL, - end_date = NULL, - bands = NULL, - impute_fn = impute_linear(), - label = "NoClass", - label_attr = NULL, - n_sam_pol = 30, - pol_avg = FALSE, - sampling_type = "random", - multicores = 2, - progress = FALSE -) - -\method{sits_get_data}{sits}( - cube, - samples, - ..., - bands = NULL, - crs = "EPSG:4326", - impute_fn = impute_linear(), - multicores = 2, - progress = FALSE -) - -\method{sits_get_data}{data.frame}( - cube, - samples, - ..., - start_date = NULL, - end_date = NULL, - bands = NULL, - label = "NoClass", - crs = "EPSG:4326", - impute_fn = impute_linear(), - multicores = 2, - progress = FALSE -) } \arguments{ \item{cube}{Data cube from where data is to be retrieved. @@ -93,43 +18,7 @@ Either a tibble of class "sits", an "sf" object, the name of a shapefile or csv file, or a data.frame with columns "longitude" and "latitude".} -\item{...}{Specific parameters for specific cases.} - -\item{bands}{Bands to be retrieved - optional -(character vector).} - -\item{crs}{Default crs for the samples -(character vector of length 1).} - -\item{impute_fn}{Imputation function to remove NA.} - -\item{multicores}{Number of threads to process the time series -(integer, with min = 1 and max = 2048).} - -\item{progress}{Logical: show progress bar?} - -\item{label}{Label to be assigned to the time series (optional) -(character vector of length 1).} - -\item{start_date}{Start of the interval for the time series - optional -(Date in "YYYY-MM-DD" format).} - -\item{end_date}{End of the interval for the time series - optional -(Date in "YYYY-MM-DD" format).} - -\item{label_attr}{Attribute in the shapefile or sf object to be used -as a polygon label. -(character vector of length 1).} - -\item{n_sam_pol}{Number of samples per polygon to be read -for POLYGON or MULTIPOLYGON shapefiles or sf objects -(single integer).} - -\item{pol_avg}{Logical: summarize samples for each polygon? -(character vector of length 1)} - -\item{sampling_type}{Spatial sampling type: random, hexagonal, -regular, or Fibonacci.} +\item{...}{Specific parameters for each input.} } \value{ A tibble of class "sits" with set of time series @@ -137,8 +26,18 @@ A tibble of class "sits" with set of time series } \description{ Retrieve a set of time series from a data cube and -and put the result in a "sits tibble", which +and put the result in a \code{sits tibble}, which contains both the satellite image time series and their metadata. + +There are five options for the specifying the input +\code{samples} parameter: +\itemize{ +\item{A CSV file: see \code{\link[sits]{sits_get_data.csv}}.} +\item{A \code{sits} tibble: see \code{\link[sits]{sits_get_data.sits}}. } +\item{A shapefile: see \code{\link[sits]{sits_get_data.shp}}. } +\item{An \code{sf} object: see \code{\link[sits]{sits_get_data.sf}}.} +\item{A data.frame: see see \code{\link[sits]{sits_get_data.data.frame}}.} +} } \note{ The main \code{sits} classification workflow has the following steps: @@ -168,45 +67,11 @@ The main \code{sits} classification workflow has the following steps: To be able to build a machine learning model to classify a data cube, one needs to use a set of labelled time series. These time series are created by taking a set of known samples, expressed as -labelled points or polygons. -This \code{sits_get_data} function uses these samples to -extract time series from a data cube. Thus, it needs a \code{cube} parameter +labelled points or polygons. This \code{sits_get_data} function + uses these samples to +extract time series from a data cube. It needs a \code{cube} parameter which points to a regularized data cube, and a \code{samples} parameter that describes the locations of the training set. - -There are five ways of specifying the -\code{samples} parameter: -\enumerate{ -\item{A CSV file with columns -\code{longitude}, \code{latitude}, -\code{start_date}, \code{end_date} and \code{label} for each sample. -The parameter must point to a file with extension ".csv";} -\item{A shapefile in POINT or POLYGON geometry -containing the location of the samples. -The parameter must point to a file with extension ".shp";} -\item{A sits tibble, which contains columns -\code{longitude}, \code{latitude}, -\code{start_date}, \code{end_date} and \code{label} for each sample.} -\item{A \code{link[sf]{sf}} object with POINT or POLYGON geometry;} -\item{A data.frame with with mandatory columns -\code{longitude}, \code{latitude}, -\code{start_date}, \code{end_date} and \code{label} for each row.} -} - -For shapefiles and sf objects, the following parameters are relevant: -\enumerate{ -\item{\code{label}: label to be assigned to the samples. -Should only be used if all geometries have a single label.} -\item{\code{label_attr}: defines which attribute should be -used as a label, required for POINT and POLYGON geometries if -\code{label} has not been set.} -\item{\code{n_sam_pol}: indicates how many points are -extracted from each polygon, required for POLYGON geometry (default = 15).} -\item{\code{sampling_type}: defines how sampling is done, required -for POLYGON geometry (default = "random").} -\item{\code{pol_avg}: indicates if average of values for POLYGON -geometry should be computed (default = "FALSE").} -} } \examples{ if (sits_run_examples()) { diff --git a/man/sits_get_data.csv.Rd b/man/sits_get_data.csv.Rd new file mode 100644 index 000000000..ba58fd033 --- /dev/null +++ b/man/sits_get_data.csv.Rd @@ -0,0 +1,65 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_get_data.R +\name{sits_get_data.csv} +\alias{sits_get_data.csv} +\title{Get time series using CSV files} +\usage{ +\method{sits_get_data}{csv}( + cube, + samples, + ..., + bands = NULL, + crs = "EPSG:4326", + impute_fn = impute_linear(), + multicores = 2, + progress = FALSE +) +} +\arguments{ +\item{cube}{Data cube from where data is to be retrieved. +(tibble of class "raster_cube").} + +\item{samples}{Location of a csv file.} + +\item{...}{Specific parameters for each kind of input.} + +\item{bands}{Bands to be retrieved - optional.} + +\item{crs}{Default crs for the samples.} + +\item{impute_fn}{Imputation function to remove NA.} + +\item{multicores}{Number of threads to process the time series +(integer, with min = 1 and max = 2048).} + +\item{progress}{Logical: show progress bar?} +} +\value{ +A tibble of class "sits" with set of time series and metadata with +. +} +\description{ +Retrieve a set of time series from a data cube and +and put the result in a "sits tibble", which +contains both the satellite image time series and their metadata. +The \code{samples} parameter must point to a file with extension ".csv", +with mandatory columns \code{longitude}, \code{latitude}, \code{label}, +\code{start_date} and \code{end_date}. +} +\examples{ +if (sits_run_examples()) { + # reading a lat/long from a local cube + # create a cube from local files + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + raster_cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + # reading samples from a cube based on a CSV file + csv_file <- system.file("extdata/samples/samples_sinop_crop.csv", + package = "sits" + ) + points <- sits_get_data(cube = raster_cube, samples = csv_file) +} +} diff --git a/man/sits_get_data.data.frame.Rd b/man/sits_get_data.data.frame.Rd new file mode 100644 index 000000000..c91e758ed --- /dev/null +++ b/man/sits_get_data.data.frame.Rd @@ -0,0 +1,77 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_get_data.R +\name{sits_get_data.data.frame} +\alias{sits_get_data.data.frame} +\title{Get time series using sits objects} +\usage{ +\method{sits_get_data}{data.frame}( + cube, + samples, + ..., + start_date = NULL, + end_date = NULL, + bands = NULL, + label = "NoClass", + crs = "EPSG:4326", + impute_fn = impute_linear(), + multicores = 2, + progress = FALSE +) +} +\arguments{ +\item{cube}{Data cube from where data is to be retrieved. +(tibble of class "raster_cube").} + +\item{samples}{A data.frame with mandatory columns \code{longitude}, +and \code{latitude}, and optional columns +\code{start_date}, \code{end_date}, \code{label}.} + +\item{...}{Specific parameters for specific cases.} + +\item{start_date}{Start of the interval for the time series - optional +(Date in "YYYY-MM-DD" format).} + +\item{end_date}{End of the interval for the time series - optional +(Date in "YYYY-MM-DD" format).} + +\item{bands}{Bands to be retrieved - optional.} + +\item{label}{Label to be assigned to all time series if +column \code{label} is not provided in the +data.frame.} + +\item{crs}{Default crs for the samples.} + +\item{impute_fn}{Imputation function to remove NA.} + +\item{multicores}{Number of threads to process the time series +(integer, with min = 1 and max = 2048).} + +\item{progress}{Logical: show progress bar?} +} +\value{ +A sits tibble with the time series for each + sample. +} +\description{ +Retrieve a set of time series from a data cube and +and put the result in a \code{sits tibble}. The \code{samples} +parameter should be a \code{data.frame} which +which contains mandatory columns +\code{longitude} and \code{latitude}, and optional columns +\code{start_date}, \code{end_date} and \code{label} for each sample. +} +\examples{ +if (sits_run_examples()) { + # create a cube from local files + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + raster_cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + # read a lat/long from a local cube + samples <- data.frame(longitude = -55.66738, latitude = -11.76990) + point_ndvi <- sits_get_data(raster_cube, samples) +} +} diff --git a/man/sits_get_data.sf.Rd b/man/sits_get_data.sf.Rd new file mode 100644 index 000000000..331b09d27 --- /dev/null +++ b/man/sits_get_data.sf.Rd @@ -0,0 +1,113 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_get_data.R +\name{sits_get_data.sf} +\alias{sits_get_data.sf} +\title{Get time series using sf objects} +\usage{ +\method{sits_get_data}{sf}( + cube, + samples, + ..., + start_date = NULL, + end_date = NULL, + bands = NULL, + impute_fn = impute_linear(), + label = "NoClass", + label_attr = NULL, + n_sam_pol = 30, + pol_avg = FALSE, + sampling_type = "random", + multicores = 2, + progress = FALSE +) +} +\arguments{ +\item{cube}{Data cube from where data is to be retrieved. +(tibble of class "raster_cube").} + +\item{samples}{The name of a shapefile.} + +\item{...}{Specific parameters for specific cases.} + +\item{start_date}{Start of the interval for the time series - optional +(Date in "YYYY-MM-DD" format).} + +\item{end_date}{End of the interval for the time series - optional +(Date in "YYYY-MM-DD" format).} + +\item{bands}{Bands to be retrieved - optional +(character vector).} + +\item{impute_fn}{Imputation function to remove NA.} + +\item{label}{Label to be assigned to all time series - optional} + +\item{label_attr}{Attribute in the sf object to be used +as a polygon label.} + +\item{n_sam_pol}{Number of samples per polygon to be read +for POLYGON or MULTIPOLYGON objects.} + +\item{pol_avg}{Logical: summarize samples for each polygon?} + +\item{sampling_type}{Spatial sampling type: random, hexagonal, +regular, or Fibonacci.} + +\item{multicores}{Number of threads to process the time series +(integer, with min = 1 and max = 2048).} + +\item{progress}{Logical: show progress bar?} +} +\value{ +A tibble of class "sits" with set of time series +. +} +\description{ +Retrieve a set of time series from a data cube and +and put the result in a "sits tibble", which +contains both the satellite image time series and their metadata. +The \code{samples} parameter must be a \code{sf} object +in POINT or POLYGON geometry. +If \code{start_date} and \code{end_date} are not informed, the function +uses these data from the cube. +} +\note{ +#' For sf objects, the following parameters are relevant: +\itemize{ +\item{\code{label}: label to be assigned to the samples. +Should only be used if all geometries have a single label.} +\item{\code{label_attr}: defines which attribute should be +used as a label, required for POINT and POLYGON geometries if +\code{label} has not been set.} +\item{\code{n_sam_pol}: indicates how many points are +extracted from each polygon, required for POLYGON geometry (default = 15).} +\item{\code{sampling_type}: defines how sampling is done, required +for POLYGON geometry (default = "random").} +\item{\code{pol_avg}: indicates if average of values for POLYGON +geometry should be computed (default = "FALSE").} +} +} +\examples{ +if (sits_run_examples()) { + # reading a shapefile from BDC (Brazil Data Cube) + bdc_cube <- sits_cube( + source = "BDC", + collection = "CBERS-WFI-16D", + bands = c("NDVI", "EVI"), + tiles = c("007004", "007005"), + start_date = "2018-09-01", + end_date = "2018-10-28" + ) + # define a shapefile to be read from the cube + shp_file <- system.file("extdata/shapefiles/bdc-test/samples.shp", + package = "sits" + ) + # read a shapefile into an sf object + sf_object <- sf::st_read(shp_file) + # get samples from the BDC using an sf object + time_series_bdc <- sits_get_data( + cube = bdc_cube, + samples = sf_object + ) +} +} diff --git a/man/sits_get_data.shp.Rd b/man/sits_get_data.shp.Rd new file mode 100644 index 000000000..1cab36227 --- /dev/null +++ b/man/sits_get_data.shp.Rd @@ -0,0 +1,112 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_get_data.R +\name{sits_get_data.shp} +\alias{sits_get_data.shp} +\title{Get time series using shapefiles} +\usage{ +\method{sits_get_data}{shp}( + cube, + samples, + ..., + start_date = NULL, + end_date = NULL, + bands = NULL, + impute_fn = impute_linear(), + label = "NoClass", + label_attr = NULL, + n_sam_pol = 30, + pol_avg = FALSE, + sampling_type = "random", + multicores = 2, + progress = FALSE +) +} +\arguments{ +\item{cube}{Data cube from where data is to be retrieved. +(tibble of class "raster_cube").} + +\item{samples}{The name of a shapefile.} + +\item{...}{Specific parameters for specific cases.} + +\item{start_date}{Start of the interval for the time series - optional +(Date in "YYYY-MM-DD" format).} + +\item{end_date}{End of the interval for the time series - optional +(Date in "YYYY-MM-DD" format).} + +\item{bands}{Bands to be retrieved - optional} + +\item{impute_fn}{Imputation function to remove NA.} + +\item{label}{Label to be assigned to all time series - optional} + +\item{label_attr}{Attribute in the shapefile to be used +as a polygon label.} + +\item{n_sam_pol}{Number of samples per polygon to be read +for POLYGON or MULTIPOLYGON shapefiles.} + +\item{pol_avg}{Logical: summarize samples for each polygon?} + +\item{sampling_type}{Spatial sampling type: random, hexagonal, +regular, or Fibonacci.} + +\item{multicores}{Number of threads to process the time series +(integer, with min = 1 and max = 2048).} + +\item{progress}{Logical: show progress bar?} +} +\value{ +A tibble of class "sits" with set of time series and metadata +. +} +\description{ +Retrieve a set of time series from a data cube and +and put the result in a \code{sits tibble}, which +contains both the satellite image time series and their metadata. +The \code{samples} parameter must point to a file with extension ".shp" +which should be a valid shapefile in POINT or POLYGON geometry. +If \code{start_date} and \code{end_date} are not informed, the function +uses these data from the cube. +} +\note{ +For shapefiles, the following parameters are relevant: +\itemize{ +\item{\code{label}: label to be assigned to the samples. +Should only be used if all geometries have a single label.} +\item{\code{label_attr}: defines which attribute should be +used as a label, required for POINT and POLYGON geometries if +\code{label} has not been set.} +\item{\code{n_sam_pol}: indicates how many points are +extracted from each polygon, required for POLYGON geometry (default = 15).} +\item{\code{sampling_type}: defines how sampling is done, required +for POLYGON geometry (default = "random").} +\item{\code{pol_avg}: indicates if average of values for POLYGON +geometry should be computed (default = "FALSE").} +} +} +\examples{ +if (sits_run_examples()) { + + # reading a shapefile from BDC (Brazil Data Cube) + bdc_cube <- sits_cube( + source = "BDC", + collection = "CBERS-WFI-16D", + bands = c("NDVI", "EVI"), + tiles = c("007004", "007005"), + start_date = "2018-09-01", + end_date = "2018-10-28" + ) + # define a shapefile to be read from the cube + shp_file <- system.file("extdata/shapefiles/bdc-test/samples.shp", + package = "sits" + ) + # get samples from the BDC based on the shapefile + time_series_bdc <- sits_get_data( + cube = bdc_cube, + samples = shp_file + ) +} + +} diff --git a/man/sits_get_data.sits.Rd b/man/sits_get_data.sits.Rd new file mode 100644 index 000000000..9ff385a7e --- /dev/null +++ b/man/sits_get_data.sits.Rd @@ -0,0 +1,53 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_get_data.R +\name{sits_get_data.sits} +\alias{sits_get_data.sits} +\title{Get time series using sits objects} +\usage{ +\method{sits_get_data}{sits}( + cube, + samples, + ..., + bands = NULL, + crs = "EPSG:4326", + impute_fn = impute_linear(), + multicores = 2, + progress = FALSE +) +} +\arguments{ +\item{cube}{Data cube from where data is to be retrieved. +(tibble of class "raster_cube").} + +\item{samples}{Location of the samples to be retrieved. +Either a tibble of class "sits", an "sf" object, +the name of a shapefile or csv file, or +a data.frame with columns "longitude" and "latitude".} + +\item{...}{Specific parameters for specific cases.} + +\item{bands}{Bands to be retrieved - optional.} + +\item{crs}{Default crs for the samples.} + +\item{impute_fn}{Imputation function to remove NA.} + +\item{multicores}{Number of threads to process the time series +(integer, with min = 1 and max = 2048).} + +\item{progress}{Logical: show progress bar?} + +\item{start_date}{Start of the interval for the time series - optional +(Date in "YYYY-MM-DD" format).} + +\item{end_date}{End of the interval for the time series - optional +(Date in "YYYY-MM-DD" format).} +} +\description{ +Retrieve a set of time series from a data cube and +and put the result in a \code{sits tibble}. The \code{samples} +parameter should be a valid \code{sits tibble} which +which contains columns +\code{longitude}, \code{latitude}, +\code{start_date}, \code{end_date} and \code{label} for each sample. +} diff --git a/man/sits_get_probs.Rd b/man/sits_get_probs.Rd index be92c2046..3d1e9e698 100644 --- a/man/sits_get_probs.Rd +++ b/man/sits_get_probs.Rd @@ -28,8 +28,11 @@ sits_get_probs(cube, samples, window_size = NULL) \item{cube}{Probability data cube.} \item{samples}{Location of the samples to be retrieved. -Either a tibble of class "sits", an "sf" object, -the name of a shapefile or csv file, or +Either a tibble of class "sits", +an "sf" object with POINT geometry, +the location of a POINT shapefile, +the location of csv file with columns +"longitude" and "latitude", or a data.frame with columns "longitude" and "latitude"} \item{window_size}{Size of window around pixel (optional)} @@ -49,11 +52,13 @@ between classifiers. \note{ There are four ways of specifying data to be retrieved using the \code{samples} parameter: -(a) CSV file: a CSV file with columns \code{longitude}, \code{latitude}; -(b) SHP file: a shapefile in POINT geometry; -(c) sits object: A sits tibble; -(d) sf object: An \code{link[sf]{sf}} object with POINT or geometry; -(e) data.frame: A data.frame with \code{longitude} and \code{latitude}. +\itemize{ +\item{CSV: a CSV file with columns \code{longitude}, \code{latitude}.} +\item{SHP: a shapefile in POINT geometry.} +\item{sf object: An \code{link[sf]{sf}} object with POINT geometry.} +\item{sits object: A valid tibble with \code{sits} timeseries.} +\item{data.frame: A data.frame with \code{longitude} and \code{latitude}.} +} } \examples{ if (sits_run_examples()) { diff --git a/man/st_as_stars.raster_cube.Rd b/man/st_as_stars.raster_cube.Rd deleted file mode 100644 index a7d7f96bd..000000000 --- a/man/st_as_stars.raster_cube.Rd +++ /dev/null @@ -1,45 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sits_stars.R -\name{st_as_stars.raster_cube} -\alias{st_as_stars.raster_cube} -\title{Extension to stars for exporting sits cubes as stars objects} -\usage{ -st_as_stars.raster_cube(.x, ...) -} -\arguments{ -\item{.x}{A sits cube.} - -\item{...}{Other parameters for st_as_stars} -} -\value{ -A space-time stars object. -} -\description{ -Uses the information about files, bands and dates -in a data cube to produce an object of class \code{stars}. -User has to select a tile from the data cube. By default, -all bands and dates are included in the \code{stars} object. -Users can select bands and dates. -} -\note{ -By default, the \code{stars} object will be loaded in memory. This -can result in heavy memory usage. To produce a \code{stars.proxy} object, -uses have to select a single date, since \code{stars} does not allow -proxy objects to be created with two dimensions. -} -\examples{ -if (sits_run_examples()) { - library(stars) - # convert sits cube to an sf object (polygon) - data_dir <- system.file("extdata/raster/mod13q1", package = "sits") - cube <- sits_cube( - source = "BDC", - collection = "MOD13Q1-6.1", - data_dir = data_dir - ) - stars_object <- st_as_stars(cube) -} -} -\author{ -Gilberto Camara, \email{gilberto.camara.inpe@gmail.com} -} From cd340b50526242883b53bc4b1d4b62df511a6336 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Thu, 3 Apr 2025 06:36:24 -0300 Subject: [PATCH 067/122] improve documentation --- NAMESPACE | 2 +- R/api_band.R | 6 + R/api_check.R | 11 +- R/api_source_local.R | 275 ++++++++++------- R/sits_classify.R | 485 +++++++++++++++++++++--------- R/sits_cube.R | 35 ++- R/sits_cube_local.R | 94 +++--- R/sits_get_data.R | 4 - R/sits_plot.R | 2 +- inst/extdata/config_internals.yml | 4 + inst/extdata/config_messages.yml | 1 + man/sits_classify.Rd | 290 +++--------------- man/sits_classify.raster_cube.Rd | 167 ++++++++++ man/sits_classify.segs_cube.Rd | 188 ++++++++++++ man/sits_classify.sits.Rd | 101 +++++++ man/sits_cube.Rd | 2 +- man/sits_cube.results_cube.Rd | 6 +- man/sits_cube.stac_cube.Rd | 4 +- man/sits_cube.vector_cube.Rd | 20 +- man/sits_get_data.sits.Rd | 6 - 20 files changed, 1104 insertions(+), 599 deletions(-) create mode 100644 man/sits_classify.raster_cube.Rd create mode 100644 man/sits_classify.segs_cube.Rd create mode 100644 man/sits_classify.sits.Rd diff --git a/NAMESPACE b/NAMESPACE index 800d85f55..258b891f4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -358,9 +358,9 @@ S3method(sits_bbox,tbl_df) S3method(sits_classify,default) S3method(sits_classify,derived_cube) S3method(sits_classify,raster_cube) -S3method(sits_classify,segs_cube) S3method(sits_classify,sits) S3method(sits_classify,tbl_df) +S3method(sits_classify,vector_cube) S3method(sits_clean,class_cube) S3method(sits_clean,default) S3method(sits_clean,derived_cube) diff --git a/R/api_band.R b/R/api_band.R index f3f0df97f..83cc80685 100644 --- a/R/api_band.R +++ b/R/api_band.R @@ -122,3 +122,9 @@ } return(bands) } +.band_best_guess <- function(cube){ + cube_bands <- .cube_bands(cube) + if ("NDVI" %in% cube_bands) + return("NDVI") + else return(cube_bands[[1]]) +} diff --git a/R/api_check.R b/R/api_check.R index 8bbbafb79..3281ee93a 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -1173,6 +1173,7 @@ #' @param allow_duplicate allow duplicate parameter? #' @param len_min minimum length of vector #' @param len_max maximum length of vector +#' @param is_named is this a named parameter? #' @param regex regular expression to be tested #' @param msg message error #' @return Called for side effects. @@ -1181,6 +1182,7 @@ .check_chr_parameter <- function(x, len_min = 1, len_max = 2^31 - 1, + is_named = FALSE, allow_na = FALSE, allow_empty = FALSE, allow_null = FALSE, @@ -1195,6 +1197,7 @@ x, len_min = len_min, len_max = len_max, + is_named = is_named, allow_null = allow_null, allow_na = allow_na, allow_empty = allow_empty, @@ -2375,6 +2378,7 @@ #' @title Checks view bands are defined #' @name .check_bw_rgb_bands #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @param cube cube to choose band #' @param band B/W band for view #' @param red Red band for view #' @param green Green band for view @@ -2382,10 +2386,11 @@ #' @return Called for side effects #' @keywords internal #' @noRd -.check_bw_rgb_bands <- function(band, red, green, blue) { +.check_bw_rgb_bands <- function(cube, band, red, green, blue) { .check_set_caller(".check_bw_rgb_bands") - .check_that(.has(band) || (.has(red) && .has(green) && .has(blue))) - return(invisible(NULL)) + if (!.has(band) || !(.has(red) && .has(green) && .has(blue))) + band <- .band_best_guess(cube) + return(band) } #' @title Check available bands #' @name .check_available_bands diff --git a/R/api_source_local.R b/R/api_source_local.R index 3511f6ce4..abf7c6404 100644 --- a/R/api_source_local.R +++ b/R/api_source_local.R @@ -1,4 +1,90 @@ -#' @title Create data cubes using local files +#' @title Create raster data cubes using local files +#' @name .local_raster_cube +#' @keywords internal +#' @noRd +#' @param source Data source (one of \code{"AWS"}, \code{"BDC"}, +#' \code{"DEAFRICA"}, \code{"MPC"}, \code{"USGS"}). +#' @param collection Image collection in data source (To find out +#' the supported collections, use \code{\link{sits_list_collections}()}). +#' @param data_dir Local directory where images are stored.) +#' @param parse_info Parsing information for local files. +#' @param delim Delimiter for parsing local files. +#' @param tiles Tiles from the collection to be included in +#' the cube (see details below). +#' @param bands Spectral bands and indices to be included +#' in the cube (optional). +#' @param start_date,end_date Initial and final dates to include +#' images from the collection in the cube (optional). +#' @param multicores Number of workers for parallel processing +#' @param progress Show a progress bar?z +#' @param ... Other parameters to be passed for specific types. +#' @return A \code{tibble} describing the contents of a local data cube. +.local_raster_cube <- function(source, + collection, + data_dir, + parse_info, + delim, + tiles, + bands, + start_date, + end_date, + multicores, + progress, ...) { + # set caller to show in errors + .check_set_caller(".local_raster_cube") + + # bands in upper case for raw cubes, lower case for results cubes + bands <- .band_set_case(bands) + + # make query and retrieve items + raster_items <- .local_cube_items_raster_new( + data_dir = data_dir, + parse_info = parse_info, + version = version, + delim = delim, + start_date = start_date, + end_date = end_date, + bands = bands + ) + # filter tiles + if (.has(tiles)) { + raster_items <- .local_cube_items_tiles_select( + tiles = tiles, + items = raster_items + ) + } + # build file_info for the items + raster_items <- .local_cube_file_info( + items = raster_items, + multicores = multicores, + progress = progress + ) + # get all tiles + tiles <- unique(raster_items[["tile"]]) + + # make a cube for each tile (rows) + cube <- .map_dfr(tiles, function(tile) { + # filter tile + items_tile <- dplyr::filter(raster_items, .data[["tile"]] == !!tile) + # create result cube + # create EO cube + tile_cube <- .local_cube_items_cube( + source = source, + collection = collection, + items = items_tile + ) + # return! + tile_cube + }) + + # handle class cubes from external sources + cube <- .local_cube_handle_class_cube(source, collection, cube) + class(cube) <- .cube_s3class(cube) + + return(cube) +} +#' @title Create results data cubes using local files +#' @name .local_results_cube #' @keywords internal #' @noRd #' @param source Data source (one of \code{"AWS"}, \code{"BDC"}, @@ -6,8 +92,6 @@ #' @param collection Image collection in data source (To find out #' the supported collections, use \code{\link{sits_list_collections}()}). #' @param data_dir Local directory where images are stored. -#' @param vector_dir Local director where vector files are stored -#' (for local vector cubes - character vector of length 1) #' @param parse_info Parsing information for local files. #' @param version Version id for local files. #' @param delim Delimiter for parsing local files. @@ -15,33 +99,24 @@ #' the cube (see details below). #' @param bands Spectral bands and indices to be included #' in the cube (optional). -#' @param vector_band Band for vector data cube #' @param labels Labels associated to the classes (only for result cubes) -#' @param start_date,end_date Initial and final dates to include -#' images from the collection in the cube (optional). #' @param multicores Number of workers for parallel processing #' @param progress Show a progress bar?z #' @param ... Other parameters to be passed for specific types. #' @return A \code{tibble} describing the contents of a local data cube. -.local_cube <- function(source, +.local_results_cube <- function(source, collection, data_dir, - vector_dir, parse_info, version, delim, tiles, bands, - vector_band, labels, - start_date, - end_date, multicores, progress, ...) { # set caller to show in errors - .check_set_caller(".local_cube") - # initialize vector items - vector_items <- NULL + .check_set_caller(".local_results_cube") # is this a cube with results? results_cube <- .check_is_results_cube(bands, labels) @@ -57,62 +132,23 @@ parse_info = parse_info, version = version, delim = delim, - start_date = start_date, - end_date = end_date, + start_date = NULL, + end_date = NULL, bands = bands ) - if (.has(vector_dir)) { - # set the correct parse_info - parse_info <- .conf("results_parse_info_def") - - vector_items <- .local_cube_items_vector_new( - vector_dir = vector_dir, - parse_info = parse_info, - version = version, - delim = delim, - start_date = start_date, - end_date = end_date, - vector_band = vector_band - ) - } - - # filter bands in items (only for raw image cube) - if (!results_cube) { - raster_items <- .local_cube_items_bands_select( - source = source, - collection = collection, - bands = bands, - items = raster_items - ) - } # filter tiles if (.has(tiles)) { raster_items <- .local_cube_items_tiles_select( tiles = tiles, items = raster_items ) - if (.has(vector_items)) { - vector_items <- .local_cube_items_tiles_select( - tiles = tiles, - items = vector_items - ) - } } # build file_info for the items - if (results_cube) { - raster_items <- .local_results_cube_file_info( - items = raster_items, - multicores = multicores, - progress = progress - ) - } else { - raster_items <- .local_cube_file_info( - items = raster_items, - multicores = multicores, - progress = progress - ) - } - + raster_items <- .local_results_cube_file_info( + items = raster_items, + multicores = multicores, + progress = progress + ) # get all tiles tiles <- unique(raster_items[["tile"]]) @@ -121,66 +157,89 @@ # filter tile items_tile <- dplyr::filter(raster_items, .data[["tile"]] == !!tile) # create result cube - if (results_cube) { - tile_cube <- .local_results_items_cube( - source = source, - collection = collection, - raster_items = items_tile, - labels = labels - ) - return(tile_cube) - } - # create EO cube - tile_cube <- .local_cube_items_cube( + tile_cube <- .local_results_items_cube( source = source, collection = collection, - items = items_tile + raster_items = items_tile, + labels = labels ) - # return! - tile_cube + return(tile_cube) }) # handle class cubes from external sources cube <- .local_cube_handle_class_cube(source, collection, cube) - - if (.has(vector_items)) { - cube <- .local_cube_include_vector_info(cube, vector_items) - } - - if (results_cube) { - result_class <- .conf("sits_results_s3_class")[[bands]] - class(cube) <- c( - result_class, "derived_cube", - "raster_cube", class(cube) - ) - } else { - class(cube) <- .cube_s3class(cube) - if (.has(vector_items)) { - if (vector_band == "segments") { - class(cube) <- c("segs_cube", "vector_cube", class(cube)) - } else if (vector_band == "probs") { - class(cube) <- c("probs_vector_cube", - "derived_vector_cube", - "segs_cube", - "vector_cube", - class(cube)) - } else if (vector_band == "class") { - class(cube) <- c("class_vector_cube", - "derived_vector_cube", - "segs_cube", - "vector_cube", - class(cube)) - - } - } - } + result_class <- .conf("sits_results_s3_class")[[bands]] + class(cube) <- c( + result_class, "derived_cube", + "raster_cube", class(cube) + ) # check if labels match in the case of class cube - if (inherits(cube, "class_cube")) { + if (inherits(cube, "class_cube")) .check_labels_class_cube(cube) - } return(cube) } +#' @title Create vector items using local files +#' @name .local_vector_items +#' @keywords internal +#' @noRd +#' @param source Data source (one of \code{"AWS"}, \code{"BDC"}, +#' \code{"DEAFRICA"}, \code{"MPC"}, \code{"USGS"}). +#' @param collection Image collection in data source (To find out +#' the supported collections, use \code{\link{sits_list_collections}()}). +#' @param vector_dir Local director where vector files are stored +#' (for local vector cubes - character vector of length 1) +#' @param vector_band Band for vector data cube +#' @param parse_info Parsing information for local vector files. +#' @param version Version id for local files. +#' @param delim Delimiter for parsing local files. +#' @param labels Labels associated to the classes (only for result cubes) +#' @param start_date,end_date Initial and final dates to include +#' images from the collection in the cube (optional). +#' @param multicores Number of workers for parallel processing +#' @param progress Show a progress bar?z +#' @param ... Other parameters to be passed for specific types. +#' @return A \code{tibble} describing the contents of a local data cube. +.local_vector_items <- function(source, + collection, + vector_dir, + vector_band, + parse_info, + version, + delim, + start_date, + end_date, + multicores, + progress, ...) { + # set caller to show in errors + .check_set_caller(".local_vector_items") + # initialize vector items + vector_items <- NULL + + # bands in upper case for raw cubes, lower case for results cubes + vector_band <- .band_set_case(vector_band) + # set the correct parse_info + if (!.has(parse_info)) + parse_info <- .conf("results_parse_info_def") + + vector_items <- .local_cube_items_vector_new( + vector_dir = vector_dir, + parse_info = parse_info, + version = version, + delim = delim, + start_date = start_date, + end_date = end_date, + vector_band = vector_band + ) + # filter tiles + if (.has(tiles)) { + vector_items <- .local_cube_items_tiles_select( + tiles = tiles, + items = vector_items + ) + } + return(vector_items) +} #' @title Return raster items for local data cube #' @keywords internal diff --git a/R/sits_classify.R b/R/sits_classify.R index 3372db9a0..fcd1e858e 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -6,24 +6,205 @@ #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' #' @description -#' This function classifies a set of time series or data cube given +#' This function classifies a set of time series or data cube using #' a trained model prediction model created by \code{\link[sits]{sits_train}}. -#' SITS supports the following models: +#' +#' The \code{sits_classify} function takes three types of data as input +#' and produce there types of output. Users should call +#' \code{\link[sits]{sits_classify}} but be aware that the parameters +#' are different for each type of input. +#'\itemize{ +#' \item{\code{\link[sits]{sits_classify.sits}} is called when the input is +#' a set of time series. The output is the same set +#' with the additional column \code{predicted}.} +#' \item{\code{\link[sits]{sits_classify.raster_cube}} is called when the +#' input is a regular raster data cube. The output is a probability cube, +#' which has the same tiles as the raster cube. Each tile contains +#' a multiband image; each band contains the probability that +#' each pixel belongs to a given class. +#' Probability cubes are objects of class "probs_cube".} +#' \item{\code{\link[sits]{sits_classify.vector_cube}} is called when the input +#' is a vector data cube. Vector data cubes are produced when +#' closed regions are obtained from raster data cubes using +#' \code{\link[sits]{sits_segment}}. Classification of a vector +#' data cube produces a vector data structure with additional +#' columns expressing the class probabilities for each object. +#' Probability cubes for vector data cubes +#' are objects of class "probs_vector_cube".} +#' } +#' +#' @param data Data cube (tibble of class "raster_cube") +#' @param ml_model R model trained by \code{\link[sits]{sits_train}} +#' @param ... Other parameters for specific functions. +#' @return Time series with predicted labels for +#' each point (tibble of class "sits") +#' or a data cube with probabilities for each class +#' (tibble of class "probs_cube"). +#' +#' @note +#' The main \code{sits} classification workflow has the following steps: #' \enumerate{ -#' \item{support vector machines: \code{\link[sits]{sits_svm}};} -#' \item{random forests: \code{\link[sits]{sits_rfor}};} -#' \item{extreme gradient boosting: \code{\link[sits]{sits_xgboost}};} -#' \item{multi-layer perceptrons: \code{\link[sits]{sits_mlp}};} -#' \item{temporal CNN: \code{\link[sits]{sits_tempcnn}};} -#' \item{temporal self-attention encoders: \code{\link[sits]{sits_lighttae}} and +#' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from +#' a cloud provider.} +#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' from a cloud provider to a local directory for faster processing.} +#' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube +#' from an ARD image collection.} +#' \item{\code{\link[sits]{sits_apply}}: create new indices by combining +#' bands of a regular data cube (optional).} +#' \item{\code{\link[sits]{sits_get_data}}: extract time series +#' from a regular data cube based on user-provided labelled samples.} +#' \item{\code{\link[sits]{sits_train}}: train a machine learning +#' model based on image time series.} +#' \item{\code{\link[sits]{sits_classify}}: classify a data cube +#' using a machine learning model and obtain a probability cube.} +#' \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube +#' using a spatial smoother to remove outliers and +#' increase spatial consistency.} +#' \item{\code{\link[sits]{sits_label_classification}}: produce a +#' classified map by selecting the label with the highest probability +#' from a smoothed cube.} +#' } +#' +#' SITS supports the following models: +#' \itemize{ +#' \item{support vector machines: \code{\link[sits]{sits_svm}};} +#' \item{random forests: \code{\link[sits]{sits_rfor}};} +#' \item{extreme gradient boosting: \code{\link[sits]{sits_xgboost}};} +#' \item{multi-layer perceptrons: \code{\link[sits]{sits_mlp}};} +#' \item{temporal CNN: \code{\link[sits]{sits_tempcnn}};} +#' \item{temporal self-attention encoders: \code{\link[sits]{sits_lighttae}} and #' \code{\link[sits]{sits_tae}}.} #' } +#' +#' Please refer to the sits documentation available in +#' for detailed examples. +#' +#' @export +sits_classify <- function(data, ml_model, ...) { + UseMethod("sits_classify", data) +} +#' @title Classify a set of time series +#' @name sits_classify.sits +#' @description +#' \code{\link[sits]{sits_classify.sits}} is called when the input is +#' a set of time series. The output is the same set +#' with the additional column \code{predicted}. #' -#' @param data Data cube (tibble of class "raster_cube") +#' @param data Set of time series ("sits tibble") #' @param ml_model R model trained by \code{\link[sits]{sits_train}} #' (closure of class "sits_model") #' @param ... Other parameters for specific functions. +#' @param filter_fn Smoothing filter to be applied - optional +#' (closure containing object of class "function"). +#' @param impute_fn Imputation function to remove NA. +#' @param multicores Number of cores to be used for classification +#' (integer, min = 1, max = 2048). +#' @param gpu_memory Memory available in GPU in GB (default = 4) +#' @param batch_size Batch size for GPU classification. +#' @param progress Logical: Show progress bar? +#' +#' @return Time series with predicted labels for +#' each point (tibble of class "sits"). +#' @note +#' Parameter \code{filter_fn} specifies a smoothing filter +#' to be applied to each time series for reducing noise. Currently, options +#' are Savitzky-Golay (see \code{\link[sits]{sits_sgolay}}) and Whittaker +#' (see \code{\link[sits]{sits_whittaker}}) filters. Note that this +#' parameter should also have been applied to the training set to obtain +#' the model. +#' +#' Parameter \code{impute_fn} defines a 1D function that will be used +#' to interpolate NA values in each time series. Currently sits supports +#' the \code{\link{impute_linear}} function, but users can define +#' imputation functions which are defined externally. +#' +#' Parameter \code{multicores} defines the number of cores +#' used for processing. We recommend using as much memory as possible. +#' +#' When using a GPU for deep learning, \code{gpu_memory} indicates the +#' memory of the graphics card which is available for processing. +#' The parameter \code{batch_size} defines the size of the matrix +#' (measured in number of rows) which is sent to the GPU for classification. +#' Users can test different values of \code{batch_size} to +#' find out which one best fits their GPU architecture. +#' +#' It is not possible to have an exact idea of the size of Deep Learning +#' models in GPU memory, as the complexity of the model and factors +#' such as CUDA Context increase the size of the model in memory. +#' Therefore, we recommend that you leave at least 1GB free on the +#' video card to store the Deep Learning model that will be used. +#' +#' For users of Apple M3 chips or similar with a Neural Engine, be +#' aware that these chips share memory between the GPU and the CPU. +#' Tests indicate that the \code{memsize} +#' should be set to half to the total memory and the \code{batch_size} +#' parameter should be a small number (we suggest the value of 64). +#' Be aware that increasing these parameters may lead to memory +#' conflicts. +#' @examples +#' if (sits_run_examples()) { +#' # Example of classification of a time series +#' # Retrieve the samples for Mato Grosso +#' # train a random forest model +#' rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) +#' +#' # classify the point +#' point_ndvi <- sits_select(point_mt_6bands, bands = c("NDVI")) +#' point_class <- sits_classify( +#' data = point_ndvi, ml_model = rf_model +#' ) +#' plot(point_class) +#'} +#' @export +sits_classify.sits <- function(data, + ml_model, + ..., + filter_fn = NULL, + impute_fn = impute_linear(), + multicores = 2L, + gpu_memory = 4, + batch_size = 2^gpu_memory, + progress = TRUE) { + # set caller for error messages + .check_set_caller("sits_classify_sits") + # Pre-conditions + .check_samples_ts(data) + .check_is_sits_model(ml_model) + .check_int_parameter(multicores, min = 1, max = 2048) + .check_progress(progress) + .check_function(impute_fn) + .check_filter_fn(filter_fn) + # save batch_size for later use + sits_env[["batch_size"]] <- batch_size + # Update multicores + multicores <- .ml_update_multicores(ml_model, multicores) + # Do classification + classified_ts <- .classify_ts( + samples = data, + ml_model = ml_model, + filter_fn = filter_fn, + impute_fn = impute_fn, + multicores = multicores, + gpu_memory = gpu_memory, + progress = progress + ) + return(classified_ts) +} + +#' @title Classify a regular raster cube +#' @name sits_classify.raster_cube +#' @description +#' Called when the input is a regular raster data cube. +#' The output is a probability cube, +#' which has the same tiles as the raster cube. Each tile contains +#' a multiband image; each band contains the probability that +#' each pixel belongs to a given class. +#' Probability cubes are objects of class "probs_cube". +#' @param data Data cube (tibble of class "raster_cube") +#' @param ml_model R model trained by \code{\link[sits]{sits_train}} +#' @param ... Other parameters for specific functions. #' @param roi Region of interest (either an sf object, shapefile, #' or a numeric vector in WGS 84 with named XY values #' ("xmin", "xmax", "ymin", "ymax") or @@ -45,8 +226,6 @@ #' (integer, min = 1, max = 2048). #' @param gpu_memory Memory available in GPU in GB (default = 4) #' @param batch_size Batch size for GPU classification. -#' @param n_sam_pol Number of time series per segment to be classified -#' (integer, min = 10, max = 50). #' @param output_dir Directory for output file. #' @param version Version of the output. #' @param verbose Logical: print information about processing time? @@ -58,49 +237,7 @@ #' (tibble of class "probs_cube"). #' #' @note -#' The main \code{sits} classification workflow has the following steps: -#' \enumerate{ -#' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from -#' a cloud provider.} -#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection -#' from a cloud provider to a local directory for faster processing.} -#' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube -#' from an ARD image collection.} -#' \item{\code{\link[sits]{sits_apply}}: create new indices by combining -#' bands of a regular data cube (optional).} -#' \item{\code{\link[sits]{sits_get_data}}: extract time series -#' from a regular data cube based on user-provided labelled samples.} -#' \item{\code{\link[sits]{sits_train}}: train a machine learning -#' model based on image time series.} -#' \item{\code{\link[sits]{sits_classify}}: classify a data cube -#' using a machine learning model and obtain a probability cube.} -#' \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube -#' using a spatial smoother to remove outliers and -#' increase spatial consistency.} -#' \item{\code{\link[sits]{sits_label_classification}}: produce a -#' classified map by selecting the label with the highest probability -#' from a smoothed cube.} -#' } -#' The \code{sits_classify} function takes three types of data as input -#' and produce there types of output: -#' \enumerate{ -#' \item{A set of time series. The output is the same set -#' with the additional column \code{predicted}.} -#' \item{A regularized raster data cube. The output is a probability cube, -#' which has the same tiles as the raster cube. Each tile contains -#' a multiband image; each band contains the probability that -#' each pixel belongs to a given class. -#' Probability cubes are objects of class "probs_cube".} -#' \item{A vector data cube. Vector data cubes are produced when -#' closed regions are obtained from raster data cubes using -#' \code{\link[sits]{sits_segment}}. Classification of a vector -#' data cube produces a vector data structure with additional -#' columns expressing the class probabilities for each object. -#' Probability cubes for vector data cubes -#' are objects of class "probs_vector_cube".} -#' } -#' -#' The \code{roi} parameter defines a region of interest. Either: +#' The \code{roi} parameter defines a region of interest. Either: #' \enumerate{ #' \item{A path to a shapefile with polygons;} #' \item{An \code{sf} object with POLYGON or MULTIPOLYGON geometry;} @@ -150,27 +287,11 @@ #' Be aware that increasing these parameters may lead to memory #' conflicts. #' -#' For classifying vector data cubes created by -#' \code{\link[sits]{sits_segment}}, -#' \code{n_sam_pol} controls is the number of time series to be -#' classified per segment. -#' -#' Please refer to the sits documentation available in -#' for detailed examples. #' @examples #' if (sits_run_examples()) { -#' # Example of classification of a time series #' # Retrieve the samples for Mato Grosso #' # train a random forest model #' rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) -#' -#' # classify the point -#' point_ndvi <- sits_select(point_mt_6bands, bands = c("NDVI")) -#' point_class <- sits_classify( -#' data = point_ndvi, ml_model = rf_model -#' ) -#' plot(point_class) -#' #' # Example of classification of a data cube #' # create a data cube from local files #' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") @@ -194,83 +315,7 @@ #' ) #' # plot the classified image #' plot(label_cube) -#' # segmentation -#' # segment the image -#' segments <- sits_segment( -#' cube = cube, -#' seg_fn = sits_slic(step = 5, -#' compactness = 1, -#' dist_fun = "euclidean", -#' avg_fun = "median", -#' iter = 50, -#' minarea = 10, -#' verbose = FALSE -#' ), -#' output_dir = tempdir() -#' ) -#' # Create a classified vector cube -#' probs_segs <- sits_classify( -#' data = segments, -#' ml_model = rf_model, -#' output_dir = tempdir(), -#' multicores = 4, -#' version = "segs" -#' ) -#' # Create a labelled vector cube -#' class_segs <- sits_label_classification( -#' cube = probs_segs, -#' output_dir = tempdir(), -#' multicores = 2, -#' memsize = 4, -#' version = "segs_classify" -#' ) -#' # plot class_segs -#' plot(class_segs) -#' } -#' -#' @export -sits_classify <- function(data, ml_model, ...) { - UseMethod("sits_classify", data) -} - -#' @rdname sits_classify -#' @export -sits_classify.sits <- function(data, - ml_model, - ..., - filter_fn = NULL, - impute_fn = impute_linear(), - multicores = 2L, - gpu_memory = 4, - batch_size = 2^gpu_memory, - progress = TRUE) { - # set caller for error messages - .check_set_caller("sits_classify_sits") - # Pre-conditions - .check_samples_ts(data) - .check_is_sits_model(ml_model) - .check_int_parameter(multicores, min = 1, max = 2048) - .check_progress(progress) - .check_function(impute_fn) - .check_filter_fn(filter_fn) - # save batch_size for later use - sits_env[["batch_size"]] <- batch_size - # Update multicores - multicores <- .ml_update_multicores(ml_model, multicores) - # Do classification - classified_ts <- .classify_ts( - samples = data, - ml_model = ml_model, - filter_fn = filter_fn, - impute_fn = impute_fn, - multicores = multicores, - gpu_memory = gpu_memory, - progress = progress - ) - return(classified_ts) -} - -#' @rdname sits_classify +#'} #' @export sits_classify.raster_cube <- function(data, ml_model, ..., @@ -408,9 +453,151 @@ sits_classify.raster_cube <- function(data, .classify_verbose_end(verbose, start_time) return(probs_cube) } -#' @rdname sits_classify +#' @title Classify a segmented data cube +#' @name sits_classify.segs_cube +#' @description +#' This function is called when the input is a vector data cube. +#' Vector data cubes are produced when closed regions are obtained +#' from raster data cubes using +#' \code{\link[sits]{sits_segment}}. Classification of a vector +#' data cube produces a vector data structure with additional +#' columns expressing the class probabilities for each segment. +#' Probability cubes for vector data cubes +#' are objects of class "probs_vector_cube". +#' +#' @param data Data cube (tibble of class "raster_cube") +#' @param ml_model R model trained by \code{\link[sits]{sits_train}} +#' (closure of class "sits_model") +#' @param ... Other parameters for specific functions. +#' @param roi Region of interest (either an sf object, shapefile, +#' or a numeric vector in WGS 84 with named XY values +#' ("xmin", "xmax", "ymin", "ymax") or +#' named lat/long values +#' ("lon_min", "lat_min", "lon_max", "lat_max"). +#' @param filter_fn Smoothing filter to be applied - optional +#' (closure containing object of class "function"). +#' @param impute_fn Imputation function to remove NA. +#' @param start_date Starting date for the classification +#' (Date in YYYY-MM-DD format). +#' @param end_date Ending date for the classification +#' (Date in YYYY-MM-DD format). +#' @param memsize Memory available for classification in GB +#' (integer, min = 1, max = 16384). +#' @param multicores Number of cores to be used for classification +#' (integer, min = 1, max = 2048). +#' @param gpu_memory Memory available in GPU in GB (default = 4) +#' @param batch_size Batch size for GPU classification. +#' @param n_sam_pol Number of time series per segment to be classified +#' (integer, min = 10, max = 50). +#' @param output_dir Directory for output file. +#' @param version Version of the output. +#' @param verbose Logical: print information about processing time? +#' @param progress Logical: Show progress bar? +#' +#' @return Vector data cube with probabilities for each class +#' included in new columns of the tibble. +#' (tibble of class "probs_vector_cube"). +#' +#' @note +#' The \code{roi} parameter defines a region of interest. Either: +#' \enumerate{ +#' \item{A path to a shapefile with polygons;} +#' \item{An \code{sf} object with POLYGON or MULTIPOLYGON geometry;} +#' \item{A named XY vector (\code{xmin}, \code{xmax}, \code{ymin}, +#' \code{ymax}) in WGS84;} +#' \item{A name lat/long vector (\code{lon_min}, \code{lon_max}, +#' \code{lat_min}, \code{lat_max}); } +#' } +#' +#' Parameter \code{filter_fn} parameter specifies a smoothing filter +#' to be applied to each time series for reducing noise. Currently, options +#' are Savitzky-Golay (see \code{\link[sits]{sits_sgolay}}) and Whittaker +#' (see \code{\link[sits]{sits_whittaker}}) filters. +#' +#' Parameter \code{impute_fn} defines a 1D function that will be used +#' to interpolate NA values in each time series. Currently sits supports +#' the \code{\link{impute_linear}} function, but users can define +#' imputation functions which are defined externally. +#' +#' Parameter \code{memsize} controls the amount of memory available +#' for classification, while \code{multicores} defines the number of cores +#' used for processing. We recommend using as much memory as possible. +#' +#' For classifying vector data cubes created by +#' \code{\link[sits]{sits_segment}}, +#' \code{n_sam_pol} controls is the number of time series to be +#' classified per segment. +#' +#' When using a GPU for deep learning, \code{gpu_memory} indicates the +#' memory of the graphics card which is available for processing. +#' The parameter \code{batch_size} defines the size of the matrix +#' (measured in number of rows) which is sent to the GPU for classification. +#' Users can test different values of \code{batch_size} to +#' find out which one best fits their GPU architecture. +#' +#' It is not possible to have an exact idea of the size of Deep Learning +#' models in GPU memory, as the complexity of the model and factors +#' such as CUDA Context increase the size of the model in memory. +#' Therefore, we recommend that you leave at least 1GB free on the +#' video card to store the Deep Learning model that will be used. +#' +#' For users of Apple M3 chips or similar with a Neural Engine, be +#' aware that these chips share memory between the GPU and the CPU. +#' Tests indicate that the \code{memsize} +#' should be set to half to the total memory and the \code{batch_size} +#' parameter should be a small number (we suggest the value of 64). +#' Be aware that increasing these parameters may lead to memory +#' conflicts. +#' +#' Please refer to the sits documentation available in +#' for detailed examples. +#' @examples +#' if (sits_run_examples()) { +#' # train a random forest model +#' rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) +#' # Example of classification of a data cube +#' # create a data cube from local files +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' # segment the image +#' segments <- sits_segment( +#' cube = cube, +#' seg_fn = sits_slic(step = 5, +#' compactness = 1, +#' dist_fun = "euclidean", +#' avg_fun = "median", +#' iter = 50, +#' minarea = 10, +#' verbose = FALSE +#' ), +#' output_dir = tempdir() +#' ) +#' # Create a classified vector cube +#' probs_segs <- sits_classify( +#' data = segments, +#' ml_model = rf_model, +#' output_dir = tempdir(), +#' multicores = 4, +#' n_sam_pol = 15, +#' version = "segs" +#' ) +#' # Create a labelled vector cube +#' class_segs <- sits_label_classification( +#' cube = probs_segs, +#' output_dir = tempdir(), +#' multicores = 2, +#' memsize = 4, +#' version = "segs_classify" +#' ) +#' # plot class_segs +#' plot(class_segs) +#' } #' @export -sits_classify.segs_cube <- function(data, +sits_classify.vector_cube <- function(data, ml_model, ..., roi = NULL, filter_fn = NULL, diff --git a/R/sits_cube.R b/R/sits_cube.R index 31a77eeda..884a5dd30 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -7,7 +7,7 @@ #' #' @description Creates a data cube based on spatial and temporal restrictions #' in collections available in cloud services or local repositories. -#' Two options are avaliable: +#' Available options are: #' \itemize{ #' \item{To create data cubes from cloud providers which support the STAC protocol, #' use \code{\link[sits]{sits_cube.stac_cube}}.} @@ -136,16 +136,27 @@ sits_cube <- function(source, collection, ...) { dots <- list(...) # if "data_dir" parameters is provided, assumes local cube if ("data_dir" %in% names(dots)) { - if ("bands" %in% names(dots) && bands %in% .conf("sits_results_bands")){ - source <- .source_new(source = source, - is_local = TRUE, is_result = TRUE) - } - if ("vector_dir" %in% names(dots) && "vector_band" %in% names(dots) - && vector_band %in% .conf("sits_results_bands")) { - source <- .source_new(source = source, is_vector = TRUE, - is_local = TRUE) - } source <- .source_new(source = source, is_local = TRUE) + if ("bands" %in% names(dots)) { + bands <- dots["bands"] + if (bands %in% .conf("sits_results_bands")) { + source <- .source_new(source = source, + is_local = TRUE, is_result = TRUE) + return(source) + + } + } else if ("vector_dir" %in% names(dots)) { + if ("vector_band" %in% names(dots)) { + vector_band <- dots["vector_band"] + if (vector_band %in% .conf("sits_results_bands")) { + source <- .source_new(source = source, is_vector = TRUE, + is_local = TRUE) + } + } + } + } else if ("raster_cube" %in% names(dots)) { + source <- .source_new(source = source, is_local = TRUE, + is_vector = TRUE) } else { source <- .source_new(source = source, collection = collection) } @@ -276,7 +287,7 @@ sits_cube <- function(source, collection, ...) { #' start_date = "2020-06-01", #' end_date = "2020-09-28" #' ) -#' #' # --- Access to the Brazil Data Cube +#' # --- Access to the Brazil Data Cube #' # create a raster cube file based on the information in the BDC #' cbers_tile <- sits_cube( #' source = "BDC", @@ -345,7 +356,7 @@ sits_cube <- function(source, collection, ...) { #' ) #' #' -#' -- Access to World Cover data (2021) via Terrascope +#' # -- Access to World Cover data (2021) via Terrascope #' cube_terrascope <- sits_cube( #' source = "TERRASCOPE", #' collection = "WORLD-COVER-2021", diff --git a/R/sits_cube_local.R b/R/sits_cube_local.R index 43991fb51..fbfa6a9f4 100644 --- a/R/sits_cube_local.R +++ b/R/sits_cube_local.R @@ -117,7 +117,7 @@ sits_cube.local_cube <- function( .source_collection_check(source = source, collection = collection) # builds a sits data cube - cube <- .local_cube( + cube <- .local_raster_cube( source = source, collection = collection, data_dir = data_dir, @@ -127,27 +127,9 @@ sits_cube.local_cube <- function( bands = bands, start_date = start_date, end_date = end_date, - vector_dir = NULL, - vector_band = NULL, - labels = NULL, multicores = multicores, progress = progress, ... ) - .local_cube <- function(source, - collection, - data_dir, - vector_dir, - parse_info, - version, - delim, - tiles, - bands, - vector_band, - labels, - start_date, - end_date, - multicores, - progress, ...) # fix tile system name cube <- .cube_revert_tile_name(cube) return(cube) @@ -169,6 +151,7 @@ sits_cube.local_cube <- function( #' @param ... Other parameters to be passed for specific types. #' @param data_dir Local directory where images are stored #' (for local cubes only). +#' @param raster_cube Raster cube to be merged with vector data #' @param vector_dir Local directory where vector files are stored #' @param vector_band Band for vector cube ("segments", "probs", "class") #' @param parse_info Parsing information for local image files @@ -182,9 +165,9 @@ sits_cube.local_cube <- function( #' #' @note #' This function creates vector cubes from local files produced by -#' \code{\link[sits]{sits_segment}}, -#' \code{\link[sits]{sits_classify.vector_cube}} -#' or \code{\link[sits]{sits_label_classification.vector_cube}}. In this case, +#' \code{\link[sits]{sits_segment}}, \code{\link[sits]{sits_classify}} +#' or \code{\link[sits]{sits_label_classification}} when the output +#' is a vector cube. In this case, #' \code{parse_info} is specified differently as \code{c("X1", "X2", "tile", #' "start_date", "end_date", "band")}. #' The parameter \code{vector_dir} is the directory where the vector file is @@ -217,7 +200,7 @@ sits_cube.local_cube <- function( #' ) #' # segment the vector cube #' segments <- sits_segment( -#' cube = cube, +#' cube = modis_cube, #' seg_fn = sits_slic( #' step = 10, #' compactness = 1, @@ -232,7 +215,7 @@ sits_cube.local_cube <- function( #' segment_cube <- sits_cube( #' source = "BDC", #' collection = "MOD13Q1-6.1", -#' data_dir = system.file("extdata/raster/mod13q1", package = "sits"), +#' raster_cube = modis_cube, #' vector_dir = tempdir(), #' vector_band = "segments" #' ) @@ -242,35 +225,47 @@ sits_cube.local_cube <- function( sits_cube.vector_cube <- function( source, collection, ..., - data_dir, + raster_cube, vector_dir, vector_band, - parse_info = c("X1", "X2", "tile", "date", "band", "version"), + parse_info = c("X1", "X2", "tile", "start_date", + "end_date", "band", "version"), version = "v1", delim = "_", multicores = 2L, progress = TRUE) { - # builds a sits data cube - cube <- .local_cube( + # obtain vector items + vector_items <- .local_vector_items( source = source, collection = collection, - data_dir = data_dir, vector_dir = vector_dir, vector_band = vector_band, parse_info = parse_info, version = version, delim = delim, - tiles = NULL, - bands = NULL, - vector_band = NULL, - labels = NULL, - start_date = NULL, - end_date = NULL, - multicores = multicores, - progress = progress, ... - ) + multicores, + progress, ...) + cube <- .local_cube_include_vector_info(raster_cube, vector_items) + class(cube) <- .cube_s3class(cube) + if (vector_band == "segments") { + class(cube) <- c("segs_cube", "vector_cube", class(cube)) + } else if (vector_band == "probs" || vector_band == "probs-vector") { + class(cube) <- c("probs_vector_cube", + "derived_vector_cube", + "segs_cube", + "vector_cube", + class(cube)) + } else if (vector_band == "class" || vector_band == "class-vector") { + class(cube) <- c("class_vector_cube", + "derived_vector_cube", + "segs_cube", + "vector_cube", + class(cube)) + + } + return(cube) } #' @title Create a results cube from local files #' @name sits_cube.results_cube @@ -288,6 +283,8 @@ sits_cube.vector_cube <- function( #' use \code{\link{sits_list_collections}()}). #' @param ... Other parameters to be passed for specific types. #' @param data_dir Local directory where images are stored +#' @param tiles Tiles from the collection to be included in +#' the cube (see details below). #' @param bands Results bands to be retrieved #' ("probs", "bayes", "variance", "class", "uncertainty") #' @param labels Labels associated to the classes @@ -340,7 +337,8 @@ sits_cube.results_cube <- function( source, collection, ..., data_dir, - bands = NULL, + tiles = NULL, + bands, labels, parse_info = c("X1", "X2", "tile", "start_date", "end_date", "band", "version"), @@ -355,23 +353,23 @@ sits_cube.results_cube <- function( discriminator = "one_of", msg = .conf("messages", "sits_cube_results_cube")) + # check if labels exist + .check_chr_parameter(labels, + is_named = TRUE, + msg = .conf("messages", "sits_cube_results_cube_label")) + # builds a sits data cube - cube <- .local_cube( + cube <- .local_results_cube( source = source, collection = collection, data_dir = data_dir, - vector_dir = NULL, + tiles = tiles, + bands = bands, + labels = labels, parse_info = parse_info, version = version, delim = delim, - tiles = NULL, - bands = bands, - vector_band = NULL, - labels = labels, - start_date = NULL, - end_date = NULL, multicores = multicores, progress = progress, ... ) - } diff --git a/R/sits_get_data.R b/R/sits_get_data.R index 981a3f427..77eef25d5 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -461,10 +461,6 @@ sits_get_data.sf <- function(cube, #' the name of a shapefile or csv file, or #' a data.frame with columns "longitude" and "latitude". #' @param ... Specific parameters for specific cases. -#' @param start_date Start of the interval for the time series - optional -#' (Date in "YYYY-MM-DD" format). -#' @param end_date End of the interval for the time series - optional -#' (Date in "YYYY-MM-DD" format). #' @param bands Bands to be retrieved - optional. #' @param crs Default crs for the samples. #' @param impute_fn Imputation function to remove NA. diff --git a/R/sits_plot.R b/R/sits_plot.R index fac3faef5..5f22d8295 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -395,7 +395,7 @@ plot.raster_cube <- function(x, ..., # precondition for tiles .check_cube_tiles(x, tile) # precondition for bands - .check_bw_rgb_bands(band, red, green, blue) + band <- .check_bw_rgb_bands(x, band, red, green, blue) check_band <- .check_available_bands(x, band, red, green, blue) # check roi .check_roi(roi) diff --git a/inst/extdata/config_internals.yml b/inst/extdata/config_internals.yml index b7f2f3048..b8fde3cca 100644 --- a/inst/extdata/config_internals.yml +++ b/inst/extdata/config_internals.yml @@ -47,11 +47,15 @@ results_parse_info_def : ["X1", "X2", "tile", "start_date", "end_date", "band", "version"] results_parse_info_col : ["tile", "start_date", "end_date", "band"] + # bands resulting from classification and post-classification sits_results_bands : ["probs", "bayes", "uncert", "entropy", "class", "least", "margin", "variance", "segments"] +sits_results_vector_bands : ["probs-vector", "entropy", + "class-vector", "least", "margin", "variance"] + # bands resulting from classification and smoothing sits_probs_bands : ["probs", "bayes"] # bands resulting from uncertainty diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index b369aa1bf..c7f78a3dd 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -390,6 +390,7 @@ sits_cube_copy_different_resolutions: "Cube has multiple resolutions. Please, pr sits_cube_local_cube: "wrong input parameters - see example in documentation" sits_cube_local_cube_vector_band: "one vector_band must be provided (either segments, class, or probs)" sits_cube_results_cube: "one results band must be provided (either class or probs)" +sits_cube_results_cube_label: "for results cubes, a named label vector must be provided" sits_detect_change_method: "wrong input parameters - see example in documentation" sits_detect_change_method_model: "dc_method is not a valid function" sits_detect_change_method_timeline: "samples have different timeline lengths" diff --git a/man/sits_classify.Rd b/man/sits_classify.Rd index e73d911ad..f2f45e8cd 100644 --- a/man/sits_classify.Rd +++ b/man/sits_classify.Rd @@ -2,9 +2,6 @@ % Please edit documentation in R/sits_classify.R \name{sits_classify} \alias{sits_classify} -\alias{sits_classify.sits} -\alias{sits_classify.raster_cube} -\alias{sits_classify.segs_cube} \alias{sits_classify.tbl_df} \alias{sits_classify.derived_cube} \alias{sits_classify.default} @@ -12,58 +9,6 @@ \usage{ sits_classify(data, ml_model, ...) -\method{sits_classify}{sits}( - data, - ml_model, - ..., - filter_fn = NULL, - impute_fn = impute_linear(), - multicores = 2L, - gpu_memory = 4, - batch_size = 2^gpu_memory, - progress = TRUE -) - -\method{sits_classify}{raster_cube}( - data, - ml_model, - ..., - roi = NULL, - exclusion_mask = NULL, - filter_fn = NULL, - impute_fn = impute_linear(), - start_date = NULL, - end_date = NULL, - memsize = 8L, - multicores = 2L, - gpu_memory = 4, - batch_size = 2^gpu_memory, - output_dir, - version = "v1", - verbose = FALSE, - progress = TRUE -) - -\method{sits_classify}{segs_cube}( - data, - ml_model, - ..., - roi = NULL, - filter_fn = NULL, - impute_fn = impute_linear(), - start_date = NULL, - end_date = NULL, - memsize = 8L, - multicores = 2L, - gpu_memory = 4, - batch_size = 2^gpu_memory, - output_dir, - version = "v1", - n_sam_pol = 15, - verbose = FALSE, - progress = TRUE -) - \method{sits_classify}{tbl_df}(data, ml_model, ...) \method{sits_classify}{derived_cube}(data, ml_model, ...) @@ -73,52 +18,9 @@ sits_classify(data, ml_model, ...) \arguments{ \item{data}{Data cube (tibble of class "raster_cube")} -\item{ml_model}{R model trained by \code{\link[sits]{sits_train}} -(closure of class "sits_model")} +\item{ml_model}{R model trained by \code{\link[sits]{sits_train}}} \item{...}{Other parameters for specific functions.} - -\item{filter_fn}{Smoothing filter to be applied - optional -(closure containing object of class "function").} - -\item{impute_fn}{Imputation function to remove NA.} - -\item{multicores}{Number of cores to be used for classification -(integer, min = 1, max = 2048).} - -\item{gpu_memory}{Memory available in GPU in GB (default = 4)} - -\item{batch_size}{Batch size for GPU classification.} - -\item{progress}{Logical: Show progress bar?} - -\item{roi}{Region of interest (either an sf object, shapefile, -or a numeric vector in WGS 84 with named XY values -("xmin", "xmax", "ymin", "ymax") or -named lat/long values -("lon_min", "lat_min", "lon_max", "lat_max").} - -\item{exclusion_mask}{Areas to be excluded from the classification -process. It can be defined by a sf object or by a -shapefile.} - -\item{start_date}{Starting date for the classification -(Date in YYYY-MM-DD format).} - -\item{end_date}{Ending date for the classification -(Date in YYYY-MM-DD format).} - -\item{memsize}{Memory available for classification in GB -(integer, min = 1, max = 16384).} - -\item{output_dir}{Directory for output file.} - -\item{version}{Version of the output.} - -\item{verbose}{Logical: print information about processing time?} - -\item{n_sam_pol}{Number of time series per segment to be classified -(integer, min = 10, max = 50).} } \value{ Time series with predicted labels for @@ -127,18 +29,32 @@ Time series with predicted labels for (tibble of class "probs_cube"). } \description{ -This function classifies a set of time series or data cube given +This function classifies a set of time series or data cube using a trained model prediction model created by \code{\link[sits]{sits_train}}. -SITS supports the following models: -\enumerate{ -\item{support vector machines: \code{\link[sits]{sits_svm}};} -\item{random forests: \code{\link[sits]{sits_rfor}};} -\item{extreme gradient boosting: \code{\link[sits]{sits_xgboost}};} -\item{multi-layer perceptrons: \code{\link[sits]{sits_mlp}};} -\item{temporal CNN: \code{\link[sits]{sits_tempcnn}};} -\item{temporal self-attention encoders: \code{\link[sits]{sits_lighttae}} and - \code{\link[sits]{sits_tae}}.} -} + +The \code{sits_classify} function takes three types of data as input + and produce there types of output. Users should call + \code{\link[sits]{sits_classify}} but be aware that the parameters + are different for each type of input. +\itemize{ + \item{\code{\link[sits]{sits_classify.sits}} is called when the input is + a set of time series. The output is the same set + with the additional column \code{predicted}.} + \item{\code{\link[sits]{sits_classify.raster_cube}} is called when the + input is a regular raster data cube. The output is a probability cube, + which has the same tiles as the raster cube. Each tile contains + a multiband image; each band contains the probability that + each pixel belongs to a given class. + Probability cubes are objects of class "probs_cube".} + \item{\code{\link[sits]{sits_classify.vector_cube}} is called when the input + is a vector data cube. Vector data cubes are produced when + closed regions are obtained from raster data cubes using + \code{\link[sits]{sits_segment}}. Classification of a vector + data cube produces a vector data structure with additional + columns expressing the class probabilities for each object. + Probability cubes for vector data cubes + are objects of class "probs_vector_cube".} + } } \note{ The main \code{sits} classification workflow has the following steps: @@ -164,154 +80,20 @@ The main \code{sits} classification workflow has the following steps: classified map by selecting the label with the highest probability from a smoothed cube.} } - The \code{sits_classify} function takes three types of data as input - and produce there types of output: - \enumerate{ - \item{A set of time series. The output is the same set - with the additional column \code{predicted}.} - \item{A regularized raster data cube. The output is a probability cube, - which has the same tiles as the raster cube. Each tile contains - a multiband image; each band contains the probability that - each pixel belongs to a given class. - Probability cubes are objects of class "probs_cube".} - \item{A vector data cube. Vector data cubes are produced when - closed regions are obtained from raster data cubes using - \code{\link[sits]{sits_segment}}. Classification of a vector - data cube produces a vector data structure with additional - columns expressing the class probabilities for each object. - Probability cubes for vector data cubes - are objects of class "probs_vector_cube".} - } - - The \code{roi} parameter defines a region of interest. Either: - \enumerate{ - \item{A path to a shapefile with polygons;} - \item{An \code{sf} object with POLYGON or MULTIPOLYGON geometry;} - \item{A named XY vector (\code{xmin}, \code{xmax}, \code{ymin}, - \code{ymax}) in WGS84;} - \item{A name lat/long vector (\code{lon_min}, \code{lon_max}, - \code{lat_min}, \code{lat_max}); } - } - - Parameter \code{filter_fn} parameter specifies a smoothing filter - to be applied to each time series for reducing noise. Currently, options - are Savitzky-Golay (see \code{\link[sits]{sits_sgolay}}) and Whittaker - (see \code{\link[sits]{sits_whittaker}}) filters. - - Parameter \code{impute_fn} defines a 1D function that will be used - to interpolate NA values in each time series. Currently sits supports - the \code{\link{impute_linear}} function, but users can define - imputation functions which are defined externally. - - Parameter \code{memsize} controls the amount of memory available - for classification, while \code{multicores} defines the number of cores - used for processing. We recommend using as much memory as possible. - - Parameter \code{exclusion_mask} defines a region that will not be - classify. The region can be defined by multiple polygons. - Either a path to a shapefile with polygons or - a \code{sf} object with POLYGON or MULTIPOLYGON geometry; - - When using a GPU for deep learning, \code{gpu_memory} indicates the - memory of the graphics card which is available for processing. - The parameter \code{batch_size} defines the size of the matrix - (measured in number of rows) which is sent to the GPU for classification. - Users can test different values of \code{batch_size} to - find out which one best fits their GPU architecture. - - It is not possible to have an exact idea of the size of Deep Learning - models in GPU memory, as the complexity of the model and factors - such as CUDA Context increase the size of the model in memory. - Therefore, we recommend that you leave at least 1GB free on the - video card to store the Deep Learning model that will be used. - - For users of Apple M3 chips or similar with a Neural Engine, be - aware that these chips share memory between the GPU and the CPU. - Tests indicate that the \code{memsize} - should be set to half to the total memory and the \code{batch_size} - parameter should be a small number (we suggest the value of 64). - Be aware that increasing these parameters may lead to memory - conflicts. - For classifying vector data cubes created by - \code{\link[sits]{sits_segment}}, - \code{n_sam_pol} controls is the number of time series to be - classified per segment. +SITS supports the following models: +\itemize{ + \item{support vector machines: \code{\link[sits]{sits_svm}};} + \item{random forests: \code{\link[sits]{sits_rfor}};} + \item{extreme gradient boosting: \code{\link[sits]{sits_xgboost}};} + \item{multi-layer perceptrons: \code{\link[sits]{sits_mlp}};} + \item{temporal CNN: \code{\link[sits]{sits_tempcnn}};} + \item{temporal self-attention encoders: \code{\link[sits]{sits_lighttae}} and + \code{\link[sits]{sits_tae}}.} +} Please refer to the sits documentation available in for detailed examples. -} -\examples{ -if (sits_run_examples()) { - # Example of classification of a time series - # Retrieve the samples for Mato Grosso - # train a random forest model - rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) - - # classify the point - point_ndvi <- sits_select(point_mt_6bands, bands = c("NDVI")) - point_class <- sits_classify( - data = point_ndvi, ml_model = rf_model - ) - plot(point_class) - - # Example of classification of a data cube - # create a data cube from local files - data_dir <- system.file("extdata/raster/mod13q1", package = "sits") - cube <- sits_cube( - source = "BDC", - collection = "MOD13Q1-6.1", - data_dir = data_dir - ) - # classify a data cube - probs_cube <- sits_classify( - data = cube, - ml_model = rf_model, - output_dir = tempdir(), - version = "ex_classify" - ) - # label the probability cube - label_cube <- sits_label_classification( - probs_cube, - output_dir = tempdir(), - version = "ex_classify" - ) - # plot the classified image - plot(label_cube) - # segmentation - # segment the image - segments <- sits_segment( - cube = cube, - seg_fn = sits_slic(step = 5, - compactness = 1, - dist_fun = "euclidean", - avg_fun = "median", - iter = 50, - minarea = 10, - verbose = FALSE - ), - output_dir = tempdir() - ) - # Create a classified vector cube - probs_segs <- sits_classify( - data = segments, - ml_model = rf_model, - output_dir = tempdir(), - multicores = 4, - version = "segs" - ) - # Create a labelled vector cube - class_segs <- sits_label_classification( - cube = probs_segs, - output_dir = tempdir(), - multicores = 2, - memsize = 4, - version = "segs_classify" - ) - # plot class_segs - plot(class_segs) -} - } \author{ Rolf Simoes, \email{rolfsimoes@gmail.com} diff --git a/man/sits_classify.raster_cube.Rd b/man/sits_classify.raster_cube.Rd new file mode 100644 index 000000000..3783b321f --- /dev/null +++ b/man/sits_classify.raster_cube.Rd @@ -0,0 +1,167 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_classify.R +\name{sits_classify.raster_cube} +\alias{sits_classify.raster_cube} +\title{Classify a regular raster cube} +\usage{ +\method{sits_classify}{raster_cube}( + data, + ml_model, + ..., + roi = NULL, + exclusion_mask = NULL, + filter_fn = NULL, + impute_fn = impute_linear(), + start_date = NULL, + end_date = NULL, + memsize = 8L, + multicores = 2L, + gpu_memory = 4, + batch_size = 2^gpu_memory, + output_dir, + version = "v1", + verbose = FALSE, + progress = TRUE +) +} +\arguments{ +\item{data}{Data cube (tibble of class "raster_cube")} + +\item{ml_model}{R model trained by \code{\link[sits]{sits_train}}} + +\item{...}{Other parameters for specific functions.} + +\item{roi}{Region of interest (either an sf object, shapefile, +or a numeric vector in WGS 84 with named XY values +("xmin", "xmax", "ymin", "ymax") or +named lat/long values +("lon_min", "lat_min", "lon_max", "lat_max").} + +\item{exclusion_mask}{Areas to be excluded from the classification +process. It can be defined by a sf object or by a +shapefile.} + +\item{filter_fn}{Smoothing filter to be applied - optional +(closure containing object of class "function").} + +\item{impute_fn}{Imputation function to remove NA.} + +\item{start_date}{Starting date for the classification +(Date in YYYY-MM-DD format).} + +\item{end_date}{Ending date for the classification +(Date in YYYY-MM-DD format).} + +\item{memsize}{Memory available for classification in GB +(integer, min = 1, max = 16384).} + +\item{multicores}{Number of cores to be used for classification +(integer, min = 1, max = 2048).} + +\item{gpu_memory}{Memory available in GPU in GB (default = 4)} + +\item{batch_size}{Batch size for GPU classification.} + +\item{output_dir}{Directory for output file.} + +\item{version}{Version of the output.} + +\item{verbose}{Logical: print information about processing time?} + +\item{progress}{Logical: Show progress bar?} +} +\value{ +Time series with predicted labels for + each point (tibble of class "sits") + or a data cube with probabilities for each class + (tibble of class "probs_cube"). +} +\description{ +Called when the input is a regular raster data cube. + The output is a probability cube, + which has the same tiles as the raster cube. Each tile contains + a multiband image; each band contains the probability that + each pixel belongs to a given class. + Probability cubes are objects of class "probs_cube". +} +\note{ +The \code{roi} parameter defines a region of interest. Either: + \enumerate{ + \item{A path to a shapefile with polygons;} + \item{An \code{sf} object with POLYGON or MULTIPOLYGON geometry;} + \item{A named XY vector (\code{xmin}, \code{xmax}, \code{ymin}, + \code{ymax}) in WGS84;} + \item{A name lat/long vector (\code{lon_min}, \code{lon_max}, + \code{lat_min}, \code{lat_max}); } + } + + Parameter \code{filter_fn} parameter specifies a smoothing filter + to be applied to each time series for reducing noise. Currently, options + are Savitzky-Golay (see \code{\link[sits]{sits_sgolay}}) and Whittaker + (see \code{\link[sits]{sits_whittaker}}) filters. + + Parameter \code{impute_fn} defines a 1D function that will be used + to interpolate NA values in each time series. Currently sits supports + the \code{\link{impute_linear}} function, but users can define + imputation functions which are defined externally. + + Parameter \code{memsize} controls the amount of memory available + for classification, while \code{multicores} defines the number of cores + used for processing. We recommend using as much memory as possible. + + Parameter \code{exclusion_mask} defines a region that will not be + classify. The region can be defined by multiple polygons. + Either a path to a shapefile with polygons or + a \code{sf} object with POLYGON or MULTIPOLYGON geometry; + + When using a GPU for deep learning, \code{gpu_memory} indicates the + memory of the graphics card which is available for processing. + The parameter \code{batch_size} defines the size of the matrix + (measured in number of rows) which is sent to the GPU for classification. + Users can test different values of \code{batch_size} to + find out which one best fits their GPU architecture. + + It is not possible to have an exact idea of the size of Deep Learning + models in GPU memory, as the complexity of the model and factors + such as CUDA Context increase the size of the model in memory. + Therefore, we recommend that you leave at least 1GB free on the + video card to store the Deep Learning model that will be used. + + For users of Apple M3 chips or similar with a Neural Engine, be + aware that these chips share memory between the GPU and the CPU. + Tests indicate that the \code{memsize} + should be set to half to the total memory and the \code{batch_size} + parameter should be a small number (we suggest the value of 64). + Be aware that increasing these parameters may lead to memory + conflicts. +} +\examples{ +if (sits_run_examples()) { + # Retrieve the samples for Mato Grosso + # train a random forest model + rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) + # Example of classification of a data cube + # create a data cube from local files + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + # classify a data cube + probs_cube <- sits_classify( + data = cube, + ml_model = rf_model, + output_dir = tempdir(), + version = "ex_classify" + ) + # label the probability cube + label_cube <- sits_label_classification( + probs_cube, + output_dir = tempdir(), + version = "ex_classify" + ) + # plot the classified image + plot(label_cube) +} +} diff --git a/man/sits_classify.segs_cube.Rd b/man/sits_classify.segs_cube.Rd new file mode 100644 index 000000000..e5907f152 --- /dev/null +++ b/man/sits_classify.segs_cube.Rd @@ -0,0 +1,188 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_classify.R +\name{sits_classify.segs_cube} +\alias{sits_classify.segs_cube} +\alias{sits_classify.vector_cube} +\title{Classify a segmented data cube} +\usage{ +\method{sits_classify}{vector_cube}( + data, + ml_model, + ..., + roi = NULL, + filter_fn = NULL, + impute_fn = impute_linear(), + start_date = NULL, + end_date = NULL, + memsize = 8L, + multicores = 2L, + gpu_memory = 4, + batch_size = 2^gpu_memory, + output_dir, + version = "v1", + n_sam_pol = 15, + verbose = FALSE, + progress = TRUE +) +} +\arguments{ +\item{data}{Data cube (tibble of class "raster_cube")} + +\item{ml_model}{R model trained by \code{\link[sits]{sits_train}} +(closure of class "sits_model")} + +\item{...}{Other parameters for specific functions.} + +\item{roi}{Region of interest (either an sf object, shapefile, +or a numeric vector in WGS 84 with named XY values +("xmin", "xmax", "ymin", "ymax") or +named lat/long values +("lon_min", "lat_min", "lon_max", "lat_max").} + +\item{filter_fn}{Smoothing filter to be applied - optional +(closure containing object of class "function").} + +\item{impute_fn}{Imputation function to remove NA.} + +\item{start_date}{Starting date for the classification +(Date in YYYY-MM-DD format).} + +\item{end_date}{Ending date for the classification +(Date in YYYY-MM-DD format).} + +\item{memsize}{Memory available for classification in GB +(integer, min = 1, max = 16384).} + +\item{multicores}{Number of cores to be used for classification +(integer, min = 1, max = 2048).} + +\item{gpu_memory}{Memory available in GPU in GB (default = 4)} + +\item{batch_size}{Batch size for GPU classification.} + +\item{output_dir}{Directory for output file.} + +\item{version}{Version of the output.} + +\item{n_sam_pol}{Number of time series per segment to be classified +(integer, min = 10, max = 50).} + +\item{verbose}{Logical: print information about processing time?} + +\item{progress}{Logical: Show progress bar?} +} +\value{ +Vector data cube with probabilities for each class + included in new columns of the tibble. + (tibble of class "probs_vector_cube"). +} +\description{ +This function is called when the input is a vector data cube. +Vector data cubes are produced when closed regions are obtained +from raster data cubes using +\code{\link[sits]{sits_segment}}. Classification of a vector +data cube produces a vector data structure with additional +columns expressing the class probabilities for each segment. +Probability cubes for vector data cubes +are objects of class "probs_vector_cube". +} +\note{ +The \code{roi} parameter defines a region of interest. Either: + \enumerate{ + \item{A path to a shapefile with polygons;} + \item{An \code{sf} object with POLYGON or MULTIPOLYGON geometry;} + \item{A named XY vector (\code{xmin}, \code{xmax}, \code{ymin}, + \code{ymax}) in WGS84;} + \item{A name lat/long vector (\code{lon_min}, \code{lon_max}, + \code{lat_min}, \code{lat_max}); } + } + + Parameter \code{filter_fn} parameter specifies a smoothing filter + to be applied to each time series for reducing noise. Currently, options + are Savitzky-Golay (see \code{\link[sits]{sits_sgolay}}) and Whittaker + (see \code{\link[sits]{sits_whittaker}}) filters. + + Parameter \code{impute_fn} defines a 1D function that will be used + to interpolate NA values in each time series. Currently sits supports + the \code{\link{impute_linear}} function, but users can define + imputation functions which are defined externally. + + Parameter \code{memsize} controls the amount of memory available + for classification, while \code{multicores} defines the number of cores + used for processing. We recommend using as much memory as possible. + + For classifying vector data cubes created by + \code{\link[sits]{sits_segment}}, + \code{n_sam_pol} controls is the number of time series to be + classified per segment. + + When using a GPU for deep learning, \code{gpu_memory} indicates the + memory of the graphics card which is available for processing. + The parameter \code{batch_size} defines the size of the matrix + (measured in number of rows) which is sent to the GPU for classification. + Users can test different values of \code{batch_size} to + find out which one best fits their GPU architecture. + + It is not possible to have an exact idea of the size of Deep Learning + models in GPU memory, as the complexity of the model and factors + such as CUDA Context increase the size of the model in memory. + Therefore, we recommend that you leave at least 1GB free on the + video card to store the Deep Learning model that will be used. + + For users of Apple M3 chips or similar with a Neural Engine, be + aware that these chips share memory between the GPU and the CPU. + Tests indicate that the \code{memsize} + should be set to half to the total memory and the \code{batch_size} + parameter should be a small number (we suggest the value of 64). + Be aware that increasing these parameters may lead to memory + conflicts. + + Please refer to the sits documentation available in + for detailed examples. +} +\examples{ +if (sits_run_examples()) { + # train a random forest model + rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) + # Example of classification of a data cube + # create a data cube from local files + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + # segment the image + segments <- sits_segment( + cube = cube, + seg_fn = sits_slic(step = 5, + compactness = 1, + dist_fun = "euclidean", + avg_fun = "median", + iter = 50, + minarea = 10, + verbose = FALSE + ), + output_dir = tempdir() + ) + # Create a classified vector cube + probs_segs <- sits_classify( + data = segments, + ml_model = rf_model, + output_dir = tempdir(), + multicores = 4, + n_sam_pol = 15, + version = "segs" + ) + # Create a labelled vector cube + class_segs <- sits_label_classification( + cube = probs_segs, + output_dir = tempdir(), + multicores = 2, + memsize = 4, + version = "segs_classify" + ) + # plot class_segs + plot(class_segs) +} +} diff --git a/man/sits_classify.sits.Rd b/man/sits_classify.sits.Rd new file mode 100644 index 000000000..cb9948523 --- /dev/null +++ b/man/sits_classify.sits.Rd @@ -0,0 +1,101 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_classify.R +\name{sits_classify.sits} +\alias{sits_classify.sits} +\title{Classify a set of time series} +\usage{ +\method{sits_classify}{sits}( + data, + ml_model, + ..., + filter_fn = NULL, + impute_fn = impute_linear(), + multicores = 2L, + gpu_memory = 4, + batch_size = 2^gpu_memory, + progress = TRUE +) +} +\arguments{ +\item{data}{Set of time series ("sits tibble")} + +\item{ml_model}{R model trained by \code{\link[sits]{sits_train}} +(closure of class "sits_model")} + +\item{...}{Other parameters for specific functions.} + +\item{filter_fn}{Smoothing filter to be applied - optional +(closure containing object of class "function").} + +\item{impute_fn}{Imputation function to remove NA.} + +\item{multicores}{Number of cores to be used for classification +(integer, min = 1, max = 2048).} + +\item{gpu_memory}{Memory available in GPU in GB (default = 4)} + +\item{batch_size}{Batch size for GPU classification.} + +\item{progress}{Logical: Show progress bar?} +} +\value{ +Time series with predicted labels for + each point (tibble of class "sits"). +} +\description{ +\code{\link[sits]{sits_classify.sits}} is called when the input is + a set of time series. The output is the same set + with the additional column \code{predicted}. +} +\note{ +Parameter \code{filter_fn} specifies a smoothing filter + to be applied to each time series for reducing noise. Currently, options + are Savitzky-Golay (see \code{\link[sits]{sits_sgolay}}) and Whittaker + (see \code{\link[sits]{sits_whittaker}}) filters. Note that this + parameter should also have been applied to the training set to obtain + the model. + + Parameter \code{impute_fn} defines a 1D function that will be used + to interpolate NA values in each time series. Currently sits supports + the \code{\link{impute_linear}} function, but users can define + imputation functions which are defined externally. + + Parameter \code{multicores} defines the number of cores + used for processing. We recommend using as much memory as possible. + + When using a GPU for deep learning, \code{gpu_memory} indicates the + memory of the graphics card which is available for processing. + The parameter \code{batch_size} defines the size of the matrix + (measured in number of rows) which is sent to the GPU for classification. + Users can test different values of \code{batch_size} to + find out which one best fits their GPU architecture. + + It is not possible to have an exact idea of the size of Deep Learning + models in GPU memory, as the complexity of the model and factors + such as CUDA Context increase the size of the model in memory. + Therefore, we recommend that you leave at least 1GB free on the + video card to store the Deep Learning model that will be used. + + For users of Apple M3 chips or similar with a Neural Engine, be + aware that these chips share memory between the GPU and the CPU. + Tests indicate that the \code{memsize} + should be set to half to the total memory and the \code{batch_size} + parameter should be a small number (we suggest the value of 64). + Be aware that increasing these parameters may lead to memory + conflicts. +} +\examples{ +if (sits_run_examples()) { + # Example of classification of a time series + # Retrieve the samples for Mato Grosso + # train a random forest model + rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) + + # classify the point + point_ndvi <- sits_select(point_mt_6bands, bands = c("NDVI")) + point_class <- sits_classify( + data = point_ndvi, ml_model = rf_model + ) + plot(point_class) +} +} diff --git a/man/sits_cube.Rd b/man/sits_cube.Rd index 4f36e4f9b..50eeaf111 100644 --- a/man/sits_cube.Rd +++ b/man/sits_cube.Rd @@ -24,7 +24,7 @@ A \code{tibble} describing the contents of a data cube. \description{ Creates a data cube based on spatial and temporal restrictions in collections available in cloud services or local repositories. -Two options are avaliable: +Available options are: \itemize{ \item{To create data cubes from cloud providers which support the STAC protocol, use \code{\link[sits]{sits_cube.stac_cube}}.} diff --git a/man/sits_cube.results_cube.Rd b/man/sits_cube.results_cube.Rd index 710e20e5b..f5cea5d50 100644 --- a/man/sits_cube.results_cube.Rd +++ b/man/sits_cube.results_cube.Rd @@ -9,7 +9,8 @@ collection, ..., data_dir, - bands = NULL, + tiles = NULL, + bands, labels, parse_info = c("X1", "X2", "tile", "start_date", "end_date", "band", "version"), version = "v1", @@ -33,6 +34,9 @@ use \code{\link{sits_list_collections}()}).} \item{data_dir}{Local directory where images are stored} +\item{tiles}{Tiles from the collection to be included in +the cube (see details below).} + \item{bands}{Results bands to be retrieved ("probs", "bayes", "variance", "class", "uncertainty")} diff --git a/man/sits_cube.stac_cube.Rd b/man/sits_cube.stac_cube.Rd index fd01f738b..c36756e4c 100644 --- a/man/sits_cube.stac_cube.Rd +++ b/man/sits_cube.stac_cube.Rd @@ -154,7 +154,7 @@ if (sits_run_examples()) { start_date = "2020-06-01", end_date = "2020-09-28" ) - #' # --- Access to the Brazil Data Cube + # --- Access to the Brazil Data Cube # create a raster cube file based on the information in the BDC cbers_tile <- sits_cube( source = "BDC", @@ -223,7 +223,7 @@ if (sits_run_examples()) { ) - -- Access to World Cover data (2021) via Terrascope + # -- Access to World Cover data (2021) via Terrascope cube_terrascope <- sits_cube( source = "TERRASCOPE", collection = "WORLD-COVER-2021", diff --git a/man/sits_cube.vector_cube.Rd b/man/sits_cube.vector_cube.Rd index 868775cd2..239e71ceb 100644 --- a/man/sits_cube.vector_cube.Rd +++ b/man/sits_cube.vector_cube.Rd @@ -8,10 +8,10 @@ source, collection, ..., - data_dir, + raster_cube, vector_dir, vector_band, - parse_info = c("X1", "X2", "tile", "date", "band", "version"), + parse_info = c("X1", "X2", "tile", "start_date", "end_date", "band", "version"), version = "v1", delim = "_", multicores = 2L, @@ -31,8 +31,7 @@ use \code{\link{sits_list_collections}()}).} \item{...}{Other parameters to be passed for specific types.} -\item{data_dir}{Local directory where images are stored -(for local cubes only).} +\item{raster_cube}{Raster cube to be merged with vector data} \item{vector_dir}{Local directory where vector files are stored} @@ -49,6 +48,9 @@ use \code{\link{sits_list_collections}()}).} (integer, min = 1, max = 2048).} \item{progress}{Logical: show a progress bar?} + +\item{data_dir}{Local directory where images are stored +(for local cubes only).} } \value{ A \code{tibble} describing the contents of a data cube. @@ -59,9 +61,9 @@ produced by a segmentation algorithm. } \note{ This function creates vector cubes from local files produced by -\code{\link[sits]{sits_segment}}, -\code{\link[sits]{sits_classify.vector_cube}} -or \code{\link[sits]{sits_label_classification.vector_cube}}. In this case, +\code{\link[sits]{sits_segment}}, \code{\link[sits]{sits_classify}} +or \code{\link[sits]{sits_label_classification}} when the output +is a vector cube. In this case, \code{parse_info} is specified differently as \code{c("X1", "X2", "tile", "start_date", "end_date", "band")}. The parameter \code{vector_dir} is the directory where the vector file is @@ -94,7 +96,7 @@ if (sits_run_examples()) { ) # segment the vector cube segments <- sits_segment( - cube = cube, + cube = modis_cube, seg_fn = sits_slic( step = 10, compactness = 1, @@ -109,7 +111,7 @@ if (sits_run_examples()) { segment_cube <- sits_cube( source = "BDC", collection = "MOD13Q1-6.1", - data_dir = system.file("extdata/raster/mod13q1", package = "sits"), + raster_cube = modis_cube, vector_dir = tempdir(), vector_band = "segments" ) diff --git a/man/sits_get_data.sits.Rd b/man/sits_get_data.sits.Rd index 9ff385a7e..62eea7af1 100644 --- a/man/sits_get_data.sits.Rd +++ b/man/sits_get_data.sits.Rd @@ -36,12 +36,6 @@ a data.frame with columns "longitude" and "latitude".} (integer, with min = 1 and max = 2048).} \item{progress}{Logical: show progress bar?} - -\item{start_date}{Start of the interval for the time series - optional -(Date in "YYYY-MM-DD" format).} - -\item{end_date}{End of the interval for the time series - optional -(Date in "YYYY-MM-DD" format).} } \description{ Retrieve a set of time series from a data cube and From 43351d52e4c3cb4c36db10b06443678f967d209a Mon Sep 17 00:00:00 2001 From: Gilberto Camara Date: Thu, 3 Apr 2025 18:18:12 -0300 Subject: [PATCH 068/122] fix check --- R/api_source_local.R | 7 ------- R/sits_cube_local.R | 2 -- man/sits_cube.vector_cube.Rd | 3 --- 3 files changed, 12 deletions(-) diff --git a/R/api_source_local.R b/R/api_source_local.R index abf7c6404..10bca927c 100644 --- a/R/api_source_local.R +++ b/R/api_source_local.R @@ -231,13 +231,6 @@ end_date = end_date, vector_band = vector_band ) - # filter tiles - if (.has(tiles)) { - vector_items <- .local_cube_items_tiles_select( - tiles = tiles, - items = vector_items - ) - } return(vector_items) } diff --git a/R/sits_cube_local.R b/R/sits_cube_local.R index fbfa6a9f4..054bc7557 100644 --- a/R/sits_cube_local.R +++ b/R/sits_cube_local.R @@ -149,8 +149,6 @@ sits_cube.local_cube <- function( #' To find out the supported collections, #' use \code{\link{sits_list_collections}()}). #' @param ... Other parameters to be passed for specific types. -#' @param data_dir Local directory where images are stored -#' (for local cubes only). #' @param raster_cube Raster cube to be merged with vector data #' @param vector_dir Local directory where vector files are stored #' @param vector_band Band for vector cube ("segments", "probs", "class") diff --git a/man/sits_cube.vector_cube.Rd b/man/sits_cube.vector_cube.Rd index 239e71ceb..377e2ca0c 100644 --- a/man/sits_cube.vector_cube.Rd +++ b/man/sits_cube.vector_cube.Rd @@ -48,9 +48,6 @@ use \code{\link{sits_list_collections}()}).} (integer, min = 1, max = 2048).} \item{progress}{Logical: show a progress bar?} - -\item{data_dir}{Local directory where images are stored -(for local cubes only).} } \value{ A \code{tibble} describing the contents of a data cube. From 0dc715684240dcc5a96b487c6b80e54acdeebe66 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Sat, 5 Apr 2025 23:00:31 -0300 Subject: [PATCH 069/122] closes #1309 #1313 #1306 #1308 #1310 #1311 --- DESCRIPTION | 16 +- R/api_band.R | 27 +- R/api_check.R | 41 +- R/api_chunks.R | 24 +- R/api_conf.R | 2 + R/api_detect_change.R | 4 +- R/api_file_info.R | 51 ++- R/api_gdal.R | 4 +- R/api_plot_raster.R | 40 +- R/api_raster.R | 459 +++++++++++++-------- R/api_raster_sub_image.R | 8 +- R/api_samples.R | 6 +- R/api_source.R | 2 +- R/api_tile.R | 54 +-- R/api_tmap.R | 21 + R/api_view.R | 101 ++--- R/sits_config.R | 2 +- R/sits_cube.R | 3 +- R/sits_cube_local.R | 182 +++++++- R/sits_plot.R | 32 +- R/sits_view.R | 23 +- inst/extdata/config_colors.yml | 123 ++++++ inst/extdata/config_messages.yml | 1 + inst/extdata/sources/config_source_mpc.yml | 2 +- man/sits-package.Rd | 14 +- man/sits_cube.results_cube.Rd | 123 +++++- man/sits_cube.vector_cube.Rd | 47 ++- tests/testthat/test-apply.R | 40 +- tests/testthat/test-classification.R | 10 +- tests/testthat/test-combine_predictions.R | 6 +- tests/testthat/test-cube-aws.R | 4 +- tests/testthat/test-cube-bdc.R | 36 +- tests/testthat/test-cube-cdse.R | 8 +- tests/testthat/test-cube-deafrica.R | 56 +-- tests/testthat/test-cube-deaustralia.R | 36 +- tests/testthat/test-cube-hls.R | 8 +- tests/testthat/test-cube-mpc.R | 16 +- tests/testthat/test-cube-terrascope.R | 4 +- tests/testthat/test-cube-usgs.R | 8 +- tests/testthat/test-cube.R | 7 +- tests/testthat/test-mixture_model.R | 8 +- tests/testthat/test-plot.R | 6 +- tests/testthat/test-raster.R | 104 ++--- tests/testthat/test-reclassify.R | 12 +- tests/testthat/test-regularize.R | 2 +- tests/testthat/test-segmentation.R | 2 +- tests/testthat/test-smooth.R | 16 +- tests/testthat/test-variance.R | 12 +- 48 files changed, 1194 insertions(+), 619 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index b6749a71e..e17bd1344 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -6,13 +6,19 @@ Authors@R: c(person('Rolf', 'Simoes', role = c('aut'), email = 'rolfsimoes@gmail person('Gilberto', 'Camara', role = c('aut', 'cre', 'ths'), email = 'gilberto.camara.inpe@gmail.com'), person('Felipe', 'Souza', role = c('aut'), email = 'felipe.carvalho@inpe.br'), person('Felipe', 'Carlos', role = c('aut'), email = "efelipecarlos@gmail.com"), - person('Lorena', 'Santos', role = c('ctb'), email = 'lorena.santos@inpe.br'), - person('Karine', 'Ferreira', role = c('ctb', 'ths'), email = 'karine.ferreira@inpe.br'), + person('Lorena', 'Santos', role = c('aut'), email = 'lorena.santos@inpe.br'), person('Charlotte', 'Pelletier', role = c('ctb'), email = 'charlotte.pelletier@univ-ubs.fr'), - person('Pedro', 'Andrade', role = c('ctb'), email = 'pedro.andrade@inpe.br'), - person('Alber', 'Sanchez', role = c('ctb'), email = 'alber.ipia@inpe.br'), person('Estefania', 'Pizarro', role = c('ctb'), email = 'eapizarroa@ine.gob.cl'), - person('Gilberto', 'Queiroz', role = c('ctb'), email = 'gilberto.queiroz@inpe.br') + person('Karine', 'Ferreira', role = c('ctb', 'ths'), email = 'karine.ferreira@inpe.br'), + person('Alber', 'Sanchez', role = c('ctb'), email = 'alber.ipia@inpe.br'), + person('Alexandre', 'Assuncao', role = c('ctb'), email = 'alexcarssuncao@gmail.com'), + person('Daniel', 'Falbel', role = c('ctb'), email = 'dfalbel@gmail.com'), + person('Gilberto', 'Queiroz', role = c('ctb'), email = 'gilberto.queiroz@inpe.br'), + person('Johannes', 'Reiche', role = c('ctb'), email = 'johannes.reiche@wur.nl'), + person('Pedro', 'Andrade', role = c('ctb'), email = 'pedro.andrade@inpe.br'), + person('Pedro', 'Brito', role = c('ctb'), email = 'pedro_brito1997@hotmail.com'), + person('Renato', 'Assuncao', role = c('ctb'), email = 'assuncaoest@gmail.com'), + person('Ricardo', 'Cartaxo', role = c('ctb'), email = 'rcartaxoms@gmail.com') ) Maintainer: Gilberto Camara Description: An end-to-end toolkit for land use and land cover classification diff --git a/R/api_band.R b/R/api_band.R index 83cc80685..8eefe9d98 100644 --- a/R/api_band.R +++ b/R/api_band.R @@ -122,9 +122,34 @@ } return(bands) } -.band_best_guess <- function(cube){ +#' @title Make a best guess on bands to be displayed +#' @name .band_set_case +#' @description if user did not provide band names, +#' try some reasonable color composites. +#' A full list of color composites is available +#' in "./inst/extdata/config_colors.yaml" +#' @noRd +#' @param cube data cube +#' @return band names to be displayed +.bands_best_guess <- function(cube){ + # get all bands in the cube cube_bands <- .cube_bands(cube) + # get source and collection for the cube + source <- .cube_source(cube) + collection <- .cube_collection(cube) + # find which are possible color composites for the cube + comp_source <- sits_env[['composites']][["sources"]][[source]] + composites <- comp_source[["collections"]][[collection]] + # for each color composite (in order) + # see if bands are available + for (i in seq_along(composites)) { + bands <- composites[[i]] + if (all(bands %in% .cube_bands(cube))) + return(bands) + } + # if composites fail, try NDVI if ("NDVI" %in% cube_bands) return("NDVI") + # return the first band if all fails else return(cube_bands[[1]]) } diff --git a/R/api_check.R b/R/api_check.R index 3281ee93a..ba77e791a 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -1638,13 +1638,13 @@ .check_raster_cube_files <- function(x, ...) { .check_set_caller(".check_raster_cube_files") # check for data access - robj <- tryCatch( + rast <- tryCatch( .raster_open_rast(.tile_path(x)), error = function(e) { return(NULL) }) # return error if data is not accessible - .check_that(!(is.null(robj))) + .check_that(!(is.null(rast))) return(invisible(x)) } #' @title Does input data has time series? @@ -1872,6 +1872,16 @@ .check_that(!("NoClass" %in% data)) return(invisible(data)) } +#' @name .check_labels_named +#' @param data vector with labels +#' @return Called for side effects. +#' @keywords internal +#' @noRd +.check_labels_named <- function(data) { + .check_set_caller(".check_labels_named") + .check_chr(data, len_min = 1, is_named = TRUE) + return(invisible(data)) +} #' @title Does the class cube contain enough labels? #' @name .check_labels_class_cube #' @param cube class cube @@ -2383,38 +2393,23 @@ #' @param red Red band for view #' @param green Green band for view #' @param blue Blue band for view -#' @return Called for side effects +#' @return vector with bands #' @keywords internal #' @noRd .check_bw_rgb_bands <- function(cube, band, red, green, blue) { .check_set_caller(".check_bw_rgb_bands") - if (!.has(band) || !(.has(red) && .has(green) && .has(blue))) - band <- .band_best_guess(cube) - return(band) -} -#' @title Check available bands -#' @name .check_available_bands -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @param cube Data cube -#' @param band B/W band for view -#' @param red Red band for view -#' @param green Green band for view -#' @param blue Blue band for view -#' @return band for B/W and "RGB" for color images -#' @keywords internal -#' @noRd -.check_available_bands <- function(cube, band, red, green, blue) { - .check_set_caller(".check_available_bands") + # check band is available if (.has(band)) { - # check band is available .check_that(band %in% .cube_bands(cube)) return(band) } else if (.has(red) && .has(green) && .has(blue)) { - bands <- c(red, green, blue) # check bands are available + bands <- c(red, green, blue) .check_that(all(bands %in% .cube_bands(cube))) - return("RGB") + return(bands) } + bands <- .bands_best_guess(cube) + return(bands) } #' @title Check if the provided object is a vector diff --git a/R/api_chunks.R b/R/api_chunks.R index 632866a67..1c5daa3d7 100644 --- a/R/api_chunks.R +++ b/R/api_chunks.R @@ -66,13 +66,13 @@ NULL # Generate chunks' bbox chunks <- slider::slide_dfr(chunks, function(chunk) { # Crop block from template - r_obj <- .raster_crop_metadata(r_obj = t_obj, block = .block(chunk)) + rast <- .raster_crop_metadata(rast = t_obj, block = .block(chunk)) # Add bbox information - .xmin(chunk) <- .raster_xmin(r_obj = r_obj) - .xmax(chunk) <- .raster_xmax(r_obj = r_obj) - .ymin(chunk) <- .raster_ymin(r_obj = r_obj) - .ymax(chunk) <- .raster_ymax(r_obj = r_obj) - .crs(chunk) <- .raster_crs(r_obj = r_obj) + .xmin(chunk) <- .raster_xmin(rast = rast) + .xmax(chunk) <- .raster_xmax(rast = rast) + .ymin(chunk) <- .raster_ymin(rast = rast) + .ymax(chunk) <- .raster_ymax(rast = rast) + .crs(chunk) <- .raster_crs(rast = rast) chunk }) # Overlapping support @@ -126,13 +126,13 @@ NULL # Prepare a raster as template to crop bbox t_obj <- .chunks_as_raster(chunk = chunk, nlayers = 1) # Crop block from template - r_obj <- .raster_crop_metadata(r_obj = t_obj, block = .block(crop)) + rast <- .raster_crop_metadata(rast = t_obj, block = .block(crop)) # Add bbox information - .xmin(crop) <- .raster_xmin(r_obj = r_obj) - .xmax(crop) <- .raster_xmax(r_obj = r_obj) - .ymin(crop) <- .raster_ymin(r_obj = r_obj) - .ymax(crop) <- .raster_ymax(r_obj = r_obj) - .crs(crop) <- .raster_crs(r_obj = r_obj) + .xmin(crop) <- .raster_xmin(rast = rast) + .xmax(crop) <- .raster_xmax(rast = rast) + .ymin(crop) <- .raster_ymin(rast = rast) + .ymax(crop) <- .raster_ymax(rast = rast) + .crs(crop) <- .raster_crs(rast = rast) crop }) # Finish cropped chunks diff --git a/R/api_conf.R b/R/api_conf.R index 59fb40f3d..15cb9882d 100644 --- a/R/api_conf.R +++ b/R/api_conf.R @@ -266,6 +266,8 @@ input = color_yml_file, merge.precedence = "override" ) + # set the composites + sits_env[["composites"]] <- config_colors$composites # set the legends sits_env[["legends"]] <- config_colors$legends # build the color table diff --git a/R/api_detect_change.R b/R/api_detect_change.R index 5a8ae1950..dd01c33cc 100644 --- a/R/api_detect_change.R +++ b/R/api_detect_change.R @@ -258,9 +258,9 @@ tile_bands <- .tile_bands(tile, FALSE) quantile_values <- purrr::map(tile_bands, function(tile_band) { tile_paths <- .tile_paths(tile, bands = tile_band) - r_obj <- .raster_open_rast(tile_paths) + rast <- .raster_open_rast(tile_paths) quantile_values <- .raster_quantile( - r_obj, quantile = deseasonlize, na.rm = TRUE + rast, quantile = deseasonlize, na.rm = TRUE ) quantile_values <- impute_fn(t(quantile_values)) # Fill with zeros remaining NA pixels diff --git a/R/api_file_info.R b/R/api_file_info.R index 06e4c97a5..e47874257 100644 --- a/R/api_file_info.R +++ b/R/api_file_info.R @@ -93,20 +93,20 @@ NULL # precondition .check_that(length(files) == length(bands)) files <- .file_path_expand(files) - r_obj <- .raster_open_rast(files) + rast <- .raster_open_rast(files) .fi_eo( fid = fid[[1]], band = bands, date = date[[1]], - ncols = .raster_ncols(r_obj), - nrows = .raster_nrows(r_obj), - xres = .raster_xres(r_obj), - yres = .raster_yres(r_obj), - xmin = .raster_xmin(r_obj), - xmax = .raster_xmax(r_obj), - ymin = .raster_ymin(r_obj), - ymax = .raster_ymax(r_obj), - crs = .raster_crs(r_obj), + ncols = .raster_ncols(rast), + nrows = .raster_nrows(rast), + xres = .raster_xres(rast), + yres = .raster_yres(rast), + xmin = .raster_xmin(rast), + xmax = .raster_xmax(rast), + ymin = .raster_ymin(rast), + ymax = .raster_ymax(rast), + crs = .raster_crs(rast), path = files ) } @@ -151,19 +151,19 @@ NULL #' @param end_date end date of the image .fi_derived_from_file <- function(file, band, start_date, end_date) { file <- .file_path_expand(file) - r_obj <- .raster_open_rast(file) + rast <- .raster_open_rast(file) .fi_derived( band = band, start_date = start_date, end_date = end_date, - ncols = .raster_ncols(r_obj), - nrows = .raster_nrows(r_obj), - xres = .raster_xres(r_obj), - yres = .raster_yres(r_obj), - xmin = .raster_xmin(r_obj), - xmax = .raster_xmax(r_obj), - ymin = .raster_ymin(r_obj), - ymax = .raster_ymax(r_obj), + ncols = .raster_ncols(rast), + nrows = .raster_nrows(rast), + xres = .raster_xres(rast), + yres = .raster_yres(rast), + xmin = .raster_xmin(rast), + xmax = .raster_xmax(rast), + ymin = .raster_ymin(rast), + ymax = .raster_ymax(rast), path = file ) } @@ -182,6 +182,19 @@ NULL .fi_cloud_cover <- function(fi) { .as_dbl(fi[["cloud_cover"]]) } +#' @title Get file_info date with least cloud cover +#' @noRd +#' @param fi file_info +#' @returns date with smallest values of cloud cover +.fi_date_least_cloud_cover <- function(fi) { + if ("cloud_cover" %in% colnames(fi)) { + image <- fi |> + dplyr::arrange(.data[["cloud_cover"]]) |> + dplyr::slice(1) + return(as.Date(image[["date"]])) + } else + return(as.Date(.fi_timeline(fi))) +} #' @title Filter file_info for a file_info ID #' @noRd #' @param fi file_info diff --git a/R/api_gdal.R b/R/api_gdal.R index 104177281..752a09b8b 100644 --- a/R/api_gdal.R +++ b/R/api_gdal.R @@ -229,13 +229,13 @@ #' @param roi ROI to crop base_files #' @returns Name of file that was written to .gdal_merge_into <- function(file, base_files, multicores, roi = NULL) { - r_obj <- .raster_open_rast(file) + rast <- .raster_open_rast(file) # Merge src_files file <- .try( { if (.has(roi)) { # reproject ROI - roi <- .roi_as_sf(roi, as_crs = .raster_crs(r_obj)) + roi <- .roi_as_sf(roi, as_crs = .raster_crs(rast)) # Write roi in a temporary file roi_file <- .roi_write( roi = roi, diff --git a/R/api_plot_raster.R b/R/api_plot_raster.R index de8009e61..6abe3aaac 100644 --- a/R/api_plot_raster.R +++ b/R/api_plot_raster.R @@ -81,14 +81,18 @@ minq <- quantiles[[2]] maxq <- quantiles[[3]] maxv <- quantiles[[4]] - + # stretch the image vals <- ifelse(vals > minq, vals, minq) vals <- ifelse(vals < maxq, vals, maxq) rast <- .raster_set_values(rast, vals) + # set title + title <- stringr::str_flatten(c(band, as.character(date)), collapse = " ") + p <- .tmap_false_color( rast = rast, band = band, + title = title, sf_seg = sf_seg, seg_color = seg_color, line_width = line_width, @@ -110,7 +114,7 @@ #' @param tile Tile to be plotted. #' @param band Band to be plotted. #' @param dates Dates to be plotted. -#' @param roi Spatial extent to plot in WGS 84 - named vector +#' @param roi Spatial extent to plot in WGS 84 - named vector #' with either (lon_min, lon_max, lat_min, lat_max) or #' (xmin, xmax, ymin, ymax) #' @param scale Scale to plot map (0.4 to 1.0) @@ -153,11 +157,13 @@ green_file <- .gdal_warp_file(green_file, sizes) blue_file <- .gdal_warp_file(blue_file, sizes) } + title <- stringr::str_flatten(c(band, as.character(dates)), collapse = " ") # plot multitemporal band as RGB p <- .tmap_rgb_color( red_file = red_file, green_file = green_file, blue_file = blue_file, + title = title, scale = scale, max_value = max_value, first_quantile = first_quantile, @@ -175,9 +181,7 @@ #' @keywords internal #' @noRd #' @param tile Tile to be plotted -#' @param red Band to be plotted in red -#' @param green Band to be plotted in green -#' @param blue Band to be plotted in blue +#' @param bands Bands to be plotted (R, G, B) #' @param date Date to be plotted #' @param sf_seg Segments (sf object) #' @param seg_color Color to use for segment borders @@ -190,9 +194,7 @@ #' @return A plot object #' .plot_rgb <- function(tile, - red, - green, - blue, + bands, date, roi, sf_seg, @@ -207,7 +209,7 @@ # crop using ROI if (.has(roi)) { tile <- tile |> - .tile_filter_bands(bands = c(red, green, blue)) |> + .tile_filter_bands(bands = bands) |> .tile_filter_dates(dates = date) |> .crop(roi = roi, output_dir = .rand_sub_tempdir(), @@ -215,11 +217,11 @@ } # get RGB files for the requested timeline - red_file <- .tile_path(tile, red, date) - green_file <- .tile_path(tile, green, date) - blue_file <- .tile_path(tile, blue, date) + red_file <- .tile_path(tile, bands[[1]], date) + green_file <- .tile_path(tile, bands[[2]], date) + blue_file <- .tile_path(tile, bands[[3]], date) # get the max values - band_params <- .tile_band_conf(tile, red) + band_params <- .tile_band_conf(tile, bands[[1]]) max_value <- .max_value(band_params) # size of data to be read sizes <- .tile_overview_size(tile = tile, max_cog_size) @@ -228,11 +230,15 @@ green_file <- .gdal_warp_file(green_file, sizes) blue_file <- .gdal_warp_file(blue_file, sizes) + # title + title <- stringr::str_flatten(c(bands, as.character(date)), collapse = " ") + # plot RGB using tmap p <- .tmap_rgb_color( red_file = red_file, green_file = green_file, blue_file = blue_file, + title = title, scale = scale, max_value = max_value, first_quantile = first_quantile, @@ -286,6 +292,8 @@ rast <- .raster_open_rast(class_file) # get the labels labels <- .cube_labels(tile) + # get the values + # If available, use labels to define which colors must be presented. # This is useful as some datasets (e.g., World Cover) represent @@ -293,7 +301,7 @@ # of the color array (e.g., 10, 20), causing a misrepresentation of # the classes labels_available <- as.character( - sort(unique(terra::values(rast), na.omit = TRUE)) + sort(unique(.raster_values_mem(rast), na.omit = TRUE)) ) # set levels for raster terra_levels <- data.frame( @@ -437,9 +445,9 @@ points <- sf::st_sample(sf_cube, size = n_samples) points <- sf::st_coordinates(points) # get the r object - r_obj <- .raster_open_rast(var_path) + rast <- .raster_open_rast(var_path) # read the file - values <- .raster_extract(r_obj, points) + values <- .raster_extract(rast, points) # scale the data band_conf <- .conf_derived_band( derived_class = "variance_cube", diff --git a/R/api_raster.R b/R/api_raster.R index 0bdd19a8e..3bd64a6c3 100644 --- a/R/api_raster.R +++ b/R/api_raster.R @@ -96,15 +96,15 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' #' @return Numeric matrix associated to raster object -.raster_get_values <- function(r_obj, ...) { +.raster_get_values <- function(rast, ...) { # read values and close connection - terra::readStart(x = r_obj) - res <- terra::readValues(x = r_obj, mat = TRUE, ...) - terra::readStop(x = r_obj) + terra::readStart(x = rast) + res <- terra::readValues(x = rast, mat = TRUE, ...) + terra::readStop(x = rast) return(res) } @@ -114,30 +114,74 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object +#' @param rast raster package object #' @param values Numeric matrix to copy to raster object #' @param ... additional parameters to be passed to raster package #' #' @return Raster object -.raster_set_values <- function(r_obj, values, ...) { - terra::values(x = r_obj) <- as.matrix(values) - return(r_obj) +.raster_set_values <- function(rast, values, ...) { + terra::values(x = rast) <- as.matrix(values) + return(rast) +} +#' @title Raster package internal get values for rasters in memory +#' @name .raster_values_mem +#' @keywords internal +#' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' +#' @param rast raster package object +#' @param ... additional parameters to be passed to raster package +#' +#' @return Numeric vector with values +.raster_values_mem <- function(rast, ...) { + # read values and close connection + res <- terra::values(x = rast, ...) + return(res) +} +#' @title Raster package internal set min max +#' @name .raster_set_minmax +#' @keywords internal +#' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' +#' @param rast raster package object +#' +#' @return Raster object with additional minmax information +.raster_set_minmax <- function(rast) { + terra::setMinMax(rast) + return(invisible(rast)) +} +#' @title Raster package internal stretch function +#' @name .raster_stretch +#' @keywords internal +#' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' +#' @param rast raster package object +#' @param minv minimum value +#' @param maxv maximum value +#' @param minq first quartile +#' @param minq last quartile +#' +#' @return Raster object with additional minmax information +.raster_stretch <- function(rast, minv, maxv, minq, maxq) { + # # stretch the raster + rast <- terra::stretch(rast, minv, maxv, minq, maxq) } - #' @title Raster package internal set values function #' @name .raster_set_na #' @keywords internal #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object +#' @param rast raster package object #' @param na_value Numeric matrix to copy to raster object #' @param ... additional parameters to be passed to raster package #' #' @return Raster object -.raster_set_na <- function(r_obj, na_value, ...) { - terra::NAflag(x = r_obj) <- na_value - return(r_obj) +.raster_set_na <- function(rast, na_value, ...) { + terra::NAflag(x = rast) <- na_value + return(rast) } #' @title Get top values of a raster. @@ -151,7 +195,7 @@ #' Get the top values of a raster as a point `sf` object. The values #' locations are guaranteed to be separated by a certain number of pixels. #' -#' @param r_obj A raster object. +#' @param rast A raster object. #' @param block Individual block that will be processed. #' @param band A numeric band index used to read bricks. #' @param n Number of values to extract. @@ -159,7 +203,7 @@ #' #' @return A point `tibble` object. #' -.raster_get_top_values <- function(r_obj, +.raster_get_top_values <- function(rast, block, band, n, @@ -169,7 +213,7 @@ # filter by median to avoid borders # Process window values <- .raster_get_values( - r_obj, + rast, row = block[["row"]], col = block[["col"]], nrows = block[["nrows"]], @@ -195,7 +239,7 @@ with_ties = FALSE ) - tb <- r_obj |> + tb <- rast |> .raster_xy_from_cell( cell = samples_tb[["cell"]] ) |> @@ -211,7 +255,7 @@ result_tb <- tb |> sf::st_as_sf( coords = c("x", "y"), - crs = .raster_crs(r_obj), + crs = .raster_crs(rast), dim = "XY", remove = TRUE ) |> @@ -231,13 +275,13 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object +#' @param rast raster package object #' @param xy numeric matrix with coordinates #' @param ... additional parameters to be passed to raster package #' #' @return Numeric matrix with raster values for each coordinate -.raster_extract <- function(r_obj, xy, ...) { - terra::extract(x = r_obj, y = xy, ...) +.raster_extract <- function(rast, xy, ...) { + terra::extract(x = rast, y = xy, ...) } #' #' @title Return sample of values from terra object @@ -246,12 +290,12 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster object +#' @param rast raster object #' @param size size of sample #' @param ... additional parameters to be passed to raster package #' @return numeric matrix -.raster_sample <- function(r_obj, size, ...) { - terra::spatSample(r_obj, size, ...) +.raster_sample <- function(rast, size, ...) { + terra::spatSample(rast, size, ...) } #' @title Return block size of a raster #' @name .raster_file_blocksize @@ -259,11 +303,11 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object +#' @param rast raster package object #' #' @return An vector with the file block size. -.raster_file_blocksize <- function(r_obj) { - block_size <- c(terra::fileBlocksize(r_obj[[1]])) +.raster_file_blocksize <- function(rast) { + block_size <- c(terra::fileBlocksize(rast[[1]])) names(block_size) <- c("nrows", "ncols") return(block_size) } @@ -274,17 +318,30 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object to be cloned +#' @param rast raster package object to be cloned #' @param nlayers number of raster layers #' @param ... additional parameters to be passed to raster package #' #' @return Raster package object -.raster_rast <- function(r_obj, nlayers = 1, ...) { +.raster_rast <- function(rast, nlayers = 1, ...) { suppressWarnings( - terra::rast(x = r_obj, nlyrs = nlayers, ...) + terra::rast(x = rast, nlyrs = nlayers, ...) ) } - +#' @title Raster package internal open vector function +#' @name .raster_open_vect +#' @keywords internal +#' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' +#' @param sf_object sf_object to convert to a SpatVector +#' +#' @return Raster package object +.raster_open_vect <- function(sf_object) { + # set caller to show in errors + .check_set_caller(".raster_open_vect") + terra::vect(sf_object) +} #' @title Raster package internal open raster function #' @name .raster_open_rast #' @keywords internal @@ -298,13 +355,13 @@ .raster_open_rast <- function(file, ...) { # set caller to show in errors .check_set_caller(".raster_open_rast") - r_obj <- suppressWarnings( + rast <- suppressWarnings( terra::rast(x = .file_path_expand(file), ...) ) - .check_null_parameter(r_obj) + .check_null_parameter(rast) # remove gain and offset applied by terra - terra::scoff(r_obj) <- NULL - r_obj + terra::scoff(rast) <- NULL + rast } #' @title Raster package internal write raster file function @@ -313,7 +370,7 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object to be written +#' @param rast raster package object to be written #' @param file file path to save raster file #' @param format GDAL file format string (e.g. GTiff) #' @param data_type sits internal raster data type. One of "INT1U", @@ -323,7 +380,7 @@ #' @param missing_value A \code{integer} with image's missing value #' #' @return No value, called for side effects. -.raster_write_rast <- function(r_obj, +.raster_write_rast <- function(rast, file, data_type, overwrite, ..., @@ -333,7 +390,7 @@ suppressWarnings( terra::writeRaster( - x = r_obj, + x = rast, filename = path.expand(file), wopt = list( filetype = "GTiff", @@ -346,7 +403,7 @@ ) # was the file written correctly? .check_file(file) - return(invisible(r_obj)) + return(invisible(rast)) } #' @title Raster package internal create raster object function @@ -386,7 +443,7 @@ # create new raster object if resolution is not provided if (is.null(resolution)) { # create a raster object - r_obj <- suppressWarnings( + rast <- suppressWarnings( terra::rast( nrows = nrows, ncols = ncols, @@ -400,7 +457,7 @@ ) } else { # create a raster object - r_obj <- suppressWarnings( + rast <- suppressWarnings( terra::rast( nlyrs = nlayers, xmin = xmin, @@ -412,7 +469,7 @@ ) ) } - return(r_obj) + return(rast) } #' @title Raster package internal read raster file function @@ -433,23 +490,23 @@ .raster_check_block(block = block) } # create raster objects - r_obj <- .raster_open_rast(file = path.expand(files), ...) + rast <- .raster_open_rast(file = path.expand(files), ...) # start read if (.has_not(block)) { # read values - terra::readStart(r_obj) + terra::readStart(rast) values <- terra::readValues( - x = r_obj, + x = rast, mat = TRUE ) # close file descriptor - terra::readStop(r_obj) + terra::readStop(rast) } else { # read values - terra::readStart(r_obj) + terra::readStart(rast) values <- terra::readValues( - x = r_obj, + x = rast, row = block[["row"]], nrows = block[["nrows"]], col = block[["col"]], @@ -457,7 +514,7 @@ mat = TRUE ) # close file descriptor - terra::readStop(r_obj) + terra::readStop(rast) } return(values) } @@ -468,7 +525,7 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj Raster package object to be written +#' @param rast Raster package object to be written #' @param file File name to save cropped raster. #' @param data_type sits internal raster data type. One of "INT1U", #' "INT2U", "INT2S", "INT4U", "INT4S", "FLT4S", "FLT8S". @@ -481,7 +538,7 @@ #' #' @return Subset of a raster object as defined by either block #' or bbox parameters -.raster_crop <- function(r_obj, +.raster_crop <- function(rast, file, data_type, overwrite, @@ -499,19 +556,19 @@ # get extent if (.has_block(mask)) { xmin <- terra::xFromCol( - object = r_obj, + object = rast, col = mask[["col"]] ) xmax <- terra::xFromCol( - object = r_obj, + object = rast, col = mask[["col"]] + mask[["ncols"]] - 1 ) ymax <- terra::yFromRow( - object = r_obj, + object = rast, row = mask[["row"]] ) ymin <- terra::yFromRow( - object = r_obj, + object = rast, row = mask[["row"]] + mask[["nrows"]] - 1 ) @@ -522,15 +579,15 @@ ymin = ymin, ymax = ymax ) - mask <- .roi_as_sf(extent, default_crs = terra::crs(r_obj)) + mask <- .roi_as_sf(extent, default_crs = terra::crs(rast)) } # in case of sf with another crs - mask <- .roi_as_sf(mask, as_crs = terra::crs(r_obj)) + mask <- .roi_as_sf(mask, as_crs = terra::crs(rast)) # crop raster suppressWarnings( terra::mask( - x = r_obj, + x = rast, mask = terra::vect(mask), filename = path.expand(file), wopt = list( @@ -550,7 +607,7 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object to be written +#' @param rast raster package object to be written #' @param block a valid block with (\code{col}, \code{row}, #' \code{ncols}, \code{nrows}). #' @param bbox numeric vector with (xmin, xmax, ymin, ymax). @@ -560,7 +617,7 @@ #' #' @return Subset of a raster object as defined by either block #' or bbox parameters -.raster_crop_metadata <- function(r_obj, ..., block = NULL, bbox = NULL) { +.raster_crop_metadata <- function(rast, ..., block = NULL, bbox = NULL) { # set caller to show in errors .check_set_caller(".raster_crop_metadata") # pre-condition @@ -575,19 +632,19 @@ if (!is.null(block)) { # get extent xmin <- terra::xFromCol( - object = r_obj, + object = rast, col = block[["col"]] ) xmax <- terra::xFromCol( - object = r_obj, + object = rast, col = block[["col"]] + block[["ncols"]] - 1 ) ymax <- terra::yFromRow( - object = r_obj, + object = rast, row = block[["row"]] ) ymin <- terra::yFromRow( - object = r_obj, + object = rast, row = block[["row"]] + block[["nrows"]] - 1 ) } else if (!is.null(bbox)) { @@ -602,22 +659,35 @@ # crop raster suppressWarnings( - terra::crop(x = r_obj, y = extent, snap = "out") + terra::crop(x = rast, y = extent, snap = "out") ) } - +#' @title Raster package project function +#' @name .raster_project +#' @keywords internal +#' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' +#' @param rast raster package object +#' @param crs CRS to project to +#' @param ... Other parameters to be passed to terra +#' +#' @return projected raster +.raster_project <- function(rast, crs, ...) { + terra::project(x = rast, y = crs, ...) +} #' @title Return number of rows in a raster #' @name .raster_nrows #' @keywords internal #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' #' @return number of rows in raster object -.raster_nrows <- function(r_obj, ...) { - terra::nrow(x = r_obj) +.raster_nrows <- function(rast, ...) { + terra::nrow(x = rast) } #' @title Return number of columns in a raster @@ -625,99 +695,99 @@ #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return number of columns in a raster object -.raster_ncols <- function(r_obj, ...) { - terra::ncol(x = r_obj) +.raster_ncols <- function(rast, ...) { + terra::ncol(x = rast) } #' @title Return number of layers in a raster #' @name .raster_nlayers #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return number of layers in a raster object -.raster_nlayers <- function(r_obj, ...) { - terra::nlyr(x = r_obj) +.raster_nlayers <- function(rast, ...) { + terra::nlyr(x = rast) } #' @name .raster_xmax #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return maximum x coord of raster object -.raster_xmax <- function(r_obj, ...) { - terra::xmax(x = r_obj) +.raster_xmax <- function(rast, ...) { + terra::xmax(x = rast) } #' @name .raster_xmin #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return minimum x coord of raster object -.raster_xmin <- function(r_obj, ...) { - terra::xmin(x = r_obj) +.raster_xmin <- function(rast, ...) { + terra::xmin(x = rast) } #' @name .raster_ymax #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return maximum y coord of raster object -.raster_ymax <- function(r_obj, ...) { - terra::ymax(x = r_obj) +.raster_ymax <- function(rast, ...) { + terra::ymax(x = rast) } #' @name .raster_ymin #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return minimum y coord of raster object -.raster_ymin <- function(r_obj, ...) { - terra::ymin(x = r_obj) +.raster_ymin <- function(rast, ...) { + terra::ymin(x = rast) } #' @name .raster_xres #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return resolution of raster object in x direction -.raster_xres <- function(r_obj, ...) { - terra::xres(x = r_obj) +.raster_xres <- function(rast, ...) { + terra::xres(x = rast) } #' @name .raster_yres #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return resolution of raster object in y direction -.raster_yres <- function(r_obj, ...) { - terra::yres(x = r_obj) +.raster_yres <- function(rast, ...) { + terra::yres(x = rast) } #' @name .raster_scale #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return scale of values in raster object -.raster_scale <- function(r_obj, ...) { +.raster_scale <- function(rast, ...) { # check value i <- 1 - while (is.na(r_obj[i])) { + while (is.na(rast[i])) { i <- i + 1 } - value <- r_obj[i] + value <- rast[i] if (value > 1.0 && value <= 10000) scale_factor <- 0.0001 else @@ -728,40 +798,40 @@ #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return crs of raster object -.raster_crs <- function(r_obj, ...) { +.raster_crs <- function(rast, ...) { crs <- suppressWarnings( - terra::crs(x = r_obj, describe = TRUE) + terra::crs(x = rast, describe = TRUE) ) if (!is.na(crs[["code"]])) { return(paste(crs[["authority"]], crs[["code"]], sep = ":")) } suppressWarnings( - as.character(terra::crs(x = r_obj)) + as.character(terra::crs(x = rast)) ) } #' @name .raster_bbox #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return bounding box of raster object -.raster_bbox <- function(r_obj, ..., +.raster_bbox <- function(rast, ..., block = NULL) { if (is.null(block)) { # return a named bbox bbox <- c( - xmin = .raster_xmin(r_obj), - ymin = .raster_ymin(r_obj), - xmax = .raster_xmax(r_obj), - ymax = .raster_ymax(r_obj) + xmin = .raster_xmin(rast), + ymin = .raster_ymin(rast), + xmax = .raster_xmax(rast), + ymax = .raster_ymax(rast) ) } else { r_crop <- .raster_crop_metadata( - .raster_rast(r_obj = r_obj), + .raster_rast(rast = rast), block = block ) bbox <- .raster_bbox(r_crop) @@ -774,30 +844,50 @@ #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return resolution of raster object in x and y dimensions -.raster_res <- function(r_obj, ...) { +.raster_res <- function(rast, ...) { # return a named resolution res <- list( - xres = .raster_xres(r_obj), - yres = .raster_yres(r_obj) + xres = .raster_xres(rast), + yres = .raster_yres(rast) ) return(res) } +#' @name .raster_extent_bbox +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @keywords internal +#' @noRd +#' @param xmin,xmax,ymin,ymax numeric vector with bounding box +#' @return a Spatial Extent object +.raster_extent_bbox <- function(xmin, xmax, ymin, ymax) { + # return a Spatial Extent + terra::ext(xmin, xmax, ymin, ymax) +} +#' @name .raster_extent_rast +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @keywords internal +#' @noRd +#' @param rast a Spatial Raster object +#' @return a Spatial Extent object +.raster_extent_rast <- function(rast) { + # return a Spatial Extent + terra::ext(rast) +} #' @name .raster_size #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @keywords internal #' @noRd -#' @param r_obj raster package object +#' @param rast raster package object #' @param ... additional parameters to be passed to raster package #' @return number of rows and cols of raster object -.raster_size <- function(r_obj, ...) { +.raster_size <- function(rast, ...) { # return a named size size <- list( - nrows = .raster_nrows(r_obj), - ncols = .raster_ncols(r_obj) + nrows = .raster_nrows(rast), + ncols = .raster_ncols(rast) ) return(size) @@ -808,12 +898,12 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object to count values +#' @param rast raster package object to count values #' @param ... additional parameters to be passed to raster package #' #' @return matrix with layer, value, and count columns -.raster_freq <- function(r_obj, ...) { - terra::freq(x = r_obj, bylayer = TRUE) +.raster_freq <- function(rast, ...) { + terra::freq(x = rast, bylayer = TRUE) } #' @title Raster package internal raster data type @@ -822,13 +912,13 @@ #' @noRd #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' -#' @param r_obj raster package object +#' @param rast raster package object #' @param by_layer A logical value indicating the type of return #' @param ... additional parameters to be passed to raster package #' #' @return A character value with data type -.raster_datatype <- function(r_obj, ..., by_layer = TRUE) { - terra::datatype(x = r_obj, bylyr = by_layer) +.raster_datatype <- function(rast, ..., by_layer = TRUE) { + terra::datatype(x = rast, bylyr = by_layer) } #' @title Raster package internal summary values function @@ -838,12 +928,12 @@ #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' -#' @param r_obj raster package object to count values +#' @param rast raster package object to count values #' @param ... additional parameters to be passed to raster package #' #' @return matrix with layer, value, and count columns -.raster_summary <- function(r_obj, ...) { - terra::summary(r_obj, ...) +.raster_summary <- function(rast, ...) { + terra::summary(rast, ...) } #' @title Return col value given an X coordinate @@ -851,12 +941,12 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object +#' @param rast raster package object #' @param x X coordinate in raster projection #' #' @return integer with column -.raster_col <- function(r_obj, x) { - terra::colFromX(r_obj, x) +.raster_col <- function(rast, x) { + terra::colFromX(rast, x) } #' @title Return cell value given row and col #' @name .raster_cell_from_rowcol @@ -864,38 +954,38 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object +#' @param rast raster package object #' @param row row #' @param col col #' #' @return cell -.raster_cell_from_rowcol <- function(r_obj, row, col) { - terra::cellFromRowCol(r_obj, row, col) +.raster_cell_from_rowcol <- function(rast, row, col) { + terra::cellFromRowCol(rast, row, col) } #' @title Return XY values given a cell #' @keywords internal #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object +#' @param rast raster package object #' @param cell cell in raster object #' @return matrix of x and y coordinates -.raster_xy_from_cell <- function(r_obj, cell){ - terra::xyFromCell(r_obj, cell) +.raster_xy_from_cell <- function(rast, cell){ + terra::xyFromCell(rast, cell) } #' @title Return quantile value given an raster #' @keywords internal #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster package object +#' @param rast raster package object #' @param quantile quantile value #' @param na.rm Remove NA values? #' @param ... additional parameters #' #' @return numeric values representing raster quantile. -.raster_quantile <- function(r_obj, quantile, na.rm = TRUE, ...) { - terra::global(r_obj, fun = terra::quantile, probs = quantile, na.rm = na.rm) +.raster_quantile <- function(rast, quantile, na.rm = TRUE, ...) { + terra::global(rast, fun = terra::quantile, probs = quantile, na.rm = na.rm) } #' @title Return row value given an Y coordinate @@ -903,23 +993,23 @@ #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#' @param r_obj raster object +#' @param rast raster object #' @param y Y coordinate in raster projection #' #' @return integer with row number -.raster_row <- function(r_obj, y) { - terra::rowFromY(r_obj, y) +.raster_row <- function(rast, y) { + terra::rowFromY(rast, y) } #' @title Raster-to-vector #' @name .raster_extract_polygons #' @keywords internal #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} -#' @param r_obj terra raster object +#' @param rast terra raster object #' @param dissolve should the polygons be dissolved? #' @return A set of polygons -.raster_extract_polygons <- function(r_obj, dissolve = TRUE, ...) { - terra::as.polygons(r_obj, dissolve = TRUE, ...) +.raster_extract_polygons <- function(rast, dissolve = TRUE, ...) { + terra::as.polygons(rast, dissolve = TRUE, ...) } #' @title Determine the file params to write in the metadata @@ -942,18 +1032,18 @@ # use first file file <- file[[1]] # open file - r_obj <- .raster_open_rast(file = file) + rast <- .raster_open_rast(file = file) # build params file params <- tibble::tibble( - nrows = .raster_nrows(r_obj = r_obj), - ncols = .raster_ncols(r_obj = r_obj), - xmin = .raster_xmin(r_obj = r_obj), - xmax = .raster_xmax(r_obj = r_obj), - ymin = .raster_ymin(r_obj = r_obj), - ymax = .raster_ymax(r_obj = r_obj), - xres = .raster_xres(r_obj = r_obj), - yres = .raster_yres(r_obj = r_obj), - crs = .raster_crs(r_obj = r_obj) + nrows = .raster_nrows(rast = rast), + ncols = .raster_ncols(rast = rast), + xmin = .raster_xmin(rast = rast), + xmax = .raster_xmax(rast = rast), + ymin = .raster_ymin(rast = rast), + ymax = .raster_ymax(rast = rast), + xres = .raster_xres(rast = rast), + yres = .raster_yres(rast = rast), + crs = .raster_crs(rast = rast) ) return(params) } @@ -1112,14 +1202,14 @@ #' @return cloned raster object #' .raster_clone <- function(file, nlayers = NULL) { - r_obj <- .raster_open_rast(file = file) + rast <- .raster_open_rast(file = file) if (is.null(nlayers)) { - nlayers <- .raster_nlayers(r_obj = r_obj) + nlayers <- .raster_nlayers(rast = rast) } - r_obj <- .raster_rast(r_obj = r_obj, nlayers = nlayers, vals = NA) + rast <- .raster_rast(rast = rast, nlayers = nlayers, vals = NA) - return(r_obj) + return(rast) } #' @title Check if raster is valid #' @name .raster_is_valid @@ -1155,7 +1245,7 @@ return(TRUE) } # try to open the file - r_obj <- .try( + rast <- .try( { .raster_open_rast(files) }, @@ -1165,7 +1255,7 @@ } ) # File is not valid - if (is.null(r_obj)) { + if (is.null(rast)) { return(FALSE) } # if file can be opened, check if the result is correct @@ -1173,7 +1263,7 @@ # Verify if the raster is corrupted check <- .try( { - r_obj[.raster_ncols(r_obj) * .raster_nrows(r_obj)] + rast[.raster_ncols(rast) * .raster_nrows(rast)] TRUE }, .default = { @@ -1226,27 +1316,27 @@ # Get layers to be saved cols <- if (length(files) > 1) i else seq_len(nlayers) # Create a new raster - r_obj <- .raster_new_rast( + rast <- .raster_new_rast( nrows = block[["nrows"]], ncols = block[["ncols"]], xmin = bbox[["xmin"]], xmax = bbox[["xmax"]], ymin = bbox[["ymin"]], ymax = bbox[["ymax"]], nlayers = nlayers, crs = bbox[["crs"]] ) # Copy values - r_obj <- .raster_set_values( - r_obj = r_obj, + rast <- .raster_set_values( + rast = rast, values = values[, cols] ) # If no crop_block provided write the probabilities to a raster file if (is.null(crop_block)) { .raster_write_rast( - r_obj = r_obj, file = file, data_type = data_type, + rast = rast, file = file, data_type = data_type, overwrite = TRUE, missing_value = missing_value ) } else { # Crop removing overlaps .raster_crop( - r_obj = r_obj, file = file, data_type = data_type, + rast = rast, file = file, data_type = data_type, overwrite = TRUE, mask = crop_block, missing_value = missing_value ) @@ -1255,3 +1345,40 @@ # Return file path files } +#' @title Prepare raster for RGB visualization +#' @name .raster_view_rgb_object +#' @keywords internal +#' @noRd +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' +#' @param red_file Image file to be shown in red color +#' @param green_file Image file to be shown in green color +#' @param blue_file Image file to be shown in blue color +#' @param band_conf Band configuration file +#' @return A Spatial Raster object +# +.raster_view_rgb_object <- function(red_file, green_file, blue_file, band_conf){ + rgb_files <- c(r = red_file, g = green_file, b = blue_file) + rast <- .raster_open_rast(rgb_files) + + # resample and warp the image + rast <- .raster_project( + rast = rast, + crs = "EPSG:3857" + ) + # get scale and offset + band_scale <- .scale(band_conf) + band_offset <- .offset(band_conf) + + # scale the data + rast <- (rast * band_scale + band_offset) * 255 + + # # stretch the raster + rast <- .raster_stretch(rast, minv = 0, maxv = 255, + minq = 0.05, maxq = 0.95) + # convert to RGB + names(rast) <- c("red", "green", "blue") + terra::RGB(rast) <- c(1,2,3) + .raster_set_minmax(rast) + return(rast) +} diff --git a/R/api_raster_sub_image.R b/R/api_raster_sub_image.R index 74c505c76..7c77f3aae 100644 --- a/R/api_raster_sub_image.R +++ b/R/api_raster_sub_image.R @@ -57,7 +57,7 @@ ) # tile template - r_obj <- .raster_new_rast( + rast <- .raster_new_rast( nrows = .tile_nrows(tile), ncols = .tile_ncols(tile), xmin = tile[["xmin"]], @@ -69,12 +69,12 @@ ) # compute block - r_crop <- .raster_crop_metadata(r_obj, bbox = bbox) - row <- .raster_row(r_obj, + r_crop <- .raster_crop_metadata(rast, bbox = bbox) + row <- .raster_row(rast, y = .raster_ymax(r_crop) - 0.5 * .raster_yres(r_crop) ) - col <- .raster_col(r_obj, + col <- .raster_col(rast, x = .raster_xmin(r_crop) + 0.5 * .raster_xres(r_crop) ) diff --git a/R/api_samples.R b/R/api_samples.R index 3397ea0c3..7bb1d3024 100644 --- a/R/api_samples.R +++ b/R/api_samples.R @@ -304,14 +304,14 @@ cube_assets <- .cube_split_assets(cube) # Process each asset in parallel samples <- .jobs_map_parallel_dfr(cube_assets, function(tile) { - robj <- .raster_open_rast(.tile_path(tile)) + rast <- .raster_open_rast(.tile_path(tile)) cls <- samples_class |> dplyr::select("label_id", "label") |> dplyr::rename("id" = "label_id", "cover" = "label") - levels(robj) <- cls + levels(rast) <- cls # sampling! samples_sv <- .raster_sample( - r_obj = robj, + rast = rast, size = size, method = "stratified", as.points = TRUE diff --git a/R/api_source.R b/R/api_source.R index 6994b7c90..d2455a96f 100644 --- a/R/api_source.R +++ b/R/api_source.R @@ -67,7 +67,7 @@ NULL if (is_vector) { class(source) <- c("vector_cube", class(source)) } else if (is_result) { - class(source) <- c("result_cube", class(source)) + class(source) <- c("results_cube", class(source)) } return(source) } diff --git a/R/api_tile.R b/R/api_tile.R index c0e810cf9..95615f7c5 100644 --- a/R/api_tile.R +++ b/R/api_tile.R @@ -623,8 +623,8 @@ NULL if (band %in% .tile_bands(tile)) { band_path <- .tile_path(tile, band) - rast <- terra::rast(band_path) - data_type <- terra::datatype(rast) + rast <- .raster_open_rast(band_path) + data_type <- .raster_datatype(rast) band_conf <- .conf("default_values", data_type) return(band_conf) } @@ -1125,13 +1125,13 @@ NULL base_tile <- .tile(base_tile) if (update_bbox) { # Open raster - r_obj <- .raster_open_rast(files) + rast <- .raster_open_rast(files) # Update spatial bbox - .xmin(base_tile) <- .raster_xmin(r_obj) - .xmax(base_tile) <- .raster_xmax(r_obj) - .ymin(base_tile) <- .raster_ymin(r_obj) - .ymax(base_tile) <- .raster_ymax(r_obj) - .crs(base_tile) <- .raster_crs(r_obj) + .xmin(base_tile) <- .raster_xmin(rast) + .xmax(base_tile) <- .raster_xmax(rast) + .ymin(base_tile) <- .raster_ymin(rast) + .ymax(base_tile) <- .raster_ymax(rast) + .crs(base_tile) <- .raster_crs(rast) } # Update file_info .fi(base_tile) <- .fi_eo_from_files( @@ -1196,21 +1196,21 @@ NULL .check_set_caller(".tile_derived_from_file") if (derived_class %in% c("probs_cube", "variance_cube")) { # Open first block file to be merged - r_obj <- .raster_open_rast(file) + rast <- .raster_open_rast(file) # Check number of labels is correct - .check_that(.raster_nlayers(r_obj) == length(labels)) + .check_that(.raster_nlayers(rast) == length(labels)) } base_tile <- .tile(base_tile) if (update_bbox) { # Open raster - r_obj <- .raster_open_rast(file) + rast <- .raster_open_rast(file) # Update spatial bbox - .xmin(base_tile) <- .raster_xmin(r_obj) - .xmax(base_tile) <- .raster_xmax(r_obj) - .ymin(base_tile) <- .raster_ymin(r_obj) - .ymax(base_tile) <- .raster_ymax(r_obj) - .crs(base_tile) <- .raster_crs(r_obj) + .xmin(base_tile) <- .raster_xmin(rast) + .xmax(base_tile) <- .raster_xmax(rast) + .ymin(base_tile) <- .raster_ymin(rast) + .ymax(base_tile) <- .raster_ymax(rast) + .crs(base_tile) <- .raster_crs(rast) } # Update labels before file_info .tile_labels(base_tile) <- labels @@ -1283,9 +1283,9 @@ NULL .check_set_caller(".tile_derived_merge_blocks") if (derived_class %in% c("probs_cube", "variance_cube")) { # Open first block file to be merged - r_obj <- .raster_open_rast(unlist(block_files)[[1]]) + rast <- .raster_open_rast(unlist(block_files)[[1]]) # Check number of labels is correct - .check_that(.raster_nlayers(r_obj) == length(labels)) + .check_that(.raster_nlayers(rast) == length(labels)) } base_tile <- .tile(base_tile) # Get conf band @@ -1368,9 +1368,9 @@ NULL #' @export .tile_area_freq.class_cube <- function(tile) { # Open first raster - r_obj <- .raster_open_rast(.tile_path(tile)) + rast <- .raster_open_rast(.tile_path(tile)) # Retrieve the frequency - freq <- tibble::as_tibble(.raster_freq(r_obj)) + freq <- tibble::as_tibble(.raster_freq(rast)) # get labels labels <- .tile_labels(tile) # pixel area @@ -1429,9 +1429,9 @@ NULL .tile_extract <- function(tile, band, xy) { .check_set_caller(".tile_extract") # Create a stack object - r_obj <- .raster_open_rast(.tile_paths(tile = tile, bands = band)) + rast <- .raster_open_rast(.tile_paths(tile = tile, bands = band)) # Extract the values - values <- .raster_extract(r_obj, xy) + values <- .raster_extract(rast, xy) # Is the data valid? .check_that(nrow(values) == nrow(xy)) # Return values @@ -1453,9 +1453,9 @@ NULL #' .tile_base_extract <- function(tile, band, xy) { # Create a stack object - r_obj <- .raster_open_rast(.tile_base_path(tile = tile, band = band)) + rast <- .raster_open_rast(.tile_base_path(tile = tile, band = band)) # Extract the values - values <- .raster_extract(r_obj, xy) + values <- .raster_extract(rast, xy) # Is the data valid? .check_that(nrow(values) == nrow(xy)) # Return values @@ -1480,13 +1480,13 @@ NULL fi <- .fi_filter_bands(fi = fi, bands = band) files <- .fi_paths(fi) # Create a SpatRaster object - r_obj <- .raster_open_rast(files) - names(r_obj) <- paste0(band, "-", seq_len(terra::nlyr(r_obj))) + rast <- .raster_open_rast(files) + names(rast) <- paste0(band, "-", seq_len(.raster_nlayers(rast))) # Read the segments segments <- .vector_read_vec(chunk[["segments"]][[1]]) # Extract the values values <- exactextractr::exact_extract( - x = r_obj, + x = rast, y = segments, fun = NULL, include_cols = "pol_id" diff --git a/R/api_tmap.R b/R/api_tmap.R index 929ee59dc..48f982c79 100644 --- a/R/api_tmap.R +++ b/R/api_tmap.R @@ -6,6 +6,7 @@ #' @noRd #' @param rast terra spRast object. #' @param band Band to be plotted. +#' @param title Title of the plot #' @param sf_seg Segments (sf object) #' @param seg_color Color to use for segment borders #' @param line_width Line width to plot the segments boundary @@ -16,6 +17,7 @@ #' @return A list of plot objects .tmap_false_color <- function(rast, band, + title, sf_seg, seg_color, line_width, @@ -55,6 +57,13 @@ labels.size = tmap_params[["graticules_labels_size"]] ) + tmap::tm_compass() + + tmap::tm_credits( + text = title, + size = 1, + position = tmap::tm_pos_in("right", "bottom"), + bg.color = "white", + bg.alpha = 0.7 + ) + tmap::tm_layout( scale = scale ) @@ -131,6 +140,7 @@ #' @param red_file File to be plotted in red #' @param green_file File to be plotted in green #' @param blue_file File to be plotted in blue +#' @param title Title of the plot #' @param scale Scale to plot map (0.4 to 1.0) #' @param max_value Maximum value #' @param first_quantile First quantile for stretching images @@ -143,6 +153,7 @@ .tmap_rgb_color <- function(red_file, green_file, blue_file, + title, scale, max_value, first_quantile, @@ -154,6 +165,7 @@ # open RGB file rast <- .raster_open_rast(c(red_file, green_file, blue_file)) names(rast) <- c("red", "green", "blue") + .raster_set_minmax(rast) p <- tmap::tm_shape(rast, raster.downsample = FALSE) + tmap::tm_rgb( @@ -171,6 +183,13 @@ tmap::tm_layout( scale = scale ) + + tmap::tm_credits( + text = title, + size = 1, + position = tmap::tm_pos_in("right", "bottom"), + bg.color = "white", + bg.alpha = 0.9 + ) + tmap::tm_compass() # include segments @@ -266,6 +285,8 @@ else position <- tmap::tm_pos_in("left", "bottom") + .raster_set_minmax(rast) + # plot using tmap p <- tmap::tm_shape(rast, raster.downsample = FALSE) + tmap::tm_raster( diff --git a/R/api_view.R b/R/api_view.R index d2fea585e..14e9895ec 100644 --- a/R/api_view.R +++ b/R/api_view.R @@ -314,10 +314,7 @@ #' @param group Group to which map will be assigned #' @param tile Tile to be plotted. #' @param date Date to be plotted. -#' @param band For plotting grey images. -#' @param red Band for red color. -#' @param green Band for green color. -#' @param blue Band for blue color. +#' @param bands Bands to be plotted.. #' @param legend Named vector that associates labels to colors. #' @param palette Palette provided in the configuration file #' @param rev Reverse the color palette? @@ -329,14 +326,11 @@ #' #' @return A leaflet object. #' -.view_image_raster <- function(leaf_map, + .view_image_raster <- function(leaf_map, group, tile, date, - band, - red, - green, - blue, + bands, palette, rev, opacity, @@ -353,12 +347,12 @@ date <- tile_dates[idx_date] } # define which method is used - if (band == "RGB") - class(band) <- c("rgb", class(band)) + if (length(bands) == 3) + class(bands) <- c("rgb", class(bands)) else - class(band) <- c("bw", class(band)) + class(bands) <- c("bw", class(bands)) - UseMethod(".view_image_raster", band) + UseMethod(".view_image_raster", bands) } #' View RGB image #' @title Include leaflet to view RGB images @@ -371,10 +365,7 @@ #' @param group Group to which map will be assigned #' @param tile Tile to be plotted. #' @param date Date to be plotted. -#' @param band For plotting grey images. -#' @param red Band for red color. -#' @param green Band for green color. -#' @param blue Band for blue color. +#' @param bands Bands to be plotted #' @param legend Named vector that associates labels to colors. #' @param palette Palette provided in the configuration file #' @param rev Reverse the color palette? @@ -390,10 +381,7 @@ group, tile, date, - band, - red, - green, - blue, + bands, palette, rev, opacity, @@ -402,13 +390,13 @@ last_quantile, leaflet_megabytes) { # scale and offset - band_conf <- .tile_band_conf(tile, red) + band_conf <- .tile_band_conf(tile, bands[[1]]) # filter by date and band # if there is only one band, RGB files will be the same - red_file <- .tile_path(tile, red, date) - green_file <- .tile_path(tile, green, date) - blue_file <- .tile_path(tile, blue, date) + red_file <- .tile_path(tile, bands[[1]], date) + green_file <- .tile_path(tile, bands[[2]], date) + blue_file <- .tile_path(tile, bands[[3]], date) # create a leaflet for RGB bands leaf_map <- leaf_map |> @@ -437,10 +425,7 @@ #' @param group Group to which map will be assigned #' @param tile Tile to be plotted. #' @param date Date to be plotted. -#' @param band For plotting grey images. -#' @param red Band for red color. -#' @param green Band for green color. -#' @param blue Band for blue color. +#' @param bands For plotting grey images. #' @param legend Named vector that associates labels to colors. #' @param palette Palette provided in the configuration file #' @param rev Reverse the color palette? @@ -456,10 +441,7 @@ group, tile, date, - band, - red, - green, - blue, + bands, palette, rev, opacity, @@ -468,9 +450,9 @@ last_quantile, leaflet_megabytes) { # filter by date and band - band_file <- .tile_path(tile, band, date) + band_file <- .tile_path(tile, bands[[1]], date) # scale and offset - band_conf <- .tile_band_conf(tile, band) + band_conf <- .tile_band_conf(tile, bands[[1]]) leaf_map <- leaf_map |> .view_bw_band( group = group, @@ -533,10 +515,7 @@ # read spatial raster file rast <- .raster_open_rast(band_file) # resample and warp the image - rast <- terra::project( - x = rast, - y = "EPSG:3857" - ) + rast <- .raster_project(rast, "EPSG:3857") # scale the data rast <- rast * band_scale + band_offset # extract the values @@ -631,31 +610,8 @@ green_file <- .gdal_warp_file(green_file, sizes) blue_file <- .gdal_warp_file(blue_file, sizes) - # open a SpatRaster object - rgb_files <- c(r = red_file, g = green_file, b = blue_file) - rast <- .raster_open_rast(rgb_files) - - # resample and warp the image - rast <- terra::project( - x = rast, - y = "EPSG:3857" - ) - # get scale and offset - band_scale <- .scale(band_conf) - band_offset <- .offset(band_conf) - - # scale the data - rast <- (rast * band_scale + band_offset) * 255 - - # # stretch the raster - rast <- terra::stretch(rast, - minv = 0, - maxv = 255, - minq = 0.05, - maxq = 0.95) - # convert to RGB - names(rast) <- c("red", "green", "blue") - terra::RGB(rast) <- c(1,2,3) + # prepare a SpatRaster object for visualization + rast <- .raster_view_rgb_object(red_file, green_file, blue_file, band_conf) # calculate maximum size in MB max_bytes <- leaflet_megabytes * 1024^2 @@ -720,21 +676,17 @@ rast <- .raster_open_rast(class_file) # resample and warp the image - rast <- terra::project( - x = rast, - y = "EPSG:3857", - method = "near" - ) + rast <- .raster_project(rast, "EPSG:3857", method = "near") # If available, use labels to define which colors must be presented. # This is useful as some datasets (e.g., World Cover) represent # classified data with values that are not the same as the positions # of the color array (e.g., 10, 20), causing a misrepresentation of # the classes - values_available <- as.character(sort(unique(terra::values(rast), + values_available <- as.character(sort(unique(.raster_values_mem(rast), na.omit = TRUE))) labels <- labels[values_available] # set levels for raster - terra_levels <- data.frame( + rast_levels <- data.frame( id = as.numeric(names(labels)), cover = unname(labels) ) @@ -746,7 +698,7 @@ rev = TRUE ) # set the levels and the palette for terra - levels(rast) <- terra_levels + levels(rast) <- rast_levels options(terra.pal = unname(colors)) leaflet_colors <- leaflet::colorFactor( palette = unname(colors), @@ -838,10 +790,7 @@ rast <- rast[[layer_rast]] # resample and warp the image - rast <- terra::project( - x = rast, - y = "EPSG:3857" - ) + rast <- .raster_project(rast, "EPSG:3857") # scale the data rast <- rast * probs_scale + probs_offset diff --git a/R/sits_config.R b/R/sits_config.R index 223337dc9..c0b3f1d04 100644 --- a/R/sits_config.R +++ b/R/sits_config.R @@ -171,7 +171,7 @@ sits_config_user_file <- function(file_path, overwrite = FALSE){ new_file <- TRUE } # update - if (update || new_file){ + if (update || new_file) { file.copy( from = user_conf_def, to = file_path, diff --git a/R/sits_cube.R b/R/sits_cube.R index 884a5dd30..5770d6809 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -142,7 +142,6 @@ sits_cube <- function(source, collection, ...) { if (bands %in% .conf("sits_results_bands")) { source <- .source_new(source = source, is_local = TRUE, is_result = TRUE) - return(source) } } else if ("vector_dir" %in% names(dots)) { @@ -384,6 +383,8 @@ sits_cube.stac_cube <- function(source, multicores = 2, progress = TRUE) { + # set caller to show in errors + .check_set_caller("sits_cube_stac_cube") # Check for ROI and tiles .check_roi_tiles(roi, tiles) # Ensures that there are no duplicate tiles diff --git a/R/sits_cube_local.R b/R/sits_cube_local.R index 054bc7557..7e1bc7c35 100644 --- a/R/sits_cube_local.R +++ b/R/sits_cube_local.R @@ -197,7 +197,7 @@ sits_cube.local_cube <- function( #' parse_info = c("satellite", "sensor", "tile", "band", "date") #' ) #' # segment the vector cube -#' segments <- sits_segment( +#' segs_cube <- sits_segment( #' cube = modis_cube, #' seg_fn = sits_slic( #' step = 10, @@ -209,14 +209,57 @@ sits_cube.local_cube <- function( #' ), #' output_dir = tempdir() #' ) +#' plot(segs_cube) +#' #' # recover the local segmented cube -#' segment_cube <- sits_cube( +#' local_segs_cube <- sits_cube( #' source = "BDC", #' collection = "MOD13Q1-6.1", #' raster_cube = modis_cube, #' vector_dir = tempdir(), #' vector_band = "segments" #' ) +#' # plot the recover model and compare +#' plot(local_segs_cube) +#' +#' # classify the segments +#' # create a random forest model +#' rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) +#' probs_vector_cube <- sits_classify( +#' data = segs_cube, +#' ml_model = rfor_model, +#' output_dir = tempdir(), +#' n_sam_pol = 10 +#' ) +#' plot(probs_vector_cube) +#' +#' # recover vector cube +#' local_probs_vector_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' raster_cube = modis_cube, +#' vector_dir = tempdir(), +#' vector_band = "probs" +#' ) +#' plot(local_probs_vector_cube) +#' +#' # label the segments +#' class_vector_cube <- sits_label_classification( +#' cube = probs_vector_cube, +#' output_dir = tempdir(), +#' ) +#' plot(class_vector_cube) +#' +#' # recover vector cube +#' local_class_vector_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' raster_cube = modis_cube, +#' vector_dir = tempdir(), +#' vector_band = "class" +#' ) +#' plot(local_class_vector_cube) +#' #'} #' #' @export @@ -233,6 +276,8 @@ sits_cube.vector_cube <- function( multicores = 2L, progress = TRUE) { + # set caller to show in errors + .check_set_caller("sits_cube_vector_cube") # obtain vector items vector_items <- .local_vector_items( source = source, @@ -275,23 +320,22 @@ sits_cube.vector_cube <- function( #' \code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, #' \code{"HLS"}, \code{"PLANETSCOPE"}, \code{"MPC"}, #' \code{"SDC"} or \code{"USGS"}. This is the source -#' from which the data has been downloaded. -#' @param collection Image collection in data source. +#' from which the original data has been downloaded. +#' @param collection Image collection in data source from which +#' the original data has been downloaded. #' To find out the supported collections, #' use \code{\link{sits_list_collections}()}). #' @param ... Other parameters to be passed for specific types. #' @param data_dir Local directory where images are stored #' @param tiles Tiles from the collection to be included in -#' the cube (see details below). +#' the cube. #' @param bands Results bands to be retrieved #' ("probs", "bayes", "variance", "class", "uncertainty") -#' @param labels Labels associated to the classes -#' (Named character vector for cubes of -#' classes "probs_cube" or "class_cube") +#' @param labels Named vector with labels associated to the classes #' @param parse_info Parsing information for local files #' (see notes below). #' @param version Version of the classified and/or labelled files. -#' @param delim Delimiter for parsing local files +#' @param delim Delimiter for parsing local results cubes #' (default = "_") #' @param multicores Number of workers for parallel processing #' (integer, min = 1, max = 2048). @@ -329,7 +373,115 @@ sits_cube.vector_cube <- function( #' to deduce the values of \code{tile}, \code{start_date}, #' \code{end_date} and \code{band} from the file name. #' Default is c("X1", "X2", "tile", "start_date", "end_date", "band"). +#' Cubes processed by \code{sits} adhere to this format. +#' +#' +#' @examples +#' if (sits_run_examples()) { +#' # create a random forest model +#' rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) +#' # create a data cube from local files +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' # classify a data cube +#' probs_cube <- sits_classify( +#' data = cube, ml_model = rfor_model, output_dir = tempdir() +#' ) +#' # plot the probability cube +#' plot(probs_cube) +#' +#' # obtain and name the labels of the local probs cube +#' labels <- sits_labels(rfor_model) +#' names(labels) <- seq_along(labels) +#' +#' # recover the local probability cube +#' probs_local_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = tempdir(), +#' bands = "probs", +#' labels = labels +#' ) +#' # compare the two plots (they should be the same) +#' plot(probs_local_cube) +#' +#' # smooth the probability cube using Bayesian statistics +#' bayes_cube <- sits_smooth(probs_cube, output_dir = tempdir()) +#' # plot the smoothed cube +#' plot(bayes_cube) +#' +#' # recover the local smoothed cube +#' smooth_local_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = tempdir(), +#' bands = "bayes", +#' labels = labels +#' ) +#' # compare the two plots (they should be the same) +#' plot(smooth_local_cube) +#' +#' # label the probability cube +#' label_cube <- sits_label_classification( +#' bayes_cube, +#' output_dir = tempdir() +#' ) +#' # plot the labelled cube +#' plot(label_cube) +#' +#' # recover the local classified cube +#' class_local_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = tempdir(), +#' bands = "class", +#' labels = labels +#' ) +#' # compare the two plots (they should be the same) +#' plot(class_local_cube) +#' +#' # obtain an uncertainty cube with entropy +#' entropy_cube <- sits_uncertainty( +#' cube = bayes_cube, +#' type = "entropy", +#' output_dir = tempdir() +#' ) +#' # plot entropy values +#' plot(entropy_cube) +#' +#' # recover an uncertainty cube with entropy +#' entropy_local_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = tempdir(), +#' bands = "entropy" +#' ) +#'. # plot recovered entropy values +#' plot(entropy_local_cube) #' +#' # obtain an uncertainty cube with margin +#' margin_cube <- sits_uncertainty( +#' cube = bayes_cube, +#' type = "margin", +#' output_dir = tempdir() +#' ) +#' # plot entropy values +#' plot(margin_cube) +#' +#' # recover an uncertainty cube with entropy +#' margin_local_cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = tempdir(), +#' bands = "margin" +#' ) +#'. # plot recovered entropy values +#' plot(margin_local_cube) +#' } #' @export sits_cube.results_cube <- function( source, @@ -337,7 +489,7 @@ sits_cube.results_cube <- function( data_dir, tiles = NULL, bands, - labels, + labels = NULL, parse_info = c("X1", "X2", "tile", "start_date", "end_date", "band", "version"), version = "v1", @@ -345,16 +497,18 @@ sits_cube.results_cube <- function( multicores = 2L, progress = TRUE) { + # set caller to show in errors + .check_set_caller("sits_cube_results_cube") + # check if cube is results cube .check_chr_contains(bands, contains = .conf("sits_results_bands"), discriminator = "one_of", msg = .conf("messages", "sits_cube_results_cube")) - # check if labels exist - .check_chr_parameter(labels, - is_named = TRUE, - msg = .conf("messages", "sits_cube_results_cube_label")) + # check if labels exist and are named + if (any(bands %in% c("probs", "bayes", "class"))) + .check_labels_named(labels) # builds a sits data cube cube <- .local_results_cube( diff --git a/R/sits_plot.R b/R/sits_plot.R index 5f22d8295..3ba4af34f 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -395,8 +395,7 @@ plot.raster_cube <- function(x, ..., # precondition for tiles .check_cube_tiles(x, tile) # precondition for bands - band <- .check_bw_rgb_bands(x, band, red, green, blue) - check_band <- .check_available_bands(x, band, red, green, blue) + bands <- .check_bw_rgb_bands(x, band, red, green, blue) # check roi .check_roi(roi) # check scale parameter @@ -420,16 +419,16 @@ plot.raster_cube <- function(x, ..., if (.has(dates)) .check_dates_timeline(dates, tile) else - dates <- .tile_timeline(tile)[[1]] + dates <- .fi_date_least_cloud_cover(.fi(tile)) # get tmap_params from dots tmap_params <- .tmap_params_set(dots, legend_position) # deal with the case of same band in different dates - if (.has(band) && length(dates) == 3) { + if (length(bands) == 1 && length(dates) == 3) { p <- .plot_band_multidate( tile = tile, - band = band, + band = bands[[1]], dates = dates, roi = roi, scale = scale, @@ -441,10 +440,10 @@ plot.raster_cube <- function(x, ..., return(p) } # single date - either false color (one band) or RGB - if (.has(band)) { + if (length(bands) == 1) { p <- .plot_false_color( tile = tile, - band = band, + band = bands[[1]], date = dates[[1]], roi = roi, sf_seg = NULL, @@ -462,9 +461,7 @@ plot.raster_cube <- function(x, ..., # plot RGB p <- .plot_rgb( tile = tile, - red = red, - green = green, - blue = blue, + bands = bands, date = dates[[1]], roi = roi, sf_seg = NULL, @@ -640,8 +637,6 @@ plot.dem_cube <- function(x, ..., .check_require_packages("tmap") # precondition for tiles .check_cube_tiles(x, tile) - # precondition for bands - .check_available_bands(x, band, red = NULL, green = NULL, blue = NULL) # check roi .check_roi(roi) # check palette @@ -774,10 +769,9 @@ plot.vector_cube <- function(x, ..., # precondition for tiles .check_cube_tiles(x, tile) # precondition for bands - .check_bw_rgb_bands(band, red, green, blue) - .check_available_bands(x, band, red, green, blue) + bands <- .check_bw_rgb_bands(x, band, red, green, blue) # check palette - if (.has(band)) { + if (length(bands) == 1) { # check palette .check_palette(palette) # check rev @@ -814,11 +808,11 @@ plot.vector_cube <- function(x, ..., # retrieve the segments for this tile sf_seg <- .segments_read_vec(tile) # BW or color? - if (.has(band)) { + if (length(bands) == 1) { # plot the band as false color p <- .plot_false_color( tile = tile, - band = band, + band = bands[[1]], date = dates[[1]], roi = NULL, sf_seg = sf_seg, @@ -836,9 +830,7 @@ plot.vector_cube <- function(x, ..., # plot RGB p <- .plot_rgb( tile = tile, - red = red, - green = green, - blue = blue, + bands = bands, date = dates[[1]], roi = NULL, sf_seg = sf_seg, diff --git a/R/sits_view.R b/R/sits_view.R index 14101c95c..a989e16c4 100644 --- a/R/sits_view.R +++ b/R/sits_view.R @@ -301,10 +301,11 @@ sits_view.raster_cube <- function(x, ..., # check logical control .check_lgl_parameter(add) # pre-condition for bands - .check_bw_rgb_bands(band, red, green, blue) - # adjust band name for "RGB" if red, green, blue bands are defined - # else keep the name of B/W band - band <- .check_available_bands(x, band, red, green, blue) + bands <- .check_bw_rgb_bands(x, band, red, green, blue) + if (length(bands) == 1) + band_name <- bands[[1]] + else + band_name <- stringr::str_flatten(bands, collapse = " ") # retrieve dots dots <- list(...) # deal with wrong parameter "date" @@ -321,17 +322,20 @@ sits_view.raster_cube <- function(x, ..., leaf_map <- sits_env[["leaflet"]][["leaf_map"]] # convert tiles names to tile objects cube <- dplyr::filter(x, .data[["tile"]] %in% tiles) - # obtain dates vector - dates <- .view_set_dates(x, dates) # create a new layer in the leaflet for (i in seq_len(nrow(cube))) { row <- cube[i, ] tile_name <- row[["tile"]] + # check dates + if (.has(dates)) + .check_dates_timeline(dates, row) + else + dates <- .fi_date_least_cloud_cover(.fi(row)) for (date in dates) { # convert to proper date date <- lubridate::as_date(date) # add group - group <- paste(tile_name, date, band) + group <- paste(tile_name, date, band_name) # recover global leaflet and include group overlay_groups <- append(overlay_groups, group) # view image raster @@ -340,10 +344,7 @@ sits_view.raster_cube <- function(x, ..., group = group, tile = row, date = as.Date(date), - band = band, - red = red, - green = green, - blue = blue, + bands = bands, palette = palette, rev = rev, opacity = opacity, diff --git a/inst/extdata/config_colors.yml b/inst/extdata/config_colors.yml index b1c3a7348..fb9b5b220 100644 --- a/inst/extdata/config_colors.yml +++ b/inst/extdata/config_colors.yml @@ -1,3 +1,125 @@ +# Color composites +# +composites: + sources: + MPC: + collections: + MOD13Q1-6.1 : &mod13q1 + NDVI : ["NDVI"] + EVI : ["EVI"] + MOD09A1-6.1 : + RGB : ["RED", "GREEN", "BLUE"] + NIR : ["SWIR22", "NIR08", "BLUE"] + NIR2 : ["SWIR22", "NIR08", "RED"] + LANDSAT-C2-L2 : &landsat-c2-l2 + NIR : ["SWIR22", "NIR08", "BLUE"] + RGB : ["RED", "GREEN", "BLUE"] + NIR2 : ["SWIR22", "NIR08", "RED"] + SENTINEL-2-L2A : &sentinel-2 + AGRI : ["B11", "B08", "B02"] + AGRI2 : ["B11", "B8A", "B02"] + SWIR : ["B11", "B08", "B04"] + SWIR2 : ["B12", "B08", "B04"] + SWIR3 : ["B12", "B8A", "B04"] + RGB : ["B04", "B03", "B02"] + SENTINEL-1-GRD : &sentinel-1 + VH : ["VH"] + VV : ["VV"] + SENTINEL-1-RTC : + <<: *sentinel-1 + AWS: + collections: + SENTINEL-2-L2A : + SENTINEL-S2-L2A-COGS : + <<: *sentinel-2 + CDSE: + collections: + SENTINEL-2-L2A : + <<: *sentinel-2 + SENTINEL-1-RTC : + <<: *sentinel-1 + BDC: + collections: + MOD13Q1-6.1 : + <<: *mod13q1 + CBERS-WFI-16D : &cbers-wfi + RGB : ["B15", "B14", "B13"] + NIR : ["B16", "B14", "B13"] + NDVI : ["NDVI"] + EVI : ["EVI"] + CBERS-WFI-8D : + <<: *cbers-wfi + LANDSAT-OLI-16D : + <<: *landsat-c2-l2 + SENTINEL-2-16D : + <<: *sentinel-2 + DEAFRICA: + collections: + ALOS-PALSAR-MOSAIC : + HV : ["HV"] + HH : ["HH"] + LS5-SR : &landsat-tm-etm + SWIR : ["B05", "B04", "B03"] + RGB : ["B03", "B02", "B01"] + NIR : ["B04", "B03", "B02"] + LS7-SR : + <<: *landsat-tm-etm + LS8-SR : &landsat-oli + SWIR : ["B06", "B05", "B04"] + RGB : ["B04", "B03", "B02"] + NIR : ["B05", "B04", "B03"] + LS9-SR : + <<: *landsat-oli + GM-LS8-LS9-ANNUAL : + <<: *landsat-oli + GM-S2-ANNUAL : + <<: *sentinel-2 + GM-S2-ROLLING : + <<: *sentinel-2 + GM-S2-SEMIANNUAL: + <<: *sentinel-2 + DEAUSTRALIA: + collections: + GA_LS5T_ARD_3 : + <<: *landsat-tm-etm + GA_LS7E_ARD_3 : + <<: *landsat-tm-etm + GA_LS8C_ARD_3 : + <<: *landsat-oli + GA_LS9C_ARD_3 : + <<: *landsat-oli + GA_S2AM_ARD_3 : &ga-sentinel-2 + AGRI : ["SWIR-2", "NIR-1", "BLUE"] + RGB : ["RED", "BLUE", "GREEN"] + SWIR : ["SWIR-3", "NIR-1", "RED"] + GA_S2BM_ARD_3 : + <<: *ga-sentinel-2 + GA_LS5T_GM_CYEAR_3: &ga-landsat + AGRI : ["SWIR1", "NIR", "BLUE"] + RGB : ["RED", "BLUE", "GREEN"] + SWIR : ["SWIR2", "NIR", "RED"] + GA_LS7T_GM_CYEAR_3: + <<: *ga-landsat + GA_LS8CLS9C_GM_CYEAR_3: + <<: *ga-landsat + HLS : + collections: + HLSS30: + NIR : ["SWIR-2", "NIR-NARROW", "BLUE"] + RGB : ["RED", "GREEN", "BLUE"] + NIR2 : ["SWIR-2", "NIR-NARROW", "RED"] + HLSL30: + NIR : ["SWIR-2", "NIR-NARROW", "BLUE"] + RGB : ["RED", "GREEN", "BLUE"] + NIR2 : ["SWIR-2", "NIR-NARROW", "RED"] + + PLANET : + collections: + MOSAIC: + RGB : ["B03", "B02", "B01"] + NIR : ["B04", "B03", "B02"] + + # Default Palette includes: # Most classes of the "Brazilian Vegetation Manual" (IBGE,2001) # IPCC AFOLU, PRODES, TerraClass project, IGBP Discover, Copernicus Global Land Cover @@ -551,3 +673,4 @@ colors: "Rice, Stem elong." : "#E59866" "Rice, Booting" : "#DC7633" "Rice, Leaf dev." : "#BA4A00" + diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index c7f78a3dd..d522b6820 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -55,6 +55,7 @@ .check_labels: "missing labels in some or all of reference data" .check_labels_class_cube: "labels do not match number of classes in cube" .check_labels_probs_cube: "labels are not available in probs cube" +.check_labels_named: "for results cubes, a named label vector must be provided" .check_legend: "when defined as a tibble, legend needs name and color columns" .check_legend_position: "legend position is either inside or outside" .check_length: "invalid length for parameter" diff --git a/inst/extdata/sources/config_source_mpc.yml b/inst/extdata/sources/config_source_mpc.yml index 6055cd7de..8cb1cb14a 100644 --- a/inst/extdata/sources/config_source_mpc.yml +++ b/inst/extdata/sources/config_source_mpc.yml @@ -10,7 +10,7 @@ sources: url : "https://planetarycomputer.microsoft.com/api/stac/v1" token_url : "https://planetarycomputer.microsoft.com/api/sas/v1/token" collections : - MOD13Q1-6.1 : &mpc_mod13q1 + MOD13Q1-6.1 : &mpc_mod13q1 bands : NDVI : &mpc_modis_ndvi missing_value : -2000000000 diff --git a/man/sits-package.Rd b/man/sits-package.Rd index d53ac1c03..965145946 100644 --- a/man/sits-package.Rd +++ b/man/sits-package.Rd @@ -35,17 +35,23 @@ Authors: \item Rolf Simoes \email{rolfsimoes@gmail.com} \item Felipe Souza \email{felipe.carvalho@inpe.br} \item Felipe Carlos \email{efelipecarlos@gmail.com} + \item Lorena Santos \email{lorena.santos@inpe.br} } Other contributors: \itemize{ - \item Lorena Santos \email{lorena.santos@inpe.br} [contributor] - \item Karine Ferreira \email{karine.ferreira@inpe.br} [contributor, thesis advisor] \item Charlotte Pelletier \email{charlotte.pelletier@univ-ubs.fr} [contributor] - \item Pedro Andrade \email{pedro.andrade@inpe.br} [contributor] - \item Alber Sanchez \email{alber.ipia@inpe.br} [contributor] \item Estefania Pizarro \email{eapizarroa@ine.gob.cl} [contributor] + \item Karine Ferreira \email{karine.ferreira@inpe.br} [contributor, thesis advisor] + \item Alber Sanchez \email{alber.ipia@inpe.br} [contributor] + \item Alexandre Assuncao \email{alexcarssuncao@gmail.com} [contributor] + \item Daniel Falbel \email{dfalbel@gmail.com} [contributor] \item Gilberto Queiroz \email{gilberto.queiroz@inpe.br} [contributor] + \item Johannes Reiche \email{johannes.reiche@wur.nl} [contributor] + \item Pedro Andrade \email{pedro.andrade@inpe.br} [contributor] + \item Pedro Brito \email{pedro_brito1997@hotmail.com} [contributor] + \item Renato Assuncao \email{assuncaoest@gmail.com} [contributor] + \item Ricardo Cartaxo \email{rcartaxoms@gmail.com} [contributor] } } diff --git a/man/sits_cube.results_cube.Rd b/man/sits_cube.results_cube.Rd index f5cea5d50..398ae81b9 100644 --- a/man/sits_cube.results_cube.Rd +++ b/man/sits_cube.results_cube.Rd @@ -11,7 +11,7 @@ data_dir, tiles = NULL, bands, - labels, + labels = NULL, parse_info = c("X1", "X2", "tile", "start_date", "end_date", "band", "version"), version = "v1", delim = "_", @@ -24,9 +24,10 @@ \code{"CDSE"}, \code{"DEAFRICA"}, \code{"DEAUSTRALIA"}, \code{"HLS"}, \code{"PLANETSCOPE"}, \code{"MPC"}, \code{"SDC"} or \code{"USGS"}. This is the source -from which the data has been downloaded.} +from which the original data has been downloaded.} -\item{collection}{Image collection in data source. +\item{collection}{Image collection in data source from which +the original data has been downloaded. To find out the supported collections, use \code{\link{sits_list_collections}()}).} @@ -35,21 +36,19 @@ use \code{\link{sits_list_collections}()}).} \item{data_dir}{Local directory where images are stored} \item{tiles}{Tiles from the collection to be included in -the cube (see details below).} +the cube.} \item{bands}{Results bands to be retrieved ("probs", "bayes", "variance", "class", "uncertainty")} -\item{labels}{Labels associated to the classes -(Named character vector for cubes of -classes "probs_cube" or "class_cube")} +\item{labels}{Named vector with labels associated to the classes} \item{parse_info}{Parsing information for local files (see notes below).} \item{version}{Version of the classified and/or labelled files.} -\item{delim}{Delimiter for parsing local files +\item{delim}{Delimiter for parsing local results cubes (default = "_")} \item{multicores}{Number of workers for parallel processing @@ -95,4 +94,112 @@ Parameter \code{parse_info} should contain parsing information to deduce the values of \code{tile}, \code{start_date}, \code{end_date} and \code{band} from the file name. Default is c("X1", "X2", "tile", "start_date", "end_date", "band"). + Cubes processed by \code{sits} adhere to this format. +} +\examples{ +if (sits_run_examples()) { + # create a random forest model + rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) + # create a data cube from local files + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + # classify a data cube + probs_cube <- sits_classify( + data = cube, ml_model = rfor_model, output_dir = tempdir() + ) + # plot the probability cube + plot(probs_cube) + + # obtain and name the labels of the local probs cube + labels <- sits_labels(rfor_model) + names(labels) <- seq_along(labels) + + # recover the local probability cube + probs_local_cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = tempdir(), + bands = "probs", + labels = labels + ) + # compare the two plots (they should be the same) + plot(probs_local_cube) + + # smooth the probability cube using Bayesian statistics + bayes_cube <- sits_smooth(probs_cube, output_dir = tempdir()) + # plot the smoothed cube + plot(bayes_cube) + + # recover the local smoothed cube + smooth_local_cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = tempdir(), + bands = "bayes", + labels = labels + ) + # compare the two plots (they should be the same) + plot(smooth_local_cube) + + # label the probability cube + label_cube <- sits_label_classification( + bayes_cube, + output_dir = tempdir() + ) + # plot the labelled cube + plot(label_cube) + + # recover the local classified cube + class_local_cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = tempdir(), + bands = "class", + labels = labels + ) + # compare the two plots (they should be the same) + plot(class_local_cube) + + # obtain an uncertainty cube with entropy + entropy_cube <- sits_uncertainty( + cube = bayes_cube, + type = "entropy", + output_dir = tempdir() + ) + # plot entropy values + plot(entropy_cube) + + # recover an uncertainty cube with entropy + entropy_local_cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = tempdir(), + bands = "entropy" + ) +. # plot recovered entropy values + plot(entropy_local_cube) + + # obtain an uncertainty cube with margin + margin_cube <- sits_uncertainty( + cube = bayes_cube, + type = "margin", + output_dir = tempdir() + ) + # plot entropy values + plot(margin_cube) + + # recover an uncertainty cube with entropy + margin_local_cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = tempdir(), + bands = "margin" + ) +. # plot recovered entropy values + plot(margin_local_cube) +} } diff --git a/man/sits_cube.vector_cube.Rd b/man/sits_cube.vector_cube.Rd index 377e2ca0c..c129a8436 100644 --- a/man/sits_cube.vector_cube.Rd +++ b/man/sits_cube.vector_cube.Rd @@ -92,7 +92,7 @@ if (sits_run_examples()) { parse_info = c("satellite", "sensor", "tile", "band", "date") ) # segment the vector cube - segments <- sits_segment( + segs_cube <- sits_segment( cube = modis_cube, seg_fn = sits_slic( step = 10, @@ -104,14 +104,57 @@ if (sits_run_examples()) { ), output_dir = tempdir() ) + plot(segs_cube) + # recover the local segmented cube - segment_cube <- sits_cube( + local_segs_cube <- sits_cube( source = "BDC", collection = "MOD13Q1-6.1", raster_cube = modis_cube, vector_dir = tempdir(), vector_band = "segments" ) + # plot the recover model and compare + plot(local_segs_cube) + + # classify the segments + # create a random forest model + rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) + probs_vector_cube <- sits_classify( + data = segs_cube, + ml_model = rfor_model, + output_dir = tempdir(), + n_sam_pol = 10 + ) + plot(probs_vector_cube) + + # recover vector cube + local_probs_vector_cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + raster_cube = modis_cube, + vector_dir = tempdir(), + vector_band = "probs" + ) + plot(local_probs_vector_cube) + + # label the segments + class_vector_cube <- sits_label_classification( + cube = probs_vector_cube, + output_dir = tempdir(), + ) + plot(class_vector_cube) + + # recover vector cube + local_class_vector_cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + raster_cube = modis_cube, + vector_dir = tempdir(), + vector_band = "class" + ) + plot(local_class_vector_cube) + } } diff --git a/tests/testthat/test-apply.R b/tests/testthat/test-apply.R index 2c40df9f6..a50331ca0 100644 --- a/tests/testthat/test-apply.R +++ b/tests/testthat/test-apply.R @@ -123,10 +123,10 @@ test_that("Kernel functions", { memsize = 4, multicores = 1 ) - r_obj <- .raster_open_rast(cube$file_info[[1]]$path[[1]]) - v_obj <- matrix(.raster_get_values(r_obj), ncol = 255, byrow = TRUE) - r_obj_md <- .raster_open_rast(cube_median$file_info[[1]]$path[[2]]) - v_obj_md <- matrix(.raster_get_values(r_obj_md), ncol = 255, byrow = TRUE) + rast <- .raster_open_rast(cube$file_info[[1]]$path[[1]]) + v_obj <- matrix(.raster_get_values(rast), ncol = 255, byrow = TRUE) + rast_md <- .raster_open_rast(cube_median$file_info[[1]]$path[[2]]) + v_obj_md <- matrix(.raster_get_values(rast_md), ncol = 255, byrow = TRUE) median_1 <- median(as.vector(v_obj[20:22, 20:22])) median_2 <- v_obj_md[21, 21] @@ -153,10 +153,10 @@ test_that("Kernel functions", { memsize = 4, multicores = 2 ) - r_obj <- .raster_open_rast(cube[1, ]$file_info[[1]]$path[[1]]) - v_obj <- matrix(.raster_get_values(r_obj), ncol = 255, byrow = TRUE) - r_obj_m <- .raster_open_rast(cube_mean$file_info[[1]]$path[[2]]) - v_obj_m <- matrix(.raster_get_values(r_obj_m), ncol = 255, byrow = TRUE) + rast <- .raster_open_rast(cube[1, ]$file_info[[1]]$path[[1]]) + v_obj <- matrix(.raster_get_values(rast), ncol = 255, byrow = TRUE) + rast_m <- .raster_open_rast(cube_mean$file_info[[1]]$path[[2]]) + v_obj_m <- matrix(.raster_get_values(rast_m), ncol = 255, byrow = TRUE) mean_1 <- as.integer(mean(as.vector(v_obj[4:6, 4:6]))) mean_2 <- v_obj_m[5, 5] @@ -170,10 +170,10 @@ test_that("Kernel functions", { memsize = 4, multicores = 2 ) - r_obj <- .raster_open_rast(cube[1, ]$file_info[[1]]$path[[1]]) - v_obj <- matrix(.raster_get_values(r_obj), ncol = 255, byrow = TRUE) - r_obj_sd <- .raster_open_rast(cube_sd$file_info[[1]]$path[[2]]) - v_obj_sd <- matrix(.raster_get_values(r_obj_sd), ncol = 255, byrow = TRUE) + rast <- .raster_open_rast(cube[1, ]$file_info[[1]]$path[[1]]) + v_obj <- matrix(.raster_get_values(rast), ncol = 255, byrow = TRUE) + rast_sd <- .raster_open_rast(cube_sd$file_info[[1]]$path[[2]]) + v_obj_sd <- matrix(.raster_get_values(rast_sd), ncol = 255, byrow = TRUE) sd_1 <- as.integer(sd(as.vector(v_obj[4:6, 4:6]))) sd_2 <- v_obj_sd[5, 5] @@ -187,10 +187,10 @@ test_that("Kernel functions", { memsize = 4, multicores = 2 ) - r_obj <- .raster_open_rast(cube[1, ]$file_info[[1]]$path[[1]]) - v_obj <- matrix(.raster_get_values(r_obj), ncol = 255, byrow = TRUE) - r_obj_min <- .raster_open_rast(cube_min$file_info[[1]]$path[[2]]) - v_obj_min <- matrix(.raster_get_values(r_obj_min), ncol = 255, byrow = TRUE) + rast <- .raster_open_rast(cube[1, ]$file_info[[1]]$path[[1]]) + v_obj <- matrix(.raster_get_values(rast), ncol = 255, byrow = TRUE) + rast_min <- .raster_open_rast(cube_min$file_info[[1]]$path[[2]]) + v_obj_min <- matrix(.raster_get_values(rast_min), ncol = 255, byrow = TRUE) min_1 <- min(as.vector(v_obj[4:6, 4:6])) min_2 <- v_obj_min[5, 5] @@ -204,10 +204,10 @@ test_that("Kernel functions", { memsize = 4, multicores = 2 ) - r_obj <- .raster_open_rast(cube[1, ]$file_info[[1]]$path[[1]]) - v_obj <- matrix(.raster_get_values(r_obj), ncol = 255, byrow = TRUE) - r_obj_max <- .raster_open_rast(cube_max$file_info[[1]]$path[[2]]) - v_obj_max <- matrix(.raster_get_values(r_obj_max), ncol = 255, byrow = TRUE) + rast <- .raster_open_rast(cube[1, ]$file_info[[1]]$path[[1]]) + v_obj <- matrix(.raster_get_values(rast), ncol = 255, byrow = TRUE) + rast_max <- .raster_open_rast(cube_max$file_info[[1]]$path[[2]]) + v_obj_max <- matrix(.raster_get_values(rast_max), ncol = 255, byrow = TRUE) max_1 <- max(as.vector(v_obj[4:6, 4:6])) max_2 <- v_obj_max[5, 5] diff --git a/tests/testthat/test-classification.R b/tests/testthat/test-classification.R index aeb7cd067..91ddc8acf 100644 --- a/tests/testthat/test-classification.R +++ b/tests/testthat/test-classification.R @@ -92,7 +92,7 @@ test_that("Classify with NA values", { output_dir = data_dir, progress = FALSE ) - class_map_rst <- terra::rast(class_map[["file_info"]][[1]][["path"]]) + class_map_rst <- .raster_open_rast(class_map[["file_info"]][[1]][["path"]]) expect_true(anyNA(class_map_rst[])) # remove test files unlink(data_dir) @@ -143,12 +143,12 @@ test_that("Classify with exclusion mask", { ) ) # testing original data - probs_map_rst <- terra::rast(probs_map[["file_info"]][[1]][["path"]]) + probs_map_rst <- .raster_open_rast(probs_map[["file_info"]][[1]][["path"]]) expect_true(anyNA(probs_map_rst[])) # extract values - probs_map_value <- terra::extract( - x = probs_map_rst, - y = terra::vect(exclusion_mask_centroid) + probs_map_value <- .raster_extract( + probs_map_rst, + .raster_open_vect(exclusion_mask_centroid) ) expect_true(any(is.na(probs_map_value))) diff --git a/tests/testthat/test-combine_predictions.R b/tests/testthat/test-combine_predictions.R index cce8cabaf..30a3c25a9 100644 --- a/tests/testthat/test-combine_predictions.R +++ b/tests/testthat/test-combine_predictions.R @@ -47,9 +47,9 @@ test_that("Combine predictions", { xgb_obj <- .raster_open_rast(.tile_path(probs_xgb_cube)) avg_obj <- .raster_open_rast(.tile_path(comb_probs_cube_avg)) - vls_rfor <- terra::values(rfor_obj) - vls_xgb <- terra::values(xgb_obj) - vls_avg <- terra::values(avg_obj) + vls_rfor <- .raster_values_mem(rfor_obj) + vls_xgb <- .raster_values_mem(xgb_obj) + vls_avg <- .raster_values_mem(avg_obj) rfor <- as.vector(vls_rfor[1:10, 1]) xgb <- as.vector(vls_xgb[1:10, 1]) diff --git a/tests/testthat/test-cube-aws.R b/tests/testthat/test-cube-aws.R index f5ab331e3..c319a2b8a 100644 --- a/tests/testthat/test-cube-aws.R +++ b/tests/testthat/test-cube-aws.R @@ -67,9 +67,9 @@ test_that("Creating LANDSAT cubes from AWS with ROI", { bbox_cube_1 <- sits_bbox(.tile(l8_cube_aws), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(l8_cube_aws$file_info[[1]]$path[1]) + rast <- .raster_open_rast(l8_cube_aws$file_info[[1]]$path[1]) tile_nrows <- .tile_nrows(l8_cube_aws)[[1]] - expect_true(.raster_nrows(r_obj) == tile_nrows) + expect_true(.raster_nrows(rast) == tile_nrows) l8_cube_aws_l8 <- .try( { diff --git a/tests/testthat/test-cube-bdc.R b/tests/testthat/test-cube-bdc.R index 6adb6826d..c92fab913 100644 --- a/tests/testthat/test-cube-bdc.R +++ b/tests/testthat/test-cube-bdc.R @@ -30,9 +30,9 @@ test_that("Creating cubes from BDC - CBERS-WFI-16D", { expect_true(timeline[1] <= as.Date(start_date)) expect_true(timeline[length(timeline)] <= as.Date(end_date)) # test raster obj - r_obj <- .raster_open_rast(cbers_cube_16d$file_info[[1]]$path[1]) + rast <- .raster_open_rast(cbers_cube_16d$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(cbers_cube_16d) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating cubes from BDC - CBERS-WFI-8D", { @@ -66,9 +66,9 @@ test_that("Creating cubes from BDC - CBERS-WFI-8D", { expect_true(timeline[1] <= as.Date(start_date)) expect_true(timeline[length(timeline)] <= as.Date(end_date)) - r_obj <- .raster_open_rast(cbers_cube_8d$file_info[[1]]$path[1]) + rast <- .raster_open_rast(cbers_cube_8d$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(cbers_cube_8d) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating cubes from BDC - MOD13Q1-6.1 based on ROI using sf", { @@ -170,9 +170,9 @@ test_that("Creating cubes from BDC - LANDSAT per tile", { expect_true(timeline[1] <= as.Date(start_date)) expect_true(timeline[length(timeline)] <= as.Date(end_date)) # test raster obj - r_obj <- .raster_open_rast(bdc_l8_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(bdc_l8_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(bdc_l8_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating cubes from BDC - LANDSAT per roi", { @@ -211,9 +211,9 @@ test_that("Creating cubes from BDC - LANDSAT per roi", { expect_true(timeline[1] <= as.Date(start_date)) expect_true(timeline[length(timeline)] <= as.Date(end_date)) # test raster obj - r_obj <- .raster_open_rast(bdc_l8_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(bdc_l8_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(bdc_l8_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating cubes from BDC - SENTINEL-2 - roi", { @@ -251,9 +251,9 @@ test_that("Creating cubes from BDC - SENTINEL-2 - roi", { expect_true(timeline[1] <= as.Date(start_date)) expect_true(timeline[length(timeline)] <= as.Date(end_date)) # test raster obj - r_obj <- .raster_open_rast(bdc_s2_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(bdc_s2_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(bdc_s2_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating cubes from BDC - SENTINEL-2 - tile", { @@ -286,9 +286,9 @@ test_that("Creating cubes from BDC - SENTINEL-2 - tile", { expect_true(timeline[1] <= as.Date(start_date)) expect_true(timeline[length(timeline)] <= as.Date(end_date)) # test raster obj - r_obj <- .raster_open_rast(bdc_s2_cube_t$file_info[[1]]$path[1]) + rast <- .raster_open_rast(bdc_s2_cube_t$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(bdc_s2_cube_t) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Downloading and cropping cubes from BDC", { cbers_cube <- tryCatch( @@ -478,22 +478,22 @@ test_that("One-year, multi-core classification in parallel", { output_dir = dir_images, progress = FALSE ) - r_obj <- .raster_open_rast(.tile_path(l8_probs)) + rast <- .raster_open_rast(.tile_path(l8_probs)) expect_true(l8_probs[["xmin"]] >= l8_cube[["xmin"]]) expect_true(l8_probs[["xmax"]] <= l8_cube[["xmax"]]) - expect_true(.raster_nrows(r_obj) < .tile_nrows(l8_cube)) + expect_true(.raster_nrows(rast) < .tile_nrows(l8_cube)) - expect_equal(.raster_nrows(r_obj), .tile_nrows(l8_probs)) + expect_equal(.raster_nrows(rast), .tile_nrows(l8_probs)) - max_lyr2 <- max(.raster_get_values(r_obj)[, 2], na.rm = TRUE) + max_lyr2 <- max(.raster_get_values(rast)[, 2], na.rm = TRUE) expect_true(max_lyr2 <= 10000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3], na.rm = TRUE) + max_lyr3 <- max(.raster_get_values(rast)[, 3], na.rm = TRUE) expect_true(max_lyr3 <= 10000) - min_lyr3 <- min(.raster_get_values(r_obj)[, 3], na.rm = TRUE) + min_lyr3 <- min(.raster_get_values(rast)[, 3], na.rm = TRUE) expect_true(min_lyr3 >= 0) unlink(l8_probs$file_info[[1]]$path) diff --git a/tests/testthat/test-cube-cdse.R b/tests/testthat/test-cube-cdse.R index 132b5346a..ce01186af 100644 --- a/tests/testthat/test-cube-cdse.R +++ b/tests/testthat/test-cube-cdse.R @@ -37,9 +37,9 @@ test_that("Creating S2 cubes from CDSE with ROI", { bbox_cube_1 <- sits_bbox(.tile(s2_cube_cdse), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(s2_cube_cdse$file_info[[1]]$path[1]) + rast <- .raster_open_rast(s2_cube_cdse$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(s2_cube_cdse) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) # Rollback environment changes .environment_rollback(cdse_env_config) }) @@ -75,9 +75,9 @@ test_that("Creating S2 cubes from CDSE with tiles", { r <- .raster_open_rast(.tile_path(s2_cube)) expect_equal(s2_cube$xmax[[1]], .raster_xmax(r), tolerance = 1) expect_equal(s2_cube$xmin[[1]], .raster_xmin(r), tolerance = 1) - r_obj <- .raster_open_rast(s2_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(s2_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(s2_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) expect_true(s2_cube$tile == "20LKP") # Rollback environment changes .environment_rollback(cdse_env_config) diff --git a/tests/testthat/test-cube-deafrica.R b/tests/testthat/test-cube-deafrica.R index 184db35e5..0744786e1 100644 --- a/tests/testthat/test-cube-deafrica.R +++ b/tests/testthat/test-cube-deafrica.R @@ -30,9 +30,9 @@ test_that("Creating LS5-SR cubes from DEA", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating LS7-SR cubes from DEA", { @@ -66,9 +66,9 @@ test_that("Creating LS7-SR cubes from DEA", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating LS8-SR cubes from DEA", { @@ -102,9 +102,9 @@ test_that("Creating LS8-SR cubes from DEA", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating LS9-SR cubes from DEA", { @@ -138,9 +138,9 @@ test_that("Creating LS9-SR cubes from DEA", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating S2 cubes from DEA using ROI", { @@ -267,8 +267,8 @@ test_that("Creating Sentinel-1 RTC cubes from DEA using tiles", { expect_true(bbox[["ymax"]] > roi_cube_s1[["ymax"]]) expect_true(all(c("VV") %in% sits_bands(cube_s1_rtc))) - r_obj <- .raster_open_rast(cube_s1_rtc$file_info[[1]]$path[[1]]) - expect_true(terra::nrow(r_obj) == cube_s1_rtc$file_info[[1]]$nrows[[1]]) + rast <- .raster_open_rast(cube_s1_rtc$file_info[[1]]$path[[1]]) + expect_true(.raster_nrows(rast) == cube_s1_rtc$file_info[[1]]$nrows[[1]]) output_dir <- paste0(tempdir(), "/s1-rtc-reg") if (!dir.exists(output_dir)) { @@ -330,9 +330,9 @@ test_that("Creating Landsat-8/9 Geomedian (Annual) from DEA", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating Sentinel-2 Geomedian (Annual) from DEA", { sentinel_cube <- .try( @@ -365,9 +365,9 @@ test_that("Creating Sentinel-2 Geomedian (Annual) from DEA", { bbox_cube_1 <- sits_bbox(.tile(sentinel_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(sentinel_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(sentinel_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(sentinel_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating Sentinel-2 Geomedian (Semiannual) from DEA", { sentinel_cube <- .try( @@ -400,9 +400,9 @@ test_that("Creating Sentinel-2 Geomedian (Semiannual) from DEA", { bbox_cube_1 <- sits_bbox(.tile(sentinel_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(sentinel_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(sentinel_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(sentinel_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating Sentinel-2 Geomedian (Rolling) from DEA", { sentinel_cube <- .try( @@ -435,9 +435,9 @@ test_that("Creating Sentinel-2 Geomedian (Rolling) from DEA", { bbox_cube_1 <- sits_bbox(.tile(sentinel_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(sentinel_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(sentinel_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(sentinel_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating ALOS-PALSAR-MOSAIC cubes from DEA", { @@ -471,9 +471,9 @@ test_that("Creating ALOS-PALSAR-MOSAIC cubes from DEA", { bbox_cube_1 <- sits_bbox(.tile(cube_alos), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(cube_alos$file_info[[1]]$path[1]) + rast <- .raster_open_rast(cube_alos$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(cube_alos) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating NDVI-ANOMALY cubes from DEA", { @@ -507,9 +507,9 @@ test_that("Creating NDVI-ANOMALY cubes from DEA", { bbox_cube_1 <- sits_bbox(.tile(cube_ndvi), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(cube_ndvi$file_info[[1]]$path[1]) + rast <- .raster_open_rast(cube_ndvi$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(cube_ndvi) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating RAINFALL-CHIRPS-DAILY cubes from DEA", { @@ -543,9 +543,9 @@ test_that("Creating RAINFALL-CHIRPS-DAILY cubes from DEA", { bbox_cube_1 <- sits_bbox(.tile(cube_chirps), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(cube_chirps$file_info[[1]]$path[1]) + rast <- .raster_open_rast(cube_chirps$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(cube_chirps) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating RAINFALL-CHIRPS-MONTHLY cubes from DEA", { @@ -579,9 +579,9 @@ test_that("Creating RAINFALL-CHIRPS-MONTHLY cubes from DEA", { bbox_cube_1 <- sits_bbox(.tile(cube_chirps), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(cube_chirps$file_info[[1]]$path[1]) + rast <- .raster_open_rast(cube_chirps$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(cube_chirps) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating DEM-COP-30 cubes from DEA", { @@ -613,7 +613,7 @@ test_that("Creating DEM-COP-30 cubes from DEA", { bbox_cube_1 <- sits_bbox(.tile(cube_dem), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(cube_dem$file_info[[1]]$path[1]) + rast <- .raster_open_rast(cube_dem$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(cube_dem) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) diff --git a/tests/testthat/test-cube-deaustralia.R b/tests/testthat/test-cube-deaustralia.R index ba23f7c4b..b35d3b222 100644 --- a/tests/testthat/test-cube-deaustralia.R +++ b/tests/testthat/test-cube-deaustralia.R @@ -29,9 +29,9 @@ test_that("Creating GA_LS5T_ARD_3 cubes from DEAustralia", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating GA_LS5T_GM_CYEAR_3 cubes from DEAustralia", { landsat_cube <- .try( @@ -64,9 +64,9 @@ test_that("Creating GA_LS5T_GM_CYEAR_3 cubes from DEAustralia", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating GA_LS7E_ARD_3 cubes from DEAustralia", { @@ -100,9 +100,9 @@ test_that("Creating GA_LS7E_ARD_3 cubes from DEAustralia", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating GA_LS7E_GM_CYEAR_3 cubes from DEAustralia", { landsat_cube <- .try( @@ -135,9 +135,9 @@ test_that("Creating GA_LS7E_GM_CYEAR_3 cubes from DEAustralia", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating GA_LS8C_ARD_3 cubes from DEAustralia", { @@ -171,9 +171,9 @@ test_that("Creating GA_LS8C_ARD_3 cubes from DEAustralia", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating GA_LS9C_ARD_3 cubes from DEAustralia", { @@ -207,9 +207,9 @@ test_that("Creating GA_LS9C_ARD_3 cubes from DEAustralia", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating GA_LS8CLS9C_GM_CYEAR_3 cubes from DEAustralia", { @@ -243,9 +243,9 @@ test_that("Creating GA_LS8CLS9C_GM_CYEAR_3 cubes from DEAustralia", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating GA_S2AM_ARD_3 cubes from DEAustralia using ROI", { @@ -472,9 +472,9 @@ test_that("Creating GA_LS_FC_3 cubes from DEAustralia", { bbox_cube_1 <- sits_bbox(.tile(landsat_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(landsat_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(landsat_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating GA_S2LS_INTERTIDAL_CYEAR_3 cubes from DEAustralia", { @@ -510,7 +510,7 @@ test_that("Creating GA_S2LS_INTERTIDAL_CYEAR_3 cubes from DEAustralia", { bbox_cube_1 <- sits_bbox(.tile(intertidal_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(intertidal_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(intertidal_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(intertidal_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) diff --git a/tests/testthat/test-cube-hls.R b/tests/testthat/test-cube-hls.R index ca38b3c91..c440b852a 100644 --- a/tests/testthat/test-cube-hls.R +++ b/tests/testthat/test-cube-hls.R @@ -24,9 +24,9 @@ test_that("Creating Harmonized Landsat Sentinel HLSS30 cubes", { expect_true(all("20LKP" %in% hls_cube_s2$tile)) expect_true(all(.fi(hls_cube_s2)$xres == 30)) expect_true(all(.fi(hls_cube_s2)$yres == 30)) - r_obj <- .raster_open_rast(hls_cube_s2$file_info[[1]]$path[1]) + rast <- .raster_open_rast(hls_cube_s2$file_info[[1]]$path[1]) tile_nrows <- .tile_nrows(hls_cube_s2)[[1]] - expect_true(.raster_nrows(r_obj) == tile_nrows) + expect_true(.raster_nrows(rast) == tile_nrows) hls_cube_l8 <- .try( { @@ -115,9 +115,9 @@ test_that("Creating Harmonized Landsat Sentinel HLSS30 cubes using tiles", { expect_true(all(hls_cube_s2$tile %in% c("20LKP", "20LLP"))) expect_true(all(.fi(hls_cube_s2)$xres == 30)) expect_true(all(.fi(hls_cube_s2)$yres == 30)) - r_obj <- .raster_open_rast(hls_cube_s2$file_info[[1]]$path[1]) + rast <- .raster_open_rast(hls_cube_s2$file_info[[1]]$path[1]) tile_nrows <- .tile_nrows(hls_cube_s2)[[1]] - expect_true(.raster_nrows(r_obj) == tile_nrows) + expect_true(.raster_nrows(rast) == tile_nrows) hls_cube_l8 <- .try( { diff --git a/tests/testthat/test-cube-mpc.R b/tests/testthat/test-cube-mpc.R index 95650400c..a298cba5b 100644 --- a/tests/testthat/test-cube-mpc.R +++ b/tests/testthat/test-cube-mpc.R @@ -24,9 +24,9 @@ test_that("Creating S2 cubes from MPC using tiles", { r <- .raster_open_rast(.tile_path(s2_cube)) expect_equal(s2_cube$xmax[[1]], .raster_xmax(r), tolerance = 1) expect_equal(s2_cube$xmin[[1]], .raster_xmin(r), tolerance = 1) - r_obj <- .raster_open_rast(s2_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(s2_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(s2_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) s2_cube_s2a <- .try( { @@ -73,9 +73,9 @@ test_that("Creating S2 cubes from MPC with ROI", { bbox_cube_1 <- sits_bbox(.tile(s2_cube_mpc), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(s2_cube_mpc$file_info[[1]]$path[1]) + rast <- .raster_open_rast(s2_cube_mpc$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(s2_cube_mpc) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating Sentinel-1 GRD cubes from MPC using tiles", { @@ -97,8 +97,8 @@ test_that("Creating Sentinel-1 GRD cubes from MPC using tiles", { expect_true(bbox[["ymax"]] > roi_cube_s1[["ymax"]]) expect_true(all(c("VV") %in% sits_bands(cube_s1_grd))) - r_obj <- .raster_open_rast(cube_s1_grd$file_info[[1]]$path[[1]]) - expect_true(terra::nrow(r_obj) == cube_s1_grd$file_info[[1]]$nrows[[1]]) + rast <- .raster_open_rast(cube_s1_grd$file_info[[1]]$path[[1]]) + expect_true(.raster_nrows(rast) == cube_s1_grd$file_info[[1]]$nrows[[1]]) output_dir <- paste0(tempdir(), "/s1-grd-reg") if (!dir.exists(output_dir)) { @@ -203,9 +203,9 @@ test_that("Creating LANDSAT cubes from MPC with ROI", { bbox_cube_1 <- sits_bbox(.tile(l8_cube_mpc), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(l8_cube_mpc$file_info[[1]]$path[1]) + rast <- .raster_open_rast(l8_cube_mpc$file_info[[1]]$path[1]) tile_nrows <- .tile_nrows(l8_cube_mpc)[[1]] - expect_true(.raster_nrows(r_obj) == tile_nrows) + expect_true(.raster_nrows(rast) == tile_nrows) }) test_that("Creating LANDSAT cubes from MPC with WRS", { expect_error( diff --git a/tests/testthat/test-cube-terrascope.R b/tests/testthat/test-cube-terrascope.R index 6ec82fef6..d7bd272fa 100644 --- a/tests/testthat/test-cube-terrascope.R +++ b/tests/testthat/test-cube-terrascope.R @@ -26,7 +26,7 @@ test_that("Creating WORLD-COVER-2021 cubes from TERRASCOPE", { bbox_cube_1 <- sits_bbox(.tile(class_cube), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(class_cube$file_info[[1]]$path[1]) + rast <- .raster_open_rast(class_cube$file_info[[1]]$path[1]) cube_nrows <- .tile_nrows(class_cube) - expect_true(.raster_nrows(r_obj) == cube_nrows) + expect_true(.raster_nrows(rast) == cube_nrows) }) diff --git a/tests/testthat/test-cube-usgs.R b/tests/testthat/test-cube-usgs.R index e716738e9..f5b322282 100644 --- a/tests/testthat/test-cube-usgs.R +++ b/tests/testthat/test-cube-usgs.R @@ -24,9 +24,9 @@ test_that("Creating LANDSAT cubes from USGS with ROI", { bbox_cube_1 <- sits_bbox(.tile(l8_cube_usgs), as_crs = "EPSG:4326") expect_true(bbox_cube["xmax"] >= bbox_cube_1["xmax"]) expect_true(bbox_cube["ymax"] >= bbox_cube_1["ymax"]) - r_obj <- .raster_open_rast(l8_cube_usgs$file_info[[1]]$path[1]) + rast <- .raster_open_rast(l8_cube_usgs$file_info[[1]]$path[1]) tile_nrows <- .tile_nrows(l8_cube_usgs)[[1]] - expect_true(.raster_nrows(r_obj) == tile_nrows) + expect_true(.raster_nrows(rast) == tile_nrows) }) test_that("Creating LANDSAT cubes from USGS with WRS", { @@ -48,7 +48,7 @@ test_that("Creating LANDSAT cubes from USGS with WRS", { testthat::skip_if(purrr::is_null(l8_cube_223067), "USGS is not accessible") expect_true(all(sits_bands(l8_cube_223067) %in% c("NIR08"))) expect_equal(nrow(l8_cube_223067), 1) - r_obj <- .raster_open_rast(l8_cube_223067$file_info[[1]]$path[1]) + rast <- .raster_open_rast(l8_cube_223067$file_info[[1]]$path[1]) tile_nrows <- .tile_nrows(l8_cube_223067)[[1]] - expect_true(.raster_nrows(r_obj) == tile_nrows) + expect_true(.raster_nrows(rast) == tile_nrows) }) diff --git a/tests/testthat/test-cube.R b/tests/testthat/test-cube.R index c02cd31be..542a14696 100644 --- a/tests/testthat/test-cube.R +++ b/tests/testthat/test-cube.R @@ -166,12 +166,13 @@ test_that("Reading raster cube with various type of ROI", { expect_equal(cube[["tile"]], expected_tile) # Test 4a: ROI as SpatExtent - roi_raster <- terra::rast( - extent = terra::ext(roi["xmin"], roi["xmax"], roi["ymin"], roi["ymax"]), + roi_raster <- .raster_nrows( + extent = .raster_extent_bbox(roi["xmin"], roi["xmax"], + roi["ymin"], roi["ymax"]), crs = crs ) - roi_raster <- terra::ext(roi_raster) + roi_raster <- .raster_extent_rast(roi_raster) cube <- .try({ sits_cube( diff --git a/tests/testthat/test-mixture_model.R b/tests/testthat/test-mixture_model.R index 0dfa010d7..36ae735d4 100644 --- a/tests/testthat/test-mixture_model.R +++ b/tests/testthat/test-mixture_model.R @@ -60,8 +60,8 @@ test_that("Mixture model tests", { expect_true(all(sits_timeline(reg_cube) %in% sits_timeline(mm_rmse))) expect_true(all(reg_cube[["tiles"]] == mm_rmse[["tiles"]])) - r_obj <- .raster_open_rast(mm_rmse$file_info[[1]]$path[[2]]) - expect_true(.raster_nrows(r_obj) == .tile_nrows(reg_cube)) + rast <- .raster_open_rast(mm_rmse$file_info[[1]]$path[[2]]) + expect_true(.raster_nrows(rast) == .tile_nrows(reg_cube)) # test errors in mixture model reg_cube2 <- reg_cube @@ -101,9 +101,9 @@ test_that("Mixture model tests", { expect_true(all(reg_cube[["tiles"]] == mm_rmse_csv[["tiles"]])) expect_true(all(file.exists(unlist(mm_rmse_csv$file_info[[1]]$path)))) - r_obj <- .raster_open_rast(mm_rmse_csv$file_info[[1]]$path[[2]]) + rast <- .raster_open_rast(mm_rmse_csv$file_info[[1]]$path[[2]]) - expect_true(.raster_nrows(r_obj) == .tile_nrows(reg_cube)) + expect_true(.raster_nrows(rast) == .tile_nrows(reg_cube)) samples <- tibble::tibble( longitude = c(-65.39246320, -65.21814581, -65.11511198), diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index eff9e3521..8efd3ba27 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -72,18 +72,18 @@ test_that("Plot Time Series and Images", { ) p_probs <- plot(sinop_probs) rast_probs <- p_probs[[1]]$shp - expect_equal(terra::nlyr(rast_probs), 4) + expect_equal(.raster_nlayers(rast_probs), 4) p_probs_f <- plot(sinop_probs, labels = "Forest") rast_probs_f <- p_probs_f[[1]]$shp - expect_equal(terra::nlyr(rast_probs_f), 1) + expect_equal(.raster_nlayers(rast_probs_f), 1) sinop_uncert <- sits_uncertainty(sinop_probs, output_dir = tempdir() ) p_uncert <- plot(sinop_uncert, palette = "Reds", rev = FALSE) rast_uncert <- p_uncert[[1]]$shp - expect_equal(terra::nlyr(rast_uncert), 1) + expect_equal(.raster_nlayers(rast_uncert), 1) sinop_labels <- sits_label_classification( sinop_probs, diff --git a/tests/testthat/test-raster.R b/tests/testthat/test-raster.R index 1e1250bdc..1a811b70c 100644 --- a/tests/testthat/test-raster.R +++ b/tests/testthat/test-raster.R @@ -49,14 +49,14 @@ test_that("Classification with rfor (single core)", { expect_true(all(sits_labels(sinop_probs) %in% c("Cerrado", "Floresta", "Pastagem", "Soja_Milho"))) expect_true(all(file.exists(unlist(sinop_probs$file_info[[1]]$path)))) - r_obj <- .raster_open_rast(sinop_probs$file_info[[1]]$path[[1]]) + rast <- .raster_open_rast(sinop_probs$file_info[[1]]$path[[1]]) - expect_true(.raster_nrows(r_obj) == .tile_nrows(sinop_probs)) + expect_true(.raster_nrows(rast) == .tile_nrows(sinop_probs)) - max_lyr1 <- max(.raster_get_values(r_obj)[, 1]) + max_lyr1 <- max(.raster_get_values(rast)[, 1]) expect_true(max_lyr1 <= 10000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3]) + max_lyr3 <- max(.raster_get_values(rast)[, 3]) expect_true(max_lyr3 <= 10000) # defaults and errors @@ -90,13 +90,13 @@ test_that("Classification with SVM", { progress = FALSE ) expect_true(all(file.exists(unlist(sinop_probs$file_info[[1]]$path)))) - r_obj <- .raster_open_rast(sinop_probs$file_info[[1]]$path[[1]]) - expect_true(.raster_nrows(r_obj) == .tile_nrows(sinop_probs)) + rast <- .raster_open_rast(sinop_probs$file_info[[1]]$path[[1]]) + expect_true(.raster_nrows(rast) == .tile_nrows(sinop_probs)) - max_lyr2 <- max(.raster_get_values(r_obj)[, 2]) + max_lyr2 <- max(.raster_get_values(rast)[, 2]) expect_true(max_lyr2 <= 10000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3]) + max_lyr3 <- max(.raster_get_values(rast)[, 3]) expect_true(max_lyr3 <= 10000) expect_true(all(file.remove(unlist(sinop_probs$file_info[[1]]$path)))) @@ -125,13 +125,13 @@ test_that("Classification with XGBoost", { progress = FALSE ) expect_true(all(file.exists(unlist(sinop_probs$file_info[[1]]$path)))) - r_obj <- .raster_open_rast(sinop_probs$file_info[[1]]$path[[1]]) - expect_true(.raster_nrows(r_obj) == .tile_nrows(sinop_probs)) + rast <- .raster_open_rast(sinop_probs$file_info[[1]]$path[[1]]) + expect_true(.raster_nrows(rast) == .tile_nrows(sinop_probs)) - max_lyr2 <- max(.raster_get_values(r_obj)[, 2]) + max_lyr2 <- max(.raster_get_values(rast)[, 2]) expect_true(max_lyr2 <= 10000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3]) + max_lyr3 <- max(.raster_get_values(rast)[, 3]) expect_true(max_lyr3 <= 10000) expect_true(all(file.remove(unlist(sinop_probs$file_info[[1]]$path)))) @@ -162,14 +162,14 @@ test_that("Classification with SVM and Whittaker filter", { multicores = 2, progress = FALSE ) - r_obj <- .raster_open_rast(sinop_probs$file_info[[1]]$path[[1]]) + rast <- .raster_open_rast(sinop_probs$file_info[[1]]$path[[1]]) - expect_true(.raster_nrows(r_obj) == .tile_nrows(sinop_probs)) + expect_true(.raster_nrows(rast) == .tile_nrows(sinop_probs)) - max_lyr2 <- max(.raster_get_values(r_obj)[, 2]) + max_lyr2 <- max(.raster_get_values(rast)[, 2]) expect_true(max_lyr2 <= 10000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3]) + max_lyr3 <- max(.raster_get_values(rast)[, 3]) expect_true(max_lyr3 <= 10000) expect_true(all(file.remove(unlist(sinop_probs$file_info[[1]]$path)))) }) @@ -206,14 +206,14 @@ test_that("Classification with RFOR and Savitzky-Golay filter", { expect_true(all(file.exists(unlist(sinop_2014_probs$file_info[[1]]$path)))) - r_obj <- .raster_open_rast(sinop_2014_probs$file_info[[1]]$path[[1]]) + rast <- .raster_open_rast(sinop_2014_probs$file_info[[1]]$path[[1]]) - expect_true(.raster_nrows(r_obj) == .tile_nrows(sinop_2014_probs)) + expect_true(.raster_nrows(rast) == .tile_nrows(sinop_2014_probs)) - max_lyr2 <- max(.raster_get_values(r_obj)[, 2]) + max_lyr2 <- max(.raster_get_values(rast)[, 2]) expect_true(max_lyr2 <= 10000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3]) + max_lyr3 <- max(.raster_get_values(rast)[, 3]) expect_true(max_lyr3 <= 10000) expect_true(all(file.remove(unlist(sinop_2014_probs$file_info[[1]]$path)))) @@ -243,14 +243,14 @@ test_that("Classification with MLP", { ) expect_true(all(file.exists(unlist(sinop_2014_probs$file_info[[1]]$path)))) - r_obj <- .raster_open_rast(sinop_2014_probs$file_info[[1]]$path[[1]]) + rast <- .raster_open_rast(sinop_2014_probs$file_info[[1]]$path[[1]]) - expect_true(.raster_nrows(r_obj) == .tile_nrows(sinop_2014_probs)) + expect_true(.raster_nrows(rast) == .tile_nrows(sinop_2014_probs)) - max_lyr2 <- max(.raster_get_values(r_obj)[, 2]) + max_lyr2 <- max(.raster_get_values(rast)[, 2]) expect_true(max_lyr2 <= 10000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3]) + max_lyr3 <- max(.raster_get_values(rast)[, 3]) expect_true(max_lyr3 <= 10000) expect_true(all(file.remove(unlist(sinop_2014_probs$file_info[[1]]$path)))) @@ -280,14 +280,14 @@ test_that("Classification with TempCNN", { ) expect_true(all(file.exists(unlist(sinop_2014_probs$file_info[[1]]$path)))) - r_obj <- .raster_open_rast(sinop_2014_probs$file_info[[1]]$path[[1]]) + rast <- .raster_open_rast(sinop_2014_probs$file_info[[1]]$path[[1]]) - expect_true(.raster_nrows(r_obj) == .tile_nrows(sinop_2014_probs)) + expect_true(.raster_nrows(rast) == .tile_nrows(sinop_2014_probs)) - max_lyr2 <- max(.raster_get_values(r_obj)[, 2]) + max_lyr2 <- max(.raster_get_values(rast)[, 2]) expect_true(max_lyr2 <= 10000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3]) + max_lyr3 <- max(.raster_get_values(rast)[, 3]) expect_true(max_lyr3 <= 10000) expect_true(all(file.remove(unlist(sinop_2014_probs$file_info[[1]]$path)))) @@ -316,14 +316,14 @@ test_that("Classification with TAE", { ) expect_true(all(file.exists(unlist(sinop_2014_probs$file_info[[1]]$path)))) - r_obj <- .raster_open_rast(sinop_2014_probs$file_info[[1]]$path[[1]]) + rast <- .raster_open_rast(sinop_2014_probs$file_info[[1]]$path[[1]]) - expect_true(.raster_nrows(r_obj) == .tile_nrows(sinop_2014_probs)) + expect_true(.raster_nrows(rast) == .tile_nrows(sinop_2014_probs)) - max_lyr2 <- max(.raster_get_values(r_obj)[, 2]) + max_lyr2 <- max(.raster_get_values(rast)[, 2]) expect_true(max_lyr2 <= 10000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3]) + max_lyr3 <- max(.raster_get_values(rast)[, 3]) expect_true(max_lyr3 <= 10000) expect_true(all(file.remove(unlist(sinop_2014_probs$file_info[[1]]$path)))) @@ -353,14 +353,14 @@ test_that("Classification with LightTAE", { ) expect_true(all(file.exists(unlist(sinop_2014_probs$file_info[[1]]$path)))) - r_obj <- .raster_open_rast(sinop_2014_probs$file_info[[1]]$path[[1]]) + rast <- .raster_open_rast(sinop_2014_probs$file_info[[1]]$path[[1]]) - expect_true(.raster_nrows(r_obj) == .tile_nrows(sinop_2014_probs)) + expect_true(.raster_nrows(rast) == .tile_nrows(sinop_2014_probs)) - max_lyr2 <- max(.raster_get_values(r_obj)[, 2]) + max_lyr2 <- max(.raster_get_values(rast)[, 2]) expect_true(max_lyr2 <= 10000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3]) + max_lyr3 <- max(.raster_get_values(rast)[, 3]) expect_true(max_lyr3 <= 10000) expect_true(all(file.remove(unlist(sinop_2014_probs$file_info[[1]]$path)))) @@ -418,14 +418,14 @@ test_that("Classification with cloud band", { ) expect_true(all(file.exists(unlist(sinop_2014_probs$file_info[[1]]$path)))) - r_obj <- .raster_open_rast(sinop_2014_probs$file_info[[1]]$path[[1]]) + rast <- .raster_open_rast(sinop_2014_probs$file_info[[1]]$path[[1]]) - expect_true(.raster_nrows(r_obj) == .tile_nrows(sinop_2014_probs)) + expect_true(.raster_nrows(rast) == .tile_nrows(sinop_2014_probs)) - max_lyr2 <- max(.raster_get_values(r_obj)[, 2]) + max_lyr2 <- max(.raster_get_values(rast)[, 2]) expect_true(max_lyr2 <= 10000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3]) + max_lyr3 <- max(.raster_get_values(rast)[, 3]) expect_true(max_lyr3 <= 10000) expect_true(all(file.remove(unlist(sinop_2014_probs$file_info[[1]]$path)))) @@ -568,9 +568,9 @@ test_that("Classification with post-processing", { expect_true(length(sits_timeline(sinop_class)) == length(sits_timeline(sinop_probs))) - r_obj <- .raster_open_rast(sinop_class$file_info[[1]]$path[[1]]) - max_lab <- max(.raster_get_values(r_obj)) - min_lab <- min(.raster_get_values(r_obj)) + rast <- .raster_open_rast(sinop_class$file_info[[1]]$path[[1]]) + max_lab <- max(.raster_get_values(rast)) + min_lab <- min(.raster_get_values(rast)) expect_true(max_lab == 4) expect_true(min_lab == 1) @@ -907,7 +907,7 @@ test_that("Raster GDAL datatypes", { expect_equal(gdal_type, "UInt16") }) test_that("Raster terra interface", { - r_obj <- .raster_new_rast( + rast <- .raster_new_rast( nrows = 766, ncols = 1307, xmin = 534780, @@ -917,11 +917,11 @@ test_that("Raster terra interface", { nlayers = 1, crs = 3270 ) - expect_equal(nrow(r_obj), 766) - expect_equal(ncol(r_obj), 1307) - expect_equal(terra::xmin(r_obj), 534780) + expect_equal(nrow(rast), 766) + expect_equal(ncol(rast), 1307) + expect_equal(.raster_xmin(rast), 534780) - r_obj_1 <- .raster_new_rast( + rast_1 <- .raster_new_rast( nrows = 766, ncols = 1307, xmin = 534780, @@ -933,12 +933,12 @@ test_that("Raster terra interface", { xres = 20, yres = 20 ) - expect_equal(nrow(r_obj_1), 766) - expect_equal(ncol(r_obj_1), 1307) - expect_equal(terra::xmin(r_obj_1), 534780) + expect_equal(nrow(rast_1), 766) + expect_equal(ncol(rast_1), 1307) + expect_equal(.raster_xmin(rast_1), 534780) block <- c("col" = 1, "row" = 1, "ncols" = 100, "nrows" = 100) - bbox <- .raster_bbox(r_obj, block = block) + bbox <- .raster_bbox(rast, block = block) expect_equal(bbox[["xmin"]], 534780) expect_equal(bbox[["ymin"]], 9038900) expect_equal(bbox[["xmax"]], 536780) diff --git a/tests/testthat/test-reclassify.R b/tests/testthat/test-reclassify.R index 690d1b097..3a82ee17f 100644 --- a/tests/testthat/test-reclassify.R +++ b/tests/testthat/test-reclassify.R @@ -61,9 +61,9 @@ test_that("One-year, multicores processing reclassify", { prodes2021_obj <- .raster_open_rast(.tile_path(prodes2021)) ro_mask_obj <- .raster_open_rast(.tile_path(ro_mask)) - vls_ro_class <- terra::values(ro_class_obj) - vls_prodes2021 <- terra::values(prodes2021_obj) - vls_ro_mask <- terra::values(ro_mask_obj) + vls_ro_class <- .raster_values_mem(ro_class_obj) + vls_prodes2021 <- .raster_values_mem(prodes2021_obj) + vls_ro_mask <- .raster_values_mem(ro_mask_obj) # ro_class is "ClearCut_Veg" expect_equal(vls_ro_class[2000], 3) @@ -244,9 +244,9 @@ test_that("One-year, reclassify class cube from STAC", { prodes2021_obj <- .raster_open_rast(.tile_path(prodes2021)) ro_mask_obj <- .raster_open_rast(.tile_path(ro_mask)) - vls_ro_class <- terra::values(ro_class_obj) - vls_prodes2021 <- terra::values(prodes2021_obj) - vls_ro_mask <- terra::values(ro_mask_obj) + vls_ro_class <- .raster_values_mem(ro_class_obj) + vls_prodes2021 <- .raster_values_mem(prodes2021_obj) + vls_ro_mask <- .raster_values_mem(ro_mask_obj) # ro_class is "Tree Cover" expect_equal(vls_ro_class[1000], 10) diff --git a/tests/testthat/test-regularize.R b/tests/testthat/test-regularize.R index d83f69917..d55ea40cc 100644 --- a/tests/testthat/test-regularize.R +++ b/tests/testthat/test-regularize.R @@ -198,7 +198,7 @@ test_that("Regularizing local cubes without CLOUD BAND", { fi_reg <- .fi(local_reg_cube) r_obj_reg <- .raster_open_rast(fi_reg$path[[1]]) - values_reg <- terra::values(r_obj_reg) + values_reg <- .raster_values_mem(r_obj_reg) # check there are no NAs expect_equal(length(which(is.na(values_reg))), 0) # check interval is two months diff --git a/tests/testthat/test-segmentation.R b/tests/testthat/test-segmentation.R index 0481b1298..9c322f2a8 100644 --- a/tests/testthat/test-segmentation.R +++ b/tests/testthat/test-segmentation.R @@ -64,7 +64,7 @@ test_that("Segmentation", { segment_cube <- sits_cube( source = "BDC", collection = "MOD13Q1-6.1", - data_dir = data_dir, + raster_cube = sinop, vector_dir = output_dir, vector_band = "segments", version = "vt", diff --git a/tests/testthat/test-smooth.R b/tests/testthat/test-smooth.R index 17ad9cecb..bfc957d04 100644 --- a/tests/testthat/test-smooth.R +++ b/tests/testthat/test-smooth.R @@ -47,17 +47,17 @@ test_that("Smoothing with exclusion mask", { multicores = 2 ) # testing original data (no na) - probs_map_rst <- terra::rast(probs_map[["file_info"]][[1]][["path"]]) - probs_map_value <- terra::extract( - x = probs_map_rst, - y = terra::vect(exclusion_mask_centroid) + probs_map_rst <- .raster_open_rast(probs_map[["file_info"]][[1]][["path"]]) + probs_map_value <- .raster_extract( + probs_map_rst, + .raster_open_vect(exclusion_mask_centroid) ) expect_false(any(is.na(probs_map_value))) # testing smooth data (with na) - smooth_map_rst <- terra::rast(smooth_map[["file_info"]][[1]][["path"]]) - smooth_map_value <- terra::extract( - x = smooth_map_rst, - y = terra::vect(exclusion_mask_centroid) + smooth_map_rst <- .raster_open_rast(smooth_map[["file_info"]][[1]][["path"]]) + smooth_map_value <- .raster_extract( + smooth_map_rst, + .raster_open_vect(exclusion_mask_centroid) ) expect_true(any(is.na(smooth_map_value))) # remove test files diff --git a/tests/testthat/test-variance.R b/tests/testthat/test-variance.R index 64f6e0547..07c785202 100644 --- a/tests/testthat/test-variance.R +++ b/tests/testthat/test-variance.R @@ -31,12 +31,12 @@ test_that("Variance cube", { expect_true("variance_cube" %in% class(new_cube)) - r_obj <- .raster_open_rast(var_cube$file_info[[1]]$path[[1]]) + rast <- .raster_open_rast(var_cube$file_info[[1]]$path[[1]]) - max_lyr1 <- max(.raster_get_values(r_obj)[, 1], na.rm = TRUE) + max_lyr1 <- max(.raster_get_values(rast)[, 1], na.rm = TRUE) expect_true(max_lyr1 <= 4000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3], na.rm = TRUE) + max_lyr3 <- max(.raster_get_values(rast)[, 3], na.rm = TRUE) expect_true(max_lyr3 <= 4000) p <- plot(var_cube, sample_size = 10000, labels = "Cerrado") @@ -75,12 +75,12 @@ test_that("Variance cube", { output_dir = tempdir(), version = "vardf" ) - r_obj <- .raster_open_rast(df_var$file_info[[1]]$path[[1]]) + rast <- .raster_open_rast(df_var$file_info[[1]]$path[[1]]) - max_lyr1 <- max(.raster_get_values(r_obj)[, 1], na.rm = TRUE) + max_lyr1 <- max(.raster_get_values(rast)[, 1], na.rm = TRUE) expect_true(max_lyr1 <= 4000) - max_lyr3 <- max(.raster_get_values(r_obj)[, 3], na.rm = TRUE) + max_lyr3 <- max(.raster_get_values(rast)[, 3], na.rm = TRUE) expect_true(max_lyr3 <= 4000) expect_true(all(file.remove(unlist(probs_cube$file_info[[1]]$path)))) From 33c309e500295e2b0ebad2ceb566afb61f105669 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Sun, 6 Apr 2025 22:14:41 -0300 Subject: [PATCH 070/122] fix tmap plot --- R/api_tmap.R | 12 +++++------- tests/testthat/test-cube.R | 7 +++---- tests/testthat/test-view.R | 3 ++- 3 files changed, 10 insertions(+), 12 deletions(-) diff --git a/R/api_tmap.R b/R/api_tmap.R index 48f982c79..c1a873f40 100644 --- a/R/api_tmap.R +++ b/R/api_tmap.R @@ -56,13 +56,12 @@ tmap::tm_graticules( labels.size = tmap_params[["graticules_labels_size"]] ) + - tmap::tm_compass() + tmap::tm_credits( text = title, - size = 1, + size = 0.85, position = tmap::tm_pos_in("right", "bottom"), bg.color = "white", - bg.alpha = 0.7 + bg.alpha = 0.65 ) + tmap::tm_layout( scale = scale @@ -185,12 +184,11 @@ ) + tmap::tm_credits( text = title, - size = 1, + size = 0.85, position = tmap::tm_pos_in("right", "bottom"), bg.color = "white", - bg.alpha = 0.9 - ) + - tmap::tm_compass() + bg.alpha = 0.65 + ) # include segments if (.has(sf_seg)) { diff --git a/tests/testthat/test-cube.R b/tests/testthat/test-cube.R index 542a14696..c02cd31be 100644 --- a/tests/testthat/test-cube.R +++ b/tests/testthat/test-cube.R @@ -166,13 +166,12 @@ test_that("Reading raster cube with various type of ROI", { expect_equal(cube[["tile"]], expected_tile) # Test 4a: ROI as SpatExtent - roi_raster <- .raster_nrows( - extent = .raster_extent_bbox(roi["xmin"], roi["xmax"], - roi["ymin"], roi["ymax"]), + roi_raster <- terra::rast( + extent = terra::ext(roi["xmin"], roi["xmax"], roi["ymin"], roi["ymax"]), crs = crs ) - roi_raster <- .raster_extent_rast(roi_raster) + roi_raster <- terra::ext(roi_raster) cube <- .try({ sits_cube( diff --git a/tests/testthat/test-view.R b/tests/testthat/test-view.R index 680c580c1..80ce389b0 100644 --- a/tests/testthat/test-view.R +++ b/tests/testthat/test-view.R @@ -30,7 +30,8 @@ test_that("View", { ) expect_true("leaflet" %in% class(vrgb)) expect_true(grepl("EPSG3857", vrgb$x$options$crs$crsClass)) - expect_equal(vrgb$x$calls[[4]]$args[[4]], "012010 2013-09-14 RGB") + expect_equal(vrgb$x$calls[[4]]$args[[4]], + "012010 2013-09-14 NDVI NDVI NDVI") # create a probs cube rf_model <- sits_train(samples_modis_ndvi, sits_rfor()) From 8726dcb8a022991786917d63a1b5944aab43da3c Mon Sep 17 00:00:00 2001 From: Rolf Simoes Date: Mon, 7 Apr 2025 18:38:24 +0200 Subject: [PATCH 071/122] Fix #1315 --- R/api_source_mpc.R | 7 ------- R/sits_cube.R | 3 ++- 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/R/api_source_mpc.R b/R/api_source_mpc.R index c68eb68a7..24f2e06dc 100644 --- a/R/api_source_mpc.R +++ b/R/api_source_mpc.R @@ -105,13 +105,6 @@ stac_query <- .stac_create_items_query( source = source, collection = collection, - roi = list( - xmin = -50.479, - ymin = -10.1973, - xmax = -50.410, - ymax = -10.1510, - crs = "EPSG:4326" - ), start_date = start_date, end_date = end_date, limit = 1 diff --git a/R/sits_cube.R b/R/sits_cube.R index 5770d6809..e52e074f4 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -451,7 +451,8 @@ sits_cube.stac_cube <- function(source, end_date = end_date, platform = platform, multicores = multicores, - progress = progress, ... + progress = progress, + orbit = orbit, ... ) # adjust crs of the cube before return .cube_adjust_crs(cube) From 94ac677403b542e0d88b1eda074a90fba6982b4b Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Mon, 7 Apr 2025 13:50:57 -0300 Subject: [PATCH 072/122] plot documentation --- R/sits-package.R | 25 +++++++++ R/sits_plot.R | 31 ++++++++++- R/sits_predictors.R | 52 ++++++++++++++++++- R/sits_sample_functions.R | 12 +++-- R/zzz.R | 2 +- man/plot.raster_cube.Rd | 31 ++++++++++- man/sits-package.Rd | 25 +++++++++ man/sits_confidence_sampling.Rd | 12 +++-- ...d_reference.Rd => sits_pred_references.Rd} | 3 +- man/sits_predictors.Rd | 50 +++++++++++++++++- 10 files changed, 225 insertions(+), 18 deletions(-) rename man/{sits_pred_reference.Rd => sits_pred_references.Rd} (94%) diff --git a/R/sits-package.R b/R/sits-package.R index e3e444548..ff42ea4b1 100644 --- a/R/sits-package.R +++ b/R/sits-package.R @@ -9,6 +9,31 @@ #' It includes methods for filtering, clustering, classification, #' and post-processing. #' +#' @note +#' The main \code{sits} classification workflow has the following steps: +#' \enumerate{ +#' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from +#' a cloud provider.} +#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' from a cloud provider to a local directory for faster processing.} +#' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube +#' from an ARD image collection.} +#' \item{\code{\link[sits]{sits_apply}}: create new indices by combining +#' bands of a regular data cube (optional).} +#' \item{\code{\link[sits]{sits_get_data}}: extract time series +#' from a regular data cube based on user-provided labelled samples.} +#' \item{\code{\link[sits]{sits_train}}: train a machine learning +#' model based on image time series.} +#' \item{\code{\link[sits]{sits_classify}}: classify a data cube +#' using a machine learning model and obtain a probability cube.} +#' \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube +#' using a spatial smoother to remove outliers and +#' increase spatial consistency.} +#' \item{\code{\link[sits]{sits_label_classification}}: produce a +#' classified map by selecting the label with the highest probability +#' from a smoothed cube.} +#' } +#' #' @docType package #' @name sits-package #' @aliases sits diff --git a/R/sits_plot.R b/R/sits_plot.R index 3ba4af34f..a25a73ad7 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -350,7 +350,36 @@ plot.predicted <- function(x, y, ..., #' SAR data). For RGB bands with multi-dates, multiple plots will be #' produced. #' -#' @note The following optional parameters are available to allow for detailed +#' If the user does not provide band names for b/w or RGB plots, +#' and also does not provide dates, +#' \code{plot.raster_cube} tries to display some reasonable color +#' composites, using the following algorithm: +#' \enumerate{ +#' \item{Each image in \code{sits} is associated to a source and +#' a collection (e.g, "MPC" and "SENTINEL-2-L2A").} +#' \item{For each source/collection pair, \code{sits} has a set +#' of possible color composites stored in "./extdata/config_colors.yml". +#' For example, the following composites are available for all +#' "SENTINEL-2" images: +#' \itemize{ +#' \item {AGRICULTURE: ("B11", "B08", "B02")} +#' \item {AGRICULTURE2: ("B11", "B8A", "B02")} +#' \item {SWIR: ("B11", "B08", "B04")} +#' \item {SWIR2: ("B12", "B08", "B04")} +#' \item {SWIR3: ("B12", "B8A", "B04")} +#' \item {RGB: ("B04", "B03", "B02")} +#' } +#' } +#' \item{\code{sits} tries to find if the bands required for one +#' of the color composites are part of the cube. If they exist, +#' that RGB composite is selected. Otherwise, the first +#' available band is chosen.} +#' \item{After selecting the bands, the algorithm looks for the +#' date with the smallest percentage of cloud cover and +#' selects that date to be displayed.} +#' } +#' +#'. The following optional parameters are available to allow for detailed #' control over the plot output: #' \itemize{ #' \item \code{graticules_labels_size}: size of coord labels (default = 0.7) diff --git a/R/sits_predictors.R b/R/sits_predictors.R index cc528692a..e1ea58ac0 100644 --- a/R/sits_predictors.R +++ b/R/sits_predictors.R @@ -14,7 +14,55 @@ #' #' @examples #' if (sits_run_examples()) { -#' pred <- sits_predictors(samples_modis_ndvi) +#' # Include a new machine learning function (multiple linear regression) +#' # function that returns mlr model based on a sits sample tibble +#' +#' sits_mlr <- function(samples = NULL, formula = sits_formula_linear(), +#' n_weights = 20000, maxit = 2000) { +#' +#' # create a training function +#' train_fun <- function(samples) { +#' # Data normalization +#' ml_stats <- sits_stats(samples) +#' train_samples <- sits_predictors(samples) +#' train_samples <- sits_pred_normalize( +#' pred = train_samples, +#' stats = ml_stats +#' ) +#' formula <- formula(train_samples[, -1]) +#' # call method and return the trained model +#' result_mlr <- nnet::multinom( +#' formula = formula, +#' data = train_samples, +#' maxit = maxit, +#' MaxNWts = n_weights, +#' trace = FALSE, +#' na.action = stats::na.fail +#' ) +#' +#' # construct model predict closure function and returns +#' predict_fun <- function(values) { +#' # retrieve the prediction (values and probs) +#' prediction <- tibble::as_tibble( +#' stats::predict(result_mlr, +#' newdata = values, +#' type = "probs" +#' ) +#' ) +#' return(prediction) +#' } +#' class(predict_fun) <- c("sits_model", class(predict_fun)) +#' return(predict_fun) +#' } +#' result <- sits_factory_function(samples, train_fun) +#' return(result) +#' } +#' # create an mlr model using a set of samples +#' mlr_model <- sits_train(samples_modis_ndvi, sits_mlr) +#' # classify a point +#' point_ndvi <- sits_select(point_mt_6bands, bands = "NDVI") +#' point_class <- sits_classify(point_ndvi, mlr_model, multicores = 1) +#' plot(point_class) #' } #' #' @export @@ -54,7 +102,7 @@ sits_pred_features <- function(pred) { return(features) } #' @title Obtain categorical id and predictor labels for time series samples -#' @name sits_pred_reference +#' @name sits_pred_references #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @description Predictors are X-Y values required for machine learning #' algorithms, organized as a data table where each row corresponds diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R index ddeb2466c..a2912941e 100644 --- a/R/sits_sample_functions.R +++ b/R/sits_sample_functions.R @@ -67,11 +67,13 @@ sits_sample <- function(data, #' minimum distance between new labels, to minimize spatial autocorrelation #' effects. #' This function is best used in the following context: -#' 1. Select an initial set of samples. -#' 2. Train a machine learning model. -#' 3. Build a data cube and classify it using the model. -#' 4. Run a Bayesian smoothing in the resulting probability cube. -#' 5. Perform confidence sampling. +#' \enumerate{ +#' \item{Select an initial set of samples.} +#' \item{Train a machine learning model.} +#' \item{Build a data cube and classify it using the model.} +#' \item{Run a Bayesian smoothing in the resulting probability cube.} +#' \item{Perform confidence sampling.} +#' } #' #' The Bayesian smoothing procedure will reduce the classification outliers #' and thus increase the likelihood that the resulting pixels with provide diff --git a/R/zzz.R b/R/zzz.R index fd4df8a3b..e1a82ae86 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -13,7 +13,7 @@ ) packageStartupMessage( sprintf( - "Important: Please read \"Release Notes for SITS 1.5.2\" in + "Important: Please read \"Release Notes for SITS 1.5.3\" in https://github.com/e-sensing/sits." ) ) diff --git a/man/plot.raster_cube.Rd b/man/plot.raster_cube.Rd index 623d56c8e..580b6b71b 100644 --- a/man/plot.raster_cube.Rd +++ b/man/plot.raster_cube.Rd @@ -74,7 +74,36 @@ Use \code{scale} parameter for general output control. SAR data). For RGB bands with multi-dates, multiple plots will be produced. -The following optional parameters are available to allow for detailed +If the user does not provide band names for b/w or RGB plots, +and also does not provide dates, +\code{plot.raster_cube} tries to display some reasonable color +composites, using the following algorithm: +\enumerate{ +\item{Each image in \code{sits} is associated to a source and +a collection (e.g, "MPC" and "SENTINEL-2-L2A").} +\item{For each source/collection pair, \code{sits} has a set +of possible color composites stored in "./extdata/config_colors.yml". +For example, the following composites are available for all +"SENTINEL-2" images: + \itemize{ + \item: {AGRICULTURE: ("B11", "B08", "B02")} + \item: {AGRICULTURE2: ("B11", "B8A", "B02")} + \item: {SWIR: ("B11", "B08", "B04")} + \item: {SWIR2: ("B12", "B08", "B04")} + \item: {SWIR3: ("B12", "B8A", "B04")} + \item: {RGB: ("B04", "B03", "B02")} + } + } +\item{\code{sits} tries to find if the bands required for one + of the color composites are part of the cube. If they exist, + that RGB composite is selected. Otherwise, the first + available band is chosen.} +\item{After selecting the bands, the algorithm looks for the + date with the smallest percentage of cloud cover and + selects that date to be displayed.} +} + +. The following optional parameters are available to allow for detailed control over the plot output: \itemize{ \item \code{graticules_labels_size}: size of coord labels (default = 0.7) diff --git a/man/sits-package.Rd b/man/sits-package.Rd index 965145946..4435f96a2 100644 --- a/man/sits-package.Rd +++ b/man/sits-package.Rd @@ -9,6 +9,31 @@ Satellite Image Time Series Analysis for Earth Observation Data Cubes } +\note{ +The main \code{sits} classification workflow has the following steps: +\enumerate{ + \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from + a cloud provider.} + \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + from a cloud provider to a local directory for faster processing.} + \item{\code{\link[sits]{sits_regularize}}: create a regular data cube + from an ARD image collection.} + \item{\code{\link[sits]{sits_apply}}: create new indices by combining + bands of a regular data cube (optional).} + \item{\code{\link[sits]{sits_get_data}}: extract time series + from a regular data cube based on user-provided labelled samples.} + \item{\code{\link[sits]{sits_train}}: train a machine learning + model based on image time series.} + \item{\code{\link[sits]{sits_classify}}: classify a data cube + using a machine learning model and obtain a probability cube.} + \item{\code{\link[sits]{sits_smooth}}: post-process a probability cube + using a spatial smoother to remove outliers and + increase spatial consistency.} + \item{\code{\link[sits]{sits_label_classification}}: produce a + classified map by selecting the label with the highest probability + from a smoothed cube.} +} +} \section{Purpose}{ diff --git a/man/sits_confidence_sampling.Rd b/man/sits_confidence_sampling.Rd index 18bcad54a..eff7f05e4 100644 --- a/man/sits_confidence_sampling.Rd +++ b/man/sits_confidence_sampling.Rd @@ -46,11 +46,13 @@ this label compared to all others. The algorithm also considers a minimum distance between new labels, to minimize spatial autocorrelation effects. This function is best used in the following context: - 1. Select an initial set of samples. - 2. Train a machine learning model. - 3. Build a data cube and classify it using the model. - 4. Run a Bayesian smoothing in the resulting probability cube. - 5. Perform confidence sampling. +\enumerate{ +\item{Select an initial set of samples.} +\item{Train a machine learning model.} +\item{Build a data cube and classify it using the model.} +\item{Run a Bayesian smoothing in the resulting probability cube.} +\item{Perform confidence sampling.} +} The Bayesian smoothing procedure will reduce the classification outliers and thus increase the likelihood that the resulting pixels with provide diff --git a/man/sits_pred_reference.Rd b/man/sits_pred_references.Rd similarity index 94% rename from man/sits_pred_reference.Rd rename to man/sits_pred_references.Rd index 7f6668320..e4fbbe115 100644 --- a/man/sits_pred_reference.Rd +++ b/man/sits_pred_references.Rd @@ -1,7 +1,6 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/sits_predictors.R -\name{sits_pred_reference} -\alias{sits_pred_reference} +\name{sits_pred_references} \alias{sits_pred_references} \title{Obtain categorical id and predictor labels for time series samples} \usage{ diff --git a/man/sits_predictors.Rd b/man/sits_predictors.Rd index 1d697faed..d31879463 100644 --- a/man/sits_predictors.Rd +++ b/man/sits_predictors.Rd @@ -21,7 +21,55 @@ the values of each band and time, organized first by band and then by time. } \examples{ if (sits_run_examples()) { - pred <- sits_predictors(samples_modis_ndvi) + # Include a new machine learning function (multiple linear regression) + # function that returns mlr model based on a sits sample tibble + + sits_mlr <- function(samples = NULL, formula = sits_formula_linear(), + n_weights = 20000, maxit = 2000) { + + # create a training function + train_fun <- function(samples) { + # Data normalization + ml_stats <- sits_stats(samples) + train_samples <- sits_predictors(samples) + train_samples <- sits_pred_normalize( + pred = train_samples, + stats = ml_stats + ) + formula <- formula(train_samples[, -1]) + # call method and return the trained model + result_mlr <- nnet::multinom( + formula = formula, + data = train_samples, + maxit = maxit, + MaxNWts = n_weights, + trace = FALSE, + na.action = stats::na.fail + ) + + # construct model predict closure function and returns + predict_fun <- function(values) { + # retrieve the prediction (values and probs) + prediction <- tibble::as_tibble( + stats::predict(result_mlr, + newdata = values, + type = "probs" + ) + ) + return(prediction) + } + class(predict_fun) <- c("sits_model", class(predict_fun)) + return(predict_fun) + } + result <- sits_factory_function(samples, train_fun) + return(result) + } + # create an mlr model using a set of samples + mlr_model <- sits_train(samples_modis_ndvi, sits_mlr) + # classify a point + point_ndvi <- sits_select(point_mt_6bands, bands = "NDVI") + point_class <- sits_classify(point_ndvi, mlr_model, multicores = 1) + plot(point_class) } } From 6a2f50f61d7515ce7835cf6f56a2ee46395ae66c Mon Sep 17 00:00:00 2001 From: Felipe Date: Tue, 8 Apr 2025 22:27:21 +0000 Subject: [PATCH 073/122] refactoring mpc token generation --- R/api_cube.R | 102 +++++++++++++++--------------------- R/api_source_mpc.R | 125 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 165 insertions(+), 62 deletions(-) diff --git a/R/api_cube.R b/R/api_cube.R index c693176b3..4d451fce5 100644 --- a/R/api_cube.R +++ b/R/api_cube.R @@ -1422,6 +1422,17 @@ NULL # set caller to show in errors .check_set_caller(".cube_token_generator") + # List to store the generated tokens + available_tks <- list() + + # Planetary computer token endpoint + ms_endpoint <- .conf("sources", .cube_source(cube), "token_url") + + # Get environment variables + n_tries <- .conf("cube_token_generator_n_tries") + sleep_time <- .conf("cube_token_generator_sleep_time") + access_key <- Sys.getenv("MPC_TOKEN") + # we consider token is expired when the remaining time is # less than 5 minutes are_token_updated <- slider::slide_lgl(cube, function(tile) { @@ -1443,82 +1454,49 @@ NULL return(cube) } - token_endpoint <- .conf("sources", .cube_source(cube), "token_url") - url <- paste0(token_endpoint, "/", tolower(.cube_collection(cube))) - res_content <- NULL - - # Get environment variables - n_tries <- .conf("cube_token_generator_n_tries") - sleep_time <- .conf("cube_token_generator_sleep_time") - access_key <- Sys.getenv("MPC_TOKEN") - - # Generate a random time to make a new request - sleep_time <- sample(x = seq_len(sleep_time), size = 1) - # Verify access key if (!nzchar(access_key)) { access_key <- NULL } - # Generate new token - while (is.null(res_content) && n_tries > 0) { - res_content <- tryCatch( - { - res <- .get_request( - url = url, - headers = list("Ocp-Apim-Subscription-Key" = access_key) - ) - res <- .response_check_status(res) - .response_content(res) - }, - error = function(e) { - return(NULL) - } - ) - - if (is.null(res_content)) { - Sys.sleep(sleep_time) - } - n_tries <- n_tries - 1 - } - # check that token is valid - .check_that(.has(res_content)) - # parse token - token_parsed <- .url_parse_query(res_content[["token"]]) cube <- slider::slide_dfr(cube, function(tile) { + # Generate a random time to make a new request + sleep_time <- sample(x = seq_len(sleep_time), size = 1) # Get tile file info file_info <- .fi(tile) - fi_paths <- .fi_paths(file_info) - - # Concatenate token into tiles path - file_info[["path"]] <- purrr::map_chr(seq_along(fi_paths), function(i) { - path <- fi_paths[[i]] - # is local path? - if (!startsWith(path, prefix = "/vsi")) { + # Add token into paths URL + file_info <- slider::slide_dfr(file_info, function(fi) { + # Get tile path + path <- fi[["path"]] + # is file exists in local path? + if (file.exists(path)) { return(path) } - - path_prefix <- "/vsicurl/" - path <- stringr::str_replace(path, path_prefix, "") - - url_parsed <- .url_parse(path) - url_parsed[["query"]] <- utils::modifyList( - url_parsed[["query"]], token_parsed + # Remove gdaldriver from URL + gdal_driver <- "/vsicurl/" + path <- gsub(pattern = gdal_driver, replacement = "", x = path) + # Get token account (acc) and container (cnt) info + token_info <- .mpc_get_token_info(path) + # Is the token valid? + if (!.mpc_token_is_valid(available_tks, token_info)) { + token <- .mpc_new_token( + url = ms_endpoint, + token_info = token_info, + n_tries = n_tries, + sleep_time = sleep_time, + access_key = access_key + ) + available_tks <<- c(available_tks, token) + } + fi[["path"]] <- .mpc_sign_path(path, available_tks, token_info) + fi[["token_expires"]] <- .mpc_get_token_datetime( + available_tks, token_info ) - # remove the additional chars added by httr - new_path <- gsub("^://", "", .url_build(url_parsed)) - new_path <- paste0(path_prefix, new_path) - new_path + return(fi) }) - file_info[["token_expires"]] <- strptime( - x = res_content[["msft:expiry"]], - format = "%Y-%m-%dT%H:%M:%SZ" - ) - tile[["file_info"]][[1]] <- file_info - + tile[["file_info"]] <- list(file_info) return(tile) }) - return(cube) } #' @export diff --git a/R/api_source_mpc.R b/R/api_source_mpc.R index c68eb68a7..3365954a8 100644 --- a/R/api_source_mpc.R +++ b/R/api_source_mpc.R @@ -824,3 +824,128 @@ }) return(invisible(NULL)) } + +#' @title Get MPC token info +#' @name .mpc_get_token_info +#' @description Get token information about account and container in asset +#' path +#' @param path A character file path. +#' @return a list with account and container. +#' @keywords internal +#' @noRd +.mpc_get_token_info <- function(path) { + parsed_url <- .url_parse(path) + host_spplited <- strsplit( + x = parsed_url$hostname, split = ".", fixed = TRUE + ) + path_spplited <- strsplit(parsed_url$path, split = "/", fixed = TRUE) + # Based on planetary computer python library and rstac + token_info <- list( + acc = host_spplited[[1]][[1]], + cnt = path_spplited[[1]][[2]] + ) + return(token_info) +} + +#' @title Is there a valid token? +#' @name .mpc_token_is_valid +#' @description Check if there is a valid token +#' @param available_tks A list with all the tokens generated. +#' @param token_info A list with account and container. +#' @return a logical value. +#' @keywords internal +#' @noRd +.mpc_token_is_valid <- function(available_tks, token_info) { + acc <- token_info[["acc"]] + cnt <- token_info[["cnt"]] + acc %in% names(available_tks) && cnt %in% names(available_tks[[acc]]) +} + +#' @title Generate new token +#' @name .mpc_new_token +#' @description Generate new token based on account and container +#' @param url A character with the token endpoint. +#' @param token_info A list with account and container. +#' @param n_tries Number of attempts to download the same image. +#' @param sleep_time Numeric in seconds until the next requisition. +#' @param access_key A character with planetary computer access key. +#' @return a structure with account, container, token and expire time. +#' @keywords internal +#' @noRd +.mpc_new_token <- function(url, token_info, n_tries, sleep_time, access_key) { + acc <- token_info[["acc"]] + cnt <- token_info[["cnt"]] + # Generate new token + token_url <- paste(url, acc, cnt, sep = "/") + new_token <- NULL + while (is.null(new_token) && n_tries > 0) { + new_token <- tryCatch( + { + res <- .get_request( + url = token_url, + headers = list("Ocp-Apim-Subscription-Key" = access_key) + ) + res <- .response_check_status(res) + .response_content(res) + }, + error = function(e) { + return(NULL) + } + ) + + if (is.null(new_token)) { + Sys.sleep(sleep_time) + } + n_tries <- n_tries - 1 + } + + # check that token is valid + .check_that(.has(new_token)) + new_token <- list(structure(list(new_token), names = cnt)) + names(new_token) <- acc + return(new_token) +} + +#' @title Sign the asset path with new token +#' @name .mpc_sign_path +#' @description Sign the asset path with new token values. +#' @param path A character file path to be signed. +#' @param available_tks A list with all the tokens generated. +#' @param token_info A list with account and container. +#' @return a character with the path signed. +#' @keywords internal +#' @noRd +.mpc_sign_path <- function(path, available_tks, token_info) { + acc <- token_info[["acc"]] + cnt <- token_info[["cnt"]] + token <- available_tks[[acc]][[cnt]][["token"]] + token_parsed <- .url_parse_query(token) + + url_parsed <- .url_parse(path) + url_parsed[["query"]] <- utils::modifyList( + url_parsed[["query"]], token_parsed + ) + # remove the additional chars added by httr + new_path <- gsub("^://", "", .url_build(url_parsed)) + new_path <- paste0("/vsicurl/", new_path) + new_path +} + +#' @title Get the token expire value +#' @name .mpc_get_token_datetime +#' @description Get the datetime that corresponds the token expiration. +#' @param available_tks A list with all the tokens generated. +#' @param token_info A list with account and container. +#' @return a character datetime. +#' @keywords internal +#' @noRd +.mpc_get_token_datetime <- function(available_tks, token_info) { + acc <- token_info[["acc"]] + cnt <- token_info[["cnt"]] + token_res <- available_tks[[acc]][[cnt]] + + strptime( + x = token_res[["msft:expiry"]], + format = "%Y-%m-%dT%H:%M:%SZ" + ) +} From c2d294c8420018ec6ffb4566f33815610981b2ee Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Thu, 10 Apr 2025 15:09:55 -0300 Subject: [PATCH 074/122] improve syntax with lintr - part 1 --- DESCRIPTION | 1 + NAMESPACE | 5 +- R/api_accuracy.R | 16 +- R/api_apply.R | 50 ++--- R/api_band.R | 43 +++- R/api_bbox.R | 8 +- R/api_block.R | 6 +- R/api_check.R | 359 +++++++++---------------------- R/api_chunks.R | 8 +- R/api_classify.R | 33 ++- R/api_clean.R | 6 +- R/api_cluster.R | 7 +- R/api_csv.R | 5 +- R/api_cube.R | 245 +++++++++++---------- R/api_message.R | 10 + R/api_plot_raster.R | 4 + R/api_preconditions.R | 4 +- R/api_samples.R | 14 ++ R/api_source_local.R | 4 +- R/api_tibble.R | 3 +- R/sits-package.R | 2 +- R/sits_apply.R | 2 +- R/sits_bbox.R | 14 +- R/sits_classify.R | 23 +- R/sits_csv.R | 6 +- R/sits_detect_change.R | 2 +- R/sits_geo_dist.R | 8 +- R/sits_imputation.R | 2 +- R/sits_label_classification.R | 9 +- R/sits_labels.R | 2 +- R/sits_lighttae.R | 8 +- R/sits_merge.R | 1 + R/sits_plot.R | 59 +++-- R/sits_predictors.R | 20 +- R/sits_reclassify.R | 9 +- R/sits_reduce.R | 11 +- R/sits_reduce_imbalance.R | 10 +- R/sits_regularize.R | 20 +- R/sits_sample_functions.R | 38 ++-- R/sits_segmentation.R | 2 +- R/sits_select.R | 4 +- R/sits_sf.R | 25 ++- R/sits_smooth.R | 11 +- R/sits_stars.R | 12 +- R/sits_summary.R | 60 +++--- R/sits_tae.R | 9 +- R/sits_tempcnn.R | 24 +-- R/sits_terra.R | 30 +-- R/sits_texture.R | 7 +- R/sits_timeline.R | 17 +- R/sits_train.R | 4 +- R/sits_tuning.R | 6 +- R/sits_uncertainty.R | 13 +- R/sits_utils.R | 8 +- R/sits_validate.R | 10 +- R/sits_view.R | 58 ++--- R/sits_xlsx.R | 5 +- inst/extdata/config_messages.yml | 6 +- man/plot.raster_cube.Rd | 12 +- man/sits-package.Rd | 2 +- man/sits_as_sf.Rd | 3 + man/sits_classify.raster_cube.Rd | 3 +- man/sits_confidence_sampling.Rd | 8 +- man/sits_geo_dist.Rd | 2 +- man/sits_lighttae.Rd | 4 +- man/sits_regularize.Rd | 2 +- man/sits_smooth.Rd | 4 +- man/sits_train.Rd | 4 +- man/sits_uncertainty_sampling.Rd | 8 +- tests/testthat/test-accuracy.R | 9 +- tests/testthat/test-check.R | 2 +- tests/testthat/test-config.R | 11 +- tests/testthat/test-cube_copy.R | 1 - tests/testthat/test-raster.R | 3 +- tests/testthat/test-regularize.R | 2 +- 75 files changed, 635 insertions(+), 833 deletions(-) create mode 100644 R/api_message.R diff --git a/DESCRIPTION b/DESCRIPTION index e17bd1344..703579c34 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -146,6 +146,7 @@ Collate: 'api_merge.R' 'api_mixture_model.R' 'api_ml_model.R' + 'api_message.R' 'api_mosaic.R' 'api_opensearch.R' 'api_parallel.R' diff --git a/NAMESPACE b/NAMESPACE index 258b891f4..de1f7236f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,9 +17,6 @@ S3method(.accuracy_get_validation,sf) S3method(.accuracy_get_validation,shp) S3method(.band_rename,raster_cube) S3method(.band_rename,sits) -S3method(.check_samples,default) -S3method(.check_samples,sits) -S3method(.check_samples,tbl_df) S3method(.cube_adjust_crs,default) S3method(.cube_adjust_crs,grd_cube) S3method(.cube_as_sf,default) @@ -340,6 +337,7 @@ S3method(sits_apply,default) S3method(sits_apply,derived_cube) S3method(sits_apply,raster_cube) S3method(sits_apply,sits) +S3method(sits_as_sf,default) S3method(sits_as_sf,raster_cube) S3method(sits_as_sf,sits) S3method(sits_as_sf,vector_cube) @@ -475,6 +473,7 @@ S3method(summary,sits_area_accuracy) S3method(summary,variance_cube) export("sits_bands<-") export("sits_labels<-") +export(.check_samples.default) export(impute_linear) export(sits_accuracy) export(sits_accuracy_summary) diff --git a/R/api_accuracy.R b/R/api_accuracy.R index f5eef0e5b..54eda953c 100644 --- a/R/api_accuracy.R +++ b/R/api_accuracy.R @@ -18,7 +18,7 @@ .check_labels(ref) # build the tibble pred_ref <- tibble::tibble(predicted = pred, reference = ref) - return(pred_ref) + pred_ref } #' @title Support for Area-weighted post-classification accuracy @@ -49,12 +49,12 @@ # Create the error matrix error_matrix <- table( factor(pred, - levels = labels_cube, - labels = labels_cube + levels = labels_cube, + labels = labels_cube ), factor(ref, - levels = labels_cube, - labels = labels_cube + levels = labels_cube, + labels = labels_cube ) ) # Get area for each class of the cube @@ -65,9 +65,9 @@ diff_classes <- setdiff(rownames(error_matrix), names(area)) if (length(diff_classes) > 0 && length(diff_classes) < length(rownames(error_matrix))) { - warning(.conf("messages", ".accuracy_area_assess"), - call. = FALSE - ) + warning(.conf("messages", ".accuracy_area_assess"), + call. = FALSE + ) # Create a numeric vector with zeros vec_areas <- rep(0, length(diff_classes)) names(vec_areas) <- diff_classes diff --git a/R/api_apply.R b/R/api_apply.R index 9d06ad187..dab970cbd 100644 --- a/R/api_apply.R +++ b/R/api_apply.R @@ -32,7 +32,7 @@ names(x) <- col # prepare result data[[col]] <- x[[col]] - return(data) + data } #' @title Apply an expression to block of a set of input bands #' @name .apply_feature @@ -116,13 +116,13 @@ ) ) # Prepare fractions to be saved - offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { - values <- values - offset + band_offset <- .offset(band_conf) + if (.has(band_offset) && band_offset != 0.0) { + values <- values - band_offset } - scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { - values <- values / scale + band_scale <- .scale(band_conf) + if (.has(band_scale) && band_scale != 1.0) { + values <- values / band_scale } # Job crop block crop_block <- .block(.chunks_no_overlap(chunk)) @@ -198,17 +198,14 @@ #' .apply_across <- function(data, fn, ...) { # Pre-conditions - data <- .check_samples(data) - - result <- - .apply(data, col = "time_series", fn = function(x, ...) { - dplyr::mutate(x, dplyr::across( - dplyr::matches(.samples_bands(data)), - fn, ... - )) - }, ...) - - return(result) + .check_samples(data) + # apply function + .apply(data, col = "time_series", fn = function(x, ...) { + dplyr::mutate(x, dplyr::across( + dplyr::matches(.samples_bands(data)), + fn, ... + )) + }, ...) } #' @title Captures a band expression #' @name .apply_capture_expression @@ -221,9 +218,10 @@ #' .apply_capture_expression <- function(...) { # Capture dots as a list of quoted expressions - list_expr <- lapply(substitute(list(...), env = environment()), - unlist, - recursive = FALSE + list_expr <- lapply( + substitute(list(...), env = environment()), + unlist, + recursive = FALSE )[-1] # Check bands names from expression @@ -232,8 +230,7 @@ # Get out band out_band <- toupper(gsub("_", "-", names(list_expr), fixed = TRUE)) names(list_expr) <- out_band - - return(list_expr) + list_expr } #' @title Finds out all existing bands in an expression #' @name .apply_input_bands @@ -255,11 +252,9 @@ # Select bands that are in input expression bands <- bands[bands %in% expr_bands] - # Post-condition .check_that(all(expr_bands %in% bands)) - - return(bands) + bands } #' @title Returns all names in an expression #' @name .apply_get_all_names @@ -333,6 +328,5 @@ ) } ), parent = parent.env(environment()), hash = TRUE) - - return(result_env) + result_env } diff --git a/R/api_band.R b/R/api_band.R index 8eefe9d98..3995e5112 100644 --- a/R/api_band.R +++ b/R/api_band.R @@ -31,8 +31,7 @@ # rename new_bands[data_bands] <- toupper(bands) colnames(x) <- unname(new_bands) - - return(x) + x }) } #' @title Rename bands for data cube (S3 Generic function) @@ -120,10 +119,35 @@ bands <- toupper(bands) } } - return(bands) + bands +} +#' @title Set reasonable bands for visualisation +#' @name .band_set_bw_rgb +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @param cube cube to choose band +#' @param band B/W band for view +#' @param red Red band for view +#' @param green Green band for view +#' @param blue Blue band for view +#' @return vector with bands +#' @keywords internal +#' @noRd +.band_set_bw_rgb <- function(cube, band, red, green, blue) { + .check_set_caller(".band_set_bw_rgb") + # check band is available + if (.has(band)) { + .check_that(band %in% .cube_bands(cube)) + return(band) + } else if (.has(red) && .has(green) && .has(blue)) { + # check bands are available + bands <- c(red, green, blue) + .check_that(all(bands %in% .cube_bands(cube))) + return(bands) + } + .band_best_guess(cube) } #' @title Make a best guess on bands to be displayed -#' @name .band_set_case +#' @name .band_best_guess #' @description if user did not provide band names, #' try some reasonable color composites. #' A full list of color composites is available @@ -131,14 +155,14 @@ #' @noRd #' @param cube data cube #' @return band names to be displayed -.bands_best_guess <- function(cube){ +.band_best_guess <- function(cube) { # get all bands in the cube cube_bands <- .cube_bands(cube) # get source and collection for the cube - source <- .cube_source(cube) + cube_source <- .cube_source(cube) collection <- .cube_collection(cube) # find which are possible color composites for the cube - comp_source <- sits_env[['composites']][["sources"]][[source]] + comp_source <- sits_env[["composites"]][["sources"]][[cube_source]] composites <- comp_source[["collections"]][[collection]] # for each color composite (in order) # see if bands are available @@ -149,7 +173,8 @@ } # if composites fail, try NDVI if ("NDVI" %in% cube_bands) - return("NDVI") + "NDVI" # return the first band if all fails - else return(cube_bands[[1]]) + else + cube_bands[[1]] } diff --git a/R/api_bbox.R b/R/api_bbox.R index 31fc4e5a7..dadad3b54 100644 --- a/R/api_bbox.R +++ b/R/api_bbox.R @@ -9,9 +9,9 @@ #' @param tolerance Tolerance (numerical value) #' @return A logical value #' -.bbox_equal <- function(bbox1, bbox2, tolerance = 0) { +.bbox_equal <- function(bbox1, bbox2, tolerance = 0.0) { .is_eq(unlist(bbox1[.bbox_cols]), unlist(bbox2[.bbox_cols]), - tolerance = tolerance + tolerance = tolerance ) } #' @title Bounding box API @@ -74,7 +74,7 @@ NULL #' @returns One of the arguments passed in `...` according to a bbox type. .bbox_switch <- function(x, ...) { switch(.bbox_type(x), - ... + ... ) } #' @title Extract a bbox @@ -231,5 +231,5 @@ NULL crs_sf <- sf::st_crs(wkt_crs) # Convert sf CRS object to PROJ4 string proj4string <- crs_sf[["proj4string"]] - return(proj4string) + proj4string } diff --git a/R/api_block.R b/R/api_block.R index 2624fd1a1..061ced5a7 100644 --- a/R/api_block.R +++ b/R/api_block.R @@ -26,10 +26,10 @@ NULL if (!.has_block(x)) { return(NULL) } - col <- .default(x = .col(x), default = 1) - row <- .default(x = .row(x), default = 1) + xcol <- .default(x = .col(x), default = 1) + xrow <- .default(x = .row(x), default = 1) # Return a block - .common_size(col = col, row = row, ncols = .ncols(x), nrows = .nrows(x)) + .common_size(col = xcol, row = xrow, ncols = .ncols(x), nrows = .nrows(x)) } #' @title Compute block size in pixels #' @noRd diff --git a/R/api_check.R b/R/api_check.R index ba77e791a..928b2a1ef 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -97,7 +97,6 @@ envir <- sys.frame(-1) } assign(".check_caller", caller, envir = envir) - return(invisible(caller)) } #' @rdname check_functions #' @name .check_identify_caller @@ -122,7 +121,6 @@ pattern = "^(.*)\\(.*$", replacement = "\\1", x = paste(caller)[[1]] ) - return(caller) } #' @rdname check_functions #' @noRd @@ -205,7 +203,6 @@ # process message stop(msg, call. = FALSE) } - return(invisible(x)) } #' @rdname check_functions #' @keywords internal @@ -218,7 +215,6 @@ local_msg = local_msg, msg = msg ) - return(invisible(x)) } #' @rdname check_functions #' @keywords internal @@ -231,7 +227,6 @@ msg = msg ) } - return(invisible(x)) } #' @rdname check_functions @@ -256,7 +251,7 @@ .check_that( length(names(x)) == length(unique(names(x))), local_msg = local_msg, - msg = .conf("messages", ".check_names_unique" ) + msg = .conf("messages", ".check_names_unique") ) } } else { @@ -266,7 +261,6 @@ msg = .conf("messages", ".check_names_is_unnamed") ) } - return(invisible(x)) } #' @rdname check_functions #' @keywords internal @@ -281,7 +275,6 @@ local_msg = local_msg, msg = msg ) - return(invisible(x)) } #' @rdname check_functions #' @keywords internal @@ -294,7 +287,6 @@ ) # check all elements lapply(x, fn_check, ...) - return(invisible(x)) } #' @rdname check_functions #' @@ -335,7 +327,6 @@ local_msg = local_msg, msg = msg ) - return(invisible(x)) } #' @rdname check_functions #' @keywords internal @@ -361,7 +352,6 @@ msg = msg ) } - return(invisible(x)) } #' @rdname check_functions #' @keywords internal @@ -374,7 +364,6 @@ local_msg = local_msg, msg = msg ) - return(invisible(x)) } #' @rdname check_functions @@ -388,7 +377,6 @@ local_msg = local_msg, msg = msg ) - return(invisible(x)) } #' @rdname check_functions #' @@ -453,7 +441,6 @@ } # check names .check_names(x, is_named = is_named, local_msg = local_msg, msg = msg) - return(invisible(x)) } #' @rdname check_functions #' @keywords internal @@ -504,8 +491,6 @@ ) if (is_odd) .check_that(x %% 2 != 0, msg = msg) - - return(invisible(x)) } #' @rdname check_functions #' @keywords internal @@ -527,7 +512,6 @@ .check_num_type(x = tolerance, local_msg = local_msg, msg = msg) # remove NAs before check to test tolerance - result <- x x <- x[!is.na(x)] # adjust min and max to tolerance if (!is.null(tolerance)) { @@ -565,7 +549,6 @@ local_msg = local_msg, msg = paste0("value should be < ", exclusive_max) ) - return(invisible(result)) } #' @rdname check_functions #' @keywords internal @@ -614,11 +597,12 @@ ) } # check names - .check_names(x, - is_named = is_named, - is_unique = has_unique_names, - local_msg = local_msg, - msg = msg + .check_names( + x, + is_named = is_named, + is_unique = has_unique_names, + local_msg = local_msg, + msg = msg ) # check regular expression pattern if (!is.null(regex)) { @@ -628,7 +612,6 @@ msg = msg ) } - return(invisible(x)) } #' @rdname check_functions #' @keywords internal @@ -644,7 +627,6 @@ # check for null and exit if it is allowed if (allow_null && is.null(x)) { - return(invisible(x)) } # check NULL .check_null(x, local_msg = local_msg, msg = msg) @@ -660,7 +642,6 @@ .check_apply(x, fn_check = fn_check, local_msg = local_msg, msg = msg, ...) } - return(invisible(x)) } #' @rdname check_functions #' @@ -712,18 +693,19 @@ # check parameter name param_x <- deparse(substitute(x, environment())) # make default message - local_msg_x <- .check_var_message(param_x) + local_msg_x <- .message_invalid_param(param_x) # check within name param_w <- deparse(substitute(within, environment())) # make default message - local_msg_w <- .check_var_message(param_w) + local_msg_w <- .message_invalid_param(param_w) # pre-condition - .check_chr(within, - len_min = 1, - local_msg = local_msg_w, - msg = msg + .check_chr( + within, + len_min = 1, + local_msg = local_msg_w, + msg = msg ) # check parameters .check_discriminator(discriminator) @@ -737,7 +719,6 @@ msg = msg ) } - result <- x # simplify x <- unique(x) within <- unique(within) @@ -778,7 +759,6 @@ msg = msg ) } - return(invisible(result)) } #' @rdname check_functions #' @keywords internal @@ -793,13 +773,13 @@ # check parameter name var_x <- deparse(substitute(x, environment())) # make default message for param - local_msg_x <- .check_var_message(var_x) + local_msg_x <- .message_invalid_param(var_x) # check type .check_chr_type(x, local_msg = local_msg_x) # check contains name var_cont <- deparse(substitute(contains, environment())) # make default message for param - local_msg_cont <- .check_var_message(var_cont) + local_msg_cont <- .message_invalid_param(var_cont) # pre-condition .check_that(length(contains) >= 1, local_msg = local_msg_cont) # check discriminators @@ -812,7 +792,6 @@ msg = msg ) } - result <- x # simplify x <- unique(x) contains <- unique(contains) @@ -853,7 +832,6 @@ msg = msg ) } - return(invisible(result)) } #' @rdname check_functions #' @@ -874,9 +852,9 @@ local_msg = NULL, msg = NULL) { # check parameter name - var <- deparse(substitute(x, environment())) + parameter_name <- deparse(substitute(x, environment())) # make default message for param - local_msg <- .check_var_message(var) + local_msg <- .message_invalid_param(parameter_name) # file extension ext_file <- function(x) { @@ -888,13 +866,14 @@ } if (is.null(msg)) # check parameter - .check_chr(x, - allow_na = FALSE, - allow_empty = FALSE, - len_min = 1, - allow_null = FALSE, - local_msg = local_msg, - msg = msg + .check_chr( + x, + allow_na = FALSE, + allow_empty = FALSE, + len_min = 1, + allow_null = FALSE, + local_msg = local_msg, + msg = msg ) # check extension if (!is.null(extensions)) { @@ -909,8 +888,7 @@ all(existing_files | existing_dirs), local_msg = local_msg, msg = paste(.conf("messages", ".check_file_missing"), - paste0("'", x[!existing_files], "'", - collapse = ", " + paste0("'", x[!existing_files], "'", collapse = ", " ) ) ) @@ -921,7 +899,7 @@ msg = .conf("messages", ".check_file_writable") ) } - return(invisible(x)) + invisible(x) } #' @title Check environment variable #' @name .check_env_var @@ -935,12 +913,12 @@ local_msg = NULL, msg = NULL) { # check parameter name - var <- deparse(substitute(x, environment())) + parameter_name <- deparse(substitute(x, environment())) # make default message for param - local_msg <- .check_var_message(var) + local_msg <- .message_invalid_param(parameter_name) # check env var exists .check_that(nchar(Sys.getenv(x)) > 0, local_msg = local_msg) - return(invisible(x)) + invisible(x) } #' @title Check warning #' @name .check_warn @@ -960,7 +938,7 @@ warning(e[["message"]], call. = FALSE) } ) - return(invisible(result)) + invisible(result) } #' @title Check error #' @name .check_error @@ -976,7 +954,7 @@ #' @noRd .check_error <- function(expr, ..., msg = NULL) { - result <- tryCatch( + tryCatch( { expr }, @@ -984,7 +962,6 @@ .check_that(FALSE, local_msg = e[["message"]], msg = msg) } ) - return(invisible(result)) } #' @rdname check_functions #' @keywords internal @@ -994,24 +971,24 @@ .check_na_parameter(x) # check for NULL .check_null_parameter(x) - return(invisible(x)) + invisible(x) } #' @rdname check_functions #' @name .check_null_parameter #' @param x parameter to be checked #' @keywords internal #' @noRd -.check_null_parameter <- function(x, ..., - msg = NULL) { +.check_null_parameter <- function(x, ..., msg = NULL) { # check parameter name param <- deparse(substitute(x, environment())) local_msg <- paste("NULL value not allowed for", param) # check that value is not NULL - .check_that(!is.null(x), - local_msg = local_msg, - msg = msg + .check_that( + !is.null(x), + local_msg = local_msg, + msg = msg ) - return(invisible(x)) + invisible(x) } #' @rdname check_functions #' @keywords internal @@ -1027,7 +1004,7 @@ msg = msg ) } - return(invisible(x)) + invisible(x) } #' @title Check is numerical parameter is valid using reasonable defaults #' @name .check_num_parameter @@ -1056,7 +1033,7 @@ msg = NULL) { # check parameter name param <- deparse(substitute(x, environment())) - local_msg <- .check_param_message(param) + local_msg <- .message_invalid_param(param) .check_num( x, allow_na = allow_na, @@ -1071,7 +1048,7 @@ local_msg = local_msg, msg = msg ) - return(invisible(x)) + invisible(x) } #' @title Check is logical parameter is valid #' @name .check_lgl_parameter @@ -1093,7 +1070,7 @@ # check parameter name param <- deparse(substitute(x, environment())) # make default message - local_msg <- .check_param_message(param) + local_msg <- .message_invalid_param(param) .check_lgl( x, len_min = len_min, @@ -1104,7 +1081,7 @@ local_msg = local_msg, msg = msg ) - return(invisible(x)) + invisible(x) } #' @title Check is date is valid #' @name .check_date_parameter @@ -1125,7 +1102,7 @@ pattern_rfc <- "^\\d{4}-\\d{2}-\\d{2}$" # check dates are valid .check_that(all(grepl(pattern_rfc, x, perl = TRUE))) - return(invisible(x)) + invisible(x) } #' @title Check is integer parameter is valid using reasonable defaults #' @name .check_int_parameter @@ -1147,7 +1124,7 @@ # check parameter name param <- deparse(substitute(x, environment())) # make default message - local_msg <- .check_param_message(param) + local_msg <- .message_invalid_param(param) .check_num( x, allow_na = FALSE, @@ -1162,7 +1139,7 @@ local_msg = local_msg, msg = msg ) - return(invisible(x)) + invisible(x) } #' @title Check is integer parameter is valid using reasonable defaults #' @name .check_chr_parameter @@ -1192,7 +1169,7 @@ # check parameter name param <- deparse(substitute(x, environment())) # make default message - local_msg <- .check_param_message(param) + local_msg <- .message_invalid_param(param) .check_chr( x, len_min = len_min, @@ -1205,22 +1182,22 @@ local_msg = local_msg, msg = msg ) - return(invisible(x)) + invisible(x) } #' @rdname check_functions #' @keywords internal #' @noRd .check_lst_parameter <- function(x, ..., - len_min = 1, - len_max = 2^31 - 1, - allow_null = FALSE, - is_named = TRUE, - fn_check = NULL, - msg = NULL) { + len_min = 1, + len_max = 2^31 - 1, + allow_null = FALSE, + is_named = TRUE, + fn_check = NULL, + msg = NULL) { # check parameter name param <- deparse(substitute(x, environment())) # make default message - local_msg <- .check_param_message(param) + local_msg <- .message_invalid_param(param) # check for null and exit if it is allowed if (allow_null && is.null(x)) { @@ -1241,7 +1218,7 @@ .check_apply(x, fn_check = fn_check, local_msg = local_msg, msg = msg, ...) } - return(invisible(x)) + invisible(x) } #' @title Check is period parameter is valid #' @name .check_period @@ -1264,7 +1241,7 @@ # is this a valid date? dates <- as.Date(dates) .check_that(all(dates %in% .tile_timeline(tile))) - return(invisible(dates)) + invisible(dates) } #' @title Check is crs parameter is valid #' @name .check_crs @@ -1276,7 +1253,6 @@ .check_set_caller(".check_crs") crs <- suppressWarnings(.try(sf::st_crs(crs), .default = NA)) .check_that(!is.na(crs)) - return(invisible(crs)) } #' @title Check is output_dir parameter is valid using reasonable defaults #' @name .check_output_dir @@ -1296,7 +1272,6 @@ ) output_dir <- .file_path_expand(output_dir) .check_file(output_dir) - return(invisible(output_dir)) } #' @title Check is version parameter is valid using reasonable defaults #' @name .check_version @@ -1316,7 +1291,6 @@ ) # avoids use of underscores version <- tolower(gsub("_", "-", version)) - return(version) } #' @title Check is version parameter is valid using reasonable defaults #' @name .check_progress @@ -1333,7 +1307,6 @@ allow_na = FALSE, allow_null = FALSE ) - return(invisible(progress)) } #' @title Check is function parameters is valid using reasonable defaults #' @name .check_function @@ -1342,9 +1315,7 @@ #' @param fn a function parameter #' @return Called for side effects. .check_function <- function(fn) { - if (.has(fn)) - .check_that(x = is.function(fn)) - return(invisible(fn)) + .check_that(is.function(fn)) } #' @title Check is expression parameter is valid using reasonable defaults #' @name .check_expression @@ -1353,11 +1324,11 @@ #' @keywords internal #' @noRd .check_expression <- function(list_expr) { - .check_lst(list_expr, - len_min = 1, len_max = 1, - msg = .conf("messages", ".check_expression") + .check_lst( + list_expr, + len_min = 1, len_max = 1, + msg = .conf("messages", ".check_expression") ) - return(invisible(list_expr)) } #' @title Does the result have the same number of pixels as the input values? #' @name .check_processed_values @@ -1371,7 +1342,6 @@ .check_that( !(is.null(nrow(values))) && nrow(values) == input_pixels ) - return(invisible(values)) } #' @title Does the result have the same number of labels as the input values? #' @name .check_processed_labels @@ -1385,31 +1355,7 @@ .check_that(ncol(values) == n_labels) } #' @title Prepare default message for invalid parameter -#' @name .check_param_message -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @param param parameter name -#' @param msg message to be issued -#' @return A valid message -#' @keywords internal -#' @noRd -.check_param_message <- function(param) { - # make default message - msg <- paste0("invalid ", param, " parameter") - return(msg) -} #' @title Prepare default message for variable -#' @name .check_var_message -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @param var parameter name -#' @param msg message to be issued -#' @return A valid message -#' @keywords internal -#' @noRd -.check_var_message <- function(var) { - # make default message - msg <- paste0("invalid ", var, " variable") - return(msg) -} #' @title Does the input data contain a set of predicted values? #' @name .check_predicted #' @param data a sits tibble @@ -1426,7 +1372,6 @@ x = .conf("ts_predicted_cols"), within = names(data[["predicted"]][[1]]) ) - return(invisible(data)) } #' @title Does the input data contain a raster cube? #' @name .check_is_raster_cube @@ -1438,7 +1383,6 @@ # set caller to show in errors .check_set_caller(".check_is_raster_cube") .check_that(inherits(cube, "raster_cube")) - return(invisible(cube)) } #' @title Does the input data contain a vector cube? #' @name .check_is_vector_cube @@ -1450,9 +1394,7 @@ # set caller to show in errors .check_set_caller(".check_is_vector_cube") .check_that(inherits(cube, "vector_cube")) - return(invisible(cube)) } - #' @title Check if cube is a probs cube #' @name .check_is_probs_cube #' @param cube a sits cube to be tested @@ -1463,7 +1405,6 @@ # set caller to show in errors .check_set_caller(".check_is_probs_cube") .check_that(inherits(cube, "probs_cube")) - return(invisible(cube)) } #' @title Check if cube is a variance cube #' @name .check_is_variance_cube @@ -1476,7 +1417,6 @@ # set caller to show in errors .check_set_caller(".check_is_variance_cube") .check_that(inherits(cube, "variance_cube")) - return(invisible(cube)) } #' @title Check if cube is a uncert cube #' @name .check_is_uncert_cube @@ -1487,7 +1427,6 @@ .check_is_uncert_cube <- function(cube) { .check_set_caller(".check_is_uncert_cube") .check_that(inherits(cube, "uncertainty_cube")) - return(invisible(cube)) } #' @title Check if cube is a classified image #' @name .check_is_class_cube @@ -1498,7 +1437,6 @@ .check_is_class_cube <- function(cube) { .check_set_caller(".check_is_class_cube") .check_that(inherits(cube, "class_cube")) - return(invisible(cube)) } #' @title Check if cube is a results cube #' @name .check_is_results_cube @@ -1515,6 +1453,7 @@ } else { results_cube <- FALSE } + .check_that(.has(bands) && all(bands %in% .conf("sits_results_bands"))) # results cube should have only one band if (results_cube) { .check_that(length(bands) == 1) @@ -1538,8 +1477,27 @@ msg = .conf("messages", ".check_is_results_cube_class") ) } + # is label parameter was provided in labelled cubes? + if (bands %in% c("probs", "bayes")) { + .check_chr( + labels, + len_min = 1, + allow_duplicate = FALSE, + is_named = TRUE, + msg = .conf("messages", ".check_is_results_cube_probs") + ) + } + # labels should be named in class cubes? + if (bands == "class") { + .check_length( + labels, + len_min = 2, + is_named = TRUE, + msg = .conf("messages", ".check_is_results_cube_class") + ) + } + return(results_cube) } - return(results_cube) } #' @title Check that cube is regular #' @name .check_cube_is_regular @@ -1550,7 +1508,6 @@ .check_cube_is_regular <- function(cube) { .check_set_caller(".check_cube_is_regular") .check_that(.cube_is_regular(cube)) - return(invisible(TRUE)) } #' @title Does the input data contain a sits accuracy object? #' @name .check_is_sits_accuracy @@ -1561,7 +1518,6 @@ .check_is_sits_accuracy <- function(data) { .check_set_caller(".check_is_sits_accuracy") .check_that(inherits(data, what = "sits_accuracy")) - return(invisible(data)) } #' @title Does the input data contain a sits model? #' @name .check_is_sits_model @@ -1575,7 +1531,6 @@ # Check model samples samples <- .ml_samples(model) .check_samples(samples) - return(invisible(model)) } #' @title Does the data contain the cols of sample data and is not empty? #' @name .check_samples @@ -1587,33 +1542,8 @@ # set caller to show in errors .check_set_caller(".check_samples") .check_na_null_parameter(data) - UseMethod(".check_samples", data) -} -#' @title Does the data contain the cols of time series? -#' @name .check_samples.sits -#' @param data a sits tibble -#' @return Called for side effects. -#' @keywords internal -#' @noRd -#' @export -.check_samples.sits <- function(data) { - .check_that(all(.conf("df_sample_columns") %in% colnames(data))) - .check_that(nrow(data) > 0) - return(invisible(data)) -} -#' @title Does the tibble contain the cols of time series? -#' @name .check_samples.tbl_df -#' @param data a sits tibble -#' @return Called for side effects. -#' @keywords internal -#' @noRd -#' @export -.check_samples.tbl_df <- function(data) { - data <- tibble::as_tibble(data) .check_that(all(.conf("df_sample_columns") %in% colnames(data))) .check_that(nrow(data) > 0) - class(data) <- c("sits", class(data)) - return(invisible(data)) } #' @title Does the input contain the cols of time series? #' @name .check_samples.default @@ -1626,11 +1556,11 @@ if (is.list(data)) { class(data) <- c("list", class(data)) data <- tibble::as_tibble(data) - data <- .check_samples(data) - } else { - stop(.conf("messages", ".check_samples_default")) + .check_samples(data) + data <- .samples_convert_to_sits (data) + return(data) } - return(invisible(data)) + stop(.conf("messages", ".check_samples_default")) } #' @rdname check_functions #' @keywords internal @@ -1644,8 +1574,7 @@ return(NULL) }) # return error if data is not accessible - .check_that(!(is.null(rast))) - return(invisible(x)) + .check_that(.has(rast)) } #' @title Does input data has time series? #' @name .check_samples_ts @@ -1655,14 +1584,12 @@ #' @noRd .check_samples_ts <- function(data) { .check_set_caller(".check_samples_ts") - data <- .check_samples(data) + .check_samples(data) .check_that("time_series" %in% colnames(data)) # check there is an Index column .check_samples_ts_index(data) # check if all samples have the same bands .check_samples_ts_bands(data) - - return(invisible(data)) } #' @title Is there an index column in the time series? #' @name .check_samples_ts_index @@ -1673,11 +1600,9 @@ .check_samples_ts_index <- function(data) { .check_set_caller(".check_samples_ts_index") # Get unnested time series - ts <- .samples_ts(data) + ts_data <- .samples_ts(data) # check there is an Index column - .check_that(x = "Index" %in% colnames(ts)) - - return(invisible(data)) + .check_that(x = "Index" %in% colnames(ts_data)) } #' @title Are the bands in the time series the same? #' @name .check_samples_ts_bands @@ -1690,8 +1615,6 @@ # check if all samples have the same bands n_bands <- unique(lengths(data[["time_series"]])) .check_that(length(n_bands) == 1) - - return(invisible(data)) } #' @title Can the input data be used for training? #' @name .check_samples_train @@ -1701,18 +1624,18 @@ #' @noRd .check_samples_train <- function(data) { .check_set_caller(".check_samples_train") - data <- .check_samples_ts(data) + .check_samples_ts(data) # check that there is no NA in labels - labels <- .samples_labels(data) - .check_that(!("NoClass" %in% labels) && !("" %in% labels) && - !anyNA(labels)) + sample_labels <- .samples_labels(data) + .check_that(!("NoClass" %in% sample_labels) && + !("" %in% sample_labels) && + !anyNA(sample_labels)) # Get unnested time series ts <- .ts(data) # check there are no NA in distances .check_that(!(anyNA(ts))) # check samples timeline .check_samples_timeline(data) - return(invisible(data)) } #' @title Is the samples_validation object valid? #' @name .check_samples_validation @@ -1729,7 +1652,7 @@ bands) { .check_set_caller(".check_samples_validation") # check if the validation samples are ok - samples_validation <- .check_samples(samples_validation) + .check_samples(samples_validation) # check if the labels matches with train data .check_that( all(.samples_labels(samples_validation) %in% labels) && @@ -1744,7 +1667,6 @@ all(.samples_bands(samples_validation) %in% bands) && all(bands %in% .samples_bands(samples_validation)) ) - return(invisible(samples_validation)) } #' @title Do the samples contain a cluster column? #' @name .check_samples_cluster @@ -1755,10 +1677,9 @@ # Are the samples valid? .check_samples_cluster <- function(data) { .check_set_caller(".check_samples_cluster") - data <- .check_samples(data) + .check_samples(data) # is the input data the result of a cluster function? .check_that("cluster" %in% names(data)) - return(invisible(data)) } #' @title Do the samples contain a valid timeline? #' @name .check_samples_timeline @@ -1774,7 +1695,6 @@ simplify = FALSE ), use.names = FALSE)) .check_that(length(n_times) == 1) - return(invisible(data)) } #' @title Is the object a valid point? #' @name .check_point @@ -1805,7 +1725,6 @@ else n_bands_base <- 0 .check_that(ncol(pred) == 2 + n_bands * n_times + n_bands_base) - return(invisible(pred)) } #' @title Does the data contain the cols of sample data and is not empty? #' @name .check_smoothness @@ -1817,7 +1736,6 @@ .check_smoothness <- function(smoothness, nlabels) { .check_set_caller(".check_smoothness") .check_that(length(smoothness) == 1 || length(smoothness) == nlabels) - return(invisible(smoothness)) } #' @title Check if data contains predicted and reference values #' @name .check_pred_ref_match @@ -1829,7 +1747,6 @@ .check_pred_ref_match <- function(reference, predicted) { .check_set_caller(".check_pred_ref_match") .check_that(length(reference) == length(predicted)) - return(invisible(reference)) } #' @title Do the samples and tile match timelines? #' @name .check_samples_tile_match_timeline @@ -1844,7 +1761,6 @@ samples_timeline_length <- length(.samples_timeline(samples)) tiles_timeline_length <- length(.tile_timeline(tile)) .check_that(samples_timeline_length == tiles_timeline_length) - return(invisible(samples)) } #' @title Do the samples and tile match bands? #' @name .check_samples_tile_match_bands @@ -1859,7 +1775,6 @@ tile_bands <- .tile_bands(tile) bands <- .samples_bands(samples) .check_that(all(bands %in% tile_bands)) - return(invisible(samples)) } #' @title Does the input data contains valid reference labels? #' @name .check_labels @@ -1870,7 +1785,6 @@ .check_labels <- function(data) { .check_set_caller(".check_labels") .check_that(!("NoClass" %in% data)) - return(invisible(data)) } #' @name .check_labels_named #' @param data vector with labels @@ -1880,7 +1794,6 @@ .check_labels_named <- function(data) { .check_set_caller(".check_labels_named") .check_chr(data, len_min = 1, is_named = TRUE) - return(invisible(data)) } #' @title Does the class cube contain enough labels? #' @name .check_labels_class_cube @@ -1907,7 +1820,6 @@ labels_num <- names(unlist(.cube_labels(cube, dissolve = FALSE))) # do the labels and raster numbers match? .check_that(all(classes_num %in% labels_num)) - return(invisible(cube)) } #' @title Does the probs cube contains required labels? #' @name .check_labels_probs_cube @@ -1918,10 +1830,8 @@ #' @noRd .check_labels_probs_cube <- function(cube, labels) { .check_set_caller(".check_labels_probs_cube") - # check that the labels are part of the cube .check_that(all(labels %in% .cube_labels(cube))) - return(invisible(cube)) } #' @title Check if an object is a bbox #' @noRd @@ -1929,7 +1839,6 @@ .check_bbox <- function(x) { .check_set_caller(".check_bbox") .check_that(setequal(names(x), c(.bbox_cols, "crs"))) - return(invisible(x)) } #' @title Check if roi is specified correcty #' @name .check_roi @@ -1951,7 +1860,6 @@ .check_that(all(names_ll %in% roi_names) || all(names_x %in% roi_names) ) - return(invisible(roi)) } #' @title Check if roi or tiles are provided #' @name .check_roi_tiles @@ -1965,7 +1873,6 @@ .check_set_caller(".check_roi_tiles") # Ensures that only a spatial filter is informed .check_that(xor(is.null(roi), is.null(tiles))) - return(invisible(roi)) } #' @title Check if grid system is supported #' @name .check_grid_system @@ -1984,7 +1891,6 @@ can_repeat = FALSE, msg = .conf("messages", ".check_grid_system") ) - return(invisible(grid_system)) } #' @title Check if bands are part of a data cube @@ -2002,7 +1908,6 @@ bands <- toupper(bands) cube_bands <- toupper(.cube_bands(cube = cube, add_cloud = add_cloud)) .check_that(all(bands %in% cube_bands)) - return(invisible(cube)) } #' @title Check if tiles are part of a data cube #' @name .check_cube_tiles @@ -2017,7 +1922,6 @@ # set caller to show in errors .check_set_caller(".check_cube_tiles") .check_that(all(tiles %in% .cube_tiles(cube))) - return(invisible(cube)) } #' @title Check if all rows in a cube has the same bands #' @name .check_cube_row_same_bands @@ -2058,7 +1962,6 @@ } ) .check_that(all(ok)) - return(invisible(cube1)) } #' @title Check if cubes have the same size #' @name .check_cubes_same_size @@ -2074,7 +1977,6 @@ all(.cube_ncols(cube1) == .cube_ncols(cube2)) && all(.cube_nrows(cube1) == .cube_nrows(cube2)) ) - return(invisible(cube1)) } #' @title Check if cubes have the same tiles @@ -2088,7 +1990,6 @@ .check_cubes_same_tiles <- function(cube1, cube2) { .check_set_caller(".check_cubes_same_tiles") .check_that(nrow(cube1) == nrow(cube2)) - return(invisible(cube1)) } #' @title Check if cubes have the same labels #' @name .check_cubes_same_labels @@ -2104,7 +2005,6 @@ all(.cube_labels(cube1) %in% .cube_labels(cube2)) && all(.cube_labels(cube2) %in% .cube_labels(cube1)) ) - return(invisible(cube1)) } #' @title Check if cubes have the same timeline #' @name .check_cubes_same_timeline @@ -2117,7 +2017,6 @@ .check_cubes_same_timeline <- function(cube1, cube2) { .check_set_caller(".check_cubes_same_timeline") .check_that(all(.cube_timeline(cube1)[[1]] == .cube_timeline(cube2)[[1]])) - return(invisible(cube1)) } #' @title Check if two cubes have the same organization #' @name .check_cubes_match @@ -2135,7 +2034,6 @@ .check_cubes_same_bbox(cube1, cube2) .check_cubes_same_timeline(cube1, cube2) .check_cubes_same_labels(cube1, cube2) - return(invisible(cube1)) } #' @title Check if list of probs cubes have the same organization #' @name .check_probs_cube_lst @@ -2155,7 +2053,6 @@ for (i in c(2:length(cubes))) { .check_cubes_match(first, cubes[[i]]) } - return(invisible(cubes)) } #' @title Check if list of uncertainty cubes have the same organization #' @name .check_uncert_cube_lst @@ -2175,7 +2072,6 @@ for (i in c(2:length(uncert_cubes))) { .check_cubes_same_size(first, uncert_cubes[[i]]) } - return(invisible(uncert_cubes)) } #' @title Check if errox matrix and area are cosrrect #' @name .check_error_matrix_area @@ -2208,7 +2104,6 @@ x = all(names(area) %in% colnames(error_matrix)), msg = .conf("messages", ".check_error_matrix_labels") ) - return(invisible(error_matrix)) } #' @title Checks if the required packages are installed #' @name .check_require_packages @@ -2228,7 +2123,6 @@ all(are_packages_installed), msg = paste(msg, x[!are_packages_installed]) ) - return(invisible(x)) } #' @title Checks if the tibble/data.frame is empty #' @name .check_empty_data_frame @@ -2240,7 +2134,6 @@ .check_empty_data_frame <- function(x, msg = NULL, ...) { .check_set_caller(".check_empty_data_frame") .check_that(nrow(x) > 0) - return(invisible(x)) } #' @title Checks if the endmembers parameter is valid #' @name .check_endmembers_parameter @@ -2252,7 +2145,6 @@ .check_endmembers_parameter <- function(em) { .check_set_caller(".check_endmembers_parameter") .check_that(inherits(em, c("data.frame", "character"))) - return(invisible(em)) } #' @title Checks if the endmembers data is in a valid parameter #' @name .check_endmembers_tbl @@ -2274,7 +2166,6 @@ msg = .conf("messsages", ".check_endmembers_parameter") ) .check_endmembers_fracs(em) - return(invisible(em)) } #' @title Checks if the endmembers data is in a valid parameter #' @name .check_endmembers_fracs @@ -2288,7 +2179,6 @@ .check_set_caller(".check_endmembers_fracs") # Pre-condition .check_that(all(length(.endmembers_fracs(em)) >= 1)) - return(invisible(em)) } #' @title Checks if the bands required by endmembers exist #' @name .check_endmembers_bands @@ -2301,7 +2191,6 @@ .check_endmembers_bands <- function(em, bands) { .check_set_caller(".check_endmembers_bands") .check_that(all(.band_eo(.endmembers_bands(em)) %in% bands)) - return(invisible(em)) } #' @title Checks if working in documentation mode #' @name .check_documentation @@ -2346,7 +2235,6 @@ .check_set_caller(".check_stac_items") .check_null_parameter(items) .check_that(rstac::items_length(items) > 0) - return(invisible(items)) } #' @title Checks recovery #' @name .check_recovery @@ -2358,7 +2246,6 @@ if (.check_messages()) { message(.conf("messages", ".check_recovery")) } - return(invisible(data)) } #' @title Checks discriminators #' @name .check_discriminator @@ -2383,35 +2270,7 @@ call. = TRUE ) } - return(invisible(discriminator)) -} -#' @title Checks view bands are defined -#' @name .check_bw_rgb_bands -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @param cube cube to choose band -#' @param band B/W band for view -#' @param red Red band for view -#' @param green Green band for view -#' @param blue Blue band for view -#' @return vector with bands -#' @keywords internal -#' @noRd -.check_bw_rgb_bands <- function(cube, band, red, green, blue) { - .check_set_caller(".check_bw_rgb_bands") - # check band is available - if (.has(band)) { - .check_that(band %in% .cube_bands(cube)) - return(band) - } else if (.has(red) && .has(green) && .has(blue)) { - # check bands are available - bands <- c(red, green, blue) - .check_that(all(bands %in% .cube_bands(cube))) - return(bands) - } - bands <- .bands_best_guess(cube) - return(bands) } - #' @title Check if the provided object is a vector #' @name .check_vector_object #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} @@ -2427,7 +2286,6 @@ discriminator = "one_of", msg = .conf("messages", ".check_vector_object") ) - return(invisible(NULL)) } #' @title Checks local items #' @name .check_local_items @@ -2441,7 +2299,6 @@ # pre-condition .check_tiles(unique(items[["tile"]])) .check_crs(unique(items[["crs"]])) - return(invisible(items)) } #' @title Checks tiles #' @name .check_tiles @@ -2454,7 +2311,6 @@ .check_set_caller(".check_tiles") # pre-condition .check_that(length(tiles) >= 1) - return(invisible(tiles)) } #' @title Checks palette #' @name .check_palette @@ -2475,7 +2331,6 @@ .check_chr_contains(x = cols4all::c4a_palettes(), contains = palette, discriminator = "any_of") - return(invisible(NULL)) } #' @title Check legend defined as tibble #' @name .check_legend @@ -2492,7 +2347,6 @@ discriminator = "all_of", msg = .conf("messages", ".check_legend") ) - return(invisible(NULL)) } #' @title Checks legend_position #' @name .check_legend_position @@ -2509,7 +2363,6 @@ discriminator = "one_of", msg = .conf("messages", ".check_legend_position") ) - return(invisible(NULL)) } #' @title Checks if band is in list of bands #' @name .check_band_in_bands @@ -2527,7 +2380,6 @@ discriminator = "one_of", msg = .conf("messages", ".check_band_in_bands") ) - return(invisible(NULL)) } #' @title Checks shapefile attribute #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} @@ -2544,7 +2396,6 @@ shp_df <- sf::st_drop_geometry(sf_shape) if (.has(shp_attr)) .check_that(length(as.character(shp_df[1, (shp_attr)])) > 0) - return(invisible(sf_shape)) } #' @title Checks validation file #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} @@ -2559,7 +2410,6 @@ .check_set_caller(".check_validation_file") if (is.character(validation)) .check_that(tolower(.file_ext(validation)) == "csv") - return(invisible(validation)) } #' @title Checks filter function #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} @@ -2573,7 +2423,6 @@ .check_set_caller(".check_filter_fn") if (.has(filter_fn)) .check_that(is.function(filter_fn)) - return(invisible(NULL)) } #' @title Checks distance method #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} @@ -2586,7 +2435,6 @@ .check_dist_method <- function(dist_method) { .check_set_caller(".check_dist_method") .check_that(dist_method %in% .conf("dendro_dist_method")) - return(invisible(NULL)) } #' @title Checks linkage method #' @name .check_linkage_method @@ -2600,7 +2448,6 @@ .check_linkage_method <- function(linkage) { .check_set_caller(".check_linkage_method") .check_that(linkage %in% .conf("dendro_linkage")) - return(invisible(NULL)) } #' @title Check netrc file #' @name .check_netrc_gdal @@ -2652,7 +2499,6 @@ }) ) ) - return(invisible(NULL)) } #' @title Check torch hyperparameters #' @name .check_opt_hparams @@ -2672,7 +2518,6 @@ within = names(optim_params_function), msg = .conf("messages", ".check_opt_hparams") ) - return(invisible(NULL)) } #' @title Check that cube period is unique #' @name .check_unique_period @@ -2709,7 +2554,6 @@ .check_warnings_bbox_as_sf <- function() { if (.check_warnings()) warning(.conf("messages", ".bbox_as_sf"), call. = FALSE) - return(invisible(NULL)) } #' @title Warning when labels have no colors preset #' @name .check_warnings_colors_get @@ -2721,7 +2565,6 @@ warning(.conf("messages", ".colors_get_missing_palette"), palette) # grDevices does not work with one color missing } - return(invisible(NULL)) } #' @title Warning when cube has no CLOUD band #' @name .check_warnings_regularize_cloud @@ -2735,7 +2578,6 @@ immediate. = TRUE ) } - return(invisible(NULL)) } #' @title Warning when cube has multiple values of CRS #' @name .check_warnings_regularize_crs @@ -2770,5 +2612,4 @@ warning(.conf("messages", "sits_timeline_raster_cube"), call. = FALSE ) - return(invisible(NULL)) } diff --git a/R/api_chunks.R b/R/api_chunks.R index 1c5daa3d7..dcaffc41f 100644 --- a/R/api_chunks.R +++ b/R/api_chunks.R @@ -160,7 +160,7 @@ NULL # transform chunk to bbox chunks_sf <- .bbox_as_sf(.bbox(chunks, by_feature = TRUE)) # remove chunks within mask - chunks[!.within(chunks_sf, mask),] + chunks[!.within(chunks_sf, mask), ] } #' @title Crop chunk geometries by mask #' @noRd @@ -181,13 +181,13 @@ NULL #' @returns A tibble with filtered segments .chunks_filter_segments <- function(chunks, tile, output_dir) { # Read segments from tile - segments <- .segments_read_vec(tile) + segs <- .segments_read_vec(tile) # Transform each chunk in sf object sf_chunks <- .bbox_as_sf( .bbox(chunks, by_feature = TRUE, default_crs = .tile_crs(tile)) ) # Find segments in chunks - idx_intersects <- sf::st_intersects(sf_chunks, segments, sparse = TRUE) |> + idx_intersects <- sf::st_intersects(sf_chunks, segs, sparse = TRUE) |> purrr::imap_dfr( ~dplyr::as_tibble(.x) |> dplyr::mutate(id = .y) ) |> @@ -206,7 +206,7 @@ NULL output_dir = output_dir, ext = "gpkg" ) - .vector_write_vec(segments[idx, ], block_file, append = TRUE) + .vector_write_vec(segs[idx, ], block_file, append = TRUE) return(block_file) }) return(chunks) diff --git a/R/api_classify.R b/R/api_classify.R index 5206ad615..db56ef19d 100755 --- a/R/api_classify.R +++ b/R/api_classify.R @@ -164,13 +164,13 @@ derived_class = "probs_cube", band = out_band ) - offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { - values <- values - offset + band_offset <- .offset(band_conf) + if (.has(band_offset) && band_offset != 0) { + values <- values - band_offset } - scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { - values <- values / scale + band_scale <- .scale(band_conf) + if (.has(band_scale) && band_scale != 1) { + values <- values / band_scale } # Put NA back in the result values[na_mask, ] <- NA @@ -339,10 +339,6 @@ chunks = chunks, roi = roi ) - # Should bbox of resulting tile be updated? - update_bbox <- nrow(chunks) != nchunks - } else { - update_bbox <- FALSE } # Filter segments that intersects with each chunk chunks <- .chunks_filter_segments( @@ -499,7 +495,7 @@ value = band ) # Return values - return(as.data.frame(values)) + as.data.frame(values) }) # Read and preprocess values of each base band values_base <- purrr::map(base_bands, function(band) { @@ -510,7 +506,7 @@ block = block ) # Return values - return(as.data.frame(values_base)) + as.data.frame(values_base) }) # Combine two lists values <- c(values, values_base) @@ -635,6 +631,7 @@ } # Set result class and return it .set_class(x = prediction, "predicted", class(samples)) + prediction } #' @title Classify predictors using CPU #' @name .classify_ts_cpu @@ -682,8 +679,7 @@ # Return classification return(values) }, progress = progress) - - return(prediction) + prediction } #' @title Classify predictors using GPU #' @name .classify_ts_gpu @@ -705,8 +701,6 @@ gpu_memory) { # estimate size of GPU memory required (in GB) pred_size <- nrow(pred) * ncol(pred) * 8 / 1e+09 - # include processing bloat - # pred_size <- pred_size * .conf("processing_bloat") # estimate how should we partition the predictors num_parts <- ceiling(pred_size / gpu_memory) # Divide samples predictors in chunks to parallel processing @@ -732,9 +726,9 @@ colnames(values) <- values_columns # Clean GPU memory .ml_gpu_clean(ml_model) - return(values) + values }) - return(prediction) + prediction } #' @title Start recording processing time #' @name .classify_verbose_start @@ -748,13 +742,12 @@ #' @param block block size #' @return start time for processing .classify_verbose_start <- function(verbose, block) { - start_time <- Sys.time() if (verbose) { msg <- paste0(.conf("messages", ".verbose_block_size"), " ", .nrows(block), " x ", .ncols(block)) message(msg) } - return(start_time) + Sys.time() } #' @title End recording processing time #' @name .classify_verbose_end diff --git a/R/api_clean.R b/R/api_clean.R index d3f840ccd..824629e06 100644 --- a/R/api_clean.R +++ b/R/api_clean.R @@ -86,7 +86,7 @@ block_files }) # Merge blocks into a new class_cube tile - band_tile <- .tile_derived_merge_blocks( + .tile_derived_merge_blocks( file = out_file, band = band, labels = .tile_labels(tile), @@ -96,8 +96,6 @@ multicores = 1, update_bbox = FALSE ) - # Return a asset - return(band_tile) } #' @title Read data for cleaning operation @@ -115,5 +113,5 @@ # Set columns name colnames(values) <- band # Return values - return(values) + values } diff --git a/R/api_cluster.R b/R/api_cluster.R index f78384c2e..78cf6712d 100644 --- a/R/api_cluster.R +++ b/R/api_cluster.R @@ -26,13 +26,12 @@ # is the input data the result of a cluster function? .check_samples_cluster(samples) # compute CVIs and return - result <- dtwclust::cvi( + dtwclust::cvi( a = factor(samples[["cluster"]]), b = factor(samples[["label"]]), type = "external", log.base = 10 ) - return(result) } #' @title Compute a dendrogram using hierarchical clustering #' @name .cluster_dendrogram @@ -133,8 +132,7 @@ h_result <- c(0, dendro[["height"]])[h_index] # create a named vector and return - best_cut <- structure(c(k_result, h_result), .Names = c("k", "height")) - return(best_cut) + structure(c(k_result, h_result), .Names = c("k", "height")) } #' @title Compute Rand index for cluster table #' @name .cluster_rand_index @@ -156,6 +154,5 @@ factor_1 <- (nis2 * njs2) / n2 factor_2 <- (nis2 + njs2) / 2 rand <- (sum(choose(x[x > 1], 2)) - factor_1) / (factor_2 - factor_1) - return(rand) } diff --git a/R/api_csv.R b/R/api_csv.R index 4b502b750..4306cda17 100644 --- a/R/api_csv.R +++ b/R/api_csv.R @@ -50,13 +50,12 @@ ) # pre-condition - check if CSV file is correct .check_samples(samples) + samples <- .samples_convert_to_sits(samples) # select valid columns - samples <- dplyr::select( + dplyr::select( samples, c("longitude", "latitude", "label") ) - class(samples) <- c("sits", class(samples)) - return(samples) } #' @title Transform a CSV with lat/long into samples #' @name .csv_get_lat_lon diff --git a/R/api_cube.R b/R/api_cube.R index c693176b3..24c2ff1e2 100644 --- a/R/api_cube.R +++ b/R/api_cube.R @@ -241,7 +241,7 @@ NULL #' @export #' .cube_find_class.raster_cube <- function(cube) { - return(cube) + cube } #' @export #' @@ -263,7 +263,7 @@ NULL } else { class(cube) <- c("eo_cube", class(cube)) } - return(cube) + cube } #' @export .cube_find_class.default <- function(cube) { @@ -274,7 +274,7 @@ NULL } else { stop(.conf("messages", ".cube_find_class")) } - return(cube) + cube } # ---- cube manipulation ---- @@ -367,8 +367,7 @@ NULL # Get area for each class for each row of the cube freq_lst <- slider::slide(cube, function(tile) { # Get the frequency count and value for each labelled image - freq <- .tile_area_freq(tile) - return(freq) + .tile_area_freq(tile) }) # Get a tibble by binding the row (duplicated labels with different counts) freq <- do.call(rbind, freq_lst) @@ -419,7 +418,7 @@ NULL } else { stop(.conf("messages", ".cube_bands")) } - return(bands) + bands } #' @export .cube_bands.default <- function(cube, @@ -432,7 +431,7 @@ NULL } else { stop(.conf("messages", ".cube_bands")) } - return(bands) + bands } #' @title Return labels of a data cube #' @keywords internal @@ -447,15 +446,15 @@ NULL } #' @export .cube_labels.derived_cube <- function(cube, dissolve = FALSE) { - return(cube[["labels"]][[1]]) + cube[["labels"]][[1]] } #' @export .cube_labels.raster_cube <- function(cube, dissolve = TRUE) { labels <- .compact(slider::slide(cube, .tile_labels)) if (dissolve) { - return(.dissolve(labels)) + labels <- .dissolve(labels) } - return(labels) + labels } #' @export .cube_labels.tbl_df <- function(cube, dissolve = TRUE) { @@ -466,7 +465,7 @@ NULL } else { stop(.conf("messages", "cube_labels")) } - return(labels) + labels } #' @export .cube_labels.default <- function(cube, dissolve = TRUE) { @@ -625,10 +624,10 @@ NULL } #' @export .cube_s3class.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - class <- .cube_s3class(cube) - return(class) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_s3class(cube) } #' @title Return the X resolution #' @name .cube_xres @@ -667,10 +666,10 @@ NULL } #' @export .cube_ncols.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - ncols <- .cube_ncols(cube) - return(ncols) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_ncols(cube) } #' @title Return the row size of each tile #' @name .cube_nrows @@ -689,10 +688,10 @@ NULL } #' @export .cube_nrows.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - nrows <- .cube_nrows(cube) - return(nrows) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_nrows(cube) } #' @title Get cube source #' @name .cube_source @@ -711,15 +710,13 @@ NULL # set caller to show in errors .check_set_caller(".cube_source") source <- .compact(slider::slide_chr(cube, .tile_source)) - .check_that(length(source) == 1) - source } #'@export .cube_source.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - source <- .cube_source(cube) - return(source) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_source(cube) } #' @title Get start date from each tile in a cube #' @noRd @@ -734,10 +731,10 @@ NULL } #' @export .cube_start_date.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - start_date <- .cube_start_date(cube) - return(start_date) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_start_date(cube) } #' @title Get end date from each tile in a cube #' @noRd @@ -752,10 +749,10 @@ NULL } #' @export .cube_end_date.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - end_date <- .cube_end_date(cube) - return(end_date) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_end_date(cube) } #' @title Get timeline from each tile in a cube #' @noRd @@ -773,10 +770,10 @@ NULL } #' @export .cube_timeline.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - timeline <- .cube_timeline(cube) - return(timeline) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_timeline(cube) } #' @title Check if cube is complete @@ -797,10 +794,10 @@ NULL } #' @export .cube_is_complete.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - is_complete <- .cube_is_complete(cube) - return(is_complete) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_is_complete(cube) } #' @title Check that cube is regular #' @name .cube_is_regular @@ -823,7 +820,7 @@ NULL if (length(.cube_timeline(cube)) > 1) { is_regular <- FALSE } - return(is_regular) + is_regular } #' @title Check that cube has unique period @@ -904,10 +901,10 @@ NULL .cube_timeline_acquisition.default <- function(cube, period = "P1D", origin = NULL) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - values <- .cube_timeline_acquisition(cube, period, origin) - return(values) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_timeline_acquisition(cube, period, origin) } # ---- iteration ---- #' @title Tile iteration @@ -931,10 +928,10 @@ NULL } #' @export .cube_bbox.default <- function(cube, as_crs = NULL) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - bbox <- .cube_bbox(cube, as_crs = as_crs) - return(bbox) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_bbox(cube, as_crs = as_crs) } .cube_as_sf <- function(cube, as_crs = NULL) { UseMethod(".cube_as_sf", cube) @@ -945,10 +942,10 @@ NULL } #' @export .cube_as_sf.default <- function(cube, as_crs = NULL) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - sf_obj <- .cube_as_sf(cube, as_crs = as_crs) - return(sf_obj) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_as_sf(cube, as_crs = as_crs) } #' @title What tiles intersect \code{roi} parameter? #' @noRd @@ -964,10 +961,10 @@ NULL } #' @export .cube_intersects.default <- function(cube, roi) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - intersects <- .cube_intersects(cube, roi) - return(intersects) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_intersects(cube, roi) } #' @title Filter tiles that intersect \code{roi} parameter. #' @noRd @@ -987,10 +984,10 @@ NULL } #' @export .cube_filter_spatial.default <- function(cube, roi) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - result <- .cube_filter_spatial(cube, roi) - return(result) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_filter_spatial(cube, roi) } #' @title Test tiles with images during an interval #' @noRd @@ -1009,10 +1006,10 @@ NULL } #' @export .cube_during.default <- function(cube, start_date, end_date) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - result <- .cube_during(cube, start_date, end_date) - return(result) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_during(cube, start_date, end_date) } #' @title Filter tiles inside a temporal interval #' @noRd @@ -1035,10 +1032,10 @@ NULL } #' @export .cube_filter_interval.default <- function(cube, start_date, end_date) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - cube <- .cube_filter_interval(cube, start_date, end_date) - return(cube) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_filter_interval(cube, start_date, end_date) } #' @title Filter tiles by sparse dates @@ -1063,15 +1060,14 @@ NULL }) # Post-condition .check_that(nrow(cube) >= 1) - # Return cube - return(cube) + cube } #' @export .cube_filter_dates.default <- function(cube, dates) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - cube <- .cube_filter_dates(cube = cube, dates = dates) - return(cube) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_filter_dates(cube = cube, dates = dates) } #' @title Filter cube based on a set of bands #' @noRd @@ -1089,10 +1085,10 @@ NULL } #' @export .cube_filter_bands.default <- function(cube, bands) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - cube <- .cube_filter_bands(cube, bands) - return(cube) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_filter_bands(cube, bands) } #' @title Filter tiles that are non-empty. #' @noRd @@ -1101,6 +1097,7 @@ NULL .cube_filter_nonempty <- function(cube) { not_empty <- slider::slide_lgl(cube, .tile_is_nonempty) cube[not_empty, ] + } #' @title Returns the tile names of a data cube #' @noRd @@ -1115,10 +1112,10 @@ NULL } #' @export .cube_tiles.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - tiles <- .cube_tiles(cube) - return(tiles) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_tiles(cube) } #' @title Returns the paths of a data cube #' @noRd @@ -1133,10 +1130,10 @@ NULL } #' @export .cube_paths.default <- function(cube, bands = NULL) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - paths <- .cube_paths(cube, bands) - return(paths) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_paths(cube, bands) } #' @title Find if the cube is local #' @noRd @@ -1151,10 +1148,10 @@ NULL } #' @export .cube_is_local.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - result <- .cube_is_local(cube) - return(result) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_is_local(cube) } #' @title Filter the cube using tile names #' @noRd @@ -1170,10 +1167,10 @@ NULL } #' @export .cube_filter_tiles.default <- function(cube, tiles) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - cube <- .cube_filter_tiles(cube, tiles) - return(cube) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_filter_tiles(cube, tiles) } #' @title Create internal cube features with ID @@ -1199,10 +1196,10 @@ NULL } #' @export .cube_split_features.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - cube <- .cube_split_features(cube) - return(cube) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_split_features(cube) } #' @title Split assets for a data cube by assigning a unique ID #' @noRd @@ -1249,10 +1246,10 @@ NULL } #' @export .cube_split_assets.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - cube <- .cube_split_assets(cube) - return(cube) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_split_assets(cube) } #' @title Merge tiles in a data cube #' @noRd @@ -1303,10 +1300,10 @@ NULL } #' @export .cube_merge_tiles.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - cube <- .cube_merge_tiles(cube) - return(cube) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_merge_tiles(cube) } #' @title Cube contains CLOUD band #' @noRd @@ -1321,10 +1318,10 @@ NULL } #' @export .cube_contains_cloud.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - cube <- .cube_contains_cloud(cube) - return(cube) + cube <- cube |> + tibble::as_tibble() |> + .cube_find_class() + .cube_contains_cloud(cube) } #' @title Check if bboxes of all tiles of the cube are the same #' @name .cube_has_unique_bbox @@ -1562,7 +1559,7 @@ NULL } #' @export .cube_is_token_expired.default <- function(cube) { - return(FALSE) + FALSE } #' @title Split the cube by tiles and bands #' @name .cube_split_tiles_bands @@ -1579,11 +1576,9 @@ NULL band = bands ) # Generate a list combined by tiles and bands - tiles_bands <- purrr::pmap(tiles_bands, function(tile, band) { - return(list(tile, band)) + purrr::pmap(tiles_bands, function(tile, band) { + list(tile, band) }) - # Return a list of combinations - return(tiles_bands) } #' @title Split the cube by samples #' @name .cube_split_chunks_samples @@ -1623,11 +1618,11 @@ NULL chunks_sf <- slider::slide(chunks_sf, function(chunk_sf) { chunk_sf[["samples"]] <- list(samples_sf[ .within(samples_sf, chunk_sf), ]) - return(chunk_sf) + chunk_sf }) - return(chunks_sf) + chunks_sf }) - return(unlist(cube_chunks, recursive = FALSE)) + unlist(cube_chunks, recursive = FALSE) } #' @title Return base info #' @name .cube_has_base_info @@ -1640,7 +1635,7 @@ NULL #' #' .cube_has_base_info <- function(cube) { - return(.has(cube[["base_info"]])) + .has(cube[["base_info"]]) } .cube_sensor <- function(cube) { diff --git a/R/api_message.R b/R/api_message.R new file mode 100644 index 000000000..618e67961 --- /dev/null +++ b/R/api_message.R @@ -0,0 +1,10 @@ +#' @name .message_invalid_param +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @param param parameter name +#' @return A valid message +#' @keywords internal +#' @noRd +.message_invalid_param <- function(param) { + # make default message + paste0("invalid ", param, " parameter") +} diff --git a/R/api_plot_raster.R b/R/api_plot_raster.R index 6abe3aaac..737c65ebf 100644 --- a/R/api_plot_raster.R +++ b/R/api_plot_raster.R @@ -58,7 +58,11 @@ # scale and offset band_conf <- .tile_band_conf(tile, band) band_scale <- .scale(band_conf) + if (.has_not(band_scale)) + band_scale <- 1 band_offset <- .offset(band_conf) + if (.has_not(band_offset)) + band_offset <- 0 max_value <- .max_value(band_conf) # retrieve the overview if COG bw_file <- .gdal_warp_file(bw_file, sizes) diff --git a/R/api_preconditions.R b/R/api_preconditions.R index dc8f6547a..c617bd320 100644 --- a/R/api_preconditions.R +++ b/R/api_preconditions.R @@ -120,8 +120,8 @@ patience, min_delta, verbose) { # Pre-conditions: .check_samples_train(samples) - .check_int_parameter(epochs, min = 1L, max = 20000L) - .check_int_parameter(batch_size, min = 16L, max = 2048L) + .check_int_parameter(epochs, min = 1, max = 20000L) + .check_int_parameter(batch_size, min = 16, max = 2048L) .check_int_parameter(lr_decay_epochs, min = 1) .check_num_parameter(lr_decay_rate, exclusive_min = 0, max = 1.0) .check_int_parameter(patience, min = 1) diff --git a/R/api_samples.R b/R/api_samples.R index 7bb1d3024..c8586d2a9 100644 --- a/R/api_samples.R +++ b/R/api_samples.R @@ -381,3 +381,17 @@ samples <- dplyr::bind_rows(samples_lst) return(samples) } +#' @title Converts samples to sits +#' @name .samples_convert_to_sits +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @param samples Data frame +#' @return data frame converted to sits +#' @keywords internal +#' @noRd +.samples_convert_to_sits <- function(samples) { + if (!("sits" %in% class(samples))){ + samples <- tibble::as_tibble(samples) + class(samples) <- c("sits", class(samples)) + } + samples +} diff --git a/R/api_source_local.R b/R/api_source_local.R index 10bca927c..4d970399e 100644 --- a/R/api_source_local.R +++ b/R/api_source_local.R @@ -118,10 +118,10 @@ # set caller to show in errors .check_set_caller(".local_results_cube") # is this a cube with results? - results_cube <- .check_is_results_cube(bands, labels) + .check_is_results_cube(bands, labels) # set the correct parse_info - parse_info <- .conf_parse_info(parse_info, results_cube) + parse_info <- .conf_parse_info(parse_info, results_cube = TRUE) # bands in upper case for raw cubes, lower case for results cubes bands <- .band_set_case(bands) diff --git a/R/api_tibble.R b/R/api_tibble.R index 970b7bcdb..02f09df60 100644 --- a/R/api_tibble.R +++ b/R/api_tibble.R @@ -240,8 +240,7 @@ #' .tibble_prune <- function(data) { # verify that tibble is correct - data <- .check_samples(data) - + .check_samples_ts(data) n_samples <- data[["time_series"]] |> purrr::map_int(function(t) { nrow(t) diff --git a/R/sits-package.R b/R/sits-package.R index ff42ea4b1..fc956543b 100644 --- a/R/sits-package.R +++ b/R/sits-package.R @@ -14,7 +14,7 @@ #' \enumerate{ #' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from #' a cloud provider.} -#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection #' from a cloud provider to a local directory for faster processing.} #' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube #' from an ARD image collection.} diff --git a/R/sits_apply.R b/R/sits_apply.R index 23705320d..7e001becb 100644 --- a/R/sits_apply.R +++ b/R/sits_apply.R @@ -146,7 +146,7 @@ sits_apply <- function(data, ...) { #' @rdname sits_apply #' @export sits_apply.sits <- function(data, ...) { - data <- .check_samples(data) + .check_samples(data) .apply(data, col = "time_series", fn = dplyr::mutate, ...) } diff --git a/R/sits_bbox.R b/R/sits_bbox.R index 936dbf13e..a9c9e6c71 100644 --- a/R/sits_bbox.R +++ b/R/sits_bbox.R @@ -45,10 +45,9 @@ sits_bbox <- function(data, ..., crs = "EPSG:4326", as_crs = NULL) { #' @export sits_bbox.sits <- function(data, ..., crs = "EPSG:4326", as_crs = NULL) { # Pre-conditions - data <- .check_samples(data) + .check_samples(data) # Convert to bbox - bbox <- .bbox(.point(x = data, crs = crs, as_crs = as_crs)) - return(bbox) + .bbox(.point(x = data, crs = crs, as_crs = as_crs)) } #' @rdname sits_bbox #' @export @@ -56,8 +55,7 @@ sits_bbox.raster_cube <- function(data, ..., as_crs = NULL) { # Pre-condition .check_is_raster_cube(data) # Convert to bbox - bbox <- .bbox(x = data, as_crs = as_crs) - return(bbox) + .bbox(x = data, as_crs = as_crs) } #' @rdname sits_bbox #' @export @@ -70,8 +68,7 @@ sits_bbox.tbl_df <- function(data, ..., crs = "EPSG:4326", as_crs = NULL) { } else { stop(.conf("messages", "sits_bbox_default")) } - bbox <- sits_bbox(data, crs, as_crs) - return(bbox) + sits_bbox(data, crs, as_crs) } #' @rdname sits_bbox #' @export @@ -84,6 +81,5 @@ sits_bbox.default <- function(data, ..., crs = "EPSG:4326", as_crs = NULL) { } else { stop(.conf("messages", "sits_bbox_default")) } - bbox <- sits_bbox(data, crs, as_crs) - return(bbox) + sits_bbox(data, crs, as_crs) } diff --git a/R/sits_classify.R b/R/sits_classify.R index fcd1e858e..432d351f1 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -181,7 +181,7 @@ sits_classify.sits <- function(data, # Update multicores multicores <- .ml_update_multicores(ml_model, multicores) # Do classification - classified_ts <- .classify_ts( + .classify_ts( samples = data, ml_model = ml_model, filter_fn = filter_fn, @@ -190,7 +190,6 @@ sits_classify.sits <- function(data, gpu_memory = gpu_memory, progress = progress ) - return(classified_ts) } #' @title Classify a regular raster cube @@ -305,7 +304,8 @@ sits_classify.sits <- function(data, #' data = cube, #' ml_model = rf_model, #' output_dir = tempdir(), -#' version = "ex_classify" +#' version = "classify_1", +#' verbose = TRUE #' ) #' # label the probability cube #' label_cube <- sits_label_classification( @@ -425,13 +425,14 @@ sits_classify.raster_cube <- function(data, output_dir = output_dir ) on.exit(.parallel_stop(), add = TRUE) - # Show block information + # Show processing time information start_time <- .classify_verbose_start(verbose, block) + on.exit(.classify_verbose_end(verbose, start_time)) # Classification # Process each tile sequentially - probs_cube <- .cube_foreach_tile(data, function(tile) { + .cube_foreach_tile(data, function(tile) { # Classify the data - probs_tile <- .classify_tile( + .classify_tile( tile = tile, out_band = "probs", bands = bands, @@ -447,11 +448,7 @@ sits_classify.raster_cube <- function(data, verbose = verbose, progress = progress ) - return(probs_tile) }) - # Show block information - .classify_verbose_end(verbose, start_time) - return(probs_cube) } #' @title Classify a segmented data cube #' @name sits_classify.segs_cube @@ -688,9 +685,9 @@ sits_classify.vector_cube <- function(data, on.exit(.parallel_stop(), add = TRUE) # Classification # Process each tile sequentially - probs_vector_cube <- .cube_foreach_tile(data, function(tile) { + .cube_foreach_tile(data, function(tile) { # Classify all the segments for each tile - class_vector <- .classify_vector_tile( + .classify_vector_tile( tile = tile, bands = bands, base_bands = base_bands, @@ -707,9 +704,7 @@ sits_classify.vector_cube <- function(data, output_dir = output_dir, progress = progress ) - return(class_vector) }) - return(probs_vector_cube) } #' @rdname sits_classify #' @export diff --git a/R/sits_csv.R b/R/sits_csv.R index 8e6230e98..a964716b4 100644 --- a/R/sits_csv.R +++ b/R/sits_csv.R @@ -31,7 +31,8 @@ sits_to_csv <- function(data, file = NULL) { #' @export sits_to_csv.sits <- function(data, file = NULL) { # check the samples are valid - data <- .check_samples(data) + .check_samples(data) + data <- .samples_convert_to_sits(data) # check the file name is valid if (.has(file)) .check_file( @@ -87,7 +88,8 @@ sits_to_csv.default <- function(data, file) { #' sits_timeseries_to_csv <- function(data, file = NULL) { # check the samples are valid - data <- .check_samples(data) + .check_samples(data) + data <- .samples_convert_to_sits(data) csv_1 <- .csv_metadata_from_samples(data) csv_2 <- .predictors(data)[-2:0] csv_combined <- dplyr::bind_cols(csv_1, csv_2) diff --git a/R/sits_detect_change.R b/R/sits_detect_change.R index b401106f7..c898acbf1 100644 --- a/R/sits_detect_change.R +++ b/R/sits_detect_change.R @@ -54,7 +54,7 @@ sits_detect_change.sits <- function(data, # set caller for error messages .check_set_caller("sits_detect_change_sits") # preconditions - data <- .check_samples_ts(data) + .check_samples_ts(data) .check_is_sits_model(dc_method) .check_int_parameter(multicores, min = 1, max = 2048) .check_progress(progress) diff --git a/R/sits_geo_dist.R b/R/sits_geo_dist.R index b7330af6a..5ba19143a 100644 --- a/R/sits_geo_dist.R +++ b/R/sits_geo_dist.R @@ -58,10 +58,11 @@ #' } #' @export #' -sits_geo_dist <- function(samples, roi, n = 1000L, crs = "EPSG:4326") { +sits_geo_dist <- function(samples, roi, n = 1000, crs = "EPSG:4326") { .check_set_caller("sits_geo_dist") # Pre-conditions - samples <- .check_samples(samples) + .check_samples(data) + data <- .samples_convert_to_sits(data) if (.has(roi)) roi <- .roi_as_sf(roi = roi, as_crs = "EPSG:4326") samples <- samples[sample(seq_len(nrow(samples)), min(n, nrow(samples))), ] @@ -79,6 +80,5 @@ sits_geo_dist <- function(samples, roi, n = 1000L, crs = "EPSG:4326") { dist_sp <- dplyr::mutate(dist_sp, type = "sample-to-prediction") dist_tb <- dplyr::bind_rows(dist_ss, dist_sp) class(dist_tb) <- c("geo_distances", class(dist_tb)) - - return(dist_tb) + dist_tb } diff --git a/R/sits_imputation.R b/R/sits_imputation.R index 816e3e358..d9a7beb5d 100644 --- a/R/sits_imputation.R +++ b/R/sits_imputation.R @@ -35,7 +35,7 @@ impute_linear <- function(data = NULL) { #' @export sits_impute <- function(samples, impute_fn = impute_linear()) { # check data is time series - .check_samples(samples) + .check_samples_ts(samples) .samples_foreach_ts(samples, function(row) { .ts_values(row) <- tibble::as_tibble( purrr::map_df(.ts_bands(row), function(band) { diff --git a/R/sits_label_classification.R b/R/sits_label_classification.R index 71723a0e8..134da862c 100644 --- a/R/sits_label_classification.R +++ b/R/sits_label_classification.R @@ -134,7 +134,7 @@ sits_label_classification.probs_cube <- function(cube, ..., # Create label classification function label_fn <- .label_fn_majority() # Process each tile sequentially - class_cube <- .cube_foreach_tile(cube, function(tile) { + .cube_foreach_tile(cube, function(tile) { # Label the data class_tile <- .label_tile( tile = tile, @@ -144,9 +144,7 @@ sits_label_classification.probs_cube <- function(cube, ..., version = version, progress = progress ) - return(class_tile) }) - return(class_cube) } #' @rdname sits_label_classification @@ -162,7 +160,7 @@ sits_label_classification.probs_vector_cube <- function(cube, ..., # version is case-insensitive in sits version <- tolower(version) # Process each tile sequentially - class_cube <- .cube_foreach_tile(cube, function(tile) { + .cube_foreach_tile(cube, function(tile) { # Label the segments class_tile <- .label_vector_tile( tile = tile, @@ -170,10 +168,7 @@ sits_label_classification.probs_vector_cube <- function(cube, ..., version = version, output_dir = output_dir ) - # Return classified tile segments - return(class_tile) }) - return(class_cube) } #' @rdname sits_label_classification diff --git a/R/sits_labels.R b/R/sits_labels.R index fda2295a4..7cfdc73fc 100644 --- a/R/sits_labels.R +++ b/R/sits_labels.R @@ -124,7 +124,7 @@ sits_labels.default <- function(data) { #' `sits_labels<-.sits` <- function(data, value) { # does the input data exist? - data <- .check_samples(data) + .check_samples(data) labels <- .samples_labels(data) # check if value and labels match .check_chr_parameter(value, diff --git a/R/sits_lighttae.R b/R/sits_lighttae.R index 5770c01f0..c1fff5b74 100644 --- a/R/sits_lighttae.R +++ b/R/sits_lighttae.R @@ -116,9 +116,9 @@ sits_lighttae <- function(samples = NULL, eps = 1e-08, weight_decay = 7e-04 ), - lr_decay_epochs = 50L, + lr_decay_epochs = 50, lr_decay_rate = 1.0, - patience = 20L, + patience = 20, min_delta = 0.01, verbose = FALSE) { # set caller for error msg @@ -165,7 +165,6 @@ sits_lighttae <- function(samples = NULL, n_labels <- length(labels) n_bands <- length(bands) n_times <- .samples_ntimes(samples) - # Data normalization ml_stats <- .samples_stats(samples) # Organize train and the test data @@ -179,7 +178,6 @@ sits_lighttae <- function(samples = NULL, bands = bands, validation_split = validation_split ) - # Obtain the train and the test data train_samples <- train_test_data[["train_samples"]] test_samples <- train_test_data[["test_samples"]] @@ -238,8 +236,6 @@ sits_lighttae <- function(samples = NULL, dim_input_decoder, dim_layers_decoder ) - # softmax is done after classification - removed from here - # self$softmax <- torch::nn_softmax(dim = -1) }, forward = function(input) { out <- self$spatial_encoder(input) diff --git a/R/sits_merge.R b/R/sits_merge.R index 9da19c024..91ca1ec08 100644 --- a/R/sits_merge.R +++ b/R/sits_merge.R @@ -65,6 +65,7 @@ sits_merge.sits <- function(data1, data2, ..., suffix = c(".1", ".2")) { # check that data2 and data1 are sits tibble .check_samples_ts(data1) .check_samples_ts(data2) + data2 <- .samples_convert_to_sits(data2) # verify if data1 and data2 have the same number of rows .check_that(nrow(data1) == nrow(data2)) # are the names of the bands different? diff --git a/R/sits_plot.R b/R/sits_plot.R index a25a73ad7..5cd6a7e78 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -105,8 +105,7 @@ plot.patterns <- function(x, y, ..., bands = NULL, year_grid = FALSE) { function(label, ts) { lb <- as.character(label) # extract the time series and convert - df <- tibble::tibble(Time = ts[["Index"]], ts[-1], Pattern = lb) - return(df) + tibble::tibble(Time = ts[["Index"]], ts[-1], Pattern = lb) } ) # create a data.frame by melting the values per bands @@ -241,7 +240,7 @@ plot.predicted <- function(x, y, ..., function(rp_from, rp_to, rp_class, i) { best_class <- as.character(rp_class) - df_p <- data.frame( + data.frame( Time = c( lubridate::as_date(rp_from), lubridate::as_date(rp_to), @@ -254,7 +253,6 @@ plot.predicted <- function(x, y, ..., na.rm = TRUE ), each = 2) ) - return(df_p) } ) # create a multi-year plot @@ -308,10 +306,10 @@ plot.predicted <- function(x, y, ..., ggplot2::xlab("Time") g <- graphics::plot(gp) - return(g) + g } ) - return(invisible(p)) + p } #' @title Plot RGB data cubes #' @name plot.raster_cube @@ -424,7 +422,7 @@ plot.raster_cube <- function(x, ..., # precondition for tiles .check_cube_tiles(x, tile) # precondition for bands - bands <- .check_bw_rgb_bands(x, band, red, green, blue) + bands <- .band_set_bw_rgb(x, band, red, green, blue) # check roi .check_roi(roi) # check scale parameter @@ -798,7 +796,7 @@ plot.vector_cube <- function(x, ..., # precondition for tiles .check_cube_tiles(x, tile) # precondition for bands - bands <- .check_bw_rgb_bands(x, band, red, green, blue) + bands <- .band_set_bw_rgb(x, band, red, green, blue) # check palette if (length(bands) == 1) { # check palette @@ -1340,16 +1338,13 @@ plot.uncertainty_vector_cube <- function(x, ..., tmap_params <- .tmap_params_set(dots, legend_position) # filter the cube tile <- .cube_filter_tiles(cube = x, tiles = tile) - # set the title - band <- .tile_bands(tile) # plot the probs vector cube - p <- .plot_uncertainty_vector(tile = tile, - palette = palette, - rev = rev, - scale = scale, - tmap_params = tmap_params) + .plot_uncertainty_vector(tile = tile, + palette = palette, + rev = rev, + scale = scale, + tmap_params = tmap_params) - return(p) } #' @title Plot classified images #' @name plot.class_cube @@ -1585,8 +1580,7 @@ plot.rfor_model <- function(x, y, ...) { .check_is_sits_model(x) # retrieve the random forest object from the env iroment rf <- .ml_model(x) - p <- randomForestExplainer::plot_min_depth_distribution(rf) - return(p) + randomForestExplainer::plot_min_depth_distribution(rf) } #' @@ -1882,12 +1876,12 @@ plot.som_clean_samples <- function(x, ...) { dplyr::summarise(n = dplyr::n()) |> dplyr::mutate(n_class = sum(.data[["n"]])) |> dplyr::ungroup() |> - dplyr::mutate(percentage = (.data[["n"]]/.data[["n_class"]])*100) |> + dplyr::mutate(percent = (.data[["n"]] / .data[["n_class"]]) * 100) |> dplyr::select(dplyr::all_of("label"), dplyr::all_of("eval"), - dplyr::all_of("percentage")) |> + dplyr::all_of("percent")) |> tidyr::pivot_wider(names_from = .data[["eval"]], - values_from = .data[["percentage"]]) + values_from = .data[["percent"]]) colors_eval <- c("#C7BB3A", "#4FC78E", "#D98880") if (all_evals) { @@ -1907,8 +1901,8 @@ plot.som_clean_samples <- function(x, ...) { colors_eval <- c("#C7BB3A", "#4FC78E") } - labels <- unique(pivot[["label"]]) - pivot$label <- factor(pivot$label, levels = labels) + sample_labels <- unique(pivot[["label"]]) + pivot$label <- factor(pivot$label, levels = sample_labels) # Stacked bar graphs for Noise Detection g <- ggplot2::ggplot( @@ -1923,7 +1917,7 @@ plot.som_clean_samples <- function(x, ...) { width = 0.9) + ggplot2::geom_text( ggplot2::aes( - label = scales::percent(value/100, 1)), + label = scales::percent(value / 100, 1)), position = ggplot2::position_stack(vjust = 0.5), color = "black", size = length(eval_labels), @@ -1943,8 +1937,7 @@ plot.som_clean_samples <- function(x, ...) { values = colors_eval, name = "Evaluation") + ggplot2::ggtitle("Class noise detection") - - return(g) + g } #' @title Plot XGB model #' @name plot.xgb_model @@ -2071,8 +2064,7 @@ plot.torch_model <- function(x, y, ...) { ) p <- p + ggplot2::labs() - - return(p) + p } #' @title Make a kernel density plot of samples distances. @@ -2119,9 +2111,7 @@ plot.geo_distances <- function(x, y, ...) { message(.conf("messages", ".plot_geo_distances")) return(invisible(NULL)) } - - density_plot <- - distances |> + distances |> dplyr::mutate(distance = .data[["distance"]] / 1000) |> ggplot2::ggplot(ggplot2::aes(x = .data[["distance"]])) + ggplot2::geom_density( @@ -2136,7 +2126,6 @@ plot.geo_distances <- function(x, y, ...) { ggplot2::ylab("") + ggplot2::theme(legend.title = ggplot2::element_blank()) + ggplot2::ggtitle("Distribution of Nearest Neighbor Distances") - return(density_plot) } #' @title Plot a dendrogram cluster @@ -2178,13 +2167,13 @@ plot.sits_cluster <- function(x, ..., dend <- hclust_cl |> stats::as.dendrogram() # colors vector - colors <- .colors_get( + colors_hex <- .colors_get( labels = data_labels, legend = NULL, palette = palette, rev = TRUE ) - colors_leg <- colors[unique(data_labels)] + colors_leg <- colors_hex[unique(data_labels)] # set the visualization params for dendrogram dend <- dend |> @@ -2194,7 +2183,7 @@ plot.sits_cluster <- function(x, ..., ) |> dendextend::set( what = "branches_k_color", - value = colors, + value = colors_hex, k = length(data_labels) ) diff --git a/R/sits_predictors.R b/R/sits_predictors.R index e1ea58ac0..f9a931e26 100644 --- a/R/sits_predictors.R +++ b/R/sits_predictors.R @@ -69,9 +69,8 @@ sits_predictors <- function(samples) { .check_set_caller("sits_predictors") .check_na_null_parameter(samples) - samples <- .check_samples_ts(samples) - pred <- .predictors(samples) - return(pred) + .check_samples_ts(samples) + .predictors(samples) } #' @title Obtain numerical values of predictors for time series samples @@ -98,8 +97,7 @@ sits_predictors <- function(samples) { #' } #' @export sits_pred_features <- function(pred) { - features <- .pred_features(pred) - return(features) + .pred_features(pred) } #' @title Obtain categorical id and predictor labels for time series samples #' @name sits_pred_references @@ -122,8 +120,7 @@ sits_pred_features <- function(pred) { #' } #' @export sits_pred_references <- function(pred) { - ref <- .pred_references(pred) - return(ref) + .pred_references(pred) } #' @title Normalize predictor values #' @name sits_pred_normalize @@ -153,8 +150,7 @@ sits_pred_normalize <- function(pred, stats) { .check_set_caller("sits_pred_normalize") .check_na_null_parameter(pred) .check_na_null_parameter(stats) - pred <- .pred_normalize(pred, stats) - return(pred) + .pred_normalize(pred, stats) } #' @title Obtain a fraction of the predictors data frame #' @name sits_pred_sample @@ -180,8 +176,7 @@ sits_pred_normalize <- function(pred, stats) { #' } #' @export sits_pred_sample <- function(pred, frac) { - sample <- .pred_sample(pred, frac) - return(sample) + .pred_sample(pred, frac) } #' @title Obtain statistics for all sample bands #' @name sits_stats @@ -208,6 +203,5 @@ sits_pred_sample <- function(pred, frac) { #' } #' @export sits_stats <- function(samples) { - stats <- .samples_stats(samples) - return(stats) + .samples_stats(samples) } diff --git a/R/sits_reclassify.R b/R/sits_reclassify.R index 4dd850068..e23372d4f 100644 --- a/R/sits_reclassify.R +++ b/R/sits_reclassify.R @@ -115,7 +115,7 @@ #' } #' #' @export -sits_reclassify <- function(cube,...) { +sits_reclassify <- function(cube, ...) { .check_set_caller("sits_reclassify") UseMethod("sits_reclassify", cube) } @@ -180,18 +180,17 @@ sits_reclassify.class_cube <- function(cube, ..., .msg_error = .conf("messages", "sits_reclassify_mask_intersect") ) # Get new labels from cube and pre-defined rules from user - labels <- .reclassify_new_labels(cube, rules) + cube_labels <- .reclassify_new_labels(cube, rules) # Classify the data - class_tile <- .reclassify_tile( + .reclassify_tile( tile = tile, mask = mask, band = "class", - labels = labels, + labels = cube_labels, reclassify_fn = reclassify_fn, output_dir = output_dir, version = version ) - return(class_tile) }, mask = mask) class(class_cube) <- c("class_cube", class(class_cube)) return(class_cube) diff --git a/R/sits_reduce.R b/R/sits_reduce.R index 31e6e0a50..c0c163312 100644 --- a/R/sits_reduce.R +++ b/R/sits_reduce.R @@ -103,7 +103,8 @@ sits_reduce <- function(data, ...) { #' @rdname sits_reduce #' @export sits_reduce.sits <- function(data, ...) { - data <- .check_samples(data) + .check_samples(data) + data <- .samples_convert_to_sits(data) # Get samples bands bands <- .samples_bands(data) # Get output band expression @@ -121,14 +122,8 @@ sits_reduce.sits <- function(data, ...) { # Get all input band in_band <- .apply_input_bands(data, bands = bands, expr = expr) # Reduce samples - data <- .reduce_samples( - data, expr = expr, in_band = in_band, out_band = out_band - ) - # Return the reduced cube - return(data) + .reduce_samples(data, expr = expr, in_band = in_band, out_band = out_band) } - - #' @rdname sits_reduce #' @export sits_reduce.raster_cube <- function(data, ..., diff --git a/R/sits_reduce_imbalance.R b/R/sits_reduce_imbalance.R index 057c37a88..c01cb3903 100644 --- a/R/sits_reduce_imbalance.R +++ b/R/sits_reduce_imbalance.R @@ -86,7 +86,7 @@ sits_reduce_imbalance <- function(samples, ) # get the bands and the labels bands <- .samples_bands(samples) - labels <- .samples_labels(samples) + samples_labels <- .samples_labels(samples) # params of output tibble lat <- 0.0 long <- 0.0 @@ -157,21 +157,21 @@ sits_reduce_imbalance <- function(samples, ) }) class(samples_band) <- c("sits", class(samples_band)) - return(samples_band) + samples_band }) tb_class_new <- samples_bands[[1]] for (i in seq_along(samples_bands)[-1]) { tb_class_new <- sits_merge(tb_class_new, samples_bands[[i]]) } - return(tb_class_new) + tb_class_new }) # bind oversampling results samples_over_new <- dplyr::bind_rows(samples_over_new) new_samples <- dplyr::bind_rows(new_samples, samples_over_new) } # keep classes (no undersampling nor oversampling) - classes_ok <- labels[!(labels %in% classes_under | - labels %in% classes_over)] + classes_ok <- samples_labels[!(samples_labels %in% classes_under | + samples_labels %in% classes_over)] if (length(classes_ok) > 0) { samples_classes_ok <- dplyr::filter( samples, diff --git a/R/sits_regularize.R b/R/sits_regularize.R index 3ad398ebc..a6d9ec5da 100644 --- a/R/sits_regularize.R +++ b/R/sits_regularize.R @@ -40,7 +40,7 @@ #' \enumerate{ #' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from #' a cloud provider.} -#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection #' from a cloud provider to a local directory for faster processing.} #' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube #' from an ARD image collection.} @@ -272,7 +272,7 @@ sits_regularize.sar_cube <- function(cube, ..., on.exit(.parallel_stop(), add = TRUE) # Call regularize in parallel - cube <- .reg_cube( + .reg_cube( cube = cube, timeline = timeline, res = res, @@ -281,7 +281,6 @@ sits_regularize.sar_cube <- function(cube, ..., output_dir = output_dir, progress = progress ) - return(cube) } #' @rdname sits_regularize #' @export @@ -306,10 +305,8 @@ sits_regularize.combined_cube <- function(cube, ..., .check_roi_tiles(roi, tiles) if (.has(grid_system)) { .check_grid_system(grid_system) - } else { - if (any("NoTilingSystem" %in% .cube_tiles(cube) )) { + } else if (any("NoTilingSystem" %in% .cube_tiles(cube))) { grid_system <- "MGRS" - } } # Get a global timeline timeline <- .gc_get_valid_timeline( @@ -338,8 +335,7 @@ sits_regularize.combined_cube <- function(cube, ..., ) }) # In case where more than two cubes need to be merged - combined_cube <- purrr::reduce(reg_cubes, sits_merge) - return(combined_cube) + purrr::reduce(reg_cubes, sits_merge) } #' @rdname sits_regularize #' @export @@ -389,7 +385,7 @@ sits_regularize.rainfall_cube <- function(cube, ..., .parallel_start(workers = multicores) on.exit(.parallel_stop(), add = TRUE) # Call regularize in parallel - cube <- .reg_cube( + .reg_cube( cube = cube, timeline = timeline, res = res, @@ -398,7 +394,6 @@ sits_regularize.rainfall_cube <- function(cube, ..., output_dir = output_dir, progress = progress ) - return(cube) } #' @rdname sits_regularize #' @export @@ -417,8 +412,6 @@ sits_regularize.dem_cube <- function(cube, ..., .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1, max = 2048) .check_progress(progress) - # Get dots - dots <- list(...) # check for ROI and tiles if (!is.null(roi) || !is.null(tiles)) { .check_roi_tiles(roi, tiles) @@ -447,7 +440,7 @@ sits_regularize.dem_cube <- function(cube, ..., .parallel_start(workers = multicores) on.exit(.parallel_stop(), add = TRUE) # Call regularize in parallel - cube <- .reg_cube( + .reg_cube( cube = cube, timeline = NULL, res = res, @@ -456,7 +449,6 @@ sits_regularize.dem_cube <- function(cube, ..., output_dir = output_dir, progress = progress ) - return(cube) } #' @rdname sits_regularize #' @export diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R index a2912941e..675b9c4d0 100644 --- a/R/sits_sample_functions.R +++ b/R/sits_sample_functions.R @@ -118,11 +118,11 @@ sits_sample <- function(data, #' } #' @export sits_confidence_sampling <- function(probs_cube, - n = 20L, + n = 20, min_margin = 0.90, - sampling_window = 10L, - multicores = 1L, - memsize = 1L) { + sampling_window = 10, + multicores = 1, + memsize = 1) { .check_set_caller("sits_confidence_sampling") # Pre-conditions .check_is_probs_cube(probs_cube) @@ -133,7 +133,7 @@ sits_confidence_sampling <- function(probs_cube, .check_int_parameter(memsize, min = 1, max = 16384) # get labels - labels <- .cube_labels(probs_cube) + cube_labels <- .cube_labels(probs_cube) # The following functions define optimal parameters for parallel processing # @@ -181,7 +181,8 @@ sits_confidence_sampling <- function(probs_cube, # Process jobs in parallel .jobs_map_parallel_dfr(chunks, function(chunk) { # Get samples for each label - purrr::map2_dfr(labels, seq_along(labels), function(lab, i) { + purrr::map2_dfr(cube_labels, seq_along(cube_labels), + function(lab, i) { # Get a list of values of high confidence & apply threshold top_values <- .raster_open_rast(tile_path) |> .raster_get_top_values( @@ -207,8 +208,7 @@ sits_confidence_sampling <- function(probs_cube, top_values[["start_date"]] <- .tile_start_date(tile) top_values[["end_date"]] <- .tile_end_date(tile) top_values[["label"]] <- lab - - return(top_values) + top_values }) }) }) @@ -314,14 +314,14 @@ sits_sampling_design <- function(cube, .check_that(inherits(cube, "class_cube") || inherits(cube, "class_vector_cube")) # get the labels - labels <- .cube_labels(cube) - n_labels <- length(labels) + cube_labels <- .cube_labels(cube) + n_labels <- length(cube_labels) if (length(expected_ua) == 1) { expected_ua <- rep(expected_ua, n_labels) - names(expected_ua) <- labels + names(expected_ua) <- cube_labels } # check names of labels - .check_that(all(names(expected_ua) %in% labels)) + .check_that(all(names(expected_ua) %in% cube_labels)) # get cube class areas class_areas <- .cube_class_areas(cube) # define which classes from the selected ones are available in the cube. @@ -334,7 +334,7 @@ sits_sampling_design <- function(cube, class_areas <- class_areas[available_classes] expected_ua <- expected_ua[available_classes] # check that names of class areas are contained in the labels - .check_that(all(names(class_areas) %in% labels), + .check_that(all(names(class_areas) %in% cube_labels), msg = .conf("messages", "sits_sampling_design_labels")) # calculate proportion of class areas prop <- class_areas / sum(class_areas) @@ -448,12 +448,12 @@ sits_stratified_sampling <- function(cube, .check_that(inherits(cube, "class_cube") || inherits(cube, "class_vector_cube")) # get the labels - labels <- .cube_labels(cube) - n_labels <- length(labels) + cube_labels <- .cube_labels(cube) + n_labels <- length(cube_labels) # check number of labels .check_that(nrow(sampling_design) <= n_labels) # check names of labels - .check_that(all(rownames(sampling_design) %in% labels)) + .check_that(all(rownames(sampling_design) %in% cube_labels)) # check allocation method .check_that(alloc %in% colnames(sampling_design), msg = .conf("messages", "sits_stratified_sampling_alloc")) @@ -468,8 +468,8 @@ sits_stratified_sampling <- function(cube, # check progress .check_progress(progress) # transform labels to tibble - labels <- tibble::rownames_to_column( - as.data.frame(labels), var = "label_id" + cube_labels <- tibble::rownames_to_column( + as.data.frame(cube_labels), var = "label_id" ) |> dplyr::mutate(label_id = as.numeric(.data[["label_id"]])) # transform sampling design data to tibble @@ -480,7 +480,7 @@ sits_stratified_sampling <- function(cube, # correct class / values from the cube samples_class <- dplyr::inner_join( x = sampling_design, - y = labels, + y = cube_labels, by = "labels" ) |> dplyr::select("labels", "label_id", dplyr::all_of(alloc)) |> diff --git a/R/sits_segmentation.R b/R/sits_segmentation.R index 41b86fe66..70bffdca9 100644 --- a/R/sits_segmentation.R +++ b/R/sits_segmentation.R @@ -324,7 +324,7 @@ sits_slic <- function(data = NULL, clean = TRUE, centers = TRUE, dist_name = dist_fun, dist_fun = function() "", avg_fun_fun = function() "", avg_fun_name = avg_fun, iter = iter, minarea = minarea, - input_centers = matrix(c(0L, 0L), ncol = 2), + input_centers = matrix(c(0, 0), ncol = 2), verbose = as.integer(verbose) ) # Set values and NA value in template raster diff --git a/R/sits_select.R b/R/sits_select.R index 20519120e..41dce6abd 100644 --- a/R/sits_select.R +++ b/R/sits_select.R @@ -105,7 +105,5 @@ sits_select.default <- function(data, ...) { class(data) <- c("sits", class(data)) else stop(.conf("messages", "sits_select")) - data <- sits_select(data, ...) - return(data) - + sits_select(data, ...) } diff --git a/R/sits_sf.R b/R/sits_sf.R index 5def3a6f5..6e187af1b 100644 --- a/R/sits_sf.R +++ b/R/sits_sf.R @@ -34,7 +34,8 @@ sits_as_sf <- function(data, ...) { #' @rdname sits_as_sf sits_as_sf.sits <- function(data, ..., crs = "EPSG:4326", as_crs = NULL) { # Pre-conditions - data <- .check_samples(data) + .check_samples(data) + data <- .samples_convert_to_sits(data) # Convert samples to sf geom <- .point_as_sf(.point(data, crs = crs), as_crs = as_crs) # Bind columns @@ -49,10 +50,9 @@ sits_as_sf.raster_cube <- function(data, ..., as_crs = NULL) { .check_is_raster_cube(data) # Convert cube bbox to sf data_sf <- .cube_as_sf(data, as_crs = as_crs) - # Bind columns - data <- dplyr::bind_cols(data_sf, "file_info") - return(data) + dplyr::bind_cols(data_sf, .discard(data, "file_info")) } + #' @export #' @rdname sits_as_sf sits_as_sf.vector_cube <- function(data, ..., as_crs = NULL) { @@ -61,7 +61,18 @@ sits_as_sf.vector_cube <- function(data, ..., as_crs = NULL) { # Convert cube bbox to sf data_sf <- .cube_as_sf(data, as_crs = as_crs) # Bind columns - data <- dplyr::bind_cols(data_sf, "file_info") - data <- dplyr::bind_cols(data_sf, "vector_info") - return(data) + dplyr::bind_cols(data_sf, .discard(data, c("file_info", "vector_info"))) +} +#' @export +#' @rdname sits_as_sf +#' @export +sits_as_sf.default <- function(data, ...) { + data <- tibble::as_tibble(data) + if (all(.conf("sits_cube_cols") %in% colnames(data))) + data <- .cube_find_class(data) + else if (all(.conf("sits_tibble_cols") %in% colnames(data))) + class(data) <- c("sits", class(data)) + else + stop(.conf("messages", "sits_select")) + sits_as_sf(data, ...) } diff --git a/R/sits_smooth.R b/R/sits_smooth.R index 37ca986dd..cf760c614 100644 --- a/R/sits_smooth.R +++ b/R/sits_smooth.R @@ -38,7 +38,7 @@ #' \enumerate{ #' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from #' a cloud provider.} -#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection #' from a cloud provider to a local directory for faster processing.} #' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube #' from an ARD image collection.} @@ -116,7 +116,7 @@ sits_smooth <- function(cube, ...) { sits_smooth.probs_cube <- function(cube, ..., window_size = 9L, neigh_fraction = 0.5, - smoothness = 20L, + smoothness = 20, exclusion_mask = NULL, memsize = 4L, multicores = 2L, @@ -205,7 +205,7 @@ sits_smooth.probs_vector_cube <- function(cube, ...) { } #' @rdname sits_smooth #' @export -sits_smooth.raster_cube <- function(cube,...) { +sits_smooth.raster_cube <- function(cube, ...) { stop(.conf("messages", "sits_smooth_default")) } #' @rdname sits_smooth @@ -215,12 +215,11 @@ sits_smooth.derived_cube <- function(cube, ...) { } #' @rdname sits_smooth #' @export -sits_smooth.default <- function(cube,...) { +sits_smooth.default <- function(cube, ...) { cube <- tibble::as_tibble(cube) if (all(.conf("sits_cube_cols") %in% colnames(cube))) cube <- .cube_find_class(cube) else stop(.conf("messages", "sits_smooth_default")) - cube <- sits_smooth(cube,...) - return(cube) + sits_smooth(cube, ...) } diff --git a/R/sits_stars.R b/R/sits_stars.R index eebd79ab1..acac72b9e 100644 --- a/R/sits_stars.R +++ b/R/sits_stars.R @@ -34,10 +34,10 @@ #' } #' @export sits_as_stars <- function(cube, - tile = cube[1,]$tile, + tile = cube[1, ]$tile, bands = NULL, dates = NULL, - proxy = FALSE){ + proxy = FALSE) { # Pre-conditions .check_set_caller("sits_as_stars") .check_is_raster_cube(cube) @@ -55,9 +55,9 @@ sits_as_stars <- function(cube, if (.has(bands)) { .check_cube_bands(tile_cube, bands) fi <- .fi_filter_bands(fi, bands) - } else + } else { bands <- .tile_bands(tile_cube) - + } # filter dates if (.has(dates)) { # proxy? only one date is retrieved @@ -65,8 +65,10 @@ sits_as_stars <- function(cube, dates <- dates[[1]] .check_dates_timeline(dates, tile_cube) fi <- .fi_filter_dates(fi, dates) - } else + } else { dates <- as.Date(.tile_timeline(tile_cube)) + } + # retrieve files image_files <- .fi_paths(fi) diff --git a/R/sits_summary.R b/R/sits_summary.R index 510dd5c12..1857c8e27 100644 --- a/R/sits_summary.R +++ b/R/sits_summary.R @@ -176,7 +176,7 @@ summary.raster_cube <- function(object, ..., tile = NULL, date = NULL) { } # Display raster summary cli::cli_h1("Cube Summary") - sum <- slider::slide(object, function(tile) { + tile_sum <- slider::slide(object, function(tile) { # Get the first date to not read all images date <- .default(date, .tile_timeline(tile)[[1]]) tile <- .tile_filter_dates(tile, date) @@ -184,9 +184,9 @@ summary.raster_cube <- function(object, ..., tile = NULL, date = NULL) { tile <- .tile_filter_bands(tile, bands) cli::cli_h3("Tile: {.field {tile$tile}} and Date: {.field {date}}") rast <- .raster_open_rast(.tile_paths(tile)) - sum <- suppressWarnings(.raster_summary(rast)) - print(sum) - return(sum) + rast_sum <- suppressWarnings(.raster_summary(rast)) + print(rast_sum) + rast_sum }) # Return the summary from the cube names(sum) <- .cube_tiles(object) @@ -228,31 +228,29 @@ summary.raster_cube <- function(object, ..., tile = NULL, date = NULL) { #' @export summary.derived_cube <- function(object, ..., sample_size = 10000) { .check_set_caller("summary_derived_cube") - # Get cube labels - labels <- unname(.cube_labels(object)) # Extract variance values for each tiles using a sample size var_values <- slider::slide(object, function(tile) { # get the bands band <- .tile_bands(tile) # extract the file path - file <- .tile_paths(tile) + tile_file <- .tile_paths(tile) # read the files with terra - r <- .raster_open_rast(file) + r <- .raster_open_rast(tile_file) # get the a sample of the values values <- r |> .raster_sample(size = sample_size, na.rm = TRUE) # scale the values band_conf <- .tile_band_conf(tile, band) - scale <- .scale(band_conf) - offset <- .offset(band_conf) - values <- values * scale + offset + band_scale <- .scale(band_conf) + band_offset <- .offset(band_conf) + values <- values * band_scale + band_offset values }) # Combine variance values var_values <- dplyr::bind_rows(var_values) var_values <- summary(var_values) # Update columns name - colnames(var_values) <- labels + colnames(var_values) <- unname(.cube_labels(object)) # Return summary values return(var_values) } @@ -299,30 +297,27 @@ summary.variance_cube <- function( sample_size = 10000, quantiles = c("75%", "80%", "85%", "90%", "95%", "100%")) { .check_set_caller("summary_variance_cube") - # Get cube labels - labels <- unname(.cube_labels(object)) # Extract variance values for each tiles using a sample size var_values <- slider::slide(object, function(tile) { # get the bands band <- .tile_bands(tile) # extract the file path - file <- .tile_paths(tile) # read the files with terra - r <- .raster_open_rast(file) + rast <- .raster_open_rast(.tile_paths(tile)) # get the a sample of the values - values <- r |> + values <- rast |> .raster_sample(size = sample_size, na.rm = TRUE) # scale the values band_conf <- .tile_band_conf(tile, band) - scale <- .scale(band_conf) - offset <- .offset(band_conf) - values <- values * scale + offset + band_scale <- .scale(band_conf) + band_offset <- .offset(band_conf) + values <- values * band_scale + band_offset values }) # Combine variance values var_values <- dplyr::bind_rows(var_values) # Update columns name - colnames(var_values) <- labels + colnames(var_values) <- .cube_labels(object) # Extract quantile for each column var_values <- dplyr::reframe( var_values, @@ -331,8 +326,8 @@ summary.variance_cube <- function( }) ) # Update row names - percent_intervals <- paste0(seq(from = 0, to = 1, by = intervals)*100, "%") - rownames(var_values) <- percent_intervals + perc_intervals <- paste0(seq(from = 0, to = 1, by = intervals) * 100, "%") + rownames(var_values) <- perc_intervals # Return variance values filtered by quantiles return(var_values[quantiles, ]) } @@ -372,16 +367,14 @@ summary.variance_cube <- function( #' @export summary.class_cube <- function(object, ...) { .check_set_caller("summary_class_cube") - # Get cube labels - labels <- unname(.cube_labels(object)) # Extract classes values for each tiles using a sample size classes_areas <- slider::slide(object, function(tile) { # get the bands band <- .tile_bands(tile) # extract the file path - file <- .tile_paths(tile) + tile_file <- .tile_paths(tile) # read the files with terra - r <- .raster_open_rast(file) + r <- .raster_open_rast(tile_file) # get a frequency of values class_areas <- .raster_freq(r) # transform to km^2 @@ -392,16 +385,17 @@ summary.class_cube <- function(object, ...) { class_areas, value = as.character(.data[["value"]]) ) # create a data.frame with the labels - labels <- .tile_labels(tile) - df1 <- tibble::tibble(value = names(labels), class = unname(labels)) + tile_labels <- .tile_labels(tile) + df1 <- tibble::tibble(value = names(tile_labels), + class = unname(tile_labels)) # join the labels with the areas - sum <- dplyr::full_join(df1, class_areas, by = "value") - sum <- dplyr::mutate(sum, + sum_areas <- dplyr::full_join(df1, class_areas, by = "value") + sum_areas <- dplyr::mutate(sum_areas, area_km2 = signif(.data[["area"]], 2), .keep = "unused" ) # remove layer information - sum_clean <- sum[, -3] |> + sum_clean <- sum_areas[, -3] |> tidyr::replace_na(list(layer = 1, count = 0, area_km2 = 0)) sum_clean @@ -415,5 +409,5 @@ summary.class_cube <- function(object, ...) { .groups = "keep") |> dplyr::ungroup() # Return classes areas - return(classes_areas) + classes_areas } diff --git a/R/sits_tae.R b/R/sits_tae.R index e5af9c07a..bbae53892 100644 --- a/R/sits_tae.R +++ b/R/sits_tae.R @@ -211,7 +211,6 @@ sits_tae <- function(samples = NULL, dim_input_decoder, dim_layers_decoder ) - # softmax is done after classification - removed from here }, forward = function(x) { x <- x |> @@ -219,7 +218,6 @@ sits_tae <- function(samples = NULL, self$temporal_attention_encoder() |> self$decoder() # softmax is done after classification - removed from here - # self$softmax() return(x) } ) @@ -274,8 +272,6 @@ sits_tae <- function(samples = NULL, suppressWarnings(torch::torch_set_num_threads(1)) # Unserialize model torch_model[["model"]] <- .torch_unserialize_model(serialized_model) - # Used to check values (below) - input_pixels <- nrow(values) # Transform input into a 3D tensor # Reshape the 2D matrix into a 3D array n_samples <- nrow(values) @@ -313,10 +309,9 @@ sits_tae <- function(samples = NULL, predict_fun <- .set_class( predict_fun, "torch_model", "sits_model", class(predict_fun) ) - return(predict_fun) + predict_fun } # If samples is informed, train a model and return a predict function # Otherwise give back a train function to train model further - result <- .factory_function(samples, train_fun) - return(result) + .factory_function(samples, train_fun) } diff --git a/R/sits_tempcnn.R b/R/sits_tempcnn.R index 448093a5c..0ad658e76 100644 --- a/R/sits_tempcnn.R +++ b/R/sits_tempcnn.R @@ -152,17 +152,17 @@ sits_tempcnn <- function(samples = NULL, x = optim_params_function, val = opt_hparams ) - # Samples labels - labels <- .samples_labels(samples) - # Samples bands + # Sample labels + sample_labels <- .samples_labels(samples) + # Sample bands bands <- .samples_bands(samples) - # Samples timeline + # Sample timeline timeline <- .samples_timeline(samples) # Create numeric labels vector - code_labels <- seq_along(labels) - names(code_labels) <- labels + code_labels <- seq_along(sample_labels) + names(code_labels) <- sample_labels # Number of labels, bands, and number of samples (used below) - n_labels <- length(labels) + n_labels <- length(sample_labels) n_bands <- length(bands) n_times <- .samples_ntimes(samples) # Data normalization @@ -173,7 +173,7 @@ sits_tempcnn <- function(samples = NULL, samples = samples, samples_validation = samples_validation, ml_stats = ml_stats, - labels = labels, + labels = sample_labels, code_labels = code_labels, timeline = timeline, bands = bands, @@ -318,8 +318,6 @@ sits_tempcnn <- function(samples = NULL, suppressWarnings(torch::torch_set_num_threads(1)) # Unserialize model torch_model[["model"]] <- .torch_unserialize_model(serialized_model) - # Used to check values (below) - input_pixels <- nrow(values) # Transform input into a 3D tensor # Reshape the 2D matrix into a 3D array n_samples <- nrow(values) @@ -351,17 +349,15 @@ sits_tempcnn <- function(samples = NULL, # Convert from tensor to array values <- torch::as_array(values) # Update the columns names to labels - colnames(values) <- labels + colnames(values) <- sample_labels return(values) } # Set model class predict_fun <- .set_class( predict_fun, "torch_model", "sits_model", class(predict_fun) ) - return(predict_fun) } # If samples is informed, train a model and return a predict function # Otherwise give back a train function to train model further - result <- .factory_function(samples, train_fun) - return(result) + .factory_function(samples, train_fun) } diff --git a/R/sits_terra.R b/R/sits_terra.R index 5fc6f44bb..abfa23551 100644 --- a/R/sits_terra.R +++ b/R/sits_terra.R @@ -29,8 +29,8 @@ #' } #' @export sits_as_terra <- function(cube, - tile = cube[1,]$tile, - ...){ + tile = cube[1, ]$tile, + ...) { # Pre-conditions .check_set_caller("sits_as_terra") .check_is_raster_cube(cube) @@ -44,10 +44,10 @@ sits_as_terra <- function(cube, #' @rdname sits_as_terra #' @export sits_as_terra.raster_cube <- function(cube, - tile = cube[1,]$tile, + tile = cube[1, ]$tile, ..., bands = NULL, - date = NULL){ + date = NULL) { # extract tile from cube tile_cube <- .cube_filter_tiles(cube, tile) # get file info for tile @@ -57,9 +57,9 @@ sits_as_terra.raster_cube <- function(cube, if (.has(bands)) { .check_cube_bands(tile_cube, bands) fi <- .fi_filter_bands(fi, bands) - } else + } else { bands <- .tile_bands(tile_cube) - + } # filter dates if (.has(date)) .check_dates_timeline(date, tile_cube) @@ -79,8 +79,8 @@ sits_as_terra.raster_cube <- function(cube, #' @rdname sits_as_terra #' @export sits_as_terra.probs_cube <- function(cube, - tile = cube[1,]$tile, - ...){ + tile = cube[1, ]$tile, + ...) { # extract tile from cube tile_cube <- .cube_filter_tiles(cube, tile) # get file info for tile @@ -90,17 +90,17 @@ sits_as_terra.probs_cube <- function(cube, # export spatial raster spatial_raster <- terra::rast(image_file) # get all labels - labels <- .tile_labels(tile_cube) + cube_labels <- .tile_labels(tile_cube) # save names in terra object - names(spatial_raster) <- labels + names(spatial_raster) <- cube_labels # return return(spatial_raster) } #' @rdname sits_as_terra #' @export sits_as_terra.class_cube <- function(cube, - tile = cube[1,]$tile, - ...){ + tile = cube[1, ]$tile, + ...) { # extract tile from cube tile_cube <- .cube_filter_tiles(cube, tile) # get file info for tile @@ -110,11 +110,11 @@ sits_as_terra.class_cube <- function(cube, # create spatial raster spatial_raster <- terra::rast(image_file) # get all labels - labels <- .tile_labels(tile_cube) + cube_labels <- .tile_labels(tile_cube) # set levels for raster terra_levels <- data.frame( - id = as.numeric(names(labels)), - cover = unname(labels) + id = as.numeric(names(cube_labels)), + cover = unname(cube_labels) ) levels(spatial_raster) <- terra_levels # return diff --git a/R/sits_texture.R b/R/sits_texture.R index 9d22feee4..8eee231c4 100644 --- a/R/sits_texture.R +++ b/R/sits_texture.R @@ -191,7 +191,7 @@ sits_texture.raster_cube <- function(cube, ..., # Process each feature in parallel features_band <- .jobs_map_sequential_dfr(features_cube, function(feature) { # Process the data - output_feature <- .texture_feature( + .texture_feature( feature = feature, block = block, expr = expr, @@ -202,7 +202,6 @@ sits_texture.raster_cube <- function(cube, ..., overlap = overlap, output_dir = output_dir ) - return(output_feature) }) # Join output features as a cube and return it .cube_merge_tiles(dplyr::bind_rows(list(features_cube, features_band))) @@ -224,7 +223,5 @@ sits_texture.default <- function(cube, ...) { } else { stop(.conf("messages", "sits_texture_default")) } - - acc <- sits_texture(cube, ...) - return(acc) + sits_texture(cube, ...) } diff --git a/R/sits_timeline.R b/R/sits_timeline.R index 65520b4f0..cf3c908fd 100644 --- a/R/sits_timeline.R +++ b/R/sits_timeline.R @@ -18,7 +18,7 @@ sits_timeline <- function(data) { #' @export #' sits_timeline.sits <- function(data) { - return(.samples_timeline(data)) + .samples_timeline(data) } #' @rdname sits_timeline #' @export @@ -26,7 +26,7 @@ sits_timeline.sits <- function(data) { sits_timeline.sits_model <- function(data) { .check_is_sits_model(data) samples <- .ml_samples(data) - return(as.Date(samples[["time_series"]][[1]][["Index"]])) + as.Date(samples[["time_series"]][[1]][["Index"]]) } #' @rdname sits_timeline #' @export @@ -35,18 +35,17 @@ sits_timeline.raster_cube <- function(data) { .check_set_caller("sits_timeline_raster_cube") # pick the list of timelines timelines_lst <- slider::slide(data, function(tile) { - timeline_tile <- .tile_timeline(tile) - return(timeline_tile) + .tile_timeline(tile) }) names(timelines_lst) <- data[["tile"]] timeline_unique <- unname(unique(timelines_lst)) if (length(timeline_unique) == 1) { - return(timeline_unique[[1]]) + timeline_unique[[1]] } else { # warning if there is more than one timeline .check_warnings_timeline_cube() - return(timelines_lst) + timelines_lst } } #' @rdname sits_timeline @@ -55,7 +54,7 @@ sits_timeline.raster_cube <- function(data) { sits_timeline.derived_cube <- function(data) { # return the timeline of the cube timeline <- .tile_timeline(data) - return(timeline) + timeline } #' @rdname sits_timeline #' @export @@ -68,7 +67,7 @@ sits_timeline.tbl_df <- function(data) { else stop(.conf("messages", "sits_timeline_default")) timeline <- sits_timeline(data) - return(timeline) + timeline } #' @rdname sits_timeline #' @export @@ -76,6 +75,6 @@ sits_timeline.tbl_df <- function(data) { sits_timeline.default <- function(data) { data <- tibble::as_tibble(data) timeline <- sits_timeline(data) - return(timeline) + timeline } diff --git a/R/sits_train.R b/R/sits_train.R index 533ae2f99..b6baa2204 100644 --- a/R/sits_train.R +++ b/R/sits_train.R @@ -25,7 +25,7 @@ #' \enumerate{ #' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from #' a cloud provider.} -#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection #' from a cloud provider to a local directory for faster processing.} #' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube #' from an ARD image collection.} @@ -45,7 +45,7 @@ #' from a smoothed cube.} #' } #' -#' \code{sits_train} provides a standard interface to all machine learning models. +#' \code{sits_train} provides a standard interface to machine learning models. #' It takes two mandatory parameters: the training data (\code{samples}) #' and the ML algorithm (\code{ml_method}). The output is a model that #' can be used to classify individual time series or data cubes diff --git a/R/sits_tuning.R b/R/sits_tuning.R index a14847f3d..837569fd1 100644 --- a/R/sits_tuning.R +++ b/R/sits_tuning.R @@ -176,7 +176,7 @@ sits_tuning <- function(samples, ) # Remove variable 'ml_method' remove(ml_method) - return(result) + result }, progress = progress, n_retries = 0) # prepare result @@ -189,7 +189,7 @@ sits_tuning <- function(samples, tuning_tb <- dplyr::arrange(tuning_tb, dplyr::desc(.data[["accuracy"]])) # prepare result class class(tuning_tb) <- c("sits_tuned", class(tuning_tb)) - return(tuning_tb) + tuning_tb } #' @title Tuning machine learning models hyper-parameters #' @name sits_tuning_hparams @@ -254,5 +254,5 @@ sits_tuning <- function(samples, sits_tuning_hparams <- function(...) { params <- substitute(list(...), environment()) params <- as.list(params)[-1] - return(params) + params } diff --git a/R/sits_uncertainty.R b/R/sits_uncertainty.R index 71f1e04b9..ac9f38142 100644 --- a/R/sits_uncertainty.R +++ b/R/sits_uncertainty.R @@ -244,11 +244,11 @@ sits_uncertainty.default <- function(cube, ...) { #' #' @export sits_uncertainty_sampling <- function(uncert_cube, - n = 100L, + n = 100, min_uncert = 0.4, - sampling_window = 10L, - multicores = 1L, - memsize = 1L) { + sampling_window = 10, + multicores = 1, + memsize = 1) { .check_set_caller("sits_uncertainty_sampling") # Pre-conditions .check_is_uncert_cube(uncert_cube) @@ -322,9 +322,8 @@ sits_uncertainty_sampling <- function(uncert_cube, result_tile[["start_date"]] <- .tile_start_date(uncert_cube) result_tile[["end_date"]] <- .tile_end_date(uncert_cube) result_tile[["label"]] <- "NoClass" - return(result_tile) + result_tile }) samples_tb <- dplyr::rename(samples_tb, uncertainty = value) - - return(samples_tb) + samples_tb } diff --git a/R/sits_utils.R b/R/sits_utils.R index 840175012..de70b6911 100644 --- a/R/sits_utils.R +++ b/R/sits_utils.R @@ -27,10 +27,10 @@ sits_show_prediction <- function(class) { # set caller to show in errors .check_set_caller("sits_show_prediction") .check_predicted(class) - return(dplyr::select( + dplyr::select( dplyr::bind_rows(class[["predicted"]]), c("from", "to", "class") - )) + ) } #' @title Informs if sits tests should run @@ -44,7 +44,7 @@ sits_show_prediction <- function(class) { #' @return TRUE/FALSE #' @export sits_run_tests <- function() { - return(!Sys.getenv("SITS_RUN_TESTS") %in% c("", "NO", "FALSE", "OFF")) + !Sys.getenv("SITS_RUN_TESTS") %in% c("", "NO", "FALSE", "OFF") } #' @title Informs if sits examples should run #' @@ -60,5 +60,5 @@ sits_run_tests <- function() { #' @return A logical value #' @export sits_run_examples <- function() { - return(!Sys.getenv("SITS_RUN_EXAMPLES") %in% c("", "NO", "FALSE", "OFF")) + !Sys.getenv("SITS_RUN_EXAMPLES") %in% c("", "NO", "FALSE", "OFF") } diff --git a/R/sits_validate.R b/R/sits_validate.R index f6c26ba69..32417465f 100644 --- a/R/sits_validate.R +++ b/R/sits_validate.R @@ -90,12 +90,12 @@ sits_kfold_validate <- function(samples, multicores <- 1 } # Get labels from samples - labels <- .samples_labels(samples) + sample_labels <- .samples_labels(samples) # Create numeric labels vector - code_labels <- seq_along(labels) - names(code_labels) <- labels + code_labels <- seq_along(sample_labels) + names(code_labels) <- sample_labels # Is the data labelled? - .check_that(!("NoClass" %in% labels), + .check_that(!("NoClass" %in% sample_labels), msg = .conf("messages", "sits_kfold_validate_samples") ) # Create partitions different splits of the input data @@ -120,7 +120,7 @@ sits_kfold_validate <- function(samples, pred <- tidyr::unnest(values, "predicted")[["class"]] # Convert samples time series in predictors and preprocess data ref <- values[["label"]] - return(list(pred = pred, ref = ref)) + list(pred = pred, ref = ref) }) # create predicted and reference vectors pred <- unlist(lapply(conf_lst, function(x) x[["pred"]])) diff --git a/R/sits_view.R b/R/sits_view.R index a989e16c4..e99c7bb1e 100644 --- a/R/sits_view.R +++ b/R/sits_view.R @@ -229,7 +229,7 @@ sits_view.som_map <- function(x, ..., # get the samples samples <- x[["data"]] - labels <- sort(unique(samples[["label"]])) + cube_labels <- sort(unique(samples[["label"]])) for (id in id_neurons) { # assign group name (one neuron per) @@ -242,7 +242,7 @@ sits_view.som_map <- function(x, ..., leaf_map <- leaf_map |> .view_neurons( samples = samples_neuron, - labels = labels, + labels = cube_labels, group = group, legend = legend, palette = palette, @@ -301,7 +301,7 @@ sits_view.raster_cube <- function(x, ..., # check logical control .check_lgl_parameter(add) # pre-condition for bands - bands <- .check_bw_rgb_bands(x, band, red, green, blue) + bands <- .band_set_bw_rgb(x, band, red, green, blue) if (length(bands) == 1) band_name <- bands[[1]] else @@ -324,18 +324,18 @@ sits_view.raster_cube <- function(x, ..., cube <- dplyr::filter(x, .data[["tile"]] %in% tiles) # create a new layer in the leaflet for (i in seq_len(nrow(cube))) { - row <- cube[i, ] - tile_name <- row[["tile"]] + tile_row <- cube[i, ] + tile_name <- tile_row[["tile"]] # check dates if (.has(dates)) - .check_dates_timeline(dates, row) + .check_dates_timeline(dates, tile_row) else - dates <- .fi_date_least_cloud_cover(.fi(row)) + dates <- .fi_date_least_cloud_cover(.fi(tile_row)) for (date in dates) { # convert to proper date - date <- lubridate::as_date(date) + view_date <- lubridate::as_date(date) # add group - group <- paste(tile_name, date, band_name) + group <- paste(tile_name, view_date, band_name) # recover global leaflet and include group overlay_groups <- append(overlay_groups, group) # view image raster @@ -343,7 +343,7 @@ sits_view.raster_cube <- function(x, ..., .view_image_raster( group = group, tile = row, - date = as.Date(date), + date = as.Date(view_date), bands = bands, palette = palette, rev = rev, @@ -412,22 +412,22 @@ sits_view.uncertainty_cube <- function(x, ..., # create a new layer in the leaflet for (i in seq_len(nrow(cube))) { - row <- cube[i, ] - tile_name <- row[["tile"]] - band <- .tile_bands(row) + tile_row <- cube[i, ] + tile_name <- tile_row[["tile"]] + band <- .tile_bands(tile_row) # add group group <- paste(tile_name, band) # recover global leaflet and include group overlay_groups <- append(overlay_groups, group) # get image file associated to band - band_file <- .tile_path(row, band) + band_file <- .tile_path(tile_row, band) # scale and offset - band_conf <- .tile_band_conf(row, band) + band_conf <- .tile_band_conf(tile_row, band) # view image raster leaf_map <- leaf_map |> .view_bw_band( group = group, - tile = row, + tile = tile_row, band_file = band_file, band_conf = band_conf, palette = palette, @@ -458,7 +458,7 @@ sits_view.class_cube <- function(x, ..., opacity = 0.85, max_cog_size = 2048, leaflet_megabytes = 32, - add = FALSE){ + add = FALSE) { # set caller for errors .check_set_caller("sits_view_class_cube") # preconditions @@ -575,13 +575,13 @@ sits_view.probs_cube <- function(x, ..., cube <- dplyr::filter(x, .data[["tile"]] %in% tiles) # get all labels to be plotted - labels <- .tile_labels(cube) - names(labels) <- seq_along(labels) + cube_labels <- .tile_labels(cube) + names(labels) <- seq_along(cube_labels) # create a new layer in the leaflet for (i in seq_len(nrow(cube))) { - row <- cube[i, ] - tile_name <- row[["tile"]] + tile_row <- cube[i, ] + tile_name <- tile_row[["tile"]] # add group group <- paste(tile_name, "probs", label) # recover global leaflet and include group @@ -590,9 +590,9 @@ sits_view.probs_cube <- function(x, ..., leaf_map <- leaf_map |> .view_probs_label( group = group, - tile = row, + tile = tile_row, date = as.Date(date), - labels = labels, + labels = cube_labels, label = label, palette = palette, rev = rev, @@ -640,8 +640,8 @@ sits_view.vector_cube <- function(x, ..., cube <- dplyr::filter(x, .data[["tile"]] %in% tiles) # create a new layer in the leaflet for (i in seq_len(nrow(cube))) { - row <- cube[i, ] - tile_name <- row[["tile"]] + tile_row <- cube[i, ] + tile_name <- tile_row[["tile"]] group <- paste(tile_name, "segments") # recover global leaflet and include group overlay_groups <- append(overlay_groups, group) @@ -649,7 +649,7 @@ sits_view.vector_cube <- function(x, ..., leaf_map <- leaf_map |> .view_segments( group = group, - tile = row, + tile = tile_row, seg_color = seg_color, line_width = line_width ) @@ -702,8 +702,8 @@ sits_view.class_vector_cube <- function(x, ..., cube <- dplyr::filter(x, .data[["tile"]] %in% tiles) # create a new layer in the leaflet for (i in seq_len(nrow(cube))) { - row <- cube[i, ] - tile_name <- row[["tile"]] + tile_row <- cube[i, ] + tile_name <- tile_row[["tile"]] # add group group <- paste(tile_name, "class_segments") # add version if available @@ -715,7 +715,7 @@ sits_view.class_vector_cube <- function(x, ..., leaf_map <- leaf_map |> .view_vector_class_cube( group = group, - tile = row, + tile = tile_row, seg_color = seg_color, line_width = line_width, opacity = opacity, diff --git a/R/sits_xlsx.R b/R/sits_xlsx.R index c8bd6185e..10b98b9ff 100644 --- a/R/sits_xlsx.R +++ b/R/sits_xlsx.R @@ -116,7 +116,7 @@ sits_to_xlsx.list <- function(acc, file) { # the first class (called the "positive" class by caret) c1 <- cf_mat[["positive"]] # the second class - c2 <- nm[!(nm == cf_mat[["positive"]])] + c2 <- nm[(nm != cf_mat[["positive"]])] # make up the values of UA and PA for the two classes pa1 <- paste("Prod Acc ", c1) pa2 <- paste("Prod Acc ", c2) @@ -138,6 +138,5 @@ sits_to_xlsx.list <- function(acc, file) { }) # write the worksheets to the XLSX file openxlsx::saveWorkbook(workbook, file = file, overwrite = TRUE) - - return(message(.conf("messages", "sits_to_xlsx_save"), file)) + message(.conf("messages", "sits_to_xlsx_save"), file) } diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index d522b6820..9dbf28eb2 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -326,9 +326,9 @@ .ts_values: "some or all requested bands are not available in the cube" .usgs_format_tiles: "requested tiles do not match Landsat-8 WRS grid" .values_ts: "valid format parameter are 'cases_dates_bands', 'bands_cases_dates' or 'bands_dates_cases'" -.verbose_block_size: "using blocks of size" -.verbose_task_end: "task finished at" -.verbose_task_elapsed: "elapsed time for task" +.verbose_block_size: "using blocks of size " +.verbose_task_end: "task finished at " +.verbose_task_elapsed: "elapsed time for task " .view_class_cube: "invalid classified cube cannot be visualized - check 'class_cube' parameter" .view_add_overlay_grps_raster_cube: "raster cube must have associated dates" .view_filter_tiles: "requested tiles are not part of cube" diff --git a/man/plot.raster_cube.Rd b/man/plot.raster_cube.Rd index 580b6b71b..5c4b44125 100644 --- a/man/plot.raster_cube.Rd +++ b/man/plot.raster_cube.Rd @@ -86,12 +86,12 @@ of possible color composites stored in "./extdata/config_colors.yml". For example, the following composites are available for all "SENTINEL-2" images: \itemize{ - \item: {AGRICULTURE: ("B11", "B08", "B02")} - \item: {AGRICULTURE2: ("B11", "B8A", "B02")} - \item: {SWIR: ("B11", "B08", "B04")} - \item: {SWIR2: ("B12", "B08", "B04")} - \item: {SWIR3: ("B12", "B8A", "B04")} - \item: {RGB: ("B04", "B03", "B02")} + \item {AGRICULTURE: ("B11", "B08", "B02")} + \item {AGRICULTURE2: ("B11", "B8A", "B02")} + \item {SWIR: ("B11", "B08", "B04")} + \item {SWIR2: ("B12", "B08", "B04")} + \item {SWIR3: ("B12", "B8A", "B04")} + \item {RGB: ("B04", "B03", "B02")} } } \item{\code{sits} tries to find if the bands required for one diff --git a/man/sits-package.Rd b/man/sits-package.Rd index 4435f96a2..8969897d3 100644 --- a/man/sits-package.Rd +++ b/man/sits-package.Rd @@ -14,7 +14,7 @@ The main \code{sits} classification workflow has the following steps: \enumerate{ \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from a cloud provider.} - \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection from a cloud provider to a local directory for faster processing.} \item{\code{\link[sits]{sits_regularize}}: create a regular data cube from an ARD image collection.} diff --git a/man/sits_as_sf.Rd b/man/sits_as_sf.Rd index 6d1996bf3..5cb45fc44 100644 --- a/man/sits_as_sf.Rd +++ b/man/sits_as_sf.Rd @@ -5,6 +5,7 @@ \alias{sits_as_sf.sits} \alias{sits_as_sf.raster_cube} \alias{sits_as_sf.vector_cube} +\alias{sits_as_sf.default} \title{Return a sits_tibble or raster_cube as an sf object.} \usage{ sits_as_sf(data, ...) @@ -14,6 +15,8 @@ sits_as_sf(data, ...) \method{sits_as_sf}{raster_cube}(data, ..., as_crs = NULL) \method{sits_as_sf}{vector_cube}(data, ..., as_crs = NULL) + +\method{sits_as_sf}{default}(data, ...) } \arguments{ \item{data}{A sits tibble or sits cube.} diff --git a/man/sits_classify.raster_cube.Rd b/man/sits_classify.raster_cube.Rd index 3783b321f..2ee5e393d 100644 --- a/man/sits_classify.raster_cube.Rd +++ b/man/sits_classify.raster_cube.Rd @@ -153,7 +153,8 @@ if (sits_run_examples()) { data = cube, ml_model = rf_model, output_dir = tempdir(), - version = "ex_classify" + version = "classify_1", + verbose = TRUE ) # label the probability cube label_cube <- sits_label_classification( diff --git a/man/sits_confidence_sampling.Rd b/man/sits_confidence_sampling.Rd index eff7f05e4..c39530c94 100644 --- a/man/sits_confidence_sampling.Rd +++ b/man/sits_confidence_sampling.Rd @@ -6,11 +6,11 @@ \usage{ sits_confidence_sampling( probs_cube, - n = 20L, + n = 20, min_margin = 0.9, - sampling_window = 10L, - multicores = 1L, - memsize = 1L + sampling_window = 10, + multicores = 1, + memsize = 1 ) } \arguments{ diff --git a/man/sits_geo_dist.Rd b/man/sits_geo_dist.Rd index 9e385164b..85addb4b8 100644 --- a/man/sits_geo_dist.Rd +++ b/man/sits_geo_dist.Rd @@ -4,7 +4,7 @@ \alias{sits_geo_dist} \title{Compute the minimum distances among samples and prediction points.} \usage{ -sits_geo_dist(samples, roi, n = 1000L, crs = "EPSG:4326") +sits_geo_dist(samples, roi, n = 1000, crs = "EPSG:4326") } \arguments{ \item{samples}{Time series (tibble of class "sits").} diff --git a/man/sits_lighttae.Rd b/man/sits_lighttae.Rd index f3fc0466c..2659a03c4 100644 --- a/man/sits_lighttae.Rd +++ b/man/sits_lighttae.Rd @@ -12,9 +12,9 @@ sits_lighttae( validation_split = 0.2, optimizer = torch::optim_adamw, opt_hparams = list(lr = 5e-04, eps = 1e-08, weight_decay = 7e-04), - lr_decay_epochs = 50L, + lr_decay_epochs = 50, lr_decay_rate = 1, - patience = 20L, + patience = 20, min_delta = 0.01, verbose = FALSE ) diff --git a/man/sits_regularize.Rd b/man/sits_regularize.Rd index 8cdd04ac9..27bbf0aaa 100644 --- a/man/sits_regularize.Rd +++ b/man/sits_regularize.Rd @@ -131,7 +131,7 @@ The main \code{sits} classification workflow has the following steps: \enumerate{ \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from a cloud provider.} - \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection from a cloud provider to a local directory for faster processing.} \item{\code{\link[sits]{sits_regularize}}: create a regular data cube from an ARD image collection.} diff --git a/man/sits_smooth.Rd b/man/sits_smooth.Rd index 5dab324b7..06a9bef72 100644 --- a/man/sits_smooth.Rd +++ b/man/sits_smooth.Rd @@ -16,7 +16,7 @@ sits_smooth(cube, ...) ..., window_size = 9L, neigh_fraction = 0.5, - smoothness = 20L, + smoothness = 20, exclusion_mask = NULL, memsize = 4L, multicores = 2L, @@ -77,7 +77,7 @@ The main \code{sits} classification workflow has the following steps: \enumerate{ \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from a cloud provider.} - \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection from a cloud provider to a local directory for faster processing.} \item{\code{\link[sits]{sits_regularize}}: create a regular data cube from an ARD image collection.} diff --git a/man/sits_train.Rd b/man/sits_train.Rd index e85a6890a..17d411825 100644 --- a/man/sits_train.Rd +++ b/man/sits_train.Rd @@ -31,7 +31,7 @@ The main \code{sits} classification workflow has the following steps: \enumerate{ \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from a cloud provider.} - \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection from a cloud provider to a local directory for faster processing.} \item{\code{\link[sits]{sits_regularize}}: create a regular data cube from an ARD image collection.} @@ -51,7 +51,7 @@ The main \code{sits} classification workflow has the following steps: from a smoothed cube.} } -\code{sits_train} provides a standard interface to all machine learning models. +\code{sits_train} provides a standard interface to machine learning models. It takes two mandatory parameters: the training data (\code{samples}) and the ML algorithm (\code{ml_method}). The output is a model that can be used to classify individual time series or data cubes diff --git a/man/sits_uncertainty_sampling.Rd b/man/sits_uncertainty_sampling.Rd index a04fd87f3..d153050bd 100644 --- a/man/sits_uncertainty_sampling.Rd +++ b/man/sits_uncertainty_sampling.Rd @@ -6,11 +6,11 @@ \usage{ sits_uncertainty_sampling( uncert_cube, - n = 100L, + n = 100, min_uncert = 0.4, - sampling_window = 10L, - multicores = 1L, - memsize = 1L + sampling_window = 10, + multicores = 1, + memsize = 1 ) } \arguments{ diff --git a/tests/testthat/test-accuracy.R b/tests/testthat/test-accuracy.R index f629f6548..25ff425ba 100644 --- a/tests/testthat/test-accuracy.R +++ b/tests/testthat/test-accuracy.R @@ -46,14 +46,7 @@ test_that("samples_validation", { # Remove the lines used for validation sel <- !samples$id %in% train_data$id val_samples <- samples[sel, ] - samples_val <- - .check_samples_validation( - samples_validation = val_samples, - labels = sits_labels(samples), - timeline = sits_timeline(samples), - bands = sits_bands(samples) - ) - expect_true(nrow(samples_val) == nrow(val_samples)) + expect_true(nrow(val_samples) == 552) }) test_that("XLS", { set.seed(1234) diff --git a/tests/testthat/test-check.R b/tests/testthat/test-check.R index 274ff27db..05e534742 100644 --- a/tests/testthat/test-check.R +++ b/tests/testthat/test-check.R @@ -60,7 +60,7 @@ test_that("Caller", { output_dir <- paste0("/mydir/123/test") expect_error( .check_output_dir(output_dir), - ".check_output_dir: invalid output_dir variable" + ".check_output_dir: invalid output_dir parameter" ) version <- c("1", "2") expect_error( diff --git a/tests/testthat/test-config.R b/tests/testthat/test-config.R index 628c39836..c001f96e6 100644 --- a/tests/testthat/test-config.R +++ b/tests/testthat/test-config.R @@ -86,11 +86,6 @@ test_that("User functions", { c("bdc_cube", "stac_cube", "eo_cube", "raster_cube") ) - expect_error( - .source_check(source = "ZZZ"), - ".source_check: invalid source variable" - ) - expect_equal( .source_check(source = "TEST"), NULL @@ -108,17 +103,17 @@ test_that("User functions", { expect_error( .source_collection_check(source = "ZZZ", collection = "ZZZ"), - ".source_check: invalid source variable" + ".source_check: invalid source parameter" ) expect_error( .source_collection_check(source = "TEST", collection = "ZZZ"), - ".source_collection_check: invalid collection variable" + ".source_collection_check: invalid source parameter" ) expect_equal( .source_collection_check(source = "TEST", collection = "TEST"), - NULL + ".source_collection_check: invalid source parameter" ) expect_equal( .source_collection_tile_check( diff --git a/tests/testthat/test-cube_copy.R b/tests/testthat/test-cube_copy.R index b9cabb037..31b4e73a3 100644 --- a/tests/testthat/test-cube_copy.R +++ b/tests/testthat/test-cube_copy.R @@ -195,7 +195,6 @@ test_that("Copy remote cube works (specific region with resampling)", { roi = roi, res = 540 ) - # Spatial extent expect_true(sf::st_within( sf::st_union(sits_as_sf(cube_s2_local)), diff --git a/tests/testthat/test-raster.R b/tests/testthat/test-raster.R index 1a811b70c..9e70d982a 100644 --- a/tests/testthat/test-raster.R +++ b/tests/testthat/test-raster.R @@ -27,7 +27,6 @@ test_that("Classification with rfor (single core)", { ) bands_p <- sits_bands(sinop_probs) labels_p <- sits_labels(sinop_probs) - expect_true(.check_is_results_cube(bands_p, labels_p)) # testing resume feature Sys.setenv("SITS_DOCUMENTATION_MODE" = "FALSE") @@ -275,7 +274,7 @@ test_that("Classification with TempCNN", { ml_model = torch_model, output_dir = output_dir, memsize = 8, - multicores = 2, + multicores = 1, progress = FALSE ) expect_true(all(file.exists(unlist(sinop_2014_probs$file_info[[1]]$path)))) diff --git a/tests/testthat/test-regularize.R b/tests/testthat/test-regularize.R index d55ea40cc..f1b7ebad4 100644 --- a/tests/testthat/test-regularize.R +++ b/tests/testthat/test-regularize.R @@ -136,7 +136,7 @@ test_that("Creating Landsat cubes from MPC", { expect_equal(.tile_nrows(.tile(rg_landsat)), 856) expect_equal(.tile_ncols(.tile(rg_landsat)), 967) - expect_true(.check_cube_is_regular(rg_landsat)) + expect_true(.cube_is_regular(rg_landsat)) l5_cube <- .try( { From 576df89d143484589bdf19b9a805795252b4234f Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Thu, 10 Apr 2025 16:28:34 -0300 Subject: [PATCH 075/122] fix test_check --- R/api_accuracy.R | 26 ++-- R/api_band.R | 3 +- R/api_bayts.R | 6 +- R/api_bbox.R | 4 +- R/api_check.R | 243 ++++++++------------------------ R/api_colors.R | 2 +- R/api_message.R | 101 +++++++++++++ R/sits_classify.R | 13 +- R/sits_clean.R | 9 +- R/sits_combine_predictions.R | 19 ++- R/sits_cube_copy.R | 1 + R/sits_detect_change.R | 6 +- R/sits_get_data.R | 3 + R/sits_label_classification.R | 11 +- R/sits_mixture_model.R | 1 + R/sits_mosaic.R | 7 +- R/sits_reclassify.R | 3 +- R/sits_regularize.R | 11 +- R/sits_sample_functions.R | 1 + R/sits_segmentation.R | 5 +- R/sits_smooth.R | 4 +- R/sits_timeline.R | 2 +- R/sits_uncertainty.R | 10 +- R/sits_variance.R | 4 +- man/sits_combine_predictions.Rd | 8 +- tests/testthat/test-accuracy.R | 2 +- tests/testthat/test-check.R | 187 +----------------------- 27 files changed, 249 insertions(+), 443 deletions(-) diff --git a/R/api_accuracy.R b/R/api_accuracy.R index 54eda953c..acb007912 100644 --- a/R/api_accuracy.R +++ b/R/api_accuracy.R @@ -164,7 +164,7 @@ #' @param validation validation (CSV file, SHP file, SF object, data.frame) #' @return samples for validation #' -.accuracy_get_validation <- function(validation){ +.accuracy_get_validation <- function(validation) { # handle validation data as files if (is.character(validation)) { val_class <- tolower(.file_ext(validation)) @@ -173,31 +173,28 @@ UseMethod(".accuracy_get_validation", validation) } #' @export -.accuracy_get_validation.csv <- function(validation){ +.accuracy_get_validation.csv <- function(validation) { # Read sample information from CSV file and put it in a tibble - valid_samples <- .csv_get_validation_samples(validation) - return(valid_samples) + .csv_get_validation_samples(validation) } #' @export -.accuracy_get_validation.shp <- function(validation){ +.accuracy_get_validation.shp <- function(validation) { validation_sf <- sf::st_read(validation) .check_that(all(sf::st_geometry_type(validation_sf) == "POINT")) - valid_samples <- .accuracy_get_validation(validation_sf) - return(valid_samples) + .accuracy_get_validation(validation_sf) } #' @export -.accuracy_get_validation.gpkg <- function(validation){ +.accuracy_get_validation.gpkg <- function(validation) { validation_sf <- sf::st_read(validation) .check_that(all(sf::st_geometry_type(validation_sf) == "POINT")) - valid_samples <- .accuracy_get_validation(validation_sf) - return(valid_samples) + .accuracy_get_validation(validation_sf) } #' @export -.accuracy_get_validation.sf <- function(validation){ +.accuracy_get_validation.sf <- function(validation) { # Pre-condition - check for the required columns .check_chr_contains(colnames(validation), c("label")) # transform the `sf` object in a valid - valid_samples <- validation |> + validation |> dplyr::mutate( geom = sf::st_geometry(validation) ) |> @@ -214,13 +211,12 @@ dplyr::select( "label", "longitude", "latitude" ) - return(valid_samples) } #' @export -`.accuracy_get_validation.data.frame` <- function(validation){ +`.accuracy_get_validation.data.frame` <- function(validation) { # handle data frames .check_chr_contains(colnames(validation), c("label", "longitude", "latitude") ) - return(validation) + validation } diff --git a/R/api_band.R b/R/api_band.R index 3995e5112..12983d9c4 100644 --- a/R/api_band.R +++ b/R/api_band.R @@ -64,13 +64,12 @@ new_bands[data_bands] <- toupper(bands) colnames(x) <- unname(new_bands) - x <- tidyr::pivot_longer( + tidyr::pivot_longer( x, cols = toupper(bands), names_to = "band", values_to = "path" ) - return(x) }) } #' @title Return cloud band diff --git a/R/api_bayts.R b/R/api_bayts.R index 177125d19..d7cd1b806 100644 --- a/R/api_bayts.R +++ b/R/api_bayts.R @@ -42,8 +42,6 @@ "'stats' must be a valid value.") ) bands <- setdiff(colnames(stats), c("stats", "label")) - stats <- lapply( - split(stats[, bands], stats[["stats"]]), as.matrix - ) - return(stats) + # return a matrix with statistics + lapply(split(stats[, bands], stats[["stats"]]), as.matrix) } diff --git a/R/api_bbox.R b/R/api_bbox.R index dadad3b54..16d876a47 100644 --- a/R/api_bbox.R +++ b/R/api_bbox.R @@ -130,7 +130,7 @@ NULL crs <- .crs(x) } else { crs <- .default(default_crs, default = { - if (.check_warnings()) { + if (.message_warnings()) { msg <- .conf("messages", ".bbox_from_tbl") warning(msg, call. = FALSE) } @@ -177,7 +177,7 @@ NULL .check_bbox(bbox) # Check if there are multiple CRS in bbox if (length(.crs(bbox)) > 1 && is.null(as_crs)) { - .check_warnings_bbox_as_sf() + .message_warnings_bbox_as_sf() as_crs <- "EPSG:4326" } # Convert to sf object and return it diff --git a/R/api_check.R b/R/api_check.R index 928b2a1ef..89a8f55a6 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -1273,41 +1273,6 @@ output_dir <- .file_path_expand(output_dir) .check_file(output_dir) } -#' @title Check is version parameter is valid using reasonable defaults -#' @name .check_version -#' @keywords internal -#' @noRd -#' @param version character vector -#' @return version adjusted to remove underscores -.check_version <- function(version) { - .check_set_caller(".check_version") - .check_chr( - x = version, - allow_na = FALSE, - allow_null = FALSE, - allow_empty = FALSE, - len_min = 1, - len_max = 1 - ) - # avoids use of underscores - version <- tolower(gsub("_", "-", version)) -} -#' @title Check is version parameter is valid using reasonable defaults -#' @name .check_progress -#' @keywords internal -#' @noRd -#' @param progress TRUE/FALSE -#' @return Called for side effects. -.check_progress <- function(progress) { - .check_set_caller(".check_progress") - .check_lgl( - x = progress, - len_min = 1, - len_max = 1, - allow_na = FALSE, - allow_null = FALSE - ) -} #' @title Check is function parameters is valid using reasonable defaults #' @name .check_function #' @keywords internal @@ -1447,56 +1412,47 @@ #' @noRd .check_is_results_cube <- function(bands, labels) { .check_set_caller(".check_is_results_cube") - if (!(is.null(bands)) && - all(bands %in% .conf("sits_results_bands"))) { - results_cube <- TRUE - } else { - results_cube <- FALSE - } .check_that(.has(bands) && all(bands %in% .conf("sits_results_bands"))) # results cube should have only one band - if (results_cube) { - .check_that(length(bands) == 1) + .check_that(length(bands) == 1) - # is label parameter was provided in labelled cubes? - if (bands %in% c("probs", "bayes")) { - .check_chr( - labels, - len_min = 1, - allow_duplicate = FALSE, - is_named = TRUE, - msg = .conf("messages", ".check_is_results_cube_probs") - ) - } - # labels should be named in class cubes? - if (bands == "class") { - .check_length( - labels, - len_min = 2, - is_named = TRUE, - msg = .conf("messages", ".check_is_results_cube_class") - ) - } - # is label parameter was provided in labelled cubes? - if (bands %in% c("probs", "bayes")) { - .check_chr( - labels, - len_min = 1, - allow_duplicate = FALSE, - is_named = TRUE, - msg = .conf("messages", ".check_is_results_cube_probs") - ) - } - # labels should be named in class cubes? - if (bands == "class") { - .check_length( - labels, - len_min = 2, - is_named = TRUE, - msg = .conf("messages", ".check_is_results_cube_class") - ) - } - return(results_cube) + # is label parameter was provided in labelled cubes? + if (bands %in% c("probs", "bayes")) { + .check_chr( + labels, + len_min = 1, + allow_duplicate = FALSE, + is_named = TRUE, + msg = .conf("messages", ".check_is_results_cube_probs") + ) + } + # labels should be named in class cubes? + if (bands == "class") { + .check_length( + labels, + len_min = 2, + is_named = TRUE, + msg = .conf("messages", ".check_is_results_cube_class") + ) + } + # is label parameter was provided in labelled cubes? + if (bands %in% c("probs", "bayes")) { + .check_chr( + labels, + len_min = 1, + allow_duplicate = FALSE, + is_named = TRUE, + msg = .conf("messages", ".check_is_results_cube_probs") + ) + } + # labels should be named in class cubes? + if (bands == "class") { + .check_length( + labels, + len_min = 2, + is_named = TRUE, + msg = .conf("messages", ".check_is_results_cube_class") + ) } } #' @title Check that cube is regular @@ -1557,7 +1513,7 @@ class(data) <- c("list", class(data)) data <- tibble::as_tibble(data) .check_samples(data) - data <- .samples_convert_to_sits (data) + data <- .samples_convert_to_sits(data) return(data) } stop(.conf("messages", ".check_samples_default")) @@ -1720,7 +1676,7 @@ .check_that(nrow(pred) > 0) n_bands <- length(.samples_bands.sits(samples)) n_times <- length(.samples_timeline(samples)) - if(inherits(samples, "sits_base")) + if (inherits(samples, "sits_base")) n_bands_base <- length(.samples_base_bands(samples)) else n_bands_base <- 0 @@ -1749,13 +1705,13 @@ .check_that(length(reference) == length(predicted)) } #' @title Do the samples and tile match timelines? -#' @name .check_samples_tile_match_timeline +#' @name .check_match_timeline #' @param samples samples organised as a tibble #' @param tile one tile of a data cube #' @return Called for side effects. #' @keywords internal #' @noRd -.check_samples_tile_match_timeline <- function(samples, tile) { +.check_match_timeline <- function(samples, tile) { .check_set_caller(".check_samples_tile_match_timeline") # do they have the same timelines? samples_timeline_length <- length(.samples_timeline(samples)) @@ -1763,13 +1719,13 @@ .check_that(samples_timeline_length == tiles_timeline_length) } #' @title Do the samples and tile match bands? -#' @name .check_samples_tile_match_bands +#' @name .check_match_bands #' @param samples samples organised as a tibble #' @param tile one tile of a data cube #' @return Called for side effects. #' @keywords internal #' @noRd -.check_samples_tile_match_bands <- function(samples, tile) { +.check_match_bands <- function(samples, tile) { .check_set_caller(".check_samples_tile_match_bands") # do they have the same bands? tile_bands <- .tile_bands(tile) @@ -1813,7 +1769,7 @@ # get the classes as numerical values classes_tile <- as.character(freq[["value"]]) names(classes_tile) <- file - return(classes_tile) + classes_tile }) classes_num <- unique(unlist(classes_list)) classes_num <- classes_num[!is.na(classes_num)] @@ -1951,17 +1907,17 @@ "collections", .cube_collection(cube1), "ext_tolerance" ) - ok <- slider::slide2_lgl( + check_boxes <- slider::slide2_lgl( cube1, cube2, function(tile_first, tile_cube) { - return(.bbox_equal( + .bbox_equal( .tile_bbox(tile_first), .tile_bbox(tile_cube), tolerance = tolerance - )) + ) } ) - .check_that(all(ok)) + .check_that(all(check_boxes)) } #' @title Check if cubes have the same size #' @name .check_cubes_same_size @@ -2050,7 +2006,7 @@ purrr::map(cubes, .check_is_probs_cube) # check same size first <- cubes[[1]] - for (i in c(2:length(cubes))) { + for (i in 2:length(cubes)) { .check_cubes_match(first, cubes[[i]]) } } @@ -2069,7 +2025,7 @@ purrr::map(uncert_cubes, .check_is_uncert_cube) # check same size first <- uncert_cubes[[1]] - for (i in c(2:length(uncert_cubes))) { + for (i in 2:length(uncert_cubes)) { .check_cubes_same_size(first, uncert_cubes[[i]]) } } @@ -2201,11 +2157,8 @@ #' @noRd .check_documentation <- function(progress) { # if working on sits documentation mode, no progress bar - if (Sys.getenv("SITS_DOCUMENTATION_MODE") == "true" || - Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") { - progress <- FALSE - } - return(progress) + Sys.getenv("SITS_DOCUMENTATION_MODE") != "true" && + Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" } #' @title Checks if messages should be displayed #' @name .check_messages @@ -2215,12 +2168,8 @@ #' @noRd .check_messages <- function() { # if working on sits documentation mode, no progress bar - if (Sys.getenv("SITS_DOCUMENTATION_MODE") == "true" || - Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") { - return(FALSE) - } else { - return(TRUE) - } + Sys.getenv("SITS_DOCUMENTATION_MODE") != "true" && + Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" } #' @title Checks if STAC items are correct @@ -2532,84 +2481,4 @@ msg = .conf("messages", ".check_unique_period") ) } -#' @title Checks if warnings should be displayed -#' @name .check_warnings -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @return TRUE/FALSE -#' @keywords internal -#' @noRd -.check_warnings <- function() { - # if working on sits documentation mode, no progress bar - if (Sys.getenv("SITS_DOCUMENTATION_MODE") == "true" || - Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") { - return(FALSE) - } else { - return(TRUE) - } -} -#' @title Warning when converting a bbox into a sf object -#' @name .check_warnings_bbox_as_sf -#' @noRd -#' @returns Called for side effects -.check_warnings_bbox_as_sf <- function() { - if (.check_warnings()) - warning(.conf("messages", ".bbox_as_sf"), call. = FALSE) -} -#' @title Warning when labels have no colors preset -#' @name .check_warnings_colors_get -#' @noRd -#' @returns Called for side effects -.check_warnings_colors_get <- function(missing, palette){ - if (.check_warnings()) { - warning(.conf("messages", ".colors_get_missing"), toString(missing)) - warning(.conf("messages", ".colors_get_missing_palette"), palette) - # grDevices does not work with one color missing - } -} -#' @title Warning when cube has no CLOUD band -#' @name .check_warnings_regularize_cloud -#' @noRd -#' @returns Called for side effects -.check_warnings_regularize_cloud <- function(cube){ - if (!all(.cube_contains_cloud(cube))) { - if (.check_warnings()) - warning(.conf("messages", "sits_regularize_cloud"), - call. = FALSE, - immediate. = TRUE - ) - } -} -#' @title Warning when cube has multiple values of CRS -#' @name .check_warnings_regularize_crs -#' @noRd -#' @returns Called for side effects -.check_warnings_regularize_crs <- function(){ - if (.check_warnings()) - warning(.conf("messages", "sits_regularize_crs"), - call. = FALSE, - immediate. = TRUE - ) - return(invisible(NULL)) -} -#' @title Warning when cube is being regularized directly from STAC files -#' @name .check_warnings_regularize_local -#' @noRd -#' @returns Called for side effects -.check_warnings_regularize_local <- function(cube){ - if (!.cube_is_local(cube) && .check_warnings()) { - warning(.conf("messages", "sits_regularize_local"), - call. = FALSE, immediate. = TRUE - ) - } - return(invisible(NULL)) -} -#' @title Warning when cube has more than one timeline -#' @name .check_warnings_timeline_cube -#' @noRd -#' @returns Called for side effects -.check_warnings_timeline_cube <- function(){ - if (.check_warnings()) - warning(.conf("messages", "sits_timeline_raster_cube"), - call. = FALSE - ) -} + diff --git a/R/api_colors.R b/R/api_colors.R index 803fd6fcf..d180ade14 100644 --- a/R/api_colors.R +++ b/R/api_colors.R @@ -46,7 +46,7 @@ # find out the missing colors missing <- labels[!labels %in% names(colors)] # issue a warning - .check_warnings_colors_get(missing, palette) + .message_warnings_colors_get(missing, palette) # assume colors for the missing labels colors_pal <- grDevices::hcl.colors( n = length(missing), diff --git a/R/api_message.R b/R/api_message.R index 618e67961..740d81bc8 100644 --- a/R/api_message.R +++ b/R/api_message.R @@ -8,3 +8,104 @@ # make default message paste0("invalid ", param, " parameter") } +#' @title Checks if warnings should be displayed +#' @name .message_warnings +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @return TRUE/FALSE +#' @keywords internal +#' @noRd +.message_warnings <- function() { + Sys.getenv("SITS_DOCUMENTATION_MODE") != "true" && + Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" +} +#' @title Warning when converting a bbox into a sf object +#' @name .message_warnings_bbox_as_sf +#' @noRd +#' @returns Called for side effects +.message_warnings_bbox_as_sf <- function() { + if (.message_warnings()) + warning(.conf("messages", ".bbox_as_sf"), call. = FALSE) +} +#' @title Warning when labels have no colors preset +#' @name .message_warnings_colors_get +#' @noRd +#' @returns Called for side effects +.message_warnings_colors_get <- function(missing, palette) { + if (.message_warnings()) { + warning(.conf("messages", ".colors_get_missing"), toString(missing)) + warning(.conf("messages", ".colors_get_missing_palette"), palette) + # grDevices does not work with one color missing + } +} +#' @title Warning when cube has no CLOUD band +#' @name .message_warnings_regularize_cloud +#' @noRd +#' @returns Called for side effects +.message_warnings_regularize_cloud <- function(cube) { + if (!all(.cube_contains_cloud(cube))) { + if (.message_warnings()) + warning(.conf("messages", "sits_regularize_cloud"), + call. = FALSE, + immediate. = TRUE + ) + } +} +#' @title Warning when cube is being regularized directly from STAC files +#' @name .message_warnings_regularize_local +#' @noRd +#' @returns Called for side effects +.message_warnings_regularize_local <- function(cube) { + if (!.cube_is_local(cube) && .message_warnings()) { + warning(.conf("messages", "sits_regularize_local"), + call. = FALSE, immediate. = TRUE + ) + } +} +#' @title Warning when cube has multiple values of CRS +#' @name .message_warnings_regularize_crs +#' @noRd +#' @returns Called for side effects +.message_warnings_regularize_crs <- function() { + if (.message_warnings()) + warning(.conf("messages", "sits_regularize_crs"), + call. = FALSE, + immediate. = TRUE + ) +} + +#' @title Warning when cube has more than one timeline +#' @name .message_warnings_timeline_cube +#' @noRd +#' @returns Called for side effects +.message_warnings_timeline_cube <- function() { + if (.message_warnings()) + warning(.conf("messages", "sits_timeline_raster_cube"), + call. = FALSE + ) +} +.message_progress <- function(progress) { + .check_lgl_parameter(progress) + if (progress) + progress <- Sys.getenv("SITS_DOCUMENTATION_MODE") != "true" && + Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" + progress +} +#' @title Check is version parameter is valid using reasonable defaults +#' @name .message_version +#' @keywords internal +#' @noRd +#' @param version character vector +#' @return version adjusted to remove underscores +.message_version <- function(version) { + .check_set_caller(".check_version") + .check_chr( + x = version, + allow_na = FALSE, + allow_null = FALSE, + allow_empty = FALSE, + len_min = 1, + len_max = 1 + ) + # avoids use of underscores + tolower(gsub("_", "-", version)) +} diff --git a/R/sits_classify.R b/R/sits_classify.R index 432d351f1..a17249874 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -174,6 +174,7 @@ sits_classify.sits <- function(data, .check_is_sits_model(ml_model) .check_int_parameter(multicores, min = 1, max = 2048) .check_progress(progress) + progress <- .message_progress() .check_function(impute_fn) .check_filter_fn(filter_fn) # save batch_size for later use @@ -347,8 +348,8 @@ sits_classify.raster_cube <- function(data, .check_function(impute_fn) .check_filter_fn(filter_fn) # version is case-insensitive in sits - version <- .check_version(version) - .check_progress(progress) + version <- .message_version(version) + progress <- .message_progress(progress) # Spatial filter if (.has(roi)) { roi <- .roi_as_sf(roi) @@ -369,9 +370,9 @@ sits_classify.raster_cube <- function(data, # Retrieve the samples from the model samples <- .ml_samples(ml_model) # Do the samples and tile match their timeline length? - .check_samples_tile_match_timeline(samples = samples, tile = data) + .check_match_timeline(samples = samples, tile = data) # Do the samples and tile match their bands? - .check_samples_tile_match_bands(samples = samples, tile = data) + .check_match_bands(samples = samples, tile = data) # By default, base bands is null. base_bands <- NULL @@ -624,8 +625,8 @@ sits_classify.vector_cube <- function(data, .check_function(impute_fn) .check_filter_fn(filter_fn) # version is case-insensitive in sits - version <- .check_version(version) - .check_progress(progress) + version <- .message_version(version) + progress <- .message_progress(progress) # save GPU memory info for later use sits_env[["batch_size"]] <- batch_size diff --git a/R/sits_clean.R b/R/sits_clean.R index af1460e47..4aea29c5c 100644 --- a/R/sits_clean.R +++ b/R/sits_clean.R @@ -88,12 +88,9 @@ sits_clean.class_cube <- function(cube, window_size = 5L, memsize = 4L, .check_int_parameter(multicores, min = 1, max = 2048) # Check output_dir .check_output_dir(output_dir) - # Check version - .check_version(version) - # version is case-insensitive in sits - version <- tolower(version) - # Check progress - .check_progress(progress) + # Check version and progress + version <- .message_version(version) + progress <- .message_progress(progress) # Get input band band <- .cube_bands(cube) diff --git a/R/sits_combine_predictions.R b/R/sits_combine_predictions.R index bc814e634..f273f708b 100644 --- a/R/sits_combine_predictions.R +++ b/R/sits_combine_predictions.R @@ -21,6 +21,7 @@ #' (character vector of length 1). #' @param version Version of the output #' (character vector of length 1). +#' @param progress Set progress bar? #' @return A combined probability cube (tibble of class "probs_cube"). #' #' @description Calculate an ensemble predictor based a list of probability @@ -95,7 +96,8 @@ sits_combine_predictions.average <- function(cubes, memsize = 8L, multicores = 2L, output_dir, - version = "v1") { + version = "v1", + progress = FALSE) { # Check memsize .check_num_parameter(memsize, min = 1, max = 16384) # Check multicores @@ -103,7 +105,9 @@ sits_combine_predictions.average <- function(cubes, # Check output dir .check_output_dir(output_dir) # Check version and convert to lowercase - version <- .check_version(version) + # Check version and progress + version <- .message_version(version) + progress <- .message_progress(progress) # Get weights n_inputs <- length(cubes) weights <- .default(weights, rep(1 / n_inputs, n_inputs)) @@ -127,7 +131,7 @@ sits_combine_predictions.average <- function(cubes, multicores = multicores, output_dir = output_dir, version = version, - progress = FALSE, ... + progress = progress, ... ) return(probs_cube) } @@ -140,7 +144,8 @@ sits_combine_predictions.uncertainty <- function(cubes, memsize = 8L, multicores = 2L, output_dir, - version = "v1") { + version = "v1", + progress = FALSE) { # Check memsize .check_num_parameter(memsize, min = 1, max = 16384) # Check multicores @@ -148,7 +153,9 @@ sits_combine_predictions.uncertainty <- function(cubes, # Check output dir .check_output_dir(output_dir) # Check version and convert to lowercase - version <- .check_version(version) + # Check version and progress + version <- .message_version(version) + progress <- .message_progress(progress) # Check if list of probs cubes and uncert_cubes have the same organization .check_that( length(cubes) == length(uncert_cubes), @@ -168,7 +175,7 @@ sits_combine_predictions.uncertainty <- function(cubes, multicores = multicores, output_dir = output_dir, version = version, - progress = FALSE, ... + progress = progress, ... ) return(probs_cube) } diff --git a/R/sits_cube_copy.R b/R/sits_cube_copy.R index 5050b1a47..66eb80300 100644 --- a/R/sits_cube_copy.R +++ b/R/sits_cube_copy.R @@ -125,6 +125,7 @@ sits_cube_copy <- function(cube, .check_output_dir(output_dir) # Check progress .check_progress(progress) + progress <- .message_progress() # Prepare parallel processing .parallel_start(workers = multicores) on.exit(.parallel_stop(), add = TRUE) diff --git a/R/sits_detect_change.R b/R/sits_detect_change.R index c898acbf1..8375e7340 100644 --- a/R/sits_detect_change.R +++ b/R/sits_detect_change.R @@ -58,6 +58,7 @@ sits_detect_change.sits <- function(data, .check_is_sits_model(dc_method) .check_int_parameter(multicores, min = 1, max = 2048) .check_progress(progress) + progress <- .message_progress() # preconditions - impute and filter functions if (!is.null(filter_fn)) { .check_function(filter_fn) @@ -101,8 +102,9 @@ sits_detect_change.raster_cube <- function(data, # Smoothing filter .check_filter_fn(filter_fn) # version is case-insensitive in sits - version <- .check_version(version) - .check_progress(progress) + # Check version and progress + version <- .message_version(version) + progress <- .message_progress(progress) # Get default proc bloat proc_bloat <- .conf("processing_bloat_cpu") # Spatial filter diff --git a/R/sits_get_data.R b/R/sits_get_data.R index 77eef25d5..832afefc9 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -178,6 +178,7 @@ sits_get_data.csv <- function(cube, .check_crs(crs) .check_int_parameter(multicores, min = 1, max = 2048) .check_progress(progress) + progress <- .message_progress() .check_function(impute_fn) # Extract a data frame from csv samples <- .csv_get_samples(samples) @@ -290,6 +291,7 @@ sits_get_data.shp <- function(cube, end_date <- .default(end_date, .cube_end_date(cube)) .check_int_parameter(multicores, min = 1, max = 2048) .check_progress(progress) + progress <- .message_progress() # Extract a data frame from shapefile samples <- .shp_get_samples( @@ -412,6 +414,7 @@ sits_get_data.sf <- function(cube, .check_cube_bands(cube, bands = bands) .check_int_parameter(multicores, min = 1, max = 2048) .check_progress(progress) + progress <- .message_progress() .check_function(impute_fn) # Get default start and end date start_date <- .default(start_date, .cube_start_date(cube)) diff --git a/R/sits_label_classification.R b/R/sits_label_classification.R index 134da862c..97b0c58a6 100644 --- a/R/sits_label_classification.R +++ b/R/sits_label_classification.R @@ -99,9 +99,9 @@ sits_label_classification.probs_cube <- function(cube, ..., .check_num_parameter(memsize, min = 1, max = 16384) .check_num_parameter(multicores, min = 1, max = 2048) .check_output_dir(output_dir) - version <- .check_version(version) - # version is case-insensitive in sits - version <- tolower(version) + # Check version and progress + version <- .message_version(version) + progress <- .message_progress(progress) # The following functions define optimal parameters for parallel processing # @@ -156,9 +156,8 @@ sits_label_classification.probs_vector_cube <- function(cube, ..., # Pre-conditions - Check parameters .check_raster_cube_files(cube) .check_output_dir(output_dir) - version <- .check_version(version) - # version is case-insensitive in sits - version <- tolower(version) + # Check version and progress + version <- .message_version(version) # Process each tile sequentially .cube_foreach_tile(cube, function(tile) { # Label the segments diff --git a/R/sits_mixture_model.R b/R/sits_mixture_model.R index bf4af64e6..c8bc84192 100644 --- a/R/sits_mixture_model.R +++ b/R/sits_mixture_model.R @@ -122,6 +122,7 @@ sits_mixture_model.sits <- function(data, endmembers, ..., .check_lgl_parameter(rmse_band) .check_int_parameter(multicores, min = 1, max = 2048) .check_progress(progress) + progress <- .message_progress() # Transform endmembers to tibble em <- .endmembers_as_tbl(endmembers) diff --git a/R/sits_mosaic.R b/R/sits_mosaic.R index c4de5a61b..c57da3e97 100644 --- a/R/sits_mosaic.R +++ b/R/sits_mosaic.R @@ -95,10 +95,9 @@ sits_mosaic <- function(cube, .check_crs(crs) .check_int_parameter(multicores, min = 1, max = 2048) .check_output_dir(output_dir) - version <- .check_version(version) - .check_lgl_parameter(progress) - # version is case-insensitive in sits - version <- tolower(version) + # Check version and progress + version <- .message_version(version) + progress <- .message_progress(progress) # Spatial filter if (.has(roi)) { roi <- .roi_as_sf(roi) diff --git a/R/sits_reclassify.R b/R/sits_reclassify.R index e23372d4f..ae0614368 100644 --- a/R/sits_reclassify.R +++ b/R/sits_reclassify.R @@ -138,7 +138,8 @@ sits_reclassify.class_cube <- function(cube, ..., .check_int_parameter(memsize, min = 1, max = 16384) .check_int_parameter(multicores, min = 1, max = 2048) .check_output_dir(output_dir) - version <- .check_version(version) + # Check version and progress + version <- .message_version(version) # The following functions define optimal parameters for parallel processing # diff --git a/R/sits_regularize.R b/R/sits_regularize.R index a6d9ec5da..8ddb77201 100644 --- a/R/sits_regularize.R +++ b/R/sits_regularize.R @@ -181,14 +181,15 @@ sits_regularize.raster_cube <- function(cube, ..., .check_num_parameter(multicores, min = 1, max = 2048) # check progress .check_progress(progress) + progress <- .message_progress() # Does cube contain cloud band? If not, issue a warning - .check_warnings_regularize_cloud(cube) + .message_warnings_regularize_cloud(cube) if (.has(roi)) { crs <- NULL if (.roi_type(roi) == "bbox" && !.has(roi[["crs"]])) { crs <- .crs(cube) if (length(crs) > 1) - .check_warnings_regularize_crs() + .message_warnings_regularize_crs() } roi <- .roi_as_sf(roi, default_crs = crs[[1]]) } @@ -209,7 +210,7 @@ sits_regularize.raster_cube <- function(cube, ..., } # Display warning message in case regularization is done via STAC # We prefer to regularize local files - .check_warnings_regularize_local(cube) + .message_warnings_regularize_local(cube) # Regularize .gc_regularize( cube = cube, @@ -243,6 +244,7 @@ sits_regularize.sar_cube <- function(cube, ..., .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1, max = 2048) .check_progress(progress) + progress <- .message_progress() # check for ROI and tiles if (!is.null(roi) || !is.null(tiles)) { .check_roi_tiles(roi, tiles) @@ -301,6 +303,7 @@ sits_regularize.combined_cube <- function(cube, ..., .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1, max = 2048) .check_progress(progress) + progress <- .message_progress() # check for ROI and tiles .check_roi_tiles(roi, tiles) if (.has(grid_system)) { @@ -357,6 +360,7 @@ sits_regularize.rainfall_cube <- function(cube, ..., .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1, max = 2048) .check_progress(progress) + progress <- .message_progress() # check for ROI and tiles if (!is.null(roi) || !is.null(tiles)) { .check_roi_tiles(roi, tiles) @@ -412,6 +416,7 @@ sits_regularize.dem_cube <- function(cube, ..., .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1, max = 2048) .check_progress(progress) + progress <- .message_progress() # check for ROI and tiles if (!is.null(roi) || !is.null(tiles)) { .check_roi_tiles(roi, tiles) diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R index 675b9c4d0..c7dfb7fb2 100644 --- a/R/sits_sample_functions.R +++ b/R/sits_sample_functions.R @@ -467,6 +467,7 @@ sits_stratified_sampling <- function(cube, .check_int_parameter(multicores, min = 1, max = 2048) # check progress .check_progress(progress) + progress <- .message_progress() # transform labels to tibble cube_labels <- tibble::rownames_to_column( as.data.frame(cube_labels), var = "label_id" diff --git a/R/sits_segmentation.R b/R/sits_segmentation.R index 70bffdca9..b5cd35d32 100644 --- a/R/sits_segmentation.R +++ b/R/sits_segmentation.R @@ -131,8 +131,9 @@ sits_segment <- function(cube, .check_cube_is_regular(cube) .check_int_parameter(memsize, min = 1, max = 16384) .check_output_dir(output_dir) - version <- .check_version(version) - .check_progress(progress) + # Check version and progress + version <- .message_version(version) + progress <- .message_progress(progress) .check_function(seg_fn) # Spatial filter diff --git a/R/sits_smooth.R b/R/sits_smooth.R index cf760c614..1e164c1bf 100644 --- a/R/sits_smooth.R +++ b/R/sits_smooth.R @@ -135,8 +135,8 @@ sits_smooth.probs_cube <- function(cube, ..., # Check output dir output_dir <- path.expand(output_dir) .check_output_dir(output_dir) - # Check version - version <- .check_version(version) + # Check version and progress + version <- .message_version(version) # get nlabels nlabels <- length(.cube_labels(cube)) # Check smoothness diff --git a/R/sits_timeline.R b/R/sits_timeline.R index cf3c908fd..55ffe105d 100644 --- a/R/sits_timeline.R +++ b/R/sits_timeline.R @@ -44,7 +44,7 @@ sits_timeline.raster_cube <- function(data) { timeline_unique[[1]] } else { # warning if there is more than one timeline - .check_warnings_timeline_cube() + .message_warnings_timeline_cube() timelines_lst } } diff --git a/R/sits_uncertainty.R b/R/sits_uncertainty.R index ac9f38142..77781e6c4 100644 --- a/R/sits_uncertainty.R +++ b/R/sits_uncertainty.R @@ -90,12 +90,10 @@ sits_uncertainty.probs_cube <- function( # check output dir .check_output_dir(output_dir) # check version - version <- .check_version(version) - # version is case-insensitive in sits - version <- tolower(version) + # Check version and progress + version <- .message_version(version) # The following functions define optimal parameters for parallel processing - # # Get block size block <- .raster_file_blocksize(.raster_open_rast(.tile_path(cube))) # Check minimum memory needed to process one block @@ -150,8 +148,8 @@ sits_uncertainty.probs_vector_cube <- function( .check_int_parameter(multicores, min = 1, max = 2048) # check output dir .check_output_dir(output_dir) - # check version - version <- .check_version(version) + # Check version and progress + version <- .message_version(version) # Compute uncertainty uncert_cube <- .uncertainty_vector_cube( cube = cube, diff --git a/R/sits_variance.R b/R/sits_variance.R index c9bd3fcfb..6d729b0b2 100644 --- a/R/sits_variance.R +++ b/R/sits_variance.R @@ -70,8 +70,6 @@ sits_variance <- function( .check_int_parameter(multicores, min = 1, max = 2048) # check output_dir .check_output_dir(output_dir) - # check version - version <- .check_version(version) # Dispatch UseMethod("sits_variance", cube) } @@ -86,6 +84,8 @@ sits_variance.probs_cube <- function( output_dir, version = "v1") { + # Check version and progress + version <- .message_version(version) # The following functions define optimal parameters for parallel processing # # Get block size diff --git a/man/sits_combine_predictions.Rd b/man/sits_combine_predictions.Rd index 9c4193bcd..d9dc418a5 100644 --- a/man/sits_combine_predictions.Rd +++ b/man/sits_combine_predictions.Rd @@ -17,7 +17,8 @@ sits_combine_predictions(cubes, type = "average", ...) memsize = 8L, multicores = 2L, output_dir, - version = "v1" + version = "v1", + progress = FALSE ) \method{sits_combine_predictions}{uncertainty}( @@ -28,7 +29,8 @@ sits_combine_predictions(cubes, type = "average", ...) memsize = 8L, multicores = 2L, output_dir, - version = "v1" + version = "v1", + progress = FALSE ) \method{sits_combine_predictions}{default}(cubes, type, ...) @@ -55,6 +57,8 @@ sits_combine_predictions(cubes, type = "average", ...) \item{version}{Version of the output (character vector of length 1).} +\item{progress}{Set progress bar?} + \item{uncert_cubes}{Uncertainty cubes to be used as local weights when type = "uncertainty" is selected (list of tibbles with class "uncertainty_cube")} diff --git a/tests/testthat/test-accuracy.R b/tests/testthat/test-accuracy.R index 25ff425ba..c636efada 100644 --- a/tests/testthat/test-accuracy.R +++ b/tests/testthat/test-accuracy.R @@ -46,7 +46,7 @@ test_that("samples_validation", { # Remove the lines used for validation sel <- !samples$id %in% train_data$id val_samples <- samples[sel, ] - expect_true(nrow(val_samples) == 552) + expect_true(nrow(val_samples) > 500) }) test_that("XLS", { set.seed(1234) diff --git a/tests/testthat/test-check.R b/tests/testthat/test-check.R index 05e534742..39a8520e7 100644 --- a/tests/testthat/test-check.R +++ b/tests/testthat/test-check.R @@ -64,49 +64,13 @@ test_that("Caller", { ) version <- c("1", "2") expect_error( - .check_version(version), + .message_version(version), ".check_version: version should be a lower case character vector with no underlines" ) progress <- "TRUE" expect_error( - .check_progress(progress), - ".check_progress: progress must be either TRUE or FALSE" - ) - # .check_chr_within - expect_equal( - .check_chr_within(c("a", "a"), - within = c("a", "b", "c"), - discriminator = "one_of" - ), - c("a", "a") - ) - expect_equal( - .check_chr_within(c("a", "b"), - within = c("a", "b", "c"), - discriminator = "any_of" - ), - c("a", "b") - ) - expect_equal( - .check_chr_within(c("a", "b"), - within = c("a", "b", "c"), - discriminator = "all_of" - ), - c("a", "b") - ) - expect_equal( - .check_chr_within(c("a", "b", "b", "c"), - within = c("a", "b", "c"), - discriminator = "all_of" - ), - c("a", "b", "b", "c") - ) - expect_equal( - .check_chr_within(c("a", "b", "c"), - within = c("d"), - discriminator = "none_of" - ), - c("a", "b", "c") + .message_progress(progress), + ".test_check: invalid progress parameter" ) expect_error( .check_chr_within(c("a", "b", "b", "c"), @@ -140,56 +104,21 @@ test_that("Caller", { discriminator = "exactly" ) ) - expect_equal( - .check_chr_contains(c("a", "b", "c"), - contains = c("a", "b"), - discriminator = "any_of" - ), - c("a", "b", "c") - ) expect_error( .check_chr_contains(c("a", "b", "c"), contains = c("a", "b"), discriminator = "one_of" ) ) - expect_equal( - .check_chr_contains(c("a", "b", "c"), - contains = c("a", "b"), - discriminator = "any_of" - ), - c("a", "b", "c") - ) - expect_equal( - .check_chr_contains(c("a", "b", "c"), - contains = c("a", "b", "c"), - discriminator = "all_of" - ), - c("a", "b", "c") - ) expect_error( .check_chr_contains(c("a", "b", "b", "b"), contains = c("a", "b", "c"), discriminator = "all_of" ) ) - - # .check_lgl - expect_equal( - .check_lgl(c(TRUE, FALSE, FALSE), allow_na = FALSE), - c(TRUE, FALSE, FALSE) - ) expect_error( .check_lgl(c(TRUE, NA, FALSE), allow_na = FALSE) ) - expect_equal( - .check_lgl(c(TRUE, NA, FALSE), allow_na = TRUE), - c(TRUE, NA, FALSE) - ) - expect_equal( - .check_lgl(logical(0)), - logical(0) - ) expect_error( .check_lgl(logical(0), len_min = 1) ) @@ -199,26 +128,13 @@ test_that("Caller", { expect_error( .check_lgl(NULL, msg = "NULL value is not allowed") ) - expect_equal( - .check_lgl(NULL, allow_null = TRUE), - NULL - ) expect_error( .check_lgl(c(a = TRUE, b = FALSE)) ) - expect_equal( - .check_lgl(c(a = TRUE, b = FALSE), is_named = TRUE), - c(a = TRUE, b = FALSE) - ) expect_error( .check_lgl(c(TRUE, FALSE), is_named = TRUE) ) - # .check_num - expect_equal( - .check_num(c(1, 2, 3), allow_na = FALSE), - c(1, 2, 3) - ) expect_error( .check_num(c(1, NA, 3), allow_na = FALSE) ) @@ -228,14 +144,6 @@ test_that("Caller", { expect_error( .check_num(c(1, 2, 3), max = "a") ) - expect_equal( - .check_num(c(1, NA, 3), allow_na = TRUE), - c(1, NA, 3) - ) - expect_equal( - .check_num(c(0, 1, 2, 3, 4), min = -9, max = 9), - c(0, 1, 2, 3, 4) - ) expect_error( .check_num(c(0, 1, 2, 3, 4), exclusive_min = 0) ) @@ -257,14 +165,6 @@ test_that("Caller", { expect_error( .check_num(c(0, 1, 2, 3, 4), min = 1, max = 3) ) - expect_equal( - .check_num(c(0, 1, 2, 3, 4), min = 0, max = 4), - c(0, 1, 2, 3, 4) - ) - expect_equal( - .check_num(numeric(0)), - numeric(0) - ) expect_error( .check_num(numeric(0), len_min = 1) ) @@ -274,25 +174,9 @@ test_that("Caller", { expect_error( .check_num(NULL, msg = "NULL value is not allowed") ) - expect_equal( - .check_num(NULL, allow_null = TRUE), - NULL - ) - expect_equal( - .check_num(c(1, 1.23, 2)), - c(1, 1.23, 2) - ) - expect_equal( - .check_num(x = 1, min = 1.1, max = 1.1, tolerance = 0.1), - 1 - ) expect_error( .check_num(x = 1, min = 1.1, max = 1.1, tolerance = 0) ) - expect_equal( - .check_num(x = -1, min = -0.99, max = -1, tolerance = 0.1), - -1 - ) expect_error( .check_num(x = -1, min = -0.99, max = -1), ) @@ -302,44 +186,18 @@ test_that("Caller", { expect_error( .check_num(c(a = 1, b = 2)) ) - expect_equal( - .check_num(c(a = 1, b = 2), is_named = TRUE), - c(a = 1, b = 2) - ) expect_error( .check_num(c(1, 2), is_named = TRUE) ) - - # .check_chr - expect_equal( - .check_chr(c("a", "b", "c")), - c("a", "b", "c") - ) expect_error( .check_chr(c("a", NA, "c")) ) - expect_equal( - .check_chr(c("a", NA, "c"), allow_na = TRUE), - c("a", NA, "c") - ) - expect_equal( - .check_chr(c("a", "", "c")), - c("a", "", "c") - ) expect_error( .check_chr(c("a", "", "c"), allow_empty = FALSE) ) expect_error( .check_chr(c(NA, "", "c")) ) - expect_equal( - .check_chr(c(NA, "", "c"), allow_na = TRUE, allow_empty = TRUE), - c(NA, "", "c") - ) - expect_equal( - .check_chr(character(0)), - character(0) - ) expect_error( .check_chr(character(0), len_min = 1) ) @@ -356,28 +214,15 @@ test_that("Caller", { expect_error( .check_chr(c(a = "a", b = "b")) ) - expect_equal( - .check_chr(c(a = "a", b = "b"), is_named = TRUE), - c(a = "a", b = "b") - ) expect_error( .check_chr(c("a", "b"), is_named = TRUE) ) - expect_equal( - .check_chr(c("http://example.com"), regex = "^[^ \"]+://[^ \"]+$"), - c("http://example.com") - ) expect_error( .check_chr(c("http://example com"), regex = "^[^ \"]+://[^ \"]+$") ) expect_error( .check_chr(c("example.com"), regex = "^[^ \"]+://[^ \"]+$") ) - # .check_lst - expect_equal( - .check_lst(list()), - list() - ) expect_error( .check_lst(list(), len_min = 1) ) @@ -387,29 +232,12 @@ test_that("Caller", { expect_error( .check_lst(NULL, msg = "NULL value is not allowed") ) - expect_equal( - .check_lst(NULL, allow_null = TRUE), - NULL - ) - expect_equal( - .check_lst(list(a = 1, b = 2)), - list(a = 1, b = 2) - ) expect_error( .check_lst(list(a = 1, b = 2), is_named = FALSE) ) - expect_equal( - .check_lst(list(1, 2), is_named = FALSE), - list(1, 2) - ) - expect_equal( - .check_lst(list(a = 1, b = 2), fn_check = .check_num_type), - list(a = 1, b = 2) - ) expect_error( .check_lst(list(a = "a", b = "b"), fn_check = .check_num_type) ) - # .check_file expect_error( .check_file(character(0)) @@ -425,14 +253,9 @@ test_that("Caller", { expect_warning( .check_warn(.check_that(FALSE)) ) - expect_equal( - .check_warn(.check_num(123)), - 123 - ) Sys.setenv("SITS_DOCUMENTATION_MODE" = "TRUE") - expect_false(.check_warnings()) - expect_false(.check_documentation(progress = TRUE)) - expect_false(.check_messages()) + expect_false(.message_warnings()) + expect_false(.message_progress(progress = TRUE)) Sys.setenv("SITS_DOCUMENTATION_MODE" = "FALSE") }) From 03fbc3a4d435d802bd4a5b19037d40392ad4ef24 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Thu, 10 Apr 2025 16:49:05 -0300 Subject: [PATCH 076/122] fix message for progress test --- R/api_colors.R | 19 ++++++++----------- R/api_conf.R | 40 +++++++++++++++++---------------------- R/sits_classify.R | 3 +-- R/sits_cube_copy.R | 3 +-- R/sits_detect_change.R | 3 +-- R/sits_get_data.R | 9 +++------ R/sits_mixture_model.R | 3 +-- R/sits_regularize.R | 15 +++++---------- R/sits_sample_functions.R | 3 +-- 9 files changed, 38 insertions(+), 60 deletions(-) diff --git a/R/api_colors.R b/R/api_colors.R index d180ade14..04e841124 100644 --- a/R/api_colors.R +++ b/R/api_colors.R @@ -87,9 +87,8 @@ ) # find out how many lines to write per name color_tb[["lines"]] <- purrr::map_int(color_tb[["name"]], function(s) { - return(stringr::str_count(stringr::str_wrap(s, width = 12), "\n") + 1) - } - ) + stringr::str_count(stringr::str_wrap(s, width = 12), "\n") + 1 + }) n_colors <- nrow(color_tb) if (n_colors <= 12) n_rows_show <- 3 @@ -195,7 +194,6 @@ # close the file close(con) - return(invisible(NULL)) } #' @title Transform an RColorBrewer name to cols4all name #' @name .colors_cols4all_name @@ -205,7 +203,7 @@ #' @param palette An RColorBrewer palette name #' @return A valid cols4all palette name #' -.colors_cols4all_name <- function(palette){ +.colors_cols4all_name <- function(palette) { .check_set_caller(".colors_cols4all_name") # check if palette name is in RColorBrewer brewer_pals <- rownames(RColorBrewer::brewer.pal.info) @@ -214,11 +212,10 @@ c4a_pals <- cols4all::c4a_palettes() c4a_brewer <- c4a_pals[grep("brewer.", c4a_pals)] c4a_pal_name <- c4a_brewer[which(brewer_pals == palette)] - } - else { + } else { c4a_pal_name <- cols4all::c4a_info(palette, verbose = FALSE)$fullname } - return(c4a_pal_name) + c4a_pal_name } #' @title Transform an legend from tibble to vector #' @name .colors_legend_set @@ -228,12 +225,12 @@ #' @param legend A legend in tibble format #' @return A valid legend as vector #' -.colors_legend_set <- function(legend){ - if ("tbl_df" %in% class(legend)) { +.colors_legend_set <- function(legend) { + if (inherits(legend, "tbl_df"){ .check_legend(legend) legend_vec <- legend[["color"]] names(legend_vec) <- legend[["name"]] return(legend_vec) } - return(legend) + legend } diff --git a/R/api_conf.R b/R/api_conf.R index 15cb9882d..fe5292028 100644 --- a/R/api_conf.R +++ b/R/api_conf.R @@ -72,9 +72,7 @@ names(source) <- tolower(names(source)) # check source source <- .check_error( - { - do.call(.conf_new_source, args = source) - }, + do.call(.conf_new_source, args = source), msg = .conf("messages", ".conf_set_options_source") ) return(source) @@ -127,11 +125,10 @@ .check_set_caller(".conf_file") # load the default configuration file yml_file <- system.file("extdata", "config.yml", package = "sits") - # check that the file name is valid .check_file(yml_file) - - return(yml_file) + # return configuration file + yml_file } #' @title Return the internal configuration file (only for developers) #' @name .conf_internals_file @@ -144,7 +141,8 @@ yml_file <- system.file("extdata", "config_internals.yml", package = "sits") # check that the file name is valid .check_that(file.exists(yml_file)) - return(yml_file) + # return configuration file + yml_file } #' @title Return the user-relevant configuration file #' @name .config_file @@ -157,7 +155,8 @@ yml_file <- system.file("extdata", "config.yml", package = "sits") # check that the file name is valid .check_that(file.exists(yml_file)) - return(yml_file) + # return configuration file + yml_file } #' @title Return the message configuration files (only for developers) #' @name .conf_sources_files @@ -175,13 +174,14 @@ ) # check that the file name is valid purrr::map(yml_files, .check_file) - return(yml_files) + # return configuration file + yml_files } #' @name .conf_load_sources #' @description Loads sources configurations #' @keywords internal #' @noRd -#' @return NULL, called for side effects +#' @return called for side effects .conf_load_sources <- function() { # get file paths source_yml_files <- .conf_sources_files() @@ -207,8 +207,6 @@ )) # set configurations do.call(.conf_set_options, args = config_obj) - # done - return(invisible(NULL)) } #' @title Return the message configuration file (only for developers) #' @name .conf_messages_file @@ -221,13 +219,14 @@ yml_file <- system.file("extdata", "config_messages.yml", package = "sits") # check that the file name is valid .check_file(yml_file) - return(yml_file) + # return configuration file + yml_file } #' @name .conf_load_messages #' @description Loads the error messages and warnings #' @keywords internal #' @noRd -#' @return NULL, called for side effects +#' @return called for side effects .conf_load_messages <- function() { # load the color configuration file msgs_yml_file <- .conf_messages_file() @@ -237,7 +236,6 @@ ) # set the messages sits_env[["config"]][["messages"]] <- config_msgs - return(invisible(NULL)) } #' @title Return the default configuration file for colors #' @name .conf_colors_file @@ -258,7 +256,7 @@ #' @description Loads the default color table #' @keywords internal #' @noRd -#' @return NULL, called for side effects +#' @return Called for side effects .conf_load_color_table <- function() { # load the color configuration file color_yml_file <- .conf_colors_file() @@ -283,7 +281,6 @@ # set the color table sits_env[["color_table"]] <- color_table - return(invisible(color_table)) } #' @title Add user color table #' @name .conf_add_color_table @@ -292,7 +289,7 @@ #' @param color_tb user color table #' @keywords internal #' @noRd -#' @return new color table (invisible) +#' @return Called for side effects .conf_add_color_table <- function(color_tb) { .check_set_caller(".conf_add_color_table") # pre condition - table contains name and hex code @@ -307,7 +304,6 @@ old_color_tb <- dplyr::filter(sits_env[["color_table"]], !(.data[["name"]] %in% new_colors)) sits_env[["color_table"]] <- dplyr::bind_rows(old_color_tb, color_tb) - return(invisible(sits_env[["color_table"]])) } #' @title Merge user colors with default colors #' @name .conf_merge_colors @@ -335,7 +331,7 @@ } } sits_env[["color_table"]] <- color_table - return(color_table) + color_table } #' @title Merge user legends with default legends #' @name .conf_merge_legends @@ -343,7 +339,7 @@ #' @param user_legends List of user legends #' @keywords internal #' @noRd -#' @return new color table +#' @return Called for side effects .conf_merge_legends <- function(user_legends){ .check_set_caller(".conf_merge_legends") # check legends are valid names @@ -358,8 +354,6 @@ return(TRUE) }) sits_env[["legends"]] <- c(sits_env[["legends"]], user_legends) - return(invisible(sits_env[["legends"]])) - } #' @title Return the default color table #' @name .conf_colors diff --git a/R/sits_classify.R b/R/sits_classify.R index a17249874..859230125 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -173,8 +173,7 @@ sits_classify.sits <- function(data, .check_samples_ts(data) .check_is_sits_model(ml_model) .check_int_parameter(multicores, min = 1, max = 2048) - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) .check_function(impute_fn) .check_filter_fn(filter_fn) # save batch_size for later use diff --git a/R/sits_cube_copy.R b/R/sits_cube_copy.R index 66eb80300..5b10681e3 100644 --- a/R/sits_cube_copy.R +++ b/R/sits_cube_copy.R @@ -124,8 +124,7 @@ sits_cube_copy <- function(cube, output_dir <- path.expand(output_dir) .check_output_dir(output_dir) # Check progress - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) # Prepare parallel processing .parallel_start(workers = multicores) on.exit(.parallel_stop(), add = TRUE) diff --git a/R/sits_detect_change.R b/R/sits_detect_change.R index 8375e7340..9f52a3414 100644 --- a/R/sits_detect_change.R +++ b/R/sits_detect_change.R @@ -57,8 +57,7 @@ sits_detect_change.sits <- function(data, .check_samples_ts(data) .check_is_sits_model(dc_method) .check_int_parameter(multicores, min = 1, max = 2048) - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) # preconditions - impute and filter functions if (!is.null(filter_fn)) { .check_function(filter_fn) diff --git a/R/sits_get_data.R b/R/sits_get_data.R index 832afefc9..0e2c03369 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -177,8 +177,7 @@ sits_get_data.csv <- function(cube, .check_cube_bands(cube, bands = bands) .check_crs(crs) .check_int_parameter(multicores, min = 1, max = 2048) - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) .check_function(impute_fn) # Extract a data frame from csv samples <- .csv_get_samples(samples) @@ -290,8 +289,7 @@ sits_get_data.shp <- function(cube, start_date <- .default(start_date, .cube_start_date(cube)) end_date <- .default(end_date, .cube_end_date(cube)) .check_int_parameter(multicores, min = 1, max = 2048) - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) # Extract a data frame from shapefile samples <- .shp_get_samples( @@ -413,8 +411,7 @@ sits_get_data.sf <- function(cube, bands <- .cube_bands(cube) .check_cube_bands(cube, bands = bands) .check_int_parameter(multicores, min = 1, max = 2048) - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) .check_function(impute_fn) # Get default start and end date start_date <- .default(start_date, .cube_start_date(cube)) diff --git a/R/sits_mixture_model.R b/R/sits_mixture_model.R index c8bc84192..aa006e554 100644 --- a/R/sits_mixture_model.R +++ b/R/sits_mixture_model.R @@ -121,8 +121,7 @@ sits_mixture_model.sits <- function(data, endmembers, ..., .check_samples_train(data) .check_lgl_parameter(rmse_band) .check_int_parameter(multicores, min = 1, max = 2048) - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) # Transform endmembers to tibble em <- .endmembers_as_tbl(endmembers) diff --git a/R/sits_regularize.R b/R/sits_regularize.R index 8ddb77201..6500fd81b 100644 --- a/R/sits_regularize.R +++ b/R/sits_regularize.R @@ -180,8 +180,7 @@ sits_regularize.raster_cube <- function(cube, ..., # check multicores .check_num_parameter(multicores, min = 1, max = 2048) # check progress - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) # Does cube contain cloud band? If not, issue a warning .message_warnings_regularize_cloud(cube) if (.has(roi)) { @@ -243,8 +242,7 @@ sits_regularize.sar_cube <- function(cube, ..., output_dir <- .file_path_expand(output_dir) .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1, max = 2048) - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) # check for ROI and tiles if (!is.null(roi) || !is.null(tiles)) { .check_roi_tiles(roi, tiles) @@ -302,8 +300,7 @@ sits_regularize.combined_cube <- function(cube, ..., output_dir <- .file_path_expand(output_dir) .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1, max = 2048) - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) # check for ROI and tiles .check_roi_tiles(roi, tiles) if (.has(grid_system)) { @@ -359,8 +356,7 @@ sits_regularize.rainfall_cube <- function(cube, ..., output_dir <- .file_path_expand(output_dir) .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1, max = 2048) - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) # check for ROI and tiles if (!is.null(roi) || !is.null(tiles)) { .check_roi_tiles(roi, tiles) @@ -415,8 +411,7 @@ sits_regularize.dem_cube <- function(cube, ..., output_dir <- .file_path_expand(output_dir) .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1, max = 2048) - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) # check for ROI and tiles if (!is.null(roi) || !is.null(tiles)) { .check_roi_tiles(roi, tiles) diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R index c7dfb7fb2..efa425c27 100644 --- a/R/sits_sample_functions.R +++ b/R/sits_sample_functions.R @@ -466,8 +466,7 @@ sits_stratified_sampling <- function(cube, # check multicores .check_int_parameter(multicores, min = 1, max = 2048) # check progress - .check_progress(progress) - progress <- .message_progress() + progress <- .message_progress(progress) # transform labels to tibble cube_labels <- tibble::rownames_to_column( as.data.frame(cube_labels), var = "label_id" From b9f38a7d01545c5e2768eccbfdf9dd183a2b3d5b Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Thu, 10 Apr 2025 16:51:16 -0300 Subject: [PATCH 077/122] fix bug in colors_legend_set --- R/api_colors.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/api_colors.R b/R/api_colors.R index 04e841124..27b58f235 100644 --- a/R/api_colors.R +++ b/R/api_colors.R @@ -226,7 +226,7 @@ #' @return A valid legend as vector #' .colors_legend_set <- function(legend) { - if (inherits(legend, "tbl_df"){ + if (inherits(legend, "tbl_df")) { .check_legend(legend) legend_vec <- legend[["color"]] names(legend_vec) <- legend[["name"]] From d4556f2d9a466aeb4af0c973b6dd0cbd0bc47dcc Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Fri, 11 Apr 2025 13:30:51 -0300 Subject: [PATCH 078/122] fix check_source_collection --- R/api_accuracy.R | 2 +- R/api_check.R | 44 +++++++++++++++++++++++ R/api_conf.R | 39 ++------------------ R/api_csv.R | 6 ++-- R/api_cube.R | 3 +- R/api_source.R | 37 +++++-------------- R/api_tile.R | 61 ++++++++++++++++---------------- R/api_timeline.R | 33 ++++------------- R/api_tmap.R | 32 ++++++++--------- R/api_torch.R | 18 ++++------ R/api_torch_psetae.R | 16 ++++----- R/api_ts.R | 8 ++--- R/api_tuning.R | 33 ++++++++--------- R/api_uncertainty.R | 17 ++++----- R/api_utils.R | 8 ++--- R/api_validate.R | 4 +-- R/api_view.R | 43 ++++++++++------------ R/sits_accuracy.R | 19 +++++----- R/sits_apply.R | 8 ++--- R/sits_bands.R | 23 +++++------- R/sits_bayts.R | 5 ++- R/sits_classify.R | 14 ++++---- R/sits_clean.R | 5 ++- R/sits_cluster.R | 9 ++--- R/sits_colors.R | 6 +--- R/sits_config.R | 10 ++---- R/sits_csv.R | 3 +- R/sits_cube.R | 13 ++++--- R/sits_cube_copy.R | 2 +- R/sits_cube_local.R | 17 ++++----- R/sits_detect_change.R | 9 ++--- R/sits_dtw.R | 13 ++----- R/sits_factory.R | 5 ++- R/sits_filters.R | 15 ++++---- R/sits_geo_dist.R | 2 +- R/sits_get_class.R | 33 ++++++++--------- R/sits_get_data.R | 2 +- R/sits_get_probs.R | 18 +++++----- R/sits_histogram.R | 6 ++-- R/sits_imputation.R | 11 +++--- R/sits_label_classification.R | 9 +++-- R/sits_labels.R | 29 +++++++-------- R/sits_lighttae.R | 21 +++++------ R/sits_machine_learning.R | 31 +++++++--------- R/sits_merge.R | 5 ++- R/sits_mixture_model.R | 16 ++++----- R/sits_mlp.R | 9 ++--- R/sits_model_export.R | 5 ++- R/sits_patterns.R | 10 +++--- R/sits_reduce.R | 7 ++-- R/sits_sample_functions.R | 10 +++--- R/sits_segmentation.R | 12 +++---- R/sits_som.R | 21 +++++------ R/sits_summary.R | 11 +++--- R/sits_tae.R | 3 +- R/sits_tempcnn.R | 2 +- inst/extdata/config_messages.yml | 4 +++ man/sits_accuracy.Rd | 3 +- man/sits_apply.Rd | 2 +- man/sits_classify.Rd | 11 +++--- man/sits_cube.Rd | 6 ++-- man/sits_cube.results_cube.Rd | 13 +++---- man/sits_cube_copy.Rd | 2 +- man/sits_get_data.Rd | 2 +- man/sits_label_classification.Rd | 2 +- tests/testthat/test-config.R | 6 ++-- 66 files changed, 382 insertions(+), 522 deletions(-) diff --git a/R/api_accuracy.R b/R/api_accuracy.R index acb007912..8fd7e69ac 100644 --- a/R/api_accuracy.R +++ b/R/api_accuracy.R @@ -130,7 +130,7 @@ ) ) class(acc_area) <- c("sits_area_accuracy", class(acc_area)) - return(acc_area) + return(acc_area) } #' @title Support for pixel-based post-classification accuracy #' @name .accuracy_pixel_assess diff --git a/R/api_check.R b/R/api_check.R index 89a8f55a6..d6f462197 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -2481,4 +2481,48 @@ msg = .conf("messages", ".check_unique_period") ) } +#' @name .check_source_collection +#' @noRd +#' @description \code{.check_source_collection()} checks if a collection +#' is from a source. +#' @return \code{.check_source_collection()} returns \code{NULL} if +#' no error occurs. +.check_source_collection <- function(source, + collection) { + # set calller for error msg + .check_set_caller(".check_source_collection") + # check collection + .check_chr_parameter(collection, len_min = 1, len_max = 1) + .check_chr_within(collection, + within = .source_collections(source = source) + ) + return(invisible(NULL)) +} +#' @title Check band availability +#' @name .check_bands_collection +#' @description Checks if the requested bands are available in the collection +#' +#' @keywords internal +#' @noRd +#' @param source Data source +#' @param collection Collection to be searched in the data source. +#' @param bands Bands to be included. +#' +#' @return Called for side effects. +.check_bands_collection <- function(source, collection, bands) { + # set caller to show in errors + .check_set_caller(".conf_check_bands") + sits_bands <- .source_bands( + source = source, + collection = collection + ) + source_bands <- .source_bands_band_name( + source = source, + collection = collection + ) + .check_chr_within( + x = bands, + within = c(sits_bands, source_bands) + ) +} diff --git a/R/api_conf.R b/R/api_conf.R index fe5292028..ee8aab0d6 100644 --- a/R/api_conf.R +++ b/R/api_conf.R @@ -340,19 +340,13 @@ #' @keywords internal #' @noRd #' @return Called for side effects -.conf_merge_legends <- function(user_legends){ +.conf_merge_legends <- function(user_legends) { .check_set_caller(".conf_merge_legends") # check legends are valid names .check_chr_parameter(names(user_legends), len_max = 100, msg = .conf("messages", ".conf_merge_legends_user")) # check legend names do not already exist .check_that(!(any(names(user_legends) %in% names(sits_env[["legends"]])))) - # check colors names are valid - ok <- purrr::map_lgl(user_legends, function(leg){ - .check_chr_parameter(leg, len_max = 100, - msg = .conf("messages", ".conf_merge_legends_colors")) - return(TRUE) - }) sits_env[["legends"]] <- c(sits_env[["legends"]], user_legends) } #' @title Return the default color table @@ -362,7 +356,7 @@ #' @return default color table #' .conf_colors <- function() { - return(sits_env[["color_table"]]) + sits_env[["color_table"]] } #' @title Return the user configuration set in enviromental variable #' @name .conf_user_env_var @@ -449,35 +443,6 @@ } } } -#' @title Check band availability -#' @name .conf_check_bands -#' @description Checks if the requested bands are available in the collection -#' -#' @keywords internal -#' @noRd -#' @param source Data source -#' @param collection Collection to be searched in the data source. -#' @param bands Bands to be included. -#' -#' @return Called for side effects. -.conf_check_bands <- function(source, collection, bands) { - # set caller to show in errors - .check_set_caller(".conf_check_bands") - - sits_bands <- .source_bands( - source = source, - collection = collection - ) - source_bands <- .source_bands_band_name( - source = source, - collection = collection - ) - .check_chr_within( - x = bands, - within = c(sits_bands, source_bands) - ) - return(invisible(bands)) -} #' @title List configuration parameters #' @name .conf_list_params #' @description List the contents of a source diff --git a/R/api_csv.R b/R/api_csv.R index 4306cda17..a2165a42c 100644 --- a/R/api_csv.R +++ b/R/api_csv.R @@ -74,11 +74,10 @@ ) ) # select valid columns - samples <- dplyr::select( + dplyr::select( samples, c("longitude", "latitude") ) - return(samples) } #' @title Get samples metadata as CSV #' @name .csv_metadata_from_samples @@ -96,6 +95,5 @@ n_rows_csv <- nrow(csv) id <- tibble::tibble(id = 1:n_rows_csv) # join the two tibbles - csv <- dplyr::bind_cols(id, csv) - return(csv) + dplyr::bind_cols(id, csv) } diff --git a/R/api_cube.R b/R/api_cube.R index 24c2ff1e2..a4e21cf8d 100644 --- a/R/api_cube.R +++ b/R/api_cube.R @@ -519,8 +519,7 @@ NULL .cube_crs.default <- function(cube) { cube <- tibble::as_tibble(cube) cube <- .cube_find_class(cube) - crs <- .cube_crs(cube) - return(crs) + .cube_crs(cube) } #' @title Return period of a data cube #' @keywords internal diff --git a/R/api_source.R b/R/api_source.R index d2455a96f..86a3f665f 100644 --- a/R/api_source.R +++ b/R/api_source.R @@ -203,7 +203,7 @@ NULL # collection is upper case collection <- toupper(collection) # pre-condition - .source_collection_check(source = source, collection = collection) + .check_source_collection(source = source, collection = collection) # find the bands available in the collection bands <- names(.conf("sources", source, "collections", collection, "bands")) # bands names are upper case @@ -250,7 +250,7 @@ NULL # collection is upper case collection <- toupper(collection) # pre-condition - .source_collection_check(source = source, collection = collection) + .check_source_collection(source = source, collection = collection) # get the bands if (is.null(bands)) { bands <- .source_bands( @@ -297,7 +297,7 @@ NULL # collection is upper case collection <- toupper(collection) # pre-condition - .source_collection_check(source = source, collection = collection) + .check_source_collection(source = source, collection = collection) # get the bands bands <- .source_bands_reap( source = source, @@ -333,7 +333,7 @@ NULL # collection is upper case collection <- toupper(collection) # pre-condition - .source_collection_check(source = source, collection = collection) + .check_source_collection(source = source, collection = collection) # get the resolution resolution <- .source_bands_reap( source = source, @@ -439,7 +439,7 @@ NULL # collection is upper case collection <- toupper(collection) # pre-condition - .source_collection_check(source = source, collection = collection) + .check_source_collection(source = source, collection = collection) # get the bit mask bit_mask <- .conf( "sources", source, @@ -467,7 +467,7 @@ NULL # collection is upper case collection <- toupper(collection) # pre-condition - .source_collection_check(source = source, collection = collection) + .check_source_collection(source = source, collection = collection) # get values cloud_values <- .conf( "sources", source, @@ -495,7 +495,7 @@ NULL # collection is upper case collection <- toupper(collection) # pre-condition - .source_collection_check(source = source, collection = collection) + .check_source_collection(source = source, collection = collection) # get values cloud_interp_values <- .conf( "sources", source, @@ -584,25 +584,6 @@ NULL return(invisible(vars)) } -#' @rdname .source_collection -#' @noRd -#' @description \code{.source_collection_check()} checks if a collection -#' is from a source. -#' -#' @return \code{.source_collection_check()} returns \code{NULL} if -#' no error occurs. -.source_collection_check <- function(source, - collection) { - # set calller for error msg - .check_set_caller(".source_collection_check") - # check collection - .check_chr_parameter(collection, len_min = 1, len_max = 1) - .check_chr_within(collection, - within = .source_collections(source = source) - ) - return(invisible(NULL)) -} - #' @rdname source_collection #' @noRd #' @description \code{.source_collection_metadata_search()} retrieves the @@ -641,7 +622,7 @@ NULL # collection is upper case collection <- toupper(collection) # pre-condition - .source_collection_check( + .check_source_collection( source = source, collection = collection ) @@ -674,7 +655,7 @@ NULL # collection is upper case collection <- toupper(collection) # pre-condition - .source_collection_check( + .check_source_collection( source = source, collection = collection ) diff --git a/R/api_tile.R b/R/api_tile.R index 95615f7c5..10874c3ba 100644 --- a/R/api_tile.R +++ b/R/api_tile.R @@ -27,10 +27,10 @@ NULL } #' @export .tile.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - tile <- .tile(cube) - return(tile) + tile <- cube |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile() } #' @title Get source cloud provider for a tile @@ -47,10 +47,11 @@ NULL } #' @export .tile_source.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - source <- .tile_source(tile) - return(source) + source <- tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_source() + } #' @title Get image collection for a tile #' @noRd @@ -842,9 +843,10 @@ NULL } #' @export .tile_filter_interval.default <- function(tile, start_date, end_date) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - tile <- .tile_filter_interval(tile, start_date, end_date) + tile <- tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_filter_interval(start_date, end_date) return(tile) } #' @@ -975,7 +977,7 @@ NULL values <- values + offset } # Return values - return(values) + values } #' @export .tile_read_block.default <- function(tile, band, block) { @@ -1033,14 +1035,15 @@ NULL value = is_bit_mask ) # Return values - return(values) + values } #' @export .tile_cloud_read_block.default <- function(tile, block) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - tile <- .tile_cloud_read_block(tile, block) - return(tile) + tile <- tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_cloud_read_block(block) + } #' @title Create chunks of a tile to be processed #' @name .tile_chunks_create @@ -1410,7 +1413,7 @@ NULL tile <- tibble::as_tibble(tile) tile <- .cube_find_class(tile) tile <- .tile_area_freq(tile) - return(tile) + tile } #' @title Given a tile and a band, return a set of values for chosen location #' @name .tile_extract @@ -1494,7 +1497,7 @@ NULL values <- dplyr::bind_rows(values) values <- dplyr::select(values, -"coverage_fraction") # Return values - return(as.matrix(values)) + as.matrix(values) } #' @title Given a tile and a band, return a set of values for segments ready to #' be used @@ -1578,7 +1581,7 @@ NULL tile[["tile"]], "' at ", start_time ) } - return(start_time) + start_time } #' @title Measure classification time #' @name .tile_classif_end @@ -1600,7 +1603,6 @@ NULL ) message("") } - return(invisible(end_time)) } #' @title Return the cell size for the image to be reduced for plotting #' @name .tile_overview_size @@ -1627,17 +1629,17 @@ NULL } # determine the best COG size best_cog_size <- cog_sizes[[i]] - return(c( + c( xsize = best_cog_size[["xsize"]], - ysize = best_cog_size[["ysize"]]) + ysize = best_cog_size[["ysize"]] ) } else { # get the maximum number of bytes for the tiles nrows_tile <- max(.tile_nrows(tile)) ncols_tile <- max(.tile_ncols(tile)) # get the ratio to the max plot size - ratio_x <- max(ncols_tile/max_size, 1) - ratio_y <- max(nrows_tile/max_size, 1) + ratio_x <- max(ncols_tile / max_size, 1) + ratio_y <- max(nrows_tile / max_size, 1) # if image is smaller than 1000 x 1000, return full size if (ratio_x == 1 && ratio_y == 1) { return(c( @@ -1648,10 +1650,9 @@ NULL # if ratio is greater than 1, get the maximum ratio <- max(ratio_x, ratio_y) # calculate nrows, ncols to be plotted - return(c( - xsize = floor(ncols_tile/ratio), - ysize = floor(nrows_tile/ratio) - )) + c(xsize = floor(ncols_tile / ratio), + ysize = floor(nrows_tile / ratio) + ) } } #' @title Return the size of overviews for COG files @@ -1704,5 +1705,5 @@ NULL #' @param tile Tile to be plotted #' @return Base info tibble .tile_base_info <- function(tile) { - return(tile[["base_info"]][[1]]) + tile[["base_info"]][[1]] } diff --git a/R/api_timeline.R b/R/api_timeline.R index 4a85a9cef..e17b9ab92 100644 --- a/R/api_timeline.R +++ b/R/api_timeline.R @@ -54,7 +54,7 @@ # find the number of the samples nsamples <- dates_index[[1]][[2]] - dates_index[[1]][[1]] + 1 # create a class_info tibble to be used in the classification - class_info <- tibble::tibble( + tibble::tibble( bands = list(bands), labels = list(labels), timeline = list(timeline), @@ -62,7 +62,6 @@ ref_dates = list(ref_dates), dates_index = list(dates_index) ) - return(class_info) } #' @title Test if date fits with the timeline #' @@ -102,14 +101,10 @@ # what is the difference in days between the last two days of the timeline? timeline_diff <- as.integer(timeline[[length(timeline)]] - timeline[[length(timeline) - 1]]) - # if the difference in days in the timeline is smaller than the difference # between the reference date and the last date of the timeline, then # we assume the date is valid - if (abs(as.integer(date - timeline[length(timeline)])) <= timeline_diff) { - return(TRUE) - } - return(FALSE) + abs(as.integer(date - timeline[length(timeline)])) <= timeline_diff } #' @title Find dates in the input data cube that match those of the patterns @@ -189,7 +184,7 @@ # is the end date a valid one? end_date <- subset_dates[[length(subset_dates)]][[2]] .check_that(.timeline_valid_date(end_date, timeline_data)) - return(subset_dates) + subset_dates } #' @title Find indexes in a timeline that match the reference dates @@ -211,16 +206,13 @@ #' to the timelines. #' .timeline_match_indexes <- function(timeline, ref_dates) { - dates_index <- ref_dates |> + ref_dates |> purrr::map(function(date_pair) { start_index <- which(timeline == date_pair[[1]]) end_index <- which(timeline == date_pair[[2]]) dates_index <- c(start_index, end_index) - return(dates_index) }) - - return(dates_index) } #' @title Find the subset of a timeline that is contained #' in an interval defined by start_date and end_date @@ -283,34 +275,23 @@ converted_dates <- lubridate::as_date(converted_dates) # check if there are NAs values .check_that(!anyNA(converted_dates)) - return(converted_dates) + converted_dates }) # convert to a vector of dates converted_dates <- lubridate::as_date(converted_dates) # postcondition .check_that(length(converted_dates) == length(dates)) - return(converted_dates) + converted_dates } #' @title Check if two timelines overlaps. #' @name .timeline_has_overlap #' @keywords internal #' @noRd -#' #' @description This function checks if the given two timeline overlaps. -#' #' @param timeline1 First timeline #' @param timeline2 Second timeline. #' @return TRUE if first and second timeline overlaps. #' .timeline_has_overlap <- function(timeline1, timeline2) { - start1 <- min(timeline1) - end1 <- max(timeline1) - start2 <- min(timeline2) - end2 <- max(timeline2) - - if (start1 <= end2 && start2 <= end1) { - return(TRUE) - } else { - return(FALSE) - } + min(timeline1) <= max(timeline2) && min(timeline2) <= max(timeline1) } diff --git a/R/api_tmap.R b/R/api_tmap.R index c1a873f40..78fded9eb 100644 --- a/R/api_tmap.R +++ b/R/api_tmap.R @@ -24,7 +24,7 @@ palette, rev, scale, - tmap_params){ + tmap_params) { # recover palette name used by cols4all cols4all_name <- .colors_cols4all_name(palette) @@ -72,7 +72,7 @@ tmap::tm_borders(col = seg_color, lwd = line_width) } - return(p) + p } #' @title Plot a DEM #' @name .tmap_dem_map @@ -127,7 +127,7 @@ tmap::tm_layout( scale = scale ) - return(p) + p } #' @title Plot a RGB color image with tmap @@ -195,7 +195,7 @@ p <- p + tmap::tm_shape(sf_seg) + tmap::tm_borders(col = seg_color, lwd = line_width) } - return(p) + p } #' @title Plot a probs image #' @name .tmap_probs_map @@ -217,7 +217,7 @@ palette, rev, scale, - tmap_params){ + tmap_params) { # recover palette name used by cols4all cols4all_name <- .colors_cols4all_name(palette) # reverse order of colors? @@ -251,7 +251,7 @@ title.size = tmap_params[["legend_title_size"]], text.size = tmap_params[["legend_text_size"]], bg.color = tmap_params[["legend_bg_color"]], - bg.alpha = tmap_params[["legend_bg_alpha"]], + bg.alpha = tmap_params[["legend_bg_alpha"]] ) ) + tmap::tm_facets() + @@ -261,6 +261,7 @@ tmap::tm_layout( scale = scale ) + p } # #' @title Plot a color image with legend @@ -308,7 +309,7 @@ tmap::tm_layout( scale = scale ) - return(p) + p } #' @title Plot a vector probs map @@ -327,7 +328,7 @@ #' @return A plot object .tmap_vector_probs <- function(sf_seg, palette, rev, labels, labels_plot, - scale, tmap_params){ + scale, tmap_params) { cols4all_name <- .colors_cols4all_name(palette) # reverse order of colors? if (rev) @@ -363,7 +364,7 @@ tmap::tm_layout( scale = scale ) - return(p) + p } #' @title Plot a vector class map #' @name .tmap_vector_class @@ -376,7 +377,7 @@ #' @param scale Scale to plot map (0.4 to 1.0) #' @param tmap_params Parameters to control tmap output #' @return A plot object -.tmap_vector_class <- function(sf_seg, colors, scale, tmap_params){ +.tmap_vector_class <- function(sf_seg, colors, scale, tmap_params) { # position legend_position <- tmap_params[["legend_position"]] if (legend_position == "outside") @@ -412,7 +413,7 @@ ) + tmap::tm_borders(lwd = 0.2) - return(p) + p } #' @title Plot a vector uncertainty map @@ -429,7 +430,7 @@ #' @param tmap_params Tmap parameters #' @return A plot object .tmap_vector_uncert <- function(sf_seg, palette, rev, - type, scale, tmap_params){ + type, scale, tmap_params) { # recover palette name used by cols4all cols4all_name <- .colors_cols4all_name(palette) # reverse order of colors? @@ -468,9 +469,7 @@ scale = scale ) + tmap::tm_borders(lwd = 0.2) - - - return(p) + p } #' @title Prepare tmap params for dots value #' @name .tmap_params_set @@ -489,7 +488,7 @@ #' \item \code{legend_bg_color}: color of legend background (default = "white") #' \item \code{legend_bg_alpha}: legend opacity (default = 0.5) #' } -.tmap_params_set <- function(dots, legend_position, legend_title = NULL){ +.tmap_params_set <- function(dots, legend_position, legend_title = NULL) { # tmap params graticules_labels_size <- as.numeric(.conf("plot", @@ -529,4 +528,3 @@ ) return(tmap_params) } - diff --git a/R/api_torch.R b/R/api_torch.R index 845a347a7..3f5bd938d 100644 --- a/R/api_torch.R +++ b/R/api_torch.R @@ -49,11 +49,10 @@ test_samples <- test_samples[sample( nrow(test_samples), nrow(test_samples) ), ] - - return(list( + list( train_samples = train_samples, test_samples = test_samples - )) + ) } #' @title Serialize torch model #' @name .torch_serialize_model @@ -445,7 +444,7 @@ #' #' @return TRUE/FALSE #' -.torch_cuda_enabled <- function(){ +.torch_cuda_enabled <- function() { torch::cuda_is_available() } #' @title Use GPU or CPU training? @@ -460,11 +459,7 @@ #' @return TRUE/FALSE #' .torch_cpu_train <- function() { - if (torch::cuda_is_available()) - cpu_train <- FALSE - else - cpu_train <- TRUE - return(cpu_train) + !(torch::cuda_is_available()) } #' @title Transform matrix to torch dataset #' @name .torch_as_dataset @@ -483,9 +478,9 @@ }, .getitem = function(i) { if (length(self$dim) == 3) - item_data <- self$x[i,,, drop = FALSE] + item_data <- self$x[i, , , drop = FALSE] else - item_data <- self$x[i,, drop = FALSE] + item_data <- self$x[i, , drop = FALSE] list(torch::torch_tensor( array(item_data, dim = c( @@ -500,4 +495,3 @@ dim(self$x)[[1]] } ) - diff --git a/R/api_torch_psetae.R b/R/api_torch_psetae.R index 9c5d54e19..3648d372f 100644 --- a/R/api_torch_psetae.R +++ b/R/api_torch_psetae.R @@ -93,7 +93,7 @@ # from a 2D shape [(batch_size * n_times), n_bands] # to a 3D shape [batch_size, n_times, dim_enc] values <- values$view(c(batch_size, n_times, dim_enc)) - return(values) + values } ) #' @title Torch module for positional encoder @@ -188,7 +188,7 @@ }, forward = function(x) { x <- x + self$p - return(x) + x } ) @@ -376,7 +376,7 @@ # input shape is 2D [batch_size x (n_heads:4 * dim_encoder:128)] # output shape is 2D [batch_size x dim_encoder:128] o_hat <- self$mlp(attention_output) - return(o_hat) + o_hat } ) #' @title Torch module for temporal attention encoder @@ -514,8 +514,7 @@ values <- self$dropout(values) # normalize output layer values <- self$out_layer_norm(values) - - return(values) + values } ) #' @title Torch module for calculating attention from query, keys and values @@ -586,8 +585,7 @@ # values has 3D shape [(num_heads * batch_size) x seq_len x split_value] # output has a 3D shape [(num_heads * batch_size) x 1 x split_value] values <- torch::torch_matmul(attn, values) - - return(values) + values } ) #' @title Torch module for calculating multi-head attention @@ -667,7 +665,7 @@ # calculate the query tensor # concatenate a sequence of tensors to match input batch_size tensors <- purrr::map(seq_len(batch_size), function(i) { - return(self$Q) + self$Q }) # the query tensor has 3D shape [n_heads x batch_size x d_k] query <- torch::torch_stack(tensors, dim = 2) @@ -713,6 +711,6 @@ values <- values$view(c(n_heads, batch_size, 1, d_in %/% n_heads)) # reshape to 3D shape [num_heads:16 x batch_size x dim_encoder:256] values <- values$squeeze(dim = 3) - return(values) + values } ) diff --git a/R/api_ts.R b/R/api_ts.R index 623c613c3..90d0183e1 100644 --- a/R/api_ts.R +++ b/R/api_ts.R @@ -298,11 +298,9 @@ } # correct the values using the scale factor values_ts <- values_ts * scale_factor + offset_value - # return the values of one band for point xy - return(values_ts) }) # return the values of all points xy for one band - return(ts_band_lst) + ts_band_lst }) # now we have to transpose the data ts_samples <- ts_bands |> @@ -317,7 +315,7 @@ ) # set class of time series class(points) <- c("sits", class(points)) - return(points) + points } #' @title Extract a time series from raster #' @name .ts_get_raster_class @@ -365,5 +363,5 @@ ) # set class of time series class(points) <- unique(c("predicted", "sits", class(points))) - return(points) + points } diff --git a/R/api_tuning.R b/R/api_tuning.R index 32669ff9d..5be97bd08 100644 --- a/R/api_tuning.R +++ b/R/api_tuning.R @@ -13,41 +13,38 @@ .tuning_pick_random <- function(trial, params) { # uniform distribution uniform <- function(min = 0, max = 1) { - val <- stats::runif(n = 1, min = min, max = max) - return(val) + stats::runif(n = 1, min = min, max = max) + } # random choice choice <- function(..., replace = TRUE) { options <- as.list(substitute(list(...), environment()))[-1] val <- sample(x = options, replace = replace, size = 1) if (length(val) == 1) val <- val[[1]] - return(unlist(val)) + unlist(val) } # normal distribution normal <- function(mean = 0, sd = 1) { - val <- stats::rnorm(n = 1, mean = mean, sd = sd) - return(val) + stats::rnorm(n = 1, mean = mean, sd = sd) } # lognormal distribution lognormal <- function(meanlog = 0, sdlog = 1) { - val <- stats::rlnorm(n = 1, meanlog = meanlog, sdlog = sdlog) - return(val) + stats::rlnorm(n = 1, meanlog = meanlog, sdlog = sdlog) } # loguniform distribution loguniform <- function(minlog = 0, maxlog = 1) { base <- exp(1) - return(exp(stats::runif(1, log(min(c(minlog, maxlog)), base), - log(max(c(minlog, maxlog)), base)))) + exp(stats::runif(1, log(min(c(minlog, maxlog)), base), + log(max(c(minlog, maxlog)), base))) } # beta distribution beta <- function(shape1, shape2) { - val <- stats::rbeta(n = 1, shape1 = shape1, shape2 = shape2) - return(val) + stats::rbeta(n = 1, shape1 = shape1, shape2 = shape2) } # get params <- purrr::map(as.list(params), eval, envir = environment()) params[["samples"]] <- NULL - return(params) + params } #' @title Convert hyper-parameters list to a tibble #' @name .tuning_params_as_tibble @@ -62,17 +59,17 @@ params <- lapply(params, function(x) { if (purrr::is_atomic(x)) { if (length(x) != 1) { - return(list(x)) + list(x) } - return(x) + x } if (purrr::is_list(x)) { - return(list(.tuning_params_as_tibble(x))) + list(.tuning_params_as_tibble(x)) } if (is.language(x)) { - return(deparse(x)) + deparse(x) } - return(list(x)) + list(x) }) - return(tibble::tibble(!!!params)) + tibble::tibble(!!!params) } diff --git a/R/api_uncertainty.R b/R/api_uncertainty.R index 524c3586c..d8e4c42d9 100644 --- a/R/api_uncertainty.R +++ b/R/api_uncertainty.R @@ -15,18 +15,16 @@ output_dir, version) { # Process each tile sequentially - uncert_cube <- .cube_foreach_tile(cube, function(tile) { + .cube_foreach_tile(cube, function(tile) { # Compute uncertainty - uncert_tile <- .uncertainty_raster_tile( + .uncertainty_raster_tile( tile = tile, band = band, uncert_fn = uncert_fn, output_dir = output_dir, version = version ) - return(uncert_tile) }) - return(uncert_cube) } #' @title Create an uncertainty tile-band asset #' @name .uncertainty_raster_tile @@ -118,7 +116,7 @@ block_file }) # Merge blocks into a new uncertainty_cube tile - uncert_tile <- .tile_derived_merge_blocks( + .tile_derived_merge_blocks( file = out_file, band = band, labels = .tile_labels(tile), @@ -128,8 +126,6 @@ multicores = .jobs_multicores(), update_bbox = FALSE ) - # Return uncertainty tile - uncert_tile } #---- internal functions ---- @@ -149,16 +145,15 @@ # Process each tile sequentially uncert_cube <- .cube_foreach_tile(cube, function(tile) { # Compute uncertainty - uncert_tile <- .uncertainty_vector_tile( + .uncertainty_vector_tile( tile = tile, band = band, output_dir = output_dir, version = version ) - return(uncert_tile) }) class(uncert_cube) <- c("uncertainty_vector_cube", class(cube)) - return(uncert_cube) + uncert_cube } #' @title Create an uncertainty vector tile #' @name .uncertainty_vector_tile @@ -226,7 +221,7 @@ uncert_tile[["vector_info"]][[1]][["band"]] <- band uncert_tile[["vector_info"]][[1]][["path"]] <- out_file class(uncert_tile) <- c("uncertainty_vector_cube", class(uncert_tile)) - return(uncert_tile) + uncert_tile } #---- uncertainty functions ---- diff --git a/R/api_utils.R b/R/api_utils.R index 431d8f39b..64c02336c 100644 --- a/R/api_utils.R +++ b/R/api_utils.R @@ -290,7 +290,7 @@ NULL if (!all(is.na(x)) && .has(x)) { return(prepare) } - return(default) + default } #' @title Return prepared value if X is TRUE @@ -303,7 +303,7 @@ NULL if (.has(x) && x) { return(prepare) } - return(default) + default } #' @title Create a tibble from a vector @@ -358,11 +358,11 @@ NULL .rand_sub_tempdir <- function() { new_dir <- FALSE while (!new_dir) { - new_temp_dir <- paste0(tempdir(), "/", sample(1:10000, size = 1)) + new_temp_dir <- paste0(tempdir(), "/", sample.int(10000, size = 1)) if (!dir.exists(new_temp_dir)) { dir.create(new_temp_dir) new_dir <- TRUE } } - return(new_temp_dir) + new_temp_dir } diff --git a/R/api_validate.R b/R/api_validate.R index 0ecc8709b..e04eb944b 100644 --- a/R/api_validate.R +++ b/R/api_validate.R @@ -1,5 +1,5 @@ .validate_sits <- function(samples, samples_validation, - validation_split, ml_method){ + validation_split, ml_method) { # Are there samples for validation? if (is.null(samples_validation)) { @@ -29,5 +29,5 @@ acc_obj <- caret::confusionMatrix(predicted, reference) # Set result class and return it .set_class(x = acc_obj, "sits_accuracy", class(acc_obj)) - return(acc_obj) + acc_obj } diff --git a/R/api_view.R b/R/api_view.R index 14e9895ec..6242ef8b1 100644 --- a/R/api_view.R +++ b/R/api_view.R @@ -21,7 +21,7 @@ overlayGroups = overlay_groups, options = leaflet::layersControlOptions(collapsed = FALSE) ) - return(leaf_map) + leaf_map } #' @title Update global leaflet @@ -35,12 +35,12 @@ #' #' @return A leaflet object #' -.view_update_global_leaflet <- function(leaf_map, overlay_groups){ +.view_update_global_leaflet <- function(leaf_map, overlay_groups) { # update global leaflet control sits_env[["leaflet"]][["overlay_groups"]] <- overlay_groups sits_env[["leaflet"]][["leaf_map"]] <- leaf_map - return(leaf_map) + leaf_map } #' @title Visualize a set of samples @@ -120,7 +120,7 @@ opacity = 1 ) } - return(leaf_map) + leaf_map } #' @title Visualize a set of neurons #' @name .view_neurons @@ -200,7 +200,7 @@ ) sits_env[["leaflet_som_colors"]] <- TRUE } - return(leaf_map) + leaf_map } #' @title Include leaflet to view segments #' @name .view_segments @@ -238,7 +238,7 @@ group = group ) - return(leaf_map) + leaf_map } #' @title Include leaflet to view classified regions #' @name .view_vector_class_cube @@ -302,7 +302,7 @@ fillOpacity = opacity, group = group ) - return(leaf_map) + leaf_map } #' @title Include leaflet to view images (BW or RGB) #' @name .view_image_raster @@ -527,14 +527,12 @@ na.rm = TRUE ) # get quantile values - minv <- quantiles[[1]] minq <- quantiles[[2]] maxq <- quantiles[[3]] - maxv <- quantiles[[4]] # set limits to raster - vals <- ifelse(vals > minq, vals, minq) - vals <- ifelse(vals < maxq, vals, maxq) + vals <- pmax(vals, minq) + vals <- pmin(vals, maxq) rast <- .raster_set_values(rast, vals) domain <- c(minq, maxq) @@ -568,7 +566,7 @@ ) sits_env[["leaflet_false_color_legend"]] <- TRUE } - return(leaf_map) + leaf_map } #' @title Include leaflet to view RGB bands #' @name .view_rgb_bands @@ -624,7 +622,7 @@ maxBytes = max_bytes, opacity = opacity ) - return(leaf_map) + leaf_map } #' @title Include leaflet to view classified cube @@ -728,7 +726,7 @@ ) } - return(leaf_map) + leaf_map } #' @title Include leaflet to view probs label #' @name .view_probs_label @@ -779,7 +777,6 @@ probs_conf <- .tile_band_conf(tile, "probs") probs_scale <- .scale(probs_conf) probs_offset <- .offset(probs_conf) - max_value <- .max_value(probs_conf) # select SpatRaster band to be plotted layer_rast <- which(labels == label) @@ -804,14 +801,12 @@ na.rm = TRUE ) # get quantile values - minv <- quantiles[[1]] minq <- quantiles[[2]] maxq <- quantiles[[3]] - maxv <- quantiles[[4]] # set limits to raster - vals <- ifelse(vals > minq, vals, minq) - vals <- ifelse(vals < maxq, vals, maxq) + vals <- pmax(vals, minq) + vals <- pmin(vals, maxq) rast <- .raster_set_values(rast, vals) domain <- c(minq, maxq) @@ -842,7 +837,7 @@ ) sits_env[["leaflet_false_color_legend"]] <- TRUE } - return(leaf_map) + leaf_map } #' @title Set the dates for visualisation #' @name .view_set_dates @@ -863,8 +858,7 @@ dates <- timeline[[1]] } # make sure dates are valid - dates <- lubridate::as_date(dates) - return(dates) + lubridate::as_date(dates) } #' @title Select the tiles to be visualised #' @name .view_filter_tiles @@ -882,8 +876,7 @@ # try to find tiles in the list of tiles of the cube .check_that(all(tiles %in% cube[["tile"]])) # filter the tiles to be processed - cube <- .cube_filter_tiles(cube, tiles) - return(cube) + .cube_filter_tiles(cube, tiles) } #' @title Add a legend to the leafmap #' @name .view_add_legend @@ -923,5 +916,5 @@ title = "Classes", opacity = 1 ) - return(leaf_map) + leaf_map } diff --git a/R/sits_accuracy.R b/R/sits_accuracy.R index 9e25332c3..3bfdaab09 100644 --- a/R/sits_accuracy.R +++ b/R/sits_accuracy.R @@ -4,7 +4,8 @@ #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} #' @description This function calculates the accuracy of the classification #' result. The input is either a set of classified time series or a classified -#' data cube. Classified time series are produced by \code{\link[sits]{sits_classify}}. +#' data cube. Classified time series are produced +#' by \code{\link[sits]{sits_classify}}. #' Classified images are generated using \code{\link[sits]{sits_classify}} #' followed by \code{\link[sits]{sits_label_classification}}. #' @@ -139,7 +140,7 @@ sits_accuracy.sits <- function(data, ...) { # Assign class to result class(acc) <- c("sits_accuracy", class(acc)) # return caret confusion matrix - return(acc) + acc } #' @title Accuracy assessment for vector class cubes #' @rdname sits_accuracy @@ -166,7 +167,7 @@ sits_accuracy.class_vector_cube <- function(data, ..., # Assign class to result class(acc) <- c("sits_accuracy", class(acc)) # return caret confusion matrix - return(acc) + acc } #' @title Area-weighted post-classification accuracy for data cubes #' @rdname sits_accuracy @@ -234,12 +235,10 @@ sits_accuracy.class_cube <- function(data, ..., # Does the number of predicted and reference values match? .check_pred_ref_match(reference, predicted) # Create a tibble to store the results - tb <- tibble::tibble( + tibble::tibble( predicted = predicted, reference = reference ) - # Return the list - return(tb) }) # Retrieve predicted and reference vectors for all rows of the cube pred_ref <- do.call(rbind, pred_ref_lst) @@ -276,15 +275,13 @@ sits_accuracy.tbl_df <- function(data, ...) { } else { stop(.conf("messages", "sits_accuracy_tbl_df")) } - acc <- sits_accuracy(data, ...) - return(acc) + sits_accuracy(data, ...) } #' @rdname sits_accuracy #' @export sits_accuracy.default <- function(data, ...) { data <- tibble::as_tibble(data) - acc <- sits_accuracy(data, ...) - return(acc) + sits_accuracy(data, ...) } #' @title Print accuracy summary #' @name sits_accuracy_summary @@ -425,7 +422,7 @@ print.sits_accuracy <- function(x, ..., digits = NULL) { # First class is called the "positive" class by caret c1 <- x[["positive"]] # Second class - c2 <- names_classes[!(names_classes == x[["positive"]])] + c2 <- names_classes[(names_classes != x[["positive"]])] # Values of UA and PA for the two classes pa1 <- paste("Prod Acc ", c1) pa2 <- paste("Prod Acc ", c2) diff --git a/R/sits_apply.R b/R/sits_apply.R index 7e001becb..4126179f1 100644 --- a/R/sits_apply.R +++ b/R/sits_apply.R @@ -28,7 +28,7 @@ #' \enumerate{ #' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from #' a cloud provider.} -#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection #' from a cloud provider to a local directory for faster processing.} #' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube #' from an ARD image collection.} @@ -229,7 +229,7 @@ sits_apply.raster_cube <- function(data, ..., # Process each feature in parallel features_band <- .jobs_map_parallel_dfr(features_cube, function(feature) { # Process the data - output_feature <- .apply_feature( + .apply_feature( feature = feature, block = block, expr = expr, @@ -240,7 +240,6 @@ sits_apply.raster_cube <- function(data, ..., normalized = normalized, output_dir = output_dir ) - return(output_feature) }, progress = progress) # Join output features as a cube and return it .cube_merge_tiles(dplyr::bind_rows(list(features_cube, features_band))) @@ -261,6 +260,5 @@ sits_apply.default <- function(data, ...) { } else { stop(.conf("messages", "sits_apply_default")) } - acc <- sits_apply(data, ...) - return(acc) + sits_apply(data, ...) } diff --git a/R/sits_bands.R b/R/sits_bands.R index bd8d6a986..8581934f6 100644 --- a/R/sits_bands.R +++ b/R/sits_bands.R @@ -46,7 +46,7 @@ sits_bands <- function(x) { #' @rdname sits_bands #' @export sits_bands.sits <- function(x) { - return(setdiff(names(.tibble_time_series(x)), "Index")) + setdiff(names(.tibble_time_series(x)), "Index") } #' @rdname sits_bands #' @export @@ -55,22 +55,21 @@ sits_bands.raster_cube <- function(x) { .check_set_caller("sits_bands") bands_lst <- slider::slide(x, function(tile) { bands_tile <- .tile_bands(tile) - return(sort(bands_tile)) + sort(bands_tile) }) bands <- unique(bands_lst) .check_that(length(bands) == 1) - return(unlist(bands)) + unlist(bands) } #' @rdname sits_bands #' @export sits_bands.patterns <- function(x) { - return(sits_bands.sits(x)) + sits_bands.sits(x) } #' @rdname sits_bands #' @export sits_bands.sits_model <- function(x) { - bands <- .ml_bands(x) - return(bands) + .ml_bands(x) } #' @rdname sits_bands #' @export @@ -83,9 +82,7 @@ sits_bands.default <- function(x) { } else { stop(.conf("messages", "sits_bands_default")) } - - bands <- sits_bands(x) - return(bands) + sits_bands(x) } #' @rdname sits_bands #' @export @@ -102,11 +99,10 @@ sits_bands.default <- function(x) { `sits_bands<-.sits` <- function(x, value) { bands <- .samples_bands(x) .check_that(length(bands) == length(value)) - x <- .apply(x, col = "time_series", fn = function(x) { + .apply(x, col = "time_series", fn = function(x) { names(x) <- c("Index", value, "#..") - return(x) + x }) - return(x) } #' @rdname sits_bands #' @export @@ -114,11 +110,10 @@ sits_bands.default <- function(x) { bands <- .cube_bands(x) # precondition .check_that(length(bands) == length(value)) - x <- slider::slide_dfr(x, function(tile) { + slider::slide_dfr(x, function(tile) { .tile_bands(tile) <- value tile }) - return(x) } #' @rdname sits_bands #' @export diff --git a/R/sits_bayts.R b/R/sits_bayts.R index a7d7e5b50..5d5d96eee 100644 --- a/R/sits_bayts.R +++ b/R/sits_bayts.R @@ -92,10 +92,9 @@ sits_bayts <- function(samples = NULL, detect_change_fun, "bayts_model", "sits_model", class(detect_change_fun) ) - return(predict_fun) + predict_fun } # If samples is informed, train a model and return a predict function # Otherwise give back a train function to train model further - result <- .factory_function(samples, train_fun) - return(result) + .factory_function(samples, train_fun) } diff --git a/R/sits_classify.R b/R/sits_classify.R index 859230125..59546d47e 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -23,8 +23,8 @@ #' a multiband image; each band contains the probability that #' each pixel belongs to a given class. #' Probability cubes are objects of class "probs_cube".} -#' \item{\code{\link[sits]{sits_classify.vector_cube}} is called when the input -#' is a vector data cube. Vector data cubes are produced when +#' \item{\code{\link[sits]{sits_classify.vector_cube}} is called for +#' vector data cubes. Vector data cubes are produced when #' closed regions are obtained from raster data cubes using #' \code{\link[sits]{sits_segment}}. Classification of a vector #' data cube produces a vector data structure with additional @@ -46,7 +46,7 @@ #' \enumerate{ #' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from #' a cloud provider.} -#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection #' from a cloud provider to a local directory for faster processing.} #' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube #' from an ARD image collection.} @@ -73,8 +73,9 @@ #' \item{extreme gradient boosting: \code{\link[sits]{sits_xgboost}};} #' \item{multi-layer perceptrons: \code{\link[sits]{sits_mlp}};} #' \item{temporal CNN: \code{\link[sits]{sits_tempcnn}};} -#' \item{temporal self-attention encoders: \code{\link[sits]{sits_lighttae}} and -#' \code{\link[sits]{sits_tae}}.} +#' \item{temporal self-attention encoders: +#' \code{\link[sits]{sits_lighttae}} and +#' \code{\link[sits]{sits_tae}}.} #' } #' #' Please refer to the sits documentation available in @@ -717,8 +718,7 @@ sits_classify.tbl_df <- function(data, ml_model, ...) { } else { stop(.conf("messages", "sits_classify_tbl_df")) } - result <- sits_classify(data, ml_model, ...) - return(result) + sits_classify(data, ml_model, ...) } #' @rdname sits_classify #' @export diff --git a/R/sits_clean.R b/R/sits_clean.R index 4aea29c5c..e4cac428e 100644 --- a/R/sits_clean.R +++ b/R/sits_clean.R @@ -119,7 +119,7 @@ sits_clean.class_cube <- function(cube, window_size = 5L, memsize = 4L, # Process each tile sequentially clean_cube <- .cube_foreach_tile(cube, function(tile) { # Process the data - clean_tile <- .clean_tile( + .clean_tile( tile = tile, block = image_size, band = band, @@ -128,12 +128,11 @@ sits_clean.class_cube <- function(cube, window_size = 5L, memsize = 4L, output_dir = output_dir, version = version ) - return(clean_tile) }) # Update cube class class(clean_cube) <- c("class_cube", class(clean_cube)) # Return cleaned cube - return(clean_cube) + clean_cube } #' @rdname sits_clean diff --git a/R/sits_cluster.R b/R/sits_cluster.R index e47b20fe2..ac9150dee 100644 --- a/R/sits_cluster.R +++ b/R/sits_cluster.R @@ -143,11 +143,10 @@ sits_cluster_frequency <- function(samples) { # compute frequency table (matrix) result <- table(samples[["label"]], samples[["cluster"]]) # compute total row and col - result <- stats::addmargins(result, + stats::addmargins(result, FUN = list(Total = sum), quiet = TRUE ) - return(result) } #' @title Removes labels that are minority in each cluster. @@ -186,16 +185,14 @@ sits_cluster_clean <- function(samples) { # for each cluster, get the label with the maximum number of samples lbs_max <- lbs[as.vector(apply(result, 2, which.max))] # compute the resulting table - clean_clusters <- purrr::map2_dfr( + purrr::map2_dfr( lbs_max, num_cls, function(lb, cl) { - partial <- dplyr::filter( + dplyr::filter( samples, .data[["label"]] == lb, .data[["cluster"]] == cl ) - return(partial) } ) - return(clean_clusters) } diff --git a/R/sits_colors.R b/R/sits_colors.R index 2c0920498..a28a4158e 100644 --- a/R/sits_colors.R +++ b/R/sits_colors.R @@ -23,7 +23,7 @@ #' sits_colors <- function(legend = NULL) { if (.has_not(legend)) { - print("Returning all available colors") + .conf("messages", "sits_colors_not_legend") return(sits_env[["color_table"]]) } else { if (legend %in% names(sits_env[["legends"]])) { @@ -63,8 +63,6 @@ sits_colors <- function(legend = NULL) { #' sits_colors_show <- function(legend = NULL, font_family = "sans") { - # verifies if sysfonts package is installed - .check_require_packages("sysfonts") # legend must be valid if (.has_not(legend)) legend <- "none" @@ -182,7 +180,6 @@ sits_colors_set <- function(colors, legend = NULL) { #' sits_colors_reset <- function() { .conf_load_color_table() - return(invisible(NULL)) } #' @title Function to save color table as QML style for data cube #' @name sits_colors_qgis @@ -237,5 +234,4 @@ sits_colors_qgis <- function(cube, file) { color_table[["index"]] <- names(labels) # create a QGIS XML file .colors_qml(color_table, file) - return(invisible(NULL)) } diff --git a/R/sits_config.R b/R/sits_config.R index c0b3f1d04..6cffd8a4f 100644 --- a/R/sits_config.R +++ b/R/sits_config.R @@ -77,8 +77,6 @@ sits_config <- function(config_user_file = NULL) { #' sits_config_show() #' @export sits_config_show <- function() { - config <- sits_env[["config"]] - cat("Data sources and user configurable parameters in sits\n\n") cat("Data sources available in sits\n") cat(toString(.sources())) @@ -94,7 +92,6 @@ sits_config_show <- function() { .conf_list_params(config_view) cat("Use sits_config_user_file() to create a user configuration file") - return(invisible(NULL)) } #' @title List the cloud collections supported by sits @@ -129,10 +126,7 @@ sits_list_collections <- function(source = NULL) { ) sources <- source } - purrr::map(sources, function(s) { - .conf_list_source(s) - }) - return(invisible(NULL)) + purrr::map(sources, .conf_list_source()) } #' @title List the cloud collections supported by sits #' @name sits_config_user_file @@ -146,7 +140,7 @@ sits_list_collections <- function(source = NULL) { #' user_file <- paste0(tempdir(), "/my_config_file.yml") #' sits_config_user_file(user_file) #' @export -sits_config_user_file <- function(file_path, overwrite = FALSE){ +sits_config_user_file <- function(file_path, overwrite = FALSE) { # get default user configuration file user_conf_def <- system.file("extdata", "config_user_example.yml", package = "sits") diff --git a/R/sits_csv.R b/R/sits_csv.R index a964716b4..518644513 100644 --- a/R/sits_csv.R +++ b/R/sits_csv.R @@ -55,8 +55,7 @@ sits_to_csv.tbl_df <- function(data, file) { class(data) <- c("sits", class(data)) else stop(.conf("messages", "sits_to_csv_default")) - data <- sits_to_csv(data, file) - return(invisible(data)) + sits_to_csv(data, file) } #' @rdname sits_to_csv #' @export diff --git a/R/sits_cube.R b/R/sits_cube.R index e52e074f4..a45ddd302 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -9,7 +9,7 @@ #' in collections available in cloud services or local repositories. #' Available options are: #' \itemize{ -#' \item{To create data cubes from cloud providers which support the STAC protocol, +#' \item{To create data cubes from providers which support the STAC protocol, #' use \code{\link[sits]{sits_cube.stac_cube}}.} #' \item{To create raster data cubes from local image files, #' use \code{\link[sits]{sits_cube.local_cube}}.} @@ -37,7 +37,7 @@ #' \enumerate{ #' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from #' a cloud provider.} -#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection #' from a cloud provider to a local directory for faster processing.} #' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube #' from an ARD image collection.} @@ -84,7 +84,7 @@ #' \item{All tiles share the same spectral bands and indices.} #' \item{All images have the same spatial resolution.} #' \item{Each location in a tile is associated a set of multi-band time series.} -#' \item{For each tile, interval and band, the cube is associated to a 2D image.} +#' \item{For each tile, interval and band, the cube is reduce to a 2D image.} #' } # #' @examples @@ -405,7 +405,7 @@ sits_cube.stac_cube <- function(source, # collection is upper case collection <- toupper(collection) # pre-condition - check if source and collection exist - .source_collection_check( + .check_source_collection( source = source, collection = collection ) @@ -426,7 +426,7 @@ sits_cube.stac_cube <- function(source, ) } # Pre-condition - checks if the bands are supported by the collection - .conf_check_bands( + .check_bands_collection( source = source, collection = collection, bands = bands @@ -474,8 +474,7 @@ sits_cube.default <- function(source, collection, ...) { #' #' @export sits_mgrs_to_roi <- function(tiles) { - warning(paste("'sits_mgrs_to_roi()' is deprecated.", - "Please, use 'sits_tiles_to_roi()'.")) + .conf("messages", "sits_mgrs_to_roi") sits_tiles_to_roi(tiles = tiles, grid_system = "MGRS") } diff --git a/R/sits_cube_copy.R b/R/sits_cube_copy.R index 5b10681e3..e5b1f1fab 100644 --- a/R/sits_cube_copy.R +++ b/R/sits_cube_copy.R @@ -40,7 +40,7 @@ #' \enumerate{ #' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from #' a cloud provider.} -#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection #' from a cloud provider to a local directory for faster processing.} #' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube #' from an ARD image collection.} diff --git a/R/sits_cube_local.R b/R/sits_cube_local.R index 7e1bc7c35..d314927a2 100644 --- a/R/sits_cube_local.R +++ b/R/sits_cube_local.R @@ -114,7 +114,7 @@ sits_cube.local_cube <- function( bands <- as.character(dots[["band"]]) } .source_check(source = source) - .source_collection_check(source = source, collection = collection) + .check_source_collection(source = source, collection = collection) # builds a sits data cube cube <- .local_raster_cube( @@ -354,12 +354,13 @@ sits_cube.vector_cube <- function( #' \code{\link[sits]{sits_classify}}.} #' \item{\code{"bayes"}, for smoothed cubes produced by #' \code{\link[sits]{sits_smooth}}.} -#' \item{\code{"entropy"} when using \code{\link[sits]{sits_uncertainty}} to measure -#' entropy in pixel classification.} -#' \item{\code{"margin"} when using \code{\link[sits]{sits_uncertainty}} to measure -#' probability margin in pixel classification.} -#' \item{\code{"least"} when using \code{\link[sits]{sits_uncertainty}} to measure -#' difference between 100\% and most probable class in pixel classification.} +#' \item{\code{"entropy"} when using \code{\link[sits]{sits_uncertainty}} to +#' measure entropy in pixel classification.} +#' \item{\code{"margin"} when using \code{\link[sits]{sits_uncertainty}} to +#' measure probability margin in pixel classification.} +#' \item{\code{"least"} when using \code{\link[sits]{sits_uncertainty}} to +#' measure difference between 100\% and +#' most probable class in pixel classification.} #' \item{\code{"class"} for cubes produced by #' \code{\link[sits]{sits_label_classification}}.} #' } @@ -511,7 +512,7 @@ sits_cube.results_cube <- function( .check_labels_named(labels) # builds a sits data cube - cube <- .local_results_cube( + .local_results_cube( source = source, collection = collection, data_dir = data_dir, diff --git a/R/sits_detect_change.R b/R/sits_detect_change.R index 9f52a3414..1fad9d7a6 100644 --- a/R/sits_detect_change.R +++ b/R/sits_detect_change.R @@ -151,10 +151,11 @@ sits_detect_change.raster_cube <- function(data, on.exit(.parallel_stop(), add = TRUE) # Show block information start_time <- .classify_verbose_start(verbose, block) + on.exit(.classify_verbose_end(verbose, start_time)) # Process each tile sequentially - detections_cube <- .cube_foreach_tile(data, function(tile) { + .cube_foreach_tile(data, function(tile) { # Detect changes - detections_tile <- .detect_change_tile( + .detect_change_tile( tile = tile, band = "detection", dc_method = dc_method, @@ -167,11 +168,7 @@ sits_detect_change.raster_cube <- function(data, verbose = verbose, progress = progress ) - return(detections_tile) }) - # Show block information - .classify_verbose_end(verbose, start_time) - return(detections_cube) } #' @rdname sits_detect_change diff --git a/R/sits_dtw.R b/R/sits_dtw.R index 6d3bfb722..30c277a96 100644 --- a/R/sits_dtw.R +++ b/R/sits_dtw.R @@ -39,16 +39,12 @@ sits_dtw <- function(samples = NULL, .check_null_parameter(threshold) .check_date_parameter(start_date, allow_null = TRUE) .check_date_parameter(end_date, allow_null = TRUE) - # Sample labels - labels <- .samples_labels(samples) - # Generate predictors - train_samples <- .predictors(samples) # Generate patterns (if not defined by the user) if (!.has(patterns)) { # Save samples used to generate temporal patterns patterns_samples <- samples # Filter samples if required - if (!is.null(start_date) & !is.null(end_date)) { + if (!is.null(start_date) && !is.null(end_date)) { patterns_samples <- .samples_filter_interval( samples = patterns_samples, start_date = start_date, @@ -68,8 +64,6 @@ sits_dtw <- function(samples = NULL, options <- list(...) # Extract tile tile <- options[["tile"]] - # Get mask of NA pixels - na_mask <- C_mask_na(values) # Fill with zeros remaining NA pixels values[is.na(values)] <- NA # Define the type of the operation @@ -106,10 +100,9 @@ sits_dtw <- function(samples = NULL, "dtw_model", "sits_model", class(detect_change_fun)) - return(detect_change_fun) + detect_change_fun } # If samples is informed, train a model and return a predict function # Otherwise give back a train function to train model further - result <- .factory_function(samples, train_fun) - return(result) + .factory_function(samples, train_fun) } diff --git a/R/sits_factory.R b/R/sits_factory.R index 6d77d40c3..357ab14f3 100644 --- a/R/sits_factory.R +++ b/R/sits_factory.R @@ -77,10 +77,9 @@ sits_factory_function <- function(data, fun) { # if no data is given, we prepare a # function to be called as a parameter of other functions if (.has_not(data)) { - result <- fun + fun } else { # ...otherwise compute the result on the input data - result <- fun(data) + fun(data) } - return(result) } diff --git a/R/sits_filters.R b/R/sits_filters.R index 807ff3e84..c79378517 100644 --- a/R/sits_filters.R +++ b/R/sits_filters.R @@ -68,9 +68,9 @@ sits_filter <- function(data, filter = sits_whittaker()) { sits_whittaker <- function(data = NULL, lambda = 0.5) { filter_fun <- function(data) { if (inherits(data, "matrix")) { - return(smooth_whit_mtx(data, lambda = lambda, length = ncol(data))) + smooth_whit_mtx(data, lambda = lambda, length = ncol(data)) } else { - return(smooth_whit(data, lambda = lambda, length = length(data))) + smooth_whit(data, lambda = lambda, length = length(data)) } } filter_call <- function(data) { @@ -129,19 +129,19 @@ sits_sgolay <- function(data = NULL, order = 3, length = 5) { filter_fun <- function(data) { # calculate coefficients for sgolay if (inherits(data, "matrix")) { - return(smooth_sg_mtx( + smooth_sg_mtx( data, f_res = f_res, p = order, n = length - )) + ) } else { - return(smooth_sg( + smooth_sg( data, f_res = f_res, p = order, n = length - )) + ) } } filter_call <- function(data) { @@ -151,6 +151,5 @@ sits_sgolay <- function(data = NULL, order = 3, length = 5) { filter_fun(data) } } - result <- .factory_function(data, filter_call) - return(result) + .factory_function(data, filter_call) } diff --git a/R/sits_geo_dist.R b/R/sits_geo_dist.R index 5ba19143a..8f39939e0 100644 --- a/R/sits_geo_dist.R +++ b/R/sits_geo_dist.R @@ -65,7 +65,7 @@ sits_geo_dist <- function(samples, roi, n = 1000, crs = "EPSG:4326") { data <- .samples_convert_to_sits(data) if (.has(roi)) roi <- .roi_as_sf(roi = roi, as_crs = "EPSG:4326") - samples <- samples[sample(seq_len(nrow(samples)), min(n, nrow(samples))), ] + samples <- samples[sample.int(nrow(samples), min(n, nrow(samples))), ] # Convert training samples to points samples_sf <- .point_as_sf( .point(x = samples, crs = crs), diff --git a/R/sits_get_class.R b/R/sits_get_class.R index b1f1238cd..144a152cf 100644 --- a/R/sits_get_class.R +++ b/R/sits_get_class.R @@ -59,7 +59,7 @@ #' } #' #' @export -sits_get_class <- function(cube, samples){ +sits_get_class <- function(cube, samples) { .check_set_caller("sits_get_data") # Pre-conditions .check_is_class_cube(cube) @@ -72,78 +72,73 @@ sits_get_class <- function(cube, samples){ #' @rdname sits_get_class #' #' @export -sits_get_class.default <- function(cube, samples){ +sits_get_class.default <- function(cube, samples) { stop(.conf("messages", "sits_get_class_default")) } #' @rdname sits_get_class #' #' @export -sits_get_class.csv <- function(cube, samples){ +sits_get_class.csv <- function(cube, samples) { # Extract a data frame from csv samples <- .csv_get_lat_lon(samples) - data <- .data_get_class( + .data_get_class( cube = cube, samples = samples ) - return(data) } #' @rdname sits_get_class #' @export -sits_get_class.shp <- function(cube, samples){ +sits_get_class.shp <- function(cube, samples) { .check_set_caller("sits_get_class") # transform from shapefile to sf sf_shape <- .shp_transform_to_sf(shp_file = samples) # Get the geometry type geom_type <- as.character(sf::st_geometry_type(sf_shape)[[1]]) - if (!geom_type == "POINT") + if (geom_type != "POINT") stop(.conf("messages", "sits_get_class_not_point")) # Get a tibble with points samples <- .sf_point_to_latlong(sf_object = sf_shape) # get the data - data <- .data_get_class( + .data_get_class( cube = cube, samples = samples ) - return(data) } #' @rdname sits_get_class #' @export -sits_get_class.sf <- function(cube, samples){ +sits_get_class.sf <- function(cube, samples) { .check_set_caller("sits_get_class") # Get the geometry type geom_type <- as.character(sf::st_geometry_type(samples)[[1]]) - if (!geom_type == "POINT") + if (geom_type != "POINT") stop(.conf("messages", "sits_get_class_not_point")) # Get a tibble with points samples <- .sf_point_to_latlong(sf_object = samples) # get the data - data <- .data_get_class( + .data_get_class( cube = cube, samples = samples ) - return(data) } #' @rdname sits_get_class #' @export -sits_get_class.sits <- function(cube, samples){ +sits_get_class.sits <- function(cube, samples) { .check_set_caller("sits_get_class") # get the data - data <- .data_get_class( + .data_get_class( cube = cube, samples = samples ) - return(data) } #' @rdname sits_get_class #' @export -sits_get_class.data.frame <- function(cube, samples){ +sits_get_class.data.frame <- function(cube, samples) { .check_set_caller("sits_get_class") # get the data - data <- .data_get_class( + .data_get_class( cube = cube, samples = samples ) - return(data) } diff --git a/R/sits_get_data.R b/R/sits_get_data.R index 0e2c03369..d72091ea8 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -25,7 +25,7 @@ #' \enumerate{ #' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from #' a cloud provider.} -#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection #' from a cloud provider to a local directory for faster processing.} #' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube #' from an ARD image collection.} diff --git a/R/sits_get_probs.R b/R/sits_get_probs.R index ee6f0bf00..af642ad38 100644 --- a/R/sits_get_probs.R +++ b/R/sits_get_probs.R @@ -56,7 +56,7 @@ #' } #' #' @export -sits_get_probs <- function(cube, samples, window_size = NULL){ +sits_get_probs <- function(cube, samples, window_size = NULL) { .check_set_caller("sits_get_probs") # Pre-conditions .check_is_probs_cube(cube) @@ -69,7 +69,7 @@ sits_get_probs <- function(cube, samples, window_size = NULL){ #' @rdname sits_get_probs #' #' @export -sits_get_probs.csv <- function(cube, samples, window_size = NULL){ +sits_get_probs.csv <- function(cube, samples, window_size = NULL) { # Extract a data frame from csv samples <- .csv_get_lat_lon(samples) # get the data @@ -82,13 +82,13 @@ sits_get_probs.csv <- function(cube, samples, window_size = NULL){ } #' @rdname sits_get_probs #' @export -sits_get_probs.shp <- function(cube, samples, window_size = NULL){ +sits_get_probs.shp <- function(cube, samples, window_size = NULL) { .check_set_caller("sits_get_probs") # transform from shapefile to sf sf_shape <- .shp_transform_to_sf(shp_file = samples) # Get the geometry type geom_type <- as.character(sf::st_geometry_type(sf_shape)[[1]]) - if (!geom_type == "POINT") + if (geom_type != "POINT") stop(.conf("messages", "sits_get_probs_not_point")) # Get a tibble with points @@ -103,11 +103,11 @@ sits_get_probs.shp <- function(cube, samples, window_size = NULL){ } #' @rdname sits_get_probs #' @export -sits_get_probs.sf <- function(cube, samples, window_size = NULL){ +sits_get_probs.sf <- function(cube, samples, window_size = NULL) { .check_set_caller("sits_get_probs") # Get the geometry type geom_type <- as.character(sf::st_geometry_type(samples)[[1]]) - if (!geom_type == "POINT") + if (geom_type != "POINT") stop(.conf("messages", "sits_get_probs_not_point")) # Get a tibble with points @@ -122,7 +122,7 @@ sits_get_probs.sf <- function(cube, samples, window_size = NULL){ } #' @rdname sits_get_probs #' @export -sits_get_probs.sits <- function(cube, samples, window_size = NULL){ +sits_get_probs.sits <- function(cube, samples, window_size = NULL) { .check_set_caller("sits_get_probs") # get the data data <- .data_get_probs( @@ -134,7 +134,7 @@ sits_get_probs.sits <- function(cube, samples, window_size = NULL){ } #' @rdname sits_get_probs #' @export -sits_get_probs.data.frame <- function(cube, samples, window_size = NULL){ +sits_get_probs.data.frame <- function(cube, samples, window_size = NULL) { .check_set_caller("sits_get_probs") # get the data data <- .data_get_probs( @@ -147,6 +147,6 @@ sits_get_probs.data.frame <- function(cube, samples, window_size = NULL){ #' @rdname sits_get_probs #' #' @export -sits_get_probs.default <- function(cube, samples, window_size = NULL){ +sits_get_probs.default <- function(cube, samples, window_size = NULL) { stop(.conf("messages", "sits_get_probs")) } diff --git a/R/sits_histogram.R b/R/sits_histogram.R index 3b84659d0..8bd3e7802 100644 --- a/R/sits_histogram.R +++ b/R/sits_histogram.R @@ -18,7 +18,7 @@ #' @export hist.sits <- function(x, ...) { # get frequency table - print("histogram of time series not available") + .conf("messages", "sits_hist_sits") } #' @title histogram of data cubes #' @method hist raster_cube @@ -114,7 +114,7 @@ hist.raster_cube <- function(x, ..., ggplot2::xlab("Ground reflectance") + ggplot2::ylab("") + ggplot2::ggtitle(paste("Distribution of Values for band", - band,"date", date)) + band, "date", date)) return(suppressWarnings(density_plot)) } @@ -200,7 +200,6 @@ hist.probs_cube <- function(x, ..., values <- values * band_scale + band_offset colnames(values) <- label color_sits <- .colors_get(label) - # values[["color"]] <- colors_sits[values[["name"]]] density_plot <- values |> ggplot2::ggplot(ggplot2::aes(x = .data[[label]])) + @@ -306,4 +305,3 @@ hist.uncertainty_cube <- function( return(suppressWarnings(density_plot)) } - diff --git a/R/sits_imputation.R b/R/sits_imputation.R index d9a7beb5d..6f3a5722a 100644 --- a/R/sits_imputation.R +++ b/R/sits_imputation.R @@ -11,15 +11,12 @@ impute_linear <- function(data = NULL) { impute_fun <- function(data) { if (inherits(data, "matrix")) { - return(linear_interp(data)) + linear_interp(data) } else { - return(linear_interp_vec(data)) + linear_interp_vec(data) } } - - result <- .factory_function(data, impute_fun) - - return(result) + .factory_function(data, impute_fun) } #' @title Replace NA values in time series with imputation function @@ -49,6 +46,6 @@ sits_impute <- function(samples, impute_fn = impute_linear()) { ) }) ) - return(row) + row }) } diff --git a/R/sits_label_classification.R b/R/sits_label_classification.R index 97b0c58a6..8ce61c6dd 100644 --- a/R/sits_label_classification.R +++ b/R/sits_label_classification.R @@ -27,7 +27,7 @@ #' \enumerate{ #' \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from #' a cloud provider.} -#' \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection +#' \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection #' from a cloud provider to a local directory for faster processing.} #' \item{\code{\link[sits]{sits_regularize}}: create a regular data cube #' from an ARD image collection.} @@ -136,7 +136,7 @@ sits_label_classification.probs_cube <- function(cube, ..., # Process each tile sequentially .cube_foreach_tile(cube, function(tile) { # Label the data - class_tile <- .label_tile( + .label_tile( tile = tile, band = "class", label_fn = label_fn, @@ -161,7 +161,7 @@ sits_label_classification.probs_vector_cube <- function(cube, ..., # Process each tile sequentially .cube_foreach_tile(cube, function(tile) { # Label the segments - class_tile <- .label_vector_tile( + .label_vector_tile( tile = tile, band = "class", version = version, @@ -190,6 +190,5 @@ sits_label_classification.default <- function(cube, ...) { cube <- .cube_find_class(cube) else stop(.conf("messages", "sits_label_classification")) - class_cube <- sits_label_classification(cube, ...) - return(class_cube) + sits_label_classification(cube, ...) } diff --git a/R/sits_labels.R b/R/sits_labels.R index 7cfdc73fc..c543640d1 100644 --- a/R/sits_labels.R +++ b/R/sits_labels.R @@ -43,19 +43,19 @@ sits_labels <- function(data) { #' sits_labels.sits <- function(data) { # pre-condition - return(sort(unique(data[["label"]]))) + sort(unique(data[["label"]])) } #' @rdname sits_labels #' @export #' sits_labels.derived_cube <- function(data) { - return(data[["labels"]][[1]]) + data[["labels"]][[1]] } #' @rdname sits_labels #' @export #' sits_labels.derived_vector_cube <- function(data) { - return(data[["labels"]][[1]]) + data[["labels"]][[1]] } #' @rdname sits_labels #' @export @@ -67,15 +67,15 @@ sits_labels.raster_cube <- function(data) { #' @export #' sits_labels.patterns <- function(data) { - return(data[["label"]]) + data[["label"]] } #' @rdname sits_labels #' @export sits_labels.sits_model <- function(data) { .check_is_sits_model(data) # Get labels from ml_model - labels <- .ml_labels(data) - return(labels) + .ml_labels(data) + } #' @rdname sits_labels #' @export @@ -88,8 +88,7 @@ sits_labels.default <- function(data) { } else { stop(.conf("messages", "sits_labels_raster_cube")) } - data <- sits_labels(data) - return(data) + sits_labels(data) } #' @title Change the labels of a set of time series #' @name `sits_labels<-` @@ -137,7 +136,7 @@ sits_labels.default <- function(data) { .check_that(any(trimws(value) != "")) names(value) <- labels data[["label"]] <- value[data[["label"]]] - return(data) + data } #' @name `sits_labels<-` #' @return A probs or class_cube cube with modified labels. @@ -151,7 +150,7 @@ sits_labels.default <- function(data) { len_max = length(.cube_labels(data)) ) data[["labels"]] <- list(value) - return(data) + data } #' @name `sits_labels<-` #' @export @@ -167,11 +166,10 @@ sits_labels.default <- function(data) { if (.has_not(names(value))) { names(value) <- names(labels_data) } - rows <- slider::slide_dfr(data, function(row) { + slider::slide_dfr(data, function(row) { row[["labels"]] <- list(value) - return(row) + row }) - return(rows) } #' @name `sits_labels<-` #' @export @@ -184,7 +182,7 @@ sits_labels.default <- function(data) { else stop(.conf("messages", "sits_labels_raster_cube")) sits_labels(data) <- value - return(data) + data } #' @title Inform label distribution of a set of time series #' @name sits_labels_summary @@ -216,10 +214,9 @@ sits_labels_summary.sits <- function(data) { data_labels <- table(data[["label"]]) # compose tibble containing labels, count and relative frequency columns - result <- tibble::as_tibble(list( + tibble::as_tibble(list( label = names(data_labels), count = as.integer(data_labels), prop = as.numeric(prop.table(data_labels)) )) - return(result) } diff --git a/R/sits_lighttae.R b/R/sits_lighttae.R index c1fff5b74..ab306328f 100644 --- a/R/sits_lighttae.R +++ b/R/sits_lighttae.R @@ -238,14 +238,14 @@ sits_lighttae <- function(samples = NULL, ) }, forward = function(input) { - out <- self$spatial_encoder(input) - out <- self$temporal_encoder(out) - out <- self$decoder(out) - # out <- self$softmax(out) - return(out) + out <- input |> + self$spatial_encoder() |> + self$temporal_encoder() |> + self$decoder() + # softmax is done externally } ) - # torch 12.0 not working with Apple MPS + # torch 12.0 with luz not working with Apple MPS cpu_train <- .torch_cpu_train() # Train the model using luz torch_model <- @@ -302,8 +302,6 @@ sits_lighttae <- function(samples = NULL, suppressWarnings(torch::torch_set_num_threads(1)) # Unserialize model torch_model[["model"]] <- .torch_unserialize_model(serialized_model) - # Used to check values (below) - input_pixels <- nrow(values) # Transform input into a 3D tensor # Reshape the 2D matrix into a 3D array n_samples <- nrow(values) @@ -335,16 +333,15 @@ sits_lighttae <- function(samples = NULL, values <- torch::as_array(values) # Update the columns names to labels colnames(values) <- labels - return(values) + values } # Set model class predict_fun <- .set_class( predict_fun, "torch_model", "sits_model", class(predict_fun) ) - return(predict_fun) + predict_fun } # If samples is informed, train a model and return a predict function # Otherwise give back a train function to train model further - result <- .factory_function(samples, train_fun) - return(result) + .factory_function(samples, train_fun) } diff --git a/R/sits_machine_learning.R b/R/sits_machine_learning.R index 0244004c5..c07d8528e 100644 --- a/R/sits_machine_learning.R +++ b/R/sits_machine_learning.R @@ -90,18 +90,17 @@ sits_rfor <- function(samples = NULL, num_trees = 100, mtry = NULL, ...) { if (any(labels != colnames(values))) { values <- values[, labels] } - return(values) + values } # Set model class predict_fun <- .set_class( predict_fun, "rfor_model", "sits_model", class(predict_fun) ) - return(predict_fun) + predict_fun } # If samples is informed, train a model and return a predict function # Otherwise give back a train function to train model further - result <- .factory_function(samples, train_fun) - return(result) + .factory_function(samples, train_fun) } #' @title Train support vector machine models #' @name sits_svm @@ -211,18 +210,17 @@ sits_svm <- function(samples = NULL, formula = sits_formula_linear(), if (any(labels != colnames(values))) { values <- values[, labels] } - return(values) + values } # Set model class predict_fun <- .set_class( predict_fun, "svm_model", "sits_model", class(predict_fun) ) - return(predict_fun) + predict_fun } # If samples is informed, train a model and return a predict function # Otherwise give back a train function to train model further - result <- .factory_function(samples, train_fun) - return(result) + .factory_function(samples, train_fun) } #' @title Train extreme gradient boosting models #' @name sits_xgboost @@ -349,18 +347,17 @@ sits_xgboost <- function(samples = NULL, learning_rate = 0.15, .check_processed_values(values, input_pixels) # Update the columns names to labels colnames(values) <- labels - return(values) + values } # Set model class predict_fun <- .set_class( predict_fun, "xgb_model", "sits_model", class(predict_fun) ) - return(predict_fun) + predict_fun } # If samples is informed, train a model and return a predict function # Otherwise give back a train function to train model further - result <- .factory_function(samples, train_fun) - return(result) + .factory_function(samples, train_fun) } #' @title Define a loglinear formula for classification models @@ -420,15 +417,14 @@ sits_formula_logref <- function(predictors_index = -2:0) { categories <- names(tb)[c(predictors_index)] # compute formula result - result_for <- stats::as.formula(paste0( + stats::as.formula(paste0( "factor(label)~", paste0(paste0("log(`", categories, "`)"), collapse = "+" ) )) - return(result_for) } - return(result_fun) + result_fun } #' @title Define a linear formula for classification models @@ -485,13 +481,12 @@ sits_formula_linear <- function(predictors_index = -2:0) { categories <- names(tb)[c(predictors_index)] # compute formula result - result_for <- stats::as.formula(paste0( + stats::as.formula(paste0( "factor(label)~", paste0(paste0(categories, collapse = "+" )) )) - return(result_for) } - return(result_fun) + result_fun } diff --git a/R/sits_merge.R b/R/sits_merge.R index 91ca1ec08..a71d1e34c 100644 --- a/R/sits_merge.R +++ b/R/sits_merge.R @@ -94,11 +94,10 @@ sits_merge.sits <- function(data1, data2, ..., suffix = c(".1", ".2")) { data1[["time_series"]], data2[["time_series"]], function(ts1, ts2) { - ts3 <- dplyr::bind_cols(ts1, dplyr::select(ts2, -"Index")) - return(ts3) + dplyr::bind_cols(ts1, dplyr::select(ts2, -"Index")) } ) - return(result) + result } #' @rdname sits_merge diff --git a/R/sits_mixture_model.R b/R/sits_mixture_model.R index aa006e554..927309371 100644 --- a/R/sits_mixture_model.R +++ b/R/sits_mixture_model.R @@ -148,16 +148,15 @@ sits_mixture_model.sits <- function(data, endmembers, ..., # Process each group of samples in parallel samples_fracs <- .parallel_map(samples_groups, function(samples) { # Process the data - output_samples <- .mixture_samples( + .mixture_samples( samples = samples, em = em, mixture_fn = mixture_fn, out_fracs = out_fracs ) - return(output_samples) }, progress = progress) # Join groups samples as a sits tibble and return it ts <- .samples_merge_groups(samples_fracs) class(ts) <- c("sits", class(ts)) - return(ts) + ts } #' @rdname sits_mixture_model @@ -228,7 +227,7 @@ sits_mixture_model.raster_cube <- function(data, endmembers, ..., # Process each feature in parallel features_fracs <- .jobs_map_parallel_dfr(features_cube, function(feature) { # Process the data - output_feature <- .mixture_feature( + .mixture_feature( feature = feature, block = block, em = em, @@ -236,7 +235,6 @@ sits_mixture_model.raster_cube <- function(data, endmembers, ..., out_fracs = out_fracs, output_dir = output_dir ) - return(output_feature) }, progress = progress) # Join output features as a cube and return it cube <- .cube_merge_tiles(dplyr::bind_rows(list(features_cube, @@ -244,7 +242,7 @@ sits_mixture_model.raster_cube <- function(data, endmembers, ..., ) # Join groups samples as a sits tibble and return it class(cube) <- c("raster_cube", class(cube)) - return(cube) + cube } #' @rdname sits_mixture_model #' @export @@ -261,13 +259,11 @@ sits_mixture_model.tbl_df <- function(data, endmembers, ...) { class(data) <- c("sits", class(data)) else stop(.conf("messages", "sits_mixture_model_derived_cube")) - data <- sits_mixture_model(data, endmembers, ...) - return(data) + sits_mixture_model(data, endmembers, ...) } #' @rdname sits_mixture_model #' @export sits_mixture_model.default <- function(data, endmembers, ...) { data <- tibble::as_tibble(data) - data <- sits_mixture_model(data, endmembers, ...) - return(data) + sits_mixture_model(data, endmembers, ...) } diff --git a/R/sits_mlp.R b/R/sits_mlp.R index 89718cee4..86e7f6966 100644 --- a/R/sits_mlp.R +++ b/R/sits_mlp.R @@ -252,8 +252,6 @@ sits_mlp <- function(samples = NULL, suppressWarnings(torch::torch_set_num_threads(1)) # Unserialize model torch_model[["model"]] <- .torch_unserialize_model(serialized_model) - # Used to check values (below) - input_pixels <- nrow(values) # Performs data normalization values <- .pred_normalize(pred = values, stats = ml_stats) # Transform input into matrix @@ -279,16 +277,15 @@ sits_mlp <- function(samples = NULL, values <- torch::as_array(values) # Update the columns names to labels colnames(values) <- labels - return(values) + values } # Set model class predict_fun <- .set_class( predict_fun, "torch_model", "sits_model", class(predict_fun) ) - return(predict_fun) + predict_fun } # If samples is informed, train a model and return a predict function # Otherwise give back a train function to train model further - result <- .factory_function(samples, train_fun) - return(result) + .factory_function(samples, train_fun) } diff --git a/R/sits_model_export.R b/R/sits_model_export.R index 193a3c555..c0ec29840 100644 --- a/R/sits_model_export.R +++ b/R/sits_model_export.R @@ -29,7 +29,6 @@ sits_model_export <- function(ml_model) { #' @export sits_model_export.sits_model <- function(ml_model) { .check_is_sits_model(ml_model) - # Extract the result of the R RandomForest package - model <- .ml_model(ml_model) - return(model) + # Extract the model + .ml_model(ml_model) } diff --git a/R/sits_patterns.R b/R/sits_patterns.R index fabd4ce6f..4e16b8f3f 100644 --- a/R/sits_patterns.R +++ b/R/sits_patterns.R @@ -107,7 +107,7 @@ sits_patterns <- function(data = NULL, freq = 8, formula = y ~ s(x), ...) { # rename the column to match the band names names(patt_b)[names(patt_b) == "b"] <- bd # return the tibble column to the list - return(patt_b) + patt_b }) # for each band # join the estimates for each bands res_label <- dplyr::bind_cols(fit_bands) @@ -117,7 +117,7 @@ sits_patterns <- function(data = NULL, freq = 8, formula = y ~ s(x), ...) { ts <- tibble::lst() ts[[1]] <- res_label # add the pattern to the results tibble - row <- tibble::tibble( + tibble::tibble( longitude = 0.0, latitude = 0.0, start_date = as.Date(start_date), @@ -126,11 +126,9 @@ sits_patterns <- function(data = NULL, freq = 8, formula = y ~ s(x), ...) { cube = "patterns", time_series = ts ) - return(row) }) class(patterns) <- c("patterns", "sits", class(patterns)) - return(patterns) + patterns } - result <- .factory_function(data, result_fun) - return(result) + .factory_function(data, result_fun) } diff --git a/R/sits_reduce.R b/R/sits_reduce.R index c0c163312..78a18d2c6 100644 --- a/R/sits_reduce.R +++ b/R/sits_reduce.R @@ -189,9 +189,9 @@ sits_reduce.raster_cube <- function(data, ..., # Reducing # Process each tile sequentially - reduce_cube <- .cube_foreach_tile(data, function(tile) { + .cube_foreach_tile(data, function(tile) { # Reduce the data - probs_tile <- .reduce_tile( + .reduce_tile( tile = tile, block = block, expr = expr, @@ -201,8 +201,5 @@ sits_reduce.raster_cube <- function(data, ..., output_dir = output_dir, progress = progress ) - return(probs_tile) }) - # Return the reduced cube - return(reduce_cube) } diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R index efa425c27..7c07ae2e2 100644 --- a/R/sits_sample_functions.R +++ b/R/sits_sample_functions.R @@ -38,15 +38,13 @@ sits_sample <- function(data, # group the data by label groups <- by(data, data[["label"]], list) # for each group of samples, obtain the required subset - result <- .map_dfr(groups, function(class_samples) { - result_class <- dplyr::slice_sample( + .map_dfr(groups, function(class_samples) { + dplyr::slice_sample( class_samples, prop = frac, replace = oversample ) - return(result_class) }) - return(result) } #' @title Suggest high confidence samples to increase the training set. #' @@ -366,11 +364,11 @@ sits_sampling_design <- function(cube, choice_prop <- p / (1.0 - sum(rare_classes)) choice <- round(choice_prop * remaining_samples) } - return(choice) + choice }) alloc_class <- cbind(alloc_class_lst) colnames(alloc_class) <- paste0("alloc_", al) - return(alloc_class) + alloc_class }) # get the three allocation options alloc_options <- do.call(cbind, alloc_options_lst) diff --git a/R/sits_segmentation.R b/R/sits_segmentation.R index b5cd35d32..0eb04e465 100644 --- a/R/sits_segmentation.R +++ b/R/sits_segmentation.R @@ -180,9 +180,9 @@ sits_segment <- function(cube, on.exit(.parallel_stop(), add = TRUE) # Segmentation # Process each tile sequentially - segs_cube <- .cube_foreach_tile(cube, function(tile) { + .cube_foreach_tile(cube, function(tile) { # Segment the data - segs_tile <- .segments_tile( + .segments_tile( tile = tile, seg_fn = seg_fn, band = "segments", @@ -193,9 +193,7 @@ sits_segment <- function(cube, version = version, progress = progress ) - return(segs_tile) }) - return(segs_cube) } #' @title Segment an image using SLIC @@ -352,9 +350,7 @@ sits_slic <- function(data = NULL, yres <- v_obj[["y"]] * .raster_yres(v_temp) - .raster_yres(v_temp) / 2 v_obj[["x"]] <- as.vector(v_ext)[[1]] + xres v_obj[["y"]] <- as.vector(v_ext)[[4]] - yres - # Get only polygons segments - v_obj <- suppressWarnings(sf::st_collection_extract(v_obj, "POLYGON")) - # Return the segment object - return(v_obj) + # Get only polygons segments and return them + suppressWarnings(sf::st_collection_extract(v_obj, "POLYGON")) } } diff --git a/R/sits_som.R b/R/sits_som.R index f1c6a8ba8..b917c6ef9 100644 --- a/R/sits_som.R +++ b/R/sits_som.R @@ -193,7 +193,7 @@ sits_som_map <- function(data, } else { label_max_final <- which.max(labels_neuron[["prior_prob"]]) } - return(labels_neuron[label_max_final, ][["label_samples"]]) + labels_neuron[label_max_final, ][["label_samples"]] }) labels_max <- unlist(lab_max) # prepare a color assignment to the SOM map @@ -389,18 +389,16 @@ sits_som_evaluate_cluster <- function(som_map) { mixture_percentage = mixture_percentage ) # remove lines where mix_percentege is zero - current_class_ambiguity <- dplyr::filter( - current_class_ambiguity, + dplyr::filter(current_class_ambiguity, .data[["mixture_percentage"]] > 0 ) - return(current_class_ambiguity) }) purity_by_cluster <- do.call(rbind, cluster_purity_lst) class(purity_by_cluster) <- c( "som_evaluate_cluster", class(purity_by_cluster) ) - return(purity_by_cluster) + purity_by_cluster } #' @title Evaluate cluster #' @name sits_som_remove_samples @@ -428,7 +426,7 @@ sits_som_evaluate_cluster <- function(som_map) { sits_som_remove_samples <- function(som_map, som_eval, class_cluster, - class_remove){ + class_remove) { # get the samples with id_neuron data <- som_map$data @@ -436,18 +434,15 @@ sits_som_remove_samples <- function(som_map, neurons <- som_map$labelled_neurons neurons_class_1 <- dplyr::filter(neurons, - .data[["label_samples"]] == class_cluster & - .data[["prior_prob"]] > 0.50) + .data[["label_samples"]] == class_cluster, + .data[["prior_prob"]] > 0.50) id_neurons_class_1 <- neurons_class_1[["id_neuron"]] # find samples of class2 in neurons of class1 samples_remove <- dplyr::filter(data, - .data[["label"]] == class_remove & + .data[["label"]] == class_remove, .data[["id_neuron"]] %in% id_neurons_class_1) # get the id of the samples to be removed id_samples_remove <- samples_remove[["id_sample"]] # obtain the new samples - new_samples <- dplyr::filter(data, - !(.data[["id_sample"]] %in% id_samples_remove)) - # return the new samples - return(new_samples) + dplyr::filter(data, !(.data[["id_sample"]] %in% id_samples_remove)) } diff --git a/R/sits_summary.R b/R/sits_summary.R index 1857c8e27..ca438908f 100644 --- a/R/sits_summary.R +++ b/R/sits_summary.R @@ -22,12 +22,11 @@ summary.sits <- function(object, ...) { data_labels <- table(object[["label"]]) # compose tibble containing labels, count and relative frequency columns - result <- tibble::as_tibble(list( + tibble::as_tibble(list( label = names(data_labels), count = as.integer(data_labels), prop = as.numeric(prop.table(data_labels)) )) - return(result) } #' @title Summarize accuracy matrix for training data @@ -176,7 +175,7 @@ summary.raster_cube <- function(object, ..., tile = NULL, date = NULL) { } # Display raster summary cli::cli_h1("Cube Summary") - tile_sum <- slider::slide(object, function(tile) { + cube_sum <- slider::slide(object, function(tile) { # Get the first date to not read all images date <- .default(date, .tile_timeline(tile)[[1]]) tile <- .tile_filter_dates(tile, date) @@ -189,8 +188,8 @@ summary.raster_cube <- function(object, ..., tile = NULL, date = NULL) { rast_sum }) # Return the summary from the cube - names(sum) <- .cube_tiles(object) - return(invisible(sum)) + names(cube_sum) <- .cube_tiles(object) + cube_sum } #' @title Summary of a derived cube #' @author Felipe Souza, \email{felipe.souza@@inpe.br} @@ -369,8 +368,6 @@ summary.class_cube <- function(object, ...) { .check_set_caller("summary_class_cube") # Extract classes values for each tiles using a sample size classes_areas <- slider::slide(object, function(tile) { - # get the bands - band <- .tile_bands(tile) # extract the file path tile_file <- .tile_paths(tile) # read the files with terra diff --git a/R/sits_tae.R b/R/sits_tae.R index bbae53892..d3d05cdb2 100644 --- a/R/sits_tae.R +++ b/R/sits_tae.R @@ -218,7 +218,6 @@ sits_tae <- function(samples = NULL, self$temporal_attention_encoder() |> self$decoder() # softmax is done after classification - removed from here - return(x) } ) # torch 12.0 not working with Apple MPS @@ -303,7 +302,7 @@ sits_tae <- function(samples = NULL, values <- torch::as_array(values) # Update the columns names to labels colnames(values) <- labels - return(values) + values } # Set model class predict_fun <- .set_class( diff --git a/R/sits_tempcnn.R b/R/sits_tempcnn.R index 0ad658e76..d84adb41f 100644 --- a/R/sits_tempcnn.R +++ b/R/sits_tempcnn.R @@ -350,7 +350,7 @@ sits_tempcnn <- function(samples = NULL, values <- torch::as_array(values) # Update the columns names to labels colnames(values) <- sample_labels - return(values) + values } # Set model class predict_fun <- .set_class( diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index 9dbf28eb2..0ae461307 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -98,6 +98,7 @@ .check_samples_ts_bands: "all time series should have the same bands" .check_samples_validation: "invalid validation samples" .check_smoothness: "smoothness must be either one value or a named vector with a value for each label" +.check_source_collection: "collection is not available in data provider or sits is not configured to access it" .check_stac_items: "collection search returned no items\n check 'roi', 'start_date', 'end_date', and 'tile' parameters" .check_shp_attribute: "attribute missing in shapefile - check 'shp_attr' parameter" .check_tiles: "no tiles found in directory for local cube files - check 'data_dir' parameter" @@ -373,6 +374,7 @@ sits_cluster_dendro_best_cut: "desired number of clusters overrides best value" sits_cluster_dendro_default: "input should be a valid training set" sits_colors_legend_not_available: "legend not available in sits colors set" sits_colors_legends: "available legends are" +sits_colors_not_legend: "no legend provided, returning all available colors" sits_colors_qgis: "some labels are not in the color table - please run " sits_colors_set: "wrong input parameters - see example in documentation" sits_combine_predictions: "wrong input parameters - input should be a list of probs cube - see example in documentation" @@ -416,6 +418,7 @@ sits_hist_tile: "tile is not part of the cube" sits_hist_label: "labels is not one of cube labels" sits_hist_date: "date is not part of cube timeline" sits_hist_band: "band not available in the cube" +sits_hist_sits: "histogram of time series not available" sits_kfold_validate: "ml_method is not a valid sits method" sits_kfold_validate_samples: "sits_kfold_validate() requires labelled set of time series" sits_kfold_validate_windows: "sits_kfold_validate() works only with 1 core in Windows" @@ -437,6 +440,7 @@ sits_merge_sar_cube: "merge cubes requires same tiles and same timeline length i sits_merge_sar_cube_irregular: "input cubes are irregular, to merge them use 'irregular = TRUE'" sits_merge_sits: "input data is NULL or has different number of rows" sits_merge_sits_bands: "duplicated band names - merge only works if bands in inputs are different" +sits_mgrs_to_roi: "this function is deprecated; plese use 'sits_tiles_to_roi()'." sits_mixture_model: "wrong input parameters - see example in documentation" sits_mixture_model_derived_cube: "input should not be a cube that has been classified" sits_mixture_model_default: "wrong input parameters - see example in documentation" diff --git a/man/sits_accuracy.Rd b/man/sits_accuracy.Rd index 37f0d62c6..bec61e189 100644 --- a/man/sits_accuracy.Rd +++ b/man/sits_accuracy.Rd @@ -57,7 +57,8 @@ directly on the screen. \description{ This function calculates the accuracy of the classification result. The input is either a set of classified time series or a classified -data cube. Classified time series are produced by \code{\link[sits]{sits_classify}}. +data cube. Classified time series are produced +by \code{\link[sits]{sits_classify}}. Classified images are generated using \code{\link[sits]{sits_classify}} followed by \code{\link[sits]{sits_label_classification}}. diff --git a/man/sits_apply.Rd b/man/sits_apply.Rd index 43f717268..408d42416 100644 --- a/man/sits_apply.Rd +++ b/man/sits_apply.Rd @@ -61,7 +61,7 @@ The main \code{sits} classification workflow has the following steps: \enumerate{ \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from a cloud provider.} - \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection from a cloud provider to a local directory for faster processing.} \item{\code{\link[sits]{sits_regularize}}: create a regular data cube from an ARD image collection.} diff --git a/man/sits_classify.Rd b/man/sits_classify.Rd index f2f45e8cd..41cb1bfac 100644 --- a/man/sits_classify.Rd +++ b/man/sits_classify.Rd @@ -46,8 +46,8 @@ The \code{sits_classify} function takes three types of data as input a multiband image; each band contains the probability that each pixel belongs to a given class. Probability cubes are objects of class "probs_cube".} - \item{\code{\link[sits]{sits_classify.vector_cube}} is called when the input - is a vector data cube. Vector data cubes are produced when + \item{\code{\link[sits]{sits_classify.vector_cube}} is called for + vector data cubes. Vector data cubes are produced when closed regions are obtained from raster data cubes using \code{\link[sits]{sits_segment}}. Classification of a vector data cube produces a vector data structure with additional @@ -61,7 +61,7 @@ The main \code{sits} classification workflow has the following steps: \enumerate{ \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from a cloud provider.} - \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection from a cloud provider to a local directory for faster processing.} \item{\code{\link[sits]{sits_regularize}}: create a regular data cube from an ARD image collection.} @@ -88,8 +88,9 @@ SITS supports the following models: \item{extreme gradient boosting: \code{\link[sits]{sits_xgboost}};} \item{multi-layer perceptrons: \code{\link[sits]{sits_mlp}};} \item{temporal CNN: \code{\link[sits]{sits_tempcnn}};} - \item{temporal self-attention encoders: \code{\link[sits]{sits_lighttae}} and - \code{\link[sits]{sits_tae}}.} + \item{temporal self-attention encoders: + \code{\link[sits]{sits_lighttae}} and + \code{\link[sits]{sits_tae}}.} } Please refer to the sits documentation available in diff --git a/man/sits_cube.Rd b/man/sits_cube.Rd index 50eeaf111..689bedbe2 100644 --- a/man/sits_cube.Rd +++ b/man/sits_cube.Rd @@ -26,7 +26,7 @@ Creates a data cube based on spatial and temporal restrictions in collections available in cloud services or local repositories. Available options are: \itemize{ -\item{To create data cubes from cloud providers which support the STAC protocol, +\item{To create data cubes from providers which support the STAC protocol, use \code{\link[sits]{sits_cube.stac_cube}}.} \item{To create raster data cubes from local image files, use \code{\link[sits]{sits_cube.local_cube}}.} @@ -42,7 +42,7 @@ The main \code{sits} classification workflow has the following steps: \enumerate{ \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from a cloud provider.} - \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection from a cloud provider to a local directory for faster processing.} \item{\code{\link[sits]{sits_regularize}}: create a regular data cube from an ARD image collection.} @@ -89,7 +89,7 @@ A regular data cube is a data cube where: \item{All tiles share the same spectral bands and indices.} \item{All images have the same spatial resolution.} \item{Each location in a tile is associated a set of multi-band time series.} -\item{For each tile, interval and band, the cube is associated to a 2D image.} +\item{For each tile, interval and band, the cube is reduce to a 2D image.} } } \examples{ diff --git a/man/sits_cube.results_cube.Rd b/man/sits_cube.results_cube.Rd index 398ae81b9..6848b8f19 100644 --- a/man/sits_cube.results_cube.Rd +++ b/man/sits_cube.results_cube.Rd @@ -75,12 +75,13 @@ the name associated to the type of result: \code{\link[sits]{sits_classify}}.} \item{\code{"bayes"}, for smoothed cubes produced by \code{\link[sits]{sits_smooth}}.} -\item{\code{"entropy"} when using \code{\link[sits]{sits_uncertainty}} to measure - entropy in pixel classification.} -\item{\code{"margin"} when using \code{\link[sits]{sits_uncertainty}} to measure - probability margin in pixel classification.} -\item{\code{"least"} when using \code{\link[sits]{sits_uncertainty}} to measure - difference between 100\% and most probable class in pixel classification.} +\item{\code{"entropy"} when using \code{\link[sits]{sits_uncertainty}} to + measure entropy in pixel classification.} +\item{\code{"margin"} when using \code{\link[sits]{sits_uncertainty}} to + measure probability margin in pixel classification.} +\item{\code{"least"} when using \code{\link[sits]{sits_uncertainty}} to + measure difference between 100\% and + most probable class in pixel classification.} \item{\code{"class"} for cubes produced by \code{\link[sits]{sits_label_classification}}.} } diff --git a/man/sits_cube_copy.Rd b/man/sits_cube_copy.Rd index 1535571b3..35e35774e 100644 --- a/man/sits_cube_copy.Rd +++ b/man/sits_cube_copy.Rd @@ -54,7 +54,7 @@ The main \code{sits} classification workflow has the following steps: \enumerate{ \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from a cloud provider.} - \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection from a cloud provider to a local directory for faster processing.} \item{\code{\link[sits]{sits_regularize}}: create a regular data cube from an ARD image collection.} diff --git a/man/sits_get_data.Rd b/man/sits_get_data.Rd index afaedfc20..044c3ea0a 100644 --- a/man/sits_get_data.Rd +++ b/man/sits_get_data.Rd @@ -44,7 +44,7 @@ The main \code{sits} classification workflow has the following steps: \enumerate{ \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from a cloud provider.} - \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection from a cloud provider to a local directory for faster processing.} \item{\code{\link[sits]{sits_regularize}}: create a regular data cube from an ARD image collection.} diff --git a/man/sits_label_classification.Rd b/man/sits_label_classification.Rd index 9d40ed786..3d937da8f 100644 --- a/man/sits_label_classification.Rd +++ b/man/sits_label_classification.Rd @@ -66,7 +66,7 @@ The main \code{sits} classification workflow has the following steps: \enumerate{ \item{\code{\link[sits]{sits_cube}}: selects a ARD image collection from a cloud provider.} - \item{\code{\link[sits]{sits_cube_copy}}: copies the ARD image collection + \item{\code{\link[sits]{sits_cube_copy}}: copies an ARD image collection from a cloud provider to a local directory for faster processing.} \item{\code{\link[sits]{sits_regularize}}: create a regular data cube from an ARD image collection.} diff --git a/tests/testthat/test-config.R b/tests/testthat/test-config.R index c001f96e6..d10ccccf6 100644 --- a/tests/testthat/test-config.R +++ b/tests/testthat/test-config.R @@ -102,17 +102,17 @@ test_that("User functions", { ) expect_error( - .source_collection_check(source = "ZZZ", collection = "ZZZ"), + .check_source_collection(source = "ZZZ", collection = "ZZZ"), ".source_check: invalid source parameter" ) expect_error( - .source_collection_check(source = "TEST", collection = "ZZZ"), + .check_source_collection(source = "TEST", collection = "ZZZ"), ".source_collection_check: invalid source parameter" ) expect_equal( - .source_collection_check(source = "TEST", collection = "TEST"), + .check_source_collection(source = "TEST", collection = "TEST"), ".source_collection_check: invalid source parameter" ) expect_equal( From 73ffc8b1d3dda28c13f94a250fbc1766478f3879 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Fri, 11 Apr 2025 13:42:50 -0300 Subject: [PATCH 079/122] fix tests --- R/sits_geo_dist.R | 4 ++-- tests/testthat/test-config.R | 16 ++-------------- tests/testthat/test-plot.R | 5 ++--- 3 files changed, 6 insertions(+), 19 deletions(-) diff --git a/R/sits_geo_dist.R b/R/sits_geo_dist.R index 8f39939e0..fd0c7808a 100644 --- a/R/sits_geo_dist.R +++ b/R/sits_geo_dist.R @@ -61,8 +61,8 @@ sits_geo_dist <- function(samples, roi, n = 1000, crs = "EPSG:4326") { .check_set_caller("sits_geo_dist") # Pre-conditions - .check_samples(data) - data <- .samples_convert_to_sits(data) + .check_samples(samples) + samples <- .samples_convert_to_sits(samples) if (.has(roi)) roi <- .roi_as_sf(roi = roi, as_crs = "EPSG:4326") samples <- samples[sample.int(nrow(samples), min(n, nrow(samples))), ] diff --git a/tests/testthat/test-config.R b/tests/testthat/test-config.R index d10ccccf6..409c0ee37 100644 --- a/tests/testthat/test-config.R +++ b/tests/testthat/test-config.R @@ -108,22 +108,10 @@ test_that("User functions", { expect_error( .check_source_collection(source = "TEST", collection = "ZZZ"), - ".source_collection_check: invalid source parameter" - ) - - expect_equal( - .check_source_collection(source = "TEST", collection = "TEST"), - ".source_collection_check: invalid source parameter" - ) - expect_equal( - .source_collection_tile_check( - "MPC", - "LANDSAT-8-C2-L2", - "232067" - ), - NULL + ".check_source_collection: invalid collection parameter" ) }) # restore variable value Sys.setenv("SITS_CONFIG_USER_FILE" = user_file) + diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index 8efd3ba27..dfd03d0c0 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -35,9 +35,8 @@ test_that("Plot Time Series and Images", { rfor_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor()) point_class <- sits_classify(point_ndvi, rfor_model, progress = FALSE) p3 <- plot(point_class) - expect_equal(p3[[1]]$labels$y, "Value") - expect_equal(p3[[1]]$labels$x, "Time") - expect_equal(p3[[1]]$theme$legend.position, "bottom") + expect_equal(p3$labels$y, "value") + expect_equal(p3$labels$x, "Index") data_dir <- system.file("extdata/raster/mod13q1", package = "sits") sinop <- sits_cube( From 3bd30ff7a346837efcc3bb29d542f97df6b48567 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Fri, 11 Apr 2025 22:06:57 -0300 Subject: [PATCH 080/122] improve lintr --- R/api_check.R | 13 ++ R/api_source.R | 68 +++---- R/api_space_time_operations.R | 4 +- R/api_stac.R | 14 +- R/api_summary.R | 3 +- R/api_texture.R | 9 +- R/api_tibble.R | 19 +- R/api_tile.R | 241 ++++++++++++------------ R/api_timeline.R | 2 +- R/sits_config.R | 2 +- inst/extdata/config_messages.yml | 2 + inst/extdata/lintr-tests/failed_tests.R | 173 +++++++++++++++++ tests/testthat/test-config.R | 11 -- 13 files changed, 357 insertions(+), 204 deletions(-) create mode 100644 inst/extdata/lintr-tests/failed_tests.R diff --git a/R/api_check.R b/R/api_check.R index d6f462197..685a76f36 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -2481,6 +2481,19 @@ msg = .conf("messages", ".check_unique_period") ) } +#' @name .check_source +#' @noRd +#' @description Is a source available in sits? +#' @return Called for side effects +#' +.check_source <- function(source) { + .check_set_caller(".check_source") + # source is upper case + source <- toupper(source) + # check source + .check_chr(source, len_min = 1, len_max = 1) + .check_chr_within(source, within = .sources()) +} #' @name .check_source_collection #' @noRd #' @description \code{.check_source_collection()} checks if a collection diff --git a/R/api_source.R b/R/api_source.R index 86a3f665f..1b792c214 100644 --- a/R/api_source.R +++ b/R/api_source.R @@ -23,23 +23,10 @@ NULL src <- toupper(src) # post-condition .check_chr(src, allow_empty = FALSE, len_min = 1) - return(src) + src } -#' @rdname source_functions -#' @noRd -#' @description Is a source is available in sits? -#' @return code{NULL} if no error occurs. -#' -.source_check <- function(source) { - .check_set_caller(".source_check") - # source is upper case - source <- toupper(source) - # check source - .check_chr(source, len_min = 1, len_max = 1) - .check_chr_within(source, within = .sources()) - return(invisible(NULL)) -} + #' @name .source_new #' @@ -111,7 +98,7 @@ NULL # source is upper case source <- toupper(source) # pre-condition - .source_check(source = source) + .check_source(source = source) # get service name service <- .conf("sources", source, "service") # post-condition @@ -131,7 +118,7 @@ NULL # source is upper case source <- toupper(source) # pre-condition - .source_check(source = source) + .check_source(source = source) # set class s3_class <- .conf("sources", source, "s3_class") # post-condition @@ -139,7 +126,7 @@ NULL allow_empty = FALSE, len_min = 1 ) - return(s3_class) + s3_class } #' @rdname source_functions @@ -151,7 +138,7 @@ NULL # source is upper case source <- toupper(source) # pre-condition - .source_check(source = source) + .check_source(source = source) # get URL url <- .conf("sources", source, "url") # post-condition @@ -159,7 +146,7 @@ NULL allow_na = FALSE, allow_empty = FALSE, len_min = 1, len_max = 1 ) - return(url) + url } #' @title Source bands functions @@ -226,7 +213,7 @@ NULL # post-condition # check bands are non-NA character .check_chr_parameter(bands, allow_empty = FALSE) - return(bands) + bands } #' @rdname .source_bands @@ -279,7 +266,7 @@ NULL ) }) names(result) <- bands - return(result) + result } #' @rdname .source_bands @@ -312,7 +299,7 @@ NULL allow_na = FALSE, allow_empty = FALSE, len_min = length(bands), len_max = length(bands) ) - return(bands) + bands } #' @rdname .source_bands @@ -350,7 +337,7 @@ NULL exclusive_min = 0, len_min = 1 ) - return(resolution) + resolution } #' @rdname .source_bands @@ -383,7 +370,7 @@ NULL bands_converter <- c(bands_to_sits, bands_sits, unknown_bands) # post-condition .check_chr_within(bands, within = names(bands_converter)) - return(unname(bands_converter[bands])) + unname(bands_converter[bands]) } #' @rdname .source_bands @@ -412,7 +399,7 @@ NULL .check_chr_within(bands, within = names(bands_converter) ) - return(unname(bands_converter[bands])) + unname(bands_converter[bands]) } #' @rdname .source_bands @@ -422,7 +409,7 @@ NULL #' @return \code{.source_cloud()} returns a \code{character} vector with cloud #' band name. .source_cloud <- function() { - return("CLOUD") + "CLOUD" } #' @rdname .source_bands @@ -449,7 +436,7 @@ NULL ) # post-condition .check_lgl_parameter(bit_mask) - return(bit_mask) + bit_mask } #' @rdname .source_bands @@ -477,7 +464,7 @@ NULL ) # post-condition .check_lst_parameter(cloud_values) - return(cloud_values) + cloud_values } #' @rdname .source_bands @@ -506,7 +493,7 @@ NULL # post-condition .check_num_parameter(cloud_interp_values, len_max = Inf) - return(cloud_interp_values) + cloud_interp_values } #' @title Source collection functions @@ -538,10 +525,9 @@ NULL # source is upper case source <- toupper(source) # check source - .source_check(source = source) + .check_source(source = source) # get collections from source - collections <- .conf_names("sources", source, "collections") - return(collections) + .conf_names("sources", source, "collections") } #' @rdname .source_collection @@ -581,7 +567,7 @@ NULL if (length(vars) > 0) { do.call(Sys.setenv, args = vars) } - return(invisible(vars)) + invisible(vars) } #' @rdname source_collection @@ -604,7 +590,7 @@ NULL ) # if the collection cant be supported report error .check_that(!is.na(metadata_search)) - return(invisible(metadata_search)) + invisible(metadata_search) } #' @rdname .source_collection @@ -635,7 +621,7 @@ NULL .check_chr_parameter(collection_name, allow_empty = FALSE, len_min = 1, len_max = 1 ) - return(collection_name) + collection_name } #' @rdname .source_collection @@ -680,7 +666,7 @@ NULL } # post-condition .check_lgl_parameter(res) - return(res) + res } #' @rdname .source_collection #' @noRd @@ -1008,7 +994,7 @@ NULL "sensor" ) .check_chr_parameter(sensor, allow_null = TRUE) - return(sensor) + sensor } #' @rdname .source_cube @@ -1027,7 +1013,7 @@ NULL "satellite" ) .check_chr_parameter(satellite, allow_null = TRUE) - return(satellite) + satellite } #' @rdname .source_collection_dates #' @noRd @@ -1047,7 +1033,7 @@ NULL ), .default = NULL ) .check_chr_parameter(dates, allow_null = TRUE) - return(dates) + dates } #' @rdname .source_cube #' @noRd @@ -1064,7 +1050,7 @@ NULL "grid_system" ) .check_chr(grid_system, allow_null = TRUE) - return(grid_system) + grid_system } #' @rdname .source_cube diff --git a/R/api_space_time_operations.R b/R/api_space_time_operations.R index 2f585b5c5..23115240a 100644 --- a/R/api_space_time_operations.R +++ b/R/api_space_time_operations.R @@ -20,7 +20,7 @@ tibble::as_tibble() colnames(t) <- c("X", "Y") - return(t) + t } #' @title Coordinate transformation (X/Y to lat/long) @@ -42,7 +42,7 @@ sf::st_coordinates() colnames(ll) <- c("longitude", "latitude") - return(ll) + ll } #' @title Spatial intersects diff --git a/R/api_stac.R b/R/api_stac.R index c848b0cdf..09c012b42 100644 --- a/R/api_stac.R +++ b/R/api_stac.R @@ -28,9 +28,9 @@ names(item[["assets"]]) <- unname( bands_converter[names(item[["assets"]])] ) - return(item) + item }) - return(items) + items } #' @title Datetime format @@ -47,7 +47,7 @@ if (.has(start_date) && .has(end_date)) { datetime <- paste(start_date, end_date, sep = "/") } - return(datetime) + datetime } #' @title Platform format @@ -67,7 +67,7 @@ platform_source <- platforms[platform] .check_that(length(platform_source) == 1) - return(unlist(platform_source, use.names = FALSE)) + unlist(platform_source, use.names = FALSE) } #' @title Add href locator to gdal file @@ -102,7 +102,7 @@ sep = "/" ) } - return(href) + href } #' @title Creates a query to send to the STAC API @@ -175,8 +175,8 @@ return(result) } # Extract x-coordinates and y-coordinates - coordinates_x <- coordinates[,,1] - coordinates_y <- coordinates[,,2] + coordinates_x <- coordinates[, , 1] + coordinates_y <- coordinates[, , 2] # Calculate bounding box min_x <- min(coordinates_x) max_x <- max(coordinates_x) diff --git a/R/api_summary.R b/R/api_summary.R index b829a584b..d0139000e 100644 --- a/R/api_summary.R +++ b/R/api_summary.R @@ -16,6 +16,5 @@ can_repeat = FALSE ) # filter the tile to be processed - tile <- .cube_filter_tiles(cube = cube, tiles = tile) - return(tile) + .cube_filter_tiles(cube = cube, tiles = tile) } diff --git a/R/api_texture.R b/R/api_texture.R index d5fd87ba4..f0436a84f 100644 --- a/R/api_texture.R +++ b/R/api_texture.R @@ -113,7 +113,7 @@ block_files }) # Merge blocks into a new eo_cube tile - band_tile <- .tile_eo_merge_blocks( + .tile_eo_merge_blocks( files = out_file, bands = out_band, band_conf = band_conf, @@ -122,7 +122,6 @@ multicores = 1, update_bbox = FALSE ) - return(band_tile) } #' @title Normalize values based on a min and max range @@ -137,7 +136,7 @@ #' @return a vector with the adjusted block size .texture_normalize <- function(values, source, dest) { values <- (values - source[1]) / diff(source) * diff(dest) + dest[1] - return(values) + values } #' @title Get block size @@ -150,7 +149,7 @@ glcm_block_size <- .conf(c("texture_options", "block_size")) block[["nrows"]] <- min(block[["nrows"]], glcm_block_size) block[["ncols"]] <- min(block[["ncols"]], glcm_block_size) - return(block) + block } #' @title Kernel function for window operations in spatial neighbourhoods @@ -218,5 +217,5 @@ } ), parent = parent.env(environment()), hash = TRUE) - return(result_env) + result_env } diff --git a/R/api_tibble.R b/R/api_tibble.R index 02f09df60..387884711 100644 --- a/R/api_tibble.R +++ b/R/api_tibble.R @@ -28,7 +28,7 @@ time_series = list() ) class(sits) <- c("sits", class(sits)) - return(sits) + sits } @@ -99,7 +99,7 @@ # compute prediction vector pred_labels <- names(int_labels[max.col(prediction)]) - data_pred <- slider::slide2_dfr( + slider::slide2_dfr( data, seq_len(nrow(data)), function(row, row_n) { @@ -149,11 +149,9 @@ } ) row[["predicted"]] <- list(pred_sample) - return(row) + row } ) - - return(data_pred) } #' @title Aligns dates of time series to a reference date @@ -222,7 +220,7 @@ } ) class(data) <- c("sits", class(data)) - return(data) + data } #' #' @title Checks that the timeline of all time series of a data set are equal @@ -248,11 +246,10 @@ # check if all time indices are equal to the median if (all(n_samples == stats::median(n_samples))) { - message("Success!! All samples have the same number of time indices") + .conf("messages", ".tibble_prune_yes") return(data) } else { - message("Some samples of time series do not have the same time indices - as the majority of the data") + .conf("messages", ".tibble_prune_no") # return the time series that have the same number of samples ind2 <- which(n_samples == stats::median(n_samples)) return(data[ind2, ]) @@ -292,7 +289,7 @@ #' @param data a tibble with time series #' @return time series .tibble_time_series <- function(data) { - return(data[["time_series"]][[1]]) + data[["time_series"]][[1]] } #' @title Split a sits tibble @@ -319,5 +316,5 @@ ) |> dplyr::ungroup() class(result) <- c("sits", class(result)) - return(result) + result } diff --git a/R/api_tile.R b/R/api_tile.R index 10874c3ba..cf91973ec 100644 --- a/R/api_tile.R +++ b/R/api_tile.R @@ -22,12 +22,12 @@ NULL } #' @export .tile.raster_cube <- function(cube) { - cube <- .cube(cube) + cube <- .cube(cube)[1,] cube[1, ] } #' @export .tile.default <- function(cube) { - tile <- cube |> + cube |> tibble::as_tibble() |> .cube_find_class() |> .tile() @@ -47,7 +47,7 @@ NULL } #' @export .tile_source.default <- function(tile) { - source <- tile |> + tile |> tibble::as_tibble() |> .cube_find_class() |> .tile_source() @@ -67,10 +67,10 @@ NULL } #' @export .tile_collection.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - collection <- .tile_collection(tile) - return(collection) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_collection() } #' @title Get/Set tile name #' @noRd @@ -86,10 +86,10 @@ NULL } #' @export .tile_name.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - name <- .tile_name(tile) - return(name) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_name() } `.tile_name<-` <- function(tile, value) { UseMethod(".tile_name<-", tile) @@ -114,10 +114,10 @@ NULL } #' @export .tile_ncols.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - ncols <- .tile_ncols(tile) - return(ncols) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_ncols() } #' @title Get tile number of rows #' @noRd @@ -133,10 +133,10 @@ NULL } #' @export .tile_nrows.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - nrows <- .tile_nrows(tile) - return(nrows) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_nrows() } #' @title Get tile size #' @noRd @@ -151,10 +151,10 @@ NULL } #' @export .tile_size.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - size <- .tile_size(tile) - return(size) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_size() } #' @title Get X resolution #' @noRd @@ -170,10 +170,10 @@ NULL } #' @export .tile_xres.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - xres <- .tile_xres(tile) - return(xres) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_xres() } #' @title Get Y resolution #' @noRd @@ -189,10 +189,10 @@ NULL } #' @export .tile_yres.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - yres <- .tile_yres(tile) - return(yres) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_yres() } #' @title Update tile labels @@ -242,10 +242,10 @@ NULL } #' @export .tile_labels.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - labels <- .tile_labels(tile) - return(labels) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_labels() } # `.tile_labels<-` <- function(tile, value) { @@ -275,10 +275,10 @@ NULL } #' @export .tile_start_date.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - start_date <- .tile_start_date(tile) - return(start_date) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_start_date() } #' #' @title Get end date from file_info. @@ -298,10 +298,10 @@ NULL } #' @export .tile_end_date.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - end_date <- .tile_end_date(tile) - return(end_date) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_end_date() } #' @title Get fid from tile #' @name .tile_fid @@ -319,10 +319,10 @@ NULL } #' @export .tile_fid.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - fid <- .tile_fid(tile) - return(fid) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_fid() } #' @title Get unique timeline from file_info. #' @name .tile_timeline @@ -340,10 +340,10 @@ NULL } #' @export .tile_timeline.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - timeline <- .tile_timeline(tile) - return(timeline) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_timeline() } #' @title Get period from file_info. #' @name .tile_period @@ -364,10 +364,10 @@ NULL } #' @export .tile_period.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - period <- .tile_period(tile) - return(period) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_period() } #' @title Check if tile is complete #' @name .tile_is_complete @@ -385,10 +385,10 @@ NULL } #' @export .tile_is_complete.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - is_complete <- .tile_is_complete(tile) - return(is_complete) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_is_complete() } #' @title Check if tile's file info is not empty #' @name .tile_is_nonempty @@ -406,10 +406,10 @@ NULL } #' @export .tile_is_nonempty.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - is_nonempty <- .tile_is_nonempty(tile) - return(is_nonempty) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_is_nonempty() } #' @title Get path of first asset from file_info. #' @name .tile_path @@ -477,10 +477,10 @@ NULL } #' @export .tile_paths.default <- function(tile, bands = NULL) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - paths <- .tile_paths(tile, bands) - return(paths) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_paths(bands) } #' @title Get all file paths from base_info. #' @name .tile_base_path @@ -511,10 +511,10 @@ NULL } #' @export .tile_satellite.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - satellite <- .tile_satellite(tile) - return(satellite) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_satellite() } #' @title Get unique sensor name from tile. #' @name .tile_sensor @@ -533,10 +533,10 @@ NULL } #' @export .tile_sensor.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - sensor <- .tile_sensor(tile) - return(sensor) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_sensor() } #' @title Get sorted unique bands from file_info. #' @name .tile_bands @@ -564,10 +564,10 @@ NULL } #' @export .tile_bands.default <- function(tile, add_cloud = TRUE) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - bands <- .tile_bands(tile, add_cloud) - return(bands) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_bands(add_cloud) } #' @title Set bands in tile file_info. #' @rdname .tile_bands @@ -598,8 +598,7 @@ NULL #' @param tile A tile. #' @return names of base bands in the tile .tile_base_bands <- function(tile) { - base_info <- tile[["base_info"]][[1]] - return(base_info[["band"]]) + tile[["base_info"]][[1]] } #' #' @title Get a band definition from config. @@ -639,10 +638,10 @@ NULL } #' @export .tile_band_conf.default <- function(tile, band) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - band_conf <- .tile_band_conf(tile, band) - return(band_conf) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_band_conf(band) } #' #' @title Filter file_info entries of a given \code{band}. @@ -681,10 +680,10 @@ NULL } #' @export .tile_filter_bands.default <- function(tile, bands) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - tile <- .tile_filter_bands(tile, bands) - return(tile) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_filter_bands(bands) } #' #' @title Get crs from tile @@ -704,10 +703,10 @@ NULL } #' @export .tile_crs.default <- function(tile) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - crs <- .tile_crs(tile) - return(crs) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_crs() } #' @title Get bbox from tile #' @name .tile_bbox @@ -744,10 +743,10 @@ NULL } #' @export .tile_as_sf.default <- function(tile, as_crs = NULL) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - sf_obj <- .tile_as_sf(tile, as_crs = as_crs) - return(sf_obj) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_as_sf(as_crs = as_crs) } #' #' @title Does tile \code{bbox} intersect \code{roi} parameter? @@ -767,10 +766,10 @@ NULL } #' @export .tile_intersects.default <- function(tile, roi) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - intersects <- .tile_intersects(tile, roi) - return(intersects) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_intersects(roi) } #' @title Is tile inside roi? #' @name .tile_within @@ -789,10 +788,10 @@ NULL } #' @export .tile_within.default <- function(tile, roi) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - within <- .tile_within(tile, roi) - return(within) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_within(roi) } #' #' @title Is any date of tile's timeline between 'start_date' @@ -816,10 +815,10 @@ NULL } #' @export .tile_during.default <- function(tile, start_date, end_date) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - result <- .tile_during(tile, start_date, end_date) - return(result) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_during(start_date, end_date) } #' #' @title Filter file_info entries by 'start_date' and 'end_date.' @@ -843,11 +842,10 @@ NULL } #' @export .tile_filter_interval.default <- function(tile, start_date, end_date) { - tile <- tile |> + tile |> tibble::as_tibble() |> .cube_find_class() |> .tile_filter_interval(start_date, end_date) - return(tile) } #' #' @title Filter file_info entries by date @@ -945,7 +943,7 @@ NULL value = band ) # Return values - return(values) + values } #' @export .tile_read_block.derived_cube <- function(tile, band, block) { @@ -981,10 +979,10 @@ NULL } #' @export .tile_read_block.default <- function(tile, band, block) { - tile <- tibble::as_tibble(tile) - tile <- .cube_find_class(tile) - tile <- .tile_read_block(tile, band, block) - return(tile) + tile |> + tibble::as_tibble() |> + .cube_find_class() |> + .tile_read_block(band, block) } #' #' @title Read and preprocess a block of cloud values from @@ -1554,7 +1552,7 @@ NULL values <- impute_fn(values) } # Returning extracted time series - return(list(pol_id, c(t(unname(values))))) + list(pol_id, c(t(unname(values)))) } #' @title Check if tile contains cloud band #' @keywords internal @@ -1681,19 +1679,16 @@ NULL over_values <- unlist(strsplit(over, split = ":", fixed = TRUE))[2] over_pairs <- unlist(stringr::str_split(over_values, pattern = ",")) # extract the COG sizes - cog_sizes <- purrr::map(over_pairs, function(op){ + purrr::map(over_pairs, function(op) { xsize <- as.numeric(unlist( strsplit(op, split = "x", fixed = TRUE))[[1]] ) ysize <- as.numeric(unlist( strsplit(op, split = "x", fixed = TRUE))[[2]] ) - cog_size <- c( - xsize = xsize, - ysize = ysize - ) + c(xsize = xsize, ysize = ysize) }) - return(cog_sizes) + } #' @title Return base info diff --git a/R/api_timeline.R b/R/api_timeline.R index e17b9ab92..44046633a 100644 --- a/R/api_timeline.R +++ b/R/api_timeline.R @@ -211,7 +211,7 @@ start_index <- which(timeline == date_pair[[1]]) end_index <- which(timeline == date_pair[[2]]) - dates_index <- c(start_index, end_index) + c(start_index, end_index) }) } #' @title Find the subset of a timeline that is contained diff --git a/R/sits_config.R b/R/sits_config.R index 6cffd8a4f..a5bd4afaa 100644 --- a/R/sits_config.R +++ b/R/sits_config.R @@ -126,7 +126,7 @@ sits_list_collections <- function(source = NULL) { ) sources <- source } - purrr::map(sources, .conf_list_source()) + purrr::walk(sources, .conf_list_source) } #' @title List the cloud collections supported by sits #' @name sits_config_user_file diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index 0ae461307..e08fc3572 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -310,6 +310,8 @@ .summary_check_tile: "tile is not included in the cube" .test_check: "expected error during testing" .tibble_bands_check: "requested bands not available in the training samples" +.tibble_prune_yes: "Success!! All samples have the same number of time indices" +.tibble_prune_no: "Some samples of time series do not have the same time indices \n as the majority of the data" .tile_area_freq_raster_cube: "cube is not a labelled cube" .tile_bands_assign: "number of input values different for current number of bands in tile" .tile_derived_from_file: "number of image layers does not match number of labels" diff --git a/inst/extdata/lintr-tests/failed_tests.R b/inst/extdata/lintr-tests/failed_tests.R new file mode 100644 index 000000000..0c8551ff0 --- /dev/null +++ b/inst/extdata/lintr-tests/failed_tests.R @@ -0,0 +1,173 @@ +── Failed tests ─────────────────────────────────────────────────────────────────────────────────────────────────────────────────── +Error (test-samples.R:61:5): Sampling design +Error in `dplyr::inner_join(x = sampling_design, y = cube_labels, by = "labels")`: Join columns in `y` must be present in the data. +x Problem with `labels`. +Backtrace: + ▆ +1. └─sits::sits_stratified_sampling(...) at test-samples.R:61:5 +2. ├─dplyr::rename(...) at sits/R/sits_sample_functions.R:479:5 +3. ├─dplyr::select(...) +4. ├─dplyr::inner_join(x = sampling_design, y = cube_labels, by = "labels") +5. └─dplyr:::inner_join.data.frame(x = sampling_design, y = cube_labels, by = "labels") +6. └─dplyr:::join_mutate(...) +7. └─dplyr:::join_cols(...) +8. └─dplyr:::check_join_vars(by$y, y_names, by$condition, "y", error_call = error_call) +9. └─rlang::abort(bullets, call = error_call) + +Error (test-samples.R:112:5): Sampling design with class cube from STAC +Error in `dplyr::inner_join(x = sampling_design, y = cube_labels, by = "labels")`: Join columns in `y` must be present in the data. +x Problem with `labels`. +Backtrace: + ▆ +1. └─sits::sits_stratified_sampling(...) at test-samples.R:112:5 +2. ├─dplyr::rename(...) at sits/R/sits_sample_functions.R:479:5 +3. ├─dplyr::select(...) at sits/R/sits_sample_functions.R:479:5 +4. ├─dplyr::inner_join(x = sampling_design, y = cube_labels, by = "labels") at sits/R/sits_sample_functions.R:479:5 +5. └─dplyr:::inner_join.data.frame(x = sampling_design, y = cube_labels, by = "labels") +6. └─dplyr:::join_mutate(...) +7. └─dplyr:::join_cols(...) +8. └─dplyr:::check_join_vars(by$y, y_names, by$condition, "y", error_call = error_call) +9. └─rlang::abort(bullets, call = error_call) + +Error (test-segmentation.R:18:5): Segmentation + + Error in `purrr::map(rounds, function(round) { + if (!is.null(sync_fn)) { + sync_fn(round) + } + round <- slider::slide(round, identity) + .parallel_map(round, fn, ..., progress = progress) + })`: i In index: 1. +Caused by error in `.check_remote_errors()`: + ! one node produced an error: Invalid input type, expected 'integer' actual 'double' +Backtrace: + ▆ +1. ├─sits::sits_segment(...) at test-segmentation.R:18:5 +2. │ └─sits:::.cube_foreach_tile(...) at sits/R/sits_segmentation.R:183:5 +3. │ └─slider::slide_dfr(cube, fn, ...) at sits/R/api_cube.R:918:5 +4. │ └─slider::slide(...) +5. │ └─slider:::slide_impl(...) +6. │ ├─slider:::slide_common(...) +7. │ └─sits (local) .f(.x, ...) +8. │ └─sits:::.segments_tile(...) at sits/R/sits_segmentation.R:185:9 +9. │ └─sits:::.jobs_map_parallel_chr(...) at sits/R/api_segments.R:62:5 +10. │ └─sits:::.jobs_map_parallel(jobs, fn, ..., progress = progress) at sits/R/api_jobs.R:155:5 +11. │ ├─base::unlist(...) at sits/R/api_jobs.R:138:5 +12. │ └─purrr::map(...) +13. │ └─purrr:::map_("list", .x, .f, ..., .progress = .progress) +14. │ ├─purrr:::with_indexed_errors(...) +15. │ │ └─base::withCallingHandlers(...) +16. │ ├─purrr:::call_with_cleanup(...) +17. │ └─sits (local) .f(.x[[i]], ...) +18. │ └─sits:::.parallel_map(round, fn, ..., progress = progress) at sits/R/api_jobs.R:143:9 +19. │ └─sits:::.parallel_cluster_apply(x, fn, ..., pb = pb) at sits/R/api_parallel.R:296:5 +20. │ └─parallel (local) .check_remote_errors(val) at sits/R/api_parallel.R:245:9 +21. │ └─base::stop("one node produced an error: ", firstmsg, domain = NA) +22. └─base::.handleSimpleError(...) +23. └─purrr (local) h(simpleError(msg, call)) +24. └─cli::cli_abort(...) +25. └─rlang::abort(...) + +Failure (test-segmentation.R:205:5): Segmentation of large files +.check_cube_is_regular(modis_cube_local) is not TRUE + +`actual` is NULL +`expected` is a logical vector (TRUE) + +Error (test-segmentation.R:207:5): Segmentation of large files + + Error in `purrr::map(rounds, function(round) { + if (!is.null(sync_fn)) { + sync_fn(round) + } + round <- slider::slide(round, identity) + .parallel_map(round, fn, ..., progress = progress) + })`: i In index: 1. +Caused by error in `.check_remote_errors()`: + ! one node produced an error: Invalid input type, expected 'integer' actual 'double' +Backtrace: + ▆ +1. ├─sits::sits_segment(...) at test-segmentation.R:207:5 +2. │ └─sits:::.cube_foreach_tile(...) at sits/R/sits_segmentation.R:183:5 +3. │ └─slider::slide_dfr(cube, fn, ...) at sits/R/api_cube.R:918:5 +4. │ └─slider::slide(...) +5. │ └─slider:::slide_impl(...) +6. │ ├─slider:::slide_common(...) +7. │ └─sits (local) .f(.x, ...) +8. │ └─sits:::.segments_tile(...) at sits/R/sits_segmentation.R:185:9 +9. │ └─sits:::.jobs_map_parallel_chr(...) at sits/R/api_segments.R:62:5 +10. │ └─sits:::.jobs_map_parallel(jobs, fn, ..., progress = progress) at sits/R/api_jobs.R:155:5 +11. │ ├─base::unlist(...) at sits/R/api_jobs.R:138:5 +12. │ └─purrr::map(...) +13. │ └─purrr:::map_("list", .x, .f, ..., .progress = .progress) +14. │ ├─purrr:::with_indexed_errors(...) +15. │ │ └─base::withCallingHandlers(...) +16. │ ├─purrr:::call_with_cleanup(...) +17. │ └─sits (local) .f(.x[[i]], ...) +18. │ └─sits:::.parallel_map(round, fn, ..., progress = progress) at sits/R/api_jobs.R:143:9 +19. │ └─sits:::.parallel_cluster_apply(x, fn, ..., pb = pb) at sits/R/api_parallel.R:296:5 +20. │ └─parallel (local) .check_remote_errors(val) at sits/R/api_parallel.R:245:9 +21. │ └─base::stop("one node produced an error: ", firstmsg, domain = NA) +22. └─base::.handleSimpleError(...) +23. └─purrr (local) h(simpleError(msg, call)) +24. └─cli::cli_abort(...) +25. └─rlang::abort(...) + +Error (test-summary.R:73:5): summary sits area accuracy +Error in `dplyr::reframe(var_values, dplyr::across(.cols = dplyr::all_of(labels), + function(x) { + stats::quantile(x, probs = seq(0, 1, intervals)) + }))`: i In argument: `dplyr::across(...)`. +Caused by error in `across()`: + i In argument: `dplyr::all_of(labels)`. +Caused by error in `dplyr::all_of()`: + ! Can't subset elements. +x Subscript must be numeric or character, not a function. +Backtrace: + ▆ + 1. ├─utils::capture.output(suppressWarnings(summary(variance_cube))) at test-summary.R:73:5 + 2. │ └─base::withVisible(...elt(i)) + 3. ├─base::suppressWarnings(summary(variance_cube)) + 4. │ └─base::withCallingHandlers(...) + 5. ├─base::summary(variance_cube) + 6. ├─sits:::summary.variance_cube(variance_cube) + 7. │ ├─dplyr::reframe(...) at sits/R/sits_summary.R:321:5 + 8. │ └─dplyr:::reframe.data.frame(...) + 9. │ └─dplyr:::summarise_cols(.data, dplyr_quosures(...), by, "reframe") + 10. │ ├─base::withCallingHandlers(...) + 11. │ └─dplyr:::expand_across(dot) + 12. │ └─dplyr:::across_setup(...) + 13. │ └─tidyselect::eval_select(cols, data = data, error_call = error_call) + 14. │ └─tidyselect:::eval_select_impl(...) + 15. │ ├─tidyselect:::with_subscript_errors(...) + 16. │ │ └─base::withCallingHandlers(...) + 17. │ └─tidyselect:::vars_select_eval(...) + 18. │ └─tidyselect:::walk_data_tree(expr, data_mask, context_mask) + 19. │ └─tidyselect:::eval_context(expr, context_mask, call = error_call) + 20. │ ├─tidyselect:::with_chained_errors(...) + 21. │ │ └─base::withCallingHandlers(...) + 22. │ └─rlang::eval_tidy(as_quosure(expr, env), context_mask) + 23. ├─dplyr::all_of(labels) + 24. │ └─tidyselect:::as_indices_impl(x, vars = vars, strict = TRUE) + 25. │ └─vctrs::vec_as_subscript(x, logical = "error", call = call, arg = arg) + 26. ├─rlang::cnd_signal(x) + 27. │ └─rlang:::signal_abort(cnd) + 28. │ └─base::signalCondition(cnd) + 29. ├─tidyselect (local) ``(``) + 30. │ └─cli::cli_abort(c(i = msg), call = call, parent = cnd) + 31. │ └─rlang::abort(...) + 32. │ └─rlang:::signal_abort(cnd, .file) + 33. │ └─base::signalCondition(cnd) + 34. └─dplyr (local) ``(``) + 35. └─dplyr (local) handler(cnd) + 36. └─rlang::abort(message, class = error_class, parent = parent, call = error_call) + +Error (test-view.R:1:1): View + +Error: C stack usage 7974040 is too close to the limit + +Error (test-view.R:176:1): View BDC cube + +Error: C stack usage 7970280 is too close to the limit + +[ FAIL 8 | WARN 0 | SKIP 5 | PASS 1431 ] diff --git a/tests/testthat/test-config.R b/tests/testthat/test-config.R index 409c0ee37..df3712a6a 100644 --- a/tests/testthat/test-config.R +++ b/tests/testthat/test-config.R @@ -85,17 +85,6 @@ test_that("User functions", { .source_s3class(source = "BDC"), c("bdc_cube", "stac_cube", "eo_cube", "raster_cube") ) - - expect_equal( - .source_check(source = "TEST"), - NULL - ) - - expect_equal( - .source_check(source = "BDC"), - NULL - ) - expect_equal( .source_collections(source = "TEST"), "TEST" From b6034eb56c4201a35c8489c555f9f7ae6fbc8c73 Mon Sep 17 00:00:00 2001 From: Gilberto Camara Date: Sat, 12 Apr 2025 18:28:45 -0300 Subject: [PATCH 081/122] fix bugs in sits_view --- R/api_accuracy.R | 6 +- R/api_check.R | 4 +- R/api_chunks.R | 4 +- R/api_classify.R | 10 ++- R/api_cluster.R | 2 +- R/api_colors.R | 11 ++-- R/api_conf.R | 51 ++++++--------- R/api_csv.R | 2 +- R/api_cube.R | 52 +++++---------- R/api_data.R | 61 +++++++++--------- R/api_detect_change.R | 8 +-- R/api_download.R | 2 +- R/api_dtw.R | 4 +- R/api_environment.R | 4 +- R/api_factory.R | 2 +- R/api_gdal.R | 20 +++--- R/api_gdalcubes.R | 78 +++++++--------------- R/api_view.R | 7 -- R/sits_cube_local.R | 2 +- R/sits_sample_functions.R | 26 ++++---- R/sits_segmentation.R | 12 ++-- R/sits_summary.R | 19 +++--- R/sits_view.R | 38 +++++------ inst/extdata/lintr-tests/failed_tests.R | 86 +------------------------ tests/testthat/test-segmentation.R | 5 +- tests/testthat/test-view.R | 55 ++++------------ 26 files changed, 189 insertions(+), 382 deletions(-) diff --git a/R/api_accuracy.R b/R/api_accuracy.R index 8fd7e69ac..7f06fe23f 100644 --- a/R/api_accuracy.R +++ b/R/api_accuracy.R @@ -130,7 +130,7 @@ ) ) class(acc_area) <- c("sits_area_accuracy", class(acc_area)) - return(acc_area) + acc_area } #' @title Support for pixel-based post-classification accuracy #' @name .accuracy_pixel_assess @@ -154,7 +154,7 @@ # Call caret package to the classification statistics acc <- caret::confusionMatrix(pred_fac, ref_fac) class(acc) <- c("sits_accuracy", class(acc)) - return(acc) + acc } #' @title Get validation samples #' @name .accuracy_get_validation @@ -192,7 +192,7 @@ #' @export .accuracy_get_validation.sf <- function(validation) { # Pre-condition - check for the required columns - .check_chr_contains(colnames(validation), c("label")) + .check_chr_contains(colnames(validation), "label") # transform the `sf` object in a valid validation |> dplyr::mutate( diff --git a/R/api_check.R b/R/api_check.R index 685a76f36..c86d135a3 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -2498,8 +2498,7 @@ #' @noRd #' @description \code{.check_source_collection()} checks if a collection #' is from a source. -#' @return \code{.check_source_collection()} returns \code{NULL} if -#' no error occurs. +#' @return Called for side effects .check_source_collection <- function(source, collection) { # set calller for error msg @@ -2509,7 +2508,6 @@ .check_chr_within(collection, within = .source_collections(source = source) ) - return(invisible(NULL)) } #' @title Check band availability #' @name .check_bands_collection diff --git a/R/api_chunks.R b/R/api_chunks.R index dcaffc41f..da55a23f1 100644 --- a/R/api_chunks.R +++ b/R/api_chunks.R @@ -207,7 +207,7 @@ NULL ext = "gpkg" ) .vector_write_vec(segs[idx, ], block_file, append = TRUE) - return(block_file) + block_file }) - return(chunks) + chunks } diff --git a/R/api_classify.R b/R/api_classify.R index db56ef19d..1189ea5ba 100755 --- a/R/api_classify.R +++ b/R/api_classify.R @@ -244,9 +244,9 @@ ) # Return probs tile or cropped version if (.has(roi)) - return(probs_tile_crop) + probs_tile_crop else - return(probs_tile) + probs_tile } #' @title Classify a chunk of raster data using multicores @@ -332,8 +332,6 @@ ) # By default, update_bbox is FALSE if (.has(roi)) { - # How many chunks there are in tile? - nchunks <- nrow(chunks) # Intersecting chunks with ROI chunks <- .chunks_filter_spatial( chunks = chunks, @@ -398,7 +396,7 @@ # Free memory gc() # Return block file - return(block_file) + block_file }, progress = progress) # Remove empty block files block_files <- purrr::discard(block_files, Negate(nzchar)) @@ -419,7 +417,7 @@ # Remove file block unlink(block_files) # Return probability vector tile - return(probs_tile) + probs_tile } #' @title Read a block of values retrieved from a set of raster images diff --git a/R/api_cluster.R b/R/api_cluster.R index 78cf6712d..9eee2170a 100644 --- a/R/api_cluster.R +++ b/R/api_cluster.R @@ -154,5 +154,5 @@ factor_1 <- (nis2 * njs2) / n2 factor_2 <- (nis2 + njs2) / 2 rand <- (sum(choose(x[x > 1], 2)) - factor_1) / (factor_2 - factor_1) - return(rand) + rand } diff --git a/R/api_colors.R b/R/api_colors.R index 27b58f235..90bfa7326 100644 --- a/R/api_colors.R +++ b/R/api_colors.R @@ -22,10 +22,9 @@ labels_exist <- labels[labels %in% names_tb] # get the colors for the names that exist colors <- purrr::map_chr(labels_exist, function(l) { - col <- color_tb |> + color_tb |> dplyr::filter(.data[["name"]] == l) |> dplyr::pull(.data[["color"]]) - return(col) }) # get the names of the colors that exist in the SITS color table names(colors) <- labels_exist @@ -122,7 +121,7 @@ ), fill = color_tb[["color"]] ) + - suppressWarnings(ggplot2::geom_text( + ggplot2::geom_text( data = color_tb, mapping = ggplot2::aes( x = .data[["x"]] + 0.5, @@ -134,11 +133,11 @@ hjust = 0.5, vjust = 1, size = 10 / ggplot2::.pt - )) + ) g + ggplot2::theme( panel.background = ggplot2::element_rect(fill = "#FFFFFF") ) - return(suppressWarnings(g)) + g } #' #' @title Write a color table in QGIS Style format @@ -193,7 +192,7 @@ writeLines(bottom_lines, con = con) # close the file - close(con) + on.exit(close(con)) } #' @title Transform an RColorBrewer name to cols4all name #' @name .colors_cols4all_name diff --git a/R/api_conf.R b/R/api_conf.R index ee8aab0d6..a4b9d8eb2 100644 --- a/R/api_conf.R +++ b/R/api_conf.R @@ -61,7 +61,7 @@ # source names are uppercase names(sources) <- toupper(names(sources)) # check each source - sources <- lapply(sources, function(source) { + lapply(sources, function(source) { # pre-condition .check_lst_parameter(source, len_min = 2) @@ -71,11 +71,10 @@ ) names(source) <- tolower(names(source)) # check source - source <- .check_error( + .check_error( do.call(.conf_new_source, args = source), msg = .conf("messages", ".conf_set_options_source") ) - return(source) }) # initialize sources @@ -245,11 +244,9 @@ .conf_colors_file <- function() { # load the default configuration file yml_file <- system.file("extdata", "config_colors.yml", package = "sits") - # check that the file name is valid .check_file(yml_file, msg = "invalid configuration file") - - return(yml_file) + yml_file } #' @title Loads default color table and legends #' @name .conf_load_color_table @@ -272,11 +269,7 @@ colors <- config_colors[["colors"]] color_table <- purrr::map2_dfr(colors, names(colors), function(cl, nm) { - cc_tb <- tibble::tibble( - name = nm, - color = cl - ) - return(cc_tb) + tibble::tibble(name = nm, color = cl) }) # set the color table @@ -386,7 +379,7 @@ ) } # returns the user configuration, otherwise null - return(yaml_user_config) + yaml_user_config } #' @title Load the user configuration file #' @name .conf_set_user_file @@ -492,7 +485,7 @@ #' @param source Data source #' #' @return Called for side effects. -.conf_list_source <- function(source){ +.conf_list_source <- function(source) { cat(paste0(source, ":\n")) collections <- .source_collections(source) purrr::map(collections, function(col) { @@ -550,8 +543,7 @@ "key" ) ) - - return(res) + res } #' @title Include a new source in the configuration #' @name .conf_new_source @@ -614,12 +606,12 @@ .check_lst_parameter(dots, len_min = 0, msg = .conf("messages", ".conf_new_source_collections_args")) - return(c(list( + c(list( s3_class = s3_class, service = service, url = url, collections = collections - ), dots)) + ), dots) } #' @title Include a new collection in the configuration #' @name .conf_new_collection @@ -675,7 +667,7 @@ # configure class bands (assuming there is no cloud band in class cubes) class_bands <- .conf_new_bands(bands, .conf_new_class_band) # save band configuration object - collection_bands <- c(class_bands) + collection_bands <- class_bands } else { # handle cloud and non-cloud bands cloud_band <- bands[names(bands) %in% .source_cloud()] @@ -786,7 +778,7 @@ len_min = 7 ) # return a band object - return(new_band_params) + new_band_params } #' @title Include a new cloud band in the configuration #' @name .conf_new_cloud_band @@ -827,9 +819,8 @@ # post-condition .check_lst_parameter(cloud_band_params, len_min = 5) - # return a cloud band object - return(cloud_band_params) + cloud_band_params } #' @title Include a new class band in the configuration #' @name .conf_new_class_band @@ -865,9 +856,8 @@ # post-condition .check_lst_parameter(class_band_params, len_min = 4) - # return a class band object - return(class_band_params) + class_band_params } #' @title Configure bands #' @name .conf_new_bands @@ -897,8 +887,7 @@ #' @noRd #' @return pagination limit to rstac output .conf_rstac_limit <- function() { - res <- .conf("rstac_pagination_limit") - return(res) + .conf("rstac_pagination_limit") } #' @title Retrieve the raster package to be used #' @name .conf_raster_pkg @@ -907,8 +896,7 @@ #' @return the raster package used to process raster data #' .conf_raster_pkg <- function() { - res <- .conf("raster_api_package") - return(res) + .conf("raster_api_package") } #' @title Retrieve the request package to be used @@ -918,8 +906,7 @@ #' @return the package used to process http requisitions #' .conf_request_pkg <- function() { - res <- .conf("request_api_package") - return(res) + .conf("request_api_package") } #' @title Basic access config functions @@ -1235,19 +1222,19 @@ NULL sits_env[["leaflet_false_color_legend"]] <- FALSE # create a global object for controlling leaflet SOM neuron color display sits_env[["leaflet_som_colors"]] <- FALSE - return(invisible(sits_leaflet)) + invisible(sits_leaflet) } #' @title Clean global leaflet #' @name .conf_clean_leaflet #' @keywords internal #' @noRd -#' @return NULL, called for side effects +#' @return Called for side effects #' .conf_clean_leaflet <- function() { leaf_map <- sits_env[["leaflet"]][["leaf_map"]] .conf_load_leaflet() rm(leaf_map) - return(invisible(NULL)) + invisible(NULL) } #' @title Get Grid System #' @name .conf_grid_system diff --git a/R/api_csv.R b/R/api_csv.R index a2165a42c..f2fa22f9c 100644 --- a/R/api_csv.R +++ b/R/api_csv.R @@ -28,7 +28,7 @@ end_date = as.Date(.data[["end_date"]]) ) class(samples) <- c("sits", class(samples)) - return(samples) + samples } #' @title Transform a CSV with labelled points for accuracy assessment diff --git a/R/api_cube.R b/R/api_cube.R index a4e21cf8d..289acfe61 100644 --- a/R/api_cube.R +++ b/R/api_cube.R @@ -55,9 +55,7 @@ NULL ) is_sar <- is_sar && !grepl("rtc", base_class, fixed = TRUE) if (is_sar) { - return(unique( - c(base_class, "grd_cube", "sar_cube", s3_class, cube_class) - )) + unique(c(base_class, "grd_cube", "sar_cube", s3_class, cube_class)) } } #' @title Strategy function to define `SAR (RTC)` data cube classes @@ -80,9 +78,7 @@ NULL is_sar <- is_sar && grepl("rtc", base_class, fixed = TRUE) if (is_sar) { - return(unique( - c(base_class, "rtc_cube", "sar_cube", s3_class, cube_class) - )) + unique(c(base_class, "rtc_cube", "sar_cube", s3_class, cube_class)) } } #' @title Strategy function to define a `DEM` data cube class @@ -105,9 +101,7 @@ NULL ) if (is_dem) { - return(unique( - c(base_class, "dem_cube", s3_class, cube_class) - )) + unique(c(base_class, "dem_cube", s3_class, cube_class)) } } #' @title Strategy function to define a `Rainfall` data cube class @@ -125,9 +119,7 @@ NULL ) { is_rainfall <- grepl("rainfall", base_class, fixed = TRUE) if (is_rainfall) { - return(unique( - c(base_class, "rainfall_cube", s3_class, cube_class) - )) + unique(c(base_class, "rainfall_cube", s3_class, cube_class)) } } #' @title Strategy function to define a `Class` data cube class @@ -148,16 +140,11 @@ NULL }, .default = FALSE ) - if (is_class) { # explicitly defining a `class_cube` following the definition from the # `sits_label_classification` function. - return( - c( - "class_cube", "derived_cube", "raster_cube", - base_class, "tbl_df", "tbl", "data.frame" - ) - ) + c("class_cube", "derived_cube", "raster_cube", + base_class, "tbl_df", "tbl", "data.frame") } } #' @title Registry of class definition strategies @@ -553,11 +540,11 @@ NULL #' @export .cube_adjust_crs.grd_cube <- function(cube) { cube[["crs"]] <- "EPSG:4326" - return(cube) + cube } #' @export .cube_adjust_crs.default <- function(cube) { - return(cube) + cube } #' @title Adjust cube tile name #' @keywords internal @@ -708,7 +695,7 @@ NULL .cube_source.raster_cube <- function(cube) { # set caller to show in errors .check_set_caller(".cube_source") - source <- .compact(slider::slide_chr(cube, .tile_source)) + .compact(slider::slide_chr(cube, .tile_source)) } #'@export .cube_source.default <- function(cube) { @@ -1353,10 +1340,7 @@ NULL .is_eq(max_ymax, min_ymax, tolerance = tolerance) return(test) }) - if (all(equal_bbox)) - return(TRUE) - else - return(FALSE) + all(equal_bbox) } #' @title Check if sizes of all tiles of the cube are the same #' @name .cube_has_unique_tile_size @@ -1369,16 +1353,10 @@ NULL test_cube_size <- slider::slide_lgl( cube, function(tile) { - if (length(unique(.tile_nrows(tile))) > 1 || - length(unique(.tile_ncols(tile))) > 1) - return(FALSE) - else - return(TRUE) + (length(unique(.tile_nrows(tile))) == 1 && + length(unique(.tile_ncols(tile))) == 1) }) - if (all(test_cube_size)) - return(TRUE) - else - return(FALSE) + all(test_cube_size) } #' @title Check if resolutions of all tiles of the cube are the same @@ -1388,7 +1366,7 @@ NULL #' @param cube input data cube #' @return TRUE/FALSE .cube_has_unique_resolution <- function(cube) { - return(length(c(.cube_xres(cube), .cube_yres(cube))) == 2) + length(c(.cube_xres(cube), .cube_yres(cube))) == 2 } # ---- derived_cube ---- #' @title Get derived class of a cube @@ -1432,7 +1410,7 @@ NULL is_token_updated <- "token_expires" %in% colnames(fi_tile) && !.cube_is_token_expired(tile) - return(is_token_updated) + is_token_updated }) if (all(are_token_updated)) { diff --git a/R/api_data.R b/R/api_data.R index 98f80aef4..52e71739b 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -119,7 +119,7 @@ # add base class (`sits` is added as it is removed in the join above) class(ts_tbl) <- unique(c("sits_base", "sits", class(ts_tbl))) } - return(ts_tbl) + ts_tbl } #' @name .data_get_ts @@ -150,7 +150,7 @@ band = bands ) |> purrr::pmap(function(tile, band) { - return(list(tile, band)) + list(tile, band) }) # set output_dir output_dir <- tempdir() @@ -240,7 +240,7 @@ from = dates[[1]], to = dates[[length(dates)]] )) # return valid row of time series - return(sample) + sample }) ts <- .ts_get_raster_class( tile = tile, @@ -251,7 +251,7 @@ ts[["tile"]] <- tile_id ts[["#..id"]] <- seq_len(nrow(ts)) saveRDS(ts, filename) - return(ts) + ts }, progress = progress ) @@ -316,7 +316,7 @@ .data_check(nrow(samples), nrow(ts_tbl)) } class(ts_tbl) <- unique(c("predicted", "sits", class(ts_tbl))) - return(ts_tbl) + ts_tbl } #' @title Check if all points have been retrieved @@ -340,7 +340,7 @@ } else { message("All points have been retrieved") } - return(invisible(n_rows_input)) + invisible(n_rows_input) } #' @title Extracts the time series average by polygon. @@ -373,7 +373,7 @@ dplyr::select(!!colnames(data)) class(data_avg) <- class(data) - return(data_avg) + data_avg } #' @title get time series from data cubes on tile by tile bassis @@ -494,7 +494,7 @@ # store them in the sample tibble sample[["time_series"]] <- list(tibble::tibble(Index = dates)) # return valid row of time series - return(sample) + sample }) # extract time series ts <- .ts_get_raster_data( @@ -508,7 +508,7 @@ ts[["tile"]] <- tile_id ts[["#..id"]] <- seq_len(nrow(ts)) saveRDS(ts, filename) - return(ts) + ts }, progress = progress ) @@ -578,7 +578,7 @@ if (!inherits(ts_tbl, "sits")) { class(ts_tbl) <- c("sits", class(ts_tbl)) } - return(ts_tbl) + ts_tbl } #' @title get time series from data cubes using chunks #' @name .data_by_chunks @@ -699,7 +699,7 @@ # store them in the sample tibble sample[["time_series"]] <- list(tibble::tibble(Index = dates)) # return valid row of time series - return(sample) + sample }) # extract time series ts <- .ts_get_raster_data( @@ -713,7 +713,7 @@ ts[["tile"]] <- chunk[["tile"]] ts[["#..id"]] <- seq_len(nrow(ts)) saveRDS(ts, filename) - return(ts) + ts }, progress = progress) # bind rows to get a melted tibble of samples ts_tbl <- dplyr::bind_rows(samples_tiles_bands) @@ -783,7 +783,7 @@ if (!inherits(ts_tbl, "sits")) { class(ts_tbl) <- c("sits", class(ts_tbl)) } - return(ts_tbl) + ts_tbl } #' @title get time series from base tiles #' @name .data_base_tiles @@ -801,7 +801,7 @@ # retrieve values from samples # # read each tile - samples <- slider::slide_dfr(cube, function(tile){ + samples <- slider::slide_dfr(cube, function(tile) { # get XY xy_tb <- .proj_from_latlong( longitude = samples[["longitude"]], @@ -833,16 +833,16 @@ # get the values of the time series as matrix base_bands <- .tile_base_bands(tile) - samples <- purrr::map_dbl(base_bands, function(band){ + samples <- purrr::map_dbl(base_bands, function(band) { values_base_band <- .tile_base_extract( tile = tile, band = band, xy = xy ) samples[[band]] <- values_base_band - return(samples) + samples }) - return(samples) + samples }) } @@ -856,7 +856,7 @@ #' #' @return A tibble with a lat/long and respective classes. #' -.data_get_class <- function(cube, samples){ +.data_get_class <- function(cube, samples) { data <- slider::slide_dfr(cube, function(tile) { # convvert lat/long to tile CRS xy_tb <- .proj_from_latlong( @@ -899,9 +899,9 @@ samples[["label"]] <- unname(classes) samples <- dplyr::select(samples, dplyr::all_of("longitude"), dplyr::all_of("latitude"), dplyr::all_of("label")) - return(samples) + samples }) - return(data) + data } #' @title function to get probability values for a set of given locations @@ -915,14 +915,14 @@ #' #' @return A tibble with a list of lat/long and respective probs #' -.data_get_probs <- function(cube, samples, window_size){ +.data_get_probs <- function(cube, samples, window_size) { # get scale and offset band_conf <- .conf_derived_band( derived_class = "probs_cube", band = "probs" ) - - data <- slider::slide_dfr(cube, function(tile) { + # return data frame + slider::slide_dfr(cube, function(tile) { # convert lat/long to tile CRS xy_tb <- .proj_from_latlong( longitude = samples[["longitude"]], @@ -958,9 +958,8 @@ else samples <- .data_get_probs_pixel(tile, samples, xy, band_conf) - return(samples) + samples }) - return(data) } #' @title function to get probability values for a pixel #' @name .data_get_probs_pixel @@ -974,7 +973,7 @@ #' #' @return A tibble with a list of lat/long and respective probs #' -.data_get_probs_pixel <- function(tile, samples, xy, band_conf){ +.data_get_probs_pixel <- function(tile, samples, xy, band_conf) { # open spatial raster object rast <- .raster_open_rast(.tile_path(tile)) @@ -992,8 +991,7 @@ colnames(values) <- .tile_labels(tile) # insert classes into samples - samples <- dplyr::bind_cols(samples, values) - return(samples) + dplyr::bind_cols(samples, values) } #' @title function to get probability values for a window #' @name .data_get_probs_window @@ -1008,7 +1006,7 @@ #' #' @return A tibble with a list of lat/long and respective probs #' -.data_get_probs_window <- function(tile, samples, xy, band_conf, window_size){ +.data_get_probs_window <- function(tile, samples, xy, band_conf, window_size) { # open spatial raster object rast <- .raster_open_rast(.tile_path(tile)) # overlap in pixel @@ -1018,7 +1016,7 @@ ncols <- .raster_ncols(rast) # slide for each XY position - data <- slider::slide2_dfr(xy[,1], xy[,2], function(x,y){ + data <- slider::slide2_dfr(xy[, 1], xy[, 2], function(x, y) { # find the cells to be retrieved center_row <- .raster_row(rast, y) center_col <- .raster_col(rast, x) @@ -1047,6 +1045,5 @@ return(data) }) # insert classes into samples - samples <- dplyr::bind_cols(samples, data) - return(samples) + dplyr::bind_cols(samples, data) } diff --git a/R/api_detect_change.R b/R/api_detect_change.R index dd01c33cc..1a78e68fb 100644 --- a/R/api_detect_change.R +++ b/R/api_detect_change.R @@ -243,7 +243,7 @@ #' @noRd #' @export .detect_change_tile_prep.default <- function(dc_method, tile, ...) { - return(NULL) + NULL } #' @noRd #' @export @@ -328,9 +328,7 @@ return(values) } # Get only polygons segments - values <- suppressWarnings(sf::st_collection_extract(values, "POLYGON")) - # Return the segment object - return(values) + sf::st_collection_extract(values, "POLYGON") } #' @rdname .dc_samples #' @title Retrieve samples available in a given detect change method. @@ -364,7 +362,7 @@ } stats <- environment(dc_method)[["stats"]] stats <- unlist(lapply(stats, colnames)) - return(unique(stats)) + unique(stats) } #' @title Retrieve bands associated to detect_change method #' @name .dc_class diff --git a/R/api_download.R b/R/api_download.R index fbec926ce..6c2a8dad2 100644 --- a/R/api_download.R +++ b/R/api_download.R @@ -73,7 +73,7 @@ # Generate random seconds to wait before try again. This approach # is used to avoid flood the server. secs_to_retry <- .conf("download_sleep_time") - secs_to_retry <- sample(x = seq_len(secs_to_retry), size = 1) + secs_to_retry <- sample.int(secs_to_retry, size = 1) Sys.sleep(secs_to_retry) } # Return local asset diff --git a/R/api_dtw.R b/R/api_dtw.R index e5fcc7c25..1aa832836 100644 --- a/R/api_dtw.R +++ b/R/api_dtw.R @@ -16,7 +16,7 @@ # Windowed search distances <- purrr::map_df(windows, function(window) { # Get time-series in the window - data_in_window <- as.matrix(.ts_values(data[window,])) + data_in_window <- as.matrix(.ts_values(data[window, ])) # Calculate distance data.frame(distance = dtw_distance(data_in_window, pattern_ts)) }) @@ -128,7 +128,7 @@ detection_name <- detections_name[idx] detection_idx <- detections_idx[idx] # Extract detection distance (min one defined above) - detection_distance <- patterns_distances[detection_idx,] + detection_distance <- patterns_distances[detection_idx, ] detection_distance <- detection_distance[detection_name] detection_distance <- as.numeric(detection_distance) # Extract detection dates diff --git a/R/api_environment.R b/R/api_environment.R index 5173a83fa..d133ad85a 100644 --- a/R/api_environment.R +++ b/R/api_environment.R @@ -45,7 +45,7 @@ # Save variable do.call(Sys.setenv, var_target_new_value) }) - return(invisible(NULL)) + invisible(NULL) } #' @title Function to rollback patch in environment variables (Developer only). @@ -87,7 +87,7 @@ ) do.call(Sys.setenv, var_target_swap_value) }) - return(invisible(NULL)) + invisible(NULL) } # ---- Environment configurations ---- diff --git a/R/api_factory.R b/R/api_factory.R index 06443f0f6..aceceafb0 100644 --- a/R/api_factory.R +++ b/R/api_factory.R @@ -32,5 +32,5 @@ # ...otherwise compute the result on the input data result <- fun(data) } - return(result) + result } diff --git a/R/api_gdal.R b/R/api_gdal.R index 752a09b8b..11615f517 100644 --- a/R/api_gdal.R +++ b/R/api_gdal.R @@ -56,7 +56,7 @@ ) band_conf <- .tile_band_conf(asset, .tile_bands(asset)) gdal_params[["-a_nodata"]] <- .miss_value(band_conf) - return(gdal_params) + gdal_params } #' @title Format GDAL block parameters for data access #' @noRd @@ -151,15 +151,13 @@ #' @returns Called for side effects .gdal_addo <- function(base_file) { conf_cog <- .conf("gdal_presets", "cog") - suppressMessages( - sf::gdal_addo( - file = base_file, - method = conf_cog[["method"]], - overviews = conf_cog[["overviews"]], - options = c(GDAL_NUM_THREADS = "2") - ) + sf::gdal_addo( + file = base_file, + method = conf_cog[["method"]], + overviews = conf_cog[["overviews"]], + options = c(GDAL_NUM_THREADS = "2") ) - return(invisible(file)) + invisible(file) } #' @title Run gdal_translate from a block to a file #' @noRd @@ -216,7 +214,7 @@ } ) # Return file - return(file) + file } #' @title Merge files into a single file #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} @@ -360,7 +358,7 @@ ), quiet = TRUE ) - return(invisible(file)) + invisible(file) } #' @title Change the projection of an image and save to file #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} diff --git a/R/api_gdalcubes.R b/R/api_gdalcubes.R index e9f9ec414..f96b7e9df 100644 --- a/R/api_gdalcubes.R +++ b/R/api_gdalcubes.R @@ -26,32 +26,25 @@ ) # filter and change image order according to cloud coverage - cube <- .apply(cube, "file_info", function(x) { + .apply(cube, "file_info", function(x) { x <- dplyr::filter( x, .data[["date"]] >= timeline[[1]], .data[["date"]] < timeline[[length(timeline)]] ) - x <- dplyr::group_by( x, interval = cut(.data[["date"]], timeline, labels = FALSE), .add = TRUE ) - if ("cloud_cover" %in% names(x)) { x <- dplyr::arrange( x, .data[["cloud_cover"]], .by_group = TRUE ) } - x <- dplyr::select(dplyr::ungroup(x), -"interval") - - return(x) + dplyr::select(dplyr::ungroup(x), -"interval") }) - - return(cube) } - #' @title Create a cube_view object #' @name .gc_create_cube_view #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} @@ -106,20 +99,17 @@ t1 = format(date, "%Y-%m-%d") ) - # create a list of cube view - cv <- suppressMessages( - gdalcubes::cube_view( - extent = extent, - srs = .cube_crs(tile), - dt = period, - dx = res, - dy = res, - aggregation = agg_method, - resampling = resampling - ) + # create a list of cube views + gdalcubes::cube_view( + extent = extent, + srs = .cube_crs(tile), + dt = period, + dx = res, + dy = res, + aggregation = agg_method, + resampling = resampling ) - return(cv) } #' @title Create an gdalcubes::image_mask object @@ -165,8 +155,7 @@ } class(mask_values) <- "image_mask" - - return(mask_values) + mask_values } #' @title Create an image_collection object @@ -257,16 +246,11 @@ feature[["bbox"]] <- unlist(feature[["bbox"]]) feature }) - - ic_cube <- suppressMessages( - gdalcubes::stac_image_collection( - s = gc_data, - out_file = path_db, - url_fun = identity - ) + gdalcubes::stac_image_collection( + s = gc_data, + out_file = path_db, + url_fun = identity ) - - return(ic_cube) } #' @title Create a gdalcubes::pack object @@ -282,17 +266,14 @@ .gc_create_pack <- function(cube, band) { # set caller to show in errors .check_set_caller(".gc_create_pack") - conf <- .tile_band_conf(cube, band) - pack <- list( + list( type = .conf("gdalcubes_type_format"), nodata = .miss_value(conf), scale = 1, offset = 0 ) - - return(pack) } #' @title Create an gdalcubes::raster_cube object @@ -311,31 +292,17 @@ .gc_create_raster_cube <- function(cube_view, path_db, band, mask_band) { # set caller to show in errors .check_set_caller(".gc_create_raster_cube") - # open db in each process - img_col <- suppressMessages( - gdalcubes::image_collection(path = path_db) - ) - - # create a gdalcubes::raster_cube object - raster_cube <- suppressMessages( + path_db |> + gdalcubes::image_collection() |> gdalcubes::raster_cube( - image_collection = img_col, view = cube_view, mask = mask_band, chunking = .conf("gdalcubes_chunk_size") - ) - ) - - # filter band of raster_cube - raster_cube <- suppressMessages( + ) |> gdalcubes::select_bands( - cube = raster_cube, bands = band ) - ) - - return(raster_cube) } #' @title Get the timeline of intersection in all tiles @@ -397,7 +364,7 @@ if (extra_date_step) { tl <- c(tl, tl[[length(tl)]] %m+% lubridate::period(period)) } - return(tl) + tl } #' @title Saves the images of a raster cube. @@ -446,8 +413,7 @@ ) # post-condition .check_that(length(img_paths) >= 1) - - return(img_paths) + img_paths } #' @title Build a regular data cube from an irregular one diff --git a/R/api_view.R b/R/api_view.R index 6242ef8b1..344173f80 100644 --- a/R/api_view.R +++ b/R/api_view.R @@ -339,13 +339,6 @@ last_quantile, leaflet_megabytes) { # - # obtain the raster objects for the dates chosen - # check if date is inside the timeline - tile_dates <- .tile_timeline(tile) - if (!date %in% tile_dates) { - idx_date <- which.min(abs(date - tile_dates)) - date <- tile_dates[idx_date] - } # define which method is used if (length(bands) == 3) class(bands) <- c("rgb", class(bands)) diff --git a/R/sits_cube_local.R b/R/sits_cube_local.R index d314927a2..17dcad760 100644 --- a/R/sits_cube_local.R +++ b/R/sits_cube_local.R @@ -113,7 +113,7 @@ sits_cube.local_cube <- function( message("please, use 'bands' instead of 'band' as parameter") bands <- as.character(dots[["band"]]) } - .source_check(source = source) + .check_source(source = source) .check_source_collection(source = source, collection = collection) # builds a sits data cube diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R index 7c07ae2e2..0d17737a2 100644 --- a/R/sits_sample_functions.R +++ b/R/sits_sample_functions.R @@ -131,7 +131,7 @@ sits_confidence_sampling <- function(probs_cube, .check_int_parameter(memsize, min = 1, max = 16384) # get labels - cube_labels <- .cube_labels(probs_cube) + labels <- .cube_labels(probs_cube) # The following functions define optimal parameters for parallel processing # @@ -179,7 +179,7 @@ sits_confidence_sampling <- function(probs_cube, # Process jobs in parallel .jobs_map_parallel_dfr(chunks, function(chunk) { # Get samples for each label - purrr::map2_dfr(cube_labels, seq_along(cube_labels), + purrr::map2_dfr(labels, seq_along(labels), function(lab, i) { # Get a list of values of high confidence & apply threshold top_values <- .raster_open_rast(tile_path) |> @@ -312,14 +312,14 @@ sits_sampling_design <- function(cube, .check_that(inherits(cube, "class_cube") || inherits(cube, "class_vector_cube")) # get the labels - cube_labels <- .cube_labels(cube) - n_labels <- length(cube_labels) + labels <- .cube_labels(cube) + n_labels <- length(labels) if (length(expected_ua) == 1) { expected_ua <- rep(expected_ua, n_labels) - names(expected_ua) <- cube_labels + names(expected_ua) <- labels } # check names of labels - .check_that(all(names(expected_ua) %in% cube_labels)) + .check_that(all(names(expected_ua) %in% labels)) # get cube class areas class_areas <- .cube_class_areas(cube) # define which classes from the selected ones are available in the cube. @@ -332,7 +332,7 @@ sits_sampling_design <- function(cube, class_areas <- class_areas[available_classes] expected_ua <- expected_ua[available_classes] # check that names of class areas are contained in the labels - .check_that(all(names(class_areas) %in% cube_labels), + .check_that(all(names(class_areas) %in% labels), msg = .conf("messages", "sits_sampling_design_labels")) # calculate proportion of class areas prop <- class_areas / sum(class_areas) @@ -446,12 +446,12 @@ sits_stratified_sampling <- function(cube, .check_that(inherits(cube, "class_cube") || inherits(cube, "class_vector_cube")) # get the labels - cube_labels <- .cube_labels(cube) - n_labels <- length(cube_labels) + labels <- .cube_labels(cube) + n_labels <- length(labels) # check number of labels .check_that(nrow(sampling_design) <= n_labels) # check names of labels - .check_that(all(rownames(sampling_design) %in% cube_labels)) + .check_that(all(rownames(sampling_design) %in% labels)) # check allocation method .check_that(alloc %in% colnames(sampling_design), msg = .conf("messages", "sits_stratified_sampling_alloc")) @@ -466,8 +466,8 @@ sits_stratified_sampling <- function(cube, # check progress progress <- .message_progress(progress) # transform labels to tibble - cube_labels <- tibble::rownames_to_column( - as.data.frame(cube_labels), var = "label_id" + labels <- tibble::rownames_to_column( + as.data.frame(labels), var = "label_id" ) |> dplyr::mutate(label_id = as.numeric(.data[["label_id"]])) # transform sampling design data to tibble @@ -478,7 +478,7 @@ sits_stratified_sampling <- function(cube, # correct class / values from the cube samples_class <- dplyr::inner_join( x = sampling_design, - y = cube_labels, + y = labels, by = "labels" ) |> dplyr::select("labels", "label_id", dplyr::all_of(alloc)) |> diff --git a/R/sits_segmentation.R b/R/sits_segmentation.R index 0eb04e465..59f3fb42b 100644 --- a/R/sits_segmentation.R +++ b/R/sits_segmentation.R @@ -180,9 +180,9 @@ sits_segment <- function(cube, on.exit(.parallel_stop(), add = TRUE) # Segmentation # Process each tile sequentially - .cube_foreach_tile(cube, function(tile) { + segs_cube <- .cube_foreach_tile(cube, function(tile) { # Segment the data - .segments_tile( + segs_tile <- .segments_tile( tile = tile, seg_fn = seg_fn, band = "segments", @@ -193,7 +193,9 @@ sits_segment <- function(cube, version = version, progress = progress ) + segs_tile }) + segs_cube } #' @title Segment an image using SLIC @@ -350,7 +352,9 @@ sits_slic <- function(data = NULL, yres <- v_obj[["y"]] * .raster_yres(v_temp) - .raster_yres(v_temp) / 2 v_obj[["x"]] <- as.vector(v_ext)[[1]] + xres v_obj[["y"]] <- as.vector(v_ext)[[4]] - yres - # Get only polygons segments and return them - suppressWarnings(sf::st_collection_extract(v_obj, "POLYGON")) + # Get only polygons segments + v_obj <- sf::st_collection_extract(v_obj, "POLYGON") + # Return the segment object + return(v_obj) } } diff --git a/R/sits_summary.R b/R/sits_summary.R index ca438908f..097e10c18 100644 --- a/R/sits_summary.R +++ b/R/sits_summary.R @@ -296,27 +296,30 @@ summary.variance_cube <- function( sample_size = 10000, quantiles = c("75%", "80%", "85%", "90%", "95%", "100%")) { .check_set_caller("summary_variance_cube") + # Get cube labels + labels <- unname(.cube_labels(object)) # Extract variance values for each tiles using a sample size var_values <- slider::slide(object, function(tile) { # get the bands band <- .tile_bands(tile) # extract the file path + file <- .tile_paths(tile) # read the files with terra - rast <- .raster_open_rast(.tile_paths(tile)) + r <- .raster_open_rast(file) # get the a sample of the values - values <- rast |> + values <- r |> .raster_sample(size = sample_size, na.rm = TRUE) # scale the values band_conf <- .tile_band_conf(tile, band) - band_scale <- .scale(band_conf) - band_offset <- .offset(band_conf) - values <- values * band_scale + band_offset + scale <- .scale(band_conf) + offset <- .offset(band_conf) + values <- values * scale + offset values }) # Combine variance values var_values <- dplyr::bind_rows(var_values) # Update columns name - colnames(var_values) <- .cube_labels(object) + colnames(var_values) <- labels # Extract quantile for each column var_values <- dplyr::reframe( var_values, @@ -325,8 +328,8 @@ summary.variance_cube <- function( }) ) # Update row names - perc_intervals <- paste0(seq(from = 0, to = 1, by = intervals) * 100, "%") - rownames(var_values) <- perc_intervals + percent_intervals <- paste0(seq(from = 0, to = 1, by = intervals)*100, "%") + rownames(var_values) <- percent_intervals # Return variance values filtered by quantiles return(var_values[quantiles, ]) } diff --git a/R/sits_view.R b/R/sits_view.R index e99c7bb1e..5be272095 100644 --- a/R/sits_view.R +++ b/R/sits_view.R @@ -324,13 +324,13 @@ sits_view.raster_cube <- function(x, ..., cube <- dplyr::filter(x, .data[["tile"]] %in% tiles) # create a new layer in the leaflet for (i in seq_len(nrow(cube))) { - tile_row <- cube[i, ] - tile_name <- tile_row[["tile"]] + row <- cube[i, ] + tile_name <- row[["tile"]] # check dates if (.has(dates)) - .check_dates_timeline(dates, tile_row) + .check_dates_timeline(dates, row) else - dates <- .fi_date_least_cloud_cover(.fi(tile_row)) + dates <- .fi_date_least_cloud_cover(.fi(row)) for (date in dates) { # convert to proper date view_date <- lubridate::as_date(date) @@ -412,22 +412,22 @@ sits_view.uncertainty_cube <- function(x, ..., # create a new layer in the leaflet for (i in seq_len(nrow(cube))) { - tile_row <- cube[i, ] - tile_name <- tile_row[["tile"]] - band <- .tile_bands(tile_row) + row <- cube[i, ] + tile_name <- row[["tile"]] + band <- .tile_bands(row) # add group group <- paste(tile_name, band) # recover global leaflet and include group overlay_groups <- append(overlay_groups, group) # get image file associated to band - band_file <- .tile_path(tile_row, band) + band_file <- .tile_path(row, band) # scale and offset - band_conf <- .tile_band_conf(tile_row, band) + band_conf <- .tile_band_conf(row, band) # view image raster leaf_map <- leaf_map |> .view_bw_band( group = group, - tile = tile_row, + tile = row, band_file = band_file, band_conf = band_conf, palette = palette, @@ -580,8 +580,8 @@ sits_view.probs_cube <- function(x, ..., # create a new layer in the leaflet for (i in seq_len(nrow(cube))) { - tile_row <- cube[i, ] - tile_name <- tile_row[["tile"]] + row <- cube[i, ] + tile_name <- row[["tile"]] # add group group <- paste(tile_name, "probs", label) # recover global leaflet and include group @@ -590,7 +590,7 @@ sits_view.probs_cube <- function(x, ..., leaf_map <- leaf_map |> .view_probs_label( group = group, - tile = tile_row, + tile = row, date = as.Date(date), labels = cube_labels, label = label, @@ -640,8 +640,8 @@ sits_view.vector_cube <- function(x, ..., cube <- dplyr::filter(x, .data[["tile"]] %in% tiles) # create a new layer in the leaflet for (i in seq_len(nrow(cube))) { - tile_row <- cube[i, ] - tile_name <- tile_row[["tile"]] + row <- cube[i, ] + tile_name <- row[["tile"]] group <- paste(tile_name, "segments") # recover global leaflet and include group overlay_groups <- append(overlay_groups, group) @@ -649,7 +649,7 @@ sits_view.vector_cube <- function(x, ..., leaf_map <- leaf_map |> .view_segments( group = group, - tile = tile_row, + tile = row, seg_color = seg_color, line_width = line_width ) @@ -702,8 +702,8 @@ sits_view.class_vector_cube <- function(x, ..., cube <- dplyr::filter(x, .data[["tile"]] %in% tiles) # create a new layer in the leaflet for (i in seq_len(nrow(cube))) { - tile_row <- cube[i, ] - tile_name <- tile_row[["tile"]] + row <- cube[i, ] + tile_name <- row[["tile"]] # add group group <- paste(tile_name, "class_segments") # add version if available @@ -715,7 +715,7 @@ sits_view.class_vector_cube <- function(x, ..., leaf_map <- leaf_map |> .view_vector_class_cube( group = group, - tile = tile_row, + tile = row, seg_color = seg_color, line_width = line_width, opacity = opacity, diff --git a/inst/extdata/lintr-tests/failed_tests.R b/inst/extdata/lintr-tests/failed_tests.R index 0c8551ff0..4bf44d70c 100644 --- a/inst/extdata/lintr-tests/failed_tests.R +++ b/inst/extdata/lintr-tests/failed_tests.R @@ -1,34 +1,4 @@ ── Failed tests ─────────────────────────────────────────────────────────────────────────────────────────────────────────────────── -Error (test-samples.R:61:5): Sampling design -Error in `dplyr::inner_join(x = sampling_design, y = cube_labels, by = "labels")`: Join columns in `y` must be present in the data. -x Problem with `labels`. -Backtrace: - ▆ -1. └─sits::sits_stratified_sampling(...) at test-samples.R:61:5 -2. ├─dplyr::rename(...) at sits/R/sits_sample_functions.R:479:5 -3. ├─dplyr::select(...) -4. ├─dplyr::inner_join(x = sampling_design, y = cube_labels, by = "labels") -5. └─dplyr:::inner_join.data.frame(x = sampling_design, y = cube_labels, by = "labels") -6. └─dplyr:::join_mutate(...) -7. └─dplyr:::join_cols(...) -8. └─dplyr:::check_join_vars(by$y, y_names, by$condition, "y", error_call = error_call) -9. └─rlang::abort(bullets, call = error_call) - -Error (test-samples.R:112:5): Sampling design with class cube from STAC -Error in `dplyr::inner_join(x = sampling_design, y = cube_labels, by = "labels")`: Join columns in `y` must be present in the data. -x Problem with `labels`. -Backtrace: - ▆ -1. └─sits::sits_stratified_sampling(...) at test-samples.R:112:5 -2. ├─dplyr::rename(...) at sits/R/sits_sample_functions.R:479:5 -3. ├─dplyr::select(...) at sits/R/sits_sample_functions.R:479:5 -4. ├─dplyr::inner_join(x = sampling_design, y = cube_labels, by = "labels") at sits/R/sits_sample_functions.R:479:5 -5. └─dplyr:::inner_join.data.frame(x = sampling_design, y = cube_labels, by = "labels") -6. └─dplyr:::join_mutate(...) -7. └─dplyr:::join_cols(...) -8. └─dplyr:::check_join_vars(by$y, y_names, by$condition, "y", error_call = error_call) -9. └─rlang::abort(bullets, call = error_call) - Error (test-segmentation.R:18:5): Segmentation Error in `purrr::map(rounds, function(round) { @@ -113,61 +83,7 @@ Backtrace: 24. └─cli::cli_abort(...) 25. └─rlang::abort(...) -Error (test-summary.R:73:5): summary sits area accuracy -Error in `dplyr::reframe(var_values, dplyr::across(.cols = dplyr::all_of(labels), - function(x) { - stats::quantile(x, probs = seq(0, 1, intervals)) - }))`: i In argument: `dplyr::across(...)`. -Caused by error in `across()`: - i In argument: `dplyr::all_of(labels)`. -Caused by error in `dplyr::all_of()`: - ! Can't subset elements. -x Subscript must be numeric or character, not a function. -Backtrace: - ▆ - 1. ├─utils::capture.output(suppressWarnings(summary(variance_cube))) at test-summary.R:73:5 - 2. │ └─base::withVisible(...elt(i)) - 3. ├─base::suppressWarnings(summary(variance_cube)) - 4. │ └─base::withCallingHandlers(...) - 5. ├─base::summary(variance_cube) - 6. ├─sits:::summary.variance_cube(variance_cube) - 7. │ ├─dplyr::reframe(...) at sits/R/sits_summary.R:321:5 - 8. │ └─dplyr:::reframe.data.frame(...) - 9. │ └─dplyr:::summarise_cols(.data, dplyr_quosures(...), by, "reframe") - 10. │ ├─base::withCallingHandlers(...) - 11. │ └─dplyr:::expand_across(dot) - 12. │ └─dplyr:::across_setup(...) - 13. │ └─tidyselect::eval_select(cols, data = data, error_call = error_call) - 14. │ └─tidyselect:::eval_select_impl(...) - 15. │ ├─tidyselect:::with_subscript_errors(...) - 16. │ │ └─base::withCallingHandlers(...) - 17. │ └─tidyselect:::vars_select_eval(...) - 18. │ └─tidyselect:::walk_data_tree(expr, data_mask, context_mask) - 19. │ └─tidyselect:::eval_context(expr, context_mask, call = error_call) - 20. │ ├─tidyselect:::with_chained_errors(...) - 21. │ │ └─base::withCallingHandlers(...) - 22. │ └─rlang::eval_tidy(as_quosure(expr, env), context_mask) - 23. ├─dplyr::all_of(labels) - 24. │ └─tidyselect:::as_indices_impl(x, vars = vars, strict = TRUE) - 25. │ └─vctrs::vec_as_subscript(x, logical = "error", call = call, arg = arg) - 26. ├─rlang::cnd_signal(x) - 27. │ └─rlang:::signal_abort(cnd) - 28. │ └─base::signalCondition(cnd) - 29. ├─tidyselect (local) ``(``) - 30. │ └─cli::cli_abort(c(i = msg), call = call, parent = cnd) - 31. │ └─rlang::abort(...) - 32. │ └─rlang:::signal_abort(cnd, .file) - 33. │ └─base::signalCondition(cnd) - 34. └─dplyr (local) ``(``) - 35. └─dplyr (local) handler(cnd) - 36. └─rlang::abort(message, class = error_class, parent = parent, call = error_call) - -Error (test-view.R:1:1): View - -Error: C stack usage 7974040 is too close to the limit + └─rlang::abort(message, class = error_class, parent = parent, call = error_call) -Error (test-view.R:176:1): View BDC cube - -Error: C stack usage 7970280 is too close to the limit [ FAIL 8 | WARN 0 | SKIP 5 | PASS 1431 ] diff --git a/tests/testthat/test-segmentation.R b/tests/testthat/test-segmentation.R index 9c322f2a8..dbb8d9b2f 100644 --- a/tests/testthat/test-segmentation.R +++ b/tests/testthat/test-segmentation.R @@ -18,7 +18,7 @@ test_that("Segmentation", { segments <- sits_segment( cube = sinop, output_dir = output_dir, - multicores = 2, + multicores = 1, memsize = 24, progress = FALSE, version = "vt" @@ -202,8 +202,7 @@ test_that("Segmentation of large files",{ output_dir = output_dir ) ) - expect_true(.check_cube_is_regular(modis_cube_local)) - expect_true(all(sits_bands(modis_cube_local) %in% c("EVI", "NDVI"))) + .check_cube_is_regular(modis_cube_local) segments <- sits_segment( cube = modis_cube_local, seg_fn = sits_slic( diff --git a/tests/testthat/test-view.R b/tests/testthat/test-view.R index 80ce389b0..02a11888d 100644 --- a/tests/testthat/test-view.R +++ b/tests/testthat/test-view.R @@ -1,6 +1,7 @@ test_that("View", { v1 <- sits_view(cerrado_2classes) - expect_true("leaflet" %in% class(v1)) + lf <- sits:::sits_env$leaflet + expect_equal(lf$overlay_groups, "samples") # create a data cube data_dir <- system.file("extdata/raster/mod13q1", package = "sits") @@ -19,19 +20,8 @@ test_that("View", { palette = "RdYlGn" ) expect_true("leaflet" %in% class(v2)) - expect_true(grepl("EPSG3857", v2$x$options$crs$crsClass)) - expect_equal(v2$x$calls[[6]]$args[[2]], "012010 2013-09-14 NDVI") - - # view the data cube RGB - vrgb <- sits_view(modis_cube, - red = "NDVI", - green = "NDVI", - blue = "NDVI" - ) - expect_true("leaflet" %in% class(vrgb)) - expect_true(grepl("EPSG3857", vrgb$x$options$crs$crsClass)) - expect_equal(vrgb$x$calls[[4]]$args[[4]], - "012010 2013-09-14 NDVI NDVI NDVI") + lf <- sits:::sits_env$leaflet + expect_equal(lf$overlay_groups, "012010 2013-09-14 NDVI") # create a probs cube rf_model <- sits_train(samples_modis_ndvi, sits_rfor()) @@ -65,15 +55,15 @@ test_that("View", { # view RGB data cube and class cube together v4rgb <- sits_view(modis_cube, - red = "NDVI", - green = "NDVI", - blue = "NDVI", - dates = timeline[[1]], - class_cube = modis_label + band = "NDVI", + dates = timeline[[1]] ) expect_true(grepl("EPSG3857", v4rgb$x$options$crs$crsClass)) expect_equal(v4rgb$x$calls[[1]]$method, "addProviderTiles") + # view RGB data cube and class cube together + v4rgb_class <- sits_view(modis_label, add = TRUE) + # create uncert cube modis_uncert <- sits_uncertainty( cube = modis_probs, @@ -87,7 +77,7 @@ test_that("View", { expect_equal(v5$x$calls[[6]]$args[[2]], "012010 entropy") # view uncert cube and class cube - v6 <- sits_view(modis_uncert, class_cube = modis_label) + v6 <- sits_view(modis_label, add = TRUE) expect_true(grepl("EPSG3857", v6$x$options$crs$crsClass)) expect_equal(v6$x$calls[[1]]$method, "addProviderTiles") expect_equal(v6$x$calls[[1]]$args[[1]], "Esri.WorldImagery") @@ -132,7 +122,7 @@ test_that("View", { version = "v_segs_test" ) - v9 <- sits_view(class_segs, band = "NDVI", class_cube = modis_label) + v9 <- sits_view(class_segs, band = "NDVI") expect_true(grepl("EPSG3857", v9$x$options$crs$crsClass)) expect_identical(v9$x$calls[[1]]$method, "addProviderTiles") expect_identical(v9$x$calls[[1]]$args[[1]], "Esri.WorldImagery") @@ -159,18 +149,6 @@ test_that("View class cube from STAC", { ) v1 <- sits_view(to_class) expect_true("leaflet" %in% class(v1)) - - # view with dates - timeline <- sits_timeline(to_class) - - # view the data cube - v2 <- sits_view(to_class, - band = "CLASS", - dates = timeline[[1]], - palette = "RdYlGn" - ) - expect_true("leaflet" %in% class(v2)) - expect_true(grepl("EPSG3857", v2$x$options$crs$crsClass)) }) test_that("View BDC cube",{ @@ -179,7 +157,7 @@ test_that("View BDC cube",{ sits_cube( source = "BDC", collection = "CBERS-WFI-16D", - bands = c("B13", "B15", "B16"), + bands = c("B13", "B14", "B15", "B16"), tiles = c("007004", "007005"), start_date = "2018-09-01", end_date = "2018-09-28", @@ -194,16 +172,11 @@ test_that("View BDC cube",{ testthat::skip_if(purrr::is_null(cbers_cube), message = "BDC is not accessible" ) - v_cb <- sits_view(cbers_cube, - tiles = c("007004", "007005"), - red = "B15", - green = "B16", - blue = "B13", - dates = "2018-08-29") + v_cb <- sits_view(cbers_cube) expect_identical(v_cb$x$options$crs$crsClass, "L.CRS.EPSG3857") expect_identical(v_cb$x$calls[[1]]$args[[1]], "Esri.WorldImagery") - expect_identical(v_cb$x$calls[[5]]$method, "addRasterImage") + expect_identical(v_cb$x$calls[[5]]$method, "addLayersControl") }) test_that("View SOM map", { From fcdfcd46ca6a79441e02f3c0380d586ff6e8a893 Mon Sep 17 00:00:00 2001 From: Gilberto Camara Date: Sat, 12 Apr 2025 19:33:31 -0300 Subject: [PATCH 082/122] fix bug in sits_segment --- R/sits_segmentation.R | 12 ++++++------ man/sits_segment.Rd | 4 ++-- man/sits_slic.Rd | 6 +++--- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/R/sits_segmentation.R b/R/sits_segmentation.R index 59f3fb42b..c84aec91d 100644 --- a/R/sits_segmentation.R +++ b/R/sits_segmentation.R @@ -117,8 +117,8 @@ sits_segment <- function(cube, impute_fn = impute_linear(), start_date = NULL, end_date = NULL, - memsize = 1, - multicores = 1, + memsize = 4L, + multicores = 2L, output_dir, version = "v1", progress = TRUE) { @@ -285,12 +285,12 @@ sits_segment <- function(cube, #' } #' @export sits_slic <- function(data = NULL, - step = 30, + step = 30L, compactness = 1, dist_fun = "euclidean", avg_fun = "median", - iter = 30, - minarea = 10, + iter = 30L, + minarea = 10L, verbose = FALSE) { # set caller for error msg .check_set_caller("sits_slic") @@ -325,7 +325,7 @@ sits_slic <- function(data = NULL, clean = TRUE, centers = TRUE, dist_name = dist_fun, dist_fun = function() "", avg_fun_fun = function() "", avg_fun_name = avg_fun, iter = iter, minarea = minarea, - input_centers = matrix(c(0, 0), ncol = 2), + input_centers = matrix(c(0L, 0L), ncol = 2), verbose = as.integer(verbose) ) # Set values and NA value in template raster diff --git a/man/sits_segment.Rd b/man/sits_segment.Rd index 25d8c2935..6795f06f0 100644 --- a/man/sits_segment.Rd +++ b/man/sits_segment.Rd @@ -11,8 +11,8 @@ sits_segment( impute_fn = impute_linear(), start_date = NULL, end_date = NULL, - memsize = 1, - multicores = 1, + memsize = 4L, + multicores = 2L, output_dir, version = "v1", progress = TRUE diff --git a/man/sits_slic.Rd b/man/sits_slic.Rd index aee4dfb8b..8d8e9dd52 100644 --- a/man/sits_slic.Rd +++ b/man/sits_slic.Rd @@ -6,12 +6,12 @@ \usage{ sits_slic( data = NULL, - step = 30, + step = 30L, compactness = 1, dist_fun = "euclidean", avg_fun = "median", - iter = 30, - minarea = 10, + iter = 30L, + minarea = 10L, verbose = FALSE ) } From 2d83afd2751fcb7e9848ece1185b90e23ccb9b02 Mon Sep 17 00:00:00 2001 From: Gilberto Camara Date: Sat, 12 Apr 2025 23:15:33 -0300 Subject: [PATCH 083/122] fix check_source message --- inst/extdata/config_messages.yml | 1 + tests/testthat/test-config.R | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index e08fc3572..d76eef3a0 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -98,6 +98,7 @@ .check_samples_ts_bands: "all time series should have the same bands" .check_samples_validation: "invalid validation samples" .check_smoothness: "smoothness must be either one value or a named vector with a value for each label" +.check_source: "data provider is not available or sits is not configured to access it" .check_source_collection: "collection is not available in data provider or sits is not configured to access it" .check_stac_items: "collection search returned no items\n check 'roi', 'start_date', 'end_date', and 'tile' parameters" .check_shp_attribute: "attribute missing in shapefile - check 'shp_attr' parameter" diff --git a/tests/testthat/test-config.R b/tests/testthat/test-config.R index df3712a6a..8d29628ca 100644 --- a/tests/testthat/test-config.R +++ b/tests/testthat/test-config.R @@ -92,7 +92,7 @@ test_that("User functions", { expect_error( .check_source_collection(source = "ZZZ", collection = "ZZZ"), - ".source_check: invalid source parameter" + ".check_source: invalid source parameter" ) expect_error( From e0f778ee9eba40a3e6c7b2df5b630c9712a34210 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Mon, 21 Apr 2025 22:51:43 -0300 Subject: [PATCH 084/122] quasi-final version with lintr corrections --- DESCRIPTION | 1 - NAMESPACE | 1 + R/api_accuracy.R | 26 +- R/api_apply.R | 51 ++- R/api_band.R | 10 +- R/api_bayts.R | 4 +- R/api_bbox.R | 2 +- R/api_block.R | 10 +- R/api_check.R | 559 ++++++++++++++++++++-------- R/api_chunks.R | 60 +-- R/api_classify.R | 207 +++++----- R/api_clean.R | 10 +- R/api_cluster.R | 26 +- R/api_colors.R | 41 +- R/api_combine_predictions.R | 36 +- R/api_comp.R | 18 +- R/api_conf.R | 244 ++++++------ R/api_crop.R | 14 +- R/api_csv.R | 56 ++- R/api_cube.R | 140 ++++--- R/api_data.R | 107 +++--- R/api_debug.R | 6 +- R/api_detect_change.R | 72 ++-- R/api_download.R | 6 +- R/api_dtw.R | 24 +- R/api_file.R | 2 +- R/api_file_info.R | 27 +- R/api_gdal.R | 24 +- R/api_gdalcubes.R | 2 +- R/api_grid.R | 34 +- R/api_jobs.R | 7 +- R/api_kohonen.R | 222 +++++------ R/api_label_class.R | 42 +-- R/api_merge.R | 196 +++++----- R/api_message.R | 16 +- R/api_mixture_model.R | 14 +- R/api_ml_model.R | 22 +- R/api_mosaic.R | 24 +- R/api_opensearch.R | 23 +- R/api_parallel.R | 49 +-- R/api_period.R | 2 +- R/api_plot_raster.R | 87 ++--- R/api_plot_time_series.R | 80 ++-- R/api_plot_vector.R | 15 +- R/api_preconditions.R | 132 ------- R/api_predictors.R | 31 +- R/api_raster.R | 151 +++----- R/api_raster_sub_image.R | 21 +- R/api_reclassify.R | 20 +- R/api_reduce.R | 19 +- R/api_regularize.R | 33 +- R/api_request.R | 4 +- R/api_request_httr2.R | 16 +- R/api_roi.R | 20 +- R/api_samples.R | 52 ++- R/api_segments.R | 25 +- R/api_select.R | 10 +- R/api_sf.R | 95 ++--- R/api_shp.R | 14 +- R/api_signal.R | 22 +- R/api_smooth.R | 16 +- R/api_smote.R | 26 +- R/api_som.R | 73 ++-- R/api_source.R | 104 ++---- R/api_source_aws.R | 13 +- R/api_source_bdc.R | 12 +- R/api_source_cdse.R | 44 ++- R/api_source_deafrica.R | 62 +-- R/api_source_deaustralia.R | 28 +- R/api_source_hls.R | 26 +- R/api_source_local.R | 146 +++----- R/api_source_mpc.R | 101 +++-- R/api_source_sdc.R | 8 +- R/api_source_stac.R | 79 ++-- R/api_source_terrascope.R | 18 +- R/api_source_usgs.R | 27 +- R/api_space_time_operations.R | 10 +- R/api_stac.R | 28 +- R/api_stats.R | 4 +- R/api_texture.R | 11 +- R/api_tibble.R | 83 ++--- R/api_tile.R | 97 ++--- R/api_timeline.R | 67 ++-- R/api_tmap.R | 44 +-- R/api_torch.R | 24 +- R/api_torch_psetae.R | 117 +++--- R/api_ts.R | 24 +- R/api_tuning.R | 28 +- R/api_uncertainty.R | 34 +- R/api_utils.R | 10 +- R/api_values.R | 8 +- R/api_variance.R | 12 +- R/api_vector_info.R | 3 +- R/api_view.R | 87 +++-- R/sits_accuracy.R | 24 +- R/sits_add_base_cube.R | 5 +- R/sits_apply.R | 14 +- R/sits_bands.R | 4 +- R/sits_bayts.R | 6 +- R/sits_classify.R | 43 ++- R/sits_clean.R | 46 ++- R/sits_cluster.R | 12 +- R/sits_colors.R | 8 +- R/sits_combine_predictions.R | 20 +- R/sits_csv.R | 11 +- R/sits_cube.R | 6 +- R/sits_cube_copy.R | 8 +- R/sits_cube_local.R | 8 +- R/sits_detect_change.R | 14 +- R/sits_detect_change_method.R | 3 +- R/sits_filters.R | 4 +- R/sits_geo_dist.R | 5 +- R/sits_get_class.R | 4 +- R/sits_get_data.R | 24 +- R/sits_get_probs.R | 4 +- R/sits_histogram.R | 30 +- R/sits_label_classification.R | 12 +- R/sits_labels.R | 4 +- R/sits_lighttae.R | 35 +- R/sits_machine_learning.R | 66 ++-- R/sits_merge.R | 17 +- R/sits_mixture_model.R | 16 +- R/sits_mlp.R | 36 +- R/sits_mosaic.R | 4 +- R/sits_patterns.R | 10 +- R/sits_plot.R | 194 +++++----- R/sits_reclassify.R | 12 +- R/sits_reduce.R | 8 +- R/sits_reduce_imbalance.R | 26 +- R/sits_regularize.R | 34 +- R/sits_sample_functions.R | 34 +- R/sits_segmentation.R | 44 +-- R/sits_select.R | 2 +- R/sits_smooth.R | 20 +- R/sits_som.R | 28 +- R/sits_stars.R | 6 +- R/sits_summary.R | 21 +- R/sits_tae.R | 26 +- R/sits_tempcnn.R | 58 +-- R/sits_terra.R | 12 +- R/sits_texture.R | 18 +- R/sits_timeline.R | 6 +- R/sits_tuning.R | 26 +- R/sits_uncertainty.R | 38 +- R/sits_validate.R | 21 +- R/sits_variance.R | 12 +- R/sits_view.R | 62 +-- R/sits_xlsx.R | 18 +- inst/extdata/config_messages.yml | 53 +-- man/dot-check_date_parameter.Rd | 4 +- man/hist.probs_cube.Rd | 2 +- man/hist.raster_cube.Rd | 9 +- man/hist.sits.Rd | 9 +- man/hist.uncertainty_cube.Rd | 2 +- man/plot.class_cube.Rd | 4 +- man/plot.class_vector_cube.Rd | 2 +- man/plot.dem_cube.Rd | 4 +- man/plot.probs_cube.Rd | 4 +- man/plot.probs_vector_cube.Rd | 2 +- man/plot.raster_cube.Rd | 4 +- man/plot.sar_cube.Rd | 4 +- man/plot.uncertainty_cube.Rd | 4 +- man/plot.uncertainty_vector_cube.Rd | 2 +- man/plot.variance_cube.Rd | 4 +- man/plot.vector_cube.Rd | 4 +- man/plot.xgb_model.Rd | 2 +- man/print.sits_area_accuracy.Rd | 2 +- man/sits_as_stars.Rd | 2 +- man/sits_as_terra.Rd | 8 +- man/sits_classify.raster_cube.Rd | 4 +- man/sits_classify.segs_cube.Rd | 6 +- man/sits_classify.sits.Rd | 4 +- man/sits_confidence_sampling.Rd | 8 +- man/sits_cube.stac_cube.Rd | 2 +- man/sits_cube_copy.Rd | 4 +- man/sits_formula_linear.Rd | 2 +- man/sits_formula_logref.Rd | 2 +- man/sits_geo_dist.Rd | 2 +- man/sits_get_data.csv.Rd | 2 +- man/sits_get_data.data.frame.Rd | 2 +- man/sits_get_data.sf.Rd | 4 +- man/sits_get_data.shp.Rd | 4 +- man/sits_get_data.sits.Rd | 2 +- man/sits_kfold_validate.Rd | 8 +- man/sits_lighttae.Rd | 8 +- man/sits_mixture_model.Rd | 6 +- man/sits_mlp.Rd | 8 +- man/sits_mosaic.Rd | 2 +- man/sits_patterns.Rd | 2 +- man/sits_reduce_imbalance.Rd | 6 +- man/sits_rfor.Rd | 2 +- man/sits_sampling_design.Rd | 2 +- man/sits_sgolay.Rd | 2 +- man/sits_som_map.Rd | 8 +- man/sits_svm.Rd | 8 +- man/sits_tae.Rd | 8 +- man/sits_tempcnn.Rd | 14 +- man/sits_timeseries_to_csv.Rd | 1 + man/sits_tuning.Rd | 10 +- man/sits_uncertainty.Rd | 8 +- man/sits_uncertainty_sampling.Rd | 8 +- man/sits_validate.Rd | 4 +- man/sits_view.Rd | 32 +- man/sits_xgboost.Rd | 12 +- man/summary.variance_cube.Rd | 2 +- tests/testthat/test-data.R | 25 +- tests/testthat/test-plot.R | 7 +- 207 files changed, 3083 insertions(+), 3276 deletions(-) delete mode 100644 R/api_preconditions.R diff --git a/DESCRIPTION b/DESCRIPTION index 703579c34..f2c3a175a 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -157,7 +157,6 @@ Collate: 'api_plot_vector.R' 'api_point.R' 'api_predictors.R' - 'api_preconditions.R' 'api_raster.R' 'api_raster_sub_image.R' 'api_reclassify.R' diff --git a/NAMESPACE b/NAMESPACE index de1f7236f..ed5256dfb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -99,6 +99,7 @@ S3method(.detect_change_tile_prep,bayts_model) S3method(.detect_change_tile_prep,default) S3method(.gc_arrange_images,raster_cube) S3method(.get_request,httr2) +S3method(.merge,dem_case) S3method(.ml_normalize,default) S3method(.ml_normalize,torch_model) S3method(.mosaic_split_band_date,derived_cube) diff --git a/R/api_accuracy.R b/R/api_accuracy.R index 7f06fe23f..dd8bea265 100644 --- a/R/api_accuracy.R +++ b/R/api_accuracy.R @@ -49,12 +49,12 @@ # Create the error matrix error_matrix <- table( factor(pred, - levels = labels_cube, - labels = labels_cube + levels = labels_cube, + labels = labels_cube ), factor(ref, - levels = labels_cube, - labels = labels_cube + levels = labels_cube, + labels = labels_cube ) ) # Get area for each class of the cube @@ -63,13 +63,13 @@ # In the case where some classes are not in the classified cube, but # are in the validation file diff_classes <- setdiff(rownames(error_matrix), names(area)) - if (length(diff_classes) > 0 && + if (length(diff_classes) > 0L && length(diff_classes) < length(rownames(error_matrix))) { - warning(.conf("messages", ".accuracy_area_assess"), - call. = FALSE - ) + warning(.conf("messages", ".accuracy_area_assess"), + call. = FALSE + ) # Create a numeric vector with zeros - vec_areas <- rep(0, length(diff_classes)) + vec_areas <- rep(0L, length(diff_classes)) names(vec_areas) <- diff_classes # Join with all area classes area <- c(area, vec_areas) @@ -90,7 +90,7 @@ # weighted by the area of the classes # cf equation (1) of Olofsson et al (2013) prop <- weight * error_matrix / class_areas - prop[is.na(prop)] <- 0 + prop[is.na(prop)] <- 0.0 # unbiased estimator of the total area # based on the reference classification @@ -99,7 +99,7 @@ # Estimated standard error of the estimated area proportion # cf equation (3) of Olofsson et al (2013) - stderr_prop <- sqrt(colSums((weight * prop - prop**2) / (class_areas - 1))) + stderr_prop <- sqrt(colSums((weight * prop - prop**2L) / (class_areas - 1L))) # standard error of the error-adjusted estimated area # cf equation (4) of Olofsson et al (2013) @@ -205,8 +205,8 @@ coords = sf::st_coordinates(.data[["geom"]]) ) |> dplyr::mutate( - longitude = .data[["coords"]][, 1], - latitude = .data[["coords"]][, 2] + longitude = .data[["coords"]][, 1L], + latitude = .data[["coords"]][, 2L] ) |> dplyr::select( "label", "longitude", "latitude" diff --git a/R/api_apply.R b/R/api_apply.R index dab970cbd..730275eb6 100644 --- a/R/api_apply.R +++ b/R/api_apply.R @@ -20,13 +20,15 @@ # prepare to unpack x[["#.."]] <- seq_len(nrow(data)) # unpack - x <- tidyr::unnest(x, cols = dplyr::all_of(col)) - x <- dplyr::group_by(x, .data[["#.."]]) + x <- x |> + tidyr::unnest(cols = dplyr::all_of(col)) |> + dplyr::group_by(.data[["#.."]]) # apply user function x <- fn(x, ...) # pack - x <- dplyr::ungroup(x) - x <- tidyr::nest(x, `..unnest_col` = -"#..") + x <- x |> + dplyr::ungroup() |> + tidyr::nest(`..unnest_col` = -"#..") # remove garbage x[["#.."]] <- NULL names(x) <- col @@ -63,7 +65,7 @@ # Resume feature if (.raster_is_valid(out_file, output_dir = output_dir)) { # recovery message - .check_recovery(out_file) + .check_recovery() # Create tile based on template feature <- .tile_eo_from_files( @@ -86,6 +88,8 @@ if (normalized) band_conf <- .conf("default_values", "INT2S") } + band_offset <- .offset(band_conf) + band_scale <- .scale(band_conf) # Process jobs sequentially block_files <- .jobs_map_sequential(chunks, function(chunk) { # Get job block @@ -116,14 +120,10 @@ ) ) # Prepare fractions to be saved - band_offset <- .offset(band_conf) - if (.has(band_offset) && band_offset != 0.0) { + if (band_offset != 0.0) values <- values - band_offset - } - band_scale <- .scale(band_conf) - if (.has(band_scale) && band_scale != 1.0) { + if (band_scale != 1.0) values <- values / band_scale - } # Job crop block crop_block <- .block(.chunks_no_overlap(chunk)) # Prepare and save results as raster @@ -139,17 +139,15 @@ block_files }) # Merge blocks into a new eo_cube tile - band_tile <- .tile_eo_merge_blocks( + .tile_eo_merge_blocks( files = out_file, bands = out_band, band_conf = band_conf, base_tile = feature, block_files = block_files, - multicores = 1, + multicores = 1L, update_bbox = FALSE ) - # Return a feature tile - band_tile } #' @title Read data for the apply operation #' @name .apply_data_read @@ -222,7 +220,7 @@ substitute(list(...), env = environment()), unlist, recursive = FALSE - )[-1] + )[-1L] # Check bands names from expression .check_expression(list_expr) @@ -246,10 +244,8 @@ .apply_input_bands <- function(cube, bands, expr) { # set caller to show in errors .check_set_caller(".apply_input_bands") - # Get all required bands in expression - expr_bands <- toupper(.apply_get_all_names(expr[[1]])) - + expr_bands <- toupper(.apply_get_all_names(expr[[1L]])) # Select bands that are in input expression bands <- bands[bands %in% expr_bands] # Post-condition @@ -262,12 +258,11 @@ #' @keywords internal #' @noRd #' @param expr Expression. -#' #' @return Character vector with all names in expression. #' .apply_get_all_names <- function(expr) { if (is.call(expr)) { - unique(unlist(lapply(as.list(expr)[-1], .apply_get_all_names))) + unique(unlist(lapply(as.list(expr)[-1L], .apply_get_all_names))) } else if (is.name(expr)) { paste0(expr) } else { @@ -288,43 +283,43 @@ w_median = function(m) { C_kernel_median( x = as.matrix(m), ncols = img_ncol, nrows = img_nrow, - band = 0, window_size = window_size + band = 0L, window_size = window_size ) }, w_mean = function(m) { C_kernel_mean( x = as.matrix(m), ncols = img_ncol, nrows = img_nrow, - band = 0, window_size = window_size + band = 0L, window_size = window_size ) }, w_sd = function(m) { C_kernel_sd( x = as.matrix(m), ncols = img_ncol, nrows = img_nrow, - band = 0, window_size = window_size + band = 0L, window_size = window_size ) }, w_min = function(m) { C_kernel_min( x = as.matrix(m), ncols = img_ncol, nrows = img_nrow, - band = 0, window_size = window_size + band = 0L, window_size = window_size ) }, w_max = function(m) { C_kernel_max( x = as.matrix(m), ncols = img_ncol, nrows = img_nrow, - band = 0, window_size = window_size + band = 0L, window_size = window_size ) }, w_var = function(m) { C_kernel_var( x = as.matrix(m), ncols = img_ncol, nrows = img_nrow, - band = 0, window_size = window_size + band = 0L, window_size = window_size ) }, w_modal = function(m) { C_kernel_modal( x = as.matrix(m), ncols = img_ncol, nrows = img_nrow, - band = 0, window_size = window_size + band = 0L, window_size = window_size ) } ), parent = parent.env(environment()), hash = TRUE) diff --git a/R/api_band.R b/R/api_band.R index 12983d9c4..c3bcc754b 100644 --- a/R/api_band.R +++ b/R/api_band.R @@ -52,8 +52,8 @@ ) .apply(x, col = "file_info", fn = function(x) { x <- tidyr::pivot_wider(x, - names_from = "band", - values_from = "path" + names_from = "band", + values_from = "path" ) # create a conversor @@ -143,7 +143,9 @@ .check_that(all(bands %in% .cube_bands(cube))) return(bands) } - .band_best_guess(cube) + bands <- .band_best_guess(cube) + message(.conf("messages", ".plot_band_best_guess")) + bands } #' @title Make a best guess on bands to be displayed #' @name .band_best_guess @@ -175,5 +177,5 @@ "NDVI" # return the first band if all fails else - cube_bands[[1]] + cube_bands[[1L]] } diff --git a/R/api_bayts.R b/R/api_bayts.R index d7cd1b806..ae78ff434 100644 --- a/R/api_bayts.R +++ b/R/api_bayts.R @@ -17,8 +17,8 @@ ) # Transform to long form names_prefix <- NULL - if (length(bands) > 1) { - names_prefix <- paste0(bands, collapse = ",") + if (length(bands) > 1L) { + names_prefix <- paste(bands, collapse = ",") } stats <- samples |> tidyr::pivot_longer( diff --git a/R/api_bbox.R b/R/api_bbox.R index 16d876a47..80b4e2572 100644 --- a/R/api_bbox.R +++ b/R/api_bbox.R @@ -176,7 +176,7 @@ NULL # Check for a valid bbox .check_bbox(bbox) # Check if there are multiple CRS in bbox - if (length(.crs(bbox)) > 1 && is.null(as_crs)) { + if (length(.crs(bbox)) > 1L && .has_not(as_crs)) { .message_warnings_bbox_as_sf() as_crs <- "EPSG:4326" } diff --git a/R/api_block.R b/R/api_block.R index 061ced5a7..e97252a0d 100644 --- a/R/api_block.R +++ b/R/api_block.R @@ -26,8 +26,8 @@ NULL if (!.has_block(x)) { return(NULL) } - xcol <- .default(x = .col(x), default = 1) - xrow <- .default(x = .row(x), default = 1) + xcol <- .default(x = .col(x), default = 1L) + xrow <- .default(x = .row(x), default = 1L) # Return a block .common_size(col = xcol, row = xrow, ncols = .ncols(x), nrows = .nrows(x)) } @@ -36,8 +36,8 @@ NULL #' @param block A block. #' @param overlap Pixels to increase/decrease block `ncols` and `nrows`. #' @returns The size of a block with overlaps. -.block_size <- function(block, overlap = 0) { - (.nrows(block) + 2 * overlap) * (.ncols(block) + 2 * overlap) +.block_size <- function(block, overlap = 0L) { + (.nrows(block) + 2L * overlap) * (.ncols(block) + 2L * overlap) } #' @title Block accessors #' @noRd @@ -143,6 +143,6 @@ NULL #' @param block A block. #' @returns A block with the size fixed .block_regulate_size <- function(block) { - block[block == 1] <- 2 + block[block == 1L] <- 2L block } diff --git a/R/api_check.R b/R/api_check.R index c86d135a3..f90e5ea66 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -93,8 +93,8 @@ #' @return Called for side effects .check_set_caller <- function(caller) { envir <- parent.frame() - if (length(sys.frames()) > 1) { - envir <- sys.frame(-1) + if (length(sys.frames()) > 1L) { + envir <- sys.frame(-1L) } assign(".check_caller", caller, envir = envir) } @@ -116,10 +116,10 @@ return(caller) } # no caller defined, get first function in calling stack - caller <- sys.calls()[[1]] + caller <- sys.calls()[[1L]] caller <- gsub( pattern = "^(.*)\\(.*$", replacement = "\\1", - x = paste(caller)[[1]] + x = paste(caller)[[1L]] ) } #' @rdname check_functions @@ -188,7 +188,7 @@ .check_that <- function(x, ..., local_msg = NULL, msg = NULL) { - value <- (is.logical(x) && all(x)) || (!is.logical(x) && length(x) > 0) + value <- (is.logical(x) && all(x)) || (!is.logical(x) && length(x) > 0L) if (!value) { # get caller function name caller <- .check_identify_caller() @@ -228,7 +228,18 @@ ) } } - +#' @rdname check_functions +#' @keywords internal +#' @noRd +.check_content_data_frame <- function(x, ..., + local_msg = NULL, msg = NULL) { + .check_set_caller(".check_content_data_frame") + .check_that( + nrow(x) > 0L, + local_msg = local_msg, + msg = msg + ) +} #' @rdname check_functions #' @keywords internal #' @noRd @@ -238,7 +249,7 @@ local_msg = NULL, msg = NULL) { # cannot test zero length arguments - if (length(x) == 0) { + if (.has_not(x)) { return(invisible(x)) } if (is_named) { @@ -266,8 +277,8 @@ #' @keywords internal #' @noRd .check_length <- function(x, ..., - len_min = 0, - len_max = 2^31 - 1, + len_min = 0L, + len_max = 100000L, local_msg = NULL, msg = NULL) { .check_that( @@ -343,7 +354,7 @@ # test integer if (is_integer) { # if length is zero there is nothing to check - if (length(x) == 0) { + if (.has_not(x)) { return(invisible(x)) } .check_that( @@ -417,8 +428,8 @@ #' @noRd .check_lgl <- function(x, ..., allow_na = FALSE, - len_min = 0, - len_max = 2^31 - 1, + len_min = 0L, + len_max = 100000L, allow_null = FALSE, is_named = FALSE, local_msg = NULL, @@ -451,13 +462,13 @@ max = Inf, exclusive_min = -Inf, exclusive_max = Inf, - len_min = 0, - len_max = 2^31 - 1, + len_min = 0L, + len_max = 100000L, allow_null = FALSE, is_integer = FALSE, is_named = FALSE, is_odd = FALSE, - tolerance = 0, + tolerance = 0.0, local_msg = NULL, msg = NULL) { # check for NULL and exit if it is allowed @@ -490,7 +501,7 @@ msg = msg ) if (is_odd) - .check_that(x %% 2 != 0, msg = msg) + .check_that(x %% 2L != 0L, msg = msg) } #' @rdname check_functions #' @keywords internal @@ -500,7 +511,7 @@ max = Inf, exclusive_min = -Inf, exclusive_max = Inf, - tolerance = 0, + tolerance = 0.0, local_msg = NULL, msg = NULL) { @@ -557,8 +568,8 @@ allow_na = FALSE, allow_empty = TRUE, allow_duplicate = TRUE, - len_min = 0, - len_max = 2^31 - 1, + len_min = 0L, + len_max = 100000L, allow_null = FALSE, is_named = FALSE, has_unique_names = TRUE, @@ -583,7 +594,7 @@ # check empty if (!allow_empty) { .check_that( - all(nchar(x[!is.na(x)]) > 0), + all(nchar(x[!is.na(x)]) > 0L), local_msg = local_msg, msg = msg ) @@ -591,7 +602,7 @@ # check duplicate if (!allow_duplicate) { .check_that( - anyDuplicated(x) == 0, + anyDuplicated(x) == 0L, local_msg = local_msg, msg = msg ) @@ -617,8 +628,8 @@ #' @keywords internal #' @noRd .check_lst <- function(x, ..., - len_min = 0, - len_max = 2^31 - 1, + len_min = 0L, + len_max = 100000L, allow_null = FALSE, is_named = TRUE, fn_check = NULL, @@ -703,7 +714,7 @@ # pre-condition .check_chr( within, - len_min = 1, + len_min = 1L, local_msg = local_msg_w, msg = msg ) @@ -728,37 +739,34 @@ within <- tolower(within) } # check discriminator - if (discriminator == "one_of") { - .check_that( - sum(x %in% within) == 1, - local_msg = local_msg_x, - msg = msg - ) - } else if (discriminator == "any_of") { - .check_that( - any(x %in% within), - local_msg = local_msg_x, - msg = msg - ) - } else if (discriminator == "all_of") { - .check_that( - all(x %in% within), - local_msg = local_msg_x, - msg = msg - ) - } else if (discriminator == "none_of") { - .check_that( - !any(x %in% within), - local_msg = local_msg_x, - msg = msg - ) - } else if (discriminator == "exactly") { - .check_that( - all(x %in% within) && all(within %in% x), - local_msg = local_msg_x, - msg = msg - ) - } + # check discriminator + switch(discriminator, + one_of = .check_that( + sum(x %in% within) == 1L, + local_msg = local_msg_x, + msg = msg + ), + any_of = .check_that( + any(x %in% within), + local_msg = local_msg_x, + msg = msg + ), + all_of = .check_that( + all(x %in% within), + local_msg = local_msg_x, + msg = msg + ), + none_of = .check_that( + !any(x %in% within), + local_msg = local_msg_x, + msg = msg + ), + exactly = .check_that( + all(x %in% within) && all(within %in% x), + local_msg = local_msg_x, + msg = msg + ) + ) } #' @rdname check_functions #' @keywords internal @@ -781,7 +789,7 @@ # make default message for param local_msg_cont <- .message_invalid_param(var_cont) # pre-condition - .check_that(length(contains) >= 1, local_msg = local_msg_cont) + .check_that(.has(contains), local_msg = local_msg_cont) # check discriminators .check_discriminator(discriminator) # check for repeated values @@ -801,37 +809,33 @@ contains <- tolower(contains) } # check discriminator - if (discriminator == "one_of") { - .check_that( - sum(contains %in% x) == 1, - local_msg = local_msg_x, - msg = msg - ) - } else if (discriminator == "any_of") { - .check_that( - any(contains %in% x), - local_msg = local_msg_x, - msg = msg - ) - } else if (discriminator == "all_of") { - .check_that( - all(contains %in% x), - local_msg = local_msg_x, - msg = msg - ) - } else if (discriminator == "none_of") { - .check_that( - !any(contains %in% x), - local_msg = local_msg_x, - msg = msg - ) - } else if (discriminator == "exactly") { - .check_that( - all(contains %in% x) && all(x %in% contains), - local_msg = local_msg_x, - msg = msg - ) - } + switch(discriminator, + one_of = .check_that( + sum(contains %in% x) == 1L, + local_msg = local_msg_x, + msg = msg + ), + any_of = .check_that( + any(contains %in% x), + local_msg = local_msg_x, + msg = msg + ), + all_of = .check_that( + all(contains %in% x), + local_msg = local_msg_x, + msg = msg + ), + none_of = .check_that( + !any(contains %in% x), + local_msg = local_msg_x, + msg = msg + ), + exactly = .check_that( + all(contains %in% x) && all(x %in% contains), + local_msg = local_msg_x, + msg = msg + ) + ) } #' @rdname check_functions #' @@ -870,7 +874,7 @@ x, allow_na = FALSE, allow_empty = FALSE, - len_min = 1, + len_min = 1L, allow_null = FALSE, local_msg = local_msg, msg = msg @@ -917,7 +921,7 @@ # make default message for param local_msg <- .message_invalid_param(parameter_name) # check env var exists - .check_that(nchar(Sys.getenv(x)) > 0, local_msg = local_msg) + .check_that(nchar(Sys.getenv(x)) > 0L, local_msg = local_msg) invisible(x) } #' @title Check warning @@ -1023,13 +1027,13 @@ .check_num_parameter <- function(x, min = -Inf, max = Inf, - len_min = 1, - len_max = 1, + len_min = 1L, + len_max = 1L, allow_na = FALSE, allow_null = FALSE, is_named = FALSE, exclusive_min = -Inf, - tolerance = 0, + tolerance = 0.0, msg = NULL) { # check parameter name param <- deparse(substitute(x, environment())) @@ -1063,7 +1067,7 @@ #' @keywords internal #' @noRd .check_lgl_parameter <- function(x, - len_min = 1, len_max = 1, + len_min = 1L, len_max = 1L, allow_na = FALSE, allow_null = FALSE, is_named = FALSE, msg = NULL) { @@ -1093,8 +1097,8 @@ #' @return Called for side effects. #' @keywords internal .check_date_parameter <- function(x, - len_min = 1, - len_max = 1, + len_min = 1L, + len_max = 1L, allow_null = FALSE, msg = NULL) { .check_set_caller(".check_date_parameter") @@ -1117,8 +1121,8 @@ #' @return Called for side effects. #' @keywords internal #' @noRd -.check_int_parameter <- function(x, min = -2^31 + 1, max = 2^31 - 1, - len_min = 1, len_max = 2^31 - 1, +.check_int_parameter <- function(x, min = -2147483647L, max = 2147483647L, + len_min = 1L, len_max = 100000L, is_odd = FALSE, is_named = FALSE, allow_null = FALSE, msg = NULL) { # check parameter name @@ -1157,8 +1161,8 @@ #' @keywords internal #' @noRd .check_chr_parameter <- function(x, - len_min = 1, - len_max = 2^31 - 1, + len_min = 1L, + len_max = 100000L, is_named = FALSE, allow_na = FALSE, allow_empty = FALSE, @@ -1188,8 +1192,8 @@ #' @keywords internal #' @noRd .check_lst_parameter <- function(x, ..., - len_min = 1, - len_max = 2^31 - 1, + len_min = 1L, + len_max = 100000L, allow_null = FALSE, is_named = TRUE, fn_check = NULL, @@ -1267,8 +1271,8 @@ allow_na = FALSE, allow_null = FALSE, allow_empty = FALSE, - len_min = 1, - len_max = 1 + len_min = 1L, + len_max = 1L ) output_dir <- .file_path_expand(output_dir) .check_file(output_dir) @@ -1291,7 +1295,7 @@ .check_expression <- function(list_expr) { .check_lst( list_expr, - len_min = 1, len_max = 1, + len_min = 1L, len_max = 1L, msg = .conf("messages", ".check_expression") ) } @@ -1414,13 +1418,13 @@ .check_set_caller(".check_is_results_cube") .check_that(.has(bands) && all(bands %in% .conf("sits_results_bands"))) # results cube should have only one band - .check_that(length(bands) == 1) + .check_that(length(bands) == 1L) # is label parameter was provided in labelled cubes? if (bands %in% c("probs", "bayes")) { .check_chr( labels, - len_min = 1, + len_min = 1L, allow_duplicate = FALSE, is_named = TRUE, msg = .conf("messages", ".check_is_results_cube_probs") @@ -1430,26 +1434,7 @@ if (bands == "class") { .check_length( labels, - len_min = 2, - is_named = TRUE, - msg = .conf("messages", ".check_is_results_cube_class") - ) - } - # is label parameter was provided in labelled cubes? - if (bands %in% c("probs", "bayes")) { - .check_chr( - labels, - len_min = 1, - allow_duplicate = FALSE, - is_named = TRUE, - msg = .conf("messages", ".check_is_results_cube_probs") - ) - } - # labels should be named in class cubes? - if (bands == "class") { - .check_length( - labels, - len_min = 2, + len_min = 2L, is_named = TRUE, msg = .conf("messages", ".check_is_results_cube_class") ) @@ -1499,7 +1484,7 @@ .check_set_caller(".check_samples") .check_na_null_parameter(data) .check_that(all(.conf("df_sample_columns") %in% colnames(data))) - .check_that(nrow(data) > 0) + .check_content_data_frame(data) } #' @title Does the input contain the cols of time series? #' @name .check_samples.default @@ -1527,7 +1512,7 @@ rast <- tryCatch( .raster_open_rast(.tile_path(x)), error = function(e) { - return(NULL) + NULL }) # return error if data is not accessible .check_that(.has(rast)) @@ -1570,7 +1555,7 @@ .check_set_caller(".check_samples_ts_bands") # check if all samples have the same bands n_bands <- unique(lengths(data[["time_series"]])) - .check_that(length(n_bands) == 1) + .check_that(length(n_bands) == 1L) } #' @title Can the input data be used for training? #' @name .check_samples_train @@ -1679,8 +1664,8 @@ if (inherits(samples, "sits_base")) n_bands_base <- length(.samples_base_bands(samples)) else - n_bands_base <- 0 - .check_that(ncol(pred) == 2 + n_bands * n_times + n_bands_base) + n_bands_base <- 0L + .check_that(ncol(pred) == 2L + n_bands * n_times + n_bands_base) } #' @title Does the data contain the cols of sample data and is not empty? #' @name .check_smoothness @@ -1691,7 +1676,7 @@ #' @noRd .check_smoothness <- function(smoothness, nlabels) { .check_set_caller(".check_smoothness") - .check_that(length(smoothness) == 1 || length(smoothness) == nlabels) + .check_that(length(smoothness) == 1L || length(smoothness) == nlabels) } #' @title Check if data contains predicted and reference values #' @name .check_pred_ref_match @@ -1749,7 +1734,7 @@ #' @noRd .check_labels_named <- function(data) { .check_set_caller(".check_labels_named") - .check_chr(data, len_min = 1, is_named = TRUE) + .check_chr(data, len_min = 1L, is_named = TRUE) } #' @title Does the class cube contain enough labels? #' @name .check_labels_class_cube @@ -1972,7 +1957,7 @@ #' @return Called for side effects. .check_cubes_same_timeline <- function(cube1, cube2) { .check_set_caller(".check_cubes_same_timeline") - .check_that(all(.cube_timeline(cube1)[[1]] == .cube_timeline(cube2)[[1]])) + .check_that(all(.cube_timeline(cube1)[[1L]] == .cube_timeline(cube2)[[1L]])) } #' @title Check if two cubes have the same organization #' @name .check_cubes_match @@ -2001,12 +1986,12 @@ .check_probs_cube_lst <- function(cubes) { .check_set_caller(".check_probs_cube_lst") .check_that(is.list(cubes)) - .check_that(length(cubes) >= 2) + .check_that(length(cubes) >= 2L) # is every cube a probs cube? purrr::map(cubes, .check_is_probs_cube) # check same size - first <- cubes[[1]] - for (i in 2:length(cubes)) { + first <- cubes[[1L]] + for (i in 2L:length(cubes)) { .check_cubes_match(first, cubes[[i]]) } } @@ -2019,13 +2004,13 @@ #' @return Called for side effects .check_uncert_cube_lst <- function(uncert_cubes) { .check_set_caller(".check_uncert_cube_lst") - .check_that(length(uncert_cubes) >= 2) + .check_that(length(uncert_cubes) >= 2L) .check_that(is.list(uncert_cubes)) # is every cube a probs cube purrr::map(uncert_cubes, .check_is_uncert_cube) # check same size - first <- uncert_cubes[[1]] - for (i in 2:length(uncert_cubes)) { + first <- uncert_cubes[[1L]] + for (i in 2L:length(uncert_cubes)) { .check_cubes_same_size(first, uncert_cubes[[i]]) } } @@ -2041,11 +2026,11 @@ .check_error_matrix_area <- function(error_matrix, area) { .check_set_caller(".check_error_matrix_area") .check_that( - x = all(dim(error_matrix) > 1), + x = all(dim(error_matrix) > 1L), msg = .conf("messages", ".check_error_matrix_area_dim") ) .check_that( - x = length(unique(dim(error_matrix))) == 1, + x = length(unique(dim(error_matrix))) == 1L, msg = .conf("messages", ".check_error_matrix_square") ) .check_that( @@ -2089,7 +2074,7 @@ #' @noRd .check_empty_data_frame <- function(x, msg = NULL, ...) { .check_set_caller(".check_empty_data_frame") - .check_that(nrow(x) > 0) + .check_content_data_frame(x) } #' @title Checks if the endmembers parameter is valid #' @name .check_endmembers_parameter @@ -2134,7 +2119,7 @@ .check_endmembers_fracs <- function(em) { .check_set_caller(".check_endmembers_fracs") # Pre-condition - .check_that(all(length(.endmembers_fracs(em)) >= 1)) + .check_that(all(length(.endmembers_fracs(em)) >= 1L)) } #' @title Checks if the bands required by endmembers exist #' @name .check_endmembers_bands @@ -2157,8 +2142,7 @@ #' @noRd .check_documentation <- function(progress) { # if working on sits documentation mode, no progress bar - Sys.getenv("SITS_DOCUMENTATION_MODE") != "true" && - Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" + !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") } #' @title Checks if messages should be displayed #' @name .check_messages @@ -2167,9 +2151,8 @@ #' @keywords internal #' @noRd .check_messages <- function() { - # if working on sits documentation mode, no progress bar - Sys.getenv("SITS_DOCUMENTATION_MODE") != "true" && - Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" + # if working on sits documentation mode, messages + !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") } #' @title Checks if STAC items are correct @@ -2183,7 +2166,7 @@ # set caller to show in errors .check_set_caller(".check_stac_items") .check_null_parameter(items) - .check_that(rstac::items_length(items) > 0) + .check_that(rstac::items_length(items) > 0L) } #' @title Checks recovery #' @name .check_recovery @@ -2191,7 +2174,7 @@ #' @return Called for side effects #' @keywords internal #' @noRd -.check_recovery <- function(data) { +.check_recovery <- function() { if (.check_messages()) { message(.conf("messages", ".check_recovery")) } @@ -2204,6 +2187,7 @@ #' @keywords internal #' @noRd .check_discriminator <- function(discriminator) { + .check_set_caller(".check_discriminator") # allowed discriminators and its print values discriminators <- c( one_of = "be only one of", @@ -2212,13 +2196,8 @@ none_of = "be none of", exactly = "be exactly" ) - if (length(discriminator) != 1 || - !discriminator %in% names(discriminators)) { - stop(".check_chr_within: discriminator should be one of", - "'one_of', 'any_of', 'all_of', 'none_of', or 'exactly'.", - call. = TRUE - ) - } + .check_that(length(discriminator) == 1L && + discriminator %in% names(discriminators)) } #' @title Check if the provided object is a vector #' @name .check_vector_object @@ -2259,7 +2238,7 @@ .check_tiles <- function(tiles) { .check_set_caller(".check_tiles") # pre-condition - .check_that(length(tiles) >= 1) + .check_that(.has(tiles)) } #' @title Checks palette #' @name .check_palette @@ -2344,7 +2323,7 @@ # get the data frame associated to the shapefile shp_df <- sf::st_drop_geometry(sf_shape) if (.has(shp_attr)) - .check_that(length(as.character(shp_df[1, (shp_attr)])) > 0) + .check_that(length(as.character(shp_df[1L, (shp_attr)])) > 0L) } #' @title Checks validation file #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} @@ -2477,7 +2456,7 @@ # .check_unique_period <- function(cube) { .check_that( - x = length(.cube_period(cube)) == 1, + x = length(.cube_period(cube)) == 1L, msg = .conf("messages", ".check_unique_period") ) } @@ -2491,7 +2470,7 @@ # source is upper case source <- toupper(source) # check source - .check_chr(source, len_min = 1, len_max = 1) + .check_chr(source, len_min = 1L, len_max = 1L) .check_chr_within(source, within = .sources()) } #' @name .check_source_collection @@ -2504,11 +2483,33 @@ # set calller for error msg .check_set_caller(".check_source_collection") # check collection - .check_chr_parameter(collection, len_min = 1, len_max = 1) + .check_chr_parameter(collection, len_min = 1L, len_max = 1L) .check_chr_within(collection, within = .source_collections(source = source) ) } +#' @name .check_source_collection_token +#' @noRd +#' @description checks if a collection +#' needs environmental variables. +#' +#' @return Called for side effects +#' +.check_source_collection_token <- function(source, collection) { + .check_set_caller(".check_source_collection_token") + token <- .try( + .conf( + "sources", source, + "collections", collection, + "token_vars" + ), + .default = "NO_TOKEN" + ) + # Pre-condition - try to find the access key as an environment variable + if (token != "NO_TOKEN") + .check_env_var(token) + +} #' @title Check band availability #' @name .check_bands_collection #' @description Checks if the requested bands are available in the collection @@ -2522,7 +2523,7 @@ #' @return Called for side effects. .check_bands_collection <- function(source, collection, bands) { # set caller to show in errors - .check_set_caller(".conf_check_bands") + .check_set_caller(".check_bands_collection") sits_bands <- .source_bands( source = source, @@ -2537,3 +2538,233 @@ within = c(sits_bands, source_bands) ) } +#' @name .check_tiles_source_collection +#' @noRd +#' @description checks if a collection +#' requires tiles to be defined +#' @return Called for side effects +#' +.check_tiles_source_collection <- function(source, collection, tiles) { + .check_set_caller(".check_tiles_source_collection") + res <- .try( + .conf( + "sources", source, + "collections", collection, + "tile_required" + ), + .default = "false" + ) + if (res) { + # Are the tiles provided? + .check_chr_parameter( + x = tiles, + allow_empty = FALSE, + len_min = 1L + ) + } +} +#' @title Check that the requested bands exist in the samples +#' @name .check_tibble_bands +#' @keywords internal +#' @noRd +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' +#' @param samples Time series with the samples +#' @param bands Requested bands of the data sample +#' @return Called for side effects. +#' +.check_tibble_bands <- function(samples, bands) { + # set caller to show in errors + .check_set_caller(".check_tibble_bands") + .check_chr_within( + x = bands, + within = .samples_bands(samples) + ) +} +#' @title Preconditions for multi-layer perceptron +#' @name .ckeck_pre_sits_mlp +#' +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' +#' @param samples Time series with the training samples. +#' @param epochs Number of iterations to train the model. +#' @param batch_size Number of samples per gradient update. +#' @param layers Vector with number of hidden nodes in each layer. +#' @param dropout_rates Vector with the dropout rates (0,1) +#' for each layer. +#' @param patience Number of epochs without improvements until +#' training stops. +#' @param min_delta Minimum improvement in loss function +#' to reset the patience counter. +#' @param verbose Verbosity mode (TRUE/FALSE). Default is FALSE. +#' @keywords internal +#' @noRd +#' @return Called for side effects. +#' +.check_pre_sits_mlp <- function(samples, epochs, batch_size, + layers, dropout_rates, + patience, min_delta, verbose) { + # Pre-conditions: + .check_samples_train(samples) + .check_int_parameter(epochs) + .check_int_parameter(batch_size) + .check_int_parameter(layers) + .check_num_parameter(dropout_rates, min = 0.0, max = 1.0, + len_min = length(layers), len_max = length(layers) + ) + .check_that(length(layers) == length(dropout_rates), + msg = .conf("messages", "sits_mlp_layers_dropout") + ) + .check_int_parameter(patience) + .check_num_parameter(min_delta, min = 0.0) + .check_lgl_parameter(verbose) +} +#' @title Preconditions for temporal convolutional neural network models +#' @name .check_pre_sits_tempcnn +#' +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' +#' @param samples Time series with the training samples. +#' @param cnn_layers Number of 1D convolutional filters per layer +#' @param cnn_kernels Size of the 1D convolutional kernels. +#' @param cnn_dropout_rates Dropout rates for 1D convolutional filters. +#' @param dense_layer_nodes Number of nodes in the dense layer. +#' @param dense_layer_dropout_rate Dropout rate (0,1) for the dense layer. +#' @param epochs Number of iterations to train the model. +#' @param batch_size Number of samples per gradient update. +#' @param lr_decay_epochs Number of epochs to reduce learning rate. +#' @param lr_decay_rate Decay factor for reducing learning rate. +#' @param patience Number of epochs without improvements until +#' training stops. +#' @param min_delta Minimum improvement in loss function +#' to reset the patience counter. +#' @param verbose Verbosity mode (TRUE/FALSE). Default is FALSE. +#' +#' @keywords internal +#' @noRd +#' +#' @return Called for side effects. +#' +.check_pre_sits_tempcnn <- function(samples, cnn_layers, cnn_kernels, + cnn_dropout_rates, dense_layer_nodes, + dense_layer_dropout_rate, epochs, batch_size, + lr_decay_epochs, lr_decay_rate, + patience, min_delta, verbose) { + # Pre-conditions: + .check_samples_train(samples) + .check_int_parameter(cnn_layers, len_max = 2L^31L - 1L) + .check_int_parameter(cnn_kernels, + len_min = length(cnn_layers), + len_max = length(cnn_layers)) + .check_num_parameter(cnn_dropout_rates, min = 0.0, max = 1.0, + len_min = length(cnn_layers), + len_max = length(cnn_layers)) + .check_int_parameter(dense_layer_nodes, len_max = 1L) + .check_num_parameter(dense_layer_dropout_rate, + min = 0.0, max = 1.0, len_max = 1L) + .check_int_parameter(epochs) + .check_int_parameter(batch_size) + .check_int_parameter(lr_decay_epochs) + .check_num_parameter(lr_decay_rate, exclusive_min = 0.0, max = 1.0) + .check_int_parameter(patience) + .check_num_parameter(min_delta, min = 0.0) + .check_lgl_parameter(verbose) +} +#' @title Preconditions for Lightweight Temporal Self-Attention Encoder +#' and Temporal Self-Attention Encoder. +#' @name .check_pre_sits_lighttae +#' +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' +#' @param samples Time series with the training samples +#' (tibble of class "sits"). +#' @param epochs Number of iterations to train the model +#' (integer, min = 1, max = 20000). +#' @param batch_size Number of samples per gradient update +#' (integer, min = 16L, max = 2048L) +#' @param lr_decay_epochs Number of epochs to reduce learning rate. +#' @param lr_decay_rate Decay factor for reducing learning rate. +#' @param patience Number of epochs without improvements until +#' training stops. +#' @param min_delta Minimum improvement in loss function +#' to reset the patience counter. +#' @param verbose Verbosity mode (TRUE/FALSE). Default is FALSE. +#' +#' @keywords internal +#' @noRd +#' @return Called for side effects. +#' +.check_pre_sits_lighttae <- function(samples, epochs, batch_size, + lr_decay_epochs, lr_decay_rate, + patience, min_delta, verbose) { + # Pre-conditions: + .check_samples_train(samples) + .check_int_parameter(epochs, min = 1L, max = 20000L) + .check_int_parameter(batch_size, min = 16L, max = 2048L) + .check_int_parameter(lr_decay_epochs, min = 1L) + .check_num_parameter(lr_decay_rate, exclusive_min = 0.0, max = 1.0) + .check_int_parameter(patience, min = 1L) + .check_num_parameter(min_delta, min = 0.0) + .check_lgl_parameter(verbose) +} +#' @title Check for block object consistency +#' @name .check_raster_block +#' @keywords internal +#' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @return No value, called for side effects. +.check_raster_block <- function(block) { + # set caller to show in errors + .check_set_caller(".check_raster_block") + # precondition 1 + .check_chr_contains( + x = names(block), + contains = c("row", "nrows", "col", "ncols") + ) + # precondition 2 + .check_that(block[["row"]] > 0L && block[["col"]] > 0L) + # precondition 3 + .check_that(block[["nrows"]] > 0L && block[["ncols"]] > 0L) +} +#' @title Check for bbox object consistency +#' @name .check_raster_bbox +#' @keywords internal +#' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @param bbox Bounding box of raster data cube +#' @return No value, called for side effects. +.check_raster_bbox <- function(bbox) { + # set caller to show in errors + .check_set_caller(".check_raster_bbox") + # precondition 1 + .check_chr_contains( + x = names(bbox), + contains = c("xmin", "xmax", "ymin", "ymax") + ) + # precondition 2 + .check_that(bbox[["ymin"]] < bbox[["ymax"]]) + # precondition 3 + .check_that(bbox[["xmin"]] < bbox[["xmax"]]) +} +#' @title Check for bbox tolerance +#' @name .check_raster_bbox_tolerance +#' @keywords internal +#' @noRd +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @param bbox Bounding box of raster data cube +#' @param tile Tile to be matched against +#' @param tolerance Tolerance for edge cases +#' @return No value, called for side effects. +.check_raster_bbox_tolerance <- function(bbox, tile, tolerance = 0.001) { + # set caller to show in errors + .check_set_caller(".check_raster_bbox_tolerance") + # pre-conditions + .check_that( + bbox[["xmin"]] < bbox[["xmax"]] && + bbox[["ymin"]] < bbox[["ymax"]] + tolerance && + bbox[["xmin"]] >= tile[["xmin"]] - tolerance && + bbox[["xmax"]] <= tile[["xmax"]] + tolerance && + bbox[["ymin"]] >= tile[["ymin"]] - tolerance && + bbox[["ymax"]] <= tile[["ymax"]] + tolerance + ) +} diff --git a/R/api_chunks.R b/R/api_chunks.R index da55a23f1..e9bd1a442 100644 --- a/R/api_chunks.R +++ b/R/api_chunks.R @@ -44,25 +44,25 @@ NULL .chunks_create <- function(block, overlap, image_size, image_bbox) { # Generate all starting block points (col, row) chunks <- tidyr::expand_grid( - col = seq(1, .ncols(image_size), .ncols(block)), - row = seq(1, .nrows(image_size), .nrows(block)) + col = seq(1L, .ncols(image_size), .ncols(block)), + row = seq(1L, .nrows(image_size), .nrows(block)) ) # Adjust col and row to do overlap - chunks[["col"]] <- .as_int(pmax(1, .col(chunks) - overlap)) - chunks[["row"]] <- .as_int(pmax(1, .row(chunks) - overlap)) + chunks[["col"]] <- .as_int(pmax(1L, .col(chunks) - overlap)) + chunks[["row"]] <- .as_int(pmax(1L, .row(chunks) - overlap)) # Adjust ncols and nrows to do overlap chunks[["ncols"]] <- .as_int( pmin(.ncols(image_size), - .col(chunks) + .ncols(block) + overlap - 1) - .col(chunks) + 1 + .col(chunks) + .ncols(block) + overlap - 1L) - .col(chunks) + 1L ) chunks[["nrows"]] <- .as_int( pmin(.nrows(image_size), - .row(chunks) + .nrows(block) + overlap - 1) - .row(chunks) + 1 + .row(chunks) + .nrows(block) + overlap - 1L) - .row(chunks) + 1L ) # Chunk of entire image entire_image <- c(image_size, image_bbox) # Prepare a raster as template to crop bbox - t_obj <- .chunks_as_raster(chunk = entire_image, nlayers = 1) + t_obj <- .chunks_as_raster(chunk = entire_image, nlayers = 1L) # Generate chunks' bbox chunks <- slider::slide_dfr(chunks, function(chunk) { # Crop block from template @@ -79,10 +79,10 @@ NULL chunks[["overlap"]] <- .as_int(overlap) # Chunk size without overlap chunks[["crop_ncols"]] <- .as_int(pmin( - .ncols(image_size) - .col(chunks) + 1, .ncols(block) + .ncols(image_size) - .col(chunks) + 1L, .ncols(block) )) chunks[["crop_nrows"]] <- .as_int(pmin( - .nrows(image_size) - .row(chunks) + 1, .nrows(block) + .nrows(image_size) - .row(chunks) + 1L, .nrows(block) )) # Return chunks chunks @@ -94,14 +94,14 @@ NULL #' @return An empty raster object based on the on a chunk. .chunks_as_raster <- function(chunk, nlayers) { .raster_new_rast( - nrows = .nrows(chunk)[[1]], - ncols = .ncols(chunk)[[1]], - xmin = .xmin(chunk)[[1]], - xmax = .xmax(chunk)[[1]], - ymin = .ymin(chunk)[[1]], - ymax = .ymax(chunk)[[1]], + nrows = .nrows(chunk)[[1L]], + ncols = .ncols(chunk)[[1L]], + xmin = .xmin(chunk)[[1L]], + xmax = .xmax(chunk)[[1L]], + ymin = .ymin(chunk)[[1L]], + ymax = .ymax(chunk)[[1L]], nlayers = nlayers, - crs = .crs(chunk)[[1]] + crs = .crs(chunk)[[1L]] ) } #' @title Remove overlaps from chunks @@ -111,20 +111,20 @@ NULL .chunks_no_overlap <- function(chunks) { # Generate blocks cropped <- tibble::tibble( - col = .as_int(pmin(chunks[["overlap"]] + 1, .col(chunks))), - row = .as_int(pmin(chunks[["overlap"]] + 1, .row(chunks))) + col = .as_int(pmin(chunks[["overlap"]] + 1L, .col(chunks))), + row = .as_int(pmin(chunks[["overlap"]] + 1L, .row(chunks))) ) # Adjust blocks size .ncols(cropped) <- pmin( - .ncols(chunks) - .col(cropped) + 1, .as_int(chunks[["crop_ncols"]]) + .ncols(chunks) - .col(cropped) + 1L, .as_int(chunks[["crop_ncols"]]) ) .nrows(cropped) <- pmin( - .nrows(chunks) - .row(cropped) + 1, .as_int(chunks[["crop_nrows"]]) + .nrows(chunks) - .row(cropped) + 1L, .as_int(chunks[["crop_nrows"]]) ) # Generate bbox for each chunk cropped <- slider::slide2_dfr(chunks, cropped, function(chunk, crop) { # Prepare a raster as template to crop bbox - t_obj <- .chunks_as_raster(chunk = chunk, nlayers = 1) + t_obj <- .chunks_as_raster(chunk = chunk, nlayers = 1L) # Crop block from template rast <- .raster_crop_metadata(rast = t_obj, block = .block(crop)) # Add bbox information @@ -136,7 +136,7 @@ NULL crop }) # Finish cropped chunks - cropped[["overlap"]] <- 0 + cropped[["overlap"]] <- 0L cropped[["crop_ncols"]] <- chunks[["crop_ncols"]] cropped[["crop_nrows"]] <- chunks[["crop_nrows"]] # Return cropped chunks @@ -188,18 +188,18 @@ NULL ) # Find segments in chunks idx_intersects <- sf::st_intersects(sf_chunks, segs, sparse = TRUE) |> - purrr::imap_dfr( - ~dplyr::as_tibble(.x) |> dplyr::mutate(id = .y) - ) |> - dplyr::distinct(.data[["value"]], .keep_all = TRUE) |> - dplyr::group_by(.data[["id"]]) |> - tidyr::nest() |> - tibble::deframe() + purrr::imap_dfr( + ~dplyr::as_tibble(.x) |> dplyr::mutate(id = .y) + ) |> + dplyr::distinct(.data[["value"]], .keep_all = TRUE) |> + dplyr::group_by(.data[["id"]]) |> + tidyr::nest() |> + tibble::deframe() idx_positions <- as.integer(names(idx_intersects)) chunks <- chunks[idx_positions, ] chunks[["segments"]] <- purrr::map(seq_along(idx_intersects), function(i) { idx <- unname(as.vector(idx_intersects[[i]])) - idx <- idx[[1]] + idx <- idx[[1L]] block_file <- .file_block_name( pattern = "chunk_seg", block = .block(chunks[i, ]), diff --git a/R/api_classify.R b/R/api_classify.R index 1189ea5ba..814475a50 100755 --- a/R/api_classify.R +++ b/R/api_classify.R @@ -7,13 +7,10 @@ #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' -#' @description Classifies a block of data using multicores. It breaks -#' the data into horizontal blocks and divides them between the available cores. -#' -#' Reads data using terra, cleans the data for NAs and missing values. -#' The clean data is stored in a data table with the time instances -#' for all pixels of the block. The algorithm then classifies data on -#' an year by year basis. For each year, extracts the sub-blocks for each band. +#' @description Classifies a block of data using multicores, breaking +#' the data into blocks and divides them between the available cores. +#' The size of the blocks is optimized to account for COG files and +#' for the balance of multicores and memory size. #' #' After all cores process their blocks, it joins the result and then writes it #' in the classified images for each corresponding year. @@ -46,18 +43,18 @@ version, verbose, progress) { - # Output file + # Define the name of the output file out_file <- .file_derived_name( tile = tile, band = out_band, version = version, output_dir = output_dir ) - # Resume feature + # If output file exists, builds a + # probability cube directly from the file + # and does not reprocess input if (file.exists(out_file)) { - if (.check_messages()) { - .check_recovery(out_file) - } + .check_recovery() probs_tile <- .tile_derived_from_file( file = out_file, band = out_band, @@ -68,18 +65,19 @@ ) return(probs_tile) } - # Show initial time for tile classification + # Initial time for tile classification tile_start_time <- .tile_classif_start( tile = tile, verbose = verbose ) - # Create chunks as jobs + # Create chunks to be allocated to jobs in parallel chunks <- .tile_chunks_create( tile = tile, - overlap = 0, + overlap = 0L, block = block ) - # By default, update_bbox is FALSE + # Create a variable to control updating of bounding box + # by default, update_bbox is FALSE update_bbox <- FALSE if (.has(exclusion_mask)) { # How many chunks there are in tile? @@ -98,21 +96,21 @@ update_bbox <- nrow(chunks) != nchunks } if (.has(roi)) { - # How many chunks still available ? + # How many chunks do we need to process? nchunks <- nrow(chunks) - # Intersecting chunks with ROI + # Intersect chunks with ROI chunks <- .chunks_filter_spatial( chunks = chunks, roi = roi ) - # Should bbox of resulting tile be updated? + # Update bbox to account for ROI update_bbox <- nrow(chunks) != nchunks } - # Process jobs in parallel + # Process jobs in parallel - one job per chunk block_files <- .jobs_map_parallel_chr(chunks, function(chunk) { - # Job block + # Retrive block to be processed block <- .block(chunk) - # Block file name + # Create a temporary block file name block_file <- .file_block_name( pattern = .file_pattern(out_file), block = block, @@ -122,7 +120,7 @@ if (.raster_is_valid(block_file)) { return(block_file) } - # Read and preprocess values + # Read and preprocess values from files values <- .classify_data_read( tile = tile, block = block, @@ -135,46 +133,45 @@ # Get mask of NA pixels na_mask <- C_mask_na(values) # Fill with zeros remaining NA pixels - values <- C_fill_na(values, 0) - # Used to check values (below) + values <- C_fill_na(values, 0.0) + # Define control variable to check for correct termination input_pixels <- nrow(values) - # Log here + # Start log file .debug_log( event = "start_block_data_classification", key = "model", value = .ml_class(ml_model) ) # Apply the classification model to values - values <- ml_model(values) - # normalize and calibrate the values - values <- .ml_normalize(ml_model, values) + # Uses the closure created by sits_train + # Normalize and calibrate the values + # Perform softmax for torch models, + values <- values |> + ml_model() |> + .ml_normalize(ml_model) + # Are the results consistent with the data input? .check_processed_values( values = values, input_pixels = input_pixels ) - # Log + # Log end of block .debug_log( event = "end_block_data_classification", key = "model", value = .ml_class(ml_model) ) - # Prepare probability to be saved + # Obtain configuration parameters for probability cube band_conf <- .conf_derived_band( derived_class = "probs_cube", band = out_band ) - band_offset <- .offset(band_conf) - if (.has(band_offset) && band_offset != 0) { - values <- values - band_offset - } + # Apply scaling to classified values band_scale <- .scale(band_conf) - if (.has(band_scale) && band_scale != 1) { - values <- values / band_scale - } + values <- values / band_scale # Put NA back in the result values[na_mask, ] <- NA - # Log + # Log start of block saving .debug_log( event = "start_block_data_save", key = "file", @@ -190,7 +187,7 @@ missing_value = .miss_value(band_conf), crop_block = chunk[["mask"]] ) - # Log + # Log end of block saving .debug_log( event = "end_block_data_save", key = "file", @@ -202,17 +199,16 @@ block_file }, progress = progress) # Merge blocks into a new probs_cube tile - # Check if there is a ROI # If ROI exists, blocks are merged to a different directory # than output_dir, which is used to save the final cropped version merge_out_file <- out_file if (.has(roi)) { merge_out_file <- .file_derived_name( - tile = tile, - band = out_band, - version = version, - output_dir = file.path(output_dir, ".sits") - ) + tile = tile, + band = out_band, + version = version, + output_dir = file.path(output_dir, ".sits") + ) } probs_tile <- .tile_derived_merge_blocks( file = merge_out_file, @@ -226,13 +222,13 @@ ) # Clean GPU memory allocation .ml_gpu_clean(ml_model) - # if there is a ROI, we need to crop + # if there is a ROI, crop the probability cube if (.has(roi)) { probs_tile_crop <- .crop( cube = probs_tile, roi = roi, output_dir = output_dir, - multicores = 1, + multicores = 1L, progress = FALSE) unlink(.fi_paths(.fi(probs_tile))) } @@ -242,7 +238,7 @@ start_time = tile_start_time, verbose = verbose ) - # Return probs tile or cropped version + # Return probs tile (cropped version in case of ROI) if (.has(roi)) probs_tile_crop else @@ -258,16 +254,10 @@ #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' -#' @description Classifies a block of data using multicores. It breaks -#' the data into horizontal blocks and divides them between the available cores. -#' -#' Reads data using terra, cleans the data for NAs and missing values. -#' The clean data is stored in a data table with the time instances -#' for all pixels of the block. The algorithm then classifies data on -#' an year by year basis. For each year, extracts the sub-blocks for each band. -#' -#' After all cores process their blocks, it joins the result and then writes it -#' in the classified images for each corresponding year. +#' @description Classifies a block of data using multicores. Breaks +#' the data into blocks and divides them between the available cores. +#' After all cores process their blocks, +#' joins the result and then writes it. #' #' @param tile Single tile of a data cube. #' @param bands Bands to extract time series @@ -278,8 +268,8 @@ #' @param filter_fn Smoothing filter function to be applied to the data. #' @param impute_fn Imputation function to remove NA values. #' @param n_sam_pol Number of samples per polygon to be read -#' for POLYGON or MULTIPOLYGON shapefiles or sf objects. -#' @param multicores Number of cores to be used for classification +#' for POLYGON or MULTIPOLYGON vector objects. +#' @param multicores Number of cores for classification #' @param gpu_memory Memory available in GPU (default = NULL) #' @param version Version of result. #' @param output_dir Output directory. @@ -300,7 +290,7 @@ version, output_dir, progress) { - # Output file + # Define output vector file name and extension out_file <- .file_derived_name( tile = tile, band = "probs", @@ -308,11 +298,10 @@ output_dir = output_dir, ext = "gpkg" ) - # Resume feature + # Checks if output file already exists + # If TRUE, returns the existing file and avoids re-processing if (.segments_is_valid(out_file)) { - if (.check_messages()) { - .check_recovery(out_file) - } + .check_recovery() # Create tile based on template probs_tile <- .tile_segments_from_file( file = out_file, @@ -327,7 +316,7 @@ # Create chunks as jobs chunks <- .tile_chunks_create( tile = tile, - overlap = 0, + overlap = 0L, block = block ) # By default, update_bbox is FALSE @@ -344,12 +333,13 @@ tile = tile, output_dir = output_dir ) + # Define that chunks will be deleted upon exit on.exit(unlink(unlist(chunks[["segments"]]))) # Process jobs in parallel block_files <- .jobs_map_parallel_chr(chunks, function(chunk) { - # Job block + # Retrieve block from chunk block <- .block(chunk) - # Block file name + # Define block file name block_file <- .file_block_name( pattern = .file_pattern(out_file), block = block, @@ -360,7 +350,8 @@ if (.segments_is_valid(block_file)) { return(block_file) } - # Extract segments time series + # Extract time series from segments + # Number of time series per segment is defined by n_sam_pol segments_ts <- .segments_poly_read( tile = tile, bands = bands, @@ -369,17 +360,19 @@ n_sam_pol = n_sam_pol, impute_fn = impute_fn ) - # In some cases, the chunk doesn't have data (e.g., cloudy areas) - if (nrow(segments_ts) == 0) { + # Deal with NO DATA cases (e.g., cloudy areas) + if (nrow(segments_ts) == 0L) { return("") } - # Classify segments + # Classify times series + # This is the same function called to classify + # individual time series (with an extra polygon_id) segments_ts <- .classify_ts( samples = segments_ts, ml_model = ml_model, filter_fn = filter_fn, impute_fn = impute_fn, - multicores = 1, + multicores = 1L, gpu_memory = gpu_memory, progress = FALSE ) @@ -400,12 +393,14 @@ }, progress = progress) # Remove empty block files block_files <- purrr::discard(block_files, Negate(nzchar)) - # Read all segments - segments_ts <- purrr::map(block_files, .vector_read_vec) - segments_ts <- dplyr::bind_rows(segments_ts) - # Write all segments + # Read segments from all block files + segments_ts <- block_files |> + purrr::map(.vector_read_vec) |> + dplyr::bind_rows() + # Write segments to a vector data cube .vector_write_vec(v_obj = segments_ts, file_path = out_file) - # Create tile based on template + # Create probability vector tile + # joining vector and raster components of data cube probs_tile <- .tile_segments_from_file( file = out_file, band = "probs", @@ -414,13 +409,13 @@ vector_class = "probs_vector_cube", update_bbox = FALSE ) - # Remove file block + # Remove file blocks unlink(block_files) # Return probability vector tile probs_tile } -#' @title Read a block of values retrieved from a set of raster images +#' @title Read a block of values from a set of raster images #' @name .classify_data_read #' @keywords internal #' @noRd @@ -442,7 +437,7 @@ # For cubes that have a time limit to expire (MPC cubes only) tile <- .cube_token_generator(tile) # Read and preprocess values of cloud - # Get cloud values (NULL if not exists) + # Get cloud values (NULL if data does not exist) cloud_mask <- .tile_cloud_read_block( tile = tile, block = block @@ -482,7 +477,7 @@ q02 <- .stats_0_q02(stats, band) q98 <- .stats_0_q98(stats, band) if (.has(q02) && .has(q98)) { - # Use C_normalize_data_0 to process old version of normalization + # Use C_normalize_data_0 to process old version values <- C_normalize_data_0(values, q02, q98) } } @@ -521,7 +516,7 @@ # Return values values } -#' @title Classify a distances tibble using machine learning models +#' @title Classify a sits tibble using machine learning models #' @name .classify_ts #' @keywords internal #' @noRd @@ -532,8 +527,8 @@ #' #' @description Returns a sits tibble with the results of the ML classifier. #' -#' @param samples a tibble with sits samples -#' @param ml_model model trained by \code{\link[sits]{sits_train}}. +#' @param samples Tibble with sits samples +#' @param ml_model Model trained by \code{\link[sits]{sits_train}}. #' @param filter_fn Smoothing filter to be applied (if desired). #' @param impute_fn Imputation function (to remove NA) #' @param multicores number of threads to process the time series. @@ -579,10 +574,10 @@ samples = .ml_samples(ml_model) ) # Split long time series of samples in a set of small time series - if (length(class_info[["dates_index"]][[1]]) > 1) { + if (length(class_info[["dates_index"]][[1L]]) > 1L) { splitted <- .samples_split( samples = samples, - split_intervals = class_info[["dates_index"]][[1]] + split_intervals = class_info[["dates_index"]][[1L]] ) pred <- .predictors( samples = splitted, @@ -615,7 +610,7 @@ progress = progress ) # Store the result in the input data - if (length(class_info[["dates_index"]][[1]]) > 1) { + if (length(class_info[["dates_index"]][[1L]]) > 1L) { prediction <- .tibble_prediction_multiyear( data = samples, class_info = class_info, @@ -628,7 +623,8 @@ ) } # Set result class and return it - .set_class(x = prediction, "predicted", class(samples)) + prediction <- .set_class(x = prediction, "predicted", + class(samples)) prediction } #' @title Classify predictors using CPU @@ -659,14 +655,14 @@ ) # Do parallel process prediction <- .jobs_map_parallel_dfr(parts, function(part) { - # Get predictors of a given partition - pred_part <- .pred_part(part) - # Get predictors features to classify - values <- .pred_features(pred_part) - # Classify - values <- ml_model(values) - # normalize and calibrate values - values <- .ml_normalize(ml_model, values) + # Extract predictors of a given partition + # Extract features to classify + # Classify, normalize and calibrate value + values <- part |> + .pred_part() |> + .pred_features() |> + ml_model() |> + .ml_normalize(ml_model) # Extract columns values_columns <- colnames(values) # Transform classification results @@ -675,7 +671,7 @@ # (e.g., with spaces, icons) colnames(values) <- values_columns # Return classification - return(values) + values }, progress = progress) prediction } @@ -698,7 +694,7 @@ ml_model, gpu_memory) { # estimate size of GPU memory required (in GB) - pred_size <- nrow(pred) * ncol(pred) * 8 / 1e+09 + pred_size <- nrow(pred) * ncol(pred) * 8.0 / 1000000000.0 # estimate how should we partition the predictors num_parts <- ceiling(pred_size / gpu_memory) # Divide samples predictors in chunks to parallel processing @@ -708,13 +704,14 @@ ) prediction <- slider::slide_dfr(parts, function(part) { # Get predictors of a given partition - pred_part <- .pred_part(part) # Get predictors features to classify - values <- .pred_features(pred_part) # Classify - values <- ml_model(values) # normalize and calibrate values - values <- .ml_normalize(ml_model, values) + values <- part |> + .pred_part() |> + .pred_features() |> + ml_model() |> + .ml_normalize(ml_model) # Extract columns values_columns <- colnames(values) # Transform classification results @@ -762,7 +759,7 @@ message("") message(.conf("messages", ".verbose_task_end"), end_time) message(.conf("messages", ".verbose_task_elapsed"), - format(round(end_time - start_time, digits = 2)) + format(round(end_time - start_time, digits = 2L)) ) } } diff --git a/R/api_clean.R b/R/api_clean.R index 824629e06..19caa5fac 100644 --- a/R/api_clean.R +++ b/R/api_clean.R @@ -29,7 +29,7 @@ # Resume tile if (.raster_is_valid(out_file, output_dir = output_dir)) { # recovery message - .check_recovery(out_file) + .check_recovery() # Create tile based on template tile <- .tile_derived_from_file( file = out_file, band = band, @@ -66,7 +66,7 @@ x = as.matrix(values), ncols = block[["ncols"]], nrows = block[["nrows"]], - band = 0, + band = 0L, window_size = window_size ) # Prepare fractions to be saved @@ -93,7 +93,7 @@ base_tile = tile, derived_class = .tile_derived_class(tile), block_files = block_files, - multicores = 1, + multicores = 1L, update_bbox = FALSE ) } @@ -108,8 +108,8 @@ #' @return Values for tile-band-block combination .clean_data_read <- function(tile, block, band) { # Get band values - values <- .tile_read_block(tile = tile, band = band, block = block) - values <- as.data.frame(values) + values <- as.data.frame(.tile_read_block( + tile = tile, band = band, block = block)) # Set columns name colnames(values) <- band # Return values diff --git a/R/api_cluster.R b/R/api_cluster.R index 9eee2170a..409f95536 100644 --- a/R/api_cluster.R +++ b/R/api_cluster.R @@ -30,7 +30,7 @@ a = factor(samples[["cluster"]]), b = factor(samples[["label"]]), type = "external", - log.base = 10 + log.base = 10L ) } #' @title Compute a dendrogram using hierarchical clustering @@ -82,7 +82,7 @@ dendro <- dtwclust::tsclust( values, type = "hierarchical", - k = max(nrow(samples) - 1, 2), + k = max(nrow(samples) - 1L, 2L), distance = dist_method, control = dtwclust::hierarchical_control(method = linkage), ... @@ -112,11 +112,10 @@ #' .cluster_dendro_bestcut <- function(samples, dendro) { # compute range - k_range <- seq(2, max(length(dendro[["height"]]) - 1, 2)) + k_range <- seq(2L, max(length(dendro[["height"]]) - 1L, 2L)) # compute ARI for each k (vector) - ari <- - k_range |> + ari <- k_range |> purrr::map(function(k) { x <- stats::cutree(dendro, k = k) y <- factor(samples[["label"]]) @@ -128,8 +127,8 @@ k_result <- k_range[which.max(ari)] # compute each height corresponding to `k_result` - h_index <- length(dendro[["height"]]) - k_result + 2 - h_result <- c(0, dendro[["height"]])[h_index] + h_index <- length(dendro[["height"]]) - k_result + 2L + h_result <- c(0L, dendro[["height"]])[h_index] # create a named vector and return structure(c(k_result, h_result), .Names = c("k", "height")) @@ -142,17 +141,16 @@ #' @return Rand index for cluster .cluster_rand_index <- function(x) { .check_set_caller(".cluster_rand_index") - .check_that(length(dim(x)) == 2) + .check_that(length(dim(x)) == 2L) - n <- sum(x) ni <- rowSums(x) nj <- colSums(x) - n2 <- choose(n, 2) + n2 <- choose(sum(x), 2L) - nis2 <- sum(choose(ni[ni > 1], 2)) - njs2 <- sum(choose(nj[nj > 1], 2)) + nis2 <- sum(choose(ni[ni > 1.0], 2L)) + njs2 <- sum(choose(nj[nj > 1.0], 2L)) factor_1 <- (nis2 * njs2) / n2 - factor_2 <- (nis2 + njs2) / 2 - rand <- (sum(choose(x[x > 1], 2)) - factor_1) / (factor_2 - factor_1) + factor_2 <- (nis2 + njs2) / 2.0 + rand <- (sum(choose(x[x > 1.0], 2L)) - factor_1) / (factor_2 - factor_1) rand } diff --git a/R/api_colors.R b/R/api_colors.R index 90bfa7326..f2fdf1c63 100644 --- a/R/api_colors.R +++ b/R/api_colors.R @@ -67,7 +67,7 @@ is_named = TRUE, has_unique_names = FALSE ) - return(colors) + colors } #' @title Show color table #' @name .colors_show @@ -86,30 +86,30 @@ ) # find out how many lines to write per name color_tb[["lines"]] <- purrr::map_int(color_tb[["name"]], function(s) { - stringr::str_count(stringr::str_wrap(s, width = 12), "\n") + 1 + stringr::str_count(stringr::str_wrap(s, width = 12L), "\n") + 1L }) n_colors <- nrow(color_tb) - if (n_colors <= 12) - n_rows_show <- 3 + if (n_colors <= 12L) + n_rows_show <- 3L else - n_rows_show <- n_colors %/% 4 + n_rows_show <- n_colors %/% 4L # add place locators to color table entries color_tb <- tibble::add_column( color_tb, - y = seq(0, n_colors - 1) %% n_rows_show, - x = seq(0, n_colors - 1) %/% n_rows_show + y = seq(0L, n_colors - 1L) %% n_rows_show, + x = seq(0L, n_colors - 1L) %/% n_rows_show ) y_size <- 1.2 - g <- ggplot2::ggplot() + + ggplot2::ggplot() + ggplot2::scale_x_continuous( name = "", breaks = NULL, - expand = c(0, 0) + expand = c(0.0, 0.0) ) + ggplot2::scale_y_continuous( name = "", breaks = NULL, - expand = c(0, 0) + expand = c(0.0, 0.0) ) + ggplot2::geom_rect( data = color_tb, @@ -125,19 +125,18 @@ data = color_tb, mapping = ggplot2::aes( x = .data[["x"]] + 0.5, - y = .data[["y"]] + 0.6 + 0.1 * (.data[["lines"]] - 1), - label = stringr::str_wrap(.data[["name"]], width = 12) + y = .data[["y"]] + 0.6 + 0.1 * (.data[["lines"]] - 1L), + label = stringr::str_wrap(.data[["name"]], width = 12L) ), family = font_family, colour = "grey15", hjust = 0.5, - vjust = 1, - size = 10 / ggplot2::.pt + vjust = 1.0, + size = 10.0 / ggplot2::.pt + ) + + ggplot2::theme( + panel.background = ggplot2::element_rect(fill = "#FFFFFF") ) - g + ggplot2::theme( - panel.background = ggplot2::element_rect(fill = "#FFFFFF") - ) - g } #' #' @title Write a color table in QGIS Style format @@ -160,8 +159,6 @@ top_lines <- readLines(top_qgis_style) # write the top part of QGIS style in the output file writeLines(top_lines, con = con) - - # the palette entry goes after this part # write start of color palette writeLines(" ", con = con) # write palette entries @@ -177,12 +174,11 @@ " alpha=", "\"255\"", "/>"), con = con ) - return(invisible("")) + invisible("") } ) # write end of color palette writeLines(" ", con = con) - # read the bottom part of QGIS style files # this part goes after the palette entry bottom_qgis_style <- system.file("extdata/qgis/qgis_style_bottom.xml", @@ -190,7 +186,6 @@ bottom_lines <- readLines(bottom_qgis_style) # write the bottom part of QGIS style in the output file writeLines(bottom_lines, con = con) - # close the file on.exit(close(con)) } diff --git a/R/api_combine_predictions.R b/R/api_combine_predictions.R index 34bcaa7fe..33fdf8ca5 100644 --- a/R/api_combine_predictions.R +++ b/R/api_combine_predictions.R @@ -27,7 +27,7 @@ progress, ...) { # Check memory and multicores # Get block size - base_cube <- probs_cubes[[1]] + base_cube <- probs_cubes[[1L]] block_size <- .raster_file_blocksize( .raster_open_rast(.tile_path(base_cube)) ) @@ -35,8 +35,8 @@ job_block_memsize <- .jobs_block_memsize( block_size = .block_size(block = block_size), npaths = length(probs_cubes) * nrow(base_cube) * - length(.cube_labels(base_cube)), - nbytes = 8, + length(.cube_labels(base_cube)), + nbytes = 8L, proc_bloat = .conf("processing_bloat_cpu") ) # Update multicores parameter @@ -59,7 +59,7 @@ # Call the combine method # Process each tile sequentially probs_cube <- .map_dfr(seq_len(nrow(base_cube)), function(i) { - probs_tile <- .comb_tiles( + .comb_tiles( probs_tiles = lapply(probs_cubes, .slice_dfr, i), uncert_tiles = lapply(uncert_cubes, .slice_dfr, i), band = band, @@ -69,7 +69,6 @@ version = version, progress = progress ) - probs_tile }) probs_cube } @@ -96,7 +95,7 @@ output_dir, version, progress) { - base_tile <- probs_tiles[[1]] + base_tile <- probs_tiles[[1L]] # Output file out_file <- .file_derived_name( tile = base_tile, @@ -106,7 +105,7 @@ ) # Resume feature if (file.exists(out_file)) { - .check_recovery(out_file) + .check_recovery() probs_tile <- .tile_derived_from_file( file = out_file, band = band, @@ -120,7 +119,7 @@ # Create chunks as jobs chunks <- .tile_chunks_create( tile = base_tile, - overlap = 0, + overlap = 0L, block = block_size ) # Process jobs in parallel @@ -163,16 +162,11 @@ band_conf <- .conf_derived_band( derived_class = "probs_cube", band = band ) - offset <- .offset(band_conf) - if (offset != 0) { - values <- values - offset - } scale <- .scale(band_conf) - if (scale != 1) { - values <- values / scale - } min <- .min_value(band_conf) max <- .max_value(band_conf) + # scale values + values <- values / scale # check minimum and maximum values values[values < min] <- min values[values > max] <- max @@ -192,7 +186,7 @@ block_file }, progress = progress) # Merge blocks into a new probs_cube tile - probs_tile <- .tile_derived_merge_blocks( + .tile_derived_merge_blocks( file = out_file, band = band, labels = .tile_labels(base_tile), @@ -202,8 +196,6 @@ multicores = .jobs_multicores(), update_bbox = FALSE ) - # Return probs tile - probs_tile } #---- combine functions ---- #' @title Combine probs tiles by average value @@ -219,11 +211,11 @@ # Average probability calculation comb_fn <- function(values, uncert_values = NULL) { # Check values length - input_pixels <- nrow(values[[1]]) + input_pixels <- nrow(values[[1L]]) # Combine by average values <- weighted_probs(values, weights) # get the number of labels - n_labels <- length(.cube_labels(cubes[[1]])) + n_labels <- length(.cube_labels(cubes[[1L]])) # Are the results consistent with the data input? .check_processed_values(values, input_pixels) .check_processed_labels(values, n_labels) @@ -244,11 +236,11 @@ # Average probability calculation comb_fn <- function(values, uncert_values) { # Check values length - input_pixels <- nrow(values[[1]]) + input_pixels <- nrow(values[[1L]]) # Combine by average values <- weighted_uncert_probs(values, uncert_values) # get the number of labels - n_labels <- length(.cube_labels(cubes[[1]])) + n_labels <- length(.cube_labels(cubes[[1L]])) # Are the results consistent with the data input? .check_processed_values(values, input_pixels) .check_processed_labels(values, n_labels) diff --git a/R/api_comp.R b/R/api_comp.R index 6ea2fdb5e..db74b0523 100644 --- a/R/api_comp.R +++ b/R/api_comp.R @@ -15,27 +15,27 @@ NULL #' @title Compare if `x` is equal to `y` considering a tolerance #' @noRd #' @returns A logical value -.is_eq <- function(x, y, tolerance = 0) { +.is_eq <- function(x, y, tolerance = 0.0) { .check_set_caller(".is_eq") - .check_that(tolerance >= 0) + .check_that(tolerance >= 0.0) # Compute result and return - all(abs(x - y) <= tolerance[[1]]) + all(abs(x - y) <= tolerance) } #' @title Compare if `x` is less than `y` considering a tolerance #' @noRd #' @returns A logical value -.is_lt <- function(x, y, tolerance = 0) { +.is_lt <- function(x, y, tolerance = 0.0) { .check_set_caller(".is_lt") - .check_that(tolerance >= 0) + .check_that(tolerance >= 0.0) # Compute result and return - all(abs(y - x) > tolerance[[1]]) + all(abs(y - x) > tolerance) } #' @title Compare if `x` is greater than `y` considering a tolerance #' @noRd #' @returns A logical value -.is_gt <- function(x, y, tolerance = 0) { +.is_gt <- function(x, y, tolerance = 0.0) { .check_set_caller(".is_gt") - .check_that(tolerance >= 0) + .check_that(tolerance >= 0.0) # Compute result and return - all(abs(x - y) > tolerance[[1]]) + all(abs(x - y) > tolerance) } diff --git a/R/api_conf.R b/R/api_conf.R index a4b9d8eb2..44054e04e 100644 --- a/R/api_conf.R +++ b/R/api_conf.R @@ -23,65 +23,63 @@ if (!exists("config", envir = sits_env)) sits_env[["config"]] <- list() # process processing_bloat - if (!is.null(processing_bloat)) { + if (.has(processing_bloat)) { .check_int_parameter(processing_bloat, - min = 1, len_min = 1, len_max = 1, max = 10 + min = 1.0, len_min = 1L, len_max = 1L, max = 10.0 ) sits_env[["config"]][["processing_bloat"]] <- processing_bloat } # process rstac_pagination_limit - if (!is.null(rstac_pagination_limit)) { + if (.has(rstac_pagination_limit)) { .check_int_parameter(rstac_pagination_limit, - min = 1, len_min = 1, len_max = 1, max = 500 + min = 1L, len_min = 1L, len_max = 1L, max = 500L ) sits_env[["config"]][["rstac_pagination_limit"]] <- rstac_pagination_limit } # process gdal_creation_options - if (!is.null(gdal_creation_options)) { + if (.has(gdal_creation_options)) { .check_chr(gdal_creation_options, - allow_empty = FALSE, - regex = "^.+=.+$", - msg = .conf("messages", ".conf_set_options_gdal_creation") + allow_empty = FALSE, + regex = "^.+=.+$", + msg = .conf("messages", ".conf_set_options_gdal_creation") ) sits_env$config[["gdal_creation_options"]] <- gdal_creation_options } # process gdalcubes_chunk_size - if (!is.null(gdalcubes_chunk_size)) { + if (.has(gdalcubes_chunk_size)) { .check_num_parameter(gdalcubes_chunk_size, - len_min = 3, - len_max = 3, - is_named = FALSE + len_min = 3L, + len_max = 3L, + is_named = FALSE ) sits_env[["config"]][["gdalcubes_chunk_size"]] <- gdalcubes_chunk_size } # process sources - if (!is.null(sources)) { - .check_lst_parameter(sources, len_min = 1) + if (.has(sources)) { + .check_lst_parameter(sources, len_min = 1L) # source names are uppercase names(sources) <- toupper(names(sources)) # check each source lapply(sources, function(source) { # pre-condition - .check_lst_parameter(source, len_min = 2) + .check_lst_parameter(source, len_min = 2L) # check that source contains essential parameters .check_chr_contains(names(source), - contains = c("s3_class", "collections") + contains = c("s3_class", "collections") ) names(source) <- tolower(names(source)) # check source .check_error( - do.call(.conf_new_source, args = source), + do.call(.conf_new_source, args = source), msg = .conf("messages", ".conf_set_options_source") ) }) - # initialize sources - if (is.null(sits_env[["config"]][["sources"]])) { + if (.has_not(sits_env[["config"]][["sources"]])) { sits_env[["config"]][["sources"]] <- sources } - sits_env[["config"]][["sources"]] <- utils::modifyList( sits_env[["config"]][["sources"]], sources, @@ -91,7 +89,7 @@ # check and initialize palettes if (.has(colors)) { # initialize colors - if (is.null(sits_env[["config"]][["colors"]])) { + if (.has_not(sits_env[["config"]][["colors"]])) { sits_env[["config"]][["colors"]] <- colors } # add colors @@ -105,7 +103,7 @@ dots <- list(...) .check_lst(dots) - if (length(dots) > 0) { + if (.has(dots)) { sits_env[["config"]] <- utils::modifyList( sits_env[["config"]], dots, @@ -137,11 +135,7 @@ .conf_internals_file <- function() { .check_set_caller(".conf_internals_file") # load the default configuration file - yml_file <- system.file("extdata", "config_internals.yml", package = "sits") - # check that the file name is valid - .check_that(file.exists(yml_file)) - # return configuration file - yml_file + system.file("extdata", "config_internals.yml", package = "sits") } #' @title Return the user-relevant configuration file #' @name .config_file @@ -151,11 +145,7 @@ .config_file <- function() { .check_set_caller(".config_file") # load the default configuration file - yml_file <- system.file("extdata", "config.yml", package = "sits") - # check that the file name is valid - .check_that(file.exists(yml_file)) - # return configuration file - yml_file + system.file("extdata", "config.yml", package = "sits") } #' @title Return the message configuration files (only for developers) #' @name .conf_sources_files @@ -192,18 +182,18 @@ ) }) # prepare sources object - source_obj <- purrr::map(source_configs, "sources") - source_obj <- purrr::flatten(source_obj) + source_obj <- source_configs |> + purrr::map("sources") |> + purrr::flatten() # prepare extras objects (e.g., token, url config) - extras_obj <- purrr::map(source_configs, function(source_config) { - source_config[["sources"]] <- NULL - source_config - }) - extras_obj <- purrr::flatten(extras_obj) - # merge objects - config_obj <- utils::modifyList(extras_obj, list( - sources = source_obj - )) + # and merge with source objects + config_obj <- source_configs |> + purrr::map(function(source_config) { + source_config[["sources"]] <- NULL + source_config + }) |> + purrr::flatten() |> + utils::modifyList(list(sources = source_obj)) # set configurations do.call(.conf_set_options, args = config_obj) } @@ -269,8 +259,8 @@ colors <- config_colors[["colors"]] color_table <- purrr::map2_dfr(colors, names(colors), function(cl, nm) { - tibble::tibble(name = nm, color = cl) - }) + tibble::tibble(name = nm, color = cl) + }) # set the color table sits_env[["color_table"]] <- color_table @@ -314,12 +304,12 @@ name <- names_user_colors[[i]] col <- col_user_colors[[i]] id <- which(color_table[["name"]] == name) - if (length(id) > 0) { + if (.has(id)) { color_table[id, "color"] <- col } else { color_table <- tibble::add_row(color_table, - name = name, - color = col + name = name, + color = col ) } } @@ -336,7 +326,7 @@ .conf_merge_legends <- function(user_legends) { .check_set_caller(".conf_merge_legends") # check legends are valid names - .check_chr_parameter(names(user_legends), len_max = 100, + .check_chr_parameter(names(user_legends), len_max = 100L, msg = .conf("messages", ".conf_merge_legends_user")) # check legend names do not already exist .check_that(!(any(names(user_legends) %in% names(sits_env[["legends"]])))) @@ -361,17 +351,17 @@ yml_file <- Sys.getenv("SITS_CONFIG_USER_FILE") yaml_user_config <- NULL # check if the file exists when env var is set - if (nchar(yml_file) > 0) { + if (nchar(yml_file) > 0L) { .check_warn( .check_file(yml_file, - msg = .conf("messages", ".conf_user_env_var") + msg = .conf("messages", ".conf_user_env_var") ) ) # if the YAML file exists, try to load it tryCatch({ yaml_user_config <- yaml::yaml.load_file( - input = yml_file, - merge.precedence = "override" + input = yml_file, + merge.precedence = "override" )}, error = function(e) { warning(.conf("messages", ".conf_user_env_var"), call. = TRUE) @@ -413,10 +403,10 @@ .conf_merge_legends(user_legends) user_config[["legends"]] <- NULL } - if (length(user_config) > 0) { + if (.has(user_config)) { user_config <- utils::modifyList(sits_env[["config"]], - user_config, - keep.null = FALSE + user_config, + keep.null = FALSE ) # set options defined by user (via YAML file) # modifying existing configuration @@ -454,7 +444,7 @@ }) params_txt <- yaml::as.yaml( params, - indent = 4, + indent = 4L, handlers = list( character = function(x) { res <- toString(x) @@ -531,17 +521,17 @@ names(sits_env[["config"]][[key]]) }, error = function(e) { - return(NULL) + NULL } ) # post-condition .check_chr(res, - allow_empty = FALSE, - msg = paste( - "invalid names for", - paste0("'", paste0(key, collapse = "$"), "'"), - "key" - ) + allow_empty = FALSE, + msg = paste( + "invalid names for", + paste0("'", paste(key, collapse = "$"), "'"), + "key" + ) ) res } @@ -564,49 +554,47 @@ .check_set_caller(".conf_new_source") # pre-condition .check_chr_parameter(s3_class, - allow_empty = FALSE, len_min = 1, - msg = .conf("messages", ".conf_new_source_s3class") + allow_empty = FALSE, len_min = 1L, + msg = .conf("messages", ".conf_new_source_s3class") ) if (!is.null(service)) { .check_chr_parameter(service, - allow_empty = FALSE, len_min = 1, len_max = 1, - msg = .conf("messages", ".conf_new_source_service") + allow_empty = FALSE, len_min = 1L, len_max = 1L, + msg = .conf("messages", ".conf_new_source_service") ) } if (!is.null(url)) { .check_chr_parameter(url, - allow_empty = FALSE, len_min = 1, len_max = 1, - regex = '^(http|https)://[^ "]+$', - msg = .conf("messages", ".conf_new_source_url") + allow_empty = FALSE, len_min = 1L, len_max = 1L, + regex = '^(http|https)://[^ "]+$', + msg = .conf("messages", ".conf_new_source_url") ) } - .check_lst(collections, len_min = 1) + .check_lst(collections, len_min = 1L) names(collections) <- toupper(names(collections)) collections <- lapply(collections, function(collection) { # pre-condition .check_lst_parameter(collection, - len_min = 1, - msg = .conf("messages", ".conf_new_source_collections") + len_min = 1L, + msg = .conf("messages", ".conf_new_source_collections") ) # collection members must be lower case names(collection) <- tolower(names(collection)) - collection <- .check_error( - { - do.call(.conf_new_collection, args = collection) - }, + .check_error( + do.call(.conf_new_collection, args = collection), msg = .conf("messages", ".conf_new_source_collections") ) - return(collection) + collection }) # extra parameters dots <- list(...) - .check_lst_parameter(dots, len_min = 0, - msg = .conf("messages", ".conf_new_source_collections_args")) + .check_lst_parameter(dots, len_min = 0L, + msg = .conf("messages", ".conf_new_source_collections_args")) - c(list( + c(list( s3_class = s3_class, service = service, url = url, @@ -631,19 +619,19 @@ .check_set_caller(".conf_new_collection") # check satellite .check_chr_parameter(satellite, - allow_null = TRUE, - msg = .conf("messages", ".conf_new_collection_satellite") + allow_null = TRUE, + msg = .conf("messages", ".conf_new_collection_satellite") ) # check sensor .check_chr(sensor, - allow_null = TRUE, - msg = .conf("messages", ".conf_new_collection_sensor") + allow_null = TRUE, + msg = .conf("messages", ".conf_new_collection_sensor") ) # check metadata_search if (!missing(metadata_search)) { .check_chr_within(metadata_search, - within = .conf("metadata_search_strategies"), - msg = .conf("messages", ".conf_new_collection_metadata") + within = .conf("metadata_search_strategies"), + msg = .conf("messages", ".conf_new_collection_metadata") ) } # check extra parameters @@ -655,14 +643,14 @@ names(bands) <- toupper(names(bands)) # pre-condition .check_lst(bands, - len_min = 1, + len_min = 1L, msg = .conf("messages", ".conf_new_collection_bands") ) # define collection bands - collection_bands <- c() + collection_bands <- NULL # handle class bands is_class_cube <- dots[["class_cube"]] - is_class_cube <- all(!is.null(is_class_cube)) + is_class_cube <- all(.has(is_class_cube)) if (is_class_cube) { # configure class bands (assuming there is no cloud band in class cubes) class_bands <- .conf_new_bands(bands, .conf_new_class_band) @@ -681,18 +669,18 @@ } # merge metadata properties res <- c(list(bands = collection_bands), - "satellite" = satellite, - "sensor" = sensor, - "metadata_search" = metadata_search, dots + "satellite" = satellite, + "sensor" = sensor, + "metadata_search" = metadata_search, dots ) # post-condition .check_lst(res, - len_min = 1, - msg = .conf("messages", ".conf_new_collection") + len_min = 1L, + msg = .conf("messages", ".conf_new_collection") ) .check_lst(res$bands, - len_min = 1, - msg = .conf("messages", ".conf_new_collection_bands") + len_min = 1L, + msg = .conf("messages", ".conf_new_collection_bands") ) # return a new collection data return(res) @@ -722,42 +710,42 @@ # pre-condition .check_num_parameter( missing_value, - len_min = 1, - len_max = 1 + len_min = 1L, + len_max = 1L ) .check_num_parameter( minimum_value, - len_min = 1, - len_max = 1 + len_min = 1L, + len_max = 1L ) .check_num_parameter( x = maximum_value, - len_min = 1, - len_max = 1 + len_min = 1L, + len_max = 1L ) .check_num_parameter( scale_factor, - len_min = 1, - len_max = 1, - exclusive_min = 0 + len_min = 1L, + len_max = 1L, + exclusive_min = 0.0 ) .check_num_parameter( offset_value, - len_min = 1, - len_max = 1 + len_min = 1L, + len_max = 1L ) .check_num_parameter( resolution, - exclusive_min = 0, - len_min = 1, - len_max = 1, + exclusive_min = 0.0, + len_min = 1L, + len_max = 1L, allow_null = TRUE ) .check_chr( band_name, allow_empty = FALSE, - len_min = 1, - len_max = 1 + len_min = 1L, + len_max = 1L ) # extra parameters dots <- list(...) @@ -775,7 +763,7 @@ # post-condition .check_lst_parameter(new_band_params, - len_min = 7 + len_min = 7L ) # return a band object new_band_params @@ -802,8 +790,8 @@ # pre-condition .check_lgl_parameter(bit_mask) .check_lst_parameter(values, fn_check = .check_chr) - .check_int_parameter(interp_values, len_min = 1) - .check_chr_parameter(band_name, len_min = 1, len_max = 1) + .check_int_parameter(interp_values, len_min = 1L) + .check_chr_parameter(band_name, len_min = 1L, len_max = 1L) # extra parameters dots <- list(...) @@ -818,7 +806,7 @@ ), dots) # post-condition - .check_lst_parameter(cloud_band_params, len_min = 5) + .check_lst_parameter(cloud_band_params, len_min = 5L) # return a cloud band object cloud_band_params } @@ -839,7 +827,7 @@ # pre-condition .check_lgl_parameter(bit_mask) .check_lst_parameter(values, fn_check = .check_chr) - .check_chr_parameter(band_name, len_min = 1, len_max = 1) + .check_chr_parameter(band_name, len_min = 1L, len_max = 1L) # check extra parameters dots <- list(...) @@ -855,7 +843,7 @@ ), dots) # post-condition - .check_lst_parameter(class_band_params, len_min = 4) + .check_lst_parameter(class_band_params, len_min = 4L) # return a class band object class_band_params } @@ -1105,42 +1093,42 @@ NULL #' @noRd #' @return Data type associated to the configuration .data_type <- function(conf) { - .as_chr(conf[["data_type"]][[1]]) + .as_chr(conf[["data_type"]][[1L]]) } #' @title Get the missing value from a band configuration #' @noRd #' @param conf A band definition value from config. #' @return Missing value associated to the band .miss_value <- function(conf) { - .as_dbl(conf[["missing_value"]][[1]]) + .as_dbl(conf[["missing_value"]][[1L]]) } #' @title Get the minimum value from a band configuration #' @noRd #' @param conf A band definition value from config. #' @return Minimum value associated to the band .min_value <- function(conf) { - .as_dbl(conf[["minimum_value"]][[1]]) + .as_dbl(conf[["minimum_value"]][[1L]]) } #' @title Get the maximum value from a band configuration #' @noRd #' @param conf A band definition value from config. #' @return Maximum value associated to the band .max_value <- function(conf) { - .as_dbl(conf[["maximum_value"]][[1]]) + .as_dbl(conf[["maximum_value"]][[1L]]) } #' @title Get the scale factor from a band configuration #' @noRd #' @param conf A band definition value from config. #' @return Scale factor associated to the band .scale <- function(conf) { - .as_dbl(conf[["scale_factor"]][[1]]) + .as_dbl(conf[["scale_factor"]][[1L]]) } #' @title Get the offset value from a band configuration #' @noRd #' @param conf A band definition value from config. #' @return Offset value associated to the band .offset <- function(conf) { - .as_dbl(conf[["offset_value"]][[1]]) + .as_dbl(conf[["offset_value"]][[1L]]) } #' @title Get the cloud interpolation values from a band configuration #' @noRd @@ -1154,7 +1142,7 @@ NULL #' @param conf A band definition value from config. #' @return Cloud bit mask values associated to the band. .cloud_bit_mask <- function(conf) { - .as_int(conf[["bit_mask"]][[1]]) + .as_int(conf[["bit_mask"]][[1L]]) } #' @title Get the default parse info for local files flag #' @noRd @@ -1214,7 +1202,7 @@ NULL sits_leaflet <- list(leaf_map = leaf_map, base_groups = base_groups, overlay_groups = vector() - ) + ) # put the object in the global sits environment sits_env[["leaflet"]] <- sits_leaflet diff --git a/R/api_crop.R b/R/api_crop.R index 721b652b9..fbf1a45d8 100644 --- a/R/api_crop.R +++ b/R/api_crop.R @@ -1,25 +1,27 @@ #' @title Crop cube #' @name .crop +#' @description cuts a data cube according to a ROI #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal #' @noRd #' @param cube Data cube -#' @param roi ROI to crop #' @param output_dir Directory where file will be written +#' @param roi ROI to crop #' @param overwrite Overwrite existing output file (Default is FALSE) +#' @param progress Show progress bar?? #' @return Cropped data cube .crop <- function(cube, - roi = NULL, - multicores = 2, output_dir, + roi = NULL, + multicores = 2L, overwrite = FALSE, progress = TRUE) { .check_set_caller("sits_crop") # Pre-conditions .check_is_raster_cube(cube) - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) .check_output_dir(output_dir) .check_lgl_parameter(progress) # Spatial filter @@ -46,7 +48,7 @@ out_file <- .file_path(.file_base(file), output_dir = output_dir) # Resume feature if (!overwrite && .raster_is_valid(out_file, output_dir = output_dir)) { - .check_recovery(out_file) + .check_recovery() asset_cropped <- .tile_from_file( file = out_file, base_tile = asset, band = .tile_bands(asset), update_bbox = TRUE, @@ -120,7 +122,7 @@ as_crs = NULL, miss_value = .miss_value(band_conf), data_type = .data_type(band_conf), - multicores = 1, + multicores = 1L, overwrite = TRUE, gdal_params ) diff --git a/R/api_csv.R b/R/api_csv.R index f2fa22f9c..87dc87462 100644 --- a/R/api_csv.R +++ b/R/api_csv.R @@ -13,20 +13,16 @@ file = csv_file, stringsAsFactors = FALSE ) - ) - # pre-condition - check if CSV file is correct - .check_samples(samples) - # select valid columns - samples <- dplyr::select( - samples, - .conf("df_sample_columns") - ) - # transform to date - samples <- dplyr::mutate( - samples, - start_date = as.Date(.data[["start_date"]]), - end_date = as.Date(.data[["end_date"]]) - ) + ) |> + # select valid columns + dplyr::select( + .conf("df_sample_columns") + ) |> + # transform to date + dplyr::mutate( + start_date = as.Date(.data[["start_date"]]), + end_date = as.Date(.data[["end_date"]]) + ) class(samples) <- c("sits", class(samples)) samples } @@ -42,20 +38,17 @@ #' .csv_get_validation_samples <- function(csv_file) { # read sample information from CSV file and put it in a tibble - samples <- tibble::as_tibble( + tibble::as_tibble( utils::read.csv( file = csv_file, stringsAsFactors = FALSE ) - ) - # pre-condition - check if CSV file is correct - .check_samples(samples) - samples <- .samples_convert_to_sits(samples) - # select valid columns - dplyr::select( - samples, - c("longitude", "latitude", "label") - ) + ) |> + .samples_convert_to_sits() |> + # select valid columns + dplyr::select( + c("longitude", "latitude", "label") + ) } #' @title Transform a CSV with lat/long into samples #' @name .csv_get_lat_lon @@ -67,17 +60,16 @@ #' .csv_get_lat_lon <- function(csv_file) { # read sample information from CSV file and put it in a tibble - samples <- tibble::as_tibble( + tibble::as_tibble( utils::read.csv( file = csv_file, stringsAsFactors = FALSE ) - ) - # select valid columns - dplyr::select( - samples, - c("longitude", "latitude") - ) + ) |> + # select valid columns + dplyr::select( + c("longitude", "latitude") + ) } #' @title Get samples metadata as CSV #' @name .csv_metadata_from_samples @@ -93,7 +85,7 @@ csv <- dplyr::select(data, dplyr::all_of(csv_columns)) # create a column with the id n_rows_csv <- nrow(csv) - id <- tibble::tibble(id = 1:n_rows_csv) + id <- tibble::tibble(id = seq_len(n_rows_csv)) # join the two tibbles dplyr::bind_cols(id, csv) } diff --git a/R/api_cube.R b/R/api_cube.R index 54b3ce8cb..8b95b97e9 100644 --- a/R/api_cube.R +++ b/R/api_cube.R @@ -51,7 +51,7 @@ NULL is_sar <- .try({ .conf("sources", source, "collections", collection, "sar_cube") }, - .default = FALSE + .default = FALSE ) is_sar <- is_sar && !grepl("rtc", base_class, fixed = TRUE) if (is_sar) { @@ -73,7 +73,7 @@ NULL is_sar <- .try({ .conf("sources", source, "collections", collection, "sar_cube") }, - .default = FALSE + .default = FALSE ) is_sar <- is_sar && grepl("rtc", base_class, fixed = TRUE) @@ -97,7 +97,7 @@ NULL is_dem <- .try({ .conf("sources", source, "collections", collection, "dem_cube") }, - .default = FALSE + .default = FALSE ) if (is_dem) { @@ -133,18 +133,18 @@ NULL #' @param cube_class Current cube class. #' @return cube classes .cube_class_strategy_class <- function( - base_class, source, collection, s3_class, cube_class, ... + base_class, source, collection, s3_class, cube_class, ... ) { is_class <- .try({ .conf("sources", source, "collections", collection, "class_cube") }, - .default = FALSE + .default = FALSE ) if (is_class) { # explicitly defining a `class_cube` following the definition from the # `sits_label_classification` function. c("class_cube", "derived_cube", "raster_cube", - base_class, "tbl_df", "tbl", "data.frame") + base_class, "tbl_df", "tbl", "data.frame") } } #' @title Registry of class definition strategies @@ -193,7 +193,7 @@ NULL # remove invalid values cube_class_new <- purrr::flatten_chr(cube_class_new) # use the default cube if any class was found - if (length(cube_class_new) == 0) { + if (length(cube_class_new) == 0L) { cube_class_new <- .cube_class_strategy_default( base_class, source, @@ -369,8 +369,8 @@ NULL # Names of area are the classes names(class_areas) <- freq[["class"]] # NAs are set to 0 - class_areas[is.na(class_areas)] <- 0 - return(class_areas) + class_areas[is.na(class_areas)] <- 0.0 + class_areas } #' @title Return bands of a data cube @@ -433,7 +433,7 @@ NULL } #' @export .cube_labels.derived_cube <- function(cube, dissolve = FALSE) { - cube[["labels"]][[1]] + cube[["labels"]][[1L]] } #' @export .cube_labels.raster_cube <- function(cube, dissolve = TRUE) { @@ -452,7 +452,7 @@ NULL } else { stop(.conf("messages", "cube_labels")) } - labels + labels } #' @export .cube_labels.default <- function(cube, dissolve = TRUE) { @@ -480,14 +480,12 @@ NULL } #' @export .cube_collection.default <- function(cube) { - if (is.list(cube)) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - collection <- .cube_collection(cube) - return(collection) - } else { - stop(.conf("messages", "cube_collection")) - } + .check_that(is.list(cube), + msg = .conf("messages", "cube_collection")) + cube |> + tibble::as_tibble() |> + .cube_find_class() |> + .cube_collection() } #' @title Return crs of a data cube #' @keywords internal @@ -523,10 +521,10 @@ NULL } #' @export .cube_period.default <- function(cube) { - cube <- tibble::as_tibble(cube) - cube <- .cube_find_class(cube) - period <- .cube_period(cube) - return(period) + cube |> + tibble::as_tibble() |> + .cube_find_class() |> + .cube_period() } #' @title Adjust crs of a data cube #' @keywords internal @@ -595,7 +593,7 @@ NULL collection <- .tile_collection(cube) s3_class <- .source_s3class(source = source) col_class <- paste( - s3_class[[1]], + s3_class[[1L]], tolower(collection), sep = "_" ) @@ -613,7 +611,7 @@ NULL cube <- cube |> tibble::as_tibble() |> .cube_find_class() - .cube_s3class(cube) + .cube_s3class(cube) } #' @title Return the X resolution #' @name .cube_xres @@ -773,7 +771,7 @@ NULL } #' @export .cube_is_complete.raster_cube <- function(cube) { - if (length(.cube_bands(cube, dissolve = FALSE)) > 1) { + if (length(.cube_bands(cube, dissolve = FALSE)) > 1L) { return(FALSE) } all(slider::slide_lgl(cube, .tile_is_complete)) @@ -803,7 +801,7 @@ NULL if (!.cube_has_unique_tile_size(cube)) { is_regular <- FALSE } - if (length(.cube_timeline(cube)) > 1) { + if (length(.cube_timeline(cube)) > 1L) { is_regular <- FALSE } is_regular @@ -816,7 +814,7 @@ NULL #' @param cube datacube #' @return Called for side effects. .cube_has_unique_period <- function(cube) { - length(.cube_period(cube)) == 1 + length(.cube_period(cube)) == 1L } #' @title Check that cube is a base cube @@ -1045,7 +1043,7 @@ NULL .tile_filter_dates(tile, dates[dates_in_tile]) }) # Post-condition - .check_that(nrow(cube) >= 1) + .check_that(nrow(cube) >= 1L) cube } #' @export @@ -1175,7 +1173,7 @@ NULL features[["feature"]] <- features[["fid"]] features <- tidyr::nest(features, file_info = -c("tile", "feature")) # Replicate each tile so that we can copy file_info to cube - tile <- tile[rep(1, nrow(features)), ] + tile <- tile[rep(1L, nrow(features)), ] tile[["file_info"]] <- features[["file_info"]] tile }) @@ -1208,7 +1206,7 @@ NULL file_info = -c("tile", "feature", "asset") ) # Replicate each tile so that we can copy file_info to cube - tile <- tile[rep(1, nrow(assets)), ] + tile <- tile[rep(1L, nrow(assets)), ] tile[["file_info"]] <- assets[["file_info"]] tile }) @@ -1225,7 +1223,7 @@ NULL file_info = -c("tile", "asset") ) # Replicate each tile so that we can copy file_info to cube - tile <- tile[rep(1, nrow(assets)), ] + tile <- tile[rep(1L, nrow(assets)), ] tile[["file_info"]] <- assets[["file_info"]] tile }) @@ -1247,21 +1245,19 @@ NULL #' @export .cube_merge_tiles.raster_cube <- function(cube) { class_orig <- class(cube) - derived_cube <- inherits(cube, "derived_cube") cube <- tidyr::unnest(cube, "file_info", names_sep = ".") - if (!derived_cube) { + if (!inherits(cube, "derived_cube")) { cube <- dplyr::distinct(cube) } - cube <- dplyr::arrange( - cube, - .data[["file_info.date"]], - .data[["file_info.band"]] - ) - cube <- tidyr::nest( - cube, - file_info = tidyr::starts_with("file_info"), - .names_sep = "." - ) + cube <- cube |> + dplyr::arrange( + .data[["file_info.date"]], + .data[["file_info.band"]] + ) |> + tidyr::nest( + file_info = tidyr::starts_with("file_info"), + .names_sep = "." + ) # Set class features for the cube class(cube) <- class_orig # Return cube @@ -1270,15 +1266,15 @@ NULL #' @export .cube_merge_tiles.derived_cube <- function(cube) { class_orig <- class(cube) - cube <- tidyr::unnest(cube, "file_info", names_sep = ".") - cube <- dplyr::arrange( - cube, .data[["file_info.start_date"]], .data[["file_info.band"]] - ) - cube <- tidyr::nest( - cube, - file_info = tidyr::starts_with("file_info"), - .names_sep = "." - ) + cube <- cube |> + tidyr::unnest("file_info", names_sep = ".") |> + dplyr::arrange( + .data[["file_info.start_date"]], .data[["file_info.band"]] + ) |> + tidyr::nest( + file_info = tidyr::starts_with("file_info"), + .names_sep = "." + ) # Set class features for the cube class(cube) <- class_orig # Return cube @@ -1334,11 +1330,11 @@ NULL max_ymin <- max(file_info[["ymin"]]) min_ymin <- min(file_info[["ymin"]]) - test <- .is_eq(max_xmax, min_xmax, tolerance = tolerance) && - .is_eq(max_xmin, min_xmin, tolerance = tolerance) && - .is_eq(max_ymin, min_ymin, tolerance = tolerance) && - .is_eq(max_ymax, min_ymax, tolerance = tolerance) - return(test) + .is_eq(max_xmax, min_xmax, tolerance = tolerance) && + .is_eq(max_xmin, min_xmin, tolerance = tolerance) && + .is_eq(max_ymin, min_ymin, tolerance = tolerance) && + .is_eq(max_ymax, min_ymax, tolerance = tolerance) + }) all(equal_bbox) } @@ -1353,9 +1349,9 @@ NULL test_cube_size <- slider::slide_lgl( cube, function(tile) { - (length(unique(.tile_nrows(tile))) == 1 && - length(unique(.tile_ncols(tile))) == 1) - }) + (length(unique(.tile_nrows(tile))) == 1L && + length(unique(.tile_ncols(tile))) == 1L) + }) all(test_cube_size) } @@ -1366,7 +1362,7 @@ NULL #' @param cube input data cube #' @return TRUE/FALSE .cube_has_unique_resolution <- function(cube) { - length(c(.cube_xres(cube), .cube_yres(cube))) == 2 + length(c(.cube_xres(cube), .cube_yres(cube))) == 2L } # ---- derived_cube ---- #' @title Get derived class of a cube @@ -1435,7 +1431,7 @@ NULL cube <- slider::slide_dfr(cube, function(tile) { # Generate a random time to make a new request - sleep_time <- sample(x = seq_len(sleep_time), size = 1) + sleep_time <- sample.int(sleep_time, size = 1L) # Get tile file info file_info <- .fi(tile) # Add token into paths URL @@ -1466,16 +1462,16 @@ NULL fi[["token_expires"]] <- .mpc_get_token_datetime( available_tks, token_info ) - return(fi) + fi }) tile[["file_info"]] <- list(file_info) - return(tile) + tile }) - return(cube) + cube } #' @export .cube_token_generator.default <- function(cube) { - return(cube) + cube } #' @title Check if a cube token was expired @@ -1490,7 +1486,7 @@ NULL } #' @export .cube_is_token_expired.mpc_cube <- function(cube) { - file_info <- cube[["file_info"]][[1]] + file_info <- cube[["file_info"]][[1L]] fi_paths <- file_info[["path"]] min_remaining_time <- .conf( @@ -1503,14 +1499,14 @@ NULL } if ("token_expires" %in% colnames(file_info)) { difftime_token <- difftime( - time1 = file_info[["token_expires"]][[1]], + time1 = file_info[["token_expires"]][[1L]], time2 = as.POSIXct(format(Sys.time(), tz = "UTC", usetz = TRUE)), units = "mins" ) return(difftime_token < min_remaining_time) } - return(FALSE) + FALSE } #' @export .cube_is_token_expired.default <- function(cube) { @@ -1557,7 +1553,7 @@ NULL cube_chunks <- slider::slide(cube, function(tile) { chunks <- .tile_chunks_create( tile = tile, - overlap = 0, + overlap = 0L, block = block ) chunks_sf <- .bbox_as_sf( @@ -1565,7 +1561,7 @@ NULL ) chunks_sf <- dplyr::bind_cols(chunks_sf, chunks) chunks_sf <- chunks_sf[.intersects(chunks_sf, samples_sf), ] - if (nrow(chunks_sf) == 0) + if (nrow(chunks_sf) == 0L) return(NULL) chunks_sf[["tile"]] <- tile[["tile"]] chunks_sf <- dplyr::group_by(chunks_sf, .data[["row"]], .data[["tile"]]) diff --git a/R/api_data.R b/R/api_data.R index 52e71739b..ea03279e8 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -62,7 +62,7 @@ block <- .raster_file_blocksize(rast) # 1st case - split samples by tiles if ((.raster_nrows(rast) == block[["nrows"]] && - .raster_ncols(rast) == block[["ncols"]]) || + .raster_ncols(rast) == block[["ncols"]]) || inherits(cube, "dem_cube")) { # split samples by bands and tile ts_tbl <- .data_by_tile( @@ -102,8 +102,8 @@ ) # prepare output data base_tbl <- base_tbl |> - dplyr::select("longitude", "latitude", "time_series") |> - dplyr::rename("base_data" = "time_series") + dplyr::select("longitude", "latitude", "time_series") |> + dplyr::rename("base_data" = "time_series") # Assuming `ts_tbl` as the source of truth, the size of the following # `join` must be the same as the current `ts_tbl`. ts_tbl_size <- nrow(ts_tbl) @@ -143,7 +143,7 @@ } .check_cube_bands(cube, bands = bands) # get cubes timeline - tl <- .cube_timeline(cube)[[1]] + tl <- .cube_timeline(cube)[[1L]] # create tile-band pairs for parallelization tiles_bands <- tidyr::expand_grid( tile = .cube_tiles(cube), @@ -165,8 +165,8 @@ tiles_bands, function(tile_band) { # select tile and band - tile_id <- tile_band[[1]] - band <- tile_band[[2]] + tile_id <- tile_band[[1L]] + band <- tile_band[[2L]] tile <- .select_raster_cube(cube, bands = band, tiles = tile_id) # create a hash to store temporary samples file hash_bundle <- digest::digest(list(tile, samples), algo = "md5") @@ -204,17 +204,17 @@ .data[["Y"]] > tile[["ymin"]], .data[["Y"]] < tile[["ymax"]], .data[["start_date"]] <= as.Date(tl[[length(tl)]]), - .data[["end_date"]] >= as.Date(tl[[1]]) + .data[["end_date"]] >= as.Date(tl[[1L]]) ) # are there points to be retrieved from the cube? - if (nrow(samples) == 0) { + if (nrow(samples) == 0L) { return(NULL) } # create a matrix to extract the values xy <- matrix( c(samples[["X"]], samples[["Y"]]), nrow = nrow(samples), - ncol = 2 + ncol = 2L ) colnames(xy) <- c("X", "Y") # build the sits tibble for the storing the points @@ -228,7 +228,7 @@ sample <- tibble::tibble( longitude = point[["longitude"]], latitude = point[["latitude"]], - start_date = dates[[1]], + start_date = dates[[1L]], end_date = dates[[length(dates)]], label = point[["label"]], cube = tile[["collection"]], @@ -237,7 +237,7 @@ # store them in the sample tibble sample[["predicted"]] <- list(tibble::tibble( # from 1 to the number of dates (can be more than one) - from = dates[[1]], to = dates[[length(dates)]] + from = dates[[1L]], to = dates[[length(dates)]] )) # return valid row of time series sample @@ -291,13 +291,13 @@ .data[["start_date"]], .data[["end_date"]], .data[["label"]], .data[["cube"]] ) |> - dplyr::slice_head(n = 1) |> + dplyr::slice_head(n = 1L) |> dplyr::ungroup() # recreate hash values hash_bundle <- purrr::map_chr(tiles_bands, function(tile_band) { - tile_id <- tile_band[[1]] - band <- tile_band[[2]] + tile_id <- tile_band[[1L]] + band <- tile_band[[2L]] tile <- .select_raster_cube(cube, bands = band, tiles = tile_id) digest::digest(list(tile, samples), algo = "md5") }) @@ -330,7 +330,7 @@ #' .data_check <- function(n_rows_input, n_rows_output) { # Have all input rows being read? - if (n_rows_output == 0) { + if (n_rows_output == 0L) { message("No points have been retrieved") return(invisible(FALSE)) } @@ -399,7 +399,7 @@ progress) { .check_set_caller(".data_by_tile") # Get cube timeline - tl <- .cube_timeline(cube)[[1]] + tl <- .cube_timeline(cube)[[1L]] # Get tile-band combination tiles_bands <- .cube_split_tiles_bands(cube = cube, bands = bands) # Set output_dir @@ -416,8 +416,8 @@ on.exit(.parallel_stop(), add = TRUE) # Get the samples in parallel using tile-band combination samples_tiles_bands <- .parallel_map(tiles_bands, function(tile_band) { - tile_id <- tile_band[[1]] - band <- tile_band[[2]] + tile_id <- tile_band[[1L]] + band <- tile_band[[2L]] tile <- .select_raster_cube( data = cube, @@ -460,18 +460,18 @@ .data[["Y"]] > tile[["ymin"]], .data[["Y"]] < tile[["ymax"]], .data[["start_date"]] <= as.Date(tl[length(tl)]), - .data[["end_date"]] >= as.Date(tl[[1]]) + .data[["end_date"]] >= as.Date(tl[[1L]]) ) # are there points to be retrieved from the cube? - if (nrow(samples) == 0) { + if (nrow(samples) == 0L) { return(NULL) } # create a matrix to extract the values xy <- matrix( c(samples[["X"]], samples[["Y"]]), nrow = nrow(samples), - ncol = 2 + ncol = 2L ) colnames(xy) <- c("X", "Y") # build the sits tibble for the storing the points @@ -485,7 +485,7 @@ sample <- tibble::tibble( longitude = point[["longitude"]], latitude = point[["latitude"]], - start_date = dates[[1]], + start_date = dates[[1L]], end_date = dates[[length(dates)]], label = point[["label"]], cube = tile[["collection"]], @@ -550,15 +550,15 @@ .data[["start_date"]], .data[["end_date"]], .data[["label"]], .data[["cube"]] ) |> - dplyr::slice_head(n = 1) |> + dplyr::slice_head(n = 1L) |> dplyr::ungroup() # recreate hash values hash_bundle <- purrr::map_chr(tiles_bands, function(tile_band) { - tile_id <- tile_band[[1]] - band <- tile_band[[2]] + tile_id <- tile_band[[1L]] + band <- tile_band[[2L]] tile <- .select_raster_cube(cube, bands = c(band, cld_band), tiles = tile_id - ) + ) digest::digest(list(tile, samples), algo = "md5") }) # recreate file names to delete them @@ -602,7 +602,7 @@ multicores, progress) { # Get cube timeline - tl <- .cube_timeline(cube)[[1]] + tl <- .cube_timeline(cube)[[1L]] # transform sits tibble to sf samples_sf <- sits_as_sf(samples) # Get chunks samples @@ -629,7 +629,7 @@ tiles = chunk[["tile"]] ) # Get chunk samples - samples <- chunk[["samples"]][[1]] + samples <- chunk[["samples"]][[1L]] hash_bundle <- digest::digest(list(tile, samples), algo = "md5") # Create a file to store the samples filename <- .file_path( @@ -666,17 +666,17 @@ .data[["Y"]] > tile[["ymin"]], .data[["Y"]] < tile[["ymax"]], .data[["start_date"]] <= as.Date(tl[[length(tl)]]), - .data[["end_date"]] >= as.Date(tl[[1]]) + .data[["end_date"]] >= as.Date(tl[[1L]]) ) # are there points to be retrieved from the cube? - if (nrow(samples) == 0) { + if (nrow(samples) == 0L) { return(NULL) } # create a matrix to extract the values xy <- matrix( c(samples[["X"]], samples[["Y"]]), nrow = nrow(samples), - ncol = 2 + ncol = 2L ) colnames(xy) <- c("X", "Y") # build the sits tibble for the storing the points @@ -690,7 +690,7 @@ sample <- tibble::tibble( longitude = point[["longitude"]], latitude = point[["latitude"]], - start_date = dates[[1]], + start_date = dates[[1L]], end_date = dates[[length(dates)]], label = point[["label"]], cube = tile[["collection"]], @@ -719,7 +719,7 @@ ts_tbl <- dplyr::bind_rows(samples_tiles_bands) if (!.has_ts(ts_tbl)) { warning(.conf("messages", ".data_by_chunks"), - immediate. = TRUE, call. = FALSE + immediate. = TRUE, call. = FALSE ) return(.tibble()) } @@ -753,7 +753,7 @@ .data[["start_date"]], .data[["end_date"]], .data[["label"]], .data[["cube"]] ) |> - dplyr::slice_head(n = 1) |> + dplyr::slice_head(n = 1L) |> dplyr::ungroup() # recreate hash values hash_bundle <- purrr::map_chr(chunks_samples, function(chunk) { @@ -763,7 +763,7 @@ tiles = chunk[["tile"]] ) # Get chunk samples - samples <- chunk[["samples"]][[1]] + samples <- chunk[["samples"]][[1L]] digest::digest(list(tile, samples), algo = "md5") }) # recreate file names to delete them @@ -820,14 +820,14 @@ ) # are there points to be retrieved from the cube? - if (nrow(samples) == 0) { + if (nrow(samples) == 0L) { return(NULL) } # create a matrix to extract the values xy <- matrix( c(samples[["X"]], samples[["Y"]]), nrow = nrow(samples), - ncol = 2 + ncol = 2L ) colnames(xy) <- c("X", "Y") @@ -876,14 +876,14 @@ ) # are there points to be retrieved from the cube? - if (nrow(samples) == 0) { + if (nrow(samples) == 0L) { return(NULL) } # create a matrix to extract the values xy <- matrix( c(samples[["X"]], samples[["Y"]]), nrow = nrow(samples), - ncol = 2 + ncol = 2L ) colnames(xy) <- c("X", "Y") @@ -898,7 +898,7 @@ # insert classes into samples samples[["label"]] <- unname(classes) samples <- dplyr::select(samples, dplyr::all_of("longitude"), - dplyr::all_of("latitude"), dplyr::all_of("label")) + dplyr::all_of("latitude"), dplyr::all_of("label")) samples }) data @@ -941,14 +941,14 @@ ) # are there points to be retrieved from the cube? - if (nrow(samples) == 0) { + if (nrow(samples) == 0L) { return(NULL) } # create a matrix to extract the values xy <- matrix( c(samples[["X"]], samples[["Y"]]), nrow = nrow(samples), - ncol = 2 + ncol = 2L ) colnames(xy) <- c("X", "Y") @@ -981,11 +981,11 @@ values <- .raster_extract(rast, xy) offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { + if (.has(offset) && offset != 0.0) { values <- values - offset } scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { + if (.has(scale) && scale != 1.0) { values <- values * scale } colnames(values) <- .tile_labels(tile) @@ -1010,19 +1010,19 @@ # open spatial raster object rast <- .raster_open_rast(.tile_path(tile)) # overlap in pixel - overlap <- ceiling(window_size / 2) - 1 + overlap <- ceiling(window_size / 2L) - 1L # number of rows and cols nrows <- .raster_nrows(rast) ncols <- .raster_ncols(rast) # slide for each XY position - data <- slider::slide2_dfr(xy[, 1], xy[, 2], function(x, y) { + data <- slider::slide2_dfr(xy[, 1L], xy[, 2L], function(x, y) { # find the cells to be retrieved center_row <- .raster_row(rast, y) center_col <- .raster_col(rast, x) - top_row <- max(center_row - overlap, 1) + top_row <- max(center_row - overlap, 1L) bottow_row <- min(center_row + overlap, nrows) - left_col <- max(center_col - overlap, 1) + left_col <- max(center_col - overlap, 1L) right_col <- min(center_col + overlap, ncols) # build a vector of cells cells <- vector() @@ -1031,18 +1031,15 @@ cells <- c(cells, .raster_cell_from_rowcol(rast, row, col)) values <- .raster_extract(rast, cells) offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { + if (.has(offset) && offset != 0.0) { values <- values - offset } scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { + if (.has(scale) && scale != 1.0) { values <- values * scale } - # build a tibble to store the values - data <- tibble::tibble( - neighbors = list(values) - ) - return(data) + # build a tibble to store the values and return + tibble::tibble(neighbors = list(values)) }) # insert classes into samples dplyr::bind_cols(samples, data) diff --git a/R/api_debug.R b/R/api_debug.R index b2087811e..8b52533ac 100644 --- a/R/api_debug.R +++ b/R/api_debug.R @@ -53,7 +53,7 @@ time1 = time, time2 = sits_env[["log_time"]], units = "secs" - )[[1]], digits = 4) + )[[1L]], digits = 4L) } # Add log header once if (is.null(elapsed_time)) { @@ -71,8 +71,8 @@ } # Log entry cat(paste0(paste( - esc(time), Sys.getpid(), esc(event[[1]]), elapsed_time, - sum(mem[, 2]), sum(mem[, 6]), esc(key[[1]]), esc(list(value)), + esc(time), Sys.getpid(), esc(event[[1L]]), elapsed_time, + sum(mem[, 2L]), sum(mem[, 6L]), esc(key[[1L]]), esc(list(value)), sep = ", " ), "\n"), file = log_file, append = TRUE) return(invisible(NULL)) diff --git a/R/api_detect_change.R b/R/api_detect_change.R index 1a78e68fb..ad45bf175 100644 --- a/R/api_detect_change.R +++ b/R/api_detect_change.R @@ -80,9 +80,7 @@ ) # Resume feature if (file.exists(out_file)) { - if (.check_messages()) { - .check_recovery(out_file) - } + .check_recovery() seg_tile <- .tile_segments_from_file( file = out_file, band = band, @@ -100,7 +98,7 @@ # Create chunks as jobs chunks <- .tile_chunks_create( tile = tile, - overlap = 0, + overlap = 0L, block = block ) # By default, update_bbox is FALSE @@ -249,36 +247,36 @@ #' @export .detect_change_tile_prep.bayts_model <- function(dc_method, tile, ..., impute_fn) { - deseasonlize <- environment(dc_method)[["deseasonlize"]] - - if (!.has(deseasonlize)) { - return(matrix(NA)) - } + deseasonlize <- environment(dc_method)[["deseasonlize"]] - tile_bands <- .tile_bands(tile, FALSE) - quantile_values <- purrr::map(tile_bands, function(tile_band) { - tile_paths <- .tile_paths(tile, bands = tile_band) - rast <- .raster_open_rast(tile_paths) - quantile_values <- .raster_quantile( - rast, quantile = deseasonlize, na.rm = TRUE - ) - quantile_values <- impute_fn(t(quantile_values)) - # Fill with zeros remaining NA pixels - quantile_values <- C_fill_na(quantile_values, 0) - # Apply scale - band_conf <- .tile_band_conf(tile = tile, band = tile_band) - scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { - quantile_values <- quantile_values * scale + if (!.has(deseasonlize)) { + return(matrix(NA)) } - offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { - quantile_values <- quantile_values + offset - } - unname(quantile_values) - }) - do.call(cbind, quantile_values) -} + + tile_bands <- .tile_bands(tile, FALSE) + quantile_values <- purrr::map(tile_bands, function(tile_band) { + tile_paths <- .tile_paths(tile, bands = tile_band) + rast <- .raster_open_rast(tile_paths) + quantile_values <- .raster_quantile( + rast, quantile = deseasonlize, na.rm = TRUE + ) + quantile_values <- impute_fn(t(quantile_values)) + # Fill with zeros remaining NA pixels + quantile_values <- C_fill_na(quantile_values, 0.0) + # Apply scale + band_conf <- .tile_band_conf(tile = tile, band = tile_band) + scale <- .scale(band_conf) + if (.has(scale) && scale != 1.0) { + quantile_values <- quantile_values * scale + } + offset <- .offset(band_conf) + if (.has(offset) && offset != 0.0) { + quantile_values <- quantile_values + offset + } + unname(quantile_values) + }) + do.call(cbind, quantile_values) + } #' @title Pre-process tile to run detect_change method (bayts) #' @name .detect_change_create_timeline #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} @@ -295,7 +293,7 @@ tile_tl <- .as_chr(.tile_timeline(tile)) tile_tl <- c("0", tile_tl) names(tile_tl) <- seq.int( - from = 0, to = length(tile_tl) - 1, by = 1 + from = 0L, to = length(tile_tl) - 1L, by = 1L ) tile_tl } @@ -315,16 +313,16 @@ nrows = block[["nrows"]], ncols = block[["ncols"]], xmin = bbox[["xmin"]], xmax = bbox[["xmax"]], ymin = bbox[["ymin"]], ymax = bbox[["ymax"]], - nlayers = 1, crs = bbox[["crs"]] + nlayers = 1L, crs = bbox[["crs"]] ) # Set values and NA value in template raster values <- .raster_set_values(template_raster, values) - values <- .raster_set_na(values, 0) + values <- .raster_set_na(values, 0.0) names(values) <- "date" # Extract polygons raster and convert to sf object values <- .raster_extract_polygons(values, dissolve = TRUE) values <- sf::st_as_sf(values) - if (nrow(values) == 0) { + if (nrow(values) == 0L) { return(values) } # Get only polygons segments @@ -371,5 +369,5 @@ #' @param dc_method Detect change method #' @return Class of the model. .dc_class <- function(dc_method) { - class(dc_method)[[1]] + class(dc_method)[[1L]] } diff --git a/R/api_download.R b/R/api_download.R index 6c2a8dad2..8722b60bf 100644 --- a/R/api_download.R +++ b/R/api_download.R @@ -41,7 +41,7 @@ output_dir = output_dir ) # Try to download - while (n_tries > 0) { + while (n_tries > 0L) { # Check if the output file already exists if (.raster_is_valid(output_file)) { local_asset <- .tile_from_file( @@ -69,11 +69,11 @@ return(local_asset) } # If file is not valid, try to download it again. - n_tries <- n_tries - 1 + n_tries <- n_tries - 1L # Generate random seconds to wait before try again. This approach # is used to avoid flood the server. secs_to_retry <- .conf("download_sleep_time") - secs_to_retry <- sample.int(secs_to_retry, size = 1) + secs_to_retry <- sample.int(secs_to_retry, size = 1L) Sys.sleep(secs_to_retry) } # Return local asset diff --git a/R/api_dtw.R b/R/api_dtw.R index 1aa832836..2820106f9 100644 --- a/R/api_dtw.R +++ b/R/api_dtw.R @@ -21,7 +21,7 @@ data.frame(distance = dtw_distance(data_in_window, pattern_ts)) }) # Associate the pattern name with the distances - stats::setNames(distances, pattern[["label"]][[1]]) + stats::setNames(distances, pattern[["label"]][[1L]]) }) } # ---- Operation mode ---- @@ -34,16 +34,16 @@ #' @noRd .dtw_cube <- function(values, patterns, window, threshold, ...) { # Extract dates - dates <- .ts_index(values[[1]]) - dates_min <- .ts_min_date(values[[1]]) - dates_max <- .ts_max_date(values[[1]]) + dates <- .ts_index(values[[1L]]) + dates_min <- .ts_min_date(values[[1L]]) + dates_max <- .ts_max_date(values[[1L]]) # Assume time-series are regularized, then use the period # as the step of the moving window. As a result, we have # one step per iteration. dates_step <- lubridate::as.period( - lubridate::int_diff(.ts_index(values[[1]])) + lubridate::int_diff(.ts_index(values[[1L]])) ) - dates_step <- dates_step[[1]] + dates_step <- dates_step[[1L]] # Create comparison windows comparison_windows <- .period_windows( period = window, @@ -84,16 +84,16 @@ #' @noRd .dtw_ts <- function(values, patterns, window, threshold, ...) { # Extract dates - dates <- .ts_index(values[[1]]) - dates_min <- .ts_min_date(values[[1]]) - dates_max <- .ts_max_date(values[[1]]) + dates <- .ts_index(values[[1L]]) + dates_min <- .ts_min_date(values[[1L]]) + dates_max <- .ts_max_date(values[[1L]]) # Assume time-series are regularized, then use the period # as the step of the moving window. As a result, we have # one step per iteration. dates_step <- lubridate::as.period( - lubridate::int_diff(.ts_index(values[[1]])) + lubridate::int_diff(.ts_index(values[[1L]])) ) - dates_step <- dates_step[[1]] + dates_step <- dates_step[[1L]] # Create comparison windows comparison_windows <- .period_windows( period = window, @@ -119,7 +119,7 @@ patterns_distances[patterns_distances < threshold] <- NA # Define where each label was detected. For this, first # get from each label the minimal distance - detections_idx <- apply(patterns_distances, 2, which.max) + detections_idx <- apply(patterns_distances, 2.0, which.max) detections_name <- names(detections_idx) # For each label, extract the metadata where they had # minimal distance diff --git a/R/api_file.R b/R/api_file.R index d0696882d..0ccbafed7 100644 --- a/R/api_file.R +++ b/R/api_file.R @@ -71,7 +71,7 @@ if (!dir.exists(output_dir) && create_dir) { dir.create(output_dir, recursive = TRUE) } - filenames <- if (length(filenames) == 0) "" else filenames + filenames <- if (.has_not(filenames)) "" else filenames filenames <- file.path(output_dir, filenames) } filenames diff --git a/R/api_file_info.R b/R/api_file_info.R index e47874257..ef15e706a 100644 --- a/R/api_file_info.R +++ b/R/api_file_info.R @@ -13,7 +13,7 @@ NULL #' @param tile A tile. #' @returns A `file_info` tibble. .fi <- function(tile) { - fi <- tile[["file_info"]][[1]] + fi <- tile[["file_info"]][[1L]] fi } #' @title Set `file_info` into a given tile. @@ -95,9 +95,9 @@ NULL files <- .file_path_expand(files) rast <- .raster_open_rast(files) .fi_eo( - fid = fid[[1]], + fid = fid[[1L]], band = bands, - date = date[[1]], + date = date[[1L]], ncols = .raster_ncols(rast), nrows = .raster_nrows(rast), xres = .raster_xres(rast), @@ -190,10 +190,11 @@ NULL if ("cloud_cover" %in% colnames(fi)) { image <- fi |> dplyr::arrange(.data[["cloud_cover"]]) |> - dplyr::slice(1) - return(as.Date(image[["date"]])) - } else - return(as.Date(.fi_timeline(fi))) + dplyr::slice(1L) + as.Date(image[["date"]]) + } else { + as.Date(.fi_timeline(fi)) + } } #' @title Filter file_info for a file_info ID #' @noRd @@ -292,7 +293,7 @@ NULL #' @param fi file_info #' @returns first file path .fi_path <- function(fi) { - .as_chr(fi[["path"]][[1]]) + .as_chr(fi[["path"]][[1L]]) } #' @title Filter file_info for a temporal interval #' @noRd @@ -304,8 +305,8 @@ NULL fi_tl <- .fi_timeline(fi) .fi_switch( fi = fi, - eo_cube = .between(fi_tl, start_date[[1]], end_date[[1]]), - derived_cube = all(.between(fi_tl, start_date[[1]], end_date[[1]])) + eo_cube = .between(fi_tl, start_date[[1L]], end_date[[1L]]), + derived_cube = all(.between(fi_tl, start_date[[1L]], end_date[[1L]])) ) } #' @title Filter file_info for a temporal interval @@ -326,7 +327,7 @@ NULL ) if (!any(dates_in_fi)) { stop(.conf("messages", ".fi_filter_interval"), - start_date[[1]], end_date[[1]]) + start_date[[1L]], end_date[[1L]]) } fi[dates_in_fi, ] } @@ -351,7 +352,7 @@ NULL #' @param block selected block #' @returns image values for the selected band and block .fi_read_block <- function(fi, band, block) { - band <- band[[1]] + band <- band[[1L]] # Stops if no band is found fi <- .fi_filter_bands(fi = fi, bands = band) files <- .fi_paths(fi) @@ -384,5 +385,5 @@ NULL #' @param fi file_info #' @returns TRUE/FALSE .fi_is_complete <- function(fi) { - length(unique(.by(fi, col = "band", .fi_timeline))) <= 1 + length(unique(.by(fi, col = "band", .fi_timeline))) <= 1L } diff --git a/R/api_gdal.R b/R/api_gdal.R index 11615f517..1a461df06 100644 --- a/R/api_gdal.R +++ b/R/api_gdal.R @@ -20,7 +20,6 @@ if (!.has(params)) { return(character(0)) } - unlist(mapply(function(par, val) { if (is.null(val)) { NULL @@ -69,8 +68,8 @@ .gdal_as_srcwin <- function(asset, roi) { block <- .raster_sub_image(tile = asset, roi = roi) list( - xoff = block[["col"]] - 1, - yoff = block[["row"]] - 1, + xoff = block[["col"]] - 1L, + yoff = block[["row"]] - 1L, xsize = block[["ncols"]], ysize = block[["nrows"]] ) @@ -87,14 +86,15 @@ #' @param quiet TRUE/FALSE #' @returns Called for side effects .gdal_translate <- function(file, base_file, params, - conf_opts = character(0), quiet) { + conf_opts = character(0L), quiet) { sf::gdal_utils( - util = "translate", source = base_file[[1]], destination = file[[1]], + util = "translate", source = base_file[[1L]], destination = file[[1L]], options = .gdal_params(params), config_options = conf_opts, quiet = quiet ) - return(invisible(file)) + invisible(file) } +#' #' @title Run gdal_warp #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} @@ -107,9 +107,9 @@ #' @param quiet TRUE/FALSE #' @returns Called for side effects .gdal_warp <- function(file, base_files, params, - quiet, conf_opts = character(0)) { + quiet, conf_opts = character(0L)) { sf::gdal_utils( - util = "warp", source = base_files, destination = file[[1]], + util = "warp", source = base_files, destination = file[[1L]], options = .gdal_params(params), config_options = conf_opts, quiet = quiet ) @@ -174,7 +174,7 @@ .gdal_template_block <- function(block, bbox, file, nlayers, miss_value, data_type) { # Get first file - file <- file[[1]] + file <- file[[1L]] # Convert to gdal data type data_type <- .gdal_data_type[[data_type]] # Output file @@ -192,9 +192,9 @@ params = list( "-ot" = data_type, "-of" = .conf("gdal_presets", "image", "of"), - "-b" = rep(1, nlayers), + "-b" = rep(1L, nlayers), "-outsize" = list(.ncols(block), .nrows(block)), - "-scale" = list(0, 1, miss_value, miss_value), + "-scale" = list(0.0, 1.0, miss_value, miss_value), "-a_srs" = .crs(bbox), "-a_ullr" = list( .xmin(bbox), .ymax(bbox), .xmax(bbox), .ymin(bbox) @@ -300,7 +300,7 @@ as_crs, miss_value, data_type, - multicores = 1, + multicores = 1L, overwrite = TRUE, ...) { gdal_params <- list( "-ot" = .gdal_data_type[[data_type]], diff --git a/R/api_gdalcubes.R b/R/api_gdalcubes.R index f96b7e9df..1c550a9fc 100644 --- a/R/api_gdalcubes.R +++ b/R/api_gdalcubes.R @@ -565,7 +565,7 @@ ) # check documentation mode - progress <- .check_documentation(progress) + progress <- .message_progress(progress) # gdalcubes log file gdalcubes_log_file <- file.path(tempdir(), "/gdalcubes.log") diff --git a/R/api_grid.R b/R/api_grid.R index 6df95c379..051a3168d 100644 --- a/R/api_grid.R +++ b/R/api_grid.R @@ -25,7 +25,7 @@ epsg_lst <- unique(s2_tb[["epsg"]]) points_sf <- sf::st_as_sf(.map_dfr(epsg_lst, function(epsg) { tiles <- dplyr::filter(s2_tb, epsg == {{epsg}}) - sfc <- matrix(c(tiles[["xmin"]], tiles[["ymin"]]), ncol = 2) |> + sfc <- matrix(c(tiles[["xmin"]], tiles[["ymin"]]), ncol = 2L) |> sf::st_multipoint(dim = "XY") |> sf::st_sfc(crs = epsg) |> sf::st_transform(crs = "EPSG:4326") @@ -50,8 +50,8 @@ s2_sf_lst <- purrr::map(epsg_lst, function(epsg) { dplyr::filter(s2_tb, epsg == {{epsg}}) |> dplyr::mutate( - xmax = xmin + 109800, - ymax = ymin + 109800, + xmax = xmin + 109800L, + ymax = ymin + 109800L, crs = paste0("EPSG:", {{epsg}}) ) |> dplyr::rowwise() |> @@ -69,19 +69,18 @@ s2_sf <- sf::st_as_sf( x = s2_sf, sf_column_name = "geom", - crs = paste0("EPSG:", s2_sf[["epsg"]][[1]]) + crs = paste0("EPSG:", s2_sf[["epsg"]][[1L]]) ) sf::st_transform( - x = sf::st_segmentize(s2_sf, 10980), + x = sf::st_segmentize(x = s2_sf, dfMaxLength = 10980L), crs = "EPSG:4326" ) })) - # if roi is given, filter tiles by desired roi if (.has(roi)) s2_tiles <- s2_tiles[.intersects(s2_tiles, .roi_as_sf(roi)), ] - - return(s2_tiles) + # return s2 tiles + s2_tiles } #' @title Filter data in the Brazil Data Cube grid system #' @name .grid_filter_bdc @@ -106,7 +105,7 @@ bdc_tiles <- readRDS(grid_path) # define dummy local variables to stop warnings - proj <- xmin <- ymin <- xmax <- ymax <- NULL + xmin <- ymin <- xmax <- ymax <- NULL if (.has(tiles)) { bdc_tiles <- bdc_tiles[bdc_tiles[["tile_id"]] %in% tiles, ] @@ -142,13 +141,11 @@ roi <- .roi_as_sf(roi, as_crs = .vector_crs(bdc_tiles)) bdc_tiles <- bdc_tiles[.intersects(bdc_tiles, roi), ] } - # Transform each sf to WGS84 and merge them into a single one sf object - bdc_tiles <- sf::st_transform( + sf::st_transform( x = bdc_tiles, crs = "EPSG:4326" ) - return(bdc_tiles) } #' @title Filter tiles in different grid system #' @name .grid_filter_tiles @@ -198,9 +195,9 @@ # obtain a list of sf objects bbox_dfr <- slider::slide_dfr(tiles_selected, function(tile) { xmin <- as.double(tile[["xmin"]]) - xmax <- xmin + 109800 + xmax <- xmin + 109800L ymin <- as.double(tile[["ymin"]]) - ymax <- ymin + 109800 + ymax <- ymin + 109800L bbox <- sf::st_bbox( c(xmin = xmin, ymin = ymin, @@ -212,20 +209,19 @@ sf::st_as_sfc() |> sf::st_transform(crs = "EPSG:4326") |> sf::st_bbox() - - ll <- c( + # return tile box in lat/long as a row of a data frame + c( lon_min = bbox_ll[["xmin"]], lat_min = bbox_ll[["ymin"]], lon_max = bbox_ll[["xmax"]], lat_max = bbox_ll[["ymax"]] ) - return(ll) }) - roi <- c( + # return the absolute bbox of the set of tiles + c( lon_min = min(bbox_dfr[["lon_min"]]), lat_min = min(bbox_dfr[["lat_min"]]), lon_max = max(bbox_dfr[["lon_max"]]), lat_max = max(bbox_dfr[["lat_max"]]) ) - return(roi) } diff --git a/R/api_jobs.R b/R/api_jobs.R index 754784aad..65f65ea45 100644 --- a/R/api_jobs.R +++ b/R/api_jobs.R @@ -26,10 +26,10 @@ # Memory per core mpc <- memsize / multicores # Blocks per core - bpc <- max(1, floor(mpc / job_block_memsize)) + bpc <- max(1L, floor(mpc / job_block_memsize)) # Image blocks in the horizontal direction hb <- ceiling(image_size[["ncols"]] / block[["ncols"]]) - if (bpc < hb * 2) { + if (bpc < hb * 2L) { # 1st optimization - line level # Number of segments to process whole line h_nsegs <- ceiling(hb / bpc) @@ -59,8 +59,7 @@ ) # Terra requires at least two pixels to recognize an extent as valid # polygon and not a line or point - block <- .block_regulate_size(block) - return(block) + .block_regulate_size(block) } #' @title Estimate the number of multicores to be used #' @name .job_max_multicore diff --git a/R/api_kohonen.R b/R/api_kohonen.R index b9c7ad313..e11b2b27c 100644 --- a/R/api_kohonen.R +++ b/R/api_kohonen.R @@ -48,18 +48,18 @@ .kohonen_get_n_na <- function(data, max_na_fraction, nobjects) { if (max_na_fraction > 0L) { res <- data |> - purrr::map(function(x){ - apply(x, 1, function(y) + purrr::map(function(x) { + apply(x, 1L, function(y) { sum(is.na(y)) - ) + }) }) |> dplyr::bind_rows() |> as.matrix() |> t() } else { - res <- matrix(0, length(data), nobjects) + res <- matrix(0.0, length(data), nobjects) } - return(res) + res } #' @title Transform a Kohonen classes vector in a compatible classes matrix @@ -76,19 +76,18 @@ #' object into a compatible matrix. #' @param yvec Kohonen classes vector. #' @return Classes matrix. -.kohonen_classvec2classmat <- function(yvec) -{ +.kohonen_classvec2classmat <- function(yvec) { if (!is.factor(yvec)) { yvec <- factor(yvec) } nclasses <- nlevels(yvec) - outmat <- matrix(0, length(yvec), nclasses) + outmat <- matrix(0.0, length(yvec), nclasses) dimnames(outmat) <- list(NULL, levels(yvec)) - for (i in 1:nclasses) { - outmat[which(as.integer(yvec) == i), i] <- 1 + for (i in seq_len(nclasses)) { + outmat[which(as.integer(yvec) == i), i] <- 1L } outmat } @@ -113,8 +112,7 @@ #' related metadata. .kohonen_object_distances <- function(kohobj, type = c("data", "codes"), - whatmap) -{ + whatmap) { # validate type type <- match.arg(type) # define the layer to be used based on the `whatmap` @@ -133,7 +131,7 @@ data <- kohobj[[type]][whatmap] # calculate the number of variables, objects and, NA values in the map data nvars <- purrr::map_int(data, ncol) - nobjects <- nrow(data[[1]]) + nobjects <- nrow(data[[1L]]) n_na <- .kohonen_get_n_na(data, max_na_fraction, nobjects) # prepare data matrix datamat <- matrix(unlist(data), ncol = nobjects, byrow = TRUE) @@ -176,8 +174,8 @@ #' @param max_na_fraction Max fraction of NA values. #' @return Kohonen map object. .kohonen_map <- function(x, whatmap = NULL, user_weights = NULL, - max_na_fraction = x$max_na_fraction, ...) -{ + max_na_fraction = x$max_na_fraction, ...) { + .check_set_caller(".kohonen_map") # extract relevant info from the kohonen object codes <- x$codes newdata <- x$data @@ -198,30 +196,30 @@ use_train_weights <- FALSE } # if only one layer of weights is defined, then, replicate it to all layers - if (length(user_weights) == 1) { - user_weights <- rep(1, nlayers) + if (length(user_weights) == 1L) { + user_weights <- rep(1L, nlayers) } # validate if new data is being used to create the kohonen map - if (use_train_weights & any(user_weights[whatmap_tr] < 1e-8)) { - warning("Mapping new data using data layers not involved in training") + if (use_train_weights && any(user_weights[whatmap_tr] < 1e-8)) { + warning(.conf("messages", ".kohonen_map")) } # select `codes` and `weights` from a given layer codes <- codes[whatmap_tr] user_weights_original <- user_weights user_weights <- user_weights[whatmap_tr] # validate `weights` from a given layer - if (length(whatmap_tr) == 1) { - user_weights <- 1 + if (length(whatmap_tr) == 1L) { + user_weights <- 1.0 } else { - if (sum(user_weights >= 1e-8) == 0) { - stop("Only user_weights of zero given") + if (sum(user_weights >= 1e-8) == 0.0) { + stop(.conf("messages", ".kohonen_map_user_weights")) } } # calculate the number of variables and codes in the codes data nvars <- purrr::map_int(codes, ncol) - ncodes <- nrow(codes[[1]]) + ncodes <- nrow(codes[[1L]]) # calculate the number of objects and NA values in the map data - nobjects <- nrow(newdata[[1]]) + nobjects <- nrow(newdata[[1L]]) n_na <- .kohonen_get_n_na(newdata, max_na_fraction, nobjects) # prepare codes and map data newdata <- matrix(unlist(newdata), ncol = nobjects, byrow = TRUE) @@ -240,7 +238,7 @@ ) # prepare the result and return it list( - unit.classif = res$winners + 1, + unit.classif = res$winners + 1.0, distances = res$unitdistances, whatmap = whatmap, user_weights = user_weights_original @@ -275,28 +273,19 @@ #' @param alpha learning rate, a vector of two numbers indicating the #' amount of change. Default is to decline linearly from 0.05 #' to 0.01 over rlen updates. Not used for the batch -#' algorithm. -#' @param radius the radius of the neighbourhood, either given as a single -#' number or a vector (start, stop). If it is given as a -#' single number the radius will change linearly from radius -#' to zero; as soon as the neighbourhood gets smaller than one -#' only the winning unit will be updated. Note that the -#' default before version 3.0 was to run from radius to -#' -radius. If nothing is supplied, the default is to start -#' with a value that covers 2/3 of all unit-to-unit distances. +#' algorithm.. #' @return Complete kohonen object. .kohonen_supersom <- function(data, grid = kohonen::somgrid(), distance = "dtw", - rlen = 100, + rlen = 100L, alpha = c(0.05, 0.01), - radius = stats::quantile(nhbrdist, 2 / 3), - mode = NULL) -{ + mode = NULL) { + .check_set_caller(".kohonen_supersom") # define the initial weights - user_weights <- 1 + user_weights <- 1.0 # define the max NA fraction. In `sits`, no NA values are allowed. - max_na_fraction <- 0 + max_na_fraction <- 0.0 # define layers to be used. In `sits`, all data layers are used (i.e., NULL) whatmap <- NULL # save original input data @@ -310,12 +299,15 @@ # get a (symmetrical) matrix containing distances from the # user-defined grid. nhbrdist <- kohonen::unit.distances(grid) - # check radius and fix it - if (length(radius) == 1) { - radius <- c(radius, 0) + # the radius of the neighbourhood, given as a vector (start, stop). + #' the default is to start + #' with a value that covers 2/3 of all unit-to-unit distances + radius <- stats::quantile(nhbrdist, 0.66) + if (length(radius) == 1L) { + radius <- c(radius, 0.0) } # calculate the number of variables, objects and, NA values in the map data - nobjects <- nrow(data[[1]]) + nobjects <- nrow(data[[1L]]) nvar <- purrr::map_int(data, ncol) n_na <- .kohonen_get_n_na(data, max_na_fraction, nobjects) # transform the user-defined data in a matrix @@ -324,118 +316,102 @@ distance_ptr <- .kohonen_get_distance(distance) # get or create initial codebooks ncodes <- nrow(grid$pts) - starters <- sample(1:nobjects, ncodes, replace = FALSE) + starters <- sample.int(nobjects, ncodes, replace = FALSE) init <- lapply(data, function(x) x[starters, , drop = FALSE]) init_matrix <- matrix(unlist(init), ncol = ncodes, byrow = TRUE) # define the initial weights - distance_weights <- original_user_weights <- rep(0, nmat) + distance_weights <- original_user_weights <- rep(0.0, nmat) # prepare `weights` and `distances` based on data from layers. - if (length(whatmap) == 1) { - weights <- user_weights <- 1 - distance_weights[whatmap] <- original_user_weights[whatmap] <- 1 + if (length(whatmap) == 1L) { + weights <- user_weights <- 1.0 + distance_weights[whatmap] <- original_user_weights[whatmap] <- 1.0 } else { - if (length(user_weights) == 1) { + if (length(user_weights) == 1L) { user_weights <- rep(user_weights, length(whatmap)) } else { if (length(user_weights) == nmat) user_weights <- user_weights[whatmap] } - if (any(user_weights == 0)) { - stop("Incompatibility between whatmap and user_weights") - } - - if (abs(sum(user_weights)) < .Machine$double.eps) { - stop("user_weights sum to zero") - } + .check_that(all(user_weights != 0.0)) + .check_that(abs(sum(user_weights)) > .Machine$double.eps) user_weights <- user_weights / sum(user_weights) original_user_weights[whatmap] <- user_weights - # comment from the `kohonen` package # calculate distance weights from the init data. - # the goal is to bring each data layer to more or less the same scale, + # the goal is to bring each data layer to the same scale, # after which the user weights are applied. We call object.distances # layer by layer here, which leads to a list of distance vectors. meanDistances <- - lapply(seq(along = init), function(ii) - .kohonen_object_distances( - list( - data = init[ii], - whatmap = 1, - user_weights = 1, - distance_weights = 1, - max_na_fraction = max_na_fraction, - distance_fnc = distance_ptr - ), - type = "data" - ) - ) + lapply(seq(along = init), function(ii) { + .kohonen_object_distances( + list( + data = init[ii], + whatmap = 1L, + user_weights = 1.0, + distance_weights = 1.0, + max_na_fraction = max_na_fraction, + distance_fnc = distance_ptr + ), + type = "data" + ) + }) - if (any(purrr::map_dbl(meanDistances, mean) < .Machine$double.eps)) { - stop("Non-informative layers present: mean distance between - objects zero") - } + .check_that(all(purrr::map_dbl(meanDistances, mean) >= .Machine$double.eps)) - # comment from the `kohonen` package - ## the distance weights are then the reciprocal values of the mean + ## the distance weights are the reciprocal values of the mean ## distances per layer. We no longer use median distances since ## there is a real chance that for factor data the median equals zero - distance_weights[whatmap] <- 1 / purrr::map_dbl(meanDistances, mean) + distance_weights[whatmap] <- 1.0 / purrr::map_dbl(meanDistances, mean) weights <- user_weights * distance_weights[whatmap] weights <- weights / sum(weights) } # create supersom - switch (mode, - online = { - res <- suppressWarnings({RcppSupersom( - data = data_matrix, - codes = init_matrix, - numVars = nvar, - weights = weights, - numNAs = n_na, - neighbourhoodDistances = nhbrdist, - alphas = alpha, - radii = radius, - numEpochs = rlen, - distanceFunction = distance_ptr - )}) - }, - batch = { - res <- suppressWarnings({RcppBatchSupersom( - data = data_matrix, - codes = init_matrix, - numVars = nvar, - weights = weights, - numNAs = n_na, - neighbourhoodDistances = nhbrdist, - radii = radius, - numEpochs = rlen, - distanceFunction = distance_ptr - )}) - }, - pbatch = { - res <- suppressWarnings({RcppParallelBatchSupersom( - data = data_matrix, - codes = init_matrix, - numVars = nvar, - weights = weights, - numNAs = n_na, - neighbourhoodDistances = nhbrdist, - radii = radius, - numEpochs = rlen, - numCores = -1, - distanceFunction = distance_ptr - )}) - } + switch(mode, + online = {res <- suppressWarnings({RcppSupersom( + data = data_matrix, + codes = init_matrix, + numVars = nvar, + weights = weights, + numNAs = n_na, + neighbourhoodDistances = nhbrdist, + alphas = alpha, + radii = radius, + numEpochs = rlen, + distanceFunction = distance_ptr + )})}, + batch = {res <- suppressWarnings({RcppBatchSupersom( + data = data_matrix, + codes = init_matrix, + numVars = nvar, + weights = weights, + numNAs = n_na, + neighbourhoodDistances = nhbrdist, + radii = radius, + numEpochs = rlen, + distanceFunction = distance_ptr + )})}, + pbatch = {res <- suppressWarnings({RcppParallelBatchSupersom( + data = data_matrix, + codes = init_matrix, + numVars = nvar, + weights = weights, + numNAs = n_na, + neighbourhoodDistances = nhbrdist, + radii = radius, + numEpochs = rlen, + numCores = -1L, + distanceFunction = distance_ptr + )})} ) # extract changes changes <- matrix(res$changes, ncol = nmap, byrow = TRUE) colnames(changes) <- names(data) mycodes <- res$codes # format codes - layerID <- rep(1:nmap, nvar) + layerID <- rep(1L:nmap, nvar) mycodes2 <- split(as.data.frame(mycodes), layerID) mycodes3 <- lapply(mycodes2, function(x) t(as.matrix(x))) # codes as vector diff --git a/R/api_label_class.R b/R/api_label_class.R index 099115fc4..72b707e56 100644 --- a/R/api_label_class.R +++ b/R/api_label_class.R @@ -16,7 +16,7 @@ ) # Resume feature if (file.exists(out_file)) { - .check_recovery(tile[["tile"]]) + .check_recovery() class_tile <- .tile_derived_from_file( file = out_file, band = "class", @@ -28,7 +28,7 @@ return(class_tile) } # Create chunks as jobs - chunks <- .tile_chunks_create(tile = tile, overlap = 0) + chunks <- .tile_chunks_create(tile = tile, overlap = 0L) # Process jobs in parallel block_files <- .jobs_map_parallel_chr(chunks, function(chunk) { # Get job block @@ -43,24 +43,15 @@ if (.raster_is_valid(block_file)) { return(block_file) } + band_conf <- .conf_derived_band( + derived_class = "class_cube", band = band + ) # Read and preprocess values values <- .tile_read_block( tile = tile, band = .tile_bands(tile), block = block ) # Apply the labeling function to values values <- label_fn(values) - # Prepare probability to be saved - band_conf <- .conf_derived_band( - derived_class = "class_cube", band = band - ) - offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { - values <- values - offset - } - scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { - values <- values / scale - } # Prepare and save results as raster .raster_write_block( files = block_file, block = block, bbox = .bbox(chunk), @@ -105,7 +96,7 @@ ) # Resume feature if (.segments_is_valid(out_file)) { - .check_recovery(out_file) + .check_recovery() # Create tile based on template class_tile <- .tile_segments_from_file( file = out_file, @@ -126,19 +117,20 @@ segment_labels <- setdiff( colnames(probs_segments), c("supercells", "x", "y", "pol_id", "geom") ) - # Necessary when not all labels are present on the tile + # Required when not all labels are present on the tile labels <- intersect(tile_labels, segment_labels) # Classify each segment by majority probability probs_segments <- probs_segments |> dplyr::rowwise() |> dplyr::filter(!anyNA(dplyr::c_across(dplyr::all_of(labels)))) |> - dplyr::mutate(class = labels[which.max( - dplyr::c_across(dplyr::all_of(labels)))]) |> - dplyr::mutate(pol_id = as.numeric(.data[["pol_id"]])) + dplyr::mutate( + class = labels[which.max(dplyr::c_across(dplyr::all_of(labels)))], + pol_id = as.numeric(.data[["pol_id"]])) + # Write all segments .vector_write_vec(v_obj = probs_segments, file_path = out_file) - # Create tile based on template - class_tile <- .tile_segments_from_file( + # Create class tile based on template and return empty vector tile + .tile_segments_from_file( file = out_file, band = "class", base_tile = tile, @@ -146,8 +138,6 @@ vector_class = "class_vector_cube", update_bbox = FALSE ) - # Return classified vector tile - return(class_tile) } #' @title Label the probs maps with the most probable class @@ -180,7 +170,7 @@ #' @returns labels required by sits .label_gpkg_file <- function(gpkg_file) { sf <- sf::st_read(gpkg_file, quiet = TRUE) - labels <- setdiff(colnames(sf), c("supercells", "x", "y", - "pol_id", "geom", "class")) - return(labels) + # Extract the labels required by sits from GPKG file + setdiff(colnames(sf), c("supercells", "x", "y", + "pol_id", "geom", "class")) } diff --git a/R/api_merge.R b/R/api_merge.R index 0e2344a9a..9bfffe297 100644 --- a/R/api_merge.R +++ b/R/api_merge.R @@ -18,7 +18,7 @@ # get bands intersects bands_intersects <- setdiff(data1_bands, data2_bands) # no extra bands are allowed when the same bands are defined - .check_that(length(bands_intersects) == 0) + .check_that(length(bands_intersects) == 0L) # same sensor is required when bands with the same names are defined .check_that(all(.cube_sensor(data1) %in% .cube_sensor(data2))) } @@ -50,15 +50,15 @@ #' @return Common timeline for both cubes .merge_zipper_strategy <- function(t1, t2) { # define vector to store overlapping dates - t_overlap <- c() + t_overlap <- NULL # define the size of the `for` - size of the reference time-series - ts_reference_len <- length(t1) - 1 + ts_reference_len <- length(t1) - 1L # search the overlapping dates for (idx in seq_len(ts_reference_len)) { # reference interval (`t1`) - reference_interval <- t1[idx: (idx + 1)] + reference_interval <- t1[idx: (idx + 1L)] # verify which dates are in the reference interval - t2_in_interval <- t2 >= t1[idx] & t2 <= t1[idx + 1] + t2_in_interval <- t2 >= t1[idx] & t2 <= t1[idx + 1L] # get the interval dates t2_interval_dates <- t2[t2_in_interval] # if have interval, process them @@ -116,7 +116,7 @@ .keep_all = TRUE ) # return - return(x) + x }) }) } @@ -174,7 +174,24 @@ .merge_cube_compactify <- function(data1, data2) { # extract tiles tiles <- .merge_get_common_tiles(data1, data2) - if (!.has(tiles)) { + if (.has(tiles)) { + # align timeline tile by tile. + merged_cube <- .map_dfr(tiles, function(tile) { + # get tiles + tile1 <- .cube_filter_tiles(data1, tile) + tile2 <- .cube_filter_tiles(data2, tile) + # get tile timelines + ts1 <- .tile_timeline(tile1) + ts2 <- .tile_timeline(tile2) + # adjust timeline using zipper strategy + ts_overlap <- .merge_zipper_strategy(ts1, ts2) + # filter cubes in the overlapping dates + tile1 <- .cube_filter_dates(tile1, ts_overlap) + tile2 <- .cube_filter_dates(tile2, ts_overlap) + # merge by file + .merge_strategy_file(tile1, tile2) + }) + } else { # It is not possible to merge non-common tiles with multiple bands using # the same sensor .check_that( @@ -202,26 +219,8 @@ # assign `combined cube` class, meaning the cube is a combination of # cubes that contains different timelines in different tiles class(merged_cube) <- c("combined_cube", class(data1)) - } else { - # align timeline tile by tile. - merged_cube <- .map_dfr(tiles, function(tile) { - # get tiles - tile1 <- .cube_filter_tiles(data1, tile) - tile2 <- .cube_filter_tiles(data2, tile) - # get tile timelines - ts1 <- .tile_timeline(tile1) - ts2 <- .tile_timeline(tile2) - # adjust timeline using zipper strategy - ts_overlap <- .merge_zipper_strategy(ts1, ts2) - # filter cubes in the overlapping dates - tile1 <- .cube_filter_dates(tile1, ts_overlap) - tile2 <- .cube_filter_dates(tile2, ts_overlap) - # merge by file - .merge_strategy_file(tile1, tile2) - }) + merged_cube } - # return - merged_cube } #' @title Define merge strategy based on intersecting the timeline #' @name .merge_strategy_intersects @@ -233,12 +232,12 @@ #' @return Merged data cube .merge_strategy_intersects <- function(data1, data2) { # Get data cubes timeline - t1 <- .cube_timeline(data1)[[1]] - t2 <- .cube_timeline(data2)[[1]] + t1 <- .cube_timeline(data1)[[1L]] + t2 <- .cube_timeline(data2)[[1L]] # Get cubes period - t2_period <- t2[2] - t2[1] - t1_period <- t1[2] - t1[1] + t2_period <- t2[2L] - t2[1L] + t1_period <- t1[2L] - t1[1L] # Lists to store dates t1_date <- list() @@ -247,11 +246,11 @@ # Get overlapped dates for (i in seq_along(t2)) { t2_int <- lubridate::interval( - lubridate::ymd(t2[i]), lubridate::ymd(t2[i]) + t2_period - 1 + lubridate::ymd(t2[i]), lubridate::ymd(t2[i]) + t2_period - 1L ) overlapped_dates <- lapply(seq_along(t1), function(j) { t1_int <- lubridate::interval( - lubridate::ymd(t1[j]), lubridate::ymd(t1[j]) + t1_period - 1 + lubridate::ymd(t1[j]), lubridate::ymd(t1[j]) + t1_period - 1L ) lubridate::int_overlaps(t2_int, t1_int) }) @@ -277,7 +276,7 @@ fi_list <- purrr::map(.tile_bands(y), function(band) { fi_band <- .fi_filter_bands(.fi(y), bands = band) fi_band[["date"]] <- t1_date - return(fi_band) + fi_band }) tile_fi <- dplyr::bind_rows(fi_list) tile_fi <- dplyr::arrange( @@ -291,19 +290,31 @@ }) # Merge the cubes - data1 <- .merge_strategy_file(data1, data2) - return(data1) + .merge_strategy_file(data1, data2) } - -#' @title Define merge strategy when one of the cubes is a DEM -#' @name .merge_dem +#' @title Merges cubes based on adequate strategy +#' @name .merge +#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param data1 Data cube +#' @param data2 Data cube +#' @return Strategy to be used +.merge <- function(data1, data2) { + merge_type <- .merge_type(data1, data2) + class(data1) <- c(merge_type, class(data1)) + UseMethod(".merge", data1) +} +#' @title Merge strategy when one of the cubes is a DEM +#' @name .merge.dem_case #' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param data1 Data cube #' @param data2 Data cube #' @return Merged data cube -.merge_dem <- function(data1, data2) { +#' @export +.merge.dem_case <- function(data1, data2) { # define cubes dem_cube <- data1 other_cube <- data2 @@ -318,8 +329,6 @@ dem_cube <- .map_dfr(tiles, function(tile_name) { tile_other <- .cube_filter_tiles(other_cube, tile_name) tile_dem <- .cube_filter_tiles(dem_cube, tile_name) - # Get data1 timeline. - d1_tl <- unique(as.Date(.cube_timeline(tile_other)[[1]])) # Create new `file_info` using dates from `data1` timeline. fi_new <- purrr::map(.tile_timeline(tile_other), function(date_row) { fi <- .fi(tile_dem) @@ -334,15 +343,15 @@ .merge_strategy_file(other_cube, dem_cube) } -#' @title Define merge strategy for Harmonized Landsat-Sentinel data -#' @name .merge_hls +#' @title Merge strategy for Harmonized Landsat-Sentinel data +#' @name .merge.hls_case #' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param data1 Data cube #' @param data2 Data cube #' @return Merged data cube -.merge_hls <- function(data1, data2) { +.merge.hls_case <- function(data1, data2) { if ((.cube_collection(data1) == "HLSS30" || .cube_collection(data2) == "HLSS30")) { data1[["collection"]] <- "HLSS30" @@ -352,15 +361,15 @@ .merge_strategy_file(data1, data2) } -#' @title Define merge strategy for regular cubes -#' @name .merge_regular +#' @title Merge strategy for regular cubes +#' @name .merge.regular_case #' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param data1 Data cube #' @param data2 Data cube #' @return Merged data cube -.merge_regular <- function(data1, data2) { +.merge.regular_case <- function(data1, data2) { # Rule 1: Do the cubes have same tiles? .check_cube_tiles(data1, .cube_tiles(data2)) .check_cube_tiles(data2, .cube_tiles(data1)) @@ -368,7 +377,7 @@ # Rule 2: Do the cubes have same bands? bands_to_merge <- setdiff(.cube_bands(data2), .cube_bands(data1)) .check_that( - length(bands_to_merge) > 0, + .has(bands_to_merge), msg = .conf("messages", ".merge_regular_bands") ) @@ -383,46 +392,33 @@ merged_cube <- .merge_strategy_intersects(data1, data2) } # Return merged cube - return(merged_cube) + merged_cube } -#' @title Define merge strategy for irregular cubes -#' @name .merge_irregular +#' @title Merge strategy for irregular cubes +#' @name .merge.irregular_case #' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd #' @param data1 Data cube #' @param data2 Data cube #' @return Merged data cube -.merge_irregular <- function(data1, data2) { +.merge.irregular_case <- function(data1, data2) { # verify if cube has the same bands has_same_bands <- .merge_has_equal_bands(data1, data2) # rule 1: if the bands are the same, combine cubes (`densify`) if (has_same_bands) { # merge! - merged_cube <- .merge_cube_densify(data1, data2) + .merge_cube_densify(data1, data2) } else { # rule 2: if the bands are different and their timelines are # compatible, the bands are joined. The resulting timeline is the one # from the first cube. - merged_cube <- .merge_cube_compactify(data1, data2) + .merge_cube_compactify(data1, data2) } } -#' @title Chooses strategy based on input data -#' @name .merge_switch -#' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} -#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} -#' @noRd -#' @param data1 Data cube -#' @param data2 Data cube -#' @param ... Additional params for operations -#' @return Merged data cube -.merge_switch <- function(data1, data2, ...) { - switch(.merge_type(data1, data2), - ... - ) -} -#' @title Chooses strategy type -#' @name .merge_type + +#' @title Merges cubes based on adequate strategy +#' @name .merge #' @author Felipe Carvalho, \email{filipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @noRd @@ -430,33 +426,41 @@ #' @param data2 Data cube #' @return Strategy to be used .merge_type <- function(data1, data2) { - # Special cases - if (any(inherits(data1, "dem_cube"), inherits(data2, "dem_cube"))) { - "dem_case" - } else if (all(inherits(data1, "hls_cube"), inherits(data2, "hls_cube"))) { - "hls_case" - } else if ( - all( - inherits(data1, "deaustralia_cube_ga_s2am_ard_3"), - inherits(data2, "deaustralia_cube_ga_s2am_ard_3") - ) && + if (.merge_type_dem(data1, data2)) + return("dem_case") + if (.merge_type_hls(data1, data2)) + return("hls_case") + if (.merge_type_deaustralia_s2(data1, data2)) + return("irregular_case") + if (.merge_type_regular(data1, data2)) + return("regular_case") + if (.merge_type_irregular(data1, data2)) + return("irregular_case") + # find no alternative? error messages + stop(.conf("messages", ".merge_type"), toString(class(data1))) +} +.merge_type_regular <- function(data1, data2) { + .cube_is_regular(data1) && + .cube_is_regular(data2) && + .cube_has_unique_period(data1) && + .cube_has_unique_period(data2) +} +.merge_type_dem <- function(data1, data2) { + any(inherits(data1, "dem_cube"), inherits(data2, "dem_cube")) +} +.merge_type_hls <- function(data1, data2) { + all(inherits(data1, "hls_cube"), inherits(data2, "hls_cube")) +} +.merge_type_deaustralia_s2 <- function(data1, data2) { + all( + inherits(data1, "deaustralia_cube_ga_s2am_ard_3"), + inherits(data2, "deaustralia_cube_ga_s2bm_ard_3") + ) || all( inherits(data1, "deaustralia_cube_ga_s2bm_ard_3"), - inherits(data2, "deaustralia_cube_ga_s2bm_ard_3") + inherits(data2, "deaustralia_cube_ga_s2am_ard_3") ) - ) { - "irregular_case" - # General cases - } else if (.cube_is_regular(data1) && - .cube_is_regular(data2) && - .cube_has_unique_period(data1) && - .cube_has_unique_period(data2)) { - "regular_case" - } else if (!.cube_is_regular(data1) || !.cube_is_regular(data2) || - !.cube_has_unique_period(data1) || - !.cube_has_unique_period(data2)) { - "irregular_case" - } else { - stop(.conf("messages", ".merge_type"), class(data1)) - } +} +.merge_type_irregular <- function(data1, data2) { + !(.merge_type_regular(data1, data2)) } diff --git a/R/api_message.R b/R/api_message.R index 740d81bc8..ea9a9931a 100644 --- a/R/api_message.R +++ b/R/api_message.R @@ -15,8 +15,7 @@ #' @keywords internal #' @noRd .message_warnings <- function() { - Sys.getenv("SITS_DOCUMENTATION_MODE") != "true" && - Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" + !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") } #' @title Warning when converting a bbox into a sf object #' @name .message_warnings_bbox_as_sf @@ -86,10 +85,15 @@ .message_progress <- function(progress) { .check_lgl_parameter(progress) if (progress) - progress <- Sys.getenv("SITS_DOCUMENTATION_MODE") != "true" && - Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" + progress <- !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") progress } +.message_verbose <- function(verbose) { + .check_lgl_parameter(verbose) + if (verbose) + verbose <- !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") + verbose +} #' @title Check is version parameter is valid using reasonable defaults #' @name .message_version #' @keywords internal @@ -103,8 +107,8 @@ allow_na = FALSE, allow_null = FALSE, allow_empty = FALSE, - len_min = 1, - len_max = 1 + len_min = 1L, + len_max = 1L ) # avoids use of underscores tolower(gsub("_", "-", version)) diff --git a/R/api_mixture_model.R b/R/api_mixture_model.R index f88eb1eb7..f4809d76d 100644 --- a/R/api_mixture_model.R +++ b/R/api_mixture_model.R @@ -45,7 +45,7 @@ ) # Resume feature if (.raster_is_valid(out_files, output_dir = output_dir)) { - .check_recovery(out_fracs) + .check_recovery() # Create tile based on template fracs_feature <- .tile_eo_from_files( @@ -63,7 +63,7 @@ # Get band configuration band_conf <- .conf("default_values", "INT2S") # Create chunks as jobs - chunks <- .tile_chunks_create(tile = feature, overlap = 0, block = block) + chunks <- .tile_chunks_create(tile = feature, overlap = 0L, block = block) # Process jobs sequentially block_files <- .jobs_map_sequential(chunks, function(chunk) { # Get job block @@ -84,11 +84,11 @@ values <- mixture_fn(values = as.matrix(values)) # Prepare fractions to be saved offset <- .offset(band_conf) - if (!is.null(offset) && offset != 0) { + if (!is.null(offset) && offset != 0.0) { values <- values - offset } scale <- .scale(band_conf) - if (!is.null(scale) && scale != 1) { + if (!is.null(scale) && scale != 1.0) { values <- values / scale } # Prepare and save results as raster @@ -113,7 +113,7 @@ band_conf = band_conf, base_tile = feature, block_files = block_files, - multicores = 1, + multicores = 2L, update_bbox = FALSE ) # Return a eo_cube tile feature @@ -229,7 +229,7 @@ #' @return Bands in endmember specification .endmembers_bands <- function(em) { # endmembers tribble can be type or class - type_class <- colnames(em)[[1]] + type_class <- colnames(em)[[1L]] setdiff(colnames(em), type_class) } #' @title Return fraction bands in endmembers specification @@ -240,7 +240,7 @@ #' @return Bands in endmember specification .endmembers_fracs <- function(em, include_rmse = FALSE) { # endmembers tribble can be type or class - type_class <- toupper(colnames(em)[[1]]) + type_class <- toupper(colnames(em)[[1L]]) if (!include_rmse) { return(toupper(em[[type_class]])) } diff --git a/R/api_ml_model.R b/R/api_ml_model.R index 72bc02999..c68916832 100644 --- a/R/api_ml_model.R +++ b/R/api_ml_model.R @@ -52,7 +52,7 @@ #' @param ml_model Closure that contains ML model and its environment #' @return ML model class .ml_class <- function(ml_model) { - class(ml_model)[[1]] + class(ml_model)[[1L]] } #' @title Return names of features used to train ML model #' @keywords internal @@ -62,7 +62,7 @@ #' @return Features used to build the model .ml_features_name <- function(ml_model) { # Get feature names from variable used in training - names(environment(ml_model)[["train_samples"]])[-2:0] + names(environment(ml_model)[["train_samples"]])[-2L:0L] } #' @title Return names of bands used to train ML model #' @keywords internal @@ -112,27 +112,29 @@ #' @keywords internal #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' @noRd -#' @param ml_model Closure that contains ML model and its environment #' @param values Values to be normalized +#' @param ml_model Closure that contains ML model and its environment #' @return Normalized values #' -.ml_normalize <- function(ml_model, values){ +.ml_normalize <- function(values, ml_model) { UseMethod(".ml_normalize", ml_model) } #' @export #' -.ml_normalize.torch_model <- function(ml_model, values){ +.ml_normalize.torch_model <- function(values, ml_model) { + # Correct the default behaviour of softmax in torch models + # Run softmax here instead of inside a torch model column_names <- colnames(values) values[is.na(values)] <- 0 values <- softmax(values) colnames(values) <- column_names - return(values) + values } #' @export #' -.ml_normalize.default <- function(ml_model, values){ +.ml_normalize.default <- function(values, ml_model) { values[is.na(values)] <- 0 - return(values) + values } #' @title Update multicores for models that do internal multiprocessing #' @keywords internal @@ -146,10 +148,10 @@ .ml_update_multicores <- function(ml_model, multicores){ # xgboost model has internal multiprocessing if ("xgb_model" %in% .ml_class(ml_model)) - multicores <- 1 + multicores <- 1L # torch in GPU has internal multiprocessing else if (.torch_gpu_classification() && .ml_is_torch_model(ml_model)) - multicores <- 1 + multicores <- 1L return(multicores) } diff --git a/R/api_mosaic.R b/R/api_mosaic.R index aaf2d59cd..bd42d56de 100644 --- a/R/api_mosaic.R +++ b/R/api_mosaic.R @@ -97,10 +97,7 @@ version, progress) { # check if cube is derived - if ("derived_cube" %in% class(cube)) - derived_cube <- TRUE - else - derived_cube <- FALSE + derived_cube <- inherits(cube, "derived_cube") # Create band date as jobs band_date_cube <- .mosaic_split_band_date(cube) # Get band configs from tile @@ -111,7 +108,7 @@ # Process jobs in parallel mosaic_cube <- .jobs_map_parallel_dfr(band_date_cube, function(job) { # Get cube as a job - cube <- job[["cube"]][[1]] + cube <- job[["cube"]][[1L]] # Get cube file paths cube_files <- unlist(.cube_paths(cube)) # Get a template tile @@ -134,7 +131,7 @@ # Resume feature if (.raster_is_valid(out_file, output_dir = output_dir)) { if (.check_messages()) { - .check_recovery(out_file) + .check_recovery() } base_tile <- .tile_from_file( file = out_file, base_tile = base_tile, @@ -162,13 +159,11 @@ # Create COG overviews .gdal_addo(base_file = out_file) # Create tile based on template - base_tile <- .tile_from_file( + .tile_from_file( file = out_file, base_tile = base_tile, band = .tile_bands(base_tile), update_bbox = TRUE, labels = .tile_labels(base_tile) ) - # Return cube - return(base_tile) }, progress = progress) # Join output assets as a cube and return it .cube_merge_tiles(mosaic_cube) @@ -200,7 +195,7 @@ ) # Resume feature if (.raster_is_valid(out_file, output_dir = output_dir)) { - .check_recovery(out_file) + .check_recovery() asset <- .tile_from_file( file = out_file, base_tile = asset, band = .tile_bands(asset), update_bbox = TRUE, @@ -233,7 +228,7 @@ as_crs = .mosaic_crs(tile = asset, as_crs = crs), miss_value = .miss_value(band_conf), data_type = .data_type(band_conf), - multicores = 1, + multicores = 2L, overwrite = TRUE ) asset <- .tile_from_file( @@ -260,19 +255,18 @@ as_crs = .mosaic_crs(tile = asset, as_crs = crs), miss_value = .miss_value(band_conf), data_type = .data_type(band_conf), - multicores = 1, + multicores = 1L, overwrite = TRUE ) # Move the generated file to use the correct name file.rename(out_file_base, out_file) # Update asset metadata update_bbox <- if (.has(roi)) TRUE else FALSE - asset <- .tile_from_file( + .tile_from_file( file = out_file, base_tile = asset, band = .tile_bands(asset), update_bbox = update_bbox, labels = .tile_labels(asset) ) - return(asset) } #' @title Get type of mosaic #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} @@ -285,7 +279,7 @@ if (.cube_source(tile) == "BDC") { return("BDC") } - return("RASTER") + "RASTER" } #' @title Switch based on mosaic type #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} diff --git a/R/api_opensearch.R b/R/api_opensearch.R index 59fdca32d..4c91bb1b6 100644 --- a/R/api_opensearch.R +++ b/R/api_opensearch.R @@ -79,7 +79,7 @@ start_date, end_date, bbox, paginate = TRUE, - limit = 1000, ...) { + limit = 1000L, ...) { .check_set_caller(".opensearch_cdse_client") # CDSE Open Search configurations cdse_opensearch_base_url <- .conf( @@ -91,16 +91,15 @@ cdse_opensearch_endpoint <- "search.json" # Create the Open Search endpoint for the collection # Selected by user - collection_url <- paste( + collection_url <- file.path( cdse_opensearch_base_url, collection, - cdse_opensearch_endpoint, - sep = "/" + cdse_opensearch_endpoint ) # Define features to save content from Open Search - features_result <- c() + features_result <- NULL # Define variables to support the pagination in the Open Search - current_page <- 1 + current_page <- 1L is_to_fetch_more <- TRUE # Prepare bounding box in the format required by Open Search if (!is.null(bbox)) { @@ -122,8 +121,8 @@ # Get raw content from Open Search API response <- .get_request(url = collection_url, query = query) .check_int_parameter(.response_status(response), - min = 200, - max = 200 + min = 200L, + max = 200L ) # Extract data from the response page_data <- .response_content(response) @@ -168,7 +167,7 @@ .opensearch_cdse_extract_tile.S2MSI2A <- function(items) { items_titles <- rstac::items_reap(items, field = c("properties", "title")) purrr::map(items_titles, function(item_title) { - tile_name <- stringr::str_split(item_title, "_")[[1]][6] + tile_name <- stringr::str_split(item_title, "_")[[1L]][6L] tile_name <- stringr::str_replace(tile_name, "T", "") tile_name }) @@ -215,7 +214,7 @@ platform, orbit = NULL, paginate = TRUE, - limit = 1000, ...) { + limit = 1000L, ...) { UseMethod(".opensearch_cdse_search") } @@ -231,7 +230,7 @@ platform = NULL, orbit = NULL, paginate = TRUE, - limit = 1000, ...) { + limit = 1000L, ...) { .check_set_caller(".opensearch_cdse_search_s2msi2a") # Search! .opensearch_cdse_client( @@ -260,7 +259,7 @@ bbox, platform = NULL, orbit = NULL, - paginate = TRUE, limit = 1000, ...) { + paginate = TRUE, limit = 1000L, ...) { .check_set_caller(".opensearch_cdse_search_rtc") # check orbit orbits <- .conf("sources", source, "collections", collection, "orbits") diff --git a/R/api_parallel.R b/R/api_parallel.R index 305149272..9801b9902 100644 --- a/R/api_parallel.R +++ b/R/api_parallel.R @@ -29,7 +29,7 @@ tryCatch( { !is.null(sits_env[["cluster"]]) && - socketSelect(list(sits_env[["cluster"]][[1]][["con"]]), + socketSelect(list(sits_env[["cluster"]][[1L]][["con"]]), write = TRUE) }, error = function(e) FALSE @@ -50,10 +50,10 @@ .parallel_start <- function(workers, log = FALSE, output_dir = NULL) { .debug(flag = log, output_dir = output_dir) if (!.parallel_is_open() || - length(sits_env[["cluster"]]) != workers) { + length(sits_env[["cluster"]]) != workers) { .parallel_stop() - if (workers > 1) { + if (workers > 1L) { sits_env[["cluster"]] <- parallel::makePSOCKcluster(workers) # make sure library paths is the same as actual environment @@ -72,7 +72,7 @@ cl = sits_env[["cluster"]], expr = .libPaths(lib_paths) ) - if (length(env_vars) > 0) { + if (.has(env_vars)) { parallel::clusterEvalQ( cl = sits_env[["cluster"]], expr = do.call(Sys.setenv, env_vars) @@ -104,7 +104,7 @@ }) # create a new node - sits_env[["cluster"]][[worker_id]] <- parallel::makePSOCKcluster(1)[[1]] + sits_env[["cluster"]][[worker_id]] <- parallel::makePSOCKcluster(1L)[[1L]] } #' @name .parallel_recv_one_data @@ -167,7 +167,7 @@ } ) - return(list(node = worker_id, value = value)) + list(node = worker_id, value = value) } #' @name .parallel_recv_one_result @@ -179,9 +179,10 @@ # fault tolerant version of parallel:::recvOneData v <- .parallel_recv_one_data() - return(list(value = v[["value"]][["value"]], - node = v[["node"]], - tag = v[["value"]][["tag"]])) + list(value = v[["value"]][["value"]], + node = v[["node"]], + tag = v[["value"]][["tag"]] + ) } #' @rdname .parallel_cluster_apply @@ -196,13 +197,13 @@ n <- length(x) # number of workers p <- length(cl) - if (n > 0 && p) { + if (n > 0L && p) { # function to dispatch a job to a node submit <- function(node, job) { # get hidden object from parallel .send_call <- get("sendCall", - envir = asNamespace("parallel"), - inherits = FALSE + envir = asNamespace("parallel"), + inherits = FALSE ) .send_call( con = cl[[node]], @@ -213,7 +214,7 @@ ) } # start initial jobs - for (i in 1:min(n, p)) submit(i, i) + for (i in seq_len(min(n, p))) submit(i, i) # prepare result list val <- vector("list", n) # retrieve results and start jobs @@ -232,15 +233,15 @@ if (!is.null(pb)) { utils::setTxtProgressBar( pb = pb, - value = utils::getTxtProgressBar(pb) + 1 + value = utils::getTxtProgressBar(pb) + 1L ) } } } # get hidden object from parallel .check_remote_errors <- get("checkForRemoteErrors", - envir = asNamespace("parallel"), - inherits = FALSE + envir = asNamespace("parallel"), + inherits = FALSE ) .check_remote_errors(val) } @@ -262,14 +263,14 @@ #' as the input list #' .parallel_map <- function(x, fn, ..., progress = FALSE, - n_retries = 3, sleep = 0) { + n_retries = 3L, sleep = 0L) { # check documentation mode - progress <- .check_documentation(progress) + progress <- .message_progress(progress) # create progress bar pb <- NULL - progress <- progress && (length(x) > 0) + progress <- progress && .has(x) if (progress) { - pb <- utils::txtProgressBar(min = 0, max = length(x), style = 3) + pb <- utils::txtProgressBar(min = 0L, max = length(x), style = 3L) } # sequential processing if (.has_not(sits_env[["cluster"]])) { @@ -280,7 +281,7 @@ if (progress) { utils::setTxtProgressBar( pb = pb, - value = utils::getTxtProgressBar(pb) + 1 + value = utils::getTxtProgressBar(pb) + 1L ) } return(value) @@ -296,7 +297,7 @@ values <- .parallel_cluster_apply(x, fn, ..., pb = pb) # check for faults - retry <- vapply(values, inherits, logical(1), "retry") + retry <- vapply(values, inherits, logical(1L), "retry") # is there any node to be recovered? if (any(retry)) { @@ -310,12 +311,12 @@ pb = pb ) # check for faults again - retry <- vapply(values, inherits, logical(1), "retry") + retry <- vapply(values, inherits, logical(1L), "retry") if (!any(retry)) break } if (any(retry)) { stop(.conf("messages", ".parallel_map"), - call. = FALSE + call. = FALSE ) } } diff --git a/R/api_period.R b/R/api_period.R index 632cb7132..793caa5d4 100644 --- a/R/api_period.R +++ b/R/api_period.R @@ -66,7 +66,7 @@ NULL # Define first time period (used as part of the step) current_start <- start_date # Create period windows - while(current_start < end_date) { + while (current_start < end_date) { # Create the window: current start date + step current_end <- current_start + period_duration # Avoid window definition beyond the end date diff --git a/R/api_plot_raster.R b/R/api_plot_raster.R index 737c65ebf..d9112b51c 100644 --- a/R/api_plot_raster.R +++ b/R/api_plot_raster.R @@ -59,11 +59,10 @@ band_conf <- .tile_band_conf(tile, band) band_scale <- .scale(band_conf) if (.has_not(band_scale)) - band_scale <- 1 + band_scale <- 1.0 band_offset <- .offset(band_conf) if (.has_not(band_offset)) - band_offset <- 0 - max_value <- .max_value(band_conf) + band_offset <- 0.0 # retrieve the overview if COG bw_file <- .gdal_warp_file(bw_file, sizes) @@ -78,22 +77,19 @@ # obtain the quantiles quantiles <- stats::quantile( vals, - probs = c(0, first_quantile, last_quantile, 1), + probs = c(0.0, first_quantile, last_quantile, 1.0), na.rm = TRUE ) - minv <- quantiles[[1]] - minq <- quantiles[[2]] - maxq <- quantiles[[3]] - maxv <- quantiles[[4]] + minq <- quantiles[[2L]] + maxq <- quantiles[[3L]] # stretch the image - vals <- ifelse(vals > minq, vals, minq) - vals <- ifelse(vals < maxq, vals, maxq) + vals <- pmax(vals, minq) + vals <- pmin(vals, maxq) rast <- .raster_set_values(rast, vals) # set title title <- stringr::str_flatten(c(band, as.character(date)), collapse = " ") - - p <- .tmap_false_color( + .tmap_false_color( rast = rast, band = band, title = title, @@ -104,9 +100,7 @@ rev = rev, scale = scale, tmap_params = tmap_params - ) - return(p) - + ) } #' @title Plot a multi-date band as RGB @@ -148,9 +142,9 @@ progress = FALSE) } # select the files to be plotted - red_file <- .tile_path(tile, band, dates[[1]]) - green_file <- .tile_path(tile, band, dates[[2]]) - blue_file <- .tile_path(tile, band, dates[[3]]) + red_file <- .tile_path(tile, band, dates[[1L]]) + green_file <- .tile_path(tile, band, dates[[2L]]) + blue_file <- .tile_path(tile, band, dates[[3L]]) sizes <- .tile_overview_size(tile = tile, max_cog_size) # get the max values band_params <- .tile_band_conf(tile, band) @@ -163,7 +157,7 @@ } title <- stringr::str_flatten(c(band, as.character(dates)), collapse = " ") # plot multitemporal band as RGB - p <- .tmap_rgb_color( + .tmap_rgb_color( red_file = red_file, green_file = green_file, blue_file = blue_file, @@ -177,7 +171,6 @@ seg_color = NULL, line_width = NULL ) - return(p) } #' @title Plot a RGB image #' @name .plot_rgb @@ -221,11 +214,11 @@ } # get RGB files for the requested timeline - red_file <- .tile_path(tile, bands[[1]], date) - green_file <- .tile_path(tile, bands[[2]], date) - blue_file <- .tile_path(tile, bands[[3]], date) + red_file <- .tile_path(tile, bands[[1L]], date) + green_file <- .tile_path(tile, bands[[2L]], date) + blue_file <- .tile_path(tile, bands[[3L]], date) # get the max values - band_params <- .tile_band_conf(tile, bands[[1]]) + band_params <- .tile_band_conf(tile, bands[[1L]]) max_value <- .max_value(band_params) # size of data to be read sizes <- .tile_overview_size(tile = tile, max_cog_size) @@ -238,7 +231,7 @@ title <- stringr::str_flatten(c(bands, as.character(date)), collapse = " ") # plot RGB using tmap - p <- .tmap_rgb_color( + .tmap_rgb_color( red_file = red_file, green_file = green_file, blue_file = blue_file, @@ -252,7 +245,6 @@ seg_color = seg_color, line_width = line_width ) - return(p) } #' @title Plot a classified image #' @name .plot_class_image @@ -296,17 +288,6 @@ rast <- .raster_open_rast(class_file) # get the labels labels <- .cube_labels(tile) - # get the values - - - # If available, use labels to define which colors must be presented. - # This is useful as some datasets (e.g., World Cover) represent - # classified data with values that are not the same as the positions - # of the color array (e.g., 10, 20), causing a misrepresentation of - # the classes - labels_available <- as.character( - sort(unique(.raster_values_mem(rast), na.omit = TRUE)) - ) # set levels for raster terra_levels <- data.frame( id = as.numeric(names(labels)), @@ -326,13 +307,12 @@ label = unname(labels), color = unname(colors) ) - p <- .tmap_class_map( + .tmap_class_map( rast = rast, colors = colors_plot, scale = scale, tmap_params = tmap_params ) - return(p) } #' @title Plot probs #' @name .plot_probs @@ -404,17 +384,17 @@ # show only the chosen quantile values <- lapply( colnames(values), function(name) { - vls <- values[,name] + vls <- values[, name] quant <- stats::quantile(vls, quantile, na.rm = TRUE) vls[vls < quant] <- NA - return(vls) + vls }) values <- do.call(cbind, values) colnames(values) <- names(probs_rast) probs_rast <- .raster_set_values(probs_rast, values) } - p <- .tmap_probs_map( + .tmap_probs_map( probs_rast = probs_rast, labels = labels, labels_plot = labels_plot, @@ -423,7 +403,6 @@ scale = scale, tmap_params = tmap_params ) - return(p) } #' @title Plot variance histogram #' @name .plot_variance_hist @@ -445,7 +424,7 @@ nrows <- .tile_nrows(tile) ncols <- .tile_ncols(tile) # sample the pixels - n_samples <- as.integer(nrows / 5 * ncols / 5) + n_samples <- as.integer(nrows / 5L * ncols / 5L) points <- sf::st_sample(sf_cube, size = n_samples) points <- sf::st_coordinates(points) # get the r object @@ -458,11 +437,11 @@ band = "variance" ) scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { + if (.has(scale) && scale != 1.0) { values <- values * scale } offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { + if (.has(offset) && offset != 0.0) { values <- values + offset } # convert to tibble @@ -471,23 +450,21 @@ colnames(values) <- labels # dissolve the data for plotting values <- tidyr::pivot_longer(values, - cols = tidyr::everything(), - names_to = "labels", - values_to = "variance" + cols = tidyr::everything(), + names_to = "labels", + values_to = "variance" ) # Histogram with density plot - p <- ggplot2::ggplot( + ggplot2::ggplot( values, ggplot2::aes(x = .data[["variance"]]) ) + ggplot2::geom_histogram( - binwidth = 1, + binwidth = 1L, fill = "#69b3a2", color = "#e9ecef", alpha = 0.9 ) + - ggplot2::scale_x_continuous() - p <- p + ggplot2::facet_wrap(facets = "labels") - - return(p) + ggplot2::scale_x_continuous() + + ggplot2::facet_wrap(facets = "labels") } diff --git a/R/api_plot_time_series.R b/R/api_plot_time_series.R index 4c8e71bfd..00fe5da69 100644 --- a/R/api_plot_time_series.R +++ b/R/api_plot_time_series.R @@ -12,7 +12,7 @@ .plot_allyears <- function(data) { locs <- dplyr::distinct(data, .data[["longitude"]], .data[["latitude"]]) - plots <- purrr::pmap( + purrr::pmap( list(locs[["longitude"]], locs[["latitude"]]), function(long, lat) { dplyr::filter( @@ -24,7 +24,6 @@ graphics::plot() } ) - return(invisible(plots[[1]])) } #' @title Plot a set of time series for the same spatiotemporal reference @@ -50,18 +49,16 @@ qt25 = stats::quantile(.data[["value"]], 0.25), qt75 = stats::quantile(.data[["value"]], 0.75) ) - return(qts) + qts } # this function plots the values of all time series together (for one band) plot_samples <- function(melted, qts, band, label, number) { # make the plot title title <- paste0("Samples (", number, ") for class ", - label, " in band = ", band + label, " in band = ", band ) # plot all data together - g <- .plot_ggplot_together(melted, qts, title) - p <- graphics::plot(g) - return(p) + graphics::plot(.plot_ggplot_together(melted, qts, title)) } # how many different labels are there? @@ -81,7 +78,7 @@ # align all time series to the same dates data2 <- .tibble_align_dates(data2, ref_dates) - band_plots <- bands |> + band_plots <- bands |> purrr::map(function(band) { # select the band to be shown band_tb <- .samples_select_bands(data2, band) @@ -95,12 +92,11 @@ qts <- create_iqr(melted) # plot the time series together # (highlighting the median and quartiles 25% and 75%) - p <- plot_samples(melted, qts, band, lb, number) - return(p) + plot_samples(melted, qts, band, lb, number) }) - return(band_plots) + band_plots }) - return(invisible(label_plots[[1]][[1]])) + label_plots[[1L]][[1L]] } #' @title Plot one time series using ggplot @@ -116,12 +112,11 @@ #' one time series. .plot_ggplot_series <- function(row) { # Are there NAs in the data? - if (anyNA(row[["time_series"]][[1]])) { - g <- .plot_ggplot_series_na(row) + if (anyNA(row[["time_series"]][[1L]])) { + .plot_ggplot_series_na(row) } else { - g <- .plot_ggplot_series_no_na(row) + .plot_ggplot_series_no_na(row) } - return(g) } #' @title Plot one time series using ggplot (no NAs present) #' @name .plot_ggplot_series_no_na @@ -142,13 +137,6 @@ row[["longitude"]], row[["label"]] ) - # select colors - colors <- grDevices::hcl.colors( - n = 20, - palette = "Harmonic", - alpha = 1, - rev = TRUE - ) # extract the time series data_ts <- dplyr::bind_rows(row[["time_series"]]) # melt the data into long format @@ -156,14 +144,13 @@ tidyr::pivot_longer(cols = -"Index", names_to = "variable") |> as.data.frame() # plot the data with ggplot - g <- ggplot2::ggplot(melted_ts, ggplot2::aes( + ggplot2::ggplot(melted_ts, ggplot2::aes( x = .data[["Index"]], y = .data[["value"]], group = .data[["variable"]] )) + ggplot2::geom_line(ggplot2::aes(color = .data[["variable"]])) + ggplot2::labs(title = plot_title) - return(g) } #' @title Plot one time series with NAs using ggplot #' @name .plot_ggplot_series_na @@ -181,10 +168,10 @@ # define a function to replace the NAs for unique values replace_na <- function(x) { - x[is.na(x)] <- -10000 - x[x != -10000] <- NA - x[x == -10000] <- 1 - return(x) + x[is.na(x)] <- -10000.0 + x[x != -10000.0] <- NA + x[x == -10000.0] <- 1.0 + x } # create the plot title plot_title <- .plot_title( @@ -193,17 +180,16 @@ row[["label"]] ) # include a new band in the data to show the NAs - data <- row[["time_series"]][[1]] + data <- row[["time_series"]][[1L]] data_x1 <- dplyr::select_if(data, function(x) anyNA(x)) - data_x1 <- data_x1[, 1] + data_x1 <- data_x1[, 1L] colnames(data_x1) <- "X1" data_x1 <- dplyr::transmute(data_x1, cld = replace_na(.data[["X1"]])) data <- dplyr::bind_cols(data, data_x1) # prepare tibble to ggplot (fortify) ts1 <- tidyr::pivot_longer(data, -"Index") - g <- ggplot2::ggplot(data = ts1 |> - dplyr::filter(.data[["name"]] != "cld")) + + ggplot2::ggplot(data = dplyr::filter(ts1, .data[["name"]] != "cld")) + ggplot2::geom_col( ggplot2::aes( x = .data[["Index"]], @@ -211,11 +197,11 @@ ), fill = "sienna", alpha = 0.3, - data = ts1 |> - dplyr::filter( - .data[["name"]] == "cld", - !is.na(.data[["value"]]) - ) + data = dplyr::filter( + ts1, + .data[["name"]] == "cld", + !is.na(.data[["value"]]) + ) ) + ggplot2::geom_line(ggplot2::aes( x = .data[["Index"]], @@ -228,8 +214,6 @@ color = .data[["name"]] )) + ggplot2::labs(title = plot_title) - - return(g) } #' @title Plot many time series together using ggplot @@ -247,7 +231,7 @@ #' and one label. #' .plot_ggplot_together <- function(melted, means, plot_title) { - g <- ggplot2::ggplot(data = melted, ggplot2::aes( + ggplot2::ggplot(data = melted, ggplot2::aes( x = .data[["Index"]], y = .data[["value"]], group = .data[["variable"]] @@ -257,19 +241,18 @@ ggplot2::geom_line( data = means, ggplot2::aes(x = .data[["Index"]], y = .data[["med"]]), - colour = "#B16240", linewidth = 2, inherit.aes = FALSE + colour = "#B16240", linewidth = 2L, inherit.aes = FALSE ) + ggplot2::geom_line( data = means, ggplot2::aes(x = .data[["Index"]], y = .data[["qt25"]]), - colour = "#B19540", linewidth = 1, inherit.aes = FALSE + colour = "#B19540", linewidth = 1L, inherit.aes = FALSE ) + ggplot2::geom_line( data = means, ggplot2::aes(x = .data[["Index"]], y = .data[["qt75"]]), - colour = "#B19540", linewidth = 1, inherit.aes = FALSE + colour = "#B19540", linewidth = 1L, inherit.aes = FALSE ) - return(g) } #' @title Create a plot title to use with ggplot @@ -284,11 +267,10 @@ #' @param label label of the location to be plotted. #' @return title to be used in the plot. .plot_title <- function(latitude, longitude, label) { - title <- paste0( + paste0( "location (", - signif(latitude, digits = 4), ", ", - signif(longitude, digits = 4), ") - ", + signif(latitude, digits = 4L), ", ", + signif(longitude, digits = 4L), ") - ", label ) - return(title) } diff --git a/R/api_plot_vector.R b/R/api_plot_vector.R index 6d8a533ef..1eb65f8f0 100644 --- a/R/api_plot_vector.R +++ b/R/api_plot_vector.R @@ -44,11 +44,10 @@ dplyr::summarise() # plot - p <- .tmap_vector_class(sf_seg = sf_seg, - colors = colors, - scale = scale, - tmap_params = tmap_params) - return(p) + .tmap_vector_class(sf_seg = sf_seg, + colors = colors, + scale = scale, + tmap_params = tmap_params) } #' @title Plot a probs vector cube #' @name .plot_probs_vector @@ -89,7 +88,7 @@ sf_seg <- .segments_read_vec(tile) # plot the segments by facet - p <- .tmap_vector_probs( + .tmap_vector_probs( sf_seg = sf_seg, palette = palette, rev = rev, @@ -98,7 +97,6 @@ scale = scale, tmap_params = tmap_params ) - return(p) } #' @title Plot uncertainty vector cube #' @name .plot_uncertainty_vector @@ -126,7 +124,7 @@ # obtain the uncertainty type uncert_type <- .vi(tile)[["band"]] - p <- .tmap_vector_uncert( + .tmap_vector_uncert( sf_seg = sf_seg, palette = palette, rev = rev, @@ -134,5 +132,4 @@ scale = scale, tmap_params = tmap_params ) - return(p) } diff --git a/R/api_preconditions.R b/R/api_preconditions.R deleted file mode 100644 index c617bd320..000000000 --- a/R/api_preconditions.R +++ /dev/null @@ -1,132 +0,0 @@ -#' @title Preconditions for multi-layer perceptron -#' @name .pre_sits_mlp -#' -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' -#' @param samples Time series with the training samples. -#' @param epochs Number of iterations to train the model. -#' @param batch_size Number of samples per gradient update. -#' @param layers Vector with number of hidden nodes in each layer. -#' @param dropout_rates Vector with the dropout rates (0,1) -#' for each layer. -#' @param patience Number of epochs without improvements until -#' training stops. -#' @param min_delta Minimum improvement in loss function -#' to reset the patience counter. -#' @param verbose Verbosity mode (TRUE/FALSE). Default is FALSE. -#' @keywords internal -#' @noRd -#' @return Called for side effects. -#' -.pre_sits_mlp <- function(samples, epochs, batch_size, - layers, dropout_rates, - patience, min_delta, verbose) { - # Pre-conditions: - .check_samples_train(samples) - .check_int_parameter(epochs) - .check_int_parameter(batch_size) - .check_int_parameter(layers) - .check_num_parameter(dropout_rates, min = 0, max = 1, - len_min = length(layers), len_max = length(layers) - ) - .check_that(length(layers) == length(dropout_rates), - msg = .conf("messages", "sits_mlp_layers_dropout") - ) - .check_int_parameter(patience) - .check_num_parameter(min_delta, min = 0) - .check_lgl_parameter(verbose) - - return(invisible(NULL)) -} -#' @title Preconditions for temporal convolutional neural network models -#' @name .pre_sits_tempcnn -#' -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' -#' @param samples Time series with the training samples. -#' @param cnn_layers Number of 1D convolutional filters per layer -#' @param cnn_kernels Size of the 1D convolutional kernels. -#' @param cnn_dropout_rates Dropout rates for 1D convolutional filters. -#' @param dense_layer_nodes Number of nodes in the dense layer. -#' @param dense_layer_dropout_rate Dropout rate (0,1) for the dense layer. -#' @param epochs Number of iterations to train the model. -#' @param batch_size Number of samples per gradient update. -#' @param lr_decay_epochs Number of epochs to reduce learning rate. -#' @param lr_decay_rate Decay factor for reducing learning rate. -#' @param patience Number of epochs without improvements until -#' training stops. -#' @param min_delta Minimum improvement in loss function -#' to reset the patience counter. -#' @param verbose Verbosity mode (TRUE/FALSE). Default is FALSE. -#' -#' @keywords internal -#' @noRd -#' -#' @return Called for side effects. -#' -.pre_sits_tempcnn <- function(samples, cnn_layers, cnn_kernels, - cnn_dropout_rates, dense_layer_nodes, - dense_layer_dropout_rate, epochs, batch_size, - lr_decay_epochs, lr_decay_rate, - patience, min_delta, verbose) { - # Pre-conditions: - .check_samples_train(samples) - .check_int_parameter(cnn_layers, len_max = 2^31 - 1) - .check_int_parameter(cnn_kernels, - len_min = length(cnn_layers), - len_max = length(cnn_layers)) - .check_num_parameter(cnn_dropout_rates, min = 0, max = 1, - len_min = length(cnn_layers), - len_max = length(cnn_layers)) - .check_int_parameter(dense_layer_nodes, len_max = 1) - .check_num_parameter(dense_layer_dropout_rate, - min = 0, max = 1, len_max = 1) - .check_int_parameter(epochs) - .check_int_parameter(batch_size) - .check_int_parameter(lr_decay_epochs) - .check_num_parameter(lr_decay_rate, exclusive_min = 0, max = 1) - .check_int_parameter(patience) - .check_num_parameter(min_delta, min = 0) - .check_lgl_parameter(verbose) - - return(invisible(NULL)) -} -#' @title Preconditions for Lightweight Temporal Self-Attention Encoder -#' and Temporal Self-Attention Encoder. -#' @name .pre_sits_lighttae -#' -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' -#' @param samples Time series with the training samples -#' (tibble of class "sits"). -#' @param epochs Number of iterations to train the model -#' (integer, min = 1, max = 20000). -#' @param batch_size Number of samples per gradient update -#' (integer, min = 16L, max = 2048L) -#' @param lr_decay_epochs Number of epochs to reduce learning rate. -#' @param lr_decay_rate Decay factor for reducing learning rate. -#' @param patience Number of epochs without improvements until -#' training stops. -#' @param min_delta Minimum improvement in loss function -#' to reset the patience counter. -#' @param verbose Verbosity mode (TRUE/FALSE). Default is FALSE. -#' -#' @keywords internal -#' @noRd -#' @return Called for side effects. -#' -.pre_sits_lighttae <- function(samples, epochs, batch_size, - lr_decay_epochs, lr_decay_rate, - patience, min_delta, verbose) { - # Pre-conditions: - .check_samples_train(samples) - .check_int_parameter(epochs, min = 1, max = 20000L) - .check_int_parameter(batch_size, min = 16, max = 2048L) - .check_int_parameter(lr_decay_epochs, min = 1) - .check_num_parameter(lr_decay_rate, exclusive_min = 0, max = 1.0) - .check_int_parameter(patience, min = 1) - .check_num_parameter(min_delta, min = 0) - .check_lgl_parameter(verbose) - - return(invisible(NULL)) -} diff --git a/R/api_predictors.R b/R/api_predictors.R index 0a209a9a5..43723dc05 100644 --- a/R/api_predictors.R +++ b/R/api_predictors.R @@ -62,7 +62,7 @@ # Rearrange data to create predictors pred <- tidyr::pivot_wider( data = pred, names_from = "index", values_from = dplyr::all_of(bands), - names_prefix = if (length(bands) == 1) bands else "", + names_prefix = if (length(bands) == 1L) bands else "", names_sep = "" ) # Return predictors @@ -76,11 +76,11 @@ pred <- .predictors.sits(samples, ml_model) # Get predictors for base data pred_base <- samples |> - dplyr::rename( - "_" = "time_series", "time_series" = "base_data" - ) |> - .predictors.sits() |> - dplyr::select(-.data[["label"]]) + dplyr::rename( + "_" = "time_series", "time_series" = "base_data" + ) |> + .predictors.sits() |> + dplyr::select(-.data[["label"]]) # Merge predictors pred <- dplyr::inner_join(pred, pred_base, by = "sample_id") # Return predictors @@ -110,7 +110,7 @@ #' @return Data.frame without first two cols .pred_features <- function(pred) { if (all(.pred_cols %in% names(pred))) { - pred[, -2:0] + pred[, -2L:0L] } else { pred } @@ -124,7 +124,7 @@ #' @return Data.frame with new value `.pred_features<-` <- function(pred, value) { if (all(.pred_cols %in% names(pred))) { - pred[, seq_len(ncol(pred) - 2) + 2] <- value + pred[, seq_len(ncol(pred) - 2L) + 2L] <- value } else { pred[, ] <- value } @@ -174,10 +174,10 @@ #' @param frac Fraction to sample #' @return Predictors data.frame sampled .pred_sample <- function(pred, frac) { - pred <- dplyr::group_by(pred, .data[["label"]]) - frac <- dplyr::slice_sample(pred, prop = frac) |> + pred |> + dplyr::group_by(.data[["label"]]) |> + dplyr::slice_sample(prop = frac) |> dplyr::ungroup() - return(frac) } #' @title Convert predictors to ts #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} @@ -200,10 +200,10 @@ ) |> dplyr::mutate( sample_id = rep(seq_len(nrow(data)), - each = dplyr::n() / nrow(data)), + each = dplyr::n() / nrow(data)), label = "NoClass", Index = rep(timeline, nrow(data)), - .before = 1 + .before = 1L ) } #' @title Get predictors of a given partition @@ -212,8 +212,5 @@ #' @noRd #' @param part Predictors partition .pred_part <- function(part) { - .default(part[["predictors"]][[1]]) + .default(part[["predictors"]][[1L]]) } - - - diff --git a/R/api_raster.R b/R/api_raster.R index 3bd64a6c3..2683cdca8 100644 --- a/R/api_raster.R +++ b/R/api_raster.R @@ -3,49 +3,9 @@ #' @noRd #' @return Names of raster packages supported by sits .raster_supported_packages <- function() { - return("terra") -} -#' @title Check for block object consistency -#' @name .raster_check_block -#' @keywords internal -#' @noRd -#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} -#' @return No value, called for side effects. -.raster_check_block <- function(block) { - # set caller to show in errors - .check_set_caller(".raster_check_block") - # precondition 1 - .check_chr_contains( - x = names(block), - contains = c("row", "nrows", "col", "ncols") - ) - # precondition 2 - .check_that(block[["row"]] > 0 && block[["col"]] > 0) - # precondition 3 - .check_that(block[["nrows"]] > 0 && block[["ncols"]] > 0) - return(invisible(block)) + "terra" } -#' @title Check for bbox object consistency -#' @name .raster_check_bbox -#' @keywords internal -#' @noRd -#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} -#' @return No value, called for side effects. -.raster_check_bbox <- function(bbox) { - # set caller to show in errors - .check_set_caller(".raster_check_bbox") - # precondition 1 - .check_chr_contains( - x = names(bbox), - contains = c("xmin", "xmax", "ymin", "ymax") - ) - # precondition 2 - .check_that(bbox[["ymin"]] < bbox[["ymax"]]) - # precondition 3 - .check_that(bbox[["xmin"]] < bbox[["xmax"]]) - return(invisible(bbox)) -} #' @title Convert internal data type to gdal data type #' @name .raster_gdal_datatype #' @keywords internal @@ -62,10 +22,10 @@ gdal_data_types <- .raster_gdal_datatypes(sits_names = FALSE) names(gdal_data_types) <- sits_data_types # check data_type type - .check_that(length(data_type) == 1) + .check_that(length(data_type) == 1L) .check_that(data_type %in% sits_data_types) # convert - return(gdal_data_types[[data_type]]) + gdal_data_types[[data_type]] } #' @title Match sits data types to GDAL data types #' @name .raster_gdal_datatypes @@ -105,7 +65,7 @@ terra::readStart(x = rast) res <- terra::readValues(x = rast, mat = TRUE, ...) terra::readStop(x = rast) - return(res) + res } #' @title Raster package internal set values function @@ -121,7 +81,7 @@ #' @return Raster object .raster_set_values <- function(rast, values, ...) { terra::values(x = rast) <- as.matrix(values) - return(rast) + rast } #' @title Raster package internal get values for rasters in memory #' @name .raster_values_mem @@ -135,8 +95,7 @@ #' @return Numeric vector with values .raster_values_mem <- function(rast, ...) { # read values and close connection - res <- terra::values(x = rast, ...) - return(res) + terra::values(x = rast, ...) } #' @title Raster package internal set min max #' @name .raster_set_minmax @@ -149,7 +108,7 @@ #' @return Raster object with additional minmax information .raster_set_minmax <- function(rast) { terra::setMinMax(rast) - return(invisible(rast)) + invisible(rast) } #' @title Raster package internal stretch function #' @name .raster_stretch @@ -181,7 +140,7 @@ #' @return Raster object .raster_set_na <- function(rast, na_value, ...) { terra::NAflag(x = rast) <- na_value - return(rast) + rast } #' @title Get top values of a raster. @@ -223,7 +182,7 @@ x = values, nrows = block[["nrows"]], ncols = block[["ncols"]], - band = 0, + band = 0L, window_size = sampling_window ) samples_tb <- C_max_sampling( @@ -247,7 +206,7 @@ # find NA na_rows <- which(is.na(tb)) # remove NA - if (length(na_rows) > 0) { + if (.has(na_rows)) { tb <- tb[-na_rows, ] samples_tb <- samples_tb[-na_rows, ] } @@ -263,10 +222,8 @@ sf::st_coordinates() colnames(result_tb) <- c("longitude", "latitude") - result_tb <- result_tb |> - dplyr::bind_cols(samples_tb) - - return(result_tb) + # bind cols and return + dplyr::bind_cols(result_tb, samples_tb) } #' @title Raster package internal extract values function @@ -307,9 +264,9 @@ #' #' @return An vector with the file block size. .raster_file_blocksize <- function(rast) { - block_size <- c(terra::fileBlocksize(rast[[1]])) + block_size <- c(terra::fileBlocksize(rast[[1L]])) names(block_size) <- c("nrows", "ncols") - return(block_size) + block_size } #' @title Raster package internal object creation @@ -323,7 +280,7 @@ #' @param ... additional parameters to be passed to raster package #' #' @return Raster package object -.raster_rast <- function(rast, nlayers = 1, ...) { +.raster_rast <- function(rast, nlayers = 1L, ...) { suppressWarnings( terra::rast(x = rast, nlyrs = nlayers, ...) ) @@ -487,7 +444,7 @@ .raster_read_rast <- function(files, ..., block = NULL) { # check block if (.has(block)) { - .raster_check_block(block = block) + .check_raster_block(block = block) } # create raster objects rast <- .raster_open_rast(file = path.expand(files), ...) @@ -548,7 +505,7 @@ .check_null_parameter(mask) # check block if (.has_block(mask)) { - .raster_check_block(block = mask) + .check_raster_block(block = mask) } # Update missing_value missing_value <- if (is.null(missing_value)) NA else missing_value @@ -561,7 +518,7 @@ ) xmax <- terra::xFromCol( object = rast, - col = mask[["col"]] + mask[["ncols"]] - 1 + col = mask[["col"]] + mask[["ncols"]] - 1L ) ymax <- terra::yFromRow( object = rast, @@ -569,7 +526,7 @@ ) ymin <- terra::yFromRow( object = rast, - row = mask[["row"]] + mask[["nrows"]] - 1 + row = mask[["row"]] + mask[["nrows"]] - 1L ) # xmin, xmax, ymin, ymax @@ -624,10 +581,10 @@ .check_that(.has_not(block) || .has_not(bbox)) # check block if (.has(block)) - .raster_check_block(block = block) + .check_raster_block(block = block) # check bbox if (.has(bbox)) - .raster_check_bbox(bbox = bbox) + .check_raster_bbox(bbox = bbox) # obtain coordinates from columns and rows if (!is.null(block)) { # get extent @@ -637,7 +594,7 @@ ) xmax <- terra::xFromCol( object = rast, - col = block[["col"]] + block[["ncols"]] - 1 + col = block[["col"]] + block[["ncols"]] - 1L ) ymax <- terra::yFromRow( object = rast, @@ -645,7 +602,7 @@ ) ymin <- terra::yFromRow( object = rast, - row = block[["row"]] + block[["nrows"]] - 1 + row = block[["row"]] + block[["nrows"]] - 1L ) } else if (!is.null(bbox)) { xmin <- bbox[["xmin"]] @@ -783,16 +740,16 @@ #' @return scale of values in raster object .raster_scale <- function(rast, ...) { # check value - i <- 1 + i <- 1L while (is.na(rast[i])) { - i <- i + 1 + i <- i + 1L } value <- rast[i] - if (value > 1.0 && value <= 10000) + if (value > 1.0 && value <= 10000L) scale_factor <- 0.0001 else scale_factor <- 1.0 - return(scale_factor) + scale_factor } #' @name .raster_crs #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} @@ -848,13 +805,11 @@ #' @param ... additional parameters to be passed to raster package #' @return resolution of raster object in x and y dimensions .raster_res <- function(rast, ...) { - # return a named resolution - res <- list( + # return a named list + list( xres = .raster_xres(rast), yres = .raster_yres(rast) ) - - return(res) } #' @name .raster_extent_bbox #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} @@ -884,13 +839,11 @@ #' @param ... additional parameters to be passed to raster package #' @return number of rows and cols of raster object .raster_size <- function(rast, ...) { - # return a named size - size <- list( + # return a named list + list( nrows = .raster_nrows(rast), ncols = .raster_ncols(rast) ) - - return(size) } #' @title Raster package internal frequency values function #' @name .raster_freq @@ -970,7 +923,7 @@ #' @param rast raster package object #' @param cell cell in raster object #' @return matrix of x and y coordinates -.raster_xy_from_cell <- function(rast, cell){ +.raster_xy_from_cell <- function(rast, cell) { terra::xyFromCell(rast, cell) } #' @title Return quantile value given an raster @@ -1030,11 +983,11 @@ # preconditions .check_that(all(file.exists(file))) # use first file - file <- file[[1]] + file <- file[[1L]] # open file rast <- .raster_open_rast(file = file) # build params file - params <- tibble::tibble( + tibble::tibble( nrows = .raster_nrows(rast = rast), ncols = .raster_ncols(rast = rast), xmin = .raster_xmin(rast = rast), @@ -1045,7 +998,6 @@ yres = .raster_yres(rast = rast), crs = .raster_crs(rast = rast) ) - return(params) } #' @title Template for creating a new raster #' @name .raster_template @@ -1071,8 +1023,8 @@ params = list( "-ot" = .raster_gdal_datatype(data_type), "-of" = .conf("gdal_presets", "image", "of"), - "-b" = rep(1, nlayers), - "-scale" = list(0, 1, missing_value, missing_value), + "-b" = rep(1L, nlayers), + "-scale" = list(0L, 1L, missing_value, missing_value), "-a_nodata" = missing_value, "-co" = .conf("gdal_creation_options") ), @@ -1080,7 +1032,7 @@ ) # Delete auxiliary files on.exit(unlink(paste0(out_file, ".aux.xml")), add = TRUE) - return(out_file) + out_file } #' @title Merge all input files into one raster file @@ -1105,14 +1057,14 @@ block_files, data_type, missing_value, - multicores = 2) { + multicores = 2L) { # set caller to show in errors .check_set_caller(".raster_merge_blocks") # Check consistency between block_files and out_files if (is.list(block_files)) { .check_that(all(lengths(block_files) == length(out_files))) } else { - .check_that(length(out_files) == 1) + .check_that(length(out_files) == 1L) block_files <- as.list(block_files) } # for each file merge blocks @@ -1131,7 +1083,7 @@ extensions = "tif" ) # Get number of layers - nlayers <- .raster_nlayers(.raster_open_rast(merge_files[[1]])) + nlayers <- .raster_nlayers(.raster_open_rast(merge_files[[1L]])) if (.has(base_file)) { # Create raster template .raster_template( @@ -1230,7 +1182,7 @@ } # check if files were already checked before checked_files <- NULL - checked <- logical(0) + checked <- logical(0L) if (!is.null(output_dir)) { checked_files <- .file_path( ".check", .file_sans_ext(files), @@ -1241,7 +1193,7 @@ checked <- file.exists(checked_files) } files <- files[!files %in% checked] - if (length(files) == 0) { + if (length(files) == 0L) { return(TRUE) } # try to open the file @@ -1302,19 +1254,19 @@ # to support old models convert values to matrix values <- as.matrix(values) nlayers <- ncol(values) - if (length(files) > 1) { + if (length(files) > 1L) { .check_that( length(files) == ncol(values), msg = .conf("messages", ".raster_write_block_mismatch") ) # Write each layer in a separate file - nlayers <- 1 + nlayers <- 1L } for (i in seq_along(files)) { # Get i-th file file <- files[[i]] # Get layers to be saved - cols <- if (length(files) > 1) i else seq_len(nlayers) + cols <- if (length(files) > 1L) i else seq_len(nlayers) # Create a new raster rast <- .raster_new_rast( nrows = block[["nrows"]], ncols = block[["ncols"]], @@ -1357,7 +1309,10 @@ #' @param band_conf Band configuration file #' @return A Spatial Raster object # -.raster_view_rgb_object <- function(red_file, green_file, blue_file, band_conf){ +.raster_view_rgb_object <- function(red_file, + green_file, + blue_file, + band_conf) { rgb_files <- c(r = red_file, g = green_file, b = blue_file) rast <- .raster_open_rast(rgb_files) @@ -1371,14 +1326,14 @@ band_offset <- .offset(band_conf) # scale the data - rast <- (rast * band_scale + band_offset) * 255 + rast <- (rast * band_scale + band_offset) * 255L # # stretch the raster - rast <- .raster_stretch(rast, minv = 0, maxv = 255, + rast <- .raster_stretch(rast, minv = 0L, maxv = 255L, minq = 0.05, maxq = 0.95) # convert to RGB names(rast) <- c("red", "green", "blue") - terra::RGB(rast) <- c(1,2,3) + terra::RGB(rast) <- c(1L, 2L, 3L) .raster_set_minmax(rast) - return(rast) + rast } diff --git a/R/api_raster_sub_image.R b/R/api_raster_sub_image.R index 7c77f3aae..b6fd799c8 100644 --- a/R/api_raster_sub_image.R +++ b/R/api_raster_sub_image.R @@ -10,7 +10,7 @@ .raster_sub_image <- function(tile, roi) { .check_set_caller(".raster_sub_image") # pre-condition - .check_int_parameter(nrow(tile), min = 1, max = 1) + .check_int_parameter(nrow(tile), min = 1L, max = 1L) # calculate the intersection between the bbox of the ROI and the cube # transform the tile bbox to sf @@ -22,8 +22,7 @@ # get bbox of subimage sub_image_bbox <- .bbox(geom) # return the sub_image - sub_image <- .raster_sub_image_from_bbox(sub_image_bbox, tile) - return(sub_image) + .raster_sub_image_from_bbox(sub_image_bbox, tile) } #' @title Extract a sub_image from a bounding box and a cube @@ -41,20 +40,10 @@ .check_set_caller(".raster_sub_image_from_bbox") # pre-condition n_tiles <- nrow(tile) - .check_int_parameter(n_tiles, min = 1, max = 1) + .check_int_parameter(n_tiles, min = 1L, max = 1L) # tolerance added to handle edge cases - tolerance <- 0.001 - - # pre-conditions - .check_that( - bbox[["xmin"]] < bbox[["xmax"]] && - bbox[["ymin"]] < bbox[["ymax"]] + tolerance && - bbox[["xmin"]] >= tile[["xmin"]] - tolerance && - bbox[["xmax"]] <= tile[["xmax"]] + tolerance && - bbox[["ymin"]] >= tile[["ymin"]] - tolerance && - bbox[["ymax"]] <= tile[["ymax"]] + tolerance - ) + .check_raster_bbox_tolerance(bbox, tile, tolerance = 0.001) # tile template rast <- .raster_new_rast( @@ -126,5 +115,5 @@ tolerance = tolerance ) - return(si) + si } diff --git a/R/api_reclassify.R b/R/api_reclassify.R index 6d4f64363..215a0f33f 100644 --- a/R/api_reclassify.R +++ b/R/api_reclassify.R @@ -19,7 +19,7 @@ ) # Resume feature if (file.exists(out_file)) { - .check_recovery(tile[["tile"]]) + .check_recovery() class_tile <- .tile_derived_from_file( file = out_file, band = band, @@ -33,7 +33,7 @@ return(class_tile) } # Create chunks as jobs - chunks <- .tile_chunks_create(tile = tile, overlap = 0) + chunks <- .tile_chunks_create(tile = tile, overlap = 0L) # start parallel process block_files <- .jobs_map_parallel_chr(chunks, function(chunk) { # Get job block @@ -63,13 +63,13 @@ # Create template block for mask .gdal_template_block( block = block, bbox = .bbox(chunk), file = mask_block_file, - nlayers = 1, miss_value = .miss_value(band_conf), + nlayers = 1L, miss_value = .miss_value(band_conf), data_type = .data_type(band_conf) ) # Copy values from mask cube into mask template .gdal_merge_into( file = mask_block_file, - base_files = .fi_paths(.fi(mask)), multicores = 1 + base_files = .fi_paths(.fi(mask)), multicores = 1L ) # Build a new tile for mask based on template mask_tile <- .tile_derived_from_file( @@ -94,11 +94,11 @@ values <- rep(NA, .block_size(block)) } offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { + if (.has(offset) && offset != 0.0) { values <- values - offset } scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { + if (.has(scale) && scale != 1.0) { values <- values / scale } # Prepare and save results as raster @@ -212,13 +212,13 @@ # Get rules new labels new_labels <- setdiff(names(rules), cube_labels) # Does rules has new labels in the composition? - if (.has(new_labels) > 0) { + if (.has(new_labels)) { # Get the next index - next_idx <- max(as.numeric(names(cube_labels))) + 1 + next_idx <- max(as.numeric(names(cube_labels))) + 1L idx_values <- seq.int( - from = next_idx, to = next_idx + length(new_labels) - 1 + from = next_idx, to = next_idx + length(new_labels) - 1L ) names(new_labels) <- as.character(idx_values) } - return(c(cube_labels, new_labels)) + c(cube_labels, new_labels) } diff --git a/R/api_reduce.R b/R/api_reduce.R index ac0f823da..bfc62af16 100644 --- a/R/api_reduce.R +++ b/R/api_reduce.R @@ -31,7 +31,7 @@ # Resume feature if (.raster_is_valid(out_file, output_dir = output_dir)) { # recovery message - .check_recovery(out_file) + .check_recovery() # Create tile based on template tile <- .tile_eo_from_files( @@ -45,7 +45,7 @@ unlink(out_file) # Create chunks as jobs chunks <- .tile_chunks_create( - tile = tile, overlap = 0, block = block + tile = tile, overlap = 0L, block = block ) # Add cloud band in input bands if (.tile_contains_cloud(tile)) { @@ -60,7 +60,7 @@ ) # In case the user has not defined a config for the output band if (.has_not(band_conf)) { - fn_name <- .as_chr(as.list(expr[[out_band]])[[1]]) + fn_name <- .as_chr(as.list(expr[[out_band]])[[1L]]) band_conf <- .conf("default_values", .reduce_datatypes(fn_name)) } # Process jobs in parallel @@ -99,11 +99,11 @@ ) # Prepare fractions to be saved offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { + if (.has(offset) && offset != 0.0) { values <- values - offset } scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { + if (.has(scale) && scale != 1.0) { values <- values / scale } # Job crop block @@ -128,7 +128,7 @@ band_conf = band_conf, base_tile = tile, block_files = block_files, - multicores = 1, + multicores = 1L, update_bbox = FALSE ) # Return a reduced tile @@ -186,7 +186,7 @@ names(x) <- col # prepare result data[[col]] <- x[[col]] - return(data) + data } #' @title Temporal functions for reduce operations @@ -195,7 +195,7 @@ #' @noRd #' @return operations on reduce function .reduce_fns <- function() { - result_env <- list2env(list( + list2env(list( t_max = function(m) { C_temp_max(mtx = as.matrix(m)) }, @@ -239,10 +239,7 @@ C_temp_iqr(mtx = as.matrix(m)) } ), parent = parent.env(environment()), hash = TRUE) - - return(result_env) } - #' @title Output datatypes for a defined reduce function #' @name .reduce_datatypes #' @author Felipe Carvalho, \email{lipecaso@@gmail.com} diff --git a/R/api_regularize.R b/R/api_regularize.R index c33eca636..485ef8e19 100644 --- a/R/api_regularize.R +++ b/R/api_regularize.R @@ -1,3 +1,14 @@ +#' @title Regularize data cube +#' @noRd +#' @param cube Irregular data cube +#' @param timeline Timeline of the regularized cube +#' @param res Resolution of the regularized cube +#' @param roi ROI of the regularized cube (optional) +#' @param period Temporal period of the regularized cube +#' @param output_dir Directory to save the cube +#' @param progress Show progress bar? +#' +#' @return a data cube with assets of the same period (file ID) .reg_cube <- function(cube, timeline, res, roi, period, output_dir, progress) { # Save input cube class cube_class <- class(cube) @@ -69,9 +80,9 @@ .discard(assets, "tile") ) # Compare to original timeline - origin_tl <- timeline[seq_along(timeline) - 1] + origin_tl <- timeline[seq_along(timeline) - 1L] empty_dates <- as.Date(setdiff(origin_tl, unique(assets[["feature"]]))) - temp_date <- assets[1, "feature"][[1]] + temp_date <- assets[1L, "feature"][[1L]] empty_files <- purrr::map_dfr(empty_dates, function(date) { temp_df <- assets[assets[["feature"]] == temp_date,] temp_df[["feature"]] <- date @@ -88,7 +99,7 @@ .check_that( nrow(assets) == length(origin_tl) * length(.tile_bands(tile)) ) - return(assets) + assets }) } @@ -112,7 +123,7 @@ ) # Resume feature if (file.exists(out_file)) { - .check_recovery(asset[["tile"]]) + .check_recovery() asset <- .tile_eo_from_files( files = out_file, fid = fid_name, @@ -143,7 +154,7 @@ block = block, bbox = bbox, file = out_file, - nlayers = 1, + nlayers = 1L, miss_value = .miss_value(band_conf), data_type = .data_type(band_conf) ) @@ -188,7 +199,7 @@ return(cube) } # if roi and tiles are not provided, use the whole cube as extent - if (!.has(roi) && !.has(tiles)) { + if (.has_not(roi) && .has_not(tiles)) { roi <- .cube_as_sf(cube) } @@ -215,7 +226,7 @@ # if unique crs pre-calculate bbox fi_bbox <- NULL - if (length(tiles_filtered_crs) == 1) { + if (length(tiles_filtered_crs) == 1L) { # extract bounding box from files fi_bbox <- .bbox_as_sf(.bbox( x = cube_fi_unique, @@ -230,7 +241,7 @@ dplyr::group_map(~{ # prepare a sf object representing the bbox of each image in # file_info - if (!.has(fi_bbox)) { + if (.has_not(fi_bbox)) { fi_bbox <- .bbox_as_sf(.bbox( x = cube_fi_unique, default_crs = .crs(cube), @@ -240,7 +251,7 @@ # check intersection between files and tile fids_in_tile <- cube_fi_unique[.intersects(fi_bbox, .x), ] # get fids in tile - file_info <- cube_fi[cube_fi[["fid"]] %in% fids_in_tile[["fid"]],] + file_info <- cube_fi[cube_fi[["fid"]] %in% fids_in_tile[["fid"]], ] # create cube! .cube_create( source = .tile_source(cube), @@ -395,7 +406,7 @@ # file_info cube_crs <- dplyr::filter(cube, .data[["crs"]] == .x[["crs"]]) # check if it is required to use all tiles - if (nrow(cube_crs) == 0) { + if (nrow(cube_crs) == 0L) { # all tiles are used cube_crs <- cube # extracting files from all tiles @@ -455,7 +466,7 @@ # file_info cube_crs <- dplyr::filter(cube, .data[["crs"]] == .x[["crs"]]) # check if it is required to use all tiles - if (nrow(cube_crs) == 0) { + if (nrow(cube_crs) == 0L) { # all tiles are used cube_crs <- cube # extracting files from all tiles diff --git a/R/api_request.R b/R/api_request.R index 069f7bbab..2d4e0d226 100644 --- a/R/api_request.R +++ b/R/api_request.R @@ -3,7 +3,7 @@ #' @noRd #' @return Names of http verbs packages supported by sits .request_supported_packages <- function() { - return("httr2") + "httr2" } #' @title Check for request package availability @@ -49,7 +49,7 @@ #' @param ... Additional parameters to be passed to httr2 package #' #' @return A response object returned by the requisition package -.retry_request <- function(url, n_tries = 10, sleep = 10, ...) { +.retry_request <- function(url, n_tries = 10L, sleep = 10L, ...) { # check package pkg_class <- .request_check_package() diff --git a/R/api_request_httr2.R b/R/api_request_httr2.R index 40e93f15c..a8c0cf780 100644 --- a/R/api_request_httr2.R +++ b/R/api_request_httr2.R @@ -8,13 +8,9 @@ .request_check_package.httr2 <- function() { # package namespace pkg_name <- "httr2" - # check if terra package is available .check_require_packages(pkg_name) - - class(pkg_name) <- pkg_name - - return(invisible(pkg_name)) + .set_class(pkg_name, "httr2") } #' @title Perform a request using httr2 package @@ -45,13 +41,13 @@ #' #' @return A httr2 response object. #' @export -.retry_request.httr2 <- function(url, n_tries = 10, sleep = 10, ...) { - while (n_tries > 0) { +.retry_request.httr2 <- function(url, n_tries = 10L, sleep = 10L, ...) { + while (n_tries > 0L) { out <- .get_request(url = url, ...) if (!.response_is_error(out)) { return(out) } - n_tries <- n_tries - 1 + n_tries <- n_tries - 1L Sys.sleep(sleep) } return(out) @@ -81,7 +77,7 @@ headers, .request_headers(req_obj, headers), req_obj ) # Quiet requisition? zero verbosity means quiet request - quiet <- .prepare_lgl(quiet, 0, 1) + quiet <- .prepare_lgl(quiet, 0L, 1L) # Perform request .request(req_obj, verbosity = quiet, ...) } @@ -148,7 +144,7 @@ resp_obj, "application/json" = httr2::resp_body_json, "application/x-www-form-urlencoded" = httr2::resp_body_html, - "application/xml","text/xml" = httr2::resp_body_xml, + "application/xml", "text/xml" = httr2::resp_body_xml, default = httr2::resp_body_json ) content_fn(resp_obj) diff --git a/R/api_roi.R b/R/api_roi.R index 2743e0f07..7568aec29 100644 --- a/R/api_roi.R +++ b/R/api_roi.R @@ -10,15 +10,13 @@ # verifies if geojsonsf and jsonlite packages are installed .check_require_packages(c("geojsonsf", "jsonlite")) # pre-conditions - .check_that(nrow(roi) == 1) + .check_that(nrow(roi) == 1L) # reproject roi to WGS84 - roi <- .roi_as_sf(roi, as_crs = "WGS84") - # convert roi_sf to geojson - geojson <- sf::st_geometry(sf::st_convex_hull(roi)) - geojson <- geojsonsf::sfc_geojson(geojson) - geojson <- jsonlite::fromJSON(geojson) - - return(geojson) + .roi_as_sf(roi, as_crs = "WGS84") |> + sf::st_convex_hull() |> + sf::st_geometry() |> + geojsonsf::sfc_geojson() |> + jsonlite::fromJSON() } # ROI API # @@ -89,7 +87,7 @@ NULL #' @noRd .roi_switch <- function(roi, ...) { switch(.roi_type(roi), - ... + ... ) } @@ -136,7 +134,7 @@ NULL # Clean roi roi <- .sf_clean(roi) # Transform feature to multipolygons - roi <- if (.has(nrow(roi)) && nrow(roi) > 1) sf::st_union(roi) else roi + roi <- if (.has(nrow(roi)) && nrow(roi) > 1L) sf::st_union(roi) else roi # Return roi roi } @@ -160,5 +158,5 @@ NULL file_name <- .file_sans_ext(roi) shp_exts <- c(".shp", ".shx", ".dbf", ".prj") unlink(paste0(file.path(dir_name, file_name), shp_exts)) - return(invisible(roi)) + invisible(roi) } diff --git a/R/api_samples.R b/R/api_samples.R index c8586d2a9..cfb00fbdc 100644 --- a/R/api_samples.R +++ b/R/api_samples.R @@ -63,7 +63,7 @@ data[["folds"]] <- caret::createFolds(data[["label"]], k = folds, returnTrain = FALSE, list = FALSE) - return(data) + data } #' @title Extract time series from samples #' @noRd @@ -97,20 +97,17 @@ #' @export .samples_bands.sits <- function(samples, ...) { # Bands of the first sample governs whole samples data - bands <- setdiff(names(.samples_ts(samples)), "Index") - return(bands) + setdiff(names(.samples_ts(samples)), "Index") } #' @export .samples_bands.sits_base <- function(samples, ..., include_base = TRUE) { # Bands of the first sample governs whole samples data bands <- .samples_bands.sits(samples) - if (include_base) { bands <- c( bands, .samples_base_bands(samples) ) } - bands } #' @title Check if samples is base (has base property) @@ -133,14 +130,14 @@ #' @return Bands for the first sample .samples_base_bands <- function(samples) { # Bands of the first sample governs whole samples data - setdiff(names(samples[["base_data"]][[1]]), "Index") + setdiff(names(samples[["base_data"]][[1L]]), "Index") } #' @title Get timeline of time series samples #' @noRd #' @param samples Data.frame with samples #' @return Timeline of the first sample .samples_timeline <- function(samples) { - as.Date(samples[["time_series"]][[1]][["Index"]]) + as.Date(samples[["time_series"]][[1L]][["Index"]]) } #' @title Select bands of time series samples #' @noRd @@ -221,11 +218,10 @@ # Get the time series length for the first sample ntimes <- .samples_ntimes(samples) # Prune time series according to the first time series length and return - new_samples <- .samples_foreach_ts(samples, function(ts) { + .samples_foreach_ts(samples, function(ts) { .check_that(nrow(ts) >= ntimes) ts[seq_len(ntimes), ] }) - return(new_samples) } #' @title Get sample statistics #' @noRd @@ -237,8 +233,8 @@ # Select attributes preds <- preds[.samples_bands.sits(samples)] # Compute stats - q02 <- apply(preds, 2, stats::quantile, probs = 0.02, na.rm = TRUE) - q98 <- apply(preds, 2, stats::quantile, probs = 0.98, na.rm = TRUE) + q02 <- apply(preds, 2L, stats::quantile, probs = 0.02, na.rm = TRUE) + q98 <- apply(preds, 2L, stats::quantile, probs = 0.98, na.rm = TRUE) # Number of observations ntimes <- .samples_ntimes(samples) # Replicate stats @@ -254,12 +250,12 @@ #' @return Samples split by desired intervals .samples_split <- function(samples, split_intervals) { slider::slide_dfr(samples, function(sample) { - ts <- sample[["time_series"]][[1]] + ts <- sample[["time_series"]][[1L]] .map_dfr(split_intervals, function(index) { new_sample <- sample - start <- index[[1]] - end <- index[[2]] - new_sample[["time_series"]][[1]] <- ts[seq(start, end), ] + start <- index[[1L]] + end <- index[[2L]] + new_sample[["time_series"]][[1L]] <- ts[seq(start, end), ] new_sample[["start_date"]] <- ts[["Index"]][[start]] new_sample[["end_date"]] <- ts[["Index"]][[end]] new_sample @@ -281,7 +277,7 @@ .samples_alloc_strata <- function(cube, samples_class, alloc, ..., - multicores = 2, + multicores = 2L, progress = TRUE){ UseMethod(".samples_alloc_strata", cube) } @@ -289,8 +285,10 @@ .samples_alloc_strata.class_cube <- function(cube, samples_class, alloc, ..., - multicores = 2, + multicores = 2L, progress = TRUE){ + # check progress + progress <- .message_progress(progress) # estimate size size <- samples_class[[alloc]] size <- ceiling(max(size) / nrow(cube)) @@ -346,9 +344,7 @@ dplyr::slice_sample(n = round(samples_label)) }) # transform to sf object - samples <- sf::st_as_sf(samples) - - return(samples) + sf::st_as_sf(samples) } #' @export .samples_alloc_strata.class_vector_cube <- function(cube, @@ -356,9 +352,11 @@ alloc, ..., multicores = 2, progress = TRUE) { + # check progress + progress <- .message_progress(progress) + # Open segments and transform them to tibble segments_cube <- slider::slide_dfr(cube, function(tile){ - # Open segments and transform them to tibble - segments <- .segments_read_vec(tile) + .segments_read_vec(tile) }) # Retrieve the required number of segments per class samples_lst <- segments_cube |> @@ -378,8 +376,7 @@ # return! sf_samples }) - samples <- dplyr::bind_rows(samples_lst) - return(samples) + dplyr::bind_rows(samples_lst) } #' @title Converts samples to sits #' @name .samples_convert_to_sits @@ -389,9 +386,6 @@ #' @keywords internal #' @noRd .samples_convert_to_sits <- function(samples) { - if (!("sits" %in% class(samples))){ - samples <- tibble::as_tibble(samples) - class(samples) <- c("sits", class(samples)) - } - samples + samples <- tibble::as_tibble(samples) + .set_class(samples, "sits", class(samples)) } diff --git a/R/api_segments.R b/R/api_segments.R index 76b3e2912..57ff61761 100755 --- a/R/api_segments.R +++ b/R/api_segments.R @@ -30,9 +30,7 @@ ) # Resume feature if (file.exists(out_file)) { - if (.check_messages()) { - .check_recovery(out_file) - } + .check_recovery() seg_tile <- .tile_segments_from_file( file = out_file, band = band, @@ -42,7 +40,6 @@ ) return(seg_tile) } - # Create chunks as jobs chunks <- .tile_chunks_create(tile = tile, overlap = 0, block = block) # By default, update_bbox is FALSE @@ -135,7 +132,7 @@ if (is.null(s_obj)) { return(FALSE) } - return(TRUE) + TRUE } #' @name .segments_data_read @@ -200,7 +197,7 @@ #' @return GPKG file name .segments_path <- function(cube) { slider::slide_chr(cube, function(tile) { - tile[["vector_info"]][[1]][["path"]] + tile[["vector_info"]][[1L]][["path"]] }) } #' @name .segments_read_vec @@ -211,9 +208,7 @@ #' @return segment vectors (sf object) .segments_read_vec <- function(cube) { tile <- .tile(cube) - vector_seg <- .vector_read_vec(.segments_path(tile)) - - return(vector_seg) + .vector_read_vec(.segments_path(tile)) } #' @name .segments_join_probs #' @keywords internal @@ -299,7 +294,7 @@ ) }) # extract the pol_id information from the first element of the list - pol_id <- ts_bands[[1]][[1]] + pol_id <- ts_bands[[1L]][[1L]] # remove the first element of the each list and retain the second ts_bands <- purrr::map(ts_bands, function(ts_band) ts_band[[2]]) # rename the resulting list @@ -395,8 +390,8 @@ lat_long <- .proj_to_latlong( segments[["x"]], segments[["y"]], .crs(tile)) } else { - lat_long <- tibble::tibble("longitude" = rep(0, nrow(segments)), - "latitude" = rep(0, nrow(segments))) + lat_long <- tibble::tibble("longitude" = rep(0.0, nrow(segments)), + "latitude" = rep(0.0, nrow(segments))) } # create metadata for the polygons @@ -423,12 +418,10 @@ ) } samples <- .discard(samples, "sample_id") - # set sits class - class(samples) <- c("sits", class(samples)) # define `sits_base` if applicable if (.has(base_bands)) { class(samples) <- c("sits_base", class(samples)) } - # return! - return(samples) + # set sits class and return + .set_class(samples, "sits", class(samples)) } diff --git a/R/api_select.R b/R/api_select.R index 44d688fff..81a4465d5 100644 --- a/R/api_select.R +++ b/R/api_select.R @@ -12,14 +12,14 @@ bands, allow_empty = FALSE, allow_duplicate = FALSE, - len_min = 1, + len_min = 1L, len_max = length(.cube_bands(data)) ) # filter the selected bands data <- .cube_filter_bands(cube = data, bands = bands) } - return(data) + data } #' @title Select dates from cube #' @noRd @@ -31,7 +31,7 @@ dates <- .timeline_format(dates) data <- .cube_filter_dates(cube = data, dates = dates) } - return(data) + data } #' @title Select period from cube #' @noRd @@ -48,7 +48,7 @@ cube = data, start_date = start_date, end_date = end_date ) } - return(data) + data } #' @title Select tiles from cube #' @noRd @@ -60,7 +60,7 @@ .check_chr_parameter(tiles) data <- .cube_filter_tiles(cube = data, tiles = tiles) } - return(data) + data } #' @title Select tiles from cube #' @noRd diff --git a/R/api_sf.R b/R/api_sf.R index 6cacb5acd..8978ebb60 100644 --- a/R/api_sf.R +++ b/R/api_sf.R @@ -23,9 +23,9 @@ # set caller to show in errors .check_set_caller(".sf_get_samples") # Pre-condition - is the sf object has geometries? - .check_that(nrow(sf_object) > 0) + .check_that(.has(sf_object)) # Pre-condition - can the function deal with the geometry_type? - geom_type <- as.character(sf::st_geometry_type(sf_object)[[1]]) + geom_type <- as.character(sf::st_geometry_type(sf_object)[[1L]]) sf_geom_types_supported <- .conf("sf_geom_types_supported") .check_that(geom_type %in% sf_geom_types_supported) # Get the points to be read @@ -38,11 +38,8 @@ start_date = start_date, end_date = end_date ) - class(samples) <- c("sits", class(samples)) - - return(samples) + .set_class(samples, "sits", class(samples)) } - #' @title Obtain a tibble with lat/long points from an sf object #' @name .sf_to_tibble #' @keywords internal @@ -76,32 +73,29 @@ sf::st_transform(sf_object, crs = "EPSG:4326") ) # Get the geometry type - geom_type <- as.character(sf::st_geometry_type(sf_object)[[1]]) + geom_type <- as.character(sf::st_geometry_type(sf_object)[[1L]]) # Get a tibble with points and labels points_tbl <- switch(geom_type, - POINT = .sf_point_to_tibble( - sf_object = sf_object, - label_attr = label_attr, - label = label - ), - POLYGON = , - MULTIPOLYGON = .sf_polygon_to_tibble( - sf_object = sf_object, - label_attr = label_attr, - label = label, - n_sam_pol = n_sam_pol, - sampling_type = sampling_type - ) + POINT = .sf_point_to_tibble( + sf_object = sf_object, + label_attr = label_attr, + label = label + ), + POLYGON = , + MULTIPOLYGON = .sf_polygon_to_tibble( + sf_object = sf_object, + label_attr = label_attr, + label = label, + n_sam_pol = n_sam_pol, + sampling_type = sampling_type + ) ) - # Transform to type Date - points_tbl <- dplyr::mutate( + dplyr::mutate( points_tbl, start_date = as.Date(start_date), end_date = as.Date(end_date) ) - - return(points_tbl) } #' @title Obtain a tibble with latitude/longitude points from POINT geometry @@ -134,13 +128,11 @@ labels <- rep(label, times = nrow(points)) } # build a tibble with lat/long and label - points_tbl <- tibble::tibble( - longitude = points[, 1], - latitude = points[, 2], + tibble::tibble( + longitude = points[, 1L], + latitude = points[, 2L], label = labels ) - - return(points_tbl) } #' @title Obtain a tibble with latitude/longitude points from POINT geometry #' @name .sf_point_to_latlong @@ -150,18 +142,13 @@ #' @return A tibble with latitude/longitude points. #' .sf_point_to_latlong <- function(sf_object) { - # get the db file - sf_df <- sf::st_drop_geometry(sf_object) - # if geom_type is POINT, use the points provided in the shapefile points <- sf::st_coordinates(sf_object) - - # build a tibble with lat/long and label - points_tbl <- tibble::tibble( - longitude = points[, 1], - latitude = points[, 2], + # build a tibble with lat/long + tibble::tibble( + longitude = points[, 1L], + latitude = points[, 2L] ) - return(points_tbl) } #' @title Obtain a tibble from POLYGON geometry #' @name .sf_polygon_to_tibble @@ -190,7 +177,7 @@ within = colnames(sf_df) ) } - points_tab <- seq_len(nrow(sf_object)) |> + seq_len(nrow(sf_object)) |> .map_dfr(function(row_id) { # retrieve the class from the shape attribute if ("label" %in% colnames(sf_df)) { @@ -198,7 +185,7 @@ unlist(sf_df[row_id, "label"], use.names = FALSE) ) } else if (.has(label_attr) && - label_attr %in% colnames(sf_df)) { + label_attr %in% colnames(sf_df)) { label <- as.character( unlist(sf_df[row_id, label_attr], use.names = FALSE) ) @@ -208,20 +195,18 @@ type = sampling_type, size = n_sam_pol)) # get one time series per sample - pts_tab <- points |> - purrr::pmap_dfr(function(p) { - pll <- sf::st_geometry(p)[[1]] - row <- tibble::tibble( - longitude = pll[[1]], - latitude = pll[[2]], - label = label, - polygon_id = row_id - ) - return(row) - }) - return(pts_tab) + # return a data frame + purrr::pmap_dfr(points, function(p) { + pll <- sf::st_geometry(p)[[1L]] + # return row + tibble::tibble( + longitude = pll[[1L]], + latitude = pll[[2L]], + label = label, + polygon_id = row_id + ) + }) }) - return(points_tab) } #' @title Clean invalid geometries @@ -242,7 +227,7 @@ warning(.conf("messages", ".sf_clean")) } # return only valid geometries - sf_object[is_geometry_valid,] + sf_object[is_geometry_valid, ] } #' @title Create an sf polygon from a window #' @name .sf_from_window @@ -260,7 +245,7 @@ window[["ymax"]], window[["ymin"]]) ) polygon <- df |> - sf::st_as_sf(coords = c("lon", "lat"), crs = 4326) |> + sf::st_as_sf(coords = c("lon", "lat"), crs = 4326L) |> dplyr::summarise(geometry = sf::st_combine(geometry)) |> sf::st_cast("POLYGON") polygon diff --git a/R/api_shp.R b/R/api_shp.R index c76a5765c..43f9bacd1 100644 --- a/R/api_shp.R +++ b/R/api_shp.R @@ -39,10 +39,8 @@ start_date = start_date, end_date = end_date ) - - class(samples) <- c("sits", class(samples)) - - return(samples) + # set class and return + .set_class(samples, "sits", class(samples)) } #' @title Check the validity of the shape file and return an sf object @@ -64,10 +62,10 @@ # read the shapefile sf_shape <- sf::read_sf(shp_file) # postcondition - is the shape file valid? - .check_that(nrow(sf_shape) > 0) + .check_that(.has(sf_shape)) # get the geometry type - geom_type <- sf::st_geometry_type(sf_shape)[[1]] + geom_type <- sf::st_geometry_type(sf_shape)[[1L]] # postcondition - are all geometries compatible? .check_that(all(sf::st_geometry_type(sf_shape) == geom_type)) @@ -75,6 +73,6 @@ .check_that(as.character(geom_type) %in% .conf("sf_geom_types_supported")) # postcondition - is the shape attribute valid? .check_shp_attribute(sf_shape, shp_attr) - - return(sf_shape) + # return + sf_shape } diff --git a/R/api_signal.R b/R/api_signal.R index a4276068b..1a9247ab6 100644 --- a/R/api_signal.R +++ b/R/api_signal.R @@ -46,34 +46,34 @@ #' @param m Derivative to calculate (default = 0) #' @param ts Time scaling (integer). #' @return filter coefficients -.signal_sgolay_coef <- function(p, n, m = 0, ts = 1) { - if (n %% 2 != 1) { +.signal_sgolay_coef <- function(p, n, m = 0.0, ts = 1L) { + if (n %% 2L != 1L) { stop(.conf("messages", ".signal_odd_filter_length")) } if (p >= n) { - stop(.conf("messages",".signal_filter_length")) + stop(.conf("messages", ".signal_filter_length")) } ## Construct a set of filters from complete causal to completely ## noncausal, one filter per row. For the bulk of your data you ## will use the central filter, but towards the ends you will need ## a filter that doesn't go beyond the end points. - filter <- matrix(0., n, n) - k <- floor(n / 2) - for (row in 1:(k + 1)) { + filter <- matrix(0.0, n, n) + k <- floor(n / 2L) + for (row in 1L:(k + 1L)) { ## Construct a matrix of weights Cij = xi ^ j. The points xi are ## equally spaced on the unit grid, with past points using negative ## values and future points using positive values. - weights <- (((1:n) - row) %*% - matrix(1, 1, p + 1))^(matrix(1, n) %*% (0:p)) + weights <- (((1L:n) - row) %*% + matrix(1L, 1L, p + 1L))^(matrix(1L, n) %*% (0L:p)) ## A = pseudo-inverse (C), so C*A = I; this is constructed from the SVD pseudo_inv <- .signal_mass_ginv(weights, tol = .Machine[["double.eps"]]) ## Take the row of the matrix corresponding to the derivative ## you want to compute. - filter[row, ] <- pseudo_inv[1 + m, ] + filter[row, ] <- pseudo_inv[1L + m, ] } ## The filters shifted to the right are symmetric with those to the left. - filter[(k + 2):n, ] <- (-1)^m * filter[k:1, n:1] + filter[(k + 2L):n, ] <- (-1.0)^m * filter[k:1L, n:1L] class(filter) <- "sgolay_filter" return(filter) } @@ -96,5 +96,5 @@ #' .signal_mass_ginv <- function(mtx, tol = sqrt(.Machine[["double.eps"]])) { mtx_svd <- svd(mtx) - mtx_svd[["v"]] %*% (1 / mtx_svd[["d"]] * t(mtx_svd[["u"]])) + mtx_svd[["v"]] %*% (1.0 / mtx_svd[["d"]] * t(mtx_svd[["u"]])) } diff --git a/R/api_smooth.R b/R/api_smooth.R index aac527822..dc8589e29 100644 --- a/R/api_smooth.R +++ b/R/api_smooth.R @@ -27,7 +27,7 @@ ) # Resume feature if (file.exists(out_file)) { - .check_recovery(tile[["tile"]]) + .check_recovery() probs_tile <- .tile_derived_from_file( file = out_file, band = band, @@ -78,11 +78,11 @@ derived_class = "probs_cube", band = band ) offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { + if (.has(offset) && offset != 0.0) { values <- values - offset } scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { + if (.has(scale) && scale != 1.0) { values <- values / scale } # Job crop block @@ -129,7 +129,7 @@ cube = probs_tile, roi = exclusion_mask, output_dir = output_dir, - multicores = 1, + multicores = 1L, overwrite = TRUE, progress = FALSE ) @@ -180,7 +180,7 @@ smoothness = smoothness ) # Overlapping pixels - overlap <- ceiling(window_size / 2) - 1 + overlap <- ceiling(window_size / 2L) - 1L # Smoothing # Process each tile sequentially .cube_foreach_tile(cube, function(tile) { @@ -210,9 +210,9 @@ neigh_fraction, smoothness) { # Check window size - .check_int_parameter(window_size, min = 5, is_odd = TRUE) + .check_int_parameter(window_size, min = 5L, is_odd = TRUE) # Check neigh_fraction - .check_num_parameter(neigh_fraction, exclusive_min = 0, max = 1) + .check_num_parameter(neigh_fraction, exclusive_min = 0.0, max = 1.0) # Define smooth function smooth_fn <- function(values, block) { @@ -234,7 +234,7 @@ neigh_fraction = neigh_fraction ) # Compute inverse logit - values <- exp(values) / (exp(values) + 1) + values <- exp(values) / (exp(values) + 1.0) # Are the results consistent with the data input? .check_processed_values(values, input_pixels) # Return values diff --git a/R/api_smote.R b/R/api_smote.R index 816271133..c1418f5e2 100644 --- a/R/api_smote.R +++ b/R/api_smote.R @@ -21,8 +21,8 @@ # SMOTE breaks for one-dim datasets. This adds a dummy column # so SMOTE can execute in that case. This does not affect how data is # synthesized - if (ncol(data) == 2) { - data[["dummy__col__"]] <- 0 + if (ncol(data) == 2L) { + data[["dummy__col__"]] <- 0.0 } # perform SMOTE smote_ret <- .smote_apply( @@ -47,7 +47,7 @@ # remove the dummy column if necessary d_prime <- d_prime[, names(d_prime) != "dummy__col__"] # reorder the columns to be the same as the original data - return(d_prime[, orig_cols]) + d_prime[, orig_cols] } #' @title Oversample a dataset by SMOTE. @@ -72,7 +72,7 @@ #' Journal of Artificial Intelligence Research. 16, 321-357. #' @return A list with the following values. #' -.smote_apply <- function(data, target, k = 5, dup_size = 0) { +.smote_apply <- function(data, target, k = 5L, dup_size = 0L) { ncol_data <- ncol(data) # The number of attributes n_target <- table(target) # Extract a set of positive instances @@ -93,7 +93,7 @@ knear <- .smote_knearest(p_set, p_set, k) sum_dup <- dup_size syn_dat <- NULL - for (i in 1:size_p) { + for (i in seq_len(size_p)) { if (is.matrix(knear)) { pair_idx <- knear[i, ceiling(stats::runif(sum_dup) * k)] } else { @@ -106,14 +106,14 @@ syn_dat <- rbind(syn_dat, syn_i) } - p_set[, ncol_data + 1] <- p_class + p_set[, ncol_data + 1L] <- p_class colnames(p_set) <- c(colnames(data), "class") - n_set[, ncol_data + 1] <- n_class + n_set[, ncol_data + 1L] <- n_class colnames(n_set) <- c(colnames(data), "class") rownames(syn_dat) <- NULL syn_dat <- data.frame(syn_dat) - syn_dat[, ncol_data + 1] <- rep(names(which.min(n_target)), nrow(syn_dat)) + syn_dat[, ncol_data + 1L] <- rep(names(which.min(n_target)), nrow(syn_dat)) colnames(syn_dat) <- c(colnames(data), "class") new_data <- rbind(p_set, syn_dat, n_set) rownames(new_data) <- NULL @@ -144,12 +144,12 @@ .check_require_packages("FNN") kn_dist <- FNN::knnx.index(q_data, p_data, - k = (n_clust + 1), algorithm = "kd_tree") + k = (n_clust + 1L), algorithm = "kd_tree") kn_dist <- kn_dist * (kn_dist != row(kn_dist)) - que <- which(kn_dist[, 1] > 0) + que <- which(kn_dist[, 1L] > 0.0) for (i in que) { - kn_dist[i, which(kn_dist[i, ] == 0)] <- kn_dist[[i, 1]] - kn_dist[[i, 1]] <- 0 + kn_dist[i, which(kn_dist[i, ] == 0.0)] <- kn_dist[[i, 1L]] + kn_dist[[i, 1L]] <- 0.0 } - return(kn_dist[, 2:(n_clust + 1)]) + kn_dist[, 2L:(n_clust + 1L)] } diff --git a/R/api_som.R b/R/api_som.R index 1a5f179cc..49ab6c36e 100644 --- a/R/api_som.R +++ b/R/api_som.R @@ -14,7 +14,7 @@ #' and a majority label which is the neuron is labelled. #' .som_label_neurons <- function(data, kohonen_obj) { - grid_size <- dim(kohonen_obj[["grid"]][["pts"]])[[1]] + grid_size <- dim(kohonen_obj[["grid"]][["pts"]])[[1L]] labels_lst <- seq_len(grid_size) |> purrr::map(function(i) { @@ -23,7 +23,7 @@ neuron_i <- neuron_c[["id_sample"]] # Check if the neuron is empty or full - if (length(neuron_i) != 0) { + if (.has(neuron_i)) { alloc_neurons_i <- data[neuron_i, ] data_vec <- table(alloc_neurons_i[["label"]]) @@ -37,15 +37,15 @@ label_neuron <- tibble::tibble( id_neuron = as.numeric(i), label_samples = "No_Samples", - count = 0, - prior_prob = 0 + count = 0L, + prior_prob = 0.0 ) } - return(label_neuron) + label_neuron }) - labelled_neurons <- do.call(rbind, labels_lst) - return(labelled_neurons) + # return labelled_neurons + do.call(rbind, labels_lst) } #' @title Probability of a sample belongs to a cluster using bayesian filter @@ -71,7 +71,7 @@ labelled_neurons, som_radius) { # get the grid size - grid_size <- dim(kohonen_obj[["grid"]][["pts"]])[[1]] + grid_size <- dim(kohonen_obj[["grid"]][["pts"]])[[1L]] post_probs_lst <- seq_len(grid_size) |> purrr::map(function(neuron_id) { @@ -87,7 +87,7 @@ # get information on the samples that are mapped to the neuron data_neuron_i <- labelled_neurons |> dplyr::filter(.data[["id_neuron"]] == neuron_id) - if ((data_neuron_i[["label_samples"]][[1]]) == "Noclass") { + if ((data_neuron_i[["label_samples"]][[1L]]) == "Noclass") { return(NULL) } # calculate the smoothing factor to be used to the posterior prob @@ -103,7 +103,7 @@ # how many neighbours with zero probabilities? n_zeros <- length(neighbours) - nrow(neigh_label) # get the prior probability vector considering the zero probs - prior_probs <- c(neigh_label[["prior_prob"]], rep(0, n_zeros)) + prior_probs <- c(neigh_label[["prior_prob"]], rep(0L, n_zeros)) # neighborhood label frequency variance var_neig <- stats::var(prior_probs) # neighborhood label frequency mean @@ -119,12 +119,10 @@ w1 <- (var_neig / (eta + var_neig)) * row[["prior_prob"]] w2 <- (eta / (eta + var_neig)) * mean_neig post_prob <- w1 + w2 - return(post_prob) + post_prob }) - # get the posterior probabilities for the neuron - post_probs_neu <- unlist(post_probs) - # add to the list - return(post_probs_neu) + # return the posterior probabilities for the neuron + unlist(post_probs) }) # get the posterior probabilities for all the neurons post_probs <- unlist(post_probs_lst) @@ -132,7 +130,7 @@ # include the probabilities in the labeled neurons labelled_neurons[["post_prob"]] <- post_probs # return the updated labeled neurons - return(labelled_neurons) + labelled_neurons } #' @title Paint neurons @@ -165,8 +163,8 @@ ) labels <- koh[["som_properties"]][["neuron_label"]] koh[["som_properties"]][["paint_map"]] <- unname(colors[labels]) - - return(koh) + # return + koh } #' @title Adjacency matrix @@ -182,7 +180,7 @@ #' .som_adjacency <- function(som_map) { koh <- som_map$som_properties - adjacency <- proxy::as.matrix(proxy::dist(koh$codes$NDVI, method = "dtw")) + proxy::as.matrix(proxy::dist(koh$codes$NDVI, method = "dtw")) } #' @title Transform SOM map into sf object. @@ -199,25 +197,22 @@ .som_to_sf <- function(som_map) { koh <- som_map$som_properties - grid_idx <- 0 - neuron_ids <- koh$grid$pts neuron_pols <- purrr::map(seq_len(neuron_ids), function(id) { - x <- neuron_ids[id,"x"] - y <- neuron_ids[id,"y"] - pol <- rbind(c((x - 1), (y - 1)), - c(x, (y - 1)), + x <- neuron_ids[id, "x"] + y <- neuron_ids[id, "y"] + pol <- rbind(c((x - 1L), (y - 1L)), + c(x, (y - 1L)), c(x, y), - c((x - 1), y), - c((x - 1), (y - 1))) - pol <- sf::st_polygon(list(pol)) - return(pol) + c((x - 1L), y), + c((x - 1L), (y - 1L))) + # return polygon as sf object + sf::st_polygon(list(pol)) }) neuron_attr <- as.data.frame(koh$codes) neuron_attr$geometry <- sf::st_sfc(neuron_pols) - - sf_neurons <- sf::st_sf(neuron_attr, geometry = neuron_attr$geometry) - return(sf_neurons) + # return neurons as sf objects + sf::st_sf(neuron_attr, geometry = neuron_attr$geometry) } #' @title Use SOM to undersample classes with many samples #' @name .som_undersample @@ -235,7 +230,7 @@ #' @return Samples for chosen classes with reduced number #' .som_undersample <- function(samples, classes_under, - n_samples_under, multicores){ + n_samples_under, multicores) { # for each class, select some of the samples using SOM .parallel_start(workers = multicores) on.exit(.parallel_stop()) @@ -243,7 +238,7 @@ # select the samples for the class samples_cls <- dplyr::filter(samples, .data[["label"]] == cls) # set the dimension of the SOM grid - grid_dim <- ceiling(sqrt(n_samples_under / 4)) + grid_dim <- ceiling(sqrt(n_samples_under / 4L)) # build the SOM map som_map <- suppressWarnings( sits_som_map( @@ -251,18 +246,16 @@ grid_xdim = grid_dim, grid_ydim = grid_dim, distance = "dtw", - rlen = 10, + rlen = 10L, mode = "pbatch" ) ) # select samples on the SOM grid using the neurons - samples_under <- som_map[["data"]] |> + som_map[["data"]] |> dplyr::group_by(.data[["id_neuron"]]) |> - dplyr::slice_sample(n = 4, replace = TRUE) |> + dplyr::slice_sample(n = 4L, replace = TRUE) |> dplyr::ungroup() - return(samples_under) }) # bind undersample results - samples_under_new <- dplyr::bind_rows(samples_under_new) - return(samples_under_new) + dplyr::bind_rows(samples_under_new) } diff --git a/R/api_source.R b/R/api_source.R index 1b792c214..ab56596f3 100644 --- a/R/api_source.R +++ b/R/api_source.R @@ -22,7 +22,7 @@ NULL # source names are upper case src <- toupper(src) # post-condition - .check_chr(src, allow_empty = FALSE, len_min = 1) + .check_chr(src, allow_empty = FALSE, len_min = 1L) src } @@ -66,14 +66,14 @@ NULL # is this a collection of SAR data? sar_cube <- .try({ .conf("sources", source, "collections", collection, "sar_cube") - }, - .default = FALSE + }, + .default = FALSE ) # is this a collection of DEM data ? dem_cube <- .try({ .conf("sources", source, "collections", collection, "dem_cube") - }, - .default = FALSE + }, + .default = FALSE ) # if this is a SAR collection, add "sar_cube" to the class if (sar_cube) @@ -82,7 +82,7 @@ NULL if (dem_cube) class(source) <- c("dem_cube", class(source)) # add a class combining source and collection - class_source_col <- paste(classes[[1]], tolower(collection), sep = "_") + class_source_col <- paste(classes[[1L]], tolower(collection), sep = "_") class(source) <- unique(c(class_source_col, class(source))) } return(source) @@ -103,10 +103,10 @@ NULL service <- .conf("sources", source, "service") # post-condition .check_chr_parameter(service, - allow_na = TRUE, allow_empty = FALSE, - len_min = 1, len_max = 1 + allow_na = TRUE, allow_empty = FALSE, + len_min = 1L, len_max = 1L ) - return(service) + service } #' @rdname source_functions @@ -123,8 +123,8 @@ NULL s3_class <- .conf("sources", source, "s3_class") # post-condition .check_chr_parameter(s3_class, - allow_empty = FALSE, - len_min = 1 + allow_empty = FALSE, + len_min = 1L ) s3_class } @@ -143,8 +143,8 @@ NULL url <- .conf("sources", source, "url") # post-condition .check_chr_parameter(url, - allow_na = FALSE, allow_empty = FALSE, - len_min = 1, len_max = 1 + allow_na = FALSE, allow_empty = FALSE, + len_min = 1L, len_max = 1L ) url } @@ -207,7 +207,7 @@ NULL "collections", collection, "bands", band )) - }, logical(1)) + }, logical(1L)) bands <- bands[select] } # post-condition @@ -249,7 +249,7 @@ NULL } # pre-condition .check_chr_parameter(bands, - allow_na = FALSE, allow_empty = FALSE, len_min = 1 + allow_na = FALSE, allow_empty = FALSE, len_min = 1L ) # bands names are upper case bands <- toupper(bands) @@ -296,8 +296,8 @@ NULL bands <- unlist(bands, recursive = FALSE, use.names = FALSE) # post-conditions .check_chr(bands, - allow_na = FALSE, allow_empty = FALSE, - len_min = length(bands), len_max = length(bands) + allow_na = FALSE, allow_empty = FALSE, + len_min = length(bands), len_max = length(bands) ) bands } @@ -334,8 +334,8 @@ NULL .check_lst_parameter( resolution, fn_check = .check_num, - exclusive_min = 0, - len_min = 1 + exclusive_min = 0.0, + len_min = 1L ) resolution } @@ -397,7 +397,7 @@ NULL bands_converter <- c(bands_to_source, bands_source) # post-condition .check_chr_within(bands, - within = names(bands_converter) + within = names(bands_converter) ) unname(bands_converter[bands]) } @@ -564,7 +564,7 @@ NULL ) # post-condition .check_lst(vars) - if (length(vars) > 0) { + if (.has(vars)) { do.call(Sys.setenv, args = vars) } invisible(vars) @@ -619,7 +619,7 @@ NULL ) # post-condition .check_chr_parameter(collection_name, - allow_empty = FALSE, len_min = 1, len_max = 1 + allow_empty = FALSE, len_min = 1L, len_max = 1L ) collection_name } @@ -668,59 +668,9 @@ NULL .check_lgl_parameter(res) res } -#' @rdname .source_collection -#' @noRd -#' @description \code{.source_collection_token_check()} checks if a collection -#' needs environmental variables. -#' -#' @return \code{.source_collection_token_check()} returns \code{NULL} if -#' no error occurs. -#' -.source_collection_token_check <- function(source, collection) { - .check_set_caller(".source_collection_token_check") - token <- .try( - .conf( - "sources", source, - "collections", collection, - "token_vars" - ), - .default = "NO_TOKEN" - ) - # Pre-condition - try to find the access key as an environment variable - if (token != "NO_TOKEN") - .check_env_var(token) - return(invisible(TRUE)) -} -#' @rdname .source_collection -#' @noRd -#' @description \code{.source_collection_tile_check()} checks if a collection -#' requires tiles to be defined -#' -#' @return \code{.source_collection_tile_check()} returns \code{NULL} if -#' no error occurs. -#' -.source_collection_tile_check <- function(source, collection, tiles) { - .check_set_caller(".source_collection_tile_check") - res <- .try( - .conf( - "sources", source, - "collections", collection, - "tile_required" - ), - .default = "false" - ) - if (res) { - # Are the tiles provided? - .check_chr_parameter( - x = tiles, - allow_empty = FALSE, - len_min = 1 - ) - } - return(invisible(NULL)) -} + #' @rdname .source_collection_class_labels #' @noRd #' @description \code{.source_collection_class_labels()} fixes the @@ -781,14 +731,14 @@ NULL ) # class cube from source collection doesn't have multiple dates if (is_class_cube) { - tile_date <- tile[["file_info"]][[1]][["date"]] + tile_date <- tile[["file_info"]][[1L]][["date"]] # create start and end dates - tile[["file_info"]][[1]][["start_date"]] <- tile_date - tile[["file_info"]][[1]][["end_date"]] <- tile_date + tile[["file_info"]][[1L]][["start_date"]] <- tile_date + tile[["file_info"]][[1L]][["end_date"]] <- tile_date # delete date - tile[["file_info"]][[1]][["date"]] <- NULL + tile[["file_info"]][[1L]][["date"]] <- NULL } # return! tile diff --git a/R/api_source_aws.R b/R/api_source_aws.R index 199d508e3..fd27a067b 100644 --- a/R/api_source_aws.R +++ b/R/api_source_aws.R @@ -49,10 +49,10 @@ # if more than 2 times items pagination are found the progress bar # is displayed - progress <- rstac::items_matched(items_info) > 2 * + progress <- rstac::items_matched(items_info) > 2L * .conf("rstac_pagination_limit") # check documentation mode - progress <- .check_documentation(progress) + progress <- .message_progress(progress) # fetching all the metadata items_info <- rstac::items_fetch( items = items_info, @@ -132,7 +132,7 @@ collapse = "" ) feature - }) + }) rstac::items_reap(items, field = c("properties", "tile")) } @@ -167,7 +167,7 @@ .source_adjust_date.aws_cube <- function(source, date) { if (.has(date)) date <- paste0(date, "T00:00:00Z") - return(date) + date } #' @noRd #' @title Configure access. @@ -177,10 +177,9 @@ .source_configure_access.aws_cube <- function(source, collection) { .check_set_caller(".source_configure_access_aws_cube") if (.conf("sources", "AWS", "collections", collection, "open_data") - == "false") { + == "false") { aws_access_key <- Sys.getenv("AWS_SECRET_ACCESS_KEY") - if (nchar(aws_access_key) == 0) + if (.has_not(aws_access_key)) stop(.conf("messages", ".source_configure_access_aws_cube")) } - return(invisible(source)) } diff --git a/R/api_source_bdc.R b/R/api_source_bdc.R index 20662f3b4..698dcbf87 100644 --- a/R/api_source_bdc.R +++ b/R/api_source_bdc.R @@ -17,7 +17,7 @@ "?access_token=", access_key ) # add gdal vsi in href urls - return(.stac_add_gdal_fs(href)) + .stac_add_gdal_fs(href) } #' @title Create an items object in a BDC cube #' @keywords internal @@ -49,16 +49,14 @@ # if more than 2 times items pagination are found the progress bar # is displayed progress <- rstac::items_matched(items_info) > - 2 * .conf("rstac_pagination_limit") + 2L * .conf("rstac_pagination_limit") # check documentation mode - progress <- .check_documentation(progress) + progress <- .message_progress(progress) # fetching all the metadata - items_info <- rstac::items_fetch( + rstac::items_fetch( items = items_info, progress = progress, ... ) - - return(items_info) } #' @title Organizes items by tiles for BDC collections #' @param source Name of the STAC provider. @@ -81,7 +79,7 @@ #' @return Called for side effects .source_configure_access.bdc_cube <- function(source, collection = NULL) { bdc_access_key <- Sys.getenv("BDC_ACCESS_KEY") - if (nchar(bdc_access_key) == 0) + if (.has_not(bdc_access_key)) Sys.setenv(BDC_ACCESS_KEY = .conf("BDC_ACCESS_KEY")) return(invisible(source)) } diff --git a/R/api_source_cdse.R b/R/api_source_cdse.R index 5a5f099a0..0db3f1359 100644 --- a/R/api_source_cdse.R +++ b/R/api_source_cdse.R @@ -71,7 +71,7 @@ dplyr::filter(item_s3_content, stringr::str_detect(.data[["Key"]], band_pattern)) # Check if the correct file was selected. - .check_that(nrow(band_item) == 1) + .check_that(nrow(band_item) == 1L) # Prepare the file address band_path_s3 <- paste0(s3_protocol, s3_bucket, band_item[["Key"]]) # Prepare result and return it @@ -138,7 +138,7 @@ end_date = end_date, bbox = NULL, paginate = FALSE, - limit = 1, + limit = 1L, ... ) }, .default = NULL) @@ -148,22 +148,21 @@ items <- .source_items_bands_select( source = source, items = items, - bands = bands[[1]], + bands = bands[[1L]], collection = collection, ... ) href <- .source_item_get_hrefs( source = source, - item = items$feature[[1]], + item = items$feature[[1L]], collection = collection, ... ) # assert that token and/or href is valid if (dry_run) { - rast <- .try({.raster_open_rast(href)}, + rast <- .try(.raster_open_rast(href), default = NULL ) .check_null_parameter(rast) } - return(invisible(source)) } #' @title Transform an items object in a CDSE cube @@ -191,7 +190,7 @@ # set caller to show in errors .check_set_caller(".source_items_new_cdse_cube") # check multicores - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) # check platform (filter available for CDSE collections supported by sits) if (!is.null(platform)) { platform <- .stac_format_platform( @@ -201,7 +200,7 @@ ) } # define the maximum number of records per request - cdse_query_limit <- 1000 + cdse_query_limit <- 1000L # as CDSE STAC returns many types of items in the same collection, # it is required to filter the content by a specific type. item_type <- .cdse_item_type(source, collection) @@ -244,7 +243,7 @@ ... ) # Validate results - .check_length(items[["features"]], len_min = 1) + .check_length(items[["features"]], len_min = 1L) # Done! items } @@ -322,7 +321,7 @@ collection, cube, tiles) { - return(cube) + cube } #' @keywords internal @@ -330,19 +329,18 @@ #' @export `.source_tile_get_bbox.cdse_cube_sentinel-1-rtc` <- function(source, file_info, ..., collection = NULL) { - .check_set_caller(".source_tile_get_bbox_cdse_s1_rtc") - # pre-condition - .check_num(nrow(file_info), min = 1) + .check_set_caller(".source_tile_get_bbox_cdse_s1_rtc") + # pre-condition + .check_content_data_frame(file_info) - # get bbox based on file_info - xmin <- min(file_info[["xmin"]]) - ymin <- min(file_info[["ymin"]]) - xmax <- max(file_info[["xmax"]]) - ymax <- max(file_info[["ymax"]]) + # get bbox based on file_info + xmin <- min(file_info[["xmin"]]) + ymin <- min(file_info[["ymin"]]) + xmax <- max(file_info[["xmax"]]) + ymax <- max(file_info[["ymax"]]) - # post-condition - .check_that(xmin < xmax && ymin < ymax) - # create a bbox - bbox <- c(xmin = xmin, ymin = ymin, xmax = xmax, ymax = ymax) - return(bbox) + # post-condition + .check_that(xmin < xmax && ymin < ymax) + # create a bbox + c(xmin = xmin, ymin = ymin, xmax = xmax, ymax = ymax) } diff --git a/R/api_source_deafrica.R b/R/api_source_deafrica.R index 43aeddab5..decb30a05 100644 --- a/R/api_source_deafrica.R +++ b/R/api_source_deafrica.R @@ -29,9 +29,9 @@ # if more than 2 times items pagination are found the progress bar # is displayed progress <- rstac::items_matched(items_info) > - 2 * .conf("rstac_pagination_limit") + 2L * .conf("rstac_pagination_limit") # check documentation mode - progress <- .check_documentation(progress) + progress <- .message_progress(progress) # fetching all the metadata and updating to upper case instruments items_info <- rstac::items_fetch(items = items_info, progress = progress) @@ -54,10 +54,10 @@ #' @return An object referring the images of a sits cube. #' @export `.source_items_new.deafrica_cube_sentinel-2-l2a` <- function(source, ..., - collection, - stac_query, - tiles = NULL, - platform = NULL) { + collection, + stac_query, + tiles = NULL, + platform = NULL) { # set caller to show in errors .check_set_caller(".source_items_new") # check platform @@ -87,14 +87,14 @@ # filter items items_info <- rstac::items_filter(items_info, filter_fn = function(feature) { - lgl_res <- TRUE + lgl_res <- TRUE - if (!is.null(platform)) { - lgl_res <- feature[["properties"]][["platform"]] == platform - } + if (!is.null(platform)) { + lgl_res <- feature[["properties"]][["platform"]] == platform + } - lgl_res - }) + lgl_res + }) # check results .check_stac_items(items_info) # done @@ -104,12 +104,12 @@ #' @noRd #' @export `.source_items_new.deafrica_cube_sentinel-1-rtc` <- function( - source, ..., - collection, - stac_query, - tiles = NULL, - platform = NULL, - orbit = NULL) { + source, ..., + collection, + stac_query, + tiles = NULL, + platform = NULL, + orbit = NULL) { # set caller to show in errors .check_set_caller(".source_items_new") # check orbits @@ -142,17 +142,17 @@ # filter items items_info <- rstac::items_filter(items_info, filter_fn = function(feature) { - lgl_res <- feature[["properties"]][["sat:orbit_state"]] == orbit && - feature[["properties"]][["sar:instrument_mode"]] == "IW" && - feature[["properties"]][["sar:frequency_band"]] == "C" + lgl_res <- feature[["properties"]][["sat:orbit_state"]] == orbit && + feature[["properties"]][["sar:instrument_mode"]] == "IW" && + feature[["properties"]][["sar:frequency_band"]] == "C" - if (!is.null(platform)) { - lgl_res <- lgl_res && - feature[["properties"]][["platform"]] == platform - } + if (!is.null(platform)) { + lgl_res <- lgl_res && + feature[["properties"]][["platform"]] == platform + } - lgl_res - }) + lgl_res + }) # check results .check_stac_items(items_info) # done @@ -165,7 +165,7 @@ collection, cube, tiles) { - return(cube) + cube } #' @keywords internal #' @noRd @@ -200,11 +200,11 @@ `.source_items_tile.deafrica_cube_rainfall-chirps-daily` <- function(source, items, ..., collection = NULL) { rep("NoTilingSystem", rstac::items_length(items)) -} + } #' @keywords internal #' @noRd #' @export `.source_items_tile.deafrica_cube_rainfall-chirps-monthly` <- function(source, items, ..., collection = NULL) { - rep("NoTilingSystem", rstac::items_length(items)) -} + rep("NoTilingSystem", rstac::items_length(items)) + } diff --git a/R/api_source_deaustralia.R b/R/api_source_deaustralia.R index fa3e3d65c..3ff491aaa 100644 --- a/R/api_source_deaustralia.R +++ b/R/api_source_deaustralia.R @@ -14,10 +14,10 @@ #' @return An object referring the images of a sits cube. #' @export .source_items_new.deaustralia_cube <- function(source, ..., - collection, - stac_query, - tiles = NULL, - platform = NULL) { + collection, + stac_query, + tiles = NULL, + platform = NULL) { .check_that(is.null(tiles)) # Convert roi to bbox roi <- .stac_intersects_as_bbox(stac_query) @@ -29,9 +29,9 @@ # if more than 2 times items pagination are found the progress bar # is displayed progress <- rstac::items_matched(items_info) > - 2 * .conf("rstac_pagination_limit") + 2L * .conf("rstac_pagination_limit") # check documentation mode - progress <- .check_documentation(progress) + progress <- .message_progress(progress) # fetching all the metadata and updating to upper case instruments items_info <- rstac::items_fetch(items = items_info, progress = progress) @@ -83,9 +83,9 @@ #' @noRd #' @export `.source_items_new.deaustralia_cube_ga_s2am_ard_3` <- function(source, ..., - collection, - stac_query, - tiles = NULL) { + collection, + stac_query, + tiles = NULL) { # set caller to show in errors .check_set_caller(".source_items_new") # process sentinel-2 data @@ -102,9 +102,9 @@ #' @noRd #' @export `.source_items_new.deaustralia_cube_ga_s2bm_ard_3` <- function(source, ..., - collection, - stac_query, - tiles = NULL) { + collection, + stac_query, + tiles = NULL) { # set caller to show in errors .check_set_caller(".source_items_new") # process sentinel-2 data @@ -121,7 +121,7 @@ #' @noRd #' @export .source_items_tile.deaustralia_cube <- function(source, ..., - items, - collection = NULL) { + items, + collection = NULL) { rstac::items_reap(items, field = c("properties", "odc:region_code")) } diff --git a/R/api_source_hls.R b/R/api_source_hls.R index e8ddb0937..58c06db9b 100644 --- a/R/api_source_hls.R +++ b/R/api_source_hls.R @@ -15,10 +15,10 @@ #' @return Called for side effects #' @export .source_collection_access_test.hls_cube <- function(source, collection, - bands, ..., - start_date = NULL, - end_date = NULL, - dry_run = FALSE) { + bands, ..., + start_date = NULL, + end_date = NULL, + dry_run = FALSE) { # require package .check_require_packages("rstac") # create a query @@ -27,7 +27,7 @@ collection = collection, start_date = start_date, end_date = end_date, - limit = 1 + limit = 1L ) # format query dates items_query[["params"]][["datetime"]] <- .stac_dates_as_datetimes( @@ -44,12 +44,12 @@ items <- .source_items_bands_select( source = source, items = items, - bands = bands[[1]], + bands = bands[[1L]], collection = collection, ... ) href <- .source_item_get_hrefs( source = source, - item = items[["features"]][[1]], + item = items[["features"]][[1L]], collection = collection, ... ) # assert that token and/or href is valid @@ -98,8 +98,8 @@ ) } else { # Convert roi to bbox - lon <- stac_query[["params"]][["intersects"]][["coordinates"]][, , 1] - lat <- stac_query[["params"]][["intersects"]][["coordinates"]][, , 2] + lon <- stac_query[["params"]][["intersects"]][["coordinates"]][, , 1L] + lat <- stac_query[["params"]][["intersects"]][["coordinates"]][, , 2L] stac_query[["params"]][["intersects"]] <- NULL stac_query[["params"]][["bbox"]] <- c(min(lon), min(lat), @@ -112,10 +112,10 @@ .check_stac_items(items_info) # if more than 2 times items pagination are found the progress bar # is displayed - progress <- rstac::items_matched(items_info) > 2 * + progress <- rstac::items_matched(items_info) > 2L * .conf("rstac_pagination_limit") # check documentation mode - progress <- .check_documentation(progress) + progress <- .message_progress(progress) # fetching all the metadata and updating to upper case instruments items_info <- rstac::items_fetch(items = items_info, progress = progress) # checks if the items returned any items @@ -135,8 +135,8 @@ items, collection = NULL) { tiles <- strsplit(rstac::items_reap(items, field = "id"), "\\.") - tiles <- purrr::map_chr(tiles, function(x) x[[3]]) - substr(tiles, 2, 6) + tiles <- purrr::map_chr(tiles, function(x) x[[3L]]) + substr(tiles, 2L, 6L) } #' @noRd #' @title Configure access. diff --git a/R/api_source_local.R b/R/api_source_local.R index 4d970399e..fc9cbef0d 100644 --- a/R/api_source_local.R +++ b/R/api_source_local.R @@ -80,8 +80,7 @@ # handle class cubes from external sources cube <- .local_cube_handle_class_cube(source, collection, cube) class(cube) <- .cube_s3class(cube) - - return(cube) + cube } #' @title Create results data cubes using local files #' @name .local_results_cube @@ -105,16 +104,16 @@ #' @param ... Other parameters to be passed for specific types. #' @return A \code{tibble} describing the contents of a local data cube. .local_results_cube <- function(source, - collection, - data_dir, - parse_info, - version, - delim, - tiles, - bands, - labels, - multicores, - progress, ...) { + collection, + data_dir, + parse_info, + version, + delim, + tiles, + bands, + labels, + multicores, + progress, ...) { # set caller to show in errors .check_set_caller(".local_results_cube") # is this a cube with results? @@ -157,13 +156,12 @@ # filter tile items_tile <- dplyr::filter(raster_items, .data[["tile"]] == !!tile) # create result cube - tile_cube <- .local_results_items_cube( + .local_results_items_cube( source = source, collection = collection, raster_items = items_tile, labels = labels ) - return(tile_cube) }) # handle class cubes from external sources @@ -177,7 +175,7 @@ if (inherits(cube, "class_cube")) .check_labels_class_cube(cube) - return(cube) + cube } #' @title Create vector items using local files #' @name .local_vector_items @@ -201,20 +199,18 @@ #' @param ... Other parameters to be passed for specific types. #' @return A \code{tibble} describing the contents of a local data cube. .local_vector_items <- function(source, - collection, - vector_dir, - vector_band, - parse_info, - version, - delim, - start_date, - end_date, - multicores, - progress, ...) { + collection, + vector_dir, + vector_band, + parse_info, + version, + delim, + start_date, + end_date, + multicores, + progress, ...) { # set caller to show in errors .check_set_caller(".local_vector_items") - # initialize vector items - vector_items <- NULL # bands in upper case for raw cubes, lower case for results cubes vector_band <- .band_set_case(vector_band) @@ -222,7 +218,7 @@ if (!.has(parse_info)) parse_info <- .conf("results_parse_info_def") - vector_items <- .local_cube_items_vector_new( + .local_cube_items_vector_new( vector_dir = vector_dir, parse_info = parse_info, version = version, @@ -231,7 +227,6 @@ end_date = end_date, vector_band = vector_band ) - return(vector_items) } #' @title Return raster items for local data cube @@ -258,7 +253,7 @@ # is this a cube with results? if (.has(bands) && - bands[[1]] %in% .conf("sits_results_bands")) { + bands[[1L]] %in% .conf("sits_results_bands")) { results_cube <- TRUE } else { results_cube <- FALSE @@ -269,10 +264,10 @@ # list the files in the data directory img_files <- list.files( path = data_dir, - pattern = paste0("\\.(", paste0(file_ext, collapse = "|"), ")$") + pattern = paste0("\\.(", paste(file_ext, collapse = "|"), ")$") ) # postcondition - .check_chr_parameter(img_files, allow_empty = FALSE, len_min = 1) + .has(img_files) # remove the extension img_files_noext <- tools::file_path_sans_ext(img_files) @@ -280,16 +275,13 @@ img_files_lst <- strsplit(img_files_noext, split = delim, fixed = TRUE) # which image files in directory match the parse info? are_img_files_ok <- purrr::map_lgl(img_files_lst, function(img_file) { - if (length(img_file) == length(parse_info)) - return(TRUE) - else - return(FALSE) + length(img_file) == length(parse_info) }) # select the images that match the file info img_files_ok <- img_files_lst[are_img_files_ok] # post condition - .check_that(length(img_files_ok) > 0) + .has(img_files_ok) # get valid files img_files_filt <- img_files[are_img_files_ok] @@ -300,7 +292,7 @@ # joint the list into a tibble and convert bands name to upper case items <- suppressMessages( tibble::as_tibble(img_files_mx, - .name_repair = "universal" + .name_repair = "universal" ) ) if (.has(bands)) { @@ -322,14 +314,13 @@ msg = .conf("messages", ".local_cube_items_version") ) # get only the first band - band <- bands[[1]] + band <- bands[[1L]] # get the information on the required band, dates and path items <- items |> # bands are case insensitive (converted to lower case) dplyr::mutate(band = tolower(.data[["band"]])) |> # add path - dplyr::mutate(path = paste(data_dir, - img_files_filt, sep = "/")) |> + dplyr::mutate(path = file.path(data_dir, img_files_filt)) |> # filter by the band dplyr::filter(.data[["band"]] == !!band) |> # filter by the version @@ -366,7 +357,7 @@ dplyr::mutate(band = toupper(.data[["band"]])) |> # add path dplyr::mutate( - path = paste(!!data_dir, !!img_files_filt, sep = "/") + path = file.path(!!data_dir, !!img_files_filt) ) |> # select the relevant parts dplyr::select( @@ -396,8 +387,8 @@ } } # post-condition - .check_that(nrow(items) > 0) - return(items) + .has(items) + items } #' @title Return raster items for local data cube #' @keywords internal @@ -426,10 +417,10 @@ # list the vector files in the data directory gpkg_files <- list.files( path = vector_dir, - pattern = paste0("\\.(", paste0(file_ext, collapse = "|"), ")$") + pattern = paste0("\\.(", paste(file_ext, collapse = "|"), ")$") ) # post-condition - gpkg_files_path <- paste0(vector_dir, "/", gpkg_files) + gpkg_files_path <- file.path(vector_dir, gpkg_files) .check_that(all(file.exists(gpkg_files_path))) # remove the extension @@ -438,10 +429,7 @@ gpkg_files_lst <- strsplit(gpkg_files_noext, split = delim, fixed = TRUE) # check gkpg files are_gpkg_files_ok <- purrr::map_lgl(gpkg_files_lst, function(gpkg_file) { - if (length(gpkg_file) == length(parse_info)) { - return(TRUE) - } - return(FALSE) + length(gpkg_file) == length(parse_info) }) # subset gkpg files gpkg_files_ok <- gpkg_files_lst[are_gpkg_files_ok] @@ -477,8 +465,7 @@ # bands are case insensitive (converted to lower case) dplyr::mutate(band = tolower(.data[["band"]])) |> # add path - dplyr::mutate(path = paste(vector_dir, - gpkg_files_filt, sep = "/")) |> + dplyr::mutate(path = file.path(vector_dir, gpkg_files_filt)) |> # filter by the band dplyr::filter(.data[["band"]] == !!vector_band) |> # filter by the version @@ -511,8 +498,8 @@ dplyr::arrange(.data[["start_date"]]) # post-condition - .check_that(nrow(items) > 0) - return(items) + .has(items) + items } #' @title Select items by bands #' @keywords internal @@ -545,12 +532,12 @@ if (.has(bands)) { # verify that the requested bands exist .check_chr_within(bands, - within = unique(items[["band"]]) + within = unique(items[["band"]]) ) # select the requested bands items <- dplyr::filter(items, .data[["band"]] %in% !!bands) } - return(items) + items } #' @title Select items by tiles #' @keywords internal @@ -566,11 +553,10 @@ # filter tiles # verify that the requested tiles exist .check_chr_within(tiles, - within = unique(items[["tile"]]) + within = unique(items[["tile"]]) ) # select the requested tiles - items <- dplyr::filter(items, .data[["tile"]] %in% !!tiles) - return(items) + dplyr::filter(items, .data[["tile"]] %in% !!tiles) } #' @title Build local cube file_info @@ -585,8 +571,8 @@ progress) { # set caller to show in errors .check_set_caller(".local_cube_file_info") - # post-condition - .check_that(nrow(items) > 0) + # pre-condition + .has(items) # add feature id (fid) items <- dplyr::group_by(items, .data[["tile"]], .data[["date"]]) |> dplyr::mutate(fid = paste0(dplyr::cur_group_id())) |> @@ -620,27 +606,26 @@ bad_assets <- purrr::map_lgl(assets_info, purrr::is_character) item <- item[!bad_assets, ] - # bind items and assets info - result <- list( + # bind items and assets info and return result + list( item = dplyr::bind_cols( item, dplyr::bind_rows(assets_info[!bad_assets]) ), error = unlist(assets_info[bad_assets]) ) - return(result) }, progress = progress) items <- purrr::map(results_lst, `[[`, "item") errors <- unlist(purrr::map(results_lst, `[[`, "error")) - if (length(errors) > 0) { + if (.has(errors)) { warning(.conf("messages", ".local_cube_file_info_error"), toString(errors), call. = FALSE, immediate. = TRUE ) } - items <- dplyr::bind_rows(items) |> + # bind rows into a tibble and then organizw by date, fid, and band + dplyr::bind_rows(items) |> dplyr::arrange(.data[["date"]], .data[["fid"]], .data[["band"]]) - return(items) } #' @title Build local cube file_info for results cubes @@ -654,8 +639,8 @@ # set caller to show in errors .check_set_caller(".local_results_cube_file_info") - # post-condition - .check_that(nrow(items) > 0) + # pre-condition + .has(items) # prepare parallel requests if (is.null(sits_env[["cluster"]])) { @@ -695,19 +680,19 @@ error = unlist(assets_info[bad_assets]) ) - return(results) + results }, progress = progress) items_lst <- purrr::map(results_lst, `[[`, "item") errors <- unlist(purrr::map(results_lst, `[[`, "error")) - if (length(errors) > 0) { + if (.has(errors)) { warning(.conf("messages", ".local_cube_file_info_error"), toString(errors), call. = FALSE, immediate. = TRUE ) } - items <- dplyr::bind_rows(items_lst) - return(items) + # return items as a data frame + dplyr::bind_rows(items_lst) } #' @title Build data cube tibble @@ -750,7 +735,7 @@ ) # create a tibble to store the metadata - cube_tile <- .cube_create( + .cube_create( source = source, collection = collection, satellite = .source_collection_satellite(source, collection), @@ -763,7 +748,6 @@ crs = crs, file_info = file_info ) - return(cube_tile) } #' @title Build data cube tibble for results cube @@ -807,7 +791,7 @@ )) ) # create a tibble to store the metadata - cube_tile <- .cube_create( + .cube_create( source = source, collection = collection, satellite = .source_collection_satellite(source, collection), @@ -821,7 +805,6 @@ labels = labels, file_info = file_info ) - return(cube_tile) } #' @title Handle details related to class cubes from external sources. @@ -850,7 +833,7 @@ } .local_cube_include_vector_info <- function(cube, vector_items) { - cube <- slider::slide_dfr(cube, function(tile) { + slider::slide_dfr(cube, function(tile) { item <- dplyr::filter(vector_items, .data[["tile"]] == !!tile[["tile"]]) vector_info <- tibble::tibble( band = item[["band"]], @@ -866,11 +849,6 @@ ) tile[["labels"]] <- list(.label_gpkg_file(item[["path"]])) tile[["vector_info"]] <- list(vector_info) - return(tile) + tile }) - - return(cube) } - - - diff --git a/R/api_source_mpc.R b/R/api_source_mpc.R index 421318e95..2d1b0755d 100644 --- a/R/api_source_mpc.R +++ b/R/api_source_mpc.R @@ -28,13 +28,13 @@ collection = collection, start_date = start_date, end_date = end_date, - limit = 1 + limit = 1L ) # assert that service is online items <- .try({ rstac::post_request(items_query, ...) - }, - .default = NULL + }, + .default = NULL ) .check_stac_items(items) # signing the url with the mpc token @@ -53,20 +53,20 @@ items <- .source_items_bands_select( source = source, items = items, - bands = bands[[1]], + bands = bands[[1L]], collection = collection, ... ) href <- .source_item_get_hrefs( source = source, - item = items[["features"]][[1]], + item = items[["features"]][[1L]], collection = collection, ... ) # assert that token and/or href is valid if (dry_run) { rast <- .try({ .raster_open_rast(href) - }, - default = NULL + }, + default = NULL ) .check_null_parameter(rast) } @@ -107,7 +107,7 @@ collection = collection, start_date = start_date, end_date = end_date, - limit = 1 + limit = 1L ) stac_query <- rstac::ext_filter( stac_query, @@ -140,20 +140,20 @@ items <- .source_items_bands_select( source = source, items = items, - bands = bands[[1]], + bands = bands[[1L]], collection = collection, ... ) href <- .source_item_get_hrefs( source = source, - item = items[["features"]][[1]], + item = items[["features"]][[1L]], collection = collection, ... ) # assert that token and/or href is valid if (dry_run) { rast <- .try({ .raster_open_rast(href) - }, - default = NULL + }, + default = NULL ) .check_null_parameter(rast) } @@ -194,7 +194,7 @@ .check_set_caller(".source_tile_get_bbox_mpc_s1_grd") # pre-condition - .check_num(nrow(file_info), min = 1) + .check_num(nrow(file_info), min = 1L) # get bbox based on file_info xmin <- min(file_info[["xmin"]]) @@ -241,7 +241,7 @@ .check_set_caller(".source_tile_get_bbox_mpc_dem_30") # pre-condition - .check_num(nrow(file_info), min = 1) + .check_num(nrow(file_info), min = 1L) # get bbox based on file_info xmin <- min(file_info[["xmin"]]) @@ -361,7 +361,7 @@ }) # getting the first item info - items_info <- items_list[[1]] + items_info <- items_list[[1L]] # joining the items items_info[["features"]] <- do.call( c, @@ -596,8 +596,8 @@ #' @noRd #' @export `.source_items_tile.mpc_cube_mod13q1-6.1` <- function(source, - items, ..., - collection = NULL) { + items, ..., + collection = NULL) { # store tile info in items object items[["features"]] <- purrr::map(items[["features"]], function(feature) { h_tile <- feature[["properties"]][["modis:horizontal-tile"]] @@ -605,10 +605,9 @@ h_tile <- paste0("h", h_tile) v_tile <- paste0("v", v_tile) feature[["properties"]][["tile"]] <- paste0(h_tile, v_tile) - - return(feature) + feature }) - tile_name <- rstac::items_reap(items, field = c("properties", "tile")) + rstac::items_reap(items, field = c("properties", "tile")) } #' @title Organizes items for MPC MOD10A1 collections #' @param source Name of the STAC provider. @@ -630,10 +629,9 @@ h_tile <- paste0("h", h_tile) v_tile <- paste0("v", v_tile) feature[["properties"]][["tile"]] <- paste0(h_tile, v_tile) - - return(feature) + feature }) - tile_name <- rstac::items_reap(items, field = c("properties", "tile")) + rstac::items_reap(items, field = c("properties", "tile")) } #' @title Organizes items for MPC MOD09A1 collections #' @param source Name of the STAC provider. @@ -655,10 +653,10 @@ h_tile <- paste0("h", h_tile) v_tile <- paste0("v", v_tile) feature[["properties"]][["tile"]] <- paste0(h_tile, v_tile) - - return(feature) + feature }) - tile_name <- rstac::items_reap(items, field = c("properties", "tile")) + # return tile name + rstac::items_reap(items, field = c("properties", "tile")) } #' @title Organizes items for MPC Landsat collections #' @param source Name of the STAC provider. @@ -692,13 +690,13 @@ #' @noRd #' @export `.source_items_tile.mpc_cube_cop-dem-glo-30` <- function(source, - items, ..., - collection = NULL) { + items, ..., + collection = NULL) { feature_ids <- stringr::str_split(rstac::items_reap(items, "id"), "_") purrr::map(feature_ids, function(feature_id) { - paste(feature_id[5:length(feature_id) - 1], collapse = "-") + paste(feature_id[5L:length(feature_id) - 1L], collapse = "-") }) } #' @title Filter S1 GRD tiles @@ -712,7 +710,7 @@ collection, cube, tiles) { - return(cube) + cube } `.source_filter_tiles.mpc_cube_sentinel-1-rtc` <- function(source, collection, @@ -736,7 +734,7 @@ collection, cube, tiles) { - return(cube) + cube } #' @title Get date from STAC item for MOD13Q1 collection #' @keywords internal @@ -748,12 +746,9 @@ #' @return List of dates #' @export `.source_item_get_date.mpc_cube_mod13q1-6.1` <- function(source, - item, ..., - collection = NULL) { - - - datetime <- item[["properties"]][["start_datetime"]] - date <- lubridate::as_date(datetime) + item, ..., + collection = NULL) { + lubridate::as_date(item[["properties"]][["start_datetime"]]) } #' @title Get date from STAC item for MOD10A1 #' @keywords internal @@ -767,10 +762,7 @@ `.source_item_get_date.mpc_cube_mod10a1-6.1` <- function(source, item, ..., collection = NULL) { - - - datetime <- item[["properties"]][["start_datetime"]] - date <- lubridate::as_date(datetime) + lubridate::as_date(item[["properties"]][["start_datetime"]]) } #' @title Get date from STAC item for MOD09A1 #' @keywords internal @@ -786,8 +778,7 @@ collection = NULL) { - datetime <- item[["properties"]][["start_datetime"]] - date <- lubridate::as_date(datetime) + lubridate::as_date(item[["properties"]][["start_datetime"]]) } #' @title Check if roi or tiles are provided #' @param source Data source @@ -801,7 +792,6 @@ # set caller to show in errors .check_set_caller(".source_roi_tiles_mpc_cube_landsat_c2_l2") .check_that(.has_not(tiles)) - return(invisible(source)) } #' @title Clear MPC token cache #' @name .mpc_clean_token_cache @@ -815,13 +805,11 @@ purrr::map(cached_tokens, function(cached_token) { assign(cached_token, NULL, envir = mpc_token) }) - return(invisible(NULL)) } #' @title Get MPC token info #' @name .mpc_get_token_info -#' @description Get token information about account and container in asset -#' path +#' @description Get token information about account and container in asset path #' @param path A character file path. #' @return a list with account and container. #' @keywords internal @@ -833,11 +821,10 @@ ) path_spplited <- strsplit(parsed_url$path, split = "/", fixed = TRUE) # Based on planetary computer python library and rstac - token_info <- list( - acc = host_spplited[[1]][[1]], - cnt = path_spplited[[1]][[2]] + list( + acc = host_spplited[[1L]][[1L]], + cnt = path_spplited[[1L]][[2L]] ) - return(token_info) } #' @title Is there a valid token? @@ -869,9 +856,9 @@ acc <- token_info[["acc"]] cnt <- token_info[["cnt"]] # Generate new token - token_url <- paste(url, acc, cnt, sep = "/") + token_url <- file.path(url, acc, cnt) new_token <- NULL - while (is.null(new_token) && n_tries > 0) { + while (is.null(new_token) && n_tries > 0L) { new_token <- tryCatch( { res <- .get_request( @@ -882,21 +869,21 @@ .response_content(res) }, error = function(e) { - return(NULL) + NULL } ) if (is.null(new_token)) { Sys.sleep(sleep_time) } - n_tries <- n_tries - 1 + n_tries <- n_tries - 1L } # check that token is valid .check_that(.has(new_token)) new_token <- list(structure(list(new_token), names = cnt)) names(new_token) <- acc - return(new_token) + new_token } #' @title Sign the asset path with new token @@ -920,7 +907,7 @@ ) # remove the additional chars added by httr new_path <- gsub("^://", "", .url_build(url_parsed)) - new_path <- paste0("/vsicurl/", new_path) + new_path <- file.path("/vsicurl/", new_path) new_path } diff --git a/R/api_source_sdc.R b/R/api_source_sdc.R index f8019fdf5..7fcacf28d 100644 --- a/R/api_source_sdc.R +++ b/R/api_source_sdc.R @@ -20,10 +20,10 @@ .check_stac_items(items_info) # if more than 2 times items pagination are found the progress bar # is displayed - progress <- rstac::items_matched(items_info) > 2 * + progress <- rstac::items_matched(items_info) > 2L * .conf("rstac_pagination_limit") # check documentation mode - progress <- .check_documentation(progress) + progress <- .message_progress(progress) # fetching all the metadata and updating to upper case instruments items_info <- rstac::items_fetch(items = items_info, progress = progress) # checks if the items returned any items @@ -66,7 +66,7 @@ replacement = "-", fixed = TRUE, x = rstac::items_reap(items, - field = c("properties", "cubedash:region_code") + field = c("properties", "cubedash:region_code") ) ) } @@ -81,5 +81,5 @@ .source_roi_tiles.sdc_cube <- function(source, roi, tiles) { .check_set_caller(".source_roi_tiles_sdc_cube") .check_that(.has_not(tiles)) - return(invisible(source)) + invisible(source) } diff --git a/R/api_source_stac.R b/R/api_source_stac.R index 6d9a28100..0caade594 100644 --- a/R/api_source_stac.R +++ b/R/api_source_stac.R @@ -27,33 +27,33 @@ collection = collection, start_date = start_date, end_date = end_date, - limit = 1 + limit = 1L ) # assert that service is online items <- .try({ - rstac::post_request(items_query, ...) - }, - .default = NULL + rstac::post_request(items_query, ...) + }, + .default = NULL ) .check_stac_items(items) items <- .source_items_bands_select( source = source, items = items, - bands = bands[[1]], + bands = bands[[1L]], collection = collection, ... ) href <- .source_item_get_hrefs( source = source, - item = items[["features"]][[1]], + item = items[["features"]][[1L]], collection = collection, ... ) # assert that token and/or href is valid if (dry_run) { rast <- .try({ - .raster_open_rast(href) - }, - default = NULL + .raster_open_rast(href) + }, + default = NULL ) .check_null_parameter(rast) } @@ -138,7 +138,7 @@ ) class(cube) <- .cube_s3class(cube) - return(cube) + cube } #' @title Select bands from a STAC item #' @keywords internal @@ -155,7 +155,7 @@ items, bands, collection, ...) { - items <- .stac_select_bands( + .stac_select_bands( items = items, bands_source = .source_bands_to_source( source = source, @@ -168,7 +168,6 @@ bands = bands ) ) - return(items) } #' @title Create a new data cube based on STAC item #' @keywords internal @@ -187,7 +186,8 @@ multicores, progress) { .check_set_caller(".source_items_cube_stac_cube") - + # show progress? + progress <- .message_progress(progress) # start by tile and items data <- tibble::tibble( tile = .source_items_tile( @@ -234,9 +234,9 @@ # get features features <- data[["items"]][[i]][["features"]] # post-condition - .check_that(length(features) >= 1) + .check_that(length(features) >= 1L) # get item - item <- features[[1]] + item <- features[[1L]] # get file paths paths <- .source_item_get_hrefs( source = source, @@ -244,19 +244,18 @@ collection = collection, ... ) # post-condition - .check_that(length(paths) >= 1) + .check_that(length(paths) >= 1L) # open band rasters and retrieve asset info asset_info <- tryCatch( { purrr::map(paths, function(path) { asset <- .raster_open_rast(path) - info <- tibble::as_tibble_row(c( + tibble::as_tibble_row(c( .raster_res(asset), .raster_bbox(asset), .raster_size(asset), list(crs = .raster_crs(asset)) )) - return(info) }) }, error = function(e) { @@ -297,14 +296,14 @@ item = item, collection = collection, ... ) - cloud_cover <- .default(cloud_cover, 0) + cloud_cover <- .default(cloud_cover, 0L) # post-conditions .check_date_parameter(date) - .check_chr_parameter(bands, len_min = 1) + .check_chr_parameter(bands, len_min = 1L) .check_chr_parameter(paths, - allow_empty = FALSE, - len_min = length(bands), - len_max = length(bands) + allow_empty = FALSE, + len_min = length(bands), + len_max = length(bands) ) # do in case of 'feature' strategy if (.source_collection_metadata_search( @@ -316,13 +315,12 @@ { purrr::map(paths, function(path) { asset <- .raster_open_rast(path) - info <- tibble::as_tibble_row(c( + tibble::as_tibble_row(c( .raster_res(asset), .raster_bbox(asset), .raster_size(asset), list(crs = .raster_crs(asset)) )) - return(info) }) }, error = function(e) { @@ -352,18 +350,15 @@ ), cols = c("band", "asset_info", "path", "cloud_cover") ) - return(assets_info) + assets_info }) - - return(items_info) + items_info }, progress = progress) # bind cube rows cube <- dplyr::bind_rows(tiles) - # post-condition - .check_that(nrow(cube) > 0) - + .check_content_data_frame(cube) # review known malformed paths review_date <- .try( .conf( @@ -406,7 +401,7 @@ dplyr::rename(crs = "crs2") |> slider::slide_dfr(function(tile) { # get file_info - file_info <- tile[["file_info"]][[1]] + file_info <- tile[["file_info"]][[1L]] # arrange file_info file_info <- dplyr::arrange( file_info, .data[["date"]], @@ -446,9 +441,9 @@ source, collection, tile ) # return! - return(tile) + tile }) - return(cube) + cube } #' @title Get date from STAC item #' @keywords internal @@ -483,8 +478,7 @@ # post-conditions .check_chr_parameter(hrefs, allow_empty = FALSE) # add gdal VSI in href urls - hrefs <- .stac_add_gdal_fs(hrefs) - return(hrefs) + .stac_add_gdal_fs(hrefs) } #' @title Get cloud cover from STAC item #' @keywords internal @@ -528,7 +522,7 @@ collection = NULL) { # pre-condition - .check_that(nrow(file_info) >= 1) + .check_content_data_frame(file_info) # get bbox based on file_info xmin <- max(file_info[["xmin"]]) @@ -539,8 +533,7 @@ # post-condition .check_that(xmin < xmax && ymin < ymax) # create a bbox - bbox <- c(xmin = xmin, ymin = ymin, xmax = xmax, ymax = ymax) - return(bbox) + c(xmin = xmin, ymin = ymin, xmax = xmax, ymax = ymax) } #' @title Get file ID from STAC item #' @keywords internal @@ -567,7 +560,7 @@ #' @param collection Image collection #' @return No return, called for side effects .source_configure_access.stac_cube <- function(source, collection) { - return(invisible(source)) + invisible(source) } #' @title Adjusts date-time if required by source #' @noRd @@ -575,7 +568,7 @@ #' @param date Date to be adjusted #' @return Adjusted date .source_adjust_date.stac_cube <- function(source, date) { - return(date) + date } #' @title Filter tiles if required by source #' @noRd @@ -596,7 +589,7 @@ # filter cube tiles cube <- dplyr::filter(cube, .data[["tile"]] %in% tiles) } - return(cube) + cube } #' @title Check if roi or tiles are provided #' @param source Data source @@ -607,5 +600,5 @@ #' @noRd #' @export .source_roi_tiles.stac_cube <- function(source, roi, tiles) { - return(invisible(source)) + invisible(source) } diff --git a/R/api_source_terrascope.R b/R/api_source_terrascope.R index 7798e2fcc..159dd1455 100644 --- a/R/api_source_terrascope.R +++ b/R/api_source_terrascope.R @@ -14,10 +14,10 @@ #' @return An object referring the images of a sits cube. #' @export `.source_items_new.terrascope_cube_world-cover-2021` <- function(source, ..., - collection, - stac_query, - tiles = NULL, - platform = NULL) { + collection, + stac_query, + tiles = NULL, + platform = NULL) { # set caller to show in errors .check_set_caller(".source_items_new_terrascope_cube") # convert roi to bbox @@ -34,9 +34,7 @@ # if more than 2 times items pagination are found the progress bar # is displayed progress <- rstac::items_matched(items_info) > - 2 * .conf("rstac_pagination_limit") - # check documentation mode - progress <- .check_documentation(progress) + 2L * .conf("rstac_pagination_limit") # fetching all the metadata and updating to upper case instruments items_info <- rstac::items_fetch(items = items_info, progress = FALSE) # checks if the items returned any items @@ -47,11 +45,11 @@ #' @noRd #' @export `.source_items_tile.terrascope_cube_world-cover-2021` <- function(source, ..., - items, - collection = NULL) { + items, + collection = NULL) { rstac::items_reap(items, field = c("properties", "title")) |> purrr::map_chr(function(property) { # extract date from the filename - stringr::str_split(property, "_")[[1]][[6]] + stringr::str_split(property, "_")[[1L]][[6L]] }) } diff --git a/R/api_source_usgs.R b/R/api_source_usgs.R index b559b51c6..8bdc90dc8 100644 --- a/R/api_source_usgs.R +++ b/R/api_source_usgs.R @@ -14,14 +14,9 @@ .check_that(all(grepl(pattern_l8, tiles, perl = TRUE))) # prepare the tiles for a valid STAC query to the USGS archive - tiles_tbl <- .map_dfr(tiles, function(tile) { - c( - wrs_path = substring(tile, 1, 3), - wrs_row = substring(tile, 4, 6) - ) + .map_dfr(tiles, function(tile) { + c(wrs_path = substring(tile, 1L, 3L), wrs_row = substring(tile, 4L, 6L)) }) - - return(tiles_tbl) } #' @title Test access to collection in USGS #' @keywords internal @@ -41,7 +36,7 @@ items_query <- .stac_create_items_query( source = source, collection = collection, - limit = 1 + limit = 1L ) # Run a query items_query <- rstac::ext_query( @@ -62,13 +57,13 @@ items <- .source_items_bands_select( source = source, items = items, - bands = bands[[1]], + bands = bands[[1L]], collection = collection, ... ) # Get HTTP refs href <- .source_item_get_hrefs( source = source, - item = items[["features"]][[1]], + item = items[["features"]][[1L]], collection = collection, ... ) # assert that token and/or href is valid @@ -79,7 +74,7 @@ default = NULL ) .check_null_parameter(rast) - return(invisible(source)) + invisible(source) } #' @title Retrieves the paths or URLs of each file bands of an item for BDC #' @param source Name of the STAC provider. @@ -123,14 +118,14 @@ stac_query[["params"]][["datetime"]], split = "/" ) - dates_chr <- date_time[[1]] + dates_chr <- date_time[[1L]] # USGS stac only accepts RFC 3339 datetime format stac_query[["params"]][["datetime"]] <- paste( format(as.Date(dates_chr), "%Y-%m-%dT%H:%M:%SZ"), collapse = "/" ) # requests with more than searched items throws 502 error - stac_query[["params"]][["limit"]] <- 300 + stac_query[["params"]][["limit"]] <- 300L if (!is.null(platform)) { platform <- .stac_format_platform( @@ -185,9 +180,9 @@ # is displayed matched_items <- rstac::items_matched(items = items) # progress bar - progress <- matched_items > 2 * .conf("rstac_pagination_limit") + progress <- matched_items > 2L * .conf("rstac_pagination_limit") # check documentation mode - progress <- .check_documentation(progress) + progress <- .message_progress(progress) # fetching all the metadata and updating to upper case instruments items_info <- suppressWarnings( rstac::items_fetch(items = items, progress = progress) @@ -225,7 +220,7 @@ .source_configure_access.usgs_cube <- function(source, collection = NULL) { .check_set_caller(".source_configure_access_usgs_cube") aws_access_key <- Sys.getenv("AWS_SECRET_ACCESS_KEY") - if (nchar(aws_access_key) == 0) + if (.has(aws_access_key)) stop(.conf("messages", ".source_configure_access_usgs_cube")) return(invisible(source)) } diff --git a/R/api_space_time_operations.R b/R/api_space_time_operations.R index 23115240a..cdd31705c 100644 --- a/R/api_space_time_operations.R +++ b/R/api_space_time_operations.R @@ -72,7 +72,7 @@ .intersects <- function(x, y) { as_crs <- sf::st_crs(x) y <- sf::st_transform(y, crs = as_crs) - apply(suppressMessages(sf::st_intersects(x, y, sparse = FALSE)), 1, any) + apply(suppressMessages(sf::st_intersects(x, y, sparse = FALSE)), 1L, any) } #' @title Spatial within #' @noRd @@ -100,7 +100,7 @@ .within <- function(x, y) { as_crs <- sf::st_crs(x) y <- sf::st_transform(y, crs = as_crs) - apply(suppressMessages(sf::st_within(x, y, sparse = FALSE)), 1, any) + apply(suppressMessages(sf::st_within(x, y, sparse = FALSE)), 1L, any) } #' @title Spatial contains #' @noRd @@ -129,7 +129,7 @@ .contains <- function(x, y) { as_crs <- sf::st_crs(x) y <- sf::st_transform(y, crs = as_crs) - apply(suppressMessages(sf::st_contains(x, y, sparse = FALSE)), 1, any) + apply(suppressMessages(sf::st_contains(x, y, sparse = FALSE)), 1L, any) } #' @title Spatial difference #' @noRd @@ -178,8 +178,8 @@ class(dist_xy) <- setdiff(class(dist_xy), "units") attr(dist_xy, "units") <- NULL - dist_xy[dist_xy == 0] <- Inf - min_dist <- apply(dist_xy, MARGIN = 1, FUN = min) + dist_xy[dist_xy == 0.0] <- Inf + min_dist <- apply(dist_xy, MARGIN = 1L, FUN = min) dist_df <- tibble::tibble(distance = min_dist) return(dist_df) } diff --git a/R/api_stac.R b/R/api_stac.R index 09c012b42..a66697977 100644 --- a/R/api_stac.R +++ b/R/api_stac.R @@ -65,7 +65,7 @@ "sources", source, "collections", collection, "platforms" ) platform_source <- platforms[platform] - .check_that(length(platform_source) == 1) + .check_that(length(platform_source) == 1L) unlist(platform_source, use.names = FALSE) } @@ -84,22 +84,22 @@ # reference for HHTP (generic) index <- grepl("^http|[s]://.*", href) if (any(index)) { - href[index] <- paste("/vsicurl", href[index], sep = "/") + href[index] <- file.path("/vsicurl", href[index]) } # reference for AWS S3 index <- grepl("^s3://.*", href) if (any(index)) { - href[index] <- paste("/vsis3", - gsub("^s3://(.*)$", "\\1", href[index]), - sep = "/" + href[index] <- file.path( + "/vsis3", + gsub("^s3://(.*)$", "\\1", href[index]) ) } # reference for google cloud index <- grepl("^gs://.*", href) if (any(index)) { - href[index] <- paste("/vsigs", - gsub("^gs://(.*)$", "\\1", href[index]), - sep = "/" + href[index] <- file.path( + "/vsigs", + gsub("^gs://(.*)$", "\\1", href[index]) ) } href @@ -157,7 +157,7 @@ # adjust limit datatype rstac_query[["params"]][["limit"]] <- as.numeric(limit) # return! - return(rstac_query) + rstac_query } #' @title Extract bounding box from a STAC Query. #' @keywords internal @@ -175,8 +175,8 @@ return(result) } # Extract x-coordinates and y-coordinates - coordinates_x <- coordinates[, , 1] - coordinates_y <- coordinates[, , 2] + coordinates_x <- coordinates[, , 1L] + coordinates_y <- coordinates[, , 2L] # Calculate bounding box min_x <- min(coordinates_x) max_x <- max(coordinates_x) @@ -197,8 +197,8 @@ stac_query[["params"]][["datetime"]], "/" ) list( - start_date = query_datetime[[1]][1], - end_date = query_datetime[[1]][2] + start_date = query_datetime[[1L]][1L], + end_date = query_datetime[[1L]][2L] ) } #' @title Extract dates as datetime from a STAC Query. @@ -213,7 +213,7 @@ stac_query[["params"]][["datetime"]], split = "/" ) - dates_chr <- date_time[[1]] + dates_chr <- date_time[[1L]] # format as datetime (RFC 3339) paste( format(as.Date(dates_chr), "%Y-%m-%dT%H:%M:%SZ"), diff --git a/R/api_stats.R b/R/api_stats.R index fce4c0842..20517b4f9 100644 --- a/R/api_stats.R +++ b/R/api_stats.R @@ -6,7 +6,7 @@ #' @param band Spectral band #' @return old_style statistics for band for Q02 .stats_0_q02 <- function(stats, band) { - quantile_02 <- 2 + quantile_02 <- 2L stats[[band]][[quantile_02]] } #' @title Supports former version of stats for Q98 @@ -15,7 +15,7 @@ #' @param band Spectral band #' @return old_style statistics for band for Q98 .stats_0_q98 <- function(stats, band) { - quantile_98 <- 3 + quantile_98 <- 3L stats[[band]][[quantile_98]] } #' @title Stats for Q02 diff --git a/R/api_texture.R b/R/api_texture.R index f0436a84f..b73fcb7a0 100644 --- a/R/api_texture.R +++ b/R/api_texture.R @@ -30,8 +30,7 @@ # Resume feature if (.raster_is_valid(out_file, output_dir = output_dir)) { # recovery message - .check_recovery(out_file) - + .check_recovery() # Create tile based on template feature <- .tile_eo_from_files( files = out_file, fid = .fi_fid(.fi(feature)), @@ -72,7 +71,7 @@ tile = feature, block = block, in_bands = in_bands ) # Fill with zeros remaining NA pixels - values[[1]] <- C_fill_na(as.matrix(values[[1]]), 0) + values[[1L]] <- C_fill_na(as.matrix(values[[1L]]), 0.0) # Scale values scale <- .scale(band_conf) values <- values / scale @@ -97,7 +96,7 @@ ) # Prepare fractions to be saved offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { + if (.has(offset) && offset != 0.0) { values <- values - offset } # Job crop block @@ -119,7 +118,7 @@ band_conf = band_conf, base_tile = feature, block_files = block_files, - multicores = 1, + multicores = 1L, update_bbox = FALSE ) } @@ -135,7 +134,7 @@ #' values. #' @return a vector with the adjusted block size .texture_normalize <- function(values, source, dest) { - values <- (values - source[1]) / diff(source) * diff(dest) + dest[1] + values <- (values - source[1L]) / diff(source) * diff(dest) + dest[1L] values } diff --git a/R/api_tibble.R b/R/api_tibble.R index 387884711..69e47f14c 100644 --- a/R/api_tibble.R +++ b/R/api_tibble.R @@ -51,7 +51,7 @@ labels <- names(prediction) n_labels <- length(labels) # create a named vector with integers match the class labels - int_labels <- 1:n_labels + int_labels <- seq_len(n_labels) names(int_labels) <- labels # compute prediction vector @@ -87,13 +87,13 @@ #' .tibble_prediction_multiyear <- function(data, class_info, prediction) { # retrieve the global timeline - timeline_global <- class_info[["timeline"]][[1]] + timeline_global <- class_info[["timeline"]][[1L]] # get the labels of the data - labels <- class_info[["labels"]][[1]] + labels <- class_info[["labels"]][[1L]] n_labels <- length(labels) # create a named vector with integers match the class labels - int_labels <- 1:n_labels + int_labels <- seq_len(n_labels) names(int_labels) <- labels # compute prediction vector @@ -105,29 +105,29 @@ function(row, row_n) { # get the timeline of the row timeline_row <- lubridate::as_date( - row[["time_series"]][[1]][["Index"]] + row[["time_series"]][[1L]][["Index"]] ) # the timeline of the row may differ from the global timeline # when we are processing samples with different dates - if (timeline_row[[1]] != timeline_global[[1]]) { + if (timeline_row[[1L]] != timeline_global[[1L]]) { # what are the reference dates to do the classification? ref_dates_lst <- .timeline_match( timeline_data = timeline_row, model_start_date = lubridate::as_date(row[["start_date"]]), model_end_date = lubridate::as_date(row[["end_date"]]), - num_samples = nrow(row[["time_series"]][[1]]) + num_samples = nrow(row[["time_series"]][[1L]]) ) } else { # simplest case - timelines match - ref_dates_lst <- class_info[["ref_dates"]][[1]] + ref_dates_lst <- class_info[["ref_dates"]][[1L]] } - idx_fst <- (row_n - 1) * (length(ref_dates_lst)) + 1 - idx_lst <- idx_fst + length(ref_dates_lst) - 1 + idx_fst <- (row_n - 1L) * (length(ref_dates_lst)) + 1L + idx_lst <- idx_fst + length(ref_dates_lst) - 1L pred_row <- prediction[idx_fst:idx_lst, ] if (idx_lst == idx_fst) { pred_row <- matrix( pred_row, - nrow = 1, + nrow = 1L, dimnames = list(NULL, colnames(prediction)) ) } @@ -141,8 +141,8 @@ probs_date <- rbind.data.frame(pred_row[idx, ]) names(probs_date) <- names(pred_row[idx, ]) pred_date <- tibble::tibble( - from = as.Date(rd[[1]]), - to = as.Date(rd[[2]]), + from = as.Date(rd[[1L]]), + to = as.Date(rd[[2L]]), class = pred_row_lab[idx] ) pred_date <- dplyr::bind_cols(pred_date, probs_date) @@ -182,7 +182,7 @@ ) } # get the reference date - start_date <- lubridate::as_date(ref_dates[[1]]) + start_date <- lubridate::as_date(ref_dates[[1L]]) # align the dates in the data data <- purrr::pmap_dfr( list( @@ -198,29 +198,29 @@ # find the date of minimum distance to the reference date idx <- which.min( abs((lubridate::as_date(ts[["Index"]]) - - lubridate::as_date(start_date)) - / lubridate::ddays(1)) + - lubridate::as_date(start_date)) + / lubridate::ddays(1L)) ) # shift the time series to match dates - if (idx != 1) ts <- shift_ts(ts, -(idx - 1)) + if (idx != 1L) ts <- shift_ts(ts, -(idx - 1L)) # change the dates to the reference dates ts1 <- dplyr::mutate(ts, Index = !!ref_dates) # save the resulting row in the output tibble row <- tibble::tibble( longitude = long, latitude = lat, - start_date = lubridate::as_date(ref_dates[[1]]), + start_date = lubridate::as_date(ref_dates[[1L]]), end_date = ref_dates[[length(ref_dates)]], label = lab, cube = cb, time_series = list(ts1) ) } - return(row) + row } ) - class(data) <- c("sits", class(data)) - data + # set class and return + .set_class(data, "sits", class(data)) } #' #' @title Checks that the timeline of all time series of a data set are equal @@ -239,49 +239,20 @@ .tibble_prune <- function(data) { # verify that tibble is correct .check_samples_ts(data) - n_samples <- data[["time_series"]] |> - purrr::map_int(function(t) { - nrow(t) - }) + # get a vector with the number of samples per time series + n_samples <- purrr::map_int(data[["time_series"]], nrow) # check if all time indices are equal to the median if (all(n_samples == stats::median(n_samples))) { .conf("messages", ".tibble_prune_yes") - return(data) + data } else { .conf("messages", ".tibble_prune_no") # return the time series that have the same number of samples ind2 <- which(n_samples == stats::median(n_samples)) - return(data[ind2, ]) - } -} -#' @title Check that the requested bands exist in the samples -#' @name .tibble_bands_check -#' @keywords internal -#' @noRd -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' -#' @param samples Time series with the samples -#' @param bands Requested bands of the data sample -#' @return Checked bands (cube bands if bands are NULL). -#' -.tibble_bands_check <- function(samples, bands = NULL) { - # set caller to show in errors - .check_set_caller(".tibble_bands_check") - # check the bands are available - sp_bands <- .samples_bands(samples) - if (.has_not(bands)) { - bands <- toupper(sp_bands) - } else { - bands <- toupper(bands) - .check_chr_within( - x = bands, - within = sp_bands - ) + data[ind2, ] } - return(bands) } - #' @title Returns a time series #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @name .tibble_time_series @@ -289,7 +260,7 @@ #' @param data a tibble with time series #' @return time series .tibble_time_series <- function(data) { - data[["time_series"]][[1]] + data[["time_series"]][[1L]] } #' @title Split a sits tibble @@ -310,7 +281,7 @@ dplyr::group_by(.data[["label"]]) |> dplyr::mutate( train = sample(c( - rep(TRUE, round(dplyr::n() * (1 - !!validation_split))), + rep(TRUE, round(dplyr::n() * (1.0 - !!validation_split))), rep(FALSE, round(dplyr::n() * !!validation_split)) )) ) |> diff --git a/R/api_tile.R b/R/api_tile.R index cf91973ec..1796fb3f1 100644 --- a/R/api_tile.R +++ b/R/api_tile.R @@ -22,12 +22,12 @@ NULL } #' @export .tile.raster_cube <- function(cube) { - cube <- .cube(cube)[1,] - cube[1, ] + cube <- .cube(cube)[1L, ] + cube[1L, ] } #' @export .tile.default <- function(cube) { - cube |> + cube |> tibble::as_tibble() |> .cube_find_class() |> .tile() @@ -220,7 +220,7 @@ NULL # Set new labels .tile_labels(tile) <- tile_labels # Return tile with updated labels - return(tile) + tile } #' @export @@ -238,7 +238,7 @@ NULL #' @export .tile_labels.raster_cube <- function(tile) { tile <- .tile(tile) - tile[["labels"]][[1]] + tile[["labels"]][[1L]] } #' @export .tile_labels.default <- function(tile) { @@ -359,8 +359,7 @@ NULL .tile_period.raster_cube <- function(tile) { tile <- .tile(tile) tl_diff <- lubridate::int_diff(.tile_timeline(tile)) - period <- .compact(as.integer(lubridate::as.period(tl_diff), "days")) - return(period) + .compact(as.integer(lubridate::as.period(tl_diff), "days")) } #' @export .tile_period.default <- function(tile) { @@ -395,14 +394,14 @@ NULL #' @keywords internal #' @noRd #' @param tile A tile. -#' @return TRUE/FALSE +#' @return Called for side effects .tile_is_nonempty <- function(tile) { UseMethod(".tile_is_nonempty", tile) } #' @export .tile_is_nonempty.raster_cube <- function(tile) { - tile <- .tile(tile) - nrow(.fi(tile)) > 0 + .check_content_data_frame(.fi(.tile(tile))) + TRUE } #' @export .tile_is_nonempty.default <- function(tile) { @@ -426,10 +425,10 @@ NULL .tile_path.raster_cube <- function(tile, band = NULL, date = NULL) { tile <- .tile(tile) if (.has(band)) { - tile <- .tile_filter_bands(tile = tile, bands = band[[1]]) + tile <- .tile_filter_bands(tile = tile, bands = band[[1L]]) } if (.has(date)) { - tile <- .tile_filter_dates(tile = tile, dates = date[[1]]) + tile <- .tile_filter_dates(tile = tile, dates = date[[1L]]) } # Get path of first asset path <- .fi_path(.fi(tile)) @@ -440,7 +439,7 @@ NULL .tile_path.derived_cube <- function(tile, band = NULL, date = NULL) { tile <- .tile(tile) if (.has(band)) { - tile <- .tile_filter_bands(tile = tile, bands = band[[1]]) + tile <- .tile_filter_bands(tile = tile, bands = band[[1L]]) } # Get path of first asset path <- .fi_path(.fi(tile)) @@ -490,9 +489,10 @@ NULL #' @param band Required band #' @return Path of asset in `base_info` filtered by band .tile_base_path <- function(tile, band) { - base_info <- tile[["base_info"]][[1]] - band_tile <- dplyr::filter(base_info, .data[["band"]] == !!band) - return(band_tile[["path"]]) + band_tile <- tile[["base_info"]][[1L]] |> + dplyr::filter(.data[["band"]] == !!band) + # Path of asset in `base_info` filtered by band + band_tile[["path"]] } #' @title Get unique satellite name from tile. #' @name .tile_satellite @@ -598,7 +598,7 @@ NULL #' @param tile A tile. #' @return names of base bands in the tile .tile_base_bands <- function(tile) { - tile[["base_info"]][[1]] + tile[["base_info"]][[1L]] } #' #' @title Get a band definition from config. @@ -614,26 +614,28 @@ NULL } #' @export .tile_band_conf.eo_cube <- function(tile, band) { + .check_set_caller(".tile_band_conf_eo_cube") band_conf <- .conf_eo_band( source = .tile_source(tile), collection = .tile_collection(tile), - band = band[[1]] + band = band[[1L]] ) if (.has(band_conf)) return(band_conf) - + # try to obtain a band configuration if (band %in% .tile_bands(tile)) { - band_path <- .tile_path(tile, band) - rast <- .raster_open_rast(band_path) - data_type <- .raster_datatype(rast) + data_type <- tile |> + .tile_path(band) |> + .raster_open_rast() |> + .raster_datatype() + # use default band configuration for data type band_conf <- .conf("default_values", data_type) - return(band_conf) } - return(NULL) + band_conf } #' @export .tile_band_conf.derived_cube <- function(tile, band) { .conf_derived_band( - derived_class = .tile_derived_class(tile), band = band[[1]] + derived_class = .tile_derived_class(tile), band = band[[1L]] ) } #' @export @@ -874,7 +876,7 @@ NULL } #' @export .tile_derived_class.derived_cube <- function(tile) { - class(tile)[[1]] + class(tile)[[1L]] } #' #' @title Read and preprocess a block of band values from @@ -927,11 +929,11 @@ NULL values[values > max_value] <- NA } scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { + if (.has(scale) && scale != 1.0) { values <- values * scale } offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { + if (.has(offset) && offset != 0.0) { values <- values + offset } # @@ -967,11 +969,11 @@ NULL values[values > max_value] <- max_value } scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { + if (.has(scale) && scale != 1.0) { values <- values * scale } offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { + if (.has(offset) && offset != 0.0) { values <- values + offset } # Return values @@ -1019,7 +1021,7 @@ NULL # Prepare cloud_mask # Identify values to be removed if (is_bit_mask) - values <- matrix(bitwAnd(values, sum(2^interp_values)) > 0, + values <- matrix(bitwAnd(values, sum(2L^interp_values)) > 0L, nrow = length(values) ) else @@ -1284,7 +1286,7 @@ NULL .check_set_caller(".tile_derived_merge_blocks") if (derived_class %in% c("probs_cube", "variance_cube")) { # Open first block file to be merged - rast <- .raster_open_rast(unlist(block_files)[[1]]) + rast <- .raster_open_rast(unlist(block_files)[[1L]]) # Check number of labels is correct .check_that(.raster_nlayers(rast) == length(labels)) } @@ -1377,7 +1379,7 @@ NULL # pixel area # convert the area to hectares # assumption: spatial resolution unit is meters - area <- freq[["count"]] * .tile_xres(tile) * .tile_yres(tile) / 10000 + area <- freq[["count"]] * .tile_xres(tile) * .tile_yres(tile) / 10000.0 # Include class names freq <- dplyr::mutate( freq, @@ -1484,7 +1486,7 @@ NULL rast <- .raster_open_rast(files) names(rast) <- paste0(band, "-", seq_len(.raster_nlayers(rast))) # Read the segments - segments <- .vector_read_vec(chunk[["segments"]][[1]]) + segments <- .vector_read_vec(chunk[["segments"]][[1L]]) # Extract the values values <- exactextractr::exact_extract( x = rast, @@ -1520,7 +1522,7 @@ NULL chunk = chunk ) pol_id <- values[, "pol_id"] - values <- values[, -1:0] + values <- values[, -1L:0L] # Correct missing, minimum, and maximum values and # apply scale and offset. band_conf <- .tile_band_conf( @@ -1540,11 +1542,11 @@ NULL values[values > max_value] <- NA } scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { + if (.has(scale) && scale != 1.0) { values <- values * scale } offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { + if (.has(offset) && offset != 0.0) { values <- values + offset } # are there NA values? interpolate them @@ -1597,7 +1599,7 @@ NULL message("Tile '", tile[["tile"]], "' finished at ", end_time) message( "Elapsed time of ", - format(round(end_time - start_time, digits = 2)) + format(round(end_time - start_time, digits = 2L)) ) message("") } @@ -1618,12 +1620,12 @@ NULL cog_sizes <- .tile_cog_sizes(tile) if (.has(cog_sizes)) { # find out the first cog size smaller than max_size - i <- 1 + i <- 1L while (i < length(cog_sizes)) { if (cog_sizes[[i]][["xsize"]] < max_size || cog_sizes[[i]][["ysize"]] < max_size) break - i <- i + 1 + i <- i + 1L } # determine the best COG size best_cog_size <- cog_sizes[[i]] @@ -1636,10 +1638,10 @@ NULL nrows_tile <- max(.tile_nrows(tile)) ncols_tile <- max(.tile_ncols(tile)) # get the ratio to the max plot size - ratio_x <- max(ncols_tile / max_size, 1) - ratio_y <- max(nrows_tile / max_size, 1) + ratio_x <- max(ncols_tile / max_size, 1L) + ratio_y <- max(nrows_tile / max_size, 1L) # if image is smaller than 1000 x 1000, return full size - if (ratio_x == 1 && ratio_y == 1) { + if (ratio_x == 1L && ratio_y == 1L) { return(c( xsize = ncols_tile, ysize = nrows_tile @@ -1662,7 +1664,6 @@ NULL #' @param tile File containing tile to be plotted #' @return COG size (assumed to be square) #' -#' .tile_cog_sizes <- function(tile) { # run gdalinfo on file info <- utils::capture.output(sf::gdal_utils( @@ -1676,15 +1677,15 @@ NULL if (!.has(over)) return(NULL) # get the value pairs - over_values <- unlist(strsplit(over, split = ":", fixed = TRUE))[2] + over_values <- unlist(strsplit(over, split = ":", fixed = TRUE))[2L] over_pairs <- unlist(stringr::str_split(over_values, pattern = ",")) # extract the COG sizes purrr::map(over_pairs, function(op) { xsize <- as.numeric(unlist( - strsplit(op, split = "x", fixed = TRUE))[[1]] + strsplit(op, split = "x", fixed = TRUE))[[1L]] ) ysize <- as.numeric(unlist( - strsplit(op, split = "x", fixed = TRUE))[[2]] + strsplit(op, split = "x", fixed = TRUE))[[2L]] ) c(xsize = xsize, ysize = ysize) }) @@ -1700,5 +1701,5 @@ NULL #' @param tile Tile to be plotted #' @return Base info tibble .tile_base_info <- function(tile) { - tile[["base_info"]][[1]] + tile[["base_info"]][[1L]] } diff --git a/R/api_timeline.R b/R/api_timeline.R index 44046633a..844df3c15 100644 --- a/R/api_timeline.R +++ b/R/api_timeline.R @@ -17,8 +17,8 @@ #' #' In this set of steps, this function provides support for step (b). #' It requires the user to provide a timeline, the classification interval, -#' and the start and end dates of the reference period. T -#' he results is a tibble with information that allows the user +#' and the start and end dates of the reference period. +#' The result is a tibble with information that allows the user #' to perform steps (c) to (e). #' #' @param data Description on the data being classified. @@ -31,17 +31,17 @@ # find the timeline timeline <- .samples_timeline(data) # precondition is the timeline correct? - .check_that(length(timeline) >= 1) + .check_that(.has(timeline)) # find the labels labels <- .samples_labels(samples) # find the bands bands <- .samples_bands(samples) # what is the reference start date? - ref_start_date <- lubridate::as_date(samples[1, ][["start_date"]]) + ref_start_date <- lubridate::as_date(samples[1L, ][["start_date"]]) # what is the reference end date? - ref_end_date <- lubridate::as_date(samples[1, ][["end_date"]]) + ref_end_date <- lubridate::as_date(samples[1L, ][["end_date"]]) # number of samples - num_samples <- nrow(samples[1, ][["time_series"]][[1]]) + num_samples <- nrow(samples[1L, ][["time_series"]][[1L]]) # obtain the reference dates that match the patterns in the full timeline ref_dates <- .timeline_match( timeline, @@ -52,7 +52,7 @@ # obtain the indexes of the timeline that match the reference dates dates_index <- .timeline_match_indexes(timeline, ref_dates) # find the number of the samples - nsamples <- dates_index[[1]][[2]] - dates_index[[1]][[1]] + 1 + nsamples <- dates_index[[1L]][[2L]] - dates_index[[1L]][[1L]] + 1L # create a class_info tibble to be used in the classification tibble::tibble( bands = list(bands), @@ -70,11 +70,13 @@ #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' -#' @description A timeline is a list of dates where observations are available. -#' This function estimates if a date is valid by comparing it to the timeline. -#' If the date's estimate is not inside the timeline and the difference between -#' the date and the first date of timeline is greater than the acquisition -#' interval of the timeline, the date is not valid. +#' @description A timeline is a list of dates where +#' observations are available. This function estimates if a date is valid +#' by comparing it to the timeline. +#' If the date's estimate is not inside the timeline +#' and the difference between the date and the first date of +#' timeline is greater than the acquisition +#' interval of the timeline, the date is invalid. #' #' @param date A date. #' @param timeline A vector of reference dates. @@ -84,23 +86,22 @@ .timeline_valid_date <- function(date, timeline) { # is the date inside the timeline? if (date %within% lubridate::interval( - timeline[[1]], + timeline[[1L]], timeline[[length(timeline)]] - )) { + )) return(TRUE) - } - # what is the difference in days between the last two days of the timeline? - timeline_diff <- as.integer(timeline[[2]] - timeline[[1]]) + # what is the difference in days between the first two days of the timeline? + timeline_diff <- as.integer(timeline[[2L]] - timeline[[1L]]) # if the difference in days in the timeline is smaller than the difference # between the reference date and the first date of the timeline, then # we assume the date is valid - if (abs(as.integer(date - timeline[[1]])) <= timeline_diff) { + if (abs(as.integer(date - timeline[[1L]])) <= timeline_diff) { return(TRUE) } # what is the difference in days between the last two days of the timeline? timeline_diff <- as.integer(timeline[[length(timeline)]] - - timeline[[length(timeline) - 1]]) + timeline[[length(timeline) - 1L]]) # if the difference in days in the timeline is smaller than the difference # between the reference date and the last date of the timeline, then # we assume the date is valid @@ -134,14 +135,14 @@ # make sure the timeline is a valid set of dates timeline_data <- lubridate::as_date(timeline_data) # define the input start date - input_start_date <- timeline_data[[1]] + input_start_date <- timeline_data[[1L]] # create a list the subset dates to break the input data set subset_dates <- list() # consider two cases: # (1) start date of data is before start date model # (2) start date of data is the same or after start date of model - if (timeline_data[[1]] < model_start_date) { + if (timeline_data[[1L]] < model_start_date) { # what is the expected start and end dates based on the patterns? ref_st_mday <- as.character(lubridate::mday(model_start_date)) ref_st_month <- as.character(lubridate::month(model_start_date)) @@ -163,7 +164,7 @@ # is the start date a valid one? .check_that(.timeline_valid_date(start_date, timeline_data)) # what is the expected end date of the classification? - idx_end_date <- idx_start_date + (num_samples - 1) + idx_end_date <- idx_start_date + (num_samples - 1L) end_date <- timeline_data[idx_end_date] # is the end date a valid one? .check_that(!(is.na(end_date))) @@ -172,17 +173,17 @@ # find the reference dates for the classification while (!is.na(end_date)) { # add the start and end date - subset_dates[[length(subset_dates) + 1]] <- c(start_date, end_date) + subset_dates[[length(subset_dates) + 1L]] <- c(start_date, end_date) # estimate the next start and end dates - idx_start_date <- idx_end_date + 1 + idx_start_date <- idx_end_date + 1L start_date <- timeline_data[idx_start_date] - idx_end_date <- idx_start_date + num_samples - 1 + idx_end_date <- idx_start_date + num_samples - 1L # estimate end_date <- timeline_data[idx_end_date] } # is the end date a valid one? - end_date <- subset_dates[[length(subset_dates)]][[2]] + end_date <- subset_dates[[length(subset_dates)]][[2L]] .check_that(.timeline_valid_date(end_date, timeline_data)) subset_dates } @@ -208,8 +209,8 @@ .timeline_match_indexes <- function(timeline, ref_dates) { ref_dates |> purrr::map(function(date_pair) { - start_index <- which(timeline == date_pair[[1]]) - end_index <- which(timeline == date_pair[[2]]) + start_index <- which(timeline == date_pair[[1L]]) + end_index <- which(timeline == date_pair[[2L]]) c(start_index, end_index) }) @@ -233,7 +234,7 @@ .check_set_caller(".timeline_during") # obtain the start and end indexes if (.has_not(start_date)) { - start_date <- timeline[[1]] + start_date <- timeline[[1L]] } if (.has_not(end_date)) { end_date <- timeline[[length(timeline)]] @@ -259,17 +260,17 @@ .timeline_format <- function(dates) { # set caller to show in errors .check_set_caller(".timeline_format") - .check_that(length(dates) >= 1) + .check_that(.has(dates)) # convert to character (strsplit does not deal with dates) dates <- as.character(dates) # check type of date interval converted_dates <- purrr::map_dbl(dates, function(dt) { - if (length(strsplit(dt, "-")[[1]]) == 1) { + if (length(strsplit(dt, "-")[[1L]]) == 1L) { converted_dates <- lubridate::fast_strptime(dt, c("%Y%m%d", "%Y")) - } else if (length(strsplit(dt, "-")[[1]]) == 2) { + } else if (length(strsplit(dt, "-")[[1L]]) == 2L) { converted_dates <- lubridate::fast_strptime(dt, "%Y-%m") - } else if (length(strsplit(dt, "-")[[1]]) == 3) { + } else if (length(strsplit(dt, "-")[[1L]]) == 3L) { converted_dates <- lubridate::fast_strptime(dt, "%Y-%m-%d") } converted_dates <- lubridate::as_date(converted_dates) diff --git a/R/api_tmap.R b/R/api_tmap.R index 78fded9eb..cfaa5fb23 100644 --- a/R/api_tmap.R +++ b/R/api_tmap.R @@ -168,7 +168,7 @@ p <- tmap::tm_shape(rast, raster.downsample = FALSE) + tmap::tm_rgb( - col = tmap::tm_vars(n = 3, multivariate = TRUE), + col = tmap::tm_vars(n = 3L, multivariate = TRUE), col.scale = tmap::tm_scale_rgb( value.na = NA, stretch = TRUE, @@ -303,7 +303,7 @@ ) + tmap::tm_graticules( labels.size = tmap_params[["graticules_labels_size"]], - ndiscr = 50 + ndiscr = 50L ) + tmap::tm_compass() + tmap::tm_layout( @@ -341,7 +341,7 @@ position <- tmap::tm_pos_in("left", "bottom") # plot the segments - p <- tmap::tm_shape(sf_seg) + + tmap::tm_shape(sf_seg) + tmap::tm_polygons( fill = labels_plot, fill.scale = tmap::tm_scale_continuous( @@ -364,7 +364,6 @@ tmap::tm_layout( scale = scale ) - p } #' @title Plot a vector class map #' @name .tmap_vector_class @@ -387,7 +386,7 @@ # sort the color vector colors <- colors[sort(names(colors))] # plot the data using tmap - p <- tmap::tm_shape(sf_seg) + + tmap::tm_shape(sf_seg) + tmap::tm_polygons( fill = "class", fill.scale = tmap::tm_scale_categorical( @@ -412,8 +411,6 @@ scale = scale ) + tmap::tm_borders(lwd = 0.2) - - p } #' @title Plot a vector uncertainty map @@ -446,21 +443,21 @@ # plot p <- tmap::tm_shape(sf_seg) + - tmap::tm_polygons( - fill = type, - fill.scale = tmap::tm_scale_continuous( - values = cols4all_name, - midpoint = NA), - fill.legend = tmap::tm_legend( - frame = TRUE, - title = "uncert", - position = position, - title.size = tmap_params[["legend_title_size"]], - text.size = tmap_params[["legend_text_size"]], - bg.color = tmap_params[["legend_bg_color"]], - bg.alpha = tmap_params[["legend_bg_alpha"]] - ) - ) + + tmap::tm_polygons( + fill = type, + fill.scale = tmap::tm_scale_continuous( + values = cols4all_name, + midpoint = NA), + fill.legend = tmap::tm_legend( + frame = TRUE, + title = "uncert", + position = position, + title.size = tmap_params[["legend_title_size"]], + text.size = tmap_params[["legend_text_size"]], + bg.color = tmap_params[["legend_bg_color"]], + bg.alpha = tmap_params[["legend_bg_alpha"]] + ) + ) + tmap::tm_graticules( labels.size = tmap_params[["graticules_labels_size"]] ) + @@ -517,7 +514,7 @@ if ("legend_text_size" %in% names(dots)) legend_text_size <- dots[["legend_text_size"]] - tmap_params <- list( + list( "graticules_labels_size" = graticules_labels_size, "legend_bg_color" = legend_bg_color, "legend_bg_alpha" = legend_bg_alpha, @@ -526,5 +523,4 @@ "legend_text_size" = legend_text_size, "legend_position" = legend_position ) - return(tmap_params) } diff --git a/R/api_torch.R b/R/api_torch.R index 3f5bd938d..6221cc3e7 100644 --- a/R/api_torch.R +++ b/R/api_torch.R @@ -160,7 +160,7 @@ initialize = function(input_dim, output_dim, kernel_size, - padding = 0) { + padding = 0L) { self$block <- torch::nn_sequential( torch::nn_conv1d( in_channels = input_dim, @@ -203,7 +203,7 @@ initialize = function(input_dim, output_dim, kernel_size, - padding = 0) { + padding = 0L) { self$block <- torch::nn_sequential( torch::nn_batch_norm1d(num_features = input_dim), torch::nn_conv1d( @@ -245,7 +245,7 @@ initialize = function(input_dim, output_dim, kernel_size, - padding = 0) { + padding = 0L) { self$block <- torch::nn_sequential( torch::nn_conv1d( in_channels = input_dim, @@ -399,16 +399,16 @@ initialize = function(input_dim, hidden_dims) { tensors <- list() # input layer - tensors[[1]] <- .torch_linear_batch_norm_relu( + tensors[[1L]] <- .torch_linear_batch_norm_relu( input_dim = input_dim, - output_dim = hidden_dims[[1]] + output_dim = hidden_dims[[1L]] ) # if hidden layers is a vector then we add those layers - if (length(hidden_dims) > 1) { - for (i in 2:length(hidden_dims)) { - tensors[[length(tensors) + 1]] <- + if (length(hidden_dims) > 1L) { + for (i in 2L:length(hidden_dims)) { + tensors[[length(tensors) + 1L]] <- .torch_linear_batch_norm_relu( - input_dim = hidden_dims[[i - 1]], + input_dim = hidden_dims[[i - 1L]], output_dim = hidden_dims[[i]] ) } @@ -477,14 +477,14 @@ self$dim <- dim(x) }, .getitem = function(i) { - if (length(self$dim) == 3) + if (length(self$dim) == 3L) item_data <- self$x[i, , , drop = FALSE] else item_data <- self$x[i, , drop = FALSE] list(torch::torch_tensor( array(item_data, dim = c( - nrow(item_data), self$dim[2:length(self$dim)] + nrow(item_data), self$dim[2L:length(self$dim)] )) )) }, @@ -492,6 +492,6 @@ self$.getitem(i) }, .length = function() { - dim(self$x)[[1]] + dim(self$x)[[1L]] } ) diff --git a/R/api_torch_psetae.R b/R/api_torch_psetae.R index 3648d372f..126b66734 100644 --- a/R/api_torch_psetae.R +++ b/R/api_torch_psetae.R @@ -65,7 +65,7 @@ .torch_pixel_spatial_encoder <- torch::nn_module( classname = "torch_pixel_spatial_encoder", initialize = function(n_bands, - layers_spatial_encoder = c(32, 64, 128)) { + layers_spatial_encoder = c(32L, 64L, 128L)) { self$layers_spatial_encoder <- layers_spatial_encoder self$spatial_encoder <- .torch_multi_linear_batch_norm_relu( input_dim = n_bands, @@ -74,11 +74,11 @@ }, forward = function(values) { # batch size is the first dimension of the input tensor - batch_size <- values[["shape"]][[1]] + batch_size <- values[["shape"]][[1L]] # n_times is the second dimension - n_times <- values[["shape"]][[2]] + n_times <- values[["shape"]][[2L]] # n_bands is the third dimension - n_bands <- values[["shape"]][[3]] + n_bands <- values[["shape"]][[3L]] # reshape the input # from a 3D shape [batch_size, n_times, n_bands] # to a 2D shape [(batch_size * n_times), n_bands] @@ -148,7 +148,7 @@ .torch_positional_encoding <- torch::nn_module( classname = "positional_encoding", # timeline is a vector with the observation dates - initialize = function(timeline, dim_encoder = 128) { + initialize = function(timeline, dim_encoder = 128L) { # length of positional encoder is the length of dates vector len_max <- length(timeline) # keep the dates vector @@ -158,12 +158,12 @@ days <- unlist(purrr::map( timeline, function(d) { - lubridate::interval(timeline[[1]], d) / lubridate::days(1) + lubridate::interval(timeline[[1L]], d) / lubridate::days(1L) } )) # create a days tensor days_t <- torch::torch_tensor(days) - days_t <- torch::torch_unsqueeze(days_t, 2) + days_t <- torch::torch_unsqueeze(days_t, 2L) # Calculate the positional encoding p # 2D shape [(len_max, dim_encoder:128)] @@ -171,18 +171,18 @@ # calculate an exponential distance measure for the positions div_term <- torch::torch_exp( torch::torch_arange( - start = 0, - end = dim_encoder - 1, - step = 2 + start = 0L, + end = dim_encoder - 1L, + step = 2L ) * (-log(1000.0) / dim_encoder) ) - div_term <- torch::torch_unsqueeze(div_term, 1) + div_term <- torch::torch_unsqueeze(div_term, 1L) # fill the tensor p - p[, seq(1, dim_encoder, 2)] <- torch::torch_sin(days_t * div_term) - p[, seq(2, dim_encoder, 2)] <- torch::torch_cos(days_t * div_term) + p[, seq(1L, dim_encoder, 2L)] <- torch::torch_sin(days_t * div_term) + p[, seq(2L, dim_encoder, 2L)] <- torch::torch_cos(days_t * div_term) # here p is a 2D shape [(len_max, dim_encoder:128)] - p <- torch::torch_unsqueeze(p, 1) + p <- torch::torch_unsqueeze(p, 1L) # after unsqueeze p is a 3D shape [(1, len_max, dim_encoder:128)] self$register_buffer("p", p) }, @@ -247,10 +247,10 @@ .torch_temporal_attention_encoder <- torch::nn_module( classname = "torch_temporal_attention_encoder", initialize = function(timeline, - dim_encoder = 128, - n_heads = 4, - input_out_enc_mlp = 512, - hidden_nodes_out_enc_mlp = c(128, 128)) { + dim_encoder = 128L, + n_heads = 4L, + input_out_enc_mlp = 512L, + hidden_nodes_out_enc_mlp = c(128L, 128L)) { # store parameters self$dim_encoder <- dim_encoder self$n_heads <- n_heads @@ -275,10 +275,10 @@ # with Pixel-Set Encoders and Temporal Self-Attention" # # obtain the input parameters - batch_size <- x[["shape"]][[1]] + batch_size <- x[["shape"]][[1L]] # seq_len is the - seq_len <- x[["shape"]][[2]] - hidden_state <- x[["shape"]][[3]] + seq_len <- x[["shape"]][[2L]] + hidden_state <- x[["shape"]][[3L]] # Calculate the positional encoding # result is 3D shape [batch_size x seq_len x dim_encoder:128] e_p <- self$pos_encoding(x) @@ -294,7 +294,7 @@ query <- self$fc(e_p) # Calculate the mean of query tensor along dimension 2 # result is a tensor of shape [batch_size x dim_encoder:128] - query <- torch::torch_mean(query, dim = 2) + query <- torch::torch_mean(query, dim = 2L) # Run the mean by a FC (fully connected layer) query <- self$fc(query) # Reorganize the result as a 3D tensor @@ -303,10 +303,10 @@ query <- query$contiguous() # Reorganize the result as a 2D tensor # output shape is 2D [(batch_size * n_heads:4) x dim_k:32] - query <- query$view(c(-1, self$dim_k)) + query <- query$view(c(-1L, self$dim_k)) # Create an additional dimension # output shape is 3D [(batch_size * n_heads:4) x 1 x dim_k:32] - query <- query$unsqueeze(dim = 2) + query <- query$unsqueeze(dim = 2L) # Calculate the key tensor # Run the encoded position through FC @@ -316,7 +316,7 @@ # shape is 4D [batch_size x seq_len x n_heads:4 x dim_k:32] key <- key$view(c(batch_size, seq_len, self$n_heads, self$dim_k)) # Permute dimensions (2,3) of the 4D tensor - key <- key$permute(c(1, 3, 2, 4)) + key <- key$permute(c(1L, 3L, 2L, 4L)) # shape is 4D [batch_size x n_heads:4 x seq_len x dim_k:32] key <- key$contiguous() # Reduce the key tensor to 3D merging dimensions (1,2) @@ -326,7 +326,7 @@ # transpose key tensor dimensions 2 and 3 # input shape is 3D [(batch_size * n_heads) x seq_len x dim_k] # output shape is 3D [(batch_size * n_heads) x dim_k x seq_len] - key <- torch::torch_transpose(key, dim0 = -2, dim1 = -1) + key <- torch::torch_transpose(key, dim0 = -2L, dim1 = -1L) # Calculate attention # Attention scores = averaged product of query and key tensor @@ -339,12 +339,12 @@ # softmax of the normalized query * key product using the last dimension # input shape is 3D [(batch_size * n_heads) x 1 x seq_len] # output_shape is 3D [(batch_size * n_heads) x 1 x seq_len] - attention_probs <- torch::nnf_softmax(attention_probs, dim = -1) + attention_probs <- torch::nnf_softmax(attention_probs, dim = -1L) # Values with positional encoding repeated over attention heads # input 3D shape [batch_size x seq_len x hidden_state:128] # output 3D shape [(batch_size * num_heads) x seq_len x hidden:128] - values <- e_p$`repeat`(c(self$n_heads, 1, 1)) + values <- e_p$`repeat`(c(self$n_heads, 1L, 1L)) # Multi-head self-attention # multiply values by product of query * key @@ -363,14 +363,14 @@ # output shape is 3D [batch_size x n_heads x hidden_state:128] attention_output <- attention_output$contiguous() attention_output <- attention_output$view( - c(batch_size, self$n_heads, -1) + c(batch_size, self$n_heads, -1L) ) # reshape attention output to 2D shape # input shape is 3D [batch_size x n_heads x dim_encoder:128] # output shape is 2D [batch_size x (n_heads:4 * dim_encoder:128)] attention_output <- attention_output$contiguous() - attention_output <- attention_output$view(c(batch_size, -1)) + attention_output <- attention_output$view(c(batch_size, -1L)) # Run the output by a multi-layer perceptron # input shape is 2D [batch_size x (n_heads:4 * dim_encoder:128)] @@ -412,9 +412,9 @@ .torch_light_temporal_attention_encoder <- torch::nn_module( classname = "torch_temporal_attention_encoder", initialize = function(timeline, - in_channels = 128, - n_heads = 16, - n_neurons = c(256, 128), + in_channels = 128L, + n_heads = 16L, + n_neurons = c(256L, 128L), dropout_rate = 0.2) { # store parameters self$in_channels <- in_channels @@ -432,12 +432,12 @@ # Do a 1D convolution on the input sequence # input is 3D shape (batch_size x seq_len x in_channels:128) # output is 3D shape (batch_size x seq_len x d_model:256) - self$d_model <- n_neurons[[1]] + self$d_model <- n_neurons[[1L]] self$inconv <- torch::nn_sequential( torch::nn_conv1d( in_channels = in_channels, out_channels = self$d_model, - kernel_size = 1 + kernel_size = 1L ), torch::nn_layer_norm( normalized_shape = c(self$d_model, seq_len) @@ -458,9 +458,9 @@ ) # output enconding # multi-layer perceptron with batch norm and relu - hidden_dims <- n_neurons[[-1]] + hidden_dims <- n_neurons[[-1L]] self$mlp <- .torch_multi_linear_batch_norm_relu( - input_dim = n_neurons[[1]], + input_dim = n_neurons[[1L]], hidden_dims = hidden_dims ) # dropout node @@ -478,9 +478,9 @@ #' for Classifying Satellite Image Time Series" # # obtain the input parameters - batch_size <- values[["shape"]][[1]] + batch_size <- values[["shape"]][[1L]] # seq_len is the size of the timeline - seq_len <- values[["shape"]][[2]] + seq_len <- values[["shape"]][[2L]] # normalize the input layer # [batch_size x seq_len x in_channels:128] @@ -490,10 +490,10 @@ # convolution is performed in 3D shape # [batch_size x in_channels:128 x seq_len] # and returns a 3D shape [batch_size x d_model:256 x seq_len] - values <- self$inconv(values$permute(c(1, 3, 2))) + values <- self$inconv(values$permute(c(1L, 3L, 2L))) # reshape the input again # to 3D shape [batch_size x seq_len x d_model:256] - values <- values$permute(c(1, 3, 2)) + values <- values$permute(c(1L, 3L, 2L)) # Calculate the positional encoding # result is 3D shape [batch_size x seq_len x d_model:256] @@ -504,9 +504,9 @@ values <- self$attention_heads(values) # permute dimensions of the output # result is 3D shape [batch_size x n_heads x d_model:256] - values <- values$permute(c(2, 1, 3))$contiguous() + values <- values$permute(c(2L, 1L, 3L))$contiguous() # reshape the output - values <- values$view(c(batch_size, -1)) + values <- values$view(c(batch_size, -1L)) # apply multilayer processor values <- self$mlp(values) @@ -558,7 +558,7 @@ initialize = function(temperature, attn_dropout = 0.1) { self$temperature <- temperature self$dropout <- torch::nn_dropout(attn_dropout) - self$softmax <- torch::nn_softmax(dim = 3) + self$softmax <- torch::nn_softmax(dim = 3L) }, forward = function(query, keys, values) { # calculate the dot product between query and keys @@ -567,8 +567,8 @@ # keys has 3D shape [(n_heads * batch_size) x seq_len x d_k] # after transpose a 3D shape [(n_heads * batch_size) x d_k x seq_len] attn <- torch::torch_matmul( - query$unsqueeze(dim = 2), - keys$transpose(dim0 = 2, dim1 = 3) + query$unsqueeze(dim = 2L), + keys$transpose(dim0 = 2L, dim1 = 3L) ) # attention tensor has 3D shape [(n_heads * batch_size) x 1 x seq_len] # weight the attention module @@ -633,7 +633,7 @@ torch::torch_zeros(c(n_heads, d_k), requires_grad = TRUE) ) # initialization with a gaussian distribution - torch::nn_init_normal_(self$Q, mean = 0, std = sqrt(2.0 / (d_k))) + torch::nn_init_normal_(self$Q, mean = 0.0, std = sqrt(2.0 / (d_k))) # d_in is equal to d_model:256 # FC module for calculating keys @@ -644,7 +644,7 @@ # initialization with a gaussian distribution torch::nn_init_normal_( self$fc_k$weight, - mean = 0, + mean = 0.0, std = sqrt(2.0 / (d_k)) ) @@ -659,8 +659,8 @@ n_heads <- self$n_heads # input values tensor is 3D [batch_size x seq_len x d_model:256] - batch_size <- values$shape[[1]] - seq_len <- values$shape[[2]] + batch_size <- values$shape[[1L]] + seq_len <- values$shape[[2L]] # calculate the query tensor # concatenate a sequence of tensors to match input batch_size @@ -668,11 +668,11 @@ self$Q }) # the query tensor has 3D shape [n_heads x batch_size x d_k] - query <- torch::torch_stack(tensors, dim = 2) + query <- torch::torch_stack(tensors, dim = 2L) # drop a dimension in the query tensor # from 3D shape [n_heads x batch_size x d_k] # to 2D shape [(n_heads * batch_size) x d_k] - query <- query$view(c(-1, d_k)) + query <- query$view(c(-1L, d_k)) # create the keys tensor by replicating the values tensor # keys tensor has 3D shape [batch_size x seq_len x d_model:256] @@ -684,10 +684,9 @@ # permute shape of keys tensor # from 4D shape [batch_size, seq_len, n_heads, d_k] # to 4D shape [n_heads, batch_size, seq_len, d_k] - keys <- keys$permute(c(3, 1, 2, 4))$contiguous() + keys <- keys$permute(c(3L, 1L, 2L, 4L))$contiguous() # Reshape keys tensor to 3D [(n_heads * batch_size) x seq_len x d_k] - keys <- keys$view(c(-1, seq_len, d_k)) - + keys <- keys$view(c(-1L, seq_len, d_k)) # split the values tensor by attention heads dim_encoder <- values$shape[length(values$shape)] split_value <- dim_encoder %/% n_heads @@ -695,22 +694,22 @@ # from 3D shape[batch_size x seq_len x dim_encoder:256] # to a 4D shape # [n_heads x batch_size x seq_len x (dim_encoder %/% n_heads)] - values <- torch::torch_stack(values$split(split_value, dim = -1)) + values <- torch::torch_stack(values$split(split_value, dim = -1L)) # reshape the values tensor # from 4D shape # [n_heads x batch_size x seq_len x (dim_encoder %/% n_heads)] # to 3D shape # [(n_heads * batch_size) x seq_len x (dim_encoder %/% n_heads)] - values <- values$view(c(n_heads * batch_size, seq_len, -1)) + values <- values$view(c(n_heads * batch_size, seq_len, -1L)) # calculate the attention values values <- self$attention(query, keys, values) # output has 3D shape # [(num_heads * batch_size) x seq_len x (dim_encoder %/% n_heads)] # d_in = 256 and n_heads = 16, d_in %/% n_heads = 16 # reshape to 4D shape [num_heads x batch_size x 1 x d_in %/% n_heads:16] - values <- values$view(c(n_heads, batch_size, 1, d_in %/% n_heads)) + values <- values$view(c(n_heads, batch_size, 1L, d_in %/% n_heads)) # reshape to 3D shape [num_heads:16 x batch_size x dim_encoder:256] - values <- values$squeeze(dim = 3) + values <- values$squeeze(dim = 3L) values } ) diff --git a/R/api_ts.R b/R/api_ts.R index 90d0183e1..4406bfdf5 100644 --- a/R/api_ts.R +++ b/R/api_ts.R @@ -18,7 +18,7 @@ #' @param x R object #' @return TRUE/FALSE .has_ts <- function(x) { - "time_series" %in% names(x) && .is_ts(x[["time_series"]][[1]]) + "time_series" %in% names(x) && .is_ts(x[["time_series"]][[1L]]) } #' @title Return the time series for a SITS tibble #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} @@ -238,7 +238,7 @@ cld_values <- as.matrix(cld_values) cld_rows <- nrow(cld_values) cld_values <- matrix( - bitwAnd(cld_values, sum(2^cld_index)), + bitwAnd(cld_values, sum(2L^cld_index)), nrow = cld_rows ) } @@ -268,22 +268,22 @@ end_date = lubridate::as_date(points[["end_date"]][[i]]) ) # select the valid dates in the timeline - start_idx <- which(timeline == t_point[[1]]) + start_idx <- which(timeline == t_point[[1L]]) end_idx <- which(timeline == t_point[[length(t_point)]]) # get only valid values for the timeline values_ts <- unlist(values_band[i, start_idx:end_idx], - use.names = FALSE + use.names = FALSE ) # include information from cloud band if (.has(cld_band)) { cld_values <- unlist(cld_values[i, start_idx:end_idx], - use.names = FALSE + use.names = FALSE ) if (.source_cloud_bit_mask( source = .cube_source(cube = tile), collection = .cube_collection(cube = tile) )) { - values_ts[cld_values > 0] <- NA + values_ts[cld_values > 0L] <- NA } else { values_ts[cld_values %in% cld_index] <- NA } @@ -313,9 +313,8 @@ ts_samples, dplyr::bind_cols ) - # set class of time series - class(points) <- c("sits", class(points)) - points + # set class of time series and return + .set_class(points, "sits", class(points)) } #' @title Extract a time series from raster #' @name .ts_get_raster_class @@ -341,7 +340,7 @@ # get timeline length timeline_length <- length(timeline) # check timeline - .check_that(timeline_length == 1 || timeline_length == 2) + .check_that(timeline_length == 1L || timeline_length == 2L) # get tile labels labels <- .tile_labels(tile) # check for labels @@ -361,7 +360,6 @@ traj_samples, dplyr::bind_cols ) - # set class of time series - class(points) <- unique(c("predicted", "sits", class(points))) - points + # set class of time series and return + .set_class(points, "predicted", "sits", class(points)) } diff --git a/R/api_tuning.R b/R/api_tuning.R index 5be97bd08..035ac6191 100644 --- a/R/api_tuning.R +++ b/R/api_tuning.R @@ -12,34 +12,34 @@ #' .tuning_pick_random <- function(trial, params) { # uniform distribution - uniform <- function(min = 0, max = 1) { - stats::runif(n = 1, min = min, max = max) + uniform <- function(min = 0.0, max = 1.0) { + stats::runif(n = 1L, min = min, max = max) } # random choice choice <- function(..., replace = TRUE) { - options <- as.list(substitute(list(...), environment()))[-1] - val <- sample(x = options, replace = replace, size = 1) - if (length(val) == 1) val <- val[[1]] + options <- as.list(substitute(list(...), environment()))[-1L] + val <- sample(x = options, replace = replace, size = 1L) + if (length(val) == 1L) val <- val[[1L]] unlist(val) } # normal distribution - normal <- function(mean = 0, sd = 1) { - stats::rnorm(n = 1, mean = mean, sd = sd) + normal <- function(mean = 0.0, sd = 1.0) { + stats::rnorm(n = 1L, mean = mean, sd = sd) } # lognormal distribution - lognormal <- function(meanlog = 0, sdlog = 1) { - stats::rlnorm(n = 1, meanlog = meanlog, sdlog = sdlog) + lognormal <- function(meanlog = 0.0, sdlog = 1.0) { + stats::rlnorm(n = 1L, meanlog = meanlog, sdlog = sdlog) } # loguniform distribution - loguniform <- function(minlog = 0, maxlog = 1) { - base <- exp(1) - exp(stats::runif(1, log(min(c(minlog, maxlog)), base), + loguniform <- function(minlog = 0.0, maxlog = 1.0) { + base <- exp(1L) + exp(stats::runif(1L, log(min(c(minlog, maxlog)), base), log(max(c(minlog, maxlog)), base))) } # beta distribution beta <- function(shape1, shape2) { - stats::rbeta(n = 1, shape1 = shape1, shape2 = shape2) + stats::rbeta(n = 1L, shape1 = shape1, shape2 = shape2) } # get params <- purrr::map(as.list(params), eval, envir = environment()) @@ -58,7 +58,7 @@ .tuning_params_as_tibble <- function(params) { params <- lapply(params, function(x) { if (purrr::is_atomic(x)) { - if (length(x) != 1) { + if (length(x) != 1L) { list(x) } x diff --git a/R/api_uncertainty.R b/R/api_uncertainty.R index d8e4c42d9..f507d50a1 100644 --- a/R/api_uncertainty.R +++ b/R/api_uncertainty.R @@ -10,10 +10,10 @@ #' @param version version name of resulting cube#' #' @return uncertainty cube .uncertainty_raster_cube <- function(cube, - band, - uncert_fn, - output_dir, - version) { + band, + uncert_fn, + output_dir, + version) { # Process each tile sequentially .cube_foreach_tile(cube, function(tile) { # Compute uncertainty @@ -37,10 +37,10 @@ #' @param version version name of resulting cube #' @return uncertainty tile-band combination .uncertainty_raster_tile <- function(tile, - band, - uncert_fn, - output_dir, - version) { + band, + uncert_fn, + output_dir, + version) { # Output file out_file <- .file_derived_name( tile = tile, @@ -50,7 +50,7 @@ ) # Resume feature if (file.exists(out_file)) { - .check_recovery(tile[["tile"]]) + .check_recovery() # return the existing tile uncert_tile <- .tile_derived_from_file( file = out_file, @@ -62,7 +62,7 @@ } # If output file does not exist # Create chunks as jobs - chunks <- .tile_chunks_create(tile = tile, overlap = 0) + chunks <- .tile_chunks_create(tile = tile, overlap = 0L) # Process jobs in parallel block_files <- .jobs_map_parallel_chr(chunks, function(chunk) { # Job block @@ -84,7 +84,7 @@ block = block ) # Fill with zeros remaining NA pixels - values <- C_fill_na(values, 0) + values <- C_fill_na(values, 0.0) # Apply the labeling function to values values <- uncert_fn(values) # Prepare uncertainty to be saved @@ -93,13 +93,13 @@ band = band ) offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { + if (.has(offset) && offset != 0.0) { values <- values - offset } scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { + if (.has(scale) && scale != 1.0) { values <- values / scale - values[values > 10000] <- 10000 + values[values > 10000L] <- 10000L } # Prepare and save results as raster .raster_write_block( @@ -179,7 +179,7 @@ # Resume feature if (file.exists(out_file)) { if (.check_messages()) { - .check_recovery(out_file) + .check_recovery() } uncert_tile <- .tile_segments_from_file( file = out_file, @@ -218,8 +218,8 @@ .vector_write_vec(v_obj = sf_seg, file_path = out_file) # Set information on uncert_tile uncert_tile <- tile - uncert_tile[["vector_info"]][[1]][["band"]] <- band - uncert_tile[["vector_info"]][[1]][["path"]] <- out_file + uncert_tile[["vector_info"]][[1L]][["band"]] <- band + uncert_tile[["vector_info"]][[1L]][["path"]] <- out_file class(uncert_tile) <- c("uncertainty_vector_cube", class(uncert_tile)) uncert_tile } diff --git a/R/api_utils.R b/R/api_utils.R index 64c02336c..8d0c9c325 100644 --- a/R/api_utils.R +++ b/R/api_utils.R @@ -65,7 +65,7 @@ NULL #' Returns \code{logical}. #' @noRd .has <- function(x) { - length(x) > 0 + length(x) > 0L } #' @title Check if variable has not been defined. Any zero length #' value of any type is evaluated as \code{FALSE}. This function is broader @@ -110,7 +110,7 @@ NULL #' @noRd .compact <- function(x) { value <- unique(x) - if (length(value) != 1) { + if (length(value) != 1L) { return(x) } value @@ -258,8 +258,8 @@ NULL #' @param n Number of partitions #' @returns Vector with indexes for partitions .partitions <- function(x, n) { - n <- max(1, min(length(x), n)) - .as_int(round(seq.int(from = 1, to = n, length.out = length(x)))) + n <- max(1L, min(length(x), n)) + .as_int(round(seq.int(from = 1L, to = n, length.out = length(x)))) } #' @title Collapse #' @noRd @@ -358,7 +358,7 @@ NULL .rand_sub_tempdir <- function() { new_dir <- FALSE while (!new_dir) { - new_temp_dir <- paste0(tempdir(), "/", sample.int(10000, size = 1)) + new_temp_dir <- file.path(tempdir(), sample.int(10000L, size = 1L)) if (!dir.exists(new_temp_dir)) { dir.create(new_temp_dir) new_dir <- TRUE diff --git a/R/api_values.R b/R/api_values.R index 648716f80..294b608b3 100644 --- a/R/api_values.R +++ b/R/api_values.R @@ -40,7 +40,7 @@ purrr::map(function(ts) { data.matrix(dplyr::select(ts, dplyr::all_of(bands))) }) - return(values) + values } #' @noRd #' @export @@ -59,7 +59,7 @@ dplyr::mutate(temp_index = seq_len(dplyr::n())) |> dplyr::ungroup() # melt the data - if (length(bands) > 1) { + if (length(bands) > 1L) { distances_tbl <- tidyr::pivot_wider( distances_tbl, names_from = "temp_index", @@ -82,7 +82,7 @@ ))) }) names(values) <- bands - return(values) + values } #' @noRd #' @export @@ -100,5 +100,5 @@ as.matrix() }) names(values) <- bands - return(values) + values } diff --git a/R/api_variance.R b/R/api_variance.R index 09f3389c7..37f36e2f9 100644 --- a/R/api_variance.R +++ b/R/api_variance.R @@ -30,7 +30,7 @@ ) # Resume feature if (file.exists(out_file)) { - .check_recovery(tile[["tile"]]) + .check_recovery() var_tile <- .tile_derived_from_file( file = out_file, @@ -69,11 +69,11 @@ derived_class = "variance_cube", band = band ) offset <- .offset(band_conf) - if (.has(offset) && offset != 0) { + if (.has(offset) && offset != 0.0) { values <- values - offset } scale <- .scale(band_conf) - if (.has(scale) && scale != 1) { + if (.has(scale) && scale != 1.0) { values <- values / scale } # Job crop block @@ -141,7 +141,7 @@ neigh_fraction = neigh_fraction ) # Overlapping pixels - overlap <- ceiling(window_size / 2) - 1 + overlap <- ceiling(window_size / 2L) - 1L # Smoothing # Process each tile sequentially .cube_foreach_tile(cube, function(tile) { @@ -170,9 +170,9 @@ .variance_fn <- function(window_size, neigh_fraction) { # Check window size - .check_int_parameter(window_size, min = 3, is_odd = TRUE) + .check_int_parameter(window_size, min = 3L, is_odd = TRUE) # Create a window - window <- matrix(1, nrow = window_size, ncol = window_size) + window <- matrix(1L, nrow = window_size, ncol = window_size) # Define smooth function smooth_fn <- function(values, block) { # Check values length diff --git a/R/api_vector_info.R b/R/api_vector_info.R index 1feb5119a..61251d821 100644 --- a/R/api_vector_info.R +++ b/R/api_vector_info.R @@ -13,7 +13,7 @@ NULL #' @param tile A tile. #' @returns A `vector_info` tibble. .vi <- function(tile) { - vi <- tile[["vector_info"]][[1]] + vi <- tile[["vector_info"]][[1L]] vi } #' @title Set `vector_info` into a given tile. @@ -43,7 +43,6 @@ NULL path = path ) } - .vi_segment_from_file <- function(file, base_tile, band, start_date, end_date) { file <- .file_path_expand(file) v_obj <- .vector_read_vec(file_path = file) diff --git a/R/api_view.R b/R/api_view.R index 344173f80..724a55254 100644 --- a/R/api_view.R +++ b/R/api_view.R @@ -103,7 +103,7 @@ fillColor = ~ factpal(label), radius = radius, stroke = FALSE, - fillOpacity = 1, + fillOpacity = 1.0, group = group ) # recover overlay groups @@ -117,7 +117,7 @@ pal = factpal, values = labels, title = "Classes", - opacity = 1 + opacity = 1.0 ) } leaf_map @@ -181,7 +181,7 @@ fillColor = ~ factpal(label), radius = radius, stroke = FALSE, - fillOpacity = 1, + fillOpacity = 1.0, group = group ) # recover overlay groups @@ -196,7 +196,7 @@ pal = factpal, values = labels, title = "Classes", - opacity = 1 + opacity = 1.0 ) sits_env[["leaflet_som_colors"]] <- TRUE } @@ -232,8 +232,8 @@ leafgl::addGlPolygons( data = sf_seg, color = seg_color, - opacity = 1, - fillOpacity = 0, + opacity = 1.0, + fillOpacity = 0.0, weight = line_width, group = group ) @@ -297,7 +297,7 @@ color = seg_color, stroke = TRUE, weight = line_width, - opacity = 1, + opacity = 1.0, fillColor = unname(colors), fillOpacity = opacity, group = group @@ -326,7 +326,7 @@ #' #' @return A leaflet object. #' - .view_image_raster <- function(leaf_map, +.view_image_raster <- function(leaf_map, group, tile, date, @@ -340,7 +340,7 @@ leaflet_megabytes) { # # define which method is used - if (length(bands) == 3) + if (length(bands) == 3L) class(bands) <- c("rgb", class(bands)) else class(bands) <- c("bw", class(bands)) @@ -383,13 +383,13 @@ last_quantile, leaflet_megabytes) { # scale and offset - band_conf <- .tile_band_conf(tile, bands[[1]]) + band_conf <- .tile_band_conf(tile, bands[[1L]]) # filter by date and band # if there is only one band, RGB files will be the same - red_file <- .tile_path(tile, bands[[1]], date) - green_file <- .tile_path(tile, bands[[2]], date) - blue_file <- .tile_path(tile, bands[[3]], date) + red_file <- .tile_path(tile, bands[[1L]], date) + green_file <- .tile_path(tile, bands[[2L]], date) + blue_file <- .tile_path(tile, bands[[3L]], date) # create a leaflet for RGB bands leaf_map <- leaf_map |> @@ -443,9 +443,9 @@ last_quantile, leaflet_megabytes) { # filter by date and band - band_file <- .tile_path(tile, bands[[1]], date) + band_file <- .tile_path(tile, bands[[1L]], date) # scale and offset - band_conf <- .tile_band_conf(tile, bands[[1]]) + band_conf <- .tile_band_conf(tile, bands[[1L]]) leaf_map <- leaf_map |> .view_bw_band( group = group, @@ -516,12 +516,12 @@ # obtain the quantiles quantiles <- stats::quantile( vals, - probs = c(0, 0.05, 0.95, 1), + probs = c(0.0, 0.05, 0.95, 1.0), na.rm = TRUE ) # get quantile values - minq <- quantiles[[2]] - maxq <- quantiles[[3]] + minq <- quantiles[[2L]] + maxq <- quantiles[[3L]] # set limits to raster vals <- pmax(vals, minq) @@ -536,7 +536,7 @@ reverse = rev ) # calculate maximum size in MB - max_bytes <- leaflet_megabytes * 1024^2 + max_bytes <- leaflet_megabytes * 1048576L # add SpatRaster to leaflet leaf_map <- leaf_map |> @@ -547,7 +547,7 @@ group = group, maxBytes = max_bytes, opacity = opacity - ) + ) if (!sits_env[["leaflet_false_color_legend"]]) { leaf_map <- leaf_map |> leaflet::addLegend( @@ -555,7 +555,7 @@ pal = colors_leaf, values = vals, title = "scale", - opacity = 1 + opacity = 1.0 ) sits_env[["leaflet_false_color_legend"]] <- TRUE } @@ -605,7 +605,7 @@ rast <- .raster_view_rgb_object(red_file, green_file, blue_file, band_conf) # calculate maximum size in MB - max_bytes <- leaflet_megabytes * 1024^2 + max_bytes <- leaflet_megabytes * 1048576L leaf_map <- leaf_map |> leaflet::addRasterImage( @@ -696,7 +696,7 @@ domain = as.character(names(labels)) ) # calculate maximum size in MB - max_bytes <- leaflet_megabytes * 1024^2 + max_bytes <- leaflet_megabytes * 1048576L # add the classified image object leaf_map <- leaf_map |> leaflet::addRasterImage( @@ -718,7 +718,6 @@ palette = palette ) } - leaf_map } #' @title Include leaflet to view probs label @@ -742,21 +741,21 @@ #' @return A leaflet object # .view_probs_label <- function(leaf_map, - group, - tile, - labels, - label, - date, - palette, - rev, - opacity, - max_cog_size, - first_quantile, - last_quantile, - leaflet_megabytes) { + group, + tile, + labels, + label, + date, + palette, + rev, + opacity, + max_cog_size, + first_quantile, + last_quantile, + leaflet_megabytes) { # calculate maximum size in MB - max_bytes <- leaflet_megabytes * 1024^2 + max_bytes <- leaflet_megabytes * 1048576L # obtain the raster objects probs_file <- .tile_path(tile) # find if file supports COG overviews @@ -790,12 +789,12 @@ # obtain the quantiles quantiles <- stats::quantile( vals, - probs = c(0, 0.05, 0.95, 1), + probs = c(0.0, 0.05, 0.95, 1.0), na.rm = TRUE ) # get quantile values - minq <- quantiles[[2]] - maxq <- quantiles[[3]] + minq <- quantiles[[2L]] + maxq <- quantiles[[3L]] # set limits to raster vals <- pmax(vals, minq) @@ -826,7 +825,7 @@ pal = colors_leaf, values = vals, title = "scale", - opacity = 1 + opacity = 1.0 ) sits_env[["leaflet_false_color_legend"]] <- TRUE } @@ -845,10 +844,10 @@ #' .view_set_dates <- function(cube, dates) { # get the timeline - timeline <- .cube_timeline(cube)[[1]] + timeline <- .cube_timeline(cube)[[1L]] if (.has_not(dates)) { - dates <- timeline[[1]] + dates <- timeline[[1L]] } # make sure dates are valid lubridate::as_date(dates) @@ -907,7 +906,7 @@ pal = fact_pal, values = labels, title = "Classes", - opacity = 1 + opacity = 1.0 ) leaf_map } diff --git a/R/sits_accuracy.R b/R/sits_accuracy.R index 3bfdaab09..6f815cf47 100644 --- a/R/sits_accuracy.R +++ b/R/sits_accuracy.R @@ -187,7 +187,7 @@ sits_accuracy.class_cube <- function(data, ..., # Find the labelled band labelled_band <- .tile_bands(tile) # Is the labelled band unique? - .check_that(length(labelled_band) == 1) + .check_that(length(labelled_band) == 1L) # get xy in cube projection xy_tb <- .proj_from_latlong( longitude = valid_samples[["longitude"]], @@ -197,7 +197,7 @@ sits_accuracy.class_cube <- function(data, ..., # join samples with XY values in a single tibble points <- dplyr::bind_cols(valid_samples, xy_tb) # are there points to be retrieved from the cube? - .check_that(nrow(points) != 0) + .check_content_data_frame(points) # Filter the points inside the tile points_tile <- dplyr::filter( points, @@ -207,13 +207,13 @@ sits_accuracy.class_cube <- function(data, ..., .data[["Y"]] <= tile[["ymax"]] ) # No points in the cube? Return an empty list - if (nrow(points_tile) < 1) + if (nrow(points_tile) < 1L) return(NULL) # Convert the tibble to a matrix xy <- matrix(c(points_tile[["X"]], points_tile[["Y"]]), nrow = nrow(points_tile), - ncol = 2 + ncol = 2L ) colnames(xy) <- c("X", "Y") # Extract values from cube @@ -300,7 +300,7 @@ sits_accuracy_summary <- function(x, digits = NULL) { # set caller to show in errors .check_set_caller("sits_accuracy_summary") # default value for digits - digits <- .default(digits, max(3, getOption("digits") - 3)) + digits <- .default(digits, max(3L, getOption("digits") - 3L)) if (inherits(x, "sits_area_accuracy")) { print.sits_area_accuracy(x) @@ -311,7 +311,7 @@ sits_accuracy_summary <- function(x, digits = NULL) { # round the data to the significant digits overall <- round(x[["overall"]], digits = digits) - accuracy_ci <- paste0( + accuracy_ci <- paste( "(", toString(overall[c("AccuracyLower", "AccuracyUpper")]), ")" ) overall_text <- c( @@ -348,7 +348,7 @@ sits_accuracy_summary <- function(x, digits = NULL) { #' @export print.sits_accuracy <- function(x, ..., digits = NULL) { # default value for digits - digits <- .default(digits, max(3, getOption("digits") - 3)) + digits <- .default(digits, max(3L, getOption("digits") - 3L)) # rename confusion matrix names names(x) <- c("positive", "table", "overall", "by_class", "mode", "dots") cat("Confusion Matrix and Statistics\n\n") @@ -358,9 +358,7 @@ print.sits_accuracy <- function(x, ..., digits = NULL) { overall <- round(x[["overall"]], digits = digits) # Format accuracy accuracy_ci <- paste( - "(", - paste(overall[c("AccuracyLower", "AccuracyUpper")], collapse = ", "), - ")", sep = "" + "(", toString(overall[c("AccuracyLower", "AccuracyUpper")]), ")" ) overall_text <- c( paste(overall[["Accuracy"]]), accuracy_ci, "", @@ -369,7 +367,7 @@ print.sits_accuracy <- function(x, ..., digits = NULL) { overall_names <- c("Accuracy", "95% CI", "", "Kappa") - if (dim(x[["table"]])[[1]] > 2) { + if (dim(x[["table"]])[[1L]] > 2L) { # Multiclass case # Names in caret are different from usual names in Earth observation cat("\nOverall Statistics\n") @@ -444,7 +442,7 @@ print.sits_accuracy <- function(x, ..., digits = NULL) { colnames(out) <- rep("", ncol(out)) rownames(out) <- rep("", nrow(out)) - out <- rbind(out, rep("", 2)) + out <- rbind(out, rep("", 2L)) print(out, quote = FALSE) } @@ -464,7 +462,7 @@ print.sits_accuracy <- function(x, ..., digits = NULL) { #' #' @keywords internal #' @export -print.sits_area_accuracy <- function(x, ..., digits = 2) { +print.sits_area_accuracy <- function(x, ..., digits = 2L) { # round the data to the significant digits overall <- round(x[["accuracy"]][["overall"]], digits = digits) diff --git a/R/sits_add_base_cube.R b/R/sits_add_base_cube.R index 2fcb692c0..9bc93006e 100644 --- a/R/sits_add_base_cube.R +++ b/R/sits_add_base_cube.R @@ -88,7 +88,6 @@ sits_add_base_cube <- function(cube1, cube2) { tile_cube1[["base_info"]] <- list(base_info) tile_cube1 }) - # update cube class - class(cube1) <- c("base_raster_cube", class(cube1)) - cube1 + # update cube class and return + .set_class(cube1, "base_raster_cube", class(cube1)) } diff --git a/R/sits_apply.R b/R/sits_apply.R index 4126179f1..68fed1820 100644 --- a/R/sits_apply.R +++ b/R/sits_apply.R @@ -163,15 +163,17 @@ sits_apply.raster_cube <- function(data, ..., .check_is_raster_cube(data) .check_cube_is_regular(data) # Check window size - .check_int_parameter(window_size, min = 1, is_odd = TRUE) + .check_int_parameter(window_size, min = 1L, is_odd = TRUE) # Check normalized index .check_lgl_parameter(normalized) # Check memsize - .check_int_parameter(memsize, min = 1, max = 16384) + .check_int_parameter(memsize, min = 1L, max = 16384L) # Check multicores - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) # Check output_dir .check_output_dir(output_dir) + # show progress bar? + progress <- .message_progress(progress) # Get cube bands bands <- .cube_bands(data) @@ -194,14 +196,14 @@ sits_apply.raster_cube <- function(data, ..., expr = expr ) # Overlapping pixels - overlap <- ceiling(window_size / 2) - 1 + overlap <- ceiling(window_size / 2L) - 1L # Get block size block <- .raster_file_blocksize(.raster_open_rast(.tile_path(data))) # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( block_size = .block_size(block = block, overlap = overlap), - npaths = length(in_bands) + 1, - nbytes = 8, + npaths = length(in_bands) + 1L, + nbytes = 8L, proc_bloat = .conf("processing_bloat_cpu") ) # Update multicores parameter diff --git a/R/sits_bands.R b/R/sits_bands.R index 8581934f6..41729f7f5 100644 --- a/R/sits_bands.R +++ b/R/sits_bands.R @@ -58,7 +58,7 @@ sits_bands.raster_cube <- function(x) { sort(bands_tile) }) bands <- unique(bands_lst) - .check_that(length(bands) == 1) + .check_that(length(bands) == 1L) unlist(bands) } #' @rdname sits_bands @@ -89,7 +89,7 @@ sits_bands.default <- function(x) { `sits_bands<-` <- function(x, value) { # set caller to show in errors .check_set_caller("sits_bands_assign") - .check_chr(value, len_min = 1) + .check_chr(value, len_min = 1L) value <- toupper(value) UseMethod("sits_bands<-", x) } diff --git a/R/sits_bayts.R b/R/sits_bayts.R index 5d5d96eee..d5c6d9cbf 100644 --- a/R/sits_bayts.R +++ b/R/sits_bayts.R @@ -61,11 +61,11 @@ sits_bayts <- function(samples = NULL, n_times <- length(tile_tl) # Get the start and end time of the detection period - start_detection <- 0 - end_detection <- n_times + 1 + start_detection <- 0L + end_detection <- n_times + 1L if (.has(start_date) && .has(end_date)) { filt_idxs <- which(tile_tl >= start_date & tile_tl <= end_date) - start_detection <- min(filt_idxs) - 1 + start_detection <- min(filt_idxs) - 1L end_detection <- max(filt_idxs) } diff --git a/R/sits_classify.R b/R/sits_classify.R index 59546d47e..d2e9e7577 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -165,15 +165,15 @@ sits_classify.sits <- function(data, filter_fn = NULL, impute_fn = impute_linear(), multicores = 2L, - gpu_memory = 4, - batch_size = 2^gpu_memory, + gpu_memory = 4L, + batch_size = 2L^gpu_memory, progress = TRUE) { # set caller for error messages .check_set_caller("sits_classify_sits") # Pre-conditions .check_samples_ts(data) .check_is_sits_model(ml_model) - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) .check_function(impute_fn) .check_filter_fn(filter_fn) @@ -328,8 +328,8 @@ sits_classify.raster_cube <- function(data, end_date = NULL, memsize = 8L, multicores = 2L, - gpu_memory = 4, - batch_size = 2^gpu_memory, + gpu_memory = 4L, + batch_size = 2L^gpu_memory, output_dir, version = "v1", verbose = FALSE, @@ -340,16 +340,19 @@ sits_classify.raster_cube <- function(data, .check_is_raster_cube(data) .check_cube_is_regular(data) .check_is_sits_model(ml_model) - .check_int_parameter(memsize, min = 1) - .check_int_parameter(multicores, min = 1) - .check_int_parameter(gpu_memory, min = 1) + .check_int_parameter(memsize, min = 1L) + .check_int_parameter(multicores, min = 1L) + .check_int_parameter(gpu_memory, min = 1L) .check_output_dir(output_dir) # preconditions - impute and filter functions .check_function(impute_fn) .check_filter_fn(filter_fn) # version is case-insensitive in sits version <- .message_version(version) + # documentation mode? progress is FALSE progress <- .message_progress(progress) + # documentation mode? verbose is FALSE + verbose <- .message_verbose(verbose) # Spatial filter if (.has(roi)) { roi <- .roi_as_sf(roi) @@ -388,22 +391,21 @@ sits_classify.raster_cube <- function(data, multicores <- .ml_update_multicores(ml_model, multicores) # The following functions define optimal parameters for parallel processing - # # Get block size block <- .raster_file_blocksize(.raster_open_rast(.tile_path(data))) # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( - block_size = .block_size(block = block, overlap = 0), + block_size = .block_size(block = block, overlap = 0L), npaths = ( length(.tile_paths(data, bands)) + length(.ml_labels(ml_model)) + ifelse( test = .cube_is_base(data), yes = length(.tile_paths(.cube_base_info(data), base_bands)), - no = 0 + no = 0L ) ), - nbytes = 8, + nbytes = 8L, proc_bloat = .conf("processing_bloat") ) # Update multicores parameter based on size of a single block @@ -604,11 +606,11 @@ sits_classify.vector_cube <- function(data, end_date = NULL, memsize = 8L, multicores = 2L, - gpu_memory = 4, - batch_size = 2^gpu_memory, + gpu_memory = 4L, + batch_size = 2L^gpu_memory, output_dir, version = "v1", - n_sam_pol = 15, + n_sam_pol = 15L, verbose = FALSE, progress = TRUE) { @@ -617,15 +619,16 @@ sits_classify.vector_cube <- function(data, # preconditions .check_is_vector_cube(data) .check_is_sits_model(ml_model) - .check_int_parameter(n_sam_pol, min = 5, allow_null = TRUE) - .check_int_parameter(memsize, min = 1, max = 16384) - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(n_sam_pol, min = 5L, allow_null = TRUE) + .check_int_parameter(memsize, min = 1L, max = 16384L) + .check_int_parameter(multicores, min = 1L, max = 2048L) .check_output_dir(output_dir) # preconditions - impute and filter functions .check_function(impute_fn) .check_filter_fn(filter_fn) # version is case-insensitive in sits version <- .message_version(version) + # documentation mode? progress is FALSE progress <- .message_progress(progress) # save GPU memory info for later use @@ -658,9 +661,9 @@ sits_classify.vector_cube <- function(data, block <- .raster_file_blocksize(.raster_open_rast(.tile_path(data))) # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( - block_size = .block_size(block = block, overlap = 0), + block_size = .block_size(block = block, overlap = 0L), npaths = length(.tile_paths(data)) + length(.ml_labels(ml_model)), - nbytes = 8, + nbytes = 8L, proc_bloat = .conf("processing_bloat") ) # Update multicores parameter based on size of a single block diff --git a/R/sits_clean.R b/R/sits_clean.R index e4cac428e..86ad506cd 100644 --- a/R/sits_clean.R +++ b/R/sits_clean.R @@ -74,18 +74,22 @@ sits_clean <- function(cube, window_size = 5L, memsize = 4L, } #' @rdname sits_clean #' @export -sits_clean.class_cube <- function(cube, window_size = 5L, memsize = 4L, - multicores = 2L, output_dir, - version = "v1-clean", progress = TRUE) { +sits_clean.class_cube <- function(cube, + window_size = 5L, + memsize = 4L, + multicores = 2L, + output_dir, + version = "v1-clean", + progress = TRUE) { # Preconditions # Check cube has files .check_raster_cube_files(cube) # Check window size - .check_int_parameter(window_size, min = 3, max = 15, is_odd = TRUE) + .check_int_parameter(window_size, min = 3L, max = 15L, is_odd = TRUE) # Check memsize - .check_int_parameter(memsize, min = 1, max = 16384) + .check_int_parameter(memsize, min = 1L, max = 16384L) # Check multicores - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) # Check output_dir .check_output_dir(output_dir) # Check version and progress @@ -97,13 +101,13 @@ sits_clean.class_cube <- function(cube, window_size = 5L, memsize = 4L, # image size image_size <- .raster_size(.raster_open_rast(.tile_path(cube))) # Overlapping pixels - overlap <- ceiling(window_size / 2) - 1 + overlap <- ceiling(window_size / 2L) - 1L # The following functions define optimal parameters for parallel processing # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( block_size = .block_size(block = image_size, overlap = overlap), - npaths = 1, nbytes = 8, + npaths = 1L, nbytes = 8L, proc_bloat = .conf("processing_bloat") ) # Update multicores parameter @@ -129,24 +133,30 @@ sits_clean.class_cube <- function(cube, window_size = 5L, memsize = 4L, version = version ) }) - # Update cube class - class(clean_cube) <- c("class_cube", class(clean_cube)) - # Return cleaned cube - clean_cube + # Update cube class and return + .set_class(clean_cube, "class_cube", class(clean_cube)) } #' @rdname sits_clean #' @export -sits_clean.raster_cube <- function(cube, window_size = 5L, memsize = 4L, - multicores = 2L, output_dir, - version = "v1-clean", progress = TRUE) { +sits_clean.raster_cube <- function(cube, + window_size = 5L, + memsize = 4L, + multicores = 2L, + output_dir, + version = "v1-clean", + progress = TRUE) { stop(.conf("messages", "sits_clean")) } #' @rdname sits_clean #' @export -sits_clean.derived_cube <- function(cube, window_size = 5L, memsize = 4L, - multicores = 2L, output_dir, - version = "v1-clean", progress = TRUE) { +sits_clean.derived_cube <- function(cube, + window_size = 5L, + memsize = 4L, + multicores = 2L, + output_dir, + version = "v1-clean", + progress = TRUE) { stop(.conf("messages", "sits_clean")) } #' @rdname sits_clean diff --git a/R/sits_cluster.R b/R/sits_cluster.R index ac9150dee..5fda80a28 100644 --- a/R/sits_cluster.R +++ b/R/sits_cluster.R @@ -68,11 +68,11 @@ sits_cluster_dendro <- function(samples, # verify if data is OK .check_samples_train(samples) # bands in sits are uppercase - bands <- .default(bands, .samples_bands(samples)) - bands <- .tibble_bands_check(samples, bands) + bands <- .default(toupper(bands), .samples_bands(samples)) + .check_tibble_bands(samples, bands) # check k (number of clusters) if (.has(k)) { - .check_int_parameter(k, min = 2, max = 200) + .check_int_parameter(k, min = 2L, max = 200L) } # check distance method .check_dist_method(dist_method) @@ -101,7 +101,7 @@ sits_cluster_dendro <- function(samples, message(.conf("messages", "sits_cluster_dendro_best_cut")) best_cut[["k"]] <- k best_cut[["height"]] <- - c(0, cluster[["height"]])[length(cluster[["height"]]) - k + 2] + c(0L, cluster[["height"]])[length(cluster[["height"]]) - k + 2L] } samples[["cluster"]] <- stats::cutree( cluster, @@ -117,7 +117,7 @@ sits_cluster_dendro <- function(samples, cutree_height = best_cut[["height"]], palette = palette ) - return(samples) + samples } #' #' @title Show label frequency in each cluster produced by dendrogram analysis @@ -183,7 +183,7 @@ sits_cluster_clean <- function(samples) { # get the labels of the data lbs <- unique(samples[["label"]]) # for each cluster, get the label with the maximum number of samples - lbs_max <- lbs[as.vector(apply(result, 2, which.max))] + lbs_max <- lbs[as.vector(apply(result, 2L, which.max))] # compute the resulting table purrr::map2_dfr( lbs_max, num_cls, diff --git a/R/sits_colors.R b/R/sits_colors.R index a28a4158e..a19c26413 100644 --- a/R/sits_colors.R +++ b/R/sits_colors.R @@ -38,7 +38,7 @@ sits_colors <- function(legend = NULL) { } else { message(.conf("messages", "sits_colors_legend_not_available")) leg <- paste0(paste(.conf("messages", "sits_colors_legends"), - paste(names(sits_env[["legends"]]), collapse = ", ")) + toString(names(sits_env[["legends"]]))) ) message(leg) return(NULL) @@ -83,9 +83,7 @@ sits_colors_show <- function(legend = NULL, match(colors, color_table_legend[["name"]]), ] # plot the colors - g <- .colors_show(color_table_legend, font_family) - - return(g) + .colors_show(color_table_legend, font_family) } #' @title Function to set sits color table @@ -158,7 +156,7 @@ sits_colors_set <- function(colors, legend = NULL) { # create a new legend entry new_legend_entry <- list() # add the colors from the color table - new_legend_entry[[1]] <- dplyr::pull(colors, .data[["name"]]) + new_legend_entry[[1L]] <- dplyr::pull(colors, .data[["name"]]) # give a new to the new legend entry names(new_legend_entry) <- legend sits_env[["legends"]] <- c(sits_env[["legends"]], new_legend_entry) diff --git a/R/sits_combine_predictions.R b/R/sits_combine_predictions.R index f273f708b..1e4df25f2 100644 --- a/R/sits_combine_predictions.R +++ b/R/sits_combine_predictions.R @@ -99,9 +99,9 @@ sits_combine_predictions.average <- function(cubes, version = "v1", progress = FALSE) { # Check memsize - .check_num_parameter(memsize, min = 1, max = 16384) + .check_num_parameter(memsize, min = 1L, max = 16384L) # Check multicores - .check_num_parameter(multicores, min = 1, max = 2048) + .check_num_parameter(multicores, min = 1L, max = 2048L) # Check output dir .check_output_dir(output_dir) # Check version and convert to lowercase @@ -110,19 +110,19 @@ sits_combine_predictions.average <- function(cubes, progress <- .message_progress(progress) # Get weights n_inputs <- length(cubes) - weights <- .default(weights, rep(1 / n_inputs, n_inputs)) + weights <- .default(weights, rep(1L / n_inputs, n_inputs)) .check_that( length(weights) == n_inputs, msg = .conf("messages", "sits_combine_predictions_weights") ) .check_that( - sum(weights) == 1, + sum(weights) == 1.0, msg = .conf("messages", "sits_combine_predictions_sum_weights") ) # Get combine function comb_fn <- .comb_fn_average(cubes, weights = weights) # Call combine predictions - probs_cube <- .comb( + .comb( probs_cubes = cubes, uncert_cubes = NULL, comb_fn = comb_fn, @@ -133,7 +133,6 @@ sits_combine_predictions.average <- function(cubes, version = version, progress = progress, ... ) - return(probs_cube) } #' @rdname sits_combine_predictions @@ -147,9 +146,9 @@ sits_combine_predictions.uncertainty <- function(cubes, version = "v1", progress = FALSE) { # Check memsize - .check_num_parameter(memsize, min = 1, max = 16384) + .check_num_parameter(memsize, min = 1L, max = 16384L) # Check multicores - .check_num_parameter(multicores, min = 1, max = 2048) + .check_num_parameter(multicores, min = 1L, max = 2048L) # Check output dir .check_output_dir(output_dir) # Check version and convert to lowercase @@ -162,11 +161,11 @@ sits_combine_predictions.uncertainty <- function(cubes, msg = .conf("messages", "sits_combine_predictions_uncert_cubes") ) .check_uncert_cube_lst(uncert_cubes) - .check_cubes_same_size(cubes[[1]], uncert_cubes[[1]]) + .check_cubes_same_size(cubes[[1L]], uncert_cubes[[1L]]) # Get combine function comb_fn <- .comb_fn_uncertainty(cubes) # Call combine predictions - probs_cube <- .comb( + .comb( probs_cubes = cubes, uncert_cubes = uncert_cubes, comb_fn = comb_fn, @@ -177,7 +176,6 @@ sits_combine_predictions.uncertainty <- function(cubes, version = version, progress = progress, ... ) - return(probs_cube) } #' @rdname sits_combine_predictions #' @export diff --git a/R/sits_csv.R b/R/sits_csv.R index 518644513..8c919f7f9 100644 --- a/R/sits_csv.R +++ b/R/sits_csv.R @@ -81,6 +81,7 @@ sits_to_csv.default <- function(data, file) { #' @return Return data.frame with CSV columns (optional) #' #' @examples +#' csv_ts <- sits_timeseries_to_csv(cerrado_2classes) #' csv_file <- paste0(tempdir(), "/cerrado_2classes_ts.csv") #' sits_timeseries_to_csv(cerrado_2classes, file = csv_file) #' @export @@ -90,15 +91,15 @@ sits_timeseries_to_csv <- function(data, file = NULL) { .check_samples(data) data <- .samples_convert_to_sits(data) csv_1 <- .csv_metadata_from_samples(data) - csv_2 <- .predictors(data)[-2:0] - csv_combined <- dplyr::bind_cols(csv_1, csv_2) + csv_2 <- .predictors(data)[-2L:0L] + csv_ts <- dplyr::bind_cols(csv_1, csv_2) # write the CSV file if (.has(file)) - utils::write.csv(csv_combined, + utils::write.csv(csv_ts, file, row.names = FALSE, quote = FALSE) - - return(csv_combined) + else + return(csv_ts) } diff --git a/R/sits_cube.R b/R/sits_cube.R index a45ddd302..85965e85c 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -380,7 +380,7 @@ sits_cube.stac_cube <- function(source, end_date = NULL, orbit = "descending", platform = NULL, - multicores = 2, + multicores = 2L, progress = TRUE) { # set caller to show in errors @@ -410,7 +410,7 @@ sits_cube.stac_cube <- function(source, collection = collection ) # Does the collection need a token for access? - .source_collection_token_check( + .check_source_collection_token( source = source, collection = collection ) @@ -440,6 +440,8 @@ sits_cube.stac_cube <- function(source, start_date = start_date, end_date = end_date ) + # show progress bar? + progress <- .message_progress(progress) # builds a sits data cube cube <- .source_cube( source = source, diff --git a/R/sits_cube_copy.R b/R/sits_cube_copy.R index e5b1f1fab..f838259bf 100644 --- a/R/sits_cube_copy.R +++ b/R/sits_cube_copy.R @@ -81,7 +81,7 @@ #' lat_max = -14.6 #' ), #' multicores = 2L, -#' res = 250, +#' res = 250 #' ) #' } #' @@ -90,7 +90,7 @@ sits_cube_copy <- function(cube, roi = NULL, res = NULL, crs = NULL, - n_tries = 3, + n_tries = 3L, multicores = 2L, output_dir, progress = TRUE) { @@ -99,7 +99,7 @@ sits_cube_copy <- function(cube, # Pre-conditions .check_is_raster_cube(cube) # Check n_tries parameter - .check_num_min_max(x = n_tries, min = 1, max = 50) + .check_num_min_max(x = n_tries, min = 1L, max = 50L) # Check files .check_raster_cube_files(cube) # Spatial filter @@ -119,7 +119,7 @@ sits_cube_copy <- function(cube, ) } } - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) # Check Output dir output_dir <- path.expand(output_dir) .check_output_dir(output_dir) diff --git a/R/sits_cube_local.R b/R/sits_cube_local.R index 17dcad760..f2559857b 100644 --- a/R/sits_cube_local.R +++ b/R/sits_cube_local.R @@ -115,7 +115,8 @@ sits_cube.local_cube <- function( } .check_source(source = source) .check_source_collection(source = source, collection = collection) - + # show progress bar? + progress <- .message_progress(progress) # builds a sits data cube cube <- .local_raster_cube( source = source, @@ -278,6 +279,8 @@ sits_cube.vector_cube <- function( # set caller to show in errors .check_set_caller("sits_cube_vector_cube") + # show progress bar? + progress <- .message_progress(progress) # obtain vector items vector_items <- .local_vector_items( source = source, @@ -510,7 +513,8 @@ sits_cube.results_cube <- function( # check if labels exist and are named if (any(bands %in% c("probs", "bayes", "class"))) .check_labels_named(labels) - + # show progress bar? + progress <- .message_progress(progress) # builds a sits data cube .local_results_cube( source = source, diff --git a/R/sits_detect_change.R b/R/sits_detect_change.R index 1fad9d7a6..059e740cd 100644 --- a/R/sits_detect_change.R +++ b/R/sits_detect_change.R @@ -56,8 +56,10 @@ sits_detect_change.sits <- function(data, # preconditions .check_samples_ts(data) .check_is_sits_model(dc_method) - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) + # documentation mode? verbose is FALSE + verbose <- .message_verbose(verbose) # preconditions - impute and filter functions if (!is.null(filter_fn)) { .check_function(filter_fn) @@ -93,8 +95,8 @@ sits_detect_change.raster_cube <- function(data, # preconditions .check_is_raster_cube(data) .check_cube_is_regular(data) - .check_int_parameter(memsize, min = 1, max = 16384) - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(memsize, min = 1L, max = 16384L) + .check_int_parameter(multicores, min = 1L, max = 2048L) .check_output_dir(output_dir) # preconditions - impute and filter functions .check_function(impute_fn) @@ -124,9 +126,9 @@ sits_detect_change.raster_cube <- function(data, # Check minimum memory needed to process one block # '2' stands for forest and non-forest job_block_memsize <- .jobs_block_memsize( - block_size = .block_size(block = block, overlap = 0), - npaths = length(.tile_paths(data)) + 2, - nbytes = 8, + block_size = .block_size(block = block, overlap = 0L), + npaths = length(.tile_paths(data)) + 2L, + nbytes = 8L, proc_bloat = proc_bloat ) # Update multicores parameter diff --git a/R/sits_detect_change_method.R b/R/sits_detect_change_method.R index b4a6e0d61..fcf2c6c5c 100644 --- a/R/sits_detect_change_method.R +++ b/R/sits_detect_change_method.R @@ -13,7 +13,8 @@ #' to be passed to #' \code{\link[sits]{sits_detect_change}} #' @noRd -sits_detect_change_method <- function(samples = NULL, dc_method = sits_dtw()) { +sits_detect_change_method <- function(samples = NULL, + dc_method = sits_dtw()) { # set caller to show in errors .check_set_caller("sits_detect_change_method") # is the train method a function? diff --git a/R/sits_filters.R b/R/sits_filters.R index c79378517..ef8e8e86c 100644 --- a/R/sits_filters.R +++ b/R/sits_filters.R @@ -122,9 +122,9 @@ sits_whittaker <- function(data = NULL, lambda = 0.5) { #' plot(point_ndvi) #' } #' @export -sits_sgolay <- function(data = NULL, order = 3, length = 5) { +sits_sgolay <- function(data = NULL, order = 3L, length = 5L) { # compute filter coefficients once - f_res <- .signal_sgolay_coef(p = order, n = length, ts = 1) + f_res <- .signal_sgolay_coef(p = order, n = length, ts = 1L) # function to be applied filter_fun <- function(data) { # calculate coefficients for sgolay diff --git a/R/sits_geo_dist.R b/R/sits_geo_dist.R index fd0c7808a..139b2ba24 100644 --- a/R/sits_geo_dist.R +++ b/R/sits_geo_dist.R @@ -58,7 +58,7 @@ #' } #' @export #' -sits_geo_dist <- function(samples, roi, n = 1000, crs = "EPSG:4326") { +sits_geo_dist <- function(samples, roi, n = 1000L, crs = "EPSG:4326") { .check_set_caller("sits_geo_dist") # Pre-conditions .check_samples(samples) @@ -79,6 +79,5 @@ sits_geo_dist <- function(samples, roi, n = 1000, crs = "EPSG:4326") { dist_ss <- dplyr::mutate(dist_ss, type = "sample-to-sample") dist_sp <- dplyr::mutate(dist_sp, type = "sample-to-prediction") dist_tb <- dplyr::bind_rows(dist_ss, dist_sp) - class(dist_tb) <- c("geo_distances", class(dist_tb)) - dist_tb + .set_class(dist_tb, "geo_distances", class(dist_tb)) } diff --git a/R/sits_get_class.R b/R/sits_get_class.R index 144a152cf..49e4eedb5 100644 --- a/R/sits_get_class.R +++ b/R/sits_get_class.R @@ -93,7 +93,7 @@ sits_get_class.shp <- function(cube, samples) { # transform from shapefile to sf sf_shape <- .shp_transform_to_sf(shp_file = samples) # Get the geometry type - geom_type <- as.character(sf::st_geometry_type(sf_shape)[[1]]) + geom_type <- as.character(sf::st_geometry_type(sf_shape)[[1L]]) if (geom_type != "POINT") stop(.conf("messages", "sits_get_class_not_point")) @@ -110,7 +110,7 @@ sits_get_class.shp <- function(cube, samples) { sits_get_class.sf <- function(cube, samples) { .check_set_caller("sits_get_class") # Get the geometry type - geom_type <- as.character(sf::st_geometry_type(samples)[[1]]) + geom_type <- as.character(sf::st_geometry_type(samples)[[1L]]) if (geom_type != "POINT") stop(.conf("messages", "sits_get_class_not_point")) diff --git a/R/sits_get_data.R b/R/sits_get_data.R index d72091ea8..a63dcac6e 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -170,13 +170,13 @@ sits_get_data.csv <- function(cube, bands = NULL, crs = "EPSG:4326", impute_fn = impute_linear(), - multicores = 2, + multicores = 2L, progress = FALSE) { if (!.has(bands)) bands <- .cube_bands(cube) .check_cube_bands(cube, bands = bands) .check_crs(crs) - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) .check_function(impute_fn) # Extract a data frame from csv @@ -276,10 +276,10 @@ sits_get_data.shp <- function(cube, impute_fn = impute_linear(), label = "NoClass", label_attr = NULL, - n_sam_pol = 30, + n_sam_pol = 30L, pol_avg = FALSE, sampling_type = "random", - multicores = 2, + multicores = 2L, progress = FALSE) { .check_set_caller("sits_get_data_shp") if (!.has(bands)) @@ -288,7 +288,7 @@ sits_get_data.shp <- function(cube, # Get default start and end date start_date <- .default(start_date, .cube_start_date(cube)) end_date <- .default(end_date, .cube_end_date(cube)) - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) # Extract a data frame from shapefile @@ -401,16 +401,16 @@ sits_get_data.sf <- function(cube, impute_fn = impute_linear(), label = "NoClass", label_attr = NULL, - n_sam_pol = 30, + n_sam_pol = 30L, pol_avg = FALSE, sampling_type = "random", - multicores = 2, + multicores = 2L, progress = FALSE) { .check_set_caller("sits_get_data_sf") if (!.has(bands)) bands <- .cube_bands(cube) .check_cube_bands(cube, bands = bands) - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) .check_function(impute_fn) # Get default start and end date @@ -474,9 +474,11 @@ sits_get_data.sits <- function(cube, bands = NULL, crs = "EPSG:4326", impute_fn = impute_linear(), - multicores = 2, + multicores = 2L, progress = FALSE) { bands <- .default(bands, .cube_bands(cube)) + # show progress bar? + progress <- .message_progress(progress) # Extract time series from a cube given a data.frame data <- .data_get_ts( cube = cube, @@ -545,7 +547,7 @@ sits_get_data.data.frame <- function(cube, label = "NoClass", crs = "EPSG:4326", impute_fn = impute_linear(), - multicores = 2, + multicores = 2L, progress = FALSE) { .check_set_caller("sits_get_data_data_frame") if (!.has(bands)) @@ -556,6 +558,8 @@ sits_get_data.data.frame <- function(cube, contains = c("latitude", "longitude"), discriminator = "all_of" ) + # show progress bar? + progress <- .message_progress(progress) # Get default start and end date start_date <- .default(start_date, .cube_start_date(cube)) end_date <- .default(end_date, .cube_end_date(cube)) diff --git a/R/sits_get_probs.R b/R/sits_get_probs.R index af642ad38..37db9a6be 100644 --- a/R/sits_get_probs.R +++ b/R/sits_get_probs.R @@ -87,7 +87,7 @@ sits_get_probs.shp <- function(cube, samples, window_size = NULL) { # transform from shapefile to sf sf_shape <- .shp_transform_to_sf(shp_file = samples) # Get the geometry type - geom_type <- as.character(sf::st_geometry_type(sf_shape)[[1]]) + geom_type <- as.character(sf::st_geometry_type(sf_shape)[[1L]]) if (geom_type != "POINT") stop(.conf("messages", "sits_get_probs_not_point")) @@ -106,7 +106,7 @@ sits_get_probs.shp <- function(cube, samples, window_size = NULL) { sits_get_probs.sf <- function(cube, samples, window_size = NULL) { .check_set_caller("sits_get_probs") # Get the geometry type - geom_type <- as.character(sf::st_geometry_type(samples)[[1]]) + geom_type <- as.character(sf::st_geometry_type(samples)[[1L]]) if (geom_type != "POINT") stop(.conf("messages", "sits_get_probs_not_point")) diff --git a/R/sits_histogram.R b/R/sits_histogram.R index 8bd3e7802..052abdee5 100644 --- a/R/sits_histogram.R +++ b/R/sits_histogram.R @@ -12,7 +12,14 @@ #' #' @examples #' if (sits_run_examples()) { -#' hist(samples_modis_ndvi) +#' # create a data cube from local files +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' hist(cube) #' } #' #' @export @@ -50,10 +57,10 @@ hist.sits <- function(x, ...) { #' #' @export hist.raster_cube <- function(x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], date = NULL, band = NULL, - size = 10000) { + size = 100000L) { .check_set_caller("summary_raster_cube") # Pre-conditional check .check_date_parameter(date, allow_null = TRUE) @@ -77,7 +84,7 @@ hist.raster_cube <- function(x, ..., msg = .conf("messages", "sits_hist_date") ) } else { - date <- .tile_timeline(tile)[[1]] + date <- .tile_timeline(tile)[[1L]] } if (.has(band)) { # is this a valid band? @@ -85,7 +92,7 @@ hist.raster_cube <- function(x, ..., msg = .conf("messages", "sits_hist_band") ) } else { - band <- .tile_bands(tile)[[1]] + band <- .tile_bands(tile)[[1L]] } # select the file to be plotted band_file <- .tile_path(tile, band, date) @@ -153,9 +160,9 @@ hist.raster_cube <- function(x, ..., #' #' @export hist.probs_cube <- function(x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], label = NULL, - size = 100000) { + size = 100000L) { .check_set_caller("sits_hist_raster_cube") # Pre-conditional check .check_chr_parameter(tile, allow_null = TRUE) @@ -178,7 +185,7 @@ hist.probs_cube <- function(x, ..., msg = .conf("messages", "sits_hist_label") ) } else { - label <- .tile_labels(tile)[[1]] + label <- .tile_labels(tile)[[1L]] } # select the file to be plotted probs_file <- .tile_path(tile) @@ -254,10 +261,9 @@ hist.probs_cube <- function(x, ..., #' hist(uncert_cube) #' } #' @export -hist.uncertainty_cube <- function( - x, ..., - tile = x[["tile"]][[1]], - size = 100000) { +hist.uncertainty_cube <- function(x, ..., + tile = x[["tile"]][[1L]], + size = 100000L) { .check_set_caller("sits_hist_uncertainty_cube") # Pre-conditional check .check_chr_parameter(tile, allow_null = TRUE) diff --git a/R/sits_label_classification.R b/R/sits_label_classification.R index 8ce61c6dd..3723dda5e 100644 --- a/R/sits_label_classification.R +++ b/R/sits_label_classification.R @@ -96,8 +96,8 @@ sits_label_classification.probs_cube <- function(cube, ..., progress = TRUE) { # Pre-conditions - Check parameters .check_raster_cube_files(cube) - .check_num_parameter(memsize, min = 1, max = 16384) - .check_num_parameter(multicores, min = 1, max = 2048) + .check_num_parameter(memsize, min = 1L, max = 16384L) + .check_num_parameter(multicores, min = 1L, max = 2048L) .check_output_dir(output_dir) # Check version and progress version <- .message_version(version) @@ -109,9 +109,9 @@ sits_label_classification.probs_cube <- function(cube, ..., block <- .raster_file_blocksize(.raster_open_rast(.tile_path(cube))) # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( - block_size = .block_size(block = block, overlap = 0), - npaths = length(.cube_labels(cube)) + 1, - nbytes = 8, + block_size = .block_size(block = block, overlap = 0L), + npaths = length(.cube_labels(cube)) + 1L, + nbytes = 8L, proc_bloat = .conf("processing_bloat_cpu") ) # Update multicores parameter @@ -158,6 +158,8 @@ sits_label_classification.probs_vector_cube <- function(cube, ..., .check_output_dir(output_dir) # Check version and progress version <- .message_version(version) + # show progress bar? + progress <- .message_progress(progress) # Process each tile sequentially .cube_foreach_tile(cube, function(tile) { # Label the segments diff --git a/R/sits_labels.R b/R/sits_labels.R index c543640d1..0bd7ad8ca 100644 --- a/R/sits_labels.R +++ b/R/sits_labels.R @@ -49,13 +49,13 @@ sits_labels.sits <- function(data) { #' @export #' sits_labels.derived_cube <- function(data) { - data[["labels"]][[1]] + data[["labels"]][[1L]] } #' @rdname sits_labels #' @export #' sits_labels.derived_vector_cube <- function(data) { - data[["labels"]][[1]] + data[["labels"]][[1L]] } #' @rdname sits_labels #' @export diff --git a/R/sits_lighttae.R b/R/sits_lighttae.R index ab306328f..a3563c13f 100644 --- a/R/sits_lighttae.R +++ b/R/sits_lighttae.R @@ -107,8 +107,8 @@ #' @export sits_lighttae <- function(samples = NULL, samples_validation = NULL, - epochs = 150, - batch_size = 128, + epochs = 150L, + batch_size = 128L, validation_split = 0.2, optimizer = torch::optim_adamw, opt_hparams = list( @@ -116,15 +116,17 @@ sits_lighttae <- function(samples = NULL, eps = 1e-08, weight_decay = 7e-04 ), - lr_decay_epochs = 50, + lr_decay_epochs = 50L, lr_decay_rate = 1.0, - patience = 20, + patience = 20L, min_delta = 0.01, verbose = FALSE) { # set caller for error msg .check_set_caller("sits_lighttae") # Verifies if 'torch' and 'luz' packages is installed .check_require_packages(c("torch", "luz")) + # documentation mode? verbose is FALSE + verbose <- .message_verbose(verbose) # Function that trains a torch model based on samples train_fun <- function(samples) { # does not support working with DEM or other base data @@ -134,10 +136,11 @@ sits_lighttae <- function(samples = NULL, self <- NULL # Check validation_split parameter if samples_validation is not passed if (is.null(samples_validation)) { - .check_num_parameter(validation_split, exclusive_min = 0, max = 0.5) + .check_num_parameter(validation_split, + exclusive_min = 0.0, max = 0.5) } # Pre-conditions - .pre_sits_lighttae(samples = samples, epochs = epochs, + .check_pre_sits_lighttae(samples = samples, epochs = epochs, batch_size = batch_size, lr_decay_epochs = lr_decay_epochs, lr_decay_rate = lr_decay_rate, @@ -146,7 +149,7 @@ sits_lighttae <- function(samples = NULL, # Check opt_hparams # Get parameters list and remove the 'param' parameter - optim_params_function <- formals(optimizer)[-1] + optim_params_function <- formals(optimizer)[-1L] .check_opt_hparams(opt_hparams, optim_params_function) optim_params_function <- utils::modifyList( x = optim_params_function, @@ -197,19 +200,19 @@ sits_lighttae <- function(samples = NULL, ) test_y <- unname(code_labels[.pred_references(test_samples)]) # Set torch seed - torch::torch_manual_seed(sample.int(10^5, 1)) + torch::torch_manual_seed(sample.int(10000L, 1L)) # Define the L-TAE architecture light_tae_model <- torch::nn_module( classname = "model_ltae", initialize = function(n_bands, n_labels, timeline, - layers_spatial_encoder = c(32, 64, 128), - n_heads = 16, - n_neurons = c(256, 128), + layers_spatial_encoder = c(32L, 64L, 128L), + n_heads = 16L, + n_neurons = c(256L, 128L), dropout_rate = 0.2, - dim_input_decoder = 128, - dim_layers_decoder = c(64, 32)) { + dim_input_decoder = 128L, + dim_layers_decoder = c(64L, 32L)) { # define an spatial encoder self$spatial_encoder <- .torch_pixel_spatial_encoder( @@ -230,7 +233,7 @@ sits_lighttae <- function(samples = NULL, ) # add a final layer to the decoder # with a dimension equal to the number of layers - dim_layers_decoder[length(dim_layers_decoder) + 1] <- n_labels + dim_layers_decoder[length(dim_layers_decoder) + 1L] <- n_labels # decode the tensor self$decoder <- .torch_multi_linear_batch_norm_relu( dim_input_decoder, @@ -242,7 +245,9 @@ sits_lighttae <- function(samples = NULL, self$spatial_encoder() |> self$temporal_encoder() |> self$decoder() + out # softmax is done externally + # by .ml_normalize.torch_model function } ) # torch 12.0 with luz not working with Apple MPS @@ -299,7 +304,7 @@ sits_lighttae <- function(samples = NULL, .check_require_packages("torch") # Set torch threads to 1 # Note: function does not work on MacOS - suppressWarnings(torch::torch_set_num_threads(1)) + suppressWarnings(torch::torch_set_num_threads(1L)) # Unserialize model torch_model[["model"]] <- .torch_unserialize_model(serialized_model) # Transform input into a 3D tensor diff --git a/R/sits_machine_learning.R b/R/sits_machine_learning.R index c07d8528e..f69944947 100644 --- a/R/sits_machine_learning.R +++ b/R/sits_machine_learning.R @@ -42,14 +42,14 @@ #' } #' @export #' -sits_rfor <- function(samples = NULL, num_trees = 100, mtry = NULL, ...) { +sits_rfor <- function(samples = NULL, num_trees = 100L, mtry = NULL, ...) { .check_set_caller("sits_rfor") # Function that trains a random forest model train_fun <- function(samples) { # Verifies if 'randomForest' package is installed .check_require_packages("randomForest") # Checks 'num_trees' - .check_int_parameter(num_trees, min = 20) + .check_int_parameter(num_trees, min = 20L) # Get labels (used later to ensure column order in result matrix) labels <- .samples_labels(samples) # Get predictors features @@ -57,11 +57,11 @@ sits_rfor <- function(samples = NULL, num_trees = 100, mtry = NULL, ...) { # Post condition: is predictor data valid? .check_predictors(pred = train_samples, samples = samples) # determine number of random forest - n_features <- ncol(train_samples) - 2 + n_features <- ncol(train_samples) - 2L # Apply the 'mtry' default value of 'randomForest' package if (.has(mtry)) { # Checks 'mtry' - .check_int_parameter(mtry, min = 1, max = n_features) + .check_int_parameter(mtry, min = 1L, max = n_features) } else { # set the default values of `mtry` mtry <- floor(sqrt(n_features)) @@ -71,7 +71,7 @@ sits_rfor <- function(samples = NULL, num_trees = 100, mtry = NULL, ...) { x = .pred_features(train_samples), y = as.factor(.pred_references(train_samples)), samples = NULL, ntree = num_trees, mtry = mtry, - nodesize = 1, localImp = TRUE, norm.votes = FALSE, ..., + nodesize = 1L, localImp = TRUE, norm.votes = FALSE, ..., na.action = stats::na.fail ) # Function that predicts results @@ -158,9 +158,15 @@ sits_rfor <- function(samples = NULL, num_trees = 100, mtry = NULL, ...) { #' @export #' sits_svm <- function(samples = NULL, formula = sits_formula_linear(), - scale = FALSE, cachesize = 1000, kernel = "radial", - degree = 3, coef0 = 0, cost = 10, tolerance = 0.001, - epsilon = 0.1, cross = 10, ...) { + scale = FALSE, + cachesize = 1000L, + kernel = "radial", + degree = 3L, + coef0 = 0L, + cost = 10.0, + tolerance = 0.001, + epsilon = 0.1, + cross = 10L, ...) { .check_set_caller("sits_svm") # Function that trains a support vector machine model train_fun <- function(samples) { @@ -285,13 +291,21 @@ sits_svm <- function(samples = NULL, formula = sits_formula_linear(), #' } #' @export #' -sits_xgboost <- function(samples = NULL, learning_rate = 0.15, - min_split_loss = 1, max_depth = 5, - min_child_weight = 1, max_delta_step = 1, - subsample = 0.8, nfold = 5, nrounds = 100, - nthread = 6, - early_stopping_rounds = 20, verbose = FALSE) { +sits_xgboost <- function(samples = NULL, + learning_rate = 0.15, + min_split_loss = 1.0, + max_depth = 5L, + min_child_weight = 1.0, + max_delta_step = 1.0, + subsample = 0.85, + nfold = 5L, + nrounds = 100L, + nthread = 6L, + early_stopping_rounds = 20L, + verbose = FALSE) { .check_set_caller("sits_xgboost") + # documentation mode? verbose is FALSE + verbose <- .message_verbose(verbose) # Function that trains a xgb model train_fun <- function(samples) { # verifies if xgboost package is installed @@ -307,7 +321,7 @@ sits_xgboost <- function(samples = NULL, learning_rate = 0.15, names(code_labels) <- labels # Reference labels for each sample expressed as numerical values references <- - unname(code_labels[.pred_references(train_samples)]) - 1 + unname(code_labels[.pred_references(train_samples)]) - 1L # Define the parameters of the model params <- list( booster = "gbtree", objective = "multi:softprob", @@ -318,9 +332,9 @@ sits_xgboost <- function(samples = NULL, learning_rate = 0.15, nthread = nthread ) if (verbose) - verbose <- 1 + verbose <- 1L else - verbose <- 0 + verbose <- 0L # transform predictors in a xgb.DMatrix xgb_matrix <- xgboost::xgb.DMatrix( data = as.matrix(.pred_features(train_samples)), @@ -395,7 +409,7 @@ sits_xgboost <- function(samples = NULL, learning_rate = 0.15, #' } #' @export #' -sits_formula_logref <- function(predictors_index = -2:0) { +sits_formula_logref <- function(predictors_index = -2L:0L) { # set caller to show in errors .check_set_caller("sits_formula_logref") @@ -407,15 +421,11 @@ sits_formula_logref <- function(predictors_index = -2:0) { # the predictor fields given by the predictor index. result_fun <- function(tb) { .check_that(nrow(tb) > 0) - n_rows_tb <- nrow(tb) - # if no predictors_index are given, assume all tb's fields are used if (!.has(predictors_index)) - predictors_index <- 1:n_rows_tb - + predictors_index <- seq_len(nrow(tb)) # get predictors names categories <- names(tb)[c(predictors_index)] - # compute formula result stats::as.formula(paste0( "factor(label)~", @@ -460,7 +470,7 @@ sits_formula_logref <- function(predictors_index = -2:0) { #' } #' @export #' -sits_formula_linear <- function(predictors_index = -2:0) { +sits_formula_linear <- function(predictors_index = -2L:0L) { # set caller to show in errors .check_set_caller("sits_formula_linear") @@ -471,19 +481,19 @@ sits_formula_linear <- function(predictors_index = -2:0) { # 'factor(reference~log(f1)+log(f2)+...+log(fn)' where f1, f2, ..., fn are # the predictor fields. result_fun <- function(tb) { - .check_that(nrow(tb) > 0) + .check_content_data_frame(tb) n_rows_tb <- nrow(tb) # if no predictors_index are given, assume that all fields are used if (!.has(predictors_index)) - predictors_index <- 1:n_rows_tb + predictors_index <- seq_len(n_rows_tb) # get predictors names categories <- names(tb)[c(predictors_index)] # compute formula result - stats::as.formula(paste0( + stats::as.formula(paste( "factor(label)~", - paste0(paste0(categories, + paste(paste(categories, collapse = "+" )) )) diff --git a/R/sits_merge.R b/R/sits_merge.R index a71d1e34c..09b6ee57e 100644 --- a/R/sits_merge.R +++ b/R/sits_merge.R @@ -61,7 +61,8 @@ sits_merge <- function(data1, data2, ...) { sits_merge.sits <- function(data1, data2, ..., suffix = c(".1", ".2")) { .check_set_caller("sits_merge_sits") # precondition - data sets are not empty - .check_that(nrow(data1) > 0 & nrow(data2) > 0) + .check_content_data_frame(data1) + .check_content_data_frame(data2) # check that data2 and data1 are sits tibble .check_samples_ts(data1) .check_samples_ts(data2) @@ -74,8 +75,8 @@ sits_merge.sits <- function(data1, data2, ..., suffix = c(".1", ".2")) { coincidences1 <- bands1 %in% bands2 coincidences2 <- bands2 %in% bands1 if (any(coincidences1) || any(coincidences2)) { - bands1_names <- rep(x = suffix[[1]], length(coincidences1)) - bands2_names <- rep(x = suffix[[2]], length(coincidences2)) + bands1_names <- rep(x = suffix[[1L]], length(coincidences1)) + bands2_names <- rep(x = suffix[[2L]], length(coincidences2)) bands1[coincidences1] <- paste0(bands1[coincidences1], bands1_names[coincidences1] ) @@ -108,15 +109,7 @@ sits_merge.raster_cube <- function(data1, data2, ...) { .check_is_raster_cube(data1) .check_is_raster_cube(data2) # merge cubes - merged_cube <- .merge_switch( - data1 = data1, data2 = data2, - dem_case = .merge_dem(data1, data2), - hls_case = .merge_hls(data1, data2), - regular_case = .merge_regular(data1, data2), - irregular_case = .merge_irregular(data1, data2) - ) - # return - merged_cube + .merge(data1, data2) } #' @rdname sits_merge diff --git a/R/sits_mixture_model.R b/R/sits_mixture_model.R index 927309371..1a7116aae 100644 --- a/R/sits_mixture_model.R +++ b/R/sits_mixture_model.R @@ -115,12 +115,12 @@ sits_mixture_model <- function(data, endmembers, ...) { #' @export sits_mixture_model.sits <- function(data, endmembers, ..., rmse_band = TRUE, - multicores = 2, + multicores = 2L, progress = TRUE) { # Pre-conditions .check_samples_train(data) .check_lgl_parameter(rmse_band) - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) # Transform endmembers to tibble @@ -163,16 +163,18 @@ sits_mixture_model.sits <- function(data, endmembers, ..., #' @export sits_mixture_model.raster_cube <- function(data, endmembers, ..., rmse_band = TRUE, - memsize = 4, - multicores = 2, + memsize = 4L, + multicores = 2L, output_dir, progress = TRUE) { # Pre-conditions .check_is_raster_cube(data) .check_lgl_parameter(rmse_band) - .check_int_parameter(memsize, min = 1, max = 16384) + .check_int_parameter(memsize, min = 1L, max = 16384L) .check_output_dir(output_dir) .check_lgl_parameter(progress) + # show progress bar? + progress <- .message_progress(progress) # Transform endmembers to tibble em <- .endmembers_as_tbl(endmembers) # Check endmember format @@ -198,9 +200,9 @@ sits_mixture_model.raster_cube <- function(data, endmembers, ..., block <- .raster_file_blocksize(.raster_open_rast(.tile_path(data))) # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( - block_size = .block_size(block = block, overlap = 0), + block_size = .block_size(block = block, overlap = 0L), npaths = length(bands) + length(out_fracs), - nbytes = 8, + nbytes = 8L, proc_bloat = .conf("processing_bloat_cpu") ) # Update multicores parameter diff --git a/R/sits_mlp.R b/R/sits_mlp.R index 86e7f6966..51a2a89e9 100644 --- a/R/sits_mlp.R +++ b/R/sits_mlp.R @@ -99,7 +99,7 @@ #' sits_mlp <- function(samples = NULL, samples_validation = NULL, - layers = c(512, 512, 512), + layers = c(512L, 512L, 512L), dropout_rates = c(0.20, 0.30, 0.40), optimizer = torch::optim_adamw, opt_hparams = list( @@ -107,16 +107,18 @@ sits_mlp <- function(samples = NULL, eps = 1e-08, weight_decay = 1.0e-06 ), - epochs = 100, - batch_size = 64, + epochs = 100L, + batch_size = 64L, validation_split = 0.2, - patience = 20, + patience = 20L, min_delta = 0.01, verbose = FALSE) { # set caller for error msg .check_set_caller("sits_mlp") # Verifies if 'torch' and 'luz' packages is installed .check_require_packages(c("torch", "luz")) + # documentation mode? verbose is FALSE + verbose <- .message_verbose(verbose) # Function that trains a torch model based on samples train_fun <- function(samples) { # does not support working with DEM or other base data @@ -126,16 +128,16 @@ sits_mlp <- function(samples = NULL, self <- NULL # Check validation_split parameter if samples_validation is not passed if (is.null(samples_validation)) { - .check_num_parameter(validation_split, exclusive_min = 0, max = 0.5) + .check_num_parameter(validation_split, exclusive_min = 0.0, max = 0.5) } # Pre-conditions - checking parameters - .pre_sits_mlp(samples = samples, epochs = epochs, + .check_pre_sits_mlp(samples = samples, epochs = epochs, batch_size = batch_size, layers = layers, dropout_rates = dropout_rates, patience = patience, min_delta = min_delta, verbose = verbose) # Check opt_hparams # Get parameters list and remove the 'param' parameter - optim_params_function <- formals(optimizer)[-1] + optim_params_function <- formals(optimizer)[-1L] .check_opt_hparams(opt_hparams, optim_params_function) optim_params_function <- utils::modifyList( x = optim_params_function, @@ -176,30 +178,30 @@ sits_mlp <- function(samples = NULL, test_y <- unname(code_labels[.pred_references(test_samples)]) # Set torch seed - torch::torch_manual_seed(sample.int(10^5, 1)) + torch::torch_manual_seed(sample.int(100000L, 1L)) # Define the MLP architecture mlp_model <- torch::nn_module( initialize = function(num_pred, layers, dropout_rates, y_dim) { tensors <- list() # input layer - tensors[[1]] <- .torch_linear_relu_dropout( + tensors[[1L]] <- .torch_linear_relu_dropout( input_dim = num_pred, - output_dim = layers[[1]], - dropout_rate = dropout_rates[[1]] + output_dim = layers[[1L]], + dropout_rate = dropout_rates[[1L]] ) # if hidden layers is a vector then we add those layers - if (length(layers) > 1) { - for (i in 2:length(layers)) { - tensors[[length(tensors) + 1]] <- + if (length(layers) > 1L) { + for (i in 2L:length(layers)) { + tensors[[length(tensors) + 1L]] <- .torch_linear_batch_norm_relu_dropout( - input_dim = layers[[i - 1]], + input_dim = layers[[i - 1L]], output_dim = layers[[i]], dropout_rate = dropout_rates[[i]] ) } } # add output layer - tensors[[length(tensors) + 1]] <- + tensors[[length(tensors) + 1L]] <- torch::nn_linear(layers[length(layers)], y_dim) # softmax is done externally # create a sequential module that calls the layers @@ -249,7 +251,7 @@ sits_mlp <- function(samples = NULL, .check_require_packages("torch") # Set torch threads to 1 # Note: function does not work on MacOS - suppressWarnings(torch::torch_set_num_threads(1)) + suppressWarnings(torch::torch_set_num_threads(1L)) # Unserialize model torch_model[["model"]] <- .torch_unserialize_model(serialized_model) # Performs data normalization diff --git a/R/sits_mosaic.R b/R/sits_mosaic.R index c57da3e97..74c0b5e47 100644 --- a/R/sits_mosaic.R +++ b/R/sits_mosaic.R @@ -85,7 +85,7 @@ sits_mosaic <- function(cube, crs = "EPSG:3857", roi = NULL, - multicores = 2, + multicores = 2L, output_dir, version = "v1", progress = TRUE) { @@ -93,7 +93,7 @@ sits_mosaic <- function(cube, # Pre-conditions .check_is_raster_cube(cube) .check_crs(crs) - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) .check_output_dir(output_dir) # Check version and progress version <- .message_version(version) diff --git a/R/sits_patterns.R b/R/sits_patterns.R index 4e16b8f3f..496b61734 100644 --- a/R/sits_patterns.R +++ b/R/sits_patterns.R @@ -35,7 +35,7 @@ #' } #' #' @export -sits_patterns <- function(data = NULL, freq = 8, formula = y ~ s(x), ...) { +sits_patterns <- function(data = NULL, freq = 8L, formula = y ~ s(x), ...) { .check_set_caller("sits_patterns") # verifies if mgcv package is installed .check_require_packages("mgcv") @@ -53,8 +53,8 @@ sits_patterns <- function(data = NULL, freq = 8, formula = y ~ s(x), ...) { sample_dates <- lubridate::as_date(.samples_timeline(tb)) tb <- .tibble_align_dates(tb, sample_dates) # extract the start and and dates - start_date <- lubridate::as_date(utils::head(sample_dates, n = 1)) - end_date <- lubridate::as_date(utils::tail(sample_dates, n = 1)) + start_date <- lubridate::as_date(utils::head(sample_dates, n = 1L)) + end_date <- lubridate::as_date(utils::tail(sample_dates, n = 1L)) # determine the sequence of prediction times pred_time <- seq( from = lubridate::as_date(start_date), @@ -73,7 +73,7 @@ sits_patterns <- function(data = NULL, freq = 8, formula = y ~ s(x), ...) { # create a data frame to store the time instances time <- data.frame(as.numeric(pred_time)) # name the time as the second variable of the formula - names(time) <- vars[[2]] + names(time) <- vars[[2L]] # store the time series associated to the pattern index <- tibble::tibble(Index = lubridate::as_date(pred_time)) # calculate the fit for each band @@ -115,7 +115,7 @@ sits_patterns <- function(data = NULL, freq = 8, formula = y ~ s(x), ...) { res_label <- dplyr::bind_cols(index, res_label) # put the pattern in a list to store in a sits tibble ts <- tibble::lst() - ts[[1]] <- res_label + ts[[1L]] <- res_label # add the pattern to the results tibble tibble::tibble( longitude = 0.0, diff --git a/R/sits_plot.R b/R/sits_plot.R index 5cd6a7e78..fe4c0ff3a 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -51,7 +51,7 @@ plot.sits <- function(x, y, ..., together = FALSE) { # default value is set to empty char in case null .check_lgl_parameter(together) # Are there more than 30 samples? Plot them together! - if (together || nrow(x) > 30) { + if (together || nrow(x) > 30L) { p <- .plot_together(x) } else { # otherwise, take "allyears" as the default @@ -105,7 +105,7 @@ plot.patterns <- function(x, y, ..., bands = NULL, year_grid = FALSE) { function(label, ts) { lb <- as.character(label) # extract the time series and convert - tibble::tibble(Time = ts[["Index"]], ts[-1], Pattern = lb) + tibble::tibble(Time = ts[["Index"]], ts[-1L], Pattern = lb) } ) # create a data.frame by melting the values per bands @@ -197,7 +197,7 @@ plot.predicted <- function(x, y, ..., } # configure plot colors # get labels from predicted tibble - labels <- unique(x[["predicted"]][[1]][["class"]]) + labels <- unique(x[["predicted"]][[1L]][["class"]]) colors <- .colors_get( labels = labels, legend = NULL, @@ -205,7 +205,7 @@ plot.predicted <- function(x, y, ..., rev = FALSE ) # put the time series in the data frame - p <- purrr::pmap( + plots <- purrr::pmap( list( x[["latitude"]], x[["longitude"]], x[["label"]], x[["time_series"]], x[["predicted"]] @@ -235,7 +235,7 @@ plot.predicted <- function(x, y, ..., df_pol <- purrr::pmap_dfr( list( row_predicted[["from"]], row_predicted[["to"]], - row_predicted[["class"]], seq(1:nrows_p) + row_predicted[["class"]], seq(1L:nrows_p) ), function(rp_from, rp_to, rp_class, i) { best_class <- as.character(rp_class) @@ -247,11 +247,11 @@ plot.predicted <- function(x, y, ..., lubridate::as_date(rp_to), lubridate::as_date(rp_from) ), - Group = rep(i, 4), - Class = rep(best_class, 4), + Group = rep(i, 4L), + Class = rep(best_class, 4L), value = rep(range(y_breaks, na.rm = TRUE - ), each = 2) + ), each = 2L) ) } ) @@ -260,13 +260,13 @@ plot.predicted <- function(x, y, ..., df_pol[["Class"]] <- factor(df_pol[["Class"]]) df_pol[["Series"]] <- rep(lb, length(df_pol[["Time"]])) # temporal adjustments - create a time index - idx <- min(df_pol[["Time"]], na.rm = TRUE) - 30 <= df_x[["Time"]] & - df_x[["Time"]] <= max(df_pol[["Time"]], na.rm = TRUE) + 30 + idx <- min(df_pol[["Time"]], na.rm = TRUE) - 30L <= df_x[["Time"]] & + df_x[["Time"]] <= max(df_pol[["Time"]], na.rm = TRUE) + 30L df_x <- df_x[idx, , drop = FALSE] # plot facets gp <- ggplot2::ggplot() + ggplot2::facet_wrap(~Series, - scales = "free_x", ncol = 1 + scales = "free_x", ncol = 1L ) + ggplot2::geom_polygon( data = df_pol, @@ -289,7 +289,7 @@ plot.predicted <- function(x, y, ..., ) + ggplot2::scale_color_brewer(palette = "Set1") + ggplot2::scale_y_continuous( - expand = c(0, 0), + expand = c(0.0, 0.0), breaks = y_breaks, labels = y_labels ) + @@ -305,11 +305,10 @@ plot.predicted <- function(x, y, ..., ggplot2::ylab("Value") + ggplot2::xlab("Time") - g <- graphics::plot(gp) - g + graphics::plot(gp) } ) - p + invisible(plots) } #' @title Plot RGB data cubes #' @name plot.raster_cube @@ -405,7 +404,7 @@ plot.raster_cube <- function(x, ..., red = NULL, green = NULL, blue = NULL, - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], dates = NULL, roi = NULL, palette = "RdYlGn", @@ -413,7 +412,7 @@ plot.raster_cube <- function(x, ..., scale = 1.0, first_quantile = 0.02, last_quantile = 0.98, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside") { # check caller .check_set_caller(".plot_raster_cube") @@ -431,7 +430,7 @@ plot.raster_cube <- function(x, ..., .check_num_parameter(first_quantile, min = 0.0, max = 1.0) .check_num_parameter(last_quantile, min = 0.0, max = 1.0) # check COG size - .check_int_parameter(max_cog_size, min = 512) + .check_int_parameter(max_cog_size, min = 512L) # filter the tile to be processed tile <- .cube_filter_tiles(cube = x, tiles = tile) @@ -443,19 +442,21 @@ plot.raster_cube <- function(x, ..., dates <- as.Date(dots[["date"]]) # check dates - if (.has(dates)) + if (.has(dates)) { .check_dates_timeline(dates, tile) - else + } + else { dates <- .fi_date_least_cloud_cover(.fi(tile)) - + message(.conf("messages", ".plot_least_cloud_cover")) + } # get tmap_params from dots tmap_params <- .tmap_params_set(dots, legend_position) # deal with the case of same band in different dates - if (length(bands) == 1 && length(dates) == 3) { + if (length(bands) == 1L && length(dates) == 3L) { p <- .plot_band_multidate( tile = tile, - band = bands[[1]], + band = bands[[1L]], dates = dates, roi = roi, scale = scale, @@ -467,11 +468,11 @@ plot.raster_cube <- function(x, ..., return(p) } # single date - either false color (one band) or RGB - if (length(bands) == 1) { + if (length(bands) == 1L) { p <- .plot_false_color( tile = tile, - band = bands[[1]], - date = dates[[1]], + band = bands[[1L]], + date = dates[[1L]], roi = roi, sf_seg = NULL, seg_color = NULL, @@ -489,7 +490,7 @@ plot.raster_cube <- function(x, ..., p <- .plot_rgb( tile = tile, bands = bands, - date = dates[[1]], + date = dates[[1L]], roi = roi, sf_seg = NULL, seg_color = NULL, @@ -571,7 +572,7 @@ plot.sar_cube <- function(x, ..., red = NULL, green = NULL, blue = NULL, - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], dates = NULL, roi = NULL, palette = "Greys", @@ -579,7 +580,7 @@ plot.sar_cube <- function(x, ..., scale = 1.0, first_quantile = 0.05, last_quantile = 0.95, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside") { plot.raster_cube( @@ -651,12 +652,12 @@ plot.sar_cube <- function(x, ..., #' @export plot.dem_cube <- function(x, ..., band = "ELEVATION", - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], roi = NULL, palette = "Spectral", rev = TRUE, scale = 1.0, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside") { # check caller .check_set_caller(".plot_dem_cube") @@ -671,7 +672,7 @@ plot.dem_cube <- function(x, ..., # check rev .check_lgl_parameter(rev) # check COG size - .check_int_parameter(max_cog_size, min = 512) + .check_int_parameter(max_cog_size, min = 512L) # check scale parameter .check_num_parameter(scale, min = 0.2) # retrieve dots @@ -781,7 +782,7 @@ plot.vector_cube <- function(x, ..., red = NULL, green = NULL, blue = NULL, - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], dates = NULL, seg_color = "yellow", line_width = 0.3, @@ -790,7 +791,7 @@ plot.vector_cube <- function(x, ..., scale = 1.0, first_quantile = 0.02, last_quantile = 0.98, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside") { .check_set_caller(".plot_vector_cube") # precondition for tiles @@ -798,7 +799,7 @@ plot.vector_cube <- function(x, ..., # precondition for bands bands <- .band_set_bw_rgb(x, band, red, green, blue) # check palette - if (length(bands) == 1) { + if (length(bands) == 1L) { # check palette .check_palette(palette) # check rev @@ -812,7 +813,7 @@ plot.vector_cube <- function(x, ..., .check_num_parameter(first_quantile, min = 0.0, max = 1.0) .check_num_parameter(last_quantile, min = 0.0, max = 1.0) # check COG size - .check_int_parameter(max_cog_size, min = 512) + .check_int_parameter(max_cog_size, min = 512L) # retrieve dots dots <- list(...) # deal with wrong parameter "date" @@ -825,22 +826,22 @@ plot.vector_cube <- function(x, ..., tile <- .cube_filter_tiles(cube = x, tiles = tile) if (.has(dates)) { # is this a valid date? - dates <- as.Date(dates)[[1]] + dates <- as.Date(dates)[[1L]] .check_that(all(dates %in% .tile_timeline(tile)), msg = .conf("messages", ".plot_raster_cube_date") ) } else { - dates <- .tile_timeline(tile)[[1]] + dates <- .fi_date_least_cloud_cover(.fi(tile)) } # retrieve the segments for this tile sf_seg <- .segments_read_vec(tile) # BW or color? - if (length(bands) == 1) { + if (length(bands) == 1L) { # plot the band as false color p <- .plot_false_color( tile = tile, - band = bands[[1]], - date = dates[[1]], + band = bands[[1L]], + date = dates[[1L]], roi = NULL, sf_seg = sf_seg, seg_color = seg_color, @@ -858,7 +859,7 @@ plot.vector_cube <- function(x, ..., p <- .plot_rgb( tile = tile, bands = bands, - date = dates[[1]], + date = dates[[1L]], roi = NULL, sf_seg = sf_seg, seg_color = seg_color, @@ -917,14 +918,14 @@ plot.vector_cube <- function(x, ..., #' @export #' plot.probs_cube <- function(x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], roi = NULL, labels = NULL, palette = "YlGn", rev = FALSE, quantile = NULL, scale = 1.0, - max_cog_size = 512, + max_cog_size = 512L, legend_position = "outside", legend_title = "probs") { .check_set_caller(".plot_probs_cube") @@ -941,7 +942,7 @@ plot.probs_cube <- function(x, ..., # check quantile .check_num_parameter(quantile, min = 0.0, max = 1.0, allow_null = TRUE) # check COG size - .check_int_parameter(max_cog_size, min = 512) + .check_int_parameter(max_cog_size, min = 512L) # check legend position .check_legend_position(legend_position) # get tmap params from dots @@ -1016,7 +1017,7 @@ plot.probs_cube <- function(x, ..., #' @export #' plot.probs_vector_cube <- function(x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], labels = NULL, palette = "YlGn", rev = FALSE, @@ -1100,7 +1101,7 @@ plot.probs_vector_cube <- function(x, ..., #' @export #' plot.variance_cube <- function(x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], roi = NULL, labels = NULL, palette = "YlGnBu", @@ -1108,7 +1109,7 @@ plot.variance_cube <- function(x, ..., type = "map", quantile = 0.75, scale = 1.0, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside", legend_title = "logvar") { .check_set_caller(".plot_variance_cube") @@ -1126,7 +1127,7 @@ plot.variance_cube <- function(x, ..., # check quantile .check_num_parameter(quantile, min = 0.0, max = 1.0, allow_null = TRUE) # check COG size - .check_int_parameter(max_cog_size, min = 512) + .check_int_parameter(max_cog_size, min = 512L) # check legend position .check_legend_position(legend_position) # retrieve dots @@ -1207,14 +1208,14 @@ plot.variance_cube <- function(x, ..., #' @export #' plot.uncertainty_cube <- function(x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], roi = NULL, palette = "RdYlGn", rev = TRUE, scale = 1.0, first_quantile = 0.02, last_quantile = 0.98, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside") { .check_set_caller(".plot_uncertainty_cube") # precondition for tiles @@ -1230,7 +1231,7 @@ plot.uncertainty_cube <- function(x, ..., .check_num_parameter(first_quantile, min = 0.0, max = 1.0) .check_num_parameter(last_quantile, min = 0.0, max = 1.0) # check COG size - .check_int_parameter(max_cog_size, min = 512) + .check_int_parameter(max_cog_size, min = 512L) # check legend position .check_legend_position(legend_position) # get tmap params from dots @@ -1238,7 +1239,7 @@ plot.uncertainty_cube <- function(x, ..., tmap_params <- .tmap_params_set(dots, legend_position) # filter the cube - tile <- .cube_filter_tiles(cube = x, tiles = tile[[1]]) + tile <- .cube_filter_tiles(cube = x, tiles = tile[[1L]]) band <- .tile_bands(tile) # plot the data p <- .plot_false_color( @@ -1317,7 +1318,7 @@ plot.uncertainty_cube <- function(x, ..., #' @export #' plot.uncertainty_vector_cube <- function(x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], palette = "RdYlGn", rev = TRUE, scale = 1.0, @@ -1403,13 +1404,13 @@ plot.uncertainty_vector_cube <- function(x, ..., #' @export #' plot.class_cube <- function(x, y, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], roi = NULL, title = "Classified Image", legend = NULL, palette = "Spectral", scale = 1.0, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside") { stopifnot(missing(y)) # set caller to show in errors @@ -1423,7 +1424,7 @@ plot.class_cube <- function(x, y, ..., # check scale parameter .check_num_parameter(scale, min = 0.2) # check COG size - .check_int_parameter(max_cog_size, min = 512) + .check_int_parameter(max_cog_size, min = 512L) # check legend position .check_legend_position(legend_position) # check legend - convert to vector if legend is tibble @@ -1502,7 +1503,7 @@ plot.class_cube <- function(x, y, ..., #' } #' @export plot.class_vector_cube <- function(x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], legend = NULL, seg_color = "black", line_width = 0.5, @@ -1636,7 +1637,7 @@ plot.sits_accuracy <- function(x, y, ..., title = "Confusion matrix") { rev = TRUE ) - data <- tibble::as_tibble(t(prop.table(x[["table"]], margin = 2))) + data <- tibble::as_tibble(t(prop.table(x[["table"]], margin = 2L))) colnames(data) <- c("pred", "class", "conf_per") @@ -1654,7 +1655,7 @@ plot.sits_accuracy <- function(x, y, ..., title = "Confusion matrix") { ggplot2::theme_minimal() + ggplot2::theme( axis.text.x = - ggplot2::element_text(angle = 60, hjust = 1) + ggplot2::element_text(angle = 60.0, hjust = 1L) ) + ggplot2::labs(x = "Class", y = "Agreement with reference") + ggplot2::scale_fill_manual(name = "Class", values = colors) + @@ -1737,7 +1738,7 @@ plot.som_evaluate_cluster <- function(x, y, ..., ggplot2::theme_minimal() + ggplot2::theme( axis.text.x = - ggplot2::element_text(angle = 60, hjust = 1) + ggplot2::element_text(angle = 60.0, hjust = 1.0) ) + ggplot2::labs(x = "Class", y = "Percentage of mixture") + ggplot2::scale_fill_manual(name = "Class label", values = colors) + @@ -1797,7 +1798,7 @@ plot.som_map <- function(x, y, ..., names(bands_koh) <- bands whatmap <- bands_koh[[band]] } else { - whatmap <- 1 + whatmap <- 1L } @@ -1822,15 +1823,15 @@ plot.som_map <- function(x, y, ..., koh[["som_properties"]][["paint_map"]]) graphics::legend( "bottomright", - legend = unique(leg[, 1]), - col = unique(leg[, 2]), - pch = 15, - pt.cex = 2, - cex = 1, + legend = unique(leg[, 1L]), + col = unique(leg[, 2L]), + pch = 15L, + pt.cex = 2L, + cex = 1L, text.col = "black", inset = c(0.0095, 0.05), xpd = TRUE, - ncol = 1 + ncol = 1L ) return(invisible(x)) } @@ -1876,7 +1877,7 @@ plot.som_clean_samples <- function(x, ...) { dplyr::summarise(n = dplyr::n()) |> dplyr::mutate(n_class = sum(.data[["n"]])) |> dplyr::ungroup() |> - dplyr::mutate(percent = (.data[["n"]] / .data[["n_class"]]) * 100) |> + dplyr::mutate(percent = (.data[["n"]] / .data[["n_class"]]) * 100.0) |> dplyr::select(dplyr::all_of("label"), dplyr::all_of("eval"), dplyr::all_of("percent")) |> @@ -1887,7 +1888,7 @@ plot.som_clean_samples <- function(x, ...) { if (all_evals) { eval <- eval |> dplyr::select(c("label", "clean", "remove", "analyze")) |> - tidyr::replace_na(list(clean = 0, remove = 0, analyze = 0)) + tidyr::replace_na(list(clean = 0.0, remove = 0.0, analyze = 0.0)) pivot <- tidyr::pivot_longer(eval, cols = c("clean", "remove", "analyze"), @@ -1895,7 +1896,7 @@ plot.som_clean_samples <- function(x, ...) { } else { eval <- eval |> dplyr::select(c("label", "clean", "analyze")) |> - tidyr::replace_na(list(clean = 0, analyze = 0)) + tidyr::replace_na(list(clean = 0.0, analyze = 0.0)) pivot <- tidyr::pivot_longer(eval, cols = c("clean", "analyze"), names_to = "Eval", values_to = "value") colors_eval <- c("#C7BB3A", "#4FC78E") @@ -1917,7 +1918,7 @@ plot.som_clean_samples <- function(x, ...) { width = 0.9) + ggplot2::geom_text( ggplot2::aes( - label = scales::percent(value / 100, 1)), + label = scales::percent(value / 100.0, 1L)), position = ggplot2::position_stack(vjust = 0.5), color = "black", size = length(eval_labels), @@ -1926,8 +1927,8 @@ plot.som_clean_samples <- function(x, ...) { ggplot2::theme_classic() + ggplot2::theme( axis.title.y = ggplot2::element_blank(), - legend.title = ggplot2::element_text(size = 11), - legend.text = ggplot2::element_text(size = 9), + legend.title = ggplot2::element_text(size = 11L), + legend.text = ggplot2::element_text(size = 9L), legend.key.size = ggplot2::unit(0.5, "cm"), legend.spacing.y = ggplot2::unit(0.5, "cm"), legend.position = "right", @@ -1968,9 +1969,9 @@ plot.som_clean_samples <- function(x, ...) { #' @export #' plot.xgb_model <- function(x, ..., - trees = 0:4, - width = 1500, - height = 1900) { + trees = 0L:4L, + width = 1500L, + height = 1900L) { # verifies if DiagrammeR package is installed .check_require_packages("DiagrammeR") .check_is_sits_model(x) @@ -2028,43 +2029,40 @@ plot.torch_model <- function(x, y, ...) { .map_dfr(met, tibble::as_tibble_row) |> dplyr::mutate(epoch = seq_len(dplyr::n()), data = name) |> - tidyr::pivot_longer(cols = 1:2, names_to = "metric") + tidyr::pivot_longer(cols = 1L:2L, names_to = "metric") }) - p <- ggplot2::ggplot(metrics_dfr, ggplot2::aes( + ggplot2::ggplot(metrics_dfr, ggplot2::aes( x = .data[["epoch"]], y = .data[["value"]], color = .data[["data"]], - fill = .data[["data"]] - )) - - p <- p + ggplot2::geom_point( - shape = 21, col = 1, - na.rm = TRUE, size = 2 - ) + + fill = .data[["data"]]) + ) + + ggplot2::geom_point( + shape = 21L, col = 1L, + na.rm = TRUE, size = 2L + ) + ggplot2::geom_smooth( formula = y ~ x, se = FALSE, method = "loess", na.rm = TRUE - ) - - p <- p + ggplot2::facet_grid(metric ~ ., switch = "y", scales = "free_y") + + ) + + ggplot2::facet_grid(metric ~ ., switch = "y", scales = "free_y" + ) + ggplot2::theme( axis.title.y = ggplot2::element_blank(), strip.placement = "outside", strip.text = ggplot2::element_text( colour = "black", - size = 11 + size = 11L ), strip.background = ggplot2::element_rect( fill = NA, color = NA ) - ) - - p <- p + ggplot2::labs() - p + ) + + ggplot2::labs() } #' @title Make a kernel density plot of samples distances. @@ -2112,14 +2110,14 @@ plot.geo_distances <- function(x, y, ...) { return(invisible(NULL)) } distances |> - dplyr::mutate(distance = .data[["distance"]] / 1000) |> + dplyr::mutate(distance = .data[["distance"]] / 1000L) |> ggplot2::ggplot(ggplot2::aes(x = .data[["distance"]])) + ggplot2::geom_density( ggplot2::aes( color = .data[["type"]], fill = .data[["type"]] ), - linewidth = 1, alpha = 0.25 + linewidth = 1L, alpha = 0.25 ) + ggplot2::scale_x_log10(labels = scales::label_number()) + ggplot2::xlab("Distance (km)") + @@ -2195,7 +2193,7 @@ plot.sits_cluster <- function(x, ..., ) # plot cutree line if (.has(cutree_height)) { - graphics::abline(h = cutree_height, lty = 2) + graphics::abline(h = cutree_height, lty = 2L) } # plot legend @@ -2203,5 +2201,5 @@ plot.sits_cluster <- function(x, ..., fill = colors_leg, legend = .samples_labels(x) ) - return(invisible(dend)) + invisible(dend) } diff --git a/R/sits_reclassify.R b/R/sits_reclassify.R index ae0614368..1301f462a 100644 --- a/R/sits_reclassify.R +++ b/R/sits_reclassify.R @@ -135,8 +135,8 @@ sits_reclassify.class_cube <- function(cube, ..., .check_that(inherits(mask, "class_cube")) .check_raster_cube_files(mask) # check other params - .check_int_parameter(memsize, min = 1, max = 16384) - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(memsize, min = 1L, max = 16384L) + .check_int_parameter(multicores, min = 1L, max = 2048L) .check_output_dir(output_dir) # Check version and progress version <- .message_version(version) @@ -147,9 +147,9 @@ sits_reclassify.class_cube <- function(cube, ..., block <- .raster_file_blocksize(.raster_open_rast(.tile_path(cube))) # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( - block_size = .block_size(block = block, overlap = 0), - npaths = 2, - nbytes = 8, proc_bloat = .conf("processing_bloat_cpu") + block_size = .block_size(block = block, overlap = 0L), + npaths = 2L, + nbytes = 8L, proc_bloat = .conf("processing_bloat_cpu") ) # Update multicores parameter multicores <- .jobs_max_multicores( @@ -161,7 +161,7 @@ sits_reclassify.class_cube <- function(cube, ..., .parallel_start(workers = multicores) on.exit(.parallel_stop(), add = TRUE) # Capture expression - rules <- as.list(substitute(rules, environment()))[-1] + rules <- as.list(substitute(rules, environment()))[-1L] # Reclassify parameters checked in reclassify function # Create reclassification function reclassify_fn <- .reclassify_fn_expr( diff --git a/R/sits_reduce.R b/R/sits_reduce.R index 78a18d2c6..6922157fb 100644 --- a/R/sits_reduce.R +++ b/R/sits_reduce.R @@ -137,9 +137,9 @@ sits_reduce.raster_cube <- function(data, ..., .check_is_raster_cube(data) .check_cube_is_regular(data) # Check memsize - .check_num_parameter(memsize, min = 1, max = 16384) + .check_num_parameter(memsize, min = 1L, max = 16384L) # Check multicores - .check_num_parameter(multicores, min = 1, max = 2048) + .check_num_parameter(multicores, min = 1L, max = 2048L) # Check output_dir .check_output_dir(output_dir) @@ -166,9 +166,9 @@ sits_reduce.raster_cube <- function(data, ..., block <- .raster_file_blocksize(.raster_open_rast(.tile_path(data))) # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( - block_size = .block_size(block = block, overlap = 0), + block_size = .block_size(block = block, overlap = 0L), npaths = length(in_bands) * length(.tile_timeline(data)), - nbytes = 8, proc_bloat = .conf("processing_bloat_cpu") + nbytes = 8L, proc_bloat = .conf("processing_bloat_cpu") ) # Update multicores parameter to match estimated block size multicores <- .jobs_max_multicores( diff --git a/R/sits_reduce_imbalance.R b/R/sits_reduce_imbalance.R index c01cb3903..4d3f6008f 100644 --- a/R/sits_reduce_imbalance.R +++ b/R/sits_reduce_imbalance.R @@ -69,10 +69,10 @@ #' } #' @export sits_reduce_imbalance <- function(samples, - n_samples_over = 200, - n_samples_under = 400, + n_samples_over = 200L, + n_samples_under = 400L, method = "smote", - multicores = 2) { + multicores = 2L) { # set caller to show in errors .check_set_caller("sits_reduce_imbalance") # pre-conditions @@ -90,9 +90,9 @@ sits_reduce_imbalance <- function(samples, # params of output tibble lat <- 0.0 long <- 0.0 - start_date <- samples[["start_date"]][[1]] - end_date <- samples[["end_date"]][[1]] - cube <- samples[["cube"]][[1]] + start_date <- samples[["start_date"]][[1L]] + end_date <- samples[["end_date"]][[1L]] + cube <- samples[["cube"]][[1L]] timeline <- .samples_timeline(samples) # get classes to undersample classes_under <- samples |> @@ -107,7 +107,7 @@ sits_reduce_imbalance <- function(samples, # create an output tibble new_samples <- .tibble() # under sampling - if (length(classes_under) > 0) { + if (.has(classes_under)) { # undersample classes with lots of data samples_under_new <- .som_undersample( samples = samples, @@ -119,7 +119,7 @@ sits_reduce_imbalance <- function(samples, new_samples <- dplyr::bind_rows(new_samples, samples_under_new) } # oversampling - if (length(classes_over) > 0) { + if (.has(classes_over)) { .parallel_start(workers = multicores) on.exit(.parallel_stop()) # for each class, build synthetic samples using SMOTE @@ -131,7 +131,7 @@ sits_reduce_imbalance <- function(samples, .samples_select_bands(band) |> dplyr::filter(.data[["label"]] == cls) |> .predictors() - dist_band <- dist_band[-1] + dist_band <- dist_band[-1L] # oversampling of band for the class dist_over <- .smote_oversample( data = dist_band, @@ -143,7 +143,7 @@ sits_reduce_imbalance <- function(samples, samples_band <- slider::slide_dfr(dist_over, function(row) { time_series <- tibble::tibble( Index = as.Date(timeline), - values = unname(as.numeric(row[-1])) + values = unname(as.numeric(row[-1L])) ) colnames(time_series) <- c("Index", band) tibble::tibble( @@ -159,8 +159,8 @@ sits_reduce_imbalance <- function(samples, class(samples_band) <- c("sits", class(samples_band)) samples_band }) - tb_class_new <- samples_bands[[1]] - for (i in seq_along(samples_bands)[-1]) { + tb_class_new <- samples_bands[[1L]] + for (i in seq_along(samples_bands)[-1L]) { tb_class_new <- sits_merge(tb_class_new, samples_bands[[i]]) } tb_class_new @@ -172,7 +172,7 @@ sits_reduce_imbalance <- function(samples, # keep classes (no undersampling nor oversampling) classes_ok <- samples_labels[!(samples_labels %in% classes_under | samples_labels %in% classes_over)] - if (length(classes_ok) > 0) { + if (.has(classes_ok)) { samples_classes_ok <- dplyr::filter( samples, .data[["label"]] %in% classes_ok diff --git a/R/sits_regularize.R b/R/sits_regularize.R index 6500fd81b..a25415289 100644 --- a/R/sits_regularize.R +++ b/R/sits_regularize.R @@ -169,7 +169,7 @@ sits_regularize.raster_cube <- function(cube, ..., # check period .check_period(period) # check resolution - .check_num_parameter(res, exclusive_min = 0) + .check_num_parameter(res, exclusive_min = 0.0) # check output_dir output_dir <- .file_path_expand(output_dir) .check_output_dir(output_dir) @@ -178,7 +178,7 @@ sits_regularize.raster_cube <- function(cube, ..., .check_roi_tiles(roi, tiles) } # check multicores - .check_num_parameter(multicores, min = 1, max = 2048) + .check_num_parameter(multicores, min = 1L, max = 2048L) # check progress progress <- .message_progress(progress) # Does cube contain cloud band? If not, issue a warning @@ -187,10 +187,10 @@ sits_regularize.raster_cube <- function(cube, ..., crs <- NULL if (.roi_type(roi) == "bbox" && !.has(roi[["crs"]])) { crs <- .crs(cube) - if (length(crs) > 1) + if (length(crs) > 1L) .message_warnings_regularize_crs() } - roi <- .roi_as_sf(roi, default_crs = crs[[1]]) + roi <- .roi_as_sf(roi, default_crs = crs[[1L]]) } # Convert input cube to the user's provided grid system if (.has(grid_system)) { @@ -238,10 +238,10 @@ sits_regularize.sar_cube <- function(cube, ..., # Preconditions .check_raster_cube_files(cube) .check_period(period) - .check_num_parameter(res, exclusive_min = 0) + .check_num_parameter(res, exclusive_min = 0.0) output_dir <- .file_path_expand(output_dir) .check_output_dir(output_dir) - .check_num_parameter(multicores, min = 1, max = 2048) + .check_num_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) # check for ROI and tiles if (!is.null(roi) || !is.null(tiles)) { @@ -260,7 +260,7 @@ sits_regularize.sar_cube <- function(cube, ..., tiles = tiles ) .check_that(nrow(cube) > 0, - msg = .conf("messages", "sits_regularize_roi") + msg = .conf("messages", "sits_regularize_roi") ) # Filter tiles if (is.character(tiles)) { @@ -296,10 +296,10 @@ sits_regularize.combined_cube <- function(cube, ..., # Preconditions .check_raster_cube_files(cube) .check_period(period) - .check_num_parameter(res, exclusive_min = 0) + .check_num_parameter(res, exclusive_min = 0.0) output_dir <- .file_path_expand(output_dir) .check_output_dir(output_dir) - .check_num_parameter(multicores, min = 1, max = 2048) + .check_num_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) # check for ROI and tiles .check_roi_tiles(roi, tiles) @@ -352,10 +352,10 @@ sits_regularize.rainfall_cube <- function(cube, ..., # Preconditions .check_raster_cube_files(cube) .check_period(period) - .check_num_parameter(res, exclusive_min = 0) + .check_num_parameter(res, exclusive_min = 0.0) output_dir <- .file_path_expand(output_dir) .check_output_dir(output_dir) - .check_num_parameter(multicores, min = 1, max = 2048) + .check_num_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) # check for ROI and tiles if (!is.null(roi) || !is.null(tiles)) { @@ -373,9 +373,7 @@ sits_regularize.rainfall_cube <- function(cube, ..., roi = roi, tiles = tiles ) - .check_that(nrow(cube) > 0, - msg = .conf("messages", "sits_regularize_roi") - ) + .check_content_data_frame(cube) # Filter tiles if (is.character(tiles)) { cube <- .cube_filter_tiles(cube, tiles) @@ -407,10 +405,10 @@ sits_regularize.dem_cube <- function(cube, ..., progress = TRUE) { # Preconditions .check_raster_cube_files(cube) - .check_num_parameter(res, exclusive_min = 0) + .check_num_parameter(res, exclusive_min = 0L) output_dir <- .file_path_expand(output_dir) .check_output_dir(output_dir) - .check_num_parameter(multicores, min = 1, max = 2048) + .check_num_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) # check for ROI and tiles if (!is.null(roi) || !is.null(tiles)) { @@ -425,9 +423,7 @@ sits_regularize.dem_cube <- function(cube, ..., roi = roi, tiles = tiles ) - .check_that(nrow(cube) > 0, - msg = .conf("messages", "sits_regularize_roi") - ) + .check_content_data_frame(cube) # Filter tiles if (is.character(tiles)) { cube <- .cube_filter_tiles(cube, tiles) diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R index 0d17737a2..54f82452d 100644 --- a/R/sits_sample_functions.R +++ b/R/sits_sample_functions.R @@ -116,19 +116,19 @@ sits_sample <- function(data, #' } #' @export sits_confidence_sampling <- function(probs_cube, - n = 20, + n = 20L, min_margin = 0.90, - sampling_window = 10, - multicores = 1, - memsize = 1) { + sampling_window = 10L, + multicores = 2L, + memsize = 4L) { .check_set_caller("sits_confidence_sampling") # Pre-conditions .check_is_probs_cube(probs_cube) - .check_int_parameter(n, min = 20) + .check_int_parameter(n, min = 20L) .check_num_parameter(min_margin, min = 0.01, max = 1.0) - .check_int_parameter(sampling_window, min = 10) - .check_int_parameter(multicores, min = 1, max = 2048) - .check_int_parameter(memsize, min = 1, max = 16384) + .check_int_parameter(sampling_window, min = 10L) + .check_int_parameter(multicores, min = 1L, max = 2048L) + .check_int_parameter(memsize, min = 1L, max = 16384L) # get labels labels <- .cube_labels(probs_cube) @@ -138,12 +138,12 @@ sits_confidence_sampling <- function(probs_cube, # Get block size block <- .raster_file_blocksize(.raster_open_rast(.tile_path(probs_cube))) # Overlapping pixels - overlap <- ceiling(sampling_window / 2) - 1 + overlap <- ceiling(sampling_window / 2L) - 1L # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( block_size = .block_size(block = block, overlap = overlap), npaths = sampling_window, - nbytes = 8, + nbytes = 8L, proc_bloat = .conf("processing_bloat_cpu") ) # Update multicores parameter @@ -233,7 +233,7 @@ sits_confidence_sampling <- function(probs_cube, dplyr::filter(.data[["n"]] < !!n) |> dplyr::pull("label") - if (length(incomplete_labels) > 0) { + if (.has(incomplete_labels)) { warning(.conf("messages", "sits_confidence_sampling_window"), toString(incomplete_labels), call. = FALSE @@ -241,7 +241,7 @@ sits_confidence_sampling <- function(probs_cube, } class(result_tb) <- c("sits_confidence", "sits", class(result_tb)) - return(result_tb) + result_tb } #' @title Allocation of sample size to strata @@ -304,7 +304,7 @@ sits_confidence_sampling <- function(probs_cube, #' @export sits_sampling_design <- function(cube, expected_ua = 0.75, - alloc_options = c(100, 75, 50), + alloc_options = c(100L, 75L, 50L), std_err = 0.01, rare_class_prop = 0.1) { .check_set_caller("sits_sampling_design") @@ -314,7 +314,7 @@ sits_sampling_design <- function(cube, # get the labels labels <- .cube_labels(cube) n_labels <- length(labels) - if (length(expected_ua) == 1) { + if (length(expected_ua) == 1L) { expected_ua <- rep(expected_ua, n_labels) names(expected_ua) <- labels } @@ -337,9 +337,9 @@ sits_sampling_design <- function(cube, # calculate proportion of class areas prop <- class_areas / sum(class_areas) # standard deviation of the stratum - std_dev <- signif(sqrt(expected_ua * (1 - expected_ua)), 3) + std_dev <- signif(sqrt(expected_ua * (1.0 - expected_ua)), 3L) # calculate sample size - sample_size <- round((sum(prop * std_dev) / std_err) ^ 2) + sample_size <- round((sum(prop * std_dev) / std_err) ^ 2L) # determine "equal" allocation n_classes <- length(class_areas) equal <- rep(round(sample_size / n_classes), n_classes) @@ -462,7 +462,7 @@ sits_stratified_sampling <- function(cube, msg = .conf("messages", "sits_stratified_sampling_samples") ) # check multicores - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) # check progress progress <- .message_progress(progress) # transform labels to tibble diff --git a/R/sits_segmentation.R b/R/sits_segmentation.R index c84aec91d..25a99a2bf 100644 --- a/R/sits_segmentation.R +++ b/R/sits_segmentation.R @@ -129,7 +129,7 @@ sits_segment <- function(cube, # Preconditions .check_is_raster_cube(cube) .check_cube_is_regular(cube) - .check_int_parameter(memsize, min = 1, max = 16384) + .check_int_parameter(memsize, min = 1L, max = 16384L) .check_output_dir(output_dir) # Check version and progress version <- .message_version(version) @@ -156,9 +156,9 @@ sits_segment <- function(cube, block <- .raster_file_blocksize(.raster_open_rast(.tile_path(cube))) # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( - block_size = .block_size(block = block, overlap = 0), + block_size = .block_size(block = block, overlap = 0L), npaths = length(.tile_paths(cube)), - nbytes = 8, + nbytes = 8L, proc_bloat = .conf("processing_bloat_seg") ) # Update multicores parameter @@ -286,7 +286,7 @@ sits_segment <- function(cube, #' @export sits_slic <- function(data = NULL, step = 30L, - compactness = 1, + compactness = 1.0, dist_fun = "euclidean", avg_fun = "median", iter = 30L, @@ -295,13 +295,15 @@ sits_slic <- function(data = NULL, # set caller for error msg .check_set_caller("sits_slic") # step is OK? - .check_int_parameter(step, min = 1, max = 500) + .check_int_parameter(step, min = 1L, max = 500L) # compactness is OK? - .check_num_parameter(compactness, min = 0.1, max = 50) + .check_num_parameter(compactness, min = 0.1, max = 50.0) # iter is OK? - .check_int_parameter(iter, min = 10, max = 100) + .check_int_parameter(iter, min = 10L, max = 100L) # minarea is OK? - .check_int_parameter(minarea, min = 1, max = 50) + .check_int_parameter(minarea, min = 1L, max = 50L) + # documentation mode? verbose is FALSE + verbose <- .message_verbose(verbose) function(data, block, bbox) { # Create a template rast @@ -309,7 +311,7 @@ sits_slic <- function(data = NULL, nrows = block[["nrows"]], ncols = block[["ncols"]], xmin = bbox[["xmin"]], xmax = bbox[["xmax"]], ymin = bbox[["ymin"]], ymax = bbox[["ymax"]], - nlayers = 1, crs = bbox[["crs"]] + nlayers = 1L, crs = bbox[["crs"]] ) # Get raster dimensions mat <- as.integer( @@ -325,36 +327,36 @@ sits_slic <- function(data = NULL, clean = TRUE, centers = TRUE, dist_name = dist_fun, dist_fun = function() "", avg_fun_fun = function() "", avg_fun_name = avg_fun, iter = iter, minarea = minarea, - input_centers = matrix(c(0L, 0L), ncol = 2), + input_centers = matrix(c(0L, 0L), ncol = 2L), verbose = as.integer(verbose) ) # Set values and NA value in template raster - v_obj <- .raster_set_values(v_temp, slic[[1]]) - v_obj <- .raster_set_na(v_obj, -1) + v_obj <- .raster_set_values(v_temp, slic[[1L]]) + v_obj <- .raster_set_na(v_obj, -1L) # Extract polygons raster and convert to sf object v_obj <- .raster_extract_polygons(v_obj, dissolve = TRUE) v_obj <- sf::st_as_sf(v_obj) - if (nrow(v_obj) == 0) { + if (nrow(v_obj) == 0L) { return(v_obj) } # Get valid centers - valid_centers <- slic[[2]][, 1] != 0 | slic[[2]][, 2] != 0 + valid_centers <- slic[[2L]][, 1L] != 0L | slic[[2L]][, 2L] != 0L # Bind valid centers with segments table v_obj <- cbind( - v_obj, matrix(stats::na.omit(slic[[2]][valid_centers, ]), ncol = 2) + v_obj, matrix(stats::na.omit(slic[[2L]][valid_centers, ]), ncol = 2L) ) # Rename columns names(v_obj) <- c("supercells", "x", "y", "geometry") # Get the extent of template raster v_ext <- .raster_bbox(v_temp) # Calculate pixel position by rows and cols - xres <- v_obj[["x"]] * .raster_xres(v_temp) + .raster_xres(v_temp) / 2 - yres <- v_obj[["y"]] * .raster_yres(v_temp) - .raster_yres(v_temp) / 2 - v_obj[["x"]] <- as.vector(v_ext)[[1]] + xres - v_obj[["y"]] <- as.vector(v_ext)[[4]] - yres + xres <- v_obj[["x"]] * .raster_xres(v_temp) + .raster_xres(v_temp) / 2L + yres <- v_obj[["y"]] * .raster_yres(v_temp) - .raster_yres(v_temp) / 2L + v_obj[["x"]] <- as.vector(v_ext)[[1L]] + xres + v_obj[["y"]] <- as.vector(v_ext)[[4L]] - yres # Get only polygons segments - v_obj <- sf::st_collection_extract(v_obj, "POLYGON") + v_obj <- suppressWarnings(sf::st_collection_extract(v_obj, "POLYGON")) # Return the segment object - return(v_obj) + v_obj } } diff --git a/R/sits_select.R b/R/sits_select.R index 41dce6abd..c307446dd 100644 --- a/R/sits_select.R +++ b/R/sits_select.R @@ -56,7 +56,7 @@ sits_select.sits <- function(data, ..., .check_chr_parameter(bands, allow_empty = FALSE, allow_duplicate = FALSE, - len_min = 1, + len_min = 1L, len_max = length(.samples_bands(data)) ) diff --git a/R/sits_smooth.R b/R/sits_smooth.R index 1e164c1bf..66cc8faa4 100644 --- a/R/sits_smooth.R +++ b/R/sits_smooth.R @@ -116,7 +116,7 @@ sits_smooth <- function(cube, ...) { sits_smooth.probs_cube <- function(cube, ..., window_size = 9L, neigh_fraction = 0.5, - smoothness = 20, + smoothness = 20.0, exclusion_mask = NULL, memsize = 4L, multicores = 2L, @@ -125,13 +125,13 @@ sits_smooth.probs_cube <- function(cube, ..., # Check if cube has probability data .check_raster_cube_files(cube) # check window size - .check_int_parameter(window_size, min = 3, max = 33, is_odd = TRUE) + .check_int_parameter(window_size, min = 3L, max = 33L, is_odd = TRUE) # check neighborhood fraction - .check_num_parameter(neigh_fraction, min = 0., max = 1.0) + .check_num_parameter(neigh_fraction, min = 0.0, max = 1.0) # Check memsize - .check_int_parameter(memsize, min = 1, max = 16384) + .check_int_parameter(memsize, min = 1L, max = 16384L) # Check multicores - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) # Check output dir output_dir <- path.expand(output_dir) .check_output_dir(output_dir) @@ -142,7 +142,7 @@ sits_smooth.probs_cube <- function(cube, ..., # Check smoothness .check_smoothness(smoothness, nlabels) # Prepare smoothness parameter - if (length(smoothness) == 1) { + if (length(smoothness) == 1L) { smoothness <- rep(smoothness, nlabels) } # version is case-insensitive in sits @@ -150,7 +150,7 @@ sits_smooth.probs_cube <- function(cube, ..., # get nlabels nlabels <- length(.cube_labels(cube)) # Prepare smoothness parameter - if (length(smoothness) == 1) { + if (length(smoothness) == 1L) { smoothness <- rep(smoothness, nlabels) } @@ -159,12 +159,12 @@ sits_smooth.probs_cube <- function(cube, ..., # Get block size block <- .raster_file_blocksize(.raster_open_rast(.tile_path(cube))) # Overlapping pixels - overlap <- ceiling(window_size / 2) - 1 + overlap <- ceiling(window_size / 2L) - 1L # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( block_size = .block_size(block = block, overlap = overlap), - npaths = length(.tile_labels(cube)) * 2, - nbytes = 8, + npaths = length(.tile_labels(cube)) * 2L, + nbytes = 8L, proc_bloat = .conf("processing_bloat_cpu") ) # Update multicores parameter diff --git a/R/sits_som.R b/R/sits_som.R index b917c6ef9..0f62ad27f 100644 --- a/R/sits_som.R +++ b/R/sits_som.R @@ -98,12 +98,12 @@ #' #' @export sits_som_map <- function(data, - grid_xdim = 10, - grid_ydim = 10, + grid_xdim = 10L, + grid_ydim = 10L, alpha = 1.0, - rlen = 100, + rlen = 100L, distance = "dtw", - som_radius = 2, + som_radius = 2L, mode = "online") { # set caller to show in errors .check_set_caller("sits_som_map") @@ -118,8 +118,8 @@ sits_som_map <- function(data, # is are there more neurons than samples? n_samples <- nrow(data) # check recommended grid sizes - min_grid_size <- floor(sqrt(5 * sqrt(n_samples))) - 2 - max_grid_size <- ceiling(sqrt(5 * sqrt(n_samples))) + 2 + min_grid_size <- floor(sqrt(5L * sqrt(n_samples))) - 2L + max_grid_size <- ceiling(sqrt(5L * sqrt(n_samples))) + 2L if (grid_xdim < min_grid_size || grid_xdim > max_grid_size) warning(.conf("messages", "sits_som_map_grid_size"), "(", min_grid_size, " ...", max_grid_size, ")" @@ -160,7 +160,7 @@ sits_som_map <- function(data, som_radius ) # get the list of labels for maximum a priori probability - lab_max <- seq(1:(grid_xdim * grid_ydim)) |> + lab_max <- seq_len(grid_xdim * grid_ydim) |> purrr::map(function(neuron_id) { labels_neuron <- dplyr::filter( labelled_neurons, @@ -176,7 +176,7 @@ sits_som_map <- function(data, label_max_final <- which.max(labels_neuron[["prior_prob"]]) # if more than one sample has been mapped AND their max are the # same, then a posteriori probability is considered - if (length(number_of_label_max) > 1) { + if (length(number_of_label_max) > 1L) { # Get the maximum posterior among the tied classes max_post <- max( labels_neuron[number_of_label_max, ][["post_prob"]] @@ -369,17 +369,17 @@ sits_som_evaluate_cluster <- function(som_map) { )) # get dimensions (rows and col) # rows are original classes of samples - dim_row <- dim(confusion_matrix)[[1]] + dim_row <- dim(confusion_matrix)[[1L]] # cols are clusters - dim_col <- dim(confusion_matrix)[[2]] + dim_col <- dim(confusion_matrix)[[2L]] # estimate the purity index per cluster - cluster_purity_lst <- seq_len(dim_col - 1) |> + cluster_purity_lst <- seq_len(dim_col - 1L) |> purrr::map(function(d) { - current_col <- confusion_matrix[1:dim_row - 1, d] + current_col <- confusion_matrix[seq_len(dim_row - 1L), d] current_col_total <- confusion_matrix[dim_row, d] # get mixture percentage per cluster mixture_percentage <- as.numeric( - (current_col / current_col_total) * 100 + (current_col / current_col_total) * 100L ) nrows <- length(mixture_percentage) current_class_ambiguity <- tibble::tibble( @@ -390,7 +390,7 @@ sits_som_evaluate_cluster <- function(som_map) { ) # remove lines where mix_percentege is zero dplyr::filter(current_class_ambiguity, - .data[["mixture_percentage"]] > 0 + .data[["mixture_percentage"]] > 0.0 ) }) purity_by_cluster <- do.call(rbind, cluster_purity_lst) diff --git a/R/sits_stars.R b/R/sits_stars.R index acac72b9e..fb22b59d3 100644 --- a/R/sits_stars.R +++ b/R/sits_stars.R @@ -34,14 +34,14 @@ #' } #' @export sits_as_stars <- function(cube, - tile = cube[1, ]$tile, + tile = cube[1L, ]$tile, bands = NULL, dates = NULL, proxy = FALSE) { # Pre-conditions .check_set_caller("sits_as_stars") .check_is_raster_cube(cube) - .check_chr_parameter(tile, len_max = 1) + .check_chr_parameter(tile, len_max = 1L) .check_chr_contains(cube[["tile"]], contains = tile, discriminator = "any_of", msg = .conf("messages", "sits_as_stars_tile")) @@ -62,7 +62,7 @@ sits_as_stars <- function(cube, if (.has(dates)) { # proxy? only one date is retrieved if (proxy) - dates <- dates[[1]] + dates <- dates[[1L]] .check_dates_timeline(dates, tile_cube) fi <- .fi_filter_dates(fi, dates) } else { diff --git a/R/sits_summary.R b/R/sits_summary.R index 097e10c18..2c967ad3c 100644 --- a/R/sits_summary.R +++ b/R/sits_summary.R @@ -177,9 +177,9 @@ summary.raster_cube <- function(object, ..., tile = NULL, date = NULL) { cli::cli_h1("Cube Summary") cube_sum <- slider::slide(object, function(tile) { # Get the first date to not read all images - date <- .default(date, .tile_timeline(tile)[[1]]) + date <- .default(date, .tile_timeline(tile)[[1L]]) tile <- .tile_filter_dates(tile, date) - bands <- if (is_regular) .tile_bands(tile) else .tile_bands(tile)[[1]] + bands <- if (is_regular) .tile_bands(tile) else .tile_bands(tile)[[1L]] tile <- .tile_filter_bands(tile, bands) cli::cli_h3("Tile: {.field {tile$tile}} and Date: {.field {date}}") rast <- .raster_open_rast(.tile_paths(tile)) @@ -225,7 +225,7 @@ summary.raster_cube <- function(object, ..., tile = NULL, date = NULL) { #' } #' #' @export -summary.derived_cube <- function(object, ..., sample_size = 10000) { +summary.derived_cube <- function(object, ..., sample_size = 10000L) { .check_set_caller("summary_derived_cube") # Extract variance values for each tiles using a sample size var_values <- slider::slide(object, function(tile) { @@ -293,7 +293,7 @@ summary.derived_cube <- function(object, ..., sample_size = 10000) { summary.variance_cube <- function( object, ..., intervals = 0.05, - sample_size = 10000, + sample_size = 10000L, quantiles = c("75%", "80%", "85%", "90%", "95%", "100%")) { .check_set_caller("summary_variance_cube") # Get cube labels @@ -324,11 +324,12 @@ summary.variance_cube <- function( var_values <- dplyr::reframe( var_values, dplyr::across(.cols = dplyr::all_of(labels), function(x) { - stats::quantile(x, probs = seq(0, 1, intervals)) + stats::quantile(x, probs = seq(0L, 1L, intervals)) }) ) # Update row names - percent_intervals <- paste0(seq(from = 0, to = 1, by = intervals)*100, "%") + percent_intervals <- paste0(seq(from = 0L, to = 1L, + by = intervals) * 100L, "%") rownames(var_values) <- percent_intervals # Return variance values filtered by quantiles return(var_values[quantiles, ]) @@ -379,7 +380,7 @@ summary.class_cube <- function(object, ...) { class_areas <- .raster_freq(r) # transform to km^2 cell_size <- .tile_xres(tile) * .tile_yres(tile) - class_areas[["area"]] <- (class_areas[["count"]] * cell_size) / 10^6 + class_areas[["area"]] <- (class_areas[["count"]] * cell_size) / 1000000L # change value to character class_areas <- dplyr::mutate( class_areas, value = as.character(.data[["value"]]) @@ -391,12 +392,12 @@ summary.class_cube <- function(object, ...) { # join the labels with the areas sum_areas <- dplyr::full_join(df1, class_areas, by = "value") sum_areas <- dplyr::mutate(sum_areas, - area_km2 = signif(.data[["area"]], 2), + area_km2 = signif(.data[["area"]], 2L), .keep = "unused" ) # remove layer information - sum_clean <- sum_areas[, -3] |> - tidyr::replace_na(list(layer = 1, count = 0, area_km2 = 0)) + sum_clean <- sum_areas[, -3L] |> + tidyr::replace_na(list(layer = 1L, count = 0L, area_km2 = 0.0)) sum_clean }) diff --git a/R/sits_tae.R b/R/sits_tae.R index d3d05cdb2..dc5c6ff66 100644 --- a/R/sits_tae.R +++ b/R/sits_tae.R @@ -98,8 +98,8 @@ #' @export sits_tae <- function(samples = NULL, samples_validation = NULL, - epochs = 150, - batch_size = 64, + epochs = 150L, + batch_size = 64L, validation_split = 0.2, optimizer = torch::optim_adamw, opt_hparams = list( @@ -107,15 +107,17 @@ sits_tae <- function(samples = NULL, eps = 1e-08, weight_decay = 1.0e-06 ), - lr_decay_epochs = 1, + lr_decay_epochs = 1L, lr_decay_rate = 0.95, - patience = 20, + patience = 20L, min_delta = 0.01, verbose = FALSE) { # set caller for error msg .check_set_caller("sits_tae") # Verifies if 'torch' and 'luz' packages is installed .check_require_packages(c("torch", "luz")) + # documentation mode? verbose is FALSE + verbose <- .message_verbose(verbose) # Function that trains a torch model based on samples train_fun <- function(samples) { # Add a global variable for 'self' @@ -125,7 +127,7 @@ sits_tae <- function(samples = NULL, stop(.conf("messages", "sits_train_base_data"), call. = FALSE) # Pre-conditions: # Pre-conditions - .pre_sits_lighttae(samples = samples, epochs = epochs, + .check_pre_sits_lighttae(samples = samples, epochs = epochs, batch_size = batch_size, lr_decay_epochs = lr_decay_epochs, lr_decay_rate = lr_decay_rate, @@ -133,11 +135,11 @@ sits_tae <- function(samples = NULL, verbose = verbose) # Check validation_split parameter if samples_validation is not passed if (is.null(samples_validation)) { - .check_num_parameter(validation_split, exclusive_min = 0, max = 0.5) + .check_num_parameter(validation_split, exclusive_min = 0.0, max = 0.5) } # Check opt_hparams # Get parameters list and remove the 'param' parameter - optim_params_function <- formals(optimizer)[-1] + optim_params_function <- formals(optimizer)[-1L] .check_opt_hparams(opt_hparams, optim_params_function) optim_params_function <- utils::modifyList( x = optim_params_function, @@ -188,15 +190,15 @@ sits_tae <- function(samples = NULL, ) test_y <- unname(code_labels[.pred_references(test_samples)]) # Set torch seed - torch::torch_manual_seed(sample.int(10^5, 1)) + torch::torch_manual_seed(sample.int(100000L, 1L)) # Define the PSE-TAE model pse_tae_model <- torch::nn_module( classname = "model_pse_tae", initialize = function(n_bands, n_labels, timeline, - dim_input_decoder = 128, - dim_layers_decoder = c(64, 32)) { + dim_input_decoder = 128L, + dim_layers_decoder = c(64L, 32L)) { # define an spatial encoder self$spatial_encoder <- .torch_pixel_spatial_encoder(n_bands = n_bands) @@ -206,7 +208,7 @@ sits_tae <- function(samples = NULL, # add a final layer to the decoder # with a dimension equal to the number of layers - dim_layers_decoder[length(dim_layers_decoder) + 1] <- n_labels + dim_layers_decoder[length(dim_layers_decoder) + 1L] <- n_labels self$decoder <- .torch_multi_linear_batch_norm_relu( dim_input_decoder, dim_layers_decoder @@ -268,7 +270,7 @@ sits_tae <- function(samples = NULL, .check_require_packages("torch") # Set torch threads to 1 # Note: function does not work on MacOS - suppressWarnings(torch::torch_set_num_threads(1)) + suppressWarnings(torch::torch_set_num_threads(1L)) # Unserialize model torch_model[["model"]] <- .torch_unserialize_model(serialized_model) # Transform input into a 3D tensor diff --git a/R/sits_tempcnn.R b/R/sits_tempcnn.R index d84adb41f..594f45a7e 100644 --- a/R/sits_tempcnn.R +++ b/R/sits_tempcnn.R @@ -99,13 +99,13 @@ #' @export sits_tempcnn <- function(samples = NULL, samples_validation = NULL, - cnn_layers = c(64, 64, 64), - cnn_kernels = c(5, 5, 5), + cnn_layers = c(64L, 64L, 64L), + cnn_kernels = c(5L, 5L, 5L), cnn_dropout_rates = c(0.20, 0.20, 0.20), - dense_layer_nodes = 256, + dense_layer_nodes = 256L, dense_layer_dropout_rate = 0.50, - epochs = 150, - batch_size = 64, + epochs = 150L, + batch_size = 64L, validation_split = 0.2, optimizer = torch::optim_adamw, opt_hparams = list( @@ -113,15 +113,17 @@ sits_tempcnn <- function(samples = NULL, eps = 1.0e-08, weight_decay = 1.0e-06 ), - lr_decay_epochs = 1, + lr_decay_epochs = 1L, lr_decay_rate = 0.95, - patience = 20, + patience = 20L, min_delta = 0.01, verbose = FALSE) { # set caller for error msg .check_set_caller("sits_tempcnn") # Verifies if 'torch' and 'luz' packages is installed .check_require_packages(c("torch", "luz")) + # documentation mode? verbose is FALSE + verbose <- .message_verbose(verbose) # Function that trains a torch model based on samples train_fun <- function(samples) { # does not support working with DEM or other base data @@ -131,10 +133,10 @@ sits_tempcnn <- function(samples = NULL, self <- NULL # Check validation_split parameter if samples_validation is not passed if (is.null(samples_validation)) { - .check_num_parameter(validation_split, exclusive_min = 0, max = 0.5) + .check_num_parameter(validation_split, exclusive_min = 0.0, max = 0.5) } # Preconditions - .pre_sits_tempcnn(samples = samples, cnn_layers = cnn_layers, + .check_pre_sits_tempcnn(samples = samples, cnn_layers = cnn_layers, cnn_kernels = cnn_kernels, cnn_dropout_rates = cnn_dropout_rates, dense_layer_nodes = dense_layer_nodes, @@ -146,7 +148,7 @@ sits_tempcnn <- function(samples = NULL, verbose = verbose) # Check opt_hparams # Get parameters list and remove the 'param' parameter - optim_params_function <- formals(optimizer)[-1] + optim_params_function <- formals(optimizer)[-1L] .check_opt_hparams(opt_hparams, optim_params_function) optim_params_function <- utils::modifyList( x = optim_params_function, @@ -199,7 +201,7 @@ sits_tempcnn <- function(samples = NULL, test_y <- unname(code_labels[.pred_references(test_samples)]) # Set torch seed - torch::torch_manual_seed(sample.int(10^5, 1)) + torch::torch_manual_seed(sample.int(100000L, 1L)) # Define the TempCNN architecture tcnn_model <- torch::nn_module( classname = "model_tcnn", @@ -215,32 +217,32 @@ sits_tempcnn <- function(samples = NULL, # first module - transform input to hidden dims self$conv_bn_relu1 <- .torch_conv1D_batch_norm_relu_dropout( input_dim = n_bands, - output_dim = hidden_dims[[1]], - kernel_size = kernel_sizes[[1]], - padding = as.integer(kernel_sizes[[1]] %/% 2), - dropout_rate = dropout_rates[[1]] + output_dim = hidden_dims[[1L]], + kernel_size = kernel_sizes[[1L]], + padding = as.integer(kernel_sizes[[1L]] %/% 2L), + dropout_rate = dropout_rates[[1L]] ) # second module - 1D CNN self$conv_bn_relu2 <- .torch_conv1D_batch_norm_relu_dropout( - input_dim = hidden_dims[[1]], - output_dim = hidden_dims[[2]], - kernel_size = kernel_sizes[[2]], - padding = as.integer(kernel_sizes[[2]] %/% 2), - dropout_rate = dropout_rates[[2]] + input_dim = hidden_dims[[1L]], + output_dim = hidden_dims[[2L]], + kernel_size = kernel_sizes[[2L]], + padding = as.integer(kernel_sizes[[2L]] %/% 2L), + dropout_rate = dropout_rates[[2L]] ) # third module - 1D CNN self$conv_bn_relu3 <- .torch_conv1D_batch_norm_relu_dropout( - input_dim = hidden_dims[[2]], - output_dim = hidden_dims[[3]], - kernel_size = kernel_sizes[[3]], - padding = as.integer(kernel_sizes[[3]] %/% 2), - dropout_rate = dropout_rates[[3]] + input_dim = hidden_dims[[2L]], + output_dim = hidden_dims[[3L]], + kernel_size = kernel_sizes[[3L]], + padding = as.integer(kernel_sizes[[3L]] %/% 2L), + dropout_rate = dropout_rates[[3L]] ) # flatten 3D tensor to 2D tensor self$flatten <- torch::nn_flatten() # create a dense tensor self$dense <- .torch_linear_batch_norm_relu_dropout( - input_dim = hidden_dims[[3]] * n_times, + input_dim = hidden_dims[[3L]] * n_times, output_dim = dense_layer_nodes, dropout_rate = dense_layer_dropout_rate ) @@ -253,7 +255,7 @@ sits_tempcnn <- function(samples = NULL, forward = function(x) { # input is 3D n_samples x n_times x n_bands x <- x |> - torch::torch_transpose(2, 3) |> + torch::torch_transpose(2L, 3L) |> self$conv_bn_relu1() |> self$conv_bn_relu2() |> self$conv_bn_relu3() |> @@ -315,7 +317,7 @@ sits_tempcnn <- function(samples = NULL, .check_require_packages("torch") # Set torch threads to 1 # Note: function does not work on MacOS - suppressWarnings(torch::torch_set_num_threads(1)) + suppressWarnings(torch::torch_set_num_threads(1L)) # Unserialize model torch_model[["model"]] <- .torch_unserialize_model(serialized_model) # Transform input into a 3D tensor diff --git a/R/sits_terra.R b/R/sits_terra.R index abfa23551..9f9b77896 100644 --- a/R/sits_terra.R +++ b/R/sits_terra.R @@ -29,12 +29,12 @@ #' } #' @export sits_as_terra <- function(cube, - tile = cube[1, ]$tile, + tile = cube[1L, ]$tile, ...) { # Pre-conditions .check_set_caller("sits_as_terra") .check_is_raster_cube(cube) - .check_chr_parameter(tile, len_max = 1) + .check_chr_parameter(tile, len_max = 1L) .check_chr_contains(cube[["tile"]], contains = tile, discriminator = "any_of", msg = .conf("messages", "sits_as_terra_tile")) @@ -44,7 +44,7 @@ sits_as_terra <- function(cube, #' @rdname sits_as_terra #' @export sits_as_terra.raster_cube <- function(cube, - tile = cube[1, ]$tile, + tile = cube[1L, ]$tile, ..., bands = NULL, date = NULL) { @@ -64,7 +64,7 @@ sits_as_terra.raster_cube <- function(cube, if (.has(date)) .check_dates_timeline(date, tile_cube) else - date <- as.Date(.tile_timeline(tile_cube)[[1]]) + date <- as.Date(.tile_timeline(tile_cube)[[1L]]) fi <- .fi_filter_dates(fi, date) @@ -79,7 +79,7 @@ sits_as_terra.raster_cube <- function(cube, #' @rdname sits_as_terra #' @export sits_as_terra.probs_cube <- function(cube, - tile = cube[1, ]$tile, + tile = cube[1L, ]$tile, ...) { # extract tile from cube tile_cube <- .cube_filter_tiles(cube, tile) @@ -99,7 +99,7 @@ sits_as_terra.probs_cube <- function(cube, #' @rdname sits_as_terra #' @export sits_as_terra.class_cube <- function(cube, - tile = cube[1, ]$tile, + tile = cube[1L, ]$tile, ...) { # extract tile from cube tile_cube <- .cube_filter_tiles(cube, tile) diff --git a/R/sits_texture.R b/R/sits_texture.R index 8eee231c4..bc5abc83d 100644 --- a/R/sits_texture.R +++ b/R/sits_texture.R @@ -125,7 +125,7 @@ sits_texture <- function(cube, ...) { #' @export sits_texture.raster_cube <- function(cube, ..., window_size = 3L, - angles = 0, + angles = 0.0, memsize = 4L, multicores = 2L, output_dir, @@ -134,15 +134,17 @@ sits_texture.raster_cube <- function(cube, ..., .check_is_raster_cube(cube) .check_that(.cube_is_regular(cube)) # Check window size - .check_int_parameter(window_size, min = 1, is_odd = TRUE) + .check_int_parameter(window_size, min = 1L, is_odd = TRUE) # Check normalized index - .check_num_parameter(angles, len_min = 1, len_max = 4) + .check_num_parameter(angles, len_min = 1L, len_max = 4L) # Check memsize - .check_int_parameter(memsize, min = 1, max = 16384) + .check_int_parameter(memsize, min = 1L, max = 16384L) # Check multicores - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) # Check output_dir .check_output_dir(output_dir) + # show progress bar? + progress <- .message_progress(progress) # Get cube bands bands <- .cube_bands(cube) @@ -165,14 +167,14 @@ sits_texture.raster_cube <- function(cube, ..., expr = expr ) # Overlapping pixels - overlap <- ceiling(window_size / 2) - 1 + overlap <- ceiling(window_size / 2L) - 1L # Get block size block <- .texture_blocksize(cube) # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( block_size = .block_size(block = block, overlap = overlap), - npaths = length(in_bands) + 1, - nbytes = 8, + npaths = length(in_bands) + 1L, + nbytes = 8L, proc_bloat = .conf("processing_bloat_cpu") ) # Update multicores parameter diff --git a/R/sits_timeline.R b/R/sits_timeline.R index 55ffe105d..5f3eec1f4 100644 --- a/R/sits_timeline.R +++ b/R/sits_timeline.R @@ -26,7 +26,7 @@ sits_timeline.sits <- function(data) { sits_timeline.sits_model <- function(data) { .check_is_sits_model(data) samples <- .ml_samples(data) - as.Date(samples[["time_series"]][[1]][["Index"]]) + as.Date(samples[["time_series"]][[1L]][["Index"]]) } #' @rdname sits_timeline #' @export @@ -40,8 +40,8 @@ sits_timeline.raster_cube <- function(data) { names(timelines_lst) <- data[["tile"]] timeline_unique <- unname(unique(timelines_lst)) - if (length(timeline_unique) == 1) { - timeline_unique[[1]] + if (length(timeline_unique) == 1L) { + timeline_unique[[1L]] } else { # warning if there is more than one timeline .message_warnings_timeline_cube() diff --git a/R/sits_tuning.R b/R/sits_tuning.R index 837569fd1..e7112519b 100644 --- a/R/sits_tuning.R +++ b/R/sits_tuning.R @@ -99,13 +99,13 @@ sits_tuning <- function(samples, params = sits_tuning_hparams( optimizer = torch::optim_adamw, opt_hparams = list( - lr = loguniform(10^-2, 10^-4) + lr = loguniform(0.01, 0.0001) ) ), - trials = 30, - multicores = 2, - gpu_memory = 4, - batch_size = 2^gpu_memory, + trials = 30L, + multicores = 2L, + gpu_memory = 4L, + batch_size = 2L^gpu_memory, progress = FALSE) { # set caller to show in errors .check_set_caller("sits_tuning") @@ -117,15 +117,15 @@ sits_tuning <- function(samples, .check_samples_train(samples_validation) } else { # check validation_split parameter if samples_validation is not passed - .check_num_parameter(validation_split, exclusive_min = 0, max = 0.5) + .check_num_parameter(validation_split, exclusive_min = 0.0, max = 0.5) } # check 'ml_functions' parameter ml_function <- substitute(ml_method, env = environment()) if (is.call(ml_function)) - ml_function <- ml_function[[1]] + ml_function <- ml_function[[1L]] ml_function <- eval(ml_function, envir = asNamespace("sits")) # check 'params' parameter - .check_lst_parameter(params, len_min = 1) + .check_lst_parameter(params, len_min = 1L) .check_that(!"samples" %in% names(params), msg = .conf("messages", "sits_tuning_samples") ) @@ -139,7 +139,9 @@ sits_tuning <- function(samples, # check trials .check_int_parameter(trials) # check 'multicores' parameter - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) + # show progress bar? + progress <- .message_progress(progress) # generate random params params_lst <- purrr::map( as.list(seq_len(trials)), @@ -151,7 +153,7 @@ sits_tuning <- function(samples, # Update multicores if (.torch_gpu_classification() && "optimizer" %in% ls(environment(ml_method))) - multicores <- 1 + multicores <- 1L # start processes .parallel_start(workers = multicores) on.exit(.parallel_stop()) @@ -177,7 +179,7 @@ sits_tuning <- function(samples, # Remove variable 'ml_method' remove(ml_method) result - }, progress = progress, n_retries = 0) + }, progress = progress, n_retries = 0L) # prepare result result <- dplyr::bind_rows(result_lst) @@ -253,6 +255,6 @@ sits_tuning <- function(samples, #' sits_tuning_hparams <- function(...) { params <- substitute(list(...), environment()) - params <- as.list(params)[-1] + params <- as.list(params)[-1L] params } diff --git a/R/sits_uncertainty.R b/R/sits_uncertainty.R index 77781e6c4..65c66cbdc 100644 --- a/R/sits_uncertainty.R +++ b/R/sits_uncertainty.R @@ -77,16 +77,16 @@ sits_uncertainty <- function(cube, ...) { sits_uncertainty.probs_cube <- function( cube, ..., type = "entropy", - multicores = 2, - memsize = 4, + multicores = 2L, + memsize = 4L, output_dir, version = "v1") { # Check if cube has probability data .check_raster_cube_files(cube) # Check memsize - .check_num_parameter(memsize, min = 1, max = 16384) + .check_int_parameter(memsize, min = 1L, max = 16384L) # Check multicores - .check_num_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) # check output dir .check_output_dir(output_dir) # check version @@ -98,9 +98,9 @@ sits_uncertainty.probs_cube <- function( block <- .raster_file_blocksize(.raster_open_rast(.tile_path(cube))) # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( - block_size = .block_size(block = block, overlap = 0), - npaths = length(.tile_labels(cube)) + 1, - nbytes = 8, + block_size = .block_size(block = block, overlap = 0L), + npaths = length(.tile_labels(cube)) + 1L, + nbytes = 8L, proc_bloat = .conf("processing_bloat_cpu") ) # Update multicores parameter @@ -136,16 +136,16 @@ sits_uncertainty.probs_cube <- function( sits_uncertainty.probs_vector_cube <- function( cube, ..., type = "entropy", - multicores = 2, - memsize = 4, + multicores = 2L, + memsize = 4L, output_dir, version = "v1") { # Check if cube has probability data .check_raster_cube_files(cube) # Check memsize - .check_int_parameter(memsize, min = 1, max = 16384) + .check_int_parameter(memsize, min = 1L, max = 16384L) # Check multicores - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) # check output dir .check_output_dir(output_dir) # Check version and progress @@ -242,19 +242,19 @@ sits_uncertainty.default <- function(cube, ...) { #' #' @export sits_uncertainty_sampling <- function(uncert_cube, - n = 100, + n = 100L, min_uncert = 0.4, - sampling_window = 10, - multicores = 1, - memsize = 1) { + sampling_window = 10L, + multicores = 2L, + memsize = 4L) { .check_set_caller("sits_uncertainty_sampling") # Pre-conditions .check_is_uncert_cube(uncert_cube) - .check_int_parameter(n, min = 1) + .check_int_parameter(n, min = 1L) .check_num_parameter(min_uncert, min = 0.0, max = 1.0) .check_int_parameter(sampling_window, min = 1L) - .check_int_parameter(multicores, min = 1) - .check_int_parameter(memsize, min = 1) + .check_int_parameter(multicores, min = 1L) + .check_int_parameter(memsize, min = 1L) # Slide on cube tiles samples_tb <- slider::slide_dfr(uncert_cube, function(tile) { # open spatial raster object @@ -286,7 +286,7 @@ sits_uncertainty_sampling <- function(uncert_cube, # find NA na_rows <- which(is.na(tb)) # remove NA - if (length(na_rows) > 0) { + if (.has(na_rows)) { tb <- tb[-na_rows, ] samples_tile <- samples_tile[-na_rows, ] } diff --git a/R/sits_validate.R b/R/sits_validate.R index 32417465f..e145f480b 100644 --- a/R/sits_validate.R +++ b/R/sits_validate.R @@ -66,13 +66,13 @@ #' #' @export sits_kfold_validate <- function(samples, - folds = 5, + folds = 5L, ml_method = sits_rfor(), filter_fn = NULL, impute_fn = impute_linear(), - multicores = 2, - gpu_memory = 4, - batch_size = 2^gpu_memory, + multicores = 2L, + gpu_memory = 4L, + batch_size = 2L^gpu_memory, progress = TRUE) { # set caller to show in errors .check_set_caller("sits_kfold_validate") @@ -81,13 +81,15 @@ sits_kfold_validate <- function(samples, # pre-condition .check_that(inherits(ml_method, "function")) # pre-condition - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) + # show progress bar? + progress <- .message_progress(progress) # save batch size for later sits_env[["batch_size"]] <- batch_size # Torch models in GPU need multicores = 1 if (.torch_gpu_classification() && "optimizer" %in% ls(environment(ml_method))) { - multicores <- 1 + multicores <- 1L } # Get labels from samples sample_labels <- .samples_labels(samples) @@ -209,8 +211,8 @@ sits_validate <- function(samples, samples_validation = NULL, validation_split = 0.2, ml_method = sits_rfor(), - gpu_memory = 4, - batch_size = 2^gpu_memory) { + gpu_memory = 4L, + batch_size = 2L^gpu_memory) { # set caller to show in errors .check_set_caller("sits_validate") # require package @@ -222,7 +224,8 @@ sits_validate <- function(samples, .check_samples_train(samples_validation) } # check validation split - .check_num(validation_split, min = 0, max = 1, len_min = 1, len_max = 1) + .check_num(validation_split, min = 0.0, max = 1.0, + len_min = 1L, len_max = 1L) # pre-condition for ml_method .check_that(inherits(ml_method, "function")) diff --git a/R/sits_variance.R b/R/sits_variance.R index 6d729b0b2..8f213fafe 100644 --- a/R/sits_variance.R +++ b/R/sits_variance.R @@ -61,13 +61,13 @@ sits_variance <- function( # Check if cube has data and metadata .check_raster_cube_files(cube) # check window size - .check_int_parameter(window_size, min = 3, max = 33, is_odd = TRUE) + .check_int_parameter(window_size, min = 3L, max = 33L, is_odd = TRUE) # check neighborhood fraction .check_num_parameter(neigh_fraction, min = 0., max = 1.0) # Check memsize - .check_int_parameter(memsize, min = 1, max = 16384) + .check_int_parameter(memsize, min = 1L, max = 16384L) # Check multicores - .check_int_parameter(multicores, min = 1, max = 2048) + .check_int_parameter(multicores, min = 1L, max = 2048L) # check output_dir .check_output_dir(output_dir) # Dispatch @@ -91,12 +91,12 @@ sits_variance.probs_cube <- function( # Get block size block <- .raster_file_blocksize(.raster_open_rast(.tile_path(cube))) # Overlapping pixels - overlap <- ceiling(window_size / 2) - 1 + overlap <- ceiling(window_size / 2L) - 1L # Check minimum memory needed to process one block job_block_memsize <- .jobs_block_memsize( block_size = .block_size(block = block, overlap = overlap), - npaths = length(.tile_labels(cube)) * 2, - nbytes = 8, + npaths = length(.tile_labels(cube)) * 2L, + nbytes = 8L, proc_bloat = .conf("processing_bloat_cpu") ) # Update multicores parameter diff --git a/R/sits_view.R b/R/sits_view.R index 5be272095..e6d400cba 100644 --- a/R/sits_view.R +++ b/R/sits_view.R @@ -152,7 +152,7 @@ sits_view <- function(x, ...) { sits_view.sits <- function(x, ..., legend = NULL, palette = "Set3", - radius = 10, + radius = 10L, add = FALSE) { .check_set_caller("sits_view_sits") # precondition @@ -208,15 +208,15 @@ sits_view.som_map <- function(x, ..., id_neurons, legend = NULL, palette = "Harmonic", - radius = 10, + radius = 10L, add = FALSE) { .check_set_caller("sits_view_som_map") # check id_neuron .check_int_parameter( id_neurons, - min = 1, + min = 1L, max = max(unique(x[["labelled_neurons"]][["id_neuron"]])), - len_min = 1, + len_min = 1L, len_max = length(unique(x[["labelled_neurons"]][["id_neuron"]])) ) # if not ADD, create a new sits leaflet @@ -268,15 +268,15 @@ sits_view.raster_cube <- function(x, ..., red = NULL, green = NULL, blue = NULL, - tiles = x[["tile"]][[1]], + tiles = x[["tile"]][[1L]], dates = NULL, palette = "RdYlGn", rev = FALSE, opacity = 0.85, - max_cog_size = 2048, + max_cog_size = 2048L, first_quantile = 0.02, last_quantile = 0.98, - leaflet_megabytes = 64, + leaflet_megabytes = 64L, add = FALSE) { # set caller for errors .check_set_caller("sits_view_raster_cube") @@ -292,18 +292,18 @@ sits_view.raster_cube <- function(x, ..., # check opacity .check_num_parameter(opacity, min = 0.2, max = 1.0) # check COG size - .check_int_parameter(max_cog_size, min = 512) + .check_int_parameter(max_cog_size, min = 512L) # check quantiles .check_num_parameter(first_quantile, min = 0.0, max = 1.0) .check_num_parameter(last_quantile, min = 0.0, max = 1.0) # check leaflet megabytes - .check_int_parameter(leaflet_megabytes, min = 16) + .check_int_parameter(leaflet_megabytes, min = 16L) # check logical control .check_lgl_parameter(add) # pre-condition for bands bands <- .band_set_bw_rgb(x, band, red, green, blue) - if (length(bands) == 1) - band_name <- bands[[1]] + if (length(bands) == 1L) + band_name <- bands[[1L]] else band_name <- stringr::str_flatten(bands, collapse = " ") # retrieve dots @@ -366,15 +366,15 @@ sits_view.raster_cube <- function(x, ..., #' #' @export sits_view.uncertainty_cube <- function(x, ..., - tiles = x[["tile"]][[1]], + tiles = x[["tile"]][[1L]], legend = NULL, palette = "RdYlGn", rev = FALSE, opacity = 0.85, - max_cog_size = 2048, + max_cog_size = 2048L, first_quantile = 0.02, last_quantile = 0.98, - leaflet_megabytes = 64, + leaflet_megabytes = 64L, add = FALSE) { # set caller for errors .check_set_caller("sits_view_uncertainty_cube") @@ -390,12 +390,12 @@ sits_view.uncertainty_cube <- function(x, ..., # check opacity .check_num_parameter(opacity, min = 0.2, max = 1.0) # check COG size - .check_int_parameter(max_cog_size, min = 512) + .check_int_parameter(max_cog_size, min = 512L) # check quantiles .check_num_parameter(first_quantile, min = 0.0, max = 1.0) .check_num_parameter(last_quantile, min = 0.0, max = 1.0) # check leaflet megabytes - .check_int_parameter(leaflet_megabytes, min = 16) + .check_int_parameter(leaflet_megabytes, min = 16L) # check logical control .check_lgl_parameter(add) @@ -456,8 +456,8 @@ sits_view.class_cube <- function(x, ..., palette = "Set3", version = NULL, opacity = 0.85, - max_cog_size = 2048, - leaflet_megabytes = 32, + max_cog_size = 2048L, + leaflet_megabytes = 32L, add = FALSE) { # set caller for errors .check_set_caller("sits_view_class_cube") @@ -468,13 +468,13 @@ sits_view.class_cube <- function(x, ..., # check palette .check_palette(palette) # check version - .check_chr_parameter(version, len_max = 1, allow_null = TRUE) + .check_chr_parameter(version, len_max = 1L, allow_null = TRUE) # check opacity .check_num_parameter(opacity, min = 0.2, max = 1.0) # check COG size - .check_int_parameter(max_cog_size, min = 512) + .check_int_parameter(max_cog_size, min = 512L) # check leaflet megabytes - .check_int_parameter(leaflet_megabytes, min = 16) + .check_int_parameter(leaflet_megabytes, min = 16L) # check logical control .check_lgl_parameter(add) @@ -526,16 +526,16 @@ sits_view.class_cube <- function(x, ..., #' @export #' sits_view.probs_cube <- function(x, ..., - tiles = x[["tile"]][[1]], - label = x[["labels"]][[1]][[1]], + tiles = x[["tile"]][[1L]], + label = x[["labels"]][[1L]][[1L]], legend = NULL, palette = "YlGn", rev = FALSE, opacity = 0.85, - max_cog_size = 2048, + max_cog_size = 2048L, first_quantile = 0.02, last_quantile = 0.98, - leaflet_megabytes = 64, + leaflet_megabytes = 64L, add = FALSE) { # set caller for errors @@ -545,7 +545,7 @@ sits_view.probs_cube <- function(x, ..., # precondition for tiles .check_cube_tiles(x, tiles) # check if label is unique - .check_chr_parameter(label, len_max = 1, + .check_chr_parameter(label, len_max = 1L, msg = .conf("messages", "sits_view_probs_label")) # check that label is part of the probs cube .check_labels_probs_cube(x, label) @@ -554,12 +554,12 @@ sits_view.probs_cube <- function(x, ..., # check opacity .check_num_parameter(opacity, min = 0.2, max = 1.0) # check COG size - .check_int_parameter(max_cog_size, min = 512) + .check_int_parameter(max_cog_size, min = 512L) # check quantiles .check_num_parameter(first_quantile, min = 0.0, max = 1.0) .check_num_parameter(last_quantile, min = 0.0, max = 1.0) # check leaflet megabytes - .check_int_parameter(leaflet_megabytes, min = 16) + .check_int_parameter(leaflet_megabytes, min = 16L) # check logical control .check_lgl_parameter(add) @@ -614,7 +614,7 @@ sits_view.probs_cube <- function(x, ..., #' #' @export sits_view.vector_cube <- function(x, ..., - tiles = x[["tile"]][[1]], + tiles = x[["tile"]][[1L]], seg_color = "yellow", line_width = 0.5, add = FALSE) { @@ -665,7 +665,7 @@ sits_view.vector_cube <- function(x, ..., #' #' @export sits_view.class_vector_cube <- function(x, ..., - tiles = x[["tile"]][[1]], + tiles = x[["tile"]][[1L]], seg_color = "yellow", line_width = 0.2, version = NULL, @@ -685,7 +685,7 @@ sits_view.class_vector_cube <- function(x, ..., # check palette .check_palette(palette) # check version - .check_chr_parameter(version, len_max = 1, allow_null = TRUE) + .check_chr_parameter(version, len_max = 1L, allow_null = TRUE) # check opacity .check_num_parameter(opacity, min = 0.2, max = 1.0) # check logical control diff --git a/R/sits_xlsx.R b/R/sits_xlsx.R index 10b98b9ff..13b744498 100644 --- a/R/sits_xlsx.R +++ b/R/sits_xlsx.R @@ -66,9 +66,9 @@ sits_to_xlsx.list <- function(acc, file) { eo_n <- "(Sensitivity)|(Specificity)|(Pos Pred Value)|(Neg Pred Value)|(F1)" # defined the number of sheets num_sheets <- length(acc) - .check_that(length(num_sheets) >= 1) + .check_that(length(num_sheets) >= 1L) # save all elements of the list - purrr::map2(acc, 1:num_sheets, function(cf_mat, ind) { + purrr::map2(acc, seq_len(num_sheets), function(cf_mat, ind) { # create a worksheet for each confusion matrix if (!.has(cf_mat[["name"]])) { cf_mat[["name"]] <- paste0("sheet", ind) @@ -83,20 +83,20 @@ sits_to_xlsx.list <- function(acc, file) { # write the confusion matrix table in the worksheet openxlsx::writeData(workbook, sheet_name, cf_mat[["table"]]) # overall assessment (accuracy and kappa) - acc_kappa <- as.matrix(cf_mat[["overall"]][1:2]) + acc_kappa <- as.matrix(cf_mat[["overall"]][1L:2L]) # save the accuracy data in the worksheet openxlsx::writeData( wb = workbook, sheet = sheet_name, x = acc_kappa, rowNames = TRUE, - startRow = nrow(cf_mat[["table"]]) + 3, - startCol = 1 + startRow = nrow(cf_mat[["table"]]) + 3L, + startCol = 1L ) # obtain the per class accuracy assessment - if (dim(cf_mat[["table"]])[[1]] > 2) { + if (dim(cf_mat[["table"]])[[1L]] > 2L) { # per class accuracy assessment - acc_bc <- t(cf_mat[["byClass"]][, c(1:4, 7)]) + acc_bc <- t(cf_mat[["byClass"]][, c(1L:4L, 7L)]) # remove prefix from confusion matrix table colnames(acc_bc) <- new_names row.names(acc_bc) <- c( @@ -126,14 +126,14 @@ sits_to_xlsx.list <- function(acc, file) { acc_bc <- as.matrix(acc_bc) } # save the per class data in the worksheet - start_row <- nrow(cf_mat[["table"]]) + 8 + start_row <- nrow(cf_mat[["table"]]) + 8L openxlsx::writeData( wb = workbook, sheet = sheet_name, x = acc_bc, rowNames = TRUE, startRow = start_row, - startCol = 1 + startCol = 1L ) }) # write the worksheets to the XLSX file diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index d76eef3a0..2acabddd0 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -1,10 +1,24 @@ # Messages for SITS # +.accuracy_area_assess: "validation data has more classes than labelled cube" +.apply: "invalid column name" +.as_crs: "invalid CRS value" +.apply_input_bands: "required bands not available in cube" +.band_rename: "all input bands must be provided" +.bbox_as_sf: "reprojecting to EPSG:3426 due to multiple CRS\n (use 'as_crs' to reproject to a different CRS)" +.bbox_from_tbl: "no CRS informed, assuming EPSG:4326" +.bbox_from_sf: "reprojecting to EPSG:3426 due to multiple CRS\n (use 'as_crs' to reproject to a different CRS)" +.bbox_type: "cannot extract bbox from object of class " +.by: "col parameter not found in data columns" +.cdse_stac_fix_items: "invalid band in CDSE configuration" .check_apply: "invalid function provided to be applied" .check_available_bands: 'requested band(s) not available in the cube' .check_band_in_bands: "requested band(s) not available" +.check_bands_collection: "invalid bands in collection definition" .check_bbox: "input is not a valid bbox" .check_bw_rgb_bands: "either 'band' parameter or 'red', 'green', and 'blue' parameters should be informed" +.check_content_data_frame: "invalid input - data frame without content" +.check_content_vector: "invalid input - no content avaliable in vector" .check_crs: "invalid crs information in image files" .check_cube_bands: "some bands are not available in data cube - check 'bands' parameter" .check_cube_tiles: "one or more requested tiles are not part of the data cube" @@ -17,6 +31,7 @@ .check_cube_is_regular: "cube is not regular - run sits_regularize() first" .check_date_parameter: "invalid date format - dates should follow year-month-day: YYYY-MM-DD" .check_dates_timeline: "dates are not part of tile timeline" +.check_discriminator: discriminators available are 'one_of', 'any_of', 'all_of', 'none_of', and 'exactly' .check_dist_method: "invalid distance method for dendrogram calculation" .check_empty_data_frame: "no intersection between roi and cube" .check_endmembers_bands: "bands required by endmembers are not available in data cube" @@ -67,6 +82,9 @@ .check_names_unique: "names should be unique" .check_na_null_parameter: "value cannot be NA or NULL" .check_na_parameter: "NA value not allowed" +.check_new_band_dots: "invalid extra arguments in band" +.check_new_class_band_dots: "invalid extra arguments in class band" +.check_new_cloud_band_dots: "invalid extra arguments in cloud band" .check_null_parameter: "NULL value not allowed" .check_opt_hparams: "invalid hyperparameters provided in optimizer" .check_output_dir: "invalid output_dir - check 'output_dir' exists and is writable" @@ -82,6 +100,9 @@ .check_processed_values: "size of processed matrix is different from number of input pixels" .check_processed_labels: "number of columns of result is different from the number of cube labels" .check_progress: "progress must be either TRUE or FALSE" +.check_raster_block: "invalid block" +.check_raster_bbox: "invalid bounding box" +.check_raster_bbox_tolerance: "bounding box is invalid according to tolerance" .check_raster_cube_files: "Invalid data cube - missing files" .check_recovery: "recovery mode: data already exists. To produce new data, change output_dir or version" .check_roi: "invalid specification of ROI - check function documentation" @@ -100,43 +121,31 @@ .check_smoothness: "smoothness must be either one value or a named vector with a value for each label" .check_source: "data provider is not available or sits is not configured to access it" .check_source_collection: "collection is not available in data provider or sits is not configured to access it" +.check_source_collection_token: "missing access token for collection" .check_stac_items: "collection search returned no items\n check 'roi', 'start_date', 'end_date', and 'tile' parameters" .check_shp_attribute: "attribute missing in shapefile - check 'shp_attr' parameter" +.check_tibble_bands: "requested bands not available in the training samples" .check_tiles: "no tiles found in directory for local cube files - check 'data_dir' parameter" +.check_tiles_source_collection: "tiles need to be defined when using this collection" .check_uncert_cube_lst: "invalid list of uncertainty cubes - check 'uncert_cubes' parameter" .check_unique_period: "invalid period in data cube" .check_window_size: "window_size must be an odd number" .check_validation_file: "invalid or missing CSV validation file for accuracy assessment" .check_vector_object: "segmentation did not produce a valid vector object" .check_version: "version should be a lower case character vector with no underlines" -.accuracy_area_assess: "validation data has more classes than labelled cube" -.apply: "invalid column name" -.as_crs: "invalid CRS value" -.apply_input_bands: "required bands not available in cube" -.band_rename: "all input bands must be provided" -.bbox_as_sf: "reprojecting to EPSG:3426 due to multiple CRS\n (use 'as_crs' to reproject to a different CRS)" -.bbox_from_tbl: "no CRS informed, assuming EPSG:4326" -.bbox_from_sf: "reprojecting to EPSG:3426 due to multiple CRS\n (use 'as_crs' to reproject to a different CRS)" -.bbox_type: "cannot extract bbox from object of class " -.by: "col parameter not found in data columns" -.cdse_stac_fix_items: "invalid band in CDSE configuration" .cluster_rand_index: "input should be a 2-dimensional table." .colors_get: "invalid color values" .colors_get_missing: "missing colors for labels" .colors_get_missing_palette: "palette for missing colors is" .conf_add_color_table: "invalid color table - missing either name or hex columns" -.conf_check_bands: "invalid bands in collection definition" .conf_internals_file: "unable to find config_internals file" .conf_merge_legends: "user defined legends already exist in sits - see sits_colors_show()" .conf_merge_legends_colors: "invalid color names in user legends" .conf_merge_legends_user: "invalid user legends" .conf_messages_file: "unable to find config_messages file" .conf_new_band: "unable to configure parameters for new band" -.check_new_band_dots: "invalid extra arguments in band" -.check_new_class_band_dots: "invalid extra arguments in class band" .conf_new_cloud_band: "unable to configure parameters for new cloud band" .conf_new_class_band: "unable to configure parameters for new class band" -.check_new_cloud_band_dots: "invalid extra arguments in cloud band" .conf_new_collection: "invalid collection value" .conf_new_collection_bands: "invalid value for bands" .conf_new_collection_metadata: "invalid value for metadata_search" @@ -157,6 +166,7 @@ .conf_set_user_file: "invalid user configuration file" .conf_source_files: "unable to find config_sources files" .conf_user_env_var: "invalid configuration file informed in SITS_CONFIG_USER_FILE" +.crop: "unable to crop cube to ROI - please ensure input is a raster cube and ROI is set correctly" .cube_bands: "input is not a valid data cube" .cube_collection: "input is not a valid data cube" .cube_find_class: "input is not a valid data cube" @@ -185,6 +195,9 @@ .is_lt: "tolerance parameter should be >= 0" .is_gt: "tolerance parameter should be >= 0" .jobs_max_multicores: "please increase 'memsize' parameter" +.kohonen_map: "Mapping new data using data layers not involved in training" +.kohonen_map_user_weights: "All user weights must be positive" +.kohonen_supersom: "All user weights must be positive" .local_cube_items_bands: "wrong bands requested - please review input parameters" .local_cube_items_version: "wrong version requested - please review input parameters" .local_cube_items_raster_new: "could not find files in local directory - check parse_info and data_dir parameters" @@ -203,9 +216,11 @@ .opensearch_cdse_search_rtc: "invalid orbit parameter" .parallel_map: "Some parallel nodes failed" .parallel_recv_one_data: "Error has occurred in a node; recovery will be attempted" +.plot_band_best_guess: "no bands provided - using a best guess color composite" .plot_class_cube: "wrong input parameters - see example in documentation" .plot_class_vector_cube: "wrong input parameters - see example in documentation" .plot_class_vector: "segments have not been classified - run sits_classify()" +.plot_least_cloud_cover: "no date provided - using date with least cloud cover" .plot_geo_distances: "invalid distances object - use sits_geo_dist to create it." .plot_palette: "please use palette in place of color_palette" .plot_patterns: "wrong input parameters - see example in documentation" @@ -229,8 +244,6 @@ .plot_uncertainty_vector_cube: "wrong input parameters - see example in documentation" .plot_variance_cube: "plot variance type should be either map or hist" .plot_vector_cube: "wrong input parameters - see example in documentation" -.raster_check_block: "invalid block" -.raster_check_bbox: "invalid bounding box" .raster_crop_metadata: "only one of 'block' or 'bbox' should be informed" .raster_gdal_datatype: "invalid 'data_type' parameter for GDAL access" .raster_open_rast: "unable to open image files" @@ -264,12 +277,10 @@ .source_bands_reap: "requested bands not available in the selected collection" .source_bands_resolution: "invalid band resolution in collection configuration" .source_bands_to_source: "invalid bands parameter in collection configuration" -.source_check: "invalid source parameter" .source_cloud_bit_mask: "unable to set bit mask for cloud band" .source_cloud_interp_vales: "invalid cloud interpolation values in collection configuration" .source_cloud_values: "invalid cloud values in collection configuration" .source_collection_open_data: "unable to find if collection is open data or not" -.source_collection_check: "collection is not available in data provider or sits is not configured to access it" .source_collection_class_labels: "invalid bands for collection" .source_collection_class_tile_dates: "invalid dates for collection" .source_collection_class_tile_band: "invalid band for collection" @@ -277,14 +288,12 @@ .source_collection_grid_system: "invalid grid system for collection" .source_collection_satellite: "invalid satellite for collection" .source_collection_sensor: "invalid sensor for collection" -.source_collection_tile_check: "invalid tiles for collection" .source_configure_access: "unable to access collection - service is unavailable" .source_configure_access_aws_cube: "a valid AWS_SECRET_ACCESS_KEY is required to access this collection\n if you have one, include it as an enviromental variable" .source_configure_access_usgs_cube: "a valid AWS_SECRET_ACCESS_KEY is required to access USGS collection\n if you have one, include it as an enviromental variable" .source_collection_access_test: "enable to access data from the collection" .source_collection_access_var_set: "invalid access vars for collection" .source_collection_metadata_search: "cannot find description for collection - check 'source' and 'collection' params" -.source_collection_token_check: "missing access token for collection" .source_items_get_hrefs_stac_cube: "error when retrieving hrefs from stac query" .source_items_bands_select: "unable to retrieve selected bands from chosen collection - check input parameters" .source_items_cube: "error when retrieving items using stac query - check selection parameters" @@ -310,11 +319,11 @@ .stac_select_bands: "some bands for this product are not pre-configured in sits\n please include them in you user configuration file." .summary_check_tile: "tile is not included in the cube" .test_check: "expected error during testing" -.tibble_bands_check: "requested bands not available in the training samples" .tibble_prune_yes: "Success!! All samples have the same number of time indices" .tibble_prune_no: "Some samples of time series do not have the same time indices \n as the majority of the data" .tile_area_freq_raster_cube: "cube is not a labelled cube" .tile_bands_assign: "number of input values different for current number of bands in tile" +.tile_band_conf_eo_cube: "unable to obtain band configuration" .tile_derived_from_file: "number of image layers does not match number of labels" .tile_derived_merge_blocks: "number of image layers does not match number of labels" .tile_extract: "number of extracted points differs from number of requested points" diff --git a/man/dot-check_date_parameter.Rd b/man/dot-check_date_parameter.Rd index cd3f8e862..2abdc1697 100644 --- a/man/dot-check_date_parameter.Rd +++ b/man/dot-check_date_parameter.Rd @@ -6,8 +6,8 @@ \usage{ .check_date_parameter( x, - len_min = 1, - len_max = 1, + len_min = 1L, + len_max = 1L, allow_null = FALSE, msg = NULL ) diff --git a/man/hist.probs_cube.Rd b/man/hist.probs_cube.Rd index d7619ffcc..ee4c9ff91 100644 --- a/man/hist.probs_cube.Rd +++ b/man/hist.probs_cube.Rd @@ -4,7 +4,7 @@ \alias{hist.probs_cube} \title{histogram of prob cubes} \usage{ -\method{hist}{probs_cube}(x, ..., tile = x[["tile"]][[1]], label = NULL, size = 1e+05) +\method{hist}{probs_cube}(x, ..., tile = x[["tile"]][[1L]], label = NULL, size = 100000L) } \arguments{ \item{x}{Object of classes "raster_cube".} diff --git a/man/hist.raster_cube.Rd b/man/hist.raster_cube.Rd index 06d7c710e..5fff08544 100644 --- a/man/hist.raster_cube.Rd +++ b/man/hist.raster_cube.Rd @@ -4,7 +4,14 @@ \alias{hist.raster_cube} \title{histogram of data cubes} \usage{ -\method{hist}{raster_cube}(x, ..., tile = x[["tile"]][[1]], date = NULL, band = NULL, size = 10000) +\method{hist}{raster_cube}( + x, + ..., + tile = x[["tile"]][[1L]], + date = NULL, + band = NULL, + size = 100000L +) } \arguments{ \item{x}{Object of classes "raster_cube".} diff --git a/man/hist.sits.Rd b/man/hist.sits.Rd index cde9d31c1..54cd8577a 100644 --- a/man/hist.sits.Rd +++ b/man/hist.sits.Rd @@ -20,7 +20,14 @@ type of input. } \examples{ if (sits_run_examples()) { - hist(samples_modis_ndvi) + # create a data cube from local files + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + hist(cube) } } diff --git a/man/hist.uncertainty_cube.Rd b/man/hist.uncertainty_cube.Rd index 3d16dd2b3..46e452744 100644 --- a/man/hist.uncertainty_cube.Rd +++ b/man/hist.uncertainty_cube.Rd @@ -4,7 +4,7 @@ \alias{hist.uncertainty_cube} \title{Histogram uncertainty cubes} \usage{ -\method{hist}{uncertainty_cube}(x, ..., tile = x[["tile"]][[1]], size = 1e+05) +\method{hist}{uncertainty_cube}(x, ..., tile = x[["tile"]][[1L]], size = 100000L) } \arguments{ \item{x}{Object of class "variance_cube"} diff --git a/man/plot.class_cube.Rd b/man/plot.class_cube.Rd index fb668035f..918a64aa1 100644 --- a/man/plot.class_cube.Rd +++ b/man/plot.class_cube.Rd @@ -8,13 +8,13 @@ x, y, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], roi = NULL, title = "Classified Image", legend = NULL, palette = "Spectral", scale = 1, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside" ) } diff --git a/man/plot.class_vector_cube.Rd b/man/plot.class_vector_cube.Rd index 496806d22..1073abc61 100644 --- a/man/plot.class_vector_cube.Rd +++ b/man/plot.class_vector_cube.Rd @@ -7,7 +7,7 @@ \method{plot}{class_vector_cube}( x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], legend = NULL, seg_color = "black", line_width = 0.5, diff --git a/man/plot.dem_cube.Rd b/man/plot.dem_cube.Rd index 7da544dab..089c3e7d9 100644 --- a/man/plot.dem_cube.Rd +++ b/man/plot.dem_cube.Rd @@ -8,12 +8,12 @@ x, ..., band = "ELEVATION", - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], roi = NULL, palette = "Spectral", rev = TRUE, scale = 1, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside" ) } diff --git a/man/plot.probs_cube.Rd b/man/plot.probs_cube.Rd index a91c7be7d..1a3dbea2e 100644 --- a/man/plot.probs_cube.Rd +++ b/man/plot.probs_cube.Rd @@ -7,14 +7,14 @@ \method{plot}{probs_cube}( x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], roi = NULL, labels = NULL, palette = "YlGn", rev = FALSE, quantile = NULL, scale = 1, - max_cog_size = 512, + max_cog_size = 512L, legend_position = "outside", legend_title = "probs" ) diff --git a/man/plot.probs_vector_cube.Rd b/man/plot.probs_vector_cube.Rd index 4432ec10a..432e16d13 100644 --- a/man/plot.probs_vector_cube.Rd +++ b/man/plot.probs_vector_cube.Rd @@ -7,7 +7,7 @@ \method{plot}{probs_vector_cube}( x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], labels = NULL, palette = "YlGn", rev = FALSE, diff --git a/man/plot.raster_cube.Rd b/man/plot.raster_cube.Rd index 5c4b44125..8d75a7729 100644 --- a/man/plot.raster_cube.Rd +++ b/man/plot.raster_cube.Rd @@ -11,7 +11,7 @@ red = NULL, green = NULL, blue = NULL, - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], dates = NULL, roi = NULL, palette = "RdYlGn", @@ -19,7 +19,7 @@ scale = 1, first_quantile = 0.02, last_quantile = 0.98, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside" ) } diff --git a/man/plot.sar_cube.Rd b/man/plot.sar_cube.Rd index 3fb1e3c8c..03d14bf81 100644 --- a/man/plot.sar_cube.Rd +++ b/man/plot.sar_cube.Rd @@ -11,7 +11,7 @@ red = NULL, green = NULL, blue = NULL, - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], dates = NULL, roi = NULL, palette = "Greys", @@ -19,7 +19,7 @@ scale = 1, first_quantile = 0.05, last_quantile = 0.95, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside" ) } diff --git a/man/plot.uncertainty_cube.Rd b/man/plot.uncertainty_cube.Rd index 5b11a5d45..039ed8546 100644 --- a/man/plot.uncertainty_cube.Rd +++ b/man/plot.uncertainty_cube.Rd @@ -7,14 +7,14 @@ \method{plot}{uncertainty_cube}( x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], roi = NULL, palette = "RdYlGn", rev = TRUE, scale = 1, first_quantile = 0.02, last_quantile = 0.98, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside" ) } diff --git a/man/plot.uncertainty_vector_cube.Rd b/man/plot.uncertainty_vector_cube.Rd index de7681980..35f1ef971 100644 --- a/man/plot.uncertainty_vector_cube.Rd +++ b/man/plot.uncertainty_vector_cube.Rd @@ -7,7 +7,7 @@ \method{plot}{uncertainty_vector_cube}( x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], palette = "RdYlGn", rev = TRUE, scale = 1, diff --git a/man/plot.variance_cube.Rd b/man/plot.variance_cube.Rd index 15dc11808..01564073f 100644 --- a/man/plot.variance_cube.Rd +++ b/man/plot.variance_cube.Rd @@ -7,7 +7,7 @@ \method{plot}{variance_cube}( x, ..., - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], roi = NULL, labels = NULL, palette = "YlGnBu", @@ -15,7 +15,7 @@ type = "map", quantile = 0.75, scale = 1, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside", legend_title = "logvar" ) diff --git a/man/plot.vector_cube.Rd b/man/plot.vector_cube.Rd index 340a3d1f2..2e19504ff 100644 --- a/man/plot.vector_cube.Rd +++ b/man/plot.vector_cube.Rd @@ -11,7 +11,7 @@ red = NULL, green = NULL, blue = NULL, - tile = x[["tile"]][[1]], + tile = x[["tile"]][[1L]], dates = NULL, seg_color = "yellow", line_width = 0.3, @@ -20,7 +20,7 @@ scale = 1, first_quantile = 0.02, last_quantile = 0.98, - max_cog_size = 1024, + max_cog_size = 1024L, legend_position = "inside" ) } diff --git a/man/plot.xgb_model.Rd b/man/plot.xgb_model.Rd index 19245bb07..6ccc8305b 100644 --- a/man/plot.xgb_model.Rd +++ b/man/plot.xgb_model.Rd @@ -4,7 +4,7 @@ \alias{plot.xgb_model} \title{Plot XGB model} \usage{ -\method{plot}{xgb_model}(x, ..., trees = 0:4, width = 1500, height = 1900) +\method{plot}{xgb_model}(x, ..., trees = 0L:4L, width = 1500L, height = 1900L) } \arguments{ \item{x}{Object of class "xgb_model".} diff --git a/man/print.sits_area_accuracy.Rd b/man/print.sits_area_accuracy.Rd index 1c5b033ed..3ec08d962 100644 --- a/man/print.sits_area_accuracy.Rd +++ b/man/print.sits_area_accuracy.Rd @@ -4,7 +4,7 @@ \alias{print.sits_area_accuracy} \title{Print the area-weighted accuracy} \usage{ -\method{print}{sits_area_accuracy}(x, ..., digits = 2) +\method{print}{sits_area_accuracy}(x, ..., digits = 2L) } \arguments{ \item{x}{An object of class \code{sits_area_accuracy}.} diff --git a/man/sits_as_stars.Rd b/man/sits_as_stars.Rd index ec41cbfd0..602aad814 100644 --- a/man/sits_as_stars.Rd +++ b/man/sits_as_stars.Rd @@ -6,7 +6,7 @@ \usage{ sits_as_stars( cube, - tile = cube[1, ]$tile, + tile = cube[1L, ]$tile, bands = NULL, dates = NULL, proxy = FALSE diff --git a/man/sits_as_terra.Rd b/man/sits_as_terra.Rd index e5832bb70..e84941555 100644 --- a/man/sits_as_terra.Rd +++ b/man/sits_as_terra.Rd @@ -7,13 +7,13 @@ \alias{sits_as_terra.class_cube} \title{Convert a data cube into a Spatial Raster object from terra} \usage{ -sits_as_terra(cube, tile = cube[1, ]$tile, ...) +sits_as_terra(cube, tile = cube[1L, ]$tile, ...) -\method{sits_as_terra}{raster_cube}(cube, tile = cube[1, ]$tile, ..., bands = NULL, date = NULL) +\method{sits_as_terra}{raster_cube}(cube, tile = cube[1L, ]$tile, ..., bands = NULL, date = NULL) -\method{sits_as_terra}{probs_cube}(cube, tile = cube[1, ]$tile, ...) +\method{sits_as_terra}{probs_cube}(cube, tile = cube[1L, ]$tile, ...) -\method{sits_as_terra}{class_cube}(cube, tile = cube[1, ]$tile, ...) +\method{sits_as_terra}{class_cube}(cube, tile = cube[1L, ]$tile, ...) } \arguments{ \item{cube}{A sits cube.} diff --git a/man/sits_classify.raster_cube.Rd b/man/sits_classify.raster_cube.Rd index 2ee5e393d..b7de16769 100644 --- a/man/sits_classify.raster_cube.Rd +++ b/man/sits_classify.raster_cube.Rd @@ -16,8 +16,8 @@ end_date = NULL, memsize = 8L, multicores = 2L, - gpu_memory = 4, - batch_size = 2^gpu_memory, + gpu_memory = 4L, + batch_size = 2L^gpu_memory, output_dir, version = "v1", verbose = FALSE, diff --git a/man/sits_classify.segs_cube.Rd b/man/sits_classify.segs_cube.Rd index e5907f152..ce79f13b8 100644 --- a/man/sits_classify.segs_cube.Rd +++ b/man/sits_classify.segs_cube.Rd @@ -16,11 +16,11 @@ end_date = NULL, memsize = 8L, multicores = 2L, - gpu_memory = 4, - batch_size = 2^gpu_memory, + gpu_memory = 4L, + batch_size = 2L^gpu_memory, output_dir, version = "v1", - n_sam_pol = 15, + n_sam_pol = 15L, verbose = FALSE, progress = TRUE ) diff --git a/man/sits_classify.sits.Rd b/man/sits_classify.sits.Rd index cb9948523..d487bd851 100644 --- a/man/sits_classify.sits.Rd +++ b/man/sits_classify.sits.Rd @@ -11,8 +11,8 @@ filter_fn = NULL, impute_fn = impute_linear(), multicores = 2L, - gpu_memory = 4, - batch_size = 2^gpu_memory, + gpu_memory = 4L, + batch_size = 2L^gpu_memory, progress = TRUE ) } diff --git a/man/sits_confidence_sampling.Rd b/man/sits_confidence_sampling.Rd index c39530c94..9b8923298 100644 --- a/man/sits_confidence_sampling.Rd +++ b/man/sits_confidence_sampling.Rd @@ -6,11 +6,11 @@ \usage{ sits_confidence_sampling( probs_cube, - n = 20, + n = 20L, min_margin = 0.9, - sampling_window = 10, - multicores = 1, - memsize = 1 + sampling_window = 10L, + multicores = 2L, + memsize = 4L ) } \arguments{ diff --git a/man/sits_cube.stac_cube.Rd b/man/sits_cube.stac_cube.Rd index c36756e4c..df17a8643 100644 --- a/man/sits_cube.stac_cube.Rd +++ b/man/sits_cube.stac_cube.Rd @@ -16,7 +16,7 @@ end_date = NULL, orbit = "descending", platform = NULL, - multicores = 2, + multicores = 2L, progress = TRUE ) } diff --git a/man/sits_cube_copy.Rd b/man/sits_cube_copy.Rd index 35e35774e..4fecda10a 100644 --- a/man/sits_cube_copy.Rd +++ b/man/sits_cube_copy.Rd @@ -9,7 +9,7 @@ sits_cube_copy( roi = NULL, res = NULL, crs = NULL, - n_tries = 3, + n_tries = 3L, multicores = 2L, output_dir, progress = TRUE @@ -103,7 +103,7 @@ if (sits_run_examples()) { lat_max = -14.6 ), multicores = 2L, - res = 250, + res = 250 ) } diff --git a/man/sits_formula_linear.Rd b/man/sits_formula_linear.Rd index 37909b01e..b96eb7cc8 100644 --- a/man/sits_formula_linear.Rd +++ b/man/sits_formula_linear.Rd @@ -4,7 +4,7 @@ \alias{sits_formula_linear} \title{Define a linear formula for classification models} \usage{ -sits_formula_linear(predictors_index = -2:0) +sits_formula_linear(predictors_index = -2L:0L) } \arguments{ \item{predictors_index}{Index of the valid columns diff --git a/man/sits_formula_logref.Rd b/man/sits_formula_logref.Rd index f0b407f16..7d4e3f73c 100644 --- a/man/sits_formula_logref.Rd +++ b/man/sits_formula_logref.Rd @@ -4,7 +4,7 @@ \alias{sits_formula_logref} \title{Define a loglinear formula for classification models} \usage{ -sits_formula_logref(predictors_index = -2:0) +sits_formula_logref(predictors_index = -2L:0L) } \arguments{ \item{predictors_index}{Index of the valid columns diff --git a/man/sits_geo_dist.Rd b/man/sits_geo_dist.Rd index 85addb4b8..9e385164b 100644 --- a/man/sits_geo_dist.Rd +++ b/man/sits_geo_dist.Rd @@ -4,7 +4,7 @@ \alias{sits_geo_dist} \title{Compute the minimum distances among samples and prediction points.} \usage{ -sits_geo_dist(samples, roi, n = 1000, crs = "EPSG:4326") +sits_geo_dist(samples, roi, n = 1000L, crs = "EPSG:4326") } \arguments{ \item{samples}{Time series (tibble of class "sits").} diff --git a/man/sits_get_data.csv.Rd b/man/sits_get_data.csv.Rd index ba58fd033..ce5817b5b 100644 --- a/man/sits_get_data.csv.Rd +++ b/man/sits_get_data.csv.Rd @@ -11,7 +11,7 @@ bands = NULL, crs = "EPSG:4326", impute_fn = impute_linear(), - multicores = 2, + multicores = 2L, progress = FALSE ) } diff --git a/man/sits_get_data.data.frame.Rd b/man/sits_get_data.data.frame.Rd index c91e758ed..8675b56a1 100644 --- a/man/sits_get_data.data.frame.Rd +++ b/man/sits_get_data.data.frame.Rd @@ -14,7 +14,7 @@ label = "NoClass", crs = "EPSG:4326", impute_fn = impute_linear(), - multicores = 2, + multicores = 2L, progress = FALSE ) } diff --git a/man/sits_get_data.sf.Rd b/man/sits_get_data.sf.Rd index 331b09d27..f37f82872 100644 --- a/man/sits_get_data.sf.Rd +++ b/man/sits_get_data.sf.Rd @@ -14,10 +14,10 @@ impute_fn = impute_linear(), label = "NoClass", label_attr = NULL, - n_sam_pol = 30, + n_sam_pol = 30L, pol_avg = FALSE, sampling_type = "random", - multicores = 2, + multicores = 2L, progress = FALSE ) } diff --git a/man/sits_get_data.shp.Rd b/man/sits_get_data.shp.Rd index 1cab36227..53aa66a92 100644 --- a/man/sits_get_data.shp.Rd +++ b/man/sits_get_data.shp.Rd @@ -14,10 +14,10 @@ impute_fn = impute_linear(), label = "NoClass", label_attr = NULL, - n_sam_pol = 30, + n_sam_pol = 30L, pol_avg = FALSE, sampling_type = "random", - multicores = 2, + multicores = 2L, progress = FALSE ) } diff --git a/man/sits_get_data.sits.Rd b/man/sits_get_data.sits.Rd index 62eea7af1..4a0faa88c 100644 --- a/man/sits_get_data.sits.Rd +++ b/man/sits_get_data.sits.Rd @@ -11,7 +11,7 @@ bands = NULL, crs = "EPSG:4326", impute_fn = impute_linear(), - multicores = 2, + multicores = 2L, progress = FALSE ) } diff --git a/man/sits_kfold_validate.Rd b/man/sits_kfold_validate.Rd index c9f7e4175..c41e22bf2 100644 --- a/man/sits_kfold_validate.Rd +++ b/man/sits_kfold_validate.Rd @@ -6,13 +6,13 @@ \usage{ sits_kfold_validate( samples, - folds = 5, + folds = 5L, ml_method = sits_rfor(), filter_fn = NULL, impute_fn = impute_linear(), - multicores = 2, - gpu_memory = 4, - batch_size = 2^gpu_memory, + multicores = 2L, + gpu_memory = 4L, + batch_size = 2L^gpu_memory, progress = TRUE ) } diff --git a/man/sits_lighttae.Rd b/man/sits_lighttae.Rd index 2659a03c4..850af63a8 100644 --- a/man/sits_lighttae.Rd +++ b/man/sits_lighttae.Rd @@ -7,14 +7,14 @@ sits_lighttae( samples = NULL, samples_validation = NULL, - epochs = 150, - batch_size = 128, + epochs = 150L, + batch_size = 128L, validation_split = 0.2, optimizer = torch::optim_adamw, opt_hparams = list(lr = 5e-04, eps = 1e-08, weight_decay = 7e-04), - lr_decay_epochs = 50, + lr_decay_epochs = 50L, lr_decay_rate = 1, - patience = 20, + patience = 20L, min_delta = 0.01, verbose = FALSE ) diff --git a/man/sits_mixture_model.Rd b/man/sits_mixture_model.Rd index b447c92f8..190af0aa6 100644 --- a/man/sits_mixture_model.Rd +++ b/man/sits_mixture_model.Rd @@ -16,7 +16,7 @@ sits_mixture_model(data, endmembers, ...) endmembers, ..., rmse_band = TRUE, - multicores = 2, + multicores = 2L, progress = TRUE ) @@ -25,8 +25,8 @@ sits_mixture_model(data, endmembers, ...) endmembers, ..., rmse_band = TRUE, - memsize = 4, - multicores = 2, + memsize = 4L, + multicores = 2L, output_dir, progress = TRUE ) diff --git a/man/sits_mlp.Rd b/man/sits_mlp.Rd index fe2e4d0db..95400bbd7 100644 --- a/man/sits_mlp.Rd +++ b/man/sits_mlp.Rd @@ -7,14 +7,14 @@ sits_mlp( samples = NULL, samples_validation = NULL, - layers = c(512, 512, 512), + layers = c(512L, 512L, 512L), dropout_rates = c(0.2, 0.3, 0.4), optimizer = torch::optim_adamw, opt_hparams = list(lr = 0.001, eps = 1e-08, weight_decay = 1e-06), - epochs = 100, - batch_size = 64, + epochs = 100L, + batch_size = 64L, validation_split = 0.2, - patience = 20, + patience = 20L, min_delta = 0.01, verbose = FALSE ) diff --git a/man/sits_mosaic.Rd b/man/sits_mosaic.Rd index b6916aef1..1d50d9a0b 100644 --- a/man/sits_mosaic.Rd +++ b/man/sits_mosaic.Rd @@ -8,7 +8,7 @@ sits_mosaic( cube, crs = "EPSG:3857", roi = NULL, - multicores = 2, + multicores = 2L, output_dir, version = "v1", progress = TRUE diff --git a/man/sits_patterns.Rd b/man/sits_patterns.Rd index 4278fa0e9..89662b250 100644 --- a/man/sits_patterns.Rd +++ b/man/sits_patterns.Rd @@ -4,7 +4,7 @@ \alias{sits_patterns} \title{Find temporal patterns associated to a set of time series} \usage{ -sits_patterns(data = NULL, freq = 8, formula = y ~ s(x), ...) +sits_patterns(data = NULL, freq = 8L, formula = y ~ s(x), ...) } \arguments{ \item{data}{Time series.} diff --git a/man/sits_reduce_imbalance.Rd b/man/sits_reduce_imbalance.Rd index 2a5a27769..6ef2b0cab 100644 --- a/man/sits_reduce_imbalance.Rd +++ b/man/sits_reduce_imbalance.Rd @@ -6,10 +6,10 @@ \usage{ sits_reduce_imbalance( samples, - n_samples_over = 200, - n_samples_under = 400, + n_samples_over = 200L, + n_samples_under = 400L, method = "smote", - multicores = 2 + multicores = 2L ) } \arguments{ diff --git a/man/sits_rfor.Rd b/man/sits_rfor.Rd index 9a2e36012..7f30ec0dd 100644 --- a/man/sits_rfor.Rd +++ b/man/sits_rfor.Rd @@ -4,7 +4,7 @@ \alias{sits_rfor} \title{Train random forest models} \usage{ -sits_rfor(samples = NULL, num_trees = 100, mtry = NULL, ...) +sits_rfor(samples = NULL, num_trees = 100L, mtry = NULL, ...) } \arguments{ \item{samples}{Time series with the training samples diff --git a/man/sits_sampling_design.Rd b/man/sits_sampling_design.Rd index 19af8bf63..524cf9d3c 100644 --- a/man/sits_sampling_design.Rd +++ b/man/sits_sampling_design.Rd @@ -7,7 +7,7 @@ sits_sampling_design( cube, expected_ua = 0.75, - alloc_options = c(100, 75, 50), + alloc_options = c(100L, 75L, 50L), std_err = 0.01, rare_class_prop = 0.1 ) diff --git a/man/sits_sgolay.Rd b/man/sits_sgolay.Rd index 61f0c9e82..00c7df863 100644 --- a/man/sits_sgolay.Rd +++ b/man/sits_sgolay.Rd @@ -4,7 +4,7 @@ \alias{sits_sgolay} \title{Filter time series with Savitzky-Golay filter} \usage{ -sits_sgolay(data = NULL, order = 3, length = 5) +sits_sgolay(data = NULL, order = 3L, length = 5L) } \arguments{ \item{data}{Time series or matrix.} diff --git a/man/sits_som_map.Rd b/man/sits_som_map.Rd index 5f317c706..b60319c16 100644 --- a/man/sits_som_map.Rd +++ b/man/sits_som_map.Rd @@ -6,12 +6,12 @@ \usage{ sits_som_map( data, - grid_xdim = 10, - grid_ydim = 10, + grid_xdim = 10L, + grid_ydim = 10L, alpha = 1, - rlen = 100, + rlen = 100L, distance = "dtw", - som_radius = 2, + som_radius = 2L, mode = "online" ) } diff --git a/man/sits_svm.Rd b/man/sits_svm.Rd index 84864eb16..182af1122 100644 --- a/man/sits_svm.Rd +++ b/man/sits_svm.Rd @@ -8,14 +8,14 @@ sits_svm( samples = NULL, formula = sits_formula_linear(), scale = FALSE, - cachesize = 1000, + cachesize = 1000L, kernel = "radial", - degree = 3, - coef0 = 0, + degree = 3L, + coef0 = 0L, cost = 10, tolerance = 0.001, epsilon = 0.1, - cross = 10, + cross = 10L, ... ) } diff --git a/man/sits_tae.Rd b/man/sits_tae.Rd index 487481ae1..ff8e65e20 100644 --- a/man/sits_tae.Rd +++ b/man/sits_tae.Rd @@ -7,14 +7,14 @@ sits_tae( samples = NULL, samples_validation = NULL, - epochs = 150, - batch_size = 64, + epochs = 150L, + batch_size = 64L, validation_split = 0.2, optimizer = torch::optim_adamw, opt_hparams = list(lr = 0.001, eps = 1e-08, weight_decay = 1e-06), - lr_decay_epochs = 1, + lr_decay_epochs = 1L, lr_decay_rate = 0.95, - patience = 20, + patience = 20L, min_delta = 0.01, verbose = FALSE ) diff --git a/man/sits_tempcnn.Rd b/man/sits_tempcnn.Rd index 9b0cbf508..79794d56c 100644 --- a/man/sits_tempcnn.Rd +++ b/man/sits_tempcnn.Rd @@ -7,19 +7,19 @@ sits_tempcnn( samples = NULL, samples_validation = NULL, - cnn_layers = c(64, 64, 64), - cnn_kernels = c(5, 5, 5), + cnn_layers = c(64L, 64L, 64L), + cnn_kernels = c(5L, 5L, 5L), cnn_dropout_rates = c(0.2, 0.2, 0.2), - dense_layer_nodes = 256, + dense_layer_nodes = 256L, dense_layer_dropout_rate = 0.5, - epochs = 150, - batch_size = 64, + epochs = 150L, + batch_size = 64L, validation_split = 0.2, optimizer = torch::optim_adamw, opt_hparams = list(lr = 5e-04, eps = 1e-08, weight_decay = 1e-06), - lr_decay_epochs = 1, + lr_decay_epochs = 1L, lr_decay_rate = 0.95, - patience = 20, + patience = 20L, min_delta = 0.01, verbose = FALSE ) diff --git a/man/sits_timeseries_to_csv.Rd b/man/sits_timeseries_to_csv.Rd index 6854f79da..e64f5557d 100644 --- a/man/sits_timeseries_to_csv.Rd +++ b/man/sits_timeseries_to_csv.Rd @@ -25,6 +25,7 @@ Converts metadata and data from a sits tibble to a CSV file. each data } \examples{ +csv_ts <- sits_timeseries_to_csv(cerrado_2classes) csv_file <- paste0(tempdir(), "/cerrado_2classes_ts.csv") sits_timeseries_to_csv(cerrado_2classes, file = csv_file) } diff --git a/man/sits_tuning.Rd b/man/sits_tuning.Rd index 584b8d068..8c2318a9e 100644 --- a/man/sits_tuning.Rd +++ b/man/sits_tuning.Rd @@ -10,11 +10,11 @@ sits_tuning( validation_split = 0.2, ml_method = sits_tempcnn(), params = sits_tuning_hparams(optimizer = torch::optim_adamw, opt_hparams = list(lr = - loguniform(10^-2, 10^-4))), - trials = 30, - multicores = 2, - gpu_memory = 4, - batch_size = 2^gpu_memory, + loguniform(0.01, 1e-04))), + trials = 30L, + multicores = 2L, + gpu_memory = 4L, + batch_size = 2L^gpu_memory, progress = FALSE ) } diff --git a/man/sits_uncertainty.Rd b/man/sits_uncertainty.Rd index 97511af86..73c74fa73 100644 --- a/man/sits_uncertainty.Rd +++ b/man/sits_uncertainty.Rd @@ -13,8 +13,8 @@ sits_uncertainty(cube, ...) cube, ..., type = "entropy", - multicores = 2, - memsize = 4, + multicores = 2L, + memsize = 4L, output_dir, version = "v1" ) @@ -23,8 +23,8 @@ sits_uncertainty(cube, ...) cube, ..., type = "entropy", - multicores = 2, - memsize = 4, + multicores = 2L, + memsize = 4L, output_dir, version = "v1" ) diff --git a/man/sits_uncertainty_sampling.Rd b/man/sits_uncertainty_sampling.Rd index d153050bd..a1f61a003 100644 --- a/man/sits_uncertainty_sampling.Rd +++ b/man/sits_uncertainty_sampling.Rd @@ -6,11 +6,11 @@ \usage{ sits_uncertainty_sampling( uncert_cube, - n = 100, + n = 100L, min_uncert = 0.4, - sampling_window = 10, - multicores = 1, - memsize = 1 + sampling_window = 10L, + multicores = 2L, + memsize = 4L ) } \arguments{ diff --git a/man/sits_validate.Rd b/man/sits_validate.Rd index 6c8751d53..b18ca43bd 100644 --- a/man/sits_validate.Rd +++ b/man/sits_validate.Rd @@ -9,8 +9,8 @@ sits_validate( samples_validation = NULL, validation_split = 0.2, ml_method = sits_rfor(), - gpu_memory = 4, - batch_size = 2^gpu_memory + gpu_memory = 4L, + batch_size = 2L^gpu_memory ) } \arguments{ diff --git a/man/sits_view.Rd b/man/sits_view.Rd index 6b4b77633..68cbf8726 100644 --- a/man/sits_view.Rd +++ b/man/sits_view.Rd @@ -16,7 +16,7 @@ \usage{ sits_view(x, ...) -\method{sits_view}{sits}(x, ..., legend = NULL, palette = "Set3", radius = 10, add = FALSE) +\method{sits_view}{sits}(x, ..., legend = NULL, palette = "Set3", radius = 10L, add = FALSE) \method{sits_view}{data.frame}(x, ..., legend = NULL, palette = "Harmonic", add = FALSE) @@ -26,7 +26,7 @@ sits_view(x, ...) id_neurons, legend = NULL, palette = "Harmonic", - radius = 10, + radius = 10L, add = FALSE ) @@ -37,30 +37,30 @@ sits_view(x, ...) red = NULL, green = NULL, blue = NULL, - tiles = x[["tile"]][[1]], + tiles = x[["tile"]][[1L]], dates = NULL, palette = "RdYlGn", rev = FALSE, opacity = 0.85, - max_cog_size = 2048, + max_cog_size = 2048L, first_quantile = 0.02, last_quantile = 0.98, - leaflet_megabytes = 64, + leaflet_megabytes = 64L, add = FALSE ) \method{sits_view}{uncertainty_cube}( x, ..., - tiles = x[["tile"]][[1]], + tiles = x[["tile"]][[1L]], legend = NULL, palette = "RdYlGn", rev = FALSE, opacity = 0.85, - max_cog_size = 2048, + max_cog_size = 2048L, first_quantile = 0.02, last_quantile = 0.98, - leaflet_megabytes = 64, + leaflet_megabytes = 64L, add = FALSE ) @@ -72,31 +72,31 @@ sits_view(x, ...) palette = "Set3", version = NULL, opacity = 0.85, - max_cog_size = 2048, - leaflet_megabytes = 32, + max_cog_size = 2048L, + leaflet_megabytes = 32L, add = FALSE ) \method{sits_view}{probs_cube}( x, ..., - tiles = x[["tile"]][[1]], - label = x[["labels"]][[1]][[1]], + tiles = x[["tile"]][[1L]], + label = x[["labels"]][[1L]][[1L]], legend = NULL, palette = "YlGn", rev = FALSE, opacity = 0.85, - max_cog_size = 2048, + max_cog_size = 2048L, first_quantile = 0.02, last_quantile = 0.98, - leaflet_megabytes = 64, + leaflet_megabytes = 64L, add = FALSE ) \method{sits_view}{vector_cube}( x, ..., - tiles = x[["tile"]][[1]], + tiles = x[["tile"]][[1L]], seg_color = "yellow", line_width = 0.5, add = FALSE @@ -105,7 +105,7 @@ sits_view(x, ...) \method{sits_view}{class_vector_cube}( x, ..., - tiles = x[["tile"]][[1]], + tiles = x[["tile"]][[1L]], seg_color = "yellow", line_width = 0.2, version = NULL, diff --git a/man/sits_xgboost.Rd b/man/sits_xgboost.Rd index 1de9ee00c..32bcc5ca4 100644 --- a/man/sits_xgboost.Rd +++ b/man/sits_xgboost.Rd @@ -8,14 +8,14 @@ sits_xgboost( samples = NULL, learning_rate = 0.15, min_split_loss = 1, - max_depth = 5, + max_depth = 5L, min_child_weight = 1, max_delta_step = 1, - subsample = 0.8, - nfold = 5, - nrounds = 100, - nthread = 6, - early_stopping_rounds = 20, + subsample = 0.85, + nfold = 5L, + nrounds = 100L, + nthread = 6L, + early_stopping_rounds = 20L, verbose = FALSE ) } diff --git a/man/summary.variance_cube.Rd b/man/summary.variance_cube.Rd index c713bf956..a632bba01 100644 --- a/man/summary.variance_cube.Rd +++ b/man/summary.variance_cube.Rd @@ -8,7 +8,7 @@ object, ..., intervals = 0.05, - sample_size = 10000, + sample_size = 10000L, quantiles = c("75\%", "80\%", "85\%", "90\%", "95\%", "100\%") ) } diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index 25dce8e6c..8d3ad97ca 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -424,33 +424,32 @@ test_that("Retrieving points from BDC using sf objects", { }) test_that("Retrieving points from MPC Base Cube", { - regdir <- paste0(tempdir(), "/base_cube_reg/") + regdir <- paste0(tempdir(), "/base_cube_reg_data/") if (!dir.exists(regdir)) { suppressWarnings(dir.create(regdir)) } # define roi roi <- list( - lon_min = -55.69004, - lon_max = -55.62223, + lon_min = -55.75218, + lon_max = -55.37380, lat_min = -11.78788, - lat_max = -11.73343 + lat_max = -11.58296 ) # load sentinel-2 cube s2_cube <- sits_cube( source = "AWS", collection = "SENTINEL-2-L2A", - start_date = "2019-01-01", - end_date = "2019-01-20", - bands = c("B05"), - tiles = "21LXH", + start_date = "2019-06-01", + end_date = "2019-08-30", + bands = c("B05", "CLOUD"), + roi = roi, progress = FALSE ) - s2_cube <- suppressWarnings(sits_regularize( + s2_cube_reg <- suppressWarnings(sits_regularize( cube = s2_cube, period = "P16D", res = 320, multicores = 1, - tiles = "21LXH", output_dir = regdir, progress = FALSE )) @@ -458,12 +457,12 @@ test_that("Retrieving points from MPC Base Cube", { dem_cube <- sits_cube( source = "MPC", collection = "COP-DEM-GLO-30", - tiles = "21LXH" + roi = roi ) - dem_cube <- sits_regularize( + dem_cube_reg <- sits_regularize( cube = dem_cube, multicores = 1, - res = 232, + res = 320, tiles = "21LXH", output_dir = regdir ) diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index dfd03d0c0..df7ad75a2 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -2,8 +2,7 @@ test_that("Plot Time Series and Images", { set.seed(290356) cerrado_ndvi <- sits_select(cerrado_2classes, "NDVI") - p <- plot(cerrado_ndvi[1, ]) - expect_equal(p$labels$title, "location (-14.05, -54.23) - Cerrado") + plot(cerrado_ndvi[1, ]) cerrado_ndvi_1class <- dplyr::filter(cerrado_ndvi, label == "Cerrado") p1 <- plot(cerrado_ndvi_1class) @@ -34,9 +33,7 @@ test_that("Plot Time Series and Images", { set.seed(290356) rfor_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor()) point_class <- sits_classify(point_ndvi, rfor_model, progress = FALSE) - p3 <- plot(point_class) - expect_equal(p3$labels$y, "value") - expect_equal(p3$labels$x, "Index") + plot(point_class) data_dir <- system.file("extdata/raster/mod13q1", package = "sits") sinop <- sits_cube( From fbcac5d084ed5ce70ea5d111f143290562b82f6a Mon Sep 17 00:00:00 2001 From: Felipe Carlos Date: Tue, 22 Apr 2025 01:46:35 -0300 Subject: [PATCH 085/122] fix sits_apply and sits_get_data --- R/api_apply.R | 4 ++-- tests/testthat/test-data.R | 22 +++++++++------------- 2 files changed, 11 insertions(+), 15 deletions(-) diff --git a/R/api_apply.R b/R/api_apply.R index 730275eb6..5ed27ac8f 100644 --- a/R/api_apply.R +++ b/R/api_apply.R @@ -120,9 +120,9 @@ ) ) # Prepare fractions to be saved - if (band_offset != 0.0) + if (.has(band_offset) && band_offset != 0.0) values <- values - band_offset - if (band_scale != 1.0) + if (.has(band_scale) && band_scale != 1.0) values <- values / band_scale # Job crop block crop_block <- .block(.chunks_no_overlap(chunk)) diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index 8d3ad97ca..6b066970c 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -428,21 +428,14 @@ test_that("Retrieving points from MPC Base Cube", { if (!dir.exists(regdir)) { suppressWarnings(dir.create(regdir)) } - # define roi - roi <- list( - lon_min = -55.75218, - lon_max = -55.37380, - lat_min = -11.78788, - lat_max = -11.58296 - ) # load sentinel-2 cube s2_cube <- sits_cube( source = "AWS", collection = "SENTINEL-2-L2A", - start_date = "2019-06-01", - end_date = "2019-08-30", + start_date = "2019-01-01", + end_date = "2019-01-20", bands = c("B05", "CLOUD"), - roi = roi, + tiles = "21LXH", progress = FALSE ) s2_cube_reg <- suppressWarnings(sits_regularize( @@ -450,6 +443,7 @@ test_that("Retrieving points from MPC Base Cube", { period = "P16D", res = 320, multicores = 1, + tiles = "21LXH", output_dir = regdir, progress = FALSE )) @@ -457,7 +451,7 @@ test_that("Retrieving points from MPC Base Cube", { dem_cube <- sits_cube( source = "MPC", collection = "COP-DEM-GLO-30", - roi = roi + tiles = "21LXH" ) dem_cube_reg <- sits_regularize( cube = dem_cube, @@ -467,7 +461,7 @@ test_that("Retrieving points from MPC Base Cube", { output_dir = regdir ) # create base cube - base_cube <- sits_add_base_cube(s2_cube, dem_cube) + base_cube <- sits_add_base_cube(s2_cube_reg, dem_cube_reg) # load samples samples <- read.csv( system.file("extdata/samples/samples_sinop_crop.csv", package = "sits") @@ -484,7 +478,7 @@ test_that("Retrieving points from MPC Base Cube", { ) # validations cube_timeline <- sits_timeline(base_cube) - expect_equal(object = nrow(samples_ts), expected = 18) + expect_equal(object = nrow(samples_ts), expected = 17) expect_equal( object = unique(samples_ts[["start_date"]]), expected = as.Date(cube_timeline[1]) @@ -501,7 +495,9 @@ test_that("Retrieving points from MPC Base Cube", { ) unlink(s2_cube[["file_info"]][[1]]$path) + unlink(s2_cube_reg[["file_info"]][[1]]$path) unlink(dem_cube[["file_info"]][[1]]$path) + unlink(dem_cube_reg[["file_info"]][[1]]$path) unlink(base_cube[["file_info"]][[1]]$path) }) From eaac0e2b7aac8b69da71f87ac15b7d74f9f12fca Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Tue, 22 Apr 2025 16:05:22 -0300 Subject: [PATCH 086/122] add CRS to ROI in regularization --- R/sits_regularize.R | 75 ++++++++++++++++++++------------ man/sits_regularize.Rd | 25 +++++++++-- tests/testthat/test-data.R | 42 ++++++++++-------- tests/testthat/test-regularize.R | 7 ++- 4 files changed, 94 insertions(+), 55 deletions(-) diff --git a/R/sits_regularize.R b/R/sits_regularize.R index a25415289..cdfacad9f 100644 --- a/R/sits_regularize.R +++ b/R/sits_regularize.R @@ -28,6 +28,8 @@ #' @param output_dir Valid directory for storing regularized images. #' @param timeline User-defined timeline for regularized cube. #' @param roi Region of interest (see notes below). +#' @param crs Coordinate Reference System (CRS) of the roi. +#' (see details below). #' @param tiles Tiles to be produced. #' @param grid_system Grid system to be used for the output images. #' @param multicores Number of cores used for regularization; @@ -82,10 +84,19 @@ #' The "timeline" parameter, if used, must contain a set of #' dates which are compatible with the input cube. #' -#' The optional "roi" parameter defines a region of interest. It can be -#' an sf_object, a shapefile, or a bounding box vector with -#' named XY values ("xmin", "xmax", "ymin", "ymax") or -#' named lat/long values ("lat_min", "lat_max", "long_min", "long_max"). +#' To define a \code{roi} use one of: +#' \itemize{ +#' \item{A path to a shapefile with polygons;} +#' \item{A \code{sfc} or \code{sf} object from \code{sf} package;} +#' \item{A \code{SpatExtent} object from \code{terra} package;} +#' \item{A named \code{vector} (\code{"lon_min"}, +#' \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84;} +#' \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, +#' \code{"ymin"}, \code{"ymax"}) with XY coordinates.} +#' } +#' +#' Defining a region of interest using \code{SpatExtent} or XY values not +#' in WGS84 requires the \code{crs} parameter to be specified. #' \code{sits_regularize()} function will crop the images #' that contain the region of interest(). #' @@ -160,6 +171,7 @@ sits_regularize.raster_cube <- function(cube, ..., output_dir, timeline = NULL, roi = NULL, + crs = NULL, tiles = NULL, grid_system = NULL, multicores = 2L, @@ -173,25 +185,19 @@ sits_regularize.raster_cube <- function(cube, ..., # check output_dir output_dir <- .file_path_expand(output_dir) .check_output_dir(output_dir) - # check for ROI and tiles - if (!is.null(roi) || !is.null(tiles)) { - .check_roi_tiles(roi, tiles) - } # check multicores .check_num_parameter(multicores, min = 1L, max = 2048L) # check progress progress <- .message_progress(progress) # Does cube contain cloud band? If not, issue a warning .message_warnings_regularize_cloud(cube) - if (.has(roi)) { - crs <- NULL - if (.roi_type(roi) == "bbox" && !.has(roi[["crs"]])) { - crs <- .crs(cube) - if (length(crs) > 1L) - .message_warnings_regularize_crs() - } - roi <- .roi_as_sf(roi, default_crs = crs[[1L]]) + # check for ROI and tiles + if (.has(roi) || .has(tiles)) { + .check_roi_tiles(roi, tiles) } + # Deal with roi + if (.has(roi)) + roi <- .roi_as_sf(roi, default_crs = crs) # Convert input cube to the user's provided grid system if (.has(grid_system)) { .check_grid_system(grid_system) @@ -232,6 +238,7 @@ sits_regularize.sar_cube <- function(cube, ..., timeline = NULL, grid_system = "MGRS", roi = NULL, + crs = NULL, tiles = NULL, multicores = 2L, progress = TRUE) { @@ -243,14 +250,15 @@ sits_regularize.sar_cube <- function(cube, ..., .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) - # check for ROI and tiles - if (!is.null(roi) || !is.null(tiles)) { - .check_roi_tiles(roi, tiles) - } else { - roi <- .cube_as_sf(cube) - } if (.has(grid_system)) .check_grid_system(grid_system) + # deal for ROI and tiles + if (.has(roi) || .has(tiles)) + .check_roi_tiles(roi, tiles) + if (.has(roi)) + roi <- .roi_as_sf(roi, default_crs = crs) + if (.has_not(roi) && .has_not(tiles)) + roi <- .cube_as_sf(cube) # Convert input sentinel1 cube to the user's provided grid system cube <- .reg_tile_convert( @@ -290,6 +298,7 @@ sits_regularize.combined_cube <- function(cube, ..., output_dir, grid_system = NULL, roi = NULL, + crs = NULL, tiles = NULL, multicores = 2L, progress = TRUE) { @@ -327,6 +336,7 @@ sits_regularize.combined_cube <- function(cube, ..., period = period, res = res, roi = roi, + crs = crs, tiles = tiles, output_dir = output_dir, grid_system = grid_system, @@ -346,6 +356,7 @@ sits_regularize.rainfall_cube <- function(cube, ..., timeline = NULL, grid_system = "MGRS", roi = NULL, + crs = NULL, tiles = NULL, multicores = 2L, progress = TRUE) { @@ -357,12 +368,13 @@ sits_regularize.rainfall_cube <- function(cube, ..., .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) - # check for ROI and tiles - if (!is.null(roi) || !is.null(tiles)) { + # deal for ROI and tiles + if (.has(roi) || .has(tiles)) .check_roi_tiles(roi, tiles) - } else { + if (.has(roi)) + roi <- .roi_as_sf(roi, default_crs = crs) + if (.has_not(roi) && .has_not(tiles)) roi <- .cube_as_sf(cube) - } if (.has(grid_system)) { .check_grid_system(grid_system) } @@ -400,6 +412,7 @@ sits_regularize.dem_cube <- function(cube, ..., output_dir, grid_system = "MGRS", roi = NULL, + crs = NULL, tiles = NULL, multicores = 2L, progress = TRUE) { @@ -410,11 +423,15 @@ sits_regularize.dem_cube <- function(cube, ..., .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) - # check for ROI and tiles - if (!is.null(roi) || !is.null(tiles)) { + # deal for ROI and tiles + if (.has(roi) || .has(tiles)) .check_roi_tiles(roi, tiles) - } else { + if (.has(roi)) + roi <- .roi_as_sf(roi, default_crs = crs) + if (.has_not(roi) && .has_not(tiles)) roi <- .cube_as_sf(cube) + if (.has(grid_system)) { + .check_grid_system(grid_system) } # Convert input sentinel1 cube to the user's provided grid system cube <- .reg_tile_convert( diff --git a/man/sits_regularize.Rd b/man/sits_regularize.Rd index 27bbf0aaa..90c46dafd 100644 --- a/man/sits_regularize.Rd +++ b/man/sits_regularize.Rd @@ -21,6 +21,7 @@ sits_regularize(cube, ...) output_dir, timeline = NULL, roi = NULL, + crs = NULL, tiles = NULL, grid_system = NULL, multicores = 2L, @@ -36,6 +37,7 @@ sits_regularize(cube, ...) timeline = NULL, grid_system = "MGRS", roi = NULL, + crs = NULL, tiles = NULL, multicores = 2L, progress = TRUE @@ -49,6 +51,7 @@ sits_regularize(cube, ...) output_dir, grid_system = NULL, roi = NULL, + crs = NULL, tiles = NULL, multicores = 2L, progress = TRUE @@ -63,6 +66,7 @@ sits_regularize(cube, ...) timeline = NULL, grid_system = "MGRS", roi = NULL, + crs = NULL, tiles = NULL, multicores = 2L, progress = TRUE @@ -75,6 +79,7 @@ sits_regularize(cube, ...) output_dir, grid_system = "MGRS", roi = NULL, + crs = NULL, tiles = NULL, multicores = 2L, progress = TRUE @@ -103,6 +108,9 @@ data cubes, with number and unit, where \item{roi}{Region of interest (see notes below).} +\item{crs}{Coordinate Reference System (CRS) of the roi. +(see details below).} + \item{tiles}{Tiles to be produced.} \item{grid_system}{Grid system to be used for the output images.} @@ -173,10 +181,19 @@ The main \code{sits} classification workflow has the following steps: The "timeline" parameter, if used, must contain a set of dates which are compatible with the input cube. - The optional "roi" parameter defines a region of interest. It can be - an sf_object, a shapefile, or a bounding box vector with - named XY values ("xmin", "xmax", "ymin", "ymax") or - named lat/long values ("lat_min", "lat_max", "long_min", "long_max"). + To define a \code{roi} use one of: + \itemize{ + \item{A path to a shapefile with polygons;} + \item{A \code{sfc} or \code{sf} object from \code{sf} package;} + \item{A \code{SpatExtent} object from \code{terra} package;} + \item{A named \code{vector} (\code{"lon_min"}, + \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84;} + \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, + \code{"ymin"}, \code{"ymax"}) with XY coordinates.} + } + + Defining a region of interest using \code{SpatExtent} or XY values not + in WGS84 requires the \code{crs} parameter to be specified. \code{sits_regularize()} function will crop the images that contain the region of interest(). diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index 6b066970c..d1fd31141 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -424,26 +424,39 @@ test_that("Retrieving points from BDC using sf objects", { }) test_that("Retrieving points from MPC Base Cube", { - regdir <- paste0(tempdir(), "/base_cube_reg_data/") + # load samples + samples <- read.csv( + system.file("extdata/samples/samples_sinop_crop.csv", package = "sits") + ) + # edit samples to work with the cube (test purposes only) + samples[["start_date"]] <- "2019-06-01" + samples[["end_date"]] <- "2019-08-30" + + regdir <- file.path(tempdir(), "/base_cube_reg_data/") if (!dir.exists(regdir)) { suppressWarnings(dir.create(regdir)) } + xmax <- max(samples[["longitude"]]) + ymax <- max(samples[["latitude"]]) + xmin <- min(samples[["longitude"]]) + ymin <- min(samples[["latitude"]]) + roi <- c(xmax = xmax, ymax = ymax, xmin = xmin, ymin = ymin) # load sentinel-2 cube s2_cube <- sits_cube( source = "AWS", collection = "SENTINEL-2-L2A", - start_date = "2019-01-01", - end_date = "2019-01-20", + start_date = "2019-06-01", + end_date = "2019-08-30", bands = c("B05", "CLOUD"), - tiles = "21LXH", + roi = roi, progress = FALSE ) s2_cube_reg <- suppressWarnings(sits_regularize( cube = s2_cube, period = "P16D", - res = 320, + res = 232, multicores = 1, - tiles = "21LXH", + roi = roi, output_dir = regdir, progress = FALSE )) @@ -451,34 +464,27 @@ test_that("Retrieving points from MPC Base Cube", { dem_cube <- sits_cube( source = "MPC", collection = "COP-DEM-GLO-30", - tiles = "21LXH" + roi = roi ) dem_cube_reg <- sits_regularize( cube = dem_cube, multicores = 1, - res = 320, - tiles = "21LXH", + res = 232, + roi = roi, output_dir = regdir ) # create base cube base_cube <- sits_add_base_cube(s2_cube_reg, dem_cube_reg) - # load samples - samples <- read.csv( - system.file("extdata/samples/samples_sinop_crop.csv", package = "sits") - ) - # edit samples to work with the cube (test purposes only) - samples[["start_date"]] <- "2019-01-02" - samples[["end_date"]] <- "2019-01-02" + # extract data samples_ts <- sits_get_data( base_cube, samples = samples, - crs = 32721, multicores = 1 ) # validations cube_timeline <- sits_timeline(base_cube) - expect_equal(object = nrow(samples_ts), expected = 17) + expect_equal(object = nrow(samples_ts), expected = 13) expect_equal( object = unique(samples_ts[["start_date"]]), expected = as.Date(cube_timeline[1]) diff --git a/tests/testthat/test-regularize.R b/tests/testthat/test-regularize.R index f1b7ebad4..a3608e98d 100644 --- a/tests/testthat/test-regularize.R +++ b/tests/testthat/test-regularize.R @@ -90,8 +90,7 @@ test_that("Regularizing cubes from AWS, and extracting samples from them", { test_that("Creating Landsat cubes from MPC", { bbox <- c( xmin = -48.28579, ymin = -16.05026, - xmax = -47.30839, ymax = -15.50026, - crs = 4326 + xmax = -47.30839, ymax = -15.50026 ) landsat_cube <- .try( @@ -125,14 +124,14 @@ test_that("Creating Landsat cubes from MPC", { if (!dir.exists(output_dir)) { dir.create(output_dir) } - expect_warning(rg_landsat <- sits_regularize( + rg_landsat <- sits_regularize( cube = landsat_cube, output_dir = output_dir, res = 240, period = "P30D", multicores = 1, progress = FALSE - )) + ) expect_equal(.tile_nrows(.tile(rg_landsat)), 856) expect_equal(.tile_ncols(.tile(rg_landsat)), 967) From 830b4bc0a820c888530c728947f36ee0493bafb9 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Tue, 22 Apr 2025 19:06:19 -0300 Subject: [PATCH 087/122] final version after lintr --- R/api_check.R | 24 +------------ R/api_cube.R | 2 -- R/api_gdalcubes.R | 18 +++++----- R/api_kohonen.R | 74 ++++++++++++++++++++------------------ R/api_merge.R | 4 +-- R/api_message.R | 6 ++-- R/api_ml_model.R | 7 ++-- R/api_mosaic.R | 4 +-- R/api_parallel.R | 14 +++----- R/api_regularize.R | 2 +- R/api_samples.R | 11 +++--- R/api_source_deafrica.R | 1 - R/api_source_deaustralia.R | 1 - R/api_source_mpc.R | 2 +- R/api_source_terrascope.R | 3 -- R/api_uncertainty.R | 4 +-- R/sits_apply.R | 2 +- R/sits_plot.R | 8 ++--- R/sits_reduce.R | 4 +-- R/sits_regularize.R | 12 ++++--- R/sits_som.R | 11 +++--- R/sits_texture.R | 2 +- demo/ml_comparison.R | 2 +- tests/testthat/test-data.R | 2 +- 24 files changed, 93 insertions(+), 127 deletions(-) diff --git a/R/api_check.R b/R/api_check.R index f90e5ea66..3a4e620c8 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -2133,28 +2133,6 @@ .check_set_caller(".check_endmembers_bands") .check_that(all(.band_eo(.endmembers_bands(em)) %in% bands)) } -#' @title Checks if working in documentation mode -#' @name .check_documentation -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @param progress flag set to show progress bar -#' @return TRUE/FALSE -#' @keywords internal -#' @noRd -.check_documentation <- function(progress) { - # if working on sits documentation mode, no progress bar - !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") -} -#' @title Checks if messages should be displayed -#' @name .check_messages -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @return TRUE/FALSE -#' @keywords internal -#' @noRd -.check_messages <- function() { - # if working on sits documentation mode, messages - !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") -} - #' @title Checks if STAC items are correct #' @name .check_stac_items #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} @@ -2175,7 +2153,7 @@ #' @keywords internal #' @noRd .check_recovery <- function() { - if (.check_messages()) { + if (.message_warnings()) { message(.conf("messages", ".check_recovery")) } } diff --git a/R/api_cube.R b/R/api_cube.R index 8b95b97e9..46ae2fbec 100644 --- a/R/api_cube.R +++ b/R/api_cube.R @@ -1423,12 +1423,10 @@ NULL if (all(are_token_updated)) { return(cube) } - # Verify access key if (!nzchar(access_key)) { access_key <- NULL } - cube <- slider::slide_dfr(cube, function(tile) { # Generate a random time to make a new request sleep_time <- sample.int(sleep_time, size = 1L) diff --git a/R/api_gdalcubes.R b/R/api_gdalcubes.R index 1c550a9fc..269e1cf32 100644 --- a/R/api_gdalcubes.R +++ b/R/api_gdalcubes.R @@ -324,14 +324,14 @@ max_min_date <- do.call( what = max, args = purrr::map(cube[["file_info"]], function(file_info) { - return(min(file_info[["date"]])) + min(file_info[["date"]]) }) ) # end date - minimum of all maximums min_max_date <- do.call( what = min, args = purrr::map(cube[["file_info"]], function(file_info) { - return(max(file_info[["date"]])) + max(file_info[["date"]]) }) ) # check if all timeline of tiles intersects @@ -568,7 +568,7 @@ progress <- .message_progress(progress) # gdalcubes log file - gdalcubes_log_file <- file.path(tempdir(), "/gdalcubes.log") + gdalcubes_log_file <- file.path(tempdir(), "gdalcubes.log") # setting threads to process gdalcubes::gdalcubes_options( parallel = 2, @@ -681,7 +681,7 @@ ) { return("proj:epsg") } - return("proj:wkt2") + "proj:wkt2" } #' @title Finds the missing tiles in a regularized cube @@ -705,7 +705,7 @@ time = timeline ) |> purrr::pmap(function(tile, band, time) { - return(list(tile, band, time)) + list(tile, band, time) }) }), recursive = FALSE) @@ -722,7 +722,7 @@ time = timeline ) |> purrr::pmap(function(tile, band, time) { - return(list(tile, band, time)) + list(tile, band, time) }) }), recursive = FALSE) @@ -741,7 +741,7 @@ function(tile, band, date) { tile <- local_cube[local_cube[["tile"]] == tile, ] tile <- .select_raster_cube(tile, bands = band) - return(!date %in% .tile_timeline(tile)) + !date %in% .tile_timeline(tile) } ) @@ -750,8 +750,6 @@ # return all tiles from the original cube # that have not been processed or regularized correctly - miss_tiles_bands_times <- - unique(c(miss_tiles_bands_times, proc_tiles_bands_times)) + unique(c(miss_tiles_bands_times, proc_tiles_bands_times)) - return(miss_tiles_bands_times) } diff --git a/R/api_kohonen.R b/R/api_kohonen.R index e11b2b27c..33fe1d6c3 100644 --- a/R/api_kohonen.R +++ b/R/api_kohonen.R @@ -370,41 +370,47 @@ } # create supersom switch(mode, - online = {res <- suppressWarnings({RcppSupersom( - data = data_matrix, - codes = init_matrix, - numVars = nvar, - weights = weights, - numNAs = n_na, - neighbourhoodDistances = nhbrdist, - alphas = alpha, - radii = radius, - numEpochs = rlen, - distanceFunction = distance_ptr + online = { + res <- suppressWarnings({ + RcppSupersom( + data = data_matrix, + codes = init_matrix, + numVars = nvar, + weights = weights, + numNAs = n_na, + neighbourhoodDistances = nhbrdist, + alphas = alpha, + radii = radius, + numEpochs = rlen, + distanceFunction = distance_ptr )})}, - batch = {res <- suppressWarnings({RcppBatchSupersom( - data = data_matrix, - codes = init_matrix, - numVars = nvar, - weights = weights, - numNAs = n_na, - neighbourhoodDistances = nhbrdist, - radii = radius, - numEpochs = rlen, - distanceFunction = distance_ptr - )})}, - pbatch = {res <- suppressWarnings({RcppParallelBatchSupersom( - data = data_matrix, - codes = init_matrix, - numVars = nvar, - weights = weights, - numNAs = n_na, - neighbourhoodDistances = nhbrdist, - radii = radius, - numEpochs = rlen, - numCores = -1L, - distanceFunction = distance_ptr - )})} + batch = { + res <- suppressWarnings({ + RcppBatchSupersom( + data = data_matrix, + codes = init_matrix, + numVars = nvar, + weights = weights, + numNAs = n_na, + neighbourhoodDistances = nhbrdist, + radii = radius, + numEpochs = rlen, + distanceFunction = distance_ptr + )})}, + pbatch = { + res <- suppressWarnings({ + RcppParallelBatchSupersom( + data = data_matrix, + codes = init_matrix, + numVars = nvar, + weights = weights, + numNAs = n_na, + neighbourhoodDistances = nhbrdist, + radii = radius, + numEpochs = rlen, + numCores = -1L, + distanceFunction = distance_ptr + )})} ) # extract changes changes <- matrix(res$changes, ncol = nmap, byrow = TRUE) diff --git a/R/api_merge.R b/R/api_merge.R index 9bfffe297..9d17edd81 100644 --- a/R/api_merge.R +++ b/R/api_merge.R @@ -454,11 +454,11 @@ .merge_type_deaustralia_s2 <- function(data1, data2) { all( inherits(data1, "deaustralia_cube_ga_s2am_ard_3"), - inherits(data2, "deaustralia_cube_ga_s2bm_ard_3") + inherits(data2, "deaustralia_cube_ga_s2am_ard_3") ) || all( inherits(data1, "deaustralia_cube_ga_s2bm_ard_3"), - inherits(data2, "deaustralia_cube_ga_s2am_ard_3") + inherits(data2, "deaustralia_cube_ga_s2bm_ard_3") ) } .merge_type_irregular <- function(data1, data2) { diff --git a/R/api_message.R b/R/api_message.R index ea9a9931a..39d064ec9 100644 --- a/R/api_message.R +++ b/R/api_message.R @@ -15,7 +15,7 @@ #' @keywords internal #' @noRd .message_warnings <- function() { - !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") + Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" } #' @title Warning when converting a bbox into a sf object #' @name .message_warnings_bbox_as_sf @@ -85,13 +85,13 @@ .message_progress <- function(progress) { .check_lgl_parameter(progress) if (progress) - progress <- !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") + progress <- Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE") progress } .message_verbose <- function(verbose) { .check_lgl_parameter(verbose) if (verbose) - verbose <- !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") + verbose <- Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" verbose } #' @title Check is version parameter is valid using reasonable defaults diff --git a/R/api_ml_model.R b/R/api_ml_model.R index c68916832..6d672f13b 100644 --- a/R/api_ml_model.R +++ b/R/api_ml_model.R @@ -105,7 +105,7 @@ if (.torch_cuda_enabled() && .ml_is_torch_model(ml_model)) { torch::cuda_empty_cache() } - return(invisible(NULL)) + invisible(NULL) } #' @title normalize the probability results @@ -145,15 +145,14 @@ #' @param multicores Current multicores setting #' @return Updated multicores #' -.ml_update_multicores <- function(ml_model, multicores){ +.ml_update_multicores <- function(ml_model, multicores) { # xgboost model has internal multiprocessing if ("xgb_model" %in% .ml_class(ml_model)) multicores <- 1L # torch in GPU has internal multiprocessing else if (.torch_gpu_classification() && .ml_is_torch_model(ml_model)) multicores <- 1L - - return(multicores) + multicores } #' @title Is the ML model a torch model? #' @keywords internal diff --git a/R/api_mosaic.R b/R/api_mosaic.R index bd42d56de..7e64fb0bb 100644 --- a/R/api_mosaic.R +++ b/R/api_mosaic.R @@ -130,9 +130,7 @@ ) # Resume feature if (.raster_is_valid(out_file, output_dir = output_dir)) { - if (.check_messages()) { - .check_recovery() - } + .check_recovery() base_tile <- .tile_from_file( file = out_file, base_tile = base_tile, band = .tile_bands(base_tile), update_bbox = TRUE, diff --git a/R/api_parallel.R b/R/api_parallel.R index 9801b9902..d88b74ef4 100644 --- a/R/api_parallel.R +++ b/R/api_parallel.R @@ -268,31 +268,25 @@ progress <- .message_progress(progress) # create progress bar pb <- NULL - progress <- progress && .has(x) - if (progress) { + if (progress) pb <- utils::txtProgressBar(min = 0L, max = length(x), style = 3L) - } # sequential processing if (.has_not(sits_env[["cluster"]])) { result <- lapply(seq_along(x), function(i) { value <- fn(x[[i]], ...) - # update progress bar - if (progress) { + if (progress) utils::setTxtProgressBar( pb = pb, value = utils::getTxtProgressBar(pb) + 1L ) - } - return(value) + value }) # close progress bar - if (progress) { + if (progress) close(pb) - } return(result) } - # parallel processing values <- .parallel_cluster_apply(x, fn, ..., pb = pb) diff --git a/R/api_regularize.R b/R/api_regularize.R index 485ef8e19..7e724db31 100644 --- a/R/api_regularize.R +++ b/R/api_regularize.R @@ -84,7 +84,7 @@ empty_dates <- as.Date(setdiff(origin_tl, unique(assets[["feature"]]))) temp_date <- assets[1L, "feature"][[1L]] empty_files <- purrr::map_dfr(empty_dates, function(date) { - temp_df <- assets[assets[["feature"]] == temp_date,] + temp_df <- assets[assets[["feature"]] == temp_date, ] temp_df[["feature"]] <- date temp_df[["file_info"]] <- purrr::map(temp_df[["file_info"]], function(fi) { diff --git a/R/api_samples.R b/R/api_samples.R index cfb00fbdc..1a93267a6 100644 --- a/R/api_samples.R +++ b/R/api_samples.R @@ -278,7 +278,7 @@ samples_class, alloc, ..., multicores = 2L, - progress = TRUE){ + progress = TRUE) { UseMethod(".samples_alloc_strata", cube) } #' @export @@ -286,7 +286,7 @@ samples_class, alloc, ..., multicores = 2L, - progress = TRUE){ + progress = TRUE) { # check progress progress <- .message_progress(progress) # estimate size @@ -294,7 +294,6 @@ size <- ceiling(max(size) / nrow(cube)) # get labels labels <- samples_class[["label"]] - n_labels <- length(labels) # Prepare parallel processing .parallel_start(workers = multicores) on.exit(.parallel_stop(), add = TRUE) @@ -318,8 +317,8 @@ # prepare results - factor just need to be renamed if (is.factor(samples_sf[["cover"]])) { samples_sf <- dplyr::rename(samples_sf, "label" = "cover") - } else # prepare results - non-factor must be transform to have label - { + } else { + # prepare results - non-factor must be transform to have label # get labels from `samples_class` by `label_id` to avoid errors samples_sf <- samples_sf |> dplyr::left_join( @@ -355,7 +354,7 @@ # check progress progress <- .message_progress(progress) # Open segments and transform them to tibble - segments_cube <- slider::slide_dfr(cube, function(tile){ + segments_cube <- slider::slide_dfr(cube, function(tile) { .segments_read_vec(tile) }) # Retrieve the required number of segments per class diff --git a/R/api_source_deafrica.R b/R/api_source_deafrica.R index decb30a05..4cd67a746 100644 --- a/R/api_source_deafrica.R +++ b/R/api_source_deafrica.R @@ -32,7 +32,6 @@ 2L * .conf("rstac_pagination_limit") # check documentation mode progress <- .message_progress(progress) - # fetching all the metadata and updating to upper case instruments items_info <- rstac::items_fetch(items = items_info, progress = progress) # checks if the items returned any items diff --git a/R/api_source_deaustralia.R b/R/api_source_deaustralia.R index 3ff491aaa..bb4fc6fdd 100644 --- a/R/api_source_deaustralia.R +++ b/R/api_source_deaustralia.R @@ -32,7 +32,6 @@ 2L * .conf("rstac_pagination_limit") # check documentation mode progress <- .message_progress(progress) - # fetching all the metadata and updating to upper case instruments items_info <- rstac::items_fetch(items = items_info, progress = progress) # checks if the items returned any items diff --git a/R/api_source_mpc.R b/R/api_source_mpc.R index 2d1b0755d..1c653abca 100644 --- a/R/api_source_mpc.R +++ b/R/api_source_mpc.R @@ -907,7 +907,7 @@ ) # remove the additional chars added by httr new_path <- gsub("^://", "", .url_build(url_parsed)) - new_path <- file.path("/vsicurl/", new_path) + new_path <- file.path("/vsicurl", new_path) new_path } diff --git a/R/api_source_terrascope.R b/R/api_source_terrascope.R index 159dd1455..917797d7c 100644 --- a/R/api_source_terrascope.R +++ b/R/api_source_terrascope.R @@ -32,9 +32,6 @@ items_info <- rstac::post_request(q = stac_query, ...) .check_stac_items(items_info) # if more than 2 times items pagination are found the progress bar - # is displayed - progress <- rstac::items_matched(items_info) > - 2L * .conf("rstac_pagination_limit") # fetching all the metadata and updating to upper case instruments items_info <- rstac::items_fetch(items = items_info, progress = FALSE) # checks if the items returned any items diff --git a/R/api_uncertainty.R b/R/api_uncertainty.R index f507d50a1..6b1a3d9a0 100644 --- a/R/api_uncertainty.R +++ b/R/api_uncertainty.R @@ -178,9 +178,7 @@ ) # Resume feature if (file.exists(out_file)) { - if (.check_messages()) { - .check_recovery() - } + .check_recovery() uncert_tile <- .tile_segments_from_file( file = out_file, band = band, diff --git a/R/sits_apply.R b/R/sits_apply.R index 68fed1820..8ed10fa22 100644 --- a/R/sits_apply.R +++ b/R/sits_apply.R @@ -182,7 +182,7 @@ sits_apply.raster_cube <- function(data, ..., out_band <- names(expr) # Check if band already exists in cube if (out_band %in% bands) { - if (.check_messages()) { + if (.message_warnings()) { warning(.conf("messages", "sits_apply_out_band"), call. = FALSE ) diff --git a/R/sits_plot.R b/R/sits_plot.R index fe4c0ff3a..8230ce0f1 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -444,8 +444,7 @@ plot.raster_cube <- function(x, ..., # check dates if (.has(dates)) { .check_dates_timeline(dates, tile) - } - else { + } else { dates <- .fi_date_least_cloud_cover(.fi(tile)) message(.conf("messages", ".plot_least_cloud_cover")) } @@ -1438,7 +1437,7 @@ plot.class_cube <- function(x, y, ..., tile <- .cube_filter_tiles(cube = x, tiles = tile) # plot class cube - .plot_class_image( + p <- .plot_class_image( tile = tile, roi = roi, legend = legend, @@ -1447,6 +1446,7 @@ plot.class_cube <- function(x, y, ..., max_cog_size = max_cog_size, tmap_params = tmap_params ) + invisible(p) } #' @title Plot Segments #' @name plot.class_vector_cube @@ -1547,7 +1547,7 @@ plot.class_vector_cube <- function(x, ..., scale = scale, tmap_params = tmap_params ) - return(p) + invisible(p) } #' @title Plot Random Forest model diff --git a/R/sits_reduce.R b/R/sits_reduce.R index 6922157fb..3212cc3a5 100644 --- a/R/sits_reduce.R +++ b/R/sits_reduce.R @@ -112,7 +112,7 @@ sits_reduce.sits <- function(data, ...) { out_band <- names(expr) # Check if band already exists in samples if (out_band %in% bands) { - if (.check_messages()) { + if (.message_warnings()) { warning(.conf("messages", "sits_reduce_bands"), call. = FALSE ) @@ -150,7 +150,7 @@ sits_reduce.raster_cube <- function(data, ..., out_band <- names(expr) # Check if band already exists in cube if (out_band %in% bands) { - if (.check_messages()) { + if (.message_warnings()) { warning(.conf("messages", "sits_reduce_bands"), call. = FALSE ) diff --git a/R/sits_regularize.R b/R/sits_regularize.R index cdfacad9f..4c4011c7d 100644 --- a/R/sits_regularize.R +++ b/R/sits_regularize.R @@ -191,13 +191,14 @@ sits_regularize.raster_cube <- function(cube, ..., progress <- .message_progress(progress) # Does cube contain cloud band? If not, issue a warning .message_warnings_regularize_cloud(cube) - # check for ROI and tiles - if (.has(roi) || .has(tiles)) { + # ROI and tiles + if (.has(roi) || .has(tiles)) .check_roi_tiles(roi, tiles) - } - # Deal with roi if (.has(roi)) roi <- .roi_as_sf(roi, default_crs = crs) + if (.has_not(roi) && .has_not(tiles)) + roi <- .cube_as_sf(cube) + # Convert input cube to the user's provided grid system if (.has(grid_system)) { .check_grid_system(grid_system) @@ -423,13 +424,14 @@ sits_regularize.dem_cube <- function(cube, ..., .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) - # deal for ROI and tiles + # ROI and tiles if (.has(roi) || .has(tiles)) .check_roi_tiles(roi, tiles) if (.has(roi)) roi <- .roi_as_sf(roi, default_crs = crs) if (.has_not(roi) && .has_not(tiles)) roi <- .cube_as_sf(cube) + if (.has(grid_system)) { .check_grid_system(grid_system) } diff --git a/R/sits_som.R b/R/sits_som.R index 0f62ad27f..3e4f79630 100644 --- a/R/sits_som.R +++ b/R/sits_som.R @@ -275,11 +275,12 @@ sits_som_clean_samples <- function(som_map, ) # function to detect of class noise .detect_class_noise <- function(prior_prob, post_prob) { - ifelse(prior_prob >= prior_threshold & - post_prob >= posterior_threshold, "clean", - ifelse(prior_prob >= prior_threshold & - post_prob < posterior_threshold, "analyze", "remove" - ) + switch( + prior_prob >= prior_threshold & + post_prob >= posterior_threshold = "clean", + prior_prob >= prior_threshold & + post_prob < posterior_threshold = "analyze", + "remove" ) } # extract tibble from SOM map diff --git a/R/sits_texture.R b/R/sits_texture.R index bc5abc83d..d3dd01763 100644 --- a/R/sits_texture.R +++ b/R/sits_texture.R @@ -153,7 +153,7 @@ sits_texture.raster_cube <- function(cube, ..., out_band <- names(expr) # Check if band already exists in cube if (out_band %in% bands) { - if (.check_messages()) { + if (.message_warnings()) { warning(.conf("messages", "sits_texture_out_band"), call. = FALSE ) diff --git a/demo/ml_comparison.R b/demo/ml_comparison.R index 2e6c6cfb2..307841138 100644 --- a/demo/ml_comparison.R +++ b/demo/ml_comparison.R @@ -66,4 +66,4 @@ acc_xgb[["name"]] <- "xgboost" results[[length(results) + 1]] <- acc_xgb -sits_to_xlsx(results, file = file.path(tempdir(), "/accuracy_mt_ml.xlsx")) +sits_to_xlsx(results, file = file.path(tempdir(), "accuracy_mt_ml.xlsx")) diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index d1fd31141..cb57d8a50 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -432,7 +432,7 @@ test_that("Retrieving points from MPC Base Cube", { samples[["start_date"]] <- "2019-06-01" samples[["end_date"]] <- "2019-08-30" - regdir <- file.path(tempdir(), "/base_cube_reg_data/") + regdir <- file.path(tempdir(), "base_cube_reg_data") if (!dir.exists(regdir)) { suppressWarnings(dir.create(regdir)) } From 06433c4beb048cf5e0809e8b0684ee02ebe0a8fd Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Tue, 22 Apr 2025 19:57:23 -0300 Subject: [PATCH 088/122] fix plots --- R/api_message.R | 2 +- R/api_plot_raster.R | 1 - R/sits_plot.R | 77 +++++++++++++-------------------- R/sits_som.R | 13 +++--- tests/testthat/test-cube-cdse.R | 2 +- 5 files changed, 40 insertions(+), 55 deletions(-) diff --git a/R/api_message.R b/R/api_message.R index 39d064ec9..2d8188811 100644 --- a/R/api_message.R +++ b/R/api_message.R @@ -85,7 +85,7 @@ .message_progress <- function(progress) { .check_lgl_parameter(progress) if (progress) - progress <- Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE") + progress <- Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" progress } .message_verbose <- function(verbose) { diff --git a/R/api_plot_raster.R b/R/api_plot_raster.R index d9112b51c..11a6bddaa 100644 --- a/R/api_plot_raster.R +++ b/R/api_plot_raster.R @@ -393,7 +393,6 @@ colnames(values) <- names(probs_rast) probs_rast <- .raster_set_values(probs_rast, values) } - .tmap_probs_map( probs_rast = probs_rast, labels = labels, diff --git a/R/sits_plot.R b/R/sits_plot.R index 8230ce0f1..311871f30 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -52,13 +52,11 @@ plot.sits <- function(x, y, ..., together = FALSE) { .check_lgl_parameter(together) # Are there more than 30 samples? Plot them together! if (together || nrow(x) > 30L) { - p <- .plot_together(x) + .plot_together(x) } else { # otherwise, take "allyears" as the default - p <- .plot_allyears(x) + .plot_allyears(x) } - # return the plot - return(invisible(p)) } #' @title Plot patterns that describe classes #' @name plot.patterns @@ -138,8 +136,7 @@ plot.patterns <- function(x, y, ..., bands = NULL, year_grid = FALSE) { ggplot2::guides(colour = ggplot2::guide_legend(title = "Bands")) + ggplot2::ylab("Value") # plot the data - p <- graphics::plot(gp) - return(invisible(p)) + graphics::plot(gp) } #' @title Plot time series predictions @@ -395,8 +392,8 @@ plot.predicted <- function(x, y, ..., #' collection = "MOD13Q1-6.1", #' data_dir = data_dir #' ) -#' # plot NDVI band of the second date date of the data cube -#' plot(cube, band = "NDVI", dates = sits_timeline(cube)[1]) +#' # plot NDVI band of the least cloud cover date +#' plot(cube) #' } #' @export plot.raster_cube <- function(x, ..., @@ -453,7 +450,7 @@ plot.raster_cube <- function(x, ..., # deal with the case of same band in different dates if (length(bands) == 1L && length(dates) == 3L) { - p <- .plot_band_multidate( + .plot_band_multidate( tile = tile, band = bands[[1L]], dates = dates, @@ -464,11 +461,10 @@ plot.raster_cube <- function(x, ..., last_quantile = last_quantile, tmap_params = tmap_params ) - return(p) } # single date - either false color (one band) or RGB - if (length(bands) == 1L) { - p <- .plot_false_color( + else if (length(bands) == 1L) { + .plot_false_color( tile = tile, band = bands[[1L]], date = dates[[1L]], @@ -486,7 +482,7 @@ plot.raster_cube <- function(x, ..., ) } else { # plot RGB - p <- .plot_rgb( + .plot_rgb( tile = tile, bands = bands, date = dates[[1L]], @@ -501,7 +497,6 @@ plot.raster_cube <- function(x, ..., tmap_params = tmap_params ) } - return(p) } #' @title Plot SAR data cubes #' @name plot.sar_cube @@ -712,13 +707,12 @@ plot.dem_cube <- function(x, ..., # read SpatialRaster file rast <- .raster_open_rast(dem_file) # plot the DEM - p <- .tmap_dem_map(r = rast, + .tmap_dem_map(r = rast, band = band, palette = palette, rev = rev, scale = scale, tmap_params = tmap_params) - return(p) } #' @title Plot RGB vector data cubes #' @name plot.vector_cube @@ -837,7 +831,7 @@ plot.vector_cube <- function(x, ..., # BW or color? if (length(bands) == 1L) { # plot the band as false color - p <- .plot_false_color( + .plot_false_color( tile = tile, band = bands[[1L]], date = dates[[1L]], @@ -855,7 +849,7 @@ plot.vector_cube <- function(x, ..., ) } else { # plot RGB - p <- .plot_rgb( + .plot_rgb( tile = tile, bands = bands, date = dates[[1L]], @@ -870,7 +864,6 @@ plot.vector_cube <- function(x, ..., tmap_params = tmap_params ) } - return(p) } #' @title Plot probability cubes #' @name plot.probs_cube @@ -951,17 +944,16 @@ plot.probs_cube <- function(x, ..., tile <- .cube_filter_tiles(cube = x, tiles = tile) # plot the probs cube - p <- .plot_probs(tile = tile, - roi = roi, - labels_plot = labels, - palette = palette, - rev = rev, - scale = scale, - quantile = quantile, - max_cog_size = max_cog_size, - tmap_params = tmap_params) + .plot_probs(tile = tile, + roi = roi, + labels_plot = labels, + palette = palette, + rev = rev, + scale = scale, + quantile = quantile, + max_cog_size = max_cog_size, + tmap_params = tmap_params) - return(p) } #' @title Plot probability vector cubes #' @name plot.probs_vector_cube @@ -1010,7 +1002,7 @@ plot.probs_cube <- function(x, ..., #' output_dir = tempdir() #' ) #' # plot the resulting probability cube -#' plot(probs_vector_cube, labels = "Forest") +#' plot(probs_vector_cube) #' } #' #' @export @@ -1042,14 +1034,12 @@ plot.probs_vector_cube <- function(x, ..., tile <- .cube_filter_tiles(cube = x, tiles = tile) # plot the probs vector cube - p <- .plot_probs_vector(tile = tile, + .plot_probs_vector(tile = tile, labels_plot = labels, palette = palette, rev = rev, scale = scale, tmap_params = tmap_params) - - return(p) } #' @title Plot variance cubes #' @name plot.variance_cube @@ -1137,7 +1127,7 @@ plot.variance_cube <- function(x, ..., tile <- .cube_filter_tiles(cube = x, tiles = tile) # plot the variance cube if (type == "map") { - p <- .plot_probs(tile = tile, + .plot_probs(tile = tile, roi = roi, labels_plot = labels, palette = palette, @@ -1147,10 +1137,8 @@ plot.variance_cube <- function(x, ..., max_cog_size = max_cog_size, tmap_params = tmap_params) } else { - p <- .plot_variance_hist(tile) + .plot_variance_hist(tile) } - - return(p) } #' @title Plot uncertainty cubes @@ -1241,7 +1229,7 @@ plot.uncertainty_cube <- function(x, ..., tile <- .cube_filter_tiles(cube = x, tiles = tile[[1L]]) band <- .tile_bands(tile) # plot the data - p <- .plot_false_color( + .plot_false_color( tile = tile, band = band, date = NULL, @@ -1257,7 +1245,6 @@ plot.uncertainty_cube <- function(x, ..., max_cog_size = max_cog_size, tmap_params = tmap_params ) - return(p) } #' @title Plot uncertainty vector cubes #' @name plot.uncertainty_vector_cube @@ -1437,7 +1424,7 @@ plot.class_cube <- function(x, y, ..., tile <- .cube_filter_tiles(cube = x, tiles = tile) # plot class cube - p <- .plot_class_image( + .plot_class_image( tile = tile, roi = roi, legend = legend, @@ -1446,7 +1433,6 @@ plot.class_cube <- function(x, y, ..., max_cog_size = max_cog_size, tmap_params = tmap_params ) - invisible(p) } #' @title Plot Segments #' @name plot.class_vector_cube @@ -1540,14 +1526,13 @@ plot.class_vector_cube <- function(x, ..., # filter the tile to be processed tile <- .cube_filter_tiles(cube = x, tiles = tile) # plot class vector cube - p <- .plot_class_vector( + .plot_class_vector( tile = tile, legend = legend, palette = palette, scale = scale, tmap_params = tmap_params ) - invisible(p) } #' @title Plot Random Forest model @@ -1661,8 +1646,8 @@ plot.sits_accuracy <- function(x, y, ..., title = "Confusion matrix") { ggplot2::scale_fill_manual(name = "Class", values = colors) + ggplot2::ggtitle(title) - p <- graphics::plot(p) - return(invisible(p)) + graphics::plot(p) + invisible(p) } #' @@ -1745,7 +1730,7 @@ plot.som_evaluate_cluster <- function(x, y, ..., ggplot2::ggtitle(title) p <- graphics::plot(p) - return(invisible(p)) + invisible(p) } #' @title Plot a SOM map #' @name plot.som_map diff --git a/R/sits_som.R b/R/sits_som.R index 3e4f79630..41e9d747d 100644 --- a/R/sits_som.R +++ b/R/sits_som.R @@ -275,13 +275,14 @@ sits_som_clean_samples <- function(som_map, ) # function to detect of class noise .detect_class_noise <- function(prior_prob, post_prob) { - switch( - prior_prob >= prior_threshold & - post_prob >= posterior_threshold = "clean", - prior_prob >= prior_threshold & - post_prob < posterior_threshold = "analyze", + if (prior_prob >= prior_threshold & + post_prob >= posterior_threshold) + return ("clean") + else if (prior_prob >= prior_threshold & + post_prob < posterior_threshold) + return("analyze") + else "remove" - ) } # extract tibble from SOM map data <- som_map[["data"]] |> diff --git a/tests/testthat/test-cube-cdse.R b/tests/testthat/test-cube-cdse.R index ce01186af..4d761b493 100644 --- a/tests/testthat/test-cube-cdse.R +++ b/tests/testthat/test-cube-cdse.R @@ -1,6 +1,5 @@ test_that("Creating S2 cubes from CDSE with ROI", { # Configure environment - cdse_env_config <- .environment_cdse() # Patch environment variables .environment_patch(cdse_env_config) # Test @@ -42,6 +41,7 @@ test_that("Creating S2 cubes from CDSE with ROI", { expect_true(.raster_nrows(rast) == cube_nrows) # Rollback environment changes .environment_rollback(cdse_env_config) + # # Configure environment }) test_that("Creating S2 cubes from CDSE with tiles", { # Configure environment From ec3f9325d491c9d2b0aecd7d5a0b754a13c48917 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 23 Apr 2025 18:59:33 +0000 Subject: [PATCH 089/122] refactoring sits_get_data --- R/api_data.R | 957 ++++++++++++---------------------------------- R/sits_get_data.R | 81 ++-- 2 files changed, 301 insertions(+), 737 deletions(-) diff --git a/R/api_data.R b/R/api_data.R index 52e71739b..136a398a8 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -33,6 +33,7 @@ # Dispatch UseMethod(".data_get_ts", cube) } + #' @name .data_get_ts #' @keywords internal #' @noRd @@ -43,56 +44,34 @@ impute_fn, multicores, progress) { - # Pre-condition - .check_cube_bands(cube, bands = bands) # Is the cloud band available? - cld_band <- .source_cloud() - if (cld_band %in% bands) { - bands <- bands[bands != cld_band] - } else { - cld_band <- NULL + cld_band <- NULL + if (.has_cloud(bands)) { + cld_band <- .source_cloud() + bands <- setdiff(bands, cld_band) } + # Does the cube have base info? if (.cube_is_base(cube)) { bands <- setdiff(bands, .cube_bands(.cube_base_info(cube))) } - - # define parallelization strategy - # find block size - rast <- .raster_open_rast(.tile_path(cube)) - block <- .raster_file_blocksize(rast) - # 1st case - split samples by tiles - if ((.raster_nrows(rast) == block[["nrows"]] && - .raster_ncols(rast) == block[["ncols"]]) || - inherits(cube, "dem_cube")) { - # split samples by bands and tile - ts_tbl <- .data_by_tile( - cube = cube, - samples = samples, - bands = bands, - impute_fn = impute_fn, - cld_band = cld_band, - multicores = multicores, - progress = progress - ) - } else { - # get data by chunks - ts_tbl <- .data_by_chunks( - cube = cube, - samples = samples, - bands = bands, - impute_fn = impute_fn, - cld_band = cld_band, - multicores = multicores, - progress = progress - ) - } - if (.has(cube[["base_info"]])) { - # get base info + # Extract samples time series from raster cube + samples_ts <- .data_extract( + cube = cube, + samples = samples, + bands = bands, + impute_fn = impute_fn, + cld_band = cld_band, + multicores = multicores, + progress = progress + ) + # Extract samples time series from base cube + if (.cube_is_base(cube)) { + # Get cube base info cube_base <- .cube_base_info(cube) - # get bands + # Get base bands bands_base <- .cube_bands(cube_base) - # extract data - base_tbl <- .data_get_ts( + # Extract samples time series + base_ts <- .data_get_ts( cube = cube_base, samples = samples, bands = bands_base, @@ -100,284 +79,17 @@ multicores = multicores, progress = progress ) - # prepare output data - base_tbl <- base_tbl |> - dplyr::select("longitude", "latitude", "time_series") |> - dplyr::rename("base_data" = "time_series") - # Assuming `ts_tbl` as the source of truth, the size of the following - # `join` must be the same as the current `ts_tbl`. - ts_tbl_size <- nrow(ts_tbl) - # joining samples data from cube and base_cube by longitude / latitude - ts_tbl <- dplyr::left_join( - x = ts_tbl, - y = base_tbl, - by = c("longitude", "latitude") - ) |> - tidyr::drop_na() - # checking samples consistency - .data_check(ts_tbl_size, nrow(ts_tbl)) - # add base class (`sits` is added as it is removed in the join above) - class(ts_tbl) <- unique(c("sits_base", "sits", class(ts_tbl))) - } - ts_tbl -} - -#' @name .data_get_ts -#' @keywords internal -#' @noRd -#' @export -.data_get_ts.class_cube <- function(cube, - samples, ..., - bands, - crs, - multicores, - progress) { - # Filter only tiles that intersects with samples - cube <- .cube_filter_spatial( - cube = cube, - roi = .point_as_sf(point = .point(x = samples, crs = crs)) - ) - # pre-condition - check bands - if (is.null(bands)) { - bands <- .cube_bands(cube) - } - .check_cube_bands(cube, bands = bands) - # get cubes timeline - tl <- .cube_timeline(cube)[[1]] - # create tile-band pairs for parallelization - tiles_bands <- tidyr::expand_grid( - tile = .cube_tiles(cube), - band = bands - ) |> - purrr::pmap(function(tile, band) { - list(tile, band) - }) - # set output_dir - output_dir <- tempdir() - if (Sys.getenv("SITS_SAMPLES_CACHE_DIR") != "") { - output_dir <- Sys.getenv("SITS_SAMPLES_CACHE_DIR") - } - # prepare parallelization - .parallel_start(workers = multicores) - on.exit(.parallel_stop(), add = TRUE) - # get the samples in parallel using tile-band combination - samples_tiles_bands <- .parallel_map( - tiles_bands, - function(tile_band) { - # select tile and band - tile_id <- tile_band[[1]] - band <- tile_band[[2]] - tile <- .select_raster_cube(cube, bands = band, tiles = tile_id) - # create a hash to store temporary samples file - hash_bundle <- digest::digest(list(tile, samples), algo = "md5") - filename <- .file_path( - "samples", hash_bundle, - ext = ".rds", - output_dir = output_dir - ) - # does the file exist? - if (file.exists(filename)) { - tryCatch( - { # ensure that the file is not corrupted - timeseries <- readRDS(filename) - return(timeseries) - }, - error = function(e) { - unlink(filename) - gc() - } - ) - } - # get XY - xy_tb <- .proj_from_latlong( - longitude = samples[["longitude"]], - latitude = samples[["latitude"]], - crs = .cube_crs(tile) - ) - # join lat-long with XY values in a single tibble - samples <- dplyr::bind_cols(samples, xy_tb) - # filter the points inside the data cube space-time extent - samples <- dplyr::filter( - samples, - .data[["X"]] > tile[["xmin"]], - .data[["X"]] < tile[["xmax"]], - .data[["Y"]] > tile[["ymin"]], - .data[["Y"]] < tile[["ymax"]], - .data[["start_date"]] <= as.Date(tl[[length(tl)]]), - .data[["end_date"]] >= as.Date(tl[[1]]) - ) - # are there points to be retrieved from the cube? - if (nrow(samples) == 0) { - return(NULL) - } - # create a matrix to extract the values - xy <- matrix( - c(samples[["X"]], samples[["Y"]]), - nrow = nrow(samples), - ncol = 2 - ) - colnames(xy) <- c("X", "Y") - # build the sits tibble for the storing the points - samples_tbl <- slider::slide_dfr(samples, function(point) { - # get the valid timeline - dates <- .timeline_during( - timeline = tl, - start_date = as.Date(point[["start_date"]]), - end_date = as.Date(point[["end_date"]]) - ) - sample <- tibble::tibble( - longitude = point[["longitude"]], - latitude = point[["latitude"]], - start_date = dates[[1]], - end_date = dates[[length(dates)]], - label = point[["label"]], - cube = tile[["collection"]], - polygon_id = point[["polygon_id"]] - ) - # store them in the sample tibble - sample[["predicted"]] <- list(tibble::tibble( - # from 1 to the number of dates (can be more than one) - from = dates[[1]], to = dates[[length(dates)]] - )) - # return valid row of time series - sample - }) - ts <- .ts_get_raster_class( - tile = tile, - points = samples_tbl, - band = "class", - xy = xy - ) - ts[["tile"]] <- tile_id - ts[["#..id"]] <- seq_len(nrow(ts)) - saveRDS(ts, filename) - ts - }, - progress = progress - ) - # reorganise the samples - ts_tbl <- samples_tiles_bands |> - dplyr::bind_rows() |> - tidyr::unnest("predicted") |> - dplyr::group_by( - .data[["longitude"]], .data[["latitude"]], - .data[["start_date"]], .data[["end_date"]], - .data[["label"]], .data[["cube"]], - .data[["from"]], .data[["to"]], .data[["tile"]], - .data[["#..id"]] + # Combine cube time series with base data + samples_ts <- .data_combine_ts( + samples_ts = samples_ts, + base_ts = base_ts ) - # is there a polygon id? This occurs when we have segments - if ("polygon_id" %in% colnames(ts_tbl)) { - ts_tbl <- dplyr::group_by(ts_tbl, .data[["polygon_id"]], .add = TRUE) } - ts_tbl <- ts_tbl |> - dplyr::summarise( - dplyr::across( - dplyr::all_of(bands), stats::na.omit - ) - ) |> - dplyr::arrange(.data[["from"]]) |> - dplyr::ungroup() |> - tidyr::nest( - predicted = !!c("from", "to", 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 |> - dplyr::group_by( - .data[["longitude"]], .data[["latitude"]], - .data[["start_date"]], .data[["end_date"]], - .data[["label"]], .data[["cube"]] - ) |> - dplyr::slice_head(n = 1) |> - dplyr::ungroup() - - # recreate hash values - hash_bundle <- purrr::map_chr(tiles_bands, function(tile_band) { - tile_id <- tile_band[[1]] - band <- tile_band[[2]] - tile <- .select_raster_cube(cube, bands = band, tiles = tile_id) - digest::digest(list(tile, samples), algo = "md5") - }) - # recreate file names to delete them - # samples will be recycled for each hash_bundle - temp_timeseries <- .file_path( - "samples", hash_bundle, - ext = "rds", - output_dir = output_dir - ) - # delete temporary rds - unlink(temp_timeseries) - gc() - # check if data has been retrieved - if (progress) { - .data_check(nrow(samples), nrow(ts_tbl)) - } - class(ts_tbl) <- unique(c("predicted", "sits", class(ts_tbl))) - ts_tbl -} - -#' @title Check if all points have been retrieved -#' @name .data_check -#' @keywords internal -#' @noRd -#' @param n_rows_input Number of rows in input. -#' @param n_rows_output Number of rows in output. -#' -#' @return No return value, called for side effects. -#' -.data_check <- function(n_rows_input, n_rows_output) { - # Have all input rows being read? - if (n_rows_output == 0) { - message("No points have been retrieved") - return(invisible(FALSE)) - } - - if (n_rows_output < n_rows_input) { - message("Some points could not be retrieved") - } else { - message("All points have been retrieved") - } - invisible(n_rows_input) -} - -#' @title Extracts the time series average by polygon. -#' @name .data_avg_polygon -#' @keywords internal -#' @noRd -#' @description This function extracts the average of the automatically -#' generated points for each polygon in a shapefile. -#' -#' @param data A sits tibble with points time series. -#' -#' @return A sits tibble with the average of all points by each polygon. -.data_avg_polygon <- function(data) { - bands <- .samples_bands(data) - columns_to_avg <- c(bands, "latitude", "longitude") - data_avg <- data |> - tidyr::unnest(cols = "time_series") |> - dplyr::group_by( - .data[["Index"]], - .data[["start_date"]], - .data[["end_date"]], - .data[["label"]], - .data[["cube"]], - .data[["polygon_id"]] - ) |> - dplyr::summarise(dplyr::across(!!columns_to_avg, function(x) { - mean(x, na.rm = TRUE) - }), .groups = "drop") |> - tidyr::nest("time_series" = c("Index", dplyr::all_of(bands))) |> - dplyr::select(!!colnames(data)) - - class(data_avg) <- class(data) - data_avg + samples_ts } #' @title get time series from data cubes on tile by tile bassis -#' @name .data_by_tile +#' @name .data_extract #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @keywords internal @@ -390,23 +102,28 @@ #' @param multicores Number of threads to process the time series. #' @param progress A logical value indicating if a progress bar #' should be shown. -.data_by_tile <- function(cube, +.data_extract <- function(cube, samples, bands, impute_fn, cld_band, multicores, progress) { - .check_set_caller(".data_by_tile") + .check_set_caller(".data_extract") # Get cube timeline - tl <- .cube_timeline(cube)[[1]] - # Get tile-band combination - tiles_bands <- .cube_split_tiles_bands(cube = cube, bands = bands) + tl <- .dissolve(.cube_timeline(cube)) + # Set output_dir output_dir <- tempdir() if (Sys.getenv("SITS_SAMPLES_CACHE_DIR") != "") { output_dir <- Sys.getenv("SITS_SAMPLES_CACHE_DIR") } + + # Reproject the samples and use them on-the-fly without allocate + samples_rep <- .data_lazy_reproject(samples, cube, output_dir) + + # Get tile-band combination + tiles_bands <- .cube_split_tiles_bands(cube = cube, bands = bands) # To avoid open more process than tiles and bands combinations if (multicores > length(tiles_bands)) { multicores <- length(tiles_bands) @@ -414,436 +131,94 @@ # Prepare parallelization .parallel_start(workers = multicores) on.exit(.parallel_stop(), add = TRUE) + # Get the samples in parallel using tile-band combination - samples_tiles_bands <- .parallel_map(tiles_bands, function(tile_band) { - tile_id <- tile_band[[1]] + ts <- .parallel_map(tiles_bands, function(tile_band) { + tile_name <- tile_band[[1]] band <- tile_band[[2]] - + # Select the tile and band for extracting time series tile <- .select_raster_cube( data = cube, bands = c(band, cld_band), - tiles = tile_id - ) - hash_bundle <- digest::digest(list(tile, samples), algo = "md5") - # File to store the samples - filename <- .file_path( - "samples", hash_bundle, - ext = ".rds", - output_dir = output_dir + tiles = tile_name ) + tile_crs <- .tile_crs(tile) + # Create a hash based on tile and samples + hash <- digest::digest(list(tile, samples), algo = "md5") + # File to store the temporary samples + filename <- .file_samples_name(hash, output_dir) # Does the file exist? if (file.exists(filename)) { - tryCatch( - { # ensure that the file is not corrupted - timeseries <- readRDS(filename) - return(timeseries) - }, - error = function(e) { - unlink(filename) - gc() - } + timeseries <- .try( + expr = readRDS(filename), + .default = unlink(filename) ) + if (.has_ts(timeseries)) { + return(timeseries) + } } - # get XY - xy_tb <- .proj_from_latlong( - longitude = samples[["longitude"]], - latitude = samples[["latitude"]], - crs = .cube_crs(tile) + # Filter samples ... + samples <- .data_filter_samples( + samples = samples, cube = cube, samples_rep = samples_rep, + timeline = tl ) - # join lat-long with XY values in a single tibble - samples <- dplyr::bind_cols(samples, xy_tb) - # filter the points inside the data cube space-time extent - samples <- dplyr::filter( - samples, - .data[["X"]] > tile[["xmin"]], - .data[["X"]] < tile[["xmax"]], - .data[["Y"]] > tile[["ymin"]], - .data[["Y"]] < tile[["ymax"]], - .data[["start_date"]] <= as.Date(tl[length(tl)]), - .data[["end_date"]] >= as.Date(tl[[1]]) + # Create samples ... + samples <- .data_create_tibble( + samples = samples, + tile = tile, + timeline = tl ) - - # are there points to be retrieved from the cube? + # Are there points to be retrieved from the cube? if (nrow(samples) == 0) { return(NULL) } - # create a matrix to extract the values - xy <- matrix( - c(samples[["X"]], samples[["Y"]]), - nrow = nrow(samples), - ncol = 2 - ) - colnames(xy) <- c("X", "Y") - # build the sits tibble for the storing the points - samples_tbl <- slider::slide_dfr(samples, function(point) { - # get the valid timeline - dates <- .timeline_during( - timeline = tl, - start_date = as.Date(point[["start_date"]]), - end_date = as.Date(point[["end_date"]]) - ) - sample <- tibble::tibble( - longitude = point[["longitude"]], - latitude = point[["latitude"]], - start_date = dates[[1]], - end_date = dates[[length(dates)]], - label = point[["label"]], - cube = tile[["collection"]], - polygon_id = point[["polygon_id"]] - ) - # store them in the sample tibble - sample[["time_series"]] <- list(tibble::tibble(Index = dates)) - # return valid row of time series - sample - }) - # extract time series - ts <- .ts_get_raster_data( + + # Extract time series + samples <- .ts_get_raster_data( tile = tile, - points = samples_tbl, + points = samples, bands = band, impute_fn = impute_fn, - xy = xy, + xy = as.matrix(samples[, c("X", "Y")]), cld_band = cld_band ) - ts[["tile"]] <- tile_id - ts[["#..id"]] <- seq_len(nrow(ts)) - saveRDS(ts, filename) - ts - }, - progress = progress - ) + samples[["tile"]] <- tile_name + saveRDS(samples, filename) + samples + }, progress = progress) # bind rows to get a melted tibble of samples - ts_tbl <- dplyr::bind_rows(samples_tiles_bands) - if (!.has_ts(ts_tbl)) { + ts <- dplyr::bind_rows(ts) + if (!.has_ts(ts)) { warning(.conf("messages", ".data_by_tile"), immediate. = TRUE, call. = FALSE ) return(.tibble()) } - # reorganise the samples - ts_tbl <- ts_tbl |> - tidyr::unnest("time_series") |> - dplyr::group_by( - .data[["longitude"]], .data[["latitude"]], - .data[["start_date"]], .data[["end_date"]], - .data[["label"]], .data[["cube"]], - .data[["Index"]], .data[["tile"]], .data[["#..id"]] - ) - # is there a polygon id? This occurs when we have segments - if ("polygon_id" %in% colnames(ts_tbl)) { - ts_tbl <- dplyr::group_by(ts_tbl, .data[["polygon_id"]], .add = TRUE) - } - # create time series - ts_tbl <- ts_tbl |> - dplyr::reframe( - dplyr::across(dplyr::all_of(bands), stats::na.omit) - ) |> - dplyr::arrange(.data[["Index"]]) |> - dplyr::ungroup() |> - 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 |> - dplyr::group_by( - .data[["longitude"]], .data[["latitude"]], - .data[["start_date"]], .data[["end_date"]], - .data[["label"]], .data[["cube"]] - ) |> - dplyr::slice_head(n = 1) |> - dplyr::ungroup() + # Post-process the samples + ts <- .data_reorganise_ts(ts, bands) # recreate hash values hash_bundle <- purrr::map_chr(tiles_bands, function(tile_band) { tile_id <- tile_band[[1]] band <- tile_band[[2]] - tile <- .select_raster_cube(cube, bands = c(band, cld_band), - tiles = tile_id - ) - digest::digest(list(tile, samples), algo = "md5") - }) - # recreate file names to delete them - # samples will be recycled for each hash_bundle - temp_timeseries <- .file_path( - "samples", hash_bundle, - ext = "rds", - output_dir = output_dir - ) - # delete temporary rds - unlink(temp_timeseries) - gc() - # check if data has been retrieved - if (progress) { - .data_check(nrow(samples), nrow(ts_tbl)) - } - if (!inherits(ts_tbl, "sits")) { - class(ts_tbl) <- c("sits", class(ts_tbl)) - } - ts_tbl -} -#' @title get time series from data cubes using chunks -#' @name .data_by_chunks -#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} -#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} -#' @keywords internal -#' @noRd -#' @param cube Data cube from where data is to be retrieved. -#' @param samples Samples to be retrieved. -#' @param bands Bands to be retrieved (optional). -#' @param impute_fn Imputation function to remove NA. -#' @param cld_band Cloud band -#' @param multicores Number of threads to process the time series. -#' @param progress A logical value indicating if a progress bar -#' should be shown. -.data_by_chunks <- function(cube, - samples, - bands, - impute_fn, - cld_band, - multicores, - progress) { - # Get cube timeline - tl <- .cube_timeline(cube)[[1]] - # transform sits tibble to sf - samples_sf <- sits_as_sf(samples) - # Get chunks samples - chunks_samples <- .cube_split_chunks_samples( - cube = cube, samples_sf = samples_sf - ) - # Set output_dir - output_dir <- tempdir() - if (Sys.getenv("SITS_SAMPLES_CACHE_DIR") != "") { - output_dir <- Sys.getenv("SITS_SAMPLES_CACHE_DIR") - } - # To avoid open more process than chunks and samples combinations - if (multicores > length(chunks_samples)) { - multicores <- length(chunks_samples) - } - # Prepare parallelization - .parallel_start(workers = multicores) - on.exit(.parallel_stop(), add = TRUE) - # Get the samples in parallel using tile-band combination - samples_tiles_bands <- .parallel_map(chunks_samples, function(chunk) { tile <- .select_raster_cube( - data = cube, - bands = c(bands, cld_band), - tiles = chunk[["tile"]] - ) - # Get chunk samples - samples <- chunk[["samples"]][[1]] - hash_bundle <- digest::digest(list(tile, samples), algo = "md5") - # Create a file to store the samples - filename <- .file_path( - "samples", hash_bundle, - ext = ".rds", - output_dir = output_dir - ) - # Does the file exist? - if (file.exists(filename)) { - tryCatch( - { # ensure that the file is not corrupted - timeseries <- readRDS(filename) - return(timeseries) - }, - error = function(e) { - unlink(filename) - gc() - } - ) - } - # get XY - xy_tb <- .proj_from_latlong( - longitude = samples[["longitude"]], - latitude = samples[["latitude"]], - crs = .cube_crs(tile) - ) - # join lat-long with XY values in a single tibble - samples <- dplyr::bind_cols(samples, xy_tb) - # filter the points inside the data cube space-time extent - samples <- dplyr::filter( - samples, - .data[["X"]] > tile[["xmin"]], - .data[["X"]] < tile[["xmax"]], - .data[["Y"]] > tile[["ymin"]], - .data[["Y"]] < tile[["ymax"]], - .data[["start_date"]] <= as.Date(tl[[length(tl)]]), - .data[["end_date"]] >= as.Date(tl[[1]]) - ) - # are there points to be retrieved from the cube? - if (nrow(samples) == 0) { - return(NULL) - } - # create a matrix to extract the values - xy <- matrix( - c(samples[["X"]], samples[["Y"]]), - nrow = nrow(samples), - ncol = 2 + cube, bands = c(band, cld_band), tiles = tile_id ) - colnames(xy) <- c("X", "Y") - # build the sits tibble for the storing the points - samples_tbl <- slider::slide_dfr(samples, function(point) { - # get the valid timeline - dates <- .timeline_during( - timeline = tl, - start_date = as.Date(point[["start_date"]]), - end_date = as.Date(point[["end_date"]]) - ) - sample <- tibble::tibble( - longitude = point[["longitude"]], - latitude = point[["latitude"]], - start_date = dates[[1]], - end_date = dates[[length(dates)]], - label = point[["label"]], - cube = tile[["collection"]], - polygon_id = point[["polygon_id"]] - ) - # store them in the sample tibble - sample[["time_series"]] <- list(tibble::tibble(Index = dates)) - # return valid row of time series - sample - }) - # extract time series - ts <- .ts_get_raster_data( - tile = tile, - points = samples_tbl, - bands = bands, - impute_fn = impute_fn, - xy = xy, - cld_band = cld_band - ) - ts[["tile"]] <- chunk[["tile"]] - ts[["#..id"]] <- seq_len(nrow(ts)) - saveRDS(ts, filename) - ts - }, progress = progress) - # bind rows to get a melted tibble of samples - ts_tbl <- dplyr::bind_rows(samples_tiles_bands) - if (!.has_ts(ts_tbl)) { - warning(.conf("messages", ".data_by_chunks"), - immediate. = TRUE, call. = FALSE - ) - return(.tibble()) - } - # reorganise the samples - ts_tbl <- ts_tbl |> - tidyr::unnest("time_series") |> - dplyr::group_by( - .data[["longitude"]], .data[["latitude"]], - .data[["start_date"]], .data[["end_date"]], - .data[["label"]], .data[["cube"]], - .data[["Index"]], .data[["tile"]], .data[["#..id"]] - ) - # is there a polygon id? This occurs when we have segments - if ("polygon_id" %in% colnames(ts_tbl)) { - ts_tbl <- dplyr::group_by(ts_tbl, .data[["polygon_id"]], .add = TRUE) - } - # create time series - ts_tbl <- ts_tbl |> - dplyr::reframe( - dplyr::across(dplyr::all_of(bands), stats::na.omit) - ) |> - dplyr::arrange(.data[["Index"]]) |> - dplyr::ungroup() |> - 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 |> - dplyr::group_by( - .data[["longitude"]], .data[["latitude"]], - .data[["start_date"]], .data[["end_date"]], - .data[["label"]], .data[["cube"]] - ) |> - dplyr::slice_head(n = 1) |> - dplyr::ungroup() - # recreate hash values - hash_bundle <- purrr::map_chr(chunks_samples, function(chunk) { - tile <- .select_raster_cube( - data = cube, - bands = c(bands, cld_band), - tiles = chunk[["tile"]] - ) - # Get chunk samples - samples <- chunk[["samples"]][[1]] digest::digest(list(tile, samples), algo = "md5") }) - # recreate file names to delete them - # samples will be recycled for each hash_bundle - temp_timeseries <- .file_path( - "samples", hash_bundle, - ext = "rds", - output_dir = output_dir - ) - # delete temporary rds - unlink(temp_timeseries) + # Recreate file names to delete them + filename <- .file_samples_name(hash_bundle, output_dir) + # Delete temporary rds + unlink(filename) + unlink(.dissolve(samples_rep)) gc() # check if data has been retrieved if (progress) { - .data_check(nrow(samples), nrow(ts_tbl)) + .message_data_check(nrow(samples), nrow(ts)) } - if (!inherits(ts_tbl, "sits")) { - class(ts_tbl) <- c("sits", class(ts_tbl)) + if (!inherits(ts, "sits")) { + class(ts) <- c("sits", class(ts)) } - ts_tbl -} -#' @title get time series from base tiles -#' @name .data_base_tiles -#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} -#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} -#' @keywords internal -#' @noRd -#' @param cube Data cube from where data is to be retrieved. -#' @param samples Samples to be retrieved. -#' @param ts_time Time series from multitemporal bands -#' -#' @return Time series information with base tile data -#' -.data_base_tiles <- function(cube, samples) { - # retrieve values from samples - # - # read each tile - samples <- slider::slide_dfr(cube, function(tile) { - # get XY - xy_tb <- .proj_from_latlong( - longitude = samples[["longitude"]], - latitude = samples[["latitude"]], - crs = .cube_crs(tile) - ) - # join lat-long with XY values in a single tibble - samples <- dplyr::bind_cols(samples, xy_tb) - # filter the points inside the data cube space-time extent - samples <- dplyr::filter( - samples, - .data[["X"]] > tile[["xmin"]], - .data[["X"]] < tile[["xmax"]], - .data[["Y"]] > tile[["ymin"]], - .data[["Y"]] < tile[["ymax"]] - ) - - # are there points to be retrieved from the cube? - if (nrow(samples) == 0) { - return(NULL) - } - # create a matrix to extract the values - xy <- matrix( - c(samples[["X"]], samples[["Y"]]), - nrow = nrow(samples), - ncol = 2 - ) - colnames(xy) <- c("X", "Y") - - # get the values of the time series as matrix - base_bands <- .tile_base_bands(tile) - samples <- purrr::map_dbl(base_bands, function(band) { - values_base_band <- .tile_base_extract( - tile = tile, - band = band, - xy = xy - ) - samples[[band]] <- values_base_band - samples - }) - samples - }) + ts } #' @title function to get class for point in a classified cube @@ -898,7 +273,7 @@ # insert classes into samples samples[["label"]] <- unname(classes) samples <- dplyr::select(samples, dplyr::all_of("longitude"), - dplyr::all_of("latitude"), dplyr::all_of("label")) + dplyr::all_of("latitude"), dplyr::all_of("label")) samples }) data @@ -1047,3 +422,159 @@ # insert classes into samples dplyr::bind_cols(samples, data) } + +#' @title Extracts the time series average by polygon. +#' @name .data_avg_polygon +#' @keywords internal +#' @noRd +#' @description This function extracts the average of the automatically +#' generated points for each polygon in a shapefile. +#' +#' @param data A sits tibble with points time series. +#' +#' @return A sits tibble with the average of all points by each polygon. +.data_avg_polygon <- function(data) { + bands <- .samples_bands(data) + columns_to_avg <- c(bands, "latitude", "longitude") + data_avg <- data |> + tidyr::unnest(cols = "time_series") |> + dplyr::group_by( + .data[["Index"]], + .data[["start_date"]], + .data[["end_date"]], + .data[["label"]], + .data[["cube"]], + .data[["polygon_id"]] + ) |> + dplyr::summarise(dplyr::across(!!columns_to_avg, function(x) { + mean(x, na.rm = TRUE) + }), .groups = "drop") |> + tidyr::nest("time_series" = c("Index", dplyr::all_of(bands))) |> + dplyr::select(!!colnames(data)) + + class(data_avg) <- class(data) + data_avg +} + +.timeline_filter <- function(timeline, samples) { + start_date <- samples[["start_date"]] + end_date <- samples[["end_date"]] + timeline[timeline >= start_date & timeline <= end_date] +} + +.data_lazy_reproject <- function(samples, cube, output_dir) { + xy_list <- purrr::map(.cube_crs(cube), function(cube_crs) { + # Create a hash based on crs and samples + hash <- digest::digest(list(cube_crs, samples), algo = "md5") + # File to store the temporary samples + filename <- .file_samples_name(hash, output_dir) + xy <- .proj_from_latlong( + longitude = samples[["longitude"]], + latitude = samples[["latitude"]], + crs = cube_crs + ) + saveRDS(xy, filename) + filename + }) + names(xy_list) <- .cube_crs(cube) + xy_list +} + +.data_filter_samples <- function(samples, cube, samples_rep, timeline) { + cube_crs <- .cube_crs(cube) + # Read the reprojected samples + samples_rep <- readRDS(samples_rep[[cube_crs]]) + # join lat-long with XY values in a single tibble + samples <- dplyr::bind_cols(samples, samples_rep) + # Filter samples extent + dplyr::filter( + samples, + .data[["X"]] > cube[["xmin"]], + .data[["X"]] < cube[["xmax"]], + .data[["Y"]] > cube[["ymin"]], + .data[["Y"]] < cube[["ymax"]], + .data[["start_date"]] <= as.Date(timeline[[length(timeline)]]), + .data[["end_date"]] >= as.Date(timeline[[1]]) + ) +} + +.data_create_tibble <- function(samples, tile, timeline) { + samples[["#..id"]] <- seq_len(nrow(samples)) + samples[["cube"]] <- .tile_collection(tile) + # build the sits tibble for the storing the points + samples <- samples |> + dplyr::group_by(.data[["#..id"]]) |> + dplyr::mutate( + Index = list(Index = .timeline_filter(timeline, .data)) + ) |> + tidyr::unnest("Index") |> + dplyr::mutate( + start_date = min(.data[["Index"]]), + end_date = max(.data[["Index"]]) + ) |> + tidyr::nest(time_series = "Index") |> + dplyr::ungroup() +} + +.data_reorganise_ts <- function(ts, bands) { + # reorganise the samples + ts <- ts |> + tidyr::unnest("time_series") |> + dplyr::group_by( + .data[["longitude"]], .data[["latitude"]], + .data[["start_date"]], .data[["end_date"]], + .data[["label"]], .data[["cube"]], + .data[["Index"]], .data[["tile"]], .data[["#..id"]] + ) + # is there a polygon id? This occurs when we have segments + if ("polygon_id" %in% colnames(ts)) { + ts <- dplyr::group_by( + ts, .data[["polygon_id"]], .add = TRUE + ) + } + # Verify NA values in time series + ts <- ts |> + dplyr::reframe( + dplyr::across(dplyr::all_of(bands), stats::na.omit) + ) |> + dplyr::arrange(.data[["Index"]]) |> + dplyr::ungroup() |> + 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 |> + dplyr::group_by( + .data[["longitude"]], .data[["latitude"]], + .data[["start_date"]], .data[["end_date"]], + .data[["label"]], .data[["cube"]] + ) |> + dplyr::slice_head(n = 1) |> + dplyr::ungroup() +} + +#' @name .data_combine_ts +#' @keywords internal +#' @noRd +#' @export +.data_combine_ts <- function(samples_ts, base_ts) { + # prepare output data + base_ts <- base_ts |> + dplyr::select("longitude", "latitude", "time_series") |> + dplyr::rename("base_data" = "time_series") + # Assuming `ts_tbl` as the source of truth, the size of the following + # `join` must be the same as the current `ts_tbl`. + ts_tbl_size <- nrow(samples_ts) + # joining samples data from cube and base_cube by longitude / latitude + samples_ts <- dplyr::left_join( + x = samples_ts, + y = base_ts, + by = c("longitude", "latitude") + ) |> + tidyr::drop_na() + # checking samples consistency + .message_data_check(ts_tbl_size, nrow(samples_ts)) + # add base class (`sits` is added as it is removed in the join above) + class(samples_ts) <- unique(c("sits_base", "sits", class(samples_ts))) + samples_ts +} diff --git a/R/sits_get_data.R b/R/sits_get_data.R index d72091ea8..ea4ada19c 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -106,8 +106,7 @@ #' } #' #' @export -sits_get_data <- function(cube, - samples, ...) { +sits_get_data <- function(cube, samples, ...) { .check_set_caller("sits_get_data") # Pre-conditions .check_is_raster_cube(cube) @@ -118,12 +117,6 @@ sits_get_data <- function(cube, } UseMethod("sits_get_data", samples) } -#' @rdname sits_get_data -#' -#' @export -sits_get_data.default <- function(cube, samples, ...) { - stop(.conf("messages", "sits_get_data_default")) -} #' @title Get time series using CSV files #' @name sits_get_data.csv @@ -172,13 +165,13 @@ sits_get_data.csv <- function(cube, impute_fn = impute_linear(), multicores = 2, progress = FALSE) { - if (!.has(bands)) - bands <- .cube_bands(cube) + # Pre-conditions + bands <- .default(bands, .cube_bands(cube)) .check_cube_bands(cube, bands = bands) .check_crs(crs) - .check_int_parameter(multicores, min = 1, max = 2048) - progress <- .message_progress(progress) .check_function(impute_fn) + .check_int_parameter(multicores, min = 1) + progress <- .message_progress(progress) # Extract a data frame from csv samples <- .csv_get_samples(samples) # Extract time series from a cube given a data.frame @@ -281,16 +274,25 @@ sits_get_data.shp <- function(cube, sampling_type = "random", multicores = 2, progress = FALSE) { + # Set caller for error messages .check_set_caller("sits_get_data_shp") - if (!.has(bands)) - bands <- .cube_bands(cube) + # Pre-conditions + bands <- .default(bands, .cube_bands(cube)) .check_cube_bands(cube, bands = bands) + .check_function(impute_fn) + .check_chr_parameter(label, allow_null = TRUE) + .check_chr_parameter(label_attr, allow_null = TRUE) + .check_int_parameter(n_sam_pol, min = 1, max = 2048) + .check_lgl_parameter(pol_avg) + .check_chr_parameter(sampling_type) + .check_int_parameter(multicores, min = 1) + progress <- .message_progress(progress) # Get default start and end date start_date <- .default(start_date, .cube_start_date(cube)) end_date <- .default(end_date, .cube_end_date(cube)) - .check_int_parameter(multicores, min = 1, max = 2048) - progress <- .message_progress(progress) - + cube <- .cube_filter_interval( + cube = cube, start_date = start_date, end_date = end_date + ) # Extract a data frame from shapefile samples <- .shp_get_samples( shp_file = samples, @@ -406,13 +408,19 @@ sits_get_data.sf <- function(cube, sampling_type = "random", multicores = 2, progress = FALSE) { + # Set caller for error messages .check_set_caller("sits_get_data_sf") - if (!.has(bands)) - bands <- .cube_bands(cube) + # Pre-conditions + bands <- .default(bands, .cube_bands(cube)) .check_cube_bands(cube, bands = bands) - .check_int_parameter(multicores, min = 1, max = 2048) - progress <- .message_progress(progress) .check_function(impute_fn) + .check_chr_parameter(label, allow_null = TRUE) + .check_chr_parameter(label_attr, allow_null = TRUE) + .check_int_parameter(n_sam_pol, min = 1, max = 2048) + .check_lgl_parameter(pol_avg) + .check_chr_parameter(sampling_type) + .check_int_parameter(multicores, min = 1) + progress <- .message_progress(progress) # Get default start and end date start_date <- .default(start_date, .cube_start_date(cube)) end_date <- .default(end_date, .cube_end_date(cube)) @@ -476,7 +484,15 @@ sits_get_data.sits <- function(cube, impute_fn = impute_linear(), multicores = 2, progress = FALSE) { + # Set caller for error messages + .check_set_caller("sits_get_data") + # Pre-conditions bands <- .default(bands, .cube_bands(cube)) + .check_cube_bands(cube, bands = bands) + .check_crs(crs) + .check_function(impute_fn) + .check_int_parameter(multicores, min = 1) + progress <- .message_progress(progress) # Extract time series from a cube given a data.frame data <- .data_get_ts( cube = cube, @@ -542,23 +558,33 @@ sits_get_data.data.frame <- function(cube, start_date = NULL, end_date = NULL, bands = NULL, + impute_fn = impute_linear(), label = "NoClass", crs = "EPSG:4326", - impute_fn = impute_linear(), multicores = 2, progress = FALSE) { + # Set caller for error messages .check_set_caller("sits_get_data_data_frame") - if (!.has(bands)) - bands <- .cube_bands(cube) + # Pre-conditions + bands <- .default(bands, .cube_bands(cube)) + .check_cube_bands(cube, bands = bands) + .check_function(impute_fn) + .check_chr_parameter(label, allow_null = TRUE) + .check_crs(crs) + .check_int_parameter(multicores, min = 1) # Check if samples contains all the required columns .check_chr_contains( x = colnames(samples), contains = c("latitude", "longitude"), discriminator = "all_of" ) + progress <- .message_progress(progress) # Get default start and end date start_date <- .default(start_date, .cube_start_date(cube)) end_date <- .default(end_date, .cube_end_date(cube)) + cube <- .cube_filter_interval( + cube = cube, start_date = start_date, end_date = end_date + ) # Fill missing columns if (!.has_column(samples, "label")) { samples[["label"]] <- label @@ -583,3 +609,10 @@ sits_get_data.data.frame <- function(cube, ) return(data) } + +#' @rdname sits_get_data +#' +#' @export +sits_get_data.default <- function(cube, samples, ...) { + stop(.conf("messages", "sits_get_data_default")) +} From b8a64fa4de1fe2cd39e5f8a2e472a5dd0ddc859e Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 23 Apr 2025 19:00:03 +0000 Subject: [PATCH 090/122] create a pattern for temporary samples --- R/api_file.R | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/R/api_file.R b/R/api_file.R index d0696882d..5bbfed721 100644 --- a/R/api_file.R +++ b/R/api_file.R @@ -131,6 +131,22 @@ ) } +#' @title Create a file path for samples +#' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @noRd +#' @param hash Character with the bundle hash value +#' @param output_dir Directory where the saves will be saved +#' @param ext file block extension +#' @returns File path for the samples +.file_samples_name <- function(hash, output_dir, ext = "rds") { + .file_path( + "samples", hash, ext = ext, output_dir = file.path(output_dir, ".sits"), + create_dir = TRUE + ) +} + #' @title Build a file path for a derived file #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} From c2efbd45089c648cc19e1e3e644ef865d5151a0f Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 23 Apr 2025 19:01:07 +0000 Subject: [PATCH 091/122] update sf API --- R/api_sf.R | 49 +++++++++++++++++-------------------------------- R/api_utils.R | 4 ++++ 2 files changed, 21 insertions(+), 32 deletions(-) diff --git a/R/api_sf.R b/R/api_sf.R index 6cacb5acd..94aaebd79 100644 --- a/R/api_sf.R +++ b/R/api_sf.R @@ -190,38 +190,23 @@ within = colnames(sf_df) ) } - points_tab <- seq_len(nrow(sf_object)) |> - .map_dfr(function(row_id) { - # retrieve the class from the shape attribute - if ("label" %in% colnames(sf_df)) { - label <- as.character( - unlist(sf_df[row_id, "label"], use.names = FALSE) - ) - } else if (.has(label_attr) && - label_attr %in% colnames(sf_df)) { - label <- as.character( - unlist(sf_df[row_id, label_attr], use.names = FALSE) - ) - } - # obtain a set of samples based on polygons - points <- list(sf::st_sample(sf_object[row_id, ], - type = sampling_type, - size = n_sam_pol)) - # get one time series per sample - pts_tab <- points |> - purrr::pmap_dfr(function(p) { - pll <- sf::st_geometry(p)[[1]] - row <- tibble::tibble( - longitude = pll[[1]], - latitude = pll[[2]], - label = label, - polygon_id = row_id - ) - return(row) - }) - return(pts_tab) - }) - return(points_tab) + sf_object[["polygon_id"]] <- seq_len(nrow(sf_object)) + + if (.has(label_attr)) { + sf_object[["label"]] <- sf_df[["label_attr"]] + } + + sf_object <- sf::st_sample( + x = sf_object, + type = sampling_type, + size = n_sam_pol, + by_polygon = TRUE + ) + sf_object[["longitude"]] <- sf::st_coordinates(sf_object)[,1] + sf_object[["latitude"]] <- sf::st_coordinates(sf_object)[,2] + sf_object <- sf::st_drop_geometry(sf_object) + + sf_object } #' @title Clean invalid geometries diff --git a/R/api_utils.R b/R/api_utils.R index 64c02336c..1fa94dd23 100644 --- a/R/api_utils.R +++ b/R/api_utils.R @@ -76,6 +76,10 @@ NULL !.has(x) } +.has_cloud <- function(bands) { + .source_cloud() %in% bands +} + #' @title Check if an input has names or not. If there is #' any element without a name the function evaluates as \code{FALSE}. #' Returns \code{logical}. From 9d7588a295e04e27249eefa9701a94ad60513431 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 23 Apr 2025 19:01:44 +0000 Subject: [PATCH 092/122] add message for data check --- R/api_message.R | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/R/api_message.R b/R/api_message.R index 740d81bc8..56ee6665c 100644 --- a/R/api_message.R +++ b/R/api_message.R @@ -109,3 +109,27 @@ # avoids use of underscores tolower(gsub("_", "-", version)) } + +#' @title Check if all points have been retrieved +#' @name .message_data_check +#' @keywords internal +#' @noRd +#' @param n_rows_input Number of rows in input. +#' @param n_rows_output Number of rows in output. +#' +#' @return No return value, called for side effects. +#' +.message_data_check <- function(n_rows_input, n_rows_output) { + # Have all input rows being read? + if (n_rows_output == 0) { + message("No points have been retrieved") + return(invisible(FALSE)) + } + + if (n_rows_output < n_rows_input) { + message("Some points could not be retrieved") + } else { + message("All points have been retrieved") + } + invisible(n_rows_input) +} From 56b335739cf0814ac0d3424f3b8591745208a59d Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 23 Apr 2025 19:01:57 +0000 Subject: [PATCH 093/122] upate docs --- NAMESPACE | 2 +- man/sits_get_data.data.frame.Rd | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index de1f7236f..5b49f0128 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -91,7 +91,6 @@ S3method(.cube_timeline_acquisition,default) S3method(.cube_timeline_acquisition,raster_cube) S3method(.cube_token_generator,default) S3method(.cube_token_generator,mpc_cube) -S3method(.data_get_ts,class_cube) S3method(.data_get_ts,raster_cube) S3method(.dc_bands,bayts_model) S3method(.dc_bands,sits_model) @@ -474,6 +473,7 @@ S3method(summary,variance_cube) export("sits_bands<-") export("sits_labels<-") export(.check_samples.default) +export(.data_combine_ts) export(impute_linear) export(sits_accuracy) export(sits_accuracy_summary) diff --git a/man/sits_get_data.data.frame.Rd b/man/sits_get_data.data.frame.Rd index c91e758ed..3c1e6272b 100644 --- a/man/sits_get_data.data.frame.Rd +++ b/man/sits_get_data.data.frame.Rd @@ -11,9 +11,9 @@ start_date = NULL, end_date = NULL, bands = NULL, + impute_fn = impute_linear(), label = "NoClass", crs = "EPSG:4326", - impute_fn = impute_linear(), multicores = 2, progress = FALSE ) @@ -36,14 +36,14 @@ and \code{latitude}, and optional columns \item{bands}{Bands to be retrieved - optional.} +\item{impute_fn}{Imputation function to remove NA.} + \item{label}{Label to be assigned to all time series if column \code{label} is not provided in the data.frame.} \item{crs}{Default crs for the samples.} -\item{impute_fn}{Imputation function to remove NA.} - \item{multicores}{Number of threads to process the time series (integer, with min = 1 and max = 2048).} From 0e5667f3d4113e040982c466589686646155a641 Mon Sep 17 00:00:00 2001 From: Felipe Date: Wed, 23 Apr 2025 22:32:21 +0000 Subject: [PATCH 094/122] fix api_data in sits_get_data --- R/api_data.R | 35 ++++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 15 deletions(-) diff --git a/R/api_data.R b/R/api_data.R index 136a398a8..3ec759193 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -159,9 +159,13 @@ } # Filter samples ... samples <- .data_filter_samples( - samples = samples, cube = cube, samples_rep = samples_rep, + samples = samples, tile = tile, samples_rep = samples_rep, timeline = tl ) + # Are there points to be retrieved from the cube? + if (nrow(samples) == 0L) { + return(NULL) + } # Create samples ... samples <- .data_create_tibble( samples = samples, @@ -463,36 +467,37 @@ } .data_lazy_reproject <- function(samples, cube, output_dir) { - xy_list <- purrr::map(.cube_crs(cube), function(cube_crs) { + cube_crs <- unique(.cube_crs(cube)) + xy_list <- purrr::map(cube_crs, function(crs) { # Create a hash based on crs and samples - hash <- digest::digest(list(cube_crs, samples), algo = "md5") + hash <- digest::digest(list(crs, samples), algo = "md5") # File to store the temporary samples filename <- .file_samples_name(hash, output_dir) xy <- .proj_from_latlong( longitude = samples[["longitude"]], latitude = samples[["latitude"]], - crs = cube_crs + crs = crs ) saveRDS(xy, filename) filename }) - names(xy_list) <- .cube_crs(cube) + names(xy_list) <- cube_crs xy_list } -.data_filter_samples <- function(samples, cube, samples_rep, timeline) { - cube_crs <- .cube_crs(cube) +.data_filter_samples <- function(samples, tile, samples_rep, timeline) { + crs <- .tile_crs(tile) # Read the reprojected samples - samples_rep <- readRDS(samples_rep[[cube_crs]]) + samples_rep <- readRDS(samples_rep[[crs]]) # join lat-long with XY values in a single tibble samples <- dplyr::bind_cols(samples, samples_rep) # Filter samples extent dplyr::filter( samples, - .data[["X"]] > cube[["xmin"]], - .data[["X"]] < cube[["xmax"]], - .data[["Y"]] > cube[["ymin"]], - .data[["Y"]] < cube[["ymax"]], + .data[["X"]] > tile[["xmin"]], + .data[["X"]] < tile[["xmax"]], + .data[["Y"]] > tile[["ymin"]], + .data[["Y"]] < tile[["ymax"]], .data[["start_date"]] <= as.Date(timeline[[length(timeline)]]), .data[["end_date"]] >= as.Date(timeline[[1]]) ) @@ -502,15 +507,15 @@ samples[["#..id"]] <- seq_len(nrow(samples)) samples[["cube"]] <- .tile_collection(tile) # build the sits tibble for the storing the points - samples <- samples |> + samples |> dplyr::group_by(.data[["#..id"]]) |> dplyr::mutate( Index = list(Index = .timeline_filter(timeline, .data)) ) |> tidyr::unnest("Index") |> dplyr::mutate( - start_date = min(.data[["Index"]]), - end_date = max(.data[["Index"]]) + start_date = as.Date(min(.data[["Index"]])), + end_date = as.Date(max(.data[["Index"]])) ) |> tidyr::nest(time_series = "Index") |> dplyr::ungroup() From 992838b10533e4ebc36c71cfb08b36d707c961e5 Mon Sep 17 00:00:00 2001 From: Felipe Date: Thu, 24 Apr 2025 01:32:25 +0000 Subject: [PATCH 095/122] update api_data --- R/api_data.R | 54 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 31 insertions(+), 23 deletions(-) diff --git a/R/api_data.R b/R/api_data.R index 3ec759193..685afa9b1 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -198,30 +198,38 @@ ) return(.tibble()) } - # Post-process the samples - ts <- .data_reorganise_ts(ts, bands) - # recreate hash values - hash_bundle <- purrr::map_chr(tiles_bands, function(tile_band) { - tile_id <- tile_band[[1]] - band <- tile_band[[2]] - tile <- .select_raster_cube( - cube, bands = c(band, cld_band), tiles = tile_id - ) - digest::digest(list(tile, samples), algo = "md5") + parts <- nrow(ts) %/% 10000 + ts[["part_id"]] <- .partitions(x = seq_len(nrow(ts)), n = parts) + ts <- tidyr::nest(ts, predictors = -"part_id") + ts <- .jobs_map_sequential_dfr(ts[1,], function(part) { + part <- part[["predictors"]][[1]] + # Post-process the samples + part <- .data_reorganise_ts(part, bands) + # recreate hash values + hash_bundle <- purrr::map_chr(tiles_bands, function(tile_band) { + tile_id <- tile_band[[1]] + band <- tile_band[[2]] + tile <- .select_raster_cube( + cube, bands = c(band, cld_band), tiles = tile_id + ) + digest::digest(list(tile, samples), algo = "md5") + }) + # Recreate file names to delete them + filename <- .file_samples_name(hash_bundle, output_dir) + # Delete temporary rds + unlink(filename) + unlink(.dissolve(samples_rep)) + gc() + # check if data has been retrieved + if (progress) { + .message_data_check(nrow(samples), nrow(part)) + } + if (!inherits(part, "sits")) { + class(part) <- c("sits", class(part)) + } + part }) - # Recreate file names to delete them - filename <- .file_samples_name(hash_bundle, output_dir) - # Delete temporary rds - unlink(filename) - unlink(.dissolve(samples_rep)) - gc() - # check if data has been retrieved - if (progress) { - .message_data_check(nrow(samples), nrow(ts)) - } - if (!inherits(ts, "sits")) { - class(ts) <- c("sits", class(ts)) - } + ts } From 0939eb6fd7b65f5a70bfeb97210ec0f63acd3f60 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Thu, 24 Apr 2025 06:48:34 -0300 Subject: [PATCH 096/122] running test --- tests/testthat/test-check.R | 2 +- tests/testthat/test-cube-cdse.R | 3 +++ tests/testthat/test-data.R | 40 +++++++++++++++++--------------- tests/testthat/test-regularize.R | 22 ++++++------------ 4 files changed, 32 insertions(+), 35 deletions(-) diff --git a/tests/testthat/test-check.R b/tests/testthat/test-check.R index 39a8520e7..afe066220 100644 --- a/tests/testthat/test-check.R +++ b/tests/testthat/test-check.R @@ -77,7 +77,7 @@ test_that("Caller", { within = c("a", "b", "c"), discriminator = "true_of" ), - ".check_chr_within: discriminator should be one of" + ".check_discriminator: discriminators available are 'one_of', 'any_of', 'all_of', 'none_of', and 'exactly'" ) expect_error( .check_chr_within(c("a", "b"), diff --git a/tests/testthat/test-cube-cdse.R b/tests/testthat/test-cube-cdse.R index 4d761b493..94ddc7beb 100644 --- a/tests/testthat/test-cube-cdse.R +++ b/tests/testthat/test-cube-cdse.R @@ -1,5 +1,7 @@ test_that("Creating S2 cubes from CDSE with ROI", { # Configure environment + # # Configure environment + cdse_env_config <- .environment_cdse() # Patch environment variables .environment_patch(cdse_env_config) # Test @@ -83,6 +85,7 @@ test_that("Creating S2 cubes from CDSE with tiles", { .environment_rollback(cdse_env_config) }) +withr::with_envvar(new = c(SITS_DOCUMENTATION_MODE = "TRUE"), devtools::test()) test_that("Creating Sentinel-1 RTC cubes from CDSE", { # Configure environment cdse_env_config <- .environment_cdse() diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index cb57d8a50..f6df95e2e 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -111,15 +111,14 @@ test_that("Retrieving points from BDC using POLYGON shapefiles", { ) # get the timeline cube_timeline <- sits_timeline(modis_cube) - # Retrieve points based on a POLYGON shapefile - points_shp <- sits_get_data( + points_shp <- suppressMessages(sits_get_data( modis_cube, samples = shp_file, n_sam_pol = 5, progress = FALSE, multicores = 1 - ) + )) expect_equal(object = nrow(points_shp), expected = 5) expect_equal( object = unique(points_shp[["start_date"]]), @@ -148,13 +147,13 @@ test_that("Retrieving points from BDC using POLYGON shapefiles", { # retrieve labelled points from BDC cube - points_shp_avg <- sits_get_data(modis_cube, + points_shp_avg <- suppressMessages(sits_get_data(modis_cube, samples = shp_file, n_sam_pol = 5, label_attr = "NM_ESTADO", pol_avg = TRUE, progress = FALSE - ) + )) expect_equal(object = nrow(points_shp_avg), expected = 1) expect_equal( @@ -162,12 +161,12 @@ test_that("Retrieving points from BDC using POLYGON shapefiles", { expected = "MATO GROSSO" ) # retrieve points from BDC cube with no label - points_shp_no_label <- sits_get_data(modis_cube, + points_shp_no_label <- suppressMessages(sits_get_data(modis_cube, samples = shp_file, n_sam_pol = 5, pol_avg = TRUE, progress = FALSE - ) + )) expect_equal(object = nrow(points_shp_no_label), expected = 1) expect_equal( @@ -214,11 +213,11 @@ test_that("Retrieving points from BDC using POINT shapefiles", { ) tf <- paste0(tempdir(), "/cerrado_forested.shp") sf::st_write(sf_cf[1:5, ], dsn = tf, quiet = TRUE, append = FALSE) - points_cf <- sits_get_data(modis_cube, + points_cf <- suppressMessages(sits_get_data(modis_cube, samples = tf, label = "Woodland", progress = FALSE - ) + )) cube_timeline <- sits_timeline(modis_cube) expect_equal(object = nrow(points_cf), expected = 5) expect_equal( @@ -264,7 +263,7 @@ test_that("Retrieving points from BDC using sits tibble", { .default = NULL ) testthat::skip_if(purrr::is_null(modis_cube), - message = "MPC is not accessible" + message = "BDC is not accessible" ) # create a sits_tibble to retrieve the data # first select unique locations @@ -277,10 +276,10 @@ test_that("Retrieving points from BDC using sits tibble", { input_tb <- cerrado_pts[1:5, ] input_tb$start_date <- as.Date("2018-08-22") input_tb$end_date <- as.Date("2019-08-30") - points_tb <- sits_get_data(modis_cube, + points_tb <- suppressMessages(sits_get_data(modis_cube, samples = input_tb, progress = FALSE - ) + )) cube_timeline <- sits_timeline(modis_cube) expect_equal(object = nrow(points_tb), expected = 5) expect_equal( @@ -327,11 +326,11 @@ test_that("Retrieving points from BDC using sf objects", { testthat::skip_if(purrr::is_null(modis_cube), message = "MPC is not accessible" ) - points_cf <- sits_get_data(modis_cube, + points_cf <- suppressMessages(sits_get_data(modis_cube, samples = sf_cf[1:5, ], label = "Woodland", progress = FALSE - ) + )) cube_timeline <- sits_timeline(modis_cube) expect_equal(object = nrow(points_cf), expected = 5) @@ -388,11 +387,11 @@ test_that("Retrieving points from BDC using sf objects", { message = "BDC is not accessible" ) # obtain a set of points based on an SF POLYGOn geometry - points_poly <- sits_get_data(modis_cube, + points_poly <- suppressMessages(sits_get_data(modis_cube, samples = sf_mt, n_sam_pol = 5, progress = FALSE - ) + )) cube_timeline <- sits_timeline(modis_cube) expect_equal(object = nrow(points_poly), expected = 5) @@ -449,6 +448,7 @@ test_that("Retrieving points from MPC Base Cube", { end_date = "2019-08-30", bands = c("B05", "CLOUD"), roi = roi, + crs = 4326, progress = FALSE ) s2_cube_reg <- suppressWarnings(sits_regularize( @@ -464,24 +464,26 @@ test_that("Retrieving points from MPC Base Cube", { dem_cube <- sits_cube( source = "MPC", collection = "COP-DEM-GLO-30", - roi = roi + roi = roi, + crs = 4326 ) dem_cube_reg <- sits_regularize( cube = dem_cube, multicores = 1, res = 232, roi = roi, + crs = 4326, output_dir = regdir ) # create base cube base_cube <- sits_add_base_cube(s2_cube_reg, dem_cube_reg) # extract data - samples_ts <- sits_get_data( + samples_ts <- suppressMessages(sits_get_data( base_cube, samples = samples, multicores = 1 - ) + )) # validations cube_timeline <- sits_timeline(base_cube) expect_equal(object = nrow(samples_ts), expected = 13) diff --git a/tests/testthat/test-regularize.R b/tests/testthat/test-regularize.R index a3608e98d..19ce35dba 100644 --- a/tests/testthat/test-regularize.R +++ b/tests/testthat/test-regularize.R @@ -33,7 +33,7 @@ test_that("Regularizing cubes from AWS, and extracting samples from them", { suppressWarnings(dir.create(dir_images)) } - expect_warning(rg_cube <- sits_regularize( + rg_cube <- suppressWarnings(sits_regularize( cube = s2_cube_open, output_dir = dir_images, res = 240, @@ -42,12 +42,6 @@ test_that("Regularizing cubes from AWS, and extracting samples from them", { progress = FALSE )) - tile_bbox <- .tile_bbox(rg_cube) - expect_equal(.tile_nrows(rg_cube), 458) - expect_equal(.tile_ncols(rg_cube), 458) - expect_equal(tile_bbox$xmax, 309780, tolerance = 1e-1) - expect_equal(tile_bbox$xmin, 199980, tolerance = 1e-1) - tile_fileinfo <- .fi(rg_cube) expect_equal(nrow(tile_fileinfo), 2) @@ -99,6 +93,7 @@ test_that("Creating Landsat cubes from MPC", { source = "MPC", collection = "LANDSAT-C2-L2", roi = bbox, + crs = 4326, bands = c("NIR08", "CLOUD"), start_date = as.Date("2008-07-18"), end_date = as.Date("2008-10-23"), @@ -124,16 +119,14 @@ test_that("Creating Landsat cubes from MPC", { if (!dir.exists(output_dir)) { dir.create(output_dir) } - rg_landsat <- sits_regularize( + rg_landsat <- suppressWarnings(sits_regularize( cube = landsat_cube, output_dir = output_dir, res = 240, period = "P30D", multicores = 1, progress = FALSE - ) - expect_equal(.tile_nrows(.tile(rg_landsat)), 856) - expect_equal(.tile_ncols(.tile(rg_landsat)), 967) + )) expect_true(.cube_is_regular(rg_landsat)) @@ -144,6 +137,7 @@ test_that("Creating Landsat cubes from MPC", { collection = "LANDSAT-C2-L2", platform = "LANDSAT-5", roi = bbox, + crs = 4326, bands = c("NIR08", "CLOUD"), start_date = as.Date("2008-07-18"), end_date = as.Date("2008-10-23"), @@ -183,15 +177,13 @@ test_that("Regularizing local cubes without CLOUD BAND", { dir.create(output_dir) } # regularize local cube - expect_warning({ - local_reg_cube <- sits_regularize( + local_reg_cube <- suppressWarnings(sits_regularize( cube = local_cube, period = "P2M", res = 500, output_dir = output_dir, progress = FALSE - ) - }) + )) tl_orig <- sits_timeline(local_cube) tl_reg <- sits_timeline(local_reg_cube) From e673c8b77a821101d248cf8f76d01163096dbb17 Mon Sep 17 00:00:00 2001 From: Felipe Date: Thu, 24 Apr 2025 14:22:25 +0000 Subject: [PATCH 097/122] add batch strategy to split up the samples --- R/api_data.R | 56 +++++++++++++++++++++++++++------------------------- 1 file changed, 29 insertions(+), 27 deletions(-) diff --git a/R/api_data.R b/R/api_data.R index 685afa9b1..9977aa83e 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -198,37 +198,39 @@ ) return(.tibble()) } - parts <- nrow(ts) %/% 10000 + ts <- tidyr::nest(ts, predictors = -"#..id") + parts <- nrow(ts) %/% (length(bands) * nrow(cube)) ts[["part_id"]] <- .partitions(x = seq_len(nrow(ts)), n = parts) ts <- tidyr::nest(ts, predictors = -"part_id") - ts <- .jobs_map_sequential_dfr(ts[1,], function(part) { - part <- part[["predictors"]][[1]] - # Post-process the samples - part <- .data_reorganise_ts(part, bands) - # recreate hash values - hash_bundle <- purrr::map_chr(tiles_bands, function(tile_band) { - tile_id <- tile_band[[1]] - band <- tile_band[[2]] - tile <- .select_raster_cube( - cube, bands = c(band, cld_band), tiles = tile_id - ) - digest::digest(list(tile, samples), algo = "md5") - }) - # Recreate file names to delete them - filename <- .file_samples_name(hash_bundle, output_dir) - # Delete temporary rds - unlink(filename) - unlink(.dissolve(samples_rep)) - gc() - # check if data has been retrieved - if (progress) { - .message_data_check(nrow(samples), nrow(part)) - } - if (!inherits(part, "sits")) { - class(part) <- c("sits", class(part)) - } + ts <- .jobs_map_parallel_dfr(ts, function(part) { + ts_part <- part[["predictors"]][[1]] + ts_part <- tidyr::unnest(ts_part, cols = "predictors") + # Combine split bands into one tibble + part <- .data_reorganise_ts(ts_part, bands) part }) + # recreate hash values + hash_bundle <- purrr::map_chr(tiles_bands, function(tile_band) { + tile_id <- tile_band[[1]] + band <- tile_band[[2]] + tile <- .select_raster_cube( + cube, bands = c(band, cld_band), tiles = tile_id + ) + digest::digest(list(tile, samples), algo = "md5") + }) + # Recreate file names to delete them + filename <- .file_samples_name(hash_bundle, output_dir) + # Delete temporary rds + unlink(filename) + unlink(.dissolve(samples_rep)) + gc() + # check if data has been retrieved + if (progress) { + .message_data_check(nrow(samples), nrow(ts)) + } + if (!inherits(ts, "sits")) { + class(ts) <- c("sits", class(ts)) + } ts } From 653729b7557703a82cbff3331e62cd6e2a8b908a Mon Sep 17 00:00:00 2001 From: Felipe Date: Thu, 24 Apr 2025 19:22:04 +0000 Subject: [PATCH 098/122] update reorganize strategy in sits_get_data --- R/api_data.R | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/R/api_data.R b/R/api_data.R index 9977aa83e..3a1796036 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -199,16 +199,26 @@ return(.tibble()) } ts <- tidyr::nest(ts, predictors = -"#..id") - parts <- nrow(ts) %/% (length(bands) * nrow(cube)) + parts <- max(multicores, length(bands) + nrow(cube)) ts[["part_id"]] <- .partitions(x = seq_len(nrow(ts)), n = parts) ts <- tidyr::nest(ts, predictors = -"part_id") ts <- .jobs_map_parallel_dfr(ts, function(part) { - ts_part <- part[["predictors"]][[1]] - ts_part <- tidyr::unnest(ts_part, cols = "predictors") + part <- part[["predictors"]][[1]] + part <- tidyr::unnest(part, cols = "predictors") # Combine split bands into one tibble - part <- .data_reorganise_ts(ts_part, bands) + part <- .data_reorganise_ts(part, bands) part - }) + }, progress = FALSE) + # Get the first point that intersect more than one tile + # eg sentinel 2 mgrs grid + ts <- ts |> + dplyr::group_by( + .data[["longitude"]], .data[["latitude"]], + .data[["start_date"]], .data[["end_date"]], + .data[["label"]], .data[["cube"]] + ) |> + dplyr::slice_head(n = 1) |> + dplyr::ungroup() # recreate hash values hash_bundle <- purrr::map_chr(tiles_bands, function(tile_band) { tile_id <- tile_band[[1]] @@ -548,7 +558,7 @@ ) } # Verify NA values in time series - ts <- ts |> + ts |> dplyr::reframe( dplyr::across(dplyr::all_of(bands), stats::na.omit) ) |> @@ -556,16 +566,6 @@ dplyr::ungroup() |> 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 |> - dplyr::group_by( - .data[["longitude"]], .data[["latitude"]], - .data[["start_date"]], .data[["end_date"]], - .data[["label"]], .data[["cube"]] - ) |> - dplyr::slice_head(n = 1) |> - dplyr::ungroup() } #' @name .data_combine_ts From 3603ffefb9977462ea086101d00598777e790442 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Thu, 24 Apr 2025 19:38:20 -0300 Subject: [PATCH 099/122] fix documentation of plot raster cube --- man/plot.probs_vector_cube.Rd | 2 +- man/plot.raster_cube.Rd | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/man/plot.probs_vector_cube.Rd b/man/plot.probs_vector_cube.Rd index 432e16d13..ca66489c1 100644 --- a/man/plot.probs_vector_cube.Rd +++ b/man/plot.probs_vector_cube.Rd @@ -69,7 +69,7 @@ if (sits_run_examples()) { output_dir = tempdir() ) # plot the resulting probability cube - plot(probs_vector_cube, labels = "Forest") + plot(probs_vector_cube) } } diff --git a/man/plot.raster_cube.Rd b/man/plot.raster_cube.Rd index 8d75a7729..f1c5e4db0 100644 --- a/man/plot.raster_cube.Rd +++ b/man/plot.raster_cube.Rd @@ -122,8 +122,8 @@ if (sits_run_examples()) { collection = "MOD13Q1-6.1", data_dir = data_dir ) - # plot NDVI band of the second date date of the data cube - plot(cube, band = "NDVI", dates = sits_timeline(cube)[1]) + # plot NDVI band of the least cloud cover date + plot(cube) } } \author{ From 8640e2ec4b73d7c4c438380cb9f27838a71faaf1 Mon Sep 17 00:00:00 2001 From: Gilberto Camara Date: Fri, 25 Apr 2025 02:30:38 -0300 Subject: [PATCH 100/122] run tests to reduce progress bar --- R/api_message.R | 2 +- R/sits_som.R | 28 +++++++--------------------- man/plot.probs_vector_cube.Rd | 2 +- man/plot.raster_cube.Rd | 4 ++-- man/sits_som_clean_samples.Rd | 3 ++- tests/testthat/test-accuracy.R | 15 ++++++++++----- tests/testthat/test-apply.R | 27 ++++++++++++++++++--------- tests/testthat/test-cube-cdse.R | 2 -- tests/testthat/test-cube-deafrica.R | 2 +- tests/testthat/test-cube-mpc.R | 19 ++++++++++++------- tests/testthat/test-cube.R | 12 ++++++++---- tests/testthat/test-cube_copy.R | 21 ++++++++++++++------- tests/testthat/test-data.R | 6 ++++-- tests/testthat/test-segmentation.R | 18 ++++++++++++------ tests/testthat/test-summary.R | 6 ++++-- tests/testthat/test-texture.R | 3 ++- tests/testthat/test-variance.R | 6 ++++-- 17 files changed, 102 insertions(+), 74 deletions(-) diff --git a/R/api_message.R b/R/api_message.R index 2d8188811..c2f771a7f 100644 --- a/R/api_message.R +++ b/R/api_message.R @@ -15,7 +15,7 @@ #' @keywords internal #' @noRd .message_warnings <- function() { - Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" + !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") } #' @title Warning when converting a bbox into a sf object #' @name .message_warnings_bbox_as_sf diff --git a/R/sits_som.R b/R/sits_som.R index 41e9d747d..2025c9a76 100644 --- a/R/sits_som.R +++ b/R/sits_som.R @@ -244,6 +244,7 @@ sits_som_map <- function(data, #' @return tibble with an two additional columns. #' The first indicates if each sample is clean, should be analyzed or #' should be removed. The second is the posterior probability of the sample. +#' The "keep" parameter indicates which #' #' @examples #' if (sits_run_examples()) { @@ -263,7 +264,7 @@ sits_som_map <- function(data, sits_som_clean_samples <- function(som_map, prior_threshold = 0.6, posterior_threshold = 0.6, - keep = c("clean", "analyze")) { + keep = c("clean", "analyze", "remove")) { # set caller to show in errors .check_set_caller("sits_som_clean_samples") # Sanity check @@ -273,17 +274,6 @@ sits_som_clean_samples <- function(som_map, within = .conf("som_outcomes"), msg = .conf("messages", "sits_som_clean_samples_keep") ) - # function to detect of class noise - .detect_class_noise <- function(prior_prob, post_prob) { - if (prior_prob >= prior_threshold & - post_prob >= posterior_threshold) - return ("clean") - else if (prior_prob >= prior_threshold & - post_prob < posterior_threshold) - return("analyze") - else - "remove" - } # extract tibble from SOM map data <- som_map[["data"]] |> dplyr::select( @@ -292,7 +282,6 @@ sits_som_clean_samples <- function(som_map, "start_date", "end_date", "label", - "cube", "time_series", "id_sample", "id_neuron" @@ -301,14 +290,11 @@ sits_som_clean_samples <- function(som_map, by = c("id_neuron", label = "label_samples") ) |> dplyr::mutate( - eval = .detect_class_noise( - .data[["prior_prob"]], - .data[["post_prob"]] - ) - ) |> - dplyr::select( - -"count", - -"prior_prob" + eval = ifelse(.data[["prior_prob"]] >= prior_threshold & + .data[["post_prob"]] >= posterior_threshold, "clean", + ifelse(.data[["prior_prob"]] >= prior_threshold & + .data[["post_prob"]] < posterior_threshold, "analyze", + "remove")) ) |> dplyr::filter(.data[["eval"]] %in% keep) diff --git a/man/plot.probs_vector_cube.Rd b/man/plot.probs_vector_cube.Rd index 432e16d13..ca66489c1 100644 --- a/man/plot.probs_vector_cube.Rd +++ b/man/plot.probs_vector_cube.Rd @@ -69,7 +69,7 @@ if (sits_run_examples()) { output_dir = tempdir() ) # plot the resulting probability cube - plot(probs_vector_cube, labels = "Forest") + plot(probs_vector_cube) } } diff --git a/man/plot.raster_cube.Rd b/man/plot.raster_cube.Rd index 8d75a7729..f1c5e4db0 100644 --- a/man/plot.raster_cube.Rd +++ b/man/plot.raster_cube.Rd @@ -122,8 +122,8 @@ if (sits_run_examples()) { collection = "MOD13Q1-6.1", data_dir = data_dir ) - # plot NDVI band of the second date date of the data cube - plot(cube, band = "NDVI", dates = sits_timeline(cube)[1]) + # plot NDVI band of the least cloud cover date + plot(cube) } } \author{ diff --git a/man/sits_som_clean_samples.Rd b/man/sits_som_clean_samples.Rd index 76af9e6c3..18441ed15 100644 --- a/man/sits_som_clean_samples.Rd +++ b/man/sits_som_clean_samples.Rd @@ -8,7 +8,7 @@ sits_som_clean_samples( som_map, prior_threshold = 0.6, posterior_threshold = 0.6, - keep = c("clean", "analyze") + keep = c("clean", "analyze", "remove") ) } \arguments{ @@ -27,6 +27,7 @@ sits_som_clean_samples( tibble with an two additional columns. The first indicates if each sample is clean, should be analyzed or should be removed. The second is the posterior probability of the sample. +The "keep" parameter indicates which } \description{ \code{sits_som_clean_samples()} evaluates the quality of the samples diff --git a/tests/testthat/test-accuracy.R b/tests/testthat/test-accuracy.R index c636efada..33cd62277 100644 --- a/tests/testthat/test-accuracy.R +++ b/tests/testthat/test-accuracy.R @@ -53,7 +53,8 @@ test_that("XLS", { data(cerrado_2classes) acc <- sits_kfold_validate(cerrado_2classes, folds = 2, - ml_method = sits_rfor(num_trees = 100) + ml_method = sits_rfor(num_trees = 100), + progress = FALSE ) results <- list() acc$name <- "cerrado_2classes" @@ -68,7 +69,8 @@ test_that("K-fold validate", { set.seed(1234) acc <- sits_kfold_validate(samples_modis_ndvi, folds = 2, - ml_method = sits_rfor(num_trees = 100) + ml_method = sits_rfor(num_trees = 100), + progress = FALSE ) expect_true(acc$overall["Accuracy"] > 0.70) @@ -179,7 +181,8 @@ test_that("Accuracy areas when samples labels do not match cube labels", { collection = "MOD13Q1-6.1", data_dir = data_dir, multicores = 2, - memsize = 4 + memsize = 4, + progress = FALSE ) probs_cube <- sits_classify( @@ -188,14 +191,16 @@ test_that("Accuracy areas when samples labels do not match cube labels", { output_dir = tempdir(), version = "ex_classify", multicores = 2, - memsize = 4 + memsize = 4, + progress = FALSE ) label_cube <- sits_label_classification( probs_cube, output_dir = tempdir(), multicores = 2, - memsize = 4 + memsize = 4, + progress = FALSE ) reclass <- sits_reclassify( diff --git a/tests/testthat/test-apply.R b/tests/testthat/test-apply.R index a50331ca0..d591af1fd 100644 --- a/tests/testthat/test-apply.R +++ b/tests/testthat/test-apply.R @@ -46,7 +46,8 @@ test_that("Testing index generation", { gc_cube_new <- sits_apply(gc_cube, EVI = 2.5 * (B8A - B05) / (B8A + 2.4 * B05 + 1), multicores = 1, - output_dir = dir_images + output_dir = dir_images, + progress = FALSE ) # Test EVI @@ -87,7 +88,8 @@ test_that("Testing index generation", { CIRE = B8A / B05 - 1, normalized = FALSE, multicores = 1, - output_dir = dir_images + output_dir = dir_images, + progress = FALSE ) expect_true(all(sits_bands(gc_cube_new) %in% c("CIRE", "EVI", "B05", "B8A"))) @@ -121,7 +123,8 @@ test_that("Kernel functions", { NDVI_MEDIAN = w_median(NDVI), window_size = 3, memsize = 4, - multicores = 1 + multicores = 1, + progress = FALSE ) rast <- .raster_open_rast(cube$file_info[[1]]$path[[1]]) v_obj <- matrix(.raster_get_values(rast), ncol = 255, byrow = TRUE) @@ -141,7 +144,8 @@ test_that("Kernel functions", { NDVI_MEDIAN = w_median(NDVI), window_size = 3, memsize = 4, - multicores = 1 + multicores = 1, + progress = FALSE ) } ) @@ -151,7 +155,8 @@ test_that("Kernel functions", { NDVI_MEAN = w_mean(NDVI), window_size = 3, memsize = 4, - multicores = 2 + multicores = 2, + progress = FALSE ) rast <- .raster_open_rast(cube[1, ]$file_info[[1]]$path[[1]]) v_obj <- matrix(.raster_get_values(rast), ncol = 255, byrow = TRUE) @@ -168,7 +173,8 @@ test_that("Kernel functions", { NDVI_SD = w_sd(NDVI), window_size = 3, memsize = 4, - multicores = 2 + multicores = 2, + progress = FALSE ) rast <- .raster_open_rast(cube[1, ]$file_info[[1]]$path[[1]]) v_obj <- matrix(.raster_get_values(rast), ncol = 255, byrow = TRUE) @@ -185,7 +191,8 @@ test_that("Kernel functions", { NDVI_MIN = w_min(NDVI), window_size = 3, memsize = 4, - multicores = 2 + multicores = 2, + progress = FALSE ) rast <- .raster_open_rast(cube[1, ]$file_info[[1]]$path[[1]]) v_obj <- matrix(.raster_get_values(rast), ncol = 255, byrow = TRUE) @@ -202,7 +209,8 @@ test_that("Kernel functions", { NDVI_MAX = w_max(NDVI), window_size = 3, memsize = 4, - multicores = 2 + multicores = 2, + progress = FALSE ) rast <- .raster_open_rast(cube[1, ]$file_info[[1]]$path[[1]]) v_obj <- matrix(.raster_get_values(rast), ncol = 255, byrow = TRUE) @@ -252,7 +260,8 @@ test_that("Error", { NDVI = w_median(NDVI), window_size = 3, memsize = 4, - multicores = 2 + multicores = 2, + progress = FALSE ) }) sinop_probs <- sits_classify( diff --git a/tests/testthat/test-cube-cdse.R b/tests/testthat/test-cube-cdse.R index 94ddc7beb..0581b9e81 100644 --- a/tests/testthat/test-cube-cdse.R +++ b/tests/testthat/test-cube-cdse.R @@ -84,8 +84,6 @@ test_that("Creating S2 cubes from CDSE with tiles", { # Rollback environment changes .environment_rollback(cdse_env_config) }) - -withr::with_envvar(new = c(SITS_DOCUMENTATION_MODE = "TRUE"), devtools::test()) test_that("Creating Sentinel-1 RTC cubes from CDSE", { # Configure environment cdse_env_config <- .environment_cdse() diff --git a/tests/testthat/test-cube-deafrica.R b/tests/testthat/test-cube-deafrica.R index 0744786e1..460584c59 100644 --- a/tests/testthat/test-cube-deafrica.R +++ b/tests/testthat/test-cube-deafrica.R @@ -282,7 +282,7 @@ test_that("Creating Sentinel-1 RTC cubes from DEA using tiles", { tiles = c("36NWJ"), multicores = 1, output_dir = output_dir, - progress = TRUE + progress = FALSE ) expect_equal(length(sits_timeline(cube_s1_reg)), 2) expect_true("36NWJ" %in% cube_s1_reg$tile) diff --git a/tests/testthat/test-cube-mpc.R b/tests/testthat/test-cube-mpc.R index a298cba5b..eba36e2be 100644 --- a/tests/testthat/test-cube-mpc.R +++ b/tests/testthat/test-cube-mpc.R @@ -86,7 +86,8 @@ test_that("Creating Sentinel-1 GRD cubes from MPC using tiles", { orbit = "descending", tiles = c("21LUJ","21LVJ"), start_date = "2021-08-01", - end_date = "2021-09-30" + end_date = "2021-09-30", + progress = FALSE ) bbox <- sits_bbox(cube_s1_grd) roi_cube_s1 <- sits_tiles_to_roi(c("21LUJ","21LVJ")) @@ -112,7 +113,7 @@ test_that("Creating Sentinel-1 GRD cubes from MPC using tiles", { tiles = c("21LUJ","21LVJ"), multicores = 1, output_dir = output_dir, - progress = TRUE + progress = FALSE ) expect_equal(length(sits_timeline(cube_s1_reg)), 2) expect_true(all(c("21LUJ", "21LVJ") %in% cube_s1_reg$tile)) @@ -136,7 +137,8 @@ test_that("Creating Sentinel-1 RTC cubes from MPC", { orbit = "descending", tiles = c("21LXJ", "21LYJ"), start_date = "2021-07-01", - end_date = "2021-09-30" + end_date = "2021-09-30", + progress = FALSE ) bbox <- sits_bbox(cube_s1_rtc[1,]) expect_true(grepl("32722", bbox[["crs"]])) @@ -156,7 +158,7 @@ test_that("Creating Sentinel-1 RTC cubes from MPC", { tiles = c("21LXJ", "21LYJ"), multicores = 1, output_dir = output_dir, - progress = TRUE + progress = FALSE ) expect_equal(length(sits_timeline(cube_s1_rtc_reg)), 5) expect_true(all(c("21LXJ", "21LYJ") %in% @@ -337,7 +339,8 @@ test_that("Accessing COP-DEM-30 from MPC",{ source = "MPC", collection = "COP-DEM-GLO-30", bands = "ELEVATION", - tiles = c("22LBL") + tiles = c("22LBL"), + progress = FALSE ) expect_equal(nrow(cube_dem), 4) expect_equal(cube_dem$collection, rep("COP-DEM-GLO-30", 4)) @@ -357,7 +360,8 @@ test_that("Accessing COP-DEM-30 from MPC",{ res = 100, memsize = 12, multicores = 6, - output_dir = output_dir + output_dir = output_dir, + progress = FALSE ) cube_s2 <- sits_cube( @@ -366,7 +370,8 @@ test_that("Accessing COP-DEM-30 from MPC",{ bands = c("B02", "B8A", "B11"), tiles = c("22LBL"), start_date = "2021-07-01", - end_date = "2021-09-30" + end_date = "2021-09-30", + progress = FALSE ) bbox_dem <- sits_bbox(cube_dem_reg) bbox_s2 <- sits_bbox(cube_s2) diff --git a/tests/testthat/test-cube.R b/tests/testthat/test-cube.R index c02cd31be..948d8f54d 100644 --- a/tests/testthat/test-cube.R +++ b/tests/testthat/test-cube.R @@ -232,7 +232,8 @@ test_that("Combining Sentinel-1 with Sentinel-2 cubes", { tiles = "20LKP", bands = c("B02", "B8A", "B11", "CLOUD"), start_date = "2020-06-01", - end_date = "2020-09-28" + end_date = "2020-09-28", + progress = FALSE ) }, .default = NULL @@ -255,7 +256,8 @@ test_that("Combining Sentinel-1 with Sentinel-2 cubes", { period = "P1M", res = 240, multicores = 2, - output_dir = dir_images + output_dir = dir_images, + progress = FALSE ) ) @@ -268,7 +270,8 @@ test_that("Combining Sentinel-1 with Sentinel-2 cubes", { orbit = "descending", tiles = "20LKP", start_date = "2020-06-01", - end_date = "2020-09-28" + end_date = "2020-09-28", + progress = FALSE ) }, .default = NULL @@ -286,7 +289,8 @@ test_that("Combining Sentinel-1 with Sentinel-2 cubes", { res = 240, tiles = "20LKP", multicores = 2, - output_dir = dir_images + output_dir = dir_images, + progress = FALSE ) ) diff --git a/tests/testthat/test-cube_copy.R b/tests/testthat/test-cube_copy.R index 31b4e73a3..bbce3e36a 100644 --- a/tests/testthat/test-cube_copy.R +++ b/tests/testthat/test-cube_copy.R @@ -95,13 +95,15 @@ test_that("Copy remote cube works (full region)", { bands = c("B02", "B8A"), roi = roi, start_date = "2024-09-15", - end_date = "2024-09-25" + end_date = "2024-09-25", + progress = FALSE ) # Copy cube_s2_local <- sits_cube_copy( cube = cube_s2, output_dir = data_dir, - multicores = 2 + multicores = 2, + progress = FALSE ) # Tiles @@ -135,14 +137,16 @@ test_that("Copy remote cube works (full region with resampling)", { bands = c("B02", "B8A"), roi = roi, start_date = "2024-09-15", - end_date = "2024-09-25" + end_date = "2024-09-25", + progress = FALSE ) cube_s2_local <- sits_cube_copy( cube = cube_s2, output_dir = data_dir, res = 540, - multicores = 2 + multicores = 2, + progress = FALSE ) # Tiles @@ -176,7 +180,8 @@ test_that("Copy remote cube works (specific region with resampling)", { bands = c("B02", "B8A"), roi = roi, start_date = "2024-09-15", - end_date = "2024-09-25" + end_date = "2024-09-25", + progress = FALSE ) # roi without res expect_error({ @@ -184,7 +189,8 @@ test_that("Copy remote cube works (specific region with resampling)", { cube = cube_s2, output_dir = data_dir, multicores = 2, - roi = roi + roi = roi, + progress = FALSE ) }) # Copy with roi + res @@ -193,7 +199,8 @@ test_that("Copy remote cube works (specific region with resampling)", { output_dir = data_dir, multicores = 2, roi = roi, - res = 540 + res = 540, + progress = FALSE ) # Spatial extent expect_true(sf::st_within( diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index f6df95e2e..2d329084f 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -465,7 +465,8 @@ test_that("Retrieving points from MPC Base Cube", { source = "MPC", collection = "COP-DEM-GLO-30", roi = roi, - crs = 4326 + crs = 4326, + progress = FALSE ) dem_cube_reg <- sits_regularize( cube = dem_cube, @@ -473,7 +474,8 @@ test_that("Retrieving points from MPC Base Cube", { res = 232, roi = roi, crs = 4326, - output_dir = regdir + output_dir = regdir, + progress = FALSE ) # create base cube base_cube <- sits_add_base_cube(s2_cube_reg, dem_cube_reg) diff --git a/tests/testthat/test-segmentation.R b/tests/testthat/test-segmentation.R index dbb8d9b2f..06a6951c3 100644 --- a/tests/testthat/test-segmentation.R +++ b/tests/testthat/test-segmentation.R @@ -91,7 +91,8 @@ test_that("Segmentation", { memsize = 24, start_date = start_date, end_date = end_date, - version = "vt2" + version = "vt2", + progress = FALSE ) # test plot p_probs_segs <- plot(probs_segs) @@ -117,7 +118,8 @@ test_that("Segmentation", { n_sam_pol = 20, multicores = 6, memsize = 24, - version = "vt2" + version = "vt2", + progress = FALSE ) }) # Create a classified vector cube @@ -125,7 +127,8 @@ test_that("Segmentation", { cube = probs_segs, output_dir = output_dir, multicores = 2, - memsize = 4 + memsize = 4, + progress = FALSE ) expect_s3_class(object = class_segs, class = "class_vector_cube") expect_true( @@ -152,7 +155,8 @@ test_that("Segmentation", { cube = probs_segs, output_dir = output_dir, multicores = 2, - memsize = 4 + memsize = 4, + progress = FALSE ) }) @@ -199,7 +203,8 @@ test_that("Segmentation of large files",{ period = "P1M", res = 1000, multicores = 6, - output_dir = output_dir + output_dir = output_dir, + progress = FALSE ) ) .check_cube_is_regular(modis_cube_local) @@ -228,7 +233,8 @@ test_that("Segmentation of large files",{ n_sam_pol = 10, multicores = 6, memsize = 24, - version = "v2bands" + version = "v2bands", + progress = FALSE ) expect_s3_class(probs_segs, class = "probs_vector_cube") expect_true( diff --git a/tests/testthat/test-summary.R b/tests/testthat/test-summary.R index f66861a77..e7c8fedcd 100644 --- a/tests/testthat/test-summary.R +++ b/tests/testthat/test-summary.R @@ -13,7 +13,8 @@ test_that("summary cube",{ cube <- sits_cube( source = "BDC", collection = "MOD13Q1-6.1", - data_dir = data_dir + data_dir = data_dir, + progress = FALSE ) sum <- capture.output(summary(cube)) expect_true(grepl("MODIS", sum[1])) @@ -68,7 +69,8 @@ test_that("summary sits area accuracy", { # get the variance cube variance_cube <- sits_variance( probs_cube, - output_dir = tempdir() + output_dir = tempdir(), + progress = FALSE ) sum_var <- capture.output(suppressWarnings(summary(variance_cube))) expect_true(any(grepl("80%", sum_var))) diff --git a/tests/testthat/test-texture.R b/tests/testthat/test-texture.R index 734466abd..aca499822 100644 --- a/tests/testthat/test-texture.R +++ b/tests/testthat/test-texture.R @@ -4,7 +4,8 @@ test_that("Testing texture generation", { cube <- sits_cube( source = "BDC", collection = "MOD13Q1-6.1", - data_dir = data_dir + data_dir = data_dir, + progress = FALSE ) feature <- sits_select(cube, bands = "NDVI", dates = "2013-09-14") dir_images <- paste0(tempdir(), "/images/") diff --git a/tests/testthat/test-variance.R b/tests/testthat/test-variance.R index 07c785202..4cd3a111e 100644 --- a/tests/testthat/test-variance.R +++ b/tests/testthat/test-variance.R @@ -57,13 +57,15 @@ test_that("Variance cube", { expect_message({ obj <- sits_variance( cube = probs_cube, - output_dir = tempdir() + output_dir = tempdir(), + progress = FALSE ) }) class_cube <- sits_label_classification( probs_cube, output_dir = tempdir(), - version = "var1" + version = "var1", + progress = FALSE ) expect_error(sits_variance(class_cube, output_dir = tempdir())) From 0bab9effc14e79ecf4d366f9770369f84291dcee Mon Sep 17 00:00:00 2001 From: Felipe Date: Fri, 25 Apr 2025 14:50:40 +0000 Subject: [PATCH 101/122] update api_data --- R/api_data.R | 6 +++++- R/api_sf.R | 4 ++-- tests/testthat/test-data.R | 1 + 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/R/api_data.R b/R/api_data.R index 3a1796036..ebfadccd4 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -111,7 +111,7 @@ progress) { .check_set_caller(".data_extract") # Get cube timeline - tl <- .dissolve(.cube_timeline(cube)) + tl <- .as_date(.dissolve(.cube_timeline(cube))) # Set output_dir output_dir <- tempdir() @@ -528,6 +528,10 @@ samples[["cube"]] <- .tile_collection(tile) # build the sits tibble for the storing the points samples |> + dplyr::mutate( + start_date = .as_date(.data[["start_date"]]), + end_date = .as_date(.data[["end_date"]]) + ) |> dplyr::group_by(.data[["#..id"]]) |> dplyr::mutate( Index = list(Index = .timeline_filter(timeline, .data)) diff --git a/R/api_sf.R b/R/api_sf.R index 94aaebd79..983521d5d 100644 --- a/R/api_sf.R +++ b/R/api_sf.R @@ -196,8 +196,8 @@ sf_object[["label"]] <- sf_df[["label_attr"]] } - sf_object <- sf::st_sample( - x = sf_object, + pts_ <- sf::st_sample( + x = sf::st_geometry(sf_object), type = sampling_type, size = n_sam_pol, by_polygon = TRUE diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index 25dce8e6c..58c3ee1b4 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -65,6 +65,7 @@ test_that("Reading a CSV file from RASTER", { points_df <- sits_get_data( raster_cube, samples = df_csv, + multicores = 1, progress = FALSE ) From a966ab2d3e046f7d2ccaffa06d7aaf7ba84f7e91 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Sat, 26 Apr 2025 03:00:51 -0300 Subject: [PATCH 102/122] improve code with styler adn include progress bar in all relevant functions --- R/api_accuracy.R | 16 +- R/api_apply.R | 9 +- R/api_band.R | 14 +- R/api_bayts.R | 15 +- R/api_check.R | 276 +++++++++++--------- R/api_chunks.R | 14 +- R/api_classify.R | 33 ++- R/api_clean.R | 8 +- R/api_colors.R | 37 ++- R/api_conf.R | 158 ++++++----- R/api_crop.R | 2 +- R/api_cube.R | 101 ++++--- R/api_data.R | 34 ++- R/api_detect_change.R | 9 +- R/api_dtw.R | 8 +- R/api_environment.R | 1 - R/api_file_info.R | 10 +- R/api_gdal.R | 6 +- R/api_gdalcubes.R | 23 +- R/api_grid.R | 54 ++-- R/api_jobs.R | 6 +- R/api_kohonen.R | 92 ++++--- R/api_label_class.R | 9 +- R/api_merge.R | 21 +- R/api_message.R | 39 +-- R/api_mixture_model.R | 4 +- R/api_ml_model.R | 7 +- R/api_mosaic.R | 9 +- R/api_opensearch.R | 4 +- R/api_parallel.R | 29 +- R/api_patterns.R | 5 +- R/api_plot_raster.R | 75 +++--- R/api_plot_time_series.R | 5 +- R/api_plot_vector.R | 32 +-- R/api_predictors.R | 3 +- R/api_raster.R | 19 +- R/api_raster_sub_image.R | 6 +- R/api_reclassify.R | 5 +- R/api_reduce.R | 11 +- R/api_regularize.R | 41 +-- R/api_request.R | 2 +- R/api_request_httr2.R | 10 +- R/api_roi.R | 5 +- R/api_samples.R | 40 +-- R/api_segments.R | 29 +- R/api_select.R | 6 +- R/api_sf.R | 53 ++-- R/api_shp.R | 10 +- R/api_signal.R | 2 +- R/api_smooth.R | 17 +- R/api_smote.R | 3 +- R/api_som.R | 16 +- R/api_source.R | 51 ++-- R/api_source_aws.R | 16 +- R/api_source_bdc.R | 3 +- R/api_source_cdse.R | 52 ++-- R/api_source_deafrica.R | 72 ++--- R/api_source_deaustralia.R | 10 +- R/api_source_hls.R | 36 +-- R/api_source_local.R | 22 +- R/api_source_mpc.R | 121 +++++---- R/api_source_sdc.R | 2 +- R/api_source_stac.R | 39 +-- R/api_source_usgs.R | 3 +- R/api_space_time_operations.R | 6 +- R/api_texture.R | 7 +- R/api_tibble.R | 4 +- R/api_tile.R | 54 ++-- R/api_timeline.R | 7 +- R/api_tmap.R | 89 ++++--- R/api_torch.R | 5 +- R/api_ts.R | 4 +- R/api_tuning.R | 7 +- R/api_uncertainty.R | 18 +- R/api_utils.R | 5 +- R/api_validate.R | 1 - R/api_variance.R | 14 +- R/api_view.R | 19 +- R/sits_accuracy.R | 35 +-- R/sits_add_base_cube.R | 70 ++--- R/sits_apply.R | 4 +- R/sits_bands.R | 2 +- R/sits_bayts.R | 4 +- R/sits_classify.R | 75 +++--- R/sits_clean.R | 86 +++--- R/sits_cluster.R | 17 +- R/sits_colors.R | 50 ++-- R/sits_config.R | 22 +- R/sits_csv.R | 23 +- R/sits_cube.R | 82 +++--- R/sits_cube_local.R | 180 ++++++------- R/sits_detect_change.R | 2 - R/sits_detect_change_method.R | 5 +- R/sits_dtw.R | 22 +- R/sits_filters.R | 6 +- R/sits_geo_dist.R | 3 +- R/sits_get_class.R | 10 +- R/sits_get_data.R | 75 +++--- R/sits_get_probs.R | 30 ++- R/sits_histogram.R | 19 +- R/sits_label_classification.R | 5 +- R/sits_labels.R | 8 +- R/sits_lighttae.R | 20 +- R/sits_machine_learning.R | 21 +- R/sits_merge.R | 10 +- R/sits_mixture_model.R | 16 +- R/sits_mlp.R | 25 +- R/sits_plot.R | 259 ++++++++++-------- R/sits_predictors.R | 3 +- R/sits_reclassify.R | 142 +++++----- R/sits_reduce.R | 3 +- R/sits_reduce_imbalance.R | 7 +- R/sits_regularize.R | 53 ++-- R/sits_sample_functions.R | 124 +++++---- R/sits_segmentation.R | 32 +-- R/sits_select.R | 22 +- R/sits_sf.R | 7 +- R/sits_smooth.R | 12 +- R/sits_som.R | 44 ++-- R/sits_stars.R | 21 +- R/sits_summary.R | 37 +-- R/sits_tae.R | 17 +- R/sits_tempcnn.R | 31 ++- R/sits_terra.R | 16 +- R/sits_texture.R | 7 +- R/sits_timeline.R | 8 +- R/sits_tuning.R | 12 +- R/sits_uncertainty.R | 37 ++- R/sits_validate.R | 27 +- R/sits_variance.R | 78 ++---- R/sits_view.R | 92 ++++--- R/sits_xlsx.R | 3 +- R/zzz.R | 13 +- README.Rmd | 6 +- demo/classify_cbers_bdc.R | 2 +- demo/classify_deeplearning.R | 2 +- demo/dl_comparison.R | 10 +- demo/ml_comparison.R | 4 +- inst/extdata/lintr-tests/failed_tests.R | 89 ------- man/sits_apply.Rd | 2 +- man/sits_clean.Rd | 43 +-- man/sits_confidence_sampling.Rd | 5 +- man/sits_smooth.Rd | 5 +- man/sits_texture.Rd | 2 +- man/sits_uncertainty.Rd | 5 +- man/sits_variance.Rd | 48 +--- tests/testthat/test-accuracy.R | 25 +- tests/testthat/test-active_learning.R | 3 +- tests/testthat/test-apply.R | 60 ++--- tests/testthat/test-bands.R | 12 +- tests/testthat/test-check.R | 22 +- tests/testthat/test-classification.R | 15 +- tests/testthat/test-clustering.R | 8 +- tests/testthat/test-color.R | 8 +- tests/testthat/test-combine_predictions.R | 9 +- tests/testthat/test-config.R | 14 +- tests/testthat/test-cube-bdc.R | 42 ++- tests/testthat/test-cube-cdse.R | 4 +- tests/testthat/test-cube-deafrica.R | 67 +++-- tests/testthat/test-cube-deaustralia.R | 143 +++++----- tests/testthat/test-cube-hls.R | 26 +- tests/testthat/test-cube-mpc.R | 37 ++- tests/testthat/test-cube-terrascope.R | 4 +- tests/testthat/test-cube.R | 102 ++++---- tests/testthat/test-cube_copy.R | 32 ++- tests/testthat/test-data.R | 37 +-- tests/testthat/test-debug.R | 9 +- tests/testthat/test-file_info.R | 5 +- tests/testthat/test-get_probs_class.R | 26 +- tests/testthat/test-labels.R | 16 +- tests/testthat/test-merge.R | 53 ++-- tests/testthat/test-mixture_model.R | 13 +- tests/testthat/test-mosaic.R | 7 +- tests/testthat/test-plot.R | 35 ++- tests/testthat/test-raster.R | 110 ++++---- tests/testthat/test-reclassify.R | 22 +- tests/testthat/test-reduce.R | 33 +-- tests/testthat/test-regularize.R | 14 +- tests/testthat/test-roi.R | 3 +- tests/testthat/test-samples.R | 73 +++--- tests/testthat/test-segmentation.R | 14 +- tests/testthat/test-sf.R | 30 ++- tests/testthat/test-smooth.R | 13 +- tests/testthat/test-som.R | 15 +- tests/testthat/test-space-time-operations.R | 1 - tests/testthat/test-summary.R | 10 +- tests/testthat/test-texture.R | 4 +- tests/testthat/test-tibble.R | 16 +- tests/testthat/test-uncertainty.R | 9 +- tests/testthat/test-utils.R | 23 +- tests/testthat/test-variance.R | 12 +- tests/testthat/test-view.R | 30 ++- 192 files changed, 2987 insertions(+), 2646 deletions(-) delete mode 100644 inst/extdata/lintr-tests/failed_tests.R diff --git a/R/api_accuracy.R b/R/api_accuracy.R index dd8bea265..16aaebe96 100644 --- a/R/api_accuracy.R +++ b/R/api_accuracy.R @@ -49,12 +49,12 @@ # Create the error matrix error_matrix <- table( factor(pred, - levels = labels_cube, - labels = labels_cube + levels = labels_cube, + labels = labels_cube ), factor(ref, - levels = labels_cube, - labels = labels_cube + levels = labels_cube, + labels = labels_cube ) ) # Get area for each class of the cube @@ -66,7 +66,7 @@ if (length(diff_classes) > 0L && length(diff_classes) < length(rownames(error_matrix))) { warning(.conf("messages", ".accuracy_area_assess"), - call. = FALSE + call. = FALSE ) # Create a numeric vector with zeros vec_areas <- rep(0L, length(diff_classes)) @@ -74,7 +74,6 @@ # Join with all area classes area <- c(area, vec_areas) area <- area[sort(names(area))] - } # check error matrix .check_error_matrix_area(error_matrix, area) @@ -215,8 +214,9 @@ #' @export `.accuracy_get_validation.data.frame` <- function(validation) { # handle data frames - .check_chr_contains(colnames(validation), - c("label", "longitude", "latitude") + .check_chr_contains( + colnames(validation), + c("label", "longitude", "latitude") ) validation } diff --git a/R/api_apply.R b/R/api_apply.R index 5ed27ac8f..41ef296e0 100644 --- a/R/api_apply.R +++ b/R/api_apply.R @@ -85,8 +85,9 @@ band_conf <- .tile_band_conf(tile = feature, band = out_band) if (.has_not(band_conf)) { band_conf <- .conf("default_values", "FLT4S") - if (normalized) + if (normalized) { band_conf <- .conf("default_values", "INT2S") + } } band_offset <- .offset(band_conf) band_scale <- .scale(band_conf) @@ -120,10 +121,12 @@ ) ) # Prepare fractions to be saved - if (.has(band_offset) && band_offset != 0.0) + if (.has(band_offset) && band_offset != 0.0) { values <- values - band_offset - if (.has(band_scale) && band_scale != 1.0) + } + if (.has(band_scale) && band_scale != 1.0) { values <- values / band_scale + } # Job crop block crop_block <- .block(.chunks_no_overlap(chunk)) # Prepare and save results as raster diff --git a/R/api_band.R b/R/api_band.R index c3bcc754b..930a212b8 100644 --- a/R/api_band.R +++ b/R/api_band.R @@ -52,8 +52,8 @@ ) .apply(x, col = "file_info", fn = function(x) { x <- tidyr::pivot_wider(x, - names_from = "band", - values_from = "path" + names_from = "band", + values_from = "path" ) # create a conversor @@ -169,13 +169,15 @@ # see if bands are available for (i in seq_along(composites)) { bands <- composites[[i]] - if (all(bands %in% .cube_bands(cube))) + if (all(bands %in% .cube_bands(cube))) { return(bands) + } } # if composites fail, try NDVI - if ("NDVI" %in% cube_bands) + if ("NDVI" %in% cube_bands) { "NDVI" - # return the first band if all fails - else + } # return the first band if all fails + else { cube_bands[[1L]] + } } diff --git a/R/api_bayts.R b/R/api_bayts.R index ae78ff434..56e0ca9ae 100644 --- a/R/api_bayts.R +++ b/R/api_bayts.R @@ -13,8 +13,8 @@ # Create mean and sd columns for each band samples <- dplyr::group_by(.ts(samples), .data[["label"]]) samples <- dplyr::summarise(samples, dplyr::across( - dplyr::matches(bands), list(mean = mean, sd = stats::sd)) - ) + dplyr::matches(bands), list(mean = mean, sd = stats::sd) + )) # Transform to long form names_prefix <- NULL if (length(bands) > 1L) { @@ -26,7 +26,8 @@ names_sep = "_", names_prefix = names_prefix, names_to = c("bands", "stats"), - cols_vary = "fastest") |> + cols_vary = "fastest" + ) |> tidyr::pivot_wider( names_from = bands ) @@ -35,11 +36,13 @@ split(stats[, bands], stats[["stats"]]), as.matrix ) return(stats) - } .check_null( - stats, msg = paste0("Invalid null parameter.", - "'stats' must be a valid value.") + stats, + msg = paste0( + "Invalid null parameter.", + "'stats' must be a valid value." + ) ) bands <- setdiff(colnames(stats), c("stats", "label")) # return a matrix with statistics diff --git a/R/api_check.R b/R/api_check.R index 3a4e620c8..c47b7f163 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -193,13 +193,15 @@ # get caller function name caller <- .check_identify_caller() # format error message - if (is.null(msg)) + if (is.null(msg)) { msg <- .conf("messages", caller) + } # include local message if available - if (is.null(local_msg)) + if (is.null(local_msg)) { msg <- paste0(caller, ": ", msg) - else + } else { msg <- paste0(caller, ": ", local_msg) + } # process message stop(msg, call. = FALSE) } @@ -434,7 +436,6 @@ is_named = FALSE, local_msg = NULL, msg = NULL) { - # check for NULL and exit if it is allowed if (allow_null && is.null(x)) { return(invisible(x)) @@ -444,8 +445,10 @@ # check type .check_lgl_type(x, local_msg = local_msg, msg = msg) # check length - .check_length(x, len_min = len_min, len_max = len_max, - local_msg = local_msg, msg = msg) + .check_length(x, + len_min = len_min, len_max = len_max, + local_msg = local_msg, msg = msg + ) # check NA if (!allow_na) { .check_na(x, local_msg = local_msg, msg = msg) @@ -478,17 +481,25 @@ # check NULL .check_null(x, local_msg = local_msg, msg = msg) # check type - .check_num_type(x, is_integer = is_integer, - local_msg = local_msg, msg = msg) + .check_num_type(x, + is_integer = is_integer, + local_msg = local_msg, msg = msg + ) # check length - .check_length(x, len_min = len_min, len_max = len_max, - local_msg = local_msg, msg = msg) + .check_length(x, + len_min = len_min, len_max = len_max, + local_msg = local_msg, msg = msg + ) # check NA - .check_na(x, allow_na = allow_na, - local_msg = local_msg, msg = msg) + .check_na(x, + allow_na = allow_na, + local_msg = local_msg, msg = msg + ) # check names - .check_names(x, is_named = is_named, - local_msg, msg = msg) + .check_names(x, + is_named = is_named, + local_msg, msg = msg + ) # check range .check_num_min_max( x = x, @@ -500,8 +511,9 @@ local_msg = local_msg, msg = msg ) - if (is_odd) + if (is_odd) { .check_that(x %% 2L != 0L, msg = msg) + } } #' @rdname check_functions #' @keywords internal @@ -514,7 +526,6 @@ tolerance = 0.0, local_msg = NULL, msg = NULL) { - # pre-condition .check_num_type(min, local_msg = local_msg, msg = msg) .check_num_type(max, local_msg = local_msg, msg = msg) @@ -585,8 +596,10 @@ # check type .check_chr_type(x, local_msg = local_msg, msg = msg) # check length - .check_length(x, len_min = len_min, len_max = len_max, - local_msg = local_msg, msg = msg) + .check_length(x, + len_min = len_min, len_max = len_max, + local_msg = local_msg, msg = msg + ) # check NA if (!allow_na) { .check_na(x, local_msg = local_msg, msg = msg) @@ -635,7 +648,6 @@ fn_check = NULL, local_msg = NULL, msg = NULL) { - # check for null and exit if it is allowed if (allow_null && is.null(x)) { } @@ -644,14 +656,18 @@ # check type .check_lst_type(x, local_msg = local_msg, msg = msg) # check length - .check_length(x, len_min = len_min, len_max = len_max, - local_msg = local_msg, msg = msg) + .check_length(x, + len_min = len_min, len_max = len_max, + local_msg = local_msg, msg = msg + ) # check names .check_names(x, is_named = is_named, local_msg = local_msg, msg = msg) # check using function if (!is.null(fn_check)) { - .check_apply(x, fn_check = fn_check, - local_msg = local_msg, msg = msg, ...) + .check_apply(x, + fn_check = fn_check, + local_msg = local_msg, msg = msg, ... + ) } } #' @rdname check_functions @@ -741,31 +757,31 @@ # check discriminator # check discriminator switch(discriminator, - one_of = .check_that( - sum(x %in% within) == 1L, - local_msg = local_msg_x, - msg = msg - ), - any_of = .check_that( - any(x %in% within), - local_msg = local_msg_x, - msg = msg - ), - all_of = .check_that( - all(x %in% within), - local_msg = local_msg_x, - msg = msg - ), - none_of = .check_that( - !any(x %in% within), - local_msg = local_msg_x, - msg = msg - ), - exactly = .check_that( - all(x %in% within) && all(within %in% x), - local_msg = local_msg_x, - msg = msg - ) + one_of = .check_that( + sum(x %in% within) == 1L, + local_msg = local_msg_x, + msg = msg + ), + any_of = .check_that( + any(x %in% within), + local_msg = local_msg_x, + msg = msg + ), + all_of = .check_that( + all(x %in% within), + local_msg = local_msg_x, + msg = msg + ), + none_of = .check_that( + !any(x %in% within), + local_msg = local_msg_x, + msg = msg + ), + exactly = .check_that( + all(x %in% within) && all(within %in% x), + local_msg = local_msg_x, + msg = msg + ) ) } #' @rdname check_functions @@ -777,7 +793,6 @@ discriminator = "all_of", can_repeat = TRUE, msg = NULL) { - # check parameter name var_x <- deparse(substitute(x, environment())) # make default message for param @@ -810,31 +825,31 @@ } # check discriminator switch(discriminator, - one_of = .check_that( - sum(contains %in% x) == 1L, - local_msg = local_msg_x, - msg = msg - ), - any_of = .check_that( - any(contains %in% x), - local_msg = local_msg_x, - msg = msg - ), - all_of = .check_that( - all(contains %in% x), - local_msg = local_msg_x, - msg = msg - ), - none_of = .check_that( - !any(contains %in% x), - local_msg = local_msg_x, - msg = msg - ), - exactly = .check_that( - all(contains %in% x) && all(x %in% contains), - local_msg = local_msg_x, - msg = msg - ) + one_of = .check_that( + sum(contains %in% x) == 1L, + local_msg = local_msg_x, + msg = msg + ), + any_of = .check_that( + any(contains %in% x), + local_msg = local_msg_x, + msg = msg + ), + all_of = .check_that( + all(contains %in% x), + local_msg = local_msg_x, + msg = msg + ), + none_of = .check_that( + !any(contains %in% x), + local_msg = local_msg_x, + msg = msg + ), + exactly = .check_that( + all(contains %in% x) && all(x %in% contains), + local_msg = local_msg_x, + msg = msg + ) ) } #' @rdname check_functions @@ -868,7 +883,7 @@ basename(x) ) } - if (is.null(msg)) + if (is.null(msg)) { # check parameter .check_chr( x, @@ -879,11 +894,13 @@ local_msg = local_msg, msg = msg ) + } # check extension if (!is.null(extensions)) { extension <- ext_file(x) .check_that(extension %in% extensions, - local_msg = local_msg) + local_msg = local_msg + ) } if (file_exists) { existing_files <- file.exists(x) @@ -891,9 +908,9 @@ .check_that( all(existing_files | existing_dirs), local_msg = local_msg, - msg = paste(.conf("messages", ".check_file_missing"), - paste0("'", x[!existing_files], "'", collapse = ", " - ) + msg = paste( + .conf("messages", ".check_file_missing"), + paste0("'", x[!existing_files], "'", collapse = ", ") ) ) } else { @@ -1212,15 +1229,21 @@ # check type .check_lst_type(x, msg = msg) # check length - .check_length(x, len_min = len_min, len_max = len_max, - local_msg = local_msg, msg = msg) + .check_length(x, + len_min = len_min, len_max = len_max, + local_msg = local_msg, msg = msg + ) # check names - .check_names(x, is_named = is_named, - local_msg = local_msg, msg = msg) + .check_names(x, + is_named = is_named, + local_msg = local_msg, msg = msg + ) # check using function if (!is.null(fn_check)) { - .check_apply(x, fn_check = fn_check, - local_msg = local_msg, msg = msg, ...) + .check_apply(x, + fn_check = fn_check, + local_msg = local_msg, msg = msg, ... + ) } invisible(x) } @@ -1513,7 +1536,8 @@ .raster_open_rast(.tile_path(x)), error = function(e) { NULL - }) + } + ) # return error if data is not accessible .check_that(.has(rast)) } @@ -1569,8 +1593,8 @@ # check that there is no NA in labels sample_labels <- .samples_labels(data) .check_that(!("NoClass" %in% sample_labels) && - !("" %in% sample_labels) && - !anyNA(sample_labels)) + !("" %in% sample_labels) && + !anyNA(sample_labels)) # Get unnested time series ts <- .ts(data) # check there are no NA in distances @@ -1661,10 +1685,11 @@ .check_that(nrow(pred) > 0) n_bands <- length(.samples_bands.sits(samples)) n_times <- length(.samples_timeline(samples)) - if (inherits(samples, "sits_base")) + if (inherits(samples, "sits_base")) { n_bands_base <- length(.samples_base_bands(samples)) - else + } else { n_bands_base <- 0L + } .check_that(ncol(pred) == 2L + n_bands * n_times + n_bands_base) } #' @title Does the data contain the cols of sample data and is not empty? @@ -1790,17 +1815,17 @@ .check_roi <- function(roi = NULL) { # set caller to show in errors .check_set_caller(".check_roi") - if (!.has(roi)) + if (!.has(roi)) { return(invisible(NULL)) + } # check vector is named .check_names(roi) # check that names are correct roi_names <- names(roi) names_ll <- c("lon_min", "lon_max", "lat_min", "lat_max") - names_x <- c("xmin", "xmax", "ymin", "ymax") + names_x <- c("xmin", "xmax", "ymin", "ymax") .check_that(all(names_ll %in% roi_names) || - all(names_x %in% roi_names) - ) + all(names_x %in% roi_names)) } #' @title Check if roi or tiles are provided #' @name .check_roi_tiles @@ -1916,7 +1941,7 @@ .check_set_caller(".check_cubes_same_size") .check_that( all(.cube_ncols(cube1) == .cube_ncols(cube2)) && - all(.cube_nrows(cube1) == .cube_nrows(cube2)) + all(.cube_nrows(cube1) == .cube_nrows(cube2)) ) } @@ -2175,7 +2200,7 @@ exactly = "be exactly" ) .check_that(length(discriminator) == 1L && - discriminator %in% names(discriminators)) + discriminator %in% names(discriminators)) } #' @title Check if the provided object is a vector #' @name .check_vector_object @@ -2233,10 +2258,13 @@ # check if palette name is in RColorBrewer brewer_pals <- rownames(RColorBrewer::brewer.pal.info) # if not a Brewer palette, check that it is a cols4all palette - if (!palette %in% brewer_pals) - .check_chr_contains(x = cols4all::c4a_palettes(), - contains = palette, - discriminator = "any_of") + if (!palette %in% brewer_pals) { + .check_chr_contains( + x = cols4all::c4a_palettes(), + contains = palette, + discriminator = "any_of" + ) + } } #' @title Check legend defined as tibble #' @name .check_legend @@ -2300,8 +2328,9 @@ .check_set_caller(".check_shp_attribute") # get the data frame associated to the shapefile shp_df <- sf::st_drop_geometry(sf_shape) - if (.has(shp_attr)) + if (.has(shp_attr)) { .check_that(length(as.character(shp_df[1L, (shp_attr)])) > 0L) + } } #' @title Checks validation file #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} @@ -2314,8 +2343,9 @@ .check_validation_file <- function(validation) { # set caller to show in errors .check_set_caller(".check_validation_file") - if (is.character(validation)) + if (is.character(validation)) { .check_that(tolower(.file_ext(validation)) == "csv") + } } #' @title Checks filter function #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} @@ -2327,8 +2357,9 @@ #' @noRd .check_filter_fn <- function(filter_fn = NULL) { .check_set_caller(".check_filter_fn") - if (.has(filter_fn)) + if (.has(filter_fn)) { .check_that(is.function(filter_fn)) + } } #' @title Checks distance method #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} @@ -2417,7 +2448,7 @@ # .check_opt_hparams <- function(opt_hparams, optim_params_function) { .check_lst_parameter(opt_hparams, - msg = .conf("messages", ".check_opt_hparams") + msg = .conf("messages", ".check_opt_hparams") ) .check_chr_within( x = names(opt_hparams), @@ -2463,7 +2494,7 @@ # check collection .check_chr_parameter(collection, len_min = 1L, len_max = 1L) .check_chr_within(collection, - within = .source_collections(source = source) + within = .source_collections(source = source) ) } #' @name .check_source_collection_token @@ -2484,9 +2515,9 @@ .default = "NO_TOKEN" ) # Pre-condition - try to find the access key as an environment variable - if (token != "NO_TOKEN") + if (token != "NO_TOKEN") { .check_env_var(token) - + } } #' @title Check band availability #' @name .check_bands_collection @@ -2587,11 +2618,12 @@ .check_int_parameter(epochs) .check_int_parameter(batch_size) .check_int_parameter(layers) - .check_num_parameter(dropout_rates, min = 0.0, max = 1.0, - len_min = length(layers), len_max = length(layers) + .check_num_parameter(dropout_rates, + min = 0.0, max = 1.0, + len_min = length(layers), len_max = length(layers) ) .check_that(length(layers) == length(dropout_rates), - msg = .conf("messages", "sits_mlp_layers_dropout") + msg = .conf("messages", "sits_mlp_layers_dropout") ) .check_int_parameter(patience) .check_num_parameter(min_delta, min = 0.0) @@ -2632,14 +2664,18 @@ .check_samples_train(samples) .check_int_parameter(cnn_layers, len_max = 2L^31L - 1L) .check_int_parameter(cnn_kernels, - len_min = length(cnn_layers), - len_max = length(cnn_layers)) - .check_num_parameter(cnn_dropout_rates, min = 0.0, max = 1.0, - len_min = length(cnn_layers), - len_max = length(cnn_layers)) + len_min = length(cnn_layers), + len_max = length(cnn_layers) + ) + .check_num_parameter(cnn_dropout_rates, + min = 0.0, max = 1.0, + len_min = length(cnn_layers), + len_max = length(cnn_layers) + ) .check_int_parameter(dense_layer_nodes, len_max = 1L) .check_num_parameter(dense_layer_dropout_rate, - min = 0.0, max = 1.0, len_max = 1L) + min = 0.0, max = 1.0, len_max = 1L + ) .check_int_parameter(epochs) .check_int_parameter(batch_size) .check_int_parameter(lr_decay_epochs) @@ -2738,11 +2774,11 @@ .check_set_caller(".check_raster_bbox_tolerance") # pre-conditions .check_that( - bbox[["xmin"]] < bbox[["xmax"]] && - bbox[["ymin"]] < bbox[["ymax"]] + tolerance && + bbox[["xmin"]] < bbox[["xmax"]] && + bbox[["ymin"]] < bbox[["ymax"]] + tolerance && bbox[["xmin"]] >= tile[["xmin"]] - tolerance && - bbox[["xmax"]] <= tile[["xmax"]] + tolerance && - bbox[["ymin"]] >= tile[["ymin"]] - tolerance && + bbox[["xmax"]] <= tile[["xmax"]] + tolerance && + bbox[["ymin"]] >= tile[["ymin"]] - tolerance && bbox[["ymax"]] <= tile[["ymax"]] + tolerance ) } diff --git a/R/api_chunks.R b/R/api_chunks.R index e9bd1a442..d5151d8eb 100644 --- a/R/api_chunks.R +++ b/R/api_chunks.R @@ -52,12 +52,16 @@ NULL chunks[["row"]] <- .as_int(pmax(1L, .row(chunks) - overlap)) # Adjust ncols and nrows to do overlap chunks[["ncols"]] <- .as_int( - pmin(.ncols(image_size), - .col(chunks) + .ncols(block) + overlap - 1L) - .col(chunks) + 1L + pmin( + .ncols(image_size), + .col(chunks) + .ncols(block) + overlap - 1L + ) - .col(chunks) + 1L ) chunks[["nrows"]] <- .as_int( - pmin(.nrows(image_size), - .row(chunks) + .nrows(block) + overlap - 1L) - .row(chunks) + 1L + pmin( + .nrows(image_size), + .row(chunks) + .nrows(block) + overlap - 1L + ) - .row(chunks) + 1L ) # Chunk of entire image entire_image <- c(image_size, image_bbox) @@ -189,7 +193,7 @@ NULL # Find segments in chunks idx_intersects <- sf::st_intersects(sf_chunks, segs, sparse = TRUE) |> purrr::imap_dfr( - ~dplyr::as_tibble(.x) |> dplyr::mutate(id = .y) + ~ dplyr::as_tibble(.x) |> dplyr::mutate(id = .y) ) |> dplyr::distinct(.data[["value"]], .keep_all = TRUE) |> dplyr::group_by(.data[["id"]]) |> diff --git a/R/api_classify.R b/R/api_classify.R index 814475a50..d3e379387 100755 --- a/R/api_classify.R +++ b/R/api_classify.R @@ -229,7 +229,8 @@ roi = roi, output_dir = output_dir, multicores = 1L, - progress = FALSE) + progress = progress + ) unlink(.fi_paths(.fi(probs_tile))) } # show final time for classification @@ -239,10 +240,11 @@ verbose = verbose ) # Return probs tile (cropped version in case of ROI) - if (.has(roi)) + if (.has(roi)) { probs_tile_crop - else + } else { probs_tile + } } #' @title Classify a chunk of raster data using multicores @@ -374,7 +376,7 @@ impute_fn = impute_fn, multicores = 1L, gpu_memory = gpu_memory, - progress = FALSE + progress = progress ) # Join probability values with segments segments_ts <- .segments_join_probs( @@ -596,19 +598,20 @@ ) } # choose between GPU and CPU - if (.torch_gpu_classification() && .ml_is_torch_model(ml_model)) + if (.torch_gpu_classification() && .ml_is_torch_model(ml_model)) { prediction <- .classify_ts_gpu( pred = pred, ml_model = ml_model, gpu_memory = gpu_memory ) - else + } else { prediction <- .classify_ts_cpu( pred = pred, ml_model = ml_model, multicores = multicores, progress = progress ) + } # Store the result in the input data if (length(class_info[["dates_index"]][[1L]]) > 1L) { prediction <- .tibble_prediction_multiyear( @@ -623,8 +626,10 @@ ) } # Set result class and return it - prediction <- .set_class(x = prediction, "predicted", - class(samples)) + prediction <- .set_class( + x = prediction, "predicted", + class(samples) + ) prediction } #' @title Classify predictors using CPU @@ -647,7 +652,6 @@ ml_model, multicores, progress) { - # Divide samples predictors in chunks to parallel processing parts <- .pred_create_partition( pred = pred, @@ -738,8 +742,10 @@ #' @return start time for processing .classify_verbose_start <- function(verbose, block) { if (verbose) { - msg <- paste0(.conf("messages", ".verbose_block_size"), " ", - .nrows(block), " x ", .ncols(block)) + msg <- paste0( + .conf("messages", ".verbose_block_size"), " ", + .nrows(block), " x ", .ncols(block) + ) message(msg) } Sys.time() @@ -758,8 +764,9 @@ end_time <- Sys.time() message("") message(.conf("messages", ".verbose_task_end"), end_time) - message(.conf("messages", ".verbose_task_elapsed"), - format(round(end_time - start_time, digits = 2L)) + message( + .conf("messages", ".verbose_task_elapsed"), + format(round(end_time - start_time, digits = 2L)) ) } } diff --git a/R/api_clean.R b/R/api_clean.R index 19caa5fac..f3bdc18b4 100644 --- a/R/api_clean.R +++ b/R/api_clean.R @@ -21,7 +21,8 @@ window_size, overlap, output_dir, - version) { + version, + progress) { # Output file out_file <- .file_derived_name( tile = tile, band = band, version = version, output_dir = output_dir @@ -84,7 +85,7 @@ gc() # Returned block files for each fraction block_files - }) + }, progress = progress) # Merge blocks into a new class_cube tile .tile_derived_merge_blocks( file = out_file, @@ -109,7 +110,8 @@ .clean_data_read <- function(tile, block, band) { # Get band values values <- as.data.frame(.tile_read_block( - tile = tile, band = band, block = block)) + tile = tile, band = band, block = block + )) # Set columns name colnames(values) <- band # Return values diff --git a/R/api_colors.R b/R/api_colors.R index f2fdf1c63..ff54d26f3 100644 --- a/R/api_colors.R +++ b/R/api_colors.R @@ -81,7 +81,8 @@ color_tb[["name"]] <- purrr::map_chr( color_tb[["name"]], function(name) { paste(name = unlist( - strsplit(name, split = "_", fixed = TRUE)), collapse = " ") + strsplit(name, split = "_", fixed = TRUE) + ), collapse = " ") } ) # find out how many lines to write per name @@ -89,10 +90,11 @@ stringr::str_count(stringr::str_wrap(s, width = 12L), "\n") + 1L }) n_colors <- nrow(color_tb) - if (n_colors <= 12L) + if (n_colors <= 12L) { n_rows_show <- 3L - else + } else { n_rows_show <- n_colors %/% 4L + } # add place locators to color table entries color_tb <- tibble::add_column( color_tb, @@ -155,7 +157,8 @@ # read the top part of QGIS style top_qgis_style <- system.file("extdata/qgis/qgis_style_top.xml", - package = "sits") + package = "sits" + ) top_lines <- readLines(top_qgis_style) # write the top part of QGIS style in the output file writeLines(top_lines, con = con) @@ -163,16 +166,21 @@ writeLines(" ", con = con) # write palette entries purrr::pmap_chr( - list(color_table[["index"]], - color_table[["color"]], - color_table[["name"]]), + list( + color_table[["index"]], + color_table[["color"]], + color_table[["name"]] + ), function(ind, color, name) { - writeLines(paste0(" "), - con = con + writeLines( + paste0( + " " + ), + con = con ) invisible("") } @@ -182,7 +190,8 @@ # read the bottom part of QGIS style files # this part goes after the palette entry bottom_qgis_style <- system.file("extdata/qgis/qgis_style_bottom.xml", - package = "sits") + package = "sits" + ) bottom_lines <- readLines(bottom_qgis_style) # write the bottom part of QGIS style in the output file writeLines(bottom_lines, con = con) diff --git a/R/api_conf.R b/R/api_conf.R index 44054e04e..9515f2d5d 100644 --- a/R/api_conf.R +++ b/R/api_conf.R @@ -20,19 +20,20 @@ # set caller to show in errors .check_set_caller(".conf_set_options") # initialize config - if (!exists("config", envir = sits_env)) + if (!exists("config", envir = sits_env)) { sits_env[["config"]] <- list() + } # process processing_bloat if (.has(processing_bloat)) { .check_int_parameter(processing_bloat, - min = 1.0, len_min = 1L, len_max = 1L, max = 10.0 + min = 1.0, len_min = 1L, len_max = 1L, max = 10.0 ) sits_env[["config"]][["processing_bloat"]] <- processing_bloat } # process rstac_pagination_limit if (.has(rstac_pagination_limit)) { .check_int_parameter(rstac_pagination_limit, - min = 1L, len_min = 1L, len_max = 1L, max = 500L + min = 1L, len_min = 1L, len_max = 1L, max = 500L ) sits_env[["config"]][["rstac_pagination_limit"]] <- rstac_pagination_limit @@ -40,18 +41,18 @@ # process gdal_creation_options if (.has(gdal_creation_options)) { .check_chr(gdal_creation_options, - allow_empty = FALSE, - regex = "^.+=.+$", - msg = .conf("messages", ".conf_set_options_gdal_creation") + allow_empty = FALSE, + regex = "^.+=.+$", + msg = .conf("messages", ".conf_set_options_gdal_creation") ) sits_env$config[["gdal_creation_options"]] <- gdal_creation_options } # process gdalcubes_chunk_size if (.has(gdalcubes_chunk_size)) { .check_num_parameter(gdalcubes_chunk_size, - len_min = 3L, - len_max = 3L, - is_named = FALSE + len_min = 3L, + len_max = 3L, + is_named = FALSE ) sits_env[["config"]][["gdalcubes_chunk_size"]] <- gdalcubes_chunk_size } @@ -67,7 +68,7 @@ # check that source contains essential parameters .check_chr_contains(names(source), - contains = c("s3_class", "collections") + contains = c("s3_class", "collections") ) names(source) <- tolower(names(source)) # check source @@ -257,10 +258,12 @@ sits_env[["legends"]] <- config_colors$legends # build the color table colors <- config_colors[["colors"]] - color_table <- purrr::map2_dfr(colors, names(colors), - function(cl, nm) { - tibble::tibble(name = nm, color = cl) - }) + color_table <- purrr::map2_dfr( + colors, names(colors), + function(cl, nm) { + tibble::tibble(name = nm, color = cl) + } + ) # set the color table sits_env[["color_table"]] <- color_table @@ -284,8 +287,10 @@ # replace all duplicates new_colors <- dplyr::pull(color_tb, .data[["name"]]) # remove duplicate colors - old_color_tb <- dplyr::filter(sits_env[["color_table"]], - !(.data[["name"]] %in% new_colors)) + old_color_tb <- dplyr::filter( + sits_env[["color_table"]], + !(.data[["name"]] %in% new_colors) + ) sits_env[["color_table"]] <- dplyr::bind_rows(old_color_tb, color_tb) } #' @title Merge user colors with default colors @@ -308,8 +313,8 @@ color_table[id, "color"] <- col } else { color_table <- tibble::add_row(color_table, - name = name, - color = col + name = name, + color = col ) } } @@ -326,8 +331,10 @@ .conf_merge_legends <- function(user_legends) { .check_set_caller(".conf_merge_legends") # check legends are valid names - .check_chr_parameter(names(user_legends), len_max = 100L, - msg = .conf("messages", ".conf_merge_legends_user")) + .check_chr_parameter(names(user_legends), + len_max = 100L, + msg = .conf("messages", ".conf_merge_legends_user") + ) # check legend names do not already exist .check_that(!(any(names(user_legends) %in% names(sits_env[["legends"]])))) sits_env[["legends"]] <- c(sits_env[["legends"]], user_legends) @@ -354,15 +361,17 @@ if (nchar(yml_file) > 0L) { .check_warn( .check_file(yml_file, - msg = .conf("messages", ".conf_user_env_var") + msg = .conf("messages", ".conf_user_env_var") ) ) # if the YAML file exists, try to load it - tryCatch({ - yaml_user_config <- yaml::yaml.load_file( - input = yml_file, - merge.precedence = "override" - )}, + tryCatch( + { + yaml_user_config <- yaml::yaml.load_file( + input = yml_file, + merge.precedence = "override" + ) + }, error = function(e) { warning(.conf("messages", ".conf_user_env_var"), call. = TRUE) } @@ -383,8 +392,10 @@ # check config user file is valid if (.has(config_user_file) && !is.na(config_user_file)) { user_config <- tryCatch( - yaml::yaml.load_file(config_user_file, error.label = "", - readLines.warn = FALSE), + yaml::yaml.load_file(config_user_file, + error.label = "", + readLines.warn = FALSE + ), error = function(e) { stop(.conf("messages", ".conf_set_user_file"), call. = TRUE) } @@ -405,8 +416,8 @@ } if (.has(user_config)) { user_config <- utils::modifyList(sits_env[["config"]], - user_config, - keep.null = FALSE + user_config, + keep.null = FALSE ) # set options defined by user (via YAML file) # modifying existing configuration @@ -420,8 +431,8 @@ user_config[["gdalcubes_chunk_size"]], sources = user_config[["sources"]], colors = user_config[["colors"]], - view = user_config[["view"]], - plot = user_config[["plot"]] + view = user_config[["view"]], + plot = user_config[["plot"]] ) } } @@ -526,12 +537,12 @@ ) # post-condition .check_chr(res, - allow_empty = FALSE, - msg = paste( - "invalid names for", - paste0("'", paste(key, collapse = "$"), "'"), - "key" - ) + allow_empty = FALSE, + msg = paste( + "invalid names for", + paste0("'", paste(key, collapse = "$"), "'"), + "key" + ) ) res } @@ -554,21 +565,21 @@ .check_set_caller(".conf_new_source") # pre-condition .check_chr_parameter(s3_class, - allow_empty = FALSE, len_min = 1L, - msg = .conf("messages", ".conf_new_source_s3class") + allow_empty = FALSE, len_min = 1L, + msg = .conf("messages", ".conf_new_source_s3class") ) if (!is.null(service)) { .check_chr_parameter(service, - allow_empty = FALSE, len_min = 1L, len_max = 1L, - msg = .conf("messages", ".conf_new_source_service") + allow_empty = FALSE, len_min = 1L, len_max = 1L, + msg = .conf("messages", ".conf_new_source_service") ) } if (!is.null(url)) { .check_chr_parameter(url, - allow_empty = FALSE, len_min = 1L, len_max = 1L, - regex = '^(http|https)://[^ "]+$', - msg = .conf("messages", ".conf_new_source_url") + allow_empty = FALSE, len_min = 1L, len_max = 1L, + regex = '^(http|https)://[^ "]+$', + msg = .conf("messages", ".conf_new_source_url") ) } .check_lst(collections, len_min = 1L) @@ -577,8 +588,8 @@ collections <- lapply(collections, function(collection) { # pre-condition .check_lst_parameter(collection, - len_min = 1L, - msg = .conf("messages", ".conf_new_source_collections") + len_min = 1L, + msg = .conf("messages", ".conf_new_source_collections") ) # collection members must be lower case names(collection) <- tolower(names(collection)) @@ -591,8 +602,10 @@ # extra parameters dots <- list(...) - .check_lst_parameter(dots, len_min = 0L, - msg = .conf("messages", ".conf_new_source_collections_args")) + .check_lst_parameter(dots, + len_min = 0L, + msg = .conf("messages", ".conf_new_source_collections_args") + ) c(list( s3_class = s3_class, @@ -619,32 +632,32 @@ .check_set_caller(".conf_new_collection") # check satellite .check_chr_parameter(satellite, - allow_null = TRUE, - msg = .conf("messages", ".conf_new_collection_satellite") + allow_null = TRUE, + msg = .conf("messages", ".conf_new_collection_satellite") ) # check sensor .check_chr(sensor, - allow_null = TRUE, - msg = .conf("messages", ".conf_new_collection_sensor") + allow_null = TRUE, + msg = .conf("messages", ".conf_new_collection_sensor") ) # check metadata_search if (!missing(metadata_search)) { .check_chr_within(metadata_search, - within = .conf("metadata_search_strategies"), - msg = .conf("messages", ".conf_new_collection_metadata") + within = .conf("metadata_search_strategies"), + msg = .conf("messages", ".conf_new_collection_metadata") ) } # check extra parameters dots <- list(...) .check_lst(dots, - msg = .conf("messages", ".conf_new_collection_metadata_args") + msg = .conf("messages", ".conf_new_collection_metadata_args") ) # bands names is upper case names(bands) <- toupper(names(bands)) # pre-condition .check_lst(bands, - len_min = 1L, - msg = .conf("messages", ".conf_new_collection_bands") + len_min = 1L, + msg = .conf("messages", ".conf_new_collection_bands") ) # define collection bands collection_bands <- NULL @@ -669,18 +682,18 @@ } # merge metadata properties res <- c(list(bands = collection_bands), - "satellite" = satellite, - "sensor" = sensor, - "metadata_search" = metadata_search, dots + "satellite" = satellite, + "sensor" = sensor, + "metadata_search" = metadata_search, dots ) # post-condition .check_lst(res, - len_min = 1L, - msg = .conf("messages", ".conf_new_collection") + len_min = 1L, + msg = .conf("messages", ".conf_new_collection") ) .check_lst(res$bands, - len_min = 1L, - msg = .conf("messages", ".conf_new_collection_bands") + len_min = 1L, + msg = .conf("messages", ".conf_new_collection_bands") ) # return a new collection data return(res) @@ -763,7 +776,7 @@ # post-condition .check_lst_parameter(new_band_params, - len_min = 7L + len_min = 7L ) # return a band object new_band_params @@ -831,8 +844,10 @@ # check extra parameters dots <- list(...) - .check_lst(dots, msg = .conf("messages", - ".check_new_class_band_dots")) + .check_lst(dots, msg = .conf( + "messages", + ".check_new_class_band_dots" + )) # build band class_band_params <- c(list( @@ -1199,9 +1214,10 @@ NULL ) base_groups <- c("ESRI", "OSM", "Sentinel-2") # create a global object for leaflet control - sits_leaflet <- list(leaf_map = leaf_map, - base_groups = base_groups, - overlay_groups = vector() + sits_leaflet <- list( + leaf_map = leaf_map, + base_groups = base_groups, + overlay_groups = vector() ) # put the object in the global sits environment sits_env[["leaflet"]] <- sits_leaflet diff --git a/R/api_crop.R b/R/api_crop.R index fbf1a45d8..0414886e1 100644 --- a/R/api_crop.R +++ b/R/api_crop.R @@ -17,7 +17,7 @@ roi = NULL, multicores = 2L, overwrite = FALSE, - progress = TRUE) { + progress = progress) { .check_set_caller("sits_crop") # Pre-conditions .check_is_raster_cube(cube) diff --git a/R/api_cube.R b/R/api_cube.R index 46ae2fbec..2dbb89eb1 100644 --- a/R/api_cube.R +++ b/R/api_cube.R @@ -30,9 +30,7 @@ NULL #' @param s3_classs S3 class defined for the cube. #' @param cube_class Current cube class. #' @return cube classes -.cube_class_strategy_default <- function( - base_class, source, collection, s3_class, cube_class, ... -) { +.cube_class_strategy_default <- function(base_class, source, collection, s3_class, cube_class, ...) { unique(c(base_class, s3_class, cube_class)) } #' @title Strategy function to define `SAR (GRD)` data cube classes @@ -45,13 +43,12 @@ NULL #' @param s3_classs S3 class defined for the cube. #' @param cube_class Current cube class. #' @return cube classes -`.cube_class_strategy_sar-grd` <- function( - base_class, source, collection, s3_class, cube_class, ... -) { - is_sar <- .try({ - .conf("sources", source, "collections", collection, "sar_cube") - }, - .default = FALSE +`.cube_class_strategy_sar-grd` <- function(base_class, source, collection, s3_class, cube_class, ...) { + is_sar <- .try( + { + .conf("sources", source, "collections", collection, "sar_cube") + }, + .default = FALSE ) is_sar <- is_sar && !grepl("rtc", base_class, fixed = TRUE) if (is_sar) { @@ -68,12 +65,12 @@ NULL #' @param s3_classs S3 class defined for the cube. #' @param cube_class Current cube class. #' @return cube classes -`.cube_class_strategy_sar-rtc` <- function( - base_class, source, collection, s3_class, cube_class, ...) { - is_sar <- .try({ - .conf("sources", source, "collections", collection, "sar_cube") - }, - .default = FALSE +`.cube_class_strategy_sar-rtc` <- function(base_class, source, collection, s3_class, cube_class, ...) { + is_sar <- .try( + { + .conf("sources", source, "collections", collection, "sar_cube") + }, + .default = FALSE ) is_sar <- is_sar && grepl("rtc", base_class, fixed = TRUE) @@ -91,13 +88,12 @@ NULL #' @param s3_classs S3 class defined for the cube. #' @param cube_class Current cube class. #' @return cube classes -.cube_class_strategy_dem <- function( - base_class, source, collection, s3_class, cube_class, ... -) { - is_dem <- .try({ - .conf("sources", source, "collections", collection, "dem_cube") - }, - .default = FALSE +.cube_class_strategy_dem <- function(base_class, source, collection, s3_class, cube_class, ...) { + is_dem <- .try( + { + .conf("sources", source, "collections", collection, "dem_cube") + }, + .default = FALSE ) if (is_dem) { @@ -114,9 +110,7 @@ NULL #' @param s3_classs S3 class defined for the cube. #' @param cube_class Current cube class. #' @return cube classes -.cube_class_strategy_rainfall <- function( - base_class, source, collection, s3_class, cube_class, ... -) { +.cube_class_strategy_rainfall <- function(base_class, source, collection, s3_class, cube_class, ...) { is_rainfall <- grepl("rainfall", base_class, fixed = TRUE) if (is_rainfall) { unique(c(base_class, "rainfall_cube", s3_class, cube_class)) @@ -132,19 +126,20 @@ NULL #' @param s3_classs S3 class defined for the cube. #' @param cube_class Current cube class. #' @return cube classes -.cube_class_strategy_class <- function( - base_class, source, collection, s3_class, cube_class, ... -) { - is_class <- .try({ - .conf("sources", source, "collections", collection, "class_cube") - }, - .default = FALSE +.cube_class_strategy_class <- function(base_class, source, collection, s3_class, cube_class, ...) { + is_class <- .try( + { + .conf("sources", source, "collections", collection, "class_cube") + }, + .default = FALSE ) if (is_class) { # explicitly defining a `class_cube` following the definition from the # `sits_label_classification` function. - c("class_cube", "derived_cube", "raster_cube", - base_class, "tbl_df", "tbl", "data.frame") + c( + "class_cube", "derived_cube", "raster_cube", + base_class, "tbl_df", "tbl", "data.frame" + ) } } #' @title Registry of class definition strategies @@ -176,9 +171,7 @@ NULL #' @param s3_classs S3 class defined for the cube. #' @param cube_class Current cube class. #' @return cube classes -.cube_define_class <- function( - base_class, source, collection, s3_class, cube_class, ... -) { +.cube_define_class <- function(base_class, source, collection, s3_class, cube_class, ...) { # guess the class cube using the rules from the registry cube_class_new <- purrr::map(.cube_define_class_strategies(), function(fn) { fn( @@ -481,7 +474,8 @@ NULL #' @export .cube_collection.default <- function(cube) { .check_that(is.list(cube), - msg = .conf("messages", "cube_collection")) + msg = .conf("messages", "cube_collection") + ) cube |> tibble::as_tibble() |> .cube_find_class() |> @@ -556,7 +550,8 @@ NULL tile = ifelse( .data[["tile"]] == "NoTilingSystem", paste0(.data[["tile"]], "-", dplyr::row_number()), - .data[["tile"]]) + .data[["tile"]] + ) ) } #' @title Adjust cube tile name @@ -589,7 +584,7 @@ NULL #' @export .cube_s3class.raster_cube <- function(cube) { # extract cube metadata - source <- .cube_source(cube = cube) + source <- .cube_source(cube = cube) collection <- .tile_collection(cube) s3_class <- .source_s3class(source = source) col_class <- paste( @@ -683,19 +678,19 @@ NULL #' @noRd #' @author Rolf Simoes, \email{rolfsimoes@@gmail.com} #' -#'@param cube input data cube +#' @param cube input data cube #' -#'@return A character string +#' @return A character string .cube_source <- function(cube) { UseMethod(".cube_source", cube) } -#'@export +#' @export .cube_source.raster_cube <- function(cube) { # set caller to show in errors .check_set_caller(".cube_source") .compact(slider::slide_chr(cube, .tile_source)) } -#'@export +#' @export .cube_source.default <- function(cube) { cube <- cube |> tibble::as_tibble() |> @@ -1081,7 +1076,6 @@ NULL .cube_filter_nonempty <- function(cube) { not_empty <- slider::slide_lgl(cube, .tile_is_nonempty) cube[not_empty, ] - } #' @title Returns the tile names of a data cube #' @noRd @@ -1334,7 +1328,6 @@ NULL .is_eq(max_xmin, min_xmin, tolerance = tolerance) && .is_eq(max_ymin, min_ymin, tolerance = tolerance) && .is_eq(max_ymax, min_ymax, tolerance = tolerance) - }) all(equal_bbox) } @@ -1350,8 +1343,9 @@ NULL cube, function(tile) { (length(unique(.tile_nrows(tile))) == 1L && - length(unique(.tile_ncols(tile))) == 1L) - }) + length(unique(.tile_ncols(tile))) == 1L) + } + ) all(test_cube_size) } @@ -1555,18 +1549,21 @@ NULL block = block ) chunks_sf <- .bbox_as_sf( - .bbox(chunks, by_feature = TRUE), as_crs = sf::st_crs(samples_sf) + .bbox(chunks, by_feature = TRUE), + as_crs = sf::st_crs(samples_sf) ) chunks_sf <- dplyr::bind_cols(chunks_sf, chunks) chunks_sf <- chunks_sf[.intersects(chunks_sf, samples_sf), ] - if (nrow(chunks_sf) == 0L) + if (nrow(chunks_sf) == 0L) { return(NULL) + } chunks_sf[["tile"]] <- tile[["tile"]] chunks_sf <- dplyr::group_by(chunks_sf, .data[["row"]], .data[["tile"]]) chunks_sf <- dplyr::summarise(chunks_sf) chunks_sf <- slider::slide(chunks_sf, function(chunk_sf) { chunk_sf[["samples"]] <- list(samples_sf[ - .within(samples_sf, chunk_sf), ]) + .within(samples_sf, chunk_sf), + ]) chunk_sf }) chunks_sf diff --git a/R/api_data.R b/R/api_data.R index ea03279e8..c304ae84d 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -62,7 +62,7 @@ block <- .raster_file_blocksize(rast) # 1st case - split samples by tiles if ((.raster_nrows(rast) == block[["nrows"]] && - .raster_ncols(rast) == block[["ncols"]]) || + .raster_ncols(rast) == block[["ncols"]]) || inherits(cube, "dem_cube")) { # split samples by bands and tile ts_tbl <- .data_by_tile( @@ -516,7 +516,7 @@ ts_tbl <- dplyr::bind_rows(samples_tiles_bands) if (!.has_ts(ts_tbl)) { warning(.conf("messages", ".data_by_tile"), - immediate. = TRUE, call. = FALSE + immediate. = TRUE, call. = FALSE ) return(.tibble()) } @@ -556,8 +556,9 @@ hash_bundle <- purrr::map_chr(tiles_bands, function(tile_band) { tile_id <- tile_band[[1L]] band <- tile_band[[2L]] - tile <- .select_raster_cube(cube, bands = c(band, cld_band), - tiles = tile_id + tile <- .select_raster_cube(cube, + bands = c(band, cld_band), + tiles = tile_id ) digest::digest(list(tile, samples), algo = "md5") }) @@ -719,7 +720,7 @@ ts_tbl <- dplyr::bind_rows(samples_tiles_bands) if (!.has_ts(ts_tbl)) { warning(.conf("messages", ".data_by_chunks"), - immediate. = TRUE, call. = FALSE + immediate. = TRUE, call. = FALSE ) return(.tibble()) } @@ -897,8 +898,10 @@ classes <- labels[class_numbers] # insert classes into samples samples[["label"]] <- unname(classes) - samples <- dplyr::select(samples, dplyr::all_of("longitude"), - dplyr::all_of("latitude"), dplyr::all_of("label")) + samples <- dplyr::select( + samples, dplyr::all_of("longitude"), + dplyr::all_of("latitude"), dplyr::all_of("label") + ) samples }) data @@ -952,11 +955,14 @@ ) colnames(xy) <- c("X", "Y") - if (.has(window_size)) - samples <- .data_get_probs_window(tile, samples, xy, - band_conf, window_size) - else + if (.has(window_size)) { + samples <- .data_get_probs_window( + tile, samples, xy, + band_conf, window_size + ) + } else { samples <- .data_get_probs_pixel(tile, samples, xy, band_conf) + } samples }) @@ -1026,9 +1032,11 @@ right_col <- min(center_col + overlap, ncols) # build a vector of cells cells <- vector() - for (row in c(top_row:bottow_row)) - for (col in c(left_col:right_col)) + for (row in c(top_row:bottow_row)) { + for (col in c(left_col:right_col)) { cells <- c(cells, .raster_cell_from_rowcol(rast, row, col)) + } + } values <- .raster_extract(rast, cells) offset <- .offset(band_conf) if (.has(offset) && offset != 0.0) { diff --git a/R/api_detect_change.R b/R/api_detect_change.R index ad45bf175..6a63c286b 100644 --- a/R/api_detect_change.R +++ b/R/api_detect_change.R @@ -16,8 +16,10 @@ bands <- .dc_bands(dc_method) # Update samples bands order if (any(bands != .samples_bands(samples))) { - samples <- .samples_select_bands(samples = samples, - bands = bands) + samples <- .samples_select_bands( + samples = samples, + bands = bands + ) } # Apply time series filter if (.has(filter_fn)) { @@ -258,7 +260,8 @@ tile_paths <- .tile_paths(tile, bands = tile_band) rast <- .raster_open_rast(tile_paths) quantile_values <- .raster_quantile( - rast, quantile = deseasonlize, na.rm = TRUE + rast, + quantile = deseasonlize, na.rm = TRUE ) quantile_values <- impute_fn(t(quantile_values)) # Fill with zeros remaining NA pixels diff --git a/R/api_dtw.R b/R/api_dtw.R index 2820106f9..0e515f5a7 100644 --- a/R/api_dtw.R +++ b/R/api_dtw.R @@ -35,8 +35,8 @@ .dtw_cube <- function(values, patterns, window, threshold, ...) { # Extract dates dates <- .ts_index(values[[1L]]) - dates_min <- .ts_min_date(values[[1L]]) - dates_max <- .ts_max_date(values[[1L]]) + dates_min <- .ts_min_date(values[[1L]]) + dates_max <- .ts_max_date(values[[1L]]) # Assume time-series are regularized, then use the period # as the step of the moving window. As a result, we have # one step per iteration. @@ -85,8 +85,8 @@ .dtw_ts <- function(values, patterns, window, threshold, ...) { # Extract dates dates <- .ts_index(values[[1L]]) - dates_min <- .ts_min_date(values[[1L]]) - dates_max <- .ts_max_date(values[[1L]]) + dates_min <- .ts_min_date(values[[1L]]) + dates_max <- .ts_max_date(values[[1L]]) # Assume time-series are regularized, then use the period # as the step of the moving window. As a result, we have # one step per iteration. diff --git a/R/api_environment.R b/R/api_environment.R index d133ad85a..d36123505 100644 --- a/R/api_environment.R +++ b/R/api_environment.R @@ -1,4 +1,3 @@ - # ---- Environment operations ---- #' @title Function to patch environment variables (Developer only). #' @name .environment_patch diff --git a/R/api_file_info.R b/R/api_file_info.R index ef15e706a..684094133 100644 --- a/R/api_file_info.R +++ b/R/api_file_info.R @@ -44,7 +44,9 @@ NULL #' @param fi file_info #' @returns Data cube type (eo_cube or derived_cube) .fi_switch <- function(fi, ...) { - switch(.fi_type(fi), ...) + switch(.fi_type(fi), + ... + ) } #' @title Create a file_info for a new eo_cube #' @noRd @@ -326,8 +328,10 @@ NULL fi = fi, start_date = start_date, end_date = end_date ) if (!any(dates_in_fi)) { - stop(.conf("messages", ".fi_filter_interval"), - start_date[[1L]], end_date[[1L]]) + stop( + .conf("messages", ".fi_filter_interval"), + start_date[[1L]], end_date[[1L]] + ) } fi[dates_in_fi, ] } diff --git a/R/api_gdal.R b/R/api_gdal.R index 1a461df06..9dcc86e36 100644 --- a/R/api_gdal.R +++ b/R/api_gdal.R @@ -132,14 +132,16 @@ "-overwrite" = FALSE ) # additional param for target SRS - if (.has(t_srs)) + if (.has(t_srs)) { params <- append(params, c("t_srs" = t_srs)) + } # warp the data .gdal_warp( file = temp_file, base_files = raster_file, params = params, - quiet = TRUE) + quiet = TRUE + ) return(temp_file) } #' @title Run gdal_addo diff --git a/R/api_gdalcubes.R b/R/api_gdalcubes.R index 269e1cf32..dad0dd87b 100644 --- a/R/api_gdalcubes.R +++ b/R/api_gdalcubes.R @@ -109,7 +109,6 @@ aggregation = agg_method, resampling = resampling ) - } #' @title Create an gdalcubes::image_mask object @@ -189,12 +188,12 @@ file_info <- file_info |> dplyr::transmute( - fid = .data[["fid"]], + fid = .data[["fid"]], xmin = .data[["xmin"]], ymin = .data[["ymin"]], xmax = .data[["xmax"]], ymax = .data[["ymax"]], - crs = .data[["crs"]], + crs = .data[["crs"]], href = .data[["path"]], datetime = as.character(.data[["date"]]), band = .data[["band"]], @@ -391,7 +390,8 @@ # convert sits gtiff options to gdalcubes format gtiff_options <- strsplit(.conf("gdalcubes_options"), - split = "=", fixed = TRUE) + split = "=", fixed = TRUE + ) gdalcubes_co <- purrr::map(gtiff_options, `[[`, 2) names(gdalcubes_co) <- purrr::map_chr(gtiff_options, `[[`, 1) @@ -455,7 +455,7 @@ tiles, output_dir, multicores = 1, - progress = progress) { + progress) { # set caller to show in errors .check_set_caller(".gc_regularize") # require gdalcubes package @@ -525,8 +525,9 @@ # we consider token is expired when the remaining time is # less than 5 minutes - if (.cube_is_token_expired(cube)) + if (.cube_is_token_expired(cube)) { return(NULL) + } # filter tile tile <- dplyr::filter(cube, .data[["tile"]] == !!tile_name) @@ -647,8 +648,7 @@ # show message message("tiles", msg, "are missing or malformed", " - and will be reprocessed." - ) + and will be reprocessed.") # remove cache .parallel_stop() @@ -661,7 +661,7 @@ roi = roi, multicores = multicores, output_dir = output_dir, - progress = FALSE + progress = progress ) return(local_cube) } @@ -677,8 +677,8 @@ #' @return A character with the type of crs: "proj:wkt2" or "proj:epsg" .gc_detect_crs_type <- function(cube_crs) { if (all(is.numeric(cube_crs)) || - all(startsWith(cube_crs, prefix = "EPSG")) - ) { + all(startsWith(cube_crs, prefix = "EPSG")) + ) { return("proj:epsg") } "proj:wkt2" @@ -751,5 +751,4 @@ # return all tiles from the original cube # that have not been processed or regularized correctly unique(c(miss_tiles_bands_times, proc_tiles_bands_times)) - } diff --git a/R/api_grid.R b/R/api_grid.R index 051a3168d..83c9210a1 100644 --- a/R/api_grid.R +++ b/R/api_grid.R @@ -14,7 +14,8 @@ # get system grid path grid_path <- system.file( - .conf("grid_systems", grid_system, "path"), package = "sits" + .conf("grid_systems", grid_system, "path"), + package = "sits" ) s2_tb <- readRDS(grid_path) @@ -24,7 +25,7 @@ # create a sf of points epsg_lst <- unique(s2_tb[["epsg"]]) points_sf <- sf::st_as_sf(.map_dfr(epsg_lst, function(epsg) { - tiles <- dplyr::filter(s2_tb, epsg == {{epsg}}) + tiles <- dplyr::filter(s2_tb, epsg == {{ epsg }}) sfc <- matrix(c(tiles[["xmin"]], tiles[["ymin"]]), ncol = 2L) |> sf::st_multipoint(dim = "XY") |> sf::st_sfc(crs = epsg) |> @@ -40,7 +41,8 @@ .bbox(.roi_as_sf(roi, as_crs = "EPSG:4326")), xmin = xmin - 1.5, ymin = ymin - 1.5 - )) + ) + ) # filter points s2_tb <- s2_tb[.intersects(points_sf, roi_search), ] } @@ -48,18 +50,20 @@ # creates a list of simple features epsg_lst <- unique(s2_tb[["epsg"]]) s2_sf_lst <- purrr::map(epsg_lst, function(epsg) { - dplyr::filter(s2_tb, epsg == {{epsg}}) |> + dplyr::filter(s2_tb, epsg == {{ epsg }}) |> dplyr::mutate( xmax = xmin + 109800L, ymax = ymin + 109800L, - crs = paste0("EPSG:", {{epsg}}) + crs = paste0("EPSG:", {{ epsg }}) ) |> dplyr::rowwise() |> dplyr::mutate(geom = sf::st_as_sfc(sf::st_bbox( - c(xmin = xmin, - ymin = ymin, - xmax = xmax, - ymax = ymax) + c( + xmin = xmin, + ymin = ymin, + xmax = xmax, + ymax = ymax + ) ))) |> dplyr::ungroup() }) @@ -77,8 +81,9 @@ ) })) # if roi is given, filter tiles by desired roi - if (.has(roi)) + if (.has(roi)) { s2_tiles <- s2_tiles[.intersects(s2_tiles, .roi_as_sf(roi)), ] + } # return s2 tiles s2_tiles } @@ -99,7 +104,8 @@ # get system grid path grid_path <- system.file( - .conf("grid_systems", grid_system, "path"), package = "sits" + .conf("grid_systems", grid_system, "path"), + package = "sits" ) # open ext_data tiles.rds file bdc_tiles <- readRDS(grid_path) @@ -129,10 +135,12 @@ ) |> dplyr::rowwise() |> dplyr::mutate(geom = sf::st_as_sfc(sf::st_bbox( - c(xmin = xmin, - ymin = ymin, - xmax = xmax, - ymax = ymax) + c( + xmin = xmin, + ymin = ymin, + xmax = xmax, + ymax = ymax + ) ))) |> sf::st_as_sf(crs = crs) @@ -158,10 +166,10 @@ #' @param tiles Tiles to be retrieved #' @return Tiles in the desired grid system .grid_filter_tiles <- function(grid_system, roi, tiles) { - switch( - grid_system, + switch(grid_system, "MGRS" = .grid_filter_mgrs(grid_system, roi, tiles), - "BDC_LG_V2" = , "BDC_MD_V2" = , + "BDC_LG_V2" = , + "BDC_MD_V2" = , "BDC_SM_V2" = .grid_filter_bdc(grid_system, roi, tiles) ) } @@ -199,10 +207,12 @@ ymin <- as.double(tile[["ymin"]]) ymax <- ymin + 109800L bbox <- sf::st_bbox( - c(xmin = xmin, - ymin = ymin, - xmax = xmax, - ymax = ymax), + c( + xmin = xmin, + ymin = ymin, + xmax = xmax, + ymax = ymax + ), crs = sf::st_crs(tile[["epsg"]]) ) bbox_ll <- bbox |> diff --git a/R/api_jobs.R b/R/api_jobs.R index 65f65ea45..1c9c4be3d 100644 --- a/R/api_jobs.R +++ b/R/api_jobs.R @@ -131,7 +131,7 @@ #' @param progress Show progress bar? #' @returns List with function results .jobs_map_parallel <- function(jobs, fn, ..., sync_fn = NULL, - progress = FALSE) { + progress = progress) { # Do split by rounds only if sync_fn is not NULL rounds <- .jobs_split(jobs) unlist(purrr::map(rounds, function(round) { @@ -150,7 +150,7 @@ #' @param ... Additional parameters for function #' @param progress Show progress bar? #' @returns Character vector with function results -.jobs_map_parallel_chr <- function(jobs, fn, ..., progress = FALSE) { +.jobs_map_parallel_chr <- function(jobs, fn, ..., progress = progress) { values_lst <- .jobs_map_parallel(jobs, fn, ..., progress = progress) vapply(values_lst, c, NA_character_) } @@ -162,7 +162,7 @@ #' @param ... Additional parameters for function #' @param progress Show progress bar? #' @returns Data.frame with function results -.jobs_map_parallel_dfr <- function(jobs, fn, ..., progress = FALSE) { +.jobs_map_parallel_dfr <- function(jobs, fn, ..., progress = progress) { values_lst <- .jobs_map_parallel(jobs, fn, ..., progress = progress) dplyr::bind_rows(values_lst) } diff --git a/R/api_kohonen.R b/R/api_kohonen.R index 33fe1d6c3..e67a18391 100644 --- a/R/api_kohonen.R +++ b/R/api_kohonen.R @@ -1,4 +1,3 @@ - # ---- kohonen utilities ---- #' @title Get a shared pointer of a distance function. #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} @@ -329,8 +328,9 @@ if (length(user_weights) == 1L) { user_weights <- rep(user_weights, length(whatmap)) } else { - if (length(user_weights) == nmat) + if (length(user_weights) == nmat) { user_weights <- user_weights[whatmap] + } } .check_that(all(user_weights != 0.0)) @@ -370,47 +370,53 @@ } # create supersom switch(mode, - online = { - res <- suppressWarnings({ - RcppSupersom( - data = data_matrix, - codes = init_matrix, - numVars = nvar, - weights = weights, - numNAs = n_na, - neighbourhoodDistances = nhbrdist, - alphas = alpha, - radii = radius, - numEpochs = rlen, - distanceFunction = distance_ptr - )})}, - batch = { - res <- suppressWarnings({ - RcppBatchSupersom( - data = data_matrix, - codes = init_matrix, - numVars = nvar, - weights = weights, - numNAs = n_na, - neighbourhoodDistances = nhbrdist, - radii = radius, - numEpochs = rlen, - distanceFunction = distance_ptr - )})}, - pbatch = { - res <- suppressWarnings({ - RcppParallelBatchSupersom( - data = data_matrix, - codes = init_matrix, - numVars = nvar, - weights = weights, - numNAs = n_na, - neighbourhoodDistances = nhbrdist, - radii = radius, - numEpochs = rlen, - numCores = -1L, - distanceFunction = distance_ptr - )})} + online = { + res <- suppressWarnings({ + RcppSupersom( + data = data_matrix, + codes = init_matrix, + numVars = nvar, + weights = weights, + numNAs = n_na, + neighbourhoodDistances = nhbrdist, + alphas = alpha, + radii = radius, + numEpochs = rlen, + distanceFunction = distance_ptr + ) + }) + }, + batch = { + res <- suppressWarnings({ + RcppBatchSupersom( + data = data_matrix, + codes = init_matrix, + numVars = nvar, + weights = weights, + numNAs = n_na, + neighbourhoodDistances = nhbrdist, + radii = radius, + numEpochs = rlen, + distanceFunction = distance_ptr + ) + }) + }, + pbatch = { + res <- suppressWarnings({ + RcppParallelBatchSupersom( + data = data_matrix, + codes = init_matrix, + numVars = nvar, + weights = weights, + numNAs = n_na, + neighbourhoodDistances = nhbrdist, + radii = radius, + numEpochs = rlen, + numCores = -1L, + distanceFunction = distance_ptr + ) + }) + } ) # extract changes changes <- matrix(res$changes, ncol = nmap, byrow = TRUE) diff --git a/R/api_label_class.R b/R/api_label_class.R index 72b707e56..2e517b267 100644 --- a/R/api_label_class.R +++ b/R/api_label_class.R @@ -125,7 +125,8 @@ dplyr::filter(!anyNA(dplyr::c_across(dplyr::all_of(labels)))) |> dplyr::mutate( class = labels[which.max(dplyr::c_across(dplyr::all_of(labels)))], - pol_id = as.numeric(.data[["pol_id"]])) + pol_id = as.numeric(.data[["pol_id"]]) + ) # Write all segments .vector_write_vec(v_obj = probs_segments, file_path = out_file) @@ -171,6 +172,8 @@ .label_gpkg_file <- function(gpkg_file) { sf <- sf::st_read(gpkg_file, quiet = TRUE) # Extract the labels required by sits from GPKG file - setdiff(colnames(sf), c("supercells", "x", "y", - "pol_id", "geom", "class")) + setdiff(colnames(sf), c( + "supercells", "x", "y", + "pol_id", "geom", "class" + )) } diff --git a/R/api_merge.R b/R/api_merge.R index 9d17edd81..3cc675a39 100644 --- a/R/api_merge.R +++ b/R/api_merge.R @@ -56,7 +56,7 @@ # search the overlapping dates for (idx in seq_len(ts_reference_len)) { # reference interval (`t1`) - reference_interval <- t1[idx: (idx + 1L)] + reference_interval <- t1[idx:(idx + 1L)] # verify which dates are in the reference interval t2_in_interval <- t2 >= t1[idx] & t2 <= t1[idx + 1L] # get the interval dates @@ -72,7 +72,7 @@ # this ensures there are not two dates in the same interval t_overlap <- c( t_overlap, # dates storage - reference_interval, # current interval + reference_interval, # current interval min(t2_interval_dates) # min t2 interval date ) } @@ -353,7 +353,7 @@ #' @return Merged data cube .merge.hls_case <- function(data1, data2) { if ((.cube_collection(data1) == "HLSS30" || - .cube_collection(data2) == "HLSS30")) { + .cube_collection(data2) == "HLSS30")) { data1[["collection"]] <- "HLSS30" } @@ -426,16 +426,21 @@ #' @param data2 Data cube #' @return Strategy to be used .merge_type <- function(data1, data2) { - if (.merge_type_dem(data1, data2)) + if (.merge_type_dem(data1, data2)) { return("dem_case") - if (.merge_type_hls(data1, data2)) + } + if (.merge_type_hls(data1, data2)) { return("hls_case") - if (.merge_type_deaustralia_s2(data1, data2)) + } + if (.merge_type_deaustralia_s2(data1, data2)) { return("irregular_case") - if (.merge_type_regular(data1, data2)) + } + if (.merge_type_regular(data1, data2)) { return("regular_case") - if (.merge_type_irregular(data1, data2)) + } + if (.merge_type_irregular(data1, data2)) { return("irregular_case") + } # find no alternative? error messages stop(.conf("messages", ".merge_type"), toString(class(data1))) } diff --git a/R/api_message.R b/R/api_message.R index c2f771a7f..113c60c0d 100644 --- a/R/api_message.R +++ b/R/api_message.R @@ -22,8 +22,9 @@ #' @noRd #' @returns Called for side effects .message_warnings_bbox_as_sf <- function() { - if (.message_warnings()) + if (.message_warnings()) { warning(.conf("messages", ".bbox_as_sf"), call. = FALSE) + } } #' @title Warning when labels have no colors preset #' @name .message_warnings_colors_get @@ -42,11 +43,12 @@ #' @returns Called for side effects .message_warnings_regularize_cloud <- function(cube) { if (!all(.cube_contains_cloud(cube))) { - if (.message_warnings()) + if (.message_warnings()) { warning(.conf("messages", "sits_regularize_cloud"), - call. = FALSE, - immediate. = TRUE + call. = FALSE, + immediate. = TRUE ) + } } } #' @title Warning when cube is being regularized directly from STAC files @@ -56,7 +58,7 @@ .message_warnings_regularize_local <- function(cube) { if (!.cube_is_local(cube) && .message_warnings()) { warning(.conf("messages", "sits_regularize_local"), - call. = FALSE, immediate. = TRUE + call. = FALSE, immediate. = TRUE ) } } @@ -65,33 +67,40 @@ #' @noRd #' @returns Called for side effects .message_warnings_regularize_crs <- function() { - if (.message_warnings()) + if (.message_warnings()) { warning(.conf("messages", "sits_regularize_crs"), - call. = FALSE, - immediate. = TRUE + call. = FALSE, + immediate. = TRUE ) + } } - #' @title Warning when cube has more than one timeline #' @name .message_warnings_timeline_cube #' @noRd #' @returns Called for side effects .message_warnings_timeline_cube <- function() { - if (.message_warnings()) + if (.message_warnings()) { warning(.conf("messages", "sits_timeline_raster_cube"), - call. = FALSE + call. = FALSE ) + } } +#' @title Test if progress bar should be shown +#' @name .message_progress +#' @noRd +#' @returns Called for side effects .message_progress <- function(progress) { .check_lgl_parameter(progress) - if (progress) - progress <- Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" + if (progress) { + progress <- !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") + } progress } .message_verbose <- function(verbose) { .check_lgl_parameter(verbose) - if (verbose) - verbose <- Sys.getenv("SITS_DOCUMENTATION_MODE") != "TRUE" + if (verbose) { + verbose <- !(Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") + } verbose } #' @title Check is version parameter is valid using reasonable defaults diff --git a/R/api_mixture_model.R b/R/api_mixture_model.R index f4809d76d..c5fe140b8 100644 --- a/R/api_mixture_model.R +++ b/R/api_mixture_model.R @@ -206,7 +206,9 @@ #' @param em Endmember values #' @return Valid endmember specification (csv of tbl_df) .endmembers_switch <- function(em, ...) { - switch(.endmembers_type(em), ...) + switch(.endmembers_type(em), + ... + ) } #' @title Convert endmembers specification to data.frame #' @keywords internal diff --git a/R/api_ml_model.R b/R/api_ml_model.R index 6d672f13b..fe4dbd2b0 100644 --- a/R/api_ml_model.R +++ b/R/api_ml_model.R @@ -147,11 +147,12 @@ #' .ml_update_multicores <- function(ml_model, multicores) { # xgboost model has internal multiprocessing - if ("xgb_model" %in% .ml_class(ml_model)) + if ("xgb_model" %in% .ml_class(ml_model)) { multicores <- 1L - # torch in GPU has internal multiprocessing - else if (.torch_gpu_classification() && .ml_is_torch_model(ml_model)) + } # torch in GPU has internal multiprocessing + else if (.torch_gpu_classification() && .ml_is_torch_model(ml_model)) { multicores <- 1L + } multicores } #' @title Is the ML model a torch model? diff --git a/R/api_mosaic.R b/R/api_mosaic.R index 7e64fb0bb..37ef0fed9 100644 --- a/R/api_mosaic.R +++ b/R/api_mosaic.R @@ -115,19 +115,20 @@ base_tile <- .tile(cube) # Update tile name .tile_name(base_tile) <- "MOSAIC" - if (derived_cube) + if (derived_cube) { out_file <- .file_mosaic_name_derived( tile = base_tile, band = .tile_bands(base_tile), version = version, output_dir = output_dir ) - else + } else { out_file <- .file_mosaic_name_raster( tile = base_tile, band = .tile_bands(base_tile), output_dir = output_dir ) + } # Resume feature if (.raster_is_valid(out_file, output_dir = output_dir)) { .check_recovery() @@ -287,7 +288,9 @@ #' @param tile Tile of data cube #' @return Result dependent on the type .mosaic_switch <- function(tile, ...) { - switch(.mosaic_type(tile), ...) + switch(.mosaic_type(tile), + ... + ) } #' @title Get mosaic CRS #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} diff --git a/R/api_opensearch.R b/R/api_opensearch.R index 4c91bb1b6..61a101c1b 100644 --- a/R/api_opensearch.R +++ b/R/api_opensearch.R @@ -121,8 +121,8 @@ # Get raw content from Open Search API response <- .get_request(url = collection_url, query = query) .check_int_parameter(.response_status(response), - min = 200L, - max = 200L + min = 200L, + max = 200L ) # Extract data from the response page_data <- .response_content(response) diff --git a/R/api_parallel.R b/R/api_parallel.R index d88b74ef4..18aaf5400 100644 --- a/R/api_parallel.R +++ b/R/api_parallel.R @@ -30,7 +30,8 @@ { !is.null(sits_env[["cluster"]]) && socketSelect(list(sits_env[["cluster"]][[1L]][["con"]]), - write = TRUE) + write = TRUE + ) }, error = function(e) FALSE ) @@ -179,9 +180,10 @@ # fault tolerant version of parallel:::recvOneData v <- .parallel_recv_one_data() - list(value = v[["value"]][["value"]], - node = v[["node"]], - tag = v[["value"]][["tag"]] + list( + value = v[["value"]][["value"]], + node = v[["node"]], + tag = v[["value"]][["tag"]] ) } @@ -202,8 +204,8 @@ submit <- function(node, job) { # get hidden object from parallel .send_call <- get("sendCall", - envir = asNamespace("parallel"), - inherits = FALSE + envir = asNamespace("parallel"), + inherits = FALSE ) .send_call( con = cl[[node]], @@ -240,8 +242,8 @@ } # get hidden object from parallel .check_remote_errors <- get("checkForRemoteErrors", - envir = asNamespace("parallel"), - inherits = FALSE + envir = asNamespace("parallel"), + inherits = FALSE ) .check_remote_errors(val) } @@ -268,23 +270,26 @@ progress <- .message_progress(progress) # create progress bar pb <- NULL - if (progress) + if (progress) { pb <- utils::txtProgressBar(min = 0L, max = length(x), style = 3L) + } # sequential processing if (.has_not(sits_env[["cluster"]])) { result <- lapply(seq_along(x), function(i) { value <- fn(x[[i]], ...) # update progress bar - if (progress) + if (progress) { utils::setTxtProgressBar( pb = pb, value = utils::getTxtProgressBar(pb) + 1L ) + } value }) # close progress bar - if (progress) + if (progress) { close(pb) + } return(result) } # parallel processing @@ -310,7 +315,7 @@ } if (any(retry)) { stop(.conf("messages", ".parallel_map"), - call. = FALSE + call. = FALSE ) } } diff --git a/R/api_patterns.R b/R/api_patterns.R index 157d5dcc7..48d30e133 100644 --- a/R/api_patterns.R +++ b/R/api_patterns.R @@ -1,4 +1,3 @@ - #' @title Extract temporal pattern from samples data. #' @name .pattern_temporal_median #' @keywords internal @@ -11,7 +10,9 @@ ts_median <- dplyr::bind_rows(data[["time_series"]]) |> dplyr::group_by(.data[["Index"]]) |> dplyr::summarize(dplyr::across(dplyr::everything(), - stats::median, na.rm = TRUE)) |> + stats::median, + na.rm = TRUE + )) |> dplyr::select(-.data[["Index"]]) ts_median["label"] <- name diff --git a/R/api_plot_raster.R b/R/api_plot_raster.R index 11a6bddaa..5662f62b5 100644 --- a/R/api_plot_raster.R +++ b/R/api_plot_raster.R @@ -35,7 +35,6 @@ first_quantile, last_quantile, tmap_params) { - # check palette .check_palette(palette) # check rev @@ -46,9 +45,11 @@ tile <- tile |> .tile_filter_bands(bands = band) |> .tile_filter_dates(dates = date) |> - .crop(roi = roi, - output_dir = .rand_sub_tempdir(), - progress = FALSE) + .crop( + roi = roi, + output_dir = .rand_sub_tempdir(), + progress = FALSE + ) } # select the file to be plotted @@ -58,11 +59,13 @@ # scale and offset band_conf <- .tile_band_conf(tile, band) band_scale <- .scale(band_conf) - if (.has_not(band_scale)) - band_scale <- 1.0 + if (.has_not(band_scale)) { + band_scale <- 1.0 + } band_offset <- .offset(band_conf) - if (.has_not(band_offset)) - band_offset <- 0.0 + if (.has_not(band_offset)) { + band_offset <- 0.0 + } # retrieve the overview if COG bw_file <- .gdal_warp_file(bw_file, sizes) @@ -137,23 +140,25 @@ tile <- tile |> .tile_filter_bands(bands = band) |> .tile_filter_dates(dates = dates) |> - .crop(roi = roi, - output_dir = .rand_sub_tempdir(), - progress = FALSE) + .crop( + roi = roi, + output_dir = .rand_sub_tempdir(), + progress = FALSE + ) } # select the files to be plotted - red_file <- .tile_path(tile, band, dates[[1L]]) + red_file <- .tile_path(tile, band, dates[[1L]]) green_file <- .tile_path(tile, band, dates[[2L]]) - blue_file <- .tile_path(tile, band, dates[[3L]]) + blue_file <- .tile_path(tile, band, dates[[3L]]) sizes <- .tile_overview_size(tile = tile, max_cog_size) # get the max values band_params <- .tile_band_conf(tile, band) max_value <- .max_value(band_params) # used for SAR images without tiling system - if (tile[["tile"]] == "NoTilingSystem") { - red_file <- .gdal_warp_file(red_file, sizes) + if (tile[["tile"]] == "NoTilingSystem") { + red_file <- .gdal_warp_file(red_file, sizes) green_file <- .gdal_warp_file(green_file, sizes) - blue_file <- .gdal_warp_file(blue_file, sizes) + blue_file <- .gdal_warp_file(blue_file, sizes) } title <- stringr::str_flatten(c(band, as.character(dates)), collapse = " ") # plot multitemporal band as RGB @@ -202,15 +207,16 @@ first_quantile, last_quantile, tmap_params) { - # crop using ROI if (.has(roi)) { tile <- tile |> .tile_filter_bands(bands = bands) |> .tile_filter_dates(dates = date) |> - .crop(roi = roi, - output_dir = .rand_sub_tempdir(), - progress = FALSE) + .crop( + roi = roi, + output_dir = .rand_sub_tempdir(), + progress = FALSE + ) } # get RGB files for the requested timeline @@ -223,9 +229,9 @@ # size of data to be read sizes <- .tile_overview_size(tile = tile, max_cog_size) # use COG if availabke to improve plots - red_file <- .gdal_warp_file(red_file, sizes) + red_file <- .gdal_warp_file(red_file, sizes) green_file <- .gdal_warp_file(green_file, sizes) - blue_file <- .gdal_warp_file(blue_file, sizes) + blue_file <- .gdal_warp_file(blue_file, sizes) # title title <- stringr::str_flatten(c(bands, as.character(date)), collapse = " ") @@ -273,9 +279,11 @@ # crop using ROI if (.has(roi)) { tile <- tile |> - .crop(roi = roi, - output_dir = .rand_sub_tempdir(), - progress = FALSE) + .crop( + roi = roi, + output_dir = .rand_sub_tempdir(), + progress = FALSE + ) } # size of data to be read sizes <- .tile_overview_size(tile = tile, max_cog_size) @@ -357,9 +365,11 @@ # crop using ROI if (.has(roi)) { tile <- tile |> - .crop(roi = roi, - output_dir = .rand_sub_tempdir(), - progress = FALSE) + .crop( + roi = roi, + output_dir = .rand_sub_tempdir(), + progress = FALSE + ) } # size of data to be read sizes <- .tile_overview_size(tile = tile, max_cog_size) @@ -388,7 +398,8 @@ quant <- stats::quantile(vls, quantile, na.rm = TRUE) vls[vls < quant] <- NA vls - }) + } + ) values <- do.call(cbind, values) colnames(values) <- names(probs_rast) probs_rast <- .raster_set_values(probs_rast, values) @@ -449,9 +460,9 @@ colnames(values) <- labels # dissolve the data for plotting values <- tidyr::pivot_longer(values, - cols = tidyr::everything(), - names_to = "labels", - values_to = "variance" + cols = tidyr::everything(), + names_to = "labels", + values_to = "variance" ) # Histogram with density plot ggplot2::ggplot( diff --git a/R/api_plot_time_series.R b/R/api_plot_time_series.R index 00fe5da69..3bf79ce55 100644 --- a/R/api_plot_time_series.R +++ b/R/api_plot_time_series.R @@ -54,8 +54,9 @@ # this function plots the values of all time series together (for one band) plot_samples <- function(melted, qts, band, label, number) { # make the plot title - title <- paste0("Samples (", number, ") for class ", - label, " in band = ", band + title <- paste0( + "Samples (", number, ") for class ", + label, " in band = ", band ) # plot all data together graphics::plot(.plot_ggplot_together(melted, qts, title)) diff --git a/R/api_plot_vector.R b/R/api_plot_vector.R index 1eb65f8f0..a6df69040 100644 --- a/R/api_plot_vector.R +++ b/R/api_plot_vector.R @@ -11,11 +11,11 @@ #' @param tmap_params Parameters for tmap control #' @return A plot object #' -.plot_class_vector <- function(tile, - legend, - palette, - scale, - tmap_params) { +.plot_class_vector <- function(tile, + legend, + palette, + scale, + tmap_params) { # set caller to show in errors .check_set_caller(".plot_class_vector") # retrieve the segments for this tile @@ -44,10 +44,12 @@ dplyr::summarise() # plot - .tmap_vector_class(sf_seg = sf_seg, - colors = colors, - scale = scale, - tmap_params = tmap_params) + .tmap_vector_class( + sf_seg = sf_seg, + colors = colors, + scale = scale, + tmap_params = tmap_params + ) } #' @title Plot a probs vector cube #' @name .plot_probs_vector @@ -64,12 +66,12 @@ #' #' @return A plot object #' -.plot_probs_vector <- function(tile, - labels_plot, - palette, - rev, - scale, - tmap_params) { +.plot_probs_vector <- function(tile, + labels_plot, + palette, + rev, + scale, + tmap_params) { # set caller to show in errors .check_set_caller(".plot_probs_vector") # precondition - check color palette diff --git a/R/api_predictors.R b/R/api_predictors.R index 43723dc05..92110fc2d 100644 --- a/R/api_predictors.R +++ b/R/api_predictors.R @@ -200,7 +200,8 @@ ) |> dplyr::mutate( sample_id = rep(seq_len(nrow(data)), - each = dplyr::n() / nrow(data)), + each = dplyr::n() / nrow(data) + ), label = "NoClass", Index = rep(timeline, nrow(data)), .before = 1L diff --git a/R/api_raster.R b/R/api_raster.R index 2683cdca8..12cbc42e0 100644 --- a/R/api_raster.R +++ b/R/api_raster.R @@ -580,11 +580,13 @@ # pre-condition .check_that(.has_not(block) || .has_not(bbox)) # check block - if (.has(block)) + if (.has(block)) { .check_raster_block(block = block) + } # check bbox - if (.has(bbox)) + if (.has(bbox)) { .check_raster_bbox(bbox = bbox) + } # obtain coordinates from columns and rows if (!is.null(block)) { # get extent @@ -745,10 +747,11 @@ i <- i + 1L } value <- rast[i] - if (value > 1.0 && value <= 10000L) + if (value > 1.0 && value <= 10000L) { scale_factor <- 0.0001 - else + } else { scale_factor <- 1.0 + } scale_factor } #' @name .raster_crs @@ -1028,7 +1031,7 @@ "-a_nodata" = missing_value, "-co" = .conf("gdal_creation_options") ), - quiet = TRUE + quiet = FALSE ) # Delete auxiliary files on.exit(unlink(paste0(out_file, ".aux.xml")), add = TRUE) @@ -1329,8 +1332,10 @@ rast <- (rast * band_scale + band_offset) * 255L # # stretch the raster - rast <- .raster_stretch(rast, minv = 0L, maxv = 255L, - minq = 0.05, maxq = 0.95) + rast <- .raster_stretch(rast, + minv = 0L, maxv = 255L, + minq = 0.05, maxq = 0.95 + ) # convert to RGB names(rast) <- c("red", "green", "blue") terra::RGB(rast) <- c(1L, 2L, 3L) diff --git a/R/api_raster_sub_image.R b/R/api_raster_sub_image.R index b6fd799c8..af8d5ac80 100644 --- a/R/api_raster_sub_image.R +++ b/R/api_raster_sub_image.R @@ -98,9 +98,9 @@ ) subimage_max <- si[["xmax"]] .check_num_parameter(subimage_max, - min = tile[["xmin"]], - max = tile[["xmax"]], - tolerance = tolerance + min = tile[["xmin"]], + max = tile[["xmax"]], + tolerance = tolerance ) subimage_ymin <- si[["ymin"]] .check_num_parameter(subimage_ymin, diff --git a/R/api_reclassify.R b/R/api_reclassify.R index 215a0f33f..8593b503b 100644 --- a/R/api_reclassify.R +++ b/R/api_reclassify.R @@ -10,9 +10,10 @@ #' @param reclassify_fn Function to be applied for reclassification #' @param output_dir Directory where image will be save #' @param version Version of result. +#' @param progress Show progress bar? #' @return reclassified tile .reclassify_tile <- function(tile, mask, band, labels, reclassify_fn, - output_dir, version) { + output_dir, version, progress) { # Output files out_file <- .file_derived_name( tile = tile, band = band, version = version, output_dir = output_dir @@ -114,7 +115,7 @@ gc() # Returned value block_file - }) + }, progress = progress) # Merge blocks into a new class_cube tile class_tile <- .tile_derived_merge_blocks( file = out_file, diff --git a/R/api_reduce.R b/R/api_reduce.R index bfc62af16..c8a2336fd 100644 --- a/R/api_reduce.R +++ b/R/api_reduce.R @@ -21,7 +21,6 @@ impute_fn, output_dir, progress) { - # Output file out_file <- .file_eo_name( tile = tile, band = out_band, @@ -119,7 +118,6 @@ gc() # Returned block files for each fraction block_file - }, progress = progress) # Merge blocks into a new eo_cube tile band_tile <- .tile_eo_merge_blocks( @@ -248,9 +246,12 @@ #' @noRd #' @return An output datatype .reduce_datatypes <- function(fn_name) { - switch( - fn_name, - t_sum = , t_std = , t_skewness = , t_kurtosis = , t_mse = "FLT4S", + switch(fn_name, + t_sum = , + t_std = , + t_skewness = , + t_kurtosis = , + t_mse = "FLT4S", "INT2S" ) } diff --git a/R/api_regularize.R b/R/api_regularize.R index 7e724db31..df107a7cf 100644 --- a/R/api_regularize.R +++ b/R/api_regularize.R @@ -97,7 +97,7 @@ dplyr::bind_rows(assets, empty_files), .data[["feature"]] ) .check_that( - nrow(assets) == length(origin_tl) * length(.tile_bands(tile)) + nrow(assets) == length(origin_tl) * length(.tile_bands(tile)) ) assets }) @@ -119,7 +119,8 @@ output_dir = output_dir ) fid_name <- paste( - asset[["satellite"]], asset[["sensor"]], asset[["feature"]], sep = "_" + asset[["satellite"]], asset[["sensor"]], asset[["feature"]], + sep = "_" ) # Resume feature if (file.exists(out_file)) { @@ -143,13 +144,17 @@ x = .roi_as_sf(roi, as_crs = .crs(asset)), y = .bbox_as_sf(.bbox(asset)) )) - block <- list(ncols = floor((.xmax(roi_bbox) - .xmin(roi_bbox)) / res), - nrows = floor((.ymax(roi_bbox) - .ymin(roi_bbox)) / res)) - bbox <- list(xmin = .xmin(roi_bbox), - xmax = .xmin(roi_bbox) + .ncols(block) * res, - ymin = .ymax(roi_bbox) - .nrows(block) * res, - ymax = .ymax(roi_bbox), - crs = .crs(roi_bbox)) + block <- list( + ncols = floor((.xmax(roi_bbox) - .xmin(roi_bbox)) / res), + nrows = floor((.ymax(roi_bbox) - .ymin(roi_bbox)) / res) + ) + bbox <- list( + xmin = .xmin(roi_bbox), + xmax = .xmin(roi_bbox) + .ncols(block) * res, + ymin = .ymax(roi_bbox) - .nrows(block) * res, + ymax = .ymax(roi_bbox), + crs = .crs(roi_bbox) + ) out_file <- .gdal_template_block( block = block, bbox = bbox, @@ -238,7 +243,7 @@ # redistribute data into tiles cube <- tiles_filtered |> dplyr::rowwise() |> - dplyr::group_map(~{ + dplyr::group_map(~ { # prepare a sf object representing the bbox of each image in # file_info if (.has_not(fi_bbox)) { @@ -297,8 +302,8 @@ cube_class <- .cube_s3class(cube) cube <- tiles_filtered |> dplyr::rowwise() |> - dplyr::group_map(~{ - file_info <- .fi(cube)[.intersects({{fi_bbox}}, .x), ] + dplyr::group_map(~ { + file_info <- .fi(cube)[.intersects({{ fi_bbox }}, .x), ] .cube_create( source = .tile_source(cube), collection = .tile_collection(cube), @@ -339,7 +344,7 @@ cube <- tiles_filtered |> dplyr::rowwise() |> - dplyr::group_map(~{ + dplyr::group_map(~ { # prepare a sf object representing the bbox of each image in # file_info cube_crs <- dplyr::filter(cube, .data[["crs"]] == .x[["crs"]]) @@ -360,7 +365,7 @@ by_feature = TRUE ), as_crs = .x[["crs"]]) # check intersection between files and tile - file_info <- cube_fi[.intersects({{fi_bbox}}, .x), ] + file_info <- cube_fi[.intersects({{ fi_bbox }}, .x), ] .cube_create( source = .tile_source(cube_crs), collection = .tile_collection(cube_crs), @@ -401,7 +406,7 @@ cube <- tiles_filtered |> dplyr::rowwise() |> - dplyr::group_map(~{ + dplyr::group_map(~ { # prepare a sf object representing the bbox of each image in # file_info cube_crs <- dplyr::filter(cube, .data[["crs"]] == .x[["crs"]]) @@ -422,7 +427,7 @@ by_feature = TRUE ), as_crs = .x[["crs"]]) # check intersection between files and tile - file_info <- cube_fi[.intersects({{fi_bbox}}, .x), ] + file_info <- cube_fi[.intersects({{ fi_bbox }}, .x), ] .cube_create( source = .tile_source(cube_crs), collection = .tile_collection(cube_crs), @@ -461,7 +466,7 @@ cube_class <- .cube_s3class(cube) cube <- tiles_filtered |> dplyr::rowwise() |> - dplyr::group_map(~{ + dplyr::group_map(~ { # prepare a sf object representing the bbox of each image in # file_info cube_crs <- dplyr::filter(cube, .data[["crs"]] == .x[["crs"]]) @@ -482,7 +487,7 @@ by_feature = TRUE ), as_crs = .x[["crs"]]) # check intersection between files and tile - file_info <- cube_fi[.intersects({{fi_bbox}}, .x), ] + file_info <- cube_fi[.intersects({{ fi_bbox }}, .x), ] .cube_create( source = .tile_source(cube_crs), collection = .tile_collection(cube_crs), diff --git a/R/api_request.R b/R/api_request.R index 2d4e0d226..e4450be43 100644 --- a/R/api_request.R +++ b/R/api_request.R @@ -29,7 +29,7 @@ #' @param ... Additional parameters to be passed to httr2 package #' #' @return A response object. -.request <- function(req_obj, ...) { +.request <- function(req_obj, ...) { # check package pkg_class <- .request_check_package() diff --git a/R/api_request_httr2.R b/R/api_request_httr2.R index a8c0cf780..1198ea886 100644 --- a/R/api_request_httr2.R +++ b/R/api_request_httr2.R @@ -24,7 +24,7 @@ #' #' @return A httr2 response object. #' @export -.request.httr2 <- function(req_obj, ...) { +.request.httr2 <- function(req_obj, ...) { httr2::req_perform(req_obj, ...) } @@ -116,8 +116,8 @@ header <- as.list(header) # Create a default header default_value <- list( - "User-Agent" = "SITS-R-PACKAGE (github.com/e-sensing/sits)", - "Accept" = "*/*", + "User-Agent" = "SITS-R-PACKAGE (github.com/e-sensing/sits)", + "Accept" = "*/*", "Connection" = "keep-alive" ) @@ -246,5 +246,7 @@ } .switch_content <- function(resp_obj, ...) { - switch(.response_content_type(resp_obj), ...) + switch(.response_content_type(resp_obj), + ... + ) } diff --git a/R/api_roi.R b/R/api_roi.R index 7568aec29..dc9e75a84 100644 --- a/R/api_roi.R +++ b/R/api_roi.R @@ -87,7 +87,7 @@ NULL #' @noRd .roi_switch <- function(roi, ...) { switch(.roi_type(roi), - ... + ... ) } @@ -98,8 +98,9 @@ NULL # is the roi defined by a shapefile if (is.character(roi) && file.exists(roi) && - (tools::file_ext(roi) == "shp")) + (tools::file_ext(roi) == "shp")) { roi <- sf::st_read(roi) + } # get roi type roi_type <- .roi_type(roi) # `xs` requires the definition of a CRS diff --git a/R/api_samples.R b/R/api_samples.R index 1a93267a6..ce31fcc5f 100644 --- a/R/api_samples.R +++ b/R/api_samples.R @@ -61,8 +61,9 @@ # verify if data exists # splits the data into k groups data[["folds"]] <- caret::createFolds(data[["label"]], - k = folds, - returnTrain = FALSE, list = FALSE) + k = folds, + returnTrain = FALSE, list = FALSE + ) data } #' @title Extract time series from samples @@ -150,8 +151,10 @@ #' @export .samples_select_bands.sits <- function(samples, bands) { # Filter samples - .ts(samples) <- .ts_select_bands(ts = .ts(samples), - bands = bands) + .ts(samples) <- .ts_select_bands( + ts = .ts(samples), + bands = bands + ) # Return samples samples } @@ -160,16 +163,20 @@ ts_bands <- .samples_bands.sits(samples) ts_select_bands <- bands[bands %in% ts_bands] # Filter time series samples - .ts(samples) <- .ts_select_bands(ts = .ts(samples), - bands = ts_select_bands) + .ts(samples) <- .ts_select_bands( + ts = .ts(samples), + bands = ts_select_bands + ) # Return samples samples } #' @export .samples_select_bands.patterns <- function(samples, bands) { # Filter samples - .ts(samples) <- .ts_select_bands(ts = .ts(samples), - bands = bands) + .ts(samples) <- .ts_select_bands( + ts = .ts(samples), + bands = bands + ) # Return samples samples } @@ -276,9 +283,7 @@ #' @noRd .samples_alloc_strata <- function(cube, samples_class, - alloc, ..., - multicores = 2L, - progress = TRUE) { + alloc, ...) { UseMethod(".samples_alloc_strata", cube) } #' @export @@ -286,9 +291,7 @@ samples_class, alloc, ..., multicores = 2L, - progress = TRUE) { - # check progress - progress <- .message_progress(progress) + progress = progress) { # estimate size size <- samples_class[[alloc]] size <- ceiling(max(size) / nrow(cube)) @@ -322,7 +325,8 @@ # get labels from `samples_class` by `label_id` to avoid errors samples_sf <- samples_sf |> dplyr::left_join( - samples_class, by = c("cover" = "label_id") + samples_class, + by = c("cover" = "label_id") ) |> dplyr::select("label", "geometry") } @@ -334,7 +338,7 @@ samples <- .map_dfr(labels, function(lab) { # get metadata for the current label samples_label <- samples_class |> - dplyr::filter(.data[["label"]] == lab) + dplyr::filter(.data[["label"]] == lab) # extract alloc strategy samples_label <- unique(samples_label[[alloc]]) # filter data @@ -350,9 +354,7 @@ samples_class, alloc, ..., multicores = 2, - progress = TRUE) { - # check progress - progress <- .message_progress(progress) + progress = progress) { # Open segments and transform them to tibble segments_cube <- slider::slide_dfr(cube, function(tile) { .segments_read_vec(tile) diff --git a/R/api_segments.R b/R/api_segments.R index 57ff61761..e45ec2fbe 100755 --- a/R/api_segments.R +++ b/R/api_segments.R @@ -232,8 +232,10 @@ # Calculate metrics data <- dplyr::summarise( data, - dplyr::across(.cols = dplyr::all_of(labels), - .names = "{.col}_mean", mean) + dplyr::across( + .cols = dplyr::all_of(labels), + .names = "{.col}_mean", mean + ) ) # Summarize probabilities data <- data |> @@ -275,9 +277,7 @@ #' @param impute_fn Imputation function to remove NA #' #' @return samples associated to segments -.segments_poly_read <- function( - tile, bands, base_bands, chunk, n_sam_pol, impute_fn -) { +.segments_poly_read <- function(tile, bands, base_bands, chunk, n_sam_pol, impute_fn) { # define bands variables ts_bands <- NULL ts_bands_base <- NULL @@ -300,7 +300,7 @@ # rename the resulting list names(ts_bands) <- bands # transform the list to a tibble - ts_bands <- tibble::as_tibble(ts_bands) + ts_bands <- tibble::as_tibble(ts_bands) # retrieve the dates of the tile n_dates <- length(.tile_timeline(tile)) # find how many samples have been extracted from the tile @@ -330,8 +330,10 @@ ) }) # remove polygon ids - ts_bands_base <- purrr::map(ts_bands_base, - function(ts_band) ts_band[[2]]) + ts_bands_base <- purrr::map( + ts_bands_base, + function(ts_band) ts_band[[2]] + ) # name band values names(ts_bands_base) <- base_bands # merge band values @@ -362,7 +364,7 @@ # we do the unnest again because we do not know the polygon id index ts_bands <- tidyr::unnest(ts_bands, colname) # remove pixels where all timeline was NA - ts_bands <- tidyr::drop_na(ts_bands) + ts_bands <- tidyr::drop_na(ts_bands) # nest the values by bands ts_bands <- tidyr::nest( ts_bands, @@ -388,10 +390,13 @@ ) if (.has_column(segments, "x") && .has_column(segments, "y")) { lat_long <- .proj_to_latlong( - segments[["x"]], segments[["y"]], .crs(tile)) + segments[["x"]], segments[["y"]], .crs(tile) + ) } else { - lat_long <- tibble::tibble("longitude" = rep(0.0, nrow(segments)), - "latitude" = rep(0.0, nrow(segments))) + lat_long <- tibble::tibble( + "longitude" = rep(0.0, nrow(segments)), + "latitude" = rep(0.0, nrow(segments)) + ) } # create metadata for the polygons diff --git a/R/api_select.R b/R/api_select.R index 81a4465d5..35c09755c 100644 --- a/R/api_select.R +++ b/R/api_select.R @@ -40,10 +40,10 @@ #' @param end_date End date #' @return cube with selected period .select_raster_interval <- function(data, start_date, end_date) { - if (.has(start_date) && .has(end_date) - && !is.na(start_date) && !is.na(end_date)) { + if (.has(start_date) && .has(end_date) && + !is.na(start_date) && !is.na(end_date)) { start_date <- .timeline_format(start_date) - end_date <- .timeline_format(end_date) + end_date <- .timeline_format(end_date) data <- .cube_filter_interval( cube = data, start_date = start_date, end_date = end_date ) diff --git a/R/api_sf.R b/R/api_sf.R index 8978ebb60..e6d007cbd 100644 --- a/R/api_sf.R +++ b/R/api_sf.R @@ -30,13 +30,13 @@ .check_that(geom_type %in% sf_geom_types_supported) # Get the points to be read samples <- .sf_to_tibble( - sf_object = sf_object, + sf_object = sf_object, label_attr = label_attr, - label = label, - n_sam_pol = n_sam_pol, + label = label, + n_sam_pol = n_sam_pol, sampling_type = sampling_type, start_date = start_date, - end_date = end_date + end_date = end_date ) .set_class(samples, "sits", class(samples)) } @@ -76,19 +76,19 @@ geom_type <- as.character(sf::st_geometry_type(sf_object)[[1L]]) # Get a tibble with points and labels points_tbl <- switch(geom_type, - POINT = .sf_point_to_tibble( - sf_object = sf_object, - label_attr = label_attr, - label = label - ), - POLYGON = , - MULTIPOLYGON = .sf_polygon_to_tibble( - sf_object = sf_object, - label_attr = label_attr, - label = label, - n_sam_pol = n_sam_pol, - sampling_type = sampling_type - ) + POINT = .sf_point_to_tibble( + sf_object = sf_object, + label_attr = label_attr, + label = label + ), + POLYGON = , + MULTIPOLYGON = .sf_polygon_to_tibble( + sf_object = sf_object, + label_attr = label_attr, + label = label, + n_sam_pol = n_sam_pol, + sampling_type = sampling_type + ) ) # Transform to type Date dplyr::mutate( @@ -185,15 +185,16 @@ unlist(sf_df[row_id, "label"], use.names = FALSE) ) } else if (.has(label_attr) && - label_attr %in% colnames(sf_df)) { + label_attr %in% colnames(sf_df)) { label <- as.character( unlist(sf_df[row_id, label_attr], use.names = FALSE) ) } # obtain a set of samples based on polygons points <- list(sf::st_sample(sf_object[row_id, ], - type = sampling_type, - size = n_sam_pol)) + type = sampling_type, + size = n_sam_pol + )) # get one time series per sample # return a data frame purrr::pmap_dfr(points, function(p) { @@ -239,10 +240,14 @@ #' .sf_from_window <- function(window) { df <- data.frame( - lon = c(window[["xmin"]], window[["xmin"]], - window[["xmax"]], window[["xmax"]]), - lat = c(window[["ymin"]], window[["ymax"]], - window[["ymax"]], window[["ymin"]]) + lon = c( + window[["xmin"]], window[["xmin"]], + window[["xmax"]], window[["xmax"]] + ), + lat = c( + window[["ymin"]], window[["ymax"]], + window[["ymax"]], window[["ymin"]] + ) ) polygon <- df |> sf::st_as_sf(coords = c("lon", "lat"), crs = 4326L) |> diff --git a/R/api_shp.R b/R/api_shp.R index 43f9bacd1..dea708be1 100644 --- a/R/api_shp.R +++ b/R/api_shp.R @@ -31,13 +31,13 @@ ) # Get the points to be read samples <- .sf_to_tibble( - sf_object = sf_shape, + sf_object = sf_shape, label_attr = shp_attr, - label = label, - n_sam_pol = n_shp_pol, + label = label, + n_sam_pol = n_shp_pol, sampling_type = sampling_type, start_date = start_date, - end_date = end_date + end_date = end_date ) # set class and return .set_class(samples, "sits", class(samples)) @@ -70,7 +70,7 @@ # postcondition - are all geometries compatible? .check_that(all(sf::st_geometry_type(sf_shape) == geom_type)) # postcondition - can the function deal with the geometry_type? - .check_that(as.character(geom_type) %in% .conf("sf_geom_types_supported")) + .check_that(as.character(geom_type) %in% .conf("sf_geom_types_supported")) # postcondition - is the shape attribute valid? .check_shp_attribute(sf_shape, shp_attr) # return diff --git a/R/api_signal.R b/R/api_signal.R index 1a9247ab6..89c7fb82c 100644 --- a/R/api_signal.R +++ b/R/api_signal.R @@ -65,7 +65,7 @@ ## equally spaced on the unit grid, with past points using negative ## values and future points using positive values. weights <- (((1L:n) - row) %*% - matrix(1L, 1L, p + 1L))^(matrix(1L, n) %*% (0L:p)) + matrix(1L, 1L, p + 1L))^(matrix(1L, n) %*% (0L:p)) ## A = pseudo-inverse (C), so C*A = I; this is constructed from the SVD pseudo_inv <- .signal_mass_ginv(weights, tol = .Machine[["double.eps"]]) ## Take the row of the matrix corresponding to the derivative diff --git a/R/api_smooth.R b/R/api_smooth.R index dc8589e29..72ff2c762 100644 --- a/R/api_smooth.R +++ b/R/api_smooth.R @@ -11,6 +11,7 @@ #' @param smooth_fn Smoothing function #' @param output_dir Directory where image will be save #' @param version Version of result +#' @param progress Check progress bar? #' @return Smoothed tile-band combination .smooth_tile <- function(tile, band, @@ -19,7 +20,8 @@ exclusion_mask, smooth_fn, output_dir, - version) { + version, + progress) { # Output file out_file <- .file_derived_name( tile = tile, band = band, version = version, @@ -47,7 +49,6 @@ chunks = chunks, mask = exclusion_mask ) - exclusion_mask <- .chunks_crop_mask( chunks = chunks, mask = exclusion_mask @@ -98,7 +99,7 @@ gc() # Return block file block_file - }) + }, progress = progress) # Check if there is a exclusion_mask # If exclusion_mask exists, blocks are merged to a different directory # than output_dir, which is used to save the final cropped version @@ -131,7 +132,7 @@ output_dir = output_dir, multicores = 1L, overwrite = TRUE, - progress = FALSE + progress = progress ) # delete old files @@ -161,6 +162,8 @@ #' @param output_dir Output directory for image files #' @param version Version of resulting image #' (in the case of multiple tests) +#' @param progress Check progress bar? +#' @return Smoothed data cube #' .smooth <- function(cube, block, @@ -171,7 +174,8 @@ multicores, memsize, output_dir, - version) { + version, + progress) { # Smooth parameters checked in smooth function creation # Create smooth function smooth_fn <- .smooth_fn_bayes( @@ -193,7 +197,8 @@ exclusion_mask = exclusion_mask, smooth_fn = smooth_fn, output_dir = output_dir, - version = version + version = version, + progress = progress ) }) } diff --git a/R/api_smote.R b/R/api_smote.R index c1418f5e2..7024faec4 100644 --- a/R/api_smote.R +++ b/R/api_smote.R @@ -144,7 +144,8 @@ .check_require_packages("FNN") kn_dist <- FNN::knnx.index(q_data, p_data, - k = (n_clust + 1L), algorithm = "kd_tree") + k = (n_clust + 1L), algorithm = "kd_tree" + ) kn_dist <- kn_dist * (kn_dist != row(kn_dist)) que <- which(kn_dist[, 1L] > 0.0) for (i in que) { diff --git a/R/api_som.R b/R/api_som.R index 49ab6c36e..21aa4e8a9 100644 --- a/R/api_som.R +++ b/R/api_som.R @@ -150,10 +150,10 @@ #' colour of the neuron. #' .som_paint_neurons <- function(koh, legend = NULL) { - # convert legend from tibble to vector - if (.has(legend)) + if (.has(legend)) { legend <- .colors_legend_set(legend) + } # assign one color per unique label colors <- .colors_get( labels = unique(koh[["som_properties"]][["neuron_label"]]), @@ -201,11 +201,13 @@ neuron_pols <- purrr::map(seq_len(neuron_ids), function(id) { x <- neuron_ids[id, "x"] y <- neuron_ids[id, "y"] - pol <- rbind(c((x - 1L), (y - 1L)), - c(x, (y - 1L)), - c(x, y), - c((x - 1L), y), - c((x - 1L), (y - 1L))) + pol <- rbind( + c((x - 1L), (y - 1L)), + c(x, (y - 1L)), + c(x, y), + c((x - 1L), y), + c((x - 1L), (y - 1L)) + ) # return polygon as sf object sf::st_polygon(list(pol)) }) diff --git a/R/api_source.R b/R/api_source.R index ab56596f3..990bbc258 100644 --- a/R/api_source.R +++ b/R/api_source.R @@ -64,23 +64,27 @@ NULL if (!is.null(collection)) { # is this a collection of SAR data? - sar_cube <- .try({ - .conf("sources", source, "collections", collection, "sar_cube") - }, - .default = FALSE + sar_cube <- .try( + { + .conf("sources", source, "collections", collection, "sar_cube") + }, + .default = FALSE ) # is this a collection of DEM data ? - dem_cube <- .try({ - .conf("sources", source, "collections", collection, "dem_cube") - }, - .default = FALSE + dem_cube <- .try( + { + .conf("sources", source, "collections", collection, "dem_cube") + }, + .default = FALSE ) # if this is a SAR collection, add "sar_cube" to the class - if (sar_cube) + if (sar_cube) { class(source) <- c("sar_cube", class(source)) + } # if this is a DEM collection, add "dem_cube" to the class - if (dem_cube) + if (dem_cube) { class(source) <- c("dem_cube", class(source)) + } # add a class combining source and collection class_source_col <- paste(classes[[1L]], tolower(collection), sep = "_") class(source) <- unique(c(class_source_col, class(source))) @@ -103,8 +107,8 @@ NULL service <- .conf("sources", source, "service") # post-condition .check_chr_parameter(service, - allow_na = TRUE, allow_empty = FALSE, - len_min = 1L, len_max = 1L + allow_na = TRUE, allow_empty = FALSE, + len_min = 1L, len_max = 1L ) service } @@ -123,8 +127,8 @@ NULL s3_class <- .conf("sources", source, "s3_class") # post-condition .check_chr_parameter(s3_class, - allow_empty = FALSE, - len_min = 1L + allow_empty = FALSE, + len_min = 1L ) s3_class } @@ -143,8 +147,8 @@ NULL url <- .conf("sources", source, "url") # post-condition .check_chr_parameter(url, - allow_na = FALSE, allow_empty = FALSE, - len_min = 1L, len_max = 1L + allow_na = FALSE, allow_empty = FALSE, + len_min = 1L, len_max = 1L ) url } @@ -249,7 +253,7 @@ NULL } # pre-condition .check_chr_parameter(bands, - allow_na = FALSE, allow_empty = FALSE, len_min = 1L + allow_na = FALSE, allow_empty = FALSE, len_min = 1L ) # bands names are upper case bands <- toupper(bands) @@ -296,8 +300,8 @@ NULL bands <- unlist(bands, recursive = FALSE, use.names = FALSE) # post-conditions .check_chr(bands, - allow_na = FALSE, allow_empty = FALSE, - len_min = length(bands), len_max = length(bands) + allow_na = FALSE, allow_empty = FALSE, + len_min = length(bands), len_max = length(bands) ) bands } @@ -397,7 +401,7 @@ NULL bands_converter <- c(bands_to_source, bands_source) # post-condition .check_chr_within(bands, - within = names(bands_converter) + within = names(bands_converter) ) unname(bands_converter[bands]) } @@ -619,7 +623,7 @@ NULL ) # post-condition .check_chr_parameter(collection_name, - allow_empty = FALSE, len_min = 1L, len_max = 1L + allow_empty = FALSE, len_min = 1L, len_max = 1L ) collection_name } @@ -720,7 +724,7 @@ NULL #' @return \code{.source_collection_class_tile_dates()} returns the input tile #' with the dates fixed. #' -.source_collection_class_tile_dates <- function(source, collection, tile) { +.source_collection_class_tile_dates <- function(source, collection, tile) { .check_set_caller(".source_collection_class_tile_dates") # define if the given collection is categorical is_class_cube <- .try( @@ -980,7 +984,8 @@ NULL "sources", source, "collections", collection, "dates" - ), .default = NULL + ), + .default = NULL ) .check_chr_parameter(dates, allow_null = TRUE) dates diff --git a/R/api_source_aws.R b/R/api_source_aws.R index fd27a067b..703e64646 100644 --- a/R/api_source_aws.R +++ b/R/api_source_aws.R @@ -17,7 +17,6 @@ stac_query, ..., tiles = NULL, platform = NULL) { - # check if platform is set if (!is.null(platform)) { platform <- .stac_format_platform( @@ -128,11 +127,12 @@ items[["features"]], function(feature) { feature[["properties"]][["tile"]] <- paste0(feature[["properties"]][["landsat:wrs_path"]], - feature[["properties"]][["landsat:wrs_row"]], - collapse = "" + feature[["properties"]][["landsat:wrs_row"]], + collapse = "" ) feature - }) + } + ) rstac::items_reap(items, field = c("properties", "tile")) } @@ -165,8 +165,9 @@ #' @param date Date to be adjusted #' @return Adjusted date .source_adjust_date.aws_cube <- function(source, date) { - if (.has(date)) + if (.has(date)) { date <- paste0(date, "T00:00:00Z") + } date } #' @noRd @@ -177,9 +178,10 @@ .source_configure_access.aws_cube <- function(source, collection) { .check_set_caller(".source_configure_access_aws_cube") if (.conf("sources", "AWS", "collections", collection, "open_data") - == "false") { + == "false") { aws_access_key <- Sys.getenv("AWS_SECRET_ACCESS_KEY") - if (.has_not(aws_access_key)) + if (.has_not(aws_access_key)) { stop(.conf("messages", ".source_configure_access_aws_cube")) + } } } diff --git a/R/api_source_bdc.R b/R/api_source_bdc.R index 698dcbf87..9a4076f27 100644 --- a/R/api_source_bdc.R +++ b/R/api_source_bdc.R @@ -79,7 +79,8 @@ #' @return Called for side effects .source_configure_access.bdc_cube <- function(source, collection = NULL) { bdc_access_key <- Sys.getenv("BDC_ACCESS_KEY") - if (.has_not(bdc_access_key)) + if (.has_not(bdc_access_key)) { Sys.setenv(BDC_ACCESS_KEY = .conf("BDC_ACCESS_KEY")) + } return(invisible(source)) } diff --git a/R/api_source_cdse.R b/R/api_source_cdse.R index 0db3f1359..e44af557e 100644 --- a/R/api_source_cdse.R +++ b/R/api_source_cdse.R @@ -68,8 +68,10 @@ band_pattern <- band_conf[["pattern"]] # Filter the S3 content to get files from the band band_item <- - dplyr::filter(item_s3_content, - stringr::str_detect(.data[["Key"]], band_pattern)) + dplyr::filter( + item_s3_content, + stringr::str_detect(.data[["Key"]], band_pattern) + ) # Check if the correct file was selected. .check_that(nrow(band_item) == 1L) # Prepare the file address @@ -129,26 +131,29 @@ "collection_name" ) # query Open Search - items <- .try({ - .opensearch_cdse_search( - product_type = item_type, - source = source, - collection = collection_endpoint, - start_date = start_date, - end_date = end_date, - bbox = NULL, - paginate = FALSE, - limit = 1L, - ... - ) - }, .default = NULL) + items <- .try( + { + .opensearch_cdse_search( + product_type = item_type, + source = source, + collection = collection_endpoint, + start_date = start_date, + end_date = end_date, + bbox = NULL, + paginate = FALSE, + limit = 1L, + ... + ) + }, + .default = NULL + ) # Check items .check_stac_items(items) # Test bands and accessibility items <- .source_items_bands_select( source = source, - items = items, - bands = bands[[1L]], + items = items, + bands = bands[[1L]], collection = collection, ... ) href <- .source_item_get_hrefs( @@ -159,7 +164,7 @@ # assert that token and/or href is valid if (dry_run) { rast <- .try(.raster_open_rast(href), - default = NULL + default = NULL ) .check_null_parameter(rast) } @@ -220,10 +225,11 @@ # other products, this must be revised. if (!is.null(tiles)) { roi <- .s2_mgrs_to_roi(tiles) - query_bbox$bbox <- c(roi[["lon_min"]], - roi[["lat_min"]], - roi[["lon_max"]], - roi[["lat_max"]] + query_bbox$bbox <- c( + roi[["lon_min"]], + roi[["lat_min"]], + roi[["lon_max"]], + roi[["lat_max"]] ) } .check_null(query_bbox$bbox) @@ -343,4 +349,4 @@ .check_that(xmin < xmax && ymin < ymax) # create a bbox c(xmin = xmin, ymin = ymin, xmax = xmax, ymax = ymax) -} + } diff --git a/R/api_source_deafrica.R b/R/api_source_deafrica.R index 4cd67a746..b8ab24ea7 100644 --- a/R/api_source_deafrica.R +++ b/R/api_source_deafrica.R @@ -71,10 +71,12 @@ if (!is.null(tiles)) { roi <- .s2_mgrs_to_roi(tiles) stac_query[["params"]][["intersects"]] <- NULL - stac_query[["params"]][["bbox"]] <- c(roi[["lon_min"]], - roi[["lat_min"]], - roi[["lon_max"]], - roi[["lat_max"]]) + stac_query[["params"]][["bbox"]] <- c( + roi[["lon_min"]], + roi[["lat_min"]], + roi[["lon_max"]], + roi[["lat_max"]] + ) } else { roi <- .stac_intersects_as_bbox(stac_query) stac_query[["params"]][["intersects"]] <- NULL @@ -85,15 +87,16 @@ items_info <- rstac::items_fetch(items = items_info, progress = FALSE) # filter items items_info <- rstac::items_filter(items_info, - filter_fn = function(feature) { - lgl_res <- TRUE + filter_fn = function(feature) { + lgl_res <- TRUE - if (!is.null(platform)) { - lgl_res <- feature[["properties"]][["platform"]] == platform - } + if (!is.null(platform)) { + lgl_res <- feature[["properties"]][["platform"]] == platform + } - lgl_res - }) + lgl_res + } + ) # check results .check_stac_items(items_info) # done @@ -102,13 +105,12 @@ #' @keywords internal #' @noRd #' @export -`.source_items_new.deafrica_cube_sentinel-1-rtc` <- function( - source, ..., - collection, - stac_query, - tiles = NULL, - platform = NULL, - orbit = NULL) { +`.source_items_new.deafrica_cube_sentinel-1-rtc` <- function(source, ..., + collection, + stac_query, + tiles = NULL, + platform = NULL, + orbit = NULL) { # set caller to show in errors .check_set_caller(".source_items_new") # check orbits @@ -126,10 +128,12 @@ if (!is.null(tiles)) { roi <- .s2_mgrs_to_roi(tiles) stac_query[["params"]][["intersects"]] <- NULL - stac_query[["params"]][["bbox"]] <- c(roi[["lon_min"]], - roi[["lat_min"]], - roi[["lon_max"]], - roi[["lat_max"]]) + stac_query[["params"]][["bbox"]] <- c( + roi[["lon_min"]], + roi[["lat_min"]], + roi[["lon_max"]], + roi[["lat_max"]] + ) } else { roi <- .stac_intersects_as_bbox(stac_query) stac_query[["params"]][["intersects"]] <- NULL @@ -140,18 +144,19 @@ items_info <- rstac::items_fetch(items = items_info, progress = FALSE) # filter items items_info <- rstac::items_filter(items_info, - filter_fn = function(feature) { - lgl_res <- feature[["properties"]][["sat:orbit_state"]] == orbit && - feature[["properties"]][["sar:instrument_mode"]] == "IW" && - feature[["properties"]][["sar:frequency_band"]] == "C" + filter_fn = function(feature) { + lgl_res <- feature[["properties"]][["sat:orbit_state"]] == orbit && + feature[["properties"]][["sar:instrument_mode"]] == "IW" && + feature[["properties"]][["sar:frequency_band"]] == "C" - if (!is.null(platform)) { - lgl_res <- lgl_res && - feature[["properties"]][["platform"]] == platform - } + if (!is.null(platform)) { + lgl_res <- lgl_res && + feature[["properties"]][["platform"]] == platform + } - lgl_res - }) + lgl_res + } + ) # check results .check_stac_items(items_info) # done @@ -186,8 +191,9 @@ # Digital Earth Africa provides some products with the `properties.datetime` # property `null`. In those cases, it is required to use other date # parameter available - if (is.null(item_date)) + if (is.null(item_date)) { item_date <- item[[c("properties", "start_datetime")]] + } suppressWarnings( lubridate::as_date(item_date) diff --git a/R/api_source_deaustralia.R b/R/api_source_deaustralia.R index bb4fc6fdd..a5d05f734 100644 --- a/R/api_source_deaustralia.R +++ b/R/api_source_deaustralia.R @@ -60,10 +60,12 @@ if (!is.null(tiles)) { roi <- .s2_mgrs_to_roi(tiles) stac_query[["params"]][["intersects"]] <- NULL - stac_query[["params"]][["bbox"]] <- c(roi[["lon_min"]], - roi[["lat_min"]], - roi[["lon_max"]], - roi[["lat_max"]]) + stac_query[["params"]][["bbox"]] <- c( + roi[["lon_min"]], + roi[["lat_min"]], + roi[["lon_max"]], + roi[["lat_max"]] + ) } else { roi <- .stac_intersects_as_bbox(stac_query) stac_query[["params"]][["intersects"]] <- NULL diff --git a/R/api_source_hls.R b/R/api_source_hls.R index 58c06db9b..ff3e22b02 100644 --- a/R/api_source_hls.R +++ b/R/api_source_hls.R @@ -34,10 +34,11 @@ items_query ) # assert that service is online - items <- .try({ - rstac::post_request(items_query, ...) - }, - .default = NULL + items <- .try( + { + rstac::post_request(items_query, ...) + }, + .default = NULL ) .check_stac_items(items) @@ -54,10 +55,11 @@ ) # assert that token and/or href is valid if (dry_run) { - rast <- .try({ - .raster_open_rast(href) - }, - default = NULL + rast <- .try( + { + .raster_open_rast(href) + }, + default = NULL ) .check_null_parameter(rast) } @@ -91,20 +93,22 @@ if (!is.null(tiles)) { roi <- .s2_mgrs_to_roi(tiles) stac_query[["params"]][["intersects"]] <- NULL - stac_query[["params"]][["bbox"]] <- c(roi[["lon_min"]], - roi[["lat_min"]], - roi[["lon_max"]], - roi[["lat_max"]] + stac_query[["params"]][["bbox"]] <- c( + roi[["lon_min"]], + roi[["lat_min"]], + roi[["lon_max"]], + roi[["lat_max"]] ) } else { # Convert roi to bbox lon <- stac_query[["params"]][["intersects"]][["coordinates"]][, , 1L] lat <- stac_query[["params"]][["intersects"]][["coordinates"]][, , 2L] stac_query[["params"]][["intersects"]] <- NULL - stac_query[["params"]][["bbox"]] <- c(min(lon), - min(lat), - max(lon), - max(lat) + stac_query[["params"]][["bbox"]] <- c( + min(lon), + min(lat), + max(lon), + max(lat) ) } # making the request diff --git a/R/api_source_local.R b/R/api_source_local.R index fc9cbef0d..1320ee38f 100644 --- a/R/api_source_local.R +++ b/R/api_source_local.R @@ -172,8 +172,9 @@ "raster_cube", class(cube) ) # check if labels match in the case of class cube - if (inherits(cube, "class_cube")) + if (inherits(cube, "class_cube")) { .check_labels_class_cube(cube) + } cube } @@ -215,8 +216,9 @@ # bands in upper case for raw cubes, lower case for results cubes vector_band <- .band_set_case(vector_band) # set the correct parse_info - if (!.has(parse_info)) + if (!.has(parse_info)) { parse_info <- .conf("results_parse_info_def") + } .local_cube_items_vector_new( vector_dir = vector_dir, @@ -292,7 +294,7 @@ # joint the list into a tibble and convert bands name to upper case items <- suppressMessages( tibble::as_tibble(img_files_mx, - .name_repair = "universal" + .name_repair = "universal" ) ) if (.has(bands)) { @@ -442,7 +444,7 @@ # joint the list into a tibble and convert bands name to upper case items <- suppressMessages( tibble::as_tibble(gpkg_files_mx, - .name_repair = "universal" + .name_repair = "universal" ) ) # check if bands exist @@ -532,7 +534,7 @@ if (.has(bands)) { # verify that the requested bands exist .check_chr_within(bands, - within = unique(items[["band"]]) + within = unique(items[["band"]]) ) # select the requested bands items <- dplyr::filter(items, .data[["band"]] %in% !!bands) @@ -553,7 +555,7 @@ # filter tiles # verify that the requested tiles exist .check_chr_within(tiles, - within = unique(items[["tile"]]) + within = unique(items[["tile"]]) ) # select the requested tiles dplyr::filter(items, .data[["tile"]] %in% !!tiles) @@ -619,8 +621,8 @@ errors <- unlist(purrr::map(results_lst, `[[`, "error")) if (.has(errors)) { warning(.conf("messages", ".local_cube_file_info_error"), - toString(errors), - call. = FALSE, immediate. = TRUE + toString(errors), + call. = FALSE, immediate. = TRUE ) } # bind rows into a tibble and then organizw by date, fid, and band @@ -687,8 +689,8 @@ errors <- unlist(purrr::map(results_lst, `[[`, "error")) if (.has(errors)) { warning(.conf("messages", ".local_cube_file_info_error"), - toString(errors), - call. = FALSE, immediate. = TRUE + toString(errors), + call. = FALSE, immediate. = TRUE ) } # return items as a data frame diff --git a/R/api_source_mpc.R b/R/api_source_mpc.R index 1c653abca..5ece17422 100644 --- a/R/api_source_mpc.R +++ b/R/api_source_mpc.R @@ -31,10 +31,11 @@ limit = 1L ) # assert that service is online - items <- .try({ - rstac::post_request(items_query, ...) - }, - .default = NULL + items <- .try( + { + rstac::post_request(items_query, ...) + }, + .default = NULL ) .check_stac_items(items) # signing the url with the mpc token @@ -63,10 +64,11 @@ ) # assert that token and/or href is valid if (dry_run) { - rast <- .try({ - .raster_open_rast(href) - }, - default = NULL + rast <- .try( + { + .raster_open_rast(href) + }, + default = NULL ) .check_null_parameter(rast) } @@ -88,15 +90,13 @@ #' @param platform Satellite platform (optional). #' @return An object referring the images of a sits cube. #' @export -`.source_collection_access_test.mpc_cube_sentinel-1-grd` <- function( - source, - collection, - bands, ..., - orbit = "descending", - start_date = NULL, - end_date = NULL, - dry_run = TRUE) { - +`.source_collection_access_test.mpc_cube_sentinel-1-grd` <- function(source, + collection, + bands, ..., + orbit = "descending", + start_date = NULL, + end_date = NULL, + dry_run = TRUE) { # require package .check_require_packages("rstac") orbits <- .conf("sources", source, "collections", collection, "orbits") @@ -113,13 +113,14 @@ stac_query, `sar:frequency_band` == "C" && `sar:instrument_mode` == "IW" && - `sat:orbit_state` == {{orbit}} + `sat:orbit_state` == {{ orbit }} ) # assert that service is online - items <- .try({ - rstac::post_request(stac_query, ... - )}, + items <- .try( + { + rstac::post_request(stac_query, ...) + }, .default = NULL ) .check_stac_items(items) @@ -150,25 +151,24 @@ ) # assert that token and/or href is valid if (dry_run) { - rast <- .try({ - .raster_open_rast(href) - }, - default = NULL + rast <- .try( + { + .raster_open_rast(href) + }, + default = NULL ) .check_null_parameter(rast) } return(invisible(NULL)) } -`.source_collection_access_test.mpc_cube_sentinel-1-rtc` <- function( - source, - collection, - bands, ..., - orbit = "descending", - start_date = NULL, - end_date = NULL, - dry_run = TRUE) { - +`.source_collection_access_test.mpc_cube_sentinel-1-rtc` <- function(source, + collection, + bands, ..., + orbit = "descending", + start_date = NULL, + end_date = NULL, + dry_run = TRUE) { `.source_collection_access_test.mpc_cube_sentinel-1-grd`( source = source, collection = collection, @@ -275,17 +275,18 @@ stac_query, `sar:frequency_band` == "C" && `sar:instrument_mode` == "IW" && - `sat:orbit_state` == {{orbit}} + `sat:orbit_state` == {{ orbit }} ) # Sentinel-1 does not support tiles - convert to ROI if (!is.null(tiles)) { roi <- .s2_mgrs_to_roi(tiles) stac_query[["params"]][["intersects"]] <- NULL - stac_query[["params"]][["bbox"]] <- c(roi[["lon_min"]], - roi[["lat_min"]], - roi[["lon_max"]], - roi[["lat_max"]] + stac_query[["params"]][["bbox"]] <- c( + roi[["lon_min"]], + roi[["lat_min"]], + roi[["lon_max"]], + roi[["lat_max"]] ) } items_info <- rstac::post_request(q = stac_query, ...) @@ -304,7 +305,8 @@ .mpc_clean_token_cache() items_info <- suppressWarnings( rstac::items_sign( - items_info, sign_fn = rstac::sign_planetary_computer( + items_info, + sign_fn = rstac::sign_planetary_computer( headers = c("Ocp-Apim-Subscription-Key" = access_key) ) ) @@ -516,10 +518,11 @@ if (!is.null(tiles)) { roi <- .s2_mgrs_to_roi(tiles) stac_query[["params"]][["intersects"]] <- NULL - stac_query[["params"]][["bbox"]] <- c(roi[["lon_min"]], - roi[["lat_min"]], - roi[["lon_max"]], - roi[["lat_max"]] + stac_query[["params"]][["bbox"]] <- c( + roi[["lon_min"]], + roi[["lat_min"]], + roi[["lon_max"]], + roi[["lat_max"]] ) } @@ -543,7 +546,8 @@ .mpc_clean_token_cache() items_info <- suppressWarnings( rstac::items_sign( - items_info, sign_fn = rstac::sign_planetary_computer( + items_info, + sign_fn = rstac::sign_planetary_computer( headers = c("Ocp-Apim-Subscription-Key" = access_key) ) ) @@ -595,9 +599,9 @@ #' @keywords internal #' @noRd #' @export -`.source_items_tile.mpc_cube_mod13q1-6.1` <- function(source, - items, ..., - collection = NULL) { +`.source_items_tile.mpc_cube_mod13q1-6.1` <- function(source, + items, ..., + collection = NULL) { # store tile info in items object items[["features"]] <- purrr::map(items[["features"]], function(feature) { h_tile <- feature[["properties"]][["modis:horizontal-tile"]] @@ -618,10 +622,9 @@ #' @keywords internal #' @noRd #' @export -`.source_items_tile.mpc_cube_mod10a1-6.1` <- function(source, - items, ..., - collection = NULL) { - +`.source_items_tile.mpc_cube_mod10a1-6.1` <- function(source, + items, ..., + collection = NULL) { # store tile info in items object items[["features"]] <- purrr::map(items[["features"]], function(feature) { h_tile <- feature[["properties"]][["modis:horizontal-tile"]] @@ -642,10 +645,9 @@ #' @keywords internal #' @noRd #' @export -`.source_items_tile.mpc_cube_mod09a1-6.1` <- function(source, - items, ..., - collection = NULL) { - +`.source_items_tile.mpc_cube_mod09a1-6.1` <- function(source, + items, ..., + collection = NULL) { # store tile info in items object items[["features"]] <- purrr::map(items[["features"]], function(feature) { h_tile <- feature[["properties"]][["modis:horizontal-tile"]] @@ -692,7 +694,6 @@ `.source_items_tile.mpc_cube_cop-dem-glo-30` <- function(source, items, ..., collection = NULL) { - feature_ids <- stringr::str_split(rstac::items_reap(items, "id"), "_") purrr::map(feature_ids, function(feature_id) { @@ -720,8 +721,8 @@ source = source, collection = collection, cube = cube, - tiles = tiles) - + tiles = tiles + ) } #' @title Filter COP-DEM-GLO-30 tiles #' @noRd @@ -776,8 +777,6 @@ `.source_item_get_date.mpc_cube_mod09a1-6.1` <- function(source, item, ..., collection = NULL) { - - lubridate::as_date(item[["properties"]][["start_datetime"]]) } #' @title Check if roi or tiles are provided diff --git a/R/api_source_sdc.R b/R/api_source_sdc.R index 7fcacf28d..d4b82d88c 100644 --- a/R/api_source_sdc.R +++ b/R/api_source_sdc.R @@ -66,7 +66,7 @@ replacement = "-", fixed = TRUE, x = rstac::items_reap(items, - field = c("properties", "cubedash:region_code") + field = c("properties", "cubedash:region_code") ) ) } diff --git a/R/api_source_stac.R b/R/api_source_stac.R index 0caade594..00be5b423 100644 --- a/R/api_source_stac.R +++ b/R/api_source_stac.R @@ -30,10 +30,11 @@ limit = 1L ) # assert that service is online - items <- .try({ - rstac::post_request(items_query, ...) - }, - .default = NULL + items <- .try( + { + rstac::post_request(items_query, ...) + }, + .default = NULL ) .check_stac_items(items) @@ -50,10 +51,11 @@ ) # assert that token and/or href is valid if (dry_run) { - rast <- .try({ - .raster_open_rast(href) - }, - default = NULL + rast <- .try( + { + .raster_open_rast(href) + }, + default = NULL ) .check_null_parameter(rast) } @@ -265,8 +267,8 @@ # check if metadata was retrieved if (is.null(asset_info)) { warning(.conf("messages", ".source_items_cube_stac_cube"), - toString(paths), - call. = FALSE + toString(paths), + call. = FALSE ) return(NULL) } @@ -301,9 +303,9 @@ .check_date_parameter(date) .check_chr_parameter(bands, len_min = 1L) .check_chr_parameter(paths, - allow_empty = FALSE, - len_min = length(bands), - len_max = length(bands) + allow_empty = FALSE, + len_min = length(bands), + len_max = length(bands) ) # do in case of 'feature' strategy if (.source_collection_metadata_search( @@ -330,8 +332,8 @@ # check if metadata was retrieved if (is.null(asset_info)) { warning(.conf("messages", ".source_items_cube_stac_cube"), - toString(paths), - call. = FALSE + toString(paths), + call. = FALSE ) return(NULL) } @@ -520,7 +522,6 @@ .source_tile_get_bbox.stac_cube <- function(source, file_info, ..., collection = NULL) { - # pre-condition .check_content_data_frame(file_info) @@ -582,9 +583,9 @@ if (is.character(tiles)) { # post-condition .check_chr_within(.cube_tiles(cube), - within = tiles, - discriminator = "any_of", - can_repeat = FALSE + within = tiles, + discriminator = "any_of", + can_repeat = FALSE ) # filter cube tiles cube <- dplyr::filter(cube, .data[["tile"]] %in% tiles) diff --git a/R/api_source_usgs.R b/R/api_source_usgs.R index 8bdc90dc8..0837f3e93 100644 --- a/R/api_source_usgs.R +++ b/R/api_source_usgs.R @@ -220,7 +220,8 @@ .source_configure_access.usgs_cube <- function(source, collection = NULL) { .check_set_caller(".source_configure_access_usgs_cube") aws_access_key <- Sys.getenv("AWS_SECRET_ACCESS_KEY") - if (.has(aws_access_key)) + if (.has(aws_access_key)) { stop(.conf("messages", ".source_configure_access_usgs_cube")) + } return(invisible(source)) } diff --git a/R/api_space_time_operations.R b/R/api_space_time_operations.R index cdd31705c..8b568aef8 100644 --- a/R/api_space_time_operations.R +++ b/R/api_space_time_operations.R @@ -64,8 +64,10 @@ #' @examples #' if (sits_run_examples()) { #' x <- .bbox_as_sf(c(xmin = 1, xmax = 2, ymin = 3, ymax = 4, crs = 4326)) -#' y <- .roi_as_sf(c(lon_min = 1.5, lon_max = 3, -#' lat_min = 3.5, lat_max = 5)) +#' y <- .roi_as_sf(c( +#' lon_min = 1.5, lon_max = 3, +#' lat_min = 3.5, lat_max = 5 +#' )) #' .intersects(x, y) # TRUE #' } #' diff --git a/R/api_texture.R b/R/api_texture.R index b73fcb7a0..d7b987514 100644 --- a/R/api_texture.R +++ b/R/api_texture.R @@ -18,10 +18,13 @@ #' @param in_bands Input bands #' @param overlap Overlap between tiles (if required) #' @param output_dir Directory where image will be save +#' @param progress Show progress bar? #' #' @return A feature compose by a combination of tile and band. +#' .texture_feature <- function(feature, block, window_size, angles, expr, - out_band, in_bands, overlap, output_dir) { + out_band, in_bands, overlap, output_dir, + progress) { # Output file out_file <- .file_eo_name( tile = feature, band = out_band, @@ -110,7 +113,7 @@ ) # Returned block files for each fraction block_files - }) + }, progress = progress) # Merge blocks into a new eo_cube tile .tile_eo_merge_blocks( files = out_file, diff --git a/R/api_tibble.R b/R/api_tibble.R index 69e47f14c..b782fa523 100644 --- a/R/api_tibble.R +++ b/R/api_tibble.R @@ -198,8 +198,8 @@ # find the date of minimum distance to the reference date idx <- which.min( abs((lubridate::as_date(ts[["Index"]]) - - lubridate::as_date(start_date)) - / lubridate::ddays(1L)) + - lubridate::as_date(start_date)) + / lubridate::ddays(1L)) ) # shift the time series to match dates if (idx != 1L) ts <- shift_ts(ts, -(idx - 1L)) diff --git a/R/api_tile.R b/R/api_tile.R index 1796fb3f1..c4261edbe 100644 --- a/R/api_tile.R +++ b/R/api_tile.R @@ -51,7 +51,6 @@ NULL tibble::as_tibble() |> .cube_find_class() |> .tile_source() - } #' @title Get image collection for a tile #' @noRd @@ -619,8 +618,9 @@ NULL source = .tile_source(tile), collection = .tile_collection(tile), band = band[[1L]] ) - if (.has(band_conf)) + if (.has(band_conf)) { return(band_conf) + } # try to obtain a band configuration if (band %in% .tile_bands(tile)) { data_type <- tile |> @@ -672,11 +672,12 @@ NULL #' @export .tile_filter_bands.class_cube <- function(tile, bands) { tile <- .tile(tile) - .fi(tile) <- .try({ - .fi_filter_bands(fi = .fi(tile), bands = "class") - }, - # handle non-sits class cubes (e.g., class cube from STAC) - .default = .fi_filter_bands(fi = .fi(tile), bands = .band_eo(bands)) + .fi(tile) <- .try( + { + .fi_filter_bands(fi = .fi(tile), bands = "class") + }, + # handle non-sits class cubes (e.g., class cube from STAC) + .default = .fi_filter_bands(fi = .fi(tile), bands = .band_eo(bands)) ) tile } @@ -1020,12 +1021,13 @@ NULL is_bit_mask <- .cloud_bit_mask(cloud_conf) # Prepare cloud_mask # Identify values to be removed - if (is_bit_mask) + if (is_bit_mask) { values <- matrix(bitwAnd(values, sum(2L^interp_values)) > 0L, - nrow = length(values) + nrow = length(values) ) - else + } else { values <- values %in% interp_values + } # # Log here # @@ -1043,7 +1045,6 @@ NULL tibble::as_tibble() |> .cube_find_class() |> .tile_cloud_read_block(block) - } #' @title Create chunks of a tile to be processed #' @name .tile_chunks_create @@ -1109,7 +1110,8 @@ NULL base_tile <- tibble::as_tibble(base_tile) base_tile <- .cube_find_class(base_tile) base_tile <- .tile_from_file(file, base_tile, band, update_bbox, - labels = NULL) + labels = NULL + ) return(base_tile) } #' @title read an EO tile from files @@ -1213,7 +1215,7 @@ NULL .xmax(base_tile) <- .raster_xmax(rast) .ymin(base_tile) <- .raster_ymin(rast) .ymax(base_tile) <- .raster_ymax(rast) - .crs(base_tile) <- .raster_crs(rast) + .crs(base_tile) <- .raster_crs(rast) } # Update labels before file_info .tile_labels(base_tile) <- labels @@ -1623,9 +1625,10 @@ NULL i <- 1L while (i < length(cog_sizes)) { if (cog_sizes[[i]][["xsize"]] < max_size || - cog_sizes[[i]][["ysize"]] < max_size) + cog_sizes[[i]][["ysize"]] < max_size) { break - i <- i + 1L + } + i <- i + 1L } # determine the best COG size best_cog_size <- cog_sizes[[i]] @@ -1650,8 +1653,9 @@ NULL # if ratio is greater than 1, get the maximum ratio <- max(ratio_x, ratio_y) # calculate nrows, ncols to be plotted - c(xsize = floor(ncols_tile / ratio), - ysize = floor(nrows_tile / ratio) + c( + xsize = floor(ncols_tile / ratio), + ysize = floor(nrows_tile / ratio) ) } } @@ -1668,28 +1672,28 @@ NULL # run gdalinfo on file info <- utils::capture.output(sf::gdal_utils( source = .tile_path(tile), - destination = NULL) - ) + destination = NULL + )) info2 <- stringr::str_split(info, pattern = "\n") # capture the line containg overview info over <- unlist(info2[grepl("Overview", info2)]) over <- over[!grepl("arbitrary", over)] - if (!.has(over)) + if (!.has(over)) { return(NULL) + } # get the value pairs over_values <- unlist(strsplit(over, split = ":", fixed = TRUE))[2L] over_pairs <- unlist(stringr::str_split(over_values, pattern = ",")) # extract the COG sizes purrr::map(over_pairs, function(op) { xsize <- as.numeric(unlist( - strsplit(op, split = "x", fixed = TRUE))[[1L]] - ) + strsplit(op, split = "x", fixed = TRUE) + )[[1L]]) ysize <- as.numeric(unlist( - strsplit(op, split = "x", fixed = TRUE))[[2L]] - ) + strsplit(op, split = "x", fixed = TRUE) + )[[2L]]) c(xsize = xsize, ysize = ysize) }) - } #' @title Return base info diff --git a/R/api_timeline.R b/R/api_timeline.R index 844df3c15..728f591d7 100644 --- a/R/api_timeline.R +++ b/R/api_timeline.R @@ -88,8 +88,9 @@ if (date %within% lubridate::interval( timeline[[1L]], timeline[[length(timeline)]] - )) + )) { return(TRUE) + } # what is the difference in days between the first two days of the timeline? timeline_diff <- as.integer(timeline[[2L]] - timeline[[1L]]) @@ -101,7 +102,7 @@ } # what is the difference in days between the last two days of the timeline? timeline_diff <- as.integer(timeline[[length(timeline)]] - - timeline[[length(timeline) - 1L]]) + timeline[[length(timeline) - 1L]]) # if the difference in days in the timeline is smaller than the difference # between the reference date and the last date of the timeline, then # we assume the date is valid @@ -294,5 +295,5 @@ #' @return TRUE if first and second timeline overlaps. #' .timeline_has_overlap <- function(timeline1, timeline2) { - min(timeline1) <= max(timeline2) && min(timeline2) <= max(timeline1) + min(timeline1) <= max(timeline2) && min(timeline2) <= max(timeline1) } diff --git a/R/api_tmap.R b/R/api_tmap.R index cfaa5fb23..208cb011d 100644 --- a/R/api_tmap.R +++ b/R/api_tmap.R @@ -25,24 +25,26 @@ rev, scale, tmap_params) { - # recover palette name used by cols4all cols4all_name <- .colors_cols4all_name(palette) # reverse order of colors? - if (rev) + if (rev) { cols4all_name <- paste0("-", cols4all_name) + } legend_position <- tmap_params[["legend_position"]] - if (legend_position == "outside") + if (legend_position == "outside") { position <- tmap::tm_pos_out() - else + } else { position <- tmap::tm_pos_in("left", "bottom") + } p <- tmap::tm_shape(rast) + tmap::tm_raster( col.scale = tmap::tm_scale_continuous( values = cols4all_name, - midpoint = NA), + midpoint = NA + ), col.legend = tmap::tm_legend( title = band, title.size = tmap_params[["legend_title_size"]], @@ -95,14 +97,16 @@ tmap_params) { cols4all_name <- .colors_cols4all_name(palette) # reverse order of colors? - if (rev) + if (rev) { cols4all_name <- paste0("-", cols4all_name) + } # position legend_position <- tmap_params[["legend_position"]] - if (legend_position == "outside") + if (legend_position == "outside") { position <- tmap::tm_pos_out() - else + } else { position <- tmap::tm_pos_in("left", "bottom") + } # generate plot p <- tmap::tm_shape(r, raster.downsample = FALSE) + tmap::tm_raster( @@ -221,8 +225,9 @@ # recover palette name used by cols4all cols4all_name <- .colors_cols4all_name(palette) # reverse order of colors? - if (rev) + if (rev) { cols4all_name <- paste0("-", cols4all_name) + } # select bands to be plotted bds <- as.numeric(names(labels[labels %in% labels_plot])) @@ -241,11 +246,12 @@ tmap::tm_raster( col.scale = tmap::tm_scale_continuous( values = cols4all_name, - midpoint = NA), + midpoint = NA + ), col.free = cols_free, col.legend = tmap::tm_legend( title = tmap_params[["legend_title"]], - show = TRUE, + show = TRUE, frame = TRUE, position = position, title.size = tmap_params[["legend_title_size"]], @@ -276,13 +282,13 @@ #' @param tmap_params List with tmap params for detailed plot control #' @return A plot object .tmap_class_map <- function(rast, colors, scale, tmap_params) { - # position legend_position <- tmap_params[["legend_position"]] - if (legend_position == "outside") + if (legend_position == "outside") { position <- tmap::tm_pos_out() - else + } else { position <- tmap::tm_pos_in("left", "bottom") + } .raster_set_minmax(rast) @@ -331,14 +337,16 @@ scale, tmap_params) { cols4all_name <- .colors_cols4all_name(palette) # reverse order of colors? - if (rev) + if (rev) { cols4all_name <- paste0("-", cols4all_name) + } # position legend_position <- tmap_params[["legend_position"]] - if (legend_position == "outside") + if (legend_position == "outside") { position <- tmap::tm_pos_out() - else + } else { position <- tmap::tm_pos_in("left", "bottom") + } # plot the segments tmap::tm_shape(sf_seg) + @@ -346,7 +354,8 @@ fill = labels_plot, fill.scale = tmap::tm_scale_continuous( values = cols4all_name, - midpoint = NA), + midpoint = NA + ), fill.legend = tmap::tm_legend( frame = TRUE, position = position, @@ -379,10 +388,11 @@ .tmap_vector_class <- function(sf_seg, colors, scale, tmap_params) { # position legend_position <- tmap_params[["legend_position"]] - if (legend_position == "outside") + if (legend_position == "outside") { position <- tmap::tm_pos_out() - else + } else { position <- tmap::tm_pos_in("left", "bottom") + } # sort the color vector colors <- colors[sort(names(colors))] # plot the data using tmap @@ -431,15 +441,17 @@ # recover palette name used by cols4all cols4all_name <- .colors_cols4all_name(palette) # reverse order of colors? - if (rev) + if (rev) { cols4all_name <- paste0("-", cols4all_name) + } # position legend_position <- tmap_params[["legend_position"]] - if (legend_position == "outside") + if (legend_position == "outside") { position <- tmap::tm_pos_out() - else + } else { position <- tmap::tm_pos_in("left", "bottom") + } # plot p <- tmap::tm_shape(sf_seg) + @@ -447,7 +459,8 @@ fill = type, fill.scale = tmap::tm_scale_continuous( values = cols4all_name, - midpoint = NA), + midpoint = NA + ), fill.legend = tmap::tm_legend( frame = TRUE, title = "uncert", @@ -486,33 +499,41 @@ #' \item \code{legend_bg_alpha}: legend opacity (default = 0.5) #' } .tmap_params_set <- function(dots, legend_position, legend_title = NULL) { - # tmap params - graticules_labels_size <- as.numeric(.conf("plot", - "graticules_labels_size")) + graticules_labels_size <- as.numeric(.conf( + "plot", + "graticules_labels_size" + )) legend_bg_color <- .conf("plot", "legend_bg_color") legend_bg_alpha <- as.numeric(.conf("plot", "legend_bg_alpha")) legend_title_size <- as.numeric(.conf("plot", "legend_title_size")) legend_text_size <- as.numeric(.conf("plot", "legend_text_size")) # deal with legend position separately - if (!.has(legend_position)) + if (!.has(legend_position)) { legend_position <- .conf("plot", "legend_position") + } # deal with legend title separately - if (!.has(legend_title)) + if (!.has(legend_title)) { legend_title <- .conf("plot", "legend_title") + } - if ("graticules_labels_size" %in% names(dots)) + if ("graticules_labels_size" %in% names(dots)) { graticules_labels_size <- dots[["graticules_labels_size"]] - if ("legend_bg_color" %in% names(dots)) + } + if ("legend_bg_color" %in% names(dots)) { legend_bg_color <- dots[["legend_bg_color"]] - if ("legend_bg_alpha" %in% names(dots)) + } + if ("legend_bg_alpha" %in% names(dots)) { legend_bg_alpha <- dots[["legend_bg_alpha"]] - if ("legend_title_size" %in% names(dots)) + } + if ("legend_title_size" %in% names(dots)) { legend_title_size <- dots[["legend_title_size"]] - if ("legend_text_size" %in% names(dots)) + } + if ("legend_text_size" %in% names(dots)) { legend_text_size <- dots[["legend_text_size"]] + } list( "graticules_labels_size" = graticules_labels_size, diff --git a/R/api_torch.R b/R/api_torch.R index 6221cc3e7..38eb52bc4 100644 --- a/R/api_torch.R +++ b/R/api_torch.R @@ -477,10 +477,11 @@ self$dim <- dim(x) }, .getitem = function(i) { - if (length(self$dim) == 3L) + if (length(self$dim) == 3L) { item_data <- self$x[i, , , drop = FALSE] - else + } else { item_data <- self$x[i, , drop = FALSE] + } list(torch::torch_tensor( array(item_data, dim = c( diff --git a/R/api_ts.R b/R/api_ts.R index 4406bfdf5..10c0e6537 100644 --- a/R/api_ts.R +++ b/R/api_ts.R @@ -272,12 +272,12 @@ end_idx <- which(timeline == t_point[[length(t_point)]]) # get only valid values for the timeline values_ts <- unlist(values_band[i, start_idx:end_idx], - use.names = FALSE + use.names = FALSE ) # include information from cloud band if (.has(cld_band)) { cld_values <- unlist(cld_values[i, start_idx:end_idx], - use.names = FALSE + use.names = FALSE ) if (.source_cloud_bit_mask( source = .cube_source(cube = tile), diff --git a/R/api_tuning.R b/R/api_tuning.R index 035ac6191..d2af1ff11 100644 --- a/R/api_tuning.R +++ b/R/api_tuning.R @@ -14,7 +14,6 @@ # uniform distribution uniform <- function(min = 0.0, max = 1.0) { stats::runif(n = 1L, min = min, max = max) - } # random choice choice <- function(..., replace = TRUE) { @@ -34,8 +33,10 @@ # loguniform distribution loguniform <- function(minlog = 0.0, maxlog = 1.0) { base <- exp(1L) - exp(stats::runif(1L, log(min(c(minlog, maxlog)), base), - log(max(c(minlog, maxlog)), base))) + exp(stats::runif( + 1L, log(min(c(minlog, maxlog)), base), + log(max(c(minlog, maxlog)), base) + )) } # beta distribution beta <- function(shape1, shape2) { diff --git a/R/api_uncertainty.R b/R/api_uncertainty.R index 6b1a3d9a0..2994f1a65 100644 --- a/R/api_uncertainty.R +++ b/R/api_uncertainty.R @@ -7,13 +7,15 @@ #' @param band band name #' @param uncert_fn function to compute uncertainty #' @param output_dir directory where files will be saved -#' @param version version name of resulting cube#' +#' @param version version name of resulting cube +#' @param progress Check progress bar? #' @return uncertainty cube .uncertainty_raster_cube <- function(cube, band, uncert_fn, output_dir, - version) { + version, + progress) { # Process each tile sequentially .cube_foreach_tile(cube, function(tile) { # Compute uncertainty @@ -22,7 +24,8 @@ band = band, uncert_fn = uncert_fn, output_dir = output_dir, - version = version + version = version, + progress = progress ) }) } @@ -35,12 +38,14 @@ #' @param uncert_fn function to compute uncertainty #' @param output_dir directory where files will be saved #' @param version version name of resulting cube +#' @param progress Check progress bar? #' @return uncertainty tile-band combination .uncertainty_raster_tile <- function(tile, band, uncert_fn, output_dir, - version) { + version, + progress) { # Output file out_file <- .file_derived_name( tile = tile, @@ -114,7 +119,7 @@ gc() # Return block file block_file - }) + }, progress = progress) # Merge blocks into a new uncertainty_cube tile .tile_derived_merge_blocks( file = out_file, @@ -189,8 +194,7 @@ return(uncert_tile) } # select uncertainty function - uncert_fn <- switch( - band, + uncert_fn <- switch(band, least = .uncertainty_fn_least(), margin = .uncertainty_fn_margin(), entropy = .uncertainty_fn_entropy() diff --git a/R/api_utils.R b/R/api_utils.R index 8d0c9c325..9ee057d14 100644 --- a/R/api_utils.R +++ b/R/api_utils.R @@ -238,8 +238,9 @@ NULL # precondition .check_set_caller(".by") .check_chr_within(col, - within = names(data), - discriminator = "any_of") + within = names(data), + discriminator = "any_of" + ) unname(c(by(data, data[[col]], fn, ...))) } diff --git a/R/api_validate.R b/R/api_validate.R index e04eb944b..325fe6baf 100644 --- a/R/api_validate.R +++ b/R/api_validate.R @@ -1,6 +1,5 @@ .validate_sits <- function(samples, samples_validation, validation_split, ml_method) { - # Are there samples for validation? if (is.null(samples_validation)) { samples <- .tibble_samples_split( diff --git a/R/api_variance.R b/R/api_variance.R index 37f36e2f9..3f80800c7 100644 --- a/R/api_variance.R +++ b/R/api_variance.R @@ -15,6 +15,7 @@ #' @param output_dir Output directory for image files #' @param version Version of resulting image #' (in the case of multiple tests) +#' @param progress Check progress bar? #' @return A variance tile. .variance_tile <- function(tile, band, @@ -22,7 +23,8 @@ overlap, smooth_fn, output_dir, - version) { + version, + progress) { # Output file out_file <- .file_derived_name( tile = tile, band = band, version = version, @@ -31,7 +33,6 @@ # Resume feature if (file.exists(out_file)) { .check_recovery() - var_tile <- .tile_derived_from_file( file = out_file, band = band, @@ -89,7 +90,7 @@ gc() # Return block file block_file - }) + }, progress = progress) # Merge blocks into a new var_cube tile var_tile <- .tile_derived_merge_blocks( file = out_file, @@ -124,6 +125,7 @@ #' @param output_dir Output directory for image files #' @param version Version of resulting image #' (in the case of multiple tests) +#' @param progress Show progress bar? #' #' @return A variance data cube. .variance <- function(cube, @@ -133,7 +135,8 @@ multicores, memsize, output_dir, - version) { + version, + progress) { # Smooth parameters checked in smooth function creation # Create smooth function smooth_fn <- .variance_fn( @@ -153,7 +156,8 @@ overlap = overlap, smooth_fn = smooth_fn, output_dir = output_dir, - version = version + version = version, + progress = progress ) }) } diff --git a/R/api_view.R b/R/api_view.R index 724a55254..a9e394780 100644 --- a/R/api_view.R +++ b/R/api_view.R @@ -10,7 +10,6 @@ #' @return A leaflet object #' .view_add_layers_control <- function(leaf_map, overlay_groups) { - # recover base groups base_groups <- sits_env[["leaflet"]][["base_groups"]] @@ -22,7 +21,6 @@ options = leaflet::layersControlOptions(collapsed = FALSE) ) leaf_map - } #' @title Update global leaflet #' @name .view_update_global_leaflet @@ -340,10 +338,11 @@ leaflet_megabytes) { # # define which method is used - if (length(bands) == 3L) + if (length(bands) == 3L) { class(bands) <- c("rgb", class(bands)) - else + } else { class(bands) <- c("bw", class(bands)) + } UseMethod(".view_image_raster", bands) } @@ -493,7 +492,6 @@ first_quantile, last_quantile, leaflet_megabytes) { - # find if file supports COG overviews sizes <- .tile_overview_size(tile = tile, max_cog_size) # warp the file to produce a temporary overview (except for derived cube) @@ -593,7 +591,6 @@ first_quantile, last_quantile, leaflet_megabytes) { - # find if file supports COG overviews sizes <- .tile_overview_size(tile = tile, max_cog_size) # warp the image @@ -655,8 +652,10 @@ names(labels) <- seq_along(labels) } # find if file supports COG overviews - sizes <- .tile_overview_size(tile = class_cube, - max_size = max_cog_size) + sizes <- .tile_overview_size( + tile = class_cube, + max_size = max_cog_size + ) # warp the file to produce a temporary overview class_file <- .gdal_warp_file( raster_file = .tile_path(tile), @@ -674,7 +673,8 @@ # of the color array (e.g., 10, 20), causing a misrepresentation of # the classes values_available <- as.character(sort(unique(.raster_values_mem(rast), - na.omit = TRUE))) + na.omit = TRUE + ))) labels <- labels[values_available] # set levels for raster rast_levels <- data.frame( @@ -753,7 +753,6 @@ first_quantile, last_quantile, leaflet_megabytes) { - # calculate maximum size in MB max_bytes <- leaflet_megabytes * 1048576L # obtain the raster objects diff --git a/R/sits_accuracy.R b/R/sits_accuracy.R index 6f815cf47..0689b160a 100644 --- a/R/sits_accuracy.R +++ b/R/sits_accuracy.R @@ -69,7 +69,7 @@ #' if (sits_run_examples()) { #' # show accuracy for a set of samples #' train_data <- sits_sample(samples_modis_ndvi, frac = 0.5) -#' test_data <- sits_sample(samples_modis_ndvi, frac = 0.5) +#' test_data <- sits_sample(samples_modis_ndvi, frac = 0.5) #' rfor_model <- sits_train(train_data, sits_rfor()) #' points_class <- sits_classify( #' data = test_data, ml_model = rfor_model @@ -150,12 +150,14 @@ sits_accuracy.class_vector_cube <- function(data, ..., reference_attr) { .check_set_caller("sits_accuracy_class_vector_cube") segments <- .segments_read_vec(data) - .check_chr_contains(colnames(segments), - c(prediction_attr, reference_attr)) + .check_chr_contains( + colnames(segments), + c(prediction_attr, reference_attr) + ) # create prediction and reference data frames pred <- segments[[prediction_attr]] - ref <- segments[[reference_attr]] + ref <- segments[[reference_attr]] # Create factor vectors for caret unique_ref <- unique(ref) pred_fac <- factor(pred, levels = unique_ref) @@ -207,13 +209,14 @@ sits_accuracy.class_cube <- function(data, ..., .data[["Y"]] <= tile[["ymax"]] ) # No points in the cube? Return an empty list - if (nrow(points_tile) < 1L) + if (nrow(points_tile) < 1L) { return(NULL) + } # Convert the tibble to a matrix xy <- matrix(c(points_tile[["X"]], points_tile[["Y"]]), - nrow = nrow(points_tile), - ncol = 2L + nrow = nrow(points_tile), + ncol = 2L ) colnames(xy) <- c("X", "Y") # Extract values from cube @@ -247,8 +250,7 @@ sits_accuracy.class_cube <- function(data, ..., # Get predicted and reference values pred <- pred_ref[["predicted"]] ref <- pred_ref[["reference"]] - acc_area <- switch( - method, + acc_area <- switch(method, "olofsson" = .accuracy_area_assess(data, pred, ref), "pixel" = .accuracy_pixel_assess(data, pred, ref) ) @@ -322,8 +324,8 @@ sits_accuracy_summary <- function(x, digits = NULL) { cat("Overall Statistics") overall_names <- ifelse(overall_names == "", - "", - paste(overall_names, ":") + "", + paste(overall_names, ":") ) out <- cbind(format(overall_names, justify = "right"), overall_text) colnames(out) <- rep("", ncol(out)) @@ -372,8 +374,8 @@ print.sits_accuracy <- function(x, ..., digits = NULL) { # Names in caret are different from usual names in Earth observation cat("\nOverall Statistics\n") overall_names <- ifelse(overall_names == "", - "", - paste(overall_names, ":") + "", + paste(overall_names, ":") ) out <- cbind(format(overall_names, justify = "right"), overall_text) colnames(out) <- rep("", ncol(out)) @@ -390,8 +392,9 @@ print.sits_accuracy <- function(x, ..., digits = NULL) { ), collapse = "|" ) - x[["by_class"]] <- x[["by_class"]][, - grepl(pattern_format, colnames(x[["by_class"]])) + x[["by_class"]] <- x[["by_class"]][ + , + grepl(pattern_format, colnames(x[["by_class"]])) ] measures <- t(x[["by_class"]]) rownames(measures) <- c( @@ -435,7 +438,7 @@ print.sits_accuracy <- function(x, ..., digits = NULL) { ) overall_names <- c(overall_names, "", names(x[["by_class"]])) overall_names <- ifelse(overall_names == "", "", - paste(overall_names, ":") + paste(overall_names, ":") ) out <- cbind(format(overall_names, justify = "right"), overall_text) diff --git a/R/sits_add_base_cube.R b/R/sits_add_base_cube.R index 9bc93006e..ac35ebd72 100644 --- a/R/sits_add_base_cube.R +++ b/R/sits_add_base_cube.R @@ -19,41 +19,41 @@ #' @return a merged data cube with the inclusion of a base_info tibble #' @examples #' if (sits_run_examples()) { -#' s2_cube <- sits_cube( -#' source = "MPC", -#' collection = "SENTINEL-2-L2A", -#' tiles = "18HYE", -#' bands = c("B8A", "CLOUD"), -#' start_date = "2022-01-01", -#' end_date = "2022-03-31" -#' ) -#' output_dir <- paste0(tempdir(), "/reg") -#' if (!dir.exists(output_dir)) { -#' dir.create(output_dir) -#' } -#' dem_cube <- sits_cube( -#' source = "MPC", -#' collection = "COP-DEM-GLO-30", -#' tiles = "18HYE", -#' bands = "ELEVATION" -#' ) -#' s2_reg <- sits_regularize( -#' cube = s2_cube, -#' period = "P1M", -#' res = 240, -#' output_dir = output_dir, -#' multicores = 2, -#' memsize = 4 -#' ) -#' dem_reg <- sits_regularize( -#' cube = dem_cube, -#' res = 240, -#' tiles = "18HYE", -#' output_dir = output_dir, -#' multicores = 2, -#' memsize = 4 -#' ) -#' s2_reg <- sits_add_base_cube(s2_reg, dem_reg) +#' s2_cube <- sits_cube( +#' source = "MPC", +#' collection = "SENTINEL-2-L2A", +#' tiles = "18HYE", +#' bands = c("B8A", "CLOUD"), +#' start_date = "2022-01-01", +#' end_date = "2022-03-31" +#' ) +#' output_dir <- paste0(tempdir(), "/reg") +#' if (!dir.exists(output_dir)) { +#' dir.create(output_dir) +#' } +#' dem_cube <- sits_cube( +#' source = "MPC", +#' collection = "COP-DEM-GLO-30", +#' tiles = "18HYE", +#' bands = "ELEVATION" +#' ) +#' s2_reg <- sits_regularize( +#' cube = s2_cube, +#' period = "P1M", +#' res = 240, +#' output_dir = output_dir, +#' multicores = 2, +#' memsize = 4 +#' ) +#' dem_reg <- sits_regularize( +#' cube = dem_cube, +#' res = 240, +#' tiles = "18HYE", +#' output_dir = output_dir, +#' multicores = 2, +#' memsize = 4 +#' ) +#' s2_reg <- sits_add_base_cube(s2_reg, dem_reg) #' } #' @export #' diff --git a/R/sits_apply.R b/R/sits_apply.R index 8ed10fa22..beadab088 100644 --- a/R/sits_apply.R +++ b/R/sits_apply.R @@ -158,7 +158,7 @@ sits_apply.raster_cube <- function(data, ..., multicores = 2L, normalized = TRUE, output_dir, - progress = FALSE) { + progress = TRUE) { # Check cube .check_is_raster_cube(data) .check_cube_is_regular(data) @@ -184,7 +184,7 @@ sits_apply.raster_cube <- function(data, ..., if (out_band %in% bands) { if (.message_warnings()) { warning(.conf("messages", "sits_apply_out_band"), - call. = FALSE + call. = FALSE ) } return(data) diff --git a/R/sits_bands.R b/R/sits_bands.R index 41729f7f5..e4059924f 100644 --- a/R/sits_bands.R +++ b/R/sits_bands.R @@ -36,7 +36,7 @@ #' sits_bands(samples_modis_ndvi) <- "NDVI2" #' # Set the bands for a SITS cube #' sits_bands(cube) <- "NDVI2" -#'} +#' } #' @export sits_bands <- function(x) { .check_set_caller("sits_bands") diff --git a/R/sits_bayts.R b/R/sits_bayts.R index d5c6d9cbf..c2fdc3d43 100644 --- a/R/sits_bayts.R +++ b/R/sits_bayts.R @@ -80,9 +80,9 @@ sits_bayts <- function(samples = NULL, ) # Apply detect changes in time series C_bayts_detect_changes( - p_res = values, + p_res = values, start_detection = start_detection, - end_detection = end_detection, + end_detection = end_detection, threshold = threshold, chi = chi ) diff --git a/R/sits_classify.R b/R/sits_classify.R index d2e9e7577..dfcc23a89 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -13,7 +13,7 @@ #' and produce there types of output. Users should call #' \code{\link[sits]{sits_classify}} but be aware that the parameters #' are different for each type of input. -#'\itemize{ +#' \itemize{ #' \item{\code{\link[sits]{sits_classify.sits}} is called when the input is #' a set of time series. The output is the same set #' with the additional column \code{predicted}.} @@ -157,7 +157,7 @@ sits_classify <- function(data, ml_model, ...) { #' data = point_ndvi, ml_model = rf_model #' ) #' plot(point_class) -#'} +#' } #' @export sits_classify.sits <- function(data, ml_model, @@ -316,7 +316,7 @@ sits_classify.sits <- function(data, #' ) #' # plot the classified image #' plot(label_cube) -#'} +#' } #' @export sits_classify.raster_cube <- function(data, ml_model, ..., @@ -359,8 +359,9 @@ sits_classify.raster_cube <- function(data, data <- .cube_filter_spatial(cube = data, roi = roi) } # Exclusion mask - if (.has(exclusion_mask)) + if (.has(exclusion_mask)) { exclusion_mask <- .mask_as_sf(exclusion_mask) + } # Temporal filter start_date <- .default(start_date, .cube_start_date(data)) end_date <- .default(end_date, .cube_end_date(data)) @@ -379,11 +380,12 @@ sits_classify.raster_cube <- function(data, # By default, base bands is null. base_bands <- NULL - if (.cube_is_base(data)) + if (.cube_is_base(data)) { # Get base bands base_bands <- intersect( .ml_bands(ml_model), .cube_bands(.cube_base_info(data)) ) + } # get non-base bands bands <- setdiff(.ml_bands(ml_model), base_bands) @@ -398,12 +400,12 @@ sits_classify.raster_cube <- function(data, block_size = .block_size(block = block, overlap = 0L), npaths = ( length(.tile_paths(data, bands)) + - length(.ml_labels(ml_model)) + - ifelse( - test = .cube_is_base(data), - yes = length(.tile_paths(.cube_base_info(data), base_bands)), - no = 0L - ) + length(.ml_labels(ml_model)) + + ifelse( + test = .cube_is_base(data), + yes = length(.tile_paths(.cube_base_info(data), base_bands)), + no = 0L + ) ), nbytes = 8L, proc_bloat = .conf("processing_bloat") @@ -566,14 +568,15 @@ sits_classify.raster_cube <- function(data, #' # segment the image #' segments <- sits_segment( #' cube = cube, -#' seg_fn = sits_slic(step = 5, -#' compactness = 1, -#' dist_fun = "euclidean", -#' avg_fun = "median", -#' iter = 50, -#' minarea = 10, -#' verbose = FALSE -#' ), +#' seg_fn = sits_slic( +#' step = 5, +#' compactness = 1, +#' dist_fun = "euclidean", +#' avg_fun = "median", +#' iter = 50, +#' minarea = 10, +#' verbose = FALSE +#' ), #' output_dir = tempdir() #' ) #' # Create a classified vector cube @@ -598,22 +601,21 @@ sits_classify.raster_cube <- function(data, #' } #' @export sits_classify.vector_cube <- function(data, - ml_model, ..., - roi = NULL, - filter_fn = NULL, - impute_fn = impute_linear(), - start_date = NULL, - end_date = NULL, - memsize = 8L, - multicores = 2L, - gpu_memory = 4L, - batch_size = 2L^gpu_memory, - output_dir, - version = "v1", - n_sam_pol = 15L, - verbose = FALSE, - progress = TRUE) { - + ml_model, ..., + roi = NULL, + filter_fn = NULL, + impute_fn = impute_linear(), + start_date = NULL, + end_date = NULL, + memsize = 8L, + multicores = 2L, + gpu_memory = 4L, + batch_size = 2L^gpu_memory, + output_dir, + version = "v1", + n_sam_pol = 15L, + verbose = FALSE, + progress = TRUE) { # set caller for error messages .check_set_caller("sits_classify_segs") # preconditions @@ -647,10 +649,11 @@ sits_classify.vector_cube <- function(data, ) # Check if cube has a base band base_bands <- NULL - if (.cube_is_base(data)) + if (.cube_is_base(data)) { base_bands <- intersect( .ml_bands(ml_model), .cube_bands(.cube_base_info(data)) ) + } # get non-base bands bands <- setdiff(.ml_bands(ml_model), base_bands) # Update multicores for models with internal parallel processing diff --git a/R/sits_clean.R b/R/sits_clean.R index 86ad506cd..b57f0883a 100644 --- a/R/sits_clean.R +++ b/R/sits_clean.R @@ -12,6 +12,7 @@ #' in the result. #' #' @param cube Classified data cube (tibble of class "class_cube"). +#' @param ... Specific parameters for specialised functions #' @param window_size An odd integer representing the size of the #' sliding window of the modal function (min = 1, max = 15). #' @param memsize Memory available for classification in GB @@ -34,38 +35,36 @@ #' #' @examples #' if (sits_run_examples()) { -#' rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) -#' # create a data cube from local files -#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") -#' cube <- sits_cube( -#' source = "BDC", -#' collection = "MOD13Q1-6.1", -#' data_dir = data_dir -#' ) -#' # classify a data cube -#' probs_cube <- sits_classify( -#' data = cube, -#' ml_model = rf_model, -#' output_dir = tempdir() -#' ) -#' # label the probability cube -#' label_cube <- sits_label_classification( -#' probs_cube, -#' output_dir = tempdir() -#' ) -#' # apply a mode function in the labelled cube -#' clean_cube <- sits_clean( -#' cube = label_cube, -#' window_size = 5, -#' output_dir = tempdir(), -#' multicores = 1 -#' ) +#' rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) +#' # create a data cube from local files +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6.1", +#' data_dir = data_dir +#' ) +#' # classify a data cube +#' probs_cube <- sits_classify( +#' data = cube, +#' ml_model = rf_model, +#' output_dir = tempdir() +#' ) +#' # label the probability cube +#' label_cube <- sits_label_classification( +#' probs_cube, +#' output_dir = tempdir() +#' ) +#' # apply a mode function in the labelled cube +#' clean_cube <- sits_clean( +#' cube = label_cube, +#' window_size = 5, +#' output_dir = tempdir(), +#' multicores = 1 +#' ) #' } #' #' @export -sits_clean <- function(cube, window_size = 5L, memsize = 4L, - multicores = 2L, output_dir, version = "v1-clean", - progress = TRUE) { +sits_clean <- function(cube, ...) { .check_set_caller("sits_clean") # Precondition # Check the cube is valid @@ -74,7 +73,7 @@ sits_clean <- function(cube, window_size = 5L, memsize = 4L, } #' @rdname sits_clean #' @export -sits_clean.class_cube <- function(cube, +sits_clean.class_cube <- function(cube, ..., window_size = 5L, memsize = 4L, multicores = 2L, @@ -130,7 +129,8 @@ sits_clean.class_cube <- function(cube, window_size = window_size, overlap = overlap, output_dir = output_dir, - version = version + version = version, + progress = progress ) }) # Update cube class and return @@ -139,38 +139,22 @@ sits_clean.class_cube <- function(cube, #' @rdname sits_clean #' @export -sits_clean.raster_cube <- function(cube, - window_size = 5L, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1-clean", - progress = TRUE) { +sits_clean.raster_cube <- function(cube, ...) { stop(.conf("messages", "sits_clean")) } #' @rdname sits_clean #' @export -sits_clean.derived_cube <- function(cube, - window_size = 5L, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1-clean", - progress = TRUE) { +sits_clean.derived_cube <- function(cube, ...) { stop(.conf("messages", "sits_clean")) } #' @rdname sits_clean #' @export -sits_clean.default <- function(cube, window_size = 5L, memsize = 4L, - multicores = 2L, output_dir, - version = "v1-clean", progress = TRUE) { +sits_clean.default <- function(cube, ...) { cube <- tibble::as_tibble(cube) if (all(.conf("sits_cube_cols") %in% colnames(cube))) { cube <- .cube_find_class(cube) } else { stop(.conf("messages", "sits_clean")) } - clean_cube <- sits_clean(cube, window_size, memsize, multicores, - output_dir, version, progress) - return(clean_cube) + sits_clean(cube, ...) } diff --git a/R/sits_cluster.R b/R/sits_cluster.R index 5fda80a28..a905e1272 100644 --- a/R/sits_cluster.R +++ b/R/sits_cluster.R @@ -51,7 +51,8 @@ #' clusters <- sits_cluster_dendro(cerrado_2classes) #' # with parameters #' clusters <- sits_cluster_dendro(cerrado_2classes, -#' bands = "NDVI", k = 5) +#' bands = "NDVI", k = 5 +#' ) #' } #' #' @export @@ -72,7 +73,7 @@ sits_cluster_dendro <- function(samples, .check_tibble_bands(samples, bands) # check k (number of clusters) if (.has(k)) { - .check_int_parameter(k, min = 2L, max = 200L) + .check_int_parameter(k, min = 2L, max = 200L) } # check distance method .check_dist_method(dist_method) @@ -89,11 +90,13 @@ sits_cluster_dendro <- function(samples, ) # find the best cut for the dendrogram best_cut <- .cluster_dendro_bestcut(samples, cluster) - message(.conf("messages", "sits_cluster_dendro_best_number"), - best_cut[["k"]] + message( + .conf("messages", "sits_cluster_dendro_best_number"), + best_cut[["k"]] ) - message(.conf("messages", "sits_cluster_dendro_best_height"), - best_cut[["height"]] + message( + .conf("messages", "sits_cluster_dendro_best_height"), + best_cut[["height"]] ) # cut the tree (user-defined value overrides default) k <- .default(k, best_cut[["k"]]) @@ -192,7 +195,7 @@ sits_cluster_clean <- function(samples) { samples, .data[["label"]] == lb, .data[["cluster"]] == cl - ) + ) } ) } diff --git a/R/sits_colors.R b/R/sits_colors.R index a19c26413..fbac184af 100644 --- a/R/sits_colors.R +++ b/R/sits_colors.R @@ -37,9 +37,10 @@ sits_colors <- function(legend = NULL) { return(color_table_legend) } else { message(.conf("messages", "sits_colors_legend_not_available")) - leg <- paste0(paste(.conf("messages", "sits_colors_legends"), - toString(names(sits_env[["legends"]]))) - ) + leg <- paste0(paste( + .conf("messages", "sits_colors_legends"), + toString(names(sits_env[["legends"]])) + )) message(leg) return(NULL) } @@ -64,11 +65,13 @@ sits_colors <- function(legend = NULL) { sits_colors_show <- function(legend = NULL, font_family = "sans") { # legend must be valid - if (.has_not(legend)) + if (.has_not(legend)) { legend <- "none" + } if (!(legend %in% names(sits_env[["legends"]]))) { - leg <- paste(.conf("messages", "sits_colors_legends"), - toString(names(sits_env[["legends"]])) + leg <- paste( + .conf("messages", "sits_colors_legends"), + toString(names(sits_env[["legends"]])) ) message(leg) return(invisible(NULL)) @@ -190,22 +193,25 @@ sits_colors_reset <- function() { #' #' @examples #' if (sits_run_examples()) { -#' data_dir <- system.file("extdata/raster/classif", package = "sits") -#' ro_class <- sits_cube( -#' source = "MPC", -#' collection = "SENTINEL-2-L2A", -#' data_dir = data_dir, -#' parse_info = c( "X1", "X2", "tile", "start_date", "end_date", -#' "band", "version"), -#' bands = "class", -#' labels = c( -#' "1" = "Clear_Cut_Burned_Area", -#' "2" = "Clear_Cut_Bare_Soil", -#' "3" = "Clear_Cut_Vegetation", -#' "4" = "Forest") -#' ) -#' qml_file <- paste0(tempdir(), "/qgis.qml") -#' sits_colors_qgis(ro_class, qml_file) +#' data_dir <- system.file("extdata/raster/classif", package = "sits") +#' ro_class <- sits_cube( +#' source = "MPC", +#' collection = "SENTINEL-2-L2A", +#' data_dir = data_dir, +#' parse_info = c( +#' "X1", "X2", "tile", "start_date", "end_date", +#' "band", "version" +#' ), +#' bands = "class", +#' labels = c( +#' "1" = "Clear_Cut_Burned_Area", +#' "2" = "Clear_Cut_Bare_Soil", +#' "3" = "Clear_Cut_Vegetation", +#' "4" = "Forest" +#' ) +#' ) +#' qml_file <- paste0(tempdir(), "/qgis.qml") +#' sits_colors_qgis(ro_class, qml_file) #' } #' @export #' diff --git a/R/sits_config.R b/R/sits_config.R index a5bd4afaa..f56c16305 100644 --- a/R/sits_config.R +++ b/R/sits_config.R @@ -27,7 +27,8 @@ #' #' @examples #' yaml_user_file <- system.file("extdata/config_user_example.yml", -#' package = "sits") +#' package = "sits" +#' ) #' sits_config(config_user_file = yaml_user_file) #' @export sits_config <- function(config_user_file = NULL) { @@ -126,7 +127,7 @@ sits_list_collections <- function(source = NULL) { ) sources <- source } - purrr::walk(sources, .conf_list_source) + purrr::walk(sources, .conf_list_source) } #' @title List the cloud collections supported by sits #' @name sits_config_user_file @@ -143,7 +144,8 @@ sits_list_collections <- function(source = NULL) { sits_config_user_file <- function(file_path, overwrite = FALSE) { # get default user configuration file user_conf_def <- system.file("extdata", "config_user_example.yml", - package = "sits") + package = "sits" + ) update <- FALSE new_file <- FALSE # try to find if SITS_CONFIG_USER_FILE exists @@ -153,11 +155,12 @@ sits_config_user_file <- function(file_path, overwrite = FALSE) { # does current env point to chosen file path? if (env == file_path) { # should I overwrite existing file? - if (overwrite) + if (overwrite) { update <- TRUE - else + } else { update <- FALSE - # if file path is not current the env variable, update it + } + # if file path is not current the env variable, update it } else { update <- TRUE } @@ -174,12 +177,13 @@ sits_config_user_file <- function(file_path, overwrite = FALSE) { Sys.setenv(SITS_CONFIG_USER_FILE = file_path) } - if (update) + if (update) { warning(.conf("messages", "sits_config_user_file_updated")) - else if (new_file) + } else if (new_file) { warning(.conf("messages", "sits_config_user_file_new_file")) - else + } else { warning(.conf("messages", "sits_config_user_file_no_update")) + } return(invisible(NULL)) } diff --git a/R/sits_csv.R b/R/sits_csv.R index 8c919f7f9..1000b00de 100644 --- a/R/sits_csv.R +++ b/R/sits_csv.R @@ -34,27 +34,30 @@ sits_to_csv.sits <- function(data, file = NULL) { .check_samples(data) data <- .samples_convert_to_sits(data) # check the file name is valid - if (.has(file)) + if (.has(file)) { .check_file( x = file, extensions = "csv", file_exists = FALSE ) + } # get metadata csv <- .csv_metadata_from_samples(data) # write the CSV file - if (.has(file)) + if (.has(file)) { utils::write.csv(csv, file, row.names = FALSE, quote = FALSE) + } return(csv) } #' @rdname sits_to_csv #' @export sits_to_csv.tbl_df <- function(data, file) { data <- tibble::as_tibble(data) - if (all(.conf("sits_tibble_cols") %in% colnames(data))) + if (all(.conf("sits_tibble_cols") %in% colnames(data))) { class(data) <- c("sits", class(data)) - else + } else { stop(.conf("messages", "sits_to_csv_default")) + } sits_to_csv(data, file) } #' @rdname sits_to_csv @@ -95,11 +98,13 @@ sits_timeseries_to_csv <- function(data, file = NULL) { csv_ts <- dplyr::bind_cols(csv_1, csv_2) # write the CSV file - if (.has(file)) + if (.has(file)) { utils::write.csv(csv_ts, - file, - row.names = FALSE, - quote = FALSE) - else + file, + row.names = FALSE, + quote = FALSE + ) + } else { return(csv_ts) + } } diff --git a/R/sits_cube.R b/R/sits_cube.R index 85965e85c..3c4ccbf15 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -140,22 +140,27 @@ sits_cube <- function(source, collection, ...) { if ("bands" %in% names(dots)) { bands <- dots["bands"] if (bands %in% .conf("sits_results_bands")) { - source <- .source_new(source = source, - is_local = TRUE, is_result = TRUE) - + source <- .source_new( + source = source, + is_local = TRUE, is_result = TRUE + ) } } else if ("vector_dir" %in% names(dots)) { if ("vector_band" %in% names(dots)) { vector_band <- dots["vector_band"] if (vector_band %in% .conf("sits_results_bands")) { - source <- .source_new(source = source, is_vector = TRUE, - is_local = TRUE) + source <- .source_new( + source = source, is_vector = TRUE, + is_local = TRUE + ) } } } } else if ("raster_cube" %in% names(dots)) { - source <- .source_new(source = source, is_local = TRUE, - is_vector = TRUE) + source <- .source_new( + source = source, is_local = TRUE, + is_vector = TRUE + ) } else { source <- .source_new(source = source, collection = collection) } @@ -251,7 +256,7 @@ sits_cube <- function(source, collection, ...) { #' #' @examples #' if (sits_run_examples()) { -#' # --- Creating Sentinel cube from MPC +#' # --- Creating Sentinel cube from MPC #' s2_cube <- sits_cube( #' source = "MPC", #' collection = "SENTINEL-2-L2A", @@ -262,8 +267,10 @@ sits_cube <- function(source, collection, ...) { #' ) #' #' # --- Creating Landsat cube from MPC -#' roi <- c("lon_min" = -50.410, "lon_max" = -50.379, -#' "lat_min" = -10.1910 , "lat_max" = -10.1573) +#' roi <- c( +#' "lon_min" = -50.410, "lon_max" = -50.379, +#' "lat_min" = -10.1910, "lat_max" = -10.1573 +#' ) #' mpc_cube <- sits_cube( #' source = "MPC", #' collection = "LANDSAT-C2-L2", @@ -274,17 +281,19 @@ sits_cube <- function(source, collection, ...) { #' ) #' #' ## Sentinel-1 SAR from MPC -#' roi_sar <- c("lon_min" = -50.410, "lon_max" = -50.379, -#' "lat_min" = -10.1910, "lat_max" = -10.1573) +#' roi_sar <- c( +#' "lon_min" = -50.410, "lon_max" = -50.379, +#' "lat_min" = -10.1910, "lat_max" = -10.1573 +#' ) #' #' s1_cube_open <- sits_cube( -#' source = "MPC", -#' collection = "SENTINEL-1-GRD", -#' bands = c("VV", "VH"), -#' orbit = "descending", -#' roi = roi_sar, -#' start_date = "2020-06-01", -#' end_date = "2020-09-28" +#' source = "MPC", +#' collection = "SENTINEL-1-GRD", +#' bands = c("VV", "VH"), +#' orbit = "descending", +#' roi = roi_sar, +#' start_date = "2020-06-01", +#' end_date = "2020-09-28" #' ) #' # --- Access to the Brazil Data Cube #' # create a raster cube file based on the information in the BDC @@ -342,20 +351,22 @@ sits_cube <- function(source, collection, ...) { #' # --- remember to set the appropriate environmental variables #' # --- Obtain a AWS_ACCESS_KEY_ID and AWS_ACCESS_SECRET_KEY_ID #' # --- from CDSE -#' roi_sar <- c("lon_min" = 33.546, "lon_max" = 34.999, -#' "lat_min" = 1.427, "lat_max" = 3.726) +#' roi_sar <- c( +#' "lon_min" = 33.546, "lon_max" = 34.999, +#' "lat_min" = 1.427, "lat_max" = 3.726 +#' ) #' s1_cube_open <- sits_cube( -#' source = "CDSE", -#' collection = "SENTINEL-1-RTC", -#' bands = c("VV", "VH"), -#' orbit = "descending", -#' roi = roi_sar, -#' start_date = "2020-01-01", -#' end_date = "2020-06-10" -#' ) +#' source = "CDSE", +#' collection = "SENTINEL-1-RTC", +#' bands = c("VV", "VH"), +#' orbit = "descending", +#' roi = roi_sar, +#' start_date = "2020-01-01", +#' end_date = "2020-06-10" +#' ) #' #' -#' # -- Access to World Cover data (2021) via Terrascope +#' # -- Access to World Cover data (2021) via Terrascope #' cube_terrascope <- sits_cube( #' source = "TERRASCOPE", #' collection = "WORLD-COVER-2021", @@ -382,7 +393,6 @@ sits_cube.stac_cube <- function(source, platform = NULL, multicores = 2L, progress = TRUE) { - # set caller to show in errors .check_set_caller("sits_cube_stac_cube") # Check for ROI and tiles @@ -397,7 +407,7 @@ sits_cube.stac_cube <- function(source, } # AWS requires datetime format start_date <- .source_adjust_date(source, start_date) - end_date <- .source_adjust_date(source, end_date) + end_date <- .source_adjust_date(source, end_date) # Configure access if necessary .source_configure_access(source, collection) # source is upper case @@ -495,8 +505,10 @@ sits_mgrs_to_roi <- function(tiles) { #' @export sits_tiles_to_roi <- function(tiles, grid_system = "MGRS") { # retrieve the ROI - roi <- .grid_filter_tiles(grid_system = grid_system, - roi = NULL, - tiles = tiles) + roi <- .grid_filter_tiles( + grid_system = grid_system, + roi = NULL, + tiles = tiles + ) sf::st_bbox(roi) } diff --git a/R/sits_cube_local.R b/R/sits_cube_local.R index f2559857b..d1e24aa61 100644 --- a/R/sits_cube_local.R +++ b/R/sits_cube_local.R @@ -87,20 +87,19 @@ #' data_dir = data_dir, #' parse_info = c("satellite", "sensor", "tile", "band", "date") #' ) -#'} +#' } #' @export -sits_cube.local_cube <- function( - source, - collection, ..., - bands = NULL, - tiles = NULL, - start_date = NULL, - end_date = NULL, - data_dir, - parse_info = c("X1", "X2", "tile", "band", "date"), - delim = "_", - multicores = 2L, - progress = TRUE) { +sits_cube.local_cube <- function(source, + collection, ..., + bands = NULL, + tiles = NULL, + start_date = NULL, + end_date = NULL, + data_dir, + parse_info = c("X1", "X2", "tile", "band", "date"), + delim = "_", + multicores = 2L, + progress = TRUE) { # set caller for error messages .check_set_caller("sits_cube_local_cube") # precondition - data directory must be provided @@ -183,7 +182,7 @@ sits_cube.local_cube <- function( #' \code{\link{sits_label_classification}}.} #' } #' -#'@examples +#' @examples #' if (sits_run_examples()) { #' # --- Create a cube based on a local MODIS data #' # MODIS local files have names such as @@ -207,76 +206,75 @@ sits_cube.local_cube <- function( #' avg_fun = "median", #' iter = 30, #' minarea = 10 -#' ), -#' output_dir = tempdir() -#' ) -#' plot(segs_cube) +#' ), +#' output_dir = tempdir() +#' ) +#' plot(segs_cube) #' -#' # recover the local segmented cube -#' local_segs_cube <- sits_cube( +#' # recover the local segmented cube +#' local_segs_cube <- sits_cube( #' source = "BDC", #' collection = "MOD13Q1-6.1", #' raster_cube = modis_cube, #' vector_dir = tempdir(), #' vector_band = "segments" -#' ) -#' # plot the recover model and compare -#' plot(local_segs_cube) +#' ) +#' # plot the recover model and compare +#' plot(local_segs_cube) #' -#' # classify the segments -#' # create a random forest model -#' rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) -#' probs_vector_cube <- sits_classify( +#' # classify the segments +#' # create a random forest model +#' rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) +#' probs_vector_cube <- sits_classify( #' data = segs_cube, #' ml_model = rfor_model, #' output_dir = tempdir(), #' n_sam_pol = 10 -#' ) -#' plot(probs_vector_cube) +#' ) +#' plot(probs_vector_cube) #' -#' # recover vector cube -#' local_probs_vector_cube <- sits_cube( +#' # recover vector cube +#' local_probs_vector_cube <- sits_cube( #' source = "BDC", #' collection = "MOD13Q1-6.1", #' raster_cube = modis_cube, #' vector_dir = tempdir(), #' vector_band = "probs" -#' ) -#' plot(local_probs_vector_cube) +#' ) +#' plot(local_probs_vector_cube) #' -#' # label the segments -#' class_vector_cube <- sits_label_classification( +#' # label the segments +#' class_vector_cube <- sits_label_classification( #' cube = probs_vector_cube, #' output_dir = tempdir(), -#' ) -#' plot(class_vector_cube) +#' ) +#' plot(class_vector_cube) #' -#' # recover vector cube -#' local_class_vector_cube <- sits_cube( +#' # recover vector cube +#' local_class_vector_cube <- sits_cube( #' source = "BDC", #' collection = "MOD13Q1-6.1", #' raster_cube = modis_cube, #' vector_dir = tempdir(), #' vector_band = "class" -#' ) -#' plot(local_class_vector_cube) -#' -#'} +#' ) +#' plot(local_class_vector_cube) +#' } #' #' @export -sits_cube.vector_cube <- function( - source, - collection, ..., - raster_cube, - vector_dir, - vector_band, - parse_info = c("X1", "X2", "tile", "start_date", - "end_date", "band", "version"), - version = "v1", - delim = "_", - multicores = 2L, - progress = TRUE) { - +sits_cube.vector_cube <- function(source, + collection, ..., + raster_cube, + vector_dir, + vector_band, + parse_info = c( + "X1", "X2", "tile", "start_date", + "end_date", "band", "version" + ), + version = "v1", + delim = "_", + multicores = 2L, + progress = TRUE) { # set caller to show in errors .check_set_caller("sits_cube_vector_cube") # show progress bar? @@ -291,25 +289,29 @@ sits_cube.vector_cube <- function( version = version, delim = delim, multicores, - progress, ...) + progress, ... + ) cube <- .local_cube_include_vector_info(raster_cube, vector_items) class(cube) <- .cube_s3class(cube) if (vector_band == "segments") { class(cube) <- c("segs_cube", "vector_cube", class(cube)) } else if (vector_band == "probs" || vector_band == "probs-vector") { - class(cube) <- c("probs_vector_cube", - "derived_vector_cube", - "segs_cube", - "vector_cube", - class(cube)) + class(cube) <- c( + "probs_vector_cube", + "derived_vector_cube", + "segs_cube", + "vector_cube", + class(cube) + ) } else if (vector_band == "class" || vector_band == "class-vector") { - class(cube) <- c("class_vector_cube", - "derived_vector_cube", - "segs_cube", - "vector_cube", - class(cube)) - + class(cube) <- c( + "class_vector_cube", + "derived_vector_cube", + "segs_cube", + "vector_cube", + class(cube) + ) } return(cube) } @@ -464,7 +466,7 @@ sits_cube.vector_cube <- function( #' data_dir = tempdir(), #' bands = "entropy" #' ) -#'. # plot recovered entropy values +#' . # plot recovered entropy values #' plot(entropy_local_cube) #' #' # obtain an uncertainty cube with margin @@ -483,36 +485,38 @@ sits_cube.vector_cube <- function( #' data_dir = tempdir(), #' bands = "margin" #' ) -#'. # plot recovered entropy values +#' . # plot recovered entropy values #' plot(margin_local_cube) #' } #' @export -sits_cube.results_cube <- function( - source, - collection, ..., - data_dir, - tiles = NULL, - bands, - labels = NULL, - parse_info = c("X1", "X2", "tile", "start_date", - "end_date", "band", "version"), - version = "v1", - delim = "_", - multicores = 2L, - progress = TRUE) { - +sits_cube.results_cube <- function(source, + collection, ..., + data_dir, + tiles = NULL, + bands, + labels = NULL, + parse_info = c( + "X1", "X2", "tile", "start_date", + "end_date", "band", "version" + ), + version = "v1", + delim = "_", + multicores = 2L, + progress = TRUE) { # set caller to show in errors .check_set_caller("sits_cube_results_cube") # check if cube is results cube .check_chr_contains(bands, - contains = .conf("sits_results_bands"), - discriminator = "one_of", - msg = .conf("messages", "sits_cube_results_cube")) + contains = .conf("sits_results_bands"), + discriminator = "one_of", + msg = .conf("messages", "sits_cube_results_cube") + ) # check if labels exist and are named - if (any(bands %in% c("probs", "bayes", "class"))) + if (any(bands %in% c("probs", "bayes", "class"))) { .check_labels_named(labels) + } # show progress bar? progress <- .message_progress(progress) # builds a sits data cube diff --git a/R/sits_detect_change.R b/R/sits_detect_change.R index 059e740cd..a96aa6624 100644 --- a/R/sits_detect_change.R +++ b/R/sits_detect_change.R @@ -58,8 +58,6 @@ sits_detect_change.sits <- function(data, .check_is_sits_model(dc_method) .check_int_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) - # documentation mode? verbose is FALSE - verbose <- .message_verbose(verbose) # preconditions - impute and filter functions if (!is.null(filter_fn)) { .check_function(filter_fn) diff --git a/R/sits_detect_change_method.R b/R/sits_detect_change_method.R index fcf2c6c5c..4ea8bd33a 100644 --- a/R/sits_detect_change_method.R +++ b/R/sits_detect_change_method.R @@ -19,11 +19,12 @@ sits_detect_change_method <- function(samples = NULL, .check_set_caller("sits_detect_change_method") # is the train method a function? .check_that(inherits(dc_method, "function"), - msg = .conf("messages", "sits_detect_change_method_model") + msg = .conf("messages", "sits_detect_change_method_model") ) - if (.has(samples)) + if (.has(samples)) { # check if samples are valid .check_samples_train(samples) + } # compute the training method by the given data result <- dc_method(samples) # return a valid detect change method diff --git a/R/sits_dtw.R b/R/sits_dtw.R index 30c277a96..131d1a671 100644 --- a/R/sits_dtw.R +++ b/R/sits_dtw.R @@ -24,13 +24,13 @@ #' @return Change detection method prepared to be passed to #' \code{\link[sits]{sits_detect_change_method}} #' @noRd -sits_dtw <- function(samples = NULL, +sits_dtw <- function(samples = NULL, ..., - threshold = NULL, + threshold = NULL, start_date = NULL, - end_date = NULL, - window = NULL, - patterns = NULL) { + end_date = NULL, + window = NULL, + patterns = NULL) { .check_set_caller("sits_dtw") train_fun <- function(samples) { @@ -96,13 +96,15 @@ sits_dtw <- function(samples = NULL, ) } # Set model class - detect_change_fun <- .set_class(detect_change_fun, - "dtw_model", - "sits_model", - class(detect_change_fun)) + detect_change_fun <- .set_class( + detect_change_fun, + "dtw_model", + "sits_model", + class(detect_change_fun) + ) detect_change_fun } # If samples is informed, train a model and return a predict function # Otherwise give back a train function to train model further - .factory_function(samples, train_fun) + .factory_function(samples, train_fun) } diff --git a/R/sits_filters.R b/R/sits_filters.R index ef8e8e86c..8bf247803 100644 --- a/R/sits_filters.R +++ b/R/sits_filters.R @@ -15,7 +15,8 @@ #' point_whit <- sits_filter(point_ndvi, sits_whittaker(lambda = 3.0)) #' # Merge time series #' point_ndvi <- sits_merge(point_ndvi, point_whit, -#' suffix = c("", ".WHIT")) +#' suffix = c("", ".WHIT") +#' ) #' # Plot the two points to see the smoothing effect #' plot(point_ndvi) #' } @@ -60,7 +61,8 @@ sits_filter <- function(data, filter = sits_whittaker()) { #' point_whit <- sits_filter(point_ndvi, sits_whittaker(lambda = 3.0)) #' # Merge time series #' point_ndvi <- sits_merge(point_ndvi, point_whit, -#' suffix = c("", ".WHIT")) +#' suffix = c("", ".WHIT") +#' ) #' # Plot the two points to see the smoothing effect #' plot(point_ndvi) #' } diff --git a/R/sits_geo_dist.R b/R/sits_geo_dist.R index 139b2ba24..48d6d3582 100644 --- a/R/sits_geo_dist.R +++ b/R/sits_geo_dist.R @@ -63,8 +63,9 @@ sits_geo_dist <- function(samples, roi, n = 1000L, crs = "EPSG:4326") { # Pre-conditions .check_samples(samples) samples <- .samples_convert_to_sits(samples) - if (.has(roi)) + if (.has(roi)) { roi <- .roi_as_sf(roi = roi, as_crs = "EPSG:4326") + } samples <- samples[sample.int(nrow(samples), min(n, nrow(samples))), ] # Convert training samples to points samples_sf <- .point_as_sf( diff --git a/R/sits_get_class.R b/R/sits_get_class.R index 49e4eedb5..9ed0728b7 100644 --- a/R/sits_get_class.R +++ b/R/sits_get_class.R @@ -94,11 +94,12 @@ sits_get_class.shp <- function(cube, samples) { sf_shape <- .shp_transform_to_sf(shp_file = samples) # Get the geometry type geom_type <- as.character(sf::st_geometry_type(sf_shape)[[1L]]) - if (geom_type != "POINT") + if (geom_type != "POINT") { stop(.conf("messages", "sits_get_class_not_point")) + } # Get a tibble with points - samples <- .sf_point_to_latlong(sf_object = sf_shape) + samples <- .sf_point_to_latlong(sf_object = sf_shape) # get the data .data_get_class( cube = cube, @@ -111,11 +112,12 @@ sits_get_class.sf <- function(cube, samples) { .check_set_caller("sits_get_class") # Get the geometry type geom_type <- as.character(sf::st_geometry_type(samples)[[1L]]) - if (geom_type != "POINT") + if (geom_type != "POINT") { stop(.conf("messages", "sits_get_class_not_point")) + } # Get a tibble with points - samples <- .sf_point_to_latlong(sf_object = samples) + samples <- .sf_point_to_latlong(sf_object = samples) # get the data .data_get_class( cube = cube, diff --git a/R/sits_get_data.R b/R/sits_get_data.R index a63dcac6e..65957ea76 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -87,16 +87,16 @@ #' #' # reading a shapefile from BDC (Brazil Data Cube) #' bdc_cube <- sits_cube( -#' source = "BDC", -#' collection = "CBERS-WFI-16D", -#' bands = c("NDVI", "EVI"), -#' tiles = c("007004", "007005"), -#' start_date = "2018-09-01", -#' end_date = "2018-10-28" +#' source = "BDC", +#' collection = "CBERS-WFI-16D", +#' bands = c("NDVI", "EVI"), +#' tiles = c("007004", "007005"), +#' start_date = "2018-09-01", +#' end_date = "2018-10-28" #' ) #' # define a shapefile to be read from the cube #' shp_file <- system.file("extdata/shapefiles/bdc-test/samples.shp", -#' package = "sits" +#' package = "sits" #' ) #' # get samples from the BDC based on the shapefile #' time_series_bdc <- sits_get_data( @@ -172,8 +172,9 @@ sits_get_data.csv <- function(cube, impute_fn = impute_linear(), multicores = 2L, progress = FALSE) { - if (!.has(bands)) + if (!.has(bands)) { bands <- .cube_bands(cube) + } .check_cube_bands(cube, bands = bands) .check_crs(crs) .check_int_parameter(multicores, min = 1L, max = 2048L) @@ -246,19 +247,18 @@ sits_get_data.csv <- function(cube, #' } #' @examples #' if (sits_run_examples()) { -#' #' # reading a shapefile from BDC (Brazil Data Cube) #' bdc_cube <- sits_cube( -#' source = "BDC", -#' collection = "CBERS-WFI-16D", -#' bands = c("NDVI", "EVI"), -#' tiles = c("007004", "007005"), -#' start_date = "2018-09-01", -#' end_date = "2018-10-28" +#' source = "BDC", +#' collection = "CBERS-WFI-16D", +#' bands = c("NDVI", "EVI"), +#' tiles = c("007004", "007005"), +#' start_date = "2018-09-01", +#' end_date = "2018-10-28" #' ) #' # define a shapefile to be read from the cube #' shp_file <- system.file("extdata/shapefiles/bdc-test/samples.shp", -#' package = "sits" +#' package = "sits" #' ) #' # get samples from the BDC based on the shapefile #' time_series_bdc <- sits_get_data( @@ -282,8 +282,9 @@ sits_get_data.shp <- function(cube, multicores = 2L, progress = FALSE) { .check_set_caller("sits_get_data_shp") - if (!.has(bands)) + if (!.has(bands)) { bands <- .cube_bands(cube) + } .check_cube_bands(cube, bands = bands) # Get default start and end date start_date <- .default(start_date, .cube_start_date(cube)) @@ -293,12 +294,12 @@ sits_get_data.shp <- function(cube, # Extract a data frame from shapefile samples <- .shp_get_samples( - shp_file = samples, - label = label, - shp_attr = label_attr, - start_date = start_date, - end_date = end_date, - n_shp_pol = n_sam_pol, + shp_file = samples, + label = label, + shp_attr = label_attr, + start_date = start_date, + end_date = end_date, + n_shp_pol = n_sam_pol, sampling_type = sampling_type ) # Extract time series from a cube given a data.frame @@ -372,16 +373,16 @@ sits_get_data.shp <- function(cube, #' if (sits_run_examples()) { #' # reading a shapefile from BDC (Brazil Data Cube) #' bdc_cube <- sits_cube( -#' source = "BDC", -#' collection = "CBERS-WFI-16D", -#' bands = c("NDVI", "EVI"), -#' tiles = c("007004", "007005"), -#' start_date = "2018-09-01", -#' end_date = "2018-10-28" +#' source = "BDC", +#' collection = "CBERS-WFI-16D", +#' bands = c("NDVI", "EVI"), +#' tiles = c("007004", "007005"), +#' start_date = "2018-09-01", +#' end_date = "2018-10-28" #' ) #' # define a shapefile to be read from the cube #' shp_file <- system.file("extdata/shapefiles/bdc-test/samples.shp", -#' package = "sits" +#' package = "sits" #' ) #' # read a shapefile into an sf object #' sf_object <- sf::st_read(shp_file) @@ -407,8 +408,9 @@ sits_get_data.sf <- function(cube, multicores = 2L, progress = FALSE) { .check_set_caller("sits_get_data_sf") - if (!.has(bands)) + if (!.has(bands)) { bands <- .cube_bands(cube) + } .check_cube_bands(cube, bands = bands) .check_int_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) @@ -421,12 +423,12 @@ sits_get_data.sf <- function(cube, ) # Extract a samples data.frame from sf object samples <- .sf_get_samples( - sf_object = samples, - label = label, + sf_object = samples, + label = label, label_attr = label_attr, start_date = start_date, - end_date = end_date, - n_sam_pol = n_sam_pol, + end_date = end_date, + n_sam_pol = n_sam_pol, sampling_type = sampling_type ) # Extract time series from a cube given a data.frame @@ -550,8 +552,9 @@ sits_get_data.data.frame <- function(cube, multicores = 2L, progress = FALSE) { .check_set_caller("sits_get_data_data_frame") - if (!.has(bands)) + if (!.has(bands)) { bands <- .cube_bands(cube) + } # Check if samples contains all the required columns .check_chr_contains( x = colnames(samples), diff --git a/R/sits_get_probs.R b/R/sits_get_probs.R index 37db9a6be..48d4d3a6a 100644 --- a/R/sits_get_probs.R +++ b/R/sits_get_probs.R @@ -74,8 +74,8 @@ sits_get_probs.csv <- function(cube, samples, window_size = NULL) { samples <- .csv_get_lat_lon(samples) # get the data data <- .data_get_probs( - cube = cube, - samples = samples, + cube = cube, + samples = samples, window_size = window_size ) return(data) @@ -88,15 +88,16 @@ sits_get_probs.shp <- function(cube, samples, window_size = NULL) { sf_shape <- .shp_transform_to_sf(shp_file = samples) # Get the geometry type geom_type <- as.character(sf::st_geometry_type(sf_shape)[[1L]]) - if (geom_type != "POINT") + if (geom_type != "POINT") { stop(.conf("messages", "sits_get_probs_not_point")) + } # Get a tibble with points - samples <- .sf_point_to_latlong(sf_object = sf_shape) + samples <- .sf_point_to_latlong(sf_object = sf_shape) # get the data data <- .data_get_probs( - cube = cube, - samples = samples, + cube = cube, + samples = samples, window_size = window_size ) return(data) @@ -107,15 +108,16 @@ sits_get_probs.sf <- function(cube, samples, window_size = NULL) { .check_set_caller("sits_get_probs") # Get the geometry type geom_type <- as.character(sf::st_geometry_type(samples)[[1L]]) - if (geom_type != "POINT") + if (geom_type != "POINT") { stop(.conf("messages", "sits_get_probs_not_point")) + } # Get a tibble with points - samples <- .sf_point_to_latlong(sf_object = samples) + samples <- .sf_point_to_latlong(sf_object = samples) # get the data data <- .data_get_probs( - cube = cube, - samples = samples, + cube = cube, + samples = samples, window_size = window_size ) return(data) @@ -126,8 +128,8 @@ sits_get_probs.sits <- function(cube, samples, window_size = NULL) { .check_set_caller("sits_get_probs") # get the data data <- .data_get_probs( - cube = cube, - samples = samples, + cube = cube, + samples = samples, window_size = window_size ) return(data) @@ -138,8 +140,8 @@ sits_get_probs.data.frame <- function(cube, samples, window_size = NULL) { .check_set_caller("sits_get_probs") # get the data data <- .data_get_probs( - cube = cube, - samples = samples, + cube = cube, + samples = samples, window_size = window_size ) return(data) diff --git a/R/sits_histogram.R b/R/sits_histogram.R index 052abdee5..d922179b9 100644 --- a/R/sits_histogram.R +++ b/R/sits_histogram.R @@ -81,7 +81,7 @@ hist.raster_cube <- function(x, ..., # is this a valid date? date <- as.Date(date) .check_that(date %in% .tile_timeline(tile), - msg = .conf("messages", "sits_hist_date") + msg = .conf("messages", "sits_hist_date") ) } else { date <- .tile_timeline(tile)[[1L]] @@ -89,7 +89,7 @@ hist.raster_cube <- function(x, ..., if (.has(band)) { # is this a valid band? .check_that(band %in% .tile_bands(tile), - msg = .conf("messages", "sits_hist_band") + msg = .conf("messages", "sits_hist_band") ) } else { band <- .tile_bands(tile)[[1L]] @@ -120,8 +120,10 @@ hist.raster_cube <- function(x, ..., ggplot2::scale_x_continuous(limits = c(0.0, 1.0)) + ggplot2::xlab("Ground reflectance") + ggplot2::ylab("") + - ggplot2::ggtitle(paste("Distribution of Values for band", - band, "date", date)) + ggplot2::ggtitle(paste( + "Distribution of Values for band", + band, "date", date + )) return(suppressWarnings(density_plot)) } @@ -160,9 +162,9 @@ hist.raster_cube <- function(x, ..., #' #' @export hist.probs_cube <- function(x, ..., - tile = x[["tile"]][[1L]], - label = NULL, - size = 100000L) { + tile = x[["tile"]][[1L]], + label = NULL, + size = 100000L) { .check_set_caller("sits_hist_raster_cube") # Pre-conditional check .check_chr_parameter(tile, allow_null = TRUE) @@ -182,7 +184,7 @@ hist.probs_cube <- function(x, ..., if (.has(label)) { # is this a valid label? .check_that(label %in% .tile_labels(tile), - msg = .conf("messages", "sits_hist_label") + msg = .conf("messages", "sits_hist_label") ) } else { label <- .tile_labels(tile)[[1L]] @@ -309,5 +311,4 @@ hist.uncertainty_cube <- function(x, ..., ggplot2::ggtitle(paste("Distribution of uncertainty for band", band)) return(suppressWarnings(density_plot)) - } diff --git a/R/sits_label_classification.R b/R/sits_label_classification.R index 3723dda5e..c450bd25f 100644 --- a/R/sits_label_classification.R +++ b/R/sits_label_classification.R @@ -188,9 +188,10 @@ sits_label_classification.derived_cube <- function(cube, ...) { #' @export sits_label_classification.default <- function(cube, ...) { cube <- tibble::as_tibble(cube) - if (all(.conf("sits_cube_cols") %in% colnames(cube))) + if (all(.conf("sits_cube_cols") %in% colnames(cube))) { cube <- .cube_find_class(cube) - else + } else { stop(.conf("messages", "sits_label_classification")) + } sits_label_classification(cube, ...) } diff --git a/R/sits_labels.R b/R/sits_labels.R index 0bd7ad8ca..861fd933c 100644 --- a/R/sits_labels.R +++ b/R/sits_labels.R @@ -75,7 +75,6 @@ sits_labels.sits_model <- function(data) { .check_is_sits_model(data) # Get labels from ml_model .ml_labels(data) - } #' @rdname sits_labels #' @export @@ -175,12 +174,13 @@ sits_labels.default <- function(data) { #' @export `sits_labels<-.default` <- function(data, value) { data <- tibble::as_tibble(data) - if (all(.conf("sits_cube_cols") %in% colnames(data))) + if (all(.conf("sits_cube_cols") %in% colnames(data))) { data <- .cube_find_class(data) - else if (all(.conf("sits_tibble_cols") %in% colnames(data))) + } else if (all(.conf("sits_tibble_cols") %in% colnames(data))) { class(data) <- c("sits", class(data)) - else + } else { stop(.conf("messages", "sits_labels_raster_cube")) + } sits_labels(data) <- value data } diff --git a/R/sits_lighttae.R b/R/sits_lighttae.R index a3563c13f..aeddcb5b9 100644 --- a/R/sits_lighttae.R +++ b/R/sits_lighttae.R @@ -130,22 +130,26 @@ sits_lighttae <- function(samples = NULL, # Function that trains a torch model based on samples train_fun <- function(samples) { # does not support working with DEM or other base data - if (inherits(samples, "sits_base")) + if (inherits(samples, "sits_base")) { stop(.conf("messages", "sits_train_base_data"), call. = FALSE) + } # Avoid add a global variable for 'self' self <- NULL # Check validation_split parameter if samples_validation is not passed if (is.null(samples_validation)) { .check_num_parameter(validation_split, - exclusive_min = 0.0, max = 0.5) + exclusive_min = 0.0, max = 0.5 + ) } # Pre-conditions - .check_pre_sits_lighttae(samples = samples, epochs = epochs, - batch_size = batch_size, - lr_decay_epochs = lr_decay_epochs, - lr_decay_rate = lr_decay_rate, - patience = patience, min_delta = min_delta, - verbose = verbose) + .check_pre_sits_lighttae( + samples = samples, epochs = epochs, + batch_size = batch_size, + lr_decay_epochs = lr_decay_epochs, + lr_decay_rate = lr_decay_rate, + patience = patience, min_delta = min_delta, + verbose = verbose + ) # Check opt_hparams # Get parameters list and remove the 'param' parameter diff --git a/R/sits_machine_learning.R b/R/sits_machine_learning.R index f69944947..02dc27eff 100644 --- a/R/sits_machine_learning.R +++ b/R/sits_machine_learning.R @@ -171,8 +171,9 @@ sits_svm <- function(samples = NULL, formula = sits_formula_linear(), # Function that trains a support vector machine model train_fun <- function(samples) { # does not support working with DEM or other base data - if (inherits(samples, "sits_base")) + if (inherits(samples, "sits_base")) { stop(.conf("messages", "sits_train_base_data"), call. = FALSE) + } # Verifies if e1071 package is installed .check_require_packages("e1071") # Get labels (used later to ensure column order in result matrix) @@ -331,14 +332,16 @@ sits_xgboost <- function(samples = NULL, max_delta_step = max_delta_step, subsample = subsample, nthread = nthread ) - if (verbose) - verbose <- 1L - else - verbose <- 0L + if (verbose) { + verbose <- 1L + } else { + verbose <- 0L + } # transform predictors in a xgb.DMatrix xgb_matrix <- xgboost::xgb.DMatrix( data = as.matrix(.pred_features(train_samples)), - label = references) + label = references + ) # train the model model <- xgboost::xgb.train(xgb_matrix, num_class = length(labels), params = params, @@ -422,8 +425,9 @@ sits_formula_logref <- function(predictors_index = -2L:0L) { result_fun <- function(tb) { .check_that(nrow(tb) > 0) # if no predictors_index are given, assume all tb's fields are used - if (!.has(predictors_index)) + if (!.has(predictors_index)) { predictors_index <- seq_len(nrow(tb)) + } # get predictors names categories <- names(tb)[c(predictors_index)] # compute formula result @@ -484,8 +488,9 @@ sits_formula_linear <- function(predictors_index = -2L:0L) { .check_content_data_frame(tb) n_rows_tb <- nrow(tb) # if no predictors_index are given, assume that all fields are used - if (!.has(predictors_index)) + if (!.has(predictors_index)) { predictors_index <- seq_len(n_rows_tb) + } # get predictors names categories <- names(tb)[c(predictors_index)] diff --git a/R/sits_merge.R b/R/sits_merge.R index 09b6ee57e..e344e475a 100644 --- a/R/sits_merge.R +++ b/R/sits_merge.R @@ -77,11 +77,13 @@ sits_merge.sits <- function(data1, data2, ..., suffix = c(".1", ".2")) { if (any(coincidences1) || any(coincidences2)) { bands1_names <- rep(x = suffix[[1L]], length(coincidences1)) bands2_names <- rep(x = suffix[[2L]], length(coincidences2)) - bands1[coincidences1] <- paste0(bands1[coincidences1], - bands1_names[coincidences1] + bands1[coincidences1] <- paste0( + bands1[coincidences1], + bands1_names[coincidences1] ) - bands2[coincidences2] <- paste0(bands2[coincidences2], - bands2_names[coincidences2] + bands2[coincidences2] <- paste0( + bands2[coincidences2], + bands2_names[coincidences2] ) .check_that(!any(bands1 %in% bands2)) .check_that(!any(bands2 %in% bands1)) diff --git a/R/sits_mixture_model.R b/R/sits_mixture_model.R index 1a7116aae..545f0cb82 100644 --- a/R/sits_mixture_model.R +++ b/R/sits_mixture_model.R @@ -148,7 +148,7 @@ sits_mixture_model.sits <- function(data, endmembers, ..., # Process each group of samples in parallel samples_fracs <- .parallel_map(samples_groups, function(samples) { # Process the data - .mixture_samples( + .mixture_samples( samples = samples, em = em, mixture_fn = mixture_fn, out_fracs = out_fracs ) @@ -239,9 +239,10 @@ sits_mixture_model.raster_cube <- function(data, endmembers, ..., ) }, progress = progress) # Join output features as a cube and return it - cube <- .cube_merge_tiles(dplyr::bind_rows(list(features_cube, - features_fracs)) - ) + cube <- .cube_merge_tiles(dplyr::bind_rows(list( + features_cube, + features_fracs + ))) # Join groups samples as a sits tibble and return it class(cube) <- c("raster_cube", class(cube)) cube @@ -255,12 +256,13 @@ sits_mixture_model.derived_cube <- function(data, endmembers, ...) { #' @export sits_mixture_model.tbl_df <- function(data, endmembers, ...) { data <- tibble::as_tibble(data) - if (all(.conf("sits_cube_cols") %in% colnames(data))) + if (all(.conf("sits_cube_cols") %in% colnames(data))) { data <- .cube_find_class(data) - else if (all(.conf("sits_tibble_cols") %in% colnames(data))) + } else if (all(.conf("sits_tibble_cols") %in% colnames(data))) { class(data) <- c("sits", class(data)) - else + } else { stop(.conf("messages", "sits_mixture_model_derived_cube")) + } sits_mixture_model(data, endmembers, ...) } #' @rdname sits_mixture_model diff --git a/R/sits_mlp.R b/R/sits_mlp.R index 51a2a89e9..af1bbbc7b 100644 --- a/R/sits_mlp.R +++ b/R/sits_mlp.R @@ -66,8 +66,10 @@ #' @examples #' if (sits_run_examples()) { #' # create an MLP model -#' torch_model <- sits_train(samples_modis_ndvi, -#' sits_mlp(epochs = 20, verbose = TRUE)) +#' torch_model <- sits_train( +#' samples_modis_ndvi, +#' sits_mlp(epochs = 20, verbose = TRUE) +#' ) #' # plot the model #' plot(torch_model) #' # create a data cube from local files @@ -122,8 +124,9 @@ sits_mlp <- function(samples = NULL, # Function that trains a torch model based on samples train_fun <- function(samples) { # does not support working with DEM or other base data - if (inherits(samples, "sits_base")) + if (inherits(samples, "sits_base")) { stop(.conf("messages", "sits_train_base_data"), call. = FALSE) + } # Add a global variable for 'self' self <- NULL # Check validation_split parameter if samples_validation is not passed @@ -131,17 +134,19 @@ sits_mlp <- function(samples = NULL, .check_num_parameter(validation_split, exclusive_min = 0.0, max = 0.5) } # Pre-conditions - checking parameters - .check_pre_sits_mlp(samples = samples, epochs = epochs, - batch_size = batch_size, layers = layers, - dropout_rates = dropout_rates, patience = patience, - min_delta = min_delta, verbose = verbose) + .check_pre_sits_mlp( + samples = samples, epochs = epochs, + batch_size = batch_size, layers = layers, + dropout_rates = dropout_rates, patience = patience, + min_delta = min_delta, verbose = verbose + ) # Check opt_hparams # Get parameters list and remove the 'param' parameter optim_params_function <- formals(optimizer)[-1L] .check_opt_hparams(opt_hparams, optim_params_function) optim_params_function <- utils::modifyList( - x = optim_params_function, - val = opt_hparams + x = optim_params_function, + val = opt_hparams ) # Samples labels labels <- .samples_labels(samples) @@ -165,7 +170,7 @@ sits_mlp <- function(samples = NULL, timeline = timeline, bands = bands, validation_split = validation_split - ) + ) # Obtain the train and the test data train_samples <- train_test_data[["train_samples"]] test_samples <- train_test_data[["test_samples"]] diff --git a/R/sits_plot.R b/R/sits_plot.R index 311871f30..ad7c35992 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -373,7 +373,7 @@ plot.predicted <- function(x, y, ..., #' selects that date to be displayed.} #' } #' -#'. The following optional parameters are available to allow for detailed +#' . The following optional parameters are available to allow for detailed #' control over the plot output: #' \itemize{ #' \item \code{graticules_labels_size}: size of coord labels (default = 0.7) @@ -435,8 +435,9 @@ plot.raster_cube <- function(x, ..., # retrieve dots dots <- list(...) # deal with wrong parameter "date" - if ("date" %in% names(dots) && missing(dates)) + if ("date" %in% names(dots) && missing(dates)) { dates <- as.Date(dots[["date"]]) + } # check dates if (.has(dates)) { @@ -469,7 +470,7 @@ plot.raster_cube <- function(x, ..., band = bands[[1L]], date = dates[[1L]], roi = roi, - sf_seg = NULL, + sf_seg = NULL, seg_color = NULL, line_width = NULL, palette = palette, @@ -487,7 +488,7 @@ plot.raster_cube <- function(x, ..., bands = bands, date = dates[[1L]], roi = roi, - sf_seg = NULL, + sf_seg = NULL, seg_color = NULL, line_width = NULL, scale = scale, @@ -548,7 +549,7 @@ plot.raster_cube <- function(x, ..., #' @examples #' if (sits_run_examples()) { #' # create a SAR data cube from cloud services -#' cube_s1_grd <- sits_cube( +#' cube_s1_grd <- sits_cube( #' source = "MPC", #' collection = "SENTINEL-1-GRD", #' bands = c("VV", "VH"), @@ -562,21 +563,20 @@ plot.raster_cube <- function(x, ..., #' } #' @export plot.sar_cube <- function(x, ..., - band = NULL, - red = NULL, - green = NULL, - blue = NULL, - tile = x[["tile"]][[1L]], - dates = NULL, - roi = NULL, - palette = "Greys", - rev = FALSE, - scale = 1.0, - first_quantile = 0.05, - last_quantile = 0.95, - max_cog_size = 1024L, - legend_position = "inside") { - + band = NULL, + red = NULL, + green = NULL, + blue = NULL, + tile = x[["tile"]][[1L]], + dates = NULL, + roi = NULL, + palette = "Greys", + rev = FALSE, + scale = 1.0, + first_quantile = 0.05, + last_quantile = 0.95, + max_cog_size = 1024L, + legend_position = "inside") { plot.raster_cube( x, ..., band = band, @@ -593,7 +593,6 @@ plot.sar_cube <- function(x, ..., last_quantile = last_quantile, max_cog_size = max_cog_size, legend_position = legend_position - ) } @@ -633,14 +632,14 @@ plot.sar_cube <- function(x, ..., #' #' @examples #' if (sits_run_examples()) { -#' # obtain the DEM cube +#' # obtain the DEM cube #' dem_cube_19HBA <- sits_cube( #' source = "MPC", #' collection = "COP-DEM-GLO-30", #' bands = "ELEVATION", #' tiles = "19HBA" -#' ) -#' # plot the DEM reversing the palette +#' ) +#' # plot the DEM reversing the palette #' plot(dem_cube_19HBA, band = "ELEVATION") #' } #' @export @@ -694,9 +693,11 @@ plot.dem_cube <- function(x, ..., if (.has(roi)) { tile <- tile |> .tile_filter_bands(bands = band) |> - .crop(roi = roi, - output_dir = .rand_sub_tempdir(), - progress = FALSE) + .crop( + roi = roi, + output_dir = .rand_sub_tempdir(), + progress = FALSE + ) } # select the file to be plotted dem_file <- .tile_path(tile, band) @@ -707,12 +708,14 @@ plot.dem_cube <- function(x, ..., # read SpatialRaster file rast <- .raster_open_rast(dem_file) # plot the DEM - .tmap_dem_map(r = rast, - band = band, - palette = palette, - rev = rev, - scale = scale, - tmap_params = tmap_params) + .tmap_dem_map( + r = rast, + band = band, + palette = palette, + rev = rev, + scale = scale, + tmap_params = tmap_params + ) } #' @title Plot RGB vector data cubes #' @name plot.vector_cube @@ -821,7 +824,7 @@ plot.vector_cube <- function(x, ..., # is this a valid date? dates <- as.Date(dates)[[1L]] .check_that(all(dates %in% .tile_timeline(tile)), - msg = .conf("messages", ".plot_raster_cube_date") + msg = .conf("messages", ".plot_raster_cube_date") ) } else { dates <- .fi_date_least_cloud_cover(.fi(tile)) @@ -836,7 +839,7 @@ plot.vector_cube <- function(x, ..., band = bands[[1L]], date = dates[[1L]], roi = NULL, - sf_seg = sf_seg, + sf_seg = sf_seg, seg_color = seg_color, line_width = line_width, palette = palette, @@ -854,7 +857,7 @@ plot.vector_cube <- function(x, ..., bands = bands, date = dates[[1L]], roi = NULL, - sf_seg = sf_seg, + sf_seg = sf_seg, seg_color = seg_color, line_width = line_width, first_quantile = first_quantile, @@ -944,16 +947,17 @@ plot.probs_cube <- function(x, ..., tile <- .cube_filter_tiles(cube = x, tiles = tile) # plot the probs cube - .plot_probs(tile = tile, - roi = roi, - labels_plot = labels, - palette = palette, - rev = rev, - scale = scale, - quantile = quantile, - max_cog_size = max_cog_size, - tmap_params = tmap_params) - + .plot_probs( + tile = tile, + roi = roi, + labels_plot = labels, + palette = palette, + rev = rev, + scale = scale, + quantile = quantile, + max_cog_size = max_cog_size, + tmap_params = tmap_params + ) } #' @title Plot probability vector cubes #' @name plot.probs_vector_cube @@ -986,13 +990,15 @@ plot.probs_cube <- function(x, ..., #' # segment the image #' segments <- sits_segment( #' cube = cube, -#' seg_fn = sits_slic(step = 5, -#' compactness = 1, -#' dist_fun = "euclidean", -#' avg_fun = "median", -#' iter = 20, -#' minarea = 10, -#' verbose = FALSE), +#' seg_fn = sits_slic( +#' step = 5, +#' compactness = 1, +#' dist_fun = "euclidean", +#' avg_fun = "median", +#' iter = 20, +#' minarea = 10, +#' verbose = FALSE +#' ), #' output_dir = tempdir() #' ) #' # classify a data cube @@ -1034,12 +1040,14 @@ plot.probs_vector_cube <- function(x, ..., tile <- .cube_filter_tiles(cube = x, tiles = tile) # plot the probs vector cube - .plot_probs_vector(tile = tile, - labels_plot = labels, - palette = palette, - rev = rev, - scale = scale, - tmap_params = tmap_params) + .plot_probs_vector( + tile = tile, + labels_plot = labels, + palette = palette, + rev = rev, + scale = scale, + tmap_params = tmap_params + ) } #' @title Plot variance cubes #' @name plot.variance_cube @@ -1127,15 +1135,17 @@ plot.variance_cube <- function(x, ..., tile <- .cube_filter_tiles(cube = x, tiles = tile) # plot the variance cube if (type == "map") { - .plot_probs(tile = tile, - roi = roi, - labels_plot = labels, - palette = palette, - rev = rev, - scale = scale, - quantile = quantile, - max_cog_size = max_cog_size, - tmap_params = tmap_params) + .plot_probs( + tile = tile, + roi = roi, + labels_plot = labels, + palette = palette, + rev = rev, + scale = scale, + quantile = quantile, + max_cog_size = max_cog_size, + tmap_params = tmap_params + ) } else { .plot_variance_hist(tile) } @@ -1234,7 +1244,7 @@ plot.uncertainty_cube <- function(x, ..., band = band, date = NULL, roi = roi, - sf_seg = NULL, + sf_seg = NULL, seg_color = NULL, line_width = NULL, palette = palette, @@ -1276,13 +1286,15 @@ plot.uncertainty_cube <- function(x, ..., #' # segment the image #' segments <- sits_segment( #' cube = cube, -#' seg_fn = sits_slic(step = 5, -#' compactness = 1, -#' dist_fun = "euclidean", -#' avg_fun = "median", -#' iter = 20, -#' minarea = 10, -#' verbose = FALSE), +#' seg_fn = sits_slic( +#' step = 5, +#' compactness = 1, +#' dist_fun = "euclidean", +#' avg_fun = "median", +#' iter = 20, +#' minarea = 10, +#' verbose = FALSE +#' ), #' output_dir = tempdir() #' ) #' # classify a data cube @@ -1305,7 +1317,7 @@ plot.uncertainty_cube <- function(x, ..., #' plot.uncertainty_vector_cube <- function(x, ..., tile = x[["tile"]][[1L]], - palette = "RdYlGn", + palette = "RdYlGn", rev = TRUE, scale = 1.0, legend_position = "inside") { @@ -1326,12 +1338,13 @@ plot.uncertainty_vector_cube <- function(x, ..., # filter the cube tile <- .cube_filter_tiles(cube = x, tiles = tile) # plot the probs vector cube - .plot_uncertainty_vector(tile = tile, - palette = palette, - rev = rev, - scale = scale, - tmap_params = tmap_params) - + .plot_uncertainty_vector( + tile = tile, + palette = palette, + rev = rev, + scale = scale, + tmap_params = tmap_params + ) } #' @title Plot classified images #' @name plot.class_cube @@ -1590,7 +1603,7 @@ plot.rfor_model <- function(x, y, ...) { #' if (sits_run_examples()) { #' # show accuracy for a set of samples #' train_data <- sits_sample(samples_modis_ndvi, frac = 0.5) -#' test_data <- sits_sample(samples_modis_ndvi, frac = 0.5) +#' test_data <- sits_sample(samples_modis_ndvi, frac = 0.5) #' # compute a random forest model #' rfor_model <- sits_train(train_data, sits_rfor()) #' # classify training points @@ -1698,8 +1711,9 @@ plot.som_evaluate_cluster <- function(x, y, ..., } # configure plot colors # convert legend from tibble to vector - if (.has(legend)) + if (.has(legend)) { legend <- .colors_legend_set(legend) + } # get labels from cluster table labels <- unique(data[["class"]]) colors <- .colors_get( @@ -1804,8 +1818,10 @@ plot.som_map <- function(x, y, ..., } # create a legend - leg <- cbind(koh[["som_properties"]][["neuron_label"]], - koh[["som_properties"]][["paint_map"]]) + leg <- cbind( + koh[["som_properties"]][["neuron_label"]], + koh[["som_properties"]][["paint_map"]] + ) graphics::legend( "bottomright", legend = unique(leg[, 1L]), @@ -1853,21 +1869,26 @@ plot.som_clean_samples <- function(x, ...) { eval_labels <- unique(x[["eval"]]) # check if all eval labels are available all_evals <- all(c("clean", "analyze", "remove") - %in% eval_labels) - if (!all_evals) + %in% eval_labels) + if (!all_evals) { warning(.conf("messages", ".plot_som_clean_samples")) + } # organize the evaluation by class and percentage eval <- x |> dplyr::group_by(.data[["label"]], .data[["eval"]]) |> dplyr::summarise(n = dplyr::n()) |> - dplyr::mutate(n_class = sum(.data[["n"]])) |> + dplyr::mutate(n_class = sum(.data[["n"]])) |> dplyr::ungroup() |> dplyr::mutate(percent = (.data[["n"]] / .data[["n_class"]]) * 100.0) |> - dplyr::select(dplyr::all_of("label"), - dplyr::all_of("eval"), - dplyr::all_of("percent")) |> - tidyr::pivot_wider(names_from = .data[["eval"]], - values_from = .data[["percent"]]) + dplyr::select( + dplyr::all_of("label"), + dplyr::all_of("eval"), + dplyr::all_of("percent") + ) |> + tidyr::pivot_wider( + names_from = .data[["eval"]], + values_from = .data[["percent"]] + ) colors_eval <- c("#C7BB3A", "#4FC78E", "#D98880") if (all_evals) { @@ -1876,14 +1897,17 @@ plot.som_clean_samples <- function(x, ...) { tidyr::replace_na(list(clean = 0.0, remove = 0.0, analyze = 0.0)) pivot <- tidyr::pivot_longer(eval, - cols = c("clean", "remove", "analyze"), - names_to = "Eval", values_to = "value") + cols = c("clean", "remove", "analyze"), + names_to = "Eval", values_to = "value" + ) } else { eval <- eval |> dplyr::select(c("label", "clean", "analyze")) |> tidyr::replace_na(list(clean = 0.0, analyze = 0.0)) - pivot <- tidyr::pivot_longer(eval, cols = c("clean", "analyze"), - names_to = "Eval", values_to = "value") + pivot <- tidyr::pivot_longer(eval, + cols = c("clean", "analyze"), + names_to = "Eval", values_to = "value" + ) colors_eval <- c("#C7BB3A", "#4FC78E") } @@ -1896,19 +1920,24 @@ plot.som_clean_samples <- function(x, ...) { ggplot2::aes( x = value, y = factor(label, levels = rev(levels(label))), - fill = Eval)) + + fill = Eval + ) + ) + ggplot2::geom_bar( stat = "identity", color = "white", - width = 0.9) + + width = 0.9 + ) + ggplot2::geom_text( ggplot2::aes( - label = scales::percent(value / 100.0, 1L)), + label = scales::percent(value / 100.0, 1L) + ), position = ggplot2::position_stack(vjust = 0.5), color = "black", size = length(eval_labels), fontface = "bold", - check_overlap = TRUE) + + check_overlap = TRUE + ) + ggplot2::theme_classic() + ggplot2::theme( axis.title.y = ggplot2::element_blank(), @@ -1917,11 +1946,13 @@ plot.som_clean_samples <- function(x, ...) { legend.key.size = ggplot2::unit(0.5, "cm"), legend.spacing.y = ggplot2::unit(0.5, "cm"), legend.position = "right", - legend.justification = "center") + + legend.justification = "center" + ) + ggplot2::xlab("%") + ggplot2::scale_fill_manual( values = colors_eval, - name = "Evaluation") + + name = "Evaluation" + ) + ggplot2::ggtitle("Class noise detection") g } @@ -1964,7 +1995,7 @@ plot.xgb_model <- function(x, ..., xgb <- .ml_model(x) # plot the trees gr <- xgboost::xgb.plot.tree(model = xgb, trees = trees, render = FALSE) - p <- DiagrammeR::render_graph(gr, width = width, height = height) + p <- DiagrammeR::render_graph(gr, width = width, height = height) return(p) } #' @title Plot Torch (deep learning) model @@ -2021,11 +2052,11 @@ plot.torch_model <- function(x, y, ...) { x = .data[["epoch"]], y = .data[["value"]], color = .data[["data"]], - fill = .data[["data"]]) - ) + + fill = .data[["data"]] + )) + ggplot2::geom_point( - shape = 21L, col = 1L, - na.rm = TRUE, size = 2L + shape = 21L, col = 1L, + na.rm = TRUE, size = 2L ) + ggplot2::geom_smooth( formula = y ~ x, @@ -2033,8 +2064,7 @@ plot.torch_model <- function(x, y, ...) { method = "loess", na.rm = TRUE ) + - ggplot2::facet_grid(metric ~ ., switch = "y", scales = "free_y" - ) + + ggplot2::facet_grid(metric ~ ., switch = "y", scales = "free_y") + ggplot2::theme( axis.title.y = ggplot2::element_blank(), strip.placement = "outside", @@ -2128,8 +2158,9 @@ plot.geo_distances <- function(x, y, ...) { #' #' @examples #' if (sits_run_examples()) { -#' samples <- sits_cluster_dendro(cerrado_2classes, -#' bands = c("NDVI", "EVI")) +#' samples <- sits_cluster_dendro(cerrado_2classes, +#' bands = c("NDVI", "EVI") +#' ) #' } #' #' @export diff --git a/R/sits_predictors.R b/R/sits_predictors.R index f9a931e26..b7960c38f 100644 --- a/R/sits_predictors.R +++ b/R/sits_predictors.R @@ -19,8 +19,7 @@ #' #' sits_mlr <- function(samples = NULL, formula = sits_formula_linear(), #' n_weights = 20000, maxit = 2000) { -#' -#' # create a training function +#' # create a training function #' train_fun <- function(samples) { #' # Data normalization #' ml_stats <- sits_stats(samples) diff --git a/R/sits_reclassify.R b/R/sits_reclassify.R index 1301f462a..fec4c56d0 100644 --- a/R/sits_reclassify.R +++ b/R/sits_reclassify.R @@ -21,6 +21,7 @@ #' @param output_dir Directory where files will be saved #' (character vector of length 1 with valid location). #' @param version Version of resulting image (character). +#' @param progress Set progress bar?? #' #' @note #' @@ -46,72 +47,74 @@ #' #' @examples #' if (sits_run_examples()) { -#' # Open mask map -#' data_dir <- system.file("extdata/raster/prodes", package = "sits") -#' prodes2021 <- sits_cube( -#' source = "USGS", -#' collection = "LANDSAT-C2L2-SR", -#' data_dir = data_dir, -#' parse_info = c( -#' "X1", "X2", "tile", "start_date", "end_date", -#' "band", "version" -#' ), -#' bands = "class", -#' version = "v20220606", -#' labels = c("1" = "Forest", "2" = "Water", "3" = "NonForest", -#' "4" = "NonForest2", "6" = "d2007", "7" = "d2008", -#' "8" = "d2009", "9" = "d2010", "10" = "d2011", -#' "11" = "d2012", "12" = "d2013", "13" = "d2014", -#' "14" = "d2015", "15" = "d2016", "16" = "d2017", -#' "17" = "d2018", "18" = "r2010", "19" = "r2011", -#' "20" = "r2012", "21" = "r2013", "22" = "r2014", -#' "23" = "r2015", "24" = "r2016", "25" = "r2017", -#' "26" = "r2018", "27" = "d2019", "28" = "r2019", -#' "29" = "d2020", "31" = "r2020", "32" = "Clouds2021", -#' "33" = "d2021", "34" = "r2021"), -#' progress = FALSE -#' ) -#' #' Open classification map -#' data_dir <- system.file("extdata/raster/classif", package = "sits") -#' ro_class <- sits_cube( -#' source = "MPC", -#' collection = "SENTINEL-2-L2A", -#' data_dir = data_dir, -#' parse_info = c( -#' "X1", "X2", "tile", "start_date", "end_date", -#' "band", "version" -#' ), -#' bands = "class", -#' labels = c( -#' "1" = "ClearCut_Fire", "2" = "ClearCut_Soil", -#' "3" = "ClearCut_Veg", "4" = "Forest" -#' ), -#' progress = FALSE -#' ) -#' # Reclassify cube -#' ro_mask <- sits_reclassify( -#' cube = ro_class, -#' mask = prodes2021, -#' rules = list( -#' "Old_Deforestation" = mask %in% c( -#' "d2007", "d2008", "d2009", -#' "d2010", "d2011", "d2012", -#' "d2013", "d2014", "d2015", -#' "d2016", "d2017", "d2018", -#' "r2010", "r2011", "r2012", -#' "r2013", "r2014", "r2015", -#' "r2016", "r2017", "r2018", -#' "d2019", "r2019", "d2020", -#' "r2020", "r2021" +#' # Open mask map +#' data_dir <- system.file("extdata/raster/prodes", package = "sits") +#' prodes2021 <- sits_cube( +#' source = "USGS", +#' collection = "LANDSAT-C2L2-SR", +#' data_dir = data_dir, +#' parse_info = c( +#' "X1", "X2", "tile", "start_date", "end_date", +#' "band", "version" #' ), -#' "Water_Mask" = mask == "Water", -#' "NonForest_Mask" = mask %in% c("NonForest", "NonForest2") -#' ), -#' memsize = 4, -#' multicores = 2, -#' output_dir = tempdir(), -#' version = "ex_reclassify" -#' ) +#' bands = "class", +#' version = "v20220606", +#' labels = c( +#' "1" = "Forest", "2" = "Water", "3" = "NonForest", +#' "4" = "NonForest2", "6" = "d2007", "7" = "d2008", +#' "8" = "d2009", "9" = "d2010", "10" = "d2011", +#' "11" = "d2012", "12" = "d2013", "13" = "d2014", +#' "14" = "d2015", "15" = "d2016", "16" = "d2017", +#' "17" = "d2018", "18" = "r2010", "19" = "r2011", +#' "20" = "r2012", "21" = "r2013", "22" = "r2014", +#' "23" = "r2015", "24" = "r2016", "25" = "r2017", +#' "26" = "r2018", "27" = "d2019", "28" = "r2019", +#' "29" = "d2020", "31" = "r2020", "32" = "Clouds2021", +#' "33" = "d2021", "34" = "r2021" +#' ), +#' progress = FALSE +#' ) +#' #' Open classification map +#' data_dir <- system.file("extdata/raster/classif", package = "sits") +#' ro_class <- sits_cube( +#' source = "MPC", +#' collection = "SENTINEL-2-L2A", +#' data_dir = data_dir, +#' parse_info = c( +#' "X1", "X2", "tile", "start_date", "end_date", +#' "band", "version" +#' ), +#' bands = "class", +#' labels = c( +#' "1" = "ClearCut_Fire", "2" = "ClearCut_Soil", +#' "3" = "ClearCut_Veg", "4" = "Forest" +#' ), +#' progress = FALSE +#' ) +#' # Reclassify cube +#' ro_mask <- sits_reclassify( +#' cube = ro_class, +#' mask = prodes2021, +#' rules = list( +#' "Old_Deforestation" = mask %in% c( +#' "d2007", "d2008", "d2009", +#' "d2010", "d2011", "d2012", +#' "d2013", "d2014", "d2015", +#' "d2016", "d2017", "d2018", +#' "r2010", "r2011", "r2012", +#' "r2013", "r2014", "r2015", +#' "r2016", "r2017", "r2018", +#' "d2019", "r2019", "d2020", +#' "r2020", "r2021" +#' ), +#' "Water_Mask" = mask == "Water", +#' "NonForest_Mask" = mask %in% c("NonForest", "NonForest2") +#' ), +#' memsize = 4, +#' multicores = 2, +#' output_dir = tempdir(), +#' version = "ex_reclassify" +#' ) #' } #' #' @export @@ -128,7 +131,8 @@ sits_reclassify.class_cube <- function(cube, ..., memsize = 4L, multicores = 2L, output_dir, - version = "v1") { + version = "v1", + progress = TRUE) { # Preconditions .check_raster_cube_files(cube) # # check mask @@ -140,6 +144,7 @@ sits_reclassify.class_cube <- function(cube, ..., .check_output_dir(output_dir) # Check version and progress version <- .message_version(version) + progress <- .message_progress(progress) # The following functions define optimal parameters for parallel processing # @@ -183,14 +188,15 @@ sits_reclassify.class_cube <- function(cube, ..., # Get new labels from cube and pre-defined rules from user cube_labels <- .reclassify_new_labels(cube, rules) # Classify the data - .reclassify_tile( + .reclassify_tile( tile = tile, mask = mask, band = "class", labels = cube_labels, reclassify_fn = reclassify_fn, output_dir = output_dir, - version = version + version = version, + progress = progress ) }, mask = mask) class(class_cube) <- c("class_cube", class(class_cube)) diff --git a/R/sits_reduce.R b/R/sits_reduce.R index 3212cc3a5..aef855043 100644 --- a/R/sits_reduce.R +++ b/R/sits_reduce.R @@ -132,7 +132,6 @@ sits_reduce.raster_cube <- function(data, ..., multicores = 2L, output_dir, progress = FALSE) { - # Check cube .check_is_raster_cube(data) .check_cube_is_regular(data) @@ -152,7 +151,7 @@ sits_reduce.raster_cube <- function(data, ..., if (out_band %in% bands) { if (.message_warnings()) { warning(.conf("messages", "sits_reduce_bands"), - call. = FALSE + call. = FALSE ) } return(data) diff --git a/R/sits_reduce_imbalance.R b/R/sits_reduce_imbalance.R index 4d3f6008f..bb2e8c8ca 100644 --- a/R/sits_reduce_imbalance.R +++ b/R/sits_reduce_imbalance.R @@ -82,7 +82,7 @@ sits_reduce_imbalance <- function(samples, # check if number of required samples are correctly entered .check_that(n_samples_under >= n_samples_over, - msg = .conf("messages", "sits_reduce_imbalance_samples") + msg = .conf("messages", "sits_reduce_imbalance_samples") ) # get the bands and the labels bands <- .samples_bands(samples) @@ -113,7 +113,8 @@ sits_reduce_imbalance <- function(samples, samples = samples, classes_under = classes_under, n_samples_under = n_samples_under, - multicores = multicores) + multicores = multicores + ) # join get new samples new_samples <- dplyr::bind_rows(new_samples, samples_under_new) @@ -171,7 +172,7 @@ sits_reduce_imbalance <- function(samples, } # keep classes (no undersampling nor oversampling) classes_ok <- samples_labels[!(samples_labels %in% classes_under | - samples_labels %in% classes_over)] + samples_labels %in% classes_over)] if (.has(classes_ok)) { samples_classes_ok <- dplyr::filter( samples, diff --git a/R/sits_regularize.R b/R/sits_regularize.R index 4c4011c7d..586ed104d 100644 --- a/R/sits_regularize.R +++ b/R/sits_regularize.R @@ -134,8 +134,10 @@ #' ) #' #' ## Sentinel-1 SAR -#' roi <- c("lon_min" = -50.410, "lon_max" = -50.379, -#' "lat_min" = -10.1910, "lat_max" = -10.1573) +#' roi <- c( +#' "lon_min" = -50.410, "lon_max" = -50.379, +#' "lat_min" = -10.1910, "lat_max" = -10.1573 +#' ) #' s1_cube_open <- sits_cube( #' source = "MPC", #' collection = "SENTINEL-1-GRD", @@ -192,12 +194,15 @@ sits_regularize.raster_cube <- function(cube, ..., # Does cube contain cloud band? If not, issue a warning .message_warnings_regularize_cloud(cube) # ROI and tiles - if (.has(roi) || .has(tiles)) + if (.has(roi) || .has(tiles)) { .check_roi_tiles(roi, tiles) - if (.has(roi)) + } + if (.has(roi)) { roi <- .roi_as_sf(roi, default_crs = crs) - if (.has_not(roi) && .has_not(tiles)) + } + if (.has_not(roi) && .has_not(tiles)) { roi <- .cube_as_sf(cube) + } # Convert input cube to the user's provided grid system if (.has(grid_system)) { @@ -211,7 +216,7 @@ sits_regularize.raster_cube <- function(cube, ..., ) ) .check_that(nrow(cube) > 0, - msg = .conf("messages", "sits_regularize_roi") + msg = .conf("messages", "sits_regularize_roi") ) } # Display warning message in case regularization is done via STAC @@ -251,15 +256,19 @@ sits_regularize.sar_cube <- function(cube, ..., .check_output_dir(output_dir) .check_num_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) - if (.has(grid_system)) + if (.has(grid_system)) { .check_grid_system(grid_system) + } # deal for ROI and tiles - if (.has(roi) || .has(tiles)) + if (.has(roi) || .has(tiles)) { .check_roi_tiles(roi, tiles) - if (.has(roi)) + } + if (.has(roi)) { roi <- .roi_as_sf(roi, default_crs = crs) - if (.has_not(roi) && .has_not(tiles)) + } + if (.has_not(roi) && .has_not(tiles)) { roi <- .cube_as_sf(cube) + } # Convert input sentinel1 cube to the user's provided grid system cube <- .reg_tile_convert( @@ -269,7 +278,7 @@ sits_regularize.sar_cube <- function(cube, ..., tiles = tiles ) .check_that(nrow(cube) > 0, - msg = .conf("messages", "sits_regularize_roi") + msg = .conf("messages", "sits_regularize_roi") ) # Filter tiles if (is.character(tiles)) { @@ -316,7 +325,7 @@ sits_regularize.combined_cube <- function(cube, ..., if (.has(grid_system)) { .check_grid_system(grid_system) } else if (any("NoTilingSystem" %in% .cube_tiles(cube))) { - grid_system <- "MGRS" + grid_system <- "MGRS" } # Get a global timeline timeline <- .gc_get_valid_timeline( @@ -325,7 +334,7 @@ sits_regularize.combined_cube <- function(cube, ..., # Grouping by unique values for each type of cube: sar, optical, etc.. cubes <- dplyr::group_by( cube, .data[["source"]], .data[["collection"]], .data[["satellite"]] - ) |> dplyr::group_map(~{ + ) |> dplyr::group_map(~ { class(.x) <- .cube_s3class(.x) .x }, .keep = TRUE) @@ -370,12 +379,15 @@ sits_regularize.rainfall_cube <- function(cube, ..., .check_num_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) # deal for ROI and tiles - if (.has(roi) || .has(tiles)) + if (.has(roi) || .has(tiles)) { .check_roi_tiles(roi, tiles) - if (.has(roi)) + } + if (.has(roi)) { roi <- .roi_as_sf(roi, default_crs = crs) - if (.has_not(roi) && .has_not(tiles)) + } + if (.has_not(roi) && .has_not(tiles)) { roi <- .cube_as_sf(cube) + } if (.has(grid_system)) { .check_grid_system(grid_system) } @@ -425,12 +437,15 @@ sits_regularize.dem_cube <- function(cube, ..., .check_num_parameter(multicores, min = 1L, max = 2048L) progress <- .message_progress(progress) # ROI and tiles - if (.has(roi) || .has(tiles)) + if (.has(roi) || .has(tiles)) { .check_roi_tiles(roi, tiles) - if (.has(roi)) + } + if (.has(roi)) { roi <- .roi_as_sf(roi, default_crs = crs) - if (.has_not(roi) && .has_not(tiles)) + } + if (.has_not(roi) && .has_not(tiles)) { roi <- .cube_as_sf(cube) + } if (.has(grid_system)) { .check_grid_system(grid_system) diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R index 54f82452d..d2628b967 100644 --- a/R/sits_sample_functions.R +++ b/R/sits_sample_functions.R @@ -88,6 +88,7 @@ sits_sample <- function(data, #' (integer, min = 1, max = 2048). #' @param memsize Maximum overall memory (in GB) to run the #' function. +#' @param progress Show progress bar? #' #' @return #' A tibble with longitude and latitude in WGS84 with locations @@ -120,7 +121,8 @@ sits_confidence_sampling <- function(probs_cube, min_margin = 0.90, sampling_window = 10L, multicores = 2L, - memsize = 4L) { + memsize = 4L, + progress = TRUE) { .check_set_caller("sits_confidence_sampling") # Pre-conditions .check_is_probs_cube(probs_cube) @@ -129,6 +131,7 @@ sits_confidence_sampling <- function(probs_cube, .check_int_parameter(sampling_window, min = 10L) .check_int_parameter(multicores, min = 1L, max = 2048L) .check_int_parameter(memsize, min = 1L, max = 16384L) + progress <- .message_progress(progress) # get labels labels <- .cube_labels(probs_cube) @@ -179,36 +182,38 @@ sits_confidence_sampling <- function(probs_cube, # Process jobs in parallel .jobs_map_parallel_dfr(chunks, function(chunk) { # Get samples for each label - purrr::map2_dfr(labels, seq_along(labels), - function(lab, i) { - # Get a list of values of high confidence & apply threshold - top_values <- .raster_open_rast(tile_path) |> - .raster_get_top_values( - block = .block(chunk), - band = i, - n = n, - sampling_window = sampling_window - ) |> - dplyr::mutate( - value = .data[["value"]] * - .conf("probs_cube_scale_factor") - ) |> - dplyr::filter( - .data[["value"]] >= min_margin - ) |> - dplyr::select(dplyr::matches( - c("longitude", "latitude", "value") - )) |> - tibble::as_tibble() + purrr::map2_dfr( + labels, seq_along(labels), + function(lab, i) { + # Get a list of values of high confidence & apply threshold + top_values <- .raster_open_rast(tile_path) |> + .raster_get_top_values( + block = .block(chunk), + band = i, + n = n, + sampling_window = sampling_window + ) |> + dplyr::mutate( + value = .data[["value"]] * + .conf("probs_cube_scale_factor") + ) |> + dplyr::filter( + .data[["value"]] >= min_margin + ) |> + dplyr::select(dplyr::matches( + c("longitude", "latitude", "value") + )) |> + tibble::as_tibble() - # All the cube's uncertainty images have the same start & - # end dates. - top_values[["start_date"]] <- .tile_start_date(tile) - top_values[["end_date"]] <- .tile_end_date(tile) - top_values[["label"]] <- lab - top_values - }) - }) + # All the cube's uncertainty images have the same start & + # end dates. + top_values[["start_date"]] <- .tile_start_date(tile) + top_values[["end_date"]] <- .tile_end_date(tile) + top_values[["label"]] <- lab + top_values + } + ) + }, progress = progress) }) # Slice result samples result_tb <- samples_tb |> @@ -235,8 +240,8 @@ sits_confidence_sampling <- function(probs_cube, if (.has(incomplete_labels)) { warning(.conf("messages", "sits_confidence_sampling_window"), - toString(incomplete_labels), - call. = FALSE + toString(incomplete_labels), + call. = FALSE ) } @@ -297,8 +302,10 @@ sits_confidence_sampling <- function(probs_cube, #' output_dir = tempdir() #' ) #' # estimated UA for classes -#' expected_ua <- c(Cerrado = 0.75, Forest = 0.9, -#' Pasture = 0.8, Soy_Corn = 0.8) +#' expected_ua <- c( +#' Cerrado = 0.75, Forest = 0.9, +#' Pasture = 0.8, Soy_Corn = 0.8 +#' ) #' sampling_design <- sits_sampling_design(label_cube, expected_ua) #' } #' @export @@ -310,7 +317,7 @@ sits_sampling_design <- function(cube, .check_set_caller("sits_sampling_design") # check the cube is valid .check_that(inherits(cube, "class_cube") || - inherits(cube, "class_vector_cube")) + inherits(cube, "class_vector_cube")) # get the labels labels <- .cube_labels(cube) n_labels <- length(labels) @@ -333,13 +340,14 @@ sits_sampling_design <- function(cube, expected_ua <- expected_ua[available_classes] # check that names of class areas are contained in the labels .check_that(all(names(class_areas) %in% labels), - msg = .conf("messages", "sits_sampling_design_labels")) + msg = .conf("messages", "sits_sampling_design_labels") + ) # calculate proportion of class areas prop <- class_areas / sum(class_areas) # standard deviation of the stratum std_dev <- signif(sqrt(expected_ua * (1.0 - expected_ua)), 3L) # calculate sample size - sample_size <- round((sum(prop * std_dev) / std_err) ^ 2L) + sample_size <- round((sum(prop * std_dev) / std_err)^2L) # determine "equal" allocation n_classes <- length(class_areas) equal <- rep(round(sample_size / n_classes), n_classes) @@ -375,8 +383,9 @@ sits_sampling_design <- function(cube, # final option is the proportional allocation alloc_prop <- round(prop * sample_size) # put it all together - design <- cbind(prop, expected_ua, std_dev, - equal, alloc_options, alloc_prop + design <- cbind( + prop, expected_ua, std_dev, + equal, alloc_options, alloc_prop ) return(design) } @@ -422,14 +431,17 @@ sits_sampling_design <- function(cube, #' output_dir = tempdir() #' ) #' # estimated UA for classes -#' expected_ua <- c(Cerrado = 0.95, Forest = 0.95, -#' Pasture = 0.95, Soy_Corn = 0.95) +#' expected_ua <- c( +#' Cerrado = 0.95, Forest = 0.95, +#' Pasture = 0.95, Soy_Corn = 0.95 +#' ) #' # design sampling #' sampling_design <- sits_sampling_design(label_cube, expected_ua) #' # select samples -#' samples <- sits_stratified_sampling(label_cube, -#' sampling_design, "alloc_prop") -#' +#' samples <- sits_stratified_sampling( +#' label_cube, +#' sampling_design, "alloc_prop" +#' ) #' } #' @export sits_stratified_sampling <- function(cube, @@ -444,7 +456,7 @@ sits_stratified_sampling <- function(cube, .check_raster_cube_files(cube) # check the cube is valid .check_that(inherits(cube, "class_cube") || - inherits(cube, "class_vector_cube")) + inherits(cube, "class_vector_cube")) # get the labels labels <- .cube_labels(cube) n_labels <- length(labels) @@ -454,12 +466,14 @@ sits_stratified_sampling <- function(cube, .check_that(all(rownames(sampling_design) %in% labels)) # check allocation method .check_that(alloc %in% colnames(sampling_design), - msg = .conf("messages", "sits_stratified_sampling_alloc")) + msg = .conf("messages", "sits_stratified_sampling_alloc") + ) # check samples by class samples_by_class <- unlist(sampling_design[, alloc]) - .check_int_parameter(samples_by_class, is_named = TRUE, - msg = .conf("messages", "sits_stratified_sampling_samples") + .check_int_parameter(samples_by_class, + is_named = TRUE, + msg = .conf("messages", "sits_stratified_sampling_samples") ) # check multicores .check_int_parameter(multicores, min = 1L, max = 2048L) @@ -467,12 +481,14 @@ sits_stratified_sampling <- function(cube, progress <- .message_progress(progress) # transform labels to tibble labels <- tibble::rownames_to_column( - as.data.frame(labels), var = "label_id" + as.data.frame(labels), + var = "label_id" ) |> dplyr::mutate(label_id = as.numeric(.data[["label_id"]])) # transform sampling design data to tibble sampling_design <- tibble::rownames_to_column( - as.data.frame(sampling_design), var = "labels" + as.data.frame(sampling_design), + var = "labels" ) # merge sampling design with samples metadata to ensure reference to the # correct class / values from the cube @@ -496,11 +512,13 @@ sits_stratified_sampling <- function(cube, # save results if (.has(shp_file)) { .check_that(tools::file_ext(shp_file) == "shp", - msg = .conf("messages", "sits_stratified_sampling_shp") + msg = .conf("messages", "sits_stratified_sampling_shp") ) sf::st_write(samples, shp_file, append = FALSE) - message(.conf("messages", - "sits_stratified_sampling_shp_save"), shp_file) + message(.conf( + "messages", + "sits_stratified_sampling_shp_save" + ), shp_file) } return(samples) } diff --git a/R/sits_segmentation.R b/R/sits_segmentation.R index 25a99a2bf..bc8da21d4 100644 --- a/R/sits_segmentation.R +++ b/R/sits_segmentation.R @@ -42,7 +42,7 @@ #' vector probability cube; #' \item Display the results with \code{\link[sits]{plot}} or #' \code{\link[sits]{sits_view}}. -#'} +#' } #' The "roi" parameter defines a region of interest. It can be #' an sf_object, a shapefile, or a bounding box vector with #' named XY values ("xmin", "xmax", "ymin", "ymax") or @@ -87,12 +87,12 @@ #' segments <- sits_segment( #' cube = cube, #' seg_fn = sits_slic( -#' step = 10, -#' compactness = 1, -#' dist_fun = "euclidean", -#' avg_fun = "median", -#' iter = 30, -#' minarea = 10 +#' step = 10, +#' compactness = 1, +#' dist_fun = "euclidean", +#' avg_fun = "median", +#' iter = 30, +#' minarea = 10 #' ), #' output_dir = tempdir() #' ) @@ -257,12 +257,12 @@ sits_segment <- function(cube, #' segments <- sits_segment( #' cube = cube, #' seg_fn = sits_slic( -#' step = 10, -#' compactness = 1, -#' dist_fun = "euclidean", -#' avg_fun = "median", -#' iter = 30, -#' minarea = 10 +#' step = 10, +#' compactness = 1, +#' dist_fun = "euclidean", +#' avg_fun = "median", +#' iter = 30, +#' minarea = 10 #' ), #' output_dir = tempdir(), #' version = "slic-demo" @@ -319,8 +319,8 @@ sits_slic <- function(data = NULL, ) # Get caller function and call it fn <- get("run_slic", - envir = asNamespace("supercells"), - inherits = FALSE + envir = asNamespace("supercells"), + inherits = FALSE ) slic <- fn( mat = mat, vals = data, step = step, compactness = compactness, @@ -343,7 +343,7 @@ sits_slic <- function(data = NULL, valid_centers <- slic[[2L]][, 1L] != 0L | slic[[2L]][, 2L] != 0L # Bind valid centers with segments table v_obj <- cbind( - v_obj, matrix(stats::na.omit(slic[[2L]][valid_centers, ]), ncol = 2L) + v_obj, matrix(stats::na.omit(slic[[2L]][valid_centers, ]), ncol = 2L) ) # Rename columns names(v_obj) <- c("supercells", "x", "y", "geometry") diff --git a/R/sits_select.R b/R/sits_select.R index c307446dd..dd0220eb5 100644 --- a/R/sits_select.R +++ b/R/sits_select.R @@ -26,8 +26,9 @@ #' sits_bands(data) #' # select start and end date #' point_2010 <- sits_select(point_mt_6bands, -#' start_date = "2000-01-01", -#' end_date = "2030-12-31") +#' start_date = "2000-01-01", +#' end_date = "2030-12-31" +#' ) #' #' @export sits_select <- function(data, ...) { @@ -54,10 +55,10 @@ sits_select.sits <- function(data, ..., bands <- toupper(bands) # check bands parameter .check_chr_parameter(bands, - allow_empty = FALSE, - allow_duplicate = FALSE, - len_min = 1L, - len_max = length(.samples_bands(data)) + allow_empty = FALSE, + allow_duplicate = FALSE, + len_min = 1L, + len_max = length(.samples_bands(data)) ) # select bands from the time series @@ -66,7 +67,7 @@ sits_select.sits <- function(data, ..., if (.has(start_date) && .has(end_date)) { # Filter dates start_date <- .timeline_format(start_date) - end_date <- .timeline_format(end_date) + end_date <- .timeline_format(end_date) data <- .samples_filter_interval( data, start_date = start_date, @@ -99,11 +100,12 @@ sits_select.raster_cube <- function(data, ..., #' @export sits_select.default <- function(data, ...) { data <- tibble::as_tibble(data) - if (all(.conf("sits_cube_cols") %in% colnames(data))) + if (all(.conf("sits_cube_cols") %in% colnames(data))) { data <- .cube_find_class(data) - else if (all(.conf("sits_tibble_cols") %in% colnames(data))) + } else if (all(.conf("sits_tibble_cols") %in% colnames(data))) { class(data) <- c("sits", class(data)) - else + } else { stop(.conf("messages", "sits_select")) + } sits_select(data, ...) } diff --git a/R/sits_sf.R b/R/sits_sf.R index 6e187af1b..4b5ff97d4 100644 --- a/R/sits_sf.R +++ b/R/sits_sf.R @@ -68,11 +68,12 @@ sits_as_sf.vector_cube <- function(data, ..., as_crs = NULL) { #' @export sits_as_sf.default <- function(data, ...) { data <- tibble::as_tibble(data) - if (all(.conf("sits_cube_cols") %in% colnames(data))) + if (all(.conf("sits_cube_cols") %in% colnames(data))) { data <- .cube_find_class(data) - else if (all(.conf("sits_tibble_cols") %in% colnames(data))) + } else if (all(.conf("sits_tibble_cols") %in% colnames(data))) { class(data) <- c("sits", class(data)) - else + } else { stop(.conf("messages", "sits_select")) + } sits_as_sf(data, ...) } diff --git a/R/sits_smooth.R b/R/sits_smooth.R index 66cc8faa4..947be3e0d 100644 --- a/R/sits_smooth.R +++ b/R/sits_smooth.R @@ -30,6 +30,7 @@ #' (character vector of length 1). #' @param version Version of the output #' (character vector of length 1). +#' @param progress Check progress bar? #' #' @return A data cube. #' @@ -121,7 +122,8 @@ sits_smooth.probs_cube <- function(cube, ..., memsize = 4L, multicores = 2L, output_dir, - version = "v1") { + version = "v1", + progress = TRUE) { # Check if cube has probability data .check_raster_cube_files(cube) # check window size @@ -195,7 +197,8 @@ sits_smooth.probs_cube <- function(cube, ..., multicores = multicores, memsize = memsize, output_dir = output_dir, - version = version + version = version, + progress = progress ) } #' @rdname sits_smooth @@ -217,9 +220,10 @@ sits_smooth.derived_cube <- function(cube, ...) { #' @export sits_smooth.default <- function(cube, ...) { cube <- tibble::as_tibble(cube) - if (all(.conf("sits_cube_cols") %in% colnames(cube))) + if (all(.conf("sits_cube_cols") %in% colnames(cube))) { cube <- .cube_find_class(cube) - else + } else { stop(.conf("messages", "sits_smooth_default")) + } sits_smooth(cube, ...) } diff --git a/R/sits_som.R b/R/sits_som.R index 2025c9a76..34f6391ac 100644 --- a/R/sits_som.R +++ b/R/sits_som.R @@ -120,10 +120,12 @@ sits_som_map <- function(data, # check recommended grid sizes min_grid_size <- floor(sqrt(5L * sqrt(n_samples))) - 2L max_grid_size <- ceiling(sqrt(5L * sqrt(n_samples))) + 2L - if (grid_xdim < min_grid_size || grid_xdim > max_grid_size) - warning(.conf("messages", "sits_som_map_grid_size"), - "(", min_grid_size, " ...", max_grid_size, ")" + if (grid_xdim < min_grid_size || grid_xdim > max_grid_size) { + warning( + .conf("messages", "sits_som_map_grid_size"), + "(", min_grid_size, " ...", max_grid_size, ")" ) + } .check_that(n_samples > grid_xdim * grid_ydim) # get the time series time_series <- .values_ts(data, format = "bands_cases_dates") @@ -291,10 +293,12 @@ sits_som_clean_samples <- function(som_map, ) |> dplyr::mutate( eval = ifelse(.data[["prior_prob"]] >= prior_threshold & - .data[["post_prob"]] >= posterior_threshold, "clean", - ifelse(.data[["prior_prob"]] >= prior_threshold & - .data[["post_prob"]] < posterior_threshold, "analyze", - "remove")) + .data[["post_prob"]] >= posterior_threshold, "clean", + ifelse(.data[["prior_prob"]] >= prior_threshold & + .data[["post_prob"]] < posterior_threshold, "analyze", + "remove" + ) + ) ) |> dplyr::filter(.data[["eval"]] %in% keep) @@ -377,7 +381,8 @@ sits_som_evaluate_cluster <- function(som_map) { mixture_percentage = mixture_percentage ) # remove lines where mix_percentege is zero - dplyr::filter(current_class_ambiguity, + dplyr::filter( + current_class_ambiguity, .data[["mixture_percentage"]] > 0.0 ) }) @@ -407,28 +412,33 @@ sits_som_evaluate_cluster <- function(som_map) { #' # evaluate the som map and create clusters #' som_eval <- sits_som_evaluate_cluster(som_map) #' # clean the samples -#' new_samples <- sits_som_remove_samples(som_map, som_eval, -#' "Pasture", "Cerrado") +#' new_samples <- sits_som_remove_samples( +#' som_map, som_eval, +#' "Pasture", "Cerrado" +#' ) #' } #' @export sits_som_remove_samples <- function(som_map, som_eval, class_cluster, class_remove) { - # get the samples with id_neuron data <- som_map$data # get the samples by neurons neurons <- som_map$labelled_neurons - neurons_class_1 <- dplyr::filter(neurons, - .data[["label_samples"]] == class_cluster, - .data[["prior_prob"]] > 0.50) + neurons_class_1 <- dplyr::filter( + neurons, + .data[["label_samples"]] == class_cluster, + .data[["prior_prob"]] > 0.50 + ) id_neurons_class_1 <- neurons_class_1[["id_neuron"]] # find samples of class2 in neurons of class1 - samples_remove <- dplyr::filter(data, - .data[["label"]] == class_remove, - .data[["id_neuron"]] %in% id_neurons_class_1) + samples_remove <- dplyr::filter( + data, + .data[["label"]] == class_remove, + .data[["id_neuron"]] %in% id_neurons_class_1 + ) # get the id of the samples to be removed id_samples_remove <- samples_remove[["id_sample"]] # obtain the new samples diff --git a/R/sits_stars.R b/R/sits_stars.R index fb22b59d3..bfd0f4e78 100644 --- a/R/sits_stars.R +++ b/R/sits_stars.R @@ -22,7 +22,6 @@ #' proxy objects to be created with two dimensions. #' @examples #' if (sits_run_examples()) { -#' #' # convert sits cube to an sf object (polygon) #' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") #' cube <- sits_cube( @@ -42,9 +41,11 @@ sits_as_stars <- function(cube, .check_set_caller("sits_as_stars") .check_is_raster_cube(cube) .check_chr_parameter(tile, len_max = 1L) - .check_chr_contains(cube[["tile"]], contains = tile, + .check_chr_contains(cube[["tile"]], + contains = tile, discriminator = "any_of", - msg = .conf("messages", "sits_as_stars_tile")) + msg = .conf("messages", "sits_as_stars_tile") + ) .check_lgl_parameter(proxy) # extract tile from cube @@ -61,8 +62,9 @@ sits_as_stars <- function(cube, # filter dates if (.has(dates)) { # proxy? only one date is retrieved - if (proxy) + if (proxy) { dates <- dates[[1L]] + } .check_dates_timeline(dates, tile_cube) fi <- .fi_filter_dates(fi, dates) } else { @@ -74,17 +76,20 @@ sits_as_stars <- function(cube, image_files <- .fi_paths(fi) # proxy? only one dimension (bands) - if (proxy) + if (proxy) { stars_obj <- stars::read_stars( image_files, along = "band", proxy = TRUE ) - else + } else { stars_obj <- stars::read_stars( image_files, - along = list(band = bands, - time = dates) + along = list( + band = bands, + time = dates + ) ) + } return(stars_obj) } diff --git a/R/sits_summary.R b/R/sits_summary.R index 2c967ad3c..cc0bcc0cd 100644 --- a/R/sits_summary.R +++ b/R/sits_summary.R @@ -46,7 +46,7 @@ summary.sits <- function(object, ...) { #' data(cerrado_2classes) #' # split training and test data #' train_data <- sits_sample(cerrado_2classes, frac = 0.5) -#' test_data <- sits_sample(cerrado_2classes, frac = 0.5) +#' test_data <- sits_sample(cerrado_2classes, frac = 0.5) #' # train a random forest model #' rfor_model <- sits_train(train_data, sits_rfor()) #' # classify test data @@ -152,7 +152,7 @@ summary.raster_cube <- function(object, ..., tile = NULL, date = NULL) { # Display cube general metadata cli::cli_h1("Cube Metadata") cli::cli_li("Class: {.field raster_cube}") - cube_bbox <- .bbox(object)[, c('xmin', 'xmax', 'ymin', 'ymax')] + cube_bbox <- .bbox(object)[, c("xmin", "xmax", "ymin", "ymax")] cli::cli_li("Bounding Box: xmin = {.field {cube_bbox[['xmin']]}}, xmax = {.field {cube_bbox[['xmax']]}}, ymin = {.field {cube_bbox[['ymin']]}}, @@ -175,7 +175,7 @@ summary.raster_cube <- function(object, ..., tile = NULL, date = NULL) { } # Display raster summary cli::cli_h1("Cube Summary") - cube_sum <- slider::slide(object, function(tile) { + cube_sum <- slider::slide(object, function(tile) { # Get the first date to not read all images date <- .default(date, .tile_timeline(tile)[[1L]]) tile <- .tile_filter_dates(tile, date) @@ -290,11 +290,10 @@ summary.derived_cube <- function(object, ..., sample_size = 10000L) { #' summary(variance_cube) #' } #' @export -summary.variance_cube <- function( - object, ..., - intervals = 0.05, - sample_size = 10000L, - quantiles = c("75%", "80%", "85%", "90%", "95%", "100%")) { +summary.variance_cube <- function(object, ..., + intervals = 0.05, + sample_size = 10000L, + quantiles = c("75%", "80%", "85%", "90%", "95%", "100%")) { .check_set_caller("summary_variance_cube") # Get cube labels labels <- unname(.cube_labels(object)) @@ -328,8 +327,10 @@ summary.variance_cube <- function( }) ) # Update row names - percent_intervals <- paste0(seq(from = 0L, to = 1L, - by = intervals) * 100L, "%") + percent_intervals <- paste0(seq( + from = 0L, to = 1L, + by = intervals + ) * 100L, "%") rownames(var_values) <- percent_intervals # Return variance values filtered by quantiles return(var_values[quantiles, ]) @@ -383,17 +384,20 @@ summary.class_cube <- function(object, ...) { class_areas[["area"]] <- (class_areas[["count"]] * cell_size) / 1000000L # change value to character class_areas <- dplyr::mutate( - class_areas, value = as.character(.data[["value"]]) + class_areas, + value = as.character(.data[["value"]]) ) # create a data.frame with the labels tile_labels <- .tile_labels(tile) - df1 <- tibble::tibble(value = names(tile_labels), - class = unname(tile_labels)) + df1 <- tibble::tibble( + value = names(tile_labels), + class = unname(tile_labels) + ) # join the labels with the areas sum_areas <- dplyr::full_join(df1, class_areas, by = "value") sum_areas <- dplyr::mutate(sum_areas, - area_km2 = signif(.data[["area"]], 2L), - .keep = "unused" + area_km2 = signif(.data[["area"]], 2L), + .keep = "unused" ) # remove layer information sum_clean <- sum_areas[, -3L] |> @@ -407,7 +411,8 @@ summary.class_cube <- function(object, ...) { dplyr::summarise( count = sum(.data[["count"]]), area_km2 = sum(.data[["area_km2"]]), - .groups = "keep") |> + .groups = "keep" + ) |> dplyr::ungroup() # Return classes areas classes_areas diff --git a/R/sits_tae.R b/R/sits_tae.R index dc5c6ff66..ce94bba14 100644 --- a/R/sits_tae.R +++ b/R/sits_tae.R @@ -123,16 +123,19 @@ sits_tae <- function(samples = NULL, # Add a global variable for 'self' self <- NULL # does not support working with DEM or other base data - if (inherits(samples, "sits_base")) + if (inherits(samples, "sits_base")) { stop(.conf("messages", "sits_train_base_data"), call. = FALSE) + } # Pre-conditions: # Pre-conditions - .check_pre_sits_lighttae(samples = samples, epochs = epochs, - batch_size = batch_size, - lr_decay_epochs = lr_decay_epochs, - lr_decay_rate = lr_decay_rate, - patience = patience, min_delta = min_delta, - verbose = verbose) + .check_pre_sits_lighttae( + samples = samples, epochs = epochs, + batch_size = batch_size, + lr_decay_epochs = lr_decay_epochs, + lr_decay_rate = lr_decay_rate, + patience = patience, min_delta = min_delta, + verbose = verbose + ) # Check validation_split parameter if samples_validation is not passed if (is.null(samples_validation)) { .check_num_parameter(validation_split, exclusive_min = 0.0, max = 0.5) diff --git a/R/sits_tempcnn.R b/R/sits_tempcnn.R index 594f45a7e..215b01551 100644 --- a/R/sits_tempcnn.R +++ b/R/sits_tempcnn.R @@ -67,8 +67,10 @@ #' @examples #' if (sits_run_examples()) { #' # create a TempCNN model -#' torch_model <- sits_train(samples_modis_ndvi, -#' sits_tempcnn(epochs = 20, verbose = TRUE)) +#' torch_model <- sits_train( +#' samples_modis_ndvi, +#' sits_tempcnn(epochs = 20, verbose = TRUE) +#' ) #' # plot the model #' plot(torch_model) #' # create a data cube from local files @@ -127,8 +129,9 @@ sits_tempcnn <- function(samples = NULL, # Function that trains a torch model based on samples train_fun <- function(samples) { # does not support working with DEM or other base data - if (inherits(samples, "sits_base")) + if (inherits(samples, "sits_base")) { stop(.conf("messages", "sits_train_base_data"), call. = FALSE) + } # Avoid add a global variable for 'self' self <- NULL # Check validation_split parameter if samples_validation is not passed @@ -136,16 +139,18 @@ sits_tempcnn <- function(samples = NULL, .check_num_parameter(validation_split, exclusive_min = 0.0, max = 0.5) } # Preconditions - .check_pre_sits_tempcnn(samples = samples, cnn_layers = cnn_layers, - cnn_kernels = cnn_kernels, - cnn_dropout_rates = cnn_dropout_rates, - dense_layer_nodes = dense_layer_nodes, - dense_layer_dropout_rate = dense_layer_dropout_rate, - epochs = epochs, batch_size = batch_size, - lr_decay_epochs = lr_decay_epochs, - lr_decay_rate = lr_decay_rate, - patience = patience, min_delta = min_delta, - verbose = verbose) + .check_pre_sits_tempcnn( + samples = samples, cnn_layers = cnn_layers, + cnn_kernels = cnn_kernels, + cnn_dropout_rates = cnn_dropout_rates, + dense_layer_nodes = dense_layer_nodes, + dense_layer_dropout_rate = dense_layer_dropout_rate, + epochs = epochs, batch_size = batch_size, + lr_decay_epochs = lr_decay_epochs, + lr_decay_rate = lr_decay_rate, + patience = patience, min_delta = min_delta, + verbose = verbose + ) # Check opt_hparams # Get parameters list and remove the 'param' parameter optim_params_function <- formals(optimizer)[-1L] diff --git a/R/sits_terra.R b/R/sits_terra.R index 9f9b77896..2d09d64a9 100644 --- a/R/sits_terra.R +++ b/R/sits_terra.R @@ -17,7 +17,6 @@ #' #' @examples #' if (sits_run_examples()) { -#' #' # convert sits cube to an sf object (polygon) #' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") #' cube <- sits_cube( @@ -35,9 +34,11 @@ sits_as_terra <- function(cube, .check_set_caller("sits_as_terra") .check_is_raster_cube(cube) .check_chr_parameter(tile, len_max = 1L) - .check_chr_contains(cube[["tile"]], contains = tile, - discriminator = "any_of", - msg = .conf("messages", "sits_as_terra_tile")) + .check_chr_contains(cube[["tile"]], + contains = tile, + discriminator = "any_of", + msg = .conf("messages", "sits_as_terra_tile") + ) UseMethod("sits_as_terra", cube) } @@ -61,10 +62,11 @@ sits_as_terra.raster_cube <- function(cube, bands <- .tile_bands(tile_cube) } # filter dates - if (.has(date)) + if (.has(date)) { .check_dates_timeline(date, tile_cube) - else + } else { date <- as.Date(.tile_timeline(tile_cube)[[1L]]) + } fi <- .fi_filter_dates(fi, date) @@ -80,7 +82,7 @@ sits_as_terra.raster_cube <- function(cube, #' @export sits_as_terra.probs_cube <- function(cube, tile = cube[1L, ]$tile, - ...) { + ...) { # extract tile from cube tile_cube <- .cube_filter_tiles(cube, tile) # get file info for tile diff --git a/R/sits_texture.R b/R/sits_texture.R index d3dd01763..9cc36b4c8 100644 --- a/R/sits_texture.R +++ b/R/sits_texture.R @@ -129,7 +129,7 @@ sits_texture.raster_cube <- function(cube, ..., memsize = 4L, multicores = 2L, output_dir, - progress = FALSE) { + progress = TRUE) { # Check cube .check_is_raster_cube(cube) .check_that(.cube_is_regular(cube)) @@ -155,7 +155,7 @@ sits_texture.raster_cube <- function(cube, ..., if (out_band %in% bands) { if (.message_warnings()) { warning(.conf("messages", "sits_texture_out_band"), - call. = FALSE + call. = FALSE ) } return(cube) @@ -202,7 +202,8 @@ sits_texture.raster_cube <- function(cube, ..., out_band = out_band, in_bands = in_bands, overlap = overlap, - output_dir = output_dir + output_dir = output_dir, + progress = progress ) }) # Join output features as a cube and return it diff --git a/R/sits_timeline.R b/R/sits_timeline.R index 5f3eec1f4..c7a101053 100644 --- a/R/sits_timeline.R +++ b/R/sits_timeline.R @@ -60,12 +60,13 @@ sits_timeline.derived_cube <- function(data) { #' @export sits_timeline.tbl_df <- function(data) { data <- tibble::as_tibble(data) - if (all(.conf("sits_cube_cols") %in% colnames(data))) + if (all(.conf("sits_cube_cols") %in% colnames(data))) { data <- .cube_find_class(data) - else if (all(.conf("sits_tibble_cols") %in% colnames(data))) + } else if (all(.conf("sits_tibble_cols") %in% colnames(data))) { class(data) <- c("sits", class(data)) - else + } else { stop(.conf("messages", "sits_timeline_default")) + } timeline <- sits_timeline(data) timeline } @@ -76,5 +77,4 @@ sits_timeline.default <- function(data) { data <- tibble::as_tibble(data) timeline <- sits_timeline(data) timeline - } diff --git a/R/sits_tuning.R b/R/sits_tuning.R index e7112519b..3da294eae 100644 --- a/R/sits_tuning.R +++ b/R/sits_tuning.R @@ -121,8 +121,9 @@ sits_tuning <- function(samples, } # check 'ml_functions' parameter ml_function <- substitute(ml_method, env = environment()) - if (is.call(ml_function)) + if (is.call(ml_function)) { ml_function <- ml_function[[1L]] + } ml_function <- eval(ml_function, envir = asNamespace("sits")) # check 'params' parameter .check_lst_parameter(params, len_min = 1L) @@ -152,8 +153,9 @@ sits_tuning <- function(samples, sits_env[["batch_size"]] <- batch_size # Update multicores if (.torch_gpu_classification() && - "optimizer" %in% ls(environment(ml_method))) - multicores <- 1L + "optimizer" %in% ls(environment(ml_method))) { + multicores <- 1L + } # start processes .parallel_start(workers = multicores) on.exit(.parallel_stop()) @@ -241,8 +243,8 @@ sits_tuning <- function(samples, #' torch::optim_adagrad #' ), #' opt_hparams = list( -#' lr = loguniform(10^-2, 10^-4), -#' weight_decay = loguniform(10^-2, 10^-8) +#' lr = loguniform(10^-2, 10^-4), +#' weight_decay = loguniform(10^-2, 10^-8) #' ) #' ), #' trials = 20, diff --git a/R/sits_uncertainty.R b/R/sits_uncertainty.R index 65c66cbdc..9009ee421 100644 --- a/R/sits_uncertainty.R +++ b/R/sits_uncertainty.R @@ -14,6 +14,7 @@ #' @param output_dir Output directory for image files. #' @param version Version of resulting image (in the case of #' multiple tests). +#' @param progress Check progress bar? #' @return An uncertainty data cube #' #' @description Calculate the uncertainty cube based on the probabilities @@ -68,19 +69,19 @@ #' plot(uncert_cube) #' } #' @export -sits_uncertainty <- function(cube, ...) { +sits_uncertainty <- function(cube, ...) { # Dispatch UseMethod("sits_uncertainty", cube) } #' @rdname sits_uncertainty #' @export -sits_uncertainty.probs_cube <- function( - cube, ..., - type = "entropy", - multicores = 2L, - memsize = 4L, - output_dir, - version = "v1") { +sits_uncertainty.probs_cube <- function(cube, ..., + type = "entropy", + multicores = 2L, + memsize = 4L, + output_dir, + version = "v1", + progress = progress) { # Check if cube has probability data .check_raster_cube_files(cube) # Check memsize @@ -109,14 +110,12 @@ sits_uncertainty.probs_cube <- function( memsize = memsize, multicores = multicores ) - # Prepare parallel processing .parallel_start(workers = multicores) on.exit(.parallel_stop(), add = TRUE) # Define the class of the smoothing - uncert_fn <- switch( - type, + uncert_fn <- switch(type, least = .uncertainty_fn_least(), margin = .uncertainty_fn_margin(), entropy = .uncertainty_fn_entropy() @@ -127,19 +126,19 @@ sits_uncertainty.probs_cube <- function( band = type, uncert_fn = uncert_fn, output_dir = output_dir, - version = version + version = version, + progress = progress ) return(uncert_cube) } #' @rdname sits_uncertainty #' @export -sits_uncertainty.probs_vector_cube <- function( - cube, ..., - type = "entropy", - multicores = 2L, - memsize = 4L, - output_dir, - version = "v1") { +sits_uncertainty.probs_vector_cube <- function(cube, ..., + type = "entropy", + multicores = 2L, + memsize = 4L, + output_dir, + version = "v1") { # Check if cube has probability data .check_raster_cube_files(cube) # Check memsize diff --git a/R/sits_validate.R b/R/sits_validate.R index e145f480b..99248ba6b 100644 --- a/R/sits_validate.R +++ b/R/sits_validate.R @@ -106,7 +106,7 @@ sits_kfold_validate <- function(samples, conf_lst <- purrr::map(seq_len(folds), function(k) { # Split data into training and test data sets data_train <- samples[samples[["folds"]] != k, ] - data_test <- samples[samples[["folds"]] == k, ] + data_test <- samples[samples[["folds"]] == k, ] # Create a machine learning model ml_model <- ml_method(data_train) # classify test values @@ -195,15 +195,16 @@ sits_kfold_validate <- function(samples, #' samples <- sits_sample(cerrado_2classes, frac = 0.5) #' samples_validation <- sits_sample(cerrado_2classes, frac = 0.5) #' conf_matrix_1 <- sits_validate( -#' samples = samples, -#' samples_validation = samples_validation, -#' ml_method = sits_rfor() -#' ) -#' conf_matrix_2 <- sits_validate( -#' samples = cerrado_2classes, -#' validation_split = 0.2, -#' ml_method = sits_rfor() -#' ) +#' samples = samples, +#' samples_validation = samples_validation, +#' ml_method = sits_rfor() +#' ) +#' conf_matrix_2 <- sits_validate( +#' samples = cerrado_2classes, +#' validation_split = 0.2, +#' ml_method = sits_rfor() +#' ) +#' } #' } #' @export @@ -224,8 +225,10 @@ sits_validate <- function(samples, .check_samples_train(samples_validation) } # check validation split - .check_num(validation_split, min = 0.0, max = 1.0, - len_min = 1L, len_max = 1L) + .check_num(validation_split, + min = 0.0, max = 1.0, + len_min = 1L, len_max = 1L + ) # pre-condition for ml_method .check_that(inherits(ml_method, "function")) diff --git a/R/sits_variance.R b/R/sits_variance.R index 8f213fafe..de369c50b 100644 --- a/R/sits_variance.R +++ b/R/sits_variance.R @@ -8,6 +8,7 @@ #' to support the choice of parameters for Bayesian smoothing. #' #' @param cube Probability data cube (class "probs_cube") +#' @param ... Parameters for specific functions #' @param window_size Size of the neighborhood (odd integer) #' @param neigh_fraction Fraction of neighbors with highest probability #' for Bayesian inference (numeric from 0.0 to 1.0) @@ -19,6 +20,7 @@ #' (character vector of length 1) #' @param version Version of resulting image #' (character vector of length 1) +#' @param progress Check progress bar? #' #' @return A variance data cube. #' @@ -48,18 +50,25 @@ #' plot(var_cube) #' } #' @export -sits_variance <- function( - cube, - window_size = 9L, - neigh_fraction = 0.5, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1") { +sits_variance <- function(cube, ...) { # set caller for error messages .check_set_caller("sits_variance") # Check if cube has data and metadata .check_raster_cube_files(cube) + + # Dispatch + UseMethod("sits_variance", cube) +} +#' @rdname sits_variance +#' @export +sits_variance.probs_cube <- function(cube, ..., + window_size = 9L, + neigh_fraction = 0.5, + memsize = 4L, + multicores = 2L, + output_dir, + version = "v1", + progress = TRUE) { # check window size .check_int_parameter(window_size, min = 3L, max = 33L, is_odd = TRUE) # check neighborhood fraction @@ -70,23 +79,9 @@ sits_variance <- function( .check_int_parameter(multicores, min = 1L, max = 2048L) # check output_dir .check_output_dir(output_dir) - # Dispatch - UseMethod("sits_variance", cube) -} -#' @rdname sits_variance -#' @export -sits_variance.probs_cube <- function( - cube, - window_size = 9L, - neigh_fraction = 0.5, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1") { - # Check version and progress version <- .message_version(version) - # The following functions define optimal parameters for parallel processing + progress <- .message_progress(progress) # # Get block size block <- .raster_file_blocksize(.raster_open_rast(.tile_path(cube))) @@ -125,49 +120,30 @@ sits_variance.probs_cube <- function( multicores = multicores, memsize = memsize, output_dir = output_dir, - version = version + version = version, + progress = progress ) return(variance_cube) } #' @rdname sits_variance #' @export -sits_variance.raster_cube <- function(cube, - window_size = 7L, - neigh_fraction = 0.5, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1") { +sits_variance.raster_cube <- function(cube, ...) { stop(.conf("messages", "sits_variance_raster_cube")) } #' @rdname sits_variance #' @export -sits_variance.derived_cube <- function(cube, - window_size = 7L, - neigh_fraction = 0.5, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1") { +sits_variance.derived_cube <- function(cube, ...) { stop(.conf("messages", "sits_variance_raster_cube")) } #' @rdname sits_variance #' @export -sits_variance.default <- function(cube, - window_size = 7L, - neigh_fraction = 0.5, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1") { +sits_variance.default <- function(cube, ...) { cube <- tibble::as_tibble(cube) - if (all(.conf("sits_cube_cols") %in% colnames(cube))) + if (all(.conf("sits_cube_cols") %in% colnames(cube))) { cube <- .cube_find_class(cube) - else + } else { stop(.conf("messages", "sits_variance_raster_cube")) - variance_cube <- sits_variance(cube, window_size, - neigh_fraction, - memsize, multicores, - output_dir, version) + } + variance_cube <- sits_variance(cube, ...) return(variance_cube) } diff --git a/R/sits_view.R b/R/sits_view.R index e6d400cba..d1f2cfce4 100644 --- a/R/sits_view.R +++ b/R/sits_view.R @@ -165,12 +165,13 @@ sits_view.sits <- function(x, ..., .check_lgl_parameter(add) # if not ADD, create a new sits leaflet - if (!add) + if (!add) { .conf_clean_leaflet() + } # recover global leaflet objects overlay_groups <- sits_env[["leaflet"]][["overlay_groups"]] - leaf_map <- sits_env[["leaflet"]][["leaf_map"]] + leaf_map <- sits_env[["leaflet"]][["leaf_map"]] # create a leaflet for samples leaf_map <- leaf_map |> @@ -180,7 +181,7 @@ sits_view.sits <- function(x, ..., legend = legend, palette = palette, radius = radius - ) + ) # append samples to overlay groups overlay_groups <- append(overlay_groups, "samples") # add layers control and update global leaflet-related variables @@ -220,8 +221,9 @@ sits_view.som_map <- function(x, ..., len_max = length(unique(x[["labelled_neurons"]][["id_neuron"]])) ) # if not ADD, create a new sits leaflet - if (!add) + if (!add) { .conf_clean_leaflet() + } # recover global leaflet info overlay_groups <- sits_env[["leaflet"]][["overlay_groups"]] @@ -258,7 +260,6 @@ sits_view.som_map <- function(x, ..., # return the leaflet return(leaf_map) - } #' @rdname sits_view #' @@ -302,10 +303,11 @@ sits_view.raster_cube <- function(x, ..., .check_lgl_parameter(add) # pre-condition for bands bands <- .band_set_bw_rgb(x, band, red, green, blue) - if (length(bands) == 1L) + if (length(bands) == 1L) { band_name <- bands[[1L]] - else + } else { band_name <- stringr::str_flatten(bands, collapse = " ") + } # retrieve dots dots <- list(...) # deal with wrong parameter "date" @@ -314,8 +316,9 @@ sits_view.raster_cube <- function(x, ..., } # if not ADD, create a new sits leaflet - if (!add) + if (!add) { .conf_clean_leaflet() + } # recover global leaflet info overlay_groups <- sits_env[["leaflet"]][["overlay_groups"]] @@ -327,10 +330,11 @@ sits_view.raster_cube <- function(x, ..., row <- cube[i, ] tile_name <- row[["tile"]] # check dates - if (.has(dates)) + if (.has(dates)) { .check_dates_timeline(dates, row) - else + } else { dates <- .fi_date_least_cloud_cover(.fi(row)) + } for (date in dates) { # convert to proper date view_date <- lubridate::as_date(date) @@ -352,7 +356,7 @@ sits_view.raster_cube <- function(x, ..., first_quantile = first_quantile, last_quantile = last_quantile, leaflet_megabytes = leaflet_megabytes - ) + ) } } # add layers control and update global leaflet-related variables @@ -400,8 +404,9 @@ sits_view.uncertainty_cube <- function(x, ..., .check_lgl_parameter(add) # if not ADD, create a new sits leaflet - if (!add) + if (!add) { .conf_clean_leaflet() + } # recover global leaflet info overlay_groups <- sits_env[["leaflet"]][["overlay_groups"]] @@ -479,8 +484,9 @@ sits_view.class_cube <- function(x, ..., .check_lgl_parameter(add) # if not ADD, create a new sits leaflet - if (!add) + if (!add) { .conf_clean_leaflet() + } # recover global leaflet info overlay_groups <- sits_env[["leaflet"]][["overlay_groups"]] @@ -496,8 +502,9 @@ sits_view.class_cube <- function(x, ..., # add group group <- paste(tile_name, "class") # add version if available - if (.has(version)) + if (.has(version)) { group <- paste(group, version) + } # add a leaflet for class cube leaf_map <- leaf_map |> .view_class_cube( @@ -537,7 +544,6 @@ sits_view.probs_cube <- function(x, ..., last_quantile = 0.98, leaflet_megabytes = 64L, add = FALSE) { - # set caller for errors .check_set_caller("sits_view_probs_cube") # verifies if leaflet package is installed @@ -545,8 +551,10 @@ sits_view.probs_cube <- function(x, ..., # precondition for tiles .check_cube_tiles(x, tiles) # check if label is unique - .check_chr_parameter(label, len_max = 1L, - msg = .conf("messages", "sits_view_probs_label")) + .check_chr_parameter(label, + len_max = 1L, + msg = .conf("messages", "sits_view_probs_label") + ) # check that label is part of the probs cube .check_labels_probs_cube(x, label) # check palette @@ -564,8 +572,9 @@ sits_view.probs_cube <- function(x, ..., .check_lgl_parameter(add) # if not ADD, create a new sits leaflet - if (!add) + if (!add) { .conf_clean_leaflet() + } # recover global leaflet info overlay_groups <- sits_env[["leaflet"]][["overlay_groups"]] @@ -629,8 +638,9 @@ sits_view.vector_cube <- function(x, ..., .check_num_parameter(line_width, min = 0.1, max = 3.0) # if not ADD, create a new sits leaflet - if (!add) + if (!add) { .conf_clean_leaflet() + } # recover global leaflet info overlay_groups <- sits_env[["leaflet"]][["overlay_groups"]] @@ -642,17 +652,17 @@ sits_view.vector_cube <- function(x, ..., for (i in seq_len(nrow(cube))) { row <- cube[i, ] tile_name <- row[["tile"]] - group <- paste(tile_name, "segments") - # recover global leaflet and include group - overlay_groups <- append(overlay_groups, group) - # view image raster - leaf_map <- leaf_map |> - .view_segments( - group = group, - tile = row, - seg_color = seg_color, - line_width = line_width - ) + group <- paste(tile_name, "segments") + # recover global leaflet and include group + overlay_groups <- append(overlay_groups, group) + # view image raster + leaf_map <- leaf_map |> + .view_segments( + group = group, + tile = row, + seg_color = seg_color, + line_width = line_width + ) } # add layers control and update global leaflet-related variables leaf_map <- leaf_map |> @@ -665,14 +675,14 @@ sits_view.vector_cube <- function(x, ..., #' #' @export sits_view.class_vector_cube <- function(x, ..., - tiles = x[["tile"]][[1L]], - seg_color = "yellow", - line_width = 0.2, - version = NULL, - legend = NULL, - palette = "Set3", - opacity = 0.85, - add = FALSE) { + tiles = x[["tile"]][[1L]], + seg_color = "yellow", + line_width = 0.2, + version = NULL, + legend = NULL, + palette = "Set3", + opacity = 0.85, + add = FALSE) { # set caller for errors .check_set_caller("sits_view_class_vector_cube") # preconditions @@ -692,8 +702,9 @@ sits_view.class_vector_cube <- function(x, ..., .check_lgl_parameter(add) # if not ADD, create a new sits leaflet - if (!add) + if (!add) { .conf_clean_leaflet() + } # recover global leaflet info overlay_groups <- sits_env[["leaflet"]][["overlay_groups"]] leaf_map <- sits_env[["leaflet"]][["leaf_map"]] @@ -707,8 +718,9 @@ sits_view.class_vector_cube <- function(x, ..., # add group group <- paste(tile_name, "class_segments") # add version if available - if (.has(version)) + if (.has(version)) { group <- paste(group, version) + } # include in overlay groups overlay_groups <- append(overlay_groups, group) # view image raster diff --git a/R/sits_xlsx.R b/R/sits_xlsx.R index 13b744498..a1f628bf5 100644 --- a/R/sits_xlsx.R +++ b/R/sits_xlsx.R @@ -110,7 +110,8 @@ sits_to_xlsx.list <- function(acc, file) { # this is the case of ony two classes # get the values of the User's and Producer's Accuracy acc_bc <- cf_mat[["byClass"]][grepl( - eo_n, names(cf_mat[["byClass"]]))] + eo_n, names(cf_mat[["byClass"]]) + )] # get the names of the two classes nm <- row.names(cf_mat[["table"]]) # the first class (called the "positive" class by caret) diff --git a/R/zzz.R b/R/zzz.R index e1a82ae86..ffb020613 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -8,14 +8,13 @@ Documentation avaliable in %s.", utils::packageDescription("sits")[["Version"]], "https://e-sensing.github.io/sitsbook/" - ) ) packageStartupMessage( sprintf( "Important: Please read \"Release Notes for SITS 1.5.3\" in https://github.com/e-sensing/sits." - ) + ) ) } .onLoad <- function(lib, pkg) { @@ -28,12 +27,12 @@ sits_env <- new.env() sits_env[["model_formula"]] <- "log" # Include the following global variables in the sits package utils::globalVariables(c( - ".x", ".y", ":=", # dplyr - "self", "ctx", "super", "private", # torch - "uniform", "choice", "randint", # sits_tuning + ".x", ".y", ":=", # dplyr + "self", "ctx", "super", "private", # torch + "uniform", "choice", "randint", # sits_tuning "normal", "lognormal", "loguniform", # sits_tuning - "geometry", # sf operations - "value", "label", "Eval", # ggplot + "geometry", # sf operations + "value", "label", "Eval", # ggplot "sar:frequency_band", "sar:instrument_mode", "sat:orbit_state" # S1 stac )) #' @importFrom lubridate %within% %m+% diff --git a/README.Rmd b/README.Rmd index c26baec74..9a6f4dafc 100644 --- a/README.Rmd +++ b/README.Rmd @@ -228,9 +228,9 @@ tempcnn_model <- sits_train( # Select NDVI band of the point to be classified # Classify using TempCNN model # Plot the result -point_mt_6bands |> - sits_select(bands = "NDVI") |> - sits_classify(tempcnn_model) |> +point_mt_6bands |> + sits_select(bands = "NDVI") |> + sits_classify(tempcnn_model) |> plot() ``` diff --git a/demo/classify_cbers_bdc.R b/demo/classify_cbers_bdc.R index 554db27e1..2fe0d1ff7 100644 --- a/demo/classify_cbers_bdc.R +++ b/demo/classify_cbers_bdc.R @@ -8,7 +8,7 @@ library(sits) # load the sitsdata library if (!requireNamespace("sitsdata", quietly = TRUE)) { stop("Please install package sitsdata\n", - "Please call devtools::install_github('e-sensing/sitsdata')", + "Please call devtools::install_github('e-sensing/sitsdata')", call. = FALSE ) } diff --git a/demo/classify_deeplearning.R b/demo/classify_deeplearning.R index eec2810e7..15a2027a5 100644 --- a/demo/classify_deeplearning.R +++ b/demo/classify_deeplearning.R @@ -3,7 +3,7 @@ library(sits) # load the sitsdata library if (!requireNamespace("sitsdata", quietly = TRUE)) { stop("Please install package sitsdata\n", - "Please call devtools::install_github('e-sensing/sitsdata')", + "Please call devtools::install_github('e-sensing/sitsdata')", call. = FALSE ) } diff --git a/demo/dl_comparison.R b/demo/dl_comparison.R index ea6f573d2..532764cd7 100644 --- a/demo/dl_comparison.R +++ b/demo/dl_comparison.R @@ -4,8 +4,8 @@ devAskNewPage(ask = FALSE) library(sits) if (!requireNamespace("sitsdata", quietly = TRUE)) { stop("Please install package sitsdata\n", - "Please call devtools::install_github('e-sensing/sitsdata')", - call. = FALSE + "Please call devtools::install_github('e-sensing/sitsdata')", + call. = FALSE ) } @@ -39,5 +39,7 @@ acc_tc[["name"]] <- "TempCNN" results[[length(results) + 1]] <- acc_tc -sits_to_xlsx(results, file = file.path(tempdir(), - "/accuracy_mato_grosso_dl.xlsx")) +sits_to_xlsx(results, file = file.path( + tempdir(), + "/accuracy_mato_grosso_dl.xlsx" +)) diff --git a/demo/ml_comparison.R b/demo/ml_comparison.R index 307841138..d754a6b56 100644 --- a/demo/ml_comparison.R +++ b/demo/ml_comparison.R @@ -10,8 +10,8 @@ library(sits) library(sits) if (!requireNamespace("sitsdata", quietly = TRUE)) { stop("Please install package sitsdata\n", - "Please call devtools::install_github('e-sensing/sitsdata')", - call. = FALSE + "Please call devtools::install_github('e-sensing/sitsdata')", + call. = FALSE ) } diff --git a/inst/extdata/lintr-tests/failed_tests.R b/inst/extdata/lintr-tests/failed_tests.R deleted file mode 100644 index 4bf44d70c..000000000 --- a/inst/extdata/lintr-tests/failed_tests.R +++ /dev/null @@ -1,89 +0,0 @@ -── Failed tests ─────────────────────────────────────────────────────────────────────────────────────────────────────────────────── -Error (test-segmentation.R:18:5): Segmentation - - Error in `purrr::map(rounds, function(round) { - if (!is.null(sync_fn)) { - sync_fn(round) - } - round <- slider::slide(round, identity) - .parallel_map(round, fn, ..., progress = progress) - })`: i In index: 1. -Caused by error in `.check_remote_errors()`: - ! one node produced an error: Invalid input type, expected 'integer' actual 'double' -Backtrace: - ▆ -1. ├─sits::sits_segment(...) at test-segmentation.R:18:5 -2. │ └─sits:::.cube_foreach_tile(...) at sits/R/sits_segmentation.R:183:5 -3. │ └─slider::slide_dfr(cube, fn, ...) at sits/R/api_cube.R:918:5 -4. │ └─slider::slide(...) -5. │ └─slider:::slide_impl(...) -6. │ ├─slider:::slide_common(...) -7. │ └─sits (local) .f(.x, ...) -8. │ └─sits:::.segments_tile(...) at sits/R/sits_segmentation.R:185:9 -9. │ └─sits:::.jobs_map_parallel_chr(...) at sits/R/api_segments.R:62:5 -10. │ └─sits:::.jobs_map_parallel(jobs, fn, ..., progress = progress) at sits/R/api_jobs.R:155:5 -11. │ ├─base::unlist(...) at sits/R/api_jobs.R:138:5 -12. │ └─purrr::map(...) -13. │ └─purrr:::map_("list", .x, .f, ..., .progress = .progress) -14. │ ├─purrr:::with_indexed_errors(...) -15. │ │ └─base::withCallingHandlers(...) -16. │ ├─purrr:::call_with_cleanup(...) -17. │ └─sits (local) .f(.x[[i]], ...) -18. │ └─sits:::.parallel_map(round, fn, ..., progress = progress) at sits/R/api_jobs.R:143:9 -19. │ └─sits:::.parallel_cluster_apply(x, fn, ..., pb = pb) at sits/R/api_parallel.R:296:5 -20. │ └─parallel (local) .check_remote_errors(val) at sits/R/api_parallel.R:245:9 -21. │ └─base::stop("one node produced an error: ", firstmsg, domain = NA) -22. └─base::.handleSimpleError(...) -23. └─purrr (local) h(simpleError(msg, call)) -24. └─cli::cli_abort(...) -25. └─rlang::abort(...) - -Failure (test-segmentation.R:205:5): Segmentation of large files -.check_cube_is_regular(modis_cube_local) is not TRUE - -`actual` is NULL -`expected` is a logical vector (TRUE) - -Error (test-segmentation.R:207:5): Segmentation of large files - - Error in `purrr::map(rounds, function(round) { - if (!is.null(sync_fn)) { - sync_fn(round) - } - round <- slider::slide(round, identity) - .parallel_map(round, fn, ..., progress = progress) - })`: i In index: 1. -Caused by error in `.check_remote_errors()`: - ! one node produced an error: Invalid input type, expected 'integer' actual 'double' -Backtrace: - ▆ -1. ├─sits::sits_segment(...) at test-segmentation.R:207:5 -2. │ └─sits:::.cube_foreach_tile(...) at sits/R/sits_segmentation.R:183:5 -3. │ └─slider::slide_dfr(cube, fn, ...) at sits/R/api_cube.R:918:5 -4. │ └─slider::slide(...) -5. │ └─slider:::slide_impl(...) -6. │ ├─slider:::slide_common(...) -7. │ └─sits (local) .f(.x, ...) -8. │ └─sits:::.segments_tile(...) at sits/R/sits_segmentation.R:185:9 -9. │ └─sits:::.jobs_map_parallel_chr(...) at sits/R/api_segments.R:62:5 -10. │ └─sits:::.jobs_map_parallel(jobs, fn, ..., progress = progress) at sits/R/api_jobs.R:155:5 -11. │ ├─base::unlist(...) at sits/R/api_jobs.R:138:5 -12. │ └─purrr::map(...) -13. │ └─purrr:::map_("list", .x, .f, ..., .progress = .progress) -14. │ ├─purrr:::with_indexed_errors(...) -15. │ │ └─base::withCallingHandlers(...) -16. │ ├─purrr:::call_with_cleanup(...) -17. │ └─sits (local) .f(.x[[i]], ...) -18. │ └─sits:::.parallel_map(round, fn, ..., progress = progress) at sits/R/api_jobs.R:143:9 -19. │ └─sits:::.parallel_cluster_apply(x, fn, ..., pb = pb) at sits/R/api_parallel.R:296:5 -20. │ └─parallel (local) .check_remote_errors(val) at sits/R/api_parallel.R:245:9 -21. │ └─base::stop("one node produced an error: ", firstmsg, domain = NA) -22. └─base::.handleSimpleError(...) -23. └─purrr (local) h(simpleError(msg, call)) -24. └─cli::cli_abort(...) -25. └─rlang::abort(...) - - └─rlang::abort(message, class = error_class, parent = parent, call = error_call) - - -[ FAIL 8 | WARN 0 | SKIP 5 | PASS 1431 ] diff --git a/man/sits_apply.Rd b/man/sits_apply.Rd index 408d42416..3856ce14f 100644 --- a/man/sits_apply.Rd +++ b/man/sits_apply.Rd @@ -20,7 +20,7 @@ sits_apply(data, ...) multicores = 2L, normalized = TRUE, output_dir, - progress = FALSE + progress = TRUE ) \method{sits_apply}{derived_cube}(data, ...) diff --git a/man/sits_clean.Rd b/man/sits_clean.Rd index b89af4075..a187b8db3 100644 --- a/man/sits_clean.Rd +++ b/man/sits_clean.Rd @@ -8,18 +8,11 @@ \alias{sits_clean.default} \title{Cleans a classified map using a local window} \usage{ -sits_clean( - cube, - window_size = 5L, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1-clean", - progress = TRUE -) +sits_clean(cube, ...) \method{sits_clean}{class_cube}( cube, + ..., window_size = 5L, memsize = 4L, multicores = 2L, @@ -28,39 +21,17 @@ sits_clean( progress = TRUE ) -\method{sits_clean}{raster_cube}( - cube, - window_size = 5L, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1-clean", - progress = TRUE -) +\method{sits_clean}{raster_cube}(cube, ...) -\method{sits_clean}{derived_cube}( - cube, - window_size = 5L, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1-clean", - progress = TRUE -) +\method{sits_clean}{derived_cube}(cube, ...) -\method{sits_clean}{default}( - cube, - window_size = 5L, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1-clean", - progress = TRUE -) +\method{sits_clean}{default}(cube, ...) } \arguments{ \item{cube}{Classified data cube (tibble of class "class_cube").} +\item{...}{Specific parameters for specialised functions} + \item{window_size}{An odd integer representing the size of the sliding window of the modal function (min = 1, max = 15).} diff --git a/man/sits_confidence_sampling.Rd b/man/sits_confidence_sampling.Rd index 9b8923298..9e21fb46e 100644 --- a/man/sits_confidence_sampling.Rd +++ b/man/sits_confidence_sampling.Rd @@ -10,7 +10,8 @@ sits_confidence_sampling( min_margin = 0.9, sampling_window = 10L, multicores = 2L, - memsize = 4L + memsize = 4L, + progress = TRUE ) } \arguments{ @@ -30,6 +31,8 @@ The minimum window size is 10.} \item{memsize}{Maximum overall memory (in GB) to run the function.} + +\item{progress}{Show progress bar?} } \value{ A tibble with longitude and latitude in WGS84 with locations diff --git a/man/sits_smooth.Rd b/man/sits_smooth.Rd index 06a9bef72..252a86fcf 100644 --- a/man/sits_smooth.Rd +++ b/man/sits_smooth.Rd @@ -21,7 +21,8 @@ sits_smooth(cube, ...) memsize = 4L, multicores = 2L, output_dir, - version = "v1" + version = "v1", + progress = TRUE ) \method{sits_smooth}{probs_vector_cube}(cube, ...) @@ -63,6 +64,8 @@ shapefile.} \item{version}{Version of the output (character vector of length 1).} + +\item{progress}{Check progress bar?} } \value{ A data cube. diff --git a/man/sits_texture.Rd b/man/sits_texture.Rd index dc0db78cb..6a24426c2 100644 --- a/man/sits_texture.Rd +++ b/man/sits_texture.Rd @@ -17,7 +17,7 @@ sits_texture(cube, ...) memsize = 4L, multicores = 2L, output_dir, - progress = FALSE + progress = TRUE ) \method{sits_texture}{derived_cube}(cube, ...) diff --git a/man/sits_uncertainty.Rd b/man/sits_uncertainty.Rd index 73c74fa73..f1c14550d 100644 --- a/man/sits_uncertainty.Rd +++ b/man/sits_uncertainty.Rd @@ -16,7 +16,8 @@ sits_uncertainty(cube, ...) multicores = 2L, memsize = 4L, output_dir, - version = "v1" + version = "v1", + progress = progress ) \method{sits_uncertainty}{probs_vector_cube}( @@ -46,6 +47,8 @@ sits_uncertainty(cube, ...) \item{version}{Version of resulting image (in the case of multiple tests).} + +\item{progress}{Check progress bar?} } \value{ An uncertainty data cube diff --git a/man/sits_variance.Rd b/man/sits_variance.Rd index 66f878cad..79828b338 100644 --- a/man/sits_variance.Rd +++ b/man/sits_variance.Rd @@ -8,59 +8,31 @@ \alias{sits_variance.default} \title{Calculate the variance of a probability cube} \usage{ -sits_variance( - cube, - window_size = 9L, - neigh_fraction = 0.5, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1" -) +sits_variance(cube, ...) \method{sits_variance}{probs_cube}( cube, + ..., window_size = 9L, neigh_fraction = 0.5, memsize = 4L, multicores = 2L, output_dir, - version = "v1" + version = "v1", + progress = TRUE ) -\method{sits_variance}{raster_cube}( - cube, - window_size = 7L, - neigh_fraction = 0.5, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1" -) +\method{sits_variance}{raster_cube}(cube, ...) -\method{sits_variance}{derived_cube}( - cube, - window_size = 7L, - neigh_fraction = 0.5, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1" -) +\method{sits_variance}{derived_cube}(cube, ...) -\method{sits_variance}{default}( - cube, - window_size = 7L, - neigh_fraction = 0.5, - memsize = 4L, - multicores = 2L, - output_dir, - version = "v1" -) +\method{sits_variance}{default}(cube, ...) } \arguments{ \item{cube}{Probability data cube (class "probs_cube")} +\item{...}{Parameters for specific functions} + \item{window_size}{Size of the neighborhood (odd integer)} \item{neigh_fraction}{Fraction of neighbors with highest probability @@ -77,6 +49,8 @@ smoothing (integer, min = 1, max = 16384)} \item{version}{Version of resulting image (character vector of length 1)} + +\item{progress}{Check progress bar?} } \value{ A variance data cube. diff --git a/tests/testthat/test-accuracy.R b/tests/testthat/test-accuracy.R index 33cd62277..05a8bb2c4 100644 --- a/tests/testthat/test-accuracy.R +++ b/tests/testthat/test-accuracy.R @@ -2,7 +2,7 @@ test_that("conf_matrix -2 classes", { data(cerrado_2classes) set.seed(1234) train_data <- sits_sample(cerrado_2classes, frac = 0.5) - test_data <- sits_sample(cerrado_2classes, frac = 0.5) + test_data <- sits_sample(cerrado_2classes, frac = 0.5) rfor_model <- sits_train(train_data, sits_rfor(verbose = FALSE)) points_class <- sits_classify( data = test_data, @@ -23,7 +23,7 @@ test_that("conf_matrix - more than 2 classes", { set.seed(1234) data(samples_modis_ndvi) train_data <- sits_sample(samples_modis_ndvi, frac = 0.5) - test_data <- sits_sample(samples_modis_ndvi, frac = 0.5) + test_data <- sits_sample(samples_modis_ndvi, frac = 0.5) rfor_model <- sits_train(train_data, sits_rfor()) points_class <- sits_classify( data = test_data, @@ -155,17 +155,17 @@ test_that("Accuracy areas", { # alternative: use a `sf` object samples_sf <- samples_csv |> - sf::st_as_sf( - coords = c("longitude", "latitude"), crs = 4326 - ) |> - dplyr::rename("geom" = "geometry") + sf::st_as_sf( + coords = c("longitude", "latitude"), crs = 4326 + ) |> + dplyr::rename("geom" = "geometry") as3 <- sits_accuracy(label_cube, validation = samples_sf) expect_true(as.numeric(as3$area_pixels["Forest"]) > - as3$area_pixels["Pasture"]) + as3$area_pixels["Pasture"]) expect_equal(as.numeric(as3$accuracy$overall), - expected = 0.75, - tolerance = 0.5 + expected = 0.75, + tolerance = 0.5 ) }) @@ -220,10 +220,9 @@ test_that("Accuracy areas when samples labels do not match cube labels", { ) expect_true(as.numeric(acc$area_pixels["Forest"]) > - acc$area_pixels["Cerrado"]) + acc$area_pixels["Cerrado"]) expect_equal(as.numeric(acc$accuracy$overall), - expected = 0.33, - tolerance = 0.5 + expected = 0.33, + tolerance = 0.5 ) - }) diff --git a/tests/testthat/test-active_learning.R b/tests/testthat/test-active_learning.R index 19eb1e9e2..f22caf712 100644 --- a/tests/testthat/test-active_learning.R +++ b/tests/testthat/test-active_learning.R @@ -26,7 +26,8 @@ test_that("Suggested samples have low confidence, high entropy", { uncert_cube <- sits_uncertainty( probs_cube, type = "least", - output_dir = output_dir + output_dir = output_dir, + progress = FALSE ) # Get sample suggestions. diff --git a/tests/testthat/test-apply.R b/tests/testthat/test-apply.R index d591af1fd..319f7675f 100644 --- a/tests/testthat/test-apply.R +++ b/tests/testthat/test-apply.R @@ -1,4 +1,5 @@ test_that("Testing index generation", { + Sys.setenv("SITS_DOCUMENTATION_MODE" = "TRUE") # Create a cube with two bands s2_cube <- tryCatch( { @@ -28,8 +29,8 @@ test_that("Testing index generation", { } unlink(list.files(dir_images, - pattern = "\\.tif$", - full.names = TRUE + pattern = "\\.tif$", + full.names = TRUE )) # Regularize cube gc_cube <- suppressWarnings( @@ -44,10 +45,10 @@ test_that("Testing index generation", { ) # Calculate EVI gc_cube_new <- sits_apply(gc_cube, - EVI = 2.5 * (B8A - B05) / (B8A + 2.4 * B05 + 1), - multicores = 1, - output_dir = dir_images, - progress = FALSE + EVI = 2.5 * (B8A - B05) / (B8A + 2.4 * B05 + 1), + multicores = 1, + output_dir = dir_images, + progress = FALSE ) # Test EVI @@ -85,14 +86,14 @@ test_that("Testing index generation", { gc_cube_new <- sits_apply(gc_cube_new, - CIRE = B8A / B05 - 1, - normalized = FALSE, - multicores = 1, - output_dir = dir_images, - progress = FALSE + CIRE = B8A / B05 - 1, + normalized = FALSE, + multicores = 1, + output_dir = dir_images, + progress = FALSE ) expect_true(all(sits_bands(gc_cube_new) %in% - c("CIRE", "EVI", "B05", "B8A"))) + c("CIRE", "EVI", "B05", "B8A"))) file_info_cire <- .fi(gc_cube_new) |> .fi_filter_bands(bands = "CIRE") cire_band_1 <- .raster_open_rast(file_info_cire$path[[1]]) @@ -109,6 +110,7 @@ test_that("Testing index generation", { }) test_that("Kernel functions", { + Sys.setenv("SITS_DOCUMENTATION_MODE" = "TRUE") data_dir <- system.file("extdata/raster/mod13q1", package = "sits") cube <- sits_cube( source = "BDC", @@ -147,8 +149,8 @@ test_that("Kernel functions", { multicores = 1, progress = FALSE ) - } - ) + }) + Sys.setenv("SITS_DOCUMENTATION_MODE" = "TRUE") cube_mean <- sits_apply( data = cube, output_dir = tempdir(), @@ -222,8 +224,8 @@ test_that("Kernel functions", { expect_true(max_1 == max_2) tif_files <- grep("tif", - list.files(tempdir(), full.names = TRUE), - value = TRUE + list.files(tempdir(), full.names = TRUE), + value = TRUE ) success <- file.remove(tif_files) @@ -248,22 +250,18 @@ test_that("Error", { dir.create(output_dir) } unlink(list.files(output_dir, - pattern = "\\.tif$", - full.names = TRUE + pattern = "\\.tif$", + full.names = TRUE )) - - Sys.setenv("SITS_DOCUMENTATION_MODE" = "FALSE") - expect_warning({ - cube_median <- sits_apply( - data = sinop, - output_dir = tempdir(), - NDVI = w_median(NDVI), - window_size = 3, - memsize = 4, - multicores = 2, - progress = FALSE - ) - }) + cube_median <- sits_apply( + data = sinop, + output_dir = tempdir(), + NDVI = w_median(NDVI), + window_size = 3, + memsize = 4, + multicores = 2, + progress = FALSE + ) sinop_probs <- sits_classify( data = sinop, ml_model = rfor_model, diff --git a/tests/testthat/test-bands.R b/tests/testthat/test-bands.R index e58506a11..e22a14c12 100644 --- a/tests/testthat/test-bands.R +++ b/tests/testthat/test-bands.R @@ -1,10 +1,14 @@ test_that("band rename", { bands <- sits_bands(point_mt_6bands) - point_mt_6bands <- .band_rename(point_mt_6bands, - c("SWIR", "BLUE", "NIR08", "RED2", "EVI2", "NDVI2")) + point_mt_6bands <- .band_rename( + point_mt_6bands, + c("SWIR", "BLUE", "NIR08", "RED2", "EVI2", "NDVI2") + ) new_bands <- sits_bands(point_mt_6bands) - expect_true(all(new_bands %in% c("SWIR", "BLUE", "NIR08", - "RED2", "EVI2", "NDVI2"))) + expect_true(all(new_bands %in% c( + "SWIR", "BLUE", "NIR08", + "RED2", "EVI2", "NDVI2" + ))) data_dir <- system.file("extdata/raster/mod13q1", package = "sits") sinop <- sits_cube( source = "BDC", diff --git a/tests/testthat/test-check.R b/tests/testthat/test-check.R index afe066220..5def39689 100644 --- a/tests/testthat/test-check.R +++ b/tests/testthat/test-check.R @@ -81,8 +81,8 @@ test_that("Caller", { ) expect_error( .check_chr_within(c("a", "b"), - within = c("a", "b", "c"), - discriminator = "exactly" + within = c("a", "b", "c"), + discriminator = "exactly" ) ) # .check_chr_contains @@ -94,14 +94,14 @@ test_that("Caller", { ) expect_error( .check_chr_contains(c("a", "b", "c"), - contains = c("a", "b"), - discriminator = "none_of" + contains = c("a", "b"), + discriminator = "none_of" ) ) expect_error( .check_chr_contains(c("a", "b", "c"), - contains = c("a", "b"), - discriminator = "exactly" + contains = c("a", "b"), + discriminator = "exactly" ) ) expect_error( @@ -248,14 +248,4 @@ test_that("Caller", { expect_error( .check_file("file_does_not_exist", extensions = "xyz") ) - - # .check_warn - expect_warning( - .check_warn(.check_that(FALSE)) - ) - Sys.setenv("SITS_DOCUMENTATION_MODE" = "TRUE") - expect_false(.message_warnings()) - expect_false(.message_progress(progress = TRUE)) - Sys.setenv("SITS_DOCUMENTATION_MODE" = "FALSE") - }) diff --git a/tests/testthat/test-classification.R b/tests/testthat/test-classification.R index 91ddc8acf..cf41c30f9 100644 --- a/tests/testthat/test-classification.R +++ b/tests/testthat/test-classification.R @@ -82,7 +82,7 @@ test_that("Classify with NA values", { ) raster_cube <- sits_select(raster_cube, bands = "NDVI_NA") .fi(raster_cube) <- .fi(raster_cube) |> - dplyr::mutate(band = "NDVI") + dplyr::mutate(band = "NDVI") # preparation - create a random forest model rfor_model <- sits_train(samples_modis_ndvi, sits_rfor(num_trees = 40)) # test classification with NA @@ -117,12 +117,13 @@ test_that("Classify with exclusion mask", { dir.create(data_dir, recursive = TRUE, showWarnings = FALSE) # preparation - create exclusion mask exclusion_mask <- sf::st_as_sfc( - x = sf::st_bbox(c( - xmin = -55.63478, - ymin = -11.63328, - xmax = -55.54080, - ymax = -11.56978 - ), + x = sf::st_bbox( + c( + xmin = -55.63478, + ymin = -11.63328, + xmax = -55.54080, + ymax = -11.56978 + ), crs = "EPSG:4326" ) ) diff --git a/tests/testthat/test-clustering.R b/tests/testthat/test-clustering.R index 9e3506bae..8068d857e 100644 --- a/tests/testthat/test-clustering.R +++ b/tests/testthat/test-clustering.R @@ -18,7 +18,7 @@ test_that("Creating a dendrogram and clustering the results", { # test message expect_true(grepl("desired", messages[3])) dendro <- .cluster_dendrogram(cerrado_2classes, - bands = c("NDVI", "EVI") + bands = c("NDVI", "EVI") ) expect_true(dendro@distmat[1] > 3.0) @@ -30,7 +30,7 @@ test_that("Creating a dendrogram and clustering the results", { freq_clusters <- sits_cluster_frequency(clusters) expect_true(nrow(freq_clusters) == - (length(sits_labels(cerrado_2classes)) + 1)) + (length(sits_labels(cerrado_2classes)) + 1)) clusters_new <- dplyr::filter(clusters, cluster != 3) clean <- sits_cluster_clean(clusters_new) @@ -39,7 +39,7 @@ test_that("Creating a dendrogram and clustering the results", { expect_true(result["ARI"] > 0.30 && result["VI"] > 0.50) expect_true(all(unique(clean$cluster) %in% - unique(clusters_new$cluster))) + unique(clusters_new$cluster))) expect_true(sits_cluster_frequency(clusters_new)[3, 1] > - sits_cluster_frequency(clean)[3, 1]) + sits_cluster_frequency(clean)[3, 1]) }) diff --git a/tests/testthat/test-color.R b/tests/testthat/test-color.R index 0c5a54011..3b6b35f83 100644 --- a/tests/testthat/test-color.R +++ b/tests/testthat/test-color.R @@ -40,7 +40,7 @@ test_that("sits colors", { test_that("color errors", { colors <- sits_colors(legend = "IGBP") expect_equal(nrow(colors), 16) - expect_equal(colors[16,1]$name, "Water_Bodies") + expect_equal(colors[16, 1]$name, "Water_Bodies") }) test_that("colors_get", { @@ -79,8 +79,9 @@ test_that("legend", { Sys.getenv("SITS_DOCUMENTATION_MODE") == "TRUE") { doc_mode <- TRUE Sys.setenv("SITS_DOCUMENTATION_MODE" = "FALSE") - } else + } else { doc_mode <- FALSE + } expect_warning({ @@ -92,6 +93,7 @@ test_that("legend", { ) }) }) - if (doc_mode) + if (doc_mode) { Sys.setenv("SITS_DOCUMENTATION_MODE" = "TRUE") + } }) diff --git a/tests/testthat/test-combine_predictions.R b/tests/testthat/test-combine_predictions.R index 30a3c25a9..bb632ee8e 100644 --- a/tests/testthat/test-combine_predictions.R +++ b/tests/testthat/test-combine_predictions.R @@ -69,18 +69,19 @@ test_that("Combine predictions", { output_dir = output_dir, version = "comb_rfor_xgb_avg" ) - } - ) + }) # combine predictions uncert_rfor <- sits_uncertainty( cube = probs_rfor_cube, output_dir = output_dir, - version = "uncert-rfor" + version = "uncert-rfor", + progress = FALSE ) uncert_xgboost <- sits_uncertainty( cube = probs_xgb_cube, output_dir = output_dir, - version = "uncert-xgb" + version = "uncert-xgb", + progress = FALSE ) uncert_cubes <- list(uncert_rfor, uncert_xgboost) diff --git a/tests/testthat/test-config.R b/tests/testthat/test-config.R index 8d29628ca..71da6fcc2 100644 --- a/tests/testthat/test-config.R +++ b/tests/testthat/test-config.R @@ -41,15 +41,16 @@ test_that("User functions", { resolution = 30 ), CLOUD = .conf_new_cloud_band( - bit_mask = TRUE, - values = list( + bit_mask = TRUE, + values = list( "0" = "No Data", "127" = "Clear Pixel", - "255" = "Cloud"), + "255" = "Cloud" + ), interp_values = 1, - resampling = "near", - resolution = 30, - band_name = "QA_PIXEL" + resampling = "near", + resolution = 30, + band_name = "QA_PIXEL" ) ), satellite = "SENTINEL-2", @@ -103,4 +104,3 @@ test_that("User functions", { # restore variable value Sys.setenv("SITS_CONFIG_USER_FILE" = user_file) - diff --git a/tests/testthat/test-cube-bdc.R b/tests/testthat/test-cube-bdc.R index c92fab913..ced0399d2 100644 --- a/tests/testthat/test-cube-bdc.R +++ b/tests/testthat/test-cube-bdc.R @@ -18,7 +18,7 @@ test_that("Creating cubes from BDC - CBERS-WFI-16D", { .default = NULL ) testthat::skip_if(purrr::is_null(cbers_cube_16d), - message = "BDC is not accessible" + message = "BDC is not accessible" ) # test bands and bbox expect_true(all(sits_bands(cbers_cube_16d) %in% bands)) @@ -55,7 +55,7 @@ test_that("Creating cubes from BDC - CBERS-WFI-8D", { .default = NULL ) testthat::skip_if(purrr::is_null(cbers_cube_8d), - message = "BDC is not accessible" + message = "BDC is not accessible" ) expect_true(all(sits_bands(cbers_cube_8d) %in% bands)) bbox <- sits_bbox(cbers_cube_8d) @@ -93,7 +93,7 @@ test_that("Creating cubes from BDC - MOD13Q1-6.1 based on ROI using sf", { .default = NULL ) testthat::skip_if(purrr::is_null(modis_cube), - message = "BDC is not accessible" + message = "BDC is not accessible" ) expect_true(all(sits_bands(modis_cube) %in% c("NDVI", "EVI"))) bbox <- sits_bbox(modis_cube, as_crs = "EPSG:4326") @@ -104,10 +104,6 @@ test_that("Creating cubes from BDC - MOD13Q1-6.1 based on ROI using sf", { expect_gt(bbox["ymax"], bbox_shp["ymax"]) intersects <- .cube_intersects(modis_cube, sf_mt) expect_true(all(intersects)) - - - - }) test_that("Creating cubes from BDC - MOD13Q1-6.1 invalid roi", { expect_error( @@ -161,7 +157,7 @@ test_that("Creating cubes from BDC - LANDSAT per tile", { ) testthat::skip_if(purrr::is_null(bdc_l8_cube), - message = "BDC cube LANDSAT-OLI-16D is not accessible" + message = "BDC cube LANDSAT-OLI-16D is not accessible" ) expect_equal(bdc_l8_cube$tile, tile) expect_true(all(sits_bands(bdc_l8_cube) %in% bands)) @@ -200,7 +196,7 @@ test_that("Creating cubes from BDC - LANDSAT per roi", { ) testthat::skip_if(purrr::is_null(bdc_l8_cube), - message = "BDC cube LANDSAT-OLI-16D is not accessible" + message = "BDC cube LANDSAT-OLI-16D is not accessible" ) expect_true(all(sits_bands(bdc_l8_cube) %in% bands)) bbox_cube <- sits_bbox(bdc_l8_cube, as_crs = "EPSG:4326") @@ -240,7 +236,7 @@ test_that("Creating cubes from BDC - SENTINEL-2 - roi", { .default = NULL ) testthat::skip_if(purrr::is_null(bdc_s2_cube), - message = "BDC cube SENTINEL-2-16D is not accessible" + message = "BDC cube SENTINEL-2-16D is not accessible" ) expect_true(all(sits_bands(bdc_s2_cube) %in% c("NDVI", "EVI"))) bbox_cube <- sits_bbox(bdc_s2_cube, as_crs = "EPSG:4326") @@ -278,7 +274,7 @@ test_that("Creating cubes from BDC - SENTINEL-2 - tile", { ) testthat::skip_if(purrr::is_null(bdc_s2_cube_t), - message = "BDC cube SENTINEL-2-16D is not accessible" + message = "BDC cube SENTINEL-2-16D is not accessible" ) expect_true(all(sits_bands(bdc_s2_cube_t) %in% c("NDVI", "EVI"))) # test timeline @@ -352,8 +348,8 @@ test_that("Downloading and cropping cubes from BDC", { unlink(files) roi_ll <- .roi_as_sf(roi_xy, - default_crs = cbers_cube$crs[[1]], - as_crs = 4326 + default_crs = cbers_cube$crs[[1]], + as_crs = 4326 ) cube_local_roi_ll <- sits_cube_copy( @@ -455,7 +451,7 @@ test_that("One-year, multi-core classification in parallel", { ) testthat::skip_if(purrr::is_null(l8_cube), - message = "BDC is not accessible" + message = "BDC is not accessible" ) rfor_model <- sits_train(samples_l8_rondonia_2bands, sits_rfor()) @@ -465,18 +461,18 @@ test_that("One-year, multi-core classification in parallel", { suppressWarnings(dir.create(dir_images)) } unlink(list.files(dir_images, - pattern = "\\.tif$", - full.names = TRUE + pattern = "\\.tif$", + full.names = TRUE )) l8_probs <- sits_classify(l8_cube, - rfor_model, - roi = roi, - memsize = 8, - multicores = 2, - output_dir = dir_images, - progress = FALSE + rfor_model, + roi = roi, + memsize = 8, + multicores = 2, + output_dir = dir_images, + progress = FALSE ) rast <- .raster_open_rast(.tile_path(l8_probs)) @@ -498,6 +494,4 @@ test_that("One-year, multi-core classification in parallel", { unlink(l8_probs$file_info[[1]]$path) expect_error(.parallel_reset_node(1)) - }) - diff --git a/tests/testthat/test-cube-cdse.R b/tests/testthat/test-cube-cdse.R index 0581b9e81..cf82a3358 100644 --- a/tests/testthat/test-cube-cdse.R +++ b/tests/testthat/test-cube-cdse.R @@ -90,7 +90,7 @@ test_that("Creating Sentinel-1 RTC cubes from CDSE", { # Patch environment variables .environment_patch(cdse_env_config) # Test - cube_s1_rtc <- .try( + cube_s1_rtc <- .try( { sits_cube( source = "CDSE", @@ -113,7 +113,7 @@ test_that("Creating Sentinel-1 RTC cubes from CDSE", { testthat::skip("CDSE is not accessible") } - bbox <- sits_bbox(cube_s1_rtc[1,]) + bbox <- sits_bbox(cube_s1_rtc[1, ]) expect_true(grepl("4326", bbox[["crs"]])) expect_equal(32, bbox[["xmin"]]) expect_equal(34, bbox[["xmax"]]) diff --git a/tests/testthat/test-cube-deafrica.R b/tests/testthat/test-cube-deafrica.R index 460584c59..9843bef21 100644 --- a/tests/testthat/test-cube-deafrica.R +++ b/tests/testthat/test-cube-deafrica.R @@ -1,4 +1,3 @@ - test_that("Creating LS5-SR cubes from DEA", { landsat_cube <- .try( { @@ -6,7 +5,7 @@ test_that("Creating LS5-SR cubes from DEA", { source = "DEAFRICA", collection = "LS5-SR", bands = c("B05", "CLOUD"), - roi = c( + roi = c( lon_min = 33.546, lon_max = 34.999, lat_min = 1.427, @@ -21,7 +20,7 @@ test_that("Creating LS5-SR cubes from DEA", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("B05", "CLOUD"))) @@ -42,7 +41,7 @@ test_that("Creating LS7-SR cubes from DEA", { source = "DEAFRICA", collection = "LS7-SR", bands = c("B05", "CLOUD"), - roi = c( + roi = c( lon_min = 33.546, lon_max = 34.999, lat_min = 1.427, @@ -57,7 +56,7 @@ test_that("Creating LS7-SR cubes from DEA", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("B05", "CLOUD"))) @@ -78,7 +77,7 @@ test_that("Creating LS8-SR cubes from DEA", { source = "DEAFRICA", collection = "LS8-SR", bands = c("B05", "CLOUD"), - roi = c( + roi = c( lon_min = 33.546, lon_max = 34.999, lat_min = 1.427, @@ -93,7 +92,7 @@ test_that("Creating LS8-SR cubes from DEA", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("B05", "CLOUD"))) @@ -114,7 +113,7 @@ test_that("Creating LS9-SR cubes from DEA", { source = "DEAFRICA", collection = "LS9-SR", bands = c("B05", "CLOUD"), - roi = c( + roi = c( lon_min = 33.546, lon_max = 34.999, lat_min = 1.427, @@ -129,7 +128,7 @@ test_that("Creating LS9-SR cubes from DEA", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("B05", "CLOUD"))) @@ -166,7 +165,7 @@ test_that("Creating S2 cubes from DEA using ROI", { ) testthat::skip_if(purrr::is_null(dea_cube), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(all(sits_bands(dea_cube) %in% c("B01", "B04", "B05"))) @@ -183,7 +182,7 @@ test_that("Creating S2 cubes from DEA using tiles", { source = "DEAFRICA", collection = "SENTINEL-2-L2A", bands = c("B02", "B8A", "B11"), - tiles = c("37MDT","37MET"), + tiles = c("37MDT", "37MET"), start_date = "2019-01-01", end_date = "2019-08-28", progress = FALSE @@ -193,7 +192,7 @@ test_that("Creating S2 cubes from DEA using tiles", { ) testthat::skip_if(purrr::is_null(dea_cube), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(all(sits_bands(dea_cube) %in% c("B02", "B8A", "B11"))) @@ -201,7 +200,7 @@ test_that("Creating S2 cubes from DEA using tiles", { r <- .raster_open_rast(.tile_path(dea_cube)) expect_equal(dea_cube$xmax[[1]], .raster_xmax(r), tolerance = 1) expect_equal(dea_cube$xmin[[1]], .raster_xmin(r), tolerance = 1) - expect_true(all(dea_cube$tile %in% c("37MDT","37MET"))) + expect_true(all(dea_cube$tile %in% c("37MDT", "37MET"))) }) test_that("Creating Sentinel-1 RTC cubes from DEA using ROI", { @@ -212,7 +211,7 @@ test_that("Creating Sentinel-1 RTC cubes from DEA using ROI", { collection = "SENTINEL-1-RTC", bands = c("VV"), orbit = "descending", - roi = c( + roi = c( lon_min = 17.379, lat_min = 1.1573, lon_max = 17.410, @@ -227,7 +226,7 @@ test_that("Creating Sentinel-1 RTC cubes from DEA using ROI", { ) testthat::skip_if(purrr::is_null(cube_s1_rtc), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(sits_bands(cube_s1_rtc) == "VV") @@ -255,7 +254,7 @@ test_that("Creating Sentinel-1 RTC cubes from DEA using tiles", { ) testthat::skip_if(purrr::is_null(cube_s1_rtc), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) bbox <- sits_bbox(cube_s1_rtc) @@ -306,7 +305,7 @@ test_that("Creating Landsat-8/9 Geomedian (Annual) from DEA", { source = "DEAFRICA", collection = "GM-LS8-LS9-ANNUAL", bands = c("B05"), - roi = c( + roi = c( lon_min = 33.546, lon_max = 34.999, lat_min = 1.427, @@ -321,7 +320,7 @@ test_that("Creating Landsat-8/9 Geomedian (Annual) from DEA", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("B05"))) @@ -341,7 +340,7 @@ test_that("Creating Sentinel-2 Geomedian (Annual) from DEA", { source = "DEAFRICA", collection = "GM-S2-ANNUAL", bands = c("B05"), - roi = c( + roi = c( lon_min = 33.546, lon_max = 34.999, lat_min = 1.427, @@ -356,7 +355,7 @@ test_that("Creating Sentinel-2 Geomedian (Annual) from DEA", { ) testthat::skip_if(purrr::is_null(sentinel_cube), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(all(sits_bands(sentinel_cube) %in% c("B05"))) @@ -376,7 +375,7 @@ test_that("Creating Sentinel-2 Geomedian (Semiannual) from DEA", { source = "DEAFRICA", collection = "GM-S2-ANNUAL", bands = c("B05"), - roi = c( + roi = c( lon_min = 33.546, lon_max = 34.999, lat_min = 1.427, @@ -391,7 +390,7 @@ test_that("Creating Sentinel-2 Geomedian (Semiannual) from DEA", { ) testthat::skip_if(purrr::is_null(sentinel_cube), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(all(sits_bands(sentinel_cube) %in% c("B05"))) @@ -411,7 +410,7 @@ test_that("Creating Sentinel-2 Geomedian (Rolling) from DEA", { source = "DEAFRICA", collection = "GM-S2-ROLLING", bands = c("B05", "B8A"), - roi = c( + roi = c( lon_min = 33.546, lon_max = 34.999, lat_min = 1.427, @@ -426,7 +425,7 @@ test_that("Creating Sentinel-2 Geomedian (Rolling) from DEA", { ) testthat::skip_if(purrr::is_null(sentinel_cube), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(all(sits_bands(sentinel_cube) %in% c("B05", "B8A"))) @@ -447,7 +446,7 @@ test_that("Creating ALOS-PALSAR-MOSAIC cubes from DEA", { source = "DEAFRICA", collection = "ALOS-PALSAR-MOSAIC", bands = c("HH", "HV", "CLOUD"), - roi = c( + roi = c( lon_min = 17.379, lat_min = 1.1573, lon_max = 17.410, @@ -462,7 +461,7 @@ test_that("Creating ALOS-PALSAR-MOSAIC cubes from DEA", { ) testthat::skip_if(purrr::is_null(cube_alos), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(all(sits_bands(cube_alos) %in% c("HH", "HV", "CLOUD"))) @@ -483,7 +482,7 @@ test_that("Creating NDVI-ANOMALY cubes from DEA", { source = "DEAFRICA", collection = "NDVI-ANOMALY", bands = c("NDVI-MEAN"), - roi = c( + roi = c( lon_min = 17.379, lat_min = 1.1573, lon_max = 17.410, @@ -498,7 +497,7 @@ test_that("Creating NDVI-ANOMALY cubes from DEA", { ) testthat::skip_if(purrr::is_null(cube_ndvi), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(sits_bands(cube_ndvi) == "NDVI-MEAN") @@ -519,7 +518,7 @@ test_that("Creating RAINFALL-CHIRPS-DAILY cubes from DEA", { source = "DEAFRICA", collection = "RAINFALL-CHIRPS-DAILY", bands = c("RAINFALL"), - roi = c( + roi = c( lon_min = 17.379, lat_min = 1.1573, lon_max = 17.410, @@ -534,7 +533,7 @@ test_that("Creating RAINFALL-CHIRPS-DAILY cubes from DEA", { ) testthat::skip_if(purrr::is_null(cube_chirps), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(sits_bands(cube_chirps) == "RAINFALL") @@ -555,7 +554,7 @@ test_that("Creating RAINFALL-CHIRPS-MONTHLY cubes from DEA", { source = "DEAFRICA", collection = "RAINFALL-CHIRPS-MONTHLY", bands = c("RAINFALL"), - roi = c( + roi = c( lon_min = 17.379, lat_min = 1.1573, lon_max = 17.410, @@ -570,7 +569,7 @@ test_that("Creating RAINFALL-CHIRPS-MONTHLY cubes from DEA", { ) testthat::skip_if(purrr::is_null(cube_chirps), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(sits_bands(cube_chirps) == "RAINFALL") @@ -591,7 +590,7 @@ test_that("Creating DEM-COP-30 cubes from DEA", { source = "DEAFRICA", collection = "DEM-COP-30", bands = c("ELEVATION"), - roi = c( + roi = c( lon_min = 17.379, lat_min = 1.1573, lon_max = 17.410, @@ -604,7 +603,7 @@ test_that("Creating DEM-COP-30 cubes from DEA", { ) testthat::skip_if(purrr::is_null(cube_dem), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) expect_true(sits_bands(cube_dem) == "ELEVATION") diff --git a/tests/testthat/test-cube-deaustralia.R b/tests/testthat/test-cube-deaustralia.R index b35d3b222..236ab316a 100644 --- a/tests/testthat/test-cube-deaustralia.R +++ b/tests/testthat/test-cube-deaustralia.R @@ -5,7 +5,7 @@ test_that("Creating GA_LS5T_ARD_3 cubes from DEAustralia", { source = "DEAUSTRALIA", collection = "GA_LS5T_ARD_3", bands = c("SWIR-1", "CLOUD"), - roi = c( + roi = c( lon_min = 137.15991, lon_max = 138.18467, lat_min = -33.85777, @@ -20,7 +20,7 @@ test_that("Creating GA_LS5T_ARD_3 cubes from DEAustralia", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAustralia is not accessible" + message = "DEAustralia is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("SWIR-1", "CLOUD"))) @@ -40,7 +40,7 @@ test_that("Creating GA_LS5T_GM_CYEAR_3 cubes from DEAustralia", { source = "DEAUSTRALIA", collection = "GA_LS5T_GM_CYEAR_3", bands = c("SWIR1"), - roi = c( + roi = c( lon_min = 137.15991, lon_max = 138.18467, lat_min = -33.85777, @@ -55,7 +55,7 @@ test_that("Creating GA_LS5T_GM_CYEAR_3 cubes from DEAustralia", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAustralia is not accessible" + message = "DEAustralia is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("SWIR1"))) @@ -76,7 +76,7 @@ test_that("Creating GA_LS7E_ARD_3 cubes from DEAustralia", { source = "DEAUSTRALIA", collection = "GA_LS7E_ARD_3", bands = c("SWIR-1", "CLOUD"), - roi = c( + roi = c( lon_min = 137.15991, lon_max = 138.18467, lat_min = -33.85777, @@ -91,7 +91,7 @@ test_that("Creating GA_LS7E_ARD_3 cubes from DEAustralia", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAustralia is not accessible" + message = "DEAustralia is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("SWIR-1", "CLOUD"))) @@ -111,7 +111,7 @@ test_that("Creating GA_LS7E_GM_CYEAR_3 cubes from DEAustralia", { source = "DEAUSTRALIA", collection = "GA_LS7E_GM_CYEAR_3", bands = c("SWIR1"), - roi = c( + roi = c( lon_min = 137.15991, lon_max = 138.18467, lat_min = -33.85777, @@ -126,7 +126,7 @@ test_that("Creating GA_LS7E_GM_CYEAR_3 cubes from DEAustralia", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAustralia is not accessible" + message = "DEAustralia is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("SWIR1"))) @@ -147,7 +147,7 @@ test_that("Creating GA_LS8C_ARD_3 cubes from DEAustralia", { source = "DEAUSTRALIA", collection = "GA_LS8C_ARD_3", bands = c("NIR", "CLOUD"), - roi = c( + roi = c( lon_min = 137.15991, lon_max = 138.18467, lat_min = -33.85777, @@ -162,7 +162,7 @@ test_that("Creating GA_LS8C_ARD_3 cubes from DEAustralia", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAustralia is not accessible" + message = "DEAustralia is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("NIR", "CLOUD"))) @@ -183,7 +183,7 @@ test_that("Creating GA_LS9C_ARD_3 cubes from DEAustralia", { source = "DEAUSTRALIA", collection = "GA_LS9C_ARD_3", bands = c("NIR", "CLOUD"), - roi = c( + roi = c( lon_min = 137.15991, lon_max = 138.18467, lat_min = -33.85777, @@ -198,7 +198,7 @@ test_that("Creating GA_LS9C_ARD_3 cubes from DEAustralia", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAustralia is not accessible" + message = "DEAustralia is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("NIR", "CLOUD"))) @@ -219,7 +219,7 @@ test_that("Creating GA_LS8CLS9C_GM_CYEAR_3 cubes from DEAustralia", { source = "DEAUSTRALIA", collection = "GA_LS8CLS9C_GM_CYEAR_3", bands = c("SWIR1"), - roi = c( + roi = c( lon_min = 137.15991, lon_max = 138.18467, lat_min = -33.85777, @@ -234,7 +234,7 @@ test_that("Creating GA_LS8CLS9C_GM_CYEAR_3 cubes from DEAustralia", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAustralia is not accessible" + message = "DEAustralia is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("SWIR1"))) @@ -260,7 +260,7 @@ test_that("Creating GA_S2AM_ARD_3 cubes from DEAustralia using ROI", { "RED", "RED-EDGE-1" ), - roi = c( + roi = c( lon_min = 137.15991, lon_max = 138.18467, lat_min = -33.85777, @@ -275,7 +275,7 @@ test_that("Creating GA_S2AM_ARD_3 cubes from DEAustralia using ROI", { ) testthat::skip_if(purrr::is_null(sentinel_cube), - message = "DEAUSTRALIA is not accessible" + message = "DEAUSTRALIA is not accessible" ) expect_true(all(sits_bands(sentinel_cube) %in% c( @@ -305,7 +305,7 @@ test_that("Creating GA_S2AM_ARD_3 cubes from DEAustralia using tiles", { ) testthat::skip_if(purrr::is_null(sentinel_cube), - message = "DEAustralia is not accessible" + message = "DEAustralia is not accessible" ) expect_true(all(sits_bands(sentinel_cube) %in% c( @@ -317,7 +317,7 @@ test_that("Creating GA_S2AM_ARD_3 cubes from DEAustralia using tiles", { r <- .raster_open_rast(.tile_path(sentinel_cube)) expect_equal(sentinel_cube$xmax[[1]], .raster_xmax(r), tolerance = 1) expect_equal(sentinel_cube$xmin[[1]], .raster_xmin(r), tolerance = 1) - expect_true(all(sentinel_cube$tile %in% c("53HQE","53HPE"))) + expect_true(all(sentinel_cube$tile %in% c("53HQE", "53HPE"))) }) test_that("Creating GA_S2BM_ARD_3 cubes from DEAustralia using ROI", { @@ -332,7 +332,7 @@ test_that("Creating GA_S2BM_ARD_3 cubes from DEAustralia using ROI", { "RED", "RED-EDGE-1" ), - roi = c( + roi = c( lon_min = 137.15991, lon_max = 138.18467, lat_min = -33.85777, @@ -347,7 +347,7 @@ test_that("Creating GA_S2BM_ARD_3 cubes from DEAustralia using ROI", { ) testthat::skip_if(purrr::is_null(sentinel_cube), - message = "DEAUSTRALIA is not accessible" + message = "DEAUSTRALIA is not accessible" ) expect_true(all(sits_bands(sentinel_cube) %in% c( @@ -371,7 +371,7 @@ test_that("Creating GA_S2BM_ARD_3 cubes from DEAustralia using tiles", { "NIR-2", "SWIR-2" ), - tiles = c("53HQE","53HPE"), + tiles = c("53HQE", "53HPE"), start_date = "2019-01-01", end_date = "2019-08-28", progress = FALSE @@ -381,7 +381,7 @@ test_that("Creating GA_S2BM_ARD_3 cubes from DEAustralia using tiles", { ) testthat::skip_if(purrr::is_null(sentinel_cube), - message = "DEAustralia is not accessible" + message = "DEAustralia is not accessible" ) expect_true(all(sits_bands(sentinel_cube) %in% c( @@ -391,55 +391,56 @@ test_that("Creating GA_S2BM_ARD_3 cubes from DEAustralia using tiles", { r <- .raster_open_rast(.tile_path(sentinel_cube)) expect_equal(sentinel_cube$xmax[[1]], .raster_xmax(r), tolerance = 1) expect_equal(sentinel_cube$xmin[[1]], .raster_xmin(r), tolerance = 1) - expect_true(all(sentinel_cube$tile %in% c("53HQE","53HPE"))) + expect_true(all(sentinel_cube$tile %in% c("53HQE", "53HPE"))) }) test_that( "Creating GA_S2AM_ARD_3/GA_S2BM_ARD_3 cubes from DEAustralia using tiles", -{ - s2a_cube <- .try( - { - sits_cube( - source = "DEAUSTRALIA", - collection = "ga_s2am_ard_3", - bands = c("BLUE", "NIR-2"), - tiles = c("53HQE","53HPE"), - start_date = "2019-01-01", - end_date = "2019-08-28", - progress = FALSE - ) - }, - .default = NULL - ) - - s2b_cube <- .try( - { - sits_cube( - source = "DEAUSTRALIA", - collection = "GA_S2BM_ARD_3", - bands = c("BLUE", "RED"), - tiles = c("53HQE","53HPE"), - start_date = "2019-01-01", - end_date = "2019-08-28", - progress = FALSE - ) - }, - .default = NULL - ) - - testthat::skip_if(purrr::is_null(c(s2a_cube, s2b_cube)), - message = "DEAustralia is not accessible" - ) - - sentinel_cube <- sits_merge(s2a_cube, s2b_cube) - - expect_true(all(sits_bands(sentinel_cube) %in% c("BLUE", "NIR-2", "RED"))) - expect_equal(nrow(sentinel_cube), 2) - r <- .raster_open_rast(.tile_path(sentinel_cube)) - expect_equal(sentinel_cube[["xmax"]][[1]], .raster_xmax(r), tolerance = 1) - expect_equal(sentinel_cube[["xmin"]][[1]], .raster_xmin(r), tolerance = 1) - expect_true(all(sentinel_cube[["tile"]] %in% c("53HQE","53HPE"))) -}) + { + s2a_cube <- .try( + { + sits_cube( + source = "DEAUSTRALIA", + collection = "ga_s2am_ard_3", + bands = c("BLUE", "NIR-2"), + tiles = c("53HQE", "53HPE"), + start_date = "2019-01-01", + end_date = "2019-08-28", + progress = FALSE + ) + }, + .default = NULL + ) + + s2b_cube <- .try( + { + sits_cube( + source = "DEAUSTRALIA", + collection = "GA_S2BM_ARD_3", + bands = c("BLUE", "RED"), + tiles = c("53HQE", "53HPE"), + start_date = "2019-01-01", + end_date = "2019-08-28", + progress = FALSE + ) + }, + .default = NULL + ) + + testthat::skip_if(purrr::is_null(c(s2a_cube, s2b_cube)), + message = "DEAustralia is not accessible" + ) + + sentinel_cube <- sits_merge(s2a_cube, s2b_cube) + + expect_true(all(sits_bands(sentinel_cube) %in% c("BLUE", "NIR-2", "RED"))) + expect_equal(nrow(sentinel_cube), 2) + r <- .raster_open_rast(.tile_path(sentinel_cube)) + expect_equal(sentinel_cube[["xmax"]][[1]], .raster_xmax(r), tolerance = 1) + expect_equal(sentinel_cube[["xmin"]][[1]], .raster_xmin(r), tolerance = 1) + expect_true(all(sentinel_cube[["tile"]] %in% c("53HQE", "53HPE"))) + } +) test_that("Creating GA_LS_FC_3 cubes from DEAustralia", { landsat_cube <- .try( @@ -448,7 +449,7 @@ test_that("Creating GA_LS_FC_3 cubes from DEAustralia", { source = "DEAUSTRALIA", collection = "GA_LS_FC_3", bands = c("BS", "PV", "NPV"), - roi = c( + roi = c( lon_min = 137.15991, lon_max = 138.18467, lat_min = -33.85777, @@ -463,7 +464,7 @@ test_that("Creating GA_LS_FC_3 cubes from DEAustralia", { ) testthat::skip_if(purrr::is_null(landsat_cube), - message = "DEAustralia is not accessible" + message = "DEAustralia is not accessible" ) expect_true(all(sits_bands(landsat_cube) %in% c("BS", "PV", "NPV"))) @@ -484,7 +485,7 @@ test_that("Creating GA_S2LS_INTERTIDAL_CYEAR_3 cubes from DEAustralia", { source = "DEAUSTRALIA", collection = "GA_S2LS_INTERTIDAL_CYEAR_3", bands = c("ELEVATION", "EXPOSURE"), - roi = c( + roi = c( lon_min = 137.15991, lon_max = 138.18467, lat_min = -33.85777, @@ -499,7 +500,7 @@ test_that("Creating GA_S2LS_INTERTIDAL_CYEAR_3 cubes from DEAustralia", { ) testthat::skip_if(purrr::is_null(intertidal_cube), - message = "DEAustralia is not accessible" + message = "DEAustralia is not accessible" ) expect_true(all(sits_bands(intertidal_cube) %in% c( diff --git a/tests/testthat/test-cube-hls.R b/tests/testthat/test-cube-hls.R index c440b852a..fc7866866 100644 --- a/tests/testthat/test-cube-hls.R +++ b/tests/testthat/test-cube-hls.R @@ -19,7 +19,7 @@ test_that("Creating Harmonized Landsat Sentinel HLSS30 cubes", { "HLSS30 collection is not accessible" ) expect_true(all(sits_bands(hls_cube_s2) %in% - c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"))) + c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"))) expect_true(all(hls_cube_s2$satellite == "SENTINEL-2")) expect_true(all("20LKP" %in% hls_cube_s2$tile)) expect_true(all(.fi(hls_cube_s2)$xres == 30)) @@ -47,7 +47,7 @@ test_that("Creating Harmonized Landsat Sentinel HLSS30 cubes", { "HLSL30 collection is not accessible" ) expect_true(all(sits_bands(hls_cube_l8) %in% - c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"))) + c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"))) expect_true(all(hls_cube_l8$satellite == "LANDSAT-8")) expect_true(all(c("20LKP", "20LLP") %in% hls_cube_s2$tile)) expect_true(all(.fi(hls_cube_l8)$xres == 30)) @@ -64,16 +64,18 @@ test_that("Creating Harmonized Landsat Sentinel HLSS30 cubes", { l8_20LKP <- dplyr::filter(hls_cube_l8, tile == "20LKP") expect_true(all(sits_timeline(merge_20LKP) %in% - c(sits_timeline(l8_20LKP), sits_timeline(s2_20LKP)))) + c(sits_timeline(l8_20LKP), sits_timeline(s2_20LKP)))) netrc_file <- "~/.netrc" netrc_save <- "~/.netrc_save" file.rename(netrc_file, netrc_save) expect_error(.source_configure_access.hls_cube( - source = "HLS", collection = "HLSS30")) + source = "HLS", collection = "HLSS30" + )) expect_error(.source_items_new.hls_cube( - source = "HLS", collection = "HLSS30", stac_query = NULL)) + source = "HLS", collection = "HLSS30", stac_query = NULL + )) expect_true(file.copy(netrc_save, netrc_file)) @@ -81,13 +83,14 @@ test_that("Creating Harmonized Landsat Sentinel HLSS30 cubes", { names(conf_hls) <- "wrong.machine" utils::write.table(conf_hls, netrc_file) expect_error(.source_configure_access.hls_cube( - source = "HLS", collection = "HLSS30")) + source = "HLS", collection = "HLSS30" + )) expect_true(file.rename(netrc_save, netrc_file)) - if (file.exists("./.rcookies")) + if (file.exists("./.rcookies")) { unlink("./.rcookies") - + } }) test_that("Creating Harmonized Landsat Sentinel HLSS30 cubes using tiles", { @@ -110,7 +113,7 @@ test_that("Creating Harmonized Landsat Sentinel HLSS30 cubes using tiles", { "HLSS30 collection is not accessible" ) expect_true(all(sits_bands(hls_cube_s2) %in% - c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"))) + c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"))) expect_true(all(hls_cube_s2$satellite == "SENTINEL-2")) expect_true(all(hls_cube_s2$tile %in% c("20LKP", "20LLP"))) expect_true(all(.fi(hls_cube_s2)$xres == 30)) @@ -138,7 +141,7 @@ test_that("Creating Harmonized Landsat Sentinel HLSS30 cubes using tiles", { "HLSL30 collection is not accessible" ) expect_true(all(sits_bands(hls_cube_l8) %in% - c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"))) + c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"))) expect_true(all(hls_cube_l8$satellite == "LANDSAT-8")) expect_true(all(hls_cube_s2$tile %in% c("20LKP", "20LLP"))) expect_true(all(.fi(hls_cube_l8)$xres == 30)) @@ -149,6 +152,5 @@ test_that("Creating Harmonized Landsat Sentinel HLSS30 cubes using tiles", { s2_20LKP <- dplyr::filter(hls_cube_s2, tile == "20LKP") l8_20LKP <- dplyr::filter(hls_cube_l8, tile == "20LKP") expect_true(all(sits_timeline(merge_20LKP) %in% - c(sits_timeline(l8_20LKP), sits_timeline(s2_20LKP)))) - + c(sits_timeline(l8_20LKP), sits_timeline(s2_20LKP)))) }) diff --git a/tests/testthat/test-cube-mpc.R b/tests/testthat/test-cube-mpc.R index eba36e2be..f60cd7e50 100644 --- a/tests/testthat/test-cube-mpc.R +++ b/tests/testthat/test-cube-mpc.R @@ -78,19 +78,18 @@ test_that("Creating S2 cubes from MPC with ROI", { expect_true(.raster_nrows(rast) == cube_nrows) }) test_that("Creating Sentinel-1 GRD cubes from MPC using tiles", { - - cube_s1_grd <- sits_cube( + cube_s1_grd <- sits_cube( source = "MPC", collection = "SENTINEL-1-GRD", bands = c("VV"), orbit = "descending", - tiles = c("21LUJ","21LVJ"), + tiles = c("21LUJ", "21LVJ"), start_date = "2021-08-01", end_date = "2021-09-30", progress = FALSE ) bbox <- sits_bbox(cube_s1_grd) - roi_cube_s1 <- sits_tiles_to_roi(c("21LUJ","21LVJ")) + roi_cube_s1 <- sits_tiles_to_roi(c("21LUJ", "21LVJ")) expect_true(bbox[["xmin"]] < roi_cube_s1[["xmin"]]) expect_true(bbox[["xmax"]] > roi_cube_s1[["xmax"]]) @@ -110,7 +109,7 @@ test_that("Creating Sentinel-1 GRD cubes from MPC using tiles", { cube = cube_s1_grd, period = "P1M", res = 240, - tiles = c("21LUJ","21LVJ"), + tiles = c("21LUJ", "21LVJ"), multicores = 1, output_dir = output_dir, progress = FALSE @@ -120,17 +119,16 @@ test_that("Creating Sentinel-1 GRD cubes from MPC using tiles", { expect_true(all("EPSG:32721" %in% cube_s1_reg$crs)) bbox <- sits_bbox(cube_s1_reg, as_crs = "EPSG:4326") - roi_cube_s1 <- sits_tiles_to_roi(c("21LUJ","21LVJ")) + roi_cube_s1 <- sits_tiles_to_roi(c("21LUJ", "21LVJ")) expect_equal(bbox[["xmin"]], roi_cube_s1[["xmin"]], tolerance = 0.01) expect_equal(bbox[["xmax"]], roi_cube_s1[["xmax"]], tolerance = 0.01) expect_equal(bbox[["ymin"]], roi_cube_s1[["ymin"]], tolerance = 0.01) expect_equal(bbox[["ymax"]], roi_cube_s1[["ymax"]], tolerance = 0.01) expect_true(all(c("VV") %in% sits_bands(cube_s1_reg))) - }) test_that("Creating Sentinel-1 RTC cubes from MPC", { - cube_s1_rtc <- sits_cube( + cube_s1_rtc <- sits_cube( source = "MPC", collection = "SENTINEL-1-RTC", bands = c("VV"), @@ -140,7 +138,7 @@ test_that("Creating Sentinel-1 RTC cubes from MPC", { end_date = "2021-09-30", progress = FALSE ) - bbox <- sits_bbox(cube_s1_rtc[1,]) + bbox <- sits_bbox(cube_s1_rtc[1, ]) expect_true(grepl("32722", bbox[["crs"]])) expect_equal(117360, bbox[["xmin"]]) expect_equal(407410, bbox[["xmax"]]) @@ -162,7 +160,7 @@ test_that("Creating Sentinel-1 RTC cubes from MPC", { ) expect_equal(length(sits_timeline(cube_s1_rtc_reg)), 5) expect_true(all(c("21LXJ", "21LYJ") %in% - cube_s1_rtc_reg$tile)) + cube_s1_rtc_reg$tile)) expect_true("EPSG:32721" %in% cube_s1_rtc_reg$crs) bbox <- sits_bbox(cube_s1_rtc_reg, as_crs = "EPSG:4326") @@ -173,7 +171,6 @@ test_that("Creating Sentinel-1 RTC cubes from MPC", { expect_equal(bbox[["ymin"]], roi_cube_s1[["ymin"]], tolerance = 0.01) expect_equal(bbox[["ymax"]], roi_cube_s1[["ymax"]], tolerance = 0.01) expect_true(all(c("VV") %in% sits_bands(cube_s1_rtc_reg))) - }) test_that("Creating LANDSAT cubes from MPC with ROI", { roi <- c( @@ -244,7 +241,7 @@ test_that("Creating cubes from MPC - MOD13Q1-6.1 based on ROI using sf", { .default = NULL ) testthat::skip_if(purrr::is_null(modis_cube), - message = "MPC is not accessible" + message = "MPC is not accessible" ) expect_true(all(sits_bands(modis_cube) %in% c("NDVI", "EVI"))) bbox <- sits_bbox(modis_cube, as_crs = "EPSG:4326") @@ -255,7 +252,6 @@ test_that("Creating cubes from MPC - MOD13Q1-6.1 based on ROI using sf", { expect_gt(bbox["ymax"], bbox_shp["ymax"]) intersects <- .cube_intersects(modis_cube, sf_mt) expect_true(all(intersects)) - }) test_that("Creating cubes from MPC - MOD09A1-6.1 based on ROI using sf", { shp_file <- system.file( @@ -279,7 +275,7 @@ test_that("Creating cubes from MPC - MOD09A1-6.1 based on ROI using sf", { .default = NULL ) testthat::skip_if(purrr::is_null(modis09a1_cube), - message = "MPC is not accessible" + message = "MPC is not accessible" ) expect_true(all(sits_bands(modis09a1_cube) %in% c("BLUE", "RED", "GREEN"))) bbox <- sits_bbox(modis09a1_cube, as_crs = "EPSG:4326") @@ -293,7 +289,6 @@ test_that("Creating cubes from MPC - MOD09A1-6.1 based on ROI using sf", { tile_h13v10 <- .cube_filter_tiles(modis09a1_cube, "h13v10") expect_equal(nrow(tile_h13v10), 1) - }) test_that("Creating cubes from MPC - MOD10A1-6.1 based on ROI using sf", { shp_file <- system.file( @@ -317,7 +312,7 @@ test_that("Creating cubes from MPC - MOD10A1-6.1 based on ROI using sf", { .default = NULL ) testthat::skip_if(purrr::is_null(modis10a1_cube), - message = "MPC is not accessible" + message = "MPC is not accessible" ) expect_true(all(sits_bands(modis10a1_cube) %in% c("SNOW", "ALBEDO"))) bbox <- sits_bbox(modis10a1_cube, as_crs = "EPSG:4326") @@ -332,10 +327,9 @@ test_that("Creating cubes from MPC - MOD10A1-6.1 based on ROI using sf", { tile_h18v4 <- .cube_filter_tiles(modis10a1_cube, "h18v4") expect_equal(nrow(tile_h18v4), 1) - }) -test_that("Accessing COP-DEM-30 from MPC",{ - cube_dem <- sits_cube( +test_that("Accessing COP-DEM-30 from MPC", { + cube_dem <- sits_cube( source = "MPC", collection = "COP-DEM-GLO-30", bands = "ELEVATION", @@ -354,7 +348,7 @@ test_that("Accessing COP-DEM-30 from MPC",{ dir.create(output_dir) } - cube_dem_reg <- sits_regularize( + cube_dem_reg <- sits_regularize( cube = cube_dem, tiles = c("22LBL"), res = 100, @@ -364,7 +358,7 @@ test_that("Accessing COP-DEM-30 from MPC",{ progress = FALSE ) - cube_s2 <- sits_cube( + cube_s2 <- sits_cube( source = "MPC", collection = "SENTINEL-2-L2A", bands = c("B02", "B8A", "B11"), @@ -379,5 +373,4 @@ test_that("Accessing COP-DEM-30 from MPC",{ expect_equal(bbox_dem$ymin, bbox_s2$ymin) expect_equal(bbox_dem$xmax, bbox_s2$xmax) expect_equal(bbox_dem$ymax, bbox_s2$ymax) - }) diff --git a/tests/testthat/test-cube-terrascope.R b/tests/testthat/test-cube-terrascope.R index d7bd272fa..72cbb47a5 100644 --- a/tests/testthat/test-cube-terrascope.R +++ b/tests/testthat/test-cube-terrascope.R @@ -4,7 +4,7 @@ test_that("Creating WORLD-COVER-2021 cubes from TERRASCOPE", { sits_cube( source = "TERRASCOPE", collection = "WORLD-COVER-2021", - roi = c( + roi = c( lon_min = 137.15991, lon_max = 138.18467, lat_min = -33.85777, @@ -17,7 +17,7 @@ test_that("Creating WORLD-COVER-2021 cubes from TERRASCOPE", { ) testthat::skip_if(purrr::is_null(class_cube), - message = "TERRASCOPE is not accessible" + message = "TERRASCOPE is not accessible" ) expect_true(all(sits_bands(class_cube) %in% c("class"))) diff --git a/tests/testthat/test-cube.R b/tests/testthat/test-cube.R index 948d8f54d..12ed24e3f 100644 --- a/tests/testthat/test-cube.R +++ b/tests/testthat/test-cube.R @@ -111,15 +111,16 @@ test_that("Reading raster cube with various type of ROI", { expected_tile <- "23KNQ" # Test 1a: ROI as vector - cube <- .try({ - sits_cube( - source = "AWS", - collection = "SENTINEL-2-L2A", - roi = roi, - crs = crs, - progress = FALSE - ) - }, + cube <- .try( + { + sits_cube( + source = "AWS", + collection = "SENTINEL-2-L2A", + roi = roi, + crs = crs, + progress = FALSE + ) + }, .default = NULL ) @@ -129,18 +130,20 @@ test_that("Reading raster cube with various type of ROI", { # Test 2: ROI as SF roi_sf <- sf::st_as_sfc( x = sf::st_bbox( - roi, crs = crs + roi, + crs = crs ) ) - cube <- .try({ - sits_cube( - source = "AWS", - collection = "SENTINEL-2-L2A", - roi = roi_sf, - progress = FALSE - ) - }, + cube <- .try( + { + sits_cube( + source = "AWS", + collection = "SENTINEL-2-L2A", + roi = roi_sf, + progress = FALSE + ) + }, .default = NULL ) @@ -151,14 +154,15 @@ test_that("Reading raster cube with various type of ROI", { roi_lonlat <- roi names(roi_lonlat) <- c("lon_min", "lat_min", "lon_max", "lat_max") - cube <- .try({ - sits_cube( - source = "AWS", - collection = "SENTINEL-2-L2A", - roi = roi_lonlat, - progress = FALSE - ) - }, + cube <- .try( + { + sits_cube( + source = "AWS", + collection = "SENTINEL-2-L2A", + roi = roi_lonlat, + progress = FALSE + ) + }, .default = NULL ) @@ -173,15 +177,16 @@ test_that("Reading raster cube with various type of ROI", { roi_raster <- terra::ext(roi_raster) - cube <- .try({ - sits_cube( - source = "AWS", - collection = "SENTINEL-2-L2A", - roi = roi_raster, - crs = crs, - progress = FALSE - ) - }, + cube <- .try( + { + sits_cube( + source = "AWS", + collection = "SENTINEL-2-L2A", + roi = roi_raster, + crs = crs, + progress = FALSE + ) + }, .default = NULL ) @@ -203,19 +208,21 @@ test_that("Reading raster cube with various type of ROI", { sf::st_as_sfc( x = sf::st_bbox( - roi, crs = crs + roi, + crs = crs ) ) |> sf::st_write(shp_file, quiet = TRUE) - cube <- .try({ - sits_cube( - source = "MPC", - collection = "SENTINEL-2-L2A", - roi = shp_file, - progress = FALSE - ) - }, + cube <- .try( + { + sits_cube( + source = "MPC", + collection = "SENTINEL-2-L2A", + roi = shp_file, + progress = FALSE + ) + }, .default = NULL ) @@ -301,8 +308,11 @@ test_that("Combining Sentinel-1 with Sentinel-2 cubes", { ) testthat::expect_true( all( - sits_bands(cube_merged) %in% c(sits_bands(s2_reg), - sits_bands(s1_reg))) + sits_bands(cube_merged) %in% c( + sits_bands(s2_reg), + sits_bands(s1_reg) + ) + ) ) merged_cube <- sits_merge( s2_cube, diff --git a/tests/testthat/test-cube_copy.R b/tests/testthat/test-cube_copy.R index bbce3e36a..796ae683a 100644 --- a/tests/testthat/test-cube_copy.R +++ b/tests/testthat/test-cube_copy.R @@ -86,8 +86,10 @@ test_that("Copy remote cube works (full region)", { data_dir <- paste0(tempdir(), "/remote_copy") dir.create(data_dir, recursive = TRUE, showWarnings = FALSE) # ROI - roi <- c("lon_min" = -40.76319703, "lat_min" = -4.36079723, - "lon_max" = -40.67849202, "lat_max" = -4.29126327) + roi <- c( + "lon_min" = -40.76319703, "lat_min" = -4.36079723, + "lon_max" = -40.67849202, "lat_max" = -4.29126327 + ) # Data cube cube_s2 <- sits_cube( source = "AWS", @@ -128,8 +130,10 @@ test_that("Copy remote cube works (full region with resampling)", { data_dir <- paste0(tempdir(), "/remote_copy") dir.create(data_dir, recursive = TRUE, showWarnings = FALSE) # ROI - roi <- c("lon_min" = -40.76319703, "lat_min" = -4.36079723, - "lon_max" = -40.67849202, "lat_max" = -4.29126327) + roi <- c( + "lon_min" = -40.76319703, "lat_min" = -4.36079723, + "lon_max" = -40.67849202, "lat_max" = -4.29126327 + ) # Data cube cube_s2 <- sits_cube( source = "AWS", @@ -171,8 +175,10 @@ test_that("Copy remote cube works (specific region with resampling)", { data_dir <- paste0(tempdir(), "/remote_copy") dir.create(data_dir, recursive = TRUE, showWarnings = FALSE) # ROI - roi <- c("lon_min" = -40.76319703, "lat_min" = -4.36079723, - "lon_max" = -40.67849202, "lat_max" = -4.29126327) + roi <- c( + "lon_min" = -40.76319703, "lat_min" = -4.36079723, + "lon_max" = -40.67849202, "lat_max" = -4.29126327 + ) # Data cube cube_s2 <- sits_cube( source = "AWS", @@ -236,13 +242,13 @@ test_that("Copy invalid files", { # (skipping the first line to bypass the cube check and simulate a # cube containing invalid files) .fi(cube) <- .fi(cube) |> - dplyr::mutate( - path = ifelse( - dplyr::row_number() > 1, - paste0(path, "_invalid-file"), - path - ) - ) + dplyr::mutate( + path = ifelse( + dplyr::row_number() > 1, + paste0(path, "_invalid-file"), + path + ) + ) cube_local <- sits_cube_copy( diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index 2d329084f..df8bd1f90 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -32,7 +32,7 @@ test_that("Reading a CSV file from RASTER", { source = "BDC", collection = "MOD13Q1-6.1", data_dir = data_dir, - progress = TRUE + progress = FALSE ) csv_raster_file <- system.file("extdata/samples/samples_sinop_crop.csv", @@ -40,7 +40,8 @@ test_that("Reading a CSV file from RASTER", { ) points_poly <- sits_get_data( raster_cube, - samples = csv_raster_file + samples = csv_raster_file, + progress = FALSE ) df_csv <- utils::read.csv( @@ -442,7 +443,7 @@ test_that("Retrieving points from MPC Base Cube", { roi <- c(xmax = xmax, ymax = ymax, xmin = xmin, ymin = ymin) # load sentinel-2 cube s2_cube <- sits_cube( - source = "AWS", + source = "AWS", collection = "SENTINEL-2-L2A", start_date = "2019-06-01", end_date = "2019-08-30", @@ -484,7 +485,8 @@ test_that("Retrieving points from MPC Base Cube", { samples_ts <- suppressMessages(sits_get_data( base_cube, samples = samples, - multicores = 1 + multicores = 1, + progress = FALSE )) # validations cube_timeline <- sits_timeline(base_cube) @@ -530,7 +532,6 @@ test_that("Reading metadata from CSV file", { "id", "longitude", "latitude", "start_date", "end_date", "label" ))) - }) test_that("Working with shapefile ", { @@ -567,7 +568,10 @@ test_that("Reading data from Classified data", { progress = FALSE ) # smooth the probability cube using Bayesian statistics - bayes_cube <- sits_smooth(probs_cube, output_dir = output_dir) + bayes_cube <- sits_smooth(probs_cube, + output_dir = output_dir, + progress = FALSE + ) # label the probability cube label_cube <- sits_label_classification( bayes_cube, @@ -579,9 +583,10 @@ test_that("Reading data from Classified data", { csv_raster_file <- system.file("extdata/samples/samples_sinop_crop.csv", package = "sits" ) - points_poly <- sits_get_data(label_cube, + points_poly <- sits_get_data( + label_cube, samples = csv_raster_file, - progress = TRUE, + progress = FALSE, multicores = 1 ) expect_equal( @@ -619,8 +624,10 @@ test_that("Reading data from Classified data", { }) test_that("Reading data from Classified data from STAC", { - roi <- c("lon_min" = -55.80259, "lon_max" = -55.19900, - "lat_min" = -11.80208, "lat_max" = -11.49583) + roi <- c( + "lon_min" = -55.80259, "lon_max" = -55.19900, + "lat_min" = -11.80208, "lat_max" = -11.49583 + ) # load cube from stac class_cube <- .try( @@ -636,7 +643,7 @@ test_that("Reading data from Classified data from STAC", { ) testthat::skip_if(purrr::is_null(class_cube), - message = "TERRASCOPE is not accessible" + message = "TERRASCOPE is not accessible" ) # adapt date to work with the sinop samples @@ -644,13 +651,13 @@ test_that("Reading data from Classified data from STAC", { class_cube[["file_info"]][[1]][["end_date"]] <- "2013-10-01" # Using CSV csv_raster_file <- system.file("extdata/samples/samples_sinop_crop.csv", - package = "sits" + package = "sits" ) points_poly <- suppressWarnings( sits_get_data(class_cube, - samples = csv_raster_file, - progress = TRUE, - multicores = 1 + samples = csv_raster_file, + progress = FALSE, + multicores = 1 ) ) expect_equal(nrow(points_poly), 5) diff --git a/tests/testthat/test-debug.R b/tests/testthat/test-debug.R index b49d9c863..230a6db97 100644 --- a/tests/testthat/test-debug.R +++ b/tests/testthat/test-debug.R @@ -10,14 +10,15 @@ test_that("debug", { log_file <- list.files(paste0(tempdir(), "/.sits")) log_file <- log_file[grepl("log", log_file)] log_csv <- utils::read.csv(paste0(tempdir(), "/.sits/", log_file)) - expect_true(all(names(log_csv) %in% c("date_time", "pid", "event", - "elapsed_time", "mem_used", - "max_mem_used", "key", "value"))) + expect_true(all(names(log_csv) %in% c( + "date_time", "pid", "event", + "elapsed_time", "mem_used", + "max_mem_used", "key", "value" + ))) expect_equal(log_csv[1, "value"], " start") expect_equal(log_csv[2, "value"], " end") sits_env[["debug_flag"]] <- NULL flag <- .debug() expect_false(flag) .debug(flag = FALSE) - }) diff --git a/tests/testthat/test-file_info.R b/tests/testthat/test-file_info.R index 911ae03a5..4ba27c2ea 100644 --- a/tests/testthat/test-file_info.R +++ b/tests/testthat/test-file_info.R @@ -76,8 +76,9 @@ test_that("file_info functions", { fi2 <- .fi_filter_interval(fi, start_date = NULL, end_date = NULL) expect_equal(nrow(fi), nrow(fi2)) expect_error(.fi_filter_interval(fi, - start_date = "2019-09-01", - end_date = "2019-10-28")) + start_date = "2019-09-01", + end_date = "2019-10-28" + )) expect_error(.fi_filter_dates(fi, dates = c("2019-09-01", "2019-10-28"))) }) diff --git a/tests/testthat/test-get_probs_class.R b/tests/testthat/test-get_probs_class.R index a9121a8e9..d5ef4ba83 100644 --- a/tests/testthat/test-get_probs_class.R +++ b/tests/testthat/test-get_probs_class.R @@ -20,14 +20,17 @@ test_that("Getting data for probs and classified cube", { ) samples_sinop <- paste0(system.file( "extdata/samples/samples_sinop_crop.csv", - package = "sits")) + package = "sits" + )) probs_values <- sits_get_probs( cube = probs_cube, samples = samples_sinop ) - expect_true(all(c("longitude", "latitude", - "X", "Y", "Cerrado", "Forest", "Pasture", - "Soy_Corn") %in% colnames(probs_values))) + expect_true(all(c( + "longitude", "latitude", + "X", "Y", "Cerrado", "Forest", "Pasture", + "Soy_Corn" + ) %in% colnames(probs_values))) probs <- probs_values[1, c(5:8)] expect_true(sum(probs) > 0.99) probs2 <- probs_values[2, c(5:8)] @@ -38,12 +41,14 @@ test_that("Getting data for probs and classified cube", { samples = samples_sinop, window_size = 5L ) - expect_true(all(c("longitude", "latitude", "X", "Y", - "neighbors") %in% colnames(probs_neigh))) + expect_true(all(c( + "longitude", "latitude", "X", "Y", + "neighbors" + ) %in% colnames(probs_neigh))) - probs_mat1 <- probs_neigh[1,]$neighbors[[1]] + probs_mat1 <- probs_neigh[1, ]$neighbors[[1]] expect_true(nrow(probs_mat1) == 25) - expect_true(sum(probs_mat1[1,]) > 0.99) + expect_true(sum(probs_mat1[1, ]) > 0.99) class_cube <- sits_label_classification( cube = probs_cube, @@ -56,8 +61,7 @@ test_that("Getting data for probs and classified cube", { samples = samples_sinop ) expect_true(all(c("longitude", "latitude", "label") - %in% colnames(class_values))) + %in% colnames(class_values))) expect_true(all(unique(class_values[["label"]]) %in% - c("Forest", "Cerrado", "Pasture", "Soy_Corn"))) - + c("Forest", "Cerrado", "Pasture", "Soy_Corn"))) }) diff --git a/tests/testthat/test-labels.R b/tests/testthat/test-labels.R index 6e6ba08b2..faada38e8 100644 --- a/tests/testthat/test-labels.R +++ b/tests/testthat/test-labels.R @@ -7,8 +7,10 @@ test_that("Labels", { }) test_that("Labels from a STAC class cube", { # define roi - roi <- c("lon_min" = -55.80259, "lon_max" = -55.19900, - "lat_min" = -11.80208, "lat_max" = -11.49583) + roi <- c( + "lon_min" = -55.80259, "lon_max" = -55.19900, + "lat_min" = -11.80208, "lat_max" = -11.49583 + ) # create world cover from stac class_cube <- .try( { @@ -23,7 +25,7 @@ test_that("Labels from a STAC class cube", { ) testthat::skip_if(purrr::is_null(class_cube), - message = "TERRASCOPE is not accessible" + message = "TERRASCOPE is not accessible" ) # download class cube @@ -82,8 +84,10 @@ test_that("Relabel cubes", { }) test_that("Relabel class cube from STAC", { # define roi - roi <- c("lon_min" = -55.80259, "lon_max" = -55.19900, - "lat_min" = -11.80208, "lat_max" = -11.49583) + roi <- c( + "lon_min" = -55.80259, "lon_max" = -55.19900, + "lat_min" = -11.80208, "lat_max" = -11.49583 + ) # create world cover from stac class_cube <- .try( { @@ -97,7 +101,7 @@ test_that("Relabel class cube from STAC", { .default = NULL ) testthat::skip_if(purrr::is_null(class_cube), - message = "TERRASCOPE is not accessible" + message = "TERRASCOPE is not accessible" ) sits_labels(class_cube) <- c( "Class A", "Class B", "Class C", "Class D", "Class E", "Class F", diff --git a/tests/testthat/test-merge.R b/tests/testthat/test-merge.R index d34036efb..b925e35cd 100644 --- a/tests/testthat/test-merge.R +++ b/tests/testthat/test-merge.R @@ -17,7 +17,7 @@ test_that("same bands (1), interval, tiles (1) | regular -> regular", { ) testthat::skip_if(purrr::is_null(modis_cube), - message = "BDC is not accessible" + message = "BDC is not accessible" ) merged_cube <- sits_merge(modis_cube, modis_cube) @@ -66,7 +66,7 @@ test_that("same bands (1) | diff interval | same tiles (1) | ) testthat::skip_if(purrr::is_null(c(modis_cube_a, modis_cube_b)), - message = "BDC is not accessible" + message = "BDC is not accessible" ) expect_error(sits_merge(modis_cube_a, modis_cube_b)) @@ -108,7 +108,7 @@ test_that("diff bands (1) | diff interval | same tiles (1) | ) testthat::skip_if(purrr::is_null(c(modis_cube_a, modis_cube_b)), - message = "BDC is not accessible" + message = "BDC is not accessible" ) merged_cube <- sits_merge(modis_cube_a, modis_cube_b) @@ -159,7 +159,7 @@ test_that("same bands (1) | diff interval | diff tiles (1) | ) testthat::skip_if(purrr::is_null(c(modis_cube_a, modis_cube_b)), - message = "BDC is not accessible" + message = "BDC is not accessible" ) expect_error(sits_merge(modis_cube_a, modis_cube_b)) @@ -201,7 +201,7 @@ test_that("diff bands (1) | diff interval | diff tiles (1) | ) testthat::skip_if(purrr::is_null(c(modis_cube_a, modis_cube_b)), - message = "BDC is not accessible" + message = "BDC is not accessible" ) expect_error(sits_merge(modis_cube_a, modis_cube_b)) @@ -222,6 +222,9 @@ test_that("same bands (1) | same interval | diff tiles (2) | }, .default = NULL ) + testthat::skip_if(purrr::is_null(s2a_cube), + message = "DEAustralia is not accessible" + ) s2b_cube <- .try( { @@ -238,8 +241,8 @@ test_that("same bands (1) | same interval | diff tiles (2) | .default = NULL ) - testthat::skip_if(purrr::is_null(c(s2a_cube, s2b_cube)), - message = "DEAustralia is not accessible" + testthat::skip_if(purrr::is_null(s2b_cube), + message = "DEAustralia is not accessible" ) merged_cube <- sits_merge(s2a_cube, s2b_cube) @@ -287,7 +290,7 @@ test_that("diff bands (1) | same interval | diff tiles (1) | ) testthat::skip_if(purrr::is_null(c(s2_cube_a, s2_cube_b)), - message = "AWS is not accessible" + message = "AWS is not accessible" ) # merge @@ -330,7 +333,7 @@ test_that("same bands (1) | diff interval | same tiles (1) | ) testthat::skip_if(purrr::is_null(c(s2_cube_a, s2_cube_b)), - message = "AWS is not accessible" + message = "AWS is not accessible" ) # merge @@ -381,14 +384,14 @@ test_that("same bands (1) | diff interval | diff tiles (1) | ) testthat::skip_if(purrr::is_null(c(s2_cube_a, s2_cube_b)), - message = "AWS is not accessible" + message = "AWS is not accessible" ) # merge merged_cube <- sits_merge(s2_cube_a, s2_cube_b) - expect_equal(sits_bands(merged_cube[1,]), "B02") - expect_equal(sits_bands(merged_cube[2,]), "B02") + expect_equal(sits_bands(merged_cube[1, ]), "B02") + expect_equal(sits_bands(merged_cube[2, ]), "B02") expect_equal(unique(merged_cube[["tile"]]), c("22KGA", "22KGB")) expect_true("combined_cube" %in% class(merged_cube)) # test timeline compatibility @@ -436,13 +439,13 @@ test_that("same bands (1) | same interval | diff tiles (1) | ) testthat::skip_if(purrr::is_null(c(s2_cube_a, s2_cube_b)), - message = "AWS is not accessible" + message = "AWS is not accessible" ) # merge merged_cube <- sits_merge(s2_cube_a, s2_cube_b) - expect_equal(sits_bands(merged_cube[1,]), "B02") - expect_equal(sits_bands(merged_cube[2,]), "B02") + expect_equal(sits_bands(merged_cube[1, ]), "B02") + expect_equal(sits_bands(merged_cube[2, ]), "B02") expect_equal(unique(merged_cube[["tile"]]), c("22KGA", "22KGB")) expect_true("combined_cube" %in% class(merged_cube)) # test timeline compatibility @@ -491,16 +494,16 @@ test_that("diff bands (1) | same interval | same tiles (1) | ) testthat::skip_if(purrr::is_null(s1_cube), - message = "AWS is not accessible" + message = "AWS is not accessible" ) testthat::skip_if(purrr::is_null(s2_cube), - message = "MPC is not accessible" + message = "MPC is not accessible" ) # merge merged_cube <- sits_merge(s2_cube, s1_cube) - expect_equal(sits_bands(merged_cube[1,]), "B02") - expect_equal(sits_bands(merged_cube[2,]), "VV") + expect_equal(sits_bands(merged_cube[1, ]), "B02") + expect_equal(sits_bands(merged_cube[2, ]), "VV") expect_equal(unique(merged_cube[["tile"]]), c("22KGA", "NoTilingSystem")) expect_true("combined_cube" %in% class(merged_cube)) # test timeline compatibility @@ -520,8 +523,8 @@ test_that("diff bands (1) | same interval | same tiles (1) | source = "DEAFRICA", collection = "RAINFALL-CHIRPS-MONTHLY", roi = sits_tiles_to_roi("38LQK"), - start_date = "2022-01-01", - end_date = "2022-06-01", + start_date = "2022-01-01", + end_date = "2022-06-01", progress = FALSE ) }, @@ -547,7 +550,7 @@ test_that("diff bands (1) | same interval | same tiles (1) | ) testthat::skip_if(purrr::is_null(c(rainfall, s2b_cube)), - message = "DEAFRICA is not accessible" + message = "DEAFRICA is not accessible" ) # merge @@ -601,7 +604,7 @@ test_that("diff bands (1) | same interval | same tiles (1) | ) testthat::skip_if(purrr::is_null(c(hls_cube_s2, hls_cube_l8)), - message = "HLS is not accessible" + message = "HLS is not accessible" ) # merge @@ -652,7 +655,7 @@ test_that("combined cube | regularize", { ) testthat::skip_if(purrr::is_null(c(s2_cube, s1_cube)), - message = "MPC is not accessible" + message = "MPC is not accessible" ) # merge @@ -719,7 +722,7 @@ test_that("dem cube | regularize", { ) testthat::skip_if(purrr::is_null(c(s2_cube, dem_cube)), - message = "MPC is not accessible" + message = "MPC is not accessible" ) # Regularize S2 diff --git a/tests/testthat/test-mixture_model.R b/tests/testthat/test-mixture_model.R index 36ae735d4..aa2ac51fe 100644 --- a/tests/testthat/test-mixture_model.R +++ b/tests/testthat/test-mixture_model.R @@ -10,7 +10,7 @@ test_that("Mixture model tests", { progress = FALSE ) testthat::skip_if(purrr::is_null(s2_cube), - message = "AWS is not accessible" + message = "AWS is not accessible" ) # Delete files before check unlink(list.files(path = tempdir(), pattern = "\\.jp2$", full.names = TRUE)) @@ -74,11 +74,10 @@ test_that("Mixture model tests", { output_dir = tempdir(), rmse_band = TRUE, progress = FALSE - ) - ) + )) # Read endmembers from CSV - write.csv(em, file = paste0(tempdir(), "/mmodel.csv"), row.names = FALSE) + write.csv(em, file = paste0(tempdir(), "/mmodel.csv"), row.names = FALSE) csv_file <- paste0(tempdir(), "/mmodel.csv") reg_cube3 <- reg_cube @@ -117,7 +116,8 @@ test_that("Mixture model tests", { cube = reg_cube, samples = samples, multicores = 2, - output_dir = tempdir() + output_dir = tempdir(), + progress = FALSE ) ts_em <- sits_mixture_model( @@ -140,7 +140,8 @@ test_that("Mixture model tests", { cube = mm_rmse_csv, samples = samples, multicores = 2, - output_dir = tempdir() + output_dir = tempdir(), + progress = FALSE ) expect_equal( dplyr::bind_rows( diff --git a/tests/testthat/test-mosaic.R b/tests/testthat/test-mosaic.R index 104a2a49f..2e80f91ec 100644 --- a/tests/testthat/test-mosaic.R +++ b/tests/testthat/test-mosaic.R @@ -126,7 +126,10 @@ test_that("One-year, multicores mosaic", { expect_equal(bbox_cube[["ymin"]], bbox_roi[["ymin"]], tolerance = 0.1) expect_equal(bbox_cube[["xmax"]], bbox_roi[["xmax"]], tolerance = 0.1) expect_equal(bbox_cube[["ymax"]], bbox_roi[["ymax"]], tolerance = 0.1) - uncert_cube <- sits_uncertainty(probs_cube, output_dir = output_dir) + uncert_cube <- sits_uncertainty(probs_cube, + output_dir = output_dir, + progress = FALSE + ) mosaic_uncert <- sits_mosaic( cube = uncert_cube, roi = roi, @@ -187,7 +190,7 @@ test_that("One-date, mosaic with class cube from STAC", { .default = NULL ) testthat::skip_if(purrr::is_null(label_cube), - message = "TERRASCOPE is not accessible" + message = "TERRASCOPE is not accessible" ) # crop and reproject classified image suppressWarnings({ diff --git a/tests/testthat/test-plot.R b/tests/testthat/test-plot.R index df7ad75a2..2a2616e4e 100644 --- a/tests/testthat/test-plot.R +++ b/tests/testthat/test-plot.R @@ -50,8 +50,10 @@ test_that("Plot Time Series and Images", { rast_rgb <- p_rgb[[1]]$shp expect_true("SpatRaster" %in% class(rast_rgb)) - p_multi <- plot(sinop, band = "NDVI", - dates = c("2013-09-14", "2013-10-16", "2013-11-17")) + p_multi <- plot(sinop, + band = "NDVI", + dates = c("2013-09-14", "2013-10-16", "2013-11-17") + ) rast_multi <- p_multi[[1]]$shp expect_true("SpatRaster" %in% class(rast_multi)) @@ -75,7 +77,8 @@ test_that("Plot Time Series and Images", { expect_equal(.raster_nlayers(rast_probs_f), 1) sinop_uncert <- sits_uncertainty(sinop_probs, - output_dir = tempdir() + output_dir = tempdir(), + progress = FALSE ) p_uncert <- plot(sinop_uncert, palette = "Reds", rev = FALSE) rast_uncert <- p_uncert[[1]]$shp @@ -95,7 +98,7 @@ test_that("Plot Accuracy", { set.seed(290356) # show accuracy for a set of samples train_data <- sits_sample(samples_modis_ndvi, frac = 0.5) - test_data <- sits_sample(samples_modis_ndvi, frac = 0.5) + test_data <- sits_sample(samples_modis_ndvi, frac = 0.5) # compute a random forest model rfor_model <- sits_train(train_data, sits_rfor()) # classify training points @@ -105,20 +108,22 @@ test_that("Plot Accuracy", { # plot accuracy p_acc <- plot(acc) expect_equal(p_acc$labels$title, "Confusion matrix") - }) test_that("Plot Models", { set.seed(290356) rfor_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor()) p_model <- plot(rfor_model) - expect_equal(p_model$labels$title, - "Distribution of minimal depth and its mean") + expect_equal( + p_model$labels$title, + "Distribution of minimal depth and its mean" + ) }) test_that("Dendrogram Plot", { samples <- sits_cluster_dendro(cerrado_2classes, - bands = c("NDVI", "EVI")) + bands = c("NDVI", "EVI") + ) cluster <- .cluster_dendrogram( samples = samples, bands = c("NDVI", "EVI") @@ -150,10 +155,10 @@ test_that("Plot torch model", { test_that("SOM map plot", { set.seed(1234) som_map <- suppressWarnings(sits_som_map( - cerrado_2classes, - grid_xdim = 5, - grid_ydim = 5 - )) + cerrado_2classes, + grid_xdim = 5, + grid_ydim = 5 + )) p_som_map <- plot(som_map) expect_true(any("Cerrado" %in% p_som_map$som_properties$neuron_label)) @@ -169,6 +174,8 @@ test_that("SOM evaluate cluster plot", { cluster_purity_tb <- sits_som_evaluate_cluster(som_map) p_purity <- plot(cluster_purity_tb) - expect_equal(p_purity$labels$title, - "Confusion by cluster") + expect_equal( + p_purity$labels$title, + "Confusion by cluster" + ) }) diff --git a/tests/testthat/test-raster.R b/tests/testthat/test-raster.R index 9e70d982a..1742c2b40 100644 --- a/tests/testthat/test-raster.R +++ b/tests/testthat/test-raster.R @@ -46,7 +46,7 @@ test_that("Classification with rfor (single core)", { "Pastagem", "Soja_Milho" ) expect_true(all(sits_labels(sinop_probs) %in% - c("Cerrado", "Floresta", "Pastagem", "Soja_Milho"))) + c("Cerrado", "Floresta", "Pastagem", "Soja_Milho"))) expect_true(all(file.exists(unlist(sinop_probs$file_info[[1]]$path)))) rast <- .raster_open_rast(sinop_probs$file_info[[1]]$path[[1]]) @@ -366,7 +366,7 @@ test_that("Classification with LightTAE", { }) test_that("Classification with cloud band", { csv_file <- system.file("extdata/samples/samples_sinop_crop.csv", - package = "sits" + package = "sits" ) data_dir <- system.file("extdata/raster/mod13q1", package = "sits") cube <- sits_cube( @@ -384,7 +384,8 @@ test_that("Classification with cloud band", { output_dir = output_dir, CLOUD = ifelse(NDVI <= 0.2, 0.0002, 0.0001), memsize = 4, - multicores = 2 + multicores = 2, + progress = FALSE ) kern_cube <- sits_apply( @@ -393,7 +394,8 @@ test_that("Classification with cloud band", { NDVI_TEXTURE = w_sd(NDVI), window_size = 3, memsize = 4, - multicores = 2 + multicores = 2, + progress = FALSE ) cube_merged <- sits_merge(data1 = cloud_cube, data2 = kern_cube) @@ -458,8 +460,10 @@ test_that("Classification with post-processing", { bands <- .cube_bands(sinop2) expect_equal(bands, "NDVI") - path1 <- .tile_path(sinop2, date = "2013-09-14", - band = "NDVI") + path1 <- .tile_path(sinop2, + date = "2013-09-14", + band = "NDVI" + ) expect_true(grepl("jp2", path1)) expect_equal(.tile_source(sinop2), "BDC") @@ -490,7 +494,7 @@ test_that("Classification with post-processing", { time_tb <- .cube_timeline_acquisition(sinop2, period = "P2M", origin = NULL) expect_equal(nrow(time_tb), 6) - expect_equal(time_tb[[1,1]], as.Date("2013-09-14")) + expect_equal(time_tb[[1, 1]], as.Date("2013-09-14")) bbox <- .cube_bbox(sinop2) expect_equal(bbox[["xmin"]], -6073798) @@ -559,13 +563,17 @@ test_that("Classification with post-processing", { }) expect_error(sits_label_classification( - sinop, output_dir = tempdir())) + sinop, + output_dir = tempdir() + )) expect_error(sits_label_classification( - sinop2, output_dir = tempdir())) + sinop2, + output_dir = tempdir() + )) expect_true(all(file.exists(unlist(sinop_class$file_info[[1]]$path)))) expect_true(length(sits_timeline(sinop_class)) == - length(sits_timeline(sinop_probs))) + length(sits_timeline(sinop_probs))) rast <- .raster_open_rast(sinop_class$file_info[[1]]$path[[1]]) max_lab <- max(.raster_get_values(rast)) @@ -583,22 +591,22 @@ test_that("Classification with post-processing", { expect_true("class_cube" %in% class(new_cube4)) labels <- .cube_labels(sinop4) - expect_true(all(c("Cerrado", "Forest", "Pasture","Soy_Corn") %in% labels)) + expect_true(all(c("Cerrado", "Forest", "Pasture", "Soy_Corn") %in% labels)) labels <- .tile_labels(sinop4) - expect_true(all(c("Cerrado", "Forest", "Pasture","Soy_Corn") %in% labels)) + expect_true(all(c("Cerrado", "Forest", "Pasture", "Soy_Corn") %in% labels)) labels <- sits_labels(sinop4) - expect_true(all(c("Cerrado", "Forest", "Pasture","Soy_Corn") %in% labels)) + expect_true(all(c("Cerrado", "Forest", "Pasture", "Soy_Corn") %in% labels)) - sits_labels(sinop4) <- c("Cerrado", "Floresta", "Pastagem","Soja_Milho") + sits_labels(sinop4) <- c("Cerrado", "Floresta", "Pastagem", "Soja_Milho") labels <- sits_labels(sinop4) expect_true("Cerrado" %in% labels) - expect_equal(.tile_area_freq(sinop_class)[1,3],.tile_area_freq(sinop4)[1,3]) + expect_equal(.tile_area_freq(sinop_class)[1, 3], .tile_area_freq(sinop4)[1, 3]) expect_error(.tile_update_label( sinop_probs, - c("Cerrado", "Floresta", "Pastagem","Soja_Milho") + c("Cerrado", "Floresta", "Pastagem", "Soja_Milho") )) class(sinop4) <- "data.frame" @@ -641,7 +649,7 @@ test_that("Classification with post-processing", { expect_true(.tile_is_complete(sinop4)) # Save QML file - qml_file <- paste0(tempdir(),"/myfile.qml") + qml_file <- paste0(tempdir(), "/myfile.qml") sits_colors_qgis(sinop_class, qml_file) expect_true(file.size(qml_file) > 2000) @@ -649,20 +657,11 @@ test_that("Classification with post-processing", { sinop_probs, output_dir = output_dir, memsize = 4, - multicores = 2 + multicores = 2, + progress = FALSE ) - Sys.setenv("SITS_DOCUMENTATION_MODE" = "FALSE") - expect_message({ - object <- sits_smooth( - sinop_probs, - output_dir = output_dir, - multicores = 2, - memsize = 4 - ) - }) - expect_true(length(sits_timeline(sinop_bayes)) == - length(sits_timeline(sinop_probs))) + length(sits_timeline(sinop_probs))) r_bay <- .raster_open_rast(sinop_bayes$file_info[[1]]$path[[1]]) expect_true(.raster_nrows(r_bay) == .tile_nrows(sinop_probs)) @@ -681,7 +680,8 @@ test_that("Classification with post-processing", { neigh_fraction = 1.0, multicores = 2, memsize = 4, - version = "test_v2" + version = "test_v2", + progress = FALSE ) r_bay_2 <- .raster_open_rast(sinop_bayes_2$file_info[[1]]$path[[1]]) expect_true(.raster_nrows(r_bay_2) == .tile_nrows(sinop_probs)) @@ -697,10 +697,12 @@ test_that("Classification with post-processing", { type = "margin", output_dir = output_dir, memsize = 4, - multicores = 2 + multicores = 2, + progress = FALSE ) expect_error(sits_label_classification( - sinop_uncert, output_dir = tempdir() + sinop_uncert, + output_dir = tempdir() )) expect_true(all(file.exists(unlist(sinop_uncert$file_info[[1]]$path)))) @@ -754,8 +756,7 @@ test_that("Classification with post-processing", { expect_true(all(file.remove(unlist(sinop_uncert$file_info[[1]]$path)))) }) -test_that("Clean classification",{ - +test_that("Clean classification", { rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) data_dir <- system.file("extdata/raster/mod13q1", package = "sits") @@ -805,16 +806,20 @@ test_that("Clean classification",{ expect_equal(nrow(sum_orig), nrow(sum_clean)) expect_equal(sum(sum_orig$count), sum(sum_clean$count)) - expect_lt(sum_orig[2,4], sum_clean[2,4]) + expect_lt(sum_orig[2, 4], sum_clean[2, 4]) # test errors in sits_clean expect_error( - sits_clean(cube = sinop, - output_dir = output_dir) + sits_clean( + cube = sinop, + output_dir = output_dir + ) ) expect_error( - sits_clean(cube = sinop_probs, - output_dir = output_dir) + sits_clean( + cube = sinop_probs, + output_dir = output_dir + ) ) sp <- sinop_class class(sp) <- "data.frame" @@ -829,12 +834,13 @@ test_that("Clean classification",{ expect_equal(nrow(sum_orig), nrow(sum_clean2)) expect_equal(sum(sum_orig$count), sum(sum_clean2$count)) - expect_lt(sum_orig[2,4], sum_clean2[2,4]) - + expect_lt(sum_orig[2, 4], sum_clean2[2, 4]) }) -test_that("Clean classification with class cube from STAC",{ - cube_roi <- c("lon_min" = -62.7, "lon_max" = -62.5, - "lat_min" = -8.83 , "lat_max" = -8.70) +test_that("Clean classification with class cube from STAC", { + cube_roi <- c( + "lon_min" = -62.7, "lon_max" = -62.5, + "lat_min" = -8.83, "lat_max" = -8.70 + ) # load cube from stac to_class <- .try( @@ -850,7 +856,7 @@ test_that("Clean classification with class cube from STAC",{ .default = NULL ) testthat::skip_if(purrr::is_null(to_class), - message = "TERRASCOPE is not accessible" + message = "TERRASCOPE is not accessible" ) to_class <- sits_cube_copy( cube = to_class, @@ -889,12 +895,16 @@ test_that("Clean classification with class cube from STAC",{ # test errors in sits_clean expect_error( - sits_clean(cube = sinop, - output_dir = output_dir) + sits_clean( + cube = sinop, + output_dir = output_dir + ) ) expect_error( - sits_clean(cube = sinop_probs, - output_dir = output_dir) + sits_clean( + cube = sinop_probs, + output_dir = output_dir + ) ) unlink(to_class$file_info[[1]]$path) @@ -945,7 +955,7 @@ test_that("Raster terra interface", { prodes_dir <- system.file("extdata/raster/prodes", package = "sits") prodes_file <- list.files(prodes_dir) - r_clone <- .raster_clone(paste0(prodes_dir, "/" ,prodes_file), nlayers = 1) + r_clone <- .raster_clone(paste0(prodes_dir, "/", prodes_file), nlayers = 1) r_prodes <- .raster_open_rast(paste0(prodes_dir, "/", prodes_file)) expect_equal(nrow(r_clone), nrow(r_prodes)) expect_equal(ncol(r_clone), ncol(r_prodes)) diff --git a/tests/testthat/test-reclassify.R b/tests/testthat/test-reclassify.R index 3a82ee17f..0f3ed7967 100644 --- a/tests/testthat/test-reclassify.R +++ b/tests/testthat/test-reclassify.R @@ -11,9 +11,11 @@ test_that("One-year, multicores processing reclassify", { ), bands = "class", version = "v20220606", - labels = c("1" = "Forest", "11" = "d2012", "16" = "d2017", - "17" = "d2018", "27" = "d2019", "29" = "d2020", - "32" = "Clouds2021", "33" = "d2021"), + labels = c( + "1" = "Forest", "11" = "d2012", "16" = "d2017", + "17" = "d2018", "27" = "d2019", "29" = "d2020", + "32" = "Clouds2021", "33" = "d2021" + ), progress = FALSE ) # Open classification map @@ -146,7 +148,7 @@ test_that("One-year, reclassify different rules", { expect_equal( object = sits_labels(reclass), - expected = c("1" = "Cerrado", "2" = "Forest", "4" = "Soy_Corn") + expected = c("1" = "Cerrado", "2" = "Forest", "4" = "Soy_Corn") ) reclassv2 <- sits_reclassify( @@ -185,9 +187,11 @@ test_that("One-year, reclassify class cube from STAC", { ), bands = "class", version = "v20220606", - labels = c("1" = "Forest", "11" = "d2012", "16" = "d2017", - "17" = "d2018", "27" = "d2019", "29" = "d2020", - "32" = "Clouds2021", "33" = "d2021"), + labels = c( + "1" = "Forest", "11" = "d2012", "16" = "d2017", + "17" = "d2018", "27" = "d2019", "29" = "d2020", + "32" = "Clouds2021", "33" = "d2021" + ), progress = FALSE ) # Open classification map from STAC @@ -204,7 +208,7 @@ test_that("One-year, reclassify class cube from STAC", { .default = NULL ) testthat::skip_if(purrr::is_null(ro_class), - message = "TERRASCOPE is not accessible" + message = "TERRASCOPE is not accessible" ) # Download data from STAC ro_class <- sits_cube_copy( @@ -235,7 +239,7 @@ test_that("One-year, reclassify class cube from STAC", { sits_labels(ro_mask), c( "10" = "Tree_Cover", "20" = "Shrubland", - "30" = "Grassland", "50" = "Builtup", + "30" = "Grassland", "50" = "Builtup", "101" = "Old_Deforestation" ) ) diff --git a/tests/testthat/test-reduce.R b/tests/testthat/test-reduce.R index e8422c781..b89223fb3 100644 --- a/tests/testthat/test-reduce.R +++ b/tests/testthat/test-reduce.R @@ -28,7 +28,7 @@ test_that("Reduce cube with NDVI median", { values_median <- .raster_read_rast(.cube_paths(reduce_median)[[1]]) expect_equal( - as.integer(C_temp_median(values_cube)[4,]), values_median[4,][[1]], + as.integer(C_temp_median(values_cube)[4, ]), values_median[4, ][[1]], tolerance = 0.001 ) @@ -56,7 +56,7 @@ test_that("Reduce cube with NDVI median", { values_min <- .raster_read_rast(.cube_paths(reduce_min)[[1]]) expect_equal( - as.integer(C_temp_min(values_cube)[4,]), values_min[4,][[1]], + as.integer(C_temp_min(values_cube)[4, ]), values_min[4, ][[1]], tolerance = 0.001 ) @@ -70,7 +70,7 @@ test_that("Reduce cube with NDVI median", { values_mean <- .raster_read_rast(.cube_paths(reduce_mean)[[1]]) expect_equal( - as.integer(C_temp_mean(values_cube)[4,]), values_mean[4,][[1]], + as.integer(C_temp_mean(values_cube)[4, ]), values_mean[4, ][[1]], tolerance = 0.001 ) @@ -84,7 +84,7 @@ test_that("Reduce cube with NDVI median", { values_sum <- .raster_read_rast(.cube_paths(reduce_sum)[[1]]) expect_equal( - as.integer(C_temp_mean(values_cube)[4,]), values_mean[4,][[1]], + as.integer(C_temp_mean(values_cube)[4, ]), values_mean[4, ][[1]], tolerance = 0.001 ) @@ -98,7 +98,7 @@ test_that("Reduce cube with NDVI median", { values_std <- .raster_read_rast(.cube_paths(reduce_std)[[1]]) expect_equal( - as.integer(C_temp_std(values_cube)[4,]), values_std[4,][[1]] * 10000, + as.integer(C_temp_std(values_cube)[4, ]), values_std[4, ][[1]] * 10000, tolerance = 0.001 ) @@ -112,7 +112,7 @@ test_that("Reduce cube with NDVI median", { values_skew <- .raster_read_rast(.cube_paths(reduce_skew)[[1]]) expect_equal( - C_temp_skew(values_cube)[4,], values_skew[4,][[1]], + C_temp_skew(values_cube)[4, ], values_skew[4, ][[1]], tolerance = 0.001 ) @@ -126,7 +126,7 @@ test_that("Reduce cube with NDVI median", { values_kurt <- .raster_read_rast(.cube_paths(reduce_kurt)[[1]]) expect_equal( - C_temp_kurt(values_cube)[4,], values_kurt[4,][[1]], + C_temp_kurt(values_cube)[4, ], values_kurt[4, ][[1]], tolerance = 0.001 ) @@ -140,7 +140,7 @@ test_that("Reduce cube with NDVI median", { values_amp <- .raster_read_rast(.cube_paths(reduce_amp)[[1]]) expect_equal( - as.integer(C_temp_amplitude(values_cube)[4,]), values_amp[4,][[1]], + as.integer(C_temp_amplitude(values_cube)[4, ]), values_amp[4, ][[1]], tolerance = 0.001 ) @@ -154,7 +154,7 @@ test_that("Reduce cube with NDVI median", { values_slp <- .raster_read_rast(.cube_paths(reduce_slp)[[1]]) expect_equal( - as.integer(C_temp_fslope(values_cube)[4,]), values_slp[4,][[1]], + as.integer(C_temp_fslope(values_cube)[4, ]), values_slp[4, ][[1]], tolerance = 0.001 ) @@ -168,7 +168,7 @@ test_that("Reduce cube with NDVI median", { values_fqr <- .raster_read_rast(.cube_paths(reduce_fqr)[[1]]) expect_equal( - as.integer(C_temp_fqr(values_cube)[4,]), values_fqr[4,][[1]], + as.integer(C_temp_fqr(values_cube)[4, ]), values_fqr[4, ][[1]], tolerance = 0.001 ) reduce_tqr <- sits_reduce( @@ -181,7 +181,7 @@ test_that("Reduce cube with NDVI median", { values_tqr <- .raster_read_rast(.cube_paths(reduce_tqr)[[1]]) expect_equal( - as.integer(C_temp_tqr(values_cube)[4,]), values_tqr[4,][[1]], + as.integer(C_temp_tqr(values_cube)[4, ]), values_tqr[4, ][[1]], tolerance = 0.001 ) reduce_iqr <- sits_reduce( @@ -194,16 +194,16 @@ test_that("Reduce cube with NDVI median", { values_iqr <- .raster_read_rast(.cube_paths(reduce_iqr)[[1]]) expect_equal( - as.integer(C_temp_iqr(values_cube)[4,]), values_iqr[4,][[1]], + as.integer(C_temp_iqr(values_cube)[4, ]), values_iqr[4, ][[1]], tolerance = 0.001 ) unlink(list.files(dir_images, - pattern = "\\.tif$", - full.names = TRUE + pattern = "\\.tif$", + full.names = TRUE )) }) -test_that("Reduce samples with NDVI max",{ +test_that("Reduce samples with NDVI max", { reduced_samples <- sits_reduce( data = samples_modis_ndvi, NDVI_MAX = t_max(NDVI) @@ -224,6 +224,7 @@ test_that("Reduce samples with NDVI max",{ values_sample <- as.matrix(samples_modis_ndvi$time_series[[65]][, "NDVI"]) value_max <- reduced_samples$time_series[[65]][["NDVI-MAX"]][[1]] expect_equal( - C_temp_max(t(values_sample))[[1]], value_max, tolerance = 0.001 + C_temp_max(t(values_sample))[[1]], value_max, + tolerance = 0.001 ) }) diff --git a/tests/testthat/test-regularize.R b/tests/testthat/test-regularize.R index 19ce35dba..3a2d92817 100644 --- a/tests/testthat/test-regularize.R +++ b/tests/testthat/test-regularize.R @@ -23,7 +23,7 @@ test_that("Regularizing cubes from AWS, and extracting samples from them", { expect_error(.check_cube_is_regular(s2_cube_open)) expect_true(all(sits_bands(s2_cube_open) %in% c("B8A", "CLOUD"))) - timelines <- suppressWarnings(sits_timeline(s2_cube_open)) + timelines <- suppressWarnings(sits_timeline(s2_cube_open)) expect_equal(length(timelines), 2) expect_equal(length(timelines[["20LKP"]]), 6) expect_equal(length(timelines[["20LLP"]]), 13) @@ -63,7 +63,7 @@ test_that("Regularizing cubes from AWS, and extracting samples from them", { # Retrieving data csv_file <- system.file("extdata/samples/samples_amazonia.csv", - package = "sits" + package = "sits" ) # read sample information from CSV file and put it in a tibble @@ -178,11 +178,11 @@ test_that("Regularizing local cubes without CLOUD BAND", { } # regularize local cube local_reg_cube <- suppressWarnings(sits_regularize( - cube = local_cube, - period = "P2M", - res = 500, - output_dir = output_dir, - progress = FALSE + cube = local_cube, + period = "P2M", + res = 500, + output_dir = output_dir, + progress = FALSE )) tl_orig <- sits_timeline(local_cube) tl_reg <- sits_timeline(local_reg_cube) diff --git a/tests/testthat/test-roi.R b/tests/testthat/test-roi.R index 5adbac9e2..8d1bf09fc 100644 --- a/tests/testthat/test-roi.R +++ b/tests/testthat/test-roi.R @@ -88,10 +88,9 @@ test_that("bbox as sf", { .default = NULL ) testthat::skip_if(purrr::is_null(s2_cube_s2a), - message = "MPC is not accessible" + message = "MPC is not accessible" ) expect_warning(sits_bbox(s2_cube_s2a)) - }) test_that("Functions that work with ROI", { diff --git a/tests/testthat/test-samples.R b/tests/testthat/test-samples.R index c0faf28b9..e5283551e 100644 --- a/tests/testthat/test-samples.R +++ b/tests/testthat/test-samples.R @@ -46,36 +46,45 @@ test_that("Sampling design", { progress = FALSE ) # estimated UA for classes - expected_ua <- c(Cerrado = 0.75, Forest = 0.9, - Pasture = 0.8, Soy_Corn = 0.8) + expected_ua <- c( + Cerrado = 0.75, Forest = 0.9, + Pasture = 0.8, Soy_Corn = 0.8 + ) sampling_design <- sits_sampling_design(label_cube, expected_ua, - alloc_options = c(100)) + alloc_options = c(100) + ) - expect_true(all(c("prop", "expected_ua", "std_dev", "equal", - "alloc_100", "alloc_prop") - %in% colnames(sampling_design))) + expect_true(all(c( + "prop", "expected_ua", "std_dev", "equal", + "alloc_100", "alloc_prop" + ) + %in% colnames(sampling_design))) # select samples - shp_file <- paste0(tempdir(),"/strata.shp") + shp_file <- paste0(tempdir(), "/strata.shp") overhead <- 1.2 - samples <- sits_stratified_sampling(cube = label_cube, - sampling_design = sampling_design, - overhead = overhead, - alloc = "alloc_prop", - shp_file = shp_file, - progress = FALSE) + samples <- sits_stratified_sampling( + cube = label_cube, + sampling_design = sampling_design, + overhead = overhead, + alloc = "alloc_prop", + shp_file = shp_file, + progress = FALSE + ) expect_true(file.exists(shp_file)) - sd <- unlist(sampling_design[,5], use.names = FALSE) - expect_equal(sum(ceiling(sd*overhead)), nrow(samples), tolerance = 10) + sd <- unlist(sampling_design[, 5], use.names = FALSE) + expect_equal(sum(ceiling(sd * overhead)), nrow(samples), tolerance = 10) sf_shp <- sf::st_read(shp_file) expect_true(all(sf::st_geometry_type(sf_shp) == "POINT")) }) test_that("Sampling design with class cube from STAC", { # define roi - roi <- c("lon_min" = -55.80259, "lon_max" = -55.19900, - "lat_min" = -11.80208, "lat_max" = -11.49583) + roi <- c( + "lon_min" = -55.80259, "lon_max" = -55.19900, + "lat_min" = -11.80208, "lat_max" = -11.49583 + ) # load cube from stac class_cube <- .try( { @@ -89,7 +98,7 @@ test_that("Sampling design with class cube from STAC", { .default = NULL ) testthat::skip_if(purrr::is_null(class_cube), - message = "TERRASCOPE is not accessible" + message = "TERRASCOPE is not accessible" ) # download data class_cube <- sits_cube_copy( @@ -102,23 +111,27 @@ test_that("Sampling design with class cube from STAC", { # create sampling design sampling_design <- sits_sampling_design(class_cube) - expect_true(all(c("prop", "expected_ua", "std_dev", "equal", - "alloc_100", "alloc_75", "alloc_50", "alloc_prop") - %in% colnames(sampling_design))) + expect_true(all(c( + "prop", "expected_ua", "std_dev", "equal", + "alloc_100", "alloc_75", "alloc_50", "alloc_prop" + ) + %in% colnames(sampling_design))) # select samples - shp_file <- paste0(tempdir(),"/strata.shp") + shp_file <- paste0(tempdir(), "/strata.shp") overhead <- 1.2 - samples <- sits_stratified_sampling(cube = class_cube, - sampling_design = sampling_design, - overhead = overhead, - alloc = "alloc_prop", - shp_file = shp_file, - progress = FALSE) + samples <- sits_stratified_sampling( + cube = class_cube, + sampling_design = sampling_design, + overhead = overhead, + alloc = "alloc_prop", + shp_file = shp_file, + progress = FALSE + ) expect_true(file.exists(shp_file)) - sd <- unlist(sampling_design[,5], use.names = FALSE) - expect_equal(sum(ceiling(sd*overhead)), nrow(samples), tolerance = 10) + sd <- unlist(sampling_design[, 5], use.names = FALSE) + expect_equal(sum(ceiling(sd * overhead)), nrow(samples), tolerance = 10) sf_shp <- sf::st_read(shp_file) expect_true(all(sf::st_geometry_type(sf_shp) == "POINT")) diff --git a/tests/testthat/test-segmentation.R b/tests/testthat/test-segmentation.R index 06a6951c3..3aaa47d8b 100644 --- a/tests/testthat/test-segmentation.R +++ b/tests/testthat/test-segmentation.R @@ -75,7 +75,8 @@ test_that("Segmentation", { # Train a rf model samples_filt <- sits_apply(samples_modis_ndvi, - NDVI = sits_sgolay(NDVI)) + NDVI = sits_sgolay(NDVI) + ) rfor_model <- sits_train(samples_filt, sits_rfor()) # Create a probability vector cube @@ -143,7 +144,7 @@ test_that("Segmentation", { "class" %in% colnames(vector_class) ) p_class_segs <- plot(class_segs) - sf_segs <- p_class_segs[[1]]$shp + sf_segs <- p_class_segs[[1]]$shp bbox <- sf::st_bbox(sf_segs) expect_true(bbox[["xmin"]] < bbox[["xmax"]]) expect_true(bbox[["ymin"]] < bbox[["ymax"]]) @@ -158,10 +159,11 @@ test_that("Segmentation", { memsize = 4, progress = FALSE ) - }) uncert_vect <- sits_uncertainty(probs_segs, - output_dir = output_dir) + output_dir = output_dir, + progress = FALSE + ) p_uncert_vect <- plot(uncert_vect) shp_uncert <- p_uncert_vect[[1]]$shp @@ -174,7 +176,7 @@ test_that("Segmentation", { expect_equal(nrow(sf_uncert), nrow(vector_class)) expect_true(all(sits_labels(rfor_model) %in% colnames(sf_uncert))) }) -test_that("Segmentation of large files",{ +test_that("Segmentation of large files", { set.seed(29031956) modis_cube <- .try( { @@ -191,7 +193,7 @@ test_that("Segmentation of large files",{ .default = NULL ) testthat::skip_if(purrr::is_null(modis_cube), - message = "BDC is not accessible" + message = "BDC is not accessible" ) output_dir <- paste0(tempdir(), "/segs") if (!dir.exists(output_dir)) { diff --git a/tests/testthat/test-sf.R b/tests/testthat/test-sf.R index e91d4de7e..0926fc833 100644 --- a/tests/testthat/test-sf.R +++ b/tests/testthat/test-sf.R @@ -1,7 +1,7 @@ test_that("sf", { # define a shapefile to be read from the cube shp_file <- system.file("extdata/shapefiles/bdc-test/samples.shp", - package = "sits" + package = "sits" ) sf_shape <- sf::read_sf(shp_file) sf_object <- sf_shape @@ -14,17 +14,17 @@ test_that("sf", { expect_warning( .sf_to_tibble( - sf_object = sf_object, - label_attr = "label", - label = "Crop", - n_sam_pol = 10, - start_date = "2020-01-01", - end_date = "2020-12-31" + sf_object = sf_object, + label_attr = "label", + label = "Crop", + n_sam_pol = 10, + start_date = "2020-01-01", + end_date = "2020-12-31" ) ) # define a shapefile to be read from the cube point_file <- system.file("extdata/shapefiles/cerrado/cerrado_forested.shp", - package = "sits" + package = "sits" ) sf_point <- sf::read_sf(point_file) # case 1 @@ -42,22 +42,24 @@ test_that("sf", { # case 3 sf_point_3 <- sf_point tb3 <- .sf_point_to_tibble(sf_point_2, - label_attr = NULL, label = "Cerradao") + label_attr = NULL, label = "Cerradao" + ) expect_equal(nrow(tb3), 40) expect_true(all(tb3$label == "Cerradao")) # polygon with labels pol_file <- system.file("extdata/shapefiles/mato_grosso/mt.shp", - package = "sits" + package = "sits" ) sf_pol <- sf::read_sf(pol_file) sf_pol$label <- "MatoGrosso" tbp <- .sf_polygon_to_tibble(sf_pol, - label_attr = NULL, - label = NULL, - n_sam_pol = 10, - sampling_type = "random") + label_attr = NULL, + label = NULL, + n_sam_pol = 10, + sampling_type = "random" + ) expect_equal(nrow(tbp), 10) expect_true(all(tbp$label == "MatoGrosso")) }) diff --git a/tests/testthat/test-smooth.R b/tests/testthat/test-smooth.R index bfc957d04..84dd7d6e2 100644 --- a/tests/testthat/test-smooth.R +++ b/tests/testthat/test-smooth.R @@ -17,12 +17,13 @@ test_that("Smoothing with exclusion mask", { dir.create(data_dir, recursive = TRUE, showWarnings = FALSE) # preparation - create exclusion mask exclusion_mask <- sf::st_as_sfc( - x = sf::st_bbox(c( - xmin = -6057482, - ymin = -1290723, - xmax = -6055209, - ymax = -1288406 - ), + x = sf::st_bbox( + c( + xmin = -6057482, + ymin = -1290723, + xmax = -6055209, + ymax = -1288406 + ), crs = .cube_crs(raster_cube) ) ) diff --git a/tests/testthat/test-som.R b/tests/testthat/test-som.R index 930ac5d82..fa7c601b2 100644 --- a/tests/testthat/test-som.R +++ b/tests/testthat/test-som.R @@ -9,8 +9,10 @@ test_that("Creating clustering using Self-organizing Maps", { )) expect_true(all(colnames(som_map$labelled_neurons) %in% - c("id_neuron", "label_samples", "count", - "prior_prob", "post_prob"))) + c( + "id_neuron", "label_samples", "count", + "prior_prob", "post_prob" + ))) expect_true(som_map$labelled_neurons[1, ]$prior_prob >= 0) expect_true(som_map$labelled_neurons[1, ]$post_prob >= 0) @@ -35,9 +37,10 @@ test_that("Creating clustering using Self-organizing Maps", { grid_xdim = 4, grid_ydim = 4, distance = "dtw" - ) - ) + )) expect_true(all(colnames(som_map$labelled_neurons) %in% - c("id_neuron", "label_samples", "count", - "prior_prob", "post_prob"))) + c( + "id_neuron", "label_samples", "count", + "prior_prob", "post_prob" + ))) }) diff --git a/tests/testthat/test-space-time-operations.R b/tests/testthat/test-space-time-operations.R index 3b132ebde..b9d69015c 100644 --- a/tests/testthat/test-space-time-operations.R +++ b/tests/testthat/test-space-time-operations.R @@ -38,5 +38,4 @@ test_that("Timeline date", { expect_true(.timeline_valid_date(as.Date("2013-09-12"), timeline)) expect_true(.timeline_valid_date(as.Date("2014-09-12"), timeline)) expect_equal(timeline, .timeline_during(timeline)) - }) diff --git a/tests/testthat/test-summary.R b/tests/testthat/test-summary.R index e7c8fedcd..cf0271b33 100644 --- a/tests/testthat/test-summary.R +++ b/tests/testthat/test-summary.R @@ -7,7 +7,7 @@ test_that("sits summary", { expect_equal(sum1$count, c(379, 131, 344, 364)) }) -test_that("summary cube",{ +test_that("summary cube", { # create a data cube from local files data_dir <- system.file("extdata/raster/mod13q1", package = "sits") cube <- sits_cube( @@ -19,14 +19,13 @@ test_that("summary cube",{ sum <- capture.output(summary(cube)) expect_true(grepl("MODIS", sum[1])) expect_true(grepl("Median", sum[4])) - }) test_that("summary sits accuracy", { data(cerrado_2classes) # split training and test data train_data <- sits_sample(cerrado_2classes, frac = 0.5) - test_data <- sits_sample(cerrado_2classes, frac = 0.5) + test_data <- sits_sample(cerrado_2classes, frac = 0.5) # train a random forest model rfor_model <- sits_train(train_data, sits_rfor()) # classify test data @@ -96,8 +95,7 @@ test_that("summary sits area accuracy", { expect_true(grepl("Cerrado", sum_as[13])) }) -test_that("summary BDC cube",{ - +test_that("summary BDC cube", { tiles <- c("007004", "007005") start_date <- "2022-05-01" end_date <- "2022-08-29" @@ -117,7 +115,7 @@ test_that("summary BDC cube",{ .default = NULL ) testthat::skip_if(purrr::is_null(cbers_cube_8d), - message = "BDC cube CBERS-WFI-8D is not accessible" + message = "BDC cube CBERS-WFI-8D is not accessible" ) sum2 <- capture.output(summary(cbers_cube_8d, tile = "007004")) expect_true(grepl("007004", sum2[4])) diff --git a/tests/testthat/test-texture.R b/tests/testthat/test-texture.R index aca499822..0e9140618 100644 --- a/tests/testthat/test-texture.R +++ b/tests/testthat/test-texture.R @@ -13,8 +13,8 @@ test_that("Testing texture generation", { suppressWarnings(dir.create(dir_images)) } unlink(list.files(dir_images, - pattern = "\\.tif$", - full.names = TRUE + pattern = "\\.tif$", + full.names = TRUE )) # Compute the NDVI variance texture <- sits_texture( diff --git a/tests/testthat/test-tibble.R b/tests/testthat/test-tibble.R index e00dc50c0..834bde87c 100644 --- a/tests/testthat/test-tibble.R +++ b/tests/testthat/test-tibble.R @@ -17,16 +17,16 @@ test_that("Align dates", { test_that("Apply", { point_ndvi <- sits_select(point_mt_6bands, bands = "NDVI") point2 <- sits_apply(point_ndvi, - NDVI_norm = (NDVI - min(NDVI)) / - (max(NDVI) - min(NDVI)) + NDVI_norm = (NDVI - min(NDVI)) / + (max(NDVI) - min(NDVI)) ) expect_equal(sum((.tibble_time_series(point2))$NDVI_norm), - 101.5388, - tolerance = 0.1 + 101.5388, + tolerance = 0.1 ) }) -test_that("Data frame",{ +test_that("Data frame", { point_df <- point_mt_6bands class(point_df) <- "data.frame" point_df_ndvi <- sits_select(point_df, bands = "NDVI") @@ -108,7 +108,7 @@ test_that("Dates", { test_that("Bbox", { bbox <- sits_bbox(samples_modis_ndvi) expect_true(all(names(bbox) %in% - c("xmin", "ymin", "xmax", "ymax", "crs"))) + c("xmin", "ymin", "xmax", "ymax", "crs"))) expect_true(bbox["xmin"] < -60.0) samples <- samples_modis_ndvi @@ -129,7 +129,7 @@ test_that("Bbox", { bbox3 <- sits_bbox(new_cube) expect_equal(bbox2, bbox3) - bad_cube <- cube[1,1:3] + bad_cube <- cube[1, 1:3] # create a raster cube bbox5 <- .try( { @@ -185,7 +185,7 @@ test_that("Values", { test_that("Apply", { samples_ndwi <- sits_apply(point_mt_6bands, - NDWI = (1.5) * (NIR - MIR) / (NIR + MIR) + NDWI = (1.5) * (NIR - MIR) / (NIR + MIR) ) expect_true("NDWI" %in% sits_bands(samples_ndwi)) diff --git a/tests/testthat/test-uncertainty.R b/tests/testthat/test-uncertainty.R index 7fe99950c..eafb7be98 100644 --- a/tests/testthat/test-uncertainty.R +++ b/tests/testthat/test-uncertainty.R @@ -24,19 +24,22 @@ test_that("uncertainty", { probs_cube, type = "entropy", output_dir = tempdir(), - version = "xgb_entropy" + version = "xgb_entropy", + progress = FALSE ) least_cube <- sits_uncertainty( probs_cube, type = "least", output_dir = tempdir(), - version = "xgb_least" + version = "xgb_least", + progress = FALSE ) margin_cube <- sits_uncertainty( probs_cube, type = "margin", output_dir = tempdir(), - version = "xgb_margin" + version = "xgb_margin", + progress = FALSE ) e_cnames <- c( diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 4b5815c7d..77b826c01 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -10,20 +10,19 @@ test_that("Utils", { expect_error(length(unique(.by(fi, col = "banda", .fi_timeline)))) expect_false(.has_name(sinop$source)) - }) test_that("Try", { - expect_error( - .try({ - sits_cube( - source = "BDC", - collection = "MOD13Q1-6.1", - data_dir = ".", - progress = FALSE - ) - .msg_error <- "no cube in directory" - }) - ) + expect_error( + .try({ + sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = ".", + progress = FALSE + ) + .msg_error <- "no cube in directory" + }) + ) expect_error( .try({ sits_cube( diff --git a/tests/testthat/test-variance.R b/tests/testthat/test-variance.R index 4cd3a111e..0daa7c376 100644 --- a/tests/testthat/test-variance.R +++ b/tests/testthat/test-variance.R @@ -52,15 +52,6 @@ test_that("Variance cube", { expect_true(max(v) <= 100) expect_true(min(v) >= 0) - # test Recovery - Sys.setenv("SITS_DOCUMENTATION_MODE" = "FALSE") - expect_message({ - obj <- sits_variance( - cube = probs_cube, - output_dir = tempdir(), - progress = FALSE - ) - }) class_cube <- sits_label_classification( probs_cube, output_dir = tempdir(), @@ -75,7 +66,8 @@ test_that("Variance cube", { df_var <- sits_variance( cube = probs_df, output_dir = tempdir(), - version = "vardf" + version = "vardf", + progress = FALSE ) rast <- .raster_open_rast(df_var$file_info[[1]]$path[[1]]) diff --git a/tests/testthat/test-view.R b/tests/testthat/test-view.R index 02a11888d..4e686ef65 100644 --- a/tests/testthat/test-view.R +++ b/tests/testthat/test-view.R @@ -69,7 +69,8 @@ test_that("View", { cube = modis_probs, output_dir = tempdir(), memsize = 4, - multicores = 1 + multicores = 1, + progress = FALSE ) v5 <- sits_view(modis_uncert) expect_true(grepl("EPSG3857", v5$x$options$crs$crsClass)) @@ -86,13 +87,14 @@ test_that("View", { # segment the image segments <- sits_segment( cube = modis_cube, - seg_fn = sits_slic(step = 5, - compactness = 1, - dist_fun = "euclidean", - avg_fun = "median", - iter = 50, - minarea = 10, - verbose = FALSE + seg_fn = sits_slic( + step = 5, + compactness = 1, + dist_fun = "euclidean", + avg_fun = "median", + iter = 50, + minarea = 10, + verbose = FALSE ), output_dir = tempdir() ) @@ -134,8 +136,10 @@ test_that("View", { }) test_that("View class cube from STAC", { - cube_roi <- c("lon_min" = -62.7, "lon_max" = -62.5, - "lat_min" = -8.83 , "lat_max" = -8.70) + cube_roi <- c( + "lon_min" = -62.7, "lon_max" = -62.5, + "lat_min" = -8.83, "lat_max" = -8.70 + ) # load cube from stac to_class <- sits_cube( @@ -145,13 +149,13 @@ test_that("View class cube from STAC", { progress = FALSE ) testthat::skip_if(purrr::is_null(to_class), - message = "TERRASCOPE is not accessible" + message = "TERRASCOPE is not accessible" ) v1 <- sits_view(to_class) expect_true("leaflet" %in% class(v1)) }) -test_that("View BDC cube",{ +test_that("View BDC cube", { cbers_cube <- tryCatch( { sits_cube( @@ -170,7 +174,7 @@ test_that("View BDC cube",{ ) testthat::skip_if(purrr::is_null(cbers_cube), - message = "BDC is not accessible" + message = "BDC is not accessible" ) v_cb <- sits_view(cbers_cube) From 7bc0b17e4eba994c0f11c2de3f8c951c64dbdcbb Mon Sep 17 00:00:00 2001 From: Felipe Date: Sat, 26 Apr 2025 20:57:10 +0000 Subject: [PATCH 103/122] update tests --- tests/testthat/test-data.R | 31 ++++++++++++------------------- 1 file changed, 12 insertions(+), 19 deletions(-) diff --git a/tests/testthat/test-data.R b/tests/testthat/test-data.R index 8123ae498..7ef3a9fab 100644 --- a/tests/testthat/test-data.R +++ b/tests/testthat/test-data.R @@ -325,7 +325,7 @@ test_that("Retrieving points from BDC using sf objects", { ) testthat::skip_if(purrr::is_null(modis_cube), - message = "MPC is not accessible" + message = "BDC is not accessible" ) points_cf <- suppressMessages(sits_get_data(modis_cube, samples = sf_cf[1:5, ], @@ -580,38 +580,34 @@ test_that("Reading data from Classified data", { csv_raster_file <- system.file("extdata/samples/samples_sinop_crop.csv", package = "sits" ) - points_poly <- sits_get_data(label_cube, - samples = csv_raster_file, - progress = TRUE, - multicores = 1 + points_poly <- sits_get_class(label_cube, + samples = csv_raster_file ) expect_equal( nrow(points_poly), nrow(read.csv(csv_raster_file)) ) expect_true( all( - c("predicted", "sits", "tbl_df", "tbl", "data.frame") %in% + c("tbl_df", "tbl", "data.frame") %in% class(points_poly) ) ) expect_equal( colnames(points_poly), c( "longitude", "latitude", - "start_date", "end_date", - "label", "cube", "predicted" + "label" ) ) # Using lat/long samples <- tibble::tibble(longitude = -55.66738, latitude = -11.76990) - point_ndvi <- sits_get_data(label_cube, samples) + point_ndvi <- sits_get_class(label_cube, samples) expect_equal(nrow(point_ndvi), 1) expect_equal( colnames(point_ndvi), c( "longitude", "latitude", - "start_date", "end_date", - "label", "cube", "predicted" + "label" ) ) unlink(probs_cube$file_info[[1]]$path) @@ -648,23 +644,20 @@ test_that("Reading data from Classified data from STAC", { package = "sits" ) points_poly <- suppressWarnings( - sits_get_data(class_cube, - samples = csv_raster_file, - progress = TRUE, - multicores = 1 + sits_get_class(class_cube, + samples = csv_raster_file ) ) - expect_equal(nrow(points_poly), 5) + expect_equal(nrow(points_poly), 18) expect_equal( colnames(points_poly), c( "longitude", "latitude", - "start_date", "end_date", - "label", "cube", "predicted" + "label" ) ) expect_true( all( - c("predicted", "sits", "tbl_df", "tbl", "data.frame") %in% + c("tbl_df", "tbl", "data.frame") %in% class(points_poly) ) ) From e683ca051cdac5efbd409f995bd42b8585742423 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sat, 26 Apr 2025 20:57:26 +0000 Subject: [PATCH 104/122] update docs --- NAMESPACE | 1 - 1 file changed, 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index c8d269ca4..507a68000 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -474,7 +474,6 @@ S3method(summary,variance_cube) export("sits_bands<-") export("sits_labels<-") export(.check_samples.default) -export(.data_combine_ts) export(impute_linear) export(sits_accuracy) export(sits_accuracy_summary) From 11ba173d0129a8f24cae5cc1ab460afe3bb247c7 Mon Sep 17 00:00:00 2001 From: Felipe Date: Mon, 28 Apr 2025 17:46:34 +0000 Subject: [PATCH 105/122] update reorganize samples strategy --- R/api_data.R | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/R/api_data.R b/R/api_data.R index 67efd0cdb..77b09142c 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -118,6 +118,8 @@ output_dir <- Sys.getenv("SITS_SAMPLES_CACHE_DIR") } + # Add ID column into samples + samples[["#..id"]] <- seq_len(nrow(samples)) # Reproject the samples and use them on-the-fly without allocate samples_rep <- .data_lazy_reproject(samples, cube, output_dir) @@ -201,13 +203,13 @@ parts <- max(multicores, length(bands) + nrow(cube)) ts[["part_id"]] <- .partitions(x = seq_len(nrow(ts)), n = parts) ts <- tidyr::nest(ts, predictors = -"part_id") - ts <- .jobs_map_parallel_dfr(ts, function(part) { + ts <- .jobs_map_sequential_dfr(ts, function(part) { part <- part[["predictors"]][[1]] part <- tidyr::unnest(part, cols = "predictors") # Combine split bands into one tibble part <- .data_reorganise_ts(part, bands) part - }, progress = FALSE) + }) # Get the first point that intersect more than one tile # eg sentinel 2 mgrs grid ts <- ts |> @@ -547,7 +549,6 @@ #' #' @return A sits tibble .data_create_tibble <- function(samples, tile, timeline) { - samples[["#..id"]] <- seq_len(nrow(samples)) samples[["cube"]] <- .tile_collection(tile) # build the sits tibble for the storing the points samples |> @@ -581,7 +582,7 @@ #' #' @return A sits tibble with all bands combined. .data_reorganise_ts <- function(ts, bands) { - # reorganise the samples + # Reorganise the samples ts <- ts |> tidyr::unnest("time_series") |> dplyr::group_by( @@ -590,7 +591,7 @@ .data[["label"]], .data[["cube"]], .data[["Index"]], .data[["tile"]], .data[["#..id"]] ) - # is there a polygon id? This occurs when we have segments + # Is there a polygon id? This occurs when we have segments if ("polygon_id" %in% colnames(ts)) { ts <- dplyr::group_by( ts, .data[["polygon_id"]], .add = TRUE From 573dcedadfdbf1f58d8acd4fb4a6eeb17a9fe58e Mon Sep 17 00:00:00 2001 From: Felipe Date: Mon, 28 Apr 2025 18:08:55 +0000 Subject: [PATCH 106/122] update docs --- R/api_data.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/api_data.R b/R/api_data.R index 77b09142c..20e21d412 100644 --- a/R/api_data.R +++ b/R/api_data.R @@ -158,7 +158,7 @@ return(timeseries) } } - # Filter samples ... + # Apply spatial and temporal filter samples <- .data_filter_samples( samples = samples, tile = tile, samples_rep = samples_rep, timeline = tl @@ -167,7 +167,7 @@ if (nrow(samples) == 0L) { return(NULL) } - # Create samples ... + # Create samples tibble format samples <- .data_create_tibble( samples = samples, tile = tile, From a931820459dc305d3c10b980877b61eadd18de66 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Mon, 28 Apr 2025 15:12:46 -0300 Subject: [PATCH 107/122] improve documentation of plot --- R/sits_plot.R | 23 ++++- R/sits_validate.R | 4 +- inst/extdata/config_colors.yml | 15 ++- man/plot.dem_cube.Rd | 6 +- man/plot.patterns.Rd | 3 +- man/plot.predicted.Rd | 3 +- man/plot.probs_vector_cube.Rd | 22 +++-- man/plot.raster_cube.Rd | 2 + man/plot.sar_cube.Rd | 2 +- man/plot.sits_accuracy.Rd | 2 +- man/plot.sits_cluster.Rd | 5 +- man/plot.uncertainty_vector_cube.Rd | 16 ++-- man/plot.variance_cube.Rd | 3 +- man/plot.vector_cube.Rd | 6 +- man/sits_accuracy.Rd | 2 +- man/sits_add_base_cube.Rd | 70 +++++++------- man/sits_as_stars.Rd | 1 - man/sits_as_terra.Rd | 1 - man/sits_classify.segs_cube.Rd | 17 ++-- man/sits_clean.Rd | 52 +++++------ man/sits_cluster_dendro.Rd | 3 +- man/sits_colors_qgis.Rd | 35 +++---- man/sits_config.Rd | 3 +- man/sits_cube.results_cube.Rd | 4 +- man/sits_cube.stac_cube.Rd | 52 ++++++----- man/sits_cube.vector_cube.Rd | 57 ++++++------ man/sits_filter.Rd | 3 +- man/sits_get_data.Rd | 14 +-- man/sits_get_data.sf.Rd | 14 +-- man/sits_get_data.shp.Rd | 15 ++- man/sits_mlp.Rd | 6 +- man/sits_predictors.Rd | 3 +- man/sits_reclassify.Rd | 137 ++++++++++++++-------------- man/sits_regularize.Rd | 6 +- man/sits_sampling_design.Rd | 6 +- man/sits_segment.Rd | 12 +-- man/sits_select.Rd | 5 +- man/sits_slic.Rd | 12 +-- man/sits_som_remove_samples.Rd | 6 +- man/sits_stratified_sampling.Rd | 13 ++- man/sits_tempcnn.Rd | 6 +- man/sits_tuning_hparams.Rd | 4 +- man/sits_validate.Rd | 20 ++-- man/sits_whittaker.Rd | 3 +- man/summary.sits_accuracy.Rd | 2 +- 45 files changed, 382 insertions(+), 314 deletions(-) diff --git a/R/sits_plot.R b/R/sits_plot.R index ad7c35992..15856d1d9 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -62,7 +62,8 @@ plot.sits <- function(x, y, ..., together = FALSE) { #' @name plot.patterns #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' @author Victor Maus, \email{vwmaus1@@gmail.com} -#' @description Plots the patterns to be used for classification +#' @description Plots the patterns (one plot per band/class combination) +#' Useful to understand the trends of time series. #' #' #' @param x Object of class "patterns". @@ -143,7 +144,8 @@ plot.patterns <- function(x, y, ..., bands = NULL, year_grid = FALSE) { #' @name plot.predicted #' @author Victor Maus, \email{vwmaus1@@gmail.com} #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @description Given a sits tibble with a set of predictions, plot them +#' @description Given a sits tibble with a set of predictions, plot them. +#' Useful to show multi-year predictions for a time series. #' #' @param x Object of class "predicted". #' @param y Ignored. @@ -362,6 +364,8 @@ plot.predicted <- function(x, y, ..., #' \item {SWIR2: ("B12", "B08", "B04")} #' \item {SWIR3: ("B12", "B8A", "B04")} #' \item {RGB: ("B04", "B03", "B02")} +#' \item {RGB-FALSE1 : ("B08", "B06", "B04")} +#' \item {RGB-FALSE2 : ("B08", "B11", "B04")} #' } #' } #' \item{\code{sits} tries to find if the bands required for one @@ -721,7 +725,11 @@ plot.dem_cube <- function(x, ..., #' @name plot.vector_cube #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' -#' @description Plot RGB raster cube +#' @description Plot vector data cube with segments on top of raster image. +#' Vector cubes have both a vector and a raster component. The vector part +#' are the segments produced by \code{\link{sits_segment}}. Their +#' visual output is controlled by "seg_color" and "line_width" parameters. +#' The raster output works in the same way as the false color and RGB plots. #' #' @param x Object of class "raster_cube". #' @param ... Further specifications for \link{plot}. @@ -962,7 +970,11 @@ plot.probs_cube <- function(x, ..., #' @title Plot probability vector cubes #' @name plot.probs_vector_cube #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @description plots a probability cube +#' @description Plots a probability vector cube, which result from +#' first running a segmentation \code{\link{sits_segment}} and then +#' running a machine learning classification model. The result is +#' a set of polygons, each with an assigned propability of belonging +#' to a specific class. #' #' @param x Object of class "probs_vector_cube". #' @param ... Further specifications for \link{plot}. @@ -1052,7 +1064,8 @@ plot.probs_vector_cube <- function(x, ..., #' @title Plot variance cubes #' @name plot.variance_cube #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @description plots a variance cube +#' @description Plots a variance cube, useful to understand how local +#' smoothing will work. #' #' @param x Object of class "variance_cube". #' @param ... Further specifications for \link{plot}. diff --git a/R/sits_validate.R b/R/sits_validate.R index 99248ba6b..80c12c580 100644 --- a/R/sits_validate.R +++ b/R/sits_validate.R @@ -156,7 +156,7 @@ sits_kfold_validate <- function(samples, #' This function returns the confusion matrix, and Kappa values. #' #' @note -#' #' When using a GPU for deep learning, \code{gpu_memory} indicates the +#' When using a GPU for deep learning, \code{gpu_memory} indicates the #' memory of the graphics card which is available for processing. #' The parameter \code{batch_size} defines the size of the matrix #' (measured in number of rows) which is sent to the GPU for classification. @@ -204,8 +204,6 @@ sits_kfold_validate <- function(samples, #' validation_split = 0.2, #' ml_method = sits_rfor() #' ) -#' } - #' } #' @export sits_validate <- function(samples, diff --git a/inst/extdata/config_colors.yml b/inst/extdata/config_colors.yml index fb9b5b220..0b6c56725 100644 --- a/inst/extdata/config_colors.yml +++ b/inst/extdata/config_colors.yml @@ -15,18 +15,26 @@ composites: NIR : ["SWIR22", "NIR08", "BLUE"] RGB : ["RED", "GREEN", "BLUE"] NIR2 : ["SWIR22", "NIR08", "RED"] + AGRI : ["NIR08", "RED", "BLUE"] + NIR3 : ["NIR08", "RED", "GREEN"] + SWIR : ["SWIR22", "SWIR16", "NIR08"] SENTINEL-2-L2A : &sentinel-2 AGRI : ["B11", "B08", "B02"] AGRI2 : ["B11", "B8A", "B02"] SWIR : ["B11", "B08", "B04"] SWIR2 : ["B12", "B08", "B04"] SWIR3 : ["B12", "B8A", "B04"] + RGB-FALSE1 : ["B08", "B06", "B04"] + RGB-FALSE2 : ["B08", "B11", "B04"] + GEOLOGY : ["B12", "B11", "B03"] RGB : ["B04", "B03", "B02"] SENTINEL-1-GRD : &sentinel-1 VH : ["VH"] VV : ["VV"] SENTINEL-1-RTC : <<: *sentinel-1 + COP-DEM-GLO-30 : + ELEVATION : ["ELEVATION"] AWS: collections: SENTINEL-2-L2A : @@ -65,9 +73,12 @@ composites: LS7-SR : <<: *landsat-tm-etm LS8-SR : &landsat-oli - SWIR : ["B06", "B05", "B04"] - RGB : ["B04", "B03", "B02"] + AGRI : ["B06", "B05", "B02"] NIR : ["B05", "B04", "B03"] + RGB : ["B04", "B03", "B02"] + SWIR : ["B07", "B05", "B04"] + LANDWATER : ["B05", "B06", "B04"] + LS9-SR : <<: *landsat-oli GM-LS8-LS9-ANNUAL : diff --git a/man/plot.dem_cube.Rd b/man/plot.dem_cube.Rd index 089c3e7d9..dca7e4e3e 100644 --- a/man/plot.dem_cube.Rd +++ b/man/plot.dem_cube.Rd @@ -62,14 +62,14 @@ The following optional parameters are available to allow for detailed } \examples{ if (sits_run_examples()) { -# obtain the DEM cube + # obtain the DEM cube dem_cube_19HBA <- sits_cube( source = "MPC", collection = "COP-DEM-GLO-30", bands = "ELEVATION", tiles = "19HBA" - ) -# plot the DEM reversing the palette + ) + # plot the DEM reversing the palette plot(dem_cube_19HBA, band = "ELEVATION") } } diff --git a/man/plot.patterns.Rd b/man/plot.patterns.Rd index 1d084c78d..d068b843d 100644 --- a/man/plot.patterns.Rd +++ b/man/plot.patterns.Rd @@ -23,7 +23,8 @@ A plot object produced by ggplot2 with one average pattern per label. } \description{ -Plots the patterns to be used for classification +Plots the patterns (one plot per band/class combination) + Useful to understand the trends of time series. } \note{ This code is reused from the dtwSat package by Victor Maus. diff --git a/man/plot.predicted.Rd b/man/plot.predicted.Rd index be96ce763..ca8ce4148 100644 --- a/man/plot.predicted.Rd +++ b/man/plot.predicted.Rd @@ -23,7 +23,8 @@ A plot object produced by ggplot2 showing the time series and its label. } \description{ -Given a sits tibble with a set of predictions, plot them +Given a sits tibble with a set of predictions, plot them. + Useful to show multi-year predictions for a time series. } \note{ This code is reused from the dtwSat package by Victor Maus. diff --git a/man/plot.probs_vector_cube.Rd b/man/plot.probs_vector_cube.Rd index ca66489c1..c1e1d4214 100644 --- a/man/plot.probs_vector_cube.Rd +++ b/man/plot.probs_vector_cube.Rd @@ -37,7 +37,11 @@ A plot containing probabilities associated to each class for each pixel. } \description{ -plots a probability cube +Plots a probability vector cube, which result from +first running a segmentation \code{\link{sits_segment}} and then +running a machine learning classification model. The result is +a set of polygons, each with an assigned propability of belonging +to a specific class. } \examples{ if (sits_run_examples()) { @@ -53,13 +57,15 @@ if (sits_run_examples()) { # segment the image segments <- sits_segment( cube = cube, - seg_fn = sits_slic(step = 5, - compactness = 1, - dist_fun = "euclidean", - avg_fun = "median", - iter = 20, - minarea = 10, - verbose = FALSE), + seg_fn = sits_slic( + step = 5, + compactness = 1, + dist_fun = "euclidean", + avg_fun = "median", + iter = 20, + minarea = 10, + verbose = FALSE + ), output_dir = tempdir() ) # classify a data cube diff --git a/man/plot.raster_cube.Rd b/man/plot.raster_cube.Rd index f1c5e4db0..e51fc994d 100644 --- a/man/plot.raster_cube.Rd +++ b/man/plot.raster_cube.Rd @@ -92,6 +92,8 @@ For example, the following composites are available for all \item {SWIR2: ("B12", "B08", "B04")} \item {SWIR3: ("B12", "B8A", "B04")} \item {RGB: ("B04", "B03", "B02")} + \item {RGB-FALSE1 : ("B08", "B06", "B04")} + \item {RGB-FALSE2 : ("B08", "B11", "B04")} } } \item{\code{sits} tries to find if the bands required for one diff --git a/man/plot.sar_cube.Rd b/man/plot.sar_cube.Rd index 03d14bf81..0074ff34c 100644 --- a/man/plot.sar_cube.Rd +++ b/man/plot.sar_cube.Rd @@ -87,7 +87,7 @@ The following optional parameters are available to allow for detailed \examples{ if (sits_run_examples()) { # create a SAR data cube from cloud services - cube_s1_grd <- sits_cube( + cube_s1_grd <- sits_cube( source = "MPC", collection = "SENTINEL-1-GRD", bands = c("VV", "VH"), diff --git a/man/plot.sits_accuracy.Rd b/man/plot.sits_accuracy.Rd index d1890aeac..98db05092 100644 --- a/man/plot.sits_accuracy.Rd +++ b/man/plot.sits_accuracy.Rd @@ -31,7 +31,7 @@ Please refer to the sits documentation available in if (sits_run_examples()) { # show accuracy for a set of samples train_data <- sits_sample(samples_modis_ndvi, frac = 0.5) - test_data <- sits_sample(samples_modis_ndvi, frac = 0.5) + test_data <- sits_sample(samples_modis_ndvi, frac = 0.5) # compute a random forest model rfor_model <- sits_train(train_data, sits_rfor()) # classify training points diff --git a/man/plot.sits_cluster.Rd b/man/plot.sits_cluster.Rd index d227cf797..b9b1a73a6 100644 --- a/man/plot.sits_cluster.Rd +++ b/man/plot.sits_cluster.Rd @@ -26,8 +26,9 @@ Plot a dendrogram } \examples{ if (sits_run_examples()) { - samples <- sits_cluster_dendro(cerrado_2classes, - bands = c("NDVI", "EVI")) + samples <- sits_cluster_dendro(cerrado_2classes, + bands = c("NDVI", "EVI") + ) } } diff --git a/man/plot.uncertainty_vector_cube.Rd b/man/plot.uncertainty_vector_cube.Rd index 35f1ef971..a8974e380 100644 --- a/man/plot.uncertainty_vector_cube.Rd +++ b/man/plot.uncertainty_vector_cube.Rd @@ -50,13 +50,15 @@ if (sits_run_examples()) { # segment the image segments <- sits_segment( cube = cube, - seg_fn = sits_slic(step = 5, - compactness = 1, - dist_fun = "euclidean", - avg_fun = "median", - iter = 20, - minarea = 10, - verbose = FALSE), + seg_fn = sits_slic( + step = 5, + compactness = 1, + dist_fun = "euclidean", + avg_fun = "median", + iter = 20, + minarea = 10, + verbose = FALSE + ), output_dir = tempdir() ) # classify a data cube diff --git a/man/plot.variance_cube.Rd b/man/plot.variance_cube.Rd index 01564073f..357bb569e 100644 --- a/man/plot.variance_cube.Rd +++ b/man/plot.variance_cube.Rd @@ -54,7 +54,8 @@ A plot containing local variances associated to the logit probability for each pixel and each class. } \description{ -plots a variance cube +Plots a variance cube, useful to understand how local +smoothing will work. } \examples{ if (sits_run_examples()) { diff --git a/man/plot.vector_cube.Rd b/man/plot.vector_cube.Rd index 2e19504ff..9c601dee1 100644 --- a/man/plot.vector_cube.Rd +++ b/man/plot.vector_cube.Rd @@ -65,7 +65,11 @@ A plot object with an RGB image scale using the palette } \description{ -Plot RGB raster cube +Plot vector data cube with segments on top of raster image. +Vector cubes have both a vector and a raster component. The vector part +are the segments produced by \code{\link{sits_segment}}. Their +visual output is controlled by "seg_color" and "line_width" parameters. +The raster output works in the same way as the false color and RGB plots. } \note{ The following optional parameters are available to allow for detailed diff --git a/man/sits_accuracy.Rd b/man/sits_accuracy.Rd index bec61e189..cb81181e3 100644 --- a/man/sits_accuracy.Rd +++ b/man/sits_accuracy.Rd @@ -85,7 +85,7 @@ geometry type. if (sits_run_examples()) { # show accuracy for a set of samples train_data <- sits_sample(samples_modis_ndvi, frac = 0.5) - test_data <- sits_sample(samples_modis_ndvi, frac = 0.5) + test_data <- sits_sample(samples_modis_ndvi, frac = 0.5) rfor_model <- sits_train(train_data, sits_rfor()) points_class <- sits_classify( data = test_data, ml_model = rfor_model diff --git a/man/sits_add_base_cube.Rd b/man/sits_add_base_cube.Rd index 224d062f9..57755b8fa 100644 --- a/man/sits_add_base_cube.Rd +++ b/man/sits_add_base_cube.Rd @@ -25,41 +25,41 @@ bounding box, timeline, and have different bands. } \examples{ if (sits_run_examples()) { - s2_cube <- sits_cube( - source = "MPC", - collection = "SENTINEL-2-L2A", - tiles = "18HYE", - bands = c("B8A", "CLOUD"), - start_date = "2022-01-01", - end_date = "2022-03-31" - ) - output_dir <- paste0(tempdir(), "/reg") - if (!dir.exists(output_dir)) { - dir.create(output_dir) - } - dem_cube <- sits_cube( - source = "MPC", - collection = "COP-DEM-GLO-30", - tiles = "18HYE", - bands = "ELEVATION" - ) - s2_reg <- sits_regularize( - cube = s2_cube, - period = "P1M", - res = 240, - output_dir = output_dir, - multicores = 2, - memsize = 4 - ) - dem_reg <- sits_regularize( - cube = dem_cube, - res = 240, - tiles = "18HYE", - output_dir = output_dir, - multicores = 2, - memsize = 4 - ) - s2_reg <- sits_add_base_cube(s2_reg, dem_reg) + s2_cube <- sits_cube( + source = "MPC", + collection = "SENTINEL-2-L2A", + tiles = "18HYE", + bands = c("B8A", "CLOUD"), + start_date = "2022-01-01", + end_date = "2022-03-31" + ) + output_dir <- paste0(tempdir(), "/reg") + if (!dir.exists(output_dir)) { + dir.create(output_dir) + } + dem_cube <- sits_cube( + source = "MPC", + collection = "COP-DEM-GLO-30", + tiles = "18HYE", + bands = "ELEVATION" + ) + s2_reg <- sits_regularize( + cube = s2_cube, + period = "P1M", + res = 240, + output_dir = output_dir, + multicores = 2, + memsize = 4 + ) + dem_reg <- sits_regularize( + cube = dem_cube, + res = 240, + tiles = "18HYE", + output_dir = output_dir, + multicores = 2, + memsize = 4 + ) + s2_reg <- sits_add_base_cube(s2_reg, dem_reg) } } \author{ diff --git a/man/sits_as_stars.Rd b/man/sits_as_stars.Rd index 602aad814..14b9abd57 100644 --- a/man/sits_as_stars.Rd +++ b/man/sits_as_stars.Rd @@ -41,7 +41,6 @@ proxy objects to be created with two dimensions. } \examples{ if (sits_run_examples()) { - # convert sits cube to an sf object (polygon) data_dir <- system.file("extdata/raster/mod13q1", package = "sits") cube <- sits_cube( diff --git a/man/sits_as_terra.Rd b/man/sits_as_terra.Rd index e84941555..0d1d99406 100644 --- a/man/sits_as_terra.Rd +++ b/man/sits_as_terra.Rd @@ -38,7 +38,6 @@ Users can select bands. } \examples{ if (sits_run_examples()) { - # convert sits cube to an sf object (polygon) data_dir <- system.file("extdata/raster/mod13q1", package = "sits") cube <- sits_cube( diff --git a/man/sits_classify.segs_cube.Rd b/man/sits_classify.segs_cube.Rd index ce79f13b8..bf4118505 100644 --- a/man/sits_classify.segs_cube.Rd +++ b/man/sits_classify.segs_cube.Rd @@ -155,14 +155,15 @@ if (sits_run_examples()) { # segment the image segments <- sits_segment( cube = cube, - seg_fn = sits_slic(step = 5, - compactness = 1, - dist_fun = "euclidean", - avg_fun = "median", - iter = 50, - minarea = 10, - verbose = FALSE - ), + seg_fn = sits_slic( + step = 5, + compactness = 1, + dist_fun = "euclidean", + avg_fun = "median", + iter = 50, + minarea = 10, + verbose = FALSE + ), output_dir = tempdir() ) # Create a classified vector cube diff --git a/man/sits_clean.Rd b/man/sits_clean.Rd index a187b8db3..900456fd6 100644 --- a/man/sits_clean.Rd +++ b/man/sits_clean.Rd @@ -67,32 +67,32 @@ of the classified maps. } \examples{ if (sits_run_examples()) { -rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) -# create a data cube from local files -data_dir <- system.file("extdata/raster/mod13q1", package = "sits") -cube <- sits_cube( - source = "BDC", - collection = "MOD13Q1-6.1", - data_dir = data_dir -) -# classify a data cube -probs_cube <- sits_classify( - data = cube, - ml_model = rf_model, - output_dir = tempdir() -) -# label the probability cube -label_cube <- sits_label_classification( - probs_cube, - output_dir = tempdir() -) -# apply a mode function in the labelled cube -clean_cube <- sits_clean( - cube = label_cube, - window_size = 5, - output_dir = tempdir(), - multicores = 1 -) + rf_model <- sits_train(samples_modis_ndvi, ml_method = sits_rfor) + # create a data cube from local files + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6.1", + data_dir = data_dir + ) + # classify a data cube + probs_cube <- sits_classify( + data = cube, + ml_model = rf_model, + output_dir = tempdir() + ) + # label the probability cube + label_cube <- sits_label_classification( + probs_cube, + output_dir = tempdir() + ) + # apply a mode function in the labelled cube + clean_cube <- sits_clean( + cube = label_cube, + window_size = 5, + output_dir = tempdir(), + multicores = 1 + ) } } diff --git a/man/sits_cluster_dendro.Rd b/man/sits_cluster_dendro.Rd index cc1384354..7c4511cb5 100644 --- a/man/sits_cluster_dendro.Rd +++ b/man/sits_cluster_dendro.Rd @@ -72,7 +72,8 @@ if (sits_run_examples()) { clusters <- sits_cluster_dendro(cerrado_2classes) # with parameters clusters <- sits_cluster_dendro(cerrado_2classes, - bands = "NDVI", k = 5) + bands = "NDVI", k = 5 + ) } } diff --git a/man/sits_colors_qgis.Rd b/man/sits_colors_qgis.Rd index d2d2324bd..26c0447b0 100644 --- a/man/sits_colors_qgis.Rd +++ b/man/sits_colors_qgis.Rd @@ -20,22 +20,25 @@ Saves a color table associated to a classified } \examples{ if (sits_run_examples()) { - data_dir <- system.file("extdata/raster/classif", package = "sits") - ro_class <- sits_cube( - source = "MPC", - collection = "SENTINEL-2-L2A", - data_dir = data_dir, - parse_info = c( "X1", "X2", "tile", "start_date", "end_date", - "band", "version"), - bands = "class", - labels = c( - "1" = "Clear_Cut_Burned_Area", - "2" = "Clear_Cut_Bare_Soil", - "3" = "Clear_Cut_Vegetation", - "4" = "Forest") - ) - qml_file <- paste0(tempdir(), "/qgis.qml") - sits_colors_qgis(ro_class, qml_file) + data_dir <- system.file("extdata/raster/classif", package = "sits") + ro_class <- sits_cube( + source = "MPC", + collection = "SENTINEL-2-L2A", + data_dir = data_dir, + parse_info = c( + "X1", "X2", "tile", "start_date", "end_date", + "band", "version" + ), + bands = "class", + labels = c( + "1" = "Clear_Cut_Burned_Area", + "2" = "Clear_Cut_Bare_Soil", + "3" = "Clear_Cut_Vegetation", + "4" = "Forest" + ) + ) + qml_file <- paste0(tempdir(), "/qgis.qml") + sits_colors_qgis(ro_class, qml_file) } } \author{ diff --git a/man/sits_config.Rd b/man/sits_config.Rd index 5a3b0cf87..db7079bd2 100644 --- a/man/sits_config.Rd +++ b/man/sits_config.Rd @@ -34,7 +34,8 @@ use \code{link[sits]{sits_config_show()}}. } \examples{ yaml_user_file <- system.file("extdata/config_user_example.yml", - package = "sits") + package = "sits" +) sits_config(config_user_file = yaml_user_file) } \author{ diff --git a/man/sits_cube.results_cube.Rd b/man/sits_cube.results_cube.Rd index 6848b8f19..960e0fbee 100644 --- a/man/sits_cube.results_cube.Rd +++ b/man/sits_cube.results_cube.Rd @@ -181,7 +181,7 @@ if (sits_run_examples()) { data_dir = tempdir(), bands = "entropy" ) -. # plot recovered entropy values + . # plot recovered entropy values plot(entropy_local_cube) # obtain an uncertainty cube with margin @@ -200,7 +200,7 @@ if (sits_run_examples()) { data_dir = tempdir(), bands = "margin" ) -. # plot recovered entropy values + . # plot recovered entropy values plot(margin_local_cube) } } diff --git a/man/sits_cube.stac_cube.Rd b/man/sits_cube.stac_cube.Rd index df17a8643..da9fc23f0 100644 --- a/man/sits_cube.stac_cube.Rd +++ b/man/sits_cube.stac_cube.Rd @@ -119,7 +119,7 @@ collections you can use with \code{sits} } \examples{ if (sits_run_examples()) { -# --- Creating Sentinel cube from MPC + # --- Creating Sentinel cube from MPC s2_cube <- sits_cube( source = "MPC", collection = "SENTINEL-2-L2A", @@ -130,8 +130,10 @@ if (sits_run_examples()) { ) # --- Creating Landsat cube from MPC - roi <- c("lon_min" = -50.410, "lon_max" = -50.379, - "lat_min" = -10.1910 , "lat_max" = -10.1573) + roi <- c( + "lon_min" = -50.410, "lon_max" = -50.379, + "lat_min" = -10.1910, "lat_max" = -10.1573 + ) mpc_cube <- sits_cube( source = "MPC", collection = "LANDSAT-C2-L2", @@ -142,17 +144,19 @@ if (sits_run_examples()) { ) ## Sentinel-1 SAR from MPC - roi_sar <- c("lon_min" = -50.410, "lon_max" = -50.379, - "lat_min" = -10.1910, "lat_max" = -10.1573) + roi_sar <- c( + "lon_min" = -50.410, "lon_max" = -50.379, + "lat_min" = -10.1910, "lat_max" = -10.1573 + ) s1_cube_open <- sits_cube( - source = "MPC", - collection = "SENTINEL-1-GRD", - bands = c("VV", "VH"), - orbit = "descending", - roi = roi_sar, - start_date = "2020-06-01", - end_date = "2020-09-28" + source = "MPC", + collection = "SENTINEL-1-GRD", + bands = c("VV", "VH"), + orbit = "descending", + roi = roi_sar, + start_date = "2020-06-01", + end_date = "2020-09-28" ) # --- Access to the Brazil Data Cube # create a raster cube file based on the information in the BDC @@ -210,20 +214,22 @@ if (sits_run_examples()) { # --- remember to set the appropriate environmental variables # --- Obtain a AWS_ACCESS_KEY_ID and AWS_ACCESS_SECRET_KEY_ID # --- from CDSE - roi_sar <- c("lon_min" = 33.546, "lon_max" = 34.999, - "lat_min" = 1.427, "lat_max" = 3.726) + roi_sar <- c( + "lon_min" = 33.546, "lon_max" = 34.999, + "lat_min" = 1.427, "lat_max" = 3.726 + ) s1_cube_open <- sits_cube( - source = "CDSE", - collection = "SENTINEL-1-RTC", - bands = c("VV", "VH"), - orbit = "descending", - roi = roi_sar, - start_date = "2020-01-01", - end_date = "2020-06-10" - ) + source = "CDSE", + collection = "SENTINEL-1-RTC", + bands = c("VV", "VH"), + orbit = "descending", + roi = roi_sar, + start_date = "2020-01-01", + end_date = "2020-06-10" + ) - # -- Access to World Cover data (2021) via Terrascope + # -- Access to World Cover data (2021) via Terrascope cube_terrascope <- sits_cube( source = "TERRASCOPE", collection = "WORLD-COVER-2021", diff --git a/man/sits_cube.vector_cube.Rd b/man/sits_cube.vector_cube.Rd index c129a8436..b5227cb2a 100644 --- a/man/sits_cube.vector_cube.Rd +++ b/man/sits_cube.vector_cube.Rd @@ -101,60 +101,59 @@ if (sits_run_examples()) { avg_fun = "median", iter = 30, minarea = 10 - ), - output_dir = tempdir() - ) - plot(segs_cube) + ), + output_dir = tempdir() + ) + plot(segs_cube) - # recover the local segmented cube - local_segs_cube <- sits_cube( + # recover the local segmented cube + local_segs_cube <- sits_cube( source = "BDC", collection = "MOD13Q1-6.1", raster_cube = modis_cube, vector_dir = tempdir(), vector_band = "segments" - ) - # plot the recover model and compare - plot(local_segs_cube) - - # classify the segments - # create a random forest model - rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) - probs_vector_cube <- sits_classify( + ) + # plot the recover model and compare + plot(local_segs_cube) + + # classify the segments + # create a random forest model + rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) + probs_vector_cube <- sits_classify( data = segs_cube, ml_model = rfor_model, output_dir = tempdir(), n_sam_pol = 10 - ) - plot(probs_vector_cube) + ) + plot(probs_vector_cube) - # recover vector cube - local_probs_vector_cube <- sits_cube( + # recover vector cube + local_probs_vector_cube <- sits_cube( source = "BDC", collection = "MOD13Q1-6.1", raster_cube = modis_cube, vector_dir = tempdir(), vector_band = "probs" - ) - plot(local_probs_vector_cube) + ) + plot(local_probs_vector_cube) - # label the segments - class_vector_cube <- sits_label_classification( + # label the segments + class_vector_cube <- sits_label_classification( cube = probs_vector_cube, output_dir = tempdir(), - ) - plot(class_vector_cube) + ) + plot(class_vector_cube) - # recover vector cube - local_class_vector_cube <- sits_cube( + # recover vector cube + local_class_vector_cube <- sits_cube( source = "BDC", collection = "MOD13Q1-6.1", raster_cube = modis_cube, vector_dir = tempdir(), vector_band = "class" - ) - plot(local_class_vector_cube) - + ) + plot(local_class_vector_cube) } } diff --git a/man/sits_filter.Rd b/man/sits_filter.Rd index 8919004c8..4bcd3666f 100644 --- a/man/sits_filter.Rd +++ b/man/sits_filter.Rd @@ -26,7 +26,8 @@ if (sits_run_examples()) { point_whit <- sits_filter(point_ndvi, sits_whittaker(lambda = 3.0)) # Merge time series point_ndvi <- sits_merge(point_ndvi, point_whit, - suffix = c("", ".WHIT")) + suffix = c("", ".WHIT") + ) # Plot the two points to see the smoothing effect plot(point_ndvi) } diff --git a/man/sits_get_data.Rd b/man/sits_get_data.Rd index 044c3ea0a..35e02880f 100644 --- a/man/sits_get_data.Rd +++ b/man/sits_get_data.Rd @@ -94,16 +94,16 @@ if (sits_run_examples()) { # reading a shapefile from BDC (Brazil Data Cube) bdc_cube <- sits_cube( - source = "BDC", - collection = "CBERS-WFI-16D", - bands = c("NDVI", "EVI"), - tiles = c("007004", "007005"), - start_date = "2018-09-01", - end_date = "2018-10-28" + source = "BDC", + collection = "CBERS-WFI-16D", + bands = c("NDVI", "EVI"), + tiles = c("007004", "007005"), + start_date = "2018-09-01", + end_date = "2018-10-28" ) # define a shapefile to be read from the cube shp_file <- system.file("extdata/shapefiles/bdc-test/samples.shp", - package = "sits" + package = "sits" ) # get samples from the BDC based on the shapefile time_series_bdc <- sits_get_data( diff --git a/man/sits_get_data.sf.Rd b/man/sits_get_data.sf.Rd index f37f82872..5d78edd40 100644 --- a/man/sits_get_data.sf.Rd +++ b/man/sits_get_data.sf.Rd @@ -91,16 +91,16 @@ geometry should be computed (default = "FALSE").} if (sits_run_examples()) { # reading a shapefile from BDC (Brazil Data Cube) bdc_cube <- sits_cube( - source = "BDC", - collection = "CBERS-WFI-16D", - bands = c("NDVI", "EVI"), - tiles = c("007004", "007005"), - start_date = "2018-09-01", - end_date = "2018-10-28" + source = "BDC", + collection = "CBERS-WFI-16D", + bands = c("NDVI", "EVI"), + tiles = c("007004", "007005"), + start_date = "2018-09-01", + end_date = "2018-10-28" ) # define a shapefile to be read from the cube shp_file <- system.file("extdata/shapefiles/bdc-test/samples.shp", - package = "sits" + package = "sits" ) # read a shapefile into an sf object sf_object <- sf::st_read(shp_file) diff --git a/man/sits_get_data.shp.Rd b/man/sits_get_data.shp.Rd index 53aa66a92..35f92744d 100644 --- a/man/sits_get_data.shp.Rd +++ b/man/sits_get_data.shp.Rd @@ -88,19 +88,18 @@ geometry should be computed (default = "FALSE").} } \examples{ if (sits_run_examples()) { - # reading a shapefile from BDC (Brazil Data Cube) bdc_cube <- sits_cube( - source = "BDC", - collection = "CBERS-WFI-16D", - bands = c("NDVI", "EVI"), - tiles = c("007004", "007005"), - start_date = "2018-09-01", - end_date = "2018-10-28" + source = "BDC", + collection = "CBERS-WFI-16D", + bands = c("NDVI", "EVI"), + tiles = c("007004", "007005"), + start_date = "2018-09-01", + end_date = "2018-10-28" ) # define a shapefile to be read from the cube shp_file <- system.file("extdata/shapefiles/bdc-test/samples.shp", - package = "sits" + package = "sits" ) # get samples from the BDC based on the shapefile time_series_bdc <- sits_get_data( diff --git a/man/sits_mlp.Rd b/man/sits_mlp.Rd index 95400bbd7..7652066b3 100644 --- a/man/sits_mlp.Rd +++ b/man/sits_mlp.Rd @@ -89,8 +89,10 @@ will be randomly set side for validation. \examples{ if (sits_run_examples()) { # create an MLP model - torch_model <- sits_train(samples_modis_ndvi, - sits_mlp(epochs = 20, verbose = TRUE)) + torch_model <- sits_train( + samples_modis_ndvi, + sits_mlp(epochs = 20, verbose = TRUE) + ) # plot the model plot(torch_model) # create a data cube from local files diff --git a/man/sits_predictors.Rd b/man/sits_predictors.Rd index d31879463..b1867e6df 100644 --- a/man/sits_predictors.Rd +++ b/man/sits_predictors.Rd @@ -26,8 +26,7 @@ if (sits_run_examples()) { sits_mlr <- function(samples = NULL, formula = sits_formula_linear(), n_weights = 20000, maxit = 2000) { - - # create a training function + # create a training function train_fun <- function(samples) { # Data normalization ml_stats <- sits_stats(samples) diff --git a/man/sits_reclassify.Rd b/man/sits_reclassify.Rd index beda0b9dd..feb17d820 100644 --- a/man/sits_reclassify.Rd +++ b/man/sits_reclassify.Rd @@ -16,7 +16,8 @@ sits_reclassify(cube, ...) memsize = 4L, multicores = 2L, output_dir, - version = "v1" + version = "v1", + progress = TRUE ) \method{sits_reclassify}{default}(cube, ...) @@ -41,6 +42,8 @@ to be used in expressions (class = "class_cube").} (character vector of length 1 with valid location).} \item{version}{Version of resulting image (character).} + +\item{progress}{Set progress bar??} } \value{ An object of class "class_cube" (reclassified cube). @@ -71,72 +74,74 @@ output cube. Last expressions has precedence over first ones. } \examples{ if (sits_run_examples()) { -# Open mask map -data_dir <- system.file("extdata/raster/prodes", package = "sits") -prodes2021 <- sits_cube( - source = "USGS", - collection = "LANDSAT-C2L2-SR", - data_dir = data_dir, - parse_info = c( - "X1", "X2", "tile", "start_date", "end_date", - "band", "version" - ), - bands = "class", - version = "v20220606", - labels = c("1" = "Forest", "2" = "Water", "3" = "NonForest", - "4" = "NonForest2", "6" = "d2007", "7" = "d2008", - "8" = "d2009", "9" = "d2010", "10" = "d2011", - "11" = "d2012", "12" = "d2013", "13" = "d2014", - "14" = "d2015", "15" = "d2016", "16" = "d2017", - "17" = "d2018", "18" = "r2010", "19" = "r2011", - "20" = "r2012", "21" = "r2013", "22" = "r2014", - "23" = "r2015", "24" = "r2016", "25" = "r2017", - "26" = "r2018", "27" = "d2019", "28" = "r2019", - "29" = "d2020", "31" = "r2020", "32" = "Clouds2021", - "33" = "d2021", "34" = "r2021"), - progress = FALSE -) -#' Open classification map -data_dir <- system.file("extdata/raster/classif", package = "sits") -ro_class <- sits_cube( - source = "MPC", - collection = "SENTINEL-2-L2A", - data_dir = data_dir, - parse_info = c( - "X1", "X2", "tile", "start_date", "end_date", - "band", "version" - ), - bands = "class", - labels = c( - "1" = "ClearCut_Fire", "2" = "ClearCut_Soil", - "3" = "ClearCut_Veg", "4" = "Forest" - ), - progress = FALSE -) -# Reclassify cube -ro_mask <- sits_reclassify( - cube = ro_class, - mask = prodes2021, - rules = list( - "Old_Deforestation" = mask \%in\% c( - "d2007", "d2008", "d2009", - "d2010", "d2011", "d2012", - "d2013", "d2014", "d2015", - "d2016", "d2017", "d2018", - "r2010", "r2011", "r2012", - "r2013", "r2014", "r2015", - "r2016", "r2017", "r2018", - "d2019", "r2019", "d2020", - "r2020", "r2021" + # Open mask map + data_dir <- system.file("extdata/raster/prodes", package = "sits") + prodes2021 <- sits_cube( + source = "USGS", + collection = "LANDSAT-C2L2-SR", + data_dir = data_dir, + parse_info = c( + "X1", "X2", "tile", "start_date", "end_date", + "band", "version" ), - "Water_Mask" = mask == "Water", - "NonForest_Mask" = mask \%in\% c("NonForest", "NonForest2") - ), - memsize = 4, - multicores = 2, - output_dir = tempdir(), - version = "ex_reclassify" -) + bands = "class", + version = "v20220606", + labels = c( + "1" = "Forest", "2" = "Water", "3" = "NonForest", + "4" = "NonForest2", "6" = "d2007", "7" = "d2008", + "8" = "d2009", "9" = "d2010", "10" = "d2011", + "11" = "d2012", "12" = "d2013", "13" = "d2014", + "14" = "d2015", "15" = "d2016", "16" = "d2017", + "17" = "d2018", "18" = "r2010", "19" = "r2011", + "20" = "r2012", "21" = "r2013", "22" = "r2014", + "23" = "r2015", "24" = "r2016", "25" = "r2017", + "26" = "r2018", "27" = "d2019", "28" = "r2019", + "29" = "d2020", "31" = "r2020", "32" = "Clouds2021", + "33" = "d2021", "34" = "r2021" + ), + progress = FALSE + ) + #' Open classification map + data_dir <- system.file("extdata/raster/classif", package = "sits") + ro_class <- sits_cube( + source = "MPC", + collection = "SENTINEL-2-L2A", + data_dir = data_dir, + parse_info = c( + "X1", "X2", "tile", "start_date", "end_date", + "band", "version" + ), + bands = "class", + labels = c( + "1" = "ClearCut_Fire", "2" = "ClearCut_Soil", + "3" = "ClearCut_Veg", "4" = "Forest" + ), + progress = FALSE + ) + # Reclassify cube + ro_mask <- sits_reclassify( + cube = ro_class, + mask = prodes2021, + rules = list( + "Old_Deforestation" = mask \%in\% c( + "d2007", "d2008", "d2009", + "d2010", "d2011", "d2012", + "d2013", "d2014", "d2015", + "d2016", "d2017", "d2018", + "r2010", "r2011", "r2012", + "r2013", "r2014", "r2015", + "r2016", "r2017", "r2018", + "d2019", "r2019", "d2020", + "r2020", "r2021" + ), + "Water_Mask" = mask == "Water", + "NonForest_Mask" = mask \%in\% c("NonForest", "NonForest2") + ), + memsize = 4, + multicores = 2, + output_dir = tempdir(), + version = "ex_reclassify" + ) } } diff --git a/man/sits_regularize.Rd b/man/sits_regularize.Rd index 90c46dafd..f7dbb9b01 100644 --- a/man/sits_regularize.Rd +++ b/man/sits_regularize.Rd @@ -228,8 +228,10 @@ if (sits_run_examples()) { ) ## Sentinel-1 SAR - roi <- c("lon_min" = -50.410, "lon_max" = -50.379, - "lat_min" = -10.1910, "lat_max" = -10.1573) + roi <- c( + "lon_min" = -50.410, "lon_max" = -50.379, + "lat_min" = -10.1910, "lat_max" = -10.1573 + ) s1_cube_open <- sits_cube( source = "MPC", collection = "SENTINEL-1-GRD", diff --git a/man/sits_sampling_design.Rd b/man/sits_sampling_design.Rd index 524cf9d3c..87e256133 100644 --- a/man/sits_sampling_design.Rd +++ b/man/sits_sampling_design.Rd @@ -54,8 +54,10 @@ if (sits_run_examples()) { output_dir = tempdir() ) # estimated UA for classes - expected_ua <- c(Cerrado = 0.75, Forest = 0.9, - Pasture = 0.8, Soy_Corn = 0.8) + expected_ua <- c( + Cerrado = 0.75, Forest = 0.9, + Pasture = 0.8, Soy_Corn = 0.8 + ) sampling_design <- sits_sampling_design(label_cube, expected_ua) } } diff --git a/man/sits_segment.Rd b/man/sits_segment.Rd index 6795f06f0..a4b50038d 100644 --- a/man/sits_segment.Rd +++ b/man/sits_segment.Rd @@ -100,12 +100,12 @@ if (sits_run_examples()) { segments <- sits_segment( cube = cube, seg_fn = sits_slic( - step = 10, - compactness = 1, - dist_fun = "euclidean", - avg_fun = "median", - iter = 30, - minarea = 10 + step = 10, + compactness = 1, + dist_fun = "euclidean", + avg_fun = "median", + iter = 30, + minarea = 10 ), output_dir = tempdir() ) diff --git a/man/sits_select.Rd b/man/sits_select.Rd index 96486e376..9aedf4dd3 100644 --- a/man/sits_select.Rd +++ b/man/sits_select.Rd @@ -56,8 +56,9 @@ data <- sits_select(cerrado_2classes, bands = c("NDVI")) sits_bands(data) # select start and end date point_2010 <- sits_select(point_mt_6bands, - start_date = "2000-01-01", - end_date = "2030-12-31") + start_date = "2000-01-01", + end_date = "2030-12-31" +) } \author{ diff --git a/man/sits_slic.Rd b/man/sits_slic.Rd index 8d8e9dd52..0faccae0a 100644 --- a/man/sits_slic.Rd +++ b/man/sits_slic.Rd @@ -65,12 +65,12 @@ if (sits_run_examples()) { segments <- sits_segment( cube = cube, seg_fn = sits_slic( - step = 10, - compactness = 1, - dist_fun = "euclidean", - avg_fun = "median", - iter = 30, - minarea = 10 + step = 10, + compactness = 1, + dist_fun = "euclidean", + avg_fun = "median", + iter = 30, + minarea = 10 ), output_dir = tempdir(), version = "slic-demo" diff --git a/man/sits_som_remove_samples.Rd b/man/sits_som_remove_samples.Rd index db5d17f16..264993bcc 100644 --- a/man/sits_som_remove_samples.Rd +++ b/man/sits_som_remove_samples.Rd @@ -28,8 +28,10 @@ if (sits_run_examples()) { # evaluate the som map and create clusters som_eval <- sits_som_evaluate_cluster(som_map) # clean the samples - new_samples <- sits_som_remove_samples(som_map, som_eval, - "Pasture", "Cerrado") + new_samples <- sits_som_remove_samples( + som_map, som_eval, + "Pasture", "Cerrado" + ) } } \author{ diff --git a/man/sits_stratified_sampling.Rd b/man/sits_stratified_sampling.Rd index ed8b37b6b..e4641b924 100644 --- a/man/sits_stratified_sampling.Rd +++ b/man/sits_stratified_sampling.Rd @@ -60,14 +60,17 @@ if (sits_run_examples()) { output_dir = tempdir() ) # estimated UA for classes - expected_ua <- c(Cerrado = 0.95, Forest = 0.95, - Pasture = 0.95, Soy_Corn = 0.95) + expected_ua <- c( + Cerrado = 0.95, Forest = 0.95, + Pasture = 0.95, Soy_Corn = 0.95 + ) # design sampling sampling_design <- sits_sampling_design(label_cube, expected_ua) # select samples - samples <- sits_stratified_sampling(label_cube, - sampling_design, "alloc_prop") - + samples <- sits_stratified_sampling( + label_cube, + sampling_design, "alloc_prop" + ) } } \author{ diff --git a/man/sits_tempcnn.Rd b/man/sits_tempcnn.Rd index 79794d56c..404ed0c12 100644 --- a/man/sits_tempcnn.Rd +++ b/man/sits_tempcnn.Rd @@ -99,8 +99,10 @@ Please refer to the sits documentation available in \examples{ if (sits_run_examples()) { # create a TempCNN model - torch_model <- sits_train(samples_modis_ndvi, - sits_tempcnn(epochs = 20, verbose = TRUE)) + torch_model <- sits_train( + samples_modis_ndvi, + sits_tempcnn(epochs = 20, verbose = TRUE) + ) # plot the model plot(torch_model) # create a data cube from local files diff --git a/man/sits_tuning_hparams.Rd b/man/sits_tuning_hparams.Rd index 8f0de6ab6..65c2a8687 100644 --- a/man/sits_tuning_hparams.Rd +++ b/man/sits_tuning_hparams.Rd @@ -53,8 +53,8 @@ if (sits_run_examples()) { torch::optim_adagrad ), opt_hparams = list( - lr = loguniform(10^-2, 10^-4), - weight_decay = loguniform(10^-2, 10^-8) + lr = loguniform(10^-2, 10^-4), + weight_decay = loguniform(10^-2, 10^-8) ) ), trials = 20, diff --git a/man/sits_validate.Rd b/man/sits_validate.Rd index b18ca43bd..0efdffa1e 100644 --- a/man/sits_validate.Rd +++ b/man/sits_validate.Rd @@ -49,7 +49,7 @@ the validation test set. This function returns the confusion matrix, and Kappa values. } \note{ -#' When using a GPU for deep learning, \code{gpu_memory} indicates the +When using a GPU for deep learning, \code{gpu_memory} indicates the memory of the graphics card which is available for processing. The parameter \code{batch_size} defines the size of the matrix (measured in number of rows) which is sent to the GPU for classification. @@ -75,15 +75,15 @@ if (sits_run_examples()) { samples <- sits_sample(cerrado_2classes, frac = 0.5) samples_validation <- sits_sample(cerrado_2classes, frac = 0.5) conf_matrix_1 <- sits_validate( - samples = samples, - samples_validation = samples_validation, - ml_method = sits_rfor() - ) - conf_matrix_2 <- sits_validate( - samples = cerrado_2classes, - validation_split = 0.2, - ml_method = sits_rfor() - ) + samples = samples, + samples_validation = samples_validation, + ml_method = sits_rfor() + ) + conf_matrix_2 <- sits_validate( + samples = cerrado_2classes, + validation_split = 0.2, + ml_method = sits_rfor() + ) } } \author{ diff --git a/man/sits_whittaker.Rd b/man/sits_whittaker.Rd index 791d98efd..907f1494c 100644 --- a/man/sits_whittaker.Rd +++ b/man/sits_whittaker.Rd @@ -28,7 +28,8 @@ if (sits_run_examples()) { point_whit <- sits_filter(point_ndvi, sits_whittaker(lambda = 3.0)) # Merge time series point_ndvi <- sits_merge(point_ndvi, point_whit, - suffix = c("", ".WHIT")) + suffix = c("", ".WHIT") + ) # Plot the two points to see the smoothing effect plot(point_ndvi) } diff --git a/man/summary.sits_accuracy.Rd b/man/summary.sits_accuracy.Rd index bc4ddafba..c6037dd6d 100644 --- a/man/summary.sits_accuracy.Rd +++ b/man/summary.sits_accuracy.Rd @@ -23,7 +23,7 @@ if (sits_run_examples()) { data(cerrado_2classes) # split training and test data train_data <- sits_sample(cerrado_2classes, frac = 0.5) - test_data <- sits_sample(cerrado_2classes, frac = 0.5) + test_data <- sits_sample(cerrado_2classes, frac = 0.5) # train a random forest model rfor_model <- sits_train(train_data, sits_rfor()) # classify test data From a6756c6a0f53669b9a3b5c7dbc0073981eec12aa Mon Sep 17 00:00:00 2001 From: Felipe Carlos Date: Thu, 22 May 2025 17:26:10 -0300 Subject: [PATCH 108/122] base ogh implementation --- DESCRIPTION | 1 + NAMESPACE | 4 + R/api_source_ogh.R | 117 +++++++++++++++++ R/api_stac.R | 142 ++++++++++++++++----- R/zzz.R | 1 + inst/extdata/sources/config_source_ogh.yml | 53 ++++++++ 6 files changed, 285 insertions(+), 33 deletions(-) create mode 100644 R/api_source_ogh.R create mode 100644 inst/extdata/sources/config_source_ogh.yml diff --git a/DESCRIPTION b/DESCRIPTION index f2c3a175a..be0d4fb64 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -183,6 +183,7 @@ Collate: 'api_source_hls.R' 'api_source_local.R' 'api_source_mpc.R' + 'api_source_ogh.R' 'api_source_sdc.R' 'api_source_stac.R' 'api_source_terrascope.R' diff --git a/NAMESPACE b/NAMESPACE index 507a68000..e9756ef8c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -136,6 +136,7 @@ S3method(.source_collection_access_test,"mpc_cube_sentinel-1-grd") S3method(.source_collection_access_test,cdse_cube) S3method(.source_collection_access_test,hls_cube) S3method(.source_collection_access_test,mpc_cube) +S3method(.source_collection_access_test,ogh_cube) S3method(.source_collection_access_test,stac_cube) S3method(.source_collection_access_test,usgs_cube) S3method(.source_cube,stac_cube) @@ -179,6 +180,7 @@ S3method(.source_items_new,deaustralia_cube_ga_s2am_ard_3) S3method(.source_items_new,deaustralia_cube_ga_s2bm_ard_3) S3method(.source_items_new,hls_cube) S3method(.source_items_new,mpc_cube) +S3method(.source_items_new,ogh_cube) S3method(.source_items_new,sdc_cube) S3method(.source_items_new,usgs_cube) S3method(.source_items_tile,"aws_cube_landsat-c2-l2") @@ -193,6 +195,7 @@ S3method(.source_items_tile,"mpc_cube_mod13q1-6.1") S3method(.source_items_tile,"mpc_cube_sentinel-1-grd") S3method(.source_items_tile,"mpc_cube_sentinel-1-rtc") S3method(.source_items_tile,"mpc_cube_sentinel-2-l2a") +S3method(.source_items_tile,"ogh_cube_landsat-glad-2m") S3method(.source_items_tile,"terrascope_cube_world-cover-2021") S3method(.source_items_tile,aws_cube) S3method(.source_items_tile,bdc_cube) @@ -210,6 +213,7 @@ S3method(.source_tile_get_bbox,"mpc_cube_cop-dem-glo-30") S3method(.source_tile_get_bbox,"mpc_cube_sentinel-1-grd") S3method(.source_tile_get_bbox,"mpc_cube_sentinel-1-rtc") S3method(.source_tile_get_bbox,stac_cube) +S3method(.stac_static_date_filter,ogh) S3method(.tile,default) S3method(.tile,raster_cube) S3method(.tile_area_freq,class_cube) diff --git a/R/api_source_ogh.R b/R/api_source_ogh.R new file mode 100644 index 000000000..85693489c --- /dev/null +++ b/R/api_source_ogh.R @@ -0,0 +1,117 @@ +#' @title Test access to collection in Open Geo Hub +#' @keywords internal +#' @noRd +#' @description +#' These functions provide an API to handle/retrieve data from source's +#' collections. +#' +#' @param source Data source. +#' @param collection Image collection. +#' @param bands Band names +#' @param ... Other parameters to be passed for specific types. +#' @param start_date Start date. +#' @param end_date End date. +#' @param dry_run TRUE/FALSE +#' @return Called for side effects +#' @export +.source_collection_access_test.ogh_cube <- function(source, collection, + bands, ..., + start_date = NULL, + end_date = NULL, + dry_run = FALSE) { + # require package + .check_require_packages("rstac") + # query items + items <- .try( + { + .stac_static_items_query( + source = source, + collection = collection, + start_date = start_date, + end_date = end_date, + limit = 1 + ) + }, + .default = NULL + ) + # check items + .check_stac_items(items) + # select bands + items <- .source_items_bands_select( + source = source, + items = items, + bands = bands[[1L]], + collection = collection, ... + ) + # get hrefs available + href <- .source_item_get_hrefs( + source = source, + item = items[["features"]][[1L]], + collection = collection, ... + ) + # assert that token and/or href is valid + if (dry_run) { + rast <- .try( + { + .raster_open_rast(href) + }, + default = NULL + ) + .check_null_parameter(rast) + } + return(invisible(source)) +} + +#' @title Create an items object using items STAC Static from Open Geo Hub +#' @keywords internal +#' @noRd +#' @description \code{.source_items_new()} this function is called to create +#' an items object. In case of Web services, this function is responsible for +#' making the Web requests to the server. +#' @param source Name of the STAC provider. +#' @param collection Collection to be searched in the data source. +#' @param stac_query Query that follows the STAC protocol +#' @param ... Other parameters to be passed for specific types. +#' @param tiles Selected tiles (optional) +#' @param platform Satellite platform (optional). +#' @return An object referring the images of a sits cube. +#' @export +.source_items_new.ogh_cube <- function(source, + collection, + stac_query, ..., + tiles = NULL, + platform = NULL) { + .check_set_caller(".source_items_new_ogh_cube") + # query items + datetime <- stac_query[["params"]][["datetime"]] + datetime <- stringr::str_split(datetime, "/") + datetime <- datetime[[1]] + + start_date <- datetime[[1]] + end_date <- datetime[[2]] + + items <- .try( + { + .stac_static_items_query( + source = source, + collection = collection, + start_date = start_date, + end_date = end_date + ) + }, + .default = NULL + ) + # check results + .check_stac_items(items) + # return + return(items) +} + +#' @keywords internal +#' @noRd +#' @export +`.source_items_tile.ogh_cube_landsat-glad-2m` <- function(source, + items, ..., + collection = NULL) { + rep("NoTilingSystem", rstac::items_length(items)) +} diff --git a/R/api_stac.R b/R/api_stac.R index a66697977..492f5dd02 100644 --- a/R/api_stac.R +++ b/R/api_stac.R @@ -25,9 +25,7 @@ items[["features"]] <- purrr::map(items[["features"]], function(item) { names(item[["assets"]]) <- toupper(names(item[["assets"]])) item[["assets"]] <- item[["assets"]][bands_source] - names(item[["assets"]]) <- unname( - bands_converter[names(item[["assets"]])] - ) + names(item[["assets"]]) <- unname(bands_converter[names(item[["assets"]])]) item }) items @@ -61,9 +59,7 @@ #' @return a \code{character} formatted as parameter to STAC requisition. .stac_format_platform <- function(source, collection, platform) { .check_set_caller(".stac_format_platform") - platforms <- .conf( - "sources", source, "collections", collection, "platforms" - ) + platforms <- .conf("sources", source, "collections", collection, "platforms") platform_source <- platforms[platform] .check_that(length(platform_source) == 1L) @@ -89,18 +85,12 @@ # reference for AWS S3 index <- grepl("^s3://.*", href) if (any(index)) { - href[index] <- file.path( - "/vsis3", - gsub("^s3://(.*)$", "\\1", href[index]) - ) + href[index] <- file.path("/vsis3", gsub("^s3://(.*)$", "\\1", href[index])) } # reference for google cloud index <- grepl("^gs://.*", href) if (any(index)) { - href[index] <- file.path( - "/vsigs", - gsub("^gs://(.*)$", "\\1", href[index]) - ) + href[index] <- file.path("/vsigs", gsub("^gs://(.*)$", "\\1", href[index])) } href } @@ -120,16 +110,14 @@ #' #' @return an \code{RSTACQuery} object. .stac_create_items_query <- function(source, - collection, ..., + collection, + ..., roi = NULL, start_date = NULL, end_date = NULL, limit = NULL) { # get collection original name - collection <- .source_collection_name( - source = source, - collection = collection - ) + collection <- .source_collection_name(source = source, collection = collection) # get the URL url <- .source_url(source = source) # obtain the datetime parameter for STAC like parameter @@ -159,6 +147,8 @@ # return! rstac_query } + + #' @title Extract bounding box from a STAC Query. #' @keywords internal #' @noRd @@ -193,13 +183,8 @@ #' @param stac_query Query that follows the STAC protocol. #' @return List with `start_date` and `end_date` properties. .stac_datetime_as_dates <- function(stac_query) { - query_datetime <- stringr::str_split( - stac_query[["params"]][["datetime"]], "/" - ) - list( - start_date = query_datetime[[1L]][1L], - end_date = query_datetime[[1L]][2L] - ) + query_datetime <- stringr::str_split(stac_query[["params"]][["datetime"]], "/") + list(start_date = query_datetime[[1L]][1L], end_date = query_datetime[[1L]][2L]) } #' @title Extract dates as datetime from a STAC Query. #' @keywords internal @@ -209,14 +194,105 @@ #' @return List with `start_date` and `end_date` properties. .stac_dates_as_datetimes <- function(stac_query) { # get start and end date - date_time <- strsplit( - stac_query[["params"]][["datetime"]], - split = "/" - ) + date_time <- strsplit(stac_query[["params"]][["datetime"]], split = "/") dates_chr <- date_time[[1L]] # format as datetime (RFC 3339) - paste( - format(as.Date(dates_chr), "%Y-%m-%dT%H:%M:%SZ"), - collapse = "/" + paste(format(as.Date(dates_chr), "%Y-%m-%dT%H:%M:%SZ"), collapse = "/") +} + + +#' @title Date filter function for STAC static +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Felipe Carvalho, \email{lipecaso@@gmail.com} +#' @keywords internal +#' @noRd +.stac_static_date_filter <- function(source, start_date, end_date) { + UseMethod(".stac_static_date_filter") +} + + +#' @title Date filter function for STAC static of Open Geo Hub +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Felipe Carvalho, \email{lipecaso@@gmail.com} +#' @keywords internal +#' @noRd +#' @export +.stac_static_date_filter.ogh <- function(source, start_date, end_date) { + # define Open Geo Hub compatible date filter + date_filter_fnc <- function(x) { + # extract date interval + interval <- gsub("^.*([0-9]{8}_[0-9]{8})\\.json$", "\\1", x) + + # transform date interval in date + date <- as.Date(strsplit(interval, "_")[[1]][[1]], format = "%Y%m%d") + + # validate if ``start_date`` and ``end_date`` are in the interval + is_in_interval <- (is.null(start_date) || date >= start_date) && + (is.null(end_date) || date < end_date) + + # return! + return(is_in_interval) + } + # return! + return(date_filter_fnc) +} + +#' @title Get items from a static STAC +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Felipe Carvalho, \email{lipecaso@@gmail.com} +#' @keywords internal +#' @noRd +#' @description +#' This function prepares and execute a search in a static STAC. +#' @param source Source name. +#' @param collection Collection name. +#' @param roi Region of interest. +#' @param start_date Initial time interval. +#' @param end_date Final time interval. +#' @param limit Max number of items to retrieve from the server. +#' @return STAC Items. +.stac_static_items_query <- function(source, + collection, + ..., + roi = NULL, + start_date = NULL, + end_date = NULL, + limit = NULL) { + # get collection original name + collection <- .source_collection_name(source = source, collection = collection) + # get the URL + url <- .source_url(source = source) + # get the limit items to be returned in each page + if (is.null(limit)) { + limit <- .conf("rstac_pagination_limit") + } + filter_expr <- substitute( + rel == "item" && + .stac_static_date_filter( + source = source_name_, + href = href, + start_date = start_, + end_date = end_ + ), + env = list( + source_name_ = source, + start_ = start_date, + end_ = end_date + ) ) + # add source as class of source (to enable filter usage if possible) + source_name <- source + class(source_name) <- tolower(source) + # prepare date filter + items_filter_date <- .stac_static_date_filter( + source = source_name, + start_date = start_date, + end_date = end_date + ) + # read items + rstac::read_stac(url) |> + rstac::read_items( + items_filter_date(x = href), + limit = limit + ) } diff --git a/R/zzz.R b/R/zzz.R index ffb020613..c4e27925d 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -33,6 +33,7 @@ utils::globalVariables(c( "normal", "lognormal", "loguniform", # sits_tuning "geometry", # sf operations "value", "label", "Eval", # ggplot + "href", # rstac items (static catalog) "sar:frequency_band", "sar:instrument_mode", "sat:orbit_state" # S1 stac )) #' @importFrom lubridate %within% %m+% diff --git a/inst/extdata/sources/config_source_ogh.yml b/inst/extdata/sources/config_source_ogh.yml new file mode 100644 index 000000000..f00051f23 --- /dev/null +++ b/inst/extdata/sources/config_source_ogh.yml @@ -0,0 +1,53 @@ +# These are configuration parameters that can be set by users +# The parameters enable access to the cloud collections + +sources: + OGH : + s3_class : ["ogh_cube", "stac_cube", "eo_cube", + "raster_cube"] + service : "STAC" + rstac_version : "1.0.0" + url : "https://s3.eu-central-1.wasabisys.com/stac/openlandmap/landsat_glad.swa.ard2_bimonthly/collection.json" + collections : + LANDSAT-GLAD-2M : &ogh_glad_2m + bands : + BLUE : &ogh_landsat_blue + missing_value : 255 + minimum_value : 0 + maximum_value : 1 + scale_factor : 1 + offset_value : 0 + resolution : 30 + band_name : "blue_glad.landsat.ard2.swa_m_30m_s" + data_type : "FLT4S" + GREEN : + <<: *ogh_landsat_blue + band_name : "green_glad.landsat.ard2.swa_m_30m_s" + RED : + <<: *ogh_landsat_blue + band_name : "red_glad.landsat.ard2.swa_m_30m_s" + NIR : + <<: *ogh_landsat_blue + band_name : "nir_glad.landsat.ard2.swa_m_30m_s" + SWIR1 : + <<: *ogh_landsat_blue + band_name : "swir1_glad.landsat.ard2.swa_m_30m_s" + SWIR2 : + <<: *ogh_landsat_blue + band_name : "swir2_glad.landsat.ard2.swa_m_30m_s" + THERMAL : + <<: *ogh_landsat_blue + band_name : "thermal_glad.landsat.ard2.swa_m_30m_s" + satellite : "LANDSAT" + sensor : "TM-ETM-OLI" + platforms : + LANDSAT-5: "landsat-5" + LANDSAT-7: "landsat-7" + LANDSAT-8: "landsat-8" + collection_name : "landsat_glad.swa.ard2_bimonthly" + open_data : true + open_data_token : false + metadata_search : "tile" + ext_tolerance : 0.01 + grid_system : "WRS-2" + dates : "1997 to 2022" From 14f4499e5efc195a24be6c54b9840ea89822572c Mon Sep 17 00:00:00 2001 From: Felipe Carlos Date: Fri, 23 May 2025 19:48:04 +0000 Subject: [PATCH 109/122] add world-cereal collection --- NAMESPACE | 5 + R/api_cube.R | 38 ++++- R/api_download.R | 2 + R/api_source_terrascope.R | 131 +++++++++++++++++- R/sits_cube.R | 3 + R/sits_cube_copy.R | 6 +- R/sits_plot.R | 10 +- R/sits_view.R | 4 + inst/extdata/config_colors.yml | 1 + inst/extdata/config_messages.yml | 2 + .../sources/config_source_terrascope.yml | 22 +++ 11 files changed, 213 insertions(+), 11 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index ed5256dfb..f7fcbd937 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -89,6 +89,9 @@ S3method(.cube_timeline,default) S3method(.cube_timeline,raster_cube) S3method(.cube_timeline_acquisition,default) S3method(.cube_timeline_acquisition,raster_cube) +S3method(.cube_token_flush,"terrascope_cube_world-cereal-2021") +S3method(.cube_token_flush,default) +S3method(.cube_token_generator,"terrascope_cube_world-cereal-2021") S3method(.cube_token_generator,default) S3method(.cube_token_generator,mpc_cube) S3method(.data_get_ts,class_cube) @@ -170,6 +173,7 @@ S3method(.source_items_new,"mpc_cube_landsat-c2-l2") S3method(.source_items_new,"mpc_cube_sentinel-1-grd") S3method(.source_items_new,"mpc_cube_sentinel-1-rtc") S3method(.source_items_new,"mpc_cube_sentinel-2-l2a") +S3method(.source_items_new,"terrascope_cube_world-cereal-2021") S3method(.source_items_new,"terrascope_cube_world-cover-2021") S3method(.source_items_new,aws_cube) S3method(.source_items_new,bdc_cube) @@ -194,6 +198,7 @@ S3method(.source_items_tile,"mpc_cube_mod13q1-6.1") S3method(.source_items_tile,"mpc_cube_sentinel-1-grd") S3method(.source_items_tile,"mpc_cube_sentinel-1-rtc") S3method(.source_items_tile,"mpc_cube_sentinel-2-l2a") +S3method(.source_items_tile,"terrascope_cube_world-cereal-2021") S3method(.source_items_tile,"terrascope_cube_world-cover-2021") S3method(.source_items_tile,aws_cube) S3method(.source_items_tile,bdc_cube) diff --git a/R/api_cube.R b/R/api_cube.R index 8b95b97e9..f929a1ecc 100644 --- a/R/api_cube.R +++ b/R/api_cube.R @@ -1375,7 +1375,7 @@ NULL .cube_derived_class <- function(cube) { unique(slider::slide_chr(cube, .tile_derived_class)) } -# ---- mpc_cube ---- +# ---- token-related functions ---- #' @title Generate token to cube #' @name .cube_token_generator #' @keywords internal @@ -1423,12 +1423,10 @@ NULL if (all(are_token_updated)) { return(cube) } - # Verify access key if (!nzchar(access_key)) { access_key <- NULL } - cube <- slider::slide_dfr(cube, function(tile) { # Generate a random time to make a new request sleep_time <- sample.int(sleep_time, size = 1L) @@ -1470,10 +1468,42 @@ NULL cube } #' @export +`.cube_token_generator.terrascope_cube_world-cereal-2021` <- function(cube) { + # set caller to show in errors + .check_set_caller(".cube_token_generator_terrascope") + # generate and persist token + .source_terrascope_persist_token() + # return + cube +} +#' @export .cube_token_generator.default <- function(cube) { cube } - +#' @title Flush token in a cube +#' @name .cube_token_flush +#' @keywords internal +#' @noRd +#' @param cube input data cube +#' @param ... additional parameters for httr package +#' +#' @return A sits cube +.cube_token_flush <- function(cube) { + UseMethod(".cube_token_flush", cube) +} +#' @export +`.cube_token_flush.terrascope_cube_world-cereal-2021` <- function(cube) { + # set caller to show in errors + .check_set_caller(".cube_token_flush_terrascope") + # flush token + .source_terrascope_flush_token() + # return cube! + cube +} +#' @export +.cube_token_flush.default <- function(cube) { + cube +} #' @title Check if a cube token was expired #' @name .cube_is_token_expires #' @keywords internal diff --git a/R/api_download.R b/R/api_download.R index 8722b60bf..2382fddfb 100644 --- a/R/api_download.R +++ b/R/api_download.R @@ -75,6 +75,8 @@ secs_to_retry <- .conf("download_sleep_time") secs_to_retry <- sample.int(secs_to_retry, size = 1L) Sys.sleep(secs_to_retry) + # Flush token + asset <- .cube_token_flush(asset) } # Return local asset local_asset diff --git a/R/api_source_terrascope.R b/R/api_source_terrascope.R index 159dd1455..93453170a 100644 --- a/R/api_source_terrascope.R +++ b/R/api_source_terrascope.R @@ -32,15 +32,72 @@ items_info <- rstac::post_request(q = stac_query, ...) .check_stac_items(items_info) # if more than 2 times items pagination are found the progress bar - # is displayed - progress <- rstac::items_matched(items_info) > - 2L * .conf("rstac_pagination_limit") # fetching all the metadata and updating to upper case instruments items_info <- rstac::items_fetch(items = items_info, progress = FALSE) # checks if the items returned any items .check_stac_items(items_info) return(items_info) } +# ---- source api ---- +#' @title Transform an items object in an TerraScope (World Cover) cube +#' @keywords internal +#' @noRd +#' @description \code{.source_items_new()} this function is called to create +#' an items object. In case of Web services, this function is responsible for +#' making the Web requests to the server. +#' @param source Name of the STAC provider. +#' @param ... Other parameters to be passed for specific types. +#' @param collection Collection to be searched in the data source. +#' @param stac_query Query that follows the STAC protocol +#' @param tiles Selected tiles (optional) +#' @param platform Satellite platform (optional). +#' @return An object referring the images of a sits cube. +#' @export +`.source_items_new.terrascope_cube_world-cereal-2021` <- function(source, ..., + collection, + stac_query, + tiles = NULL, + platform = NULL) { + # set caller to show in errors + .check_set_caller(".source_items_new_terrascope_cube") + # force token generation + .source_terrascope_persist_token() + # convert roi to bbox + roi <- .stac_intersects_as_bbox(stac_query) + # update stac query with the new spatial reference + stac_query[["params"]][["intersects"]] <- NULL + stac_query[["params"]][["bbox"]] <- roi[["bbox"]] + # world cover product has all data available for a single date. So, fix the + # temporal interval from the query + stac_query[["params"]][["datetime"]] <- "2021-01-01T00:00:00Z/2021-12-31T00:00:00Z" + # making the request + items_info <- rstac::post_request(q = stac_query, ...) + .check_stac_items(items_info) + # if more than 2 times items pagination are found the progress bar + # fetching all the metadata and updating to upper case instruments + items_info <- rstac::items_fetch(items = items_info, progress = FALSE) + # checks if the items returned any items + .check_stac_items(items_info) + return(items_info) +} + + +#' @keywords internal +#' @noRd +#' @export +`.source_items_tile.terrascope_cube_world-cereal-2021` <- function(source, ..., + items, + collection = NULL) { + rstac::items_reap(items, field = c("id")) |> + purrr::map_chr(function(property) { + # extract tile from asset id + stringr::str_split(property, "_") |> + (\(x) x[[1]][4])() |> + stringr::str_split(":") |> + (\(x) x[[1]][2])() + }) +} + #' @keywords internal #' @noRd #' @export @@ -53,3 +110,71 @@ stringr::str_split(property, "_")[[1L]][[6L]] }) } + +# ---- token-related functions ---- +#' @title Get new Terrascope authentication token. +#' @keywords internal +#' @noRd +#' @description \code{.source_terrascope_get_token()} this function can be +#' used to authenticate gdal calls to Terrascope services. +#' @return A list object with the token details. +.source_terrascope_get_token <- function() { + # define caller + .check_set_caller(".terrascope_get_token") + # get authentication env variables + terrascope_user <- Sys.getenv("TERRASCOPE_USER") + terrascope_pass <- Sys.getenv("TERRASCOPE_PASSWORD") + # auth variables must be available + .check_that( + terrascope_user != "" || terrascope_pass != "" + ) + # get terrascope auth endpoint + terrascope_auth_endpoint <- .conf("sources", "TERRASCOPE", "auth") + # generate token + res <- httr2::request(terrascope_auth_endpoint) |> + httr2::req_body_form( + grant_type = "password", + client_id = "public", + username = terrascope_user, + password = terrascope_pass + ) |> + httr2::req_headers( + `Content-Type` = "application/x-www-form-urlencoded" + ) |> + httr2::req_perform() + # check status + httr2::resp_check_status(res) + # get request token and return! + httr2::resp_body_json(res) +} +#' @title Get and persist Terrascope authentication token. +#' @keywords internal +#' @noRd +#' @description \code{.source_terrascope_get_token()} this function can be +#' used to authenticate gdal calls to Terrascope services. To persist the +#' token, this function defines the \code{GDAL_HTTP_HEADER_FILE} env variable. +#' @return No value is returned. +.source_terrascope_persist_token <- function() { + # get auth token + terrascope_token <- .source_terrascope_get_token() + terrascope_token <- terrascope_token[["access_token"]] + # create gdal header file to persist token + gdal_header_file <- tempfile() + # format token as http authorization code + gdal_header_content <- paste("Authorization: Bearer", terrascope_token) + # save gdal header content + writeLines(gdal_header_content, gdal_header_file) + # gdal header + Sys.setenv("GDAL_HTTP_HEADER_FILE" = gdal_header_file) +} +#' @title Flush terrascope authentication token. +#' @keywords internal +#' @noRd +#' @description \code{.source_terrascope_flush_token()} this function flushes +#' the terrascope authentication token. To flush, the function removes the +#' content of the \code{GDAL_HTTP_HEADER_FILE} env variable. +#' @return No value is returned. +.source_terrascope_flush_token <- function() { + # flush header file + Sys.unsetenv("GDAL_HTTP_HEADER_FILE") +} diff --git a/R/sits_cube.R b/R/sits_cube.R index 85965e85c..fb3c1f6da 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -458,6 +458,9 @@ sits_cube.stac_cube <- function(source, ) # adjust crs of the cube before return .cube_adjust_crs(cube) + # flush any defined token + # (flush must be managed individually - global definitions may break sits) + .cube_token_flush(cube) } #' @export sits_cube.default <- function(source, collection, ...) { diff --git a/R/sits_cube_copy.R b/R/sits_cube_copy.R index f838259bf..a22cf8242 100644 --- a/R/sits_cube_copy.R +++ b/R/sits_cube_copy.R @@ -147,6 +147,10 @@ sits_cube_copy <- function(cube, # Check and return .check_empty_data_frame(cube_assets) cube_assets <- .cube_merge_tiles(cube_assets) + # Update assets class + class(cube_assets) <- class(cube) # Revert tile system name - .cube_revert_tile_name(cube_assets) + cube_assets <- .cube_revert_tile_name(cube_assets) + # Flush token + .cube_token_flush(cube_assets) } diff --git a/R/sits_plot.R b/R/sits_plot.R index fe4c0ff3a..327f77bad 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -1433,12 +1433,12 @@ plot.class_cube <- function(x, y, ..., dots <- list(...) # get tmap params from dots tmap_params <- .tmap_params_set(dots, legend_position) - # select only one tile tile <- .cube_filter_tiles(cube = x, tiles = tile) - + # generate cube toke + tile <- .cube_token_generator(tile) # plot class cube - .plot_class_image( + p <- .plot_class_image( tile = tile, roi = roi, legend = legend, @@ -1447,6 +1447,10 @@ plot.class_cube <- function(x, y, ..., max_cog_size = max_cog_size, tmap_params = tmap_params ) + # flush token + tile <- .cube_token_flush(tile) + # return plot object + p } #' @title Plot Segments #' @name plot.class_vector_cube diff --git a/R/sits_view.R b/R/sits_view.R index e6d400cba..ce79fe5c5 100644 --- a/R/sits_view.R +++ b/R/sits_view.R @@ -498,6 +498,8 @@ sits_view.class_cube <- function(x, ..., # add version if available if (.has(version)) group <- paste(group, version) + # generate token + tile <- .cube_token_generator(tile) # add a leaflet for class cube leaf_map <- leaf_map |> .view_class_cube( @@ -513,6 +515,8 @@ sits_view.class_cube <- function(x, ..., ) # include group in global control overlay_groups <- append(overlay_groups, group) + # flush token + tile <- .cube_token_flush(tile) } # add layers control and update global leaflet-related variables leaf_map <- leaf_map |> diff --git a/inst/extdata/config_colors.yml b/inst/extdata/config_colors.yml index fb9b5b220..adc1c6377 100644 --- a/inst/extdata/config_colors.yml +++ b/inst/extdata/config_colors.yml @@ -510,6 +510,7 @@ colors: Perennial_Agriculture : *perennial_crop Annual_Crop : *cropland Coffee : *perennial_crop + Non_Cropland : "#F2F3F4" # Soybean and its variations # Based on "orange" palette from Flat Design Color Chart diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index 2acabddd0..f0cad6d28 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -175,7 +175,9 @@ .cube_filter_dates: "provided dates do not match the cube timeline" .cube_labels: "input is not a valid data cube" .cube_source: "cube has different sources" +.cube_token_flush_terrascope: "it was not possible to remove terrascope token" .cube_token_generator: "invalid token to access data provider" +.cube_token_generator_terrascope: "invalid terrascope credentials" .data_get_ts: "unable to retrieve time series from data cube" .data_by_chunks: "no time series were extracted\n check samples and data cube" .data_by_tile: "no time series were extracted\n check samples and data cube" diff --git a/inst/extdata/sources/config_source_terrascope.yml b/inst/extdata/sources/config_source_terrascope.yml index 2594cf57f..6ddf5134d 100644 --- a/inst/extdata/sources/config_source_terrascope.yml +++ b/inst/extdata/sources/config_source_terrascope.yml @@ -7,6 +7,7 @@ sources: "raster_cube"] service : "STAC" url : "https://services.terrascope.be/stac/" + auth : "https://sso.terrascope.be/auth/realms/terrascope/protocol/openid-connect/token" collections : WORLD-COVER-2021 : bands : @@ -42,3 +43,24 @@ sources: ext_tolerance : 0 grid_system : "WORLD-COVER-TILES" dates : "2021" + WORLD-CEREAL-2021 : + bands : + CLASS : + bit_mask : false + band_name : "CLASSIFICATION" + values : + 0 : "Non_Cropland" + 100 : "Cropland" + resampling : "near" + resolution : 30 + data_type : "INT2U" + satellite : "SENTINEL-2" + sensor : "MSI" + collection_name : "urn:eop:VITO:ESA_WORLDCEREAL_TEMPORARYCROPS_V1" + open_data : true + open_data_token : true + class_cube : true + metadata_search : "tile" + ext_tolerance : 0 + grid_system : "WORLD-CEREAL-MOSAICS" + dates : "2021" From bc70ec783b1784a0e6ebe0ec673b58c1af9e2f47 Mon Sep 17 00:00:00 2001 From: Felipe Carlos Date: Fri, 23 May 2025 17:19:11 -0300 Subject: [PATCH 110/122] add hls collections from mpc --- NAMESPACE | 4 + R/api_source_mpc.R | 93 ++++++++++++++++ R/api_stac.R | 23 +--- inst/extdata/config_messages.yml | 2 + inst/extdata/sources/config_source_mpc.yml | 123 +++++++++++++++++++++ tests/testthat/test-cube-mpc.R | 109 ++++++++++++++++++ 6 files changed, 336 insertions(+), 18 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index e9756ef8c..3b7c641db 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -180,6 +180,8 @@ S3method(.source_items_new,deaustralia_cube_ga_s2am_ard_3) S3method(.source_items_new,deaustralia_cube_ga_s2bm_ard_3) S3method(.source_items_new,hls_cube) S3method(.source_items_new,mpc_cube) +S3method(.source_items_new,mpc_cube_hlsl30) +S3method(.source_items_new,mpc_cube_hlss30) S3method(.source_items_new,ogh_cube) S3method(.source_items_new,sdc_cube) S3method(.source_items_new,usgs_cube) @@ -203,6 +205,8 @@ S3method(.source_items_tile,cdse_cube) S3method(.source_items_tile,deafrica_cube) S3method(.source_items_tile,deaustralia_cube) S3method(.source_items_tile,hls_cube) +S3method(.source_items_tile,mpc_cube_hlsl30) +S3method(.source_items_tile,mpc_cube_hlss30) S3method(.source_items_tile,sdc_cube) S3method(.source_items_tile,usgs_cube) S3method(.source_roi_tiles,"mpc_cube_landsat-c2-l2") diff --git a/R/api_source_mpc.R b/R/api_source_mpc.R index 5ece17422..074fa31ec 100644 --- a/R/api_source_mpc.R +++ b/R/api_source_mpc.R @@ -557,6 +557,65 @@ #' @keywords internal #' @noRd #' @export +.source_items_new.mpc_cube_hlss30 <- function(source, + collection, + stac_query, ..., + tiles = NULL) { + .check_set_caller(".source_items_new_mpc_cube_hls") + + # HLSS30/HLSL30 does not support tiles - convert to ROI + if (!is.null(tiles)) { + roi <- .s2_mgrs_to_roi(tiles) + stac_query[["params"]][["intersects"]] <- NULL + stac_query[["params"]][["bbox"]] <- c( + roi[["lon_min"]], + roi[["lat_min"]], + roi[["lon_max"]], + roi[["lat_max"]] + ) + } + # Search content + items_info <- rstac::post_request(q = stac_query, ...) + .check_stac_items(items_info) + # fetching all the metadata + items_info <- suppressWarnings( + rstac::items_fetch(items = items_info, progress = FALSE) + ) + # assign href + access_key <- Sys.getenv("MPC_TOKEN") + if (!nzchar(access_key)) { + access_key <- NULL + } + # Clean old tokens cached in rstac + .mpc_clean_token_cache() + items_info <- suppressWarnings( + rstac::items_sign( + items_info, + sign_fn = rstac::sign_planetary_computer( + headers = c("Ocp-Apim-Subscription-Key" = access_key) + ) + ) + ) + return(items_info) +} +#' @keywords internal +#' @noRd +#' @export +.source_items_new.mpc_cube_hlsl30 <- function(source, + collection, + stac_query, ..., + tiles = NULL) { + .source_items_new.mpc_cube_hlss30( + source = source, + collection = collection, + stac_query = stac_query, + tiles = tiles, + ... + ) +} +#' @keywords internal +#' @noRd +#' @export `.source_items_tile.mpc_cube_sentinel-1-grd` <- function(source, items, ..., collection = NULL) { @@ -700,6 +759,38 @@ paste(feature_id[5L:length(feature_id) - 1L], collapse = "-") }) } +#' @title Organizes items by tiles for HLSS30 collections +#' @param source Name of the STAC provider. +#' @param ... Other parameters to be passed for specific types. +#' @param items \code{STACItemcollection} object from rstac package. +#' @param collection Collection to be searched in the data source. +#' @return A list of items. +#' @keywords internal +#' @noRd +#' @export +.source_items_tile.mpc_cube_hlss30 <- function(source, ..., + items, + collection = NULL) { + tiles <- strsplit(rstac::items_reap(items, field = "id"), "\\.") + tiles <- purrr::map_chr(tiles, function(x) x[[3L]]) + substr(tiles, 2L, 6L) +} +#' @title Organizes items by tiles for HLSL30 collections +#' @param source Name of the STAC provider. +#' @param ... Other parameters to be passed for specific types. +#' @param items \code{STACItemcollection} object from rstac package. +#' @param collection Collection to be searched in the data source. +#' @return A list of items. +#' @keywords internal +#' @noRd +#' @export +.source_items_tile.mpc_cube_hlsl30 <- function(source, ..., + items, + collection = NULL) { + tiles <- strsplit(rstac::items_reap(items, field = "id"), "\\.") + tiles <- purrr::map_chr(tiles, function(x) x[[3L]]) + substr(tiles, 2L, 6L) +} #' @title Filter S1 GRD tiles #' @noRd #' @param source Data source @@ -928,3 +1019,5 @@ format = "%Y-%m-%dT%H:%M:%SZ" ) } + + diff --git a/R/api_stac.R b/R/api_stac.R index 492f5dd02..81ee7d6fd 100644 --- a/R/api_stac.R +++ b/R/api_stac.R @@ -226,6 +226,10 @@ # transform date interval in date date <- as.Date(strsplit(interval, "_")[[1]][[1]], format = "%Y%m%d") + if (is.null(items_filter_date) && is.null(end_date)) { + return(TRUE) + } + # validate if ``start_date`` and ``end_date`` are in the interval is_in_interval <- (is.null(start_date) || date >= start_date) && (is.null(end_date) || date < end_date) @@ -266,20 +270,6 @@ if (is.null(limit)) { limit <- .conf("rstac_pagination_limit") } - filter_expr <- substitute( - rel == "item" && - .stac_static_date_filter( - source = source_name_, - href = href, - start_date = start_, - end_date = end_ - ), - env = list( - source_name_ = source, - start_ = start_date, - end_ = end_date - ) - ) # add source as class of source (to enable filter usage if possible) source_name <- source class(source_name) <- tolower(source) @@ -291,8 +281,5 @@ ) # read items rstac::read_stac(url) |> - rstac::read_items( - items_filter_date(x = href), - limit = limit - ) + rstac::read_items(rel == "item" && items_filter_date(href)) } diff --git a/inst/extdata/config_messages.yml b/inst/extdata/config_messages.yml index 2acabddd0..e2b696767 100644 --- a/inst/extdata/config_messages.yml +++ b/inst/extdata/config_messages.yml @@ -302,8 +302,10 @@ .source_items_new: "search returned no items - check selection parameters." .source_items_new_cdse_cube: "search returned no items - check selection parameters." .source_items_new_hls_cube: "search returned no items - check selection parameters." +.source_items_new_mpc_cube: "search returned no items - check selection parameters." .source_items_new_mpc_cube_landsat_c2_l2: "when retrieving Landsat collection in MPC searching by tiles is not allowed, use roi" .source_items_new_mpc_s1_grd: "invalid orbit parameter for MPC S1 GRD collection" +.source_items_new_mpc_cube_hls: "search returned no items - check selection parameters." .source_items_new_terrascope_cube: "search returned no items - check selection parameters." .source_filter_tiles_stac_cube: "requested tiles not available in the cube" .source_roi_tiles_mpc_cube_landsat_c2_l2: "error when retrieving Landsat MPC collection\n searching by tiles not allowed, use roi" diff --git a/inst/extdata/sources/config_source_mpc.yml b/inst/extdata/sources/config_source_mpc.yml index 8cb1cb14a..f080d92db 100644 --- a/inst/extdata/sources/config_source_mpc.yml +++ b/inst/extdata/sources/config_source_mpc.yml @@ -355,3 +355,126 @@ sources: ext_tolerance: 0 grid_system : "NoTilingSystem" dates : "2014 to now" + HLSS30 : + bands : + COASTAL-AEROSOL: &mspc_hls_s2_30m + missing_value : -9999 + minimum_value : 0 + maximum_value : 10000 + scale_factor : 0.0001 + offset_value : 0 + resolution : 30 + band_name : "B01" + data_type : "INT2S" + BLUE : + <<: *mspc_hls_s2_30m + band_name : "B02" + GREEN : + <<: *mspc_hls_s2_30m + band_name : "B03" + RED : + <<: *mspc_hls_s2_30m + band_name : "B04" + RED-EDGE-1: + <<: *mspc_hls_s2_30m + band_name : "B05" + RED-EDGE-2: + <<: *mspc_hls_s2_30m + band_name : "B06" + RED-EDGE-3: + <<: *mspc_hls_s2_30m + band_name : "B07" + NIR-BROAD: + <<: *mspc_hls_s2_30m + band_name : "B08" + NIR-NARROW: + <<: *mspc_hls_s2_30m + band_name : "B8A" + WATER-VAPOR: + <<: *mspc_hls_s2_30m + band_name : "B09" + SWIR-1 : + <<: *mspc_hls_s2_30m + band_name : "B11" + SWIR-2 : + <<: *mspc_hls_s2_30m + band_name : "B12" + CLOUD : + bit_mask : true + band_name : "Fmask" + values : + 0 : "Cirrus" + 1 : "Cloud" + 2 : "Adjacent to cloud/shadow" + 3 : "Cloud shadow" + 4 : "Snow/ice" + 5 : "Water" + 6 : "Aerosol level (low)" + 7 : "Aerosol level (moderate or high)" + interp_values : [1, 2, 3, 7] + resampling : "near" + resolution : 30 + data_type : "INT1U" + satellite : "SENTINEL-2" + sensor : "MSI" + collection_name: "hls2-s30" + open_data: true + open_data_token: false + metadata_search : "tile" + ext_tolerance: 0 + grid_system : "MGRS" + dates : "2015 to now" + HLSL30 : + bands : + COASTAL-AEROSOL: &mspc_hls_l8_30m + missing_value : -9999 + minimum_value : 0 + maximum_value : 10000 + scale_factor : 0.0001 + offset_value : 0 + resolution : 30 + band_name : "B01" + data_type : "INT2S" + BLUE : + <<: *mspc_hls_l8_30m + band_name : "B02" + GREEN : + <<: *mspc_hls_l8_30m + band_name : "B03" + RED : + <<: *mspc_hls_l8_30m + band_name : "B04" + NIR-NARROW: + <<: *mspc_hls_l8_30m + band_name : "B05" + SWIR-1 : + <<: *mspc_hls_l8_30m + band_name : "B06" + SWIR-2 : + <<: *mspc_hls_l8_30m + band_name : "B07" + CLOUD : + bit_mask : true + band_name : "Fmask" + values : + 0 : "Cirrus" + 1 : "Cloud" + 2 : "Adjacent to cloud/shadow" + 3 : "Cloud shadow" + 4 : "Snow/ice" + 5 : "Water" + 6 : "Aerosol level (low)" + 7 : "Aerosol level (moderate or high)" + interp_values : [1, 2, 3, 7] + resampling : "near" + resolution : 30 + data_type : "INT1U" + satellite : "LANDSAT-8" + sensor : "OLI" + collection_name: "hls2-l30" + open_data: true + open_data_token: false + metadata_search : "tile" + ext_tolerance: 0 + grid_system : "MGRS" + dates : "2013 to now" diff --git a/tests/testthat/test-cube-mpc.R b/tests/testthat/test-cube-mpc.R index f60cd7e50..cb5210c89 100644 --- a/tests/testthat/test-cube-mpc.R +++ b/tests/testthat/test-cube-mpc.R @@ -328,6 +328,115 @@ test_that("Creating cubes from MPC - MOD10A1-6.1 based on ROI using sf", { tile_h18v4 <- .cube_filter_tiles(modis10a1_cube, "h18v4") expect_equal(nrow(tile_h18v4), 1) }) +test_that("Creating cubes from MPC - Harmonized Landsat Sentinel HLSS30-HLSL30 (roi)", { + roi <- .s2_mgrs_to_roi("20LKP") + hls_cube_s2 <- .try( + { + sits_cube( + source = "MPC", + collection = "HLSS30", + roi = roi, + bands = c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"), + start_date = as.Date("2022-07-01"), + end_date = as.Date("2022-09-01"), + progress = FALSE + ) + }, + .default = NULL + ) + testthat::skip_if( + purrr::is_null(hls_cube_s2), + "MPC HLSS30 collection is not accessible" + ) + expect_true(all(sits_bands(hls_cube_s2) %in% + c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"))) + expect_true(all(hls_cube_s2$satellite == "SENTINEL-2")) + expect_true(all("20LKP" %in% hls_cube_s2$tile)) + expect_true(all(.fi(hls_cube_s2)$xres == 30)) + expect_true(all(.fi(hls_cube_s2)$yres == 30)) + rast <- .raster_open_rast(hls_cube_s2$file_info[[1]]$path[1]) + tile_nrows <- .tile_nrows(hls_cube_s2)[[1]] + expect_true(.raster_nrows(rast) == tile_nrows) + + hls_cube_l8 <- .try( + { + sits_cube( + source = "MPC", + collection = "HLSL30", + roi = roi, + bands = c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"), + start_date = as.Date("2022-07-01"), + end_date = as.Date("2022-09-01"), + progress = FALSE + ) + }, + .default = NULL + ) + testthat::skip_if( + purrr::is_null(hls_cube_l8), + "MPC HLSL30 collection is not accessible" + ) + expect_true(all(sits_bands(hls_cube_l8) %in% + c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"))) + expect_true(all(hls_cube_l8$satellite == "LANDSAT-8")) + expect_true(all(c("20LKP", "20LLP") %in% hls_cube_s2$tile)) + expect_true(all(.fi(hls_cube_l8)$xres == 30)) + expect_true(all(.fi(hls_cube_l8)$yres == 30)) +}) +test_that("Creating cubes from MPC - Harmonized Landsat Sentinel HLSS30-HLSL30 (tiles)", { + hls_cube_s2 <- .try( + { + sits_cube( + source = "MPC", + collection = "HLSS30", + tiles = c("20LKP"), + bands = c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"), + start_date = as.Date("2022-07-01"), + end_date = as.Date("2022-09-01"), + progress = FALSE + ) + }, + .default = NULL + ) + testthat::skip_if( + purrr::is_null(hls_cube_s2), + "MPC HLSS30 collection is not accessible" + ) + expect_true(all(sits_bands(hls_cube_s2) %in% + c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"))) + expect_true(all(hls_cube_s2$satellite == "SENTINEL-2")) + expect_true(all(hls_cube_s2$tile %in% c("20LKP", "20LLP"))) + expect_true(all(.fi(hls_cube_s2)$xres == 30)) + expect_true(all(.fi(hls_cube_s2)$yres == 30)) + rast <- .raster_open_rast(hls_cube_s2$file_info[[1]]$path[1]) + tile_nrows <- .tile_nrows(hls_cube_s2)[[1]] + expect_true(.raster_nrows(rast) == tile_nrows) + + hls_cube_l8 <- .try( + { + sits_cube( + source = "MPC", + collection = "HLSL30", + tiles = c("20LKP"), + bands = c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"), + start_date = as.Date("2022-07-01"), + end_date = as.Date("2022-09-01"), + progress = FALSE + ) + }, + .default = NULL + ) + testthat::skip_if( + purrr::is_null(hls_cube_l8), + "MPC HLSL30 collection is not accessible" + ) + expect_true(all(sits_bands(hls_cube_l8) %in% + c("GREEN", "NIR-NARROW", "SWIR-1", "CLOUD"))) + expect_true(all(hls_cube_l8$satellite == "LANDSAT-8")) + expect_true(all(hls_cube_s2$tile %in% c("20LKP", "20LLP"))) + expect_true(all(.fi(hls_cube_l8)$xres == 30)) + expect_true(all(.fi(hls_cube_l8)$yres == 30)) +}) test_that("Accessing COP-DEM-30 from MPC", { cube_dem <- sits_cube( source = "MPC", From 32bcb5ffb5890434e722afbf961373454e8de0b1 Mon Sep 17 00:00:00 2001 From: Felipe Carlos Date: Fri, 23 May 2025 17:26:40 -0300 Subject: [PATCH 111/122] update namespace with new functions --- NAMESPACE | 3 --- 1 file changed, 3 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index f0bebb6f2..bfff634a5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -201,11 +201,8 @@ S3method(.source_items_tile,"mpc_cube_mod13q1-6.1") S3method(.source_items_tile,"mpc_cube_sentinel-1-grd") S3method(.source_items_tile,"mpc_cube_sentinel-1-rtc") S3method(.source_items_tile,"mpc_cube_sentinel-2-l2a") -<<<<<<< HEAD S3method(.source_items_tile,"ogh_cube_landsat-glad-2m") -======= S3method(.source_items_tile,"terrascope_cube_world-cereal-2021") ->>>>>>> 14f4499e5efc195a24be6c54b9840ea89822572c S3method(.source_items_tile,"terrascope_cube_world-cover-2021") S3method(.source_items_tile,aws_cube) S3method(.source_items_tile,bdc_cube) From 283982d7042a3d987a9487de1f7ea1b250123560 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sat, 24 May 2025 23:09:44 +0000 Subject: [PATCH 112/122] add first version of sits_roi_to_tiles function --- R/sits_roi_to_tiles.R | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 R/sits_roi_to_tiles.R diff --git a/R/sits_roi_to_tiles.R b/R/sits_roi_to_tiles.R new file mode 100644 index 000000000..4451b18e1 --- /dev/null +++ b/R/sits_roi_to_tiles.R @@ -0,0 +1,15 @@ +sits_roi_to_tiles <- function(roi, grid_system = "mgrs") { + .check_roi(roi) + grid_system <- toupper(grid_system) + .check_grid_system(grid_system) + roi <- .roi_as_sf(roi) + tiles_filtered <- .grid_filter_tiles( + grid_system = grid_system, tiles = NULL, roi = roi + ) + tiles_intersection <- sf::st_intersection( + x = tiles_filtered, y = roi + ) + tiles_intersection[["area"]] <- sf::st_area(tiles_intersection) + tiles_intersection[["cover_percentage"]] <- sf::st_area(tiles_filtered) + tiles_intersection[, c("tile_id", "epsg", "cover_percentage")] +} From ab5d903c6492ea592bae6100fe23412196436e0a Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 25 May 2025 18:40:13 +0000 Subject: [PATCH 113/122] remove warning from BDC grid system --- R/api_grid.R | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/R/api_grid.R b/R/api_grid.R index 83c9210a1..37c765e41 100644 --- a/R/api_grid.R +++ b/R/api_grid.R @@ -146,14 +146,11 @@ # Just to ensure that we will reproject less data if (.has(roi)) { - roi <- .roi_as_sf(roi, as_crs = .vector_crs(bdc_tiles)) - bdc_tiles <- bdc_tiles[.intersects(bdc_tiles, roi), ] + roi <- suppressWarnings(.roi_as_sf(roi, as_crs = .vector_crs(bdc_tiles))) + bdc_tiles <- suppressWarnings(bdc_tiles[.intersects(bdc_tiles, roi), ]) } # Transform each sf to WGS84 and merge them into a single one sf object - sf::st_transform( - x = bdc_tiles, - crs = "EPSG:4326" - ) + suppressWarnings(sf::st_transform(x = bdc_tiles,crs = "EPSG:4326")) } #' @title Filter tiles in different grid system #' @name .grid_filter_tiles From a6d10bf1d15fa5624283bef00f26cc5a44e29382 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 25 May 2025 18:41:08 +0000 Subject: [PATCH 114/122] add .space and .intersection functions --- R/api_space_time_operations.R | 55 +++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) diff --git a/R/api_space_time_operations.R b/R/api_space_time_operations.R index 8b568aef8..1687eb22d 100644 --- a/R/api_space_time_operations.R +++ b/R/api_space_time_operations.R @@ -162,6 +162,61 @@ y <- sf::st_transform(y, crs = as_crs) suppressMessages(sf::st_difference(x, y)) } + +#' @title Spatial intersection +#' @noRd +#' +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' +#' @description +#' This function is based on sf::intersection(). It projects y +#' to the CRS of x before compute intersection operation. It returns the +#' intersection geometries between x and y. +#' +#' @param x,y sf geometries. +#' +#' @returns A sf object with the intersection geometries between x and y. +#' +#' @examples +#' if (sits_run_examples()) { +#' x <- .roi_as_sf(c(lon_min = 0, lon_max = 3, lat_min = 2, lat_max = 5)) +#' y <- .roi_as_sf( +#' c(lon_min = 1, lon_max = 3, lat_min = 2, lat_max = 7, crs = 4326) +#' ) +#' .intersection(x, y) +#' } +#' +.intersection <- function(x, y) { + as_crs <- sf::st_crs(x) + y <- sf::st_transform(y, crs = as_crs) + suppressWarnings(sf::st_intersection(x, y)) +} + +#' @title Spatial area +#' @noRd +#' +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' +#' @description +#' This function is based on sf::area(). It returns the +#' area of x geometries. +#' +#' @param x sf geometries. +#' +#' @returns A vector with each geometries area. +#' +#' @examples +#' if (sits_run_examples()) { +#' x <- .roi_as_sf(c(lon_min = 0, lon_max = 3, lat_min = 2, lat_max = 5)) +#' .area(x) +#' } +#' +.area <- function(x) { + suppressMessages(sf::st_area(x)) +} + #' @title Find the closest points. #' #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} From 32ce38a9b06a607b9422e7453741094abb583b1a Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 25 May 2025 18:42:11 +0000 Subject: [PATCH 115/122] introduces sits_filter_tiles (closes #1304) --- R/sits_find_tiles.R | 79 ++++++++++++++++++++++++++++++++++++++++++ R/sits_roi_to_tiles.R | 15 -------- man/sits_find_tiles.Rd | 67 +++++++++++++++++++++++++++++++++++ 3 files changed, 146 insertions(+), 15 deletions(-) create mode 100644 R/sits_find_tiles.R delete mode 100644 R/sits_roi_to_tiles.R create mode 100644 man/sits_find_tiles.Rd diff --git a/R/sits_find_tiles.R b/R/sits_find_tiles.R new file mode 100644 index 000000000..eeb18bf7b --- /dev/null +++ b/R/sits_find_tiles.R @@ -0,0 +1,79 @@ +#' @title Find tiles of a given ROI and Grid System +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @name sits_find_tiles +#' +#' @description Given an ROI and grid system, this function finds the +#' intersected tiles and returns them as an SF object. +#' +#' @param roi Region of interest (see notes below). +#' @param crs Coordinate Reference System (CRS) of the roi. +#' (see details below). +#' @param grid_system Grid system to be used for the output images. +#' (Default is "MGRS") +#' +#' @note +#' To define a \code{roi} use one of: +#' \itemize{ +#' \item{A path to a shapefile with polygons;} +#' \item{A \code{sfc} or \code{sf} object from \code{sf} package;} +#' \item{A \code{SpatExtent} object from \code{terra} package;} +#' \item{A named \code{vector} (\code{"lon_min"}, +#' \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84;} +#' \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, +#' \code{"ymin"}, \code{"ymax"}) with XY coordinates.} +#' } +#' +#' Defining a region of interest using \code{SpatExtent} or XY values not +#' in WGS84 requires the \code{crs} parameter to be specified. +#' \code{sits_regularize()} function will crop the images +#' that contain the region of interest(). +#' +#' The \code{grid_system} parameter allows the user to +#' reproject the files to a grid system which is +#' different from that used in the ARD image collection of +#' the could provider. Currently, the package supports +#' the use of MGRS grid system and those used by the Brazil +#' Data Cube ("BDC_LG_V2" "BDC_MD_V2" "BDC_SM_V2"). +#' +#'@examples +#' if (sits_run_examples()) { +#' # Defining a ROI +#' roi <- c( +#' lon_min = -64.037, +#' lat_min = -9.644, +#' lon_max = -63.886, +#' lat_max = -9.389 +#' ) +#' # Finding tiles +#' tiles <- sits_find_tiles(roi) +#' } +#' @return A \code{sf} object with the intersect tiles with three columns +#' tile_id, epsg, and the percentage of coverage area. +sits_find_tiles <- function(roi, crs = NULL, grid_system = "MGRS") { + # Pre-conditions + grid_system <- toupper(grid_system) + .check_grid_system(grid_system) + # Find the intersected tiles + roi <- .roi_as_sf(roi, default_crs = crs) + # Add a small buffer when a single point is provided + if (length(sf::st_geometry_type(roi)) == 1 && + sf::st_geometry_type(roi) == "POINT") { + roi <- sf::st_buffer(roi, dist = 0.00001) + } + tiles <- .grid_filter_tiles( + grid_system = grid_system, roi = roi, tiles = NULL + ) + # columns to select + cols_to_select <- c("tile_id") + # Compute the coverage area + if (all(sf::st_geometry_type(roi) %in% c("POLYGON", "MULTIPOLYGON"))) { + inter_tile <- .intersection(tiles, roi) + tiles[["coverage_percentage"]] <- .as_dbl(round( + (.area(inter_tile) / .area(tiles)) * 100, digits = 2 + )) + cols_to_select <- c(cols_to_select, "coverage_percentage") + } + # Return sf object with filtered columns + tiles[, cols_to_select] +} diff --git a/R/sits_roi_to_tiles.R b/R/sits_roi_to_tiles.R deleted file mode 100644 index 4451b18e1..000000000 --- a/R/sits_roi_to_tiles.R +++ /dev/null @@ -1,15 +0,0 @@ -sits_roi_to_tiles <- function(roi, grid_system = "mgrs") { - .check_roi(roi) - grid_system <- toupper(grid_system) - .check_grid_system(grid_system) - roi <- .roi_as_sf(roi) - tiles_filtered <- .grid_filter_tiles( - grid_system = grid_system, tiles = NULL, roi = roi - ) - tiles_intersection <- sf::st_intersection( - x = tiles_filtered, y = roi - ) - tiles_intersection[["area"]] <- sf::st_area(tiles_intersection) - tiles_intersection[["cover_percentage"]] <- sf::st_area(tiles_filtered) - tiles_intersection[, c("tile_id", "epsg", "cover_percentage")] -} diff --git a/man/sits_find_tiles.Rd b/man/sits_find_tiles.Rd new file mode 100644 index 000000000..43ab4985d --- /dev/null +++ b/man/sits_find_tiles.Rd @@ -0,0 +1,67 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_find_tiles.R +\name{sits_find_tiles} +\alias{sits_find_tiles} +\title{Find tiles of a given ROI and Grid System} +\usage{ +sits_find_tiles(roi, crs = NULL, grid_system = "MGRS") +} +\arguments{ +\item{roi}{Region of interest (see notes below).} + +\item{crs}{Coordinate Reference System (CRS) of the roi. +(see details below).} + +\item{grid_system}{Grid system to be used for the output images. +(Default is "MGRS")} +} +\value{ +A \code{sf} object with the intersect tiles with three columns +tile_id, epsg, and the percentage of coverage area. +} +\description{ +Given an ROI and grid system, this function finds the +intersected tiles and returns them as an SF object. +} +\note{ +To define a \code{roi} use one of: + \itemize{ + \item{A path to a shapefile with polygons;} + \item{A \code{sfc} or \code{sf} object from \code{sf} package;} + \item{A \code{SpatExtent} object from \code{terra} package;} + \item{A named \code{vector} (\code{"lon_min"}, + \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84;} + \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, + \code{"ymin"}, \code{"ymax"}) with XY coordinates.} + } + + Defining a region of interest using \code{SpatExtent} or XY values not + in WGS84 requires the \code{crs} parameter to be specified. + \code{sits_regularize()} function will crop the images + that contain the region of interest(). + + The \code{grid_system} parameter allows the user to + reproject the files to a grid system which is + different from that used in the ARD image collection of + the could provider. Currently, the package supports + the use of MGRS grid system and those used by the Brazil + Data Cube ("BDC_LG_V2" "BDC_MD_V2" "BDC_SM_V2"). +} +\examples{ +if (sits_run_examples()) { +# Defining a ROI +roi <- c( + lon_min = -64.037, + lat_min = -9.644, + lon_max = -63.886, + lat_max = -9.389 +) +# Finding tiles +tiles <- sits_find_tiles(roi) +} +} +\author{ +Felipe Carvalho, \email{felipe.carvalho@inpe.br} + +Felipe Carlos, \email{efelipecarlos@gmail.com} +} From 5fcc1175b6f09c4759a2b32cbdb7eefa395925b2 Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 25 May 2025 18:42:22 +0000 Subject: [PATCH 116/122] update docs --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index be0d4fb64..40e075bb9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -233,6 +233,7 @@ Collate: 'sits_dtw.R' 'sits_factory.R' 'sits_filters.R' + 'sits_find_tiles.R' 'sits_geo_dist.R' 'sits_get_data.R' 'sits_get_class.R' From 250121b9a5a43f398f4a101f168fbc9f9d86b81e Mon Sep 17 00:00:00 2001 From: Felipe Date: Sun, 25 May 2025 18:42:39 +0000 Subject: [PATCH 117/122] add tests for sits_filter_tiles --- tests/testthat/test-find_tiles.R | 100 +++++++++++++++++++++++++++++++ 1 file changed, 100 insertions(+) create mode 100644 tests/testthat/test-find_tiles.R diff --git a/tests/testthat/test-find_tiles.R b/tests/testthat/test-find_tiles.R new file mode 100644 index 000000000..ac57bfedb --- /dev/null +++ b/tests/testthat/test-find_tiles.R @@ -0,0 +1,100 @@ +test_that("Find MGRS tiles with bbox", { + roi1 <- c( + lon_min = -64.03732099, + lat_min = -9.64467633, + lon_max = -63.88698997, + lat_max = -9.38935222 + ) + + tiles <- sits_find_tiles(roi1) + expect_s3_class(tiles, "sf") + expect_equal( + colnames(tiles), c("tile_id", "coverage_percentage", "geom") + ) + expect_equal(tiles[["tile_id"]], c("20LLQ", "20LMQ")) +}) + +test_that("Find MGRS tiles with multipolygon", { + roi1 <- c( + lon_min = -64.03732099, + lat_min = -9.64467633, + lon_max = -63.88698997, + lat_max = -9.38935222 + ) + roi1 <- .roi_as_sf(roi1) + roi2 <- c( + lon_min = -65.04532648, + lat_min = -9.68396664, + lon_max = -64.93041845, + lat_max = -9.57234169 + ) + roi2 <- .roi_as_sf(roi2) + polys <- dplyr::bind_rows(list(roi1, roi2)) + multi_poly <- sf::st_cast(polys, "MULTIPOLYGON") + + tiles <- sits_find_tiles(multi_poly) + expect_s3_class(tiles, "sf") + expect_equal( + colnames(tiles), c("tile_id", "coverage_percentage", "geom") + ) + expect_equal(tiles[["tile_id"]], c("20LKQ", "20LLQ", "20LMQ")) +}) + +test_that("Find MGRS tiles with points", { + pt1 <- sf::st_point(c(-64.3887, -10.4357)) + pt <- sf::st_sfc(pt1, crs = 4326) + tiles <- sits_find_tiles(pt) + expect_s3_class(tiles, "sf") + # We apply a small buffer in the point, turning it into a polygon. + expect_equal( + colnames(tiles), c("tile_id", "coverage_percentage", "geom") + ) + expect_equal(tiles[["tile_id"]], c("20LLP")) + + pt2 <- sf::st_point(c(-63.4497, -12.1725)) + pts <- sf::st_sfc(pt1, pt2, crs = 4326) + tiles <- sits_find_tiles(pts) + expect_s3_class(tiles, "sf") + expect_equal( + colnames(tiles), c("tile_id", "geom") + ) + expect_equal(tiles[["tile_id"]], c("20LLP", "20LMM")) +}) + +test_that("Find BDC tiles with bbox", { + roi <- c( + lon_min = -71.66605459, + lat_min = -8.65079126, + lon_max = -71.58148249, + lat_max = -8.56555523 + ) + + tiles <- sits_find_tiles(roi, grid_system = "BDC_SM_V2") + expect_s3_class(tiles, "sf") + # We apply a small buffer in the point, turning it into a polygon. + expect_equal( + colnames(tiles), c("tile_id", "coverage_percentage", "geom") + ) + expect_equal(tiles[["tile_id"]], c("004015")) +}) + +test_that("Find BDC tiles with points", { + pt1 <- sf::st_point(c(-64.3887, -10.4357)) + pt <- sf::st_sfc(pt1, crs = 4326) + tiles <- sits_find_tiles(pt, grid_system = "BDC_SM_V2") + expect_s3_class(tiles, "sf") + # We apply a small buffer in the point, turning it into a polygon. + expect_equal( + colnames(tiles), c("tile_id", "coverage_percentage", "geom") + ) + expect_equal(tiles[["tile_id"]], c("011017")) + + pt2 <- sf::st_point(c(-63.4497, -12.1725)) + pts <- sf::st_sfc(pt1, pt2, crs = 4326) + tiles <- sits_find_tiles(pts, grid_system = "BDC_SM_V2") + expect_s3_class(tiles, "sf") + expect_equal( + colnames(tiles), c("tile_id", "geom") + ) + expect_equal(tiles[["tile_id"]], c("011017", "012018")) +}) From e252315f0c8d0a2da7a7de51e042c6a7e1fd5053 Mon Sep 17 00:00:00 2001 From: Felipe Carlos Date: Sun, 25 May 2025 16:19:13 -0300 Subject: [PATCH 118/122] fix ogh data load --- NAMESPACE | 3 +- R/api_source_ogh.R | 6 ++-- R/api_stac.R | 82 ++++++++++++++++++++++++++-------------------- R/zzz.R | 1 - 4 files changed, 52 insertions(+), 40 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index bfff634a5..ffb94e983 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -222,7 +222,8 @@ S3method(.source_tile_get_bbox,"mpc_cube_cop-dem-glo-30") S3method(.source_tile_get_bbox,"mpc_cube_sentinel-1-grd") S3method(.source_tile_get_bbox,"mpc_cube_sentinel-1-rtc") S3method(.source_tile_get_bbox,stac_cube) -S3method(.stac_static_date_filter,ogh) +S3method(.stac_static_link_filter,default) +S3method(.stac_static_link_filter,ogh) S3method(.tile,default) S3method(.tile,raster_cube) S3method(.tile_area_freq,class_cube) diff --git a/R/api_source_ogh.R b/R/api_source_ogh.R index 85693489c..03b34f564 100644 --- a/R/api_source_ogh.R +++ b/R/api_source_ogh.R @@ -82,14 +82,14 @@ tiles = NULL, platform = NULL) { .check_set_caller(".source_items_new_ogh_cube") - # query items + # transform ``datetime`` to ``start_date`` and ``end_date`` datetime <- stac_query[["params"]][["datetime"]] datetime <- stringr::str_split(datetime, "/") datetime <- datetime[[1]] - + # get ``start_date`` and ``end_date`` start_date <- datetime[[1]] end_date <- datetime[[2]] - + # read static items from ogh items <- .try( { .stac_static_items_query( diff --git a/R/api_stac.R b/R/api_stac.R index 81ee7d6fd..6da7ace4e 100644 --- a/R/api_stac.R +++ b/R/api_stac.R @@ -199,48 +199,46 @@ # format as datetime (RFC 3339) paste(format(as.Date(dates_chr), "%Y-%m-%dT%H:%M:%SZ"), collapse = "/") } - - #' @title Date filter function for STAC static #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @author Felipe Carvalho, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd -.stac_static_date_filter <- function(source, start_date, end_date) { - UseMethod(".stac_static_date_filter") +.stac_static_link_filter <- function(source, collection, href, + start_date, end_date) { + UseMethod(".stac_static_link_filter") } - - #' @title Date filter function for STAC static of Open Geo Hub #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @author Felipe Carvalho, \email{lipecaso@@gmail.com} #' @keywords internal #' @noRd #' @export -.stac_static_date_filter.ogh <- function(source, start_date, end_date) { - # define Open Geo Hub compatible date filter - date_filter_fnc <- function(x) { - # extract date interval - interval <- gsub("^.*([0-9]{8}_[0-9]{8})\\.json$", "\\1", x) +.stac_static_link_filter.ogh <- function(source, collection, href, + start_date, end_date) { + # extract date interval + interval <- gsub("^.*([0-9]{8}_[0-9]{8})\\.json$", "\\1", href) - # transform date interval in date - date <- as.Date(strsplit(interval, "_")[[1]][[1]], format = "%Y%m%d") + # transform date interval in date + date <- as.Date(strsplit(interval, "_")[[1]][[1]], format = "%Y%m%d") - if (is.null(items_filter_date) && is.null(end_date)) { - return(TRUE) - } + # validate if ``start_date`` and ``end_date`` are in the interval + is_in_interval <- (is.null(start_date) || date >= start_date) && + (is.null(end_date) || date < end_date) - # validate if ``start_date`` and ``end_date`` are in the interval - is_in_interval <- (is.null(start_date) || date >= start_date) && - (is.null(end_date) || date < end_date) - - # return! - return(is_in_interval) - } # return! - return(date_filter_fnc) + return(is_in_interval) +} +#' @title Default date filter function for STAC static +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' @author Felipe Carvalho, \email{lipecaso@@gmail.com} +#' @keywords internal +#' @noRd +#' @export +.stac_static_link_filter.default <- function(source, collection, href, + start_date, end_date) { + return(TRUE) } - #' @title Get items from a static STAC #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @author Felipe Carvalho, \email{lipecaso@@gmail.com} @@ -270,16 +268,30 @@ if (is.null(limit)) { limit <- .conf("rstac_pagination_limit") } - # add source as class of source (to enable filter usage if possible) + # read stac + stac_obj <- rstac::read_stac(url) + # get items links + items_links <- rstac::links(stac_obj) + # prepare source to define items filter source_name <- source class(source_name) <- tolower(source) - # prepare date filter - items_filter_date <- .stac_static_date_filter( - source = source_name, - start_date = start_date, - end_date = end_date - ) - # read items - rstac::read_stac(url) |> - rstac::read_items(rel == "item" && items_filter_date(href)) + # filter links + items_links <- purrr::map_lgl(items_links, function(link) { + # check if link is from an item + is_item = link[["rel"]] == "item" + # apply general static filter + is_selected <- .stac_static_link_filter( + source = source_name, + collection = collection, + href = link[["href"]], + start_date = start_date, + end_date = end_date + ) + # return + is_item && is_selected + }) + # update stac object with selected links + stac_obj[["links"]] <- stac_obj[["links"]][items_links] + # read links + rstac::read_items(stac_obj, limit = limit, progress = FALSE) } diff --git a/R/zzz.R b/R/zzz.R index c4e27925d..ffb020613 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -33,7 +33,6 @@ utils::globalVariables(c( "normal", "lognormal", "loguniform", # sits_tuning "geometry", # sf operations "value", "label", "Eval", # ggplot - "href", # rstac items (static catalog) "sar:frequency_band", "sar:instrument_mode", "sat:orbit_state" # S1 stac )) #' @importFrom lubridate %within% %m+% From 480bbcae83d04d7efa57d27b5afd31a19aa126d2 Mon Sep 17 00:00:00 2001 From: Felipe Carlos Date: Sun, 25 May 2025 16:24:07 -0300 Subject: [PATCH 119/122] update static items filter docs --- R/api_stac.R | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/R/api_stac.R b/R/api_stac.R index 6da7ace4e..b614db6e6 100644 --- a/R/api_stac.R +++ b/R/api_stac.R @@ -202,6 +202,12 @@ #' @title Date filter function for STAC static #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} #' @author Felipe Carvalho, \email{lipecaso@@gmail.com} +#' @param source Source name (must have a class with the same name as +#' the source). +#' @param collection Collection name. +#' @param href Link to the current item. +#' @param start_date Start date. +#' @param end_date End date. #' @keywords internal #' @noRd .stac_static_link_filter <- function(source, collection, href, From 0bcb64834138f765e49c4b2facb85c23dd7865b2 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Tue, 27 May 2025 11:47:12 -0300 Subject: [PATCH 120/122] fix bug in plot sits time series --- R/sits_plot.R | 133 ++++++++++++++++----- inst/extdata/config_colors.yml | 75 +++++++++--- inst/extdata/sources/config_source_bdc.yml | 2 +- man/plot.Rd | 2 +- man/plot.som_evaluate_cluster.Rd | 13 +- 5 files changed, 171 insertions(+), 54 deletions(-) diff --git a/R/sits_plot.R b/R/sits_plot.R index 15856d1d9..fdf75f78b 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -45,13 +45,13 @@ #' } #' #' @export -plot.sits <- function(x, y, ..., together = FALSE) { +plot.sits <- function(x, y, ..., together = TRUE) { .check_set_caller(".plot_sits") 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 (together || nrow(x) > 30L) { + # By default, plot them together! + if (together) { .plot_together(x) } else { # otherwise, take "allyears" as the default @@ -1707,8 +1707,59 @@ plot.sits_accuracy <- function(x, y, ..., title = "Confusion matrix") { #' } #' @export #' +# plot.som_evaluate_cluster <- function(x, y, ..., +# legend = NULL, +# name_cluster = NULL, +# title = "Confusion by cluster") { +# stopifnot(missing(y)) +# data <- x +# if (!inherits(data, "som_evaluate_cluster")) { +# message(.conf("messages", ".plot_som_evaluate_cluster")) +# return(invisible(NULL)) +# } +# +# # Filter the cluster to plot +# if (!(is.null(name_cluster))) { +# data <- dplyr::filter(data, .data[["cluster"]] %in% name_cluster) +# } +# # configure plot colors +# # convert legend from tibble to vector +# if (.has(legend)) { +# legend <- .colors_legend_set(legend) +# } +# # get labels from cluster table +# labels <- unique(data[["class"]]) +# colors <- .colors_get( +# labels = labels, +# legend = legend, +# palette = "Set3", +# rev = TRUE +# ) +# +# p <- ggplot2::ggplot() + +# ggplot2::geom_bar( +# ggplot2::aes( +# y = .data[["mixture_percentage"]], +# x = .data[["cluster"]], +# fill = class +# ), +# data = data, +# stat = "identity", +# position = ggplot2::position_dodge() +# ) + +# ggplot2::theme_minimal() + +# ggplot2::theme( +# axis.text.x = +# ggplot2::element_text(angle = 60.0, hjust = 1.0) +# ) + +# ggplot2::labs(x = "Class", y = "Percentage of mixture") + +# ggplot2::scale_fill_manual(name = "Class label", values = colors) + +# ggplot2::ggtitle(title) +# +# p <- graphics::plot(p) +# invisible(p) +# } plot.som_evaluate_cluster <- function(x, y, ..., - legend = NULL, name_cluster = NULL, title = "Confusion by cluster") { stopifnot(missing(y)) @@ -1723,41 +1774,69 @@ plot.som_evaluate_cluster <- function(x, y, ..., data <- dplyr::filter(data, .data[["cluster"]] %in% name_cluster) } # configure plot colors - # convert legend from tibble to vector - if (.has(legend)) { - legend <- .colors_legend_set(legend) - } # get labels from cluster table labels <- unique(data[["class"]]) colors <- .colors_get( labels = labels, - legend = legend, - palette = "Set3", + legend = NULL, + palette = "Spectral", rev = TRUE ) - p <- ggplot2::ggplot() + + # Optional ordering of clusters or classes by dominant mixture (clearer visual interpretation) + # Calculate dominant class by cluster + dominant <- data |> + dplyr::group_by(cluster, class) |> + dplyr::summarise(total = sum(mixture_percentage), .groups = "drop") |> + dplyr::group_by(cluster) |> + dplyr::slice_max(total, n = 1) |> + dplyr::arrange(desc(total)) |> + dplyr::pull(cluster) |> + unique() # + + # convert some elements in factor and filter percentage for plot + data_conv <- data |> + # Show labels only for percentages greater than 3% (for better visualization) + dplyr::mutate(label = ifelse(mixture_percentage < 3, NA, mixture_percentage), + class = as.factor(class), + cluster = factor(cluster, levels = dominant)) + + # Stacked bar graphs for confusion by cluster + g <- ggplot2::ggplot( + data_conv, + ggplot2::aes( + x = mixture_percentage, + y = factor(cluster, levels = rev(levels(cluster))), + fill = class)) + ggplot2::geom_bar( - ggplot2::aes( - y = .data[["mixture_percentage"]], - x = .data[["cluster"]], - fill = class - ), - data = data, stat = "identity", - position = ggplot2::position_dodge() - ) + - ggplot2::theme_minimal() + + color = "white", + width = 0.9) + + ggplot2::geom_text( + ggplot2::aes( + label = scales::percent(label/100, 1)), + position = ggplot2::position_stack(vjust = 0.5), + color = "black", + size = 3.5, + fontface = "bold", + check_overlap = TRUE) + + ggplot2::theme_classic() + ggplot2::theme( - axis.text.x = - ggplot2::element_text(angle = 60.0, hjust = 1.0) - ) + - ggplot2::labs(x = "Class", y = "Percentage of mixture") + - ggplot2::scale_fill_manual(name = "Class label", values = colors) + + axis.title.y = ggplot2::element_text(size = 11), + legend.title = ggplot2::element_text(size = 11), + legend.text = ggplot2::element_text(size = 9), + legend.key.size = ggplot2::unit(0.5, "cm"), + legend.spacing.y = ggplot2::unit(0.5, "cm"), + legend.position = "right", + legend.justification = "center") + + ggplot2::xlab("Percentage of mixture") + + ggplot2::ylab("Class")+ + ggplot2::scale_fill_manual( + values = colors, + name = "Class label") + ggplot2::ggtitle(title) - p <- graphics::plot(p) - invisible(p) + return(g) } #' @title Plot a SOM map #' @name plot.som_map diff --git a/inst/extdata/config_colors.yml b/inst/extdata/config_colors.yml index 0b6c56725..26095a93a 100644 --- a/inst/extdata/config_colors.yml +++ b/inst/extdata/config_colors.yml @@ -38,12 +38,37 @@ composites: AWS: collections: SENTINEL-2-L2A : + AGRI : ["B11", "B08", "B02"] + AGRI2 : ["B11", "B8A", "B02"] + SWIR : ["B11", "B08", "B04"] + SWIR2 : ["B12", "B08", "B04"] + SWIR3 : ["B12", "B8A", "B04"] + RGB-FALSE1 : ["B08", "B06", "B04"] + RGB-FALSE2 : ["B08", "B11", "B04"] + GEOLOGY : ["B12", "B11", "B03"] + RGB : ["B04", "B03", "B02"] SENTINEL-S2-L2A-COGS : - <<: *sentinel-2 + AGRI : ["B11", "B08", "B02"] + AGRI2 : ["B11", "B8A", "B02"] + SWIR : ["B11", "B08", "B04"] + SWIR2 : ["B12", "B08", "B04"] + SWIR3 : ["B12", "B8A", "B04"] + RGB-FALSE1 : ["B08", "B06", "B04"] + RGB-FALSE2 : ["B08", "B11", "B04"] + GEOLOGY : ["B12", "B11", "B03"] + RGB : ["B04", "B03", "B02"] CDSE: collections: SENTINEL-2-L2A : - <<: *sentinel-2 + AGRI : ["B11", "B08", "B02"] + AGRI2 : ["B11", "B8A", "B02"] + SWIR : ["B11", "B08", "B04"] + SWIR2 : ["B12", "B08", "B04"] + SWIR3 : ["B12", "B8A", "B04"] + RGB-FALSE1 : ["B08", "B06", "B04"] + RGB-FALSE2 : ["B08", "B11", "B04"] + GEOLOGY : ["B12", "B11", "B03"] + RGB : ["B04", "B03", "B02"] SENTINEL-1-RTC : <<: *sentinel-1 BDC: @@ -60,7 +85,15 @@ composites: LANDSAT-OLI-16D : <<: *landsat-c2-l2 SENTINEL-2-16D : - <<: *sentinel-2 + AGRI : ["B11", "B08", "B02"] + AGRI2 : ["B11", "B8A", "B02"] + SWIR : ["B11", "B08", "B04"] + SWIR2 : ["B12", "B08", "B04"] + SWIR3 : ["B12", "B8A", "B04"] + RGB-FALSE1 : ["B08", "B06", "B04"] + RGB-FALSE2 : ["B08", "B11", "B04"] + GEOLOGY : ["B12", "B11", "B03"] + RGB : ["B04", "B03", "B02"] DEAFRICA: collections: ALOS-PALSAR-MOSAIC : @@ -78,27 +111,40 @@ composites: RGB : ["B04", "B03", "B02"] SWIR : ["B07", "B05", "B04"] LANDWATER : ["B05", "B06", "B04"] - LS9-SR : <<: *landsat-oli GM-LS8-LS9-ANNUAL : <<: *landsat-oli - GM-S2-ANNUAL : - <<: *sentinel-2 + GM-S2-ANNUAL : &sentinel-2-dea + AGRI : ["B11", "B08", "B02"] + AGRI2 : ["B11", "B8A", "B02"] + SWIR : ["B11", "B08", "B04"] + SWIR2 : ["B12", "B08", "B04"] + SWIR3 : ["B12", "B8A", "B04"] + RGB-FALSE1 : ["B08", "B06", "B04"] + RGB-FALSE2 : ["B08", "B11", "B04"] + GEOLOGY : ["B12", "B11", "B03"] + RGB : ["B04", "B03", "B02"] GM-S2-ROLLING : - <<: *sentinel-2 + <<: *sentinel-2-dea GM-S2-SEMIANNUAL: - <<: *sentinel-2 + <<: *sentinel-2-dea DEAUSTRALIA: collections: - GA_LS5T_ARD_3 : - <<: *landsat-tm-etm + GA_LS5T_ARD_3 : &landsat-tm-etm-aus + SWIR : ["B05", "B04", "B03"] + RGB : ["B03", "B02", "B01"] + NIR : ["B04", "B03", "B02"] GA_LS7E_ARD_3 : - <<: *landsat-tm-etm - GA_LS8C_ARD_3 : - <<: *landsat-oli + <<: *landsat-tm-etm-aus + GA_LS8C_ARD_3 : &landsat-oli-aus + AGRI : ["B06", "B05", "B02"] + NIR : ["B05", "B04", "B03"] + RGB : ["B04", "B03", "B02"] + SWIR : ["B07", "B05", "B04"] + LANDWATER : ["B05", "B06", "B04"] GA_LS9C_ARD_3 : - <<: *landsat-oli + <<: *landsat-oli-aus GA_S2AM_ARD_3 : &ga-sentinel-2 AGRI : ["SWIR-2", "NIR-1", "BLUE"] RGB : ["RED", "BLUE", "GREEN"] @@ -123,7 +169,6 @@ composites: NIR : ["SWIR-2", "NIR-NARROW", "BLUE"] RGB : ["RED", "GREEN", "BLUE"] NIR2 : ["SWIR-2", "NIR-NARROW", "RED"] - PLANET : collections: MOSAIC: diff --git a/inst/extdata/sources/config_source_bdc.yml b/inst/extdata/sources/config_source_bdc.yml index 45783c3e6..55b087870 100644 --- a/inst/extdata/sources/config_source_bdc.yml +++ b/inst/extdata/sources/config_source_bdc.yml @@ -2,7 +2,7 @@ # The parameters enable access to the cloud collections # BDC access key -BDC_ACCESS_KEY: "vtclkRc5c874XBd0Y7NSUWuzLihnU1bHC5bbLSXfQ5" +BDC_ACCESS_KEY: "F32JZBqq5jdbP4ROmwH1F5cw46Ews7Q7gGu9AQqnYy" sources: BDC : diff --git a/man/plot.Rd b/man/plot.Rd index 76f0f1083..00692553b 100644 --- a/man/plot.Rd +++ b/man/plot.Rd @@ -5,7 +5,7 @@ \alias{plot.sits} \title{Plot time series and data cubes} \usage{ -\method{plot}{sits}(x, y, ..., together = FALSE) +\method{plot}{sits}(x, y, ..., together = TRUE) } \arguments{ \item{x}{Object of class "sits".} diff --git a/man/plot.som_evaluate_cluster.Rd b/man/plot.som_evaluate_cluster.Rd index 144d1e051..d1020dfcf 100644 --- a/man/plot.som_evaluate_cluster.Rd +++ b/man/plot.som_evaluate_cluster.Rd @@ -4,14 +4,7 @@ \alias{plot.som_evaluate_cluster} \title{Plot confusion between clusters} \usage{ -\method{plot}{som_evaluate_cluster}( - x, - y, - ..., - legend = NULL, - name_cluster = NULL, - title = "Confusion by cluster" -) +\method{plot}{som_evaluate_cluster}(x, y, ..., name_cluster = NULL, title = "Confusion by cluster") } \arguments{ \item{x}{Object of class "plot.som_evaluate_cluster".} @@ -20,11 +13,11 @@ \item{...}{Further specifications for \link{plot}.} -\item{legend}{Legend with colors to be plotted.} - \item{name_cluster}{Choose the cluster to plot.} \item{title}{Title of plot.} + +\item{legend}{Legend with colors to be plotted.} } \value{ A plot object produced by the ggplot2 package From fd279bb795b284aff48607829e192dd2345acecb Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Tue, 27 May 2025 16:35:43 -0300 Subject: [PATCH 121/122] new version of plot som_evaluate_cluster closes #1329 --- DESCRIPTION | 2 +- NAMESPACE | 1 + R/sits_cube.R | 38 -------- R/{sits_find_tiles.R => sits_grid_systems.R} | 89 ++++++++++++++++++- R/sits_plot.R | 82 ++++------------- man/plot.som_evaluate_cluster.Rd | 2 - man/sits_mgrs_to_roi.Rd | 2 +- man/sits_roi_to_mgrs.Rd | 52 +++++++++++ ...its_find_tiles.Rd => sits_roi_to_tiles.Rd} | 10 +-- man/sits_tiles_to_roi.Rd | 4 +- 10 files changed, 164 insertions(+), 118 deletions(-) rename R/{sits_find_tiles.R => sits_grid_systems.R} (50%) create mode 100644 man/sits_roi_to_mgrs.Rd rename man/{sits_find_tiles.Rd => sits_roi_to_tiles.Rd} (90%) diff --git a/DESCRIPTION b/DESCRIPTION index 40e075bb9..8ff0baaf4 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -233,11 +233,11 @@ Collate: 'sits_dtw.R' 'sits_factory.R' 'sits_filters.R' - 'sits_find_tiles.R' 'sits_geo_dist.R' 'sits_get_data.R' 'sits_get_class.R' 'sits_get_probs.R' + 'sits_grid_systems.R' 'sits_histogram.R' 'sits_imputation.R' 'sits_labels.R' diff --git a/NAMESPACE b/NAMESPACE index ffb94e983..3b5d2eb28 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -547,6 +547,7 @@ export(sits_reduce) export(sits_reduce_imbalance) export(sits_regularize) export(sits_rfor) +export(sits_roi_to_mgrs) export(sits_run_examples) export(sits_run_tests) export(sits_sample) diff --git a/R/sits_cube.R b/R/sits_cube.R index 263c51fcd..8a10a35f0 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -476,42 +476,4 @@ sits_cube.stac_cube <- function(source, sits_cube.default <- function(source, collection, ...) { stop(.conf("messages", "sits_cube_default")) } -#' @title Convert MGRS tile information to ROI in WGS84 -#' @name sits_mgrs_to_roi -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@gmail.com} -#' -#' @description -#' Takes a list of MGRS tiles and produces a ROI covering them -#' -#' @param tiles Character vector with names of MGRS tiles -#' @return roi Valid ROI to use in other SITS functions -#' -#' @export -sits_mgrs_to_roi <- function(tiles) { - .conf("messages", "sits_mgrs_to_roi") - sits_tiles_to_roi(tiles = tiles, grid_system = "MGRS") -} -#' @title Convert MGRS tile information to ROI in WGS84 -#' @name sits_tiles_to_roi -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @author Rolf Simoes, \email{rolf.simoes@@gmail.com} -#' -#' @description -#' Takes a list of MGRS tiles and produces a ROI covering them -#' -#' @param tiles Character vector with names of MGRS tiles -#' @param grid_system ... -#' @return roi Valid ROI to use in other SITS functions -#' -#' @export -sits_tiles_to_roi <- function(tiles, grid_system = "MGRS") { - # retrieve the ROI - roi <- .grid_filter_tiles( - grid_system = grid_system, - roi = NULL, - tiles = tiles - ) - sf::st_bbox(roi) -} diff --git a/R/sits_find_tiles.R b/R/sits_grid_systems.R similarity index 50% rename from R/sits_find_tiles.R rename to R/sits_grid_systems.R index eeb18bf7b..0def4e16b 100644 --- a/R/sits_find_tiles.R +++ b/R/sits_grid_systems.R @@ -1,7 +1,90 @@ +#' @title Convert MGRS tile information to ROI in WGS84 +#' @name sits_mgrs_to_roi +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Rolf Simoes, \email{rolf.simoes@@gmail.com} +#' +#' @description +#' Takes a list of MGRS tiles and produces a ROI covering them +#' +#' @param tiles Character vector with names of MGRS tiles +#' @return roi Valid ROI to use in other SITS functions +#' +#' @export +sits_mgrs_to_roi <- function(tiles) { + .conf("messages", "sits_mgrs_to_roi") + sits_tiles_to_roi(tiles = tiles, grid_system = "MGRS") +} + +#' @title Convert MGRS tile information to ROI in WGS84 +#' @name sits_tiles_to_roi +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @author Rolf Simoes, \email{rolf.simoes@@gmail.com} +#' +#' @description +#' Takes a list of MGRS tiles and produces a ROI covering them +#' +#' @param tiles Character vector with names of MGRS tiles +#' @param grid_system Grid system to be used +#' @return roi Valid ROI to use in other SITS functions +#' +#' +#' @export +sits_tiles_to_roi <- function(tiles, grid_system = "MGRS") { + # retrieve the ROI + roi <- .grid_filter_tiles( + grid_system = grid_system, + roi = NULL, + tiles = tiles + ) + sf::st_bbox(roi) +} + +#' @title Given a ROI, find MGRS tiles intersecting it. +#' @name sits_roi_to_mgrs +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} +#' +#' @description +#' Takes a a ROI and produces a list of MGRS tiles intersecting it +#' +#' @param roi Valid ROI to use in other SITS functions +#' @return tiles Character vector with names of MGRS tiles +#' @note +#' To define a \code{roi} use one of: +#' \itemize{ +#' \item{A path to a shapefile with polygons;} +#' \item{A \code{sfc} or \code{sf} object from \code{sf} package;} +#' \item{A \code{SpatExtent} object from \code{terra} package;} +#' \item{A named \code{vector} (\code{"lon_min"}, +#' \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84;} +#' \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, +#' \code{"ymin"}, \code{"ymax"}) with XY coordinates.} +#' } +#' +#' Defining a region of interest using \code{SpatExtent} or XY values not +#' in WGS84 requires the \code{crs} parameter to be specified. +#' \code{sits_regularize()} function will crop the images +#' that contain the region of interest() +#' @examples +#' if (sits_run_examples()) { +#' # Defining a ROI +#' roi <- c( +#' lon_min = -64.037, +#' lat_min = -9.644, +#' lon_max = -63.886, +#' lat_max = -9.389 +#' ) +#' # Finding tiles +#' tiles <- sits_roi_to_mgrs(roi) +#' } +#' @export +sits_roi_to_mgrs <- function(roi) { + sits_roi_to_tiles(roi = roi, grid_system = "MGRS") +} #' @title Find tiles of a given ROI and Grid System #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} #' @author Felipe Carlos, \email{efelipecarlos@@gmail.com} -#' @name sits_find_tiles +#' @name sits_roi_to_tiles #' #' @description Given an ROI and grid system, this function finds the #' intersected tiles and returns them as an SF object. @@ -46,11 +129,11 @@ #' lat_max = -9.389 #' ) #' # Finding tiles -#' tiles <- sits_find_tiles(roi) +#' tiles <- sits_roi_to_tiles(roi, grid_system = "MGRS") #' } #' @return A \code{sf} object with the intersect tiles with three columns #' tile_id, epsg, and the percentage of coverage area. -sits_find_tiles <- function(roi, crs = NULL, grid_system = "MGRS") { +sits_roi_to_tiles <- function(roi, crs = NULL, grid_system = "MGRS") { # Pre-conditions grid_system <- toupper(grid_system) .check_grid_system(grid_system) diff --git a/R/sits_plot.R b/R/sits_plot.R index cd8d026ef..ae89d2a6a 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -1691,7 +1691,6 @@ plot.sits_accuracy <- function(x, y, ..., title = "Confusion matrix") { #' @param x Object of class "plot.som_evaluate_cluster". #' @param y Ignored. #' @param ... Further specifications for \link{plot}. -#' @param legend Legend with colors to be plotted. #' @param name_cluster Choose the cluster to plot. #' @param title Title of plot. #' @return A plot object produced by the ggplot2 package @@ -1710,59 +1709,6 @@ plot.sits_accuracy <- function(x, y, ..., title = "Confusion matrix") { #' plot(som_clusters) #' } #' @export -#' -# plot.som_evaluate_cluster <- function(x, y, ..., -# legend = NULL, -# name_cluster = NULL, -# title = "Confusion by cluster") { -# stopifnot(missing(y)) -# data <- x -# if (!inherits(data, "som_evaluate_cluster")) { -# message(.conf("messages", ".plot_som_evaluate_cluster")) -# return(invisible(NULL)) -# } -# -# # Filter the cluster to plot -# if (!(is.null(name_cluster))) { -# data <- dplyr::filter(data, .data[["cluster"]] %in% name_cluster) -# } -# # configure plot colors -# # convert legend from tibble to vector -# if (.has(legend)) { -# legend <- .colors_legend_set(legend) -# } -# # get labels from cluster table -# labels <- unique(data[["class"]]) -# colors <- .colors_get( -# labels = labels, -# legend = legend, -# palette = "Set3", -# rev = TRUE -# ) -# -# p <- ggplot2::ggplot() + -# ggplot2::geom_bar( -# ggplot2::aes( -# y = .data[["mixture_percentage"]], -# x = .data[["cluster"]], -# fill = class -# ), -# data = data, -# stat = "identity", -# position = ggplot2::position_dodge() -# ) + -# ggplot2::theme_minimal() + -# ggplot2::theme( -# axis.text.x = -# ggplot2::element_text(angle = 60.0, hjust = 1.0) -# ) + -# ggplot2::labs(x = "Class", y = "Percentage of mixture") + -# ggplot2::scale_fill_manual(name = "Class label", values = colors) + -# ggplot2::ggtitle(title) -# -# p <- graphics::plot(p) -# invisible(p) -# } plot.som_evaluate_cluster <- function(x, y, ..., name_cluster = NULL, title = "Confusion by cluster") { @@ -1790,27 +1736,31 @@ plot.som_evaluate_cluster <- function(x, y, ..., # Optional ordering of clusters or classes by dominant mixture (clearer visual interpretation) # Calculate dominant class by cluster dominant <- data |> - dplyr::group_by(cluster, class) |> - dplyr::summarise(total = sum(mixture_percentage), .groups = "drop") |> - dplyr::group_by(cluster) |> - dplyr::slice_max(total, n = 1) |> - dplyr::arrange(desc(total)) |> - dplyr::pull(cluster) |> + dplyr::group_by(.data[["cluster"]], class) |> + dplyr::summarise(total = + sum(.data[["mixture_percentage"]]), .groups = "drop") |> + dplyr::group_by(.data[["cluster"]]) |> + dplyr::slice_max(.data[["total"]], n = 1) |> + dplyr::arrange(dplyr::desc(.data[["total"]])) |> + dplyr::pull(.data[["cluster"]]) |> unique() # # convert some elements in factor and filter percentage for plot data_conv <- data |> - # Show labels only for percentages greater than 3% (for better visualization) - dplyr::mutate(label = ifelse(mixture_percentage < 3, NA, mixture_percentage), + # Show labels only for percentages greater than 3% + # (for better visualization) + dplyr::mutate(label = ifelse(.data[["mixture_percentage"]] < 3, NA, + .data[["mixture_percentage"]]), class = as.factor(class), - cluster = factor(cluster, levels = dominant)) + cluster = factor(.data[["cluster"]], levels = dominant)) # Stacked bar graphs for confusion by cluster g <- ggplot2::ggplot( data_conv, ggplot2::aes( - x = mixture_percentage, - y = factor(cluster, levels = rev(levels(cluster))), + x = .data[["mixture_percentage"]], + y = factor(.data[["cluster"]], + levels = rev(levels(.data[["cluster"]]))), fill = class)) + ggplot2::geom_bar( stat = "identity", @@ -1826,7 +1776,7 @@ plot.som_evaluate_cluster <- function(x, y, ..., check_overlap = TRUE) + ggplot2::theme_classic() + ggplot2::theme( - axis.title.y = ggplot2::element_text(size = 11), + axis.title.y = ggplot2::element_text(size = 11), legend.title = ggplot2::element_text(size = 11), legend.text = ggplot2::element_text(size = 9), legend.key.size = ggplot2::unit(0.5, "cm"), diff --git a/man/plot.som_evaluate_cluster.Rd b/man/plot.som_evaluate_cluster.Rd index d1020dfcf..e5cda3233 100644 --- a/man/plot.som_evaluate_cluster.Rd +++ b/man/plot.som_evaluate_cluster.Rd @@ -16,8 +16,6 @@ \item{name_cluster}{Choose the cluster to plot.} \item{title}{Title of plot.} - -\item{legend}{Legend with colors to be plotted.} } \value{ A plot object produced by the ggplot2 package diff --git a/man/sits_mgrs_to_roi.Rd b/man/sits_mgrs_to_roi.Rd index 27e2cecd5..4dd8fe10c 100644 --- a/man/sits_mgrs_to_roi.Rd +++ b/man/sits_mgrs_to_roi.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sits_cube.R +% Please edit documentation in R/sits_grid_systems.R \name{sits_mgrs_to_roi} \alias{sits_mgrs_to_roi} \title{Convert MGRS tile information to ROI in WGS84} diff --git a/man/sits_roi_to_mgrs.Rd b/man/sits_roi_to_mgrs.Rd new file mode 100644 index 000000000..4e0599d70 --- /dev/null +++ b/man/sits_roi_to_mgrs.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_grid_systems.R +\name{sits_roi_to_mgrs} +\alias{sits_roi_to_mgrs} +\title{Given a ROI, find MGRS tiles intersecting it.} +\usage{ +sits_roi_to_mgrs(roi) +} +\arguments{ +\item{roi}{Valid ROI to use in other SITS functions} +} +\value{ +tiles Character vector with names of MGRS tiles +} +\description{ +Takes a a ROI and produces a list of MGRS tiles intersecting it +} +\note{ +To define a \code{roi} use one of: + \itemize{ + \item{A path to a shapefile with polygons;} + \item{A \code{sfc} or \code{sf} object from \code{sf} package;} + \item{A \code{SpatExtent} object from \code{terra} package;} + \item{A named \code{vector} (\code{"lon_min"}, + \code{"lat_min"}, \code{"lon_max"}, \code{"lat_max"}) in WGS84;} + \item{A named \code{vector} (\code{"xmin"}, \code{"xmax"}, + \code{"ymin"}, \code{"ymax"}) with XY coordinates.} + } + + Defining a region of interest using \code{SpatExtent} or XY values not + in WGS84 requires the \code{crs} parameter to be specified. + \code{sits_regularize()} function will crop the images + that contain the region of interest() +} +\examples{ +if (sits_run_examples()) { +# Defining a ROI +roi <- c( + lon_min = -64.037, + lat_min = -9.644, + lon_max = -63.886, + lat_max = -9.389 +) +# Finding tiles +tiles <- sits_roi_to_mgrs(roi) +} +} +\author{ +Felipe Carvalho, \email{felipe.carvalho@inpe.br} + +Felipe Carlos, \email{efelipecarlos@gmail.com} +} diff --git a/man/sits_find_tiles.Rd b/man/sits_roi_to_tiles.Rd similarity index 90% rename from man/sits_find_tiles.Rd rename to man/sits_roi_to_tiles.Rd index 43ab4985d..ee2269396 100644 --- a/man/sits_find_tiles.Rd +++ b/man/sits_roi_to_tiles.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sits_find_tiles.R -\name{sits_find_tiles} -\alias{sits_find_tiles} +% Please edit documentation in R/sits_grid_systems.R +\name{sits_roi_to_tiles} +\alias{sits_roi_to_tiles} \title{Find tiles of a given ROI and Grid System} \usage{ -sits_find_tiles(roi, crs = NULL, grid_system = "MGRS") +sits_roi_to_tiles(roi, crs = NULL, grid_system = "MGRS") } \arguments{ \item{roi}{Region of interest (see notes below).} @@ -57,7 +57,7 @@ roi <- c( lat_max = -9.389 ) # Finding tiles -tiles <- sits_find_tiles(roi) +tiles <- sits_roi_to_tiles(roi, grid_system = "MGRS") } } \author{ diff --git a/man/sits_tiles_to_roi.Rd b/man/sits_tiles_to_roi.Rd index 7a6ceda28..1c8058c41 100644 --- a/man/sits_tiles_to_roi.Rd +++ b/man/sits_tiles_to_roi.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sits_cube.R +% Please edit documentation in R/sits_grid_systems.R \name{sits_tiles_to_roi} \alias{sits_tiles_to_roi} \title{Convert MGRS tile information to ROI in WGS84} @@ -9,7 +9,7 @@ sits_tiles_to_roi(tiles, grid_system = "MGRS") \arguments{ \item{tiles}{Character vector with names of MGRS tiles} -\item{grid_system}{...} +\item{grid_system}{Grid system to be used} } \value{ roi Valid ROI to use in other SITS functions From a3f01bf170e1c06337f72e35fef860b2e1ddd873 Mon Sep 17 00:00:00 2001 From: gilbertocamara Date: Tue, 27 May 2025 18:57:07 -0300 Subject: [PATCH 122/122] fix problem with multiple CRS in merged HLS images --- R/api_check.R | 1 - R/api_source_local.R | 6 +++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/R/api_check.R b/R/api_check.R index c47b7f163..18329d1c6 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -2229,7 +2229,6 @@ .check_set_caller(".check_local_items") # pre-condition .check_tiles(unique(items[["tile"]])) - .check_crs(unique(items[["crs"]])) } #' @title Checks tiles #' @name .check_tiles diff --git a/R/api_source_local.R b/R/api_source_local.R index 1320ee38f..ac72d696a 100644 --- a/R/api_source_local.R +++ b/R/api_source_local.R @@ -713,7 +713,11 @@ # pre-condition .check_local_items(items) # get crs from file_info - crs <- unique(items[["crs"]]) + # # deal with special case of HLS collections + if (collection == "HLSL30" || collection == "HLSS30") + crs <- items[1,][["crs"]] + else + crs <- unique(items[["crs"]]) # get tile from file_info tile <- unique(items[["tile"]]) # make a new file info for one tile