R/mod_extract.TL.R

In dstreble/TLdating: Tools for Thermoluminescence Dating

#' Extract TL
#'
#' This function provides a new \code{\linkS4class{TLum.Analysis}} object containing only the TL curves.
#'
#' @param object
#'  \code{\linkS4class{TLum.Analysis}} (\bold{required}): object containing the initial TL curves.
#' @param plotting.parameters
#'  \link{list} (with default): list containing the plotting parameters. See details.
#' @param record.parameters
#'  \link{list} (with default): list containing the record parameters. See details.
#'
#'@details
#'  \bold{Plotting parameters} \cr
#'  The plotting parameters are:  \cr
#'  \describe{
#'    \item{\code{no.plot}}{
#'      \link{logical}: If \code{TRUE}, the results will not be plotted.}
#'  }
#'
#'  \bold{Record parameters} \cr
#'  The record parameters are:  \cr
#'  \describe{
#'    \item{\code{includePreheat}}{
#'      \link{logical}: If \code{TRUE}, the preheat was included in the TL recording. If \code{FALSE}, the preheat was recorded separately.}
#'    \item{\code{recDuringPreheatRamp}}{
#'      \link{logical}: Only used when \code{includePreheat} is \code{TRUE}. If \code{TRUE}, the signal was recorded during the preheat ramp.}
#'      \item{\code{recDuringPreheatPlateau}}{
#'      \link{logical}: Only used when \code{includePreheat} is \code{TRUE}. If \code{TRUE}, the signal was recorded during the preheat plateau.}
#'  }
#'
#' @return
#'  This function provides a new \code{\linkS4class{TLum.Analysis}} with only the TL curve. \cr
#'  It also plots the TL curves using \link{plot_extract.TL}.
#'
#' @seealso
#'  \link{plot_extract.TL}
#'
#' @author David Strebler, University of Cologne (Germany).
#'
#' @export mod_extract.TL

mod_extract.TL <- function(

  object,

  plotting.parameters=list(no.plot=FALSE),

  record.parameters=list(separatePreheat=TRUE,
                         recDuringPreheatRamp=FALSE,
                         recDuringPreheatPlateau=FALSE)

){
  C_TL <- "TL"

  # ------------------------------------------------------------------------------
  # Integrity Check
  # ------------------------------------------------------------------------------
  if (missing(object)){
    stop("[mod_extract.TL] Error: Input 'object' is missing.")
  }else if (!is(object,"TLum.Analysis")){
    stop("[mod_align.peaks] Error: Input 'object' is not of type 'TLum.Analysis'.")
  }

  if(!is.list(plotting.parameters)){
    stop("[mod_extract.TL] Error: Input 'plotting.parameters' is not of type 'list'.")
  }

  if(!is.list(record.parameters)){
    stop("[mod_extract.TL] Error: Input 'record.parameters' is not of type 'list'.")
  }
  # ------------------------------------------------------------------------------

  records <- object@records

  nRecords <- length(records)

  kept.records <- list()
  rejected.records <- list()

  TL <- list()
  temperatures <- list()

  test.TL <- vector()

  #new.id <- 1

  for(i in 1:nRecords){
    temp.curve <- records[[i]]

    temp.metadata <- temp.curve@metadata

    temp.ltype <- temp.metadata$LTYPE

    temp.data <- list(temp.curve@data)
    temp.temperatures <- list(temp.curve@temperatures)

    if(temp.ltype == C_TL){
      temp.test <- TRUE

      TL <- c(TL, temp.data)
      temperatures <- c(temperatures, temp.temperatures)

      new.curve <- temp.curve
      #new.curve@metadata$ID <- new.id
      #new.id <- new.id+1

      kept.records <- c(kept.records, new.curve)
    }else{
      temp.test <- FALSE
      rejected.records <- c(rejected.records, temp.curve)
    }

    test.TL <- c(test.TL,temp.test)
  }

  #----------------------------------------------------------------------------------------------
  # Generate TLum.Analysis
  #----------------------------------------------------------------------------------------------

  new.records <- kept.records

  new.protocol <- object@protocol

  new.history <- c(object@history,
                   as.character(match.call()[[1]]))

  new.plotData <- list(TL=TL,
                       temperatures=temperatures)

  new.plotHistory <- object@plotHistory
  new.plotHistory[[length(new.plotHistory)+1]] <- new.plotData

  new.TLum.Analysis <- set_TLum.Analysis(records= new.records,
                                         protocol=new.protocol,
                                         history = new.history,
                                         plotHistory = new.plotHistory)

  #--------------------------------------------------------------------------------------------------------
  #Plot results
  #--------------------------------------------------------------------------------------------------------

  no.plot <- plotting.parameters$no.plot

  # ------------------------------------------------------------------------------
  # Value check
  if(is.null(no.plot) || is.na(no.plot) || !is.logical(no.plot)){
    no.plot <- FALSE
  }
  # ------------------------------------------------------------------------------

  if(!no.plot){
    do.call(plot_extract.TL,
            new.plotData)
  }

  #----------------------------------------------------------------------------------------------
  #Return results
  #----------------------------------------------------------------------------------------------

  return(new.TLum.Analysis)

}