Diff of /R/radiomics_spatial.R [000000] .. [3b2327]

Switch to side-by-side view

--- a
+++ b/R/radiomics_spatial.R
@@ -0,0 +1,278 @@
+#' 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)
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+