R/struct_create.R

In espadon: Easy Study of Patient DICOM Data in Oncology

#' Struct creating from contours list
#' @description The \code{struct.create} function creates a struct object from a 
#' list of polygons, representing the contours of a shape.
#' @param contours.list list of data frames or 3-column matrices, representing the 
#' xyz coordinates of polygon vertices.  Each polygon must have a unique 
#' z-coordinate. All coordinates must be uniformly distributed according to a 
#' unique inter-slice distance.
#' @param roi.name Character string, representing the name of created RoI.
#' @param roi.nb Positive integer, representing the number of created RoI.
#' @param roi.color Color of the created RoI, in hex code format ("#RRGGBB").
#' @param roi.type Type of RoI, from among "", "EXTERNAL", "PTV", "CTV", "GTV", 
#' "TREATED_VOLUME", "IRRAD_VOLUME", "OAR", "BOLUS", "AVOIDANCE", "ORGAN", "MARKER", 
#' "REGISTRATION", "ISOCENTER", "CONTRAST_AGENT", "CAVITY", "BRACHY_CHANNEL", 
#' "BRACHY_ACCESSORY", "BRACHY_SRC_APP", "BRACHY_CHNL_SHLD", "SUPPORT", "FIXATION", 
#' "DOSE_REGION","CONTROL" and "DOSE_MEASUREMENT".
#' @param ref.pseudo Character string, frame of reference pseudonym of the 
#' created object.By defaukt equal to "ref1"
#' @param frame.of.reference Character string, frame of reference of the 
#' created object.
#' @param alias Character string, \code{$alias} of the created object.
#' @param description Character string, describing the the created object.
#' @return Returns a "struct" class object (see \link[espadon]{espadon.class}
#' for class definition), including the unique \code{roi.name} as region of interest.
#' @seealso \link[espadon]{struct.from.mesh}.
#' @examples
#' contours.z <- -50:50
#' theta <- seq(0,2*pi, length.out = 100)
#' contours <- lapply(contours.z,function(z) {
#'   if (z < (-25)) return(data.frame(x = (50 + z) * cos(theta),
#'                                    y = (50 + z) * sin(theta),
#'                                    z = z))
#'   if (z > 25) return(data.frame(x = (50 - z) * cos(theta),
#'                                 y = (50 - z) * sin(theta),
#'                                 z = z))
#'   return(data.frame(x = 25 * cos(theta),
#'                     y = 25 * sin(theta),
#'                     z = z))
#' })
#' 
#' contours <- contours[!sapply(contours, is.null)]
#' S <- struct.create(contours, roi.name="myshape",
#'                    roi.nb = 1,
#'                    roi.color = "#ff0000",
#'                    roi.type = "",
#'                    ref.pseudo = "ref1", 
#'                   alias="", description = NULL)
#' display.3D.contour(S)

#' @export

struct.create <- function(contours.list, roi.name,
                          roi.nb = 1,
                          roi.color = "#ff0000",
                          roi.type = "",
                          ref.pseudo = "ref1", 
                          frame.of.reference = "",
                          alias="", description = NULL) {

  defined.type <- c("","EXTERNAL", "PTV", "CTV", "GTV",
                    "TREATED_VOLUME", "IRRAD_VOLUME", "OAR",
                    "BOLUS", "AVOIDANCE", "ORGAN", "MARKER",
                    "REGISTRATION", "ISOCENTER", "CONTRAST_AGENT",
                    "CAVITY", "BRACHY_CHANNEL", "BRACHY_ACCESSORY",
                    "BRACHY_SRC_APP", "BRACHY_CHNL_SHLD",
                    "SUPPORT", "FIXATION", "DOSE_REGION",
                    "CONTROL", "DOSE_MEASUREMENT")
  roi.type <- roi.type[!is.na(match(roi.type,defined.type))][1]
  if (is.na(roi.type)) roi.type <- ""
  if (roi.name == "") roi.name <- "my_ROI"
  if (is.null(description)) description <- "ROI from my contours"
  roi.all.z <- sapply(contours.list, function(M) M[1,3])
  z <- sort(unique(roi.all.z))
  thickness <- 0
  if (length(z) > 1) thickness <- min(diff(z))
  
  obj <- obj.create(class = "struct")
  obj$description <- description
  obj$frame.of.reference <- frame.of.reference
  obj$ref.pseudo <- ref.pseudo
  obj$nb.of.roi <- 0
  obj$thickness <- thickness
  obj$roi.info[1,] <- c(roi.nb[1], roi.name,"","AUTOMATIC",roi.color,
                        castlow.str(roi.name))
  obj$object.alias <- alias[1]
  obj$description <- description
  obj$roi.obs[1,] <- c(1,roi.nb[1],"","","","","",roi.type,"")
  obj$roi.data <- list()
  obj$roi.data[[1]] <- lapply(contours.list,function(M) {
    M <- round(M,6)
    
    slope.x <- diff(M[,1])
    slope.y <- diff(M[,2])
    d <-  sqrt(slope.x^2 + slope.y^2)
    pt <- M[c(TRUE, !(diff(round(slope.x/d,6)) == 0 & diff(round(slope.y / d, 6)) == 0), TRUE),]
    colnames(pt) <- c("x","y","z")
    row.names(pt) <- NULL
    list(type = ifelse(nrow(pt) == 1,"POINT ",
                     ifelse(all(pt[1,1:2] == pt[nrow(pt),1:2]),"CLOSED_PLANAR ","OPEN_PLANAR ")),
         pt = as.data.frame(pt), level = 0)})
  
  # We check whether the contours are inscribed or not.
  ord <- order(roi.all.z)
  obj$roi.data[[1]] <- obj$roi.data[[1]][ord]
  roi.all.z <- roi.all.z[ord]
  if (length(roi.all.z) > 0) {     
    kz <- rep(0,length(roi.all.z))
    if (obj$thickness != 0) kz <- round((roi.all.z - roi.all.z[1]) / obj$thickness)
    
    for (k.value in unique(kz)) {
      same.k.roi <- which(kz == k.value)
      if (length(same.k.roi) > 1) {
        for (j in same.k.roi) {
          ptj <- obj$roi.data[[1]][[j]]$pt
          roi.index.k <- same.k.roi[same.k.roi != j]
          # if (length(roi.index.z)!=0) {
          r <- unique(sapply(roi.index.k, function(k) {
            if (castlow.str(obj$roi.data[[1]][[k]]$type) != "closedplanar") return(NA)
            ptk <- obj$roi.data[[1]][[k]]$pt
            keep <- .pt.in.polygon(ptj[ ,1], ptj[ ,2],
                                              ptk[ ,1], ptk[ ,2]) > 0.5
            return(ifelse(all(keep), k,NA))}))
          r <- r[!is.na(r)]
          obj$roi.data[[1]][[j]]$level <- ifelse(length(r) != 0, length(r), 0)
        } #else obj$roi.data[[1]][[j]]$level <- 0
      } else obj$roi.data[[1]][[same.k.roi]]$level <- 0
    }
  }

  db <- .struct.moreinfo(obj$roi.data, obj$ref.from.contour,obj$thickness)
  obj$roi.info  <- cbind(obj$roi.info, db)
  
  class(obj) <- "struct"
  return(obj)
}