R/glcm_stat_all.R

In neuroconductor/RIA: Radiomics Image Analysis Toolbox for Medial Images

#' @title Aggregates GLCM-based statistics based-on supplied function
#' @export
#'
#' @description Calculates aggregated statistics of GLCM matrix statistics calculated on
#' GCLM matrices evaluated in all different directions.
#' 
#' @param RIA_data_in \emph{RIA_image}, created by \code{\link[RIA]{load_dicom}}.
#' 
#' @param statistic string, defining the statistic to be calculated on the array of GLCM statistics.
#' By default, statistic is set to \emph{"mean"}, however any function may be provided. The proper
#' syntax is: function(X, attributes). The supplied string must contain a "X", which will be replaced
#' with the array of the GLCM statistics value. Further attributes of the function may also be given.
#' For example, if you wish to calculate the median of all GLCMs calculated in different directions,
#' then it must be supplied as: \emph{median(X, na.rm = TRUE)}.
#'
#' @param verbose_in logical, indicating whether to print detailed information.
#' Most prints can also be suppressed using the \code{\link{suppressMessages}} function.
#'
#' @return \emph{RIA_image} containing the statistical information.
#'
#' @examples \dontrun{
#' #Discretize loaded image and then calculate GLCM statistics for all matrices
#' RIA_image <- discretize(RIA_image, bins_in = c(4, 8), equal_prob = TRUE,
#' use_orig = TRUE, write_orig = FALSE)
#' RIA_image <- glcm_all(RIA_image, use_type = "discretized", distance = c(1:2))
#' RIA_image <- glcm_stat(RIA_image)
#' 
#' #Calculate the average of the different GLCM matrices in the different directions
#' RIA_image <- glcm_stat_all(RIA_image)
#' }
#' 
#' @references Márton KOLOSSVÁRY et al.
#' Radiomic Features Are Superior to Conventional Quantitative Computed Tomographic
#' Metrics to Identify Coronary Plaques With Napkin-Ring Sign
#' Circulation: Cardiovascular Imaging (2017).
#' DOI: 10.1161/circimaging.117.006843
#' \url{http://circimaging.ahajournals.org/content/10/12/e006843}
#' 
#' Márton KOLOSSVÁRY et al.
#' Cardiac Computed Tomography Radiomics: A Comprehensive Review on Radiomic Techniques.
#' Journal of Thoracic Imaging (2017).
#' DOI: 10.1097/RTI.0000000000000268
#' \url{https://www.ncbi.nlm.nih.gov/pubmed/28346329}
#' @encoding UTF-8



glcm_stat_all <- function(RIA_data_in, statistic = "mean(X, na.rm = TRUE)", verbose_in = TRUE)
{
  if(!any(class(RIA_data_in) == "RIA_image")) {message("PROCESSING OF RIA_image OBJECTS ARE SUPPORTED, OTHER CLASSES MIGHT CAUSE PROBLEMS! PLEASE LOAD DATA USING load_dicom")}
  
  
  #create names to save to
  names_raw <- names(RIA_data_in$stat_glcm)
  
  
  stat_abr <-  which(strsplit(statistic, "")[[1]]=="(")-1
  stat_abr <-  substr(statistic, start = 1, stop = stat_abr)
  
  names_dcr <- substr(names_raw, start = 1, stop = 2)
  names_dcr <- unique(names_dcr)
  
  bins <- NULL
  names_bin <- unlist(gregexpr('_', names_raw))
  for (i in seq(1, 2*length(names_raw), 2)) {
    bins <- c(bins, substring(names_raw[(i+1)/2], names_bin[i]+1, names_bin[i+1]-1))
  }
  names_bin <- unique(bins)
  
  dist <- NULL
  names_dist <- unlist(gregexpr('_', names_raw))
  for (i in seq(1, 2*length(names_raw), 2)) {
    dist <- c(dist, substring(names_raw[(i+1)/2], first = names_dist[i+1]+1))
  }
  names_dist <- unique(as.numeric(unlist(strsplit(gsub("[^1-9]","", unlist(dist)),""))))
  
  names_out <- NULL
  for (i in 1: length(names_dcr))
  {
    for (j in 1: length(names_bin))
    {
      for (k in 1: length(names_dist))
      {
        names_out <- append(names_out, paste0(names_dcr[i], "_b", names_bin[j], "_d", names_dist[k], "_", stat_abr))
      }
    }
  }

  #identify stat names
  unq_dist <- unique(dist)
  m_number <- NULL
  for(i in 1:length(names_dist)) {
    m_number <- c(m_number, length(grep(names_dist[i], unq_dist)))
  }
  
    D3 <-       matrix(c( 1, 0, 0,
                         -1, 0, 0,
                         0, 1, 0,
                         0,-1, 0,
                         1, 1, 0,
                         -1,-1, 0,
                         1,-1, 0,
                         -1, 1, 0,
                         
                         1, 0, 1,
                         -1, 0, 1,
                         0, 1, 1,
                         0,-1, 1,
                         1, 1, 1,
                         -1,-1, 1,
                         1,-1, 1,
                         -1, 1, 1,
                         
                         1, 0,-1,
                         -1, 0,-1,
                         0, 1,-1,
                         0,-1,-1,
                         1, 1,-1,
                         -1,-1,-1,
                         1,-1,-1,
                         -1, 1,-1,
                         
                         0, 0, 1,
                         0, 0,-1
    ), nrow = 26, ncol = 3, byrow = TRUE)

    D3s <-     matrix(c( 1, 0, 0,
                         0, 1, 0,
                         1, 1, 0,
                         1,-1, 0,
                         
                         1, 0, 1,
                         0, 1, 1,
                         1, 1, 1,
                         1,-1, 1,
                         
                         1, 0,-1,
                         0, 1,-1,
                         1, 1,-1,
                         1,-1,-1,
                         
                         0, 0, 1
    ), nrow = 13, ncol = 3, byrow = TRUE)

    D2 <- matrix(c( 1, 0, 0,
                         -1, 0, 0,
                         0, 1, 0,
                         0,-1, 0,
                         1, 1, 0,
                         -1,-1, 0,
                         1,-1, 0,
                         -1, 1, 0
    ), nrow = 8, ncol = 3, byrow = TRUE)


    D2s <- matrix(c(1, 0, 0,
                        0, 1, 0,
                        1, 1, 0,
                        1,-1, 0
    ), nrow = 4, ncol = 3, byrow = TRUE)



  names_in <- list()
  for (i in 1: length(names_dcr))
  {
    for (j in 1: length(names_bin))
    {
      for (k in 1: length(names_dist))
      {
        names_in_each <- NULL
        if(m_number[k] == 4) offsets <- D2s
        if(m_number[k] == 8) offsets <- D2
        if(m_number[k] == 13) offsets <- D3s
        if(m_number[k] == 26) offsets <- D3
        offsets <- offsets * names_dist[k]
        
        for (l in 1: dim(offsets)[1])
        {
          names_in_each <- c(names_in_each, paste0(names_dcr[i], "_", names_bin[j], "_", offsets[l,1], offsets[l,2], offsets[l,3]))
        }
        names_in <- c(names_in, list(names_in_each))
        
      }
    }
  }


  #statistical names
  stat_names <- names(RIA_data_in$stat_glcm[[names_in[[1]][1]]])
  stat_abr_plus <- paste0("stat_glcm_", stat_abr)
  stat_abr_str <- gsub("X", "stat_data",statistic)


  

  for (i in 1: length(names_out))
  {
    RIA_data_in[[stat_abr_plus]][[names_out[i]]] <- list()
    
    for (j in 1: length(stat_names))
    {
      
      stat_data <- NULL
      for (k in 1: length(names_in[[i]])){
        
        stat_data <- append(stat_data, eval(parse(text = paste0("RIA_data_in$stat_glcm$`", names_in[[i]][k], "`$", stat_names[j]))))
      }
      
      func_stat_data <- eval(parse(text = stat_abr_str))
      
      RIA_data_in[[stat_abr_plus]][[names_out[i]]][[stat_names[j]]] <- func_stat_data
      
    }
    
    if (verbose_in == TRUE) {message(paste0("AGGREGATED STATISTICS WAS ADDED TO '", names_out[i], "' SLOT OF RIA_image$", stat_abr_plus, "\n"))}
    
  }

  return (RIA_data_in)

}