R/write_R2BIN.R

In Luminescence: Comprehensive Luminescence Dating Data Analysis

#' @title Export Risoe.BINfileData into Risø BIN/BINX-file
#'
#' @description Exports a `Risoe.BINfileData` object in a `*.bin` or `*.binx` file that can be
#' opened by the Analyst software or other Risø software.
#'
#' @details
#' The structure of the exported binary data follows the data structure
#' published in the Appendices of the *Analyst* manual p. 42.
#'
#' If
#' `LTYPE`, `DTYPE` and `LIGHTSOURCE` are not of type
#' [character], no transformation into numeric values is done.
#'
#' @param object [Risoe.BINfileData-class] (**required**):
#' input object to be stored in a bin file.
#'
#' @param file [character] (**required**):
#' file name and path of the output file
#'
#' - `[WIN]`: `write_R2BIN(object, "C:/Desktop/test.bin")`
#' - `[MAC/LINUX]`: `write_R2BIN("/User/test/Desktop/test.bin")`
#'
#' @param version [character] (*optional*):
#' version number for the output file. If no value is provided the highest
#' version number from the [Risoe.BINfileData-class] is taken automatically.
#'
#' **Note:**
#' This argument can be used to convert BIN-file versions.
#'
#' @param compatibility.mode [logical] (*with default*):
#' this option recalculates the position values if necessary and set the max.
#' value to 48. The old position number is appended as comment (e.g., 'OP: 70).
#' This option accounts for potential compatibility problems with the Analyst software.
#' It further limits the maximum number of points per curve to 9,999. If a curve contains more
#' data the curve data got binned using the smallest possible bin width.
#'
#' @param txtProgressBar [logical] (*with default*):
#' enables or disables [txtProgressBar].
#'
#' @return Write a binary file.
#'
#' @note
#' The function just roughly checks the data structures. The validity of
#' the output data depends on the user.
#'
#' The validity of the file path is not further checked. BIN-file conversions
#' using the argument `version` may be a lossy conversion, depending on the
#' chosen input and output data (e.g., conversion from version 08 to 07 to 06 to 05 to 04 or 03).
#'
#' **Warning**
#'
#' Although the coding was done carefully it seems that the BIN/BINX-files
#' produced by Risø DA 15/20 TL/OSL readers slightly differ on the byte level.
#' No obvious differences are observed in the METADATA, however, the
#' BIN/BINX-file may not fully compatible, at least not similar to the once
#' directly produced by the Risø readers!
#'
#' @section Function version: 0.5.2
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @note
#' ROI definitions (introduced in BIN-file version 8) are not supported!
#' There are furthermore ignored by the function [read_BIN2R].
#'
#' @seealso [read_BIN2R], [Risoe.BINfileData-class], [writeBin]
#'
#' @references
#' DTU Nutech, 2016. The Sequence Editor, Users Manual, February, 2016.
#' [https://www.fysik.dtu.dk]()
#'
#' @keywords IO
#'
#' @examples
#' ##load exampled dataset
#' file <- system.file("extdata/BINfile_V8.binx", package = "Luminescence")
#' temp <- read_BIN2R(file)
#'
#' ##create temporary file path
#' ##(for usage replace by own path)
#' temp_file <- tempfile(pattern = "output", fileext = ".binx")
#'
#' ##export to temporary file path
#' write_R2BIN(temp, file = temp_file)
#'
#' @md
#' @export
write_R2BIN <- function(
  object,
  file,
  version,
  compatibility.mode = FALSE,
  txtProgressBar = TRUE
){

  # Config ------------------------------------------------------------------

  ##set supported BIN format version
  VERSION.supported <- as.raw(c(3, 4, 5, 6, 7, 8))

  # Check integrity ---------------------------------------------------------

  ##check if input object is of type 'Risoe.BINfileData'
  if(is(object, "Risoe.BINfileData") == FALSE){
    stop("[write_R2BIN()] Input object is not of type Risoe.BINfileData!", call. = FALSE)

  }

  ##check if it fulfils the latest definition ...
  if(ncol(object@METADATA) != ncol(set_Risoe.BINfileData()@METADATA)){
    stop("[write_R2BIN()] The number of columns in your slot 'METADATA' does not fit to the latest definition. What you are probably trying to do is to export a Risoe.BINfileData object you generated by your own or you imported with an old package version some time ago. Please re-import the BIN-file using the function read_BIN2R().", call. = FALSE)

  }

  ##check if input file is of type 'character'
  if(is(file, "character") == FALSE){
    stop("[write_R2BIN()] argument 'file' has to be of type character!", call. = FALSE)

  }

  # Check Risoe.BINfileData Struture ----------------------------------------
  ##check wether the BIN-file DATA slot contains more than 9999 records; needs to be run all the time
  temp_check <- vapply(object@DATA, function(x){
    if(length(x) > 9999){
      TRUE
    }else{
      FALSE
    }

  }, FUN.VALUE = logical(1))

  ##force compatibility
  if(compatibility.mode && any(temp_check)){

    ##drop warning
    warning("[write_R2BIN()] Compatibility mode selected: Some data sets are longer than 9,999 points and will be binned!", call. = FALSE)

    ##BIN data to reduce amount of data if the BIN-file is too long
    object@DATA <- lapply(object@DATA, function(x){
      if(length(x) > 9999){
        ##we want to have a minimum binning (smallest number possible)
        bin_width <- ceiling(length(x)/9999)

        ##it should be symatric, thus, remove values
        if((length(x)/bin_width)%%2 != 0){
          x <- x[-length(x)]

        }

        ##create matrix and return
        colSums(matrix(x, nrow = bin_width))

      }else{
        x

      }

    })

    ##reset temp_check
    temp_check <- FALSE

    ##get new number of points
    temp_NPOINTS <- sapply(object@DATA, length)

    ##correct LENGTH
    object@METADATA[["LENGTH"]] <- object@METADATA[["LENGTH"]] - (4 * object@METADATA[["NPOINTS"]]) + (temp_NPOINTS * 4)

    ##correct PREVIOUS
    object@METADATA[["PREVIOUS"]] <- c(0,object@METADATA[["LENGTH"]][2:length(object@METADATA[["LENGTH"]])])

    ##correct NPOINTS
    object@METADATA[["NPOINTS"]] <- temp_NPOINTS

    ##write comment
    object@METADATA[["COMMENT"]] <- paste(object@METADATA[["COMMENT"]], " - binned")

  }

  if(any(temp_check))
    stop(paste("[write_R2BIN()]", length(which(temp_check)), " out of ",length(temp_check), "records contain more than 9,999 data points. This violates the BIN/BINX-file definition!"), call. = FALSE)

  ##remove
  rm(temp_check)


  ##VERSION

  ##If missing version argument set to the highest value
  if(missing(version)){

    version <- as.raw(max(as.numeric(object@METADATA[,"VERSION"])))
    version.original <- version


  }else{

    version.original <- as.raw(max(as.numeric(object@METADATA[,"VERSION"])))
    version <- as.raw(version)
    object@METADATA[["VERSION"]] <- version

    ##Furthermore, entries length needed to be recalculated
    if(version.original != version){
      ##stepping decision
      header.stepping <- switch(
        EXPR = as.character(version),
        "08" = 507,
        "07" = 447,
        "06" = 447,
        "05" = 423,
        "04" = 272,
        "03" = 272)

      object@METADATA[,"LENGTH"] <- vapply(1:nrow(object@METADATA), function(x){
        header.stepping + 4 * object@METADATA[x,"NPOINTS"]

      }, numeric(1))

      object@METADATA[,"PREVIOUS"] <- vapply(1:nrow(object@METADATA), function(x){
        if(x == 1) 0 else header.stepping + 4 * object@METADATA[x-1,"NPOINTS"]

      }, numeric(1))

    }

  }

  ##check whether this file can be exported without problems due to the latest specifications
  if(ncol(object@METADATA) != 80){
    stop("[write_R2BIN()] Your Risoe.BINfileData object seems not to be compatible with the latest specification of this S4-class object. You are probably trying to export a Risoe.BINfileData from your workspace you produced manually or with an old version.", call. = FALSE)

  }

  ##Check if the BINfile object contains of unsupported versions
  if((as.raw(object@METADATA[1,"VERSION"]) %in% VERSION.supported) == FALSE ||
       version %in% VERSION.supported == FALSE){

    ##show error message
    error.text <- paste("[write_R2BIN()] Writing BIN-files in format version (",
                        object@METADATA[1,"VERSION"],") is currently not supported!
                        Supported version numbers are: ",
                        paste(VERSION.supported,collapse=", "),".",sep="")
    stop(error.text)
  }

  ##CHECK file name for version == 06 it has to be *.binx and correct for it
  if(version == 05 | version == 06 | version == 07 | version == 08){
    ##grep file ending
    temp.file.name <- unlist(strsplit(file, "[:.:]"))

    ##*.bin? >> correct to binx
    if(temp.file.name[length(temp.file.name)]=="bin"){
      temp.file.name[length(temp.file.name)] <- "binx"
      file <- paste(temp.file.name, collapse=".")

    }
  }


  ##SEQUENCE
  if (suppressWarnings(max(nchar(as.character(object@METADATA[,"SEQUENCE"]), type =
                                 "bytes"), na.rm = TRUE)) > 8) {
    stop("[write_R2BIN()] Value in 'SEQUENCE' exceed storage limit!")

  }

  ##USER
  if (suppressWarnings(max(nchar(as.character(object@METADATA[,"USER"]), type =
                                 "bytes"), na.rm = TRUE)) > 8) {
    stop("[write_R2BIN()] 'USER' exceed storage limit!")

  }

  ##SAMPLE
  if (suppressWarnings(max(nchar(as.character(object@METADATA[,"SAMPLE"]), type =
                                 "bytes"), na.rm = TRUE)) > 20) {
    stop("[write_R2BIN()] 'SAMPLE' exceed storage limit!")

  }

  ##enables compatibility to the Analyst as the the max value for POSITION becomes 48
  if(compatibility.mode){
    ##just do if position values > 48
    if(max(object@METADATA[,"POSITION"])>48){

      ##grep relevant IDs
      temp.POSITION48.id <- which(object@METADATA[,"POSITION"]>48)

      ##find unique values
      temp.POSITION48.unique <- unique(object@METADATA[temp.POSITION48.id,"POSITION"])

      ##set translation vector starting from 1 and ending at 48
      temp.POSITION48.new <- rep_len(1:48, length.out = length(temp.POSITION48.unique))

      ##recaluate POSITION and update comment
      for(i in 1:length(temp.POSITION48.unique)){

        object@METADATA[object@METADATA[,"POSITION"] == temp.POSITION48.unique[i],"COMMENT"] <-
          paste0(object@METADATA[object@METADATA[,"POSITION"] == temp.POSITION48.unique[i],"COMMENT"],
                 "OP:",object@METADATA[object@METADATA[,"POSITION"] == temp.POSITION48.unique[i],"POSITION"])

        object@METADATA[object@METADATA[,"POSITION"] == temp.POSITION48.unique[i],"POSITION"] <-
          temp.POSITION48.new[i]

      }

    }

  }

  ##COMMENT
  if(max(nchar(as.character(object@METADATA[,"COMMENT"]), type="bytes"))>80){
    stop("[write_R2BIN()] 'COMMENT' exceeds storage limit!", call. = FALSE)

  }

  # Translation Matrices -----------------------------------------------------
  ##LTYPE
  LTYPE.TranslationMatrix <- matrix(NA, nrow=14, ncol=2)
  LTYPE.TranslationMatrix[,1] <- 0:13
  LTYPE.TranslationMatrix[,2] <- c(
    "TL", "OSL", "IRSL", "M-IR", "M-VIS", "TOL", "TRPOSL", "RIR", "RBR",
    "USER", "POSL", "SGOSL", "RL", "XRF")

  ##DTYPE
  DTYPE.TranslationMatrix <- matrix(NA, nrow=8, ncol=2)
  DTYPE.TranslationMatrix[,1] <- 0:7
  DTYPE.TranslationMatrix[,2] <- c("Natural","N+dose","Bleach",
                                   "Bleach+dose","Natural (Bleach)",
                                   "N+dose (Bleach)","Dose","Background")

  ##LIGHTSOURCE
  LIGHTSOURCE.TranslationMatrix <- matrix(NA, nrow=8, ncol=2)
  LIGHTSOURCE.TranslationMatrix[,1] <- 0:7
  LIGHTSOURCE.TranslationMatrix[,2] <- c(
    "None", "Lamp", "IR diodes/IR Laser", "Calibration LED", "Blue Diodes",
    "White light", "Green laser (single grain)", "IR laser (single grain)"
  )

  ##TRANSLATE VALUES IN METADATA
  ##LTYPE
  if(is(object@METADATA[1,"LTYPE"], "character") == TRUE |
       is(object@METADATA[1,"LTYPE"], "factor") == TRUE){

    object@METADATA[,"LTYPE"]<- sapply(1:length(object@METADATA[,"LTYPE"]),function(x){
      as.integer(LTYPE.TranslationMatrix[object@METADATA[x,"LTYPE"]==LTYPE.TranslationMatrix[,2],1])

    })
  }

  ##DTYPE
  if(is(object@METADATA[1,"DTYPE"], "character") == TRUE |
       is(object@METADATA[1,"DTYPE"], "factor") == TRUE){
    object@METADATA[,"DTYPE"]<- sapply(1:length(object@METADATA[,"DTYPE"]),function(x){

      as.integer(DTYPE.TranslationMatrix[object@METADATA[x,"DTYPE"]==DTYPE.TranslationMatrix[,2],1])

    })
  }

  ##LIGHTSOURCE
  if(is(object@METADATA[1,"LIGHTSOURCE"], "character") == TRUE |
       is(object@METADATA[1,"LIGHTSOURCE"], "factor") == TRUE){

    object@METADATA[,"LIGHTSOURCE"]<- sapply(1:length(object@METADATA[,"LIGHTSOURCE"]),function(x){

      as.integer(LIGHTSOURCE.TranslationMatrix[
        object@METADATA[x,"LIGHTSOURCE"]==LIGHTSOURCE.TranslationMatrix[,2],1])

    })}

  ##TIME
  object@METADATA[,"TIME"] <- vapply(1:length(object@METADATA[["TIME"]]),function(x){
    if(is.na(object@METADATA[["TIME"]][x])){
      "000000"

    }else{
      as.character(gsub(":","",object@METADATA[["TIME"]][x]))

    }

  }, character(1))

  ##TAG and SEL
  ##in TAG information on the SEL are storred, here the values are copied to TAG
  ##before export
  object@METADATA[,"TAG"] <- ifelse(object@METADATA[,"SEL"] == TRUE, 1, 0)

  # SET FILE AND VALUES -----------------------------------------------------
  con<-file(file, "wb")

  ##get records
  n.records <- length(object@METADATA[,"ID"])

  ##output
  message(paste0("[write_R2BIN()]\n\t >> ",file))

  ##set progressbar
  if(txtProgressBar)
    pb <- txtProgressBar(min=0,max=n.records, char="=", style=3)

  # LOOP -------------------------------------------------------------------
  ID <- 1
  if(version == 03 || version == 04){
    ## version 03 and 04
    ##start loop for export BIN data
    while(ID<=n.records) {

      ##VERSION
      writeBin(as.raw(object@METADATA[ID,"VERSION"]),
               con,
               size = 1,
               endian="little")

      ##stepping
      writeBin(raw(length=1),
               con,
               size = 1,
               endian="little")


      ##LENGTH, PREVIOUS, NPOINTS
      writeBin(c(as.integer(object@METADATA[ID,"LENGTH"]),
                 as.integer(object@METADATA[ID,"PREVIOUS"]),
                 as.integer(object@METADATA[ID,"NPOINTS"])),
               con,
               size = 2,
               endian="little")

      ##LTYPE
      writeBin(object@METADATA[ID,"LTYPE"],
               con,
               size = 1,
               endian="little")

      ##LOW, HIGH, RATE
      writeBin(c(as.double(object@METADATA[ID,"LOW"]),
                 as.double(object@METADATA[ID,"HIGH"]),
                 as.double(object@METADATA[ID,"RATE"])),
               con,
               size = 4,
               endian="little")

      ##TEMPERATURE, XCOORD, YCOORD, TOLDELAY; TOLON, TOLOFF
      writeBin(c(as.integer(object@METADATA[ID,"TEMPERATURE"]),
                 as.integer(object@METADATA[ID,"XCOORD"]),
                 as.integer(object@METADATA[ID,"YCOORD"]),
                 as.integer(object@METADATA[ID,"TOLDELAY"]),
                 as.integer(object@METADATA[ID,"TOLON"]),
                 as.integer(object@METADATA[ID,"TOLOFF"])),
               con,
               size = 2,
               endian="little")

      ##POSITION, RUN
      writeBin(c(as.integer(object@METADATA[ID,"POSITION"]),
                 as.integer(object@METADATA[ID,"RUN"])),
               con,
               size = 1,
               endian="little")

      ##TIME
      TIME_SIZE <- nchar(object@METADATA[ID,"TIME"])
      writeBin(as.integer(TIME_SIZE),
               con,
               size = 1,
               endian="little")

      writeChar(object@METADATA[ID,"TIME"],
                con,
                nchars =TIME_SIZE,
                useBytes=TRUE,
                eos = NULL)

      if(6-TIME_SIZE>0){
        writeBin(raw(length = c(6-TIME_SIZE)),
                 con,
                 size = 1,
                 endian="little")

      }

      ##DATE
      writeBin(as.integer(6),
               con,
               size = 1 ,
               endian="little")

      suppressWarnings(writeChar(as.character(object@METADATA[ID,"DATE"]),
                                 con,
                                 nchars = 6,
                                 useBytes=TRUE,
                                 eos = NULL))

      ##SEQUENCE
      ##count number of characters
      SEQUENCE_SIZE <- as.integer(
        nchar(as.character(object@METADATA[["SEQUENCE"]][ID]), type = "bytes", keepNA = FALSE))

      writeBin(SEQUENCE_SIZE,
               con,
               size = 1,
               endian="little")

      writeChar(as.character(object@METADATA[ID,"SEQUENCE"]),
                con,
                nchars = SEQUENCE_SIZE,
                useBytes=TRUE,
                eos = NULL)

      ##stepping
      if(8-SEQUENCE_SIZE>0){
        writeBin(raw(length = (8-SEQUENCE_SIZE)),
                 con,
                 size = 1,
                 endian="little")
      }

      ##USER
      USER_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"USER"]), type="bytes"))

      writeBin(USER_SIZE,
               con,
               size = 1,
               endian="little")

      writeChar(as.character(object@METADATA[ID,"USER"]),
                con,
                nchars = USER_SIZE,
                useBytes=TRUE,
                eos = NULL)

      ##stepping
      if(8-USER_SIZE>0){
        writeBin(raw(length = (8-USER_SIZE)),
                 con,
                 size = 1,
                 endian="little")
      }

      ##DTYPE
      writeBin(object@METADATA[ID,"DTYPE"],
               con,
               size = 1,
               endian="little")

      ##IRR_TIME
      writeBin(as.double(object@METADATA[ID,"IRR_TIME"]),
               con,
               size = 4,
               endian="little")


      ##IRR_TYPE, IRR_UNIT
      writeBin(c(object@METADATA[ID,"IRR_TYPE"],
                 object@METADATA[ID,"IRR_UNIT"]),
               con,
               size = 1,
               endian="little")


      ##BL_TIME
      writeBin(as.double(object@METADATA[ID,"BL_TIME"]),
               con,
               size = 4,
               endian="little")

      ##BL_UNIT
      writeBin(as.integer(object@METADATA[ID,"BL_UNIT"]),
               con,
               size = 1,
               endian="little")

      ##AN_TEMP, AN_TIME, NORM1, NORM2, NORM2, BG
      writeBin(c(as.double(object@METADATA[ID,"AN_TEMP"]),
                 as.double(object@METADATA[ID,"AN_TIME"]),
                 as.double(object@METADATA[ID,"NORM1"]),
                 as.double(object@METADATA[ID,"NORM2"]),
                 as.double(object@METADATA[ID,"NORM3"]),
                 as.double(object@METADATA[ID,"BG"])),
               con,
               size = 4,
               endian="little")

      ##SHIFT
      writeBin(as.integer(object@METADATA[ID,"SHIFT"]),
               con,
               size = 2,
               endian="little")

      ##SAMPLE
      SAMPLE_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"SAMPLE"]), type="bytes"))

      ##avoid problems with empty sample names
      if(SAMPLE_SIZE == 0){

        SAMPLE_SIZE <- as.integer(2)
        object@METADATA[ID,"SAMPLE"] <- "  "

      }

      writeBin(SAMPLE_SIZE,
               con,
               size = 1,
               endian="little")

      writeChar(as.character(object@METADATA[ID,"SAMPLE"]),
                con,
                nchars = SAMPLE_SIZE,
                useBytes=TRUE,
                eos = NULL)

      if((20-SAMPLE_SIZE)>0){
        writeBin(raw(length = (20-SAMPLE_SIZE)),
                 con,
                 size = 1,
                 endian="little")
      }

      ##COMMENT
      COMMENT_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"COMMENT"]), type="bytes"))

      ##avoid problems with empty comments
      if(COMMENT_SIZE == 0){
        COMMENT_SIZE <- as.integer(2)
        object@METADATA[ID,"COMMENT"] <- "  "

      }

      writeBin(COMMENT_SIZE,
               con,
               size = 1,
               endian="little")

      suppressWarnings(writeChar(as.character(object@METADATA[ID,"COMMENT"]),
                                 con,
                                 nchars = COMMENT_SIZE,
                                 useBytes=TRUE,
                                 eos = NULL))


      if((80-COMMENT_SIZE)>0){
        writeBin(raw(length = c(80-COMMENT_SIZE)),
                 con,
                 size = 1,
                 endian="little")

      }

      ##LIGHTSOURCE, SET, TAG
      writeBin(c(as.integer(object@METADATA[ID,"LIGHTSOURCE"]),
                 as.integer(object@METADATA[ID,"SET"]),
                 as.integer(object@METADATA[ID,"TAG"])),
               con,
               size = 1,
               endian="little")

      ##GRAIN
      writeBin(as.integer(object@METADATA[ID,"GRAIN"]),
               con,
               size = 2,
               endian="little")

      ##LPOWER
      writeBin(as.double(object@METADATA[ID,"LPOWER"]),
               con,
               size = 4,
               endian="little")

      ##SYSTEMID
      writeBin(as.integer(object@METADATA[ID,"SYSTEMID"]),
               con,
               size = 2,
               endian="little")

      ##Further distinction needed to fully support format version 03 and 04 separately
      if(version == 03){
        ##RESERVED 1
        if(length(object@.RESERVED) == 0 || version.original != version){
          writeBin(raw(length=36),
                   con,
                   size = 1,
                   endian="little")
        }else{
          writeBin(object = object@.RESERVED[[ID]][[1]],
                   con,
                   size = 1,
                   endian="little")

        }

        ##ONTIME, OFFTIME
        writeBin(c(as.integer(object@METADATA[ID,"ONTIME"]),
                   as.integer(object@METADATA[ID,"OFFTIME"])),
                 con,
                 size = 4,
                 endian="little")

        ##GATE_ENABLED
        writeBin(as.integer(object@METADATA[ID,"GATE_ENABLED"]),
                 con,
                 size = 1,
                 endian="little")


        ##GATE_START, GATE_STOP
        writeBin(c(as.integer(object@METADATA[ID,"GATE_START"]),
                   as.integer(object@METADATA[ID,"GATE_STOP"])),
                 con,
                 size = 4,
                 endian="little")


        ##RESERVED 2
        if(length(object@.RESERVED) == 0 || version.original != version){
          writeBin(raw(length=1),
                   con,
                   size = 1,
                   endian="little")

        }else{
          writeBin(object@.RESERVED[[ID]][[2]],
                   con,
                   size = 1,
                   endian="little")

        }

      } else {
        ##version 04
        ##RESERVED 1
        if(length(object@.RESERVED) == 0 || version.original != version){
          writeBin(raw(length=20),
                   con,
                   size = 1,
                   endian="little")
        } else{
          writeBin(object@.RESERVED[[ID]][[1]],
                   con,
                   size = 1,
                   endian="little")

        }

        ##CURVENO
        writeBin(as.integer(object@METADATA[ID,"CURVENO"]),
                 con,
                 size = 2,
                 endian="little")

        ##TIMETICK
        writeBin(c(as.double(object@METADATA[ID,"TIMETICK"])),
                 con,
                 size = 4,
                 endian="little")

        ##ONTIME, STIMPERIOD
        writeBin(c(as.integer(object@METADATA[ID,"ONTIME"]),
                   as.integer(object@METADATA[ID,"STIMPERIOD"])),
                 con,
                 size = 4,
                 endian="little")

        ##GATE_ENABLED
        writeBin(as.integer(object@METADATA[ID,"GATE_ENABLED"]),
                 con,
                 size = 1,
                 endian="little")


        ##GATE_START, GATE_STOP
        writeBin(c(as.integer(object@METADATA[ID,"GATE_START"]),
                   as.integer(object@METADATA[ID,"GATE_STOP"])),
                 con,
                 size = 4,
                 endian="little")


        ##PTENABLED
        writeBin(as.integer(object@METADATA[ID,"PTENABLED"]),
                 con,
                 size = 1,
                 endian="little")


        ##RESERVED 2
        if(length(object@.RESERVED) == 0 || version.original != version){
          writeBin(raw(length=10),
                   con,
                   size = 1,
                   endian="little")

        } else {
          writeBin(object@.RESERVED[[ID]][[2]],
                   con,
                   size = 1,
                   endian="little")

        }
      }
      ##DPOINTS
      writeBin(as.integer(unlist(object@DATA[ID])),
               con,
               size = 4,
               endian="little")

      #SET UNIQUE ID
      ID <- ID + 1
      ##update progress bar
      if(txtProgressBar) setTxtProgressBar(pb, ID)

    }
  }
  ## ====================================================
  ## version > 06
  if(version == 05 | version == 06 | version == 07 | version == 08){
    ##start loop for export BIN data
    while(ID<=n.records) {
      ##VERSION
      writeBin(as.raw(object@METADATA[ID,"VERSION"]),
               con,
               size = 1,
               endian="little")

      ##stepping
      writeBin(raw(length=1),
               con,
               size = 1,
               endian="little")

      ##LENGTH, PREVIOUS, NPOINTS
      writeBin(c(as.integer(object@METADATA[ID,"LENGTH"]),
                 as.integer(object@METADATA[ID,"PREVIOUS"]),
                 as.integer(object@METADATA[ID,"NPOINTS"])),
               con,
               size = 4,
               endian="little")

      if(version == 08){
        writeBin(as.integer(object@METADATA[ID,"RECTYPE"]),
                 con,
                 size = 1,
                 endian="little")
      }

      ##RUN, SET, POSITION, GRAINNUMBER, CURVENO, XCOORD, YCOORD
      writeBin(c(as.integer(object@METADATA[ID,"RUN"]),
                 as.integer(object@METADATA[ID,"SET"]),
                 as.integer(object@METADATA[ID,"POSITION"]),
                 as.integer(object@METADATA[ID,"GRAINNUMBER"]),
                 as.integer(object@METADATA[ID,"CURVENO"]),
                 as.integer(object@METADATA[ID,"XCOORD"]),
                 as.integer(object@METADATA[ID,"YCOORD"])),
               con,
               size = 2,
               endian="little")

      ##SAMPLE
      SAMPLE_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"SAMPLE"]), type="bytes"))

      ##avoid problems with empty sample names
      if(SAMPLE_SIZE == 0){

        SAMPLE_SIZE <- as.integer(2)
        object@METADATA[ID,"SAMPLE"] <- "  "

      }

      writeBin(SAMPLE_SIZE,
               con,
               size = 1,
               endian="little")


      writeChar(as.character(object@METADATA[ID,"SAMPLE"]),
                con,
                nchars = SAMPLE_SIZE,
                useBytes=TRUE,
                eos = NULL)

      if((20-SAMPLE_SIZE)>0){
        writeBin(raw(length = (20-SAMPLE_SIZE)),
                 con,
                 size = 1,
                 endian="little")
      }

      ##COMMENT
      COMMENT_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"COMMENT"]), type="bytes"))

      ##avoid problems with empty comments
      if(COMMENT_SIZE == 0){

        COMMENT_SIZE <- as.integer(2)
        object@METADATA[ID,"COMMENT"] <- "  "

      }

      writeBin(COMMENT_SIZE,
               con,
               size = 1,
               endian="little")

      writeChar(as.character(object@METADATA[ID,"COMMENT"]),
                con,
                nchars = COMMENT_SIZE,
                useBytes=TRUE,
                eos = NULL)

      if((80-COMMENT_SIZE)>0){
        writeBin(raw(length = c(80-COMMENT_SIZE)),
                 con,
                 size = 1,
                 endian="little")

      }

      ##Instrument and sequence characteristics
      ##SYSTEMID
      writeBin(as.integer(object@METADATA[ID,"SYSTEMID"]),
               con,
               size = 2,
               endian="little")

      ##FNAME
      FNAME_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"FNAME"]), type="bytes"))

        ##correct for case that this is of 0 length
        if(length(FNAME_SIZE) == 0){FNAME_SIZE <- as.integer(0)}

      writeBin(FNAME_SIZE,
               con,
               size = 1,
               endian="little")

      if(FNAME_SIZE>0) {
        writeChar(
          as.character(object@METADATA[ID,"FNAME"]),
          con,
          nchars = FNAME_SIZE,
          useBytes = TRUE,
          eos = NULL
        )
      }

      if((100-FNAME_SIZE)>0){
        writeBin(raw(length = c(100-FNAME_SIZE)),
                 con,
                 size = 1,
                 endian="little")

      }

      ##USER
      USER_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"USER"]), type="bytes"))

      writeBin(USER_SIZE,
               con,
               size = 1,
               endian="little")

      writeChar(as.character(object@METADATA[ID,"USER"]),
                con,
                nchars = USER_SIZE,
                useBytes=TRUE,
                eos = NULL)


      if((30-USER_SIZE)>0){
        writeBin(raw(length = c(30-USER_SIZE)),
                 con,
                 size = 1,
                 endian="little")

      }

      ##TIME
      TIME_SIZE <- nchar(object@METADATA[ID,"TIME"])

      writeBin(as.integer(TIME_SIZE),
               con,
               size = 1,
               endian="little")

      writeChar(object@METADATA[ID,"TIME"],
                con,
                nchars =TIME_SIZE,
                useBytes=TRUE,
                eos = NULL)

      if(6-TIME_SIZE>0){
        writeBin(raw(length = c(6-TIME_SIZE)),
                 con,
                 size = 1,
                 endian="little")

      }

      ##DATE
      writeBin(as.integer(6),
               con,
               size = 1 ,
               endian="little")


      suppressWarnings(writeChar(as.character(object@METADATA[ID,"DATE"]),
                                 con,
                                 nchars = 6,
                                 useBytes=TRUE,
                                 eos = NULL))

      ##Analysis
      ##DTYPE
      writeBin(object@METADATA[ID,"DTYPE"],
               con,
               size = 1,
               endian="little")


      ##BL_TIME
      writeBin(as.double(object@METADATA[ID,"BL_TIME"]),
               con,
               size = 4,
               endian="little")

      ##BL_UNIT
      writeBin(as.integer(object@METADATA[ID,"BL_UNIT"]),
               con,
               size = 1,
               endian="little")

      ##NORM1, NORM2, NORM3, BG
      writeBin(c(as.double(object@METADATA[ID,"NORM1"]),
                 as.double(object@METADATA[ID,"NORM2"]),
                 as.double(object@METADATA[ID,"NORM3"]),
                 as.double(object@METADATA[ID,"BG"])),
               con,
               size = 4,
               endian="little")

      ##SHIFT
      writeBin(as.integer(object@METADATA[ID,"SHIFT"]),
               con,
               size = 2,
               endian="little")

      ##TAG
      writeBin(c(as.integer(object@METADATA[ID,"TAG"])),
               con,
               size = 1,
               endian="little")

      ##RESERVED 1
      if(length(object@.RESERVED) == 0 || version.original != version){
        writeBin(raw(length=20),
                 con,
                 size = 1,
                 endian="little")
      }else{

        writeBin(object@.RESERVED[[ID]][[1]],
                 con,
                 size = 1,
                 endian="little")

      }

      ##Measurement characteristics
      ##LTYPE
      writeBin(object@METADATA[ID,"LTYPE"],
               con,
               size = 1,
               endian="little")


      ##LIGHTSOURCE
      writeBin(c(as.integer(object@METADATA[ID,"LIGHTSOURCE"])),
               con,
               size = 1,
               endian="little")

      ##LIGHTPOWER, LOW, HIGH, RATE
      writeBin(c(as.double(object@METADATA[ID,"LIGHTPOWER"]),
                 as.double(object@METADATA[ID,"LOW"]),
                 as.double(object@METADATA[ID,"HIGH"]),
                 as.double(object@METADATA[ID,"RATE"])),
               con,
               size = 4,
               endian="little")

      ##TEMPERATURE, MEASTEMP
      writeBin(c(as.integer(object@METADATA[ID,"TEMPERATURE"]),
                 as.integer(object@METADATA[ID,"MEASTEMP"])),
               con,
               size = 2,
               endian="little")

      ##AN_TEMP, AN_TIME
      writeBin(c(as.double(object@METADATA[ID,"AN_TEMP"]),
                 as.double(object@METADATA[ID,"AN_TIME"])),
               con,
               size = 4,
               endian="little")

      ##TOLDELAY; TOLON, TOLOFF
      writeBin(c(as.integer(object@METADATA[ID,"TOLDELAY"]),
                 as.integer(object@METADATA[ID,"TOLON"]),
                 as.integer(object@METADATA[ID,"TOLOFF"])),
               con,
               size = 2,
               endian="little")

      ##IRR_TIME
      writeBin(as.double(object@METADATA[ID,"IRR_TIME"]),
               con,
               size = 4,
               endian="little")


      ##IRR_TYPE
      writeBin(c(object@METADATA[ID,"IRR_TYPE"]),
               con,
               size = 1,
               endian="little")

      ##IRR_DOSERATE, IRR_DOSERATEERR
      if(version == 05){
        writeBin(as.double(object@METADATA[ID,"IRR_DOSERATE"]),
                 con,
                 size = 4,
                 endian="little")

      }else{
        writeBin(c(as.double(object@METADATA[ID,"IRR_DOSERATE"]),
                   as.double(object@METADATA[ID,"IRR_DOSERATEERR"])),
                 con,
                 size = 4,
                 endian="little")

      }

      ##TIMESINCEIRR
      writeBin(c(as.integer(object@METADATA[ID,"TIMESINCEIRR"])),
               con,
               size = 4,
               endian="little")

      ##TIMETICK
      writeBin(c(as.double(object@METADATA[ID,"TIMETICK"])),
               con,
               size = 4,
               endian="little")

      ##ONTIME, STIMPERIOD
      writeBin(c(suppressWarnings(as.integer(object@METADATA[ID,"ONTIME"])),
                 as.integer(object@METADATA[ID,"STIMPERIOD"])),
               con,
               size = 4,
               endian="little")

      ##GATE_ENABLED
      writeBin(as.integer(object@METADATA[ID,"GATE_ENABLED"]),
               con,
               size = 1,
               endian="little")

      ##GATE_START, GATE_STOP
      writeBin(c(as.integer(object@METADATA[ID,"GATE_START"]),
                 as.integer(object@METADATA[ID,"GATE_STOP"])),
               con,
               size = 4,
               endian="little")

      ##PTENABLED, DTENABLED
      writeBin(c(as.integer(object@METADATA[ID,"PTENABLED"]),
                 as.integer(object@METADATA[ID,"DTENABLED"])),
               con,
               size = 1,
               endian="little")

      ##DEADTIME, MAXLPOWER, XRF_ACQTIME, XRF_HV
      writeBin(c(as.double(object@METADATA[ID,"DEADTIME"]),
                 as.double(object@METADATA[ID,"MAXLPOWER"]),
                 as.double(object@METADATA[ID,"XRF_ACQTIME"]),
                 as.double(object@METADATA[ID,"XRF_HV"])),
               con,
               size = 4,
               endian="little")

      ##XRF_CURR
      writeBin(c(as.integer(object@METADATA[ID,"XRF_CURR"])),
               con,
               size = 4,
               endian="little")

      ##XRF_DEADTIMEF
      writeBin(c(as.double(object@METADATA[ID,"XRF_DEADTIMEF"])),
               con,
               size = 4,
               endian="little")


      ##add version support for V7
      if(version == 05){
        ##RESERVED 2
        if(length(object@.RESERVED) == 0 || version.original != version){
          writeBin(raw(length=4),
                   con,
                   size = 1,
                   endian="little")
        }else{
          writeBin(object@.RESERVED[[ID]][[2]],
                   con,
                   size = 1,
                   endian="little")
        }

      }else if(version == 06){

        ##RESERVED 2
        if(length(object@.RESERVED) == 0 || version.original != version){
          writeBin(raw(length=24),
                   con,
                   size = 1,
                   endian="little")
        }else{
          writeBin(object@.RESERVED[[ID]][[2]],
                   con,
                   size = 1,
                   endian="little")
        }

      }else{

        ##DETECTOR_ID
        writeBin(as.integer(object@METADATA[ID,"DETECTOR_ID"]),
                 con,
                 size = 1,
                 endian="little")

        ##LOWERFILTER_ID, UPPERFILTER_ID
        writeBin(c(as.integer(object@METADATA[ID,"LOWERFILTER_ID"]),
                   as.integer(object@METADATA[ID,"UPPERFILTER_ID"])),
                 con,
                 size = 2,
                 endian="little")


        ##ENOISEFACTOR
        writeBin(as.double(object@METADATA[ID,"ENOISEFACTOR"]),
                 con,
                 size = 4,
                 endian="little")


        ##VERSION 08
        if(version == 07){

          ##RESERVED 2
          if(length(object@.RESERVED) == 0 || version.original != version){
            writeBin(raw(length=15),
                     con,
                     size = 1,
                     endian="little")
          }else{

            writeBin(object@.RESERVED[[ID]][[2]],
                     con,
                     size = 1,
                     endian="little")
          }


        }else{

          ##MARKPOS POSITION and extraction
          writeBin(
            c(
              as.double(object@METADATA[ID, "MARKPOS_X1"]),
              as.double(object@METADATA[ID, "MARKPOS_Y1"]),
              as.double(object@METADATA[ID, "MARKPOS_X2"]),
              as.double(object@METADATA[ID, "MARKPOS_Y2"]),
              as.double(object@METADATA[ID, "MARKPOS_X3"]),
              as.double(object@METADATA[ID, "MARKPOS_Y3"]),
              as.double(object@METADATA[ID, "EXTR_START"]),
              as.double(object@METADATA[ID, "EXTR_END"])
            ),
            con,
            size = 4,
            endian = "little"
          )

          ##RESERVED 2
          if(length(object@.RESERVED) == 0 || version.original != version){
            writeBin(raw(length=42),
                     con,
                     size = 1,
                     endian="little")
          }else{

            writeBin(object@.RESERVED[[ID]][[2]],
                     con,
                     size = 1,
                     endian="little")
          }
        }

      }#end if version decision
      ##DPOINTS
      writeBin(as.integer(unlist(object@DATA[ID])),
               con,
               size = 4,
               endian="little")

      #SET UNIQUE ID
      ID <- ID + 1

      ##update progress bar
      if(txtProgressBar)  setTxtProgressBar(pb, ID)

    }
  }

  # ##close con
  close(con)
  #
  # ##close
  if(txtProgressBar) close(pb)

  ##output
  message(paste0("\t >> ",ID-1,"records have been written successfully!\n\n"))

}