R/writeCcg.R

In HenrikBengtsson/affxparser: Affymetrix File Parsing SDK

.writeCcgFileHeader <- function(con, header, ...) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Local functions
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  writeUByte <- function(con, value, ...) {
    writeBin(as.integer(value), con=con, size=1, endian="big");
  }

  writeInt <- function(con, value, ...) {
    writeBin(as.integer(value), con=con, size=4, endian="big");
  }

  writeUInt <- function(con, value, ...) {
    writeBin(as.integer(value), con=con, size=4, endian="big");
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate 'header':
  if (!is.list(header))
    stop("Argument 'header' must be a list: ", mode(header));
  if (is.null(header$nbrOfDataGroups))
    stop("Missing element 'nbrOfDataGroups' in argument 'header'.");
  if (is.null(header$dataGroupStart))
    stop("Missing element 'dataGroupStart' in argument 'header'.");


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Further validation
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Default version is 1 (one) [1]
  if (is.null(header$version))
    header$version <- as.integer(1);


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Writing
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # The magic for Command Console generic data file format is 59 [1]
  magic <- writeUByte(con, value=59);

  # Write version
  version <- writeUByte(con, value=header$version);

  # Write number of data groups
  nbrOfDataGroups <- writeInt(con, value=header$nbrOfDataGroups);

  # Write file position of first data groups
  dataGroupStart <- writeUInt(con, value=header$nbrOfDataGroups);

  # Return the current file write position
  invisible(seek(con, origin="start", rw="write"));
} # .writeCcgFileHeader()





# Generic Data Header
# This section stores the file and file type identifiers, data to
# describe the contents of the file, parameters on how it was created
# and information about its parentage. This section contains a circular
# dependency so as to traverse across the entire parentage of a file.
# This information will provide the entire history of how a file came
# to be.
#
# The first data header section immediately follows the file header
# section.
#
# Item Type  Description
# 1    GUID  The data type identifier. This is used to identify the type
#            of data stored in the file. For example:
#            * acquisition data (affymetrix-calvin-scan-acquisition)
#            * intensity data (tbd)
#            * expression results (tbd)
#            * genotyping results (tbd)
# 2    GUID  Unique file identifier. This is the identifier to use to
#            link the file with parent files. This identifier will be
#            updated whenever the contents of the file change.
#            Example: When a  user manually aligns the grid in a DAT file
#            the grid coordinates are updated in the DAT file and the file
#            is given a new file identifier.
# 3 DATETIME Date and time of file creation.
# 4   LOCALE The locale of the operating system that the file was created on.
# 5 	   INT The number of name/type/value parameters.
# 6 	 WVT[] Array of parameters stored as name/value/type triplets.
#            WVT[]=(WSTRING/VALUE/TYPE)[]
# 7 	   INT Number of parent file headers.
# 8 	 GDH[] Array of parent file headers. GDH[]=GenericDataHeader[]
.writeCcgDataHeader <- function(con, header, ...) {
  # To please R CMD check
  charToInt <- NULL; rm(list="charToInt");

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Local functions
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  writeUByte <- function(con, value, ...) {
    writeBin(as.integer(value), con=con, size=1, endian="big");
  }

  writeInt <- function(con, value, ...) {
    writeBin(as.integer(value), con=con, size=4, endian="big");
  }

  writeUInt <- function(con, value, ...) {
    writeBin(as.integer(value), con=con, size=4, endian="big");
  }

  writeString <- function(con, str, ...) {
    # A 1 byte character string. A string object is stored as an INT
    # (to store the string length) followed by the CHAR array (to store
    # the string contents).
    str <- as.character(str);
    nchars <- as.integer(nchar(str));
    writeInt(con, value=nchars);
    writeChar(str, con=con, nchars=nchars);
  }

  writeWChar <- function(object, con, nchars=nchar(object,type="chars"), ...) {
    # Tho bytes per character
    str <- as.character(object);

    # Convert to unicode characters
    n <- nchar(str);
    raw <- matrix(raw(2*n), nrow=2, ncol=n);
    bfr <- charToInt(strsplit(str, split="")[[1]]);
    raw[2,] <- as.raw(bfr);
    raw <- as.vector(raw);

    # Write raw buffer
    writeBin(raw, con=con);
  }

  writeWString <- function(con, str, ...) {
    # A UNICODE string. A string object is stored as an INT (to store the
    # string length) followed by the WCHAR array (to store the string
    # contents).
    str <- as.character(str);
    nchars <- as.integer(nchar(str));
    writeInt(con, value=nchars);
    writeWChar(str, con=con, nchars=nchars);
  }

  writeGuid <- function(con, id, ...) {
    writeString(con, str=id, ...);
  }

  writeDateTime <- function(con, timestamp, ...) {
    writeWString(con, str=timestamp, ...);
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate 'header':
  if (!is.list(header))
    stop("Argument 'header' must be a list: ", mode(header));
  if (is.null(header$nbrOfDataGroups))
    stop("Missing element 'nbrOfDataGroups' in argument 'header'.");
  if (is.null(header$dataGroupStart))
    stop("Missing element 'dataGroupStart' in argument 'header'.");


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Further validation
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Default version is 1 (one) [1]
  if (is.null(header$version))
    header$version <- as.integer(1);


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Writing
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Data type identifier
  writeGuid(con, id=header$dataTypeId);

  # Unique file identifier
  writeGuid(con, id=header$fileId);

  # Unique file identifier
  writeDateTime(con, id=header$timestamp);

  # Write version
  version <- writeUByte(con, value=header$version);

  # Write number of data groups
  nbrOfDataGroups <- writeInt(con, value=header$nbrOfDataGroups);

  # Write file position of first data groups
  dataGroupStart <- writeUInt(con, value=header$nbrOfDataGroups);

  # Return the current file write position
  invisible(seek(con, origin="start", rw="write"));
} # .writeCcgDataHeader()


############################################################################
# HISTORY:
# 2012-05-18
# o Now using stop() instead of throw().
# 2007-08-16
# o This file only contains a stub, so there is currently no
#    writeCcgHeader() or writeCcg().
# 2006-11-06
# o Created.
############################################################################