R/load_patient_from_dicom.R

In espadon: Easy Study of Patient DICOM Data in Oncology

#' Loading patient data from DICOM files
#' @description The \code{load.patient.from.dicom} function is used to load or 
#' pre-load in memory all patient objects from DICOM files.
#' @param dcm.files String vector, representing the list of the full names of the  
#' DICOM files of the same patient, or its directories.
#' @param data Boolean. If \code{data = TRUE}, the voxels value of the "volume" 
#' class objects, or the coordinates of the RoI (region of interest)
#' of the \code{struct} class objects, are loaded into memory.
#' @param dvh Boolean. if \code{dvh = TRUE} and if they exist, patient DVH are 
#' loaded, for convenience. They are not used as is in \pkg{espadon} package.
#' @param ignore.duplicates Boolean. If \code{TRUE}, the function ignores duplicated objects.
#' @param tag.dictionary Dataframe, by default equal to 
#' \link[espadon]{dicom.tag.dictionary}, 
#' whose structure it must keep. This dataframe is used to parse DICOM files.
#' @param verbose Boolean. If \code{TRUE}, a progress bar indicates loading progress.
#' @return Returns an \pkg{espadon} object of class "patient", describing the 
#' information from \code{dcm.files}. See \link[espadon]{espadon.class} for a 
#' description of the "patient" class.

#' @seealso  \link[espadon]{dicom.to.Rdcm.converter}, \link[espadon]{load.patient.from.Rdcm}, 
#' \link[espadon]{load.obj.data},  \link[espadon]{load.obj.from.dicom}, 
#' \link[espadon]{load.obj.from.Rdcm} and \link[espadon]{load.T.MAT}.
#' @examples
#' # First, save toy.dicom.raw () raw data to a temporary file pat.dir for testing.
#' pat.dir <- file.path (tempdir(), "toy_dcm") 
#' dir.create (pat.dir, recursive = TRUE) 
#' dcm.filename <- tempfile (pattern = "toyrtplan", tmpdir = pat.dir,
#'                           fileext = ".dcm")
#' zz <- file (dcm.filename, "wb")
#' writeBin (toy.dicom.raw (), zz, size = 1)
#' close (zz)
#' 
#' # loading patient. Here the toy patient ha only a unique rt-plan object
#' patient <- load.patient.from.dicom (pat.dir, data = FALSE)
#' str (patient, max = 2)
#' # description of object
#' patient$description
#' # transfer matrices :
#' patient$T.MAT
#' # rt-plan object
#' str (patient$rtplan[[1]])

#' # Cleaning  temporary directory
#' unlink (pat.dir, recursive = TRUE)

