#' Fit and plot a dose response curve for ESR data (ESR intensity against dose)
#'
#' A dose response curve is produced for Electron Spin Resonance measurements
#' using an additive dose protocol.
#'
#' \bold{Fitting methods} \cr\cr For fitting of the dose response curve the
#' \code{nls} function with the \code{port} algorithm is used. A single
#' saturating exponential in the form of \deqn{y = a*(1-exp(-(x+c)/b))} is
#' fitted to the data. Parameters b and c are approximated by a linear fit
#' using \code{lm}.\cr\cr \bold{Fit weighting} \cr\cr If \code{'equal'} all
#' datapoints are weighted equally. For \code{'prop'} the datapoints are
#' weighted proportionally by their respective ESR intensity: \deqn{fit.weights
#' = 1/intensity/(sum(1/intensity))} If individual errors on ESR intensity are
#' available, choosing \code{'error'} enables weighting in the form of:
#' \deqn{fit.weights = 1/error/(sum(1/error))} \cr\cr \bold{Bootstrap} \cr\cr
#' If \code{bootstrap = TRUE} the function generates
#' \code{bootstrap.replicates} replicates of the input data for nonparametric
#' ordinary bootstrapping (resampling with replacement). For each bootstrap
#' sample a dose response curve is constructed by fitting the chosen function
#' and the equivalent dose is calculated. The distribution of bootstrapping
#' results is shown in a histogram, while a \code{\link{qqnorm}} plot is
#' generated to give indications for (non-)normal distribution of the data.
#'
#'
#' @param input.data \code{\link{data.frame}} (\bold{required}): data frame
#' with two columns for x=Dose, y=ESR.intensity. Optional: a third column
#' containing individual ESR intensity errors can be provided.
#'
#' @param model \code{\link{character}} (with default): Currently implemented
#' models: single-saturating exponential (\code{"EXP"}), linear (\code{"LIN"}).
#'
#' @param fit.weights \code{\link{logical}} (with default): option whether the
#' fitting is done with equal weights (\code{'equal'}) or weights proportional
#' to intensity (\code{'prop'}). If individual ESR intensity errors are
#' provided, these can be used as weights by using \code{'error'}.
#'
#' @param algorithm \code{\link{character}} (with default): specify the applied
#' algorithm used when fitting non-linear models. If \code{'port'} the 'nl2sol'
#' algorithm from the Port library is used. The default (\code{'LM'}) uses
#' the implementation of the Levenberg-Marquardt algorithm from
#' the \code{'minpack.lm'} package.
#'
#' @param mean.natural \code{\link{logical}} (with default): If there are repeated
#' measurements of the natural signal should the mean amplitude be used for
#' fitting?
#'
#' @param bootstrap \code{\link{logical}} (with default): generate replicates
#' of the input data for a nonparametric bootstrap.
#'
#' @param bootstrap.replicates \code{\link{numeric}} (with default): amount of
#' bootstrap replicates.
#'
#' @param plot \code{\link{logical}} (with default): plot output
#' (\code{TRUE/FALSE}).
#'
#' @param \dots further arguments
#'
#'
#' @return Returns terminal output and a plot. In addition, a list is returned
#' containing the following elements:
#'
#' \item{output}{data frame containing the De (De, De Error, D01 value).}
#' \item{fit}{\code{nls} object containing the fit parameters}
#'
#' @export
#' @note This function is largely derived from the \code{plot_GrowthCurve}
#' function of the 'Luminescence' package by Kreutzer et al. (2012).\cr\cr
#' \bold{Fitting methods} \cr Currently, only fitting of a single saturating
#' exponential is supported. Fitting of two exponentials or an exponential with
#' a linear term may be implemented in a future release. \cr\cr
#' \bold{Bootstrap} \cr\cr While a higher number of replicates (bootstrap
#' samples) is desirable, it is also increasingly computationally intensive.
#' @author Christoph Burow, University of Cologne (Germany) Who wrote it
#' @seealso \code{\link{plot}}, \code{\link{nls}}, \code{\link{lm}},
#' \code{link{boot}}
#' @references Efron, B. & Tibshirani, R., 1993. An Introduction to the
#' Bootstrap. Chapman & Hall. \cr\cr Davison, A.C. & Hinkley, D.V., 1997.
#' Bootstrap Methods and Their Application. Cambridge University Press. \cr\cr
#' Galbraith, R.F. & Roberts, R.G., 2012. Statistical aspects of equivalent
#' dose and error calculation and display in OSL dating: An overview and some
#' recommendations. Quaternary Geochronology, 11, pp. 1-27. \cr\cr Kreutzer,
#' S., Schmidt, C., Fuchs, M.C., Dietze, M., Fischer, M., Fuchs, M., 2012.
#' Introducing an R package for luminescence dating analysis. Ancient TL, 30
#' (1), pp 1-8.
#' @examples
#'
#' ##load example data
#' data(ExampleData.De, envir = environment())
#'
#' ##plot ESR sprectrum and peaks
#' fit_DRC(input.data = ExampleData.De, fit.weights = 'prop')
#'
#' @export fit_DRC
fit_DRC <- function(input.data, model = "EXP", fit.weights = "equal",
algorithm = "LM", mean.natural = FALSE, bootstrap = FALSE,
bootstrap.replicates = 999, plot = FALSE,
...) {
## ==========================================================================##
## CONSISTENCY CHECK OF INPUT DATA
## ==========================================================================##
## check if provided data fulfill the requirements
# 1. check if input.data is data.frame
if (!is.data.frame(input.data)) {
stop("\n [fit_DRC] >> input.data has to be of type data.fame!")
}
# 2. very if data frame has two or three columns
if (length(input.data) < 2 | length(input.data) > 3) {
cat(paste("Please provide a data frame with at two or three columns",
"(x=Dose, y=ESR.intensity, z=ESR.intensity.Error)."), fill = FALSE)
stop(domain = NA)
}
#### satisfy R CMD check Notes
x <- NULL
## ==========================================================================##
## CHECK ... ARGUMENTS
## ==========================================================================##
extraArgs <- list(...)
verbose <- if ("verbose" %in% names(extraArgs)) {
extraArgs$verbose
} else {
TRUE
}
## ==========================================================================##
## MODIFY INPUT DATA
## ==========================================================================##
if (mean.natural) {
nat_index <- which(input.data[,1] == 0)
nat_mean <- mean(input.data[nat_index, 2])
input.data <- input.data[-nat_index, ]
input.data <- rbind(c(0, nat_mean),
input.data)
}
## ==========================================================================##
## SET FUNCTIONS FOR FITTING & PREPARE INPUT DATA
## ==========================================================================##
## label input.data data frame for easier addressing
if (length(input.data) == 2) {
colnames(input.data) <- c("x", "y")
}
if (length(input.data) == 3) {
colnames(input.data) <- c("x", "y", "y.Err")
}
## set EXP function for fitting
EXP <- y ~ a * (1 - exp(-(x + c)/b))
TI1 <- y ~ a * ( exp(-(x + c)/b1) - exp(-(x + c)/b2) )
## ==========================================================================##
## START PARAMETER ESTIMATION
## ==========================================================================##
## general setting of start parameters for fitting
# a - estimation for a take the maxium of the y-values
a <- max(input.data[, 2])
# b - get start parameters from a linear fit of the log(y) data
fit.lm <- lm(log(input.data$y) ~ input.data$x)
b <- as.numeric(1/fit.lm$coefficients[2])
# c - get start parameters from a linear fit - offset on x-axis
fit.lm <- lm(input.data$y ~ input.data$x)
c <- as.numeric(abs(fit.lm$coefficients[1]/fit.lm$coefficients[2]))
## --------------------------------------------------------------------------##
## to be a little bit more flexible the start parameters varries within
## a normal distribution
# draw 50 start values from a normal distribution a start values
a.MC <- rnorm(50, mean = a, sd = a/100)
b.MC <- rnorm(50, mean = b, sd = b/100)
c.MC <- rnorm(50, mean = c, sd = c/100)
# set start vector (to avoid errors witin the loop)
a.start <- NA
b.start <- NA
c.start <- NA
## try to create some start parameters from the input values to make the
## fitting more stable
for (i in 1:50) {
a <- a.MC[i]
b <- b.MC[i]
c <- c.MC[i]
fit <- try(nls(EXP,
data = input.data,
start = c(a = a, b = b, c = c),
trace = FALSE, algorithm = "port",
lower = c(a = 0, b > 0, c = 0),
nls.control(maxiter = 100,
warnOnly = FALSE,
minFactor = 1/2048) #increase max. iterations
), silent = TRUE)
if (class(fit) != "try-error") {
# get parameters out of it
parameters <- (coef(fit))
b.start[i] <- as.vector((parameters["b"]))
a.start[i] <- as.vector((parameters["a"]))
c.start[i] <- as.vector((parameters["c"]))
}
}
# use mean as start parameters for the final fitting
a <- median(na.exclude(a.start))
b <- median(na.exclude(b.start))
c <- median(na.exclude(c.start))
## ==========================================================================##
## CALCULATE FITTING WEIGHTS
## ==========================================================================##
# all datapoints are equally weighted
if (fit.weights == "equal") {
weights <- rep(1, length(input.data$x))
}
# datapoints are weighted proportionally to their ESR intensity
# References:
# Gruen & Rhodes 1991.?, ATL
# Gruen & Rhodes 1992. Simulating SSE ESR DRCs - weighting of intensity by inverse variance, ATL
# Gruen & Brumby 1994. Assessment of errors in extrapolated ESR dose response curves, RM
if (fit.weights[1] == "prop") {
weights <- 1/ (input.data$y/(sum(1/input.data$y)))^2
}
# EXPERIMENTAL: Weight datapoints by their true error in ESR intensity
if (fit.weights[1] == "error") {
weights <- 1/input.data$y.Err/(sum(1/input.data$y.Err))
}
## ==========================================================================##
## FIT: SINGLE SATURATING EXPONENTIAL (SSE)
## ==========================================================================##
# non-linear least square fit with an SSE | a*(1-exp(-(x+c)/b))
nls.fit <- function(x) {
nls.bs.res <- suppressMessages(try(nls(EXP, data = x,
start = c(a = a, b = b, c = c), trace = FALSE, weights = weights,
algorithm = "port", nls.control(maxiter = 500)), silent = TRUE)) #end nls
}
#
nlsLM.fit <- function(x) {
nls.bs.res <- suppressMessages(minpack.lm::nlsLM(EXP, data = x,
start = c(a = a, b = b, c = c), trace = FALSE, weights = weights,
control = minpack.lm::nls.lm.control(maxiter = 500)))
}
if (model == "EXP") {
if (algorithm == "port") fit <- nls.fit(input.data)
else if (algorithm == "LM") fit <- nlsLM.fit(input.data)
# retrieve fitting results
nls.par <- try(summary(fit)$parameters, silent = TRUE)
if (class(fit) == "try-error") {
nls.par <- NA
}
}
## ==========================================================================##
## FIT: LINEAR
## ==========================================================================##
if (model == "LIN") {
fit <- lm(input.data[ ,2] ~ input.data[ ,1])
}
## ==========================================================================##
## FIT: TI-2 (double exponential with negative term [dose quenching])
## ==========================================================================##
# TODO: initial value estimation, fitting, DE solving
# REFERENCE: Duval & Guilarte (2015)
if (model == "Ti-2") {
stop("The Ti-2 model is not yet implemented", call. = FALSE)
# fit <- minpack.lm::nlsLM(TI1, data = input.data,
# start = c(a = 1000, c = 10, b1 = 1000, b2 = 500),
# trace = TRUE,
# control = minpack.lm::nls.lm.control(maxiter = 1000))
}
## ==========================================================================##
## EQUIVALENT DOSE CALCULATION
## ==========================================================================##
if (model == "EXP") {
# calculate De by solving SSE for x
if (class(fit) != "try-error") {
De.solve <- round(nls.par["c", "Estimate"], 2)
d0 <- round(nls.par["b", "Estimate"], 2)
CI <- suppressMessages(try(confint(fit, level = 0.67)))
if (!inherits(CI, "try-error")) {
De.solve.error <- round(as.numeric(dist(CI["c", ]) / 2), 2)
d0.error <- round(as.numeric(dist(CI["b", ]) / 2), 2)
} else {
De.solve.error <- round(nls.par["c", "Std. Error"], 2)
d0.error <- round(nls.par["b", "Std. Error"], 2)
}
} else {
De.solve.error <- NA
d0 <- NA
d0.error <- NA
Rsqr <- NA
}
}
if (model == "LIN") {
lm.coef <- as.numeric(coef(fit))
De.solve <- round(-lm.coef[1] / lm.coef[2], 2)
CI <- suppressMessages(confint(fit, level = 0.95))
De.solve.error <- round(as.numeric(dist(CI[2, ]) / 2), 2)
d0 <- NA
d0.error <- NA
}
## ==========================================================================##
## DETERMINE FIT QUALITY
## ==========================================================================##
if (class(fit) != "try-error") {
RSS.p <- sum(residuals(fit)^2)
TSS <- sum((input.data[, 2] - mean(input.data[, 2]))^2)
Rsqr <- 1-RSS.p/TSS
}
## ==========================================================================##
## BOOTSTRAP
## ==========================================================================##
if (bootstrap) {
nls.bs <- function(bs.data, i, FUN) {
d <- bs.data[i, ]
if (model == "EXP") {
nls.bs.fit <- nls.fit(d)
nls.bs.par <- try(summary(nls.bs.fit)$parameters, silent = TRUE)
if (class(nls.bs.fit) == "try-error") {
de <- NA
} else {
de <- nls.bs.par["c", "Estimate"]
}
}
if (model == "LIN") {
lm.bs.fit <- lm(d[, 2] ~ d[ ,1])
lm.coef <- as.numeric(coef(lm.bs.fit))
de <- abs(round(-lm.coef[1] / lm.coef[2], 2))
}
return(de)
}
nls.bs.res <- boot(input.data, nls.bs, R = bootstrap.replicates,
parallel = "multicore")
nls.bs.des <- na.exclude(nls.bs.res$t)
nls.bs.mean <- round(mean(nls.bs.des), 2)
nls.bs.median <- round(median(nls.bs.des), 2)
nls.bs.sd <- round(sd(nls.bs.des), 2)
}
## ==========================================================================##
## CONSOLE OUTPUT
## ==========================================================================##
if (verbose)
{
# save weighting method in a new variable for nicer output
if (fit.weights == "equal") {
weight.method <- "equal weights"
}
if (fit.weights == "prop") {
weight.method <- "proportional to intensity"
}
if (fit.weights == "error") {
weight.method <- "individual ESR intensity error"
}
# final console output
cat("\n [fit_DRC]")
cat(paste("\n\n ---------------------------------------------------------"))
cat(paste("\n number of datapoints :", length(input.data$x)))
cat(paste("\n maximum additive dose (Gy) :", max(input.data$x)))
cat(paste("\n Error weighting :", weight.method))
cat(paste("\n Satuation dose D0 (Gy) :", d0))
cat(paste("\n Satuation dose D0 error (Gy) :", d0.error))
cat(paste("\n De (Gy) :", abs(De.solve)))
cat(paste("\n De error (Gy) :", De.solve.error))
cat(paste("\n R^2 :", round(Rsqr, 4)))
cat(paste("\n ---------------------------------------------------------\n"))
# results of bootstrapping
if (bootstrap) {
cat(paste("\n\n ------------------- BOOTSTRAP RESULTS -------------------"))
cat(paste("\n Mean (Gy) :", round(nls.bs.mean,
2)))
cat(paste("\n Median (Gy) :", round(nls.bs.median,
2)))
cat(paste("\n Standard deviation (Gy) :", round(nls.bs.sd,
2)))
cat(paste("\n ---------------------------------------------------------\n"))
}
} #:EndOf output.console
## ==========================================================================##
## RETURN VALUES
## ==========================================================================##
# create data frame for output
if (!bootstrap) {
nls.bs.res <- NA
}
output <- try(data.frame(De = ifelse(bootstrap, nls.bs.median, abs(De.solve)),
De.Error = ifelse(bootstrap, nls.bs.sd, De.solve.error),
d0 = d0,
d0.error = d0.error,
n = length(input.data$x),
weights = fit.weights,
model = model,
rsquared = Rsqr),
silent = TRUE)
results <- list(data = input.data,
output = output,
fit = fit,
bootstrap = nls.bs.res)
if (plot) on.exit(try(plot_DRC(results, ...)))
# return output data.frame and nls.object fit
invisible(results)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.