R/data_to_AST.R

In gitdemont/IFC: Tools for Imaging Flow Cytometry

################################################################################
# This file is released under the GNU General Public License, Version 3, GPL-3 #
# Copyright (C) 2022 Yohann Demont                                             #
#                                                                              #
# It is part of IFC package, please cite:                                      #
# -IFC: An R Package for Imaging Flow Cytometry                                #
# -YEAR: 2020                                                                  #
# -COPYRIGHT HOLDERS: Yohann Demont, Gautier Stoll, Guido Kroemer,             #
#                     Jean-Pierre Marolleau, Loïc Garçon,                      #
#                     INSERM, UPD, CHU Amiens                                  #
#                                                                              #
# DISCLAIMER:                                                                  #
# -You are using this package on your own risk!                                #
# -We do not guarantee privacy nor confidentiality.                            #
# -This program is distributed in the hope that it will be useful, but WITHOUT #
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or        #
# FITNESS FOR A PARTICULAR PURPOSE. In no event shall the copyright holders or #
# contributors be liable for any direct, indirect, incidental, special,        #
# exemplary, or consequential damages (including, but not limited to,          #
# procurement of substitute goods or services; loss of use, data, or profits;  #
# or business interruption) however caused and on any theory of liability,     #
# whether in contract, strict liability, or tort (including negligence or      #
# otherwise) arising in any way out of the use of this software, even if       #
# advised of the possibility of such damage.                                   #
#                                                                              #
# You should have received a copy of the GNU General Public License            #
# along with IFC. If not, see <http://www.gnu.org/licenses/>.                  #
################################################################################

################################################################################
#              This file contains function under development                   #
################################################################################

#' @title AST File Writer
#' @description
#' Writes an `IFC_data` object to a ast file
#' @param obj an `IFC_data` object extracted with features extracted.
#' @param write_to pattern used to export file.
#' Placeholders, like "\%d/\%s_fromR.\%e", will be substituted:\cr
#' -\%d: with full path directory of 'obj$fileName'\cr
#' -\%p: with first parent directory of 'obj$fileName'\cr
#' -\%e: with extension of 'obj$fileName' (without leading .)\cr
#' -\%s: with shortname from 'obj$fileName' (i.e. basename without extension).\cr
#' Exported file extension will be deduced from this pattern. Note that it has to be a .ast.
#' @param viewing_pop Character String. Allow user to change displayed population. Default is 'All'.
#' @param overwrite whether to overwrite file or not. Default is FALSE.
#' Note that if TRUE, it will overwrite exported file if path of 'obj$fileName' and deduced from 'write_to' arguments are different.
#' Otherwise, you will get an error saying that overwriting source file is not allowed.\cr
#' Note also that an original file, i.e. generated by IDEAS(R) or INSPIRE(R), will never be overwritten.
#' Otherwise, you will get an error saying that overwriting original file is not allowed.
#' @param display_progress whether to display a progress bar. Default is TRUE.
#' @param verbose whether to display information (use for debugging purpose). Default is FALSE.
#' @param ... other arguments to be passed.
#' @return It invisibly returns full path of exported file.
#' @keywords internal
data_to_AST = function(obj, write_to, viewing_pop = "All", overwrite = FALSE,
                       display_progress = TRUE, verbose = FALSE, ...) {
  dots = list(...)
  # change locale
  locale_back <- setloc(c("LC_ALL" = "en_US.UTF-8"))
  enc_back <- options("encoding" = "UTF-8")
  on.exit(suspendInterrupts({setloc(locale_back); options(enc_back)}), add = TRUE)
  now = format(Sys.time(), format = "%d-%b-%y %H:%M:%S")
  
  # check mandatory param
  assert(obj, cla = "IFC_data")
  if(length(obj$pops)==0) stop("please use argument 'extract_features' = TRUE with ExtractFromDAF() or ExtractFromXIF() and ensure that features were correctly extracted")
  if(missing(write_to)) stop("'write_to' can't be missing")
  assert(write_to, len = 1, typ = "character")
  assert(overwrite, len = 1, alw = c(TRUE, FALSE))
  assert(display_progress, c(TRUE, FALSE))
  assert(verbose, c(TRUE, FALSE))
  
  # check on obj
  if(length(obj$description$FCS)!=0) stop("can't create .ast file from 'obj' created from .fcs")
  # TODO ask AMNIS about Raw Number, it seems to be a problem when this feature is part of daf file
  obj = suppressWarnings(data_rm_features(obj, "Raw Number", list_only = FALSE)) # ensures to remove "Raw Number"
  # when obj is from rif or cif, number of objects can be different from actual number of collected object
  # e.g. merged of subset of file, there is no way to link object number and feature value so the only solution
  # is to remove all features and only keep Object Number
  obj = checkObj(obj)
  
  # tests if file can be written
  fileName = normalizePath(obj$fileName, winslash = "/", mustWork = FALSE)
  title_progress = basename(fileName)
  splitf_obj = splitf(fileName)
  splitp_obj = splitp(write_to)
  write_to = formatn(splitp_obj, splitf_obj)
  file_extension = getFileExt(write_to)
  assert(file_extension, len = 1, alw = "ast")
  if(any(splitp_obj$channel > 0)) message("'write_to' has %c argument but channel information can't be retrieved with data_to_AST()")
  if(any(splitp_obj$object > 0)) message("'write_to' has %o argument but channel information can't be retrieved with data_to_AST()")
  
  overwritten = FALSE
  if(file.exists(write_to)) {
    write_to = enc2native(normalizePath(write_to, winslash = "/", mustWork = FALSE))
    if(!overwrite) stop("file ",write_to," already exists")
    if(tolower(fileName) == tolower(write_to)) stop("you are trying to overwrite source file which is not allowed")
    xmlEND_export = cpp_scanFirst(write_to, charToRaw("</AssayTemplate>"), start = 0, end = 0)
    if(xmlEND_export > 0) {
      xml_export = read_xml(readBin(con = write_to, what = "raw", n = xmlEND_export + nchar("</AssayTemplate>") - 1), options=c("HUGE","RECOVER","NOENT","NOBLANKS","NSCLEAN"))
      tryCatch({
        is_fromR = as.character(na.omit(xml_attr(xml_find_first(xml_export, "//AssayTemplate"), attr = "IFC_version")))
      }, finally = rm(xml_export))
      if(length(is_fromR)==0) stop("you are trying to overwrite an original file which is not allowed")
    } else {
      stop(write_to, "\ndoes not seem to be well formatted: </AssayTemplate> not found")
    }
    tmp_file = normalizePath(tempfile(), winslash = "/", mustWork = FALSE)
    overwritten = TRUE
  }
  dir_name = dirname(write_to)
  if(!dir.exists(dir_name)) if(!dir.create(dir_name, recursive = TRUE, showWarnings = FALSE)) stop("can't create\n", dir_name)
  file_w = ifelse(overwritten, tmp_file, write_to)
  tryCatch(suppressWarnings({
    towrite = file(description = file_w, open = "wb")
  }), error = function(e) {
    stop(ifelse(overwritten,"temp ","'write_to' "), "file: ", file_w, "\ncan't be created: check name ?")
  })
  close(towrite)
  write_to = normalizePath(write_to, winslash = "/", mustWork = FALSE)
  
  # defines some variables
  pkg_ver = paste0(unlist(packageVersion("IFC")), collapse = ".")
  binary = obj$description$Assay$binaryfeatures
  binary = (length(binary) != 0) && (binary == "True")
  channels = obj$description$Images
  channels$physicalChannel = channels$physicalChannel - 1
  channels$color = map_color(channels$color, FALSE)
  
  sub_nodes = #c(sub_nodes,
                list(xml_new_node(name = "ChannelPresets",
                                  # attrs = list(count = nrow(channels), bits = "12"),
                                  .children = xml_new_node(name = "gallery",
                                                           attrs = list(viewmode="All Channels",
                                                                        orderByFeature="Object Number",
                                                                        ascendingOrder="true",
                                                                        population=ifelse(viewing_pop %in% names(obj$pops), viewing_pop, "All"),
                                                                        showMasks="false",
                                                                        showColor="true",
                                                                        showSaturationColor="false"))),
                     xml_new_node(name = "Images", .children = lapply(1:nrow(channels), FUN=function(i) {
                       xml_new_node(name = "image", attrs = channels[i, ])
                     })),
                     xml_new_node(name = "Composites"),
                     toXML2_masks(obj$description$masks, verbose = verbose))#)
  
  sub_nodes = c(sub_nodes, list(toXML2_features_def(obj$features_def, verbose = verbose),
                                xml_new_node(name = "Classifiers"),
                                toXML2_regions(obj$regions, verbose = verbose),
                                toXML2_pops(obj$pops, verbose = verbose, display_progress = display_progress, title_progress = title_progress),
                                xml_new_node(name = "StatisticsReports")))
  
  # defines root node "AssayTemplate"
  root <- xml_new_root("AssayTemplate")
  # adds attributes to root node
  IDEAS_version = obj$description$Assay$IDEAS_version
  if(binary) {
    if(length(IDEAS_version) == 0)
      IDEAS_version = "6.2.64.0"
    root %>% xml_set_attrs(value = c(IFC_version = pkg_ver, 
                                     date = now, IDEAS_version = IDEAS_version)) #, binaryfeatures = "True"))
  } else {
    if(length(IDEAS_version) == 0)
      IDEAS_version = "6.1.822.0"
    root %>% xml_set_attrs(value = c(IFC_version = pkg_ver, 
                                     date = now, IDEAS_version = IDEAS_version))
  }
  
  # adds first children
  xml_add_child(root, .value = xml_new_node(name = "SampleName", text = ""))
  xml_add_child(root, .value = xml_new_node(name = "ShowSampleName", text = "False"))
  
  # writes subnodes
  lapply(sub_nodes, FUN = function(x) xml_add_child(root, .value = x ))
  
  # add stats & graphs
  stats = dots$stats
  if(length(stats) == 0) stats = list(list(type="COUNT",title="Count",def=""),
                                      list(type="PERCENT_GATED",title="%Gated",def=""))
  yloc = unlist(lapply(obj$graphs, FUN = function(g) g[["ylocation"]]))
  size = unlist(lapply(obj$graphs, FUN = function(g) g[["ysize"]]))
  stats = buildStats(obj, stats, width = 80 * (1 + length(stats)), height = 240, xlocation = 0, ylocation = max(c(yloc + size, 0)))
  disp_nodes = list(toXML2_stats(stats, verbose = verbose))
  if(length(obj$graphs) > 0) disp_nodes = c(disp_nodes, toXML2_graphs(obj$graphs, verbose = verbose))
  xml_add_child(root, .value =   xml_new_node(name = "Displays", attrs = list(count = num_to_string(1+length(obj$graphs)),
                                                                              layout="1", entriesPerRow="12", lightDarkMode="1"),
                                              .children = disp_nodes))
  tryCatch({
    write_xml(root, file = file_w, encoding = "utf-8")
  }, error = function(e) {
    stop(paste0("Can't create 'write_to' file.\n", write_to,
                ifelse(overwritten,"\nFile was not modified.\n","\n"),
                "See pre-file @\n", normalizePath(file_w, winslash = "/"), "\n",
                e$message), call. = FALSE)
  })
  if(overwritten) {
    mess = paste0("\n######################\n", write_to, "\nhas been successfully overwritten\n")
    if(!suppressWarnings(file.rename(to = write_to, from = file_w))) { # try file renaming which is faster
      if(!file.copy(to = write_to, from = file_w, overwrite = TRUE)) { # try file.copy if renaming is not possible
        stop(paste0("Can't copy temp file@\n", normalizePath(file_w, winslash = "/"), "\n",
                    "Can't create 'write_to' file.\n", write_to,
                    "\nFile was not modified.\n"), call. = FALSE)
      } else {
        file.remove(file_w, showWarnings = FALSE)
      }
    }
  } else {
    mess = paste0("\n######################\n", write_to, "\nhas been successfully exported\n")
  }
  message(mess)
  return(invisible(write_to))
}