Nothing
#' Creates a new TLum.Analysis object where the background was removed from the signal.
#'
#'
#'
#' @param object
#' \code{\linkS4class{TLum.Analysis}} (\bold{required}): object containing the initial TL curves.
#' @param keep.background
#' \link{logical} (with default): Parameter indicating if the background curve have to be kept or suppressed.
#' @param plotting.parameters
#' \link{list} (with default): list containing the plotting 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.}
#' }
#'
#' @seealso
#' \link{plot_substract.background}
#'
#' @return
#' This function provides a new \code{\linkS4class{TLum.Analysis}} object with the TL curves after background subtraction. \cr
#' It also plots the TL curves, the background curves and the background substracted curves using \link{plot_remove.preheat}.
#'
#' @author David Strebler, University of Cologne (Germany).
#'
#' @export mod_substract.background
mod_substract.background <- function(
object,
keep.background=FALSE,
plotting.parameters=list(no.plot=FALSE)
){
# ------------------------------------------------------------------------------
# Integrity Check
# ------------------------------------------------------------------------------
if (missing(object)){
stop("[mod_substract.background] Error: Input 'object' is missing.")
}else if (!is(object,"TLum.Analysis")){
stop("[mod_substract.background] Error: Input 'object' is not of type 'TLum.Analysis'.")
}
if(!is.logical(keep.background) || is.na(keep.background)){
stop("[mod_substract.background] Error: Input 'keep.background' is not of type 'logical'.")
}
if(!is.list(plotting.parameters)){
stop("[mod_substract.background] Error: Input 'plotting.parameters' is not of type 'list'.")
}
# ------------------------------------------------------------------------------
nRecords <- length(object@records)
#Extract BG & TL
test.background <- logical()
BG <- vector()
BG.error <- vector()
BG.temperature <- vector()
TL <- vector()
TL.error <- vector()
TL.temperature <- vector()
for(i in 1:nRecords){
temp.record <- object@records[[i]]
temp.curve <- temp.record@data
temp.curve.error <- temp.record@error
temp.temperatures <- temp.record@temperatures
temp.metadata <- temp.record@metadata
temp.dtype <- temp.metadata$DTYPE
if(temp.dtype == "Background"){
test.background[i] <- TRUE
BG <- cbind(BG,temp.curve)
BG.error <- cbind(BG.error,temp.curve.error)
BG.temperature <- cbind(BG.temperature, temp.temperatures)
}else{
test.background[i] <- FALSE
TL <- cbind(TL,temp.curve)
TL.error <- cbind(TL.error,temp.curve.error)
TL.temperature <- cbind(TL.temperature, temp.temperatures)
}
}
#----------------------------------------------------------------------------------------------
#Background substraction
#----------------------------------------------------------------------------------------------
if(identical(TL.temperature, BG.temperature)){
new.TL <- TL - BG
new.TL.error <- sqrt(TL.error^2 + BG.error^2)
}else{
stop("[mod_substract.background] Error: TL & BG Temperature matrix do not match.")
}
temperatures <- TL.temperature[,1]
for(i in 1:ncol(TL.temperature)){
if(!identical(temperatures, TL.temperature[,i])){
stop("[mod_substract.background] Error: All TL do not have the same temperature vector.")
}
}
#----------------------------------------------------------------------------------------------
# Generate TLum.Analysis
#----------------------------------------------------------------------------------------------
new.records <- list()
temp.i <- 0
if(keep.background == FALSE){
for(i in 1:nRecords){
temp.record <- object@records[[i]]
if(test.background[i] == FALSE) {
temp.i <- temp.i+1
#temp.record@metadata$ID <- temp.i
temp.record@data <- new.TL[,temp.i]
temp.record@error <- new.TL.error[,temp.i]
new.records <- c(new.records,temp.record)
}
}
}else{ #If keep.background == TRUE... for "analyse_SAR.TL"
for(i in 1:nRecords){
temp.record <- object@records[[i]]
if(test.background[i] == FALSE) {
temp.i <- temp.i+1
temp.record@data <- new.TL[,temp.i]
temp.record@error <- new.TL.error[,temp.i]
}
new.records <- c(new.records,temp.record)
}
}
new.protocol <- object@protocol
new.history <- c(object@history,
as.character(match.call()[[1]]))
new.plotData <- list(old.TL=TL,
BG=BG,
new.TL=new.TL,
temperatures=temperatures)
new.plotHistory <- object@plotHistory
new.plotHistory[[length(new.plotHistory)+1]] <- new.plotData
# new Analysis
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 == FALSE){
do.call(plot_substract.background,
new.plotData)
}
#----------------------------------------------------------------------------------------------
#Return results
#----------------------------------------------------------------------------------------------
return(new.TLum.Analysis)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.