#' @export
load.patient.from.dicom <- function (dcm.files, data = FALSE, dvh = FALSE, 
                                     ignore.duplicates = FALSE,
                                     tag.dictionary = dicom.tag.dictionary (),
                                     verbose = TRUE){
  
  if (length(dcm.files)==0) {
    warning ("no files to load.")
    return (NULL)
  } 
  flag <- dir.exists(dcm.files)
  dcm.dir <- dcm.files[flag]
  dcm.filenames1 <-  list.files(dcm.dir,recursive = TRUE,full.names = TRUE)
  dcm.filenames2 <- dcm.files[!flag]
  dcm.filenames2 <- dcm.filenames2[file.exists(dcm.filenames2)]
  dcm.filenames <- c(dcm.filenames1,dcm.filenames2)
  if (length(dcm.filenames)==0) {
    warning ("no files to load.")
    return (NULL)
  } 
  obj.list <- .load.dcm (dcm.filenames, data=data, 
                         ignore.duplicates = ignore.duplicates,
                         tag.dictionary = tag.dictionary,
                         verbose = verbose)
  
  if (is.null(obj.list)) return (NULL)
  
  base.n <- do.call (rbind.data.frame, lapply(obj.list, function(l) {
    nb <- switch(l$header$modality, "rtstruct" =  l$header$nb.of.roi,  
                 "rtdose" = l$header$n.ijk[3], "ct" = l$header$n.ijk[3],
                 "ct1" = l$header$n.ijk[3], "mr" = l$header$n.ijk[3], 
                 "pt" = l$header$n.ijk[3], "binary" = l$header$n.ijk[3],
                 "reg" = l$header$nb.of.ref, "mesh" = l$header$nb.faces,
                 "histo" = l$header$nb.MC,"dvh" = l$header$nb.MC,
                 "histo2D" = l$header$nb.pixels, 
                 "rtplan"=sum(l$header$fraction.info[1,c("nb.of.beam","nb.of.brachy.app")],na.rm=T), 
                 NA)
    subobj.nb <- NA
    idx <- grep ("nb[.]of[.]subobj", names(l$header$object.info))
    if (length(idx)>0) subobj.nb <-l$header$object.info[[idx]]
    max.pix <- NA
    idx <- grep ("max[.]pixel", names(l$header))
    if (length(idx)>0)  max.pix <- l$header[[idx]]
    c(l$header$patient, l$header$patient.name, as.character(l$header$patient.bd),
      l$header$patient.sex, l$header$modality, l$header$object.name, l$header$ref.pseudo,
      subobj.nb, l$header$description, nb,
      max.pix,
      l$header$object.alias, paste(l$header$file.basename,collapse=";"))
  }))
  
  colnames(base.n) <- c ("PIN", "name", "birth.date","sex", "modality", "obj", 
                         "ref.pseudo", "nb.of.subobject" ,"description","nb", 
                         "max","object.alias", "file.basename")
  base.n <- base.n[order(base.n$PIN,base.n$ref.pseudo,base.n$modality),]
  base.n$max<- suppressWarnings(as.character(round(as.numeric(base.n$max),3)))
  base.n$nb<- suppressWarnings(as.numeric(base.n$nb))
  row.names(base.n) <- NULL
  
  l <- list()
  l$patient <- unique (base.n[,c ("PIN", "name", "birth.date", "sex")])
  row.names(l$patient) <- NULL
  if (nrow(l$patient) != 1) 
    warning("Check the uniqueness of the patient : different PID, name, birthday or sex.", call.=FALSE)
  
  l$pat.pseudo <- l$patient[1,1]
  
  # db <- base.n[base.n[,1]==patient[patient.idx],2:5 ]
  
  l$description <- unique(base.n[,c (1, 5:9)])
  row.names (l$description) <- NULL
  l$description$nb <- sapply (l$description$obj, function (obj) paste(base.n$nb[which(base.n$obj==obj)], collapse = ";"))
  l$description$max <- sapply (l$description$obj, function (obj) paste(base.n$max[which(base.n$obj==obj)], collapse = ";"))
  l$description$object.alias <- sapply (l$description$obj, function (obj) paste(base.n$object.alias[which(base.n$obj==obj)], collapse = ";"))
  
  
  l$description.by.reg <- list ()
  
  
  
  reg.list <-lapply (obj.list, function (fn){
    h <- fn$header
    if (h$modality!="reg") return(list(ref.pseudo =  h$ref.pseudo,
                                       ref = h$frame.of.reference, 
                                       patient =h$patient,
									   patient.name=h$patient.name,
                                       patient.bd =h$patient.bd,
                                       patient.sex=h$patient.sex))
    return(list(ref.pseudo =  h$ref.pseudo,
                ref = h$frame.of.reference, reg.list=h,
                patient =h$patient,
				patient.name =h$patient.name,
                patient.bd =h$patient.bd,
                patient.sex=h$patient.sex))
  })
  l$T.MAT <- suppressWarnings(.load.T.MAT.by.reglist (reg.list))
  modality <- sort (unique (base.n$modality[base.n$modality!="reg"]))
  obj <- lapply(modality, function (m) {
    alias <-  base.n$object.alias[(base.n$modality==m)]
    tab.L <- strsplit(alias,paste0("[_]ref|[_]do|[_]", m))
    tab.L <- do.call(rbind.data.frame,lapply(tab.L,function(v) c(v,rep("",4))[1:4]))
    tab.L[2:4] <-lapply(tab.L[2:4], as.numeric)
    alias <- alias[order(tab.L[,1],tab.L[,2],tab.L[,3],tab.L[,4])]
    
    match.index <- match(alias, sapply (obj.list, function(l) l$header$object.alias))
    lobj.l <- list()
    for (idx in 1:length(alias)) lobj.l[[idx]] <- .load.object (Lobj = obj.list[[match.index[idx]]], data=data, raw.data.list=obj.list)
    names (lobj.l) <- alias
    return (lobj.l)
  })
  names(obj) <- modality
  l <- do.call(c, list(l, obj))
  
  if (dvh){
    l$dicom.dvh <- lapply(obj.list, function(obj) return(obj$header$dvh))
    l$dicom.dvh <- l$dicom.dvh [which(!sapply (l$dicom.dvh, is.null))]
    
    if (length( l$dicom.dvh)>0){
      for (dvh.idx in 1:length(l$dicom.dvh)){
        ref.object <-  names(obj.list)[(sapply(obj.list,function(dl) dl$header$object.info$SOP.ID)==l$dicom.dvh[[dvh.idx]]$ref.object.info$SOP.ID) & 
                                         (sapply(lapply(obj.list, function(dl) dl$header$object.info$SOP.label), function(v) l$dicom.dvh[[dvh.idx]]$ref.object.info$SOP.label %in% v))]
        
        if (length(ref.object)>0) l$dicom.dvh[[dvh.idx]]$ref.object.alias <-ref.object
        
        if (l$dicom.dvh[[dvh.idx]]$ref.object.alias[1]!=""){
          ma <- match(l$dicom.dvh[[dvh.idx]]$info$number, obj.list[[l$dicom.dvh[[dvh.idx]]$ref.object.alias[1]]]$header$roi.info$number)
          l$dicom.dvh[[dvh.idx]]$info$roi.name[!is.na(ma)] <- 
            obj.list[[l$dicom.dvh[[dvh.idx]]$ref.object.alias[1]]]$header$roi.info$name[ma[!is.na(ma)]]
          # n <- names(l$dicom.dvh[[dvh.idx]]$data)
          # n[!is.na(ma)] <- l$dicom.dvh[[dvh.idx]]$info$roi.name[!is.na(ma)]
          # names(l$dicom.dvh[[dvh.idx]]$data) <- n
        }
      }
    } else {l$dicom.dvh <- NULL}
  }
  
  l.reg <- strsplit(names(l$T.MAT$matrix.list)[sapply(l$T.MAT$matrix.list, function(m) !is.null(m))],"<-")
  l.reg <- lapply(l.reg,function(li) sort(unique(li)))
  l.reg <- l.reg[!duplicated(l.reg)]
  l.reg_ <- list ()
  reg.idx <- 1
  for (ref in sort(unique(unlist(l.reg)))) {
    v <- sort(unique(unlist(l.reg[sapply(l.reg,function(l) ref %in% l)])))
    if (!is.null(v)){
      l.reg_ [[reg.idx]]<- v
      l.reg <- l.reg[!sapply(l.reg, function(li) any(!is.na(match(li,l.reg_[[reg.idx]]))))]
      if (length(l.reg)==0) break
      reg.idx <- reg.idx + 1
    }
  }
  l$description.by.reg <- lapply (l.reg_, function (li) l$description[l$description$ref.pseudo %in% li,])
  
  
  return (l)
}