R/ref_srctodest_add.R

In espadon: Easy Study of Patient DICOM Data in Oncology

#' Linking two existing frames of reference in T.MAT
#' @description The \code{ref.srctodest.add} function links the source frame of 
#' reference with the destination frame of reference. 
#' @param src.ref Character string, pseudonym of the source frame of reference.
#' @param dest.ref Character string, pseudonym of the destination frame of reference.
#' @param TM 4x4 tansfert matrix for moving from \code{src.ref} to \code{dest.ref}.
#' @param T.MAT "t.mat" class object created by 
#' \link[espadon]{load.patient.from.dicom}, \link[espadon]{load.patient.from.Rdcm} 
#' or \link[espadon]{load.T.MAT}. If \code{T.MAT = NULL}, then only the link 
#' between \code{src.ref} and \code{dest.ref} is established.

#' @return Returns a "t.mat" class object, which contains the transfer 
#' matrices from or to \code{dest.ref} pseudonym of the new frame
#' of reference. If the \code{T.MAT} is \code{NULL}, then the returned object 
#' will contain only 4 matrices: "src.ref<-src.ref",
#' "src.ref<-dest.ref", "dest.ref<- dest.ref", "dest.ref<-src.ref".
#' @seealso \link[espadon]{ref.add}, \link[espadon]{ref.cutplane.add}, 
#' \link[espadon]{ref.remove}.
#' @examples
#' local.Tmat <-  ref.srctodest.add("ref1","ref2", 
#'                                  TM = matrix(c(0.5, -sin(pi / 3), 0, 0,
#'                                                sin(pi / 3), 0.5, 0, 0,
#'                                                0, 0, 1, 0, 0, 0, 0, 1),
#'                                               ncol = 4))
#' str(local.Tmat)   
                                           

#' @export
#' @importFrom methods is
ref.srctodest.add <- function(src.ref, dest.ref, TM = diag(4), T.MAT = NULL) {
  
  if (as.character(src.ref) == as.character(dest.ref) |
      as.character(src.ref) == "" | as.character(dest.ref) == "") stop("Redefine src.ref or dest.ref.")
  
  
  new.list.matrix <- list()
  new.list.matrix[[1]] <- diag(4)
  new.list.matrix[[2]] <- TM
  new.list.matrix[[3]] <- solve(TM) 
  new.list.matrix[[4]] <- diag(4)
  names(new.list.matrix) <- c(paste(src.ref, src.ref, sep = "<-"),
                              paste(dest.ref,src.ref, sep = "<-"),
                              paste(src.ref,dest.ref, sep = "<-"),
                              paste(dest.ref,dest.ref, sep = "<-"))
  new.matrix.description <- data.frame(t = names(new.list.matrix), src = c(src.ref, src.ref, dest.ref, dest.ref),
                                       dest = c(src.ref, dest.ref, src.ref, dest.ref), 
                                       type = rep("RIGID",4), stringsAsFactors = FALSE)
  
  
  db.file <- data.frame(t = paste(dest.ref, src.ref, sep = "<-"),path = "local")
  ref.info <- data.frame( ref.pseudo = c(src.ref,dest.ref), ref = c("",""), stringsAsFactors = FALSE)
  if (is.null(T.MAT)) {
    r <- (list(ref.info = ref.info,
               reg.info = list(patient = data.frame(patient = character(0),
                                                    patient.name = character(0),
                                                    patient.bd = character(0),
                                                    patient.sex = character(0)),
                               file = db.file),
               matrix.description = new.matrix.description, matrix.list = new.list.matrix))
    class(r) <- "t.mat"
    return(r)
  }
  
  if (!is(T.MAT, "t.mat")) stop("T.MAT should be a t.mat class object.")
  if (!(src.ref %in% T.MAT$ref.info$ref.pseudo)) stop("src.ref should be in T.MAT.")
  if (!(dest.ref %in% T.MAT$ref.info$ref.pseudo)) stop("dest.ref should be in T.MAT.")  
  
  
  if (!is.null(T.MAT$matrix.list[[paste0(dest.ref, "<-", src.ref)]])) {
    warning(paste("The link between", src.ref, "and", dest.ref, "already exists, it remains unchanged.",
                  "The link can be removed by deleting", src.ref, "or", dest.ref, 
                  "in the T.MAT object, using the ref.remove function."))
    return(T.MAT)
  }
  
  
  ref.info <- T.MAT$ref.info
  ref.info_ <- ref.info[ ,1:2]
  reg.info <- T.MAT$reg.info
  reg.info$file <- rbind(reg.info$file, db.file)
  matrix.description <- unlist(lapply(ref.info_$ref.pseudo,
                                      function(r) 
                                        paste(paste(ref.info_$ref.pseudo, r, sep = "<-"),r,ref.info_$ref.pseudo, sep = ";")))
  matrix.description <- do.call(rbind.data.frame,strsplit(matrix.description,";"))
  names(matrix.description)  <- c("t","src","dest")
  matrix.description$type = ""
  matrix.description[] <- data.frame(lapply(matrix.description[], as.character), stringsAsFactors = FALSE)
  
  list.matrix <- lapply(matrix.description$t,function(r) return(NULL))
  names(list.matrix) <- matrix.description$t
  for (i in 1:nrow(matrix.description)) {
    if (!is.null(T.MAT$matrix.list[[matrix.description$t[i]]])) {
      list.matrix[[i]] <- T.MAT$matrix.list[[matrix.description$t[i]]]
      matrix.description[i,4] <- T.MAT$matrix.description[T.MAT$matrix.description$t == matrix.description$t[i],4]
    } else if (!is.null(new.list.matrix[[matrix.description$t[i]]])) {
      list.matrix[[i]] <- new.list.matrix[[matrix.description$t[i]]]
      matrix.description[i,4] <- new.matrix.description[new.matrix.description$t == matrix.description$t[i],4]
    }
  }
  change <- TRUE
  while (change) {
    idx.left <- which(matrix.description$type == "RIGID" & matrix.description$dest != matrix.description$src)
    change <- FALSE
    for (idx in idx.left) {
      new.link <- which(matrix.description$src == matrix.description[idx,]$dest & matrix.description$type == "RIGID" &
                          matrix.description$dest != matrix.description[idx,]$src & matrix.description$dest != matrix.description$src)
      if (length(new.link) > 0) for (new.link.idx in 1:length(new.link)) {
        to.complete.idx <- which(matrix.description$src == matrix.description[idx,]$src & matrix.description$dest == matrix.description[new.link[new.link.idx],]$dest)
        if (matrix.description[to.complete.idx, ]$type == "") {
          
          matrix.description[to.complete.idx, ]$type <- "RIGID"
          list.matrix[[matrix.description[to.complete.idx, ]$t]] <- list.matrix[[matrix.description[new.link[new.link.idx],]$t]] %*% list.matrix[[matrix.description[idx, ]$t]]
          change <- TRUE
        }
      }
    }
  }
  r <- (list(ref.info = ref.info, reg.info = reg.info, matrix.description = matrix.description, matrix.list = list.matrix))
  class(r) <- "t.mat"
  
  return(r)
}