R/get_obj_connection.R

In espadon: Easy Study of Patient DICOM Data in Oncology

#' List of connections between objects
#' @description The \code{get.obj.connection} function describes with 4 matrices 
#' the different connections between the DICOM objects of the patient.
#' @param pat "patient" class object, as loaded using \link[espadon]{load.patient.from.dicom}, 
#'  \link[espadon]{load.patient.from.Rdcm} or \link[espadon]{toy.load.patient}. 
#' @return Returns a list of 4 named matrices:
#' \itemize{
#' \item the \code{$adjacency} matrix matrix specifies the source objects that 
#' generated the destination objects: the column names correspond to the 
#' destinations, and the row names to the sources.
#' \item the \code{$same.object} matrix specifies the elements belonging to the same 
#' DICOM object.
#' \item the \code{$components} matrix specifies the objects belonging to the same study.
#' \item the \code{$same.ref} matrix specifies the objects that share the same frame of 
#' reference, or with frames of reference linked in T.MAT (by a DICOM reg file 
#' for instance)
#' }
#' @examples
#' # loading of toy-patient objects
#' patient <- toy.load.patient(dxyz = c(5, 5, 5), beam.nb = 1)
#' get.obj.connection(patient)
#' display.obj.links(patient)
#' @seealso \link[espadon]{display.obj.links}
#' @export
get.obj.connection <- function(pat) {
  
  if (is.null(pat)) stop("pat is NULL")
  if (any(is.na(match(c("patient", "pat.pseudo","description","T.MAT"),names(pat))))) stop("pat is not a patient")
  obj.list <- obj.alias  <- obj.name <- c()
  obj.type <- obj.idx <- c()
  obj.con <- list()
  end.idx <- length(pat)
  if (names(pat)[end.idx] == "dicom.dvh") end.idx <- end.idx - 1
  for (i in(which(names(pat) == "T.MAT") + 1):end.idx) {
    for (j in 1:length(pat[[i]])) {
      obj.idx <- c(obj.idx, j)
      obj.list <- c(obj.list, paste(names(pat)[i], j))
      obj.alias <- c(obj.alias, pat[[i]][[j]]$object.alias)
      obj.name <- c(obj.name, pat[[i]][[j]]$object.name)
      if (is.null(pat[[i]][[j]]$ref.object.alias)) obj.con <- c(obj.con, "NA")
      else obj.con <- c(obj.con, list(pat[[i]][[j]]$ref.object.alias))
      names(obj.con) <- obj.alias
    }
  }
  
  M <- matrix(0, nrow = length(obj.list), ncol = length(obj.list))
  rownames(M) <- obj.list
  colnames(M) <- obj.list
  
  for (i in 1:length(obj.list)) {
    idx <- which(sapply(obj.con, function(V) obj.alias[i] %in% V))
    M[i, idx] <- 1
  }
 
  M.same.obj <- matrix(0, nrow = length(obj.list), ncol = length(obj.list))
  rownames(M.same.obj) <- obj.list
  colnames(M.same.obj) <- obj.list
  for (i in 1:length(obj.list)) {
    idx <- which(sapply(obj.name, function(V) obj.name[i] %in% V))
    M.same.obj[i, idx] <- 1
  }
  
  M_ <- (M + diag(ncol(M)) + t(M)) == 1
  M_[] <- sapply(M_,as.numeric)
  pere <- obj.list[apply(M,2,sum) == 0]
  pere.idx <- match(pere, obj.list)
  M0 <- M_
  M0[] <- 0
  L <- lapply(1:length(pere), function(idx) {
    A <- M0
    A[pere[idx], ] <- M_[pere[idx], ]
    A[ ,pere[idx]] <- M_[pere[idx], ]
    A
  })
  
  for (idx in 1:length(L)) {
    old.vect <- rep(FALSE, ncol(M_))
    new.vect <-  L[[idx]][pere.idx[idx],] > 0
    while (!all(new.vect == old.vect)) {
      old.vect <- L[[idx]][pere.idx[idx],] > 0
      L[[idx]] <- L[[idx]] %*% M_
      new.vect <- L[[idx]][pere.idx[idx],] > 0
    }
    L[[idx]] <- L[[idx]] > 0
    L[[idx]][new.vect,] <- L[[idx]][rep(pere.idx[idx],sum(new.vect)),]
    L[[idx]] [] <- sapply(L[[idx]],as.numeric)
  }
  
  components <- M0
  for (idx in 1:length(L)) components <- components + L[[idx]]
  components <- (components > 0) + 0

  same.ref <- M0
  for (idx in 1:length(pat$description.by.reg)) {
    reg <- unlist(strsplit(pat$description.by.reg[[idx]]$object.alias,";"))
    ma <- match( obj.alias, reg)
    vect <- !is.na(ma) 
    same.ref[vect,] <- matrix(rep(vect,sum(vect)), ncol = length(vect), byrow = TRUE)
  }
  
  return(list(adjacency = M, same.object = M.same.obj,
                components = components, same.ref=same.ref))
}