R/initialize.R

In GegznaV/hyperSpec2: Work with Hyperspectral Data, i.e. Spectra + Meta Information (Spatial, Time, Concentration, ...)

###-----------------------------------------------------------------------------
###
###  initialize -- initialization, called by new ("hyperSpec", ...)
###
###  C. Beleites
###

##' @include paste.row.R
##' @noRd
.initialize <- function (.Object, spc = NULL, data = NULL, wavelength = NULL, labels = NULL){

  ## do the small stuff first, so we need not be too careful about copies

  ## the wavelength axis
  if (! is.null (wavelength) && ! is.numeric (wavelength))
    warning ("wavelength is not numeric but ", class (wavelength), ".")

  if (!is.null (spc)){
    if (is.null (dim (spc))){
      nwl <- length (spc)
      if (.options$gc) gc ()
      dim (spc) <- c(1, nwl)
      if (.options$gc) gc ()
    } else {
      nwl <- ncol (spc)
    }
  } else if (!is.null (data$spc))
    nwl <- ncol (data$spc)
  else
    nwl <- 0


  if (is.null (wavelength)){
    ## guess from spc's colnames
    if (!is.null (spc))
      wavelength <- as.numeric (colnames (spc))

    if (length (wavelength) == 0L || any (is.na (wavelength)))
      wavelength <- as.numeric (colnames (data$spc))

    if (length (wavelength) == 0L || any (is.na (wavelength)))
      wavelength <- seq_len (nwl) # guessing didn't work
  }
  .Object@wavelength <- wavelength

  ## column + wavelength axis labels
  if (is.null (labels) || length (labels) == 0L){
    cln <- c (colnames (data), '.wavelength')
    if (! any (grepl ("spc", cln)))
      cln <- c (cln, "spc")
    labels <- vector ("list", length (cln))
    names (labels) <- cln
    rm (cln)
  }

  ## transform labels into expressions
  .make.expression <- function (x){
    if (is.language (x) && ! is.expression (x))
      class (x) <- "expression"
    else if (is.character (x))
      x <- as.expression (x)
    x
  }

  labels <- lapply (labels, .make.expression)

  .Object@label <- labels

  rm (labels, wavelength)
  if (.options$gc) gc ()

  if (! is.null (data$spc) && ! (is.null (spc)))
    warning ("Spectra in data are overwritten by argument spc.")

  ## deal with spectra
  if (is.null (spc) && is.null (data$spc)){
    spc <- structure(numeric (0), .Dim = c(0L, 0L))
  }

  if (! is.null (spc) && !is.matrix (spc)) {
    spc <- as.matrix (spc)
    if (ncol (spc) == 1L)
        spc <- t (spc)
  }

  if (.options$gc) gc ()

  if (! is.null (spc)){
    attr (spc, "class") <- "AsIs"       # I seems to make more than one copy
    if (.options$gc) gc ()
  }

  ## deal with extra data
  if (is.null (data)){
    data <- data.frame (spc = spc)
  } else if (! is.null (spc)){
    if (nrow (data) == 1 && nrow (spc) > 1)
      data <- data [rep (1, nrow (spc)), , drop = FALSE]

    data$spc <- spc
  }

  rm (spc)
  if (.options$gc) gc ()

  attr (data$spc, "class") <- NULL      # more than one copy!?
  if (.options$gc) gc ()

  .Object@data <- data
  if (.options$gc) gc ()

  if (! is.null (data$spc) && ! is.numeric (data$spc))
    warning ("spectra matrix is not numeric but ", class (data$spc), ".")

  ## finally: check whether we got a valid hyperSpec object
  validObject (.Object)

  .Object
}

