Optimized C++ Code

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: GLCMTextures
 Title: GLCM Textures of Raster Layers
-Version: 0.5.3
+Version: 0.6
 Authors@R: 
     person(given = "Alexander",
            family = "Ilich",

R/RcppExports.R

@@ -1,23 +1,15 @@
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 
-C_make_glcm_counts <- function(x, n_levels, shift, na_rm) {
-    .Call(`_GLCMTextures_C_make_glcm_counts`, x, n_levels, shift, na_rm)
+C_make_glcm <- function(x, n_levels, shift, na_rm, nrow, ncol, normalize) {
+    .Call(`_GLCMTextures_C_make_glcm`, x, n_levels, shift, na_rm, nrow, ncol, normalize)
 }
 
-C_make_glcm <- function(x, n_levels, shift, na_rm) {
-    .Call(`_GLCMTextures_C_make_glcm`, x, n_levels, shift, na_rm)
+C_glcm_metrics <- function(Pij, i_mat, j_mat, i_minus_j, i_minus_j2, i_minus_j_abs, n_levels, metric_indices, impute_corr) {
+    .Call(`_GLCMTextures_C_glcm_metrics`, Pij, i_mat, j_mat, i_minus_j, i_minus_j2, i_minus_j_abs, n_levels, metric_indices, impute_corr)
 }
 
-C_GLSV <- function(Pij, n_levels) {
-    .Call(`_GLCMTextures_C_GLSV`, Pij, n_levels)
-}
-
-C_glcm_metrics <- function(Pij, i_mat, j_mat, n_levels, metrics, impute_corr) {
-    .Call(`_GLCMTextures_C_glcm_metrics`, Pij, i_mat, j_mat, n_levels, metrics, impute_corr)
-}
-
-C_glcm_textures_helper <- function(x, w2, n_levels, shift, metrics, na_rm, impute_corr, ni, nw) {
-    .Call(`_GLCMTextures_C_glcm_textures_helper`, x, w2, n_levels, shift, metrics, na_rm, impute_corr, ni, nw)
+C_glcm_textures_helper <- function(x, w2, n_levels, shift_list, metric_indices, na_rm, impute_corr, ni, nw) {
+    .Call(`_GLCMTextures_C_glcm_textures_helper`, x, w2, n_levels, shift_list, metric_indices, na_rm, impute_corr, ni, nw)
 }
 

R/glcm_metrics.R

@@ -22,27 +22,23 @@ glcm_metrics<-function(GLCM, metrics= c("glcm_contrast", "glcm_dissimilarity", "
   if (any(!(metrics %in% all_metrics))){
     stop("Error: Invlaid metric. Valid metrics include 'glcm_contrast', 'glcm_dissimilarity', 'glcm_homogeneity', 'glcm_ASM', 'glcm_entropy', 'glcm_mean', 'glcm_variance', 'glcm_correlation'")
   }
-  needed_metrics<- metrics
-  if(("glcm_variance" %in% needed_metrics) & (!("glcm_mean" %in% needed_metrics))){
-    needed_metrics<- c(needed_metrics, "glcm_mean")
-  }
-  if(("glcm_correlation" %in% needed_metrics) & (!("glcm_mean" %in% needed_metrics))){
-    needed_metrics<- c(needed_metrics, "glcm_mean")
-  }
-  if(("glcm_correlation" %in% needed_metrics) & (!("glcm_variance" %in% needed_metrics))){
-    needed_metrics<- c(needed_metrics, "glcm_variance")
-  } #Some metrics needed
 
   if(!is.list(GLCM)){GLCM<- list(GLCM)}
   out<- vector(mode="list", length = length(GLCM))
 
   for (i in 1:length(GLCM)) {
     i_mat<- matrix(data= 0:(nrow(GLCM[[i]])-1), nrow= nrow(GLCM[[i]]), ncol=ncol(GLCM[[i]]), byrow=FALSE)
     j_mat<- matrix(data= 0:(ncol(GLCM[[i]])-1), nrow= nrow(GLCM[[i]]), ncol=ncol(GLCM[[i]]), byrow=TRUE)
+    i_minus_j<- i_mat-j_mat
+
     n_levels=nrow(GLCM[[i]])
-    # k_vals<- seq((2*n_levels)-1)-1
-    out[[i]]<- C_glcm_metrics(GLCM[[i]], i_mat = i_mat, j_mat = j_mat, n_levels=n_levels, metrics = needed_metrics, impute_corr= impute_corr)
-    out[[i]]<-  out[[i]][names(out[[i]]) %in% metrics]
+
+    metric_indices<- match(metrics, all_metrics) -1
+
+    out[[i]]<- C_glcm_metrics(GLCM[[i]], i_mat = i_mat, j_mat = j_mat, i_minus_j = i_minus_j,
+                              i_minus_j2 = i_minus_j^2, i_minus_j_abs=abs(i_minus_j),
+                              n_levels=n_levels, metric_indices = metric_indices, impute_corr=impute_corr)
+    names(out[[i]])<- metrics
   }
   if(length(out)==1){
     out<- out[[1]]

R/glcm_textures.R

@@ -81,17 +81,6 @@ glcm_textures<- function(r, w = c(3,3), n_levels, shift=list(c(1,0), c(1,1), c(0
     warning("n_levels is > 32. This may be very computationally expensive.")
     }
 
-  needed_metrics<- metrics
-  if(("glcm_variance" %in% needed_metrics) & (!("glcm_mean" %in% needed_metrics))){
-    needed_metrics<- c(needed_metrics, "glcm_mean")
-  }
-  if(("glcm_correlation" %in% needed_metrics) & (!("glcm_mean" %in% needed_metrics))){
-    needed_metrics<- c(needed_metrics, "glcm_mean")
-  }
-  if(("glcm_correlation" %in% needed_metrics) & (!("glcm_variance" %in% needed_metrics))){
-    needed_metrics<- c(needed_metrics, "glcm_variance")
-  } #Some metrics needed to calculate others
-
   if(!is.null(quantization)){
     warning("Use of 'quantization' is deprecated. Instead use 'quant_method'")
     if(is.null(quant_method)){
@@ -100,8 +89,9 @@ glcm_textures<- function(r, w = c(3,3), n_levels, shift=list(c(1,0), c(1,1), c(0
       if(quantization == "equal range"){quant_method<- "range"}
       }
   }
+
   if(is.null(quant_method)){stop("quant_method is NULL. Specify as 'none', 'range' or 'prob'")}
-  out_list<- vector(mode = "list", length=length(shift))
+
   if(quant_method!="none"){
     r<- quantize_raster(r = r, n_levels = n_levels, quant_method = quant_method, min_val = min_val, max_val = max_val, maxcell=maxcell, wopt=wopt)
     } else if(!terra::is.int(r)){
@@ -110,19 +100,11 @@ glcm_textures<- function(r, w = c(3,3), n_levels, shift=list(c(1,0), c(1,1), c(0
   if((unlist(terra::global(r, fun = max, na.rm=TRUE)) > (n_levels-1)) | (unlist(terra::global(r, fun = min, na.rm=TRUE)) < 0)){
     stop("Error: raster must have values between 0 and n_levels-1")}
 
-  out_list<- vector(mode = "list", length=length(shift))
-  for (k in 1:length(shift)) {
-    out_list[[k]]<- terra::focalCpp(r, w=w, fun = C_glcm_textures_helper, w2=w, n_levels= n_levels, shift = shift[[k]], metrics = needed_metrics, na_rm=na.rm, impute_corr = impute_corr, fillvalue=NA, wopt=wopt)
-    out_list[[k]]<- terra::subset(out_list[[k]], metrics, wopt=wopt) #Subset from needed to requested metrics
-    }
 
-  n_layers<- length(metrics)
-  if(length(shift) > 1){
-    output<- terra::app(terra::sds(out_list), fun=mean, na.rm=na.rm, wopt=wopt)
-    } else{
-      output<- out_list[[1]]
-    }
-  names(output)<- metrics #preserve names in case they were lost
+  metric_indices<- match(metrics, all_metrics)-1
+
+  output<- terra::focalCpp(r, w=w, fun = C_glcm_textures_helper, w2=w, n_levels= n_levels, shift = shift, metric_indices = metric_indices, na_rm=na.rm, impute_corr = impute_corr, fillvalue=NA, wopt=wopt)
+  names(output)<- metrics #Add in names
 
   if(include_scale){names(output)<- paste0(names(output), "_", w[1],"x", w[2])} #Add scale to layer names
 

R/make_glcm.R

@@ -19,24 +19,24 @@
 #' @export
 
 make_glcm<- function(x, n_levels, shift, na.rm = FALSE, normalize=TRUE){
-  if(class(x)[1]!="matrix"){
-    x<- as.matrix(x, wide=TRUE)
-  } # Convert to matrix
+  nr=nrow(x)
+  nc=ncol(x)
+
+  if(class(x)[1]=="matrix"){
+    x<- as.vector(t(x))
+  } else{
+    x<- as.vector(t(x))
+  }
+
   if(isTRUE(any(x > (n_levels-1))) | isTRUE(any(x < 0))){
 	  stop("Error: x must have values between 0 and n_levels-1")
 	}
   if(!is.list(shift)){shift<- list(shift)}
   GLCM<- vector(mode="list", length = length(shift))
 
   for (i in 1:length(shift)) {
-    if(normalize){
-      GLCM[[i]]<- C_make_glcm(x=x, n_levels=n_levels, shift=shift[[i]], na_rm=na.rm)
-    } else{
-      GLCM[[i]]<- C_make_glcm_counts(x=x, n_levels=n_levels, shift=shift[[i]], na_rm=na.rm)
-    }
+      GLCM[[i]]<- C_make_glcm(x=x, n_levels=n_levels, shift=shift[[i]], na_rm=na.rm, nrow=nr, ncol=nc,normalize=normalize)
   }
   if(length(GLCM)==1){GLCM<- GLCM[[1]]}
   return(GLCM)
 }
-
-

README.md

@@ -1,7 +1,7 @@
 README
 ================
 Alexander Ilich
-January 02, 2025
+April 29, 2025
 
 <!-- badges: start -->
 

src/RcppExports.cpp

@@ -11,87 +11,65 @@ Rcpp::Rostream<true>&  Rcpp::Rcout = Rcpp::Rcpp_cout_get();
 Rcpp::Rostream<false>& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get();
 #endif
 
-// C_make_glcm_counts
-IntegerMatrix C_make_glcm_counts(IntegerMatrix x, int n_levels, IntegerVector shift, bool na_rm);
-RcppExport SEXP _GLCMTextures_C_make_glcm_counts(SEXP xSEXP, SEXP n_levelsSEXP, SEXP shiftSEXP, SEXP na_rmSEXP) {
-BEGIN_RCPP
-    Rcpp::RObject rcpp_result_gen;
-    Rcpp::RNGScope rcpp_rngScope_gen;
-    Rcpp::traits::input_parameter< IntegerMatrix >::type x(xSEXP);
-    Rcpp::traits::input_parameter< int >::type n_levels(n_levelsSEXP);
-    Rcpp::traits::input_parameter< IntegerVector >::type shift(shiftSEXP);
-    Rcpp::traits::input_parameter< bool >::type na_rm(na_rmSEXP);
-    rcpp_result_gen = Rcpp::wrap(C_make_glcm_counts(x, n_levels, shift, na_rm));
-    return rcpp_result_gen;
-END_RCPP
-}
 // C_make_glcm
-arma::mat C_make_glcm(IntegerMatrix x, int n_levels, IntegerVector shift, bool na_rm);
-RcppExport SEXP _GLCMTextures_C_make_glcm(SEXP xSEXP, SEXP n_levelsSEXP, SEXP shiftSEXP, SEXP na_rmSEXP) {
-BEGIN_RCPP
-    Rcpp::RObject rcpp_result_gen;
-    Rcpp::RNGScope rcpp_rngScope_gen;
-    Rcpp::traits::input_parameter< IntegerMatrix >::type x(xSEXP);
-    Rcpp::traits::input_parameter< int >::type n_levels(n_levelsSEXP);
-    Rcpp::traits::input_parameter< IntegerVector >::type shift(shiftSEXP);
-    Rcpp::traits::input_parameter< bool >::type na_rm(na_rmSEXP);
-    rcpp_result_gen = Rcpp::wrap(C_make_glcm(x, n_levels, shift, na_rm));
-    return rcpp_result_gen;
-END_RCPP
-}
-// C_GLSV
-NumericVector C_GLSV(arma::mat Pij, int n_levels);
-RcppExport SEXP _GLCMTextures_C_GLSV(SEXP PijSEXP, SEXP n_levelsSEXP) {
+arma::mat C_make_glcm(const IntegerVector& x, const int n_levels, const IntegerVector& shift, const bool na_rm, const int nrow, const int ncol, const bool normalize);
+RcppExport SEXP _GLCMTextures_C_make_glcm(SEXP xSEXP, SEXP n_levelsSEXP, SEXP shiftSEXP, SEXP na_rmSEXP, SEXP nrowSEXP, SEXP ncolSEXP, SEXP normalizeSEXP) {
 BEGIN_RCPP
     Rcpp::RObject rcpp_result_gen;
     Rcpp::RNGScope rcpp_rngScope_gen;
-    Rcpp::traits::input_parameter< arma::mat >::type Pij(PijSEXP);
-    Rcpp::traits::input_parameter< int >::type n_levels(n_levelsSEXP);
-    rcpp_result_gen = Rcpp::wrap(C_GLSV(Pij, n_levels));
+    Rcpp::traits::input_parameter< const IntegerVector& >::type x(xSEXP);
+    Rcpp::traits::input_parameter< const int >::type n_levels(n_levelsSEXP);
+    Rcpp::traits::input_parameter< const IntegerVector& >::type shift(shiftSEXP);
+    Rcpp::traits::input_parameter< const bool >::type na_rm(na_rmSEXP);
+    Rcpp::traits::input_parameter< const int >::type nrow(nrowSEXP);
+    Rcpp::traits::input_parameter< const int >::type ncol(ncolSEXP);
+    Rcpp::traits::input_parameter< const bool >::type normalize(normalizeSEXP);
+    rcpp_result_gen = Rcpp::wrap(C_make_glcm(x, n_levels, shift, na_rm, nrow, ncol, normalize));
     return rcpp_result_gen;
 END_RCPP
 }
 // C_glcm_metrics
-NumericVector C_glcm_metrics(arma::mat Pij, arma::mat i_mat, arma::mat j_mat, int n_levels, CharacterVector metrics, bool impute_corr);
-RcppExport SEXP _GLCMTextures_C_glcm_metrics(SEXP PijSEXP, SEXP i_matSEXP, SEXP j_matSEXP, SEXP n_levelsSEXP, SEXP metricsSEXP, SEXP impute_corrSEXP) {
+NumericVector C_glcm_metrics(const arma::mat& Pij, const arma::mat& i_mat, const arma::mat& j_mat, const arma::mat& i_minus_j, const arma::mat& i_minus_j2, const arma::mat& i_minus_j_abs, const int n_levels, const IntegerVector& metric_indices, const bool impute_corr);
+RcppExport SEXP _GLCMTextures_C_glcm_metrics(SEXP PijSEXP, SEXP i_matSEXP, SEXP j_matSEXP, SEXP i_minus_jSEXP, SEXP i_minus_j2SEXP, SEXP i_minus_j_absSEXP, SEXP n_levelsSEXP, SEXP metric_indicesSEXP, SEXP impute_corrSEXP) {
 BEGIN_RCPP
     Rcpp::RObject rcpp_result_gen;
     Rcpp::RNGScope rcpp_rngScope_gen;
-    Rcpp::traits::input_parameter< arma::mat >::type Pij(PijSEXP);
-    Rcpp::traits::input_parameter< arma::mat >::type i_mat(i_matSEXP);
-    Rcpp::traits::input_parameter< arma::mat >::type j_mat(j_matSEXP);
-    Rcpp::traits::input_parameter< int >::type n_levels(n_levelsSEXP);
-    Rcpp::traits::input_parameter< CharacterVector >::type metrics(metricsSEXP);
-    Rcpp::traits::input_parameter< bool >::type impute_corr(impute_corrSEXP);
-    rcpp_result_gen = Rcpp::wrap(C_glcm_metrics(Pij, i_mat, j_mat, n_levels, metrics, impute_corr));
+    Rcpp::traits::input_parameter< const arma::mat& >::type Pij(PijSEXP);
+    Rcpp::traits::input_parameter< const arma::mat& >::type i_mat(i_matSEXP);
+    Rcpp::traits::input_parameter< const arma::mat& >::type j_mat(j_matSEXP);
+    Rcpp::traits::input_parameter< const arma::mat& >::type i_minus_j(i_minus_jSEXP);
+    Rcpp::traits::input_parameter< const arma::mat& >::type i_minus_j2(i_minus_j2SEXP);
+    Rcpp::traits::input_parameter< const arma::mat& >::type i_minus_j_abs(i_minus_j_absSEXP);
+    Rcpp::traits::input_parameter< const int >::type n_levels(n_levelsSEXP);
+    Rcpp::traits::input_parameter< const IntegerVector& >::type metric_indices(metric_indicesSEXP);
+    Rcpp::traits::input_parameter< const bool >::type impute_corr(impute_corrSEXP);
+    rcpp_result_gen = Rcpp::wrap(C_glcm_metrics(Pij, i_mat, j_mat, i_minus_j, i_minus_j2, i_minus_j_abs, n_levels, metric_indices, impute_corr));
     return rcpp_result_gen;
 END_RCPP
 }
 // C_glcm_textures_helper
-NumericMatrix C_glcm_textures_helper(IntegerVector x, IntegerVector w2, int n_levels, IntegerVector shift, CharacterVector metrics, bool na_rm, bool impute_corr, size_t ni, size_t nw);
-RcppExport SEXP _GLCMTextures_C_glcm_textures_helper(SEXP xSEXP, SEXP w2SEXP, SEXP n_levelsSEXP, SEXP shiftSEXP, SEXP metricsSEXP, SEXP na_rmSEXP, SEXP impute_corrSEXP, SEXP niSEXP, SEXP nwSEXP) {
+NumericMatrix C_glcm_textures_helper(const IntegerVector& x, const IntegerVector& w2, const int& n_levels, const List& shift_list, const IntegerVector& metric_indices, const bool na_rm, const bool impute_corr, size_t ni, size_t nw);
+RcppExport SEXP _GLCMTextures_C_glcm_textures_helper(SEXP xSEXP, SEXP w2SEXP, SEXP n_levelsSEXP, SEXP shift_listSEXP, SEXP metric_indicesSEXP, SEXP na_rmSEXP, SEXP impute_corrSEXP, SEXP niSEXP, SEXP nwSEXP) {
 BEGIN_RCPP
     Rcpp::RObject rcpp_result_gen;
     Rcpp::RNGScope rcpp_rngScope_gen;
-    Rcpp::traits::input_parameter< IntegerVector >::type x(xSEXP);
-    Rcpp::traits::input_parameter< IntegerVector >::type w2(w2SEXP);
-    Rcpp::traits::input_parameter< int >::type n_levels(n_levelsSEXP);
-    Rcpp::traits::input_parameter< IntegerVector >::type shift(shiftSEXP);
-    Rcpp::traits::input_parameter< CharacterVector >::type metrics(metricsSEXP);
-    Rcpp::traits::input_parameter< bool >::type na_rm(na_rmSEXP);
-    Rcpp::traits::input_parameter< bool >::type impute_corr(impute_corrSEXP);
+    Rcpp::traits::input_parameter< const IntegerVector& >::type x(xSEXP);
+    Rcpp::traits::input_parameter< const IntegerVector& >::type w2(w2SEXP);
+    Rcpp::traits::input_parameter< const int& >::type n_levels(n_levelsSEXP);
+    Rcpp::traits::input_parameter< const List& >::type shift_list(shift_listSEXP);
+    Rcpp::traits::input_parameter< const IntegerVector& >::type metric_indices(metric_indicesSEXP);
+    Rcpp::traits::input_parameter< const bool >::type na_rm(na_rmSEXP);
+    Rcpp::traits::input_parameter< const bool >::type impute_corr(impute_corrSEXP);
     Rcpp::traits::input_parameter< size_t >::type ni(niSEXP);
     Rcpp::traits::input_parameter< size_t >::type nw(nwSEXP);
-    rcpp_result_gen = Rcpp::wrap(C_glcm_textures_helper(x, w2, n_levels, shift, metrics, na_rm, impute_corr, ni, nw));
+    rcpp_result_gen = Rcpp::wrap(C_glcm_textures_helper(x, w2, n_levels, shift_list, metric_indices, na_rm, impute_corr, ni, nw));
     return rcpp_result_gen;
 END_RCPP
 }
 
 static const R_CallMethodDef CallEntries[] = {
-    {"_GLCMTextures_C_make_glcm_counts", (DL_FUNC) &_GLCMTextures_C_make_glcm_counts, 4},
-    {"_GLCMTextures_C_make_glcm", (DL_FUNC) &_GLCMTextures_C_make_glcm, 4},
-    {"_GLCMTextures_C_GLSV", (DL_FUNC) &_GLCMTextures_C_GLSV, 2},
-    {"_GLCMTextures_C_glcm_metrics", (DL_FUNC) &_GLCMTextures_C_glcm_metrics, 6},
+    {"_GLCMTextures_C_make_glcm", (DL_FUNC) &_GLCMTextures_C_make_glcm, 7},
+    {"_GLCMTextures_C_glcm_metrics", (DL_FUNC) &_GLCMTextures_C_glcm_metrics, 9},
     {"_GLCMTextures_C_glcm_textures_helper", (DL_FUNC) &_GLCMTextures_C_glcm_textures_helper, 9},
     {NULL, NULL, 0}
 };