Nothing
#' calculation of the Lx/Tx matrix
#'
#' Internal function called by \link{analyse_TL.MAAD} and \link{analyse_TL.SAR}. \cr
#' This function separates the Lx matrix from the Tx matrix.
#' Then, it estimates the Lx/Tx matrix.
#' It also provides a name for each of the curves. \cr
#'
#'
#' @param object
#' \code{\linkS4class{TLum.Analysis}} (\bold{required}): \code{TLum.Analysis} object
#'
#' @return
#' The function provides an \linkS4class{TLum.Results} containing: \cr
#' \describe{
#' \item{\code{Temperatures}}{
#' \link{numeric}: Vector with the temperature values.}
#' \item{\code{Names}}{
#' \link{character}: Vector with the curve names.}
#' \item{\code{Datatype}}{
#' \link{character}: Vector with the curve type.}
#' \item{\code{Doses}}{
#' \link{numeric}: Vector with the curve doses.}
#' \item{\code{Testdoses}}{
#' \link{numeric}: Vector with the curve test-doses.}
#' \item{\code{Lx}}{
#' Lx matrix.}
#' \item{\code{Lx.error}}{
#' Absolute error for the Lx matrix.}
#' \item{\code{Tx}}{
#' Tx matrix.}
#' \item{\code{Tx.error}}{
#' Absolute error for the Tx matrix}
#' \item{\code{LxTx}}{
#' Lx/Tx matrix.}
#' \item{\code{LxTx.error}}{
#' Absolute error for the Lx/Tx matrix.}
#' }
#'
#' @details
#' \bold{Warning}: This function is an internal function and should not be used except for development purposes.
#' Internal functions can be heavily modified and even renamed or removed in new version of the package.
#'
#' @references
#' Aitken, M.J. (1985) Thermoluminescence Dating, Academic Press, London \cr
#'
#' Murray & Wintle (2000). Luminescence dating of quartz using an improved single-aliquot regenerative-dose protocol. Radiation Measurements, Vol.32, No.1, p.57-73. \cr
#'
#' @seealso
#' \link{analyse_TL.MAAD},
#' \link{analyse_TL.SAR}.
#'
#' @author David Strebler, University of Cologne (Germany).
#'
#' @export calc_TL.LxTx
calc_TL.LxTx <- function(
object
){
# ------------------------------------------------------------------------------
# Integrity Check
# ------------------------------------------------------------------------------
if (missing(object)){
stop("[analyse_TL.MAAD] Error: Input object is missing.")
}else if (!is(object,"TLum.Analysis")){
stop("[analyse_TL.MAAD] Error: Input object is not of type 'TLum.Analysis'.")
}
#------------------------------------------------------------------------------
nRecords <- length(object@records)
nPoints <- length(object@records[[1]]@data)
temperatures <- object@records[[1]]@temperatures
Tmax <- max(temperatures)
# ------------------------------------------------------------------------------
# Value check
# Check Tmax & nPoints
for(i in 1: nRecords){
temp.record <- object@records[[i]]
temp.nPoints<- temp.record@metadata$NPOINTS
temp.Tmax <- max(temp.record@temperatures)
if(temp.nPoints != nPoints){
stop("[analyse_TL.MAAD] Error: All the TL curves do not have the same number of points'.")
}
if(temp.Tmax != Tmax){
stop("[analyse_TL.MAAD] Error: All the TL curves do not have the same maximum temperature'.")
}
}
#------------------------------------------------------------------------------
dTypes <- vector()
doses <- vector()
testdoses <- vector()
names <- vector()
Lx <- vector()
Lx.error <- vector()
Tx <- vector()
Tx.error <- vector()
#Test dose identification + Separation of Lx and Tx.
for (i in 1:nRecords){
temp.record <- object@records[[i]]
temp.dType <- temp.record@metadata$DTYPE
temp.dose <- temp.record@metadata$IRR_TIME
temp.curve <- temp.record@data
temp.curve.error <- temp.record@error
# Check -------------------------------------------------
if(length(temp.curve) != length(temp.curve.error)){
stop("[analyse_TL.MAAD] Error: The signal and the Error vector have a different length.")
}
#-----------------------------------------
if(temp.dType != "Testdose"){
dTypes <- c(dTypes,temp.dType)
doses <- c(doses,temp.dose)
Lx <- cbind(Lx,temp.curve)
Lx.error <- cbind(Lx.error,temp.curve.error)
}else{
testdoses <- c(testdoses,temp.dose)
Tx <- cbind(Tx,temp.curve)
Tx.error <- cbind(Tx.error,temp.curve.error)
}
}
#------------------------------------------------------------------------------
# Check: Lx & Tx length
if(length(Tx) > 0){
if(!identical(dim(Lx), dim(Tx))){
stop("[calc_TL.LxTx] Error: Lx and Tx do not have the same size.")
}
}else{
warning("[calc_TL.LxTx] Warning: No Testdose.")
}
#------------------------------------------------------------------------------
# determination of the name of the curve (Natural, R0, R1, R2,...)
temp.r <- 1
temp.a <- 1
temp.b <- 1
temp.i <- 1
for(i in 1 : length(dTypes)){
if(dTypes[i] == "Natural"){
temp.name <- "N"
}else if(dTypes[i] == "Dose"){
if(doses[i] == 0){
temp.name <- "R0"
}else{
temp.name <- paste("R", temp.r, sep="")
temp.r <- temp.r + 1
}
}else if(dTypes[i] == "N+dose"){
temp.name <- paste("A", temp.a, sep="")
temp.a <- temp.a + 1
}else if(dTypes[i] == "Bleach"){
temp.name <- "B0"
}else if(dTypes[i] == "Bleach+dose"){
temp.name <- paste("B", temp.b, sep="")
temp.b <- temp.b + 1
}else{
temp.name <- paste("O", temp.i, sep="")
temp.i <- temp.i + 1
}
names <- c(names, temp.name)
}
# Naming Lx
names(doses) <- names
colnames(Lx) <- names
colnames(Lx.error) <- names
# Naming Tx
if(identical(dim(Tx), dim(Lx))){
names(testdoses) <- names
colnames(Tx) <- names
colnames(Tx.error) <- names
}
#------------------------------------------------------------------------------
#Lx/Tx
if(identical(dim(Tx), dim(Lx))){
LxTx <- Lx/Tx
LxTx.error <- sqrt((Lx.error/Lx)^2 + (Tx.error/Tx)^2)*abs(LxTx)
}else{
LxTx <- Lx
LxTx.error <- Lx.error
warning("[calc_TL.LxTx] Warning: LxTx = Lx.")
}
#Replace NA, NaN and Inf by NA
Lx[!is.finite(Lx)] <- NA
Lx.error[!is.finite(Lx.error)] <- NA
Tx[!is.finite(Tx)] <- NA
Tx.error[!is.finite(Tx.error)] <- NA
LxTx[!is.finite(LxTx)] <- NA
LxTx.error[!is.finite(LxTx.error)] <- NA
new.originator <- as.character(match.call()[[1]])
result <- list(Temperatures=temperatures,
Names=names,
Datatypes=dTypes,
Doses=doses,
Testdoses=testdoses,
LxTx=as.data.frame(LxTx),
LxTx.error=as.data.frame(LxTx.error),
Lx=as.data.frame(Lx),
Lx.error=as.data.frame(Lx.error),
Tx=as.data.frame(Tx),
Tx.error=as.data.frame(Tx.error)
)
new.plotData <- list()
new.TLum.Results.calc_TL.LxTx <- set_TLum.Results(originator= new.originator,
data = result,
plotData = new.plotData)
return (new.TLum.Results.calc_TL.LxTx)
}
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.