##' Creating a hyperSpec Object
##' Like other S4 objects, a hyperSpec object can be created by \code{new}. The
##' hyperSpec object is then \code{initialize}d using the given parameters.
##'
##' If option \code{gc} is \code{TRUE}, the initialization will have frequent
##' calls to \code{gc ()} which can help to avoid swapping or running out of
##' memory.
##'
##' @name initialize
##' @rdname initialize
##' @aliases initialize,hyperSpec-method initialize create
##'   create,hyperSpec-method new,hyperSpec-method new
##' @docType methods
##' @param .Object the new \code{hyperSpec} object.
##' @param data \code{data.frame}, possibly with the spectra in
##'   \code{data$spc}, and further variates in more columns.  A matrix can be
##'   entered as \emph{one} column of a data frame by: \code{data.frame (spc =
##'   I (as.matrix (spc)))}.
##'
##' However, it will usually be more convenient if the spectra are given in
##'   \code{spc}
##' @param spc the spectra matrix.
##'
##' \code{spc} does not need to be a matrix, it is converted explicitly by
##'   \code{I (as.matrix (spc))}.
##' @param wavelength The wavelengths corresponding to the columns of
##'   \code{data}. If no wavelengths are given, an appropriate vector is
##'   derived from the column names of \code{data$spc}. If this is not
##'   possible, \code{1 : ncol (data$spc)} is used instead.
##' @param labels A \code{list} containing the labels for the columns of the
##'   \code{data} slot of the \code{hyperSpec} object and for the wavelength
##'   (in \code{label$.wavelength}). The labels should be given in a form ready
##'   for the text-drawing functions (see \code{\link[grDevices]{plotmath}}).
##'
##' If \code{label} is not given, a list containing \code{NULL} for each of the
##'   columns of\code{data} and \code{wavelength} is used.
##' @author C.Beleites
##' @seealso \code{\link[methods]{new}} for more information on creating and
##'   initializing S4 objects.
##'
##' \code{\link[grDevices]{plotmath}} on expressions for math annotations as
##'   for slot \code{label}.
##'
##' \code{\link{hy.setOptions}}
##' @keywords methods datagen
##' @examples
##'
##' new ("hyperSpec")
##'
##' spc <- matrix (rnorm (12), ncol = 4)
##' new ("hyperSpec", spc = spc)
##' new ("hyperSpec", data = data.frame (x = letters[1:3]),
##'      spc = spc)
##'
##' colnames (spc) <- 600:603
##' new ("hyperSpec", spc = spc)  # wavelength taken from colnames (spc)
##'
##' # given wavelengths precede over colnames of spc
##' new ("hyperSpec", spc = spc, wavelength = 700:703)
##'
##' # specifying labels
##' h <- new ("hyperSpec", spc = spc, data = data.frame (pos = 1 : 3),
##'           label = list (spc = "I / a.u.",
##'                         .wavelength = expression (tilde (nu) / cm^-1),
##'                         pos = expression ("/" (x, mu*m)))
##' )
##'
##' plot (h)
##' plotc (h, spc ~ pos)
##'
setMethod ("initialize", "hyperSpec", .initialize)

##' @include unittest.R
.test (.initialize) <- function (){
  context (".initialize / new (\"hyperSpec\")")

  test_that("empty hyperSpec object", {
    expect_equivalent (dim (new ("hyperSpec")), c (0L, 1L, 0L))
  })

  test_that("vector for spc", {
    h <- new ("hyperSpec", spc = 1 : 4)
    expect_equal (h@data$spc, matrix (1 : 4, nrow = 1))
    expect_equivalent (dim (h), c (1L, 1L, 4L))
    expect_equal (h@wavelength, 1 : 4)
  })

  test_that("matrix for spc", {
    spc <- matrix (c(1 : 12), nrow = 3)
    h <- new ("hyperSpec", spc = spc)
    expect_equivalent (h@data$spc, spc)
    expect_equivalent (dim (h), c (3L, 1L, 4L))
    expect_equal (h@wavelength, 1 : 4)
  })

  spc <- matrix (c(1 : 12), nrow = 3)
  test_that("matrix with numbers in colnames for spc", {
    colnames(spc) <- c(600, 601, 602, 603)
    h <- new ("hyperSpec", spc = spc)
    expect_equivalent (h@data$spc, spc)
    expect_equivalent (dim (h), c (3L, 1L, 4L))
    expect_equal (h@wavelength, c(600, 601, 602, 603))
  })

  colnames(spc) <- c(600, 601, 602, 603)
  test_that("spc and data given", {
    h <- new ("hyperSpec", spc = spc, data = data.frame (x = 3))
    expect_equal (h@data$spc, spc)
    expect_equivalent (dim (h), c (3L, 2L, 4L))
    expect_equal (h@wavelength, c(600, 601, 602, 603))
    expect_equal (h@data$x, rep (3, 3L))
  })

  test_that("spc and data given, data has $spc column (which should be overwritten with warning)", {
    expect_warning(h <- new ("hyperSpec", spc = spc, data = data.frame (spc = 11:13)))
    expect_equal (h@data$spc, spc)
    expect_equivalent (dim (h), c (3L, 1L, 4L))
    expect_equal (h@wavelength, c(600, 601, 602, 603))
  })

  test_that("spc and data given, different numbers of rows", {
    expect_error (new ("hyperSpec", spc = spc, data = data.frame (x = 11:12)))
  })

  test_that("only data given, data has $spc column with `I()`-protected matrix", {
    h <- new ("hyperSpec", data = data.frame (spc = I (spc)))
    expect_equal (h@data$spc, spc)
    expect_equivalent (dim (h), c (3L, 1L, 4L))
    expect_equal (h@wavelength, c(600, 601, 602, 603))
  })

  test_that("spc is data.frame", {
    h <- new ("hyperSpec", spc = as.data.frame (spc))
    expect_equal (h@data$spc, spc)
    expect_equivalent (dim (h), c (3L, 1L, 4L))
  })
}