R/radiomics_spatial.R

In muschellij2/lungct: Processing of Lung Computed Tomography ('CT') Scans

#' Calculate spatial radiomic features on a 2D or 3D array
#'
#' @param data Any 2D or 3D image (as matrix or array) to calculate spatial features
#' @param features = spatial radiomic features to calculate
#' @return Values from selected features
#' @importFrom abind abind
#' @export
radiomics_spatial <- function(data,
                              features = c('mi', 'gc', 'fd')){


  # Figure data dimension
  dimData <- length(dim(data))

  #2D
  if(dimData == 2){
    if('mi' %in% features){
      mi_value <- moran2D(data)
    }else(mi_value = NULL)
    if('gc' %in% features){
      gc_value <- geary2D(data)
    }else(gc_value = NULL)
    if('fd' %in% features){
      fd_value <- fd2D(data)
    }else(fd_value = NULL)

  }

  # 3D
  if(dimData == 3){

    if('mi' %in% features){
      mi_value <- moran3D(data)
    }else(mi_value = NULL)
    if('gc' %in% features){
      gc_value <- geary3D(data)
    }else(gc_value = NULL)
    if('fd' %in% features){
      fd_value <- NULL #fd3D(data) # still need to work on this
    }else(fd_value = NULL)

  }

  featuresList <- list(
    mi = mi_value,
    gc = gc_value,
    fd = fd_value
  )
  if(length(features)==1){
    featuresList = unlist(featuresList[features])
  }

  return(featuresList)

}


# Calculate Moran's I in 3D
moran3D <- function(mat){

  # Set up
  n <- length(mat[is.na(mat)==F])
  xbar <- mean(mat, na.rm=T)
  diff <- mat - xbar
  diff2 <- diff**2
  sum_diff2 <- sum(diff2, na.rm = T)

  # Dimension of matrix
  nx <- dim(diff)[1]
  ny <- dim(diff)[2]
  nz <- dim(diff)[3]

  # Rook shift
  left <- diff * abind(diff[-1,,], matrix(NA, nrow = ny, ncol = nz), along = 1)
  right <- diff * abind(matrix(NA, nrow = ny, ncol = nz), diff[-nx,,], along = 1)
  front <- diff * abind(diff[,-1,], matrix(NA, nrow = nx, ncol = nz), along = 2)
  back <- diff * abind(matrix(NA, nrow = nx, ncol = nz), diff[,-ny,], along = 2)
  up <- diff * abind(diff[,,-1], matrix(NA, nrow = nx, ncol = ny), along = 3)
  down <- diff * abind(matrix(NA, nrow = nx, ncol = ny), diff[,,-nz], along = 3)

  # Calcultate weights
  weights <- sum(length(left[is.na(left) == F])) +
    sum(length(right[is.na(right) == F])) +
    sum(length(front[is.na(front) == F])) +
    sum(length(back[is.na(back) == F])) +
    sum(length(up[is.na(up) == F])) +
    sum(length(down[is.na(down) == F]))

  # Change all "NAs" to zero, so we can efficiently sum matrices
  left[is.na(left)] <- 0
  right[is.na(right)] <- 0
  front[is.na(front)] <- 0
  back[is.na(back)] <- 0
  up[is.na(up)] <- 0
  down[is.na(down)] <- 0

  # Put info together to calculate MI
  sumv <- left + right + front + back + up + down
  local_mi <- sumv / sum_diff2 * n / weights
  global_mi <- sum(local_mi)

  return(global_mi)
}




# Calculate Moran's I in 2D
moran2D<-function(mat){

  # Set up
  n <- length(mat[is.na(mat)==F])
  xbar <- mean(mat, na.rm=T)
  diff <- mat - xbar
  diff2 <- diff**2
  sum_diff2 <- sum(diff2, na.rm = T)

  # Dimension of matrix
  nrow <- dim(diff)[1]
  ncol <- dim(diff)[2]

  # Rook shift
  up <- diff * rbind(diff[-1,],rep(NA,ncol))
  down <- diff * rbind(rep(NA,ncol),diff[-nrow,])
  left <- diff * cbind(diff[,-1],rep(NA,nrow))
  right <- diff * cbind(rep(NA,nrow),diff[,-ncol])

  # Calcultate weights
  weights <- sum(length(left[is.na(left) == F])) +
    sum(length(right[is.na(right) == F])) +
    sum(length(up[is.na(up) == F])) +
    sum(length(down[is.na(down) == F]))

  # Change all "NAs" to zero, so we can efficiently sum matrices
  left[is.na(left)] <- 0
  right[is.na(right)] <- 0
  up[is.na(up)] <- 0
  down[is.na(down)] <- 0

  # Put info together to calculate MI
  sumv <- left + right + up + down
  local_mi <- sumv / sum_diff2 * n / weights
  global_mi <- sum(local_mi)

  return(global_mi)
}




# Calculate Geary's C in 3D
geary3D<-function(mat){

  # Set up
  n <- length(mat[is.na(mat)==F])
  xbar <- mean(mat, na.rm=T)
  diff <- mat - xbar
  diff2 <- diff**2
  sum_diff2 <- sum(diff2, na.rm = T)

  # Dimension of matrix
  nx <- dim(diff)[1]
  ny <- dim(diff)[2]
  nz <- dim(diff)[3]

  # Rook shift
  left <- (mat - abind(mat[-1,,], matrix(NA, nrow = ny, ncol = nz), along = 1) )^2
  right <- (mat - abind(matrix(NA, nrow = ny, ncol = nz), mat[-nx,,], along = 1) )^2
  front <- (mat - abind(mat[,-1,], matrix(NA, nrow = nx, ncol = nz), along = 2) )^2
  back <- (mat - abind(matrix(NA, nrow = nx, ncol = nz), mat[,-ny,], along = 2) )^2
  up <- (mat - abind(mat[,,-1], matrix(NA, nrow = nx, ncol = ny), along = 3) )^2
  down <- (mat - abind(matrix(NA, nrow = nx, ncol = ny), mat[,,-nz], along = 3) )^2

  # Calcultate weights
  weights <- sum(length(left[is.na(left) == F])) +
    sum(length(right[is.na(right) == F])) +
    sum(length(front[is.na(front) == F])) +
    sum(length(back[is.na(back) == F])) +
    sum(length(up[is.na(up) == F])) +
    sum(length(down[is.na(down) == F]))

  # Change all "NAs" to zero, so we can efficiently sum matrices
  left[is.na(left)] <- 0
  right[is.na(right)] <- 0
  front[is.na(front)] <- 0
  back[is.na(back)] <- 0
  up[is.na(up)] <- 0
  down[is.na(down)] <- 0

  # Put info together to calculate GC
  sumv <- left + right + front + back + up + down
  local_gc <- sumv / sum_diff2 * (n - 1) / (2 * weights)
  global_gc <- sum(local_gc)

  return(global_gc)
}


# Calculate Geary's C in 2D
geary2D<-function(mat){

  # Set up
  n <- length(mat[is.na(mat)==F])
  xbar <- mean(mat, na.rm=T)
  diff <- mat - xbar
  diff2 <- diff**2
  sum_diff2 <- sum(diff2, na.rm = T)

  # Dimension of matrix
  nrow <- dim(diff)[1]
  ncol <- dim(diff)[2]

  # Rook shift
  up <- (mat - rbind(mat[-1,],rep(NA,ncol)) )^2
  down <- (mat - rbind(rep(NA,ncol),mat[-nrow,]) )^2
  left <- (mat - cbind(mat[,-1],rep(NA,nrow)) )^2
  right <- (mat - cbind(rep(NA,nrow),mat[,-ncol]) )^2

  # Calcultate weights
  weights <- sum(length(left[is.na(left) == F])) +
    sum(length(right[is.na(right) == F])) +
    sum(length(up[is.na(up) == F])) +
    sum(length(down[is.na(down) == F]))

  # Change all "NAs" to zero, so we can efficiently sum matrices
  left[is.na(left)] <- 0
  right[is.na(right)] <- 0
  up[is.na(up)] <- 0
  down[is.na(down)] <- 0

  # Put info together to calculate GC
  sumv <- left + right + up + down
  local_gc <- sumv / sum_diff2 * (n - 1) / (2 * weights)
  global_gc <- sum(local_gc)

  return(global_gc)
}






# Calculate fractal dimension in 2D
fd2D <- function(data) {
  fdx<-apply(data,1,fd1)
  fdy<-apply(data,2,fd1)
  fd<-c(fdx,fdy)
  fd_sub<-fd[fd<2]
  FD <- ifelse(length(fd_sub)<100,NA,1 + median(fd_sub,na.rm=T))
  return(FD)
}
fd1<-function(i){
  n <- length(i)
  g1 <- abs(i[2:n]-i[1:(n-1)])
  sumg1<-sum(g1,na.rm=T)/(2*length(g1[is.na(g1)==F]))
  g2 <- abs(i[3:n]-i[1:(n-2)])
  sumg2 <-  sum(g2,na.rm=T)/(2*length(g2[is.na(g2)==F]))
  slope <- sum(log(sumg2)-log(sumg1),na.rm=T)/log(2)
  fd <- 2-slope
  return(fd)
}