",
"",
" Class: ", elements$class[i],
"",
" Length: ", elements$length[i],
"",
" Dimensions: ",
ifelse(elements$row[i] != 0, paste0(elements$row[i], ", ", elements$col[i]), "-"),
"",
"\n Path: ", gsub("@", "@", elements$branch[i]),
"",
"\n\n"),
tmp)
# TABLE CONTENT
# the content of a branch is only printed if it was determined an endpoint
# in the objects structure
if (elements$endpoint[i]) {
table <- tryCatch(eval(parse(text = elements$branch[i])),
error = function(e) {
return(NULL)
})
# exceptions: content may be NULL; convert raw to character to stay
# compatible with pander::pander
if (is.null(table) | length(table) == 0)
table <- "NULL"
if (any(class(table) == "raw"))
table <- as.character(table)
# exception: surround objects of class "call" with tags to prevent
# HTML auto formatting
if (elements$class[i] == "call") {
table <- capture.output(table)
writeLines("", tmp)
for (i in 1:length(table))
writeLines(table[i], tmp)
writeLines("", tmp)
table <- NULL
}
# shorten the table if it has more than 15 rows
if (options$short_table) {
if (is.matrix(table) || is.data.frame(table)) {
if (nrow(table) > 15) {
text <- pander::pander_return(
rbind(head(table, 5), tail(table, 5)),
caption = "shortened (only first and last five rows shown)")
writeLines(text, tmp)
next
}
}
}
# write table using pander and end each table with a horizontal line
writeLines(suppressWarnings(pander::pander_return(table)), tmp)
writeLines("\n\n
", tmp)
}
}
}#EndOf::Main
# OBJECT STRUCTURE ----
if (structure$structure) {
writeLines(paste("\n\n# Object structure\n\n"), tmp)
elements.html <- elements
elements.html$branch <- gsub("\\$", "$", elements$branch)
writeLines(pander::pander_return(elements.html,
justify = paste(rep("l", ncol(elements)), collapse = "")),
tmp)
writeLines("\n\n", tmp)
}#EndOf::Structure
if (structure$rds) {
# SAVE SERIALISED OBJECT (.rds file) ----
writeLines(paste("
# File \n\n"), tmp)
writeLines(paste0("",
"",
"Click here to access the data file", "",
""), tmp)
writeLines(paste("\nThe R object was saved to ", normalizePath(file.rds),
".",
"To import the object into your R session with the following command:",
paste0("",
"x <- readRDS('", normalizePath(file.rds), "')",
""),
"**NOTE:** If you moved the file to another directory or",
"renamed the file you need to change the path/filename in the",
"code above accordingly!"),
tmp)
}#EndOf::File
# SESSION INFO ----
if (structure$session) {
writeLines(paste("\n\n
# Session Info\n\n"), tmp)
sessionInfo <- capture.output(sessionInfo())
writeLines(paste(sessionInfo, collapse = "\n\n"),
tmp)
}
# PLOTTING ----
if (structure$plot) {
isRLumObject <- length(grep("RLum", class(object)))
if (is.list(object))
isRLumList <- all(sapply(object, function(x) inherits(x, "RLum.Data.Curve")))
else
isRLumList <- FALSE
if (isRLumObject | isRLumList) {
# mutual exclusivity: it is either a list or an RLum-Object
if (isRLumList)
plotCommand <- "invisible(sapply(x, plot)) \n"
else
plotCommand <- "plot(x) \n"
writeLines(paste("\n\n
# Plots\n\n"), tmp)
writeLines(paste0(
"```{r}\n",
"library(Luminescence) \n",
"x <- readRDS('", normalizePath(file.rds),"') \n",
plotCommand,
"```"),
tmp)
if (inherits(object, "RLum.Results")) {
# AGE MODELS ----
models <- c("calc_AverageDose",
"calc_CommonDose",
"calc_CentralDose",
"calc_FiniteMixture",
"calc_MinDose",
"calc_MaxDose",
"calc_IEU",
"calc_FuchsLang2001")
if (object@originator %in% models) {
writeLines(paste0(
"```{r}\n",
"plot_AbanicoPlot(x) \n",
"plot_Histogram(x) \n",
"plot_KDE(x) \n",
"plot_ViolinPlot(x) \n",
"```"),
tmp)
}
}
}
}#EndOf::Plot
close(tmp)
## ------------------------------------------------------------------------ ##
## CLOSE & RENDER ----
rmarkdown::render(file, clean = clean, quiet = quiet)
## ------------------------------------------------------------------------ ##
## SHOW FILE -----
# SHOW REPORT IN RSTUDIOS VIEWER PANE ----
# nocov start
if (isRStudio && show_report) {
if (isTemp) {
try(rstudioapi::viewer(file.html))
} else {
# The Viewer Pane only works for files in a sessions temp directory
# see: https://support.rstudio.com/hc/en-us/articles/202133558-Extending-RStudio-with-the-Viewer-Pane
file.copy(file.html, file.path(tempdir(), "report.html"), overwrite = TRUE)
try(rstudioapi::viewer(file.path(tempdir(), "report.html")))
}
}
# launch browser if desired
# browseURL() listens on localhost to show the file with the problem that
# the download links dont work anymore. hence, we try to open the file
# with pander::openFileInOS and use browseURL() only as fallback
if (launch.browser) {
opened <- tryCatch(pander::openFileInOS(file.html), error = function(e) "error")
if (!is.null(opened))
try(browseURL(file.html))
}
# nocov end
## ------------------------------------------------------------------------ ##
## CLEANUP ----
# note that 'clean' as also passed to rmarkdown::render
if (clean)
file.remove(file)
invisible()
}
################################################################################
## ##
## HELPER FUNCTIONS ##
## ##
################################################################################
# ---------------------------------------------------------------------------- #
# This is a recursive function that goes the objects structure and prints
# all slots/elements along with their class, length, depth.
# ---------------------------------------------------------------------------- #
.tree_RLum <- function(x, root) {
## S4 object -----
if (isS4(x)) {
# print -----
cat(c(root, .class(x), base::length(x), .depth(root), FALSE, .dimension(x), "\n"), sep = "|")
for (slot in slotNames(x)) {
s4.root <- paste0(root, "@", slot)
.tree_RLum(slot(x, slot), root = s4.root)
}
invisible()
## List objects -----
} else if (inherits(x, "list") | typeof(x) == "list" & !inherits(x, "data.frame")) {
if (!is.null(names(x)) && length(x) != 0) {
# print -----
cat(c(root, .class(x), base::length(x), .depth(root), FALSE, .dimension(x), "\n"), sep = "|")
element <- names(x)
for (i in 1:length(x)) {
if (grepl(" ", element[i]))
element[i] <- paste0("`", element[i], "`")
if (element[i] == "")
list.root <- paste0(root, "[[", i, "]]")
else
list.root <- paste0(root, "$", element[i])
.tree_RLum(x[[i]], root = list.root)
}
} else if (length(x) != 0) {
# print -----
cat(c(root, .class(x), base::length(x), .depth(root), FALSE, .dimension(x), "\n"), sep = "|")
element <- paste0("[[", seq(1, length(x),1), "]]")
for (i in 1:length(x)) {
if (grepl(" ", element[i]))
element[i] <- paste0("`", element[i], "`")
list.root <- paste0(root, element[i])
.tree_RLum(x[[i]], root = list.root)
}
} else if (length(x) == 0) {
cat(c(root, .class(x), base::length(x), .depth(root), FALSE, .dimension(x), "\n"), sep = "|")
}
invisible()
## Data frames -----
} else if (inherits(x, "data.frame")) {
if (any(sapply(x, function(col) { inherits(col, "matrix") } ))) {
element <- names(x)
for (i in 1:length(x)) {
if (grepl(" ", element[i]))
element[i] <- paste0("`", element[i], "`")
list.root <- paste0(root, "$", element[[i]])
.tree_RLum(x[[i]], root = list.root)
}
} else {
# print ----
cat(c(root, .class(x), base::length(x), .depth(root), TRUE, .dimension(x), "\n"), sep = "|")
}
invisible()
## Last elements -----
} else {
# print ----
cat(c(root, .class(x), base::length(x), .depth(root), TRUE, .dimension(x), "\n"), sep = "|")
invisible()
}
}
# ---------------------------------------------------------------------------- #
# a) Derive depth in the structure tree by splitting the directory by
# indicative accessors @, $, [[
# b) Wrapper for dim() to cope with NULL values
# c) Wrapper for class() that collapses the classes of an object
# ---------------------------------------------------------------------------- #
.depth <- function(x) {
length(strsplit(x, split = "\\$|@|\\[\\[")[[1]]) - 1
}
.dimension <- function(x) {
if (!is.null(dim(x)))
dim <- paste(dim(x), collapse = "|")
else
dim <- c(0, 0)
}
.class <- function(x) {
paste(class(x), collapse = "/")
}
# ---------------------------------------------------------------------------- #
# This function captures the output of the real worker .tree_RLum and returns
# the structure of the object as a data.frame
# ---------------------------------------------------------------------------- #
.struct_RLum <- function(x, root) {
s <- capture.output(.tree_RLum(x, root = root))
df <- as.data.frame(do.call(rbind, strsplit(s, "|", fixed = TRUE)), stringsAsFactors = FALSE)
names(df) <- c("branch", "class", "length", "depth", "endpoint", "row", "col")
df$depth <- as.integer(df$depth)
df$length <- as.numeric(df$length)
df$endpoint <- as.logical(df$endpoint)
df$row <- as.integer(df$row)
df$col <- as.integer(df$col)
df$bud <- do.call(c, lapply(strsplit(df$branch, "\\$|@|\\[\\["),
function(x) x[length(x)]))
if (length(grep("]", df$bud)) != 0)
df$bud[grep("]", df$bud)] <- paste0("[[", df$bud[grep("]", df$bud)])
df$bud.freq <- NA # 1:nrow(df)
# reorder data.frame
df <- df[ ,c("branch", "bud", "bud.freq", "class",
"length", "depth", "row", "col", "endpoint")]
# for the report we must not have the same last element names of same
# depth (HTML cannot discriminate between #links of headers)
## TODO: this is highly inefficient for unnamed list due to recurrent indices
dlevel <- max(table(df$bud))
for (i in 1:dlevel) {
unique.bud <- unique(df[is.na(df$bud.freq), ]$bud)
df[is.na(df$bud.freq), ][match(unique.bud, df[is.na(df$bud.freq), ]$bud), ]$bud.freq <- i - 1
}
invisible(df)
}
Luminescence/R/plot_AbanicoPlot.R 0000644 0001762 0000144 00000371500 14762554470 016465 0 ustar ligges users #' @title Function to create an Abanico Plot.
#'
#' @description A plot is produced which allows comprehensive presentation of data precision
#' and its dispersion around a central value as well as illustration of a
#' kernel density estimate, histogram and/or dot plot of the dose values.
#'
#' @details
#' The Abanico Plot is a combination of the classic Radial Plot
#' (`plot_RadialPlot`) and a kernel density estimate plot (e.g
#' `plot_KDE`). It allows straightforward visualisation of data precision,
#' error scatter around a user-defined central value and the combined
#' distribution of the values, on the actual scale of the measured data (e.g.
#' seconds, equivalent dose, years). The principle of the plot is shown in
#' Galbraith & Green (1990). The function authors are thankful for the
#' thought-provoking figure in this article.
#'
#' The semi circle (z-axis) of the classic Radial Plot is bent to a straight
#' line here, which actually is the basis for combining this polar (radial)
#' part of the plot with any other Cartesian visualisation method
#' (KDE, histogram, PDF and so on). Note that the plot allows displaying
#' two measures of distribution. One is the 2-sigma
#' bar, which illustrates the spread in value errors, and the other is the
#' polygon, which stretches over both parts of the Abanico Plot (polar and
#' Cartesian) and illustrates the actual spread in the values themselves.
#'
#' Since the 2-sigma-bar is a polygon, it can be (and is) filled with shaded
#' lines. To change density (lines per inch, default is 15) and angle (default
#' is 45 degrees) of the shading lines, specify these parameters. See
#' `?polygon()` for further help.
#'
#' The Abanico Plot supports other than the weighted mean as measure of
#' centrality. When it is obvious that the data
#' is not (log-)normally distributed, the mean (weighted or not) cannot be a
#' valid measure of centrality and hence central dose. Accordingly, the median
#' and the weighted median can be chosen as well to represent a proper measure
#' of centrality (e.g. `centrality = "median.weighted"`). Also
#' user-defined numeric values (e.g. from the central age model) can be used if
#' this appears appropriate.
#'
#' The proportion of the polar part and the cartesian part of the Abanico Plot
#' can be modified for display reasons (`plot.ratio = 0.75`). By default,
#' the polar part spreads over 75 % and leaves 25 % for the part that
#' shows the KDE graph.
#'
#'
#' A statistic summary, i.e. a collection of statistic measures of
#' centrality and dispersion (and further measures) can be added by specifying
#' one or more of the following keywords:
#'
#' - `"n"` (number of samples)
#' - `"mean"` (mean De value)
#' - `"median"` (median of the De values)
#' - `"sd.rel"` (relative standard deviation in percent)
#' - `"sd.abs"` (absolute standard deviation)
#' - `"se.rel"` (relative standard error)
#' - `"se.abs"` (absolute standard error)
#' - `"in.2s"` (percent of samples in 2-sigma range)
#' - `"kurtosis"` (kurtosis)
#' - `"skewness"` (skewness)
#'
#' **Note** that the input data for the statistic summary is sent to the function
#' `calc_Statistics()` depending on the log-option for the z-scale. If
#' `"log.z = TRUE"`, the summary is based on the logarithms of the input
#' data. If `"log.z = FALSE"` the linearly scaled data is used.
#'
#' **Note** as well, that `"calc_Statistics()"` calculates these statistic
#' measures in three different ways: `unweighted`, `weighted` and
#' `MCM-based` (i.e., based on Monte Carlo Methods). By default, the
#' MCM-based version is used. If you wish to use another method, indicate this
#' with the appropriate keyword using the argument `summary.method`.
#'
#' The optional parameter `layout` allows more sophisticated ways to modify
#' the entire plot. Each element of the plot can be addressed and its properties
#' can be defined. This includes font type, size and decoration, colours and
#' sizes of all plot items. To infer the definition of a specific layout style
#' cf. `get_Layout()` or type e.g., for the layout type `"journal"`
#' `get_Layout("journal")`. A layout type can be modified by the user by
#' assigning new values to the list object.
#'
#' It is possible for the z-scale to specify where ticks are to be drawn
#' by using the parameter `at`, e.g. `at = seq(80, 200, 20)`, cf. function
#' documentation of `axis`. Specifying tick positions manually overrides a
#' `zlim`-definition.
#'
#' @param data [data.frame] or [RLum.Results-class] object (**required**):
#' for `data.frame` two columns: De (`data[,1]`) and De error (`data[,2]`).
#' To plot several data sets in one plot the data sets must be provided as
#' `list`, e.g. `list(data.1, data.2)`.
#'
#' @param na.rm [logical] (*with default*):
#' exclude NA values from the data set prior to any further operations.
#'
#' @param log.z [logical] (*with default*):
#' Option to display the z-axis in logarithmic scale. Default is `TRUE`.
#'
#' @param z.0 [character] or [numeric] (*with default*):
#' User-defined central value, used for centring of data. One out of `"mean"`,
#' `"mean.weighted"` and `"median"` or a numeric value (not its logarithm).
#' Default is `"mean.weighted"`.
#'
#' @param dispersion [character] (*with default*):
#' measure of dispersion, used for drawing the scatter polygon. One out of
#' - `"qr"` (quartile range, default),
#' - `"pnn"` (symmetric percentile range with `nn` the lower percentile, e.g.
#' `"p05"` indicating the range between 5 and 95 %, or `"p10"` indicating
#' the range between 10 and 90 %), or
#' - `"sd"` (standard deviation) and
#' - `"2sd"` (2 standard deviations),
#'
#' The default is `"qr"`. Note that `"sd"` and `"2sd"` are only meaningful in
#' combination with `"z.0 = 'mean'"` because the unweighted mean is used to
#' centre the polygon.
#'
#' @param plot.ratio [numeric] (*with default*):
#' Relative space, given to the radial versus the cartesian plot part,
#' default is `0.75`.
#'
#' @param rotate [logical] (*with default*):
#' Option to turn the plot by 90 degrees.
#'
#' @param mtext [character] (*optional*):
#' additional text below the plot title.
#'
#' @param summary [character] (*optional*):
#' add statistic measures of centrality and dispersion to the plot.
#' Can be one or more of several keywords. See details for available keywords.
#' Results differ depending on the log-option for the z-scale (see details).
#'
#' @param summary.pos [numeric] or [character] (*with default*):
#' optional position coordinates or keyword (e.g. `"topright"`) for the
#' statistical summary. Alternatively, the keyword `"sub"` may be
#' specified to place the summary below the plot header. However, this latter
#' option in only possible if `mtext` is not used.
#'
#' @param summary.method [character] (*with default*):
#' keyword indicating the method used to calculate the statistic summary.
#' One out of
#' - `"unweighted"`,
#' - `"weighted"` and
#' - `"MCM"`.
#'
#' See [calc_Statistics] for details.
#'
#' @param legend [character] vector (*optional*):
#' legend content to be added to the plot.
#'
#' @param legend.pos [numeric] or [character] (*with default*):
#' optional position coordinates or keyword (e.g. `"topright"`)
#' for the legend to be plotted.
#'
#' @param stats [character]:
#' additional labels of statistically important values in the plot.
#' One or more out of the following:
#' - `"min"`,
#' - `"max"`,
#' - `"median"`.
#'
#' @param rug [logical] (*with default*):
#' Option to add a rug to the KDE part, to indicate the location of individual values.
#'
#' @param kde [logical] (*with default*):
#' Option to add a KDE plot to the dispersion part, default is `TRUE`.
#'
#' @param hist [logical] (*with default*):
#' Option to add a histogram to the dispersion part. Only meaningful when not
#' more than one data set is plotted.
#'
#' @param dots [logical] (*with default*):
#' Option to add a dot plot to the dispersion part. If number of dots exceeds
#' space in the dispersion part, a square indicates this.
#'
#' @param boxplot [logical] (*with default*):
#' Option to add a boxplot to the dispersion part, default is `FALSE`.
#'
#' @param y.axis [logical] (*with default*): Option to hide standard y-axis
#' labels and show 0 only.
#' Useful for data with small scatter. If you want to suppress the y-axis entirely
#' please use `yaxt == 'n'` (the standard [graphics::par] setting) instead.
#'
#' @param error.bars [logical] (*with default*):
#' Option to show De-errors as error bars on De-points. Useful in combination
#' with `y.axis = FALSE, bar.col = "none"`.
#'
#' @param bar [numeric] (*with default*):
#' option to add one or more dispersion bars (i.e., bar showing the 2-sigma range)
#' centred at the defined values. By default a bar is drawn according to `"z.0"`.
#' To omit the bar set `"bar = FALSE"`.
#'
#' @param bar.col [character] or [numeric] (*with default*):
#' colour of the dispersion bar. Default is `"grey60"`.
#'
#' @param polygon.col [character] or [numeric] (*with default*):
#' colour of the polygon showing the data scatter. Sometimes this
#' polygon may be omitted for clarity. To disable it use `FALSE` or
#' `polygon = FALSE`. Default is `"grey80"`.
#'
#' @param line [numeric]:
#' numeric values of the additional lines to be added.
#'
#' @param line.col [character] or [numeric]:
#' colour of the additional lines.
#'
#' @param line.lty [integer]:
#' line type of additional lines
#'
#' @param line.label [character]:
#' labels for the additional lines.
#'
#' @param grid.col [character] or [numeric] (*with default*):
#' colour of the grid lines (originating at `[0,0]` and stretching to
#' the z-scale). To disable grid lines use `FALSE`. Default is `"grey"`.
#'
#' @param frame [numeric] (*with default*):
#' option to modify the plot frame type. Can be one out of
#' - `0` (no frame),
#' - `1` (frame originates at 0,0 and runs along min/max isochrons),
#' - `2` (frame embraces the 2-sigma bar),
#' - `3` (frame embraces the entire plot as a rectangle).
#'
#' Default is `1`.
#'
#' @param bw [character] (*with default*):
#' bin-width for KDE, choose a numeric value for manual setting.
#'
#' @param interactive [logical] (*with default*):
#' create an interactive abanico plot (requires the `'plotly'` package)
#'
#' @param ... Further plot arguments to pass (see [graphics::plot.default]).
#' Supported are: `main`, `sub`, `ylab`, `xlab`, `zlab`, `zlim`, `ylim`, `cex`,
#' `lty`, `lwd`, `pch`, `col`, `at`, `breaks`. `xlab` must be
#' a vector of length two, specifying the upper and lower x-axis labels.
#'
#' @return
#' Returns a plot object and, optionally, a list with plot calculus data.
#'
#' @section Function version: 0.1.18
#'
#' @author
#' Michael Dietze, GFZ Potsdam (Germany)\cr
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)\cr
#' Inspired by a plot introduced by Galbraith & Green (1990)
#'
#' @seealso [plot_RadialPlot], [plot_KDE], [plot_Histogram], [plot_ViolinPlot]
#'
#' @references
#' Galbraith, R. & Green, P., 1990. Estimating the component ages
#' in a finite mixture. International Journal of Radiation Applications and
#' Instrumentation. Part D. Nuclear Tracks and Radiation Measurements, 17 (3),
#' 197-206.
#'
#' Dietze, M., Kreutzer, S., Burow, C., Fuchs, M.C., Fischer, M., Schmidt, C., 2015.
#' The abanico plot: visualising chronometric data with individual standard errors.
#' Quaternary Geochronology. doi:10.1016/j.quageo.2015.09.003
#'
#' @examples
#'
#' ## load example data and recalculate to Gray
#' data(ExampleData.DeValues, envir = environment())
#' ExampleData.DeValues <- ExampleData.DeValues$CA1
#'
#' ## plot the example data straightforward
#' plot_AbanicoPlot(data = ExampleData.DeValues)
#'
#' ## now with linear z-scale
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' log.z = FALSE)
#'
#' ## now with output of the plot parameters
#' plot1 <- plot_AbanicoPlot(data = ExampleData.DeValues,
#' output = TRUE)
#' str(plot1)
#' plot1$zlim
#'
#' ## now with adjusted z-scale limits
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' zlim = c(10, 200))
#'
#' ## now with adjusted x-scale limits
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' xlim = c(0, 20))
#'
#' ## now with rug to indicate individual values in KDE part
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' rug = TRUE)
#'
#' ## now with a smaller bandwidth for the KDE plot
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' bw = 0.04)
#'
#' ## now with a histogram instead of the KDE plot
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' hist = TRUE,
#' kde = FALSE)
#'
#' ## now with a KDE plot and histogram with manual number of bins
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' hist = TRUE,
#' breaks = 20)
#'
#' ## now with a KDE plot and a dot plot
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' dots = TRUE)
#'
#' ## now with user-defined plot ratio
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' plot.ratio = 0.5)
#' ## now with user-defined central value
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' z.0 = 70)
#'
#' ## now with median as central value
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' z.0 = "median")
#'
#' ## now with the 17-83 percentile range as definition of scatter
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' z.0 = "median",
#' dispersion = "p17")
#'
#' ## now with user-defined green line for minimum age model
#' CAM <- calc_CentralDose(ExampleData.DeValues,
#' plot = FALSE)
#'
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' line = CAM,
#' line.col = "darkgreen",
#' line.label = "CAM")
#'
#' ## now create plot with legend, colour, different points and smaller scale
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' legend = "Sample 1",
#' col = "tomato4",
#' bar.col = "peachpuff",
#' pch = "R",
#' cex = 0.8)
#'
#' ## now without 2-sigma bar, polygon, grid lines and central value line
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' bar.col = FALSE,
#' polygon.col = FALSE,
#' grid.col = FALSE,
#' y.axis = FALSE,
#' lwd = 0)
#'
#' ## now with direct display of De errors, without 2-sigma bar
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' bar.col = FALSE,
#' ylab = "",
#' y.axis = FALSE,
#' error.bars = TRUE)
#'
#' ## now with user-defined axes labels
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' xlab = c("Data error (%)",
#' "Data precision"),
#' ylab = "Scatter",
#' zlab = "Equivalent dose [Gy]")
#'
#' ## now with minimum, maximum and median value indicated
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' stats = c("min", "max", "median"))
#'
#' ## now with a brief statistical summary as subheader
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' summary = c("n", "in.2s"))
#'
#' ## now with another statistical summary
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' summary = c("mean.weighted", "median"),
#' summary.pos = "topleft")
#'
#' ## now a plot with two 2-sigma bars for one data set
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' bar = c(30, 100))
#'
#' ## now the data set is split into sub-groups, one is manipulated
#' data.1 <- ExampleData.DeValues[1:30,]
#' data.2 <- ExampleData.DeValues[31:62,] * 1.3
#'
#' ## now a common dataset is created from the two subgroups
#' data.3 <- list(data.1, data.2)
#'
#' ## now the two data sets are plotted in one plot
#' plot_AbanicoPlot(data = data.3)
#'
#' ## now with some graphical modification
#' plot_AbanicoPlot(data = data.3,
#' z.0 = "median",
#' col = c("steelblue4", "orange4"),
#' bar.col = c("steelblue3", "orange3"),
#' polygon.col = c("steelblue1", "orange1"),
#' pch = c(2, 6),
#' angle = c(30, 50),
#' summary = c("n", "in.2s", "median"))
#'
#' ## create Abanico plot with predefined layout definition
#' plot_AbanicoPlot(data = ExampleData.DeValues,
#' layout = "journal")
#'
#' ## now with predefined layout definition and further modifications
#' plot_AbanicoPlot(
#' data = data.3,
#' z.0 = "median",
#' layout = "journal",
#' col = c("steelblue4", "orange4"),
#' bar.col = adjustcolor(c("steelblue3", "orange3"),
#' alpha.f = 0.5),
#' polygon.col = c("steelblue3", "orange3"))
#'
#' ## for further information on layout definitions see documentation
#' ## of function get_Layout()
#'
#' ## now with manually added plot content
#' ## create empty plot with numeric output
#' AP <- plot_AbanicoPlot(data = ExampleData.DeValues,
#' pch = NA,
#' output = TRUE)
#'
#' ## identify data in 2 sigma range
#' in_2sigma <- AP$data[[1]]$data.in.2s
#'
#' ## restore function-internal plot parameters
#' par(AP$par)
#'
#' ## add points inside 2-sigma range
#' points(x = AP$data[[1]]$precision[in_2sigma],
#' y = AP$data[[1]]$std.estimate.plot[in_2sigma],
#' pch = 16)
#'
#' ## add points outside 2-sigma range
#' points(x = AP$data[[1]]$precision[!in_2sigma],
#' y = AP$data[[1]]$std.estimate.plot[!in_2sigma],
#' pch = 1)
#'
#' @md
#' @export
plot_AbanicoPlot <- function(
data,
na.rm = TRUE,
log.z = TRUE,
z.0 = "mean.weighted",
dispersion = "qr",
plot.ratio = 0.75,
rotate = FALSE,
mtext,
summary,
summary.pos,
summary.method = "MCM",
legend,
legend.pos,
stats,
rug = FALSE,
kde = TRUE,
hist = FALSE,
dots = FALSE,
boxplot = FALSE,
y.axis = TRUE,
error.bars = FALSE,
bar,
bar.col,
polygon.col,
line,
line.col,
line.lty,
line.label,
grid.col,
frame = 1,
bw = "SJ",
interactive = FALSE,
...
) {
.set_function_name("plot_AbanicoPlot")
on.exit(.unset_function_name(), add = TRUE)
## Integrity checks -------------------------------------------------------
## Homogenise input data format
if(is(data, "list") == FALSE) {
data <- list(data)
}
## Check input data
for (i in seq_along(data)) {
.validate_class(data[[i]], c("data.frame", "RLum.Results"),
name = "All elements of 'data'")
if (inherits(data[[i]], "RLum.Results"))
data[[i]] <- get_RLum(data[[i]], "data")
if (ncol(data[[i]]) < 2) {
.throw_error("Data set (", i, ") has fewer than 2 columns: data ",
"without errors cannot be displayed")
}
data[[i]] <- data[[i]][,c(1:2)]
}
## optionally, remove NA-values
if(na.rm == TRUE) {
for(i in seq_along(data)) {
n.NA <- sum(!stats::complete.cases(data[[i]]))
if (n.NA > 0) {
message("[plot_AbanicoPlot()] Data set (", i, "): ", n.NA,
" NA value", ifelse (n.NA > 1, "s", ""), " excluded")
data[[i]] <- na.exclude(data[[i]])
}
}
}
##AFTER NA removal, we should check the data set carefully again ...
##(1)
##check if there is still data left in the entire set
if(all(sapply(data, nrow) == 0)){
.throw_message("'data' is empty, nothing plotted")
return(NULL)
}
##(2)
##check for sets with only 1 row or 0 rows at all
else if(any(sapply(data, nrow) <= 1)){
##select problematic sets and remove the entries from the list
NArm.id <- which(sapply(data, nrow) <= 1)
data[NArm.id] <- NULL
.throw_warning("Data sets ", paste(NArm.id, collapse = ", "),
" are found to be empty or consisting of only 1 row. Sets removed!")
rm(NArm.id)
##unfortunately, the data set might become now empty at all
if(length(data) == 0){
.throw_message("After removing invalid entries, nothing is plotted")
return(NULL)
}
}
## check for zero-error values
for(i in 1:length(data)) {
if(sum(data[[i]][,2] == 0) > 0) {
data[[i]] <- data[[i]][data[[i]][,2] > 0,]
if(nrow(data[[i]]) < 1) {
.throw_error("Data set contains only values with zero errors")
}
.throw_warning("Values with zero errors cannot be displayed and were removed")
}
}
## check for 0 values in dataset for log
if (log.z[1]) {
for(i in 1:length(data)) {
if(any(data[[i]][[1]] == 0)) {
.throw_warning("Found zero values in x-column of dataset ", i, ": set log.z = FALSE")
log.z <- FALSE
}
}
}
## plot.ratio must be numeric and positive
.validate_positive_scalar(plot.ratio)
if (!is.numeric(z.0)) {
.validate_class(z.0, "character")
z.0 <- .validate_args(z.0, c("mean", "mean.weighted", "median"),
extra = "a numerical value")
}
## the 'pnn' option need some special treatment
main.choices <- c("qr", "sd", "2sd")
extra.choice <-"a percentile of the form 'pnn' (eg. 'p05')"
if (!dispersion %in% main.choices && !grepl("^p[0-9][0-9]$", dispersion))
dispersion <- .validate_args(dispersion, main.choices, extra = extra.choice)
## save original plot parameters and restore them upon end or stop
par.old.full <- par(no.readonly = TRUE)
cex_old <- par()$cex
## this ensures par() is respected for several plots on one page
if(sum(par()$mfrow) == 2 & sum(par()$mfcol) == 2){
on.exit(par(par.old.full), add = TRUE)
}
## check/set layout definitions
if(!is.null(list(...)$layout))
layout <- get_Layout(layout = list(...)$layout)
else
layout <- get_Layout(layout = "default")
if(missing(stats))
stats <- numeric(0)
if(missing(bar))
bar <- rep(TRUE, length(data))
if(missing(bar.col)) {
bar.fill <- rep(x = rep(x = layout$abanico$colour$bar.fill,
length.out = length(data)), length(bar))
bar.line <- rep(rep(layout$abanico$colour$bar.line,
length.out = length(data)), length(bar))
} else {
bar.fill <- bar.col
bar.line <- NA
}
if(missing(polygon.col)) {
polygon.fill <- rep(layout$abanico$colour$poly.fill,
length.out = length(data))
polygon.line <- rep(layout$abanico$colour$poly.line,
length.out = length(data))
} else {
polygon.fill <- polygon.col
polygon.line <- NA
}
if(missing(grid.col)) {
grid.major <- layout$abanico$colour$grid.major
grid.minor <- layout$abanico$colour$grid.minor
} else {
if(length(grid.col) == 1) {
grid.major <- grid.col[1]
grid.minor <- grid.col[1]
} else {
grid.major <- grid.col[1]
grid.minor <- grid.col[2]
}
}
if(missing(summary))
summary <- c("n", "in.2s")
if(missing(summary.pos))
summary.pos <- "sub"
if(missing(mtext))
mtext <- ""
## create preliminary global data set
De.global <- data[[1]][,1]
if(length(data) > 1) {
for(i in 2:length(data)) {
De.global <- c(De.global, data[[i]][,1])
}
}
## calculate major preliminary tick values and tick difference
extraArgs <- list(...)
if ("zlim" %in% names(extraArgs) && !is.null(extraArgs$zlim)) {
limits.z <- extraArgs$zlim
.validate_class(limits.z, "numeric", name = "'zlim'")
} else {
z.span <- (mean(De.global) * 0.5) / (sd(De.global) * 100)
z.span <- ifelse(z.span > 1, 0.9, z.span)
limits.z <- c((ifelse(min(De.global) <= 0, 1.1, 0.9) - z.span) *
min(De.global),
(1.1 + z.span) * max(De.global))
}
if("at" %in% names(extraArgs)) {
ticks <- extraArgs$at
} else {
ticks <- round(pretty(limits.z, n = 5), 3)
}
if("breaks" %in% names(extraArgs)) {
breaks <- extraArgs$breaks
} else {
breaks <- "Sturges"
}
## check/set bw-parameter
for(i in 1:length(data)) {
bw.test <- try(density(x = data[[i]][,1],
bw = bw),
silent = TRUE)
if (inherits(bw.test, "try-error")) {
bw <- "nrd0"
.throw_warning("Option for 'bw' not valid, reset to 'nrd0'")
}
}
if ("fun" %in% names(extraArgs)) {
fun <- list(...)$fun # nocov
} else {
fun <- FALSE
}
## check for negative values, stop function, but do not stop
De.add <- 0
if(min(De.global) < 0) {
if("zlim" %in% names(extraArgs)) {
De.add <- abs(extraArgs$zlim[1])
} else {
## estimate delta De to add to all data
De.add <- min(10^ceiling(log10(abs(De.global))) * 10)
## optionally readjust delta De for extreme values
if(De.add <= abs(min(De.global))) {
De.add <- De.add * 10
}
}
}
## optionally add correction dose to data set and adjust error
if(log.z[1]) {
for(i in 1:length(data))
data[[i]][,1] <- data[[i]][,1] + De.add
De.global <- De.global + De.add
}
## calculate and append statistical measures --------------------------------
## z-values based on log-option
z <- lapply(1:length(data), function(x){
if(log.z[1]) {
log(data[[x]][,1])
} else {
data[[x]][,1]
}
})
data <- lapply(1:length(data), function(x) {
cbind(data[[x]], z[[x]])
})
rm(z)
## calculate dispersion based on log-option
se <- lapply(1:length(data), function(x, De.add){
if(log.z == TRUE) {
if(De.add != 0) {
data[[x]][,2] <- data[[x]][,2] / (data[[x]][,1] + De.add)
} else {
data[[x]][,2] / data[[x]][,1]
}
} else {
data[[x]][,2]
}}, De.add = De.add)
data <- lapply(1:length(data), function(x) {
cbind(data[[x]], se[[x]])
})
rm(se)
## calculate initial data statistics
stats.init <- list(NA)
for(i in 1:length(data)) {
stats.init[[length(stats.init) + 1]] <-
calc_Statistics(data = data[[i]][,3:4])
}
stats.init[[1]] <- NULL
## calculate central values
if(z.0 == "mean") {
z.central <- lapply(1:length(data), function(x){
rep(stats.init[[x]]$unweighted$mean,
length(data[[x]][,3]))})
} else if(z.0 == "median") {
z.central <- lapply(1:length(data), function(x){
rep(stats.init[[x]]$unweighted$median,
length(data[[x]][,3]))})
} else if(z.0 == "mean.weighted") {
z.central <- lapply(1:length(data), function(x){
rep(stats.init[[x]]$weighted$mean,
length(data[[x]][,3]))})
} else {
## z.0 is numeric
z.central <- lapply(1:length(data), function(x){
rep(ifelse(log.z == TRUE,
log(z.0),
z.0),
length(data[[x]][,3]))})
}
data <- lapply(1:length(data), function(x) {
cbind(data[[x]], z.central[[x]])})
rm(z.central)
## calculate precision
precision <- lapply(1:length(data), function(x){
1 / data[[x]][,4]})
data <- lapply(1:length(data), function(x) {
cbind(data[[x]], precision[[x]])})
rm(precision)
## calculate standardised estimate
std.estimate <- lapply(1:length(data), function(x){
(data[[x]][,3] - data[[x]][,5]) / data[[x]][,4]})
data <- lapply(1:length(data), function(x) {
cbind(data[[x]], std.estimate[[x]])})
## append empty standard estimate for plotting
data <- lapply(1:length(data), function(x) {
cbind(data[[x]], std.estimate[[x]])})
rm(std.estimate)
## append optional weights for KDE curve
if ("weights" %in% names(extraArgs) && extraArgs$weights == TRUE) {
wgt <- lapply(1:length(data), function(x) {
(1 / data[[x]][,2]) / sum(1 / data[[x]][,2]^2)
})
} else {
wgt <- lapply(1:length(data), function(x) {
rep(1, times = nrow(data[[x]])) / nrow(data[[x]])
})
}
data <- lapply(1:length(data), function(x) {
cbind(data[[x]], wgt[[x]])
})
rm(wgt)
## generate global data set
data.global <- cbind(data[[1]],
rep(x = 1, times = nrow(data[[1]])))
colnames(data.global) <- rep("", 10)
if(length(data) > 1) {
for(i in 2:length(data)) {
data.add <- cbind(data[[i]],
rep(x = i, times = nrow(data[[i]])))
colnames(data.add) <- rep("", 10)
data.global <- rbind(data.global,
data.add)
}
}
## create column names
colnames(data.global) <- c("De",
"error",
"z",
"se",
"z.central",
"precision",
"std.estimate",
"std.estimate.plot",
"weights",
"data set")
## calculate global data statistics
stats.global <- calc_Statistics(data = data.global[,3:4])
## calculate global central value
if(z.0 == "mean") {
z.central.global <- stats.global$unweighted$mean
} else if(z.0 == "median") {
z.central.global <- stats.global$unweighted$median
} else if(z.0 == "mean.weighted") {
z.central.global <- stats.global$weighted$mean
} else if(is.numeric(z.0) == TRUE) {
z.central.global <- ifelse(log.z == TRUE,
log(z.0),
z.0)
}
## create column names
for(i in 1:length(data)) {
colnames(data[[i]]) <- c("De",
"error",
"z",
"se",
"z.central",
"precision",
"std.estimate",
"std.estimate.plot",
"weights")
}
## re-calculate standardised estimate for plotting
for(i in 1:length(data)) {
data[[i]][,8] <- (data[[i]][,3] - z.central.global) / data[[i]][,4]
}
data.global.plot <- data[[1]][,8]
if(length(data) > 1) {
for(i in 2:length(data)) {
data.global.plot <- c(data.global.plot, data[[i]][,8])
}
}
data.global[,8] <- data.global.plot
## print message for too small scatter
if(max(abs(1 / data.global[6])) < 0.02) {
small.sigma <- TRUE
message("[plot_AbanicoPlot()] Attention, small standardised estimate scatter. Toggle off y.axis?")
}
## read out additional arguments---------------------------------------------
extraArgs <- list(...)
main <- if("main" %in% names(extraArgs)) {
extraArgs$main
} else {
expression(paste(D[e], " distribution"))
}
sub <- if("sub" %in% names(extraArgs)) {
extraArgs$sub
} else {
""
}
if("xlab" %in% names(extraArgs)) {
if(length(extraArgs$xlab) != 2) {
if (length(extraArgs$xlab) == 3) {
xlab <- c(extraArgs$xlab[1:2], "Density")
} else {
.throw_error("'xlab' must have length 2")
}
} else {xlab <- c(extraArgs$xlab, "Density")}
} else {
xlab <- c(if(log.z == TRUE) {
"Relative standard error (%)"
} else {
"Standard error"
},
"Precision",
"Density")
}
ylab <- if("ylab" %in% names(extraArgs)) {
extraArgs$ylab
} else {
"Standardised estimate"
}
zlab <- if("zlab" %in% names(extraArgs)) {
extraArgs$zlab
} else {
expression(paste(D[e], " [Gy]"))
}
if ("zlim" %in% names(extraArgs) && !is.null(extraArgs$zlim)) {
limits.z <- extraArgs$zlim
} else {
z.span <- (mean(data.global[,1]) * 0.5) / (sd(data.global[,1]) * 100)
z.span <- ifelse(z.span > 1, 0.9, z.span)
limits.z <- c((0.9 - z.span) * min(data.global[[1]]),
(1.1 + z.span) * max(data.global[[1]]))
}
if ("xlim" %in% names(extraArgs) && !is.null(extraArgs$xlim)) {
limits.x <- extraArgs$xlim
.validate_class(limits.x, "numeric", name = "'xlim'")
} else {
limits.x <- c(0, max(data.global[,6]) * 1.05)
}
if(limits.x[1] != 0) {
.throw_warning("Lower x-axis limit was ", limits.x[1], ", reset to zero")
limits.x[1] <- 0
}
if ("ylim" %in% names(extraArgs) && !is.null(extraArgs$ylim)) {
limits.y <- extraArgs$ylim
.validate_class(limits.y, "numeric", name = "'ylim'")
} else {
y.span <- (mean(data.global[,1]) * 10) / (sd(data.global[,1]) * 100)
y.span <- ifelse(y.span > 1, 0.98, y.span)
limits.y <- c(-(1 + y.span) * max(abs(data.global[,7])),
(1 + y.span) * max(abs(data.global[,7])))
}
cex <- if("cex" %in% names(extraArgs)) {
extraArgs$cex
} else {
1
}
lty <- if("lty" %in% names(extraArgs)) {
extraArgs$lty
} else {
rep(rep(2, length(data)), length(bar))
}
lwd <- if("lwd" %in% names(extraArgs)) {
extraArgs$lwd
} else {
rep(rep(1, length(data)), length(bar))
}
pch <- if("pch" %in% names(extraArgs)) {
extraArgs$pch
} else {
rep(20, length(data))
}
if("col" %in% names(extraArgs)) {
bar.col <- extraArgs$col
kde.line <- extraArgs$col
kde.fill <- NA
value.dot <- extraArgs$col
value.bar <- extraArgs$col
value.rug <- extraArgs$col
summary.col <- extraArgs$col
centrality.col <- extraArgs$col
} else {
bar.col <- layout$abanico$colour$bar.fill
if(length(layout$abanico$colour$bar.fill) == 1) {
bar.col <- 1:length(data)
}
kde.line <- layout$abanico$colour$kde.line
if(length(layout$abanico$colour$kde.line) == 1) {
kde.line <- 1:length(data)
}
kde.fill <- layout$abanico$colour$kde.fill
if(length(layout$abanico$colour$kde.fill) == 1) {
kde.fill <- rep(layout$abanico$colour$kde.fill, length(data))
}
value.dot <- layout$abanico$colour$value.dot
if(length(layout$abanico$colour$value.dot) == 1) {
value.dot <- 1:length(data)
}
value.bar <- layout$abanico$colour$value.bar
if(length(layout$abanico$colour$value.bar) == 1) {
value.bar <- 1:length(data)
}
value.rug <- layout$abanico$colour$value.rug
if(length(layout$abanico$colour$value.rug) == 1) {
value.rug <- 1:length(data)
}
summary.col <- layout$abanico$colour$summary
if(length(layout$abanico$colour$summary) == 1) {
summary.col <- 1:length(data)
}
if(length(layout$abanico$colour$centrality) == 1) {
centrality.col <- rep(x = 1:length(data), times = length(bar))
} else {
centrality.col <- rep(x = layout$abanico$colour$centrality,
times = length(bar))
}
}
## update central line colour
centrality.col <- rep(centrality.col, length(bar))
## define auxiliary plot parameters -----------------------------------------
## set space between z-axis and baseline of cartesian part
if(boxplot[1]) {
lostintranslation <- 1.03
} else {
lostintranslation <- 1.03
plot.ratio <- plot.ratio * 1.05
}
## create empty plot to update plot parameters
if(!rotate[1]) {
plot(NA,
xlim = c(limits.x[1], limits.x[2] * (1 / plot.ratio)),
ylim = limits.y,
main = "",
sub = "",
xlab = "",
ylab = "",
xaxs = "i",
yaxs = "i",
frame.plot = FALSE,
axes = FALSE)
} else {
plot(NA,
xlim = limits.y,
ylim = c(limits.x[1], limits.x[2] * (1 / plot.ratio)),
main = "",
sub = "",
xlab = "",
ylab = "",
xaxs = "i",
yaxs = "i",
frame.plot = FALSE,
axes = FALSE)
}
## calculate conversion factor for plot coordinates
f <- 0
## calculate major and minor z-tick values
if("at" %in% names(extraArgs)) {
tick.values.major <- extraArgs$at
tick.values.minor <- extraArgs$at
} else {
tick.values.major <- signif(pretty(limits.z, n = 5), 3)
tick.values.minor <- signif(pretty(limits.z, n = 25), 3)
}
tick.values.major <- tick.values.major[tick.values.major >=
min(tick.values.minor)]
tick.values.major <- tick.values.major[tick.values.major <=
max(tick.values.minor)]
tick.values.major <- tick.values.major[tick.values.major >=
limits.z[1]]
tick.values.major <- tick.values.major[tick.values.major <=
limits.z[2]]
tick.values.minor <- tick.values.minor[tick.values.minor >=
limits.z[1]]
tick.values.minor <- tick.values.minor[tick.values.minor <=
limits.z[2]]
if(log.z[1]) {
tick.values.major[which(tick.values.major==0)] <- 1
tick.values.minor[which(tick.values.minor==0)] <- 1
tick.values.major <- log(tick.values.major)
tick.values.minor <- log(tick.values.minor)
}
## calculate z-axis radius
r <- max(sqrt((limits.x[2])^2 + (data.global[,7] * f)^2))
## create z-axes labels
if(log.z[1]) {
label.z.text <- signif(exp(tick.values.major) - De.add, 3)
} else {
label.z.text <- signif(tick.values.major, 3)
}
## calculate node coordinates for semi-circle
ellipse.values <- c(min(ifelse(log.z == TRUE,
log(limits.z[1]),
limits.z[1]),
tick.values.major,
tick.values.minor),
max(ifelse(log.z == TRUE,
log(limits.z[2]),
limits.z[2]),
tick.values.major,
tick.values.minor))
## correct for unpleasant value
ellipse.values[ellipse.values == -Inf] <- 0
if(rotate == FALSE) {
ellipse.x <- r / sqrt(1 + f^2 * (ellipse.values - z.central.global)^2)
ellipse.y <- (ellipse.values - z.central.global) * ellipse.x
} else {
ellipse.y <- r / sqrt(1 + f^2 * (ellipse.values - z.central.global)^2)
ellipse.x <- (ellipse.values - z.central.global) * ellipse.y
}
ellipse <- cbind(ellipse.x, ellipse.y)
## calculate statistical labels
if(length(stats == 1)) {stats <- rep(stats, 2)}
stats.data <- matrix(nrow = 3, ncol = 3)
data.stats <- as.numeric(data.global[,1])
if("min" %in% stats == TRUE) {
stats.data[1, 3] <- data.stats[data.stats == min(data.stats)][1]
stats.data[1, 1] <- data.global[data.stats == stats.data[1, 3], 6][1]
stats.data[1, 2] <- data.global[data.stats == stats.data[1, 3], 8][1]
}
if("max" %in% stats == TRUE) {
stats.data[2, 3] <- data.stats[data.stats == max(data.stats)][1]
stats.data[2, 1] <- data.global[data.stats == stats.data[2, 3], 6][1]
stats.data[2, 2] <- data.global[data.stats == stats.data[2, 3], 8][1]
}
if("median" %in% stats == TRUE) {
stats.data[3, 3] <- data.stats[data.stats == quantile(data.stats, 0.5, type = 3)]
stats.data[3, 1] <- data.global[data.stats == stats.data[3, 3], 6][1]
stats.data[3, 2] <- data.global[data.stats == stats.data[3, 3], 8][1]
}
## re-calculate axes limits if necessary
if(rotate == FALSE) {
limits.z.x <- range(ellipse[,1])
limits.z.y <- range(ellipse[,2])
} else {
limits.z.x <- range(ellipse[,2])
limits.z.y <- range(ellipse[,1])
}
if(!("ylim" %in% names(extraArgs))) {
if(limits.z.y[1] < 0.66 * limits.y[1]) {
limits.y[1] <- 1.8 * limits.z.y[1]
}
if(limits.z.y[2] > 0.77 * limits.y[2]) {
limits.y[2] <- 1.3 * limits.z.y[2]
}
if(rotate == TRUE) {
limits.y <- c(-max(abs(limits.y)), max(abs(limits.y)))
}
}
if(!("xlim" %in% names(extraArgs))) {
if(limits.z.x[2] > 1.1 * limits.x[2]) {
limits.x[2] <- limits.z.x[2]
}
}
## calculate and paste statistical summary
De.stats <- matrix(nrow = length(data), ncol = 12)
colnames(De.stats) <- c("n",
"mean",
"median",
"kde.max",
"sd.abs",
"sd.rel",
"se.abs",
"se.rel",
"q.25",
"q.75",
"skewness",
"kurtosis")
for(i in 1:length(data)) {
statistics <- calc_Statistics(data[[i]])[[summary.method]]
statistics.2 <- calc_Statistics(data[[i]][,3:4])[[summary.method]]
De.stats[i,1] <- statistics$n
De.stats[i,2] <- statistics.2$mean
De.stats[i,3] <- statistics.2$median
De.stats[i,5] <- statistics$sd.abs
De.stats[i,6] <- statistics$sd.rel
De.stats[i,7] <- statistics$se.abs
De.stats[i,8] <- statistics$se.rel
De.stats[i,9] <- quantile(data[[i]][,1], 0.25)
De.stats[i,10] <- quantile(data[[i]][,1], 0.75)
De.stats[i,11] <- statistics$skewness
De.stats[i,12] <- statistics$kurtosis
## account for log.z-option
if(log.z[1]) {
De.stats[i,2:4] <- exp(De.stats[i,2:4]) - De.add
}
## kdemax - here a little doubled as it appears below again
De.density <- try(density(x = data[[i]][,1],
kernel = "gaussian",
bw = bw,
from = limits.z[1],
to = limits.z[2]),
silent = TRUE)
if(inherits(De.density, "try-error")) {
De.stats[i,4] <- NA
} else {
De.stats[i,4] <- De.density$x[which.max(De.density$y)]
}
}
label.text = list(NA)
if(summary.pos[1] != "sub") {
n.rows <- length(summary)
for(i in 1:length(data)) {
stops <- paste(rep("\n", (i - 1) * n.rows), collapse = "")
summary.text <- character(0)
for(j in 1:length(summary)) {
summary.text <- c(summary.text,
paste(
"",
ifelse("n" %in% summary[j] == TRUE,
paste("n = ",
De.stats[i,1],
"\n",
sep = ""),
""),
ifelse("mean" %in% summary[j] == TRUE,
paste("mean = ",
round(De.stats[i,2], 2),
"\n",
sep = ""),
""),
ifelse("median" %in% summary[j] == TRUE,
paste("median = ",
round(De.stats[i,3], 2),
"\n",
sep = ""),
""),
ifelse("kde.max" %in% summary[j] == TRUE,
paste("kdemax = ",
round(De.stats[i,4], 2),
" \n ",
sep = ""),
""),
ifelse("sd.abs" %in% summary[j] == TRUE,
paste("abs. sd = ",
round(De.stats[i,5], 2),
"\n",
sep = ""),
""),
ifelse("sd.rel" %in% summary[j] == TRUE,
paste("rel. sd = ",
round(De.stats[i,6], 2), " %",
"\n",
sep = ""),
""),
ifelse("se.abs" %in% summary[j] == TRUE,
paste("se = ",
round(De.stats[i,7], 2),
"\n",
sep = ""),
""),
ifelse("se.rel" %in% summary[j] == TRUE,
paste("rel. se = ",
round(De.stats[i,8], 2), " %",
"\n",
sep = ""),
""),
ifelse("skewness" %in% summary[j] == TRUE,
paste("skewness = ",
round(De.stats[i,11], 2),
"\n",
sep = ""),
""),
ifelse("kurtosis" %in% summary[j] == TRUE,
paste("kurtosis = ",
round(De.stats[i,12], 2),
"\n",
sep = ""),
""),
ifelse("in.2s" %in% summary[j] == TRUE,
paste("in 2 sigma = ",
round(sum(data[[i]][,7] > -2 &
data[[i]][,7] < 2) /
nrow(data[[i]]) * 100 , 1),
" %",
sep = ""),
""),
sep = ""))
}
summary.text <- paste(summary.text, collapse = "")
label.text[[length(label.text) + 1]] <- paste(stops,
summary.text,
stops,
sep = "")
}
} else {
for(i in 1:length(data)) {
summary.text <- character(0)
for(j in 1:length(summary)) {
summary.text <- c(summary.text,
ifelse("n" %in% summary[j] == TRUE,
paste("n = ",
De.stats[i,1],
" | ",
sep = ""),
""),
ifelse("mean" %in% summary[j] == TRUE,
paste("mean = ",
round(De.stats[i,2], 2),
" | ",
sep = ""),
""),
ifelse("median" %in% summary[j] == TRUE,
paste("median = ",
round(De.stats[i,3], 2),
" | ",
sep = ""),
""),
ifelse("kde.max" %in% summary[j] == TRUE,
paste("kdemax = ",
round(De.stats[i,4], 2),
" | ",
sep = ""),
""),
ifelse("sd.abs" %in% summary[j] == TRUE,
paste("abs. sd = ",
round(De.stats[i,5], 2),
" | ",
sep = ""),
""),
ifelse("sd.rel" %in% summary[j] == TRUE,
paste("rel. sd = ",
round(De.stats[i,6], 2), " %",
" | ",
sep = ""),
""),
ifelse("se.abs" %in% summary[j] == TRUE,
paste("abs. se = ",
round(De.stats[i,7], 2),
" | ",
sep = ""),
""),
ifelse("se.rel" %in% summary[j] == TRUE,
paste("rel. se = ",
round(De.stats[i,8], 2), " %",
" | ",
sep = ""),
""),
ifelse("skewness" %in% summary[j] == TRUE,
paste("skewness = ",
round(De.stats[i,11], 2),
" | ",
sep = ""),
""),
ifelse("kurtosis" %in% summary[j] == TRUE,
paste("kurtosis = ",
round(De.stats[i,12], 2),
" | ",
sep = ""),
""),
ifelse("in.2s" %in% summary[j] == TRUE,
paste("in 2 sigma = ",
round(sum(data[[i]][,7] > -2 &
data[[i]][,7] < 2) /
nrow(data[[i]]) * 100 , 1),
" % | ",
sep = ""),
"")
)
}
summary.text <- paste(summary.text, collapse = "")
label.text[[length(label.text) + 1]] <- paste(
" ",
summary.text,
sep = "")
}
## remove outer vertical lines from string
for(i in 2:length(label.text)) {
label.text[[i]] <- substr(x = label.text[[i]],
start = 3,
stop = nchar(label.text[[i]]) - 3)
}
}
## remove dummy list element
label.text[[1]] <- NULL
if(!rotate[1]) {
## convert keywords into summary placement coordinates
coords <- .get_keyword_coordinates(summary.pos, limits.x, limits.y)
## apply some adjustments to the y positioning
if (!missing(summary.pos)) {
if (summary.pos[1] %in% c("topleft", "top", "topright")) {
coords$pos[2] <- coords$pos[2] - par()$cxy[2] * 1.0
} else if (summary.pos[1] %in% c("bottomleft", "bottom", "bottomright")) {
coords$pos[2] <- coords$pos[2] + par()$cxy[2] * 3.5
}
}
summary.pos <- coords$pos
summary.adj <- coords$adj
## convert keywords into legend placement coordinates
coords <- .get_keyword_coordinates(legend.pos, limits.x, limits.y)
legend.pos <- coords$pos
legend.adj <- coords$adj
} else {
## convert keywords into summary placement coordinates
## this time we swap x and y limits as we are rotated, then apply some
## adjustments to the x positioning
coords <- .get_keyword_coordinates(summary.pos, limits.y, limits.x)
if (!missing(summary.pos) &&
summary.pos[1] %in% c("topleft", "left", "bottomleft")) {
coords$pos[1] <- coords$pos[1] + par()$cxy[1] * 7.5
}
summary.pos <- coords$pos
summary.adj <- coords$adj
## convert keywords into legend placement coordinates
## this time we swap x and y limits as we are rotated, then apply some
## adjustments to the x positioning
coords <- .get_keyword_coordinates(legend.pos, limits.y, limits.x)
if (!missing(legend.pos) &&
legend.pos[1] %in% c("topleft", "left", "bottomleft")) {
coords$pos[1] <- coords$pos[1] + par()$cxy[1] * 7.5
}
legend.pos <- coords$pos
legend.adj <- coords$adj
}
## define cartesian plot origins
if(rotate == FALSE) {
xy.0 <- c(min(ellipse[,1]) * lostintranslation, min(ellipse[,2]))
} else {
xy.0 <- c(min(ellipse[,1]), min(ellipse[,2]) * lostintranslation)
}
## calculate coordinates for dispersion polygon overlay
y.max.x <- 2 * limits.x[2] / max(data.global[6])
polygons <- matrix(nrow = length(data), ncol = 14)
for(i in 1:length(data)) {
if(dispersion == "qr") {
ci.lower <- quantile(data[[i]][,1], 0.25)
ci.upper <- quantile(data[[i]][,1], 0.75)
} else if(grepl(x = dispersion, pattern = "p") == TRUE) {
ci.plot <- as.numeric(strsplit(x = dispersion,
split = "p")[[1]][2])
ci.plot <- (100 - ci.plot) / 100
ci.lower <- quantile(data[[i]][,1], ci.plot)
ci.upper <- quantile(data[[i]][,1], 1 - ci.plot)
} else if(dispersion == "sd") {
if(log.z == TRUE) {
ci.lower <- exp(mean(log(data[[i]][,1])) - sd(log(data[[i]][,1])))
ci.upper <- exp(mean(log(data[[i]][,1])) + sd(log(data[[i]][,1])))
} else {
ci.lower <- mean(data[[i]][,1]) - sd(data[[i]][,1])
ci.upper <- mean(data[[i]][,1]) + sd(data[[i]][,1])
}
} else if(dispersion == "2sd") {
if(log.z == TRUE) {
ci.lower <- exp(mean(log(data[[i]][,1])) - 2 * sd(log(data[[i]][,1])))
ci.upper <- exp(mean(log(data[[i]][,1])) + 2 * sd(log(data[[i]][,1])))
} else {
ci.lower <- mean(data[[i]][,1]) - 2 * sd(data[[i]][,1])
ci.upper <- mean(data[[i]][,1]) + 2 * sd(data[[i]][,1])
}
}
if(log.z == TRUE) {
ci.lower[which(ci.lower < 0)] <- 1
y.lower <- log(ci.lower)
y.upper <- log(ci.upper)
} else {
y.lower <- ci.lower
y.upper <- ci.upper
}
if(rotate == FALSE) {
polygons[i,1:7] <- c(limits.x[1],
limits.x[2],
xy.0[1],
par()$usr[2],
par()$usr[2],
xy.0[1],
limits.x[2])
polygons[i,8:14] <- c(0,
(y.upper - z.central.global) *
limits.x[2],
(y.upper - z.central.global) *
xy.0[1],
(y.upper - z.central.global) *
xy.0[1],
(y.lower - z.central.global) *
xy.0[1],
(y.lower - z.central.global) *
xy.0[1],
(y.lower - z.central.global) *
limits.x[2]
)
} else {
y.max <- par()$usr[4]
polygons[i,1:7] <- c(limits.x[1],
limits.x[2],
xy.0[2],
y.max,
y.max,
xy.0[2],
limits.x[2])
polygons[i,8:14] <- c(0,
(y.upper - z.central.global) *
limits.x[2],
(y.upper - z.central.global) *
xy.0[2],
(y.upper - z.central.global) *
xy.0[2],
(y.lower - z.central.global) *
xy.0[2],
(y.lower - z.central.global) *
xy.0[2],
(y.lower - z.central.global) *
limits.x[2]
)
}
}
## append information about data in confidence interval
for(i in 1:length(data)) {
data.in.2s <- rep(x = FALSE, times = nrow(data[[i]]))
data.in.2s[data[[i]][,8] > -2 & data[[i]][,8] < 2] <- TRUE
data[[i]] <- cbind(data[[i]], data.in.2s)
}
## calculate coordinates for 2-sigma bar overlay
if(bar[1] == TRUE) {
bars <- matrix(nrow = length(data), ncol = 8)
for(i in 1:length(data)) {
bars[i,1:4] <- c(limits.x[1],
limits.x[1],
ifelse("xlim" %in% names(extraArgs),
extraArgs$xlim[2] * 0.95,
max(data.global$precision)),
ifelse("xlim" %in% names(extraArgs),
extraArgs$xlim[2] * 0.95,
max(data.global$precision)))
bars[i,5:8] <- c(-2,
2,
(data[[i]][1,5] - z.central.global) *
bars[i,3] + 2,
(data[[i]][1,5] - z.central.global) *
bars[i,3] - 2)
}
} else {
bars <- matrix(nrow = length(bar), ncol = 8)
if(is.numeric(bar) == TRUE & log.z == TRUE) {
bar <- log(bar)
}
for(i in 1:length(bar)) {
bars[i,1:4] <- c(limits.x[1],
limits.x[1],
ifelse("xlim" %in% names(extraArgs),
extraArgs$xlim[2] * 0.95,
max(data.global$precision)),
ifelse("xlim" %in% names(extraArgs),
extraArgs$xlim[2] * 0.95,
max(data.global$precision)))
bars[i,5:8] <- c(-2,
2,
(bar[i] - z.central.global) *
bars[i,3] + 2,
(bar[i] - z.central.global) *
bars[i,3] - 2)
}
}
if (rotate == TRUE) {
bars <- matrix(bars[, rev(seq_len(ncol(bars)))], ncol = 8)
}
## calculate error bar coordinates
if(error.bars == TRUE) {
arrow.coords <- list(NA)
for(i in 1:length(data)) {
arrow.x1 <- data[[i]][,6]
arrow.x2 <- data[[i]][,6]
arrow.y1 <- data[[i]][,1] - data[[i]][,2]
arrow.y2 <- data[[i]][,1] + data[[i]][,2]
if(log.z == TRUE) {
arrow.y1 <- log(arrow.y1)
arrow.y2 <- log(arrow.y2)
}
arrow.coords[[length(arrow.coords) + 1]] <- cbind(
arrow.x1,
arrow.x2,
(arrow.y1 - z.central.global) * arrow.x1,
(arrow.y2 - z.central.global) * arrow.x1)
}
arrow.coords[[1]] <- NULL
}
## calculate KDE
KDE <- list(NA)
KDE.ext <- 0
KDE.bw <- numeric(0)
for(i in 1:length(data)) {
KDE.i <- density(x = data[[i]][,3],
kernel = "gaussian",
bw = bw,
from = ellipse.values[1],
to = ellipse.values[2],
weights = data[[i]]$weights)
KDE.xy <- cbind(KDE.i$x, KDE.i$y)
KDE.bw <- c(KDE.bw, KDE.i$bw)
KDE.ext <- ifelse(max(KDE.xy[,2]) < KDE.ext, KDE.ext, max(KDE.xy[,2]))
KDE.xy <- rbind(c(min(KDE.xy[,1]), 0), KDE.xy, c(max(KDE.xy[,1]), 0))
KDE[[length(KDE) + 1]] <- cbind(KDE.xy[,1], KDE.xy[,2])
}
KDE[1] <- NULL
## calculate mean KDE bandwidth
KDE.bw <- mean(KDE.bw, na.rm = TRUE)
## calculate max KDE value for labelling
KDE.max.plot <- numeric(length(data))
for(i in 1:length(data)) {
KDE.plot <- density(x = data[[i]][,1],
kernel = "gaussian",
bw = bw,
from = limits.z[1],
to = limits.z[2])
KDE.max.plot[i] <- max(KDE.plot$y)
}
KDE.max.plot <- max(KDE.max.plot, na.rm = TRUE)
## calculate histogram data without plotting
## create dummy list
hist.data <- list(NA)
for(i in 1:length(data)) {
hist.i <- hist(x = data[[i]][,3],
plot = FALSE,
breaks = breaks)
hist.data[[length(hist.data) + 1]] <- hist.i
}
## remove dummy list object
hist.data[[1]] <- NULL
## calculate maximum histogram bar height for normalisation
hist.max.plot <- numeric(length(data))
for(i in 1:length(data)) {
hist.max.plot <- ifelse(max(hist.data[[i]]$counts, na.rm = TRUE) >
hist.max.plot, max(hist.data[[i]]$counts,
na.rm = TRUE), hist.max.plot)
}
hist.max.plot <- max(hist.max.plot, na.rm = TRUE)
## normalise histogram bar height to KDE dimensions
for(i in 1:length(data)) {
hist.data[[i]]$density <- hist.data[[i]]$counts / hist.max.plot *
KDE.max.plot
}
## calculate boxplot data without plotting
## create dummy list
boxplot.data <- list(NA)
for(i in 1:length(data)) {
boxplot.i <- graphics::boxplot(x = data[[i]][, 3],
plot = FALSE)
boxplot.data[[length(boxplot.data) + 1]] <- boxplot.i
}
## remove dummy list object
boxplot.data[[1]] <- NULL
## calculate line coordinates and further parameters
if(missing(line) == FALSE) {
## check if line parameters are R.Lum-objects
for(i in 1:length(line)) {
if(is.list(line) == TRUE) {
if(is(line[[i]], "RLum.Results")) {
line[[i]] <- as.numeric(get_RLum(object = line[[i]],
data.object = "summary")$de)
}
} else if(is(object = line, class2 = "RLum.Results")) {
line <- as.numeric(get_RLum(object = line,
data.object = "summary")$de)
}
}
## convert list to vector
if(is.list(line) == TRUE) {
line <- unlist(line)
}
if(log.z == TRUE) {
line <- log(line)
}
line.coords <- list(NA)
if(rotate == FALSE) {
for(i in 1:length(line)) {
line.x <- c(limits.x[1], min(ellipse[,1]), par()$usr[2])
line.y <- c(0,
(line[i] - z.central.global) * min(ellipse[,1]),
(line[i] - z.central.global) * min(ellipse[,1]))
line.coords[[length(line.coords) + 1]] <- rbind(line.x, line.y)
}
} else {
for(i in 1:length(line)) {
line.x <- c(limits.x[1], min(ellipse[,2]),y.max)
line.y <- c(0,
(line[i] - z.central.global) * min(ellipse[,2]),
(line[i] - z.central.global) * min(ellipse[,2]))
line.coords[[length(line.coords) + 1]] <- rbind(line.x, line.y)
}
}
line.coords[1] <- NULL
if(missing(line.col) == TRUE) {
line.col <- seq(from = 1, to = length(line.coords))
}
if(missing(line.lty) == TRUE) {
line.lty <- rep(1, length(line.coords))
}
if(missing(line.label) == TRUE) {
line.label <- rep("", length(line.coords))
}
}
## calculate rug coordinates
if(missing(rug) == FALSE) {
if(log.z == TRUE) {
rug.values <- log(De.global)
} else {
rug.values <- De.global
}
rug.coords <- list(NA)
if(rotate == FALSE) {
for(i in 1:length(rug.values)) {
rug.x <- c(xy.0[1] * (1 - 0.013 * (layout$abanico$dimension$rugl / 100)),
xy.0[1])
rug.y <- c((rug.values[i] - z.central.global) * min(ellipse[,1]),
(rug.values[i] - z.central.global) * min(ellipse[,1]))
rug.coords[[length(rug.coords) + 1]] <- rbind(rug.x, rug.y)
}
} else {
for(i in 1:length(rug.values)) {
rug.x <- c(xy.0[2] * (1 - 0.013 * (layout$abanico$dimension$rugl / 100)),
xy.0[2])
rug.y <- c((rug.values[i] - z.central.global) * min(ellipse[,2]),
(rug.values[i] - z.central.global) * min(ellipse[,2]))
rug.coords[[length(rug.coords) + 1]] <- rbind(rug.x, rug.y)
}
}
rug.coords[1] <- NULL
}
## Generate plot ------------------------------------------------------------
##
## determine number of subheader lines to shift the plot
if(length(summary) > 0 & summary.pos[1] == "sub") {
shift.lines <- (length(data) + 1) * layout$abanico$dimension$summary.line/100
} else {
shift.lines <- 1
}
## extract original plot parameters
bg.original <- par()$bg
on.exit(par(bg = bg.original), add = TRUE)
par(bg = layout$abanico$colour$background)
if(!rotate[1]) {
## setup plot area
par(mar = c(4.5, 4.5, shift.lines + 1.5, 7),
xpd = TRUE,
cex = cex)
dim <- layout$abanico$dimension
if (dim$figure.width != "auto" || dim$figure.height != "auto") {
par(mai = dim$margin / 25.4,
pin = c(dim$figure.width - dim$margin[2] - dim$margin[4],
dim$figure.height - dim$margin[1] - dim$margin[3]) / 25.4)
}
## create empty plot
par(new = TRUE)
plot(NA,
xlim = c(limits.x[1], limits.x[2] * (1 / plot.ratio)),
ylim = limits.y,
main = "",
sub = sub,
xlab = "",
ylab = "",
xaxs = "i",
yaxs = "i",
frame.plot = FALSE,
axes = FALSE)
## add y-axis label
mtext(text = ylab,
at = mean(x = c(min(ellipse[,2]),
max(ellipse[,2])),
na.rm = TRUE),
# at = 0, ## BUG FROM VERSION 0.4.0, maybe removed in future
adj = 0.5,
side = 2,
line = 3 * layout$abanico$dimension$ylab.line / 100,
col = layout$abanico$colour$ylab,
family = layout$abanico$font.type$ylab,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$ylab)[1],
cex = cex * layout$abanico$font.size$ylab/12)
## calculate upper x-axis label values
label.x.upper <- if(log.z == TRUE) {
as.character(round(1/axTicks(side = 1)[-1] * 100, 1))
} else {
as.character(round(1/axTicks(side = 1)[-1], 1))
}
# optionally, plot 2-sigma-bar
if(bar[1] != FALSE) {
for(i in 1:length(bar)) {
polygon(x = bars[i,1:4],
y = bars[i,5:8],
col = bar.fill[i],
border = bar.line[i])
}
}
## remove unwanted parts
polygon(x = c(par()$usr[2],
par()$usr[2],
par()$usr[2] * 2,
par()$usr[2] * 2),
y = c(min(ellipse[,2]) * 2,
max(ellipse[,2]) * 2,
max(ellipse[,2]) * 2,
min(ellipse[,2]) * 2),
col = bg.original,
lty = 0)
## optionally, plot dispersion polygon
if(polygon.fill[1] != "none") {
for(i in 1:length(data)) {
polygon(x = polygons[i,1:7],
y = polygons[i,8:14],
col = polygon.fill[i],
border = polygon.line[i])
}
}
## optionally, add minor grid lines
if(grid.minor != "none") {
for(i in 1:length(tick.values.minor)) {
lines(x = c(limits.x[1], min(ellipse[,1])),
y = c(0, (tick.values.minor[i] - z.central.global) *
min(ellipse[,1])),
col = grid.minor,
lwd = 1)
}
for(i in 1:length(tick.values.minor)) {
lines(x = c(xy.0[1], par()$usr[2]),
y = c((tick.values.minor[i] - z.central.global) *
min(ellipse[,1]),
(tick.values.minor[i] - z.central.global) *
min(ellipse[,1])),
col = grid.minor,
lwd = 1)
}
}
## optionally, add major grid lines
if(grid.major != "none") {
for(i in 1:length(tick.values.major)) {
lines(x = c(limits.x[1], min(ellipse[,1])),
y = c(0, (tick.values.major[i] - z.central.global) *
min(ellipse[,1])),
col = grid.major,
lwd = 1)
}
for(i in 1:length(tick.values.major)) {
lines(x = c(xy.0[1], par()$usr[2]),
y = c((tick.values.major[i] - z.central.global) *
min(ellipse[,1]),
(tick.values.major[i] - z.central.global) *
min(ellipse[,1])),
col = grid.major,
lwd = 1)
}
}
## optionally, plot lines for each bar
if(lwd[1] > 0 & lty[1] > 0 & bar[1] != FALSE & length(data) == 1) {
if(bar[1] == TRUE & length(bar) == 1) {
bar[1] <- z.central.global
}
for(i in 1:length(bar)) {
x2 <- r / sqrt(1 + f^2 * (
bar[i] - z.central.global)^2)
y2 <- (bar[i] - z.central.global) * x2
lines(x = c(limits.x[1], x2, xy.0[1], par()$usr[2]),
y = c(0, y2, y2, y2),
lty = lty[i],
lwd = lwd[i],
col = centrality.col[i])
}
} else if(lwd[1] > 0 & lty[1] > 0 & bar[1] != FALSE) {
for(i in 1:length(data)) {
z.line <- ifelse(test = is.numeric(bar[i]) == TRUE,
yes = bar[i],
no = data[[i]][1,5])
x2 <- r / sqrt(1 + f^2 * (
z.line - z.central.global)^2)
y2 <- (z.line - z.central.global) * x2
lines(x = c(limits.x[1], x2, xy.0[1], par()$usr[2]),
y = c(0, y2, y2, y2),
lty = lty[i],
lwd = lwd[i],
col = centrality.col[i])
}
}
## optionally add further lines
if(!missing(line)) {
for(i in 1:length(line)) {
lines(x = line.coords[[i]][1,1:3],
y = line.coords[[i]][2,1:3],
col = line.col[i],
lty = line.lty[i]
)
text(x = line.coords[[i]][1,3],
y = line.coords[[i]][2,3] + par()$cxy[2] * 0.3,
labels = line.label[i],
pos = 2,
col = line.col[i],
cex = cex * 0.9)
}
}
## add plot title
cex.old <- par()$cex
par(cex = layout$abanico$font.size$main / 12)
title(main = main,
family = layout$abanico$font.type$main,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$main)[1],
col.main = layout$abanico$colour$main,
line = shift.lines * layout$abanico$dimension$main / 100)
par(cex = cex.old)
## calculate lower x-axis (precision)
x.axis.ticks <- axTicks(side = 1)
x.axis.ticks <- x.axis.ticks[c(TRUE, x.axis.ticks <= limits.x[2])]
x.axis.ticks <- x.axis.ticks[x.axis.ticks <= max(ellipse[,1])]
## x-axis with lables and ticks
axis(side = 1,
at = x.axis.ticks,
col = layout$abanico$colour$xtck1,
col.axis = layout$abanico$colour$xtck1,
labels = NA,
tcl = -layout$abanico$dimension$xtcl1 / 200,
cex = cex)
axis(side = 1,
at = x.axis.ticks,
line = 2 * layout$abanico$dimension$xtck1.line / 100 - 2,
lwd = 0,
col = layout$abanico$colour$xtck1,
family = layout$abanico$font.type$xtck1,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xtck1)[1],
col.axis = layout$abanico$colour$xtck1,
cex.axis = layout$abanico$font.size$xlab1/12)
## extend axis line to right side of the plot
lines(x = c(max(x.axis.ticks), max(ellipse[,1])),
y = c(limits.y[1], limits.y[1]),
col = layout$abanico$colour$xtck1)
## draw closing tick on right hand side
axis(side = 1,
tcl = -layout$abanico$dimension$xtcl1 / 200,
lwd = 0,
lwd.ticks = 1,
at = limits.x[2],
labels = FALSE,
col = layout$abanico$colour$xtck1)
axis(side = 1,
tcl = layout$abanico$dimension$xtcl2 / 200,
lwd = 0,
lwd.ticks = 1,
at = limits.x[2],
labels = FALSE,
col = layout$abanico$colour$xtck2)
## add lower axis label
mtext(xlab[2],
at = (limits.x[1] + max(ellipse[,1])) / 2,
side = 1,
line = 2.5 * layout$abanico$dimension$xlab1.line / 100,
col = layout$abanico$colour$xlab1,
family = layout$abanico$font.type$xlab1,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xlab1)[1],
cex = cex * layout$abanico$font.size$xlab1/12)
## add upper axis label
mtext(xlab[1],
at = (limits.x[1] + max(ellipse[,1])) / 2,
side = 1,
line = -3.5 * layout$abanico$dimension$xlab2.line / 100,
col = layout$abanico$colour$xlab2,
family = layout$abanico$font.type$xlab2,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xlab2)[1],
cex = cex * layout$abanico$font.size$xlab2/12)
## plot upper x-axis
axis(side = 1,
at = x.axis.ticks[-1],
col = layout$abanico$colour$xtck2,
col.axis = layout$abanico$colour$xtck2,
labels = NA,
tcl = layout$abanico$dimension$xtcl2 / 200,
cex = cex)
## remove first tick label (infinity)
label.x.upper <- label.x.upper[1:(length(x.axis.ticks) - 1)]
axis(side = 1,
at = x.axis.ticks[-1],
labels = label.x.upper,
line = -1 * layout$abanico$dimension$xtck2.line / 100 - 2,
lwd = 0,
col = layout$abanico$colour$xtck2,
family = layout$abanico$font.type$xtck2,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xtck2)[1],
col.axis = layout$abanico$colour$xtck2,
cex.axis = layout$abanico$font.size$xlab2/12)
## plot y-axis
if(is.null(extraArgs$yaxt) || extraArgs$yaxt != "n"){
line <- 2 * layout$abanico$dimension$ytck.line / 100 - 2
family <- layout$abanico$font.type$ytck
font <- which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$ytck)[1]
col.axis <- layout$abanico$colour$ytck
cex.axis <- layout$abanico$font.size$ylab/12
if(y.axis) {
char.height <- par()$cxy[2]
tick.space <- grDevices::axisTicks(usr = limits.y, log = FALSE)
tick.space <- (max(tick.space) - min(tick.space)) / length(tick.space)
## this comes into play for panel plots, e.g., par(mfrow = c(4,4))
if(tick.space < char.height * 1.7) {
axis(side = 2,
tcl = -layout$abanico$dimension$ytcl / 200,
lwd = 1,
lwd.ticks = 1,
at = c(-2, 2),
labels = c("", ""),
las = 1,
col = layout$abanico$colour$ytck)
axis(side = 2,
at = 0,
tcl = 0,
labels = paste("\u00B1", "2"),
line = line, las = 1,
family = family, font = font,
col.axis = col.axis, cex.axis = cex.axis)
} else {
axis(side = 2,
at = seq(-2, 2, by = 2),
col = layout$abanico$colour$ytck,
col.axis = layout$abanico$colour$ytck,
labels = NA,
las = 1,
tcl = -layout$abanico$dimension$ytcl / 200,
cex = cex)
axis(side = 2,
at = seq(-2, 2, by = 2),
col = layout$abanico$colour$ytck,
line = line, lwd = 0, las = 1,
family = family, font = font,
col.axis = col.axis, cex.axis = cex.axis)
}
} else {
axis(side = 2,
at = 0,
col = layout$abanico$colour$ytck,
col.axis = layout$abanico$colour$ytck,
labels = NA,
las = 1,
tcl = -layout$abanico$dimension$ytcl / 200,
cex = cex)
axis(side = 2,
at = 0,
col = layout$abanico$colour$ytck,
line = line, lwd = 0, las = 1,
family = family, font = font,
col.axis = col.axis, cex.axis = cex.axis)
}
}
## plot minor z-ticks
for(i in 1:length(tick.values.minor)) {
lines(x = c(par()$usr[2],
(1 + 0.007 * cex * layout$abanico$dimension$ztcl / 100) *
par()$usr[2]),
y = c((tick.values.minor[i] - z.central.global) *
min(ellipse[,1]),
(tick.values.minor[i] - z.central.global) *
min(ellipse[,1])),
col = layout$abanico$colour$ztck)
}
## plot major z-ticks
for(i in 1:length(tick.values.major)) {
lines(x = c(par()$usr[2],
(1 + 0.015 * cex * layout$abanico$dimension$ztcl / 100) *
par()$usr[2]),
y = c((tick.values.major[i] - z.central.global) *
min(ellipse[,1]),
(tick.values.major[i] - z.central.global) *
min(ellipse[,1])),
col = layout$abanico$colour$ztck)
}
## plot z-axes
lines(ellipse, col = layout$abanico$colour$border)
lines(rep(par()$usr[2], nrow(ellipse)), ellipse[,2],
col = layout$abanico$colour$ztck)
## plot z-axis text
text(x = (1 + 0.04 * cex * layout$abanico$dimension$ztcl / 100) *
par()$usr[2],
y = (tick.values.major - z.central.global) * min(ellipse[,1]),
labels = label.z.text,
adj = 0,
family = layout$abanico$font.type$ztck,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$ztck)[1],
cex = cex * layout$abanico$font.size$ztck/12)
## plot z-label
mtext(text = zlab,
at = mean(x = c(min(ellipse[,2]),
max(ellipse[,2])),
na.rm = TRUE),
# at = 0, ## BUG from version 0.4.0, maybe removed in future
side = 4,
las = 3,
adj = 0.5,
line = 5 * layout$abanico$dimension$zlab.line / 100,
col = layout$abanico$colour$zlab,
family = layout$abanico$font.type$zlab,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$zlab)[1],
cex = cex * layout$abanico$font.size$zlab/12)
## plot values and optionally error bars
if(error.bars == TRUE) {
for(i in 1:length(data)) {
graphics::arrows(x0 = arrow.coords[[i]][,1],
x1 = arrow.coords[[i]][,2],
y0 = arrow.coords[[i]][,3],
y1 = arrow.coords[[i]][,4],
length = 0,
angle = 90,
code = 3,
col = value.bar[i])
}
}
for(i in 1:length(data)) {
points(data[[i]][,6][data[[i]][,6] <= limits.x[2]],
data[[i]][,8][data[[i]][,6] <= limits.x[2]],
col = value.dot[i],
pch = pch[i],
cex = layout$abanico$dimension$pch / 100)
}
## calculate KDE width
KDE.max <- 0
for(i in 1:length(data)) {
KDE.max <- ifelse(test = KDE.max < max(KDE[[i]][,2]),
yes = max(KDE[[i]][,2]),
no = KDE.max)
}
## optionally adjust KDE width for boxplot option
if(boxplot == TRUE) {
KDE.max <- 1.25 * KDE.max
}
KDE.scale <- (par()$usr[2] - xy.0[1]) / (KDE.max * 1.05)
## optionally add KDE plot
if(kde == TRUE) {
## plot KDE lines
for(i in 1:length(data)) {
polygon(x = xy.0[1] + KDE[[i]][,2] * KDE.scale,
y = (KDE[[i]][,1] - z.central.global) * min(ellipse[,1]),
col = kde.fill[i],
border = kde.line[i],
lwd = 1.7)
}
## plot KDE x-axis
axis(side = 1,
at = c(xy.0[1], par()$usr[2]),
col = layout$abanico$colour$xtck3,
col.axis = layout$abanico$colour$xtck3,
labels = NA,
tcl = -layout$abanico$dimension$xtcl3 / 200,
cex = cex)
axis(side = 1,
at = c(xy.0[1], par()$usr[2]),
labels = as.character(round(c(0, KDE.max.plot), 3)),
line = 2 * layout$abanico$dimension$xtck3.line / 100 - 2,
lwd = 0,
col = layout$abanico$colour$xtck3,
family = layout$abanico$font.type$xtck3,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xtck3)[1],
col.axis = layout$abanico$colour$xtck3,
cex.axis = layout$abanico$font.size$xtck3/12)
mtext(text = paste(xlab[3],
" (bw ",
round(x = KDE.bw,
digits = 3),
")",
sep = ""),
at = (xy.0[1] + par()$usr[2]) / 2,
side = 1,
line = 2.5 * layout$abanico$dimension$xlab3.line / 100,
col = layout$abanico$colour$xlab3,
family = layout$abanico$font.type$xlab3,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xlab3)[1],
cex = cex * layout$abanico$font.size$xlab3/12)
}
## optionally add histogram or dot plot axis
if(hist == TRUE) {
axis(side = 1,
at = c(xy.0[1], par()$usr[2]),
labels = as.character(c(0, hist.max.plot)),
line = -1 * layout$abanico$dimension$xtck3.line / 100 - 2,
lwd = 0,
col = layout$abanico$colour$xtck3,
family = layout$abanico$font.type$xtck3,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xtck3)[1],
col.axis = layout$abanico$colour$xtck3,
cex.axis = layout$abanico$font.size$xtck3/12)
## add label
mtext(text = "n",
at = (xy.0[1] + par()$usr[2]) / 2,
side = 1,
line = -3.5 * layout$abanico$dimension$xlab2.line / 100,
col = layout$abanico$colour$xlab2,
family = layout$abanico$font.type$xlab2,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xlab2)[1],
cex = cex * layout$abanico$font.size$xlab2/12)
## plot ticks
axis(side = 1,
at = c(xy.0[1], par()$usr[2]),
col = layout$abanico$colour$xtck2,
col.axis = layout$abanico$colour$xtck2,
labels = NA,
tcl = layout$abanico$dimension$xtcl2 / 200,
cex = cex)
## calculate scaling factor for histogram bar heights
hist.scale <- (par()$usr[2] - xy.0[1]) / (KDE.max.plot * 1.05)
## draw each bar for each data set
for(i in 1:length(data)) {
for(j in 1:length(hist.data[[i]]$density)) {
## calculate x-coordinates
hist.x.i <- c(xy.0[1],
xy.0[1],
xy.0[1] + hist.data[[i]]$density[j] * hist.scale,
xy.0[1] + hist.data[[i]]$density[j] * hist.scale)
## calculate y-coordinates
hist.y.i <- c((hist.data[[i]]$breaks[j] - z.central.global) *
min(ellipse[,1]),
(hist.data[[i]]$breaks[j + 1] - z.central.global) *
min(ellipse[,1]),
(hist.data[[i]]$breaks[j + 1] - z.central.global) *
min(ellipse[,1]),
(hist.data[[i]]$breaks[j] - z.central.global) *
min(ellipse[,1]))
## remove data out of z-axis range
hist.y.i <- ifelse(hist.y.i < min(ellipse[,2]),
min(ellipse[,2]),
hist.y.i)
hist.y.i <- ifelse(hist.y.i > max(ellipse[,2]),
max(ellipse[,2]),
hist.y.i)
## draw the bars
polygon(x = hist.x.i,
y = hist.y.i,
col = kde.fill[i],
border = kde.line[i])
}
}
}
## optionally add dot plot
if(dots == TRUE) {
for(i in 1:length(data)) {
for(j in 1:length(hist.data[[i]]$counts)) {
## calculate scaling factor for histogram bar heights
dots.distance <- (par()$usr[2] - (xy.0[1] + par()$cxy[1] * 0.4)) / hist.max.plot
dots.x.i <- seq(from = xy.0[1] + par()$cxy[1] * 0.4,
by = dots.distance,
length.out = hist.data[[i]]$counts[j])
dots.y.i <- rep((hist.data[[i]]$mids[j] - z.central.global) *
min(ellipse[,1]), length(dots.x.i))
## remove data out of z-axis range
dots.x.i <- dots.x.i[dots.y.i >= min(ellipse[,2]) &
dots.y.i <= max(ellipse[,2])]
dots.y.i <- dots.y.i[dots.y.i >= min(ellipse[,2]) &
dots.y.i <= max(ellipse[,2])]
if(max(c(0, dots.x.i), na.rm = TRUE) >= (par()$usr[2] -
par()$cxy[1] * 0.4)) {
dots.y.i <- dots.y.i[dots.x.i < (par()$usr[2] - par()$cxy[1] * 0.4)]
dots.x.i <- dots.x.i[dots.x.i < (par()$usr[2] - par()$cxy[1] * 0.4)]
pch.dots <- c(rep(20, max(length(dots.x.i) - 1),1), 15)
} else {
pch.dots <- rep(20, length(dots.x.i))
}
## plot points
points(x = dots.x.i,
y = dots.y.i,
pch = "|",
cex = 0.7 * cex,
col = kde.line[i])
}
}
}
## optionally add box plot
if(boxplot == TRUE) {
for(i in 1:length(data)) {
## draw median line
lines(x = c(xy.0[1] + KDE.max * 0.85, xy.0[1] + KDE.max * 0.95),
y = c((boxplot.data[[i]]$stats[3,1] - z.central.global) *
min(ellipse[,1]),
(boxplot.data[[i]]$stats[3,1] - z.central.global) *
min(ellipse[,1])),
lwd = 2,
col = kde.line[i])
## draw p25-p75-polygon
polygon(x = c(xy.0[1] + KDE.max * 0.85,
xy.0[1] + KDE.max * 0.85,
xy.0[1] + KDE.max * 0.95,
xy.0[1] + KDE.max * 0.95),
y = c((boxplot.data[[i]]$stats[2,1] - z.central.global) *
min(ellipse[,1]),
(boxplot.data[[i]]$stats[4,1] - z.central.global) *
min(ellipse[,1]),
(boxplot.data[[i]]$stats[4,1] - z.central.global) *
min(ellipse[,1]),
(boxplot.data[[i]]$stats[2,1] - z.central.global) *
min(ellipse[,1])),
border = kde.line[i])
## draw whiskers
lines(x = c(xy.0[1] + KDE.max * 0.9,
xy.0[1] + KDE.max * 0.9),
y = c((boxplot.data[[i]]$stats[2,1] - z.central.global) *
min(ellipse[,1]),
(boxplot.data[[i]]$stats[1,1] - z.central.global) *
min(ellipse[,1])),
col = kde.line[i])
lines(x = c(xy.0[1] + KDE.max * 0.87,
xy.0[1] + KDE.max * 0.93),
y = rep((boxplot.data[[i]]$stats[1,1] - z.central.global) *
min(ellipse[,1]), 2),
col = kde.line[i])
lines(x = c(xy.0[1] + KDE.max * 0.9,
xy.0[1] + KDE.max * 0.9),
y = c((boxplot.data[[i]]$stats[4,1] - z.central.global) *
min(ellipse[,1]),
(boxplot.data[[i]]$stats[5,1] - z.central.global) *
min(ellipse[,1])),
col = kde.line[i])
lines(x = c(xy.0[1] + KDE.max * 0.87,
xy.0[1] + KDE.max * 0.93),
y = rep((boxplot.data[[i]]$stats[5,1] - z.central.global) *
min(ellipse[,1]), 2),
col = kde.line[i])
## draw outlier points
points(x = rep(xy.0[1] + KDE.max * 0.9,
length(boxplot.data[[i]]$out)),
y = (boxplot.data[[i]]$out - z.central.global) *
min(ellipse[,1]),
cex = cex * 0.8,
col = kde.line[i])
}
}
## optionally add stats, i.e. min, max, median sample text
if(length(stats) > 0) {
text(x = stats.data[,1],
y = stats.data[,2],
pos = 2,
labels = round(stats.data[,3], 1),
family = layout$abanico$font.type$stats,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$stats)[1],
cex = cex * layout$abanico$font.size$stats/12,
col = layout$abanico$colour$stats)
}
## optionally add rug
if(rug == TRUE) {
for(i in 1:length(rug.coords)) {
lines(x = rug.coords[[i]][1,],
y = rug.coords[[i]][2,],
col = value.rug[data.global[i,10]])
}
}
## plot KDE base line
lines(x = c(xy.0[1], xy.0[1]),
y = c(min(ellipse[,2]), max(ellipse[,2])),
col = layout$abanico$colour$border)
## draw border around plot
if(frame == 1) {
polygon(x = c(limits.x[1], min(ellipse[,1]), par()$usr[2],
par()$usr[2], min(ellipse[,1])),
y = c(0, max(ellipse[,2]), max(ellipse[,2]),
min(ellipse[,2]), min(ellipse[,2])),
border = layout$abanico$colour$border,
lwd = 0.8)
} else if(frame == 2) {
polygon(x = c(limits.x[1], min(ellipse[,1]), par()$usr[2],
par()$usr[2], min(ellipse[,1]), limits.x[1]),
y = c(2, max(ellipse[,2]), max(ellipse[,2]),
min(ellipse[,2]), min(ellipse[,2]), -2),
border = layout$abanico$colour$border,
lwd = 0.8)
} else if(frame == 3) {
polygon(x = c(limits.x[1], par()$usr[2],
par()$usr[2], limits.x[1]),
y = c(max(ellipse[,2]), max(ellipse[,2]),
min(ellipse[,2]), min(ellipse[,2])),
border = layout$abanico$colour$border,
lwd = 0.8)
}
## optionally add legend content
if(!missing(legend)) {
## store and change font family
par.family <- par()$family
par(family = layout$abanico$font.type$legend)
legend(x = legend.pos[1],
y = 0.8 * legend.pos[2],
xjust = legend.adj[1],
yjust = legend.adj[2],
legend = legend,
pch = pch,
col = value.dot,
text.col = value.dot,
text.font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$legend)[1],
cex = cex * layout$abanico$font.size$legend/12,
bty = "n")
## restore font family
par(family = par.family)
}
## optionally add subheader text
mtext(text = mtext,
side = 3,
line = (shift.lines - 2) * layout$abanico$dimension$mtext / 100,
col = layout$abanico$colour$mtext,
family = layout$abanico$font.type$mtext,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$mtext)[1],
cex = cex * layout$abanico$font.size$mtext / 12)
## add summary content
for(i in 1:length(data)) {
if(summary.pos[1] != "sub") {
text(x = summary.pos[1],
y = summary.pos[2],
adj = summary.adj,
labels = label.text[[i]],
col = summary.col[i],
family = layout$abanico$font.type$summary,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$summary)[1],
cex = cex * layout$abanico$font.size$summary / 12)
} else {
if(mtext == "") {
mtext(side = 3,
line = (shift.lines- 1 - i) *
layout$abanico$dimension$summary / 100 ,
text = label.text[[i]],
col = summary.col[i],
family = layout$abanico$font.type$summary,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$summary)[1],
cex = cex * layout$abanico$font.size$summary / 12)
}
}
}
} else {
## setup plot area
par(mar = c(4, 4, shift.lines + 5, 4),
xpd = TRUE,
cex = cex)
dim <- layout$abanico$dimension
if (dim$figure.width != "auto" || dim$figure.height != "auto") {
par(mai = dim$margin / 25.4,
pin = c(dim$figure.width - dim$margin[2] - dim$margin[4],
dim$figure.height - dim$margin[1] - dim$margin[3]) / 25.4)
}
## create empty plot
par(new = TRUE)
plot(NA,
xlim = limits.y,
ylim = c(limits.x[1], limits.x[2] * (1 / plot.ratio)),
main = "",
sub = sub,
xlab = "",
ylab = "",
xaxs = "i",
yaxs = "i",
frame.plot = FALSE,
axes = FALSE)
## add y-axis label
mtext(text = ylab,
at = 0,
adj = 0.5,
side = 1,
line = 3 * layout$abanico$dimension$ylab.line / 100,
col = layout$abanico$colour$ylab,
family = layout$abanico$font.type$ylab,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$ylab)[1],
cex = cex * layout$abanico$font.size$ylab/12)
## calculate upper x-axis label values
label.x.upper <- if(log.z == TRUE) {
as.character(round(1/axTicks(side = 2)[-1] * 100, 1))
} else {
as.character(round(1/axTicks(side = 2)[-1], 1))
}
# optionally, plot 2-sigma-bar
if(bar[1] != FALSE) {
for(i in 1:length(bar)) {
polygon(x = bars[i,1:4],
y = bars[i,5:8],
col = bar.fill[i],
border = bar.line[i])
}
}
## remove unwanted parts
polygon(y = c(par()$usr[2],
par()$usr[2],
par()$usr[2] * 2,
par()$usr[2] * 2),
x = c(min(ellipse[,2]) * 2,
max(ellipse[,2]) * 2,
max(ellipse[,2]) * 2,
min(ellipse[,2]) * 2),
col = bg.original,
lty = 0)
## optionally, plot dispersion polygon
if(polygon.fill[1] != "none") {
for(i in 1:length(data)) {
polygon(x = polygons[i,8:14],
y = polygons[i,1:7],
col = polygon.fill[i],
border = polygon.line[i])
}
}
## optionally, add minor grid lines
if(grid.minor != "none") {
for(i in 1:length(tick.values.minor)) {
lines(y = c(limits.x[1], min(ellipse[,1])),
x = c(0, (tick.values.minor[i] - z.central.global) * min(ellipse[,1])),
col = grid.minor,
lwd = 1)
}
for(i in 1:length(tick.values.minor)) {
lines(y = c(xy.0[2], par()$usr[2]),
x = c((tick.values.minor[i] - z.central.global) * min(ellipse[,1]),
(tick.values.minor[i] - z.central.global) * min(ellipse[,1])),
col = grid.minor,
lwd = 1)
}
}
## optionally, add major grid lines
if(grid.major != "none") {
for(i in 1:length(tick.values.major)) {
lines(y = c(limits.x[1], min(ellipse[,2])),
x = c(0, (tick.values.major[i] - z.central.global) * min(ellipse[,2])),
col = grid.major,
lwd = 1)
}
for(i in 1:length(tick.values.major)) {
lines(y = c(xy.0[2],y.max),
x = c((tick.values.major[i] - z.central.global) * min(ellipse[,2]),
(tick.values.major[i] - z.central.global) * min(ellipse[,2])),
col = grid.major,
lwd = 1)
}
}
## optionally, plot lines for each bar
if(lwd[1] > 0 & lty[1] > 0 & bar[1] != FALSE & length(data) == 1) {
if(bar[1] == TRUE & length(bar) == 1) {
bar[1] <- z.central.global
}
for(i in 1:length(bar)) {
x2 <- r / sqrt(1 + f^2 * (
bar[i] - z.central.global)^2)
y2 <- (bar[i] - z.central.global) * x2
lines(x = c(0, y2, y2, y2),
y = c(limits.x[1], x2, xy.0[2], par()$usr[4]),
lty = lty[i],
lwd = lwd[i],
col = centrality.col[i])
}
}
## optionally add further lines
if(missing(line) == FALSE) {
for(i in 1:length(line)) {
lines(y = line.coords[[i]][1,1:3],
x = line.coords[[i]][2,1:3],
col = line.col[i],
lty = line.lty[i]
)
text(y = line.coords[[i]][1,3],
x = line.coords[[i]][2,3] + par()$cxy[2] * 0.3,
labels = line.label[i],
pos = 2,
col = line.col[i],
cex = cex * 0.9)
}
}
## add plot title
cex.old <- par()$cex
par(cex = layout$abanico$font.size$main / 12)
title(main = main,
family = layout$abanico$font.type$main,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$main)[1],
col.main = layout$abanico$colour$main,
line = (shift.lines + 3.5) * layout$abanico$dimension$main / 100)
par(cex = cex.old)
## calculate lower x-axis (precision)
x.axis.ticks <- axTicks(side = 2)
x.axis.ticks <- x.axis.ticks[c(TRUE, x.axis.ticks <= limits.x[2])]
x.axis.ticks <- x.axis.ticks[x.axis.ticks <= max(ellipse[,2])]
## x-axis with lables and ticks
axis(side = 2,
at = x.axis.ticks,
col = layout$abanico$colour$xtck1,
col.axis = layout$abanico$colour$xtck1,
labels = NA,
tcl = -layout$abanico$dimension$xtcl1 / 200,
cex = cex)
axis(side = 2,
at = x.axis.ticks,
line = 2 * layout$abanico$dimension$xtck1.line / 100 - 2,
lwd = 0,
col = layout$abanico$colour$xtck1,
family = layout$abanico$font.type$xtck1,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xtck1)[1],
col.axis = layout$abanico$colour$xtck1,
cex.axis = layout$abanico$font.size$xlab1/12)
## extend axis line to right side of the plot
lines(y = c(max(x.axis.ticks), max(ellipse[,2])),
x = c(limits.y[1], limits.y[1]),
col = layout$abanico$colour$xtck1)
## draw closing tick on right hand side
axis(side = 2,
tcl = -layout$abanico$dimension$xtcl1 / 200,
lwd = 0,
lwd.ticks = 1,
at = limits.x[2],
labels = FALSE,
col = layout$abanico$colour$xtck1)
axis(side = 2,
tcl = layout$abanico$dimension$xtcl2 / 200,
lwd = 0,
lwd.ticks = 1,
at = limits.x[2],
labels = FALSE,
col = layout$abanico$colour$xtck2)
## add lower axis label
mtext(xlab[2],
at = (limits.x[1] + max(ellipse[,2])) / 2,
side = 2,
line = 2.5 * layout$abanico$dimension$xlab1.line / 100,
col = layout$abanico$colour$xlab1,
family = layout$abanico$font.type$xlab1,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xlab1)[1],
cex = cex * layout$abanico$font.size$xlab1/12)
## add upper axis label
mtext(xlab[1],
at = (limits.x[1] + max(ellipse[,2])) / 2,
side = 2,
line = -3.5 * layout$abanico$dimension$xlab2.line / 100,
col = layout$abanico$colour$xlab2,
family = layout$abanico$font.type$xlab2,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xlab2)[1],
cex = cex * layout$abanico$font.size$xlab2/12)
## plot upper x-axis
axis(side = 2,
at = x.axis.ticks[-1],
col = layout$abanico$colour$xtck2,
col.axis = layout$abanico$colour$xtck2,
labels = NA,
tcl = layout$abanico$dimension$xtcl2 / 200,
cex = cex)
## remove first tick label (infinity)
label.x.upper <- label.x.upper[1:(length(x.axis.ticks) - 1)]
axis(side = 2,
at = x.axis.ticks[-1],
labels = label.x.upper,
line = -1 * layout$abanico$dimension$xtck2.line / 100 - 2,
lwd = 0,
col = layout$abanico$colour$xtck2,
family = layout$abanico$font.type$xtck2,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xtck2)[1],
col.axis = layout$abanico$colour$xtck2,
cex.axis = layout$abanico$font.size$xlab2/12)
## plot y-axis
if(y.axis[1]) {
char.height <- par()$cxy[2]
tick.space <- grDevices::axisTicks(usr = limits.y, log = FALSE)
tick.space <- (max(tick.space) - min(tick.space)) / length(tick.space)
if(tick.space < char.height * 1.7) {
axis(side = 1,
tcl = -layout$abanico$dimension$ytcl / 200,
lwd = 1,
lwd.ticks = 1,
at = c(-2, 2),
labels = c("", ""),
las = 1,
col = layout$abanico$colour$ytck)
axis(side = 1,
at = 0,
tcl = 0,
line = 2 * layout$abanico$dimension$ytck.line / 100 - 2,
labels = paste("\u00B1", "2"),
las = 1,
family = layout$abanico$font.type$ytck,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$ytck)[1],
col.axis = layout$abanico$colour$ytck,
cex.axis = layout$abanico$font.size$ylab/12)
} else {
axis(side = 1,
at = seq(-2, 2, by = 2),
col = layout$abanico$colour$ytck,
col.axis = layout$abanico$colour$ytck,
labels = NA,
las = 1,
tcl = -layout$abanico$dimension$ytcl / 200,
cex = cex)
axis(side = 1,
at = seq(-2, 2, by = 2),
line = 2 * layout$abanico$dimension$ytck.line / 100 - 2,
lwd = 0,
las = 1,
col = layout$abanico$colour$ytck,
family = layout$abanico$font.type$ytck,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$ytck)[1],
col.axis = layout$abanico$colour$ytck,
cex.axis = layout$abanico$font.size$ylab/12)
}
} else {
axis(side = 1,
at = 0,
col = layout$abanico$colour$ytck,
col.axis = layout$abanico$colour$ytck,
labels = NA,
las = 1,
tcl = -layout$abanico$dimension$ytcl / 200,
cex = cex)
axis(side = 1,
at = 0,
line = 2 * layout$abanico$dimension$ytck.line / 100 - 2,
lwd = 0,
las = 1,
col = layout$abanico$colour$ytck,
family = layout$abanico$font.type$ytck,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$ytck)[1],
col.axis = layout$abanico$colour$ytck,
cex.axis = layout$abanico$font.size$ylab/12)
}
## plot minor z-ticks
for(i in 1:length(tick.values.minor)) {
lines(y = c(par()$usr[4],
(1 + 0.015 * cex * layout$abanico$dimension$ztcl / 100) *
y.max),
x = c((tick.values.minor[i] - z.central.global) *
min(ellipse[,2]),
(tick.values.minor[i] - z.central.global) *
min(ellipse[,2])),
col = layout$abanico$colour$ztck)
}
## plot major z-ticks
for(i in 1:length(tick.values.major)) {
lines(y = c(par()$usr[4],
(1 + 0.03 * cex * layout$abanico$dimension$ztcl / 100) *
y.max),
x = c((tick.values.major[i] - z.central.global) *
min(ellipse[,2]),
(tick.values.major[i] - z.central.global) *
min(ellipse[,2])),
col = layout$abanico$colour$ztck)
}
## plot z-axes
lines(ellipse, col = layout$abanico$colour$border)
lines(y = rep(par()$usr[4], nrow(ellipse)),
x = ellipse[,1],
col = layout$abanico$colour$ztck)
## plot z-axis text
text(y = (1 + 0.06 * cex * layout$abanico$dimension$ztcl / 100) *
y.max,
x = (tick.values.major - z.central.global) * min(ellipse[,2]),
labels = label.z.text,
adj = 0.5,
family = layout$abanico$font.type$ztck,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$ztck)[1],
cex = cex * layout$abanico$font.size$ztck/12)
## plot z-label
mtext(text = zlab,
at = 0,
side = 3,
las = 1,
adj = 0.5,
line = 2.5 * layout$abanico$dimension$zlab.line / 100,
col = layout$abanico$colour$zlab,
family = layout$abanico$font.type$zlab,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$zlab)[1],
cex = cex * layout$abanico$font.size$zlab/12)
## plot values and optionally error bars
if(error.bars == TRUE) {
for(i in 1:length(data)) {
graphics::arrows(y0 = arrow.coords[[i]][,1],
y1 = arrow.coords[[i]][,2],
x0 = arrow.coords[[i]][,3],
x1 = arrow.coords[[i]][,4],
length = 0,
angle = 90,
code = 3,
col = value.bar[i])
}
}
for(i in 1:length(data)) {
points(y = data[[i]][,6][data[[i]][,6] <= limits.x[2]],
x = data[[i]][,8][data[[i]][,6] <= limits.x[2]],
col = value.dot[i],
pch = pch[i],
cex = layout$abanico$dimension$pch / 100)
}
## calculate KDE width
KDE.max <- 0
for(i in 1:length(data)) {
KDE.max <- ifelse(test = KDE.max < max(KDE[[i]][,2]),
yes = max(KDE[[i]][,2]),
no = KDE.max)
}
## optionally adjust KDE width for boxplot option
if(boxplot == TRUE) {
KDE.max <- 1.3 * KDE.max
}
KDE.scale <- (par()$usr[4] - xy.0[2]) / (KDE.max * 1.05)
## optionally add KDE plot
if(kde == TRUE) {
## plot KDE lines
for(i in 1:length(data)) {
polygon(y = xy.0[2] + KDE[[i]][,2] * KDE.scale,
x = (KDE[[i]][,1] - z.central.global) * min(ellipse[,2]),
col = kde.fill[i],
border = kde.line[i],
lwd = 1.7)
}
## plot KDE x-axis
axis(side = 2,
at = c(xy.0[2], y.max),
col = layout$abanico$colour$xtck3,
col.axis = layout$abanico$colour$xtck3,
labels = NA,
tcl = -layout$abanico$dimension$xtcl3 / 200,
cex = cex)
axis(side = 2,
at = c(xy.0[2], y.max),
labels = as.character(round(c(0, KDE.max.plot), 3)),
line = 2 * layout$abanico$dimension$xtck3.line / 100 - 2,
lwd = 0,
col = layout$abanico$colour$xtck3,
family = layout$abanico$font.type$xtck3,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xtck3)[1],
col.axis = layout$abanico$colour$xtck3,
cex.axis = layout$abanico$font.size$xtck3/12)
mtext(text = paste(xlab[3],
" (bw ",
round(x = KDE.bw,
digits = 3),
")",
sep = ""),
at = (xy.0[2] + y.max) / 2,
side = 2,
line = 2.5 * layout$abanico$dimension$xlab3.line / 100,
col = layout$abanico$colour$xlab3,
family = layout$abanico$font.type$xlab3,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xlab3)[1],
cex = cex * layout$abanico$font.size$xlab3/12)
}
## optionally add histogram or dot plot axis
if(hist == TRUE) {
axis(side = 2,
at = c(xy.0[2], y.max),
labels = as.character(c(0, hist.max.plot)),
line = -1 * layout$abanico$dimension$xtck3.line / 100 - 2,
lwd = 0,
col = layout$abanico$colour$xtck3,
family = layout$abanico$font.type$xtck3,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xtck3)[1],
col.axis = layout$abanico$colour$xtck3,
cex.axis = layout$abanico$font.size$xtck3/12)
## add label
mtext(text = "n",
at = (xy.0[2] + y.max) / 2,
side = 2,
line = -3.5 * layout$abanico$dimension$xlab2.line / 100,
col = layout$abanico$colour$xlab2,
family = layout$abanico$font.type$xlab2,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$xlab2)[1],
cex = cex * layout$abanico$font.size$xlab2/12)
## plot ticks
axis(side = 2,
at = c(xy.0[2], y.max),
col = layout$abanico$colour$xtck2,
col.axis = layout$abanico$colour$xtck2,
labels = NA,
tcl = layout$abanico$dimension$xtcl2 / 200,
cex = cex)
## calculate scaling factor for histogram bar heights
hist.scale <- (par()$usr[4] - xy.0[2]) / (KDE.max.plot * 1.05)
## draw each bar for each data set
for(i in 1:length(data)) {
for(j in 1:length(hist.data[[i]]$density)) {
## calculate x-coordinates
hist.x.i <- c(xy.0[2],
xy.0[2],
xy.0[2] + hist.data[[i]]$density[j] * hist.scale,
xy.0[2] + hist.data[[i]]$density[j] * hist.scale)
## calculate y-coordinates
hist.y.i <- c((hist.data[[i]]$breaks[j] - z.central.global) *
min(ellipse[,2]),
(hist.data[[i]]$breaks[j + 1] - z.central.global) *
min(ellipse[,2]),
(hist.data[[i]]$breaks[j + 1] - z.central.global) *
min(ellipse[,2]),
(hist.data[[i]]$breaks[j] - z.central.global) *
min(ellipse[,2]))
## remove data out of z-axis range
hist.y.i <- ifelse(hist.y.i < min(ellipse[,1]),
min(ellipse[,1]),
hist.y.i)
hist.y.i <- ifelse(hist.y.i > max(ellipse[,1]),
max(ellipse[,1]),
hist.y.i)
## draw the bars
polygon(y = hist.x.i,
x = hist.y.i,
col = kde.fill[i],
border = kde.line[i])
}
}
}
## optionally add dot plot
if(dots == TRUE) {
for(i in 1:length(data)) {
for(j in 1:length(hist.data[[i]]$counts)) {
## calculate scaling factor for histogram bar heights
dots.distance <- (par()$usr[4] - (xy.0[2] + par()$cxy[1] * 0.4)) / hist.max.plot
dots.x.i <- seq(from = xy.0[2] + par()$cxy[2] * 0.4,
by = dots.distance,
length.out = hist.data[[i]]$counts[j])
dots.y.i <- rep((hist.data[[i]]$mids[j] - z.central.global) *
min(ellipse[,2]), length(dots.x.i))
## remove data out of z-axis range
dots.x.i <- dots.x.i[dots.y.i >= min(ellipse[,1]) &
dots.y.i <= max(ellipse[,1])]
dots.y.i <- dots.y.i[dots.y.i >= min(ellipse[,1]) &
dots.y.i <= max(ellipse[,1])]
if(max(c(0, dots.x.i), na.rm = TRUE) >= (par()$usr[4] -
par()$cxy[2] * 0.4)) {
dots.y.i <- dots.y.i[dots.x.i < (par()$usr[4] - par()$cxy[2] * 0.4)]
dots.x.i <- dots.x.i[dots.x.i < (par()$usr[4] - par()$cxy[2] * 0.4)]
pch.dots <- c(rep(20, length(dots.x.i) - 1), 15)
} else {
pch.dots <- rep(20, length(dots.x.i))
}
## plot points
points(y = dots.x.i,
x = dots.y.i,
pch = "-",
cex = 0.7 * cex,
col = kde.line[i])
}
}
}
## optionally add box plot
if(boxplot == TRUE) {
for(i in 1:length(data)) {
## draw median line
lines(x = c((boxplot.data[[i]]$stats[3,1] - z.central.global) *
min(ellipse[,2]),
(boxplot.data[[i]]$stats[3,1] - z.central.global) *
min(ellipse[,2])),
y = c(min(ellipse[,2]) + KDE.max * 0.91,
xy.0[2] + KDE.max * 0.96),
lwd = 2,
col = kde.line[i])
## draw p25-p75-polygon
polygon(y = c(min(ellipse[,2]) + KDE.max * 0.91,
min(ellipse[,2]) + KDE.max * 0.91,
xy.0[2] + KDE.max * 0.96,
xy.0[2] + KDE.max * 0.96),
x = c((boxplot.data[[i]]$stats[2,1] - z.central.global) *
min(ellipse[,2]),
(boxplot.data[[i]]$stats[4,1] - z.central.global) *
min(ellipse[,2]),
(boxplot.data[[i]]$stats[4,1] - z.central.global) *
min(ellipse[,2]),
(boxplot.data[[i]]$stats[2,1] - z.central.global) *
min(ellipse[,2])),
border = kde.line[i])
## draw whiskers
lines(y = rep(mean(c(min(ellipse[,2]) + KDE.max * 0.91,
xy.0[2] + KDE.max * 0.96)), 2),
x = c((boxplot.data[[i]]$stats[2,1] - z.central.global) *
min(ellipse[,2]),
(boxplot.data[[i]]$stats[1,1] - z.central.global) *
min(ellipse[,2])),
col = kde.line[i])
lines(y = c(min(ellipse[,2]) + KDE.max * 0.91,
xy.0[2] + KDE.max * 0.96),
x = rep((boxplot.data[[i]]$stats[1,1] - z.central.global) *
min(ellipse[,2]), 2),
col = kde.line[i])
lines(y = rep(mean(c(min(ellipse[,2]) + KDE.max * 0.91,
xy.0[2] + KDE.max * 0.96)), 2),
x = c((boxplot.data[[i]]$stats[4,1] - z.central.global) *
min(ellipse[,2]),
(boxplot.data[[i]]$stats[5,1] - z.central.global) *
min(ellipse[,2])),
col = kde.line[i])
lines(y = c(min(ellipse[,2]) + KDE.max * 0.91,
xy.0[2] + KDE.max * 0.96),
x = rep((boxplot.data[[i]]$stats[5,1] - z.central.global) *
min(ellipse[,2]), 2),
col = kde.line[i])
## draw outlier points
points(y = rep(mean(c(min(ellipse[,2]) + KDE.max * 0.91,
xy.0[2] + KDE.max * 0.96)),
length(boxplot.data[[i]]$out)),
x = (boxplot.data[[i]]$out - z.central.global) *
min(ellipse[,2]),
cex = cex * 0.8,
col = kde.line[i])
}
}
## optionally add stats, i.e. min, max, median sample text
if(length(stats) > 0) {
text(y = stats.data[,1],
x = stats.data[,2],
pos = 2,
labels = round(stats.data[,3], 1),
family = layout$abanico$font.type$stats,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$stats)[1],
cex = cex * layout$abanico$font.size$stats/12,
col = layout$abanico$colour$stats)
}
## optionally add rug
if(rug == TRUE) {
for(i in 1:length(rug.coords)) {
lines(y = rug.coords[[i]][1,],
x = rug.coords[[i]][2,],
col = value.rug[data.global[i,10]])
}
}
## plot KDE base line
lines(y = c(xy.0[2], xy.0[2]),
x = c(min(ellipse[,1]), max(ellipse[,1])),
col = layout$abanico$colour$border)
## draw border around plot
polygon(y = c(limits.x[1], min(ellipse[,2]), y.max,
y.max, min(ellipse[,2])),
x = c(0, max(ellipse[,1]), max(ellipse[,1]),
min(ellipse[,1]), min(ellipse[,1])),
border = layout$abanico$colour$border,
lwd = 0.8)
## optionally add legend content
if(missing(legend) == FALSE) {
## store and change font familiy
par.family <- par()$family
par(family = layout$abanico$font.type$legend)
legend(y = legend.pos[2],
x = 0.8 * legend.pos[1],
xjust = legend.adj[2],
yjust = legend.adj[1],
legend = legend,
pch = pch,
col = value.dot,
text.col = value.dot,
text.font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$legend)[1],
cex = cex * layout$abanico$font.size$legend/12,
bty = "n")
## restore font family
par(family = par.family)
}
## optionally add subheader text
mtext(text = mtext,
side = 3,
line = (shift.lines - 2 + 3.5) * layout$abanico$dimension$mtext / 100,
col = layout$abanico$colour$mtext,
family = layout$abanico$font.type$mtext,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$mtext)[1],
cex = cex * layout$abanico$font.size$mtext / 12)
## add summary content
for(i in 1:length(data)) {
if(summary.pos[1] != "sub") {
text(x = summary.pos[1],
y = summary.pos[2],
adj = summary.adj,
labels = label.text[[i]],
col = summary.col[i],
family = layout$abanico$font.type$summary,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$summary)[1],
cex = cex * layout$abanico$font.size$summary / 12)
} else {
if(mtext == "") {
mtext(side = 3,
line = (shift.lines - 1 + 3.5 - i) *
layout$abanico$dimension$summary / 100 ,
text = label.text[[i]],
col = summary.col[i],
family = layout$abanico$font.type$summary,
font = which(c("normal", "bold", "italic", "bold italic") ==
layout$abanico$font.deco$summary)[1],
cex = cex * layout$abanico$font.size$summary / 12)
}
}
}
}
##sTeve
if (fun && !interactive) sTeve() # nocov
## create numeric output
plot.output <- list(xlim = limits.x,
ylim = limits.y,
zlim = limits.z,
polar.box = c(limits.x[1],
limits.x[2],
min(ellipse[,2]),
max(ellipse[,2])),
cartesian.box = c(xy.0[1],
par()$usr[2],
xy.0[2],
max(ellipse[,2])),
plot.ratio = plot.ratio,
data = data,
data.global = data.global,
KDE = KDE,
par = par(no.readonly = TRUE))
## INTERACTIVE PLOT ----------------------------------------------------------
if (interactive) {
.require_suggested_package("plotly", "The interactive abanico plot")
##cheat R check (global visible binding error)
x <- NA
y <- NA
## tidy data ----
data <- plot.output
kde <- data.frame(x = data$KDE[[1]][ ,2], y = data$KDE[[1]][ ,1])
# radial scatter plot ----
point.text <- paste0("Measured value:
",
data$data.global$De, " ± ",
data$data.global$error, "
",
"P(",format(data$data.global$precision, digits = 2, nsmall = 1),", ",
format(data$data.global$std.estimate, digits = 2, nsmall = 1),")")
IAP <- plotly::plot_ly(data = data$data.global,
x = data$data.global$precision,
y = data$data.global$std.estimate,
type = "scatter", mode = "markers",
hoverinfo = "text", text = point.text,
name = "Points",
yaxis = "y")
ellipse <- as.data.frame(ellipse)
IAP <- plotly::add_trace(IAP, data = ellipse,
x = ~ellipse.x, y = ~ellipse.y,
type = "scatter", mode = "lines",
hoverinfo = "none", text = "",
name = "z-axis (left)",
line = list(color = "black",
width = 1),
yaxis = "y")
ellipse.right <- ellipse
ellipse.right$ellipse.x <- ellipse.right$ellipse.x * 1/0.75
IAP <- plotly::add_trace(IAP, data = ellipse.right,
x = ~ellipse.x, y = ~ellipse.y,
type = "scatter", mode = "lines",
hoverinfo = "none", text = "",
name = "z-axis (right)",
line = list(color = "black",
width = 1),
yaxis = "y")
# z-axis ticks
major.ticks.x <- c(data$xlim[2] * 1/0.75,
(1 + 0.015 * layout$abanico$dimension$ztcl / 100) *
data$xlim[2] * 1/0.75)
minor.ticks.x <- c(data$xlim[2] * 1/0.75,
(1 + 0.01 * layout$abanico$dimension$ztcl / 100) *
data$xlim[2] * 1/0.75)
major.ticks.y <- (tick.values.major - z.central.global) * min(ellipse[ ,1])
minor.ticks.y <- (tick.values.minor - z.central.global) * min(ellipse[ ,1])
# major z-tick lines
for (i in 1:length(major.ticks.y)) {
major.tick <- data.frame(x = major.ticks.x, y = rep(major.ticks.y[i], 2))
IAP <- plotly::add_trace(IAP, data = major.tick,
x = ~x, y = ~y, showlegend = FALSE,
type = "scatter", mode = "lines",
hoverinfo = "none", text = "",
line = list(color = "black",
width = 1),
yaxis = "y")
}
# minor z-tick lines
for (i in 1:length(minor.ticks.y)) {
minor.tick <- data.frame(x = minor.ticks.x, y = rep(minor.ticks.y[i], 2))
IAP <- plotly::add_trace(IAP, data = minor.tick,
x = ~x, y = ~y, showlegend = FALSE,
type = "scatter", mode = "lines",
hoverinfo = "none", text = "",
line = list(color = "black",
width = 1),
yaxis = "y")
}
# z-tick label
tick.text <- paste(" ", exp(tick.values.major))
tick.pos <- data.frame(x = major.ticks.x[2],
y = major.ticks.y)
IAP <- plotly::add_trace(IAP, data = tick.pos,
x = ~x, y = ~y, showlegend = FALSE,
hoverinfo = "none",
text = tick.text, textposition = "right",
type = "scatter", mode = "text",
yaxis = "y")
# Central Line ----
central.line <- data.frame(x = c(-100, data$xlim[2]*1/0.75), y = c(0, 0))
central.line.text <- paste0("Central value: ",
format(exp(z.central.global), digits = 2, nsmall = 1))
IAP <- plotly::add_trace(IAP, data = central.line,
x = ~x, y = ~y, name = "Central line",
type = "scatter", mode = "lines",
hoverinfo = "text", text = central.line.text,
yaxis = "y",
line = list(color = "black",
width = 0.5,
dash = 2))
# KDE plot ----
KDE.x <- xy.0[1] + KDE[[1]][ ,2] * KDE.scale
KDE.y <- (KDE[[1]][ ,1] - z.central.global) * min(ellipse[,1])
KDE.curve <- data.frame(x = KDE.x, y = KDE.y)
KDE.curve <- KDE.curve[KDE.curve$x != xy.0[1], ]
KDE.text <- paste0("Value:",
format(exp(KDE.curve$x), digits = 2, nsmall = 1), "
",
"Density:",
format(KDE.curve$y, digits = 2, nsmall = 1))
IAP <- plotly::add_trace(IAP, data = KDE.curve,
x = ~x, y = ~y, name = "KDE",
type = "scatter", mode = "lines",
hoverinfo = "text",
text = KDE.text,
line = list(color = "red"),
yaxis = "y")
# set layout ----
IAP <- plotly::layout(IAP,
hovermode = "closest",
dragmode = "pan",
xaxis = list(range = c(data$xlim[1], data$xlim[2] * 1/0.65),
zeroline = FALSE,
showgrid = FALSE,
tickmode = "array",
tickvals = x.axis.ticks),
yaxis = list(range = data$ylim,
zeroline = FALSE,
showline = FALSE,
showgrid = FALSE,
tickmode = "array",
tickvals = c(-2, 0, 2)),
shapes = list(list(type = "rect", # 2 sigma bar
x0 = 0, y0 = -2,
x1 = bars[1,3], y1 = 2,
xref = "x", yref = "y",
fillcolor = "grey",
opacity = 0.2))
)
# show and return interactive plot ----
#print(plotly::subplot(IAP, IAP.kde))
print(IAP)
return(IAP)
}
## restore initial cex
par(cex = cex_old)
## create and return numeric output
invisible(plot.output)
}
Luminescence/R/calc_CentralDose.R 0000644 0001762 0000144 00000026554 14762554470 016427 0 ustar ligges users #' Apply the central age model (CAM) after Galbraith et al. (1999) to a given
#' De distribution
#'
#' @description
#' This function calculates the central dose and dispersion of the De
#' distribution, their standard errors and the profile log likelihood function
#' for `sigma`.
#'
#' This function uses the equations of Galbraith & Roberts (2012). The
#' parameters `delta` and `sigma` are estimated by numerically solving
#' eq. 15 and 16. Their standard errors are approximated using eq. 17.
#' In addition, the profile log-likelihood function for `sigma` is
#' calculated using eq. 18 and presented as a plot. Numerical values of the
#' maximum likelihood approach are **only** presented in the plot and **not**
#' in the console. A detailed explanation on maximum likelihood estimation can
#' be found in the appendix of Galbraith & Laslett (1993, 468-470) and
#' Galbraith & Roberts (2012, 15)
#'
#' @param data [RLum.Results-class] or [data.frame] (**required**):
#' for [data.frame]: two columns with De `(data[,1])` and De error `(data[,2])`.
#' Records containing missing values will be removed.
#'
#' @param sigmab [numeric] (*with default*):
#' additional spread in De values.
#' This value represents the expected overdispersion in the data should the sample be
#' well-bleached (Cunningham & Walling 2012, p. 100).
#' **NOTE**: For the logged model (`log = TRUE`) this value must be
#' a fraction, e.g. 0.2 (= 20 %). If the un-logged model is used (`log = FALSE`),
#' sigmab must be provided in the same absolute units of the De values (seconds or Gray).
#'
#' @param log [logical] (*with default*):
#' fit the (un-)logged central age model to De data. Log transformation is
#' allowed only if the De values are positive.
#'
#' @param plot [logical] (*with default*):
#' enable/disable the plot output.
#'
#' @param ... further arguments (`trace`, `verbose`).
#'
#' @return Returns a plot (*optional*) and terminal output. In addition an
#' [RLum.Results-class] object is returned containing the following elements:
#'
#' \item{.$summary}{[data.frame] summary of all relevant model results.}
#' \item{.$data}{[data.frame] original input data}
#' \item{.$args}{[list] used arguments}
#' \item{.$call}{[call] the function call}
#' \item{.$profile}{[data.frame] the log likelihood profile for sigma}
#'
#' The output should be accessed using the function [get_RLum].
#'
#' @section Function version: 1.5
#'
#' @author
#' Christoph Burow, University of Cologne (Germany) \cr
#' Based on a rewritten S script of Rex Galbraith, 2010
#'
#' @seealso [plot], [calc_CommonDose], [calc_FiniteMixture],
#' [calc_FuchsLang2001], [calc_MinDose]
#'
#' @references
#' Galbraith, R.F. & Laslett, G.M., 1993. Statistical models for
#' mixed fission track ages. Nuclear Tracks Radiation Measurements 4, 459-470.
#'
#' Galbraith, R.F., Roberts, R.G., Laslett, G.M., Yoshida, H. & Olley,
#' J.M., 1999. Optical dating of single grains of quartz from Jinmium rock
#' shelter, northern Australia. Part I: experimental design and statistical
#' models. Archaeometry 41, 339-364.
#'
#' 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, 1-27.
#'
#' **Further reading**
#'
#' Arnold, L.J. & Roberts, R.G., 2009. Stochastic modelling of multi-grain equivalent dose
#' (De) distributions: Implications for OSL dating of sediment mixtures.
#' Quaternary Geochronology 4, 204-230.
#'
#' Bailey, R.M. & Arnold, L.J., 2006. Statistical modelling of single grain quartz De distributions and an
#' assessment of procedures for estimating burial dose. Quaternary Science
#' Reviews 25, 2475-2502.
#'
#' Cunningham, A.C. & Wallinga, J., 2012. Realizing the potential of fluvial archives using robust OSL chronologies.
#' Quaternary Geochronology 12, 98-106.
#'
#' Rodnight, H., Duller, G.A.T., Wintle, A.G. & Tooth, S., 2006. Assessing the reproducibility and accuracy
#' of optical dating of fluvial deposits. Quaternary Geochronology, 1 109-120.
#'
#' Rodnight, H., 2008. How many equivalent dose values are needed to
#' obtain a reproducible distribution?. Ancient TL 26, 3-10.
#'
#' @examples
#'
#' ##load example data
#' data(ExampleData.DeValues, envir = environment())
#'
#' ##apply the central dose model
#' calc_CentralDose(ExampleData.DeValues$CA1)
#'
#' @md
#' @export
calc_CentralDose <- function(data, sigmab, log = TRUE, plot = TRUE, ...) {
.set_function_name("calc_CentralDose")
on.exit(.unset_function_name(), add = TRUE)
## ============================================================================##
## CONSISTENCY CHECK OF INPUT DATA
## ============================================================================##
.validate_class(data, c("data.frame", "RLum.Results"))
if (inherits(data, "RLum.Results")) {
data <- get_RLum(data, "data")
}
##remove NA values
if (anyNA(data)) {
message("[calc_CentralDose()] ", length(which(is.na(data))),
" NA values removed from dataset")
data <- na.exclude(data)
}
##make sure we consider onlyt take the first two columns
if(ncol(data) < 2 || nrow(data) < 2)
.throw_error("'data' should have at least two columns and two rows")
##extract only the first two columns and set column names
data <- data[,1:2]
colnames(data) <- c("ED", "ED_Error")
## don't allow log transformation if there are non-positive values
if (any(data[, 1] <= 0) && log == TRUE) {
log <- FALSE
.throw_warning("'data' contains non-positive De values, 'log' set to FALSE")
}
## don't allow negative errors, silently make them positive
if (any(data[, 2] < 0)) {
data[, 2] <- abs(data[, 2])
}
if (!missing(sigmab)) {
if (sigmab < 0 | sigmab > 1 & log)
.throw_error("'sigmab' should be a fraction between 0 and 1 (e.g., 0.2)")
}
## ============================================================================##
## ... ARGUMENTS
## ============================================================================##
options <- list(verbose = TRUE,
trace = FALSE)
options <- modifyList(options, list(...))
## deprecated argument
if ("na.rm" %in% names(list(...))) {
.throw_warning("'na.rm' is deprecated, missing values are always removed ",
"by default")
}
## ============================================================================##
## CALCULATIONS
## ============================================================================##
# set default value of sigmab
if (missing(sigmab))
sigmab <- 0
# calculate yu = log(ED) and su = se(logED)
if (log) {
yu <- log(data$ED)
su <- sqrt((data$ED_Error / data$ED)^2 + sigmab^2)
} else {
yu <- data$ED
su <- sqrt((data$ED_Error)^2 + sigmab^2)
}
# What does the code do?
# >> email conversation with Rex Galbraith 2019-06-29
# >> "fixed point iteration" method to estimate sigma
# >> starting with a fixed value
# >> once sqrt(sum((wu^2) * (yu - delta)^2 / sum(wu))) gets equal to 1
# >> the iteration is complete
# >> if everything has converged agains those fixed values
# >> this is the maximum likelihood estimate for
# >> sigma and delta
# calculate starting values and weights
sigma <- 0.15 # keep in mind that this is a relative value
wu <- 1 / (sigma^2 + su^2)
delta <- sum(wu * yu) / sum(wu)
n <- length(yu)
# compute mle's
for (j in 1:200) {
delta <- sum(wu * yu) / sum(wu)
sigma <- sigma * sqrt(sum((wu^2) * (yu - delta)^2 / sum(wu)))
wu <- 1 / (sigma^2 + su^2)
# print iterations
if (options$trace)
print(round(c(delta, sigma), 4))
## don't let sigma become zero
if (sigma < 1e-16)
break()
}
# save parameters for terminal output
out.delta <- ifelse(log, exp(delta), delta)
out.sigma <- ifelse(log, sigma * 100, sigma / out.delta * 100)
# log likelihood
llik <- 0.5 * sum(log(wu)) - 0.5 * sum(wu * (yu - delta)^2)
# save parameter for terminal output
out.llik <- round(llik, 4)
Lmax <- llik
# standard errors
sedelta <- 1 / sqrt(sum(wu))
sesigma <- 1 / sqrt(2 * sigma^2 * sum(wu^2))
# save parameters for terminal output
if (log) {
out.sedelta <- sedelta * 100
out.sesigma <- sesigma
} else {
out.sedelta <- sedelta / out.delta * 100
out.sesigma <- sqrt((sedelta / delta)^2 +
(sesigma / out.delta * 100 / out.sigma)^2) * out.sigma / 100
}
# profile log likelihood
sigmax <- sigma
llik <- 0
sig0 <- max(0, sigmax - 8 * sesigma)
sig1 <- sigmax + 9.5 * sesigma
sig <- try(seq(sig0, sig1, sig1 / 1000), silent = TRUE)
if (!inherits(sig, "try-error")) {
# TODO: rewrite this loop as a function and maximise with mle2 ll is the actual
# log likelihood, llik is a vector of all ll
for (s in sig) {
wu <- 1 / (s^2 + su^2)
mu <- sum(wu * yu)/sum(wu)
ll <- 0.5 * sum(log(wu)) - 0.5 * sum(wu * (yu - mu)^2)
llik <- c(llik, ll)
}
llik <- llik[-1] - Lmax
}
## ============================================================================##
## TERMINAL OUTPUT
## ============================================================================##
if (options$verbose) {
cat("\n [calc_CentralDose]")
cat(paste("\n\n----------- meta data ----------------"))
cat(paste("\n n: ", n))
cat(paste("\n log: ", log))
cat(paste("\n----------- dose estimate ------------"))
cat(paste("\n abs. central dose: ", format(out.delta, digits = 2, nsmall = 2)))
cat(paste("\n abs. SE: ", format(out.delta * out.sedelta/100,
digits = 2, nsmall = 2)))
cat(paste("\n rel. SE [%]: ", format(out.sedelta, digits = 2, nsmall = 2)))
cat(paste("\n----------- overdispersion -----------"))
cat(paste("\n abs. OD: ", format(ifelse(log, sigma * out.delta, sigma), digits = 2, nsmall = 2)))
cat(paste("\n abs. SE: ", format(ifelse(log, sesigma * out.delta, sesigma), digits = 2, nsmall = 2)))
cat(paste("\n OD [%]: ", format(out.sigma, digits = 2, nsmall = 2)))
cat(paste("\n SE [%]: ", if (!inherits(sig, "try-error")) {
format(out.sesigma * 100, digits = 2, nsmall = 2)
} else {
"-"
}))
cat(paste("\n-------------------------------------\n\n"))
}
## ============================================================================##
## RETURN VALUES
## ============================================================================##
if (inherits(sig, "try-error")) {
out.sigma <- 0
out.sesigma <- NA
}
if(!log) sig <- sig / delta
summary <- data.frame(
de = out.delta,
de_err = out.delta * out.sedelta / 100,
OD = ifelse(log, sigma * out.delta, sigma),
OD_err = ifelse(log, sesigma * out.delta, sesigma),
rel_OD = out.sigma,
rel_OD_err = out.sesigma * 100,
Lmax = Lmax)
args <- list(log = log, sigmab = sigmab)
newRLumResults.calc_CentralDose <- set_RLum(
class = "RLum.Results",
data = list(
summary = summary,
data = data,
args = args,
profile = data.frame(
sig = if(!inherits(sig, "try-error")) sig else NA,
llik = llik)
),
info = list(
call = sys.call()
)
)
## =========## PLOTTING
if (plot && !inherits(sig, "try-error"))
try(plot_RLum.Results(newRLumResults.calc_CentralDose, ...))
invisible(newRLumResults.calc_CentralDose)
}
Luminescence/R/plot_Risoe.BINfileData.R 0000644 0001762 0000144 00000021234 14762554470 017410 0 ustar ligges users #' @title Plot Single Luminescence Curves from a Risoe.BINfileData-class object
#'
#' @description Plots single luminescence curves from an object returned by the
#' [read_BIN2R] function [Risoe.BINfileData-class]
#'
#' @details
#' **Nomenclature**
#'
#' See [Risoe.BINfileData-class]
#'
#' **curve.transformation**
#'
#' This argument allows transforming continuous wave (CW) curves to pseudo
#' (linear) modulated curves. For the transformation, the functions of the
#' package are used. Currently, it is not possible to pass further arguments
#' to the transformation functions. The argument works only for `ltype`
#' `OSL` and `IRSL`.
#'
#' **Irradiation time**
#'
#' Plotting the irradiation time (s) or the given dose (Gy) requires that the
#' variable `IRR_TIME` has been set within the BIN-file. This is normally
#' done by using the 'Run Info' option within the Sequence Editor or by editing
#' in R.
#'
#' @param data [Risoe.BINfileData-class] (**required**):
#' requires an S4 object returned by the [read_BIN2R] function.
#'
#' @param position [vector] (*optional*):
#' option to limit the plotted curves by position
#' (e.g. `position = 1`, `position = c(1,3,5)`).
#'
#' @param run [vector] (*optional*):
#' option to limit the plotted curves by run
#' (e.g., `run = 1`, `run = c(1,3,5)`).
#'
#' @param set [vector] (*optional*):
#' option to limit the plotted curves by set
#' (e.g., `set = 1`, `set = c(1,3,5)`).
#'
#' @param sorter [character] (*with default*):
#' the plot output can be ordered by "POSITION","SET" or "RUN".
#' POSITION, SET and RUN are options defined in the Risoe Sequence Editor.
#'
#' @param ltype [character] (*with default*):
#' option to limit the plotted curves by the type of luminescence stimulation.
#' Allowed values: `"IRSL"`, `"OSL"`,`"TL"`, `"RIR"`, `"RBR"`
#' (corresponds to LM-OSL), `"RL"`. All type of curves are plotted by
#' default.
#'
#' @param curve.transformation [character] (*optional*):
#' allows transforming CW-OSL and CW-IRSL curves to pseudo-LM curves via
#' transformation functions. Allowed values are: `CW2pLM`, `CW2pLMi`,
#' `CW2pHMi` and `CW2pPMi`, see details. If set to `None` (default), no
#' transformation is applied.
#'
#' @param dose_rate [numeric] (*optional*):
#' dose rate of the irradiation source at the measurement date.
#' If set, the given irradiation dose will be shown in Gy. See details.
#'
#' @param temp.lab [character] (*optional*):
#' option to allow for different temperature units. If no value is set deg. C is chosen.
#'
#' @param cex.global [numeric] (*with default*):
#' global scaling factor.
#'
#' @param ... further undocumented plot arguments.
#'
#' @return Returns a plot.
#'
#' @note
#' The function has been successfully tested for the Sequence Editor file
#' output version 3 and 4.
#'
#' @section Function version: 0.4.2
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)\cr
#' Michael Dietze, GFZ Potsdam (Germany)
#'
#' @seealso [Risoe.BINfileData-class], [read_BIN2R], [convert_CW2pLM],
#' [convert_CW2pLMi], [convert_CW2pPMi], [convert_CW2pHMi]
#'
#' @references
#' Duller, G., 2007. Analyst. pp. 1-45.
#'
#' @keywords dplot
#'
#' @examples
#'
#' ##load data
#' data(ExampleData.BINfileData, envir = environment())
#'
#' ##plot all curves from the first position to the desktop
#' #pdf(file = "~/Desktop/CurveOutput.pdf", paper = "a4", height = 11, onefile = TRUE)
#'
#' ##example - load from *.bin file
#' #BINfile<- file.choose()
#' #BINfileData<-read_BIN2R(BINfile)
#'
#' #par(mfrow = c(4,3), oma = c(0.5,1,0.5,1))
#' #plot_Risoe.BINfileData(CWOSL.SAR.Data,position = 1)
#' #mtext(side = 4, BINfile, outer = TRUE, col = "blue", cex = .7)
#' #dev.off()
#'
#' @md
#' @export
plot_Risoe.BINfileData<- function(
data,
position,
run,
set,
sorter = "POSITION",
ltype = c("IRSL","OSL","TL","RIR","RBR","RL"),
curve.transformation = "None",
dose_rate,
temp.lab,
cex.global = 1,
...
) {
.set_function_name("plot_Risoe.BINfileData")
on.exit(.unset_function_name(), add = TRUE)
## Integrity checks -------------------------------------------------------
.validate_class(data, "Risoe.BINfileData")
curve.transformation <- .validate_args(curve.transformation,
c("CW2pLM", "CW2pLMi",
"CW2pHMi", "CW2pPMi", "None"))
## complete the function name
if (curve.transformation != "None") {
curve.transformation <- paste0("convert_", curve.transformation)
}
temp <- data
##set plot position if missing
if(missing(position)==TRUE){position<-c(min(temp@METADATA[,"POSITION"]):max(temp@METADATA[,"POSITION"]))}
if(missing(run)==TRUE){run<-c(min(temp@METADATA[,"RUN"]):max(temp@METADATA[,"RUN"]))}
if(missing(set)==TRUE){set<-c(min(temp@METADATA[,"SET"]):max(temp@METADATA[,"SET"]))}
##temp.lab
if(missing(temp.lab) == TRUE){temp.lab <- "\u00B0C"}
##fun
extraArgs <- list(...) # read out additional arguments list
fun <- if ("fun" %in% names(extraArgs)) extraArgs$fun else FALSE # nocov
# Ordering --------------------------------------------------------------------
##(1) order by RUN, SET OR BY POSITION
if(sorter=="RUN"){
temp@METADATA<-temp@METADATA[order(temp@METADATA[,"RUN"]),]
}else if(sorter=="SET"){
temp@METADATA<-temp@METADATA[order(temp@METADATA[,"SET"]),]
}else {
temp@METADATA<-temp@METADATA[order(temp@METADATA[,"POSITION"]),]
}
# Select values for plotting ------------------------------------------------------------------
##(2) set SEL for selected position
##set all to FALSE
temp@METADATA[,"SEL"]<-FALSE
##set TRUE
temp@METADATA[(temp@METADATA[,"POSITION"] %in% position)==TRUE &
(temp@METADATA[,"RUN"] %in% run)==TRUE &
(temp@METADATA[,"SET"] %in% set)==TRUE &
(temp@METADATA[,"LTYPE"] %in% ltype)==TRUE,"SEL"]<-TRUE
##------------------------------------------------------------------------##
##PLOTTING
##------------------------------------------------------------------------##
##(3) plot curves
for(i in 1:length(temp@METADATA[,"ID"])){
##print only if SEL == TRUE
if(temp@METADATA[i,"SEL"]==TRUE)
{
##find measured unit
measured_unit<-if(temp@METADATA[i,"LTYPE"]=="TL"){" \u00B0C"}else{"s"}
##set x and y values
values.x <- seq(temp@METADATA[i,"HIGH"]/temp@METADATA[i,"NPOINTS"],
temp@METADATA[i,"HIGH"],by=temp@METADATA[i,"HIGH"]/temp@METADATA[i,"NPOINTS"])
values.y <- unlist(temp@DATA[temp@METADATA[i,"ID"]])
values.xy <- data.frame(values.x, values.y)
##set curve transformation if wanted
if (grepl("IRSL|OSL", temp@METADATA[i, "LTYPE"]) &&
curve.transformation != "None") {
## get the actual function from the parameter value and apply it
values.xy <- get(curve.transformation)(values.xy)[, 1:2]
}
##plot graph
plot(values.xy,
main=paste("pos=", temp@METADATA[i,"POSITION"],", run=", temp@METADATA[i,"RUN"],
", set=", temp@METADATA[i,"SET"],sep=""
),
type="l",
ylab=paste(temp@METADATA[i,"LTYPE"]," [cts/",round(temp@METADATA[i,"HIGH"]/temp@METADATA[i,"NPOINTS"],digits=3)," ",
measured_unit,"]",sep=""),
xlab=if(measured_unit=="\u00B0C"){paste("temp. [",temp.lab,"]",sep="")}else{"time [s]"},
col=if(temp@METADATA[i,"LTYPE"]=="IRSL" | temp@METADATA[i,"LTYPE"]=="RIR"){"red"}
else if(temp@METADATA[i,"LTYPE"]=="OSL" | temp@METADATA[i,"LTYPE"]=="RBR"){"blue"}
else{"black"},
sub=if(temp@METADATA[i,"LTYPE"]=="TL"){paste("(",temp@METADATA[i,"RATE"]," K/s)",sep="")}else{},
lwd=1.2*cex.global,
cex=0.9*cex.global
)
##add mtext for temperature
##grep temperature (different for different verions)
temperature <- if(temp@METADATA[i,"VERSION"]=="03") {
temp@METADATA[i,"AN_TEMP"]
} else {
temp@METADATA[i,"TEMPERATURE"]
}
##mtext
mtext(side=3,
if(temp@METADATA[i,"LTYPE"]=="TL"){paste("TL to ",temp@METADATA[i,"HIGH"], " ",temp.lab,sep="")}
else{paste(temp@METADATA[i,"LTYPE"],"@",temperature," ",temp.lab ,sep="")},
cex=0.9*cex.global)
##add mtext for irradiation
mtext(side=4,cex=0.8*cex.global, line=0.5,
if(temp@METADATA[i, "IRR_TIME"]!=0){
if(missing("dose_rate")==TRUE){
paste("dose = ",temp@METADATA[i, "IRR_TIME"], " s", sep="")
}else{
paste("dose = ",temp@METADATA[i, "IRR_TIME"]*dose_rate, " Gy", sep="")
}
}
)#end mtext
}#endif::selection
}#endforloop
if (fun == TRUE) sTeve() # nocov
}
Luminescence/R/analyse_pIRIRSequence.R 0000644 0001762 0000144 00000073060 14762554470 017366 0 ustar ligges users #' @title Analyse post-IR IRSL measurement sequences
#'
#' @description The function performs an analysis of post-IR IRSL sequences
#' including curve
#' fitting on [RLum.Analysis-class] objects.
#'
#' @details To allow post-IR IRSL protocol (Thomsen et al., 2008) measurement
#' analyses, this function has been written as extended wrapper for function
#' [analyse_SAR.CWOSL], thus facilitating an entire sequence analysis in
#' one run. With this, its functionality is strictly limited by the
#' functionality provided by [analyse_SAR.CWOSL].
#'
#' **Defining the sequence structure**
#'
#' The argument `sequence.structure` expects a shortened pattern of your sequence structure and was
#' mainly introduced to ease the use of the function. For example: If your measurement data contains
#' the following curves: `TL`, `IRSL`, `IRSL`, `TL`, `IRSL`, `IRSL`, the sequence pattern in `sequence.structure`
#' becomes `c('TL', 'IRSL', 'IRSL')`. The second part of your sequence for one cycle should be
#' similar and can be discarded. If this is not the case (e.g., additional hotbleach) such curves
#' have to be removed before using the function.
#'
#' **If the input is a `list`**
#'
#' If the input is a list of [RLum.Analysis-class] objects, every argument
#' can be provided as list to allow
#' for different sets of parameters for every single input element.
#' For further information see [analyse_SAR.CWOSL].
#'
#' @param object [RLum.Analysis-class] or [list] of [RLum.Analysis-class] objects (**required**):
#' input object containing data for analysis.
#' If a [list] is provided the functions tries to iterate over each element
#' in the list.
#'
#' @param signal.integral.min [integer] (**required**):
#' lower bound of the signal integral. Provide this value as vector for different
#' integration limits for the different IRSL curves.
#'
#' @param signal.integral.max [integer] (**required**):
#' upper bound of the signal integral. Provide this value as vector for different
#' integration limits for the different IRSL curves.
#'
#' @param background.integral.min [integer] (**required**):
#' lower bound of the background integral. Provide this value as vector for
#' different integration limits for the different IRSL curves.
#'
#' @param background.integral.max [integer] (**required**):
#' upper bound of the background integral. Provide this value as vector for
#' different integration limits for the different IRSL curves.
#'
#' @param dose.points [numeric] (*optional*):
#' a numeric vector containing the dose points values. Using this argument overwrites dose point
#' values in the signal curves.
#'
#' @param sequence.structure [vector] [character] (*with default*):
#' specifies the general sequence structure. Allowed values are `"TL"` and
#' any `"IR"` combination (e.g., `"IR50"`,`"pIRIR225"`).
#' Additionally a parameter `"EXCLUDE"` is allowed to exclude curves from
#' the analysis (Note: If a preheat without PMT measurement is used, i.e.
#' preheat as none TL, remove the TL step.)
#'
#' @param plot [logical] (*with default*):
#' enable/disable the plot output.
#'
#' @param plot_singlePanels [logical] (*with default*):
#' enable/disable plotting of the results in a single windows for each plot.
#' Ignored if `plot = FALSE`.
#'
#' @param ... further arguments that will be passed to
#' [analyse_SAR.CWOSL] and [plot_GrowthCurve]. Furthermore, the
#' arguments `main` (headers), `log` (IRSL curves), `cex` (control
#' the size) and `mtext.outer` (additional text on the plot area) can be passed to influence the plotting. If the input
#' is a list, `main` can be passed as [vector] or [list].
#'
#' @return
#' Plots (*optional*) and an [RLum.Results-class] object is
#' returned containing the following elements:
#'
#' \tabular{lll}{
#' **DATA.OBJECT** \tab **TYPE** \tab **DESCRIPTION** \cr
#' `..$data` : \tab `data.frame` \tab Table with De values \cr
#' `..$LnLxTnTx.table` : \tab `data.frame` \tab with the `LnLxTnTx` values \cr
#' `..$rejection.criteria` : \tab [data.frame] \tab rejection criteria \cr
#' `..$Formula` : \tab [list] \tab Function used for fitting of the dose response curve \cr
#' `..$call` : \tab [call] \tab the original function call
#' }
#'
#' The output should be accessed using the function [get_RLum].
#'
#' @note
#' Best graphical output can be achieved by using the function `pdf`
#' with the following options:
#'
#' `pdf(file = "", height = 18, width = 18)`
#'
#' @section Function version: 0.2.5
#'
#' @author Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [analyse_SAR.CWOSL], [calc_OSLLxTxRatio], [plot_GrowthCurve],
#' [RLum.Analysis-class], [RLum.Results-class] [get_RLum]
#'
#' @references
#' Murray, A.S., Wintle, A.G., 2000. Luminescence dating of quartz
#' using an improved single-aliquot regenerative-dose protocol. Radiation
#' Measurements 32, 57-73. \doi{10.1016/S1350-4487(99)00253-X}
#'
#' Thomsen, K.J., Murray, A.S., Jain, M., Boetter-Jensen, L., 2008. Laboratory
#' fading rates of various luminescence signals from feldspar-rich sediment
#' extracts. Radiation Measurements 43, 1474-1486.
#' \doi{10.1016/j.radmeas.2008.06.002}
#'
#' @keywords datagen plot
#'
#' @examples
#'
#'
#' ### NOTE: For this example existing example data are used. These data are non pIRIR data.
#' ###
#' ##(1) Compile example data set based on existing example data (SAR quartz measurement)
#' ##(a) Load example data
#' data(ExampleData.BINfileData, envir = environment())
#'
#' ##(b) Transform the values from the first position in a RLum.Analysis object
#' object <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos=1)
#'
#' ##(c) Grep curves and exclude the last two (one TL and one IRSL)
#' object <- get_RLum(object, record.id = c(-29,-30))
#'
#' ##(d) Define new sequence structure and set new RLum.Analysis object
#' sequence.structure <- c(1,2,2,3,4,4)
#' sequence.structure <- as.vector(sapply(seq(0,length(object)-1,by = 4),
#' function(x){sequence.structure + x}))
#'
#' object <- sapply(1:length(sequence.structure), function(x){
#' object[[sequence.structure[x]]]
#' })
#'
#' object <- set_RLum(class = "RLum.Analysis", records = object, protocol = "pIRIR")
#'
#' ##(2) Perform pIRIR analysis (for this example with quartz OSL data!)
#' ## Note: output as single plots to avoid problems with this example
#' results <- analyse_pIRIRSequence(object,
#' signal.integral.min = 1,
#' signal.integral.max = 2,
#' background.integral.min = 900,
#' background.integral.max = 1000,
#' fit.method = "EXP",
#' sequence.structure = c("TL", "pseudoIRSL1", "pseudoIRSL2"),
#' main = "Pseudo pIRIR data set based on quartz OSL",
#' plot_singlePanels = TRUE)
#'
#'
#' ##(3) Perform pIRIR analysis (for this example with quartz OSL data!)
#' ## Alternative for PDF output, uncomment and complete for usage
#' \dontrun{
#' tempfile <- tempfile(fileext = ".pdf")
#' pdf(file = tempfile, height = 18, width = 18)
#' results <- analyse_pIRIRSequence(object,
#' signal.integral.min = 1,
#' signal.integral.max = 2,
#' background.integral.min = 900,
#' background.integral.max = 1000,
#' fit.method = "EXP",
#' main = "Pseudo pIRIR data set based on quartz OSL")
#'
#' dev.off()
#' }
#'
#' @md
#' @export
analyse_pIRIRSequence <- function(
object,
signal.integral.min,
signal.integral.max,
background.integral.min,
background.integral.max,
dose.points = NULL,
sequence.structure = c("TL", "IR50", "pIRIR225"),
plot = TRUE,
plot_singlePanels = FALSE,
...
) {
.set_function_name("analyse_pIRIRSequence")
on.exit(.unset_function_name(), add = TRUE)
# SELF CALL -----------------------------------------------------------------------------------
if(is.list(object)){
lapply(object, function(x) {
.validate_class(x, "RLum.Analysis", name = "All elements of 'object'")
})
## make life easy
if(missing("signal.integral.min")){
signal.integral.min <- 1
.throw_warning("'signal.integral.min' missing, set to 1")
}
if(missing("signal.integral.max")){
signal.integral.max <- 2
.throw_warning("'signal.integral.max' missing, set to 2")
}
## expand input arguments
rep.length <- length(object)
signal.integral.min <- .listify(signal.integral.min, rep.length)
signal.integral.max <- .listify(signal.integral.max, rep.length)
background.integral.min <- .listify(background.integral.min, rep.length)
background.integral.max <- .listify(background.integral.max, rep.length)
sequence.structure <- .listify(sequence.structure, rep.length)
dose.points <- .listify(dose.points, rep.length)
if ("main" %in% names(list(...))) {
main_list <- .listify(list(...)$main, rep.length)
}
## run analysis
temp <- .warningCatcher(lapply(1:length(object), function(x) {
analyse_pIRIRSequence(object[[x]],
signal.integral.min = signal.integral.min[[x]],
signal.integral.max = signal.integral.max[[x]],
background.integral.min = background.integral.min[[x]],
background.integral.max = background.integral.max[[x]] ,
dose.points = dose.points[[x]],
sequence.structure = sequence.structure[[x]],
plot = plot,
plot_singlePanels = plot_singlePanels,
main = ifelse("main"%in% names(list(...)), main_list[[x]], paste0("ALQ #",x)),
...)
}))
##combine everything to one RLum.Results object as this as what was written ... only
##one object
##merge results and check if the output became NULL
results <- merge_RLum(temp)
##DO NOT use invisible here, this will stop the function from stopping
if(length(results) == 0)
return(NULL)
else
return(results)
}
## Integrity checks -------------------------------------------------------
.validate_class(object, "RLum.Analysis", extra = "'list'")
.validate_logical_scalar(plot)
.validate_logical_scalar(plot_singlePanels)
## there must be at least an IR step
if (!any(grepl("IR", sequence.structure))) {
.throw_error("'sequence.structure' should contain at least one IR step")
}
## check allowed values in sequence structure
temp.collect.invalid.terms <- .collapse(
sequence.structure[!grepl("TL", sequence.structure) &
!grepl("IR", sequence.structure) &
!grepl("OSL", sequence.structure) &
!grepl("EXCLUDE", sequence.structure)])
if (temp.collect.invalid.terms != "") {
.throw_error(temp.collect.invalid.terms,
" not allowed in 'sequence.structure'")
}
## deprecated argument
if ("plot.single" %in% names(list(...))) {
plot_singlePanels <- list(...)$plot.single
.throw_warning("'plot.single' is deprecated, use 'plot_singlePanels' ",
"instead")
}
## Enforce a minimum plot device size: this is necessary as otherwise users
## may experience "figure margins too large" errors when trying to draw all
## plots on a single page. We need to round the device size values because
## often they are values such as 15.99999999999 which would incorrectly
## trigger our check
min.size <- 16
dev.size <- round(grDevices::dev.size("in"), 5)
if (plot && !plot_singlePanels && any(dev.size < min.size)) {
plot <- FALSE
msg <- paste0("Argument 'plot' reset to 'FALSE'. The smallest plot ",
"size required is IN x IN in.\nConsider plotting via ",
"`pdf(..., width = IN, height = IN)` ",
"or setting `plot_singlePanels = TRUE`")
.throw_warning(gsub(x = msg, "IN", min.size))
}
# Deal with extra arguments -------------------------------------------------------------------
## default values
mtext.outer <- "MEASUREMENT INFO"
main <- ""
log <- ""
cex <- 0.7
##deal with addition arguments
extraArgs <- list(...)
mtext.outer <- if ("mtext.outer" %in% names(extraArgs)) extraArgs$mtext.outer
main <- if ("main" %in% names(extraArgs)) extraArgs$main
log <- if ("log" %in% names(extraArgs)) extraArgs$log
cex <- if ("cex" %in% names(extraArgs)) extraArgs$cex
# Protocol Integrity Checks --------------------------------------------------
##(1) Check structure and remove curves that fit not the recordType criteria
##get sequence structure
temp.sequence.structure <- structure_RLum(object)
##remove data types that fit not to the allowed values
temp.sequence.rm.id <- temp.sequence.structure[
(!grepl("TL",temp.sequence.structure[["recordType"]])) &
(!grepl("OSL", temp.sequence.structure[["recordType"]])) &
(!grepl("IRSL", temp.sequence.structure[["recordType"]]))
,"id"]
if(length(temp.sequence.rm.id)>0){
##removed record from data set
object <- get_RLum(object, record.id = -temp.sequence.rm.id,
drop = FALSE
)
.throw_warning("The following unrecognised record types have been removed: ",
.collapse(temp.sequence.structure[temp.sequence.rm.id,
"recordType"]))
}
##(2) Apply user sequence structure
##get sequence structure
temp.sequence.structure <- structure_RLum(object)
##try to account for a very common mistake
if(any(grepl(sequence.structure, pattern = "TL", fixed = TRUE)) && !any(grepl(temp.sequence.structure[["recordType"]], pattern = "TL", fixed = TRUE))){
.throw_warning("Your sequence does not contain 'TL' curves, trying ",
"to adapt 'sequence.structure' for you ...")
sequence.structure <- sequence.structure[!grepl(sequence.structure, pattern = "TL", fixed = TRUE)]
}
##set values to structure data.frame
##but check first
if(2 * length(
rep(sequence.structure, nrow(temp.sequence.structure)/2/length(sequence.structure))) == length(temp.sequence.structure[["protocol.step"]])){
temp.sequence.structure[["protocol.step"]] <- rep(
sequence.structure, nrow(temp.sequence.structure)/2/length(sequence.structure))
}else{
.throw_message("The number of records is not a multiple of the defined ",
"sequence structure, NULL returned")
return(NULL)
}
##remove values that have been excluded
temp.sequence.rm.id <- temp.sequence.structure[
temp.sequence.structure[,"protocol.step"] == "EXCLUDE" ,"id"]
if(length(temp.sequence.rm.id)>0){
##remove from object
object <- get_RLum(
object, record.id = -temp.sequence.rm.id, drop = FALSE)
##remove from sequence structure
sequence.structure <- sequence.structure[sequence.structure != "EXCLUDE"]
##set new structure
temp.sequence.structure <- structure_RLum(object)
temp.sequence.structure[, "protocol.step"] <- rep(
sequence.structure, nrow(temp.sequence.structure)/2/length(temp.sequence.structure))
##print warning message
.throw_warning(length(temp.sequence.rm.id),
" records have been removed due to EXCLUDE")
}
##============================================================================##
# Analyse data and plotting ----------------------------------------------------
##============================================================================##
##(1) find out how many runs are needed for the analysis by checking for "IR"
## now should by every signal except the TL curves
n.TL <- sum(grepl("TL", sequence.structure))
n.loops <- as.numeric(length(sequence.structure) - n.TL)
##grep ids of TL curves (we need them later on)
TL.curves.id <- temp.sequence.structure[
temp.sequence.structure[,"protocol.step"] == "TL","id"]
##grep ids of all OSL curves (we need them later on)
IRSL.curves.id <- temp.sequence.structure[
grepl("IR", temp.sequence.structure[,"protocol.step"]),"id"]
##grep information on the names of the IR curves, we need them later on
pIRIR.curve.names <- unique(temp.sequence.structure[
temp.sequence.structure[IRSL.curves.id,"id"],"protocol.step"])
##===========================================================================#
## set graphic layout using the layout option
## unfortunately a little bit more complicated then expected previously due
## the order of the produced plots by the previous functions
if (plot && !plot_singlePanels) {
##first (Tx,Tn, Lx,Ln)
temp.IRSL.layout.vector.first <- c(3,5,6,7,3,5,6,8)
## middle (any other Lx,Ln)
temp.IRSL.layout.vector.middle <- NULL
if (n.loops > 2) {
temp.IRSL.layout.vector.middle <-
vapply(2:(n.loops - 1),
FUN = function(x) 5 * x - 1 + c(0:3, 0:2, 4),
FUN.VALUE = vector(mode = "numeric", length = 8)
)
}
## last (Lx, Ln and legend)
temp.IRSL.layout.vector.last <- c(1, 2, 4, 5, 1, 2, 4, 6) +
(if (n.loops > 2) max(temp.IRSL.layout.vector.middle)
else max(temp.IRSL.layout.vector.first))
temp.IRSL.layout.vector <- c(temp.IRSL.layout.vector.first,
temp.IRSL.layout.vector.middle,
temp.IRSL.layout.vector.last)
##get layout information
def.par <- par(no.readonly = TRUE)
##set up layout matrix linked to the number of plot areas needed
layout.matrix <- c(
rep(c(2,4,1,1),2), #header row with TL curves and info window
temp.IRSL.layout.vector, #IRSL curves,
rep((max(temp.IRSL.layout.vector)-3),8), #legend,
rep((max(temp.IRSL.layout.vector)+1),1), #GC
rep((max(temp.IRSL.layout.vector)+2),1), #TnTc
rep((max(temp.IRSL.layout.vector)+3),2), #Rejection criteria
rep((max(temp.IRSL.layout.vector)+1),1), #GC
rep((max(temp.IRSL.layout.vector)+2),1), #TnTc
rep((max(temp.IRSL.layout.vector)+3),2)) #Rejection criteria
##set layout
nf <- layout(
matrix(layout.matrix,(max(layout.matrix)/2 +
ifelse(n.loops > 2, 0,2)), 4, byrow = TRUE),
widths = c(rep(c(1,1,1,.75),6),c(1,1,1,1)),
heights = c(rep(c(1),(2+2*n.loops)),c(0.20, 0.20)))
## show the regions that have been allocated to each plot for debug
#layout.show(nf)
}
##(1) INFO PLOT
if (plot) {
plot(NA,NA,
ylim = c(0,1), xlab = "",
xlim = c(0,1), ylab = "",
axes = FALSE,
main = main)
text(0.5,0.5, paste(sequence.structure, collapse = "\n"), cex = cex *2)
}
##(2) set loop
for(i in 1:n.loops){
##compile record ids
temp.id.sel <-
sort(c(TL.curves.id, IRSL.curves.id[seq(i,length(IRSL.curves.id),by=n.loops)]))
##(a) select data set (TL curves has to be considered for the data set)
temp.curves <- get_RLum(object, record.id = temp.id.sel, drop = FALSE)
##(b) grep integral limits as they might be different for different curves
if(length(signal.integral.min)>1){
temp.signal.integral.min <- signal.integral.min[i]
temp.signal.integral.max <- signal.integral.max[i]
temp.background.integral.min <- background.integral.min[i]
temp.background.integral.max <- background.integral.max[i]
}else{
temp.signal.integral.min <- signal.integral.min
temp.signal.integral.max <- signal.integral.max
temp.background.integral.min <- background.integral.min
temp.background.integral.max <- background.integral.max
}
##(c) call analysis sequence and plot
## call single plots
if(i == 1){
temp.plot.single <- c(1,2,3,4,6)
}else if(i == n.loops){
temp.plot.single <- c(2,4,5,6)
}else{
temp.plot.single <- c(2,4,6)
}
##start analysis
temp.results <- analyse_SAR.CWOSL(
temp.curves,
signal.integral.min = temp.signal.integral.min,
signal.integral.max = temp.signal.integral.max,
background.integral.min = temp.background.integral.min,
background.integral.max = temp.background.integral.max,
plot = plot,
dose.points = dose.points,
plot_singlePanels = temp.plot.single,
cex.global = cex,
...
) ##TODO should be replaced be useful explicit arguments
##check whether NULL was return
if (is.null(temp.results)) {
.throw_message("Analysis skipped: check your sequence, NULL returned")
return(NULL)
}
##add signal information to the protocol step
temp.results.pIRIR.De <- as.data.frame(c(
get_RLum(temp.results, "data"),
data.frame(Signal = pIRIR.curve.names[i])
))
temp.results.pIRIR.LnLxTnTx <- as.data.frame(c(
get_RLum(temp.results, "LnLxTnTx.table"),
data.frame(Signal = pIRIR.curve.names[i])
))
temp.results.pIRIR.rejection.criteria <- as.data.frame(c(
get_RLum(temp.results, "rejection.criteria"),
data.frame(Signal = pIRIR.curve.names[i])
))
temp.results.pIRIR.formula <- list(get_RLum(temp.results,
"Formula"))
names(temp.results.pIRIR.formula) <- pIRIR.curve.names[i]
##create now object
temp.results <- set_RLum(
class = "RLum.Results",
data = list(
data = temp.results.pIRIR.De,
LnLxTnTx.table = temp.results.pIRIR.LnLxTnTx,
rejection.criteria = temp.results.pIRIR.rejection.criteria,
Formula = temp.results.pIRIR.formula
),
info = list(
call = sys.call()
)
)
##merge results
if (exists("temp.results.final")) {
temp.results.final <- merge_RLum(list(temp.results.final, temp.results))
} else{
temp.results.final <- temp.results
}
}
##============================================================================##
# Plotting additional --------------------------------------------------------
##============================================================================##
if(plot){
##extract LnLnxTnTx.table
LnLxTnTx.table <- get_RLum(temp.results.final, "LnLxTnTx.table")
## remove Inf
LnLxTnTx.table$LxTx[is.infinite(LnLxTnTx.table$LxTx)] <- NA
LnLxTnTx.table$LxTx.Error[is.infinite(LnLxTnTx.table$LxTx.Error)] <- NA
##plot growth curves
min.LxTx <- min(LnLxTnTx.table$LxTx, na.rm = TRUE)
max.LxTx <- max(LnLxTnTx.table$LxTx, na.rm = TRUE)
max.LxTx.Error <- max(LnLxTnTx.table$LxTx.Error, na.rm = TRUE)
plot(NA, NA,
xlim = range(get_RLum(temp.results.final, "LnLxTnTx.table")$Dose),
ylim = c(min(min.LxTx - max.LxTx.Error, 0), max.LxTx + max.LxTx.Error),
xlab = "Dose [s]",
ylab = expression(L[x]/T[x]),
main = "Summarised Dose Response Curves")
##set x for expression evaluation
x <- seq(0,max(LnLxTnTx.table$Dose)*1.05, length.out = 100)
for(j in 1:length(pIRIR.curve.names)){
##dose points
temp.curve.points <- LnLxTnTx.table[,c("Dose", "LxTx", "LxTx.Error", "Signal")]
temp.curve.points <- temp.curve.points[
temp.curve.points[,"Signal"] == pIRIR.curve.names[j],
c("Dose", "LxTx", "LxTx.Error")]
points(temp.curve.points[-1,c("Dose", "LxTx")], col = j, pch = j)
segments(x0 = temp.curve.points[-1,c("Dose")],
y0 = temp.curve.points[-1,c("LxTx")] -
temp.curve.points[-1,c("LxTx.Error")],
x1 = temp.curve.points[-1,c("Dose")],
y1 = temp.curve.points[-1,c("LxTx")] +
temp.curve.points[-1,c("LxTx.Error")],
col = j)
##De values
lines(c(0, get_RLum(temp.results.final, "data")[j,1]),
c(temp.curve.points[1,c("LxTx")], temp.curve.points[1,c("LxTx")]),
col = j,
lty = 2)
lines(c(rep(get_RLum(temp.results.final, "data")[j,1], 2)),
c(temp.curve.points[1,c("LxTx")], 0),
col = j,
lty = 2)
##curve
temp.curve.formula <- get_RLum(
temp.results.final, "Formula")[[pIRIR.curve.names[j]]]
try(lines(x, eval(temp.curve.formula), col = j), silent = TRUE)
}
rm(x)
##plot legend
legend("bottomright", legend = pIRIR.curve.names,
lty = 1, col = c(1:length(pIRIR.curve.names)),
bty = "n",
pch = c(1:length(pIRIR.curve.names))
)
##plot Tn/Tx curves
##select signal
temp.curve.TnTx <- LnLxTnTx.table[, c("TnTx", "Signal")]
temp.curve.TnTx.matrix <- matrix(NA,
nrow = nrow(temp.curve.TnTx)/
length(pIRIR.curve.names),
ncol = length(pIRIR.curve.names))
##calculate normalised values
for(j in 1:length(pIRIR.curve.names)){
temp.curve.TnTx.sel <- temp.curve.TnTx[
temp.curve.TnTx[,"Signal"] == pIRIR.curve.names[j]
, "TnTx"]
temp.curve.TnTx.matrix[,j] <- temp.curve.TnTx.sel/temp.curve.TnTx.sel[1]
}
plot(NA, NA,
xlim = c(0,nrow(LnLxTnTx.table)/
n.loops),
ylim = if (anyNA(range(temp.curve.TnTx.matrix))) c(0,1) else range(temp.curve.TnTx.matrix),
xlab = "# Cycle",
ylab = expression(T[x]/T[n]),
main = "Sensitivity change")
##zero line
abline(h = 1:nrow(temp.curve.TnTx.matrix), col = "gray")
for(j in 1:length(pIRIR.curve.names)){
lines(1:nrow(temp.curve.TnTx.matrix),
temp.curve.TnTx.matrix[,j],
type = "b",
col = j,
pch = j)
}
##plot legend
legend("bottomleft", legend = pIRIR.curve.names,
lty = 1, col = c(1:length(pIRIR.curve.names)),
bty = "n",
pch = c(1:length(pIRIR.curve.names))
)
##Rejection criteria
temp.rejection.criteria <- get_RLum(temp.results.final,
data.object = "rejection.criteria")
temp.rc.reycling.ratio <- temp.rejection.criteria[
grep("Recycling ratio",temp.rejection.criteria[,"Criteria"]),]
temp.rc.recuperation.rate <- temp.rejection.criteria[
grep("Recuperation rate",temp.rejection.criteria[,"Criteria"]),]
temp.rc.palaedose.error <- temp.rejection.criteria[
grep("Palaeodose error",temp.rejection.criteria[,"Criteria"]),]
plot(NA,NA,
xlim = c(-0.5,0.5),
ylim = c(0,30),
yaxt = "n", ylab = "",
xaxt = "n", xlab = "",
bty = "n",
main = "Rejection criteria")
axis(side = 1, at = c(-0.2,-0.1,0,0.1,0.2), labels = c("- 0.2", "- 0.1","0/1","+ 0.1", "+ 0.2"))
##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++##
##polygon for recycling ratio
text(x = -.4, y = 30, "Recycling ratio", pos = 1, srt = 0)
polygon(x = c(-as.numeric(as.character(temp.rc.reycling.ratio$Threshold))[1],
-as.numeric(as.character(temp.rc.reycling.ratio$Threshold))[1],
as.numeric(as.character(temp.rc.reycling.ratio$Threshold))[1],
as.numeric(as.character(temp.rc.reycling.ratio$Threshold))[1]),
y = c(21,29,29,21), col = "gray", border = NA)
polygon(x = c(-0.3,-0.3,0.3,0.3) , y = c(21,29,29,21))
##consider possibility of multiple pIRIR signals and multiple recycling ratios
col.id <- 1
##the conditional case might valid if no rejection criteria could be calculated
if(nrow(temp.rc.recuperation.rate)>0){
for(i in seq(1,nrow(temp.rc.recuperation.rate),
length(unique(temp.rc.recuperation.rate[,"Criteria"])))){
for(j in 0:length(unique(temp.rc.recuperation.rate[,"Criteria"]))){
points(temp.rc.reycling.ratio[i+j, "Value"]-1,
y = 25,
pch = col.id,
col = col.id)
}
col.id <- col.id + 1
}
}#endif
rm(col.id)
##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++##
##polygon for recuperation rate
text(x = -.4, y = 20, "Recuperation rate", pos = 1, srt = 0)
if(length(as.character(temp.rc.recuperation.rate$Threshold))>0){
polygon(x = c(0,
0,
as.numeric(as.character(temp.rc.recuperation.rate$Threshold))[1],
as.numeric(as.character(temp.rc.recuperation.rate$Threshold))[1]),
y = c(11,19,19,11), col = "gray", border = NA)
polygon(x = c(-0.3,-0.3,0.3,0.3) , y = c(11,19,19,11))
polygon(x = c(-0.3,-0.3,0,0) , y = c(11,19,19,11), border = NA, density = 10, angle = 45)
for(i in 1:nrow(temp.rc.recuperation.rate)){
points(temp.rc.palaedose.error[i, "Value"],
y = 15,
pch = i,
col = i)
}
}#endif
##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++##
##polygon for palaeodose error
text(x = -.4, y = 10, "Palaeodose error", pos = 1, srt = 0)
polygon(x = c(0,
0,
as.numeric(as.character(temp.rc.palaedose.error$Threshold))[1],
as.numeric(as.character(temp.rc.palaedose.error$Threshold))[1]),
y = c(1,9,9,1), col = "gray", border = NA)
polygon(x = c(-0.3,-0.3,0.3,0.3) , y = c(1,9,9,1))
polygon(x = c(-0.3,-0.3,0,0) , y = c(1,9,9,1), border = NA, density = 10, angle = 45)
for(i in 1:nrow(temp.rc.palaedose.error)){
if(length(temp.rc.palaedose.error[i, "Value"]) > 0 && !is.na(temp.rc.palaedose.error[i, "Value"]))
points(temp.rc.palaedose.error[i, "Value"],
y = 5,
pch = i,
col = i)
}
##add 0 value
lines(x = c(0,0), y = c(0,19), lwd = 1.5*cex)
lines(x = c(0,0), y = c(20,29), lwd = 1.5*cex)
##plot legend
legend("bottomright", legend = pIRIR.curve.names,
col = c(1:length(pIRIR.curve.names)),
bty = "n",
pch = c(1:length(pIRIR.curve.names)))
##reset graphic settings
if (!plot_singlePanels) {
par(def.par)
}
}##end plot == TRUE
##============================================================================##
# Return Values -----------------------------------------------------------
##============================================================================##
return(temp.results.final)
}
Luminescence/R/analyse_SAR.CWOSL.R 0000644 0001762 0000144 00000162774 14762554470 016276 0 ustar ligges users #' @title Analyse SAR CW-OSL measurements
#'
#' @description The function performs a SAR CW-OSL analysis on an
#' [RLum.Analysis-class] object including growth curve fitting.
#'
#' @details
#' The function performs an analysis for a standard SAR protocol measurements
#' introduced by Murray and Wintle (2000) with CW-OSL curves. For the
#' calculation of the `Lx/Tx` value the function [calc_OSLLxTxRatio] is
#' used. For **changing the way the Lx/Tx error is calculated** use the argument
#' `background.count.distribution` and `sigmab`, which will be passed to the function
#' [calc_OSLLxTxRatio].
#'
#' **What is part of a SAR sequence?**
#'
#' The function is rather picky when it comes down to accepted curve input (OSL,IRSL,...) and structure.
#' A SAR sequence is basically a set of \eqn{L_{x}/T_{x}} curves. Hence, every 2nd curve
#' is considered a shine-down curve related to the test dose. It also means that the number of
#' curves for \eqn{L_{x}} has to be equal to the number of \eqn{T_{x}} curves, and that
#' hot-bleach curves **do not** belong into a SAR sequence; at least not for the analysis.
#' Other curves allowed and processed are preheat curves, or preheat curves measured as TL, and
#' irradiation curves. The later one indicates the duration of the irradiation, the
#' dose and test dose points, e.g., as part of XSYG files.
#'
#' **Argument `object` is of type `list`**
#'
#' If the argument `object` is of type [list] containing **only**
#' [RLum.Analysis-class] objects, the function re-calls itself as often as elements
#' are in the list. This is useful if an entire measurement wanted to be analysed without
#' writing separate for-loops. To gain in full control of the parameters (e.g., `dose.points`) for
#' every aliquot (corresponding to one [RLum.Analysis-class] object in the list), in
#' this case the arguments can be provided as [list]. This `list` should
#' be of similar length as the `list` provided with the argument `object`,
#' otherwise the function will create an own list of the requested length.
#' Function output will be just one single [RLum.Results-class] object.
#'
#' Please be careful when using this option. It may allow a fast an efficient data analysis, but
#' the function may also break with an unclear error message, due to wrong input data.
#'
#' **Working with IRSL data**
#'
#' The function was originally designed to work just for 'OSL' curves,
#' following the principles of the SAR protocol. An IRSL measurement protocol
#' may follow this procedure, e.g., post-IR IRSL protocol (Thomsen et al.,
#' 2008). Therefore this functions has been enhanced to work with IRSL data,
#' however, the function is only capable of analysing curves that follow the
#' SAR protocol structure, i.e., to analyse a post-IR IRSL protocol, curve data
#' have to be pre-selected by the user to fit the standards of the SAR
#' protocol, i.e., Lx,Tx,Lx,Tx and so on.
#'
#' Example: Imagine the measurement contains `pIRIR50` and `pIRIR225` IRSL curves.
#' Only one curve type can be analysed at the same time: The `pIRIR50` curves or
#' the `pIRIR225` curves.
#'
#' **Supported rejection criteria**
#'
#' `[recycling.ratio]`: calculated for every repeated regeneration dose point.
#'
#' `[recuperation.rate]`: recuperation rate calculated by comparing the
#' `Lx/Tx` values of the zero regeneration point with the `Ln/Tn` value (the `Lx/Tx`
#' ratio of the natural signal). For methodological background see Aitken and
#' Smith (1988). As a variant with the argument `recuperation_reference` another dose point can be
#' selected as reference instead of `Ln/Tn`.
#'
#' `[testdose.error]`: set the allowed error for the test dose, which per
#' default should not exceed 10%. The test dose error is calculated as `Tx_net.error/Tx_net`.
#' The calculation of the \eqn{T_{n}} error is detailed in [calc_OSLLxTxRatio].
#'
#' `[palaeodose.error]`: set the allowed error for the De value, which per
#' default should not exceed 10%.
#'
#' **Irradiation times**
#'
#' The function makes two attempts to extra irradiation data (dose points)
#' automatically from the input object, if the argument `dose.points` was not
#' set (aka set to `NULL`).
#'
#' 1. It searches in every curve for an info object called `IRR_TIME`. If this was set, any value
#' set here is taken as dose point.
#'
#' 2. If the object contains curves of type `irradiation`, the function tries to
#' use this information to assign these values to the curves. However, the function
#' does **not** overwrite values preset in `IRR_TIME`.
#'
#' @param object [RLum.Analysis-class] (**required**):
#' input object containing data for analysis, alternatively a [list] of
#' [RLum.Analysis-class] objects can be provided. The object should contain **only** curves
#' considered part of the SAR protocol (see Details).
#'
#' @param signal.integral.min [integer] (**required**):
#' lower bound of the signal integral. Can be a [list] of [integer]s, if `object` is
#' of type [list]. If the input is vector (e.g., `c(1,2)`) the 2nd value will be interpreted
#' as the minimum signal integral for the `Tx` curve. Can be set to `NA`, in this
#' case no integrals are taken into account.
#'
#' @param signal.integral.max [integer] (**required**):
#' upper bound of the signal integral. Can be a [list] of [integer]s, if `object` is
#' of type [list]. If the input is vector (e.g., `c(1,2)`) the 2nd value will be interpreted
#' as the maximum signal integral for the `Tx` curve. Can be set to `NA`, in this
#' case no integrals are taken into account.
#'
#' @param background.integral.min [integer] (**required**):
#' lower bound of the background integral. Can be a [list] of [integer]s, if `object` is
#' of type [list]. If the input is vector (e.g., `c(1,2)`) the 2nd value will be interpreted
#' as the minimum background integral for the `Tx` curve. Can be set to `NA`, in this
#' case no integrals are taken into account.
#'
#' @param background.integral.max [integer] (**required**):
#' upper bound of the background integral. Can be a [list] of [integer]s, if `object` is
#' of type [list]. If the input is vector (e.g., `c(1,2)`) the 2nd value will be interpreted
#' as the maximum background integral for the `Tx` curve. Can be set to `NA`, in this
#' case no integrals are taken into account.
#'
#' @param OSL.component [character] or [integer] (*optional*): s single index
#' or a [character] defining the signal component to be evaluated.
#' It requires that the object was processed by `OSLdecomposition::RLum.OSL_decomposition`.
#' This argument can either be the name of the OSL component assigned by
#' `OSLdecomposition::RLum.OSL_global_fitting` or the index in the descending
#' order of decay rates. Then `"1"` selects the fastest decaying component, `"2"`
#' the second fastest and so on. Can be a [list] of [integer]s or strings (or mixed)
#' If object is a [list] and this parameter is provided as [list] it alternates over
#' the elements (aliquots) of the object list, e.g., `list(1,2)` processes the first
#' aliquot with component `1` and the second aliquot with component `2`.
#' `NULL` does not process any component.
#'
#' @param rejection.criteria [list] (*with default*):
#' provide a *named* list and set rejection criteria in **percentage**
#' for further calculation. Can be a [list] in a [list], if `object` is of type [list].
#' Note: If an *unnamed* [list] is provided the new settings are ignored!
#'
#' Allowed arguments are `recycling.ratio`, `recuperation.rate`,
#' `palaeodose.error`, `testdose.error`, `exceed.max.regpoint = TRUE/FALSE`,
#' `recuperation_reference = "Natural"` (or any other dose point, e.g., `"R1"`).
#' Example: `rejection.criteria = list(recycling.ratio = 10)`.
#' Per default all numerical values are set to 10, `exceed.max.regpoint = TRUE`.
#' Every criterion can be set to `NA`. In this value are calculated, but not considered, i.e.
#' the RC.Status becomes always `'OK'`
#'
#' @param dose.points [numeric] (*optional*):
#' a numeric vector containing the dose points values. Using this argument
#' overwrites dose point values extracted from other data. Can be a [list] of
#' [numeric] vectors, if `object` is of type [list]
#'
#' @param trim_channels [logical] (*with default*): trim channels per record category
#' to the lowest number of channels in the category by using [trim_RLum.Data].
#' Applies only to `OSL` and `IRSL` curves. For a more granular control use [trim_RLum.Data]
#' before passing the input object.
#'
#' @param mtext.outer [character] (*optional*):
#' option to provide an outer margin `mtext`. Can be a [list] of [character]s,
#' if `object` is of type [list]
#'
#' @param plot [logical] (*with default*): enable/disable the plot output.
#'
#' @param plot_onePage [logical] (*with default*): enable/disable one page
#' plot output.
#'
#' @param plot_singlePanels [logical] (*with default*) or [numeric] (*optional*):
#' single plot output (`TRUE/FALSE`) to allow for plotting the results in single plot windows.
#' If a [numeric] vector is provided the plots can be selected individually, i.e.
#' `plot_singlePanels = c(1,2,3,4)` will plot the TL and Lx, Tx curves but
#' not the legend (5) or the
#' growth curve (6), (7) and (8) belong to rejection criteria plots. Requires
#' `plot = TRUE`.
#'
#' @param onlyLxTxTable [logical] (*with default*): If `TRUE` the dose response
#' curve fitting and plotting is skipped.
#' This allows to get hands on the `Lx/Tx` table for large datasets
#' without the need for a curve fitting.
#'
#' @param ... further arguments that will be passed to the function
#' [plot_GrowthCurve] or [calc_OSLLxTxRatio]
#' (supported: `background.count.distribution`, `sigmab`, `sig0`).
#' **Please note** that if you consider to use the early light subtraction
#' method you should provide your own `sigmab` value!
#
#' @return
#' A plot (*optional*) and an [RLum.Results-class] object is
#' returned containing the following elements:
#'
#' \item{data}{[data.frame] containing De-values, De-error and further parameters}
#' \item{LnLxTnTx.values}{[data.frame] of all calculated Lx/Tx values including signal,
#' background counts and the dose points}
#' \item{rejection.criteria}{[data.frame] with values that might by used as rejection criteria.
#' `NA` is produced if no R0 dose point exists.}
#' \item{Formula}{[formula] formula that have been used for the growth curve fitting}
#'
#' The output should be accessed using the function [get_RLum].
#'
#' @note
#' This function must not be mixed up with the function
#' [Analyse_SAR.OSLdata], which works with
#' [Risoe.BINfileData-class] objects.
#'
#' **The function currently does support only 'OSL', 'IRSL' and 'POSL' data!**
#'
#' @section Function version: 0.10.5
#'
#' @author Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [calc_OSLLxTxRatio], [plot_GrowthCurve], [RLum.Analysis-class],
#' [RLum.Results-class], [get_RLum]
#'
#' @references
#' Aitken, M.J. and Smith, B.W., 1988. Optical dating: recuperation
#' after bleaching. Quaternary Science Reviews 7, 387-393.
#'
#' Duller, G., 2003. Distinguishing quartz and feldspar in single grain
#' luminescence measurements. Radiation Measurements, 37 (2), 161-165.
#'
#' Murray, A.S. and Wintle, A.G., 2000. Luminescence dating of quartz using an
#' improved single-aliquot regenerative-dose protocol. Radiation Measurements
#' 32, 57-73.
#'
#' Thomsen, K.J., Murray, A.S., Jain, M., Boetter-Jensen, L., 2008. Laboratory
#' fading rates of various luminescence signals from feldspar-rich sediment
#' extracts. Radiation Measurements 43, 1474-1486.
#' doi:10.1016/j.radmeas.2008.06.002
#'
#' @keywords datagen plot
#'
#' @examples
#'
#' ##load data
#' ##ExampleData.BINfileData contains two BINfileData objects
#' ##CWOSL.SAR.Data and TL.SAR.Data
#' data(ExampleData.BINfileData, envir = environment())
#'
#' ##transform the values from the first position in a RLum.Analysis object
#' object <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos=1)
#'
#' ##perform SAR analysis and set rejection criteria
#' results <- analyse_SAR.CWOSL(
#' object = object,
#' signal.integral.min = 1,
#' signal.integral.max = 2,
#' background.integral.min = 900,
#' background.integral.max = 1000,
#' log = "x",
#' fit.method = "EXP",
#' rejection.criteria = list(
#' recycling.ratio = 10,
#' recuperation.rate = 10,
#' testdose.error = 10,
#' palaeodose.error = 10,
#' recuperation_reference = "Natural",
#' exceed.max.regpoint = TRUE)
#')
#'
#' ##show De results
#' get_RLum(results)
#'
#' ##show LnTnLxTx table
#' get_RLum(results, data.object = "LnLxTnTx.table")
#'
#' @md
#' @export
analyse_SAR.CWOSL<- function(
object,
signal.integral.min = NA,
signal.integral.max = NA,
background.integral.min = NA,
background.integral.max = NA,
OSL.component = NULL,
rejection.criteria = list(),
dose.points = NULL,
trim_channels = FALSE,
mtext.outer = "",
plot = TRUE,
plot_onePage = FALSE,
plot_singlePanels = FALSE,
onlyLxTxTable = FALSE,
...
) {
.set_function_name("analyse_SAR.CWOSL")
on.exit(.unset_function_name(), add = TRUE)
# SELF CALL -----------------------------------------------------------------------------------
if(is.list(object)){
##clean object input and expand parameters
object <- .rm_nonRLum(object)
parm <- .expand_parameters(length(object))
##handle main separately
if("main"%in% names(list(...))){
main <- .listify(list(...)$main, length = length(object))
}else{
main <- as.list(paste0("ALQ #",1:length(object)))
}
results <- .warningCatcher(merge_RLum(lapply(seq_along(object), function(x){
analyse_SAR.CWOSL(
object = object[[x]],
signal.integral.min = parm$signal.integral.min[[x]],
signal.integral.max = parm$signal.integral.max[[x]],
background.integral.min = parm$background.integral.min[[x]],
background.integral.max = parm$background.integral.max[[x]],
OSL.component = parm$OSL.component[[x]],
dose.points = parm$dose.points[[x]],
trim_channels = parm$trim_channels[[x]],
mtext.outer = parm$mtext.outer[[x]],
plot = parm$plot[[x]],
rejection.criteria = parm$rejection.criteria[[x]],
plot_singlePanels = parm$plot_singlePanels[[x]],
plot_onePage = parm$plot_onePage[[x]],
onlyLxTxTable = parm$onlyLxTxTable[[x]],
main = main[[x]],
...)
})))
##return
##DO NOT use invisible here, this will prevent the function from stopping
if(length(results) == 0) return(NULL)
## add aliquot number
results@data$data$ALQ <- seq_along(object)[1:nrow(results@data$data)]
return(results)
}
# CONFIG -----------------------------------------------------------------
##set error list, this allows to set error messages without breaking the function
error.list <- list()
## Integrity checks -------------------------------------------------------
.validate_class(object, "RLum.Analysis")
.validate_class(plot_singlePanels, c("logical", "integer", "numeric"))
## trim OSL or IRSL channels
if(trim_channels[1]) {
## fetch names with OSL and IRSL
tmp_names <- unique(vapply(object@records, function(x) x@recordType, character(1)))
## grep only the one with OSL and IRSL in it
tmp_names <- tmp_names[grepl(pattern = "(?:OSL|IRSL)", x = tmp_names, perl = TRUE)]
## trim
object <- trim_RLum.Data(object, recordType = tmp_names)
}
##skip all those tests if signal integral is NA
if (anyNA(c(signal.integral.min, signal.integral.max,
background.integral.min, background.integral.max))) {
signal.integral <- background.integral <- NA
signal.integral.Tx <- background.integral.Tx <- NULL
if(is.null(OSL.component))
.throw_warning("No signal or background integral applied ",
"as they were set to NA")
} else {
##build signal and background integrals
signal.integral <- c(signal.integral.min[1]:signal.integral.max[1])
background.integral <- c(background.integral.min[1]:background.integral.max[1])
##account for the case that Lx and Tx integral differ
if (length(signal.integral.min) == 2 &
length(signal.integral.max) == 2) {
signal.integral.Tx <-
c(signal.integral.min[2]:signal.integral.max[2])
}else{
signal.integral.Tx <- NULL
}
if (length(background.integral.min) == 2 &
length(background.integral.max) == 2) {
background.integral.Tx <-
c(background.integral.min[2]:background.integral.max[2])
}else{
background.integral.Tx <- NULL
}
##Account for the case that the use did not provide everything ...
if(is.null(signal.integral.Tx) & !is.null(background.integral.Tx)){
signal.integral.Tx <- signal.integral
.throw_warning("Background integral for Tx curves set, but not for ",
"the signal integral; signal integral for Tx automatically set")
}
if(!is.null(signal.integral.Tx) & is.null(background.integral.Tx)){
background.integral.Tx <- background.integral
.throw_warning("Signal integral for Tx curves set, but not for the ",
"background integral; background integral for Tx automatically set")
}
##INTEGRAL LIMITS
if(!is(signal.integral, "integer") | !is(background.integral, "integer")){
.throw_error("'signal.integral' or 'background.integral' is not of type integer")
}
}
## try to extract the correct curves for the sequence based on allowed curve types and
## the curve type used most frequently
## now remove all non-allowed curves
CWcurve.type <- regmatches(
x = names(object),
m = regexpr("(OSL[a-zA-Z]*|IRSL[a-zA-Z]*|POSL[a-zA-Z]*)", names(object), perl = TRUE))
if(length(CWcurve.type) == 0) {
.throw_message("No record of type 'OSL', 'IRSL', 'POSL' detected, ",
"NULL returned")
return(NULL)
}
## now get the type which is used most
CWcurve.type <- names(which.max(table(CWcurve.type)))
# Rejection criteria ------------------------------------------------------
if(is.null(rejection.criteria) || class(rejection.criteria)[1] != "list")
rejection.criteria <- list()
##set list
rejection.criteria <- modifyList(x = list(
recycling.ratio = 10,
recuperation.rate = 10,
palaeodose.error = 10,
testdose.error = 10,
exceed.max.regpoint = TRUE,
recuperation_reference = "Natural"
),
val = rejection.criteria,
keep.null = TRUE)
# Deal with extra arguments ----------------------------------------------------
##deal with addition arguments
extraArgs <- list(...)
main <- if("main" %in% names(extraArgs)) extraArgs$main else ""
log <- if("log" %in% names(extraArgs)) extraArgs$log else ""
cex <- if("cex" %in% names(extraArgs)) extraArgs$cex else 1
background.count.distribution <-
if ("background.count.distribution" %in% names(extraArgs)) {
extraArgs$background.count.distribution
} else {
"non-poisson"
}
sigmab <- if("sigmab" %in% names(extraArgs)) extraArgs$sigmab else NULL
sig0 <- if("sig0" %in% names(extraArgs)) extraArgs$sig0 else 0
## deprecated argument
if ("plot.single" %in% names(extraArgs)) {
plot_singlePanels <- extraArgs$plot.single
.throw_warning("'plot.single' is deprecated, use 'plot_singlePanels' ",
"instead")
}
# Protocol Integrity Checks --------------------------------------------------
##check overall structure of the object
##every SAR protocol has to have equal number of curves
##grep curve types from analysis value and remove unwanted information
temp.ltype <- sapply(1:length(object@records), function(x) {
##export as global variable
object@records[[x]]@recordType <<- gsub(" .*", "", object@records[[x]]@recordType)
object@records[[x]]@recordType
})
##FI lexsyg devices provide irradiation information in a separate curve
if(any("irradiation" %in% temp.ltype)){
##grep irradiation times
temp.irradiation <- extract_IrradiationTimes(object)@data$irr.times[["IRR_TIME"]]
##write this into the records
for(i in 1:length(object@records)){
if(is.null(object@records[[i]]@info$IRR_TIME))
object@records[[i]]@info <- c(object@records[[i]]@info, IRR_TIME = temp.irradiation[i])
}
## remove irradiation curves
object <- get_RLum(object, record.id = c(!temp.ltype %in% "irradiation"), drop = FALSE)
}
##check if the wanted curves are a multiple of two
##gsub removes unwanted information from the curves
if(table(temp.ltype)[CWcurve.type]%%2!=0){
error.list[[1]] <- "Input OSL/IRSL curves are not a multiple of two"
}
##check if the curve lengths differ
temp.matrix.length <- unlist(sapply(1:length(object@records), function(x) {
if(object@records[[x]]@recordType==CWcurve.type){
length(object@records[[x]]@data[,1])
}
}))
if(length(unique(temp.matrix.length))!=1){
error.list[[2]] <- paste0("Input curves have different lengths (",
.collapse(unique(temp.matrix.length),
quote = FALSE), ")")
}
##just proceed if error list is empty
if (length(error.list) == 0) {
##check background integral
if (!all(is.na(signal.integral)) &&
max(signal.integral) == min(signal.integral)) {
signal.integral <-
c(min(signal.integral) : (max(signal.integral) + 1))
.throw_warning("Integral signal limits cannot be equal, reset automatically")
}
##background integral should not be longer than curve channel length
if (!all(is.na(background.integral)) &&
max(background.integral) == min(background.integral)) {
background.integral <-
c((min(background.integral) - 1) : max(background.integral))
}
if (!all(is.na(background.integral)) &&
max(background.integral) > temp.matrix.length[1]) {
background.integral <-
c((temp.matrix.length[1] - length(background.integral)):temp.matrix.length[1])
##prevent that the background integral becomes negative
if(min(background.integral) < max(signal.integral)){
background.integral <- c((max(signal.integral) + 1):max(background.integral))
}
.throw_warning("Background integral out of bounds. Set to: c(",
min(background.integral), ":", max(background.integral),
")")
}
##Do the same for the Tx-if set
if (!is.null(background.integral.Tx)) {
if (max(background.integral.Tx) == min(background.integral.Tx)) {
background.integral.Tx <-
c((min(background.integral.Tx) - 1) : max(background.integral.Tx))
}
if (max(background.integral.Tx) > temp.matrix.length[2]) {
background.integral.Tx <-
c((temp.matrix.length[2] - length(background.integral.Tx)):temp.matrix.length[2])
##prevent that the background integral becomes negative
if (min(background.integral.Tx) < max(signal.integral.Tx)) {
background.integral.Tx <-
c((max(signal.integral.Tx) + 1):max(background.integral.Tx))
}
.throw_warning(
"Background integral for Tx out of bounds. Set to: c(",
min(background.integral.Tx),
":",
max(background.integral.Tx),
")"
)
}
}
# Grep Curves -------------------------------------------------------------
##grep relevant curves from RLum.Analyis object
OSL.Curves.ID <-
get_RLum(object, recordType = CWcurve.type, get.index = TRUE)
##separate curves by Lx and Tx (it makes it much easier)
OSL.Curves.ID.Lx <-
OSL.Curves.ID[seq(1,length(OSL.Curves.ID),by = 2)]
OSL.Curves.ID.Tx <-
OSL.Curves.ID[seq(2,length(OSL.Curves.ID),by = 2)]
##get index of TL curves
TL.Curves.ID <-
suppressWarnings(get_RLum(object, recordType = "TL$", get.index = TRUE))
##separate TL curves which is always coming before the OSL curve
##Note: we do not check anymore whether the sequence makes sense.
TL.Curves.ID.Lx <- TL.Curves.ID[TL.Curves.ID%in%(OSL.Curves.ID.Lx - 1)]
TL.Curves.ID.Tx <- TL.Curves.ID[TL.Curves.ID%in%(OSL.Curves.ID.Tx - 1)]
# Calculate LnLxTnTx values --------------------------------------------------
##calculate LxTx values using external function
LnLxTnTx <- try(lapply(seq(1,length(OSL.Curves.ID),by = 2), function(x){
if(!is.null(OSL.component) && length(OSL.component) > 0){
temp.LnLxTnTx <- get_RLum(
calc_OSLLxTxDecomposed(
Lx.data = object@records[[OSL.Curves.ID[x]]]@info$COMPONENTS,
Tx.data = object@records[[OSL.Curves.ID[x + 1]]]@info$COMPONENTS,
OSL.component = OSL.component,
digits = 4,
sig0 = sig0))
} else {
temp.LnLxTnTx <- get_RLum(
calc_OSLLxTxRatio(
Lx.data = object@records[[OSL.Curves.ID[x]]]@data,
Tx.data = object@records[[OSL.Curves.ID[x + 1]]]@data,
signal.integral = signal.integral,
signal.integral.Tx = signal.integral.Tx,
background.integral = background.integral,
background.integral.Tx = background.integral.Tx,
background.count.distribution = background.count.distribution,
sigmab = sigmab,
sig0 = sig0))
}
##grep dose
temp.Dose <- object@records[[OSL.Curves.ID[x]]]@info$IRR_TIME
##for the case that no information on the dose can be found
if (is.null(temp.Dose)) temp.Dose <- NA
temp.LnLxTnTx <- cbind(Dose = temp.Dose, temp.LnLxTnTx)
}), silent = TRUE)
##this is basically for the OSL.component case to avoid that everything
##fails if something goes wrong therein
if(inherits(LnLxTnTx, "try-error")){
.throw_message("Something went wrong while generating the LxTx table, ",
"NULL returned")
return(NULL)
}
##combine
LnLxTnTx <- data.table::rbindlist(LnLxTnTx)
# Set regeneration points -------------------------------------------------
##overwrite dose point manually
if (!is.null(dose.points) & length(dose.points) > 0) {
if (length(dose.points) != length(LnLxTnTx$Dose)) {
.throw_error("Length of 'dose.points' differs from number of curves")
}
LnLxTnTx$Dose <- dose.points
}
##check whether we have dose points at all
if (is.null(dose.points) & anyNA(LnLxTnTx$Dose)) {
.throw_error("'dose.points' contains NA values or have not been set")
}
##check whether the first OSL/IRSL curve (i.e., the Natural) has 0 dose. If not
##not, it is probably a Dose Recovery Test with the given dose that is treated as the
##unknown dose. We overwrite this value and warn the user.
if (LnLxTnTx$Dose[1] != 0) {
.throw_warning("The natural signal has a dose of ", LnLxTnTx$Dose[1],
" s, which is indicative of a dose recovery test. ",
"The natural dose was set to 0.")
LnLxTnTx$Dose[1] <- 0
}
#generate unique dose id - this are also the # for the generated points
temp.DoseID <- c(0:(length(LnLxTnTx$Dose) - 1))
temp.DoseName <- paste0("R",temp.DoseID)
temp.DoseName <-
cbind(Name = temp.DoseName,Dose = LnLxTnTx$Dose)
##set natural
temp.DoseName[temp.DoseName[,"Name"] == "R0","Name"] <-
"Natural"
##set R0
temp.DoseName[temp.DoseName[,"Name"] != "Natural" &
temp.DoseName[,"Dose"] == 0,"Name"] <- "R0"
##correct numeration numeration of other dose points
##how many dose points do we have with 0?
non.temp.zero.dose.number <- nrow(temp.DoseName[temp.DoseName[, "Dose"] != 0,])
if(length(non.temp.zero.dose.number) > 0){
temp.DoseName[temp.DoseName[,"Name"] != "Natural" & temp.DoseName[,"Name"] != "R0","Name"] <-
paste0("R",c(1:non.temp.zero.dose.number))
}
##find duplicated doses (including 0 dose - which means the Natural)
temp.DoseDuplicated <- duplicated(temp.DoseName[,"Dose"])
##combine temp.DoseName
temp.DoseName <-
cbind(temp.DoseName,Repeated = temp.DoseDuplicated)
##correct value for R0 (it is not really repeated)
temp.DoseName[temp.DoseName[,"Dose"] == 0,"Repeated"] <- FALSE
##combine in the data frame
temp.LnLxTnTx <- data.frame(
Name = factor(x = temp.DoseName[, "Name"],
levels = unique(temp.DoseName[, "Name"])),
Repeated = as.logical(temp.DoseName[, "Repeated"]))
LnLxTnTx <- cbind(temp.LnLxTnTx,LnLxTnTx)
LnLxTnTx[,"Name"] <- as.character(LnLxTnTx[,"Name"])
# Calculate Recycling Ratio -----------------------------------------------
##Calculate Recycling Ratio
RecyclingRatio <- NA
if (length(LnLxTnTx[LnLxTnTx[,"Repeated"] == TRUE,"Repeated"]) > 0) {
##identify repeated doses
temp.Repeated <-
LnLxTnTx[LnLxTnTx[,"Repeated"] == TRUE,c("Name","Dose","LxTx")]
##find concerning previous dose for the repeated dose
temp.Previous <-
t(sapply(1:length(temp.Repeated[,1]),function(x) {
LnLxTnTx[LnLxTnTx[,"Dose"] == temp.Repeated[x,"Dose"] &
LnLxTnTx[,"Repeated"] == FALSE,c("Name","Dose","LxTx")]
}))
##convert to data.frame
temp.Previous <- as.data.frame(temp.Previous)
##set column names
temp.ColNames <-
unlist(lapply(1:length(temp.Repeated[,1]),function(x) {
temp <- paste("Recycling ratio (", temp.Repeated[x,"Name"],"/",
temp.Previous[temp.Previous[,"Dose"] == temp.Repeated[x,"Dose"],"Name"],
")",
sep = "")
return(temp[1])
}))
##Calculate Recycling Ratio
RecyclingRatio <-
round(as.numeric(temp.Repeated[,"LxTx"]) / as.numeric(temp.Previous[,"LxTx"]),
digits = 4)
##Just transform the matrix and add column names
RecyclingRatio <- t(RecyclingRatio)
colnames(RecyclingRatio) <- temp.ColNames
}
# Calculate Recuperation Rate ---------------------------------------------
## check for incorrect key words
if(any(!rejection.criteria$recuperation_reference[1] %in% LnLxTnTx[,"Name"]))
.throw_error("Recuperation reference invalid, valid are: ",
.collapse(LnLxTnTx[, "Name"], quote = FALSE))
##Recuperation Rate (capable of handling multiple type of recuperation values)
Recuperation <- NA
if (length(LnLxTnTx[LnLxTnTx[,"Name"] == "R0","Name"]) > 0) {
Recuperation <-
vapply(1:length(LnLxTnTx[LnLxTnTx[,"Name"] == "R0","Name"]),
function(x) {
round(LnLxTnTx[LnLxTnTx[,"Name"] == "R0","LxTx"][x] /
LnLxTnTx[LnLxTnTx[,"Name"] == rejection.criteria$recuperation_reference[1],"LxTx"],
digits = 4)
}, numeric(1))
##Just transform the matrix and add column names
Recuperation <- t(Recuperation)
colnames(Recuperation) <-
unlist(strsplit(paste(
paste0("Recuperation rate (", rejection.criteria$recuperation_reference[1], ")"),
1:length(LnLxTnTx[LnLxTnTx[,"Name"] == "R0","Name"]), collapse = ";"
), ";"))
}
# Evaluate and Combine Rejection Criteria ---------------------------------
temp.criteria <- c(
if(!is.null(colnames(RecyclingRatio))){
colnames(RecyclingRatio)}else{NA},
if(!is.null(colnames(Recuperation))){
colnames(Recuperation)}else{NA})
temp.value <- c(RecyclingRatio,Recuperation)
temp.threshold <-
c(rep(
rejection.criteria$recycling.ratio / 100, length(RecyclingRatio)
),
rep(
rejection.criteria$recuperation.rate / 100,
length(Recuperation)
))
##RecyclingRatio
temp.status.RecyclingRatio <- rep("OK", length(RecyclingRatio))
if (!anyNA(RecyclingRatio) && !is.na(rejection.criteria$recycling.ratio))
temp.status.RecyclingRatio[abs(1 - RecyclingRatio) > (rejection.criteria$recycling.ratio / 100)] <- "FAILED"
##Recuperation
temp.status.Recuperation <- "OK"
if (!is.na(Recuperation)[1] &
!is.na(rejection.criteria$recuperation.rate)) {
temp.status.Recuperation <-
sapply(1:length(Recuperation), function(x) {
if (Recuperation[x] > rejection.criteria$recuperation.rate / 100) {
"FAILED"
} else{
"OK"
}
})
}
# Provide Rejection Criteria for Testdose error --------------------------
testdose.error.calculated <- (LnLxTnTx$Net_TnTx.Error/LnLxTnTx$Net_TnTx)[1]
testdose.error.threshold <-
rejection.criteria$testdose.error / 100
if (is.na(testdose.error.calculated)) {
testdose.error.status <- "FAILED"
}else{
testdose.error.status <- "OK"
if(!is.na(testdose.error.threshold)){
testdose.error.status <- ifelse(
testdose.error.calculated <= testdose.error.threshold,
"OK", "FAILED"
)
}
}
testdose.error.data.frame <- data.frame(
Criteria = "Testdose error",
Value = testdose.error.calculated,
Threshold = testdose.error.threshold,
Status = testdose.error.status,
stringsAsFactors = FALSE
)
RejectionCriteria <- data.frame(
Criteria = temp.criteria,
Value = temp.value,
Threshold = temp.threshold,
Status = c(temp.status.RecyclingRatio,temp.status.Recuperation),
stringsAsFactors = FALSE
)
RejectionCriteria <- rbind(RejectionCriteria, testdose.error.data.frame)
##========================================================================##
##PLOTTING
##========================================================================##
if (plot) {
##make sure the par settings are good after the functions stops
##Why this is so complicated? Good question, if par() is called in the
##single mode, it starts a new plot and then subsequent functions like
##analyse_pIRIRSequence() produce an odd plot output.
par.default <- par()[c("oma","mar","cex", "mfrow", "mfcol")]
on_exit <- function(x = par.default){
par(
oma = x$oma,
mar = x$mar,
cex = x$cex,
mfrow = x$mfrow,
mfcol = x$mfcol
)
}
##colours and double for plotting
col <- get("col", pos = .LuminescenceEnv)
# plot everyting on one page ... doing it here is much cleaner than
# Plotting - one Page config -------------------------------------------------------
if(plot_onePage){
on.exit(on_exit(), add = TRUE)
plot_singlePanels <- TRUE
layout(matrix(
c(1, 1, 3, 3, 6, 6, 7,
1, 1, 3, 3, 6, 6, 8,
2, 2, 4, 4, 9, 9, 10,
2, 2, 4, 4, 9, 9, 10,
5, 5, 5, 5, 5, 5, 5), 5, 7, byrow = TRUE
))
par(oma = c(0, 0, 0, 0),
mar = c(4, 4, 3, 1),
cex = cex * 0.6)
}
# Plotting - old way config -------------------------------------------------------
if (plot_singlePanels[1] == FALSE) {
on.exit(on_exit(), add = TRUE)
layout(matrix(
c(1, 1, 3, 3,
1, 1, 3, 3,
2, 2, 4, 4,
2, 2, 4, 4,
5, 5, 5, 5), 5, 4, byrow = TRUE
))
par(
oma = c(0,0,0,0), mar = c(4,4,3,3), cex = cex * 0.6
)
## 1 -> TL previous LnLx
## 2 -> LnLx
## 3 -> TL previous TnTx
## 4 -> TnTx
## 5 -> Legend
## set selected curves to allow plotting of all curves
plot.single.sel <- c(1,2,3,4,5,6,7,8)
}else{
##check for values in the single output of the function and convert
if (!is.logical(plot_singlePanels)) {
plot.single.sel <- plot_singlePanels
}else{
plot.single.sel <- c(1,2,3,4,5,6,7,8)
}
}
##warning if number of curves exceed colour values
if (length(col) < length(OSL.Curves.ID) / 2) {
.throw_warning("Too many curves, only the first ",
length(col), " curves are plotted")
}
##legend text
legend.text <-
paste(LnLxTnTx$Name,"\n(",LnLxTnTx$Dose,")", sep = "")
##get channel resolution (should be equal for all curves)
resolution.OSLCurves <- round(object@records[[OSL.Curves.ID[1]]]@data[2,1] -
object@records[[OSL.Curves.ID[1]]]@data[1,1],
digits = 2)
# Plotting TL Curves previous LnLx ----------------------------------------
##overall plot option selection for plot.single.sel
if (1 %in% plot.single.sel) {
##check if TL curves are available
if (length(TL.Curves.ID.Lx) > 0) {
##It is just an approximation taken from the data
resolution.TLCurves <- round(mean(diff(
round(object@records[[TL.Curves.ID.Lx[[1]]]]@data[,1], digits = 1)
)), digits = 1)
ylim.range <- vapply(TL.Curves.ID.Lx, function(x) {
range(object@records[[x]]@data[,2])
}, numeric(2))
plot(
NA,NA,
xlab = "T [\u00B0C]",
ylab = paste("TL [cts/",resolution.TLCurves," \u00B0C]",sep =
""),
xlim = c(object@records[[TL.Curves.ID.Lx[[1]]]]@data[1,1],
max(object@records[[TL.Curves.ID.Lx[[1]]]]@data[,1])),
ylim = c(1,max(ylim.range)),
main = main,
log = if (log == "y" | log == "xy") {
"y"
}else{
""
}
)
#provide curve information as mtext, to keep the space for the header
mtext(side = 3,
expression(paste(
"TL previous ", L[n],",",L[x]," curves",sep = ""
)),
cex = cex * 0.7)
##plot TL curves
sapply(1:length(TL.Curves.ID.Lx) ,function(x) {
lines(object@records[[TL.Curves.ID.Lx[[x]]]]@data,col = col[x])
})
}else{
plot(
NA,NA,xlim = c(0,1), ylim = c(0,1), main = "",
axes = FALSE,
ylab = "",
xlab = ""
)
text(0.5,0.5, "No TL curve detected")
}
}#plot.single.sel
# Plotting LnLx Curves ----------------------------------------------------
## if we want to apply a log-transform on x and the first time point
## is 0, we shift the curves by one channel
if (log == "x" || log == "xy") {
sapply(OSL.Curves.ID.Lx, function(x) {
x.vals <- object@records[[x]]@data[, 1]
if (x.vals[1] == 0) {
object@records[[x]]@data[, 1] <- x.vals + x.vals[2] - x.vals[1]
.throw_warning("Curves shifted by one channel for log-plot")
}
})
}
##overall plot option selection for plot.single.sel
if (2 %in% plot.single.sel) {
ylim.range <- vapply(OSL.Curves.ID.Lx, function(x) {
range(object@records[[x]]@data[,2])
}, numeric(2))
xlim <- c(object@records[[OSL.Curves.ID.Lx[1]]]@data[1,1],
max(object@records[[OSL.Curves.ID.Lx[1]]]@data[,1]))
#open plot area LnLx
plot(
NA,NA,
xlab = "Time [s]",
ylab = paste(CWcurve.type," [cts/",resolution.OSLCurves," s]",sep =
""),
xlim = xlim,
ylim = range(ylim.range),
main = main,
log = log
)
#provide curve information as mtext, to keep the space for the header
mtext(side = 3, expression(paste(L[n],",",L[x]," curves",sep = "")),
cex = cex * 0.7)
##plot curves
sapply(1:length(OSL.Curves.ID.Lx), function(x) {
lines(object@records[[OSL.Curves.ID.Lx[[x]]]]@data,col = col[x])
})
##mark integration limit Lx curves
abline(v = c(
object@records[[OSL.Curves.ID.Lx[1]]]@data[min(signal.integral),1],
object@records[[OSL.Curves.ID.Lx[1]]]@data[max(signal.integral),1],
object@records[[OSL.Curves.ID.Lx[1]]]@data[min(background.integral),1],
object@records[[OSL.Curves.ID.Lx[1]]]@data[max(background.integral),1]),
lty = 2,
col = "gray")
##mtext, implemented here, as a plot window has to be called first
mtext(
mtext.outer,
side = 4,
outer = TRUE,
line = -1.7,
cex = cex,
col = "blue"
)
}# plot.single.sel
# Plotting TL Curves previous TnTx ----------------------------------------
##overall plot option selection for plot.single.sel
if (3 %in% plot.single.sel) {
##check if TL curves are available
if (length(TL.Curves.ID.Tx) > 0) {
##It is just an approximation taken from the data
resolution.TLCurves <- round(mean(diff(
round(object@records[[TL.Curves.ID.Tx[[1]]]]@data[,1], digits = 1)
)), digits = 1)
ylim.range <- vapply(TL.Curves.ID.Tx, function(x) {
range(object@records[[x]]@data[,2])
}, numeric(2))
plot(
NA,NA,
xlab = "T [\u00B0C]",
ylab = paste("TL [cts/",resolution.TLCurves," \u00B0C]",sep = ""),
xlim = c(object@records[[TL.Curves.ID.Tx[[1]]]]@data[1,1],
max(object@records[[TL.Curves.ID.Tx[[1]]]]@data[,1])),
ylim = c(1,max(ylim.range)),
main = main,
log = if (log == "y" | log == "xy") {
"y"
}else{
""
}
)
#provide curve information as mtext, to keep the space for the header
mtext(side = 3,
expression(paste(
"TL previous ", T[n],",",T[x]," curves",sep = ""
)),
cex = cex * 0.7)
##plot TL curves
sapply(1:length(TL.Curves.ID.Tx) ,function(x) {
lines(object@records[[TL.Curves.ID.Tx[[x]]]]@data,col = col[x])
})
}else{
plot(
NA,NA,xlim = c(0,1), ylim = c(0,1), main = "",
axes = FALSE,
ylab = "",
xlab = ""
)
text(0.5,0.5, "No TL curve detected")
}
}#plot.single.sel
# Plotting TnTx Curves ----------------------------------------------------
##overall plot option selection for plot.single.sel
if (4 %in% plot.single.sel) {
ylim.range <- vapply(OSL.Curves.ID.Tx, function(x) {
range(object@records[[x]]@data[,2])
}, numeric(2))
xlim <- c(object@records[[OSL.Curves.ID.Tx[1]]]@data[1,1],
max(object@records[[OSL.Curves.ID.Tx[1]]]@data[,1]))
#open plot area LnLx
plot(
NA,NA,
xlab = "Time [s]",
ylab = paste0(CWcurve.type ," [cts/",resolution.OSLCurves," s]"),
xlim = xlim,
ylim = range(ylim.range),
main = main,
log = log
)
#provide curve information as mtext, to keep the space for the header
mtext(side = 3,
expression(paste(T[n],",",T[x]," curves",sep = "")),
cex = cex * 0.7)
##plot curves and get legend values
sapply(1:length(OSL.Curves.ID.Tx) ,function(x) {
lines(object@records[[OSL.Curves.ID.Tx[[x]]]]@data,col = col[x])
})
##mark integration limit Tx curves
abline(v = c(
object@records[[OSL.Curves.ID.Tx[1]]]@data[min(signal.integral),1],
object@records[[OSL.Curves.ID.Tx[1]]]@data[max(signal.integral),1],
object@records[[OSL.Curves.ID.Tx[1]]]@data[min(background.integral),1],
object@records[[OSL.Curves.ID.Tx[1]]]@data[max(background.integral),1]),
lty = 2,
col = "gray")
}# plot.single.sel
# Plotting Legend ----------------------------------------
##overall plot option selection for plot.single.sel
if (5 %in% plot.single.sel) {
par.margin <- par()$mar
par.mai <- par()$mai
par(mar = c(1,1,1,1), mai = c(0,0,0,0))
plot(
c(1:(length(
OSL.Curves.ID
) / 2)),
rep(7,length(OSL.Curves.ID) / 2),
type = "p",
axes = FALSE,
xlab = "",
ylab = "",
pch = 20,
col = unique(col[1:length(OSL.Curves.ID)]),
cex = 4 * cex,
ylim = c(0,10)
)
##add text
text(c(1:(length(
OSL.Curves.ID
) / 2)),
rep(7,length(OSL.Curves.ID) / 2),
legend.text,
offset = 1,
pos = 1)
##add line
abline(h = 10,lwd = 0.5)
#reset margin
par(mar = par.margin, mai = par.mai)
}#plot.single.sel
}##end plot
# Plotting GC ----------------------------------------
##create data.frame
temp.sample <- data.frame(
Dose = LnLxTnTx$Dose,
LxTx = LnLxTnTx$LxTx,
LxTx.Error = LnLxTnTx$LxTx.Error,
TnTx = LnLxTnTx$Net_TnTx
)
##overall plot option selection for plot.single.sel
if (plot == TRUE && 6 %in% plot.single.sel) {
plot <- TRUE
}else {
plot <- FALSE
}
temp.GC.all.na <- data.frame(
De = NA,
De.Error = NA,
D01 = NA,
D01.ERROR = NA,
D02 = NA,
D02.ERROR = NA,
Dc = NA,
n_N = NA,
De.MC = NA,
De.plot = NA,
Fit = NA,
HPDI68_L = NA,
HPDI68_U = NA,
HPDI95_L = NA,
HPDI95_U = NA,
RC.Status = NA,
stringsAsFactors = FALSE)
##Fit and plot growth curve
temp.GC <- temp.GC.all.na
temp.GC.fit.Formula <- NULL
if(!onlyLxTxTable){
temp.GC <- do.call(plot_GrowthCurve, args = modifyList(
list(
sample = temp.sample,
output.plot = plot,
plot_singlePanels = plot_onePage || length(plot_singlePanels) > 1,
cex.global = if(plot_onePage) .6 else 1
),
list(...)
))
##if null
if(is.null(temp.GC)){
temp.GC <- temp.GC.all.na
temp.GC.fit.Formula <- NA
##create empty plots if needed, otherwise subsequent functions may crash
if(plot){
shape::emptyplot()
if (!"output.plotExtended" %in% extraArgs ||
extraArgs$output.plotExtended) {
shape::emptyplot()
shape::emptyplot()
}
}
}else{
##grep information on the fit object
temp.GC.fit.Formula <- get_RLum(temp.GC, "Formula")
##grep results
temp.GC <- get_RLum(temp.GC)
# Provide Rejection Criteria for Palaeodose error --------------------------
if(is.na(temp.GC[,1])){
palaeodose.error.calculated <- NA
}else{
palaeodose.error.calculated <- round(temp.GC[,2] / temp.GC[,1], digits = 5)
}
palaeodose.error.threshold <-
rejection.criteria$palaeodose.error / 100
if (!is.na(palaeodose.error.threshold) && (is.na(palaeodose.error.calculated) ||
palaeodose.error.calculated > palaeodose.error.threshold)) {
palaeodose.error.status <- "FAILED"
} else {
palaeodose.error.status <- "OK"
}
palaeodose.error.data.frame <- data.frame(
Criteria = "Palaeodose error",
Value = palaeodose.error.calculated,
Threshold = palaeodose.error.threshold,
Status = palaeodose.error.status,
stringsAsFactors = FALSE
)
##add exceed.max.regpoint
if (!is.na(temp.GC[,1]) & !is.na(rejection.criteria$exceed.max.regpoint) && rejection.criteria$exceed.max.regpoint) {
status.exceed.max.regpoint <-
ifelse(max(LnLxTnTx$Dose) < temp.GC[,1], "FAILED", "OK")
}else{
status.exceed.max.regpoint <- "OK"
}
exceed.max.regpoint.data.frame <- data.frame(
Criteria = "De > max. dose point",
Value = as.numeric(temp.GC[,1]),
Threshold = if(is.na(rejection.criteria$exceed.max.regpoint)){
NA
}else if(!rejection.criteria$exceed.max.regpoint){
Inf
}else{
as.numeric(max(LnLxTnTx$Dose))
},
Status = status.exceed.max.regpoint
)
##add to RejectionCriteria data.frame
RejectionCriteria <- rbind(RejectionCriteria,
palaeodose.error.data.frame,
exceed.max.regpoint.data.frame)
##add rejection status
if (length(grep("FAILED",RejectionCriteria$Status)) > 0) {
temp.GC <- data.frame(temp.GC, RC.Status = "FAILED", stringsAsFactors = FALSE)
}else{
temp.GC <- data.frame(temp.GC, RC.Status = "OK", stringsAsFactors = FALSE)
}
}#endif for is.null
}
##add information on the integration limits
temp.GC.extended <-
data.frame(
signal.range = paste(min(signal.integral),":",
max(signal.integral)),
background.range = paste(min(background.integral),":",
max(background.integral)),
signal.range.Tx = paste(min(ifelse(is.null(signal.integral.Tx),NA,signal.integral.Tx)),":",
max(ifelse(is.null(signal.integral.Tx),NA,signal.integral.Tx))),
background.range.Tx = paste(min(ifelse(is.null(background.integral.Tx), NA,background.integral.Tx)) ,":",
max(ifelse(is.null(background.integral.Tx), NA,background.integral.Tx))),
stringsAsFactors = FALSE
)
# Set return Values -----------------------------------------------------------
##generate unique identifier
UID <- create_UID()
## get position numbers
POSITION <- unique(unlist(lapply(object@records, function(x){
chk <- grepl(pattern = "position", tolower(names(x@info)), fixed = TRUE)
if (any(chk))
return(x@info[chk])
else
return(NA)
})))[1]
## get grain numbers
GRAIN <- unique(unlist(lapply(object@records, function(x) {
chk <- grepl(pattern = "grain", tolower(names(x@info)), fixed = TRUE)
if (any(chk))
return(x@info[chk])
else
return(NA)
})))[1]
temp.results.final <- set_RLum(
class = "RLum.Results",
data = list(
data = as.data.frame(
c(temp.GC, temp.GC.extended, ALQ = 1,
POS = POSITION, GRAIN = GRAIN, UID = UID),
stringsAsFactors = FALSE),
LnLxTnTx.table = cbind(LnLxTnTx, UID = UID, stringsAsFactors = FALSE),
rejection.criteria = cbind(RejectionCriteria, UID, stringsAsFactors = FALSE),
Formula = temp.GC.fit.Formula
),
info = list(call = sys.call())
)
# Plot graphical interpretation of rejection criteria -----------------------------------------
if (plot && 7 %in% plot.single.sel) {
##set graphical parameter
if (!plot_singlePanels[1]) par(mfrow = c(1,2))
##Rejection criteria
temp.rejection.criteria <- get_RLum(temp.results.final,
data.object = "rejection.criteria")
temp.rc.reycling.ratio <- temp.rejection.criteria[
grep("Recycling ratio",temp.rejection.criteria[,"Criteria"]),]
temp.rc.recuperation.rate <- temp.rejection.criteria[
grep("Recuperation rate",temp.rejection.criteria[,"Criteria"]),]
temp.rc.palaedose.error <- temp.rejection.criteria[
grep("Palaeodose error",temp.rejection.criteria[,"Criteria"]),]
temp.rc.testdose.error <- temp.rejection.criteria[
grep("Testdose error",temp.rejection.criteria[,"Criteria"]),]
plot(
NA,NA,
xlim = c(-0.5,0.5),
ylim = c(0,40),
yaxt = "n", ylab = "",
xaxt = "n", xlab = "",
bty = "n",
main = "Rejection criteria"
)
axis(
side = 1, at = c(-0.2,-0.1,0,0.1,0.2), labels = c("- 0.2", "- 0.1","0/1","+ 0.1", "+ 0.2")
)
##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++##
##polygon for recycling ratio
text(x = -0.35, y = 35, "Recycling R.", pos = 3, srt = 90, cex = 0.8*cex, offset = 0)
polygon(x = c(
-as.numeric(as.character(temp.rc.reycling.ratio$Threshold))[1],-as.numeric(as.character(temp.rc.reycling.ratio$Threshold))[1],
as.numeric(as.character(temp.rc.reycling.ratio$Threshold))[1],
as.numeric(as.character(temp.rc.reycling.ratio$Threshold))[1]
),
y = c(31,39,39,31),
col = "gray",
border = NA)
polygon(
x = c(-0.3, -0.3, 0.3, 0.3) ,
y = c(31, 39, 39, 31),
border = ifelse(any(
grepl(pattern = "FAILED", temp.rc.reycling.ratio$Status)
), "red", "black"))
##consider possibility of multiple pIRIR signals and multiple recycling ratios
if (nrow(temp.rc.recuperation.rate) > 0) {
col.id <- 1
for (i in seq(1,nrow(temp.rc.recuperation.rate),
length(unique(temp.rc.recuperation.rate[,"Criteria"])))) {
for (j in 0:length(unique(temp.rc.recuperation.rate[,"Criteria"]))) {
points(
temp.rc.reycling.ratio[i + j, "Value"] - 1,
y = 35,
pch = col.id,
col = col.id,
cex = 1.3 * cex
)
}
col.id <- col.id + 1
}
rm(col.id)
##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++##
##polygon for recuperation rate
text(
x = -0.35, y = 25, "Recuperation", pos = 3, srt = 90, cex = 0.8*cex, offset = 0,
)
polygon(
x = c(
0,
0,
as.numeric(as.character(
temp.rc.recuperation.rate$Threshold
))[1],
as.numeric(as.character(
temp.rc.recuperation.rate$Threshold
))[1]
),
y = c(21,29,29,21),
col = "gray",
border = NA
)
polygon(
x = c(-0.3, -0.3, 0.3, 0.3) ,
y = c(21, 29, 29, 21),
border = ifelse(any(
grepl(pattern = "FAILED", temp.rc.recuperation.rate$Status)
), "red", "black")
)
polygon(
x = c(-0.3,-0.3,0,0) , y = c(21,29,29,21), border = NA, density = 10, angle = 45
)
for (i in 1:nrow(temp.rc.recuperation.rate)) {
points(
temp.rc.recuperation.rate[i, "Value"],
y = 25,
pch = i,
col = i,
cex = 1.3 * cex
)
}
}
##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++##
##polygon for testdose error
text(
x = -0.35, y = 15, "Testdose Err.", pos = 3, srt = 90, cex = 0.8*cex, offset = 0,
)
polygon(
x = c(
0,
0,
as.numeric(as.character(temp.rc.testdose.error$Threshold))[1],
as.numeric(as.character(temp.rc.testdose.error$Threshold))[1]
),
y = c(11,19,19,11),
col = "gray",
border = NA
)
polygon(
x = c(-0.3, -0.3, 0.3, 0.3) ,
y = c(11, 19, 19, 11),
border = ifelse(any(
grepl(pattern = "FAILED", temp.rc.testdose.error$Status)
), "red", "black")
)
polygon(
x = c(-0.3,-0.3,0,0) , y = c(11,19,19,11), border = NA, density = 10, angle = 45
)
for (i in 1:nrow(temp.rc.testdose.error)) {
points(
temp.rc.testdose.error[i, "Value"],
y = 15,
pch = i,
col = i,
cex = 1.3 * cex
)
}
##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++##
##polygon for palaeodose error
text(
x = -0.35, y = 5, "Palaeodose Err.", pos = 3, srt = 90, cex = 0.8*cex, offset = 0,
)
polygon(
x = c(
0,
0,
as.numeric(as.character(temp.rc.palaedose.error$Threshold))[1],
as.numeric(as.character(temp.rc.palaedose.error$Threshold))[1]
),
y = c(1,9,9,1),
col = "gray",
border = NA
)
polygon(
x = c(-0.3, -0.3, 0.3, 0.3) ,
y = c(1, 9, 9, 1),
border = ifelse(any(
grepl(pattern = "FAILED", temp.rc.palaedose.error$Status)
), "red", "black")
)
polygon(
x = c(-0.3,-0.3,0,0) , y = c(1,9,9,1), border = NA, density = 10, angle = 45
)
if(nrow(temp.rc.palaedose.error) != 0){
for (i in 1:nrow(temp.rc.palaedose.error)) {
if(!is.na(temp.rc.palaedose.error[i, "Value"])){
points(
temp.rc.palaedose.error[i, "Value"],
y = 5,
pch = i,
col = i,
cex = 1.3 * cex
)
}
}
}
}
if (plot == TRUE && 8 %in% plot.single.sel) {
##graphical representation of IR-curve
temp.IRSL <- suppressWarnings(get_RLum(object, recordType = "IRSL"))
if(length(temp.IRSL) != 0){
.validate_class(temp.IRSL, c("RLum.Data.Curve", "list"))
if(inherits(temp.IRSL, "RLum.Data.Curve")){
plot_RLum.Data.Curve(temp.IRSL, par.local = FALSE)
}else if(inherits(temp.IRSL, "list")){
plot_RLum.Data.Curve(temp.IRSL[[length(temp.IRSL)]], par.local = FALSE)
.throw_warning("Multiple IRSL curves detected (IRSL test), only the last one shown")
}
}else{
plot(1, type="n", axes=F, xlab="", ylab="")
text(x = c(1,1), y = c(1, 1), labels = "No IRSL curve detected!")
}
}
# Return --------------------------------------------------------------------------------------
invisible(temp.results.final)
}else{
.throw_warning(paste(unlist(error.list), collapse = "\n"),
"\n... >> nothing was done here!")
invisible(NULL)
}
}
Luminescence/R/extract_ROI.R 0000644 0001762 0000144 00000016402 14762554470 015414 0 ustar ligges users #'@title Extract Pixel Values through Circular Region-of-Interests (ROI) from an Image
#'
#'@description Light-weighted function to extract pixel values from pre-defined regions-of-interest (ROI) from
#'[RLum.Data.Image-class], [array] or [matrix] objects and provide simple image processing
#'capacity. The function is limited to circular ROIs.
#'
#'@details The function uses a cheap approach to decide whether a pixel lies within
#'a circle or not. It assumes that pixel coordinates are integer values and
#'that a pixel centring within the circle is satisfied by:
#'
#'\deqn{x^2 + y^2 <= (d/2)^2}
#'
#'where \eqn{x} and \eqn{y} are integer pixel coordinates and \eqn{d} is the integer
#'diameter of the circle in pixel.
#'
#'@param object [RLum.Data.Image-class], [array] or [matrix] (**required**): input image data
#'
#'@param roi [matrix] (**required**): matrix with three columns containing the centre coordinates
#'of the ROI (first two columns) and the diameter of the circular ROI. All numbers must by of type [integer]
#'and will forcefully coerced into such numbers using `as.integer()` regardless.
#'
#'@param roi_summary (*with default*): defines what is returned in the
#'`roi_summary` element; it can be `"mean"` (default), `"median"`, `"sd"` or
#'`"sum"`.
#'Pixel values are conveniently summarised using the above defined keyword.
#'
#' @param plot [logical] (*optional*): enable/disable the plot output. Only
#' the first image frame is shown.
#'
#'@return [RLum.Results-class] object with the following elements:
#'`..$roi_signals`: a named [list] with all ROI values and their coordinates
#'`..$roi_summary`: a [matrix] where rows are frames from the image, and columns are different ROI
#'The element has two attributes: `summary` (the method used to summarise pixels) and `area` (the pixel area)
#'`..$roi_coord`: a [matrix] that can be passed to [plot_ROI]
#'
#'If `plot = TRUE` a control plot is returned.
#'
#'@section Function version: 0.1.0
#'
#'@author
#'Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#'@seealso [RLum.Data.Image-class]
#'
#'@keywords manip
#'
#'@examples
#'
#' m <- matrix(runif(100,0,255), ncol = 10, nrow = 10)
#' roi <- matrix(c(2.,4,2,5,6,7,3,1,1), ncol = 3)
#' extract_ROI(object = m, roi = roi, plot = TRUE)
#'
#'@md
#'@export
extract_ROI <- function(
object,
roi,
roi_summary = "mean",
plot = FALSE
) {
.set_function_name("extract_ROI")
on.exit(.unset_function_name(), add = TRUE)
# Self call ---------------------------------------------------------------
if (is(object, "list"))
return(merge_RLum(lapply(object, extract_ROI, roi = roi, plot = plot)))
## Integrity tests --------------------------------------------------------
.validate_class(object, c("RLum.Data.Image", "matrix", "array"),
extra = "a 'list' of such objects")
## check input for ROIs
.validate_class(roi, "matrix")
if (nrow(roi) < 1 || ncol(roi) < 3)
.throw_error("'roi' does not have the expected format")
## calculate the radius
roi <- roi[,1:3]
roi[,3] <- ceiling(roi[,3]/2)
## make sure that we have integer values only in the matrix
roi[] <- as.integer(roi)
## copy object (to not work on the input data)
a <- object
## try to convert into something meaningful
if (is(object, "RLum.Data.Image"))
a <- object@data
if (is(object, "matrix"))
a <- array(data = object, dim = c(nrow(object), ncol(object), 1))
# Helper function ---------------------------------------------------------
.extract_pixel <- function(m, r, mid) {
## get row - column combinations
grid <- as.matrix(expand.grid(x = 1:nrow(m), y = 1:ncol(m)))
## adjust values for mid point
## + get pixel coordinates if within the circle
px_id <- grid[(grid[,"x"] - mid[1])^2 + (grid[,"y"] - mid[2])^2 <= r[1]^2,]
## extract values from matrix
px_extract <- NA
if (nrow(px_id) > 0) {
px_extract <- vapply(1:nrow(px_id), function(x) {
m[px_id[x,1],px_id[x,2]]
}, numeric(1))
}
attr(px_extract, "coord") <- px_id
return(px_extract)
}
# Extract ROIs ------------------------------------------------------------
roi_signals <- lapply(1:nrow(roi), function(x){
## iterate through a stack if needed
temp <- lapply(1:(dim(a)[3]), function(z){
.extract_pixel(a[,,z], roi[x,3], mid = roi[x,1:2])
})
## compile into matrix
m <- matrix(unlist(temp), nrow = length(temp[[1]]))
## add attributes ... including coordinates; but only one time
colnames(m) <- paste0("frame_", 1:ncol(m))
attr(m, "px_coord") <- attr(temp[[1]], "coord")
return(m)
})
## add names
names(roi_signals) <- paste0("ROI_", 1:nrow(roi))
# Plot check --------------------------------------------------------------
if (plot) {
## this is a control plot, so we plot only the first image; nothing more
## image
graphics::image(
x = 1:nrow(a[, , 1]),
y = 1:ncol(a[, , 1]),
a[, , 1],
ylab = "y-dim [px]",
xlab = "x-dim [px]",
useRaster = TRUE,
main = "extract_ROIs() - control plot")
graphics::box()
## visualise ROIs
overlay <- a[,,1]
overlay[] <- 0
for (i in 1:length(roi_signals))
overlay[attr(roi_signals[[i]], "px_coord")[,1], attr(roi_signals[[i]], "px_coord")[,2]] <- 1
## marked ROIs
graphics::image(
x = 1:nrow(a[, , 1]),
y = 1:ncol(a[, , 1]),
overlay,
axes = FALSE,
add = TRUE,
useRaster = TRUE,
col = c(rgb(1, 1, 1, 0), rgb(0, 1, 0, 0.5)))
## add circles and points
for (i in 1:nrow(roi)) {
lines(shape::getellipse(rx = roi[i, 3], mid = c(roi[i, 1:2], dr = 0.1)), col = "red", lwd = 1.5)
text(x = roi[i,1], y = roi[i,2], i, col = "black", cex = 1.2)
}
}
# ROI summary -------------------------------------------------------------
## set roi fun and avoid add input
.validate_class(roi_summary, "character")
roi_fun <- .validate_args(roi_summary, c("mean", "median", "sd", "sum"))
## create summary using matrixStats
roi_summary <- matrix(unlist(
switch(roi_fun,
"mean" = lapply(roi_signals, matrixStats::colMeans2),
"median" = lapply(roi_signals, matrixStats::colMedians),
"sd" = lapply(roi_signals, matrixStats::colSds),
"sum" = lapply(roi_signals, matrixStats::colSums2))),
ncol = length(roi_signals))
## set names to make it easier
colnames(roi_summary) <- names(roi_signals)
rownames(roi_summary) <- paste0("frame_", 1:nrow(roi_summary))
attr(roi_summary, "summary") <- roi_fun
attr(roi_summary, "area") <- vapply(roi_signals, nrow, numeric(1))
## add more roi information to the output for further processing
roi <- cbind(
ROI = 1:nrow(roi),
x = roi[,1],
y = roi[,2],
area = attr(roi_summary, "area"),
width = vapply(roi_signals, function(x) diff(range(attr(x, "px_coord")[,"x"])), numeric(1)),
height = vapply(roi_signals, function(x) diff(range(attr(x, "px_coord")[,"y"])), numeric(1)),
img_width = nrow(a[, , 1]),
img_height = ncol(a[, , 1]),
grain_d = roi[,3])
# Return ------------------------------------------------------------------
return(
set_RLum(
class = "RLum.Results",
data = list(
roi_signals = roi_signals,
roi_summary = roi_summary,
roi_coord = roi),
info = list(
call = sys.call())))
}
Luminescence/R/combine_De_Dr.R 0000644 0001762 0000144 00000063613 14762554470 015710 0 ustar ligges users #'@title Estimate Individual Age using Bayesian Inference
#'
#'@description A Bayesian robust estimation of central age from equivalent dose
#' measurements under the assumption that the dose rate is modelled by a
#' finite Gaussian mixture model.
#'
#'@param theta [numeric] (**required**): the weight vector of the Gaussian mixture
#'
#'@param mu [numeric] (**required**): is the mean vector of the Gaussian mixture
#'
#'@param sigma [numeric] (**required**): is the standard deviation vector of the Gaussian mixture
#'
#'@param De [numeric] (**required**): the equivalent dose sample
#'
#'@param s [numeric] (**required**): the vector of measurement errors on De.
#'
#'@param sig0 [numeric] (**required**): the prior shrinkage parameter
#'
#'@param Age_range [numeric] (*with default*): the age range to investigate
#'
#'@param method_control [list] (*with default*): parameters passed down
#' to the jags process
#'
#' @param verbose [logical] (*with default*): enable/disable output to the
#' terminal.
#'
#'@return An [RLum.Results-class] object to be used in [combine_De_Dr]
#'
#'@section Function version: 0.1.0
#'
#'@note The function is intended to be called by [combine_De_Dr], however, for
#' reasons of transparency
#'
#'@author Anne Philippe, Université de Nantes (France),
#' Jean-Michel Galharret, Université de Nantes (France),
#' Norbert Mercier, IRAMAT-CRP2A, Université Bordeaux Montaigne (France),
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#'@examples
#' n <- 1000
#' sdt <- 0.3
#' Dr <- stats::rlnorm (n, 0, sdt)
#' int_OD <- 0.1
#' tildeDr = Dr * (1 + rnorm(length(Dr), 0, int_OD))
#' De <- c(50 * sample(Dr, 50, replace = TRUE), 10, 12, 200, 250)
#' k <- length(De)
#' s <- stats::rnorm(k, 10, 2)
#' a <- De / mean(tildeDr)
#' sig_a2 <- a ^ 2 * (s / De) ^ 2
#' sig0 <- sqrt(1 / mean(1 / sig_a2))
#' fit <- mclust::Mclust(tildeDr, model = "V")
#' theta <- fit$parameters$pro
#' mu <- fit$parameters$mean
#' sigma <- sqrt(fit$parameters$variance$sigmasq)
#' Age_range <- c(0, Dr * (1 + rnorm(length(Dr), 0, int_OD[1])))
#' res <- .calc_IndividualAgeModel(theta, mu, sigma, De, s, sig0, Age_range = Age_range)
#'@md
#'@noRd
.calc_IndividualAgeModel <- function(
theta,
mu,
sigma,
De,
s,
sig0,
Age_range,
method_control = list(),
verbose = TRUE
){
# Set parameters and models -----------------------------------------------
nobs <- length(De)
event1 <- "model{
for( i in 1 : N ) {
D_e[i] ~ dnorm(a[i] * mu, tau[i])
tau[i] <- 1 / (a[i] * sigma) ^ 2
De[i] ~ dnorm(D_e[i], prec2[i])
a[i] ~ dnorm(A, prec_a[i])
u[i] ~ dunif(0,1)
prec_a[i] <- 1 / s02 * u[i] / (1 - u[i])
prec2[i] <- 1 / (s2[i])
sig_a[i] <- 1 / sqrt(prec_a[i])
}
A ~ dunif(Amin, Amax)
}"
event2 <- "model{
for( i in 1 : N ) {
D_e[i] ~ dnorm(a[i] * mu[z[i]], tau[i])
tau[i] <- 1 / (a[i] * sigma[z[i]]) ^ 2
z[i] ~ dcat(theta)
De[i] ~ dnorm(D_e[i], prec2[i])
a[i] ~ dnorm(A, prec_a[i])
u[i] ~ dunif(0, 1)
prec_a[i] <- 1 / s02 * u[i] / (1 - u[i])
prec2[i] <- 1 / (s2[i])
sig_a[i] <- 1 / sqrt(prec_a[i])
}
A ~ dunif(Amin, Amax)
}"
data1 <- list(
'theta' = theta,
'mu' = mu,
'sigma' = sigma,
'N' = nobs ,
'De' = De,
's2' = s ^ 2,
's02' = sig0[1] ^ 2,
'Amin' = Age_range[1],
'Amax' = Age_range[2]
)
# Run Bayesian model ------------------------------------------------------
method_control <- modifyList(
x = list(
variable.names = c('A', 'a', 'sig_a'),
n.chains = 4,
n.adapt = 1000,
n.iter = 5000,
thin = 1,
progress.bar = if(verbose) "text" else "none",
quiet = if(verbose) FALSE else TRUE,
diag = if(verbose) TRUE else FALSE,
return_mcmc = FALSE
),
val = method_control)
on.exit(close(model), add = TRUE)
## select model
if(length(theta) == 1) {
data1$theta <- NULL
model <- textConnection(event1)
} else {
model <- textConnection(event2)
}
## run model
if(verbose) cat("(1) Running Bayesian modelling 'Individual Age Model' ... ")
jags <- rjags::jags.model(
file = model,
data = data1,
n.chains = method_control$n.chains,
n.adapt = method_control$n.adapt,
quiet = method_control$quiet
)
stats::update(
jags,
n.iter = method_control$n.iter,
progress.bar = method_control$progress.bar,
quiet = method_control$quiet
)
samp <-
rjags::coda.samples(
model = jags,
variable.names = method_control$variable.names,
n.iter = method_control$n.iter,
thin = method_control$thin,
progress.bar = method_control$progress.bar
)
if(verbose & method_control$quiet) cat("DONE")
if(method_control$diag) {
cat("\n[.calc_IndividualAgeModel()]\n")
print(coda::gelman.diag(samp))
}
# Return ------------------------------------------------------------------
return(set_RLum(
"RLum.Results",
data = list(
A = unlist(samp[, "A"]),
a = do.call(rbind, samp[, 2:(nobs + 1)]),
sig_a = do.call(rbind, samp[, (2 + nobs):(2 * nobs + 1)]),
model = paste(jags$model(), ""),
mcmc_IAM = if(method_control$return_mcmc) samp else NULL),
info = list(call = sys.call())
))
}
#'@title Central Bayesian Central Age Model
#'
#'@description A Bayesian estimation of central age from equivalent dose measurements
#'under the assumption that the dose rate is modelled by finite Gaussian mixture model.
#'MCMC outputs provide to JAGS program.
#'
#'@param theta [numeric] (**required**): the weight vector of the Gaussian mixture
#'
#'@param mu [numeric] (**required**): is the mean vector of the Gaussian mixture
#'
#'@param sigma [numeric] (**required**): is the standard deviation vector of the Gaussian mixture
#'
#'@param De [numeric] (**required**): the equivalent dose sample
#'
#'@param s [numeric] (**required**): the vector of measurement errors on De.
#'
#'@param Age_range [numeric] (*with default*): the age range to investigate
#'
#'@param method_control [list] (*with default*): parameters passed down to the jags process
#'
#' @param verbose [logical] (*with default*): enable/disable output to the
#' terminal.
#'
#'@return An [RLum.Results-class] object
#'
#'@section Function version: 0.1.0
#'
#'@author Anne Philippe, Université de Nantes (France),
#'Jean-Michel Galharret, Université de Nantes (France),
#'Norbert Mercier, IRAMAT-CRP2A, Université Bordeaux Montaigne (France),
#'Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#'@md
#'@noRd
.calc_BayesianCentralAgeModel <- function(
theta,
mu,
sigma,
De,
s,
Age_range,
method_control = list(),
verbose = TRUE
){
# Set models --------------------------------------------------------------
central_age_model1 <- "
model{
for( i in 1:J) {
D_e[i] ~ dnorm(A*mu,1/(A*sigma)^2)
De[i] ~ dnorm(D_e[i], prec2[i])
prec2[i] <- 1/(s2[i])
}
A ~ dunif(Amin,Amax)
}"
central_age_model2 <- "
model{
for( i in 1:J) {
D_e[i] ~ dnorm(A*mu[z[i]],tau[i])
tau[i]<-1/(A*sigma[z[i]])^2
z[i] ~ dcat(theta)
De[i] ~ dnorm(D_e[i], prec2[i])
prec2[i] <- 1/(s2[i])
}
A ~ dunif(Amin,Amax)
}"
# Run Bayesian modelling --------------------------------------------------
method_control <- modifyList(
x = list(
variable.names = c('A', 'D_e'),
n.chains = 4,
n.adapt = 1000,
n.iter = 5000,
thin = 1,
progress.bar = if(verbose) "text" else "none",
quiet = if(verbose) FALSE else TRUE,
diag = if(verbose) TRUE else FALSE,
return_mcmc = FALSE
),
val = method_control)
on.exit(close(model), add = TRUE)
data <-
list(
'theta' = theta,
'mu' = mu,
'sigma' = sigma,
'De' = De,
'J' = length(De),
's2' = s ^ 2,
'Amin' = Age_range[1],
'Amax' = Age_range[2]
)
## select model
if(length(theta) == 1) {
data$theta <- NULL
model <- textConnection(central_age_model1)
} else {
model <- textConnection(central_age_model2)
}
## run modelling
if(verbose) cat("\n(2) Running Bayesian modelling 'Bayesian Central Age Model' ... ")
jags2 <- rjags::jags.model(
file = model,
data = data,
n.chains = method_control$n.chains,
n.adapt = method_control$n.adapt,
quiet = method_control$quiet
)
stats::update(
object = jags2,
n.iter = method_control$n.iter,
progress.bar = method_control$progress.bar,
quiet = method_control$quiet
)
samp2 <- rjags::coda.samples(
model = jags2,
variable.names = method_control$variable.names,
n.iter = method_control$n.iter,
thin = method_control$thin,
progress.bar = method_control$progress.bar
)
if(verbose & method_control$quiet) cat("DONE\n")
if(method_control$diag) {
cat("\n[.calc_BayesianCentralAgeModel()]\n")
print(coda::gelman.diag(samp2))
}
# Return ------------------------------------------------------------------
return(set_RLum(
"RLum.Results",
data = list(
A = unlist(samp2[, "A"]),
D_e = do.call(rbind, samp2[, -1]),
model = paste(jags2$model(), ""),
mcmc_BCAM = if(method_control$return_mcmc) samp2 else NULL),
info = list(call = sys.call())
))
}
#'@title Combine Dose Rate and Equivalent Dose Distribution
#'
#'@description A Bayesian statistical analysis of OSL age requiring dose rate sample.
#'Estimation contains a preliminary step for detecting outliers in the equivalent
#'dose sample.
#'
#'@details
#'
#'**Outlier detection**
#'
#'Two different outlier detection methods are implemented (full details are given
#'in the cited literature).
#'
#'1. The *default* and recommend method, uses quantiles to compare prior and
#'posterior distributions of the individual variances of the equivalent doses.
#'If the corresponding quantile in the corresponding posterior distribution is larger
#'than the quantile in the prior distribution, the value is marked
#'as outlier (cf. Galharret et al., preprint)
#'
#'2. The alternative method employs the method suggested by Rousseeuw and Croux (1993)
#'using the absolute median distance.
#'
#'**Parameters available for `method_control`**
#'
#'The parameters listed below are used to granular control Bayesian modelling using
#'[rjags::rjags]. Internally the functions `.calc_IndividualAgeModel()` and
#'`.calc_BayesianCentraAgelModel()`. The parameter settings affect both models.
#'Note: `method_control` expects a **named** list of parameters
#'
#'\tabular{llll}{
#' **PARAMETER** \tab **TYPE** \tab **DEFAULT** \tab **REMARKS** \cr
#' `variable.names_IAM` \tab [character] \tab `c('A', 'a', 'sig_a')` \tab variables names to be monitored in the modelling process using the internal function `.calc_IndividualAgeModel()`\cr
#' `variable.names_BCAM` \tab [character] \tab `c('A', 'D_e')` \tab variables names to be monitored in the modelling process using the internal function `.calc_BayesianCentraAgelModel()`\cr
#' `n.chains` \tab [integer] \tab `4` \tab number of MCMC chains\cr
#' `n.adapt` \tab [integer] \tab `1000` \tab number of iterations for the adaptation\cr
#' `n.iter` \tab [integer] \tab `5000` \tab number of iterations to monitor cf. [rjags::coda.samples]\cr
#' `thin` \tab [numeric] \tab `1` \tab thinning interval for the monitoring cf. [rjags::coda.samples]\cr
#' `diag` \tab [logical] \tab `FALSE` \tab additional terminal convergence diagnostic.
#' `FALSE` if `verbose = FALSE`\cr
#' `progress.bar` \tab [logical] \tab `FALSE` \tab enable/disable progress bar. `FALSE` if `verbose = FALSE`\cr
#' `quiet` \tab [logical] \tab `TRUE` \tab silence terminal output. Set to `TRUE` if `verbose = FALSE`\cr
#' `return_mcmc`\tab [logical] \tab `FALSE` \tab return additional MCMC diagnostic information\cr
#'}
#'
#'@param De [numeric] (**required**): a equivalent dose sample
#'
#'@param s [numeric] (**required**): a vector of measurement errors on the equivalent dose
#'
#'@param Dr [numeric] (**required**): a dose rate sample
#'
#'@param int_OD [numeric] (**required**): the intrinsic overdispersion, typically the standard deviation
#'characterizing a dose-recovery test distribution
#'
#'@param Age_range [numeric] (*with default*): the age range to be investigated by the algorithm, the larger
#'the value the more iterations are needed and the longer it takes. Should not be set too narrow, cut
#'the algorithm some slack.
#'
#'@param outlier_threshold [numeric] (*with default*): the required significance level used
#'for the outlier detection. If set to `1`, no outliers are removed. If
#'`outlier_method = "RousseeuwCroux1993"`, the median distance is used as outlier threshold.
#'Please see details for further information.
#'
#'@param outlier_method [character] (*with default*): select the outlier detection
#'method, either `"default"` or `"RousseeuwCroux1993"`. See details for further information.
#'
#' @param outlier_analysis_plot [logical] (*with default*): enable/disable the
#' outlier analysis plot. Note: the outlier analysis will happen independently
#' of the plot output.
#'
#'@param method_control [list] (*with default*): named [list] of further parameters passed down
#' to the [rjags::rjags] modelling
#'
#'@param par_local [logical] (*with default*): if set to `TRUE` the function uses its
#'own [graphics::par] settings (which will end in two plots next to each other)
#'
#' @param verbose [logical] (*with default*): enable/disable output to the
#' terminal.
#'
#' @param plot [logical] (*with default*): enable/disable the plot output.
#'
#'@param ... a few further arguments to fine-tune the plot output such as
#'`cdf_ADr_quantiles` (`TRUE`/`FALSE`), `legend.pos`, `legend` (`TRUE`/`FALSE`)
#'
#'@return The function returns a plot if `plot = TRUE` and an [RLum.Results-class]
#'object with the following slots:
#'
#' `@data`\cr
#' `.. $Ages`: a [numeric] vector with the modelled ages to be further analysed or visualised\cr
#' `.. $Ages_stats`: a [data.frame] with sum HPD, CI 68% and CI 95% for the ages \cr
#' `.. $outliers_index`: the index with the detected outliers\cr
#' `.. $cdf_ADr_mean` : empirical cumulative density distribution A * Dr (mean)\cr
#' `.. $cdf_ADr_quantiles` : empirical cumulative density distribution A * Dr (quantiles .025,.975)\cr
#' `.. $cdf_De_no_outlier` : empirical cumulative density distribution of the De with no outliers\cr
#' `.. $cdf_De_initial` : empirical cumulative density distribution of the initial De\cr
#' `.. $mcmc_IAM` : the MCMC list of the Individual Age Model, only of `method_control = list(return_mcmc = TRUE)` otherwise `NULL`\cr
#' `.. $mcmc_BCAM` : the MCMC list of the Bayesian Central Age Model, only of `method_control = list(return_mcmc = TRUE)` otherwise `NULL`\cr
#'
#' `@info`\cr
#' `.. $call`: the original function call\cr
#' `.. $model_IAM`: the BUGS model used to derive the individual age\cr
#' `.. $model_BCAM`: the BUGS model used to calculate the Bayesian Central Age\cr
#'
#'@references
#'
#'Mercier, N., Galharret, J.-M., Tribolo, C., Kreutzer, S., Philippe, A., preprint.
#'Luminescence age calculation through Bayesian convolution of equivalent dose and
#'dose-rate distributions: the De_Dr model. Geochronology, 1-22.
#'
#'Galharret, J-M., Philippe, A., Mercier, N., preprint. Detection of outliers with
#'a Bayesian hierarchical model: application to the single-grain luminescence dating method.
#'Electronic Journal of Applied Statistics
#'
#'**Further reading**
#'
#'Rousseeuw, P.J., Croux, C., 1993. Alternatives to the median absolute deviation.
#'Journal of the American Statistical Association 88, 1273–1283. \doi{10.2307/2291267}
#'
#'Rousseeuw, P.J., Debruyne, M., Engelen, S., Hubert, M., 2006. Robustness and outlier detection in chemometrics.
#'Critical Reviews in Analytical Chemistry 36, 221–242. \doi{10.1080/10408340600969403}
#'
#'@author Anne Philippe, Université de Nantes (France),
#'Jean-Michel Galharret, Université de Nantes (France),
#'Norbert Mercier, IRAMAT-CRP2A, Université Bordeaux Montaigne (France),
#'Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#'@seealso [plot_OSLAgeSummary], [rjags::rjags], [mclust::mclust-package]
#'
#'@section Function version: 0.1.0
#'
#'@keywords dplot distribution datagen
#'
#'@examples
#'## set parameters
#' Dr <- stats::rlnorm (1000, 0, 0.3)
#' De <- 50*sample(Dr, 50, replace = TRUE)
#' s <- stats::rnorm(50, 10, 2)
#'
#'## run modelling
#'## note: modify parameters for more realistic results
#'\dontrun{
#'results <- combine_De_Dr(
#' Dr = Dr,
#' int_OD = 0.1,
#' De,
#' s,
#' Age_range = c(0,100),
#' method_control = list(
#' n.iter = 100,
#' n.chains = 1))
#'
#'## show models used
#'writeLines(results@info$model_IAM)
#'writeLines(results@info$model_BCAM)
#'}
#'
#'@md
#'@export
combine_De_Dr <- function(
De,
s,
Dr,
int_OD,
Age_range = c(1,300),
outlier_threshold = .05,
outlier_method = "default",
outlier_analysis_plot = FALSE,
method_control = list(),
par_local = TRUE,
verbose = TRUE,
plot = TRUE,
...
) {
.set_function_name("combine_De_Dr")
on.exit(.unset_function_name(), add = TRUE)
## check package availability ---------------------------------------------
.require_suggested_package("rjags")
.require_suggested_package("coda")
.require_suggested_package("mclust")
## Integrity checks -------------------------------------------------------
if (length(De) != length(s))
.throw_error("'De' and 's' should have the same length")
.validate_logical_scalar(verbose)
.validate_logical_scalar(plot)
# Prepare data ------------------------------------------------------------
## we have to fetch the function otherwise
## we would need it in import instead of suggests
mclustBIC <- mclust::mclustBIC
## Estimation of the rate dose Dr1 by a Gaussian Mixture Model
tildeDr <- Dr * (1 + rnorm(length(Dr), 0, int_OD[1]))
fit <-
mclust::Mclust(data = tildeDr,
modelNames = "V",
verbose = FALSE)
theta <- fit$parameters$pro
mu <- fit$parameters$mean
sigma <- sqrt(fit$parameters$variance$sigmasq)
a <- De / mean(tildeDr)
sig_a2 <- a ^ 2 * (s / De) ^ 2
sig0 <- sqrt(1 / mean(1 / sig_a2))
# Set parameters ----------------------------------------------------------
method_control <- modifyList(
x = list(
variable.names_IAM = c('A', 'a', 'sig_a'),
variable.names_BCAM = c('A', 'D_e'),
n.chains = 4,
n.adapt = 1000,
n.iter = 5000,
thin = 1,
progress.bar = "none",
quiet = TRUE,
diag = FALSE,
return_mcmc = FALSE
),
val = method_control)
# Bayesian Modelling IAM --------------------------------------------------
if(verbose) cat("\n[combine_De_Dr()]\n")
fit_IAM <- .calc_IndividualAgeModel(
theta = theta,
mu = mu,
sigma = sigma,
De = De,
s = s,
sig0 = sig0,
Age_range = Age_range[1:2],
verbose = verbose,
method_control = list(
variable.names = method_control$variable.names_IAM,
n.chains = method_control$n.chains,
n.adapt = method_control$n.adapt,
n.iter = method_control$n.iter,
thin = method_control$thin,
progress.bar = method_control$progress.bar,
quiet = method_control$quiet,
diag = method_control$diag,
return_mcmc = method_control$return_mcmc)
)
# Outlier detection -------------------------------------------------------
## set threshold for outliers
alpha <- outlier_threshold[1]
## apply method ... default is method develop by Jean-Michel and Anne
if(outlier_method == "RousseeuwCroux1993") {
## calculate the median of the sig_a
xj <- log(matrixStats::colMedians(fit_IAM$sig_a))
MAD <- 1.483 * median(abs(xj - median(xj)))
test <- (xj - median(xj)) / MAD
out <- sort(which(test > alpha))
} else {
sig_max <- sig0 * ((1 - alpha) / alpha) ^ .5
test <- vapply(1:length(De), function(j){
mean(fit_IAM$sig_a[, j] >= sig_max)
}, numeric(1))
out <- sort(which(test > alpha))
}
##some terminal output
if(verbose){
if (length(out) > 0) {
cat(
paste0(
"\n >> Outliers detected: ",
length(out), "/", length(De),
" (", round(length(out) / length(De) * 100, 1), "%)"
)
)
}
}
## apply the removal
if (length(out) == 0) {
De1 <- De
s1 <- s
} else {
De1 <- De[-out]
s1 <- s[-out]
}
# Bayesian modelling BCAM -------------------------------------------------
fit_BCAM <- .calc_BayesianCentralAgeModel(
theta,
mu,
sigma,
De = De1,
s = s1,
Age_range = Age_range,
verbose = verbose,
method_control = list(
variable.names = method_control$variable.names_BCAM,
n.chains = method_control$n.chains,
n.adapt = method_control$n.adapt,
n.iter = method_control$n.iter,
thin = method_control$thin,
progress.bar = method_control$progress.bar,
quiet = method_control$quiet,
diag = method_control$diag,
return_mcmc = method_control$return_mcmc)
)
# Calculate EDFC -------------------------------------------------
## calculate various parameters
D_e <- fit_BCAM$D_e
A2 <- fit_BCAM$A
## calculate bandwidths
h <- density(De)$bw
h1 <- density(De1)$bw
t <- seq(min(D_e), max(D_e), length.out = min(1000, round(max(D_e) - min(D_e), 0)))
ind <- min(5000, length(A2))
subsamp <- sample(1:length(A2), ind, replace = FALSE)
cdf_ADr <- matrix(0, nrow = ind, ncol = length(t))
## De distribution re-sampled without outliers -> De2
## De distribution re-sampled initial -> De3
De2 <-
rnorm(length(subsamp), sample(De1, size = length(subsamp), replace = TRUE), h1)
De3 <-
rnorm(length(subsamp), sample(De, size = length(subsamp), replace = TRUE), h)
## calculate ecdf
cdf_De_no_outlier<- stats::ecdf(De2)(t)
cdf_De_initial <- stats::ecdf(De3)(t)
for (i in 1:ind)
cdf_ADr[i, ] <- stats::ecdf(A2[subsamp[i]] * tildeDr)(t)
## calculate mean value and quantiles for the ecdf A * Dr
cdf_ADr_mean <- matrixStats::colMeans2(cdf_ADr)
cdf_ADr_quantiles <- matrixStats::colQuantiles(cdf_ADr, probs = c(.025,.975))
## further values to ease the interpretation
d <- density(fit_BCAM$A)
HPD <- d$x[which.max(d$y)[1]]
CI_68 <- .calc_HPDI(fit_BCAM$A, prob = 0.68)
CI_95 <- .calc_HPDI(fit_BCAM$A, prob = 0.95)
# Additional terminal output ----------------------------------------------
if(verbose){
cat("(3) Age results (presumably in ka) \n")
cat(" -----------------------------------\n")
cat(" Age (HPD) :\t", format(round(HPD,2), nsmall = 2), "\n")
cat(" Age (CI 68%):\t", paste(format(round(range(CI_68),2), nsmall =2), collapse = " : "), "\n")
cat(" Age (CI 95%):\t", paste(format(round(range(CI_95),2), nsmall =2), collapse = " : "), "\n")
cat(" -----------------------------------\n")
}
# Plotting ----------------------------------------------------------------
if(plot){
##check incoming plot settings
plot_settings <- modifyList(x = list(
cdf_ADr_quantiles = FALSE,
legend = TRUE,
legend.pos = "bottomright"
), list(...))
##make sure we reset plots
if(par_local) {
old.par <- par(mfrow = c(1, 2))
on.exit(par(old.par), add = TRUE)
}
if(outlier_analysis_plot){
N <- length(De)
##plot with outliers
graphics::boxplot(fit_IAM$sig_a, outline = FALSE,
col = (abs(as.numeric(
1:length(De) %in% out
) - 1) + 2),
main = "Outlier detection",
xaxt = "n",
xlab = expression(paste("Index of ", sigma[a])))
## add axis
axis(side = 1, at = 1:length(De), labels = 1:length(De), )
mtext(
text = paste0(length(out), "/", N, " (", round(length(out) / N * 100, 1), "%)"),
side = 3,
cex = 0.8
)
abline(h = sig0, col = "violet")
##plot sd of outliers
if(length(out) > 0){
graphics::boxplot(fit_IAM$sig_a[, out],
outline = FALSE,
names = out,
ylab = "Individual sd [a.u.]",
main = "Outliers: posterior distr.")
abline(h = sig0, col = "violet")
} else {
shape::emptyplot()
text(0.5, 0.5, "No outlier detected!")
}
}
##plot age summary
plot_OSLAgeSummary(
object = fit_BCAM,
level = 0.68,
rug = FALSE,
polygon_col = rgb(100, 149, 237, 75, maxColorValue = 255),
verbose = FALSE
)
## open plot area
plot(NA,
xlim = range(t),
ylim = c(0, 1),
ylab = "ecdf (mean)",
xlab = "Dose [Gy]",
main= "ECDF")
## add quantile range (only for A * Dr)
if(plot_settings$cdf_ADr_quantiles){
polygon(
x = c(t, rev(t)),
y = c(cdf_ADr_quantiles[,1], rev(cdf_ADr_quantiles[,2])),
col = rgb(1,0,0,0.2), lty = 0)
}
##add mean lines for the ecdfs
lines(t, cdf_ADr_mean, col = 2, lty = 1, lwd = 2)
lines(t, cdf_De_no_outlier, type = "l", col = 3, lty = 2, lwd = 2)
lines(t, cdf_De_initial, type = "l", col = 4, lty = 3, lwd = 2)
if(plot_settings$legend){
legend(
plot_settings$legend.pos,
legend = c(
expression(A %*% Dr),
expression(paste(D[e], " no outliers")),
expression(paste(D[e], " initial"))),
lty = c(1,2,3),
bty = "n",
col = c(2,3,4),
cex = 0.8)
}
}
# Return results ----------------------------------------------------------
return(set_RLum(
"RLum.Results",
data = list(
Ages = fit_BCAM$A,
Ages_stats = data.frame(
HPD = HPD,
CI_68_lower = CI_68[1],
CI_68_upper = CI_68[2],
CI_95_lower = CI_95[1],
CI_95_upper = CI_95[2]),
outliers_index = out,
cdf_ADr_mean = cdf_ADr_mean,
cdf_ADr_quantiles = cdf_ADr_quantiles,
cdf_De_no_outlier = cdf_De_no_outlier,
cdf_De_initial = cdf_De_initial,
mcmc_IAM = fit_IAM$mcmc_IAM,
mcmc_BCAM = fit_BCAM$mcmc_BCAM
),
info = list(
call = sys.call(),
model_IAM = fit_IAM$model,
model_BCAM = fit_BCAM$model)
))
}
Luminescence/R/calc_EED_Model.R 0000644 0001762 0000144 00000070462 14762554470 015736 0 ustar ligges users #' @title Modelling Exponential Exposure Distribution
#'
#' @description Modelling incomplete and heterogeneous bleaching of mobile grains partially
#' exposed to the light, an implementation of the EED model proposed by Guibert et al. (2019).
#'
#' @details The function is an implementation and enhancement of the scripts used in
#' Guibert et al. (2019). The implementation supports a semi-automated estimation
#' of the parameters `kappa` and `sigma_distr`. If set to `NULL`, a surface interpolation
#' is used to estimated those values.
#'
#' **Method control parameters**
#'
#' \tabular{llll}{
#' **ARGUMENT** \tab **FUNCTION** \tab **DEFAULT** \tab **DESCRIPTION**\cr
#' `lower` \tab - \tab `c(0.1,0,0)` \tab set lower bounds for kappa, sigma, and the expected De in auto mode \cr
#' `upper` \tab - \tab `c(1000,2)` \tab set upper bounds for kappa, sigma, and the expected De in auto mode \cr
#' `iter_max` \tab - \tab `1000` \tab maximum number for iterations for used to find kappa and sigma \cr
#' `trace` \tab - \tab `FALSE` \tab enable/disable terminal trace mode; overwritten by global argument `verbose`\cr
#' `trace_plot` \tab - \tab `FALSE` \tab enable/disable additional trace plot output; overwritten by global argument `verbose` \cr
#'
#' }
#'
#' @param data [data.frame] (**required**): input data consisting of two columns, the De and the
#' SE(De). Values are expected in Gy
#'
#' @param D0 [integer] (*with default*): D0 value (in Gy), defining the
#' characterisation behaviour of the quartz.
#'
#' @param expected_dose [numeric] (**required**): expected equivalent dose
#'
#' @param MinIndivDose [numeric] (*with default*): value specifying the minimum dose taken into
#' account for the plateau. `NULL` applies all values.
#'
#' @param MaxIndivDose [numeric] (*with default*): value specifying the maximum dose taken into
#' account for the plateau. `NULL` applies all values.
#'
#' @param kappa [numeric] (*optional*): positive dimensionless exposure parameter
#' characterising the bleaching state of the grains. Low values (< 10) indicate
#' poor bleaching
#'
#' @param sigma_distr [numeric] (*optional*): positive dose rate parameter, representing the
#' dose variability to which the grains were exposed ##TODO perhaps it should be renamed
#'
#' @param n.simul [integer] (*with default*): number of simulations
#'
#' @param n.minSimExp [integer] (*with default*): number of MC runs for calculating the uncertainty
#' contribution from the sampling
#'
#' @param sample_name [character] (*with default*): name of the sample
#'
#' @param method_control [list] (*with default*): additional deep control parameters, parameters
#' need to be provided as named list, see details
#'
#' @param verbose [logical] (*with default*): enable/disable output to the
#' terminal.
#'
#' @param plot [logical] (*with default*): enable/disable the plot output.
#'
#' @param ... further parameters that can be passed to better control the plot output. Support arguments
#' are `xlab`, `xlim`.
#'
#' @author Pierre Guibert, IRAMAT-CRP2A, UMR 5060, Université Bordeaux Montaigne (France),
#' Sebastian Kreutzer, Geography & Earth Sciences, Aberystwyth University (United Kingdom)
#'
#' @section Function version: 0.1.0
#'
#' @references Guibert, P., Christophe, C., Urbanova, P., Guérin, G., Blain, S., 2017.
#' Modelling incomplete and heterogeneous bleaching of mobile grains partially exposed to the
#' light - Towards a new tool for single grain OSL dating of poorly bleached mortars.
#' Radiation Measurements 107, 48–57. \doi{10.1016/j.radmeas.2017.10.003}
#'
#' @seealso [RLum.Results-class], [calc_MinDose], [calc_FuchsLang2001], [calc_IEU],
#' [calc_FiniteMixture]
#'
#' @keywords datagen
#'
#' @examples
#'
#' data(ExampleData.MortarData, envir = environment())
#' calc_EED_Model(
#' data = MortarData,
#' kappa = 14,
#' sigma_distr = 0.37,
#' expected_dose = 11.7)
#'
#' ## automated estimation of
#' ## sigma_distribution and
#' ## kappa
#' \dontrun{
#' calc_EED_Model(
#' data = MortarData,
#' kappa = NULL,
#' sigma_distr = NULL,
#' expected_dose = 11.7)
#' }
#'
#' @md
#' @export
calc_EED_Model <- function(
data,
D0 = 120L,
expected_dose,
MinIndivDose = NULL,
MaxIndivDose = NULL,
kappa = NULL,
sigma_distr = NULL,
n.simul = 5000L,
n.minSimExp = 50L,
sample_name = "",
method_control = list(),
verbose = TRUE,
plot = TRUE,
...
) {
.set_function_name("calc_EED_Model")
on.exit(.unset_function_name(), add = TRUE)
##TODO
## add docu examples
## add docu details
##
## TODO Questions to Pierre
## - what the user is doing of the real dose/age is not known, can it be assessed?
## - the underlying assumption is obviously an exponential distribution, what
## - so far the parameter uncertainty estimation does not work nicely.x
## happens to data where this is not observed? I cannot work?
## Integrity checks -------------------------------------------------------
.validate_class(data, "data.frame")
.validate_class(expected_dose, "numeric")
if (!is.null(MinIndivDose))
.validate_class(MinIndivDose, "numeric")
if (!is.null(MaxIndivDose))
.validate_class(MaxIndivDose, "numeric")
##store and restore par settings
par_default <- par(no.readonly = TRUE)
on.exit(par(mfrow = par_default$mfrow), add = TRUE)
# Helper functions ----------------------------------------------------------------------------
##the helper functions base on ode by Pierre, each helper was only a little bit
## optimised and then tested separately
# Calcul de la variance du plateau sur la base des doses arch?o
# corrig?es de la dose r?siduelle uniquement (modif 31.5.2018)
# nocov start
.calc_Plateau_Variance <- function(M_Data, MinDose_Index, MaxDose_Index){
var_ratio <- stats::var(M_Data[MinDose_Index:MaxDose_Index, 3]) # doses nettes corrigées résiduel uniquement
mean_ratio <- mean(M_Data[MinDose_Index:MaxDose_Index, 3])
return(var_ratio / (mean_ratio ^ 2))
}
# nocov end
# Calcul de la variance du plateau modifi? le 31.5.2018
# sur la base des rapport observ?/simul? des doses totales brutes
.calc_Plateau_Variance_uncorr <- function (M_Data, MinDose_Index, MaxDose_Index){
var_ratio <-
stats::var(M_Data[MinDose_Index:MaxDose_Index, 4]) # ratio observé/simulé brut
mean_ratio <- mean(M_Data[MinDose_Index:MaxDose_Index, 4])
return (var_ratio / (mean_ratio ^ 2))
}
# Calcul de la variance du plateau ajout le 20.8.2018
# sur la base des doses archeologiques
# ##TODO not yet included
# nocov start
.calc_Plateau_Variance_AD <- function (M_Data, MinDose_Index, MaxDose_Index) {
var_ratio <- stats::var(M_Data[MinDose_Index:MaxDose_Index, 6])
mean_ratio <- mean(M_Data[MinDose_Index:MaxDose_Index, 6])
return (var_ratio / (mean_ratio ^ 2))
}
# nocov end
.EED_Simul_Matrix <- function (M_Simul, expected_dose, sigma_distr,D0, kappa, Iinit, Nsimul){
## génére une liste de Nsimul valeurs distribu?es selon une loi log normale de moyenne expected_dose ##
M_Simul[,1] <- expected_dose * exp(sigma_distr * rnorm(Nsimul)) *
exp(-0.5 * (sigma_distr ^ 2))
## génére une liste de Nsimul valeurs de dose r?siduelle selon une distribution expoentielle de l'exposition ##
M_Simul[, 2] <-
(-D0 * log(1 - Iinit * exp(-stats::rexp(Nsimul, rate = 1 / kappa))))
## génére la liste des doses individuelles ##
M_Simul[,3] <- M_Simul[,1] + M_Simul[,2]
## génére la liste class?e des doses individuelles ##
M_Simul[,4] <- sort(M_Simul[,3], decreasing = FALSE)
## génére une liste d'index and sort it
index <- sort.list(rank(M_Simul[,3], ties.method = "first"))
## la liste d'index est utilis?e pour remettre les colonnes 1 et 2 dans l'ordre du classement des doses totales ##
M_Simul[,5:6] <- M_Simul[index,1:2]
##calculate cumulative mean values
M_Simul[,7:9] <- matrixStats::colCumsums(M_Simul[,4:6]) / seq_len(Nsimul)
##return value
return(M_Simul)
}
# Calcul de la matrice de M_Data : donnees experimentales traitees
.EED_Data_Matrix <- function(M_Data, Dosedata, M_Simul, expected_dose, Ndata, Nsimul){
##set index
index_SimRes <- as.integer((1:Ndata) * Nsimul / Ndata)
# recopie Dosedata dans les colonnes 9 et 10
M_Data[, 9] <- Dosedata[, 1]
M_Data[, 10] <- Dosedata[, 2]
#colonne 1 : moyenne cumulative des ED individuels
M_Data[, 1] <- cumsum(Dosedata[, 1]) / (1:Ndata)
# colonne 2 : incertitude statistique sur les valeurs de la moyenne cumulative
M_Data[, 2] <- (1 / (1:Ndata)) * sqrt(cumsum(Dosedata[, 2] ^ 2))
# colonne 3 : dose nette : dose moyenne corrigee de la moyenne des doses residuelles
M_Data[, 3] <- M_Data[, 1] - M_Simul[index_SimRes, 9]
# colonne 4 : ratio observed / simulated of uncorrected doses
M_Data[, 4] <- M_Data[, 1] / M_Simul[index_SimRes, 7]
# colonne 5 :erreur stat sur les rapports
M_Data[, 5] <- M_Data[, 2] / M_Simul[index_SimRes, 7]
# colonne 6 : dose nette corrigee des r?siduels ET de l'int?gration partielle de la
# distribution log-normale des burial doses
M_Data[, 6] <- M_Data[, 3] * (expected_dose / M_Simul[index_SimRes, 8])
# colonne 7 : erreur sur dose nette corrigee (premier calcul :
# incertitude uniquement bas?e sur erreur exp?riementale)
M_Data[, 7] <- abs((M_Data[, 6] / M_Data[, 3]) * M_Data[, 2])
# colonne 8 : ratio dose residuelle / dose nette corrigee
M_Data[M_Data[, 6] != 0, 8] <- M_Simul[index_SimRes, 9] / M_Data[, 6]
M_Data[M_Data[, 6] == 0, 8] <- 0
return(M_Data)
}
# Calcul des incertitudes statistiques liees au tirage des Ndata grains #
# calcul incertitude statistique li?e au nombre limit? de grains
#
# On se base sur un tirage de Ndata donn?es ? partir de la matrice de simlation
# on choisit les Ndata premi?res donn?es, on calcule les moyennes cumulatives de dose totale
# on prend les Ndata suivantes etc de telle sorte ? ce qu'on base le calcul d'?cart-type sur au moins 50 tirages
# Pour cela on va calculer le nb d'exp?riences simul?es possibles ? partir du rapport Nsimul/Ndata
# on teste ce rapport et s'il est inf?rieur ? une valeur limite inf?rieure, on demande de relancer le calcul
# avec davantage de simulations.
.EED_Calc_Overall_StatUncertainty <- function (M_Data, M_Simul, Ndata, Nsimul, MinNbSimExp){
M_SimExpResults <- src_EED_Calc_Overall_StatUncertainty(M_Simul, Ndata, Nsimul, MinNbSimExp)
# colonne 7 : calcule l'erreur totale sur la dose nette corrig?e M_Data[i,7]
M_Data[,7] <- abs((M_Data[,6]/M_Data[,3])*sqrt((M_SimExpResults[,2]^2)+(M_Data[,2]^2)))
return (M_Data)
}
# fonction d'initialisation de l'etat initial
# si absence de valeur, par defaut prend comme etat initial la valeur 1 (saturation)
# MaJ le 9 novembre 2018
.Initial_State_of_OSL <- function(Dosedata, D0, method) {
SaturationState <- (1 - exp(-max(Dosedata[, 1]) / D0))
if (method == "max") {
return (SaturationState)
}
# nocov start
if (!is.numeric(method) || method > 1 || method < 0) {
return(1)
}
return(max(method, SaturationState))
# nocov end
}
# fonction permettant de retourner l'indice de la valeur minimale de la dose individuelle
# prise en compte pour le calcul du plateau
# here combined to one single function returning the minium or the maxixumx
.Get_Plateau_MinDoseIndex <- function(M_Data, Ndata, MinIndivDose) {
if (is.null(MinIndivDose))
return(1)
# nocov start
current_index <- 1
while ((MinIndivDose > M_Data[current_index, 9]) &
(current_index < Ndata)) {
current_index <- current_index + 1
}
return(current_index)
# nocov end
}
# fonction permettant de retourner l'indice de la valeur maximale de la dose individuelle
# prise en compte pour le calcul du plateau
.Get_Plateau_MaxDoseIndex <- function(M_Data, Ndata, MaxIndivDose) {
if (is.null(MaxIndivDose))
return(Ndata)
# nocov start
current_index <- 1
while ((MaxIndivDose > M_Data[current_index, 9]) &
(current_index < Ndata)) {
current_index <- current_index + 1
}
return(current_index)
# nocov end
}
## allow automated kapp and sigma_distr parameter estimation
.guess_EED_parameters <- function(set_kappa, set_sigma_distr,
set_expected_dose, D0, Iinit, Nsimul, Dosedata, M_Data, M_Simul, Ndata,
set_MinDose_Index, set_MaxDose_Index, method_control_intern = method_control){
##settings to control the what needs to be controlled
method_control <- modifyList(
list(
lower = c(0.1, 0, 1),
upper = c(100, 1, 100),
iter_max = 1000,
trace = FALSE,
trace_plot = FALSE
),
method_control_intern)
##define function for the parameter estimation which will be part of
##the interpolation
fn <- function(
set_kappa, set_sigma_distr,
M_Simul, set_expected_dose,
D0, Iinit, Nsimul, Dosedata, M_Data, Ndata){
M_Simul <- .EED_Simul_Matrix (M_Simul, set_expected_dose, set_sigma_distr, D0, set_kappa, Iinit, Nsimul)
M_Data <- .EED_Data_Matrix(M_Data, Dosedata, M_Simul, set_expected_dose, Ndata, Nsimul)
M_Data <- .EED_Calc_Overall_StatUncertainty(
M_Data = M_Data,
M_Simul = M_Simul,
Ndata = Ndata,
Nsimul = Nsimul,
MinNbSimExp = MinNbSimExp
)
##return variance and the mean DE
return(
c(
VAR = .calc_Plateau_Variance_uncorr(M_Data, MinDose_Index = set_MinDose_Index,
MaxDose_Index = set_MaxDose_Index),
RESIDUAL = sum((M_Data[,6] - rep(set_expected_dose, nrow(M_Data)))^2)
))
}
par(mfrow = c(3,3))
test_var <- Inf
n_iter <- 0
while(test_var > 1e-04 && n_iter < method_control$iter_max){
##define parameter matrix
m <- matrix(NA, nrow = 16, ncol = 5)
##fill matrix if parameter is not NULL
#kappa
m[,1] <- rep(
exp(seq(log(method_control$lower[1]), log(method_control$upper[1]), length.out = 4)), 4)
##sigma_distr
m[,2] <- rep(seq(method_control$lower[2],method_control$upper[2], length.out = 4), each = 4)
##expected dose
m[,3] <- rep(expected_dose[1], 16)
##calculate the variance
for(i in 1:nrow(m)){
m[i, 4:5] <-
fn(
set_kappa = m[i, 1],
set_sigma_distr = m[i, 2],
M_Simul,
set_expected_dose = m[i,3],
D0,
Iinit,
Nsimul,
Dosedata,
M_Data,
Ndata
)
}
##surface interpolation
s <-
try(interp::interp(
x = m[, 1],
y = m[, 2],
z = m[, 4],
nx = 200,
ny = 200,
duplicate = "strip" #does not seem to work
), silent = FALSE)
if (inherits(s, "try-error")) {
.throw_error("Surface interpolation failed, you may want to try it again")
}
##graphical output
if(plot & method_control$trace_plot){
graphics::image(
s,
col = grDevices::heat.colors(30, rev = TRUE),
xlab = "kappa",
ylab = "sigma_distr"
)
graphics::contour(s, add= TRUE, nlevels = 10)
abline(h = s$y[which(s$z == min(s$z, na.rm = TRUE), arr.ind = TRUE)[,2]], lty = 2)
abline(v = s$x[which(s$z == min(s$z, na.rm = TRUE), arr.ind = TRUE)[,1]], lty = 2)
}
##our decision is the 5 % quantile
q10 <- which(s$z<= quantile(s$z, probs = 0.05, na.rm = TRUE), arr.ind = TRUE)
##calculate
optim_kappa <- c(median(s$x[unique(q10[,1])], na.rm = TRUE), sd(s$x[unique(q10[,1])]))
optim_sigm_distr <- c(median(s$y[unique(q10[,1])]), sd(s$y[unique(q10[,1])]))
##write output
if(verbose && method_control$trace){
cat("\n\n variance threshold: ", min(s$z, na.rm = TRUE))
cat("\n >> kappa: ", optim_kappa[1], "\u00b1", optim_kappa[2])
cat("\n >> sigma_distr: ", optim_sigm_distr[1] , "\u00b1", optim_sigm_distr[2])
}
##reset parameters
method_control$lower[1:2] <- c(min(s$x[unique(q10[,1])]), min(s$y[unique(q10[,2])]))
method_control$upper[1:2] <- c(max(s$x[unique(q10[,1])]), max(s$y[unique(q10[,2])]))
if(verbose && method_control$trace){
cat("\n >> lower: ", paste(method_control$lower[1:2], collapse = ", "))
cat("\n >> upper: ", paste(method_control$upper[1:2], collapse = ", "))
}
##update threshold
test_var <- min(s$z, na.rm = TRUE)
n_iter <- n_iter + 1
##implement differential break if the search area is already smaller than the area
if(diff(c(method_control$lower[1], method_control$upper[1])) < 0.1)
break()
}
return(list(
kappa = optim_kappa ,
sigma_distr = optim_sigm_distr,
min_var = test_var,
expected_dose = m[1,3]
))
}
# Input data ----------------------------------------------------------------------------------
##some parameters are rewritten the leave the code by Pierre untouched
Dosedata <- data[,1:2]
Ndata <- nrow(Dosedata)
# Nsimul est le nb de tirages de la variable al?atoire qui va g?n?rer Nsimul valeurs de dose résiduelle
# et Nsimul valeurs de dose arch?ologique (burial dose), donc Nsimul valeurs de dose equivalente
# individuelle. Pour une approche finale et précise de la dose moyenne, on peut monter ce paramétre ?
# des valeurs hautes : 100000 par exemple.
# our une premiére approche rapide d'un échantillon inconnu, il faut limiter les temps de calculs
# pour explorer l'espace kappa, sigma dans lequel on va trouver les param?tres optimaux.
# On peut proposer alors une valeur minimale par défaut de 5000 simulations
# Le mieux est de laisser votre libert? de choix et d'analyse ...
Nsimul <- n.simul
# MinNbSimExp définit le nombre de tirages minimal pour calculer l'incertitude d'echantillonnage,
# 2e membre de l'incertitude statistique globale. J'ai pense que 50 valeurs pour calculer un écart-type ?
# tait le minimum. ce paramétre ajuste le nombre de simulations en l'augmentant ? une valeur
# superieure au produit du nb de donnees et du nombre de tirages minimal au cas où Nsimul est très
# faible. Si l'on souhaite vraiment faire une étude rapide on peut diminuer MinNbSimExp.
# Pensez cependant ? conserver en commentaires cette instruction por remettre ? jour
# le code une fois l'exploration faite :
# MinNbSimExp = 50
MinNbSimExp <- n.minSimExp
if(MinNbSimExp * Ndata > Nsimul)
Nsimul <- (MinNbSimExp + 1) * Ndata
## valeur en Gy de la dose de saturation selon une loi de croissance exponentielle saturante ##
D0 <- D0 #valeur en Gy
## initialise la valeur de l'intensit? initiale (1 = saturation) ##
#si le param?tre method est "max", l'initialisation se fait selon Iinit = 1-exp(-max(Dosedata[,1])/D0)
# sinon si l'on donne une valeur comprise entre 0 et 1, la valeur introduite est prise en compte,
# sinon on affecte 1 dans tous les autres cas
# Iinit = 1 #par exemple
# ATTENTION / aucun test de coh?rence n'est fait pour savoir
# si la valeur num?rique introduite est compatible ou non avec les donn?es
Iinit <- .Initial_State_of_OSL(Dosedata, D0, "max")
# Iinit = .Initial_State_of_OSL(Dosedata, D0, method = 1)
## on définit une matrice dans laquelle on va stocker et utiliser les données de la simulation ##
M_Simul <- matrix(nrow = Nsimul, ncol = 9)
# génère une matrice à partir des donnés expérimentales #
M_Data <- matrix(nrow = Ndata, ncol = 10)
colnames(M_Data) <- c("CUM_MEAN_DE", "CUM_MEAN_DE_X", "NET_CUM_MEAN_DE_NET", "NET_CUM_MEAN_DE_X",
"RATIO_DE_SIM", "RATIO_DE_SIM_X", "INT_NET_DOSE", "INT_NET_DOSE_X",
"DE", "DE_X")
# set limits ... ##TODO M_data is still NA here ... double check, so far only NULL works
# The problem is that this call comes to early and it should be somehow integrated in the guess_EED_parameter
# function to get evaluated everytime on the other hand we just want to limit the search range, maybe this
# can be done better.
# The code in .Get_Plateau_MinDoseIndex is rather inefficient and loops over the vector, however,
# this is not out main problem. In fact we have to first understand what this function is really
# doing and whether we can achive this better and easier. So far it gets called a lot of times
Min_plateau <- .Get_Plateau_MinDoseIndex(M_Data, Ndata, MinIndivDose = NULL)
Max_plateau <- .Get_Plateau_MaxDoseIndex(M_Data, Ndata, MaxIndivDose = NULL)
if (Max_plateau <= Min_plateau) {
Min_plateau <- 1
} #priorité max dose
# Guess parameters if needed ------------------------------------------------------------------
if(verbose) cat("\n[calc_EED_Model()]\n")
## introduire le facteur d'eclairement kappa : kappa = 2 : très faible éclairement, kappa >100 bon
## blanchiment ##
## TODO - this is not really what Pierre had in mind, he wanted to have the variance, not an automated
## esstimation
if(is.null(kappa) || is.null(sigma_distr)){
if(verbose)
cat("\n>> Running automated parameter estimation... \n")
temp_guess <- .guess_EED_parameters(
set_kappa = kappa,
set_sigma_distr = sigma_distr,
set_expected_dose = expected_dose,
D0 = D0,
Iinit = Iinit,
Nsimul = Nsimul,
Dosedata = Dosedata,
M_Data = M_Data,
M_Simul = M_Simul,
Ndata = Ndata,
set_MinDose_Index = Min_plateau,
set_MaxDose_Index = Max_plateau
)
kappa <- temp_guess[[1]][1]
sigma_distr <- temp_guess[[2]][1]
min_var <- temp_guess[[3]]
expected_dose <- temp_guess[[4]]
if(verbose){
cat(">> min. variance:", min_var)
cat("\n>> kappa: ", kappa, " | sigma: ",sigma_distr)
}
}
# Calculation ---------------------------------------------------------------------------------
M_Simul <- .EED_Simul_Matrix (M_Simul, expected_dose, sigma_distr,D0, kappa, Iinit, Nsimul)
M_Data <- .EED_Data_Matrix(M_Data, Dosedata, M_Simul, expected_dose, Ndata, Nsimul)
M_Data <- .EED_Calc_Overall_StatUncertainty(M_Data = M_Data, M_Simul = M_Simul, Ndata = Ndata, Nsimul = Nsimul, MinNbSimExp)
max_dose_simul <- max(M_Simul[,3])
index_min_uncert <- sort.list(index_min_uncert <-
rank(M_Data[, 7], ties.method = "first"))
# Terminal output -----------------------------------------------------------------------------
if(verbose){
cat("\n------------------------------------ \n")
cat("\n Maximal Individual Equivalent Dose integrated: ", round(M_Data[index_min_uncert[1],9],2), "Gy")
cat("\n Averaged Corrected Equivalent Dose: ",
round(M_Data[index_min_uncert[1],6],2), "\u00b1", round(M_Data[index_min_uncert[1],7],2), "Gy")
}
#### THE ONE SHOT : calcule les valeurs de dose moyenne
##TODO discuss with Pierre
# "recherche du minimum d'incertitude statistique"
# #min(M_Data[,7])
# index_min_uncert <- rank(M_Data[,7], ties.method = "first")
# index_min_uncert<-sort.list(index_min_uncert)
# "Minimal error for maximal equivalent Dose (Gy) equal to: "
# M_Data[index_min_uncert[1],9]
# "cumulative mean corrected equivalent dose (Gy)"
# M_Data[index_min_uncert[1],6]
#
#
# #liste_type = c(9, 10, 6, 7)
# #M_Data[,liste_type[1:4]]
# Plotting ------------------------------------------------------------------------------------
if(plot) {
##plot settings
plot_settings <- modifyList(
x = list(
xlab = "Individual dose [Gy]",
xlim = c(0,max(M_Simul[,2:3]))),
val = list(...))
##set box width
box_width <- 1.5
##set output par
par(mfrow = c(1,2))
## Histograms with the data
##(1) first histogram showing the natural distribution
hist(
x = rep(Dosedata[,1], length.out = length(M_Simul[,3])),
freq = FALSE,
breaks = seq(0, box_width * (1 + as.integer(max(M_Simul[,3])/box_width)), box_width),
xlim = plot_settings$xlim,
border = rgb(0.7,0.1,0,.5),
col = rgb(240,154,149,alpha = 255, maxColorValue = 255),
main = paste0("Distribution De: ", sample_name),
xlab = plot_settings$xlab
)
##(2) overplotting the first histogram with simulated data
hist(
x = M_Simul[,3],
breaks = seq(0, box_width*(1 + as.integer(max(M_Simul[,3])/box_width)), box_width),
freq = FALSE,
border = rgb(0,0.1,0.8,.5),
col = rgb(122,206,209,alpha = 140, maxColorValue = 255),
add = TRUE,
xlab = plot_settings$xlab
)
##add legend
legend(
"topright",
bty = "n",
legend = c("Data", "Simulation"),
col = c(rgb(240,154,149,alpha = 255, maxColorValue = 255),rgb(122,206,209,alpha = 140, maxColorValue = 255)),
pch = 15)
##add mtext
mtext(side = 3, text = paste0("n_sim = ", length(M_Simul[,3])))
## Histograms with the error for the data
##(3) first histogram showing the natural distribution
hist(
x = rep(Dosedata[,2], length.out = length(M_Simul[,2])),
freq = FALSE,
breaks = seq(0, box_width*(1 + as.integer(max(M_Simul[,2])/box_width)), box_width),
xlim = plot_settings$xlim,
border = rgb(0.7,0.1,0,.5),
col = rgb(240,154,149,alpha = 255, maxColorValue = 255),
main = paste0("Distribution SE(De):", sample_name),
xlab = plot_settings$xlab
)
##(4) overplotting the first histogram with simulated data
hist(
x = M_Simul[,2],
breaks = seq(0, box_width*(1 + as.integer(max(M_Simul[,2])/box_width)), box_width),
freq = FALSE,
border = rgb(0,0.1,0.8,.5),
col = rgb(122,206,209,alpha = 140, maxColorValue = 255),
add = TRUE,
xlab = plot_settings$xlab
)
##add legend
legend(
"topright",
bty = "n",
legend = c("Data", "Simulation"),
col = c(rgb(240,154,149,alpha = 255, maxColorValue = 255),rgb(122,206,209,alpha = 140, maxColorValue = 255)),
pch = 15)
##add mtext
mtext(side = 3, text = paste0("n_sim = ", length(M_Simul[,2])))
par(mfrow = c(1,3))
liste_type <- c(4,8)
##1st plateau plot
graphics::matplot(
Dosedata[,1],
M_Data[,liste_type],
type = "p",
pch = 1,
log = "x",
main = "Observed/simulated \n Residual Dose Fraction Ratio",
xlab = plot_settings$xlab,
ylab = "Ratios",
xlim = c(min(Dosedata[,1]), plot_settings$xlim[2]),
ylim = c(0, 1.5))
abline(h = 1)
for (i in 1:Ndata) {
lines(
x = c(Dosedata[i, 1], Dosedata[i, 1]),
y = c((M_Data[i, 4] - M_Data[i, 5]), (M_Data[i, 4] + M_Data[i, 5])))
}
##2nd plateau plot
graphics::matplot(
x = Dosedata[, 1],
y = M_Data[, c(1, 6, 3)],
type = "p",
pch = 1,
log = "x",
main = paste("sample ", sample_name, sep = ""),
xlab = plot_settings$xlab,
ylab = "Cumulative mean doses [Gy]",
xlim = c(min(Dosedata[, 1]), plot_settings$xlim[2]),
ylim = c(0, 2 * expected_dose)
)
# tracer les valeurs de la liste classee des doses archeologiques de la matrice de simulation
# contrainte : ne tracer qu'une partie des points sinon on va passer un temps fou
# par exemple on veut tracer un nb de points egal a :
NbSimPtsDisplayed <- min(Nsimul, 1000)
XY_psimul <- matrix(nrow = NbSimPtsDisplayed, ncol = 2)
delta_index <- as.integer(Nsimul / NbSimPtsDisplayed)
plot_index <- 1
cur_ind <- 1
while(plot_index < Nsimul ){
XY_psimul[cur_ind, 1] <- M_Simul[plot_index, 4]
XY_psimul[cur_ind, 2] <- M_Simul[plot_index, 8]
plot_index <- plot_index + delta_index
cur_ind <- cur_ind + 1
}
abline(h = expected_dose)
points(XY_psimul[, 1], XY_psimul[, 2], pch = 1, col = rgb(0,0,0,0.2))
##add error bars
##error bars for corrected De
segments(
x0 = Dosedata[, 1],
x1 = Dosedata[, 1],
y0 = M_Data[, 6] - M_Data[, 7],
y1 = M_Data[, 6] + M_Data[, 7],
col = "red"
)
##error bars cum mean De
segments(
x0 = Dosedata[, 1],
x1 = Dosedata[, 1],
y0 = M_Data[, 3] - M_Data[, 2],
y1 = M_Data[, 3] + M_Data[, 2],
col = "green"
)
##add legend
legend(
"topright",
legend = c(
"Cum Mean (uncorr.) De",
"Cum Mean (corr.) De_sim",
"Corr. De (resid., partial integ.)",
"Cum mean (corr.) De"
),
bty = "n",
pch = 20,
col = c("black", "grey", "red", "green"))
##add standard deviation plot
plot(
Dosedata[, 1],
M_Data[, 7],
main = "Std Dev on average corrected doses \n ",
xlab = plot_settings$xlab,
ylab = "Standard deviation [Gy]",
xlim = c(min(Dosedata[,1]), plot_settings$xlim[2]),
type = "p",
pch = 1,
log = "x"
)
}#end if plot
# Output --------------------------------------------------------------------------------------
set_RLum(
class = "RLum.Results",
data = list(
M_Data = M_Data ##TODO: we should name the columns
),
info = list(
call = sys.call()
))
}
Luminescence/R/plot_RLum.Data.Image.R 0000644 0001762 0000144 00000020101 14762554470 017026 0 ustar ligges users #' @title Plot function for an `RLum.Data.Image` S4 class object
#'
#' @description The function provides very basic plot functionality for image data of an
#' [RLum.Data.Image-class] object. For more sophisticated plotting it is recommended
#' to use other very powerful packages for image processing.
#'
#'
#' **Details on the plot functions**
#'
#' Supported plot types:
#'
#' **`plot.type = "plot.raster"`**
#'
#' Uses the standard plot function of R [graphics::image]. If wanted, the image
#' is enhanced, using the argument `stretch`. Possible values are `hist`, `lin`, and
#' `NULL`. The latter does nothing. The argument `useRaster = TRUE` is used by default, but
#' can be set to `FALSE`.
#'
#' **`plot.type = "contour"`**
#'
#' This uses the function [graphics::contour]
#'
#' @param object [RLum.Data.Image-class] (**required**): S4
#' object of class `RLum.Data.Image`
#'
#' @param par.local [logical] (*with default*): use local graphical
#' parameters for plotting, e.g. the plot is shown in one column and one row.
#' If `par.local = FALSE` global parameters are inherited.
#'
#' @param frames [numeric] (*optional*): sets the frames to be set, by default all
#' frames are plotted. Can be sequence of numbers, as long as the frame number is valid.
#'
#' @param plot.type [character] (*with default*): plot types.
#' Supported types are `plot.raster`, `contour`
#'
#' @param ... further arguments and graphical parameters that will be passed
#' to the specific plot functions. Standard supported parameters are `xlim`, `ylim`, `zlim`,
#' `xlab`, `ylab`, `main`, `legend` (`TRUE` or `FALSE`), `col`, `cex`, `axes` (`TRUE` or `FALSE`),
#' `zlim_image` (adjust the z-scale over different images), `stretch`
#'
#' @return Returns a plot
#'
#' @note The axes limitations (`xlim`, `zlim`, `zlim`) work directly on the object,
#' so that regardless of the chosen limits the image parameters can be adjusted for
#' best visibility. However, in particular for z-scale limitations this is not always
#' wanted, please use `zlim_image` to maintain a particular value range over a
#' series of images.
#'
#' @section Function version: 0.2.1
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum.Data.Image-class], [plot], [plot_RLum], [graphics::image], [graphics::contour]
#'
#' @keywords aplot
#'
#' @examples
#'
#' ##load data
#' data(ExampleData.RLum.Data.Image, envir = environment())
#'
#' ##plot data
#' plot_RLum.Data.Image(ExampleData.RLum.Data.Image)
#'
#' @md
#' @export
plot_RLum.Data.Image <- function(
object,
frames = NULL,
par.local = TRUE,
plot.type = "plot.raster",
...
) {
.set_function_name("plot_RLum.Data.Image")
on.exit(.unset_function_name(), add = TRUE)
## Integrity checks -------------------------------------------------------
.validate_class(object, "RLum.Data.Image")
## extract object
object <- object@data
if (length(dim(object)) != 3) {
## the object is empty or malformed
return(NULL)
}
# Define additional functions ---------------------------------------------
.stretch <- function(x, type = "lin"){
if(is.null(type[1])) return(x[,,1])
if(type[1] == "lin") {
x <- x[,,1]
r <- range(x)
q <- stats::quantile(x, c(0.05, 0.95), na.rm = TRUE)
## consider special case for q == 0
if(sum(q) > 0) {
x <- (r[2] * (x - q[1])) / (q[2] - q[1])
x[x < 0] <- r[1]
x[x > r[2]] <- r[2]
}
}
if(type[1] == "hist")
x <- matrix(stats::ecdf(x)(x) * 255, ncol = ncol(x))
return(x)
}
plot.type <- .validate_args(plot.type, c("plot.raster", "contour"))
# Plot settings -----------------------------------------------------------
plot_settings <- modifyList(x = list(
main = "RLum.Data.Image",
axes = TRUE,
xlab = "Length [px]",
ylab = "Height [px]",
xlim = c(1,dim(object)[1]),
ylim = c(1,dim(object)[2]),
zlim = range(object),
zlim_image = NULL,
legend = TRUE,
useRaster = TRUE,
stretch = "hist",
col = c(grDevices::hcl.colors(50, palette = "Inferno")),
cex = 1
), val = list(...), keep.null = TRUE)
## set frames
if(!is.null(frames)) {
frames[1] <- max(1,min(frames))
frames[length(frames)] <- min(dim(object)[3],max(frames))
object <- object[,,frames,drop = FALSE]
}
## enforce xlim, ylim and zlim directly here
## xlim, ylim
object[] <- object[
max(plot_settings$xlim[1], 1):min(plot_settings$xlim[2], dim(object)[1]),
max(plot_settings$ylim[1], 1):min(plot_settings$ylim[2], dim(object)[2]),,
drop = FALSE]
## zlim
object[object <= plot_settings$zlim[1]] <- max(0,plot_settings$zlim[1])
object[object >= plot_settings$zlim[2]] <- min(max(object),plot_settings$zlim[2])
##par setting for possible combination with plot method for RLum.Analysis objects
if(par.local) par(mfrow=c(1,1), cex = plot_settings$cex)
if (plot.type == "plot.raster") {
# plot.raster -------------------------------------------------------------
for(i in 1:dim(object)[3]) {
par.default <- par(mar = c(4.5,4.5,4,3))
on.exit(par(par.default), add = TRUE)
x <- object[, , i, drop = FALSE]
image <-.stretch(x, type = plot_settings$stretch)
graphics::image(
x = image,
useRaster = plot_settings$useRaster,
axes = FALSE,
zlim = if(is.null(plot_settings$zlim_image)) range(image) else plot_settings$zlim_image,
xlab = plot_settings$xlab,
ylab = plot_settings$ylab,
main = paste0(plot_settings$main, " #",i),
col = plot_settings$col)
graphics::box()
## axes
if(plot_settings$axes) {
xlab <- pretty(1:dim(x)[1])
xlab[c(1,length(xlab))] <- c(0,dim(x)[1])
xat <- seq(0,1,length.out = length(xlab))
graphics::axis(side = 1, at = xat, labels = xlab)
ylab <- pretty(1:dim(x)[2])
ylab[c(1,length(ylab))] <- c(0,dim(x)[2])
yat <- seq(0,1,length.out = length(ylab))
graphics::axis(side = 2, at = yat, labels = ylab)
}
## add legend
if(plot_settings$legend) {
par.default <- c(par.default, par(xpd = TRUE))
on.exit(par(par.default), add = TRUE)
col_grad <- plot_settings$col[seq(1, length(plot_settings$col), length.out = 14)]
slices <- seq(0,1,length.out = 15)
for(s in 1:(length(slices) - 1)){
graphics::rect(
xleft = par()$usr[4] * 1.01,
xright = par()$usr[4] * 1.03,
ybottom = slices[s],
ytop = slices[s + 1],
col = col_grad[s],
border = TRUE)
}
text(
x = par()$usr[4] * 1.04,
y = par()$usr[2],
labels = if(is.null(plot_settings$zlim_image)) {
format(max(x), digits = 1, scientific = TRUE)
} else {
format(plot_settings$zlim_image[2], digits = 1, scientific = TRUE)
},
cex = 0.7,
srt = 270,
pos = 3)
text(
x = par()$usr[4] * 1.04,
y = par()$usr[3],
labels = if(is.null(plot_settings$zlim_image)) {
format(min(x), digits = 1, scientific = TRUE)
} else {
format(plot_settings$zlim_image[1], digits = 1, scientific = TRUE)
},
cex = 0.7,
pos = 3,
srt = 270)
}
}
}else if(plot.type == "contour"){
for(i in 1:dim(object)[3]) {
x <- object[, , i, drop = FALSE]
graphics::contour(
x = x[,,1],
axes = FALSE,
zlim = if(is.null(plot_settings$zlim_image)) range(x) else plot_settings$zlim_image,
xlab = plot_settings$xlab,
ylab = plot_settings$ylab,
main = paste0(plot_settings$main, " #",i),
col = plot_settings$col)
graphics::box()
}
## axes
if(plot_settings$axes) {
xlab <- pretty(1:dim(x)[1])
xlab[c(1,length(xlab))] <- c(0,dim(x)[1])
xat <- seq(0,1,length.out = length(xlab))
graphics::axis(side = 1, at = xat, labels = xlab)
ylab <- pretty(1:dim(x)[2])
ylab[c(1,length(ylab))] <- c(0,dim(x)[1])
yat <- seq(0,1,length.out = length(ylab))
graphics::axis(side = 2, at = yat, labels = ylab)
}
}
}
Luminescence/R/plot_Histogram.R 0000644 0001762 0000144 00000066446 14762554470 016241 0 ustar ligges users #' Plot a histogram with separate error plot
#'
#' Function plots a predefined histogram with an accompanying error plot as
#' suggested by Rex Galbraith at the UK LED in Oxford 2010.
#'
#' If the normal curve is added, the y-axis in the histogram will show the
#' probability density.
#'
#'
#' A statistic summary, i.e. a collection of statistic measures of
#' centrality and dispersion (and further measures) can be added by specifying
#' one or more of the following keywords:
#' - `"n"` (number of samples),
#' - `"mean"` (mean De value),
#' - `"mean.weighted"` (error-weighted mean),
#' - `"median"` (median of the De values),
#' - `"sdrel"` (relative standard deviation in percent),
#' - `"sdrel.weighted"` (error-weighted relative standard deviation in percent),
#' - `"sdabs"` (absolute standard deviation),
#' - `"sdabs.weighted"` (error-weighted absolute standard deviation),
#' - `"serel"` (relative standard error),
#' - `"serel.weighted"` (error-weighted relative standard error),
#' - `"seabs"` (absolute standard error),
#' - `"seabs.weighted"` (error-weighted absolute standard error),
#' - `"kurtosis"` (kurtosis) and
#' - `"skewness"` (skewness).
#'
#' @param data [data.frame] or [RLum.Results-class] object (**required**):
#' for `data.frame`: two columns: De (`data[,1]`) and De error (`data[,2]`)
#'
#' @param na.rm [logical] (*with default*):
#' excludes `NA` values from the data set prior to any further operations.
#'
#' @param mtext [character] (*optional*):
#' further sample information ([mtext]).
#'
#' @param cex.global [numeric] (*with default*):
#' global scaling factor.
#'
#' @param se [logical] (*optional*):
#' plots standard error points over the histogram, default is `FALSE`.
#'
#' @param rug [logical] (*optional*):
#' adds rugs to the histogram, default is `TRUE`.
#'
#' @param normal_curve [logical] (*with default*):
#' adds a normal curve to the histogram. Mean and standard deviation are calculated from the
#' input data. More see details section.
#'
#' @param summary [character] (*optional*):
#' add statistic measures of centrality and dispersion to the plot.
#' Can be one or more of several keywords. See details for available keywords.
#'
#' @param summary.pos [numeric] or [character] (*with default*):
#' optional position coordinates or keyword (e.g. `"topright"`)
#' for the statistical summary. Alternatively, the keyword `"sub"` may be
#' specified to place the summary below the plot header. However, this latter
#' option in only possible if `mtext` is not used. In case of coordinate
#' specification, y-coordinate refers to the right y-axis.
#'
#' @param colour [numeric] or [character] (*with default*):
#' optional vector of length 4 which specifies the colours of the following
#' plot items in exactly this order: histogram bars, rug lines, normal
#' distribution curve and standard error points
#' (e.g., `c("grey", "black", "red", "grey")`).
#'
#' @param interactive [logical] (*with default*):
#' create an interactive histogram plot (requires the 'plotly' package)
#'
#' @param ... further arguments and graphical parameters passed to [plot] or
#' [hist]. If y-axis labels are provided, these must be specified as a vector
#' of length 2 since the plot features two axes
#' (e.g. `ylab = c("axis label 1", "axis label 2")`). Y-axes limits
#' (`ylim`) must be provided as vector of length four, with the first two
#' elements specifying the left axes limits and the latter two elements giving
#' the right axis limits.
#'
#' @note The input data is not restricted to a special type.
#'
#' @section Function version: 0.4.5
#'
#' @author
#' Michael Dietze, GFZ Potsdam (Germany)\cr
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [hist], [plot]
#'
#' @examples
#'
#' ## load data
#' data(ExampleData.DeValues, envir = environment())
#' ExampleData.DeValues <- convert_Second2Gray(ExampleData.DeValues$BT998,
#' dose.rate = c(0.0438,0.0019))
#'
#' ## plot histogram the easiest way
#' plot_Histogram(ExampleData.DeValues)
#'
#' ## plot histogram with some more modifications
#' plot_Histogram(ExampleData.DeValues,
#' rug = TRUE,
#' normal_curve = TRUE,
#' cex.global = 0.9,
#' pch = 2,
#' colour = c("grey", "black", "blue", "green"),
#' summary = c("n", "mean", "sdrel"),
#' summary.pos = "topleft",
#' main = "Histogram of De-values",
#' mtext = "Example data set",
#' ylab = c(expression(paste(D[e], " distribution")),
#' "Standard error"),
#' xlim = c(100, 250),
#' ylim = c(0, 0.1, 5, 20))
#'
#'
#' @md
#' @export
plot_Histogram <- function(
data,
na.rm = TRUE,
mtext,
cex.global,
se,
rug,
normal_curve,
summary,
summary.pos,
colour,
interactive = FALSE,
...
) {
.set_function_name("plot_Histogram")
on.exit(.unset_function_name(), add = TRUE)
## Integrity tests --------------------------------------------------------
.validate_class(data, c("data.frame", "RLum.Results"))
if (inherits(data, "RLum.Results")) {
data <- get_RLum(data)[,1:2]
}
## check that we actually have data
if (length(data) == 0 || nrow(data) == 0) {
.throw_error("'data' contains no data")
}
## handle error-free data sets
if(length(data) < 2) {
data <- cbind(data, rep(NA, length(data)))
}
## Set general parameters ---------------------------------------------------
## Check/set default parameters
if(missing(cex.global) == TRUE) {
cex.global <- 1
}
if(missing(mtext) == TRUE) {
mtext <- ""
}
if(missing(se) == TRUE) {
se = TRUE
}
if(missing(rug) == TRUE) {
rug = TRUE
}
if(missing(colour) == TRUE) {
colour = c("white", "black", "red", "black")
}
if(missing(summary) == TRUE) {
summary <- ""
}
if(missing(summary.pos) == TRUE) {
summary.pos <- "sub"
}
if(missing(normal_curve) == TRUE) {
normal_curve = FALSE
}
## read out additional arguments list
extraArgs <- list(...)
## define fun
if("fun" %in% names(extraArgs)) {
fun <- extraArgs$fun # nocov
} else {
fun <- FALSE
}
## optionally, count and exclude NA values and print result
if(na.rm == TRUE) {
n.NA <- sum(is.na(data[,1]))
if(n.NA == 1) {
print("1 NA value excluded.")
} else if(n.NA > 1) {
print(paste(n.NA, "NA values excluded."))
}
data <- data[!is.na(data[,1]),]
}
if("main" %in% names(extraArgs)) {
main.plot <- extraArgs$main
} else {
main.plot <- "Histogram"
}
if("xlab" %in% names(extraArgs)) {
xlab.plot <- extraArgs$xlab
} else {
xlab.plot <- expression(paste(D[e], " [Gy]"))
}
if("ylab" %in% names(extraArgs)) {
ylab.plot <- extraArgs$ylab
} else {
ylab.plot <- c("Frequency",
"Standard error")
}
if("breaks" %in% names(extraArgs)) {
breaks.plot <- extraArgs$breaks
breaks_calc <- hist(x = data[,1],
breaks = breaks.plot,
plot = FALSE)$breaks
} else {
breaks.plot <- hist(x = data[,1],
plot = FALSE)$breaks
breaks_calc <- breaks.plot
}
if("xlim" %in% names(extraArgs)) {
xlim.plot <- extraArgs$xlim
} else {
xlim.plot <- range(breaks_calc)
}
if("ylim" %in% names(extraArgs)) {
ylim.plot <- extraArgs$ylim
.validate_length(ylim.plot, 4, name = "'ylim'")
} else {
H.lim <- hist(data[,1],
breaks = breaks.plot,
plot = FALSE)
if(normal_curve == TRUE) {
left.ylim <- c(0, max(H.lim$density))
} else {
left.ylim <- c(0, max(H.lim$counts))
}
range.error <- try(expr = range(data[,2], na.rm = TRUE),
silent = TRUE)
range.error[1] <- ifelse(is.infinite(range.error[1]), 0, range.error[1])
range.error[2] <- ifelse(is.infinite(range.error[2]), 0, range.error[2])
ylim.plot <- c(left.ylim, range.error)
}
if("pch" %in% names(extraArgs)) {
pch.plot <- extraArgs$pch
} else {
pch.plot <- 1
}
## Set plot area format
par(mar = c(4.5, 4.5, 4.5, 4.5),
cex = cex.global)
## Plot histogram -----------------------------------------------------------
HIST <- hist(data[,1],
main = "",
xlab = xlab.plot,
ylab = ylab.plot[1],
xlim = xlim.plot,
ylim = ylim.plot[1:2],
breaks = breaks.plot,
freq = !normal_curve,
col = colour[1]
)
## add title
title(line = 2,
main = main.plot)
## Optionally, add rug ------------------------------------------------------
if (rug) graphics::rug(data[, 1], col = colour[2])
## Optionally, add a normal curve based on the data -------------------------
if(normal_curve == TRUE){
## cheat the R check routine, tztztz how neat
x <- NULL
rm(x)
## add normal distribution curve
curve(dnorm(x,
mean = mean(na.exclude(data[,1])),
sd = sd(na.exclude(data[,1]))),
col = colour[3],
add = TRUE,
lwd = 1.2 * cex.global)
}
## calculate and paste statistical summary
data.stats <- list(data = data)
## calculate and paste statistical summary
De.stats <- matrix(nrow = length(data), ncol = 18)
colnames(De.stats) <- c("n",
"mean",
"mean.weighted",
"median",
"median.weighted",
"kde.max",
"sd.abs",
"sd.rel",
"se.abs",
"se.rel",
"q25",
"q75",
"skewness",
"kurtosis",
"sd.abs.weighted",
"sd.rel.weighted",
"se.abs.weighted",
"se.rel.weighted")
for(i in 1:length(data)) {
statistics <- calc_Statistics(data)
De.stats[i,1] <- statistics$weighted$n
De.stats[i,2] <- statistics$unweighted$mean
De.stats[i,3] <- statistics$weighted$mean
De.stats[i,4] <- statistics$unweighted$median
De.stats[i,5] <- statistics$unweighted$median
De.stats[i,7] <- statistics$unweighted$sd.abs
De.stats[i,8] <- statistics$unweighted$sd.rel
De.stats[i,9] <- statistics$unweighted$se.abs
De.stats[i,10] <- statistics$weighted$se.rel
De.stats[i,11] <- quantile(data[,1], 0.25)
De.stats[i,12] <- quantile(data[,1], 0.75)
De.stats[i,13] <- statistics$unweighted$skewness
De.stats[i,14] <- statistics$unweighted$kurtosis
De.stats[i,15] <- statistics$weighted$sd.abs
De.stats[i,16] <- statistics$weighted$sd.rel
De.stats[i,17] <- statistics$weighted$se.abs
De.stats[i,18] <- statistics$weighted$se.rel
##kdemax - here a little doubled as it appears below again
De.denisty <- NA
De.stats[i,6] <- NA
if(nrow(data) >= 2){
De.density <-density(x = data[,1],
kernel = "gaussian",
from = xlim.plot[1],
to = xlim.plot[2])
De.stats[i,6] <- De.density$x[which.max(De.density$y)]
}
}
label.text = list(NA)
if(summary.pos[1] != "sub") {
n.rows <- length(summary)
for(i in 1:length(data)) {
stops <- paste(rep("\n", (i - 1) * n.rows), collapse = "")
summary.text <- character(0)
for(j in 1:length(summary)) {
summary.text <- c(summary.text,
paste(
"",
ifelse("n" %in% summary[j] == TRUE,
paste("n = ",
De.stats[i,1],
"\n",
sep = ""),
""),
ifelse("mean" %in% summary[j] == TRUE,
paste("mean = ",
round(De.stats[i,2], 2),
"\n",
sep = ""),
""),
ifelse("mean.weighted" %in% summary[j] == TRUE,
paste("weighted mean = ",
round(De.stats[i,3], 2),
"\n",
sep = ""),
""),
ifelse("median" %in% summary[j] == TRUE,
paste("median = ",
round(De.stats[i,4], 2),
"\n",
sep = ""),
""),
ifelse("median.weighted" %in% summary[j] == TRUE,
paste("weighted median = ",
round(De.stats[i,5], 2),
"\n",
sep = ""),
""),
ifelse("kdemax" %in% summary[j] == TRUE,
paste("kdemax = ",
round(De.stats[i,6], 2),
" \n ",
sep = ""),
""),
ifelse("sdabs" %in% summary[j] == TRUE,
paste("sd = ",
round(De.stats[i,7], 2),
"\n",
sep = ""),
""),
ifelse("sdrel" %in% summary[j] == TRUE,
paste("rel. sd = ",
round(De.stats[i,8], 2), " %",
"\n",
sep = ""),
""),
ifelse("seabs" %in% summary[j] == TRUE,
paste("se = ",
round(De.stats[i,9], 2),
"\n",
sep = ""),
""),
ifelse("serel" %in% summary[j] == TRUE,
paste("rel. se = ",
round(De.stats[i,10], 2), " %",
"\n",
sep = ""),
""),
ifelse("skewness" %in% summary[j] == TRUE,
paste("skewness = ",
round(De.stats[i,13], 2),
"\n",
sep = ""),
""),
ifelse("kurtosis" %in% summary[j] == TRUE,
paste("kurtosis = ",
round(De.stats[i,14], 2),
"\n",
sep = ""),
""),
ifelse("sdabs.weighted" %in% summary[j] == TRUE,
paste("abs. weighted sd = ",
round(De.stats[i,15], 2),
"\n",
sep = ""),
""),
ifelse("sdrel.weighted" %in% summary[j] == TRUE,
paste("rel. weighted sd = ",
round(De.stats[i,16], 2),
"\n",
sep = ""),
""),
ifelse("seabs.weighted" %in% summary[j] == TRUE,
paste("abs. weighted se = ",
round(De.stats[i,17], 2),
"\n",
sep = ""),
""),
ifelse("serel.weighted" %in% summary[j] == TRUE,
paste("rel. weighted se = ",
round(De.stats[i,18], 2),
"\n",
sep = ""),
""),
sep = ""))
}
summary.text <- paste(summary.text, collapse = "")
label.text[[length(label.text) + 1]] <- paste(stops,
summary.text,
stops,
sep = "")
}
} else {
for(i in 1:length(data)) {
summary.text <- character(0)
for(j in 1:length(summary)) {
summary.text <- c(summary.text,
ifelse("n" %in% summary[j] == TRUE,
paste("n = ",
De.stats[i,1],
" | ",
sep = ""),
""),
ifelse("mean" %in% summary[j] == TRUE,
paste("mean = ",
round(De.stats[i,2], 2),
" | ",
sep = ""),
""),
ifelse("mean.weighted" %in% summary[j] == TRUE,
paste("weighted mean = ",
round(De.stats[i,3], 2),
" | ",
sep = ""),
""),
ifelse("median" %in% summary[j] == TRUE,
paste("median = ",
round(De.stats[i,4], 2),
" | ",
sep = ""),
""),
ifelse("median.weighted" %in% summary[j] == TRUE,
paste("weighted median = ",
round(De.stats[i,5], 2),
" | ",
sep = ""),
""),
ifelse("kdemax" %in% summary[j] == TRUE,
paste("kdemax = ",
round(De.stats[i,6], 2),
" | ",
sep = ""),
""),
ifelse("sdrel" %in% summary[j] == TRUE,
paste("rel. sd = ",
round(De.stats[i,8], 2), " %",
" | ",
sep = ""),
""),
ifelse("sdabs" %in% summary[j] == TRUE,
paste("abs. sd = ",
round(De.stats[i,7], 2),
" | ",
sep = ""),
""),
ifelse("serel" %in% summary[j] == TRUE,
paste("rel. se = ",
round(De.stats[i,10], 2), " %",
" | ",
sep = ""),
""),
ifelse("seabs" %in% summary[j] == TRUE,
paste("abs. se = ",
round(De.stats[i,9], 2),
" | ",
sep = ""),
""),
ifelse("skewness" %in% summary[j] == TRUE,
paste("skewness = ",
round(De.stats[i,13], 2),
" | ",
sep = ""),
""),
ifelse("kurtosis" %in% summary[j] == TRUE,
paste("kurtosis = ",
round(De.stats[i,14], 2),
" | ",
sep = ""),
""),
ifelse("sdabs.weighted" %in% summary[j] == TRUE,
paste("abs. weighted sd = ",
round(De.stats[i,15], 2), " %",
" | ",
sep = ""),
""),
ifelse("sdrel.weighted" %in% summary[j] == TRUE,
paste("rel. weighted sd = ",
round(De.stats[i,16], 2), " %",
" | ",
sep = ""),
""),
ifelse("seabs.weighted" %in% summary[j] == TRUE,
paste("abs. weighted se = ",
round(De.stats[i,17], 2), " %",
" | ",
sep = ""),
""),
ifelse("serel.weighted" %in% summary[j] == TRUE,
paste("rel. weighted se = ",
round(De.stats[i,18], 2), " %",
" | ",
sep = ""),
"")
)
}
summary.text <- paste(summary.text, collapse = "")
label.text[[length(label.text) + 1]] <- paste(
" ",
summary.text,
sep = "")
}
## remove outer vertical lines from string
for(i in 2:length(label.text)) {
label.text[[i]] <- substr(x = label.text[[i]],
start = 3,
stop = nchar(label.text[[i]]) - 3)
}
}
## remove dummy list element
label.text[[1]] <- NULL
## convert keywords into summary placement coordinates
coords <- .get_keyword_coordinates(summary.pos, xlim.plot, ylim.plot)
summary.pos <- coords$pos
summary.adj <- coords$adj
## add summary content
for(i in 1:length(data.stats)) {
if(summary.pos[1] != "sub") {
text(x = summary.pos[1],
y = summary.pos[2],
adj = summary.adj,
labels = label.text[[i]],
col = colour[2],
cex = cex.global * 0.8)
} else {
if(mtext == "") {
mtext(side = 3,
line = 1 - i,
text = label.text[[i]],
col = colour[2],
cex = cex.global * 0.8)
}
}
}
## Optionally, add standard error plot --------------------------------------
if(sum(is.na(data[,2])) == length(data[,2])) {
se <- FALSE
}
if(se == TRUE) {
par(new = TRUE)
plot.data <- data[!is.na(data[,2]),]
plot(x = plot.data[,1],
y = plot.data[,2],
xlim = xlim.plot,
ylim = ylim.plot[3:4],
pch = pch.plot,
col = colour[4],
main = "",
xlab = "",
ylab = "",
axes = FALSE,
frame.plot = FALSE
)
axis(side = 4,
labels = TRUE,
cex = cex.global
)
mtext(ylab.plot[2],
side = 4,
line = 3,
cex = cex.global)
# par(new = FALSE)
}
## Optionally add user-defined mtext
mtext(side = 3,
line = 0.5,
text = mtext,
cex = 0.8 * cex.global)
## FUN by R Luminescence Team
if (fun && !interactive) sTeve() # nocov
## Optionally: Interactive Plot ----------------------------------------------
if (interactive) {
.require_suggested_package("plotly", "The interactive histogram")
## tidy data ----
data <- as.data.frame(data)
colnames(data) <- c("x", "y")
x <- y <- NULL # suffice CRAN check for no visible binding
if (length(grep("paste", as.character(xlab.plot))) > 0)
xlab.plot <- "Equivalent dose [Gy]"
## create plots ----
# histogram
hist <- plotly::plot_ly(data = data, x = ~x,
type = "histogram",
showlegend = FALSE,
name = "Bin", opacity = 0.75,
marker = list(color = "#428BCA",
line = list(width = 1.0,
color = "white")),
histnorm = ifelse(normal_curve, "probability density", ""),
yaxis = "y"
)
# normal curve ----
if (normal_curve) {
density.curve <- density(data$x)
normal.curve <- data.frame(x = density.curve$x, y = density.curve$y)
hist <- plotly::add_trace(hist, data = normal.curve, x = ~x, y = ~y,
inherit = FALSE,
type = "scatter", mode = "lines",
line = list(color = "red"),
name = "Normal curve",
yaxis = "y")
}
# scatter plot of individual errors
if (se) {
yaxis2 <- list(overlaying = "y", side = "right",
showgrid = FALSE, title = ylab.plot[2],
ticks = "", showline = FALSE)
se.text <- paste0("Measured value:",
data$x, " ± ", data$y,"")
hist <- plotly::add_trace(hist, data = data, x = ~x, y = ~y,
inherit = FALSE,
type = "scatter", mode = "markers",
name = "Error", hoverinfo = "text",
text = se.text,
marker = list(color = "black"),
yaxis = "y2")
hist <- plotly::layout(hist, yaxis2 = yaxis2)
}
# set layout ----
hist <- plotly::layout(hist, hovermode = "closest",
title = paste("", main.plot, ""),
margin = list(r = 90),
xaxis = list(title = xlab.plot,
ticks = ""),
yaxis = list(title = ylab.plot[1],
ticks = "",
showline = FALSE,
showgrid = FALSE)
)
## show and return plot ----
print(hist)
return(hist)
}
}
Luminescence/R/calc_Lamothe2003.R 0000644 0001762 0000144 00000033055 14762554470 016114 0 ustar ligges users #'@title Apply fading correction after Lamothe et al., 2003
#'
#'@description This function applies the fading correction for the prediction of long-term fading as suggested
#' by Lamothe et al., 2003. The function basically adjusts the $L_n/T_n$ values and fits a new dose-response
#' curve using the function [plot_GrowthCurve].
#'
#'@details
#'
#' **Format of `object` if `data.frame`**
#'
#' If `object` is of type [data.frame], all input values most be of type [numeric].
#' Dose values are excepted in seconds (s) not Gray (Gy). No `NA` values are allowed and
#' the value for the natural dose (first row) should be `0`. Example for three dose points,
#' column names are arbitrary:
#'
#' ```
#' object <- data.frame(
#' dose = c(0,25,50),
#' LxTx = c(4.2, 2.5, 5.0),
#' LxTx_error = c(0.2, 0.1, 0.2))
#' ```
#'
#' **Note on the g-value and `tc`**
#'
#' Users new to R and fading measurements are often confused about what to
#' enter for `tc` and why it may differ from `tc.g_value`. The `tc` value
#' is, by convention (Huntley & Lamothe 2001), the time elapsed between the end of the irradiation and the prompt
#' measurement. Usually there is no reason for having a `tc` value different for the equivalent dose measurement
#' and the *g*-value measurement, except if different equipment was used.
#' However, if, for instance, the *g*-value measurement sequence was analysed
#' with the *Analyst* (Duller 2015) and `Luminescence` is used to correct for fading,
#' there is a high chance that the value returned by the *Analyst* comes normalised to 2-days;
#' even the `tc` values of the measurement were identical.
#' In such cases, the fading correction cannot be correct until the `tc.g_value` was manually
#' set to 2-days (`172800` s) because the function will internally recalculate values
#' to an identical `tc` value.
#'
#' @param object [RLum.Results-class] [data.frame] (**required**): Input data for applying the
#' fading correction. Allow are (1) [data.frame] with three columns (`dose`, `LxTx`, `LxTx error`; see details), (2)
#' [RLum.Results-class] object created by the function [analyse_SAR.CWOSL] or [analyse_pIRIRSequence]
#'
#' @param dose_rate.envir [numeric] vector of length 2 (**required**): Environmental dose rate in mGy/a
#'
#' @param dose_rate.source [numeric] vector of length 2 (**required**): Irradiation source dose rate in Gy/s,
#' which is, according to Lamothe et al. (2003) De/t*.
#'
#' @param g_value [numeric] vector of length 2 (**required**): g_value in
#' %/decade *recalculated at the moment* the equivalent dose was calculated,
#' i.e. `tc` is either similar for the *g*-value measurement **and** the
#' De measurement or needs be to recalculated (cf. [calc_FadingCorr]).
#' Inserting a normalised g-value, e.g., normalised to 2-days , will
#' lead to wrong results.
#'
#' @param tc [numeric] (*optional*): time in seconds between the **end** of
#' the irradiation and the prompt measurement used in the equivalent dose
#' estimation (cf. Huntley & Lamothe 2001).
#' If set to `NULL` it is assumed that `tc` is similar for the equivalent dose
#' estimation and the *g*-value estimation
#'
#' @param tc.g_value [numeric] (*with default*): the time in seconds between irradiation and the
#' prompt measurement estimating the *g*-value. If the *g*-value was normalised to, e.g., 2 days,
#' this time in seconds (i.e., `172800`) should be entered here along with the time used for the
#' equivalent dose estimation. If nothing is provided the time is set to `tc`, which is the
#' usual case for *g*-values obtained using the SAR method and *g*-values that had been not normalised to 2 days.
#' Note: If this value is not `NULL` the functions expects a [numeric] value for `tc`.
#'
#' @param plot [logical] (*with default*): enable/disable the plot output.
#'
#' @param verbose [logical] (*with default*): enable/disable output to the
#' terminal.
#'
#' @param ... further arguments passed to function [plot_GrowthCurve].
#'
#' @return The function returns are graphical output produced by the function [plot_GrowthCurve] and
#' an [RLum.Results-class].
#'
#' -----------------------------------\cr
#' `[ NUMERICAL OUTPUT ]`\cr
#' -----------------------------------\cr
#'
#' **`RLum.Results`**-object
#'
#' **slot:** **`@data`**
#'
#' \tabular{lll}{
#' **Element** \tab **Type** \tab **Description**\cr
#' `$data` \tab `data.frame` \tab the fading corrected values \cr
#' `$fit` \tab `nls` \tab the object returned by the dose response curve fitting \cr
#' }
#'
#' '**slot:** **`@info`**
#'
#' The original function call
#'
#' @references
#'
#' Huntley, D.J., Lamothe, M., 2001. Ubiquity of anomalous fading in K-feldspars and the measurement
#' and correction for it in optical dating. Canadian Journal of Earth Sciences 38, 1093-1106.
#'
#' Duller, G.A.T., 2015. The Analyst software package for luminescence data: overview and recent improvements.
#' Ancient TL 33, 35–42.
#'
#' Lamothe, M., Auclair, M., Hamzaoui, C., Huot, S., 2003.
#' Towards a prediction of long-term anomalous fading of feldspar IRSL. Radiation Measurements 37,
#' 493-498.
#'
#' @section Function version: 0.1.0
#'
#' @author Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany), Norbert Mercier,
#' IRAMAT-CRP2A, Université Bordeaux Montaigne (France)
#'
#' @keywords datagen
#'
#' @seealso [plot_GrowthCurve], [calc_FadingCorr], [analyse_SAR.CWOSL], [analyse_pIRIRSequence]
#'
#' @examples
#'
#'##load data
#'##ExampleData.BINfileData contains two BINfileData objects
#'##CWOSL.SAR.Data and TL.SAR.Data
#'data(ExampleData.BINfileData, envir = environment())
#'
#'##transform the values from the first position in a RLum.Analysis object
#'object <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos=1)
#'
#'##perform SAR analysis and set rejection criteria
#'results <- analyse_SAR.CWOSL(
#' object = object,
#' signal.integral.min = 1,
#' signal.integral.max = 2,
#' background.integral.min = 900,
#' background.integral.max = 1000,
#' verbose = FALSE,
#' plot = FALSE,
#' onlyLxTxTable = TRUE
#' )
#'
#' ##run fading correction
#' results_corr <- calc_Lamothe2003(
#' object = results,
#' dose_rate.envir = c(1.676 , 0.180),
#' dose_rate.source = c(0.184, 0.003),
#' g_value = c(2.36, 0.6),
#' plot = TRUE,
#' fit.method = "EXP")
#'
#'
#'@md
#'@export
calc_Lamothe2003 <- function(
object,
dose_rate.envir,
dose_rate.source,
g_value,
tc = NULL,
tc.g_value = tc,
verbose = TRUE,
plot = TRUE,
...
) {
.set_function_name("calc_Lamothe2003")
on.exit(.unset_function_name(), add = TRUE)
## Input parameter test ---------------------------------------------------
.validate_class(object, c("data.frame", "RLum.Results"))
## dose_rate.envir
.validate_class(dose_rate.envir, "numeric")
if (length(dose_rate.envir) < 2) {
.throw_error("'dose_rate.envir' should contain 2 elements")
}
if (length(dose_rate.envir) > 2) {
.throw_warning("'dose_rate.envir' has length > 2, taking only the first two entries")
dose_rate.envir <- dose_rate.envir[1:2]
}
## dose_rate.source
.validate_class(dose_rate.source, "numeric")
if (length(dose_rate.source) < 2) {
.throw_error("'dose_rate.source' should contain 2 elements")
}
if (length(dose_rate.source) > 2) {
.throw_warning("'dose_rate.source' has length > 2, taking only the first two entries")
dose_rate.source <- dose_rate.source[1:2]
}
## g_value
.validate_class(g_value, "numeric")
if (length(g_value) < 2) {
.throw_error("'g_value' should contain 2 elements")
}
if (length(g_value) > 2) {
.throw_warning("'g_value' has length > 2, taking only the first two entries")
g_value <- g_value[1:2]
}
##tc
if(is.null(tc) && !is.null(tc.g_value))
.throw_error("If you set 'tc.g_value' you have to provide a value for 'tc' too")
# Input assignment -----------------------------------------------------------------------------
## We allow input as data.frame() and RLum.Results objects ... the output from functions listed
## below .. if we allow a data.frame it should have at least Dose, Lx/Tx, Lx/Tx Error
if(inherits(object, "data.frame")){
data <- object[,1:3]
##add signal information
if(any(grepl(pattern = "Signal", x = colnames(object), fixed = TRUE))){
SIGNAL <- object[[which(grepl(pattern = "Signal", colnames(object), fixed = TRUE))[1]]]
}else{
SIGNAL <- NA
}
}else if(inherits(object, "RLum.Results")){
if(object@originator == "analyse_SAR.CWOSL" || object@originator == "analyse_pIRIRSequence"){
##now we do crazy stuff, we make a self-call here since this file can contain a lot of information
##get number of datasets; we have to search for the word natural, everything else is not safe enough
full_table <- object@data$LnLxTnTx.table
set_start <- which(grepl(full_table$Name, pattern = "Natural", fixed = TRUE))
set_end <- c(set_start[-1] - 1, nrow(full_table))
##signal column if available
if(object@originator == "analyse_pIRIRSequence"){
object <- full_table[,c("Dose", "LxTx", "LxTx.Error", "Signal")]
}else{
object <- full_table[,c("Dose", "LxTx", "LxTx.Error")]
}
##now run the function
results <- lapply(1:length(set_start), function(x){
calc_Lamothe2003(
object = object[set_start[x]:set_end[x], ],
dose_rate.envir = dose_rate.envir,
dose_rate.source = dose_rate.source,
g_value = g_value,
tc = tc,
tc.g_value = tc.g_value,
verbose = verbose,
plot = plot,
...
)
})
##merge output
return(merge_RLum(results))
}else{
.throw_error("Input for 'object' created by function ",
object@originator, "() not supported")
}
}
# Apply correction----------------------------------------------------------------------------
##recalculate the g-value to the given tc ...
##re-calculation thanks to the help by Sébastien Huot, e-mail: 2016-07-19
if(!is.null(tc)){
k0 <- g_value / 100 / log(10)
k1 <- k0 / (1 - k0 * log(tc[1]/tc.g_value[1]))
g_value <- 100 * k1 * log(10)
}
# transform irradiation times to dose values
data[[1]] <- data[[1]] * dose_rate.source[1]
## fading correction (including dose rate conversion from Gy/s to Gy/ka)
## and error calculation
## the formula in Lamothe et al. (2003) reads:
## I_faded = I_unfaded*(1-g*log((1/e)*DR_lab/DR_soil)))
rr <- 31.5576e+09 * dose_rate.source[1] / (exp(1) * dose_rate.envir[1])
s_rr <- sqrt((dose_rate.source[2]/dose_rate.source[1])^2 + (dose_rate.envir[2]/dose_rate.envir[1])^2) * rr
Fading_C <- 1 - g_value[1] / 100 * log10(rr)
sFading_C <- sqrt((log10(rr) * g_value[2]/100)^2 + (g_value[1]/(100 * rr) * s_rr)^2)
# store original Lx/Tx in new object
LnTn_BEFORE <- data[[2]][1]
LnTn_BEFORE.ERROR <- data[[3]][1]
# apply to input data
data[[2]][1] <- data[[2]][1] / Fading_C
data[[3]][1] <- sqrt((data[[3]][1]/data[[2]][1])^2 +
(sFading_C/Fading_C)^2) * data[[2]][1]
# Fitting ---------------------------------------------------------------------------------
##set arguments
argument_list <- list(
sample = data,
verbose = FALSE,
main = "Corrected Dose Response Curve",
xlab = "Dose [Gy]",
txtProgressBar = verbose,
output.plotExtended = FALSE,
output.plot = plot
)
##filter doubled arguments
argument_list <- modifyList(x = argument_list, val = list(...))
##run plot function
fit_results <- do.call(what = plot_GrowthCurve, args = argument_list)
# Age calculation -----------------------------------------------------------------------------
Age <- get_RLum(fit_results)[["De"]] / dose_rate.envir[1]
s_Age <- sqrt((100*get_RLum(fit_results)[["De.Error"]]/get_RLum(fit_results)[["De"]])^2 + (100*dose_rate.envir[2]/dose_rate.envir[1])^2) *Age/100
# Terminal output -----------------------------------------------------------------------------
if(verbose){
cat("\n[calc_Lamothe2003()] \n\n")
cat(" Used g_value:\t\t", round(g_value[1],3)," \u00b1 ",round(g_value[2],3),"%/decade \n")
if(!is.null(tc)){
cat(" tc for g_value:\t", tc.g_value, " s\n")
}
cat("\n")
cat(" Fading_C:\t\t", round(Fading_C,3), " \u00b1 ", round(sFading_C,3),"\n")
cat(" Corrected Ln/Tn:\t", round(data[[2]][1],3), " \u00b1 ", round(data[[3]][1],3),"\n")
cat(" Corrected De:\t\t", round(get_RLum(fit_results)[["De"]],2), " \u00b1 ", round(get_RLum(fit_results)[["De.Error"]],2)," Gy \n")
cat("--------------------------------------------------------\n")
cat(" Corrected Age:\t\t", round(Age,2), " \u00b1 ", round(s_Age,2)," ka \n")
cat("--------------------------------------------------------\n")
}
# Compile output ------------------------------------------------------------------------------
return(
set_RLum(
class = "RLum.Results",
data = list(
data = data.frame(
g_value = g_value[1],
g_value.ERROR = g_value[2],
tc = ifelse(is.null(tc), NA, tc),
tc.g_value = ifelse(is.null(tc.g_value), NA, tc.g_value),
FADING_C = Fading_C,
FADING_C.ERROR = sFading_C,
LnTn_BEFORE = LnTn_BEFORE,
LnTn_BEFORE.ERROR = LnTn_BEFORE.ERROR,
LnTn_AFTER = data[[2]][1],
LnTn_AFTER.ERROR = data[[3]][1],
DE = get_RLum(fit_results)[["De"]],
DE.ERROR = get_RLum(fit_results)[["De.Error"]],
AGE = Age,
AGE.ERROR = s_Age,
SIGNAL = SIGNAL
),
fit = get_RLum(fit_results, data.object = "Fit")
),
info = list(
call = sys.call()
)
)
)
}
Luminescence/R/plot_ROI.R 0000644 0001762 0000144 00000021476 14762554470 014727 0 ustar ligges users #'@title Create Regions of Interest (ROI) Graphic
#'
#'@description Create ROI graphic with data extracted from the data imported
#'via [read_RF2R]. This function is used internally by [analyse_IRSAR.RF] but
#'might be of use to work with reduced data from spatially resolved measurements.
#'The plot dimensions mimic the original image dimensions
#'
#'@param object [RLum.Analysis-class], [RLum.Results-class] or a [list] of such objects (**required**):
#'data input. Please note that to avoid function errors, only input created
#'by the functions [read_RF2R] or [extract_ROI] is accepted
#'
#'@param exclude_ROI [numeric] (*with default*): option to remove particular ROIs from the
#'analysis. Those ROIs are plotted but not coloured and not taken into account
#'in distance analysis. `NULL` excludes nothing.
#'
#'@param dist_thre [numeric] (*optional*): euclidean distance threshold in pixel
#'distance. All ROI for which the euclidean distance is smaller are marked. This
#'helps to identify ROIs that might be affected by signal cross-talk. Note:
#'the distance is calculated from the centre of an ROI, e.g., the threshold
#'should include consider the ROIs or grain radius.
#'
#'@param dim.CCD [numeric] (*optional*): metric x and y for the recorded (chip)
#'surface in µm. For instance `c(8192,8192)`, if set additional x and y-axes are shown
#'
#' @param bg_image [RLum.Data.Image-class] (*optional*): background image object
#' (please note that dimensions are not checked).
#'
#' @param plot [logical] (*with default*): enable/disable the plot output.
#'
#'@param ... further parameters to manipulate the plot. On top of all arguments of
#'[graphics::plot.default] the following arguments are supported: `lwd.ROI`, `lty.ROI`,
#'`col.ROI`, `col.pixel`, `text.labels`, `text.offset`, `grid` (`TRUE/FALSE`), `legend` (`TRUE/FALSE`),
#'`legend.text`, `legend.pos`
#'
#'@return An ROI plot and an [RLum.Results-class] object with a matrix containing
#'the extracted ROI data and a object produced by [stats::dist] containing
#'the euclidean distance between the ROIs.
#'
#'@section Function version: 0.2.0
#'
#'@author Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#'@seealso [read_RF2R], [analyse_IRSAR.RF]
#'
#'@keywords datagen plot
#'
#'@examples
#'
#'## simple example
#'file <- system.file("extdata", "RF_file.rf", package = "Luminescence")
#'temp <- read_RF2R(file)
#'plot_ROI(temp)
#'
#'## in combination with extract_ROI()
#'m <- matrix(runif(100,0,255), ncol = 10, nrow = 10)
#'roi <- matrix(c(2.,4,2,5,6,7,3,1,1), ncol = 3)
#'t <- extract_ROI(object = m, roi = roi)
#'plot_ROI(t, bg_image = m)
#'
#'@md
#'@export
plot_ROI <- function(
object,
exclude_ROI = c(1),
dist_thre = -Inf,
dim.CCD = NULL,
bg_image = NULL,
plot = TRUE,
...
) {
.set_function_name("plot_ROI")
on.exit(.unset_function_name(), add = TRUE)
##helper function to extract content
.spatial_data <- function(x) {
.validate_class(x, c("RLum.Analysis", "RLum.Results"),
extra = "a 'list' of such objects",
name = "'object'")
##ignore all none RLum.Analysis
if (!inherits(x, "RLum.Analysis") || x@originator != "read_RF2R")
.throw_error("Object originator '", x@originator, "' not supported")
##extract some of the elements
info <- x@info
info$ROI <- strsplit(split = " ", info$ROI, fixed = TRUE)[[1]][2]
c(ROI = info$ROI,
x = info$x,
y = info$y,
area = info$area,
width = info$width,
height = info$height,
img_width = info$image_width,
img_height = info$image_height,
grain_d = info$grain_d)
}
if (inherits(object, "RLum.Results") &&
## use %in% instead of == to support the case when originator is NULL
object@originator %in% "extract_ROI") {
m <- object@data$roi_coord
} else {
## make sure the object is a list
if(!is.list(object)) object <- list(object)
.validate_not_empty(object, "list")
##extract values and convert to numeric matrix
m <- t(vapply(object, .spatial_data, character(length = 9)))
##make numeric
storage.mode(m) <- "numeric"
## correct coordinates (they come in odd from the file)
m[,"x"] <- m[,"x"] + m[,"width"] / 2
m[,"y"] <- m[,"y"] + m[,"height"] / 2
}
##make sure the ROI selection works
if(is.null(exclude_ROI[1]) || exclude_ROI[1] <= 0)
exclude_ROI <- nrow(m) + 1
## add mid_x and mid_y
m <- cbind(m, mid_x = c(m[,"x"] + m[,"width"] / 2), mid_y = c(m[,"y"] + m[,"height"] / 2))
rownames(m) <- m[,"ROI"]
## distance calculation
euc_dist <- sel_euc_dist <- stats::dist(m[-exclude_ROI,c("mid_x","mid_y")])
## distance threshold selector
sel_euc_dist[sel_euc_dist < dist_thre[1]] <- NA
sel_euc_dist <- suppressWarnings(as.numeric(rownames(na.exclude(as.matrix(sel_euc_dist)))))
## add information to matrix
m <- cbind(m, dist_sel = FALSE)
m[m[,"ROI"]%in%sel_euc_dist,"dist_sel"] <- TRUE
## --- Plotting ---
if(plot) {
plot_settings <- modifyList(x = list(
xlim = c(0, max(m[, "img_width"])),
ylim = c(max(m[, "img_height"]), 0),
xlab = "width [px]",
ylab = "height [px]",
main = "Spatial ROI Distribution",
frame.plot = FALSE,
lwd.ROI = 0.75,
lty.ROI = 2,
col.ROI = "black",
col.pixel = rgb(0,1,0,0.6),
text.labels = m[,"ROI"],
text.offset = 0.3,
grid = FALSE,
legend = TRUE,
legend.text = c("ROI", "sel. pixel", "> dist_thre"),
legend.pos = "topright"
), val = list(...))
## set plot area
do.call(
what = graphics::plot.default,
args = c(x = NA, y = NA,
plot_settings[names(plot_settings) %in%
methods::formalArgs(graphics::plot.default)])
)
## add background image if available
if(!is.null(bg_image)){
a <- try({
as(bg_image, "RLum.Data.Image")
}, silent = TRUE)
if(inherits(a, "try-error")) {
.throw_warning("'bg_image' is not of class 'RLum.Data.Image' and ",
"cannot be converted into it, background image plot skipped")
} else {
a <- a@data
graphics::image(
x = 1:nrow(a[, , 1]),
y = 1:ncol(a[, , 1]),
z = a[,order(1:dim(a)[2], decreasing = TRUE),1],
add = TRUE,
col = grDevices::hcl.colors(20, "inferno", rev = FALSE),
useRaster = TRUE)
}
}
if (plot_settings$grid) graphics::grid(nx = max(m[, "img_width"]),
ny = max(m[, "img_height"]))
## plot metric scale
if (!is.null(dim.CCD)) {
axis(
side = 1,
at = axTicks(1),
labels = paste(floor(dim.CCD[1] / max(m[,"img_width"]) * axTicks(1)), "\u00b5m"),
lwd = -1,
lwd.ticks = -1,
line = -2.2,
cex.axis = 0.8
)
axis(
side = 2,
at = axTicks(2)[-1],
labels = paste(floor(dim.CCD[2] / max(m[,"img_height"]) * axTicks(2)), "\u00b5m")[-1],
lwd = -1,
lwd.ticks = -1,
line = -2.2,
cex.axis = 0.8
)
}
## add circles and rectangles
for (i in 1:nrow(m)) {
if (!i%in%exclude_ROI) {
## mark selected pixels
polygon(
x = c(m[i, "x"] - m[i, "width"]/ 2, m[i, "x"] - m[i, "width"]/ 2, m[i, "x"] + m[i, "width"]/2, m[i, "x"] + m[i, "width"]/2),
y = c(m[i, "y"] - m[i, "height"]/ 2, m[i, "y"] + m[i, "height"]/ 2, m[i, "y"] + m[i, "height"]/ 2, m[i, "y"] - m[i, "height"]/ 2),
col = plot_settings$col.pixel
)
}
## add ROIs
shape::plotellipse(
rx = m[i, "width"] / 2,
ry = m[i, "width"] / 2,
mid = c(m[i, "x"], m[i, "y"]),
lcol = plot_settings$col.ROI,
lty = plot_settings$lty.ROI,
lwd = plot_settings$lwd.ROI)
}
## add distance marker
points(
x = m[!m[,"ROI"]%in%sel_euc_dist & !m[,"ROI"]%in%exclude_ROI, "x"],
y = m[!m[,"ROI"]%in%sel_euc_dist & !m[,"ROI"]%in%exclude_ROI, "y"],
pch = 4,
col = "red")
## add text
if(length(m[-exclude_ROI,"x"]) > 0) {
graphics::text(
x = m[-exclude_ROI, "x"],
y = m[-exclude_ROI, "y"],
labels = plot_settings$text.labels[-exclude_ROI],
cex = 0.6,
col = if(!is.null(bg_image)) "white" else "black",
pos = 1,
offset = plot_settings$text.offset
)
}
##add legend
if(plot_settings$legend) {
legend(
plot_settings$legend.pos,
bty = "",
pch = c(1, 15, 4),
box.lty = 0,
bg = rgb(1,1,1,0.7),
legend = plot_settings$legend.text,
col = c(plot_settings$col.ROI, plot_settings$col.pixel, "red")
)
}
}##end if plot
## return results
invisible(set_RLum(
class = "RLum.Results",
data = list(
ROI = m,
euc_dist = euc_dist),
info = list(
call = sys.call()
)))
}
Luminescence/R/plot_RLum.R 0000644 0001762 0000144 00000011040 14762554470 015137 0 ustar ligges users #' General plot function for RLum S4 class objects
#'
#' Function calls object specific plot functions for RLum S4 class objects.
#'
#' The function provides a generalised access point for plotting specific
#' [RLum-class] objects.\cr
#' Depending on the input object, the
#' corresponding plot function will be selected. Allowed arguments can be
#' found in the documentations of each plot function.
#'
#' \tabular{lll}{
#' **object** \tab \tab **corresponding plot function** \cr
#' [RLum.Data.Curve-class] \tab : \tab [plot_RLum.Data.Curve] \cr
#' [RLum.Data.Spectrum-class] \tab : \tab [plot_RLum.Data.Spectrum]\cr
#' [RLum.Data.Image-class] \tab : \tab [plot_RLum.Data.Image]\cr
#' [RLum.Analysis-class] \tab : \tab [plot_RLum.Analysis]\cr
#' [RLum.Results-class] \tab : \tab [plot_RLum.Results]
#' }
#'
#' @param object [RLum-class] (**required**):
#' S4 object of class `RLum`. Optional a [list] containing objects of
#' class [RLum-class] can be provided. In this case the function tries to plot
#' every object in this list according to its `RLum` class. Non-RLum objects are
#' removed.
#'
#' @param ... further arguments and graphical parameters that will be passed
#' to the specific plot functions. The only argument that is supported directly is `main`
#' (setting the plot title). In contrast to the normal behaviour `main` can be here provided as
#' [list] and the arguments in the list will dispatched to the plots if the `object`
#' is of type `list` as well.
#'
#' @return Returns a plot.
#'
#' @note The provided plot output depends on the input object.
#'
#' @section Function version: 0.4.4
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [plot_RLum.Data.Curve], [RLum.Data.Curve-class], [plot_RLum.Data.Spectrum],
#' [RLum.Data.Spectrum-class], [plot_RLum.Data.Image], [RLum.Data.Image-class],
#' [plot_RLum.Analysis], [RLum.Analysis-class], [plot_RLum.Results],
#' [RLum.Results-class]
#'
#'
#' @keywords dplot
#'
#' @examples
#' #load Example data
#' data(ExampleData.CW_OSL_Curve, envir = environment())
#'
#' #transform data.frame to RLum.Data.Curve object
#' temp <- as(ExampleData.CW_OSL_Curve, "RLum.Data.Curve")
#'
#' #plot RLum object
#' plot_RLum(temp)
#'
#' @md
#' @export
plot_RLum<- function(
object,
...
) {
.set_function_name("plot_RLum")
on.exit(.unset_function_name(), add = TRUE)
## Define dispatcher function ---------------------------------------------
RLum.dispatcher <- function(object, ...) {
.validate_class(object, "RLum")
##grep object class
object.class <- is(object)[1]
##select which plot function should be used and call it
switch (
object.class,
RLum.Data.Curve = plot_RLum.Data.Curve(object = object, ...),
RLum.Data.Spectrum = plot_RLum.Data.Spectrum(object = object, ...),
RLum.Data.Image = plot_RLum.Data.Image(object = object, ...),
##here we have to do prevent the partial matching with 'sub' by 'subset'
RLum.Analysis =
if(!grepl(pattern = "subset", x = paste(deparse(match.call()), collapse = " "), fixed = TRUE)){
plot_RLum.Analysis(object = object, subset = NULL, ...)
}else{
plot_RLum.Analysis(object = object, ...)
},
RLum.Results = plot_RLum.Results(object = object, ...))
}
# Run dispatcher ------------------------------------------------------------------------------
##call for the list, if not just proceed as normal
if(inherits(object, "list")) {
##(0) we might have plenty of sublists before we have the list containing only
##RLum-objects
object <- .unlist_RLum(object)
object <- .rm_nonRLum(object)
##(2) check if empty, if empty do nothing ...
if (length(object) != 0) {
## If we iterate over a list, this might be extremely useful to have different plot titles
main <- NULL
if("main" %in% names(list(...))){
main <- .listify(list(...)$main, length = length(object))
}
##set also mtext, but in a different way
if(!"mtext" %in% names(list(...))){
if(is(object[[1]], "RLum.Analysis")){
mtext <- paste("Record:", 1:length(object))
}else{
mtext <- NULL
}
}else{
mtext <- rep(list(...)$mtext, length.out = length(object))
}
for (i in 1:length(object)) {
RLum.dispatcher(object = object[[i]],
main = main[[i]],
mtext = mtext[[i]],
...)
}
}
}else{
##dispatch object
RLum.dispatcher(object = object, ...)
}
}
Luminescence/R/extract_IrradiationTimes.R 0000644 0001762 0000144 00000035377 14762554470 020246 0 ustar ligges users #' @title Extract Irradiation Times from an XSYG-file
#'
#' @description Extracts irradiation times, dose and times since last irradiation, from a
#' Freiberg Instruments XSYG-file. These information can be further used to
#' update an existing BINX-file.
#'
#' @details
#' The function was written to compensate missing information in the BINX-file
#' output of Freiberg Instruments lexsyg readers. As all information are
#' available within the XSYG-file anyway, these information can be extracted
#' and used for further analysis or/and to stored in a new BINX-file, which can
#' be further used by other software, e.g., Analyst (Geoff Duller).
#'
#' Typical application example: g-value estimation from fading measurements
#' using the Analyst or any other self-written script.
#'
#' Beside some simple data transformation steps, the function applies
#' functions [read_XSYG2R], [read_BIN2R], [write_R2BIN] for data import and export.
#'
#' @param object [character], [RLum.Analysis-class] or [list] (**required**):
#' path and file name of the XSYG file or an [RLum.Analysis-class]
#' produced by the function [read_XSYG2R];
#' alternatively a `list` of [RLum.Analysis-class] can be provided.
#'
#' **Note**: If an [RLum.Analysis-class] is used, any input for
#' the arguments `file.BINX` and `recordType` will be ignored!
#'
#' @param file.BINX [character] (*optional*):
#' path and file name of an existing BINX-file. If a file name is provided the
#' file will be updated with the information from the XSYG file in the same
#' folder as the original BINX-file.
#'
#' **Note:** The XSYG and the BINX-file must originate from the
#' same measurement!
#'
#' @param recordType [character] (*with default*):
#' select relevant curves types from the XSYG file or [RLum.Analysis-class]
#' object. As the XSYG-file format comprises much more information than usually
#' needed for routine data analysis and allowed in the BINX-file format, only
#' the relevant curves are selected by using the function
#' [get_RLum]. The argument `recordType` works as
#' described for this function.
#'
#' **Note:** A wrong selection will causes a function error. Please change this
#' argument only if you have reasons to do so.
#'
#' @param compatibility.mode [logical] (*with default*):
#' this option is parsed only if a BIN/BINX file is produced and it will reset all position
#' values to a max. value of 48, cf.[write_R2BIN]
#'
#' @param txtProgressBar [logical] (*with default*):
#' enable/disable the progress bar during import and export.
#'
#' @note The function can be also used to extract irradiation times from [RLum.Analysis-class] objects
#' previously imported via [read_BIN2R] (`fastForward = TRUE`) or in combination with [Risoe.BINfileData2RLum.Analysis].
#' Unfortunately the timestamp might not be very precise (or even invalid),
#' but it allows to essentially treat different formats in a similar manner.
#'
#' @return
#' An [RLum.Results-class] object is returned with the
#' following structure:
#'
#' ```
#' .. $irr.times (data.frame)
#' ```
#'
#' If a BINX-file path and name is set, the output will be additionally
#' transferred into a new BINX-file with the function name as suffix. For the
#' output the path of the input BINX-file itself is used. Note that this will
#' not work if the input object is a file path to an XSYG-file, instead of a
#' link to only one file. In this case the argument input for `file.BINX` is ignored.
#'
#' In the self call mode (input is a `list` of [RLum.Analysis-class] objects
#' a list of [RLum.Results-class] is returned.
#'
#' @note
#' The produced output object contains still the irradiation steps to
#' keep the output transparent. However, for the BINX-file export this steps
#' are removed as the BINX-file format description does not allow irradiations
#' as separate sequences steps.
#'
#' **BINX-file 'Time Since Irradiation' value differs from the table output?**
#'
#' The way the value 'Time Since Irradiation' is defined differs. In the BINX-file the
#' 'Time Since Irradiation' is calculated as the 'Time Since Irradiation' plus the 'Irradiation
#' Time'. The table output returns only the real 'Time Since Irradiation', i.e. time between the
#' end of the irradiation and the next step.
#'
#' **Negative values for `TIMESINCELAST.STEP`?**
#'
#' Yes, this is possible and no bug, as in the XSYG-file multiple curves are stored for one step.
#' Example: TL step may comprise three curves:
#'
#' - (a) counts vs. time,
#' - (b) measured temperature vs. time and
#' - (c) predefined temperature vs. time.
#'
#' Three curves, but they are all belonging to one TL measurement step, but with regard to
#' the time stamps this could produce negative values as the important function
#' ([read_XSYG2R]) do not change the order of entries for one step
#' towards a correct time order.
#'
#' @section Function version: 0.3.4
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum.Analysis-class], [RLum.Results-class], [Risoe.BINfileData-class],
#' [read_XSYG2R], [read_BIN2R], [write_R2BIN]
#'
#' @references
#' Duller, G.A.T., 2015. The Analyst software package for luminescence data: overview and
#' recent improvements. Ancient TL 33, 35-42.
#'
#' @keywords IO manip
#'
#' @examples
#' ## (1) - example for your own data
#' ##
#' ## set files and run function
#' #
#' # file.XSYG <- file.choose()
#' # file.BINX <- file.choose()
#' #
#' # output <- extract_IrradiationTimes(file.XSYG = file.XSYG, file.BINX = file.BINX)
#' # get_RLum(output)
#' #
#' ## export results additionally to a CSV-file in the same directory as the XSYG-file
#' # write.table(x = get_RLum(output),
#' # file = paste0(file.BINX,"_extract_IrradiationTimes.csv"),
#' # sep = ";",
#' # row.names = FALSE)
#'
#' @md
#' @export
extract_IrradiationTimes <- function(
object,
file.BINX,
recordType = c("irradiation (NA)", "IRSL (UVVIS)", "OSL (UVVIS)", "TL (UVVIS)"),
compatibility.mode = TRUE,
txtProgressBar = TRUE
) {
.set_function_name("extract_IrradiationTimes")
on.exit(.unset_function_name(), add = TRUE)
# SELF CALL -----------------------------------------------------------------------------------
if(is.list(object)){
##show message for non-supported arguments
if(!missing(file.BINX)){
.throw_warning("argument 'file.BINX' is not supported in self-call mode.")
}
## expand input arguments
recordType <- .listify(recordType, length(object))
## run function
results <- lapply(seq_along(object), function(x) {
extract_IrradiationTimes(
object = object[[x]],
recordType = recordType[[x]],
txtProgressBar = txtProgressBar
)
})
##DO NOT use invisible here, this will stop the function from stopping
if(length(results) == 0){
return(NULL)
}else{
return(results)
}
}
## Integrity tests --------------------------------------------------------
.validate_class(object, c("character", "RLum.Analysis"),
extra = "a 'list' of such objects")
.validate_not_empty(object)
if (is.character(object[1])) {
.validate_length(object, 1)
##set object to file.XSYG
file.XSYG <- object
##XSYG
if (!file.exists(file.XSYG)) {
.throw_error("Wrong XSYG file name or file does not exist!")
}
##check if file is XML file
if(tail(unlist(strsplit(file.XSYG, split = "\\.")), 1) != "xsyg" &
tail(unlist(strsplit(file.XSYG, split = "\\.")), 1) != "XSYG" ){
.throw_error("File is expected to have 'xsyg' or 'XSYG' extension")
}
##BINX
if(!missing(file.BINX)){
if (!file.exists(file.BINX)) {
.throw_error("Wrong BINX file name or file does not exist!")
}
##check if file is XML file
if(tail(unlist(strsplit(file.BINX, split = "\\.")), 1) != "binx" &
tail(unlist(strsplit(file.BINX, split = "\\.")), 1) != "BINX" ){
.throw_error("File is expected to have 'binx' or 'BINX' extension")
}
}
# Settings and import XSYG --------------------------------------------------------------------
temp.XSYG <- read_XSYG2R(file.XSYG, txtProgressBar = txtProgressBar,
verbose = txtProgressBar)
if(!missing(file.BINX)){
temp.BINX <- read_BIN2R(file.BINX, txtProgressBar = txtProgressBar,
verbose = txtProgressBar)
temp.BINX.dirname <- (dirname(file.XSYG))
}
# Some data preparation -----------------------------------------------------------------------
##set list
temp.sequence.list <- list()
##select all analysis objects and combine them
for(i in 1:length(temp.XSYG)){
##select sequence and reduce the data set to really wanted values
temp.sequence.list[[i]] <- get_RLum(
object = temp.XSYG[[i]]$Sequence.Object,
recordType = recordType,
drop = FALSE)
##get corresponding position number, this will be needed later on
temp.sequence.position <- as.numeric(as.character(temp.XSYG[[i]]$Sequence.Header["position",]))
}
}else{
##now we assume a single RLum.Analysis object
##select sequence and reduce the data set to really wanted values, note that no
##record selection was made!
temp.sequence.list <- list(object)
}
##merge objects
if(length(temp.sequence.list)>1){
temp.sequence <- merge_RLum(temp.sequence.list)
}else{
temp.sequence <- temp.sequence.list[[1]]
}
# Grep relevant information -------------------------------------------------------------------
##Sequence STEP
STEP <- names_RLum(temp.sequence)
#START time of each step
## we try also to support BIN/BINX files with this function if imported
## accordingly
if(any(temp.sequence@originator %in% c("Risoe.BINfileData2RLum.Analysis", "read_BIN2R"))) {
temp.START <- vapply(temp.sequence, function(x) {
paste0(get_RLum(x, info.object = c("DATE")), get_RLum(x, info.object = c("TIME")))
}, character(1))
##a little bit reformatting.
START <- strptime(temp.START, format = "%y%m%d%H%M%S", tz = "GMT")
## make another try in case it does not make sense
if (anyNA(START))
START <- strptime(temp.START, format = "%y%m%d%H:%M:%S", tz = "GMT")
} else {
temp.START <- vapply(temp.sequence, function(x) {
tmp <- suppressWarnings(get_RLum(x, info.object = c("startDate")))
if(is.null(tmp))
tmp <- as.character(Sys.Date())
tmp
}, character(1))
##a little bit reformatting.
START <- strptime(temp.START, format = "%Y%m%d%H%M%S", tz = "GMT")
}
##DURATION of each STEP
DURATION.STEP <- vapply(temp.sequence, function(x){
max(get_RLum(x)[,1])
}, numeric(1))
##Calculate END time of each STEP
END <- START + DURATION.STEP
##add position number so far an XSYG file was the input
POSITION <- NA
if(exists("file.XSYG")){
POSITION <- rep(temp.sequence.position, each = length_RLum(temp.sequence))
}else if(!inherits(try(
suppressWarnings(get_RLum(
get_RLum(temp.sequence, record.id = 1), info.object = "position")),
silent = TRUE), "try-error")){
##POSITION of each STEP
POSITION <- vapply(temp.sequence, function(x){
tmp <- suppressWarnings(get_RLum(x, info.object = c("position")))
if(is.null(tmp))
tmp <- get_RLum(x, info.object = c("POSITION"))
tmp
}, numeric(1))
}
##Combine the results
temp.results <- data.frame(POSITION,STEP,START,DURATION.STEP,END)
# Calculate irradiation duration ------------------------------------------------------------
if(any(temp.sequence@originator %in% c("Risoe.BINfileData2RLum.Analysis", "read_BIN2R"))) {
IRR_TIME <- vapply(temp.sequence, function(x) get_RLum(x, info.object = c("IRR_TIME")), numeric(1))
} else {
IRR_TIME <- numeric(length = nrow(temp.results))
temp_last <- 0
for(i in 1:nrow(temp.results)){
if(grepl("irradiation", temp.results[["STEP"]][i])) {
temp_last <- temp.results[["DURATION.STEP"]][i]
next()
}
IRR_TIME[i] <- temp_last
}
}
# Calculate time since irradiation ------------------------------------------------------------
##set objects
time.irr.end <- NA
TIMESINCEIRR <- unlist(sapply(1:nrow(temp.results), function(x){
if(grepl("irradiation", temp.results[x,"STEP"])){
time.irr.end<<-temp.results[x,"END"]
return(-1)
}else{
if(is.na(time.irr.end)){
return(-1)
}else{
return(difftime(temp.results[x,"START"],time.irr.end, units = "secs"))
}
}
}))
# Calculate time since last step --------------------------------------------------------------
TIMESINCELAST.STEP <- unlist(sapply(1:nrow(temp.results), function(x){
if(x == 1){
return(0)
}else{
return(difftime(temp.results[x,"START"],temp.results[x-1, "END"], units = "secs"))
}
}))
# Combine final results -----------------------------------------------------------------------
##results table, export as CSV
results <- cbind(temp.results,IRR_TIME, TIMESINCEIRR,TIMESINCELAST.STEP)
# Write BINX-file if wanted -------------------------------------------------------------------
if(!missing(file.BINX)){
##(1) remove all irradiation steps as there is no record in the BINX file and update information
results.BINX <- results[results[, "STEP"] != "irradiation (NA)", ]
## (2) compare entries in the BINX-file with the entries in the table
## to make sure that both have the same length
if(nrow(results.BINX) == nrow(temp.BINX@METADATA)){
## (1a) update information on the irradiation time
temp.BINX@METADATA[["IRR_TIME"]] <- results.BINX[["IRR_TIME"]]
## (1b) update information on the time since irradiation by using the
## Risoe definition of the parameter, to make the file compatible to
## the Analyst
temp.BINX@METADATA[["TIMESINCEIRR"]] <- results.BINX[["IRR_TIME"]] + results.BINX[["TIMESINCEIRR"]]
## update BINX-file
try <- write_R2BIN(temp.BINX, version = "06",
file = paste0(file.BINX,"_extract_IrradiationTimes.BINX"),
compatibility.mode = compatibility.mode,
verbose = txtProgressBar,
txtProgressBar = txtProgressBar)
##set message on the format definition
if(!inherits(x = try, 'try-error')){
message("[extract_IrradiationTimes()] 'Time Since Irradiation' was redefined in the exported BINX-file to: 'Time Since Irradiation' plus the 'Irradiation Time' to be compatible with the Analyst.")
}
} else {
.throw_message("XSYG-file and BINX-file do not contain similar entries, ",
"BINX-file update skipped")
}
}
# Output --------------------------------------------------------------------------------------
return(set_RLum(class = "RLum.Results", data = list(irr.times = results)))
}
Luminescence/R/convert_XSYG2CSV.R 0000644 0001762 0000144 00000005465 14762554470 016230 0 ustar ligges users #' @title Export XSYG-file(s) to CSV-files
#'
#' @description
#' This function is a wrapper function around the functions [read_XSYG2R] and
#' [write_RLum2CSV] and it imports an XSYG-file and directly exports its content
#' to CSV-files. If nothing is set for the argument `path` ([write_RLum2CSV])
#' the input folder will become the output folder.
#'
#' @param file [character] (**required**):
#' name of the XSYG-file to be converted to CSV-files
#'
#' @param ... further arguments that will be passed to the function
#' [read_XSYG2R] and [write_RLum2CSV]
#'
#' @return
#' The function returns either a CSV-file (or many of them) or for the option `export = FALSE`
#' a list comprising objects of type [data.frame] and [matrix]
#'
#' @section Function version: 0.1.0
#'
#' @author Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum.Analysis-class], [RLum.Data-class], [RLum.Results-class],
#' [utils::write.table], [write_RLum2CSV], [read_XSYG2R]
#'
#' @keywords IO
#'
#' @examples
#'
#' ##transform XSYG-file values to a list
#' data(ExampleData.XSYG, envir = environment())
#' convert_XSYG2CSV(OSL.SARMeasurement$Sequence.Object[1:10], export = FALSE)
#'
#' \dontrun{
#' ##select your BIN-file
#' file <- file.choose()
#'
#' ##convert
#' convert_XSYG2CSV(file)
#'
#' }
#'
#' @md
#' @export
convert_XSYG2CSV <- function(
file,
...
) {
.set_function_name("convert_XSYG2CSV")
on.exit(.unset_function_name(), add = TRUE)
## Integrity checks -------------------------------------------------------
.validate_class(file, c("character", "RLum"))
.validate_not_empty(file)
##set input arguments
convert_XSYG2R_settings.default <- list(
recalculate.TL.curves = TRUE,
pattern = ".xsyg",
txtProgressBar = TRUE,
export = TRUE
)
##modify list on demand
convert_XSYG2R_settings <- modifyList(x = convert_XSYG2R_settings.default, val = list(...))
# Import file ---------------------------------------------------------------------------------
if(!inherits(file, "RLum")){
object <- read_XSYG2R(
file = file,
fastForward = TRUE,
recalculate.TL.curves = convert_XSYG2R_settings$recalculate.TL.curves,
pattern = convert_XSYG2R_settings$pattern,
txtProgressBar = convert_XSYG2R_settings$txtProgressBar
)
}else{
object <- file
}
# Export to CSV -------------------------------------------------------------------------------
##get all arguments we want to pass and remove the doubled one
arguments <- c(list(object = object, export = convert_XSYG2R_settings$export), list(...))
arguments[duplicated(names(arguments))] <- NULL
##this if-condition prevents NULL in the terminal
if(convert_XSYG2R_settings$export == TRUE){
invisible(do.call("write_RLum2CSV", arguments))
}else{
do.call("write_RLum2CSV", arguments)
}
}
Luminescence/R/RLum.Data.Image-class.R 0000644 0001762 0000144 00000024250 14762554470 017104 0 ustar ligges users #' Class `"RLum.Data.Image"`
#'
#' Class for representing luminescence image data (TL/OSL/RF). Such data are for example produced
#' by the function [read_SPE2R]
#'
#' @name RLum.Data.Image-class
#'
#' @docType class
#'
#' @slot recordType
#' Object of class [character] containing the type of the curve (e.g. "OSL image", "TL image")
#'
#' @slot curveType
#' Object of class [character] containing curve type, allowed values
#' are measured or predefined
#'
#' @slot data
#' Object of class [array] containing image data.
#'
#' @slot info
#' Object of class [list] containing further meta information objects
#'
#' @note
#' The class should only contain data for a set of images. For additional
#' elements the slot `info` can be used.
#'
#' @section Objects from the class:
#' Objects can be created by calls of the form `set_RLum("RLum.Data.Image", ...)`.
#'
#' @section Class version: 0.5.1
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum-class], [RLum.Data-class], [plot_RLum], [read_SPE2R], [read_TIFF2R]
#'
#' @keywords classes
#'
#' @examples
#'
#' showClass("RLum.Data.Image")
#'
#' ##create empty RLum.Data.Image object
#' set_RLum(class = "RLum.Data.Image")
#'
#' @md
#' @export
setClass(
"RLum.Data.Image",
slots = list(
recordType = "character",
curveType = "character",
data = "array",
info = "list"
),
contains = "RLum.Data",
prototype = list (
recordType = character(),
curveType = character(),
data = array(),
info = list()
)
)
# as() ----------------------------------------------------------------------------------------
##DATA.FRAME
##COERCE RLum.Data.Image >> data.frame AND data.frame >> RLum.Data.Image
#' as()
#'
#' for `[RLum.Data.Image-class]`
#'
#' **[RLum.Data.Image-class]**
#'
#' \tabular{ll}{
#' **from** \tab **to**\cr
#' `data.frame` \tab `data.frame`\cr
#' `matrix` \tab `matrix`
#' }
#'
#' @md
#' @name as
## from data.frame ----
setAs("data.frame", "RLum.Data.Image",
function(from,to){
new(to,
recordType = "unknown curve type",
curveType = "NA",
data = array(unlist(from), dim = c(nrow(from),ncol(from),1)),
info = list())
})
## to data.frame ----
setAs("RLum.Data.Image", "data.frame",
function(from){
if(dim(from@data)[3] == 1) {
as.data.frame(from@data[,,1])
} else {
stop("No viable coercion to data.frame, object contains multiple frames.",
call. = FALSE)
}
})
## from matrix ----
setAs("matrix", "RLum.Data.Image",
function(from,to){
new(to,
recordType = "unknown curve type",
curveType = "NA",
data = array(from, c(nrow(from), ncol(from), 1)),
info = list())
})
## to matrix ----
setAs("RLum.Data.Image", "matrix",
function(from){
if(dim(from@data)[3] == 1) {
from@data[,,1, drop = TRUE]
} else {
stop("No viable coercion to matrix, object contains multiple frames. Please convert to array instead.", call. = FALSE)
}
})
## from array ----
setAs("array", "RLum.Data.Image",
function(from, to){
new(to,
recordType = "unknown curve type",
curveType = "NA",
data = from,
info = list())
})
## to array ----
setAs("RLum.Data.Image", "array",
function(from) from@data)
## from list ----
setAs("list", "RLum.Data.Image",
function(from, to){
if (length(from) == 0)
return(set_RLum("RLum.Data.Image"))
array_list <- lapply(from, function(x) array(unlist(as.vector(x)), c(nrow(x), ncol(x), 1)))
new(to,
recordType = "unknown curve type",
curveType = "NA",
data = array(unlist(array_list),
c(nrow(array_list[[1]]), ncol(array_list[[1]]), length(array_list))),
info = list())
})
## to list ----
setAs("RLum.Data.Image", "list",
function(from){
num.images <- dim(from@data)[3]
if (is.na(num.images))
return(list())
lapply(1:num.images, function(x) from@data[,,x])
})
# show() --------------------------------------------------------------------------------------
#' @describeIn RLum.Data.Image
#' Show structure of `RLum.Data.Image` object
#'
#' @keywords internal
#'
#' @md
#' @export
setMethod("show",
signature(object = "RLum.Data.Image"),
function(object){
## get dimension
dim <- dim(object@data)
##print information
cat("\n [RLum.Data.Image-class]")
cat("\n\t recordType:", object@recordType)
cat("\n\t curveType:", object@curveType)
cat("\n\t .. recorded frames:", max(1,dim[3], na.rm = TRUE))
cat("\n\t .. .. pixel per frame:", dim[1]*dim[2])
cat("\n\t .. .. x dimension [px]:", dim[1])
cat("\n\t .. .. y dimension [px]:", dim[2])
cat("\n\t .. .. full pixel value range:", paste(format(range(object@data), scientific = TRUE, digits = 2), collapse=" : "))
cat("\n\t additional info elements:", length(object@info))
#cat("\n\t\t >> names:", names(object@info))
cat("\n")
}
)
# set_RLum() ----------------------------------------------------------------------------------
#' @describeIn RLum.Data.Image
#' Construction method for RLum.Data.Image object. The slot info is optional
#' and predefined as empty list by default.
#'
#' @param class [`set_RLum`]; [character]: name of the `RLum` class to create
#'
#' @param originator [`set_RLum`]; [character] (*automatic*):
#' contains the name of the calling function (the function that produces this object);
#' can be set manually.
#'
#' @param .uid [`set_RLum`]; [character] (*automatic*):
#' sets an unique ID for this object using the internal C++ function `create_UID`.
#'
#' @param .pid [`set_RLum`]; [character] (*with default*):
#' option to provide a parent id for nesting at will.
#'
#' @param recordType [`set_RLum`]; [character]:
#' record type (e.g. "OSL")
#'
#' @param curveType [`set_RLum`]; [character]:
#' curve type (e.g. "predefined" or "measured")
#'
#' @param data [`set_RLum`]; [matrix]:
#' raw curve data. If data is of type `RLum.Data.Image` this can be used to
#' re-construct the object, i.e. modified parameters except `.uid` and `.pid`. The rest
#' will be subject to copy and paste unless provided.
#'
#' @param info [`set_RLum`]; [list]:
#' info elements
#'
#' @return
#'
#' **`set_RLum`**
#'
#' Returns an object from class `RLum.Data.Image`
#'
#' @md
#' @export
setMethod(
"set_RLum",
signature = signature("RLum.Data.Image"),
definition = function(
class,
originator,
.uid,
.pid,
recordType = "Image",
curveType = NA_character_,
data = array(),
info = list()) {
##The case where an RLum.Data.Image object can be provided
##with this RLum.Data.Image objects can be provided to be reconstructed
if (is(data, "RLum.Data.Image")) {
##check for missing curveType
if (missing(curveType))
curveType <- data@curveType
##check for missing recordType
if (missing(recordType))
recordType <- data@recordType
##check for missing data ... not possible as data is the object itself
##check for missing info
if (missing(info))
info <- data@info
##check for modified .uid & .pid
## >> this cannot be changed here, since both would be reset, by
## the arguments passed down from set_RLum() ... the generic function
##set empty class form object
newRLumDataImage <- new("RLum.Data.Image")
##fill - this is the faster way, filling in new() costs ...
newRLumDataImage@originator <- data@originator
newRLumDataImage@recordType <- recordType
newRLumDataImage@curveType <- curveType
newRLumDataImage@data <- data@data
newRLumDataImage@info <- info
newRLumDataImage@.uid <- data@.uid
newRLumDataImage@.pid <- data@.pid
} else {
##set empty class from object
newRLumDataImage <- new("RLum.Data.Image")
##fill - this is the faster way, filling in new() costs ...
newRLumDataImage@originator <- originator
newRLumDataImage@recordType <- recordType
newRLumDataImage@curveType <- curveType
newRLumDataImage@data <- data
newRLumDataImage@info <- info
newRLumDataImage@.uid <- .uid
newRLumDataImage@.pid <- .pid
}
return(newRLumDataImage)
}
)
# get_RLum() ----------------------------------------------------------------------------------
#' @describeIn RLum.Data.Image
#' Accessor method for `RLum.Data.Image` object. The argument `info.object` is
#' optional to directly access the info elements. If no info element name is
#' provided, the raw image data (`array`) will be returned.
#'
#' @param object [`get_RLum`], [`names_RLum`] (**required**):
#' an object of class [RLum.Data.Image-class]
#'
#' @param info.object [`get_RLum`]; [character]:
#' name of the info object to returned
#'
#' @return
#'
#' **`get_RLum`**
#'
#' 1. Returns the data object ([array])
#' 2. only the info object if `info.object` was set.
#'
#' @md
#' @export
setMethod("get_RLum",
signature("RLum.Data.Image"),
definition = function(object, info.object) {
.set_function_name("get_RLum")
on.exit(.unset_function_name(), add = TRUE)
if(!missing(info.object)){
.validate_class(info.object, "character")
if(info.object %in% names(object@info)){
unlist(object@info[info.object])
} else {
.throw_error("Invalid element name, valid names are: ",
.collapse(names(object@info)))
}
} else {
object@data
}
})
# names_RLum() --------------------------------------------------------------------------------
#' @describeIn RLum.Data.Image
#' Returns the names info elements coming along with this curve object
#'
#' @return
#'
#' **`names_RLum`**
#'
#' Returns the names of the info elements
#'
#' @md
#' @export
setMethod(
"names_RLum",
"RLum.Data.Image",
function(object) names(object@info))
Luminescence/R/read_BIN2R.R 0000644 0001762 0000144 00000121000 14762554470 015027 0 ustar ligges users #' @title Import Risø BIN/BINX-files into R
#'
#' @description Import a `*.bin` or a `*.binx` file produced by a Risø DA15 and DA20 TL/OSL
#' reader into R.
#'
#' @details
#'
#' The binary data file is parsed byte by byte following the data structure
#' published in the Appendices of the Analyst manual p. 42.
#'
#' For the general BIN/BINX-file structure, the reader is referred to the
#' Risø website: [https://www.fysik.dtu.dk]()
#'
#' @param file [character] or [list] (**required**): path and file name of the
#' BIN/BINX file (URLs are supported). If input is a `list` it should comprise
#' only `character`s representing each valid path and BIN/BINX-file names.
#' Alternatively, the input character can be just a directory (path), in which
#' case the function tries to detect and import all BIN/BINX files found in
#' the directory.
#'
#' @param show.raw.values [logical] (*with default*):
#' shows raw values from BIN-file for `LTYPE`, `DTYPE` and `LIGHTSOURCE` without
#' translation in characters. Can be provided as `list` if `file` is a `list`.
#'
#' @param n.records [numeric] (*optional*): limits the number of imported records
#' to the provided record id (e.g., `n.records = 1:10` imports the first ten records,
#' while `n.records = 3` imports only record number 3. Can be used in combination with
#' `show.record.number` for debugging purposes, e.g. corrupt BIN-files.
#' Can be provided as `list` if `file` is a `list`.
#'
#' @param zero_data.rm [logical] (*with default*):
#' remove erroneous data with no count values. As such data are usually not
#' needed for the subsequent data analysis they will be removed by default.
#' Can be provided as `list` if `file` is a `list`.
#'
#' @param duplicated.rm [logical] (*with default*):
#' remove duplicated entries if `TRUE`. This may happen due to an erroneous
#' produced BIN/BINX-file. This option compares only predecessor and successor.
#' Can be provided as `list` if `file` is a `list`.
#'
#' @param position [numeric] (*optional*):
#' imports only the selected position. Note: the import performance will not
#' benefit by any selection made here.
#' Can be provided as `list` if `file` is a `list`.
#'
#' @param fastForward [logical] (*with default*):
#' if `TRUE` for a more efficient data processing only a list of `RLum.Analysis`
#' objects is returned instead of a [Risoe.BINfileData-class] object.
#' Can be provided as `list` if `file` is a `list`.
#'
#' @param show.record.number [logical] (*with default*):
#' shows record number of the imported record, for debugging usage only.
#' Can be provided as `list` if `file` is a `list`.
#' Ignored if `verbose = FALSE`.
#'
#' @param txtProgressBar [logical] (*with default*):
#' enable/disable the progress bar. Ignored if `verbose = FALSE`.
#'
#' @param forced.VersionNumber [integer] (*optional*):
#' allows to cheat the version number check in the function by own values for
#' cases where the BIN-file version is not supported.
#' Can be provided as `list` if `file` is a `list`.
#'
#' **Note:** The usage is at own risk, only supported BIN-file versions have been tested.
#'
#' @param ignore.RECTYPE [logical] or [numeric] (*with default*):
#' this argument allows to ignore values in the byte 'RECTYPE' (BIN-file version 08),
#' in case there are not documented or faulty set. In this case the corrupted records are skipped.
#' If the setting is [numeric] (e.g., `ignore.RECTYPE = 128`), records of those type are ignored
#' for import.
#'
#' @param pattern [character] (*optional*):
#' argument that is used if only a path is provided. The argument will than be
#' passed to the function [list.files] used internally to construct a `list`
#' of wanted files
#'
#' @param verbose [logical] (*with default*):
#' enable/disable output to the terminal.
#'
#' @param ... further arguments that will be passed to the function
#' [Risoe.BINfileData2RLum.Analysis]. Please note that any matching argument
#' automatically sets `fastForward = TRUE`
#'
#' @return
#' Returns an S4 [Risoe.BINfileData-class] object containing two
#' slots:
#'
#' \item{METADATA}{A [data.frame] containing all variables stored in the BIN-file.}
#' \item{DATA}{A [list] containing a numeric [vector] of the measured data.
#' The ID corresponds to the record ID in METADATA.}
#'
#' If `fastForward = TRUE` a list of [RLum.Analysis-class] object is returned. The
#' internal coercing is done using the function [Risoe.BINfileData2RLum.Analysis]
#'
#' @note
#' The function works for BIN/BINX-format versions 03, 04, 05, 06, 07 and 08. The
#' version number depends on the used Sequence Editor.
#'
#' @section Function version: 0.18
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)\cr
#' Margret C. Fuchs, HZDR Freiberg, (Germany) \cr
#' Marco Colombo, Institute of Geography, Heidelberg University (Germany)\cr
#' based on information provided by Torben Lapp and Karsten Bracht Nielsen (Risø DTU, Denmark)
#'
#'
#' @seealso [write_R2BIN], [Risoe.BINfileData-class],
#' [base::readBin], [merge_Risoe.BINfileData], [RLum.Analysis-class]
#' [utils::txtProgressBar], [list.files]
#'
#'
#'@references
#'DTU Nutech, 2016. The Sequence Editor, Users Manual, February, 2016.
#'[https://www.fysik.dtu.dk]()
#'
#'
#'@keywords IO
#'
#'@examples
#'
#'file <- system.file("extdata/BINfile_V8.binx", package = "Luminescence")
#'temp <- read_BIN2R(file)
#'temp
#'
#' @md
#' @export
read_BIN2R <- function(
file,
show.raw.values = FALSE,
position = NULL,
n.records = NULL,
zero_data.rm = TRUE,
duplicated.rm = FALSE,
fastForward = FALSE,
show.record.number = FALSE,
txtProgressBar = TRUE,
forced.VersionNumber = NULL,
ignore.RECTYPE = FALSE,
pattern = NULL,
verbose = TRUE,
...
) {
.set_function_name("read_BIN2R")
on.exit(.unset_function_name(), add = TRUE)
# Self Call -----------------------------------------------------------------------------------
# Option (a): Input is a list, every element in the list will be treated as file connection
# with that many file can be read in at the same time
# Option (b): The input is just a path, the function tries to grep ALL BIN/BINX files in the
# directory and import them, if this is detected, we proceed as list
.validate_class(file, c("character", "list"))
if (is.character(file)) {
.validate_not_empty(file)
if (is.null(pattern)) {
##If this is not really a path we skip this here
if (all(dir.exists(file)) & length(dir(file)) > 0) {
if (verbose)
message("[read_BIN2R()] Directory detected, trying to extract ",
"'*.bin'/'*.binx' files ...\n")
##get files
file <- as.list(list.files(
path = file,
recursive = FALSE,
pattern = "\\.bin*",
full.names = TRUE,
ignore.case = TRUE))
}
}else if(dir.exists(file)){
file <- as.list(list.files(file, pattern = pattern, full.names = TRUE, recursive = TRUE))
}
}
if (is.list(file)) {
## expand input arguments
rep.length <- length(file)
position <- .listify(position, rep.length)
n.records <- .listify(n.records, rep.length)
zero_data.rm <- .listify(zero_data.rm, rep.length)
duplicated.rm <- .listify(duplicated.rm, rep.length)
show.raw.values <- .listify(show.raw.values, rep.length)
show.record.number <- .listify(show.record.number, rep.length)
forced.VersionNumber <- .listify(forced.VersionNumber, rep.length)
temp.return <- lapply(seq_along(file), function(x) {
temp <- read_BIN2R(
file = file[[x]],
fastForward = fastForward,
position = position[[x]],
n.records = n.records[[x]],
duplicated.rm = duplicated.rm[[x]],
zero_data.rm = zero_data.rm[[x]],
show.raw.values = show.raw.values[[x]],
show.record.number = show.record.number[[x]],
txtProgressBar = txtProgressBar,
forced.VersionNumber = forced.VersionNumber[[x]],
ignore.RECTYPE = ignore.RECTYPE,
verbose = verbose,
...
)
})
##return
if (fastForward) {
return(unlist(temp.return, recursive = FALSE))
}else{
return(temp.return)
}
}
## Config -----------------------------------------------------------------
.validate_length(file, 1)
.validate_logical_scalar(show.raw.values)
.validate_logical_scalar(zero_data.rm)
.validate_logical_scalar(duplicated.rm)
.validate_logical_scalar(fastForward)
.validate_logical_scalar(show.record.number)
.validate_logical_scalar(txtProgressBar)
.validate_class(ignore.RECTYPE, c("logical", "numeric"))
##set file_link for internet downloads
url_file <- NULL
on_exit <- function(){
##unlink internet connection
if(!is.null(url_file)){
unlink(url_file)
}
##close connection
if(exists("con") && !is.null(con)){
close(con)
}
}
on.exit(expr = on_exit(), add = TRUE)
## never show the progress bar if not verbose
if (!verbose) {
txtProgressBar <- FALSE
}
## check for URL and attempt download
url_file <- .download_file(file, verbose = verbose,
tempfile("read_BIN22R_FILE", fileext = ".binx"))
if(!is.null(url_file))
file <- url_file
## normalise path, just in case
file <- suppressWarnings(normalizePath(file))
## check whether file exists
info <- file.info(file)
if (is.na(info$size)) {
.throw_error("File '", file, "' does not exist")
}
## skip if zero-byte
if (info$size == 0) {
.throw_message("File '", file, "' is a zero-byte file, NULL returned")
return(NULL)
}
## check if file is a BIN or BINX file
if(!any(tolower(tools::file_ext(file)) %in% c("bin", "binx"))) {
.throw_message("File '", file, "' is not a file of type ",
"'BIN' or 'BINX', NULL returned")
con <- NULL
return(NULL)
}
##set supported BIN format version
VERSIONS.supported <- as.raw(c(03, 04, 05, 06, 07, 08))
## Short file parsing to get number of records ----------------------------
#open connection
con <- file(file, "rb")
##read data up to the end of con
##set ID
temp.ID <- 0
##start for BIN-file check up
while(length(temp.VERSION <- readBin(con, what="raw", 1, size=1, endian="little"))>0) {
## force version number
if(!is.null(forced.VersionNumber)){
temp.VERSION <- as.raw(forced.VersionNumber)
if (verbose)
message("[read_BIN2R()] 'forced.VersionNumber' set to ", temp.VERSION,
", but this version may not match your input file")
}
##stop input if wrong VERSION
if (!temp.VERSION %in% VERSIONS.supported) {
if(temp.ID > 0){
if(is.null(n.records)){
.throw_warning("BIN-file appears to be corrupt, import limited ",
"to the first ", temp.ID, " records")
}else{
.throw_warning("BIN-file appears to be corrupt, 'n.records' ",
"reset to ", temp.ID)
}
##set or reset n.records
n.records <- seq_len(temp.ID)
break()
}else{
.throw_error("BIN/BINX format version (", temp.VERSION, ") ",
"is not supported or file is broken. ",
"Supported version numbers are: ",
.collapse(VERSIONS.supported))
}
}
#empty byte position
seek.connection(con, 1, origin = "current")
## get record LENGTH
int.size <- if (temp.VERSION >= 05) 4 else 2
temp.LENGTH <- readBin(con, what = "integer", 1, size = int.size,
endian = "little")
num.toread <- max(0, temp.LENGTH - int.size - 2)
if (num.toread > 0) {
seek.connection(con, num.toread, origin = "current")
} else {
if (verbose)
message("\n[read_BIN2R()] Record #", temp.ID + 1,
" skipped due to wrong record length")
next()
}
temp.ID <- temp.ID + 1
}
##set n.length we will need it later
n.length <- temp.ID
if (n.length == 0) {
.throw_warning("0 records read, NULL returned")
return(NULL)
}
rm(temp.ID)
close(con) ##we have to close the connection here
# Set Lookup tables --------------------------------------------------------------------------
##LTYPE
LTYPE.lookup <- c(
"0" = "TL",
"1" = "OSL",
"2" = "IRSL",
"3" = "M-IR",
"4" = "M-VIS",
"5" = "TOL",
"6" = "TRPOSL",
"7" = "RIR",
"8" = "RBR",
"9" = "USER",
"10" = "POSL",
"11" = "SGOSL",
"12" = "RL",
"13" = "XRF"
)
##DTYPE
DTYPE.lookup <-
c(
"0" = "Natural",
"1" = "N+dose",
"2" = "Bleach",
"3" = "Bleach+dose",
"4" = "Natural (Bleach)",
"5" = "N+dose (Bleach)",
"6" = "Dose",
"7" = "Background"
)
##LIGHTSOURCE
LIGHTSOURCE.lookup <- c(
"0" = "None",
"1" = "Lamp",
"2" = "IR diodes/IR Laser",
"3" = "Calibration LED",
"4" = "Blue Diodes",
"5" = "White light",
"6" = "Green laser (single grain)",
"7" = "IR laser (single grain)"
)
## helper to import string from pascal format
.read_string <- function(con, field.length, force.size = NULL) {
raw <- readBin(con, what = "raw", field.length, size = 1, endian = "little")
strlen <- max(as.integer(raw[1]), 0)
if (strlen > 0) {
if (!is.null(force.size))
strlen <- force.size
return(suppressWarnings(readChar(raw[-1], strlen, useBytes = TRUE)))
}
return("")
}
##PRESET VALUES
temp.RECTYPE <- 0
##overwrite length if required
if(!is.null(n.records))
n.length <- length(n.records)
## set index for entry row in table
id_row <- 1
## 1 to 7
ID <- integer(length = n.length)
SEL <- NULL # derived from TAG
VERSION <- rep_len(NA_integer_, n.length)
LENGTH <- integer(length = n.length)
PREVIOUS <- integer(length = n.length)
NPOINTS <- integer(length = n.length)
RECTYPE <- integer(length = n.length)
## 8 to 17
RUN <- rep_len(NA_integer_, n.length)
SET <- rep_len(NA_integer_, n.length)
POSITION <- integer(n.length) # default value 0
GRAIN <- NULL # derived from GRAINNUMBER
GRAINNUMBER <- integer(n.length) # default value 0
CURVENO <- rep_len(NA_integer_, n.length)
XCOORD <- rep_len(NA_integer_, n.length)
YCOORD <- rep_len(NA_integer_, n.length)
SAMPLE <- character(length = n.length)
COMMENT <- character(length = n.length)
## 18 to 22
SYSTEMID <- rep_len(NA_integer_, n.length)
FNAME <- character(length = n.length)
USER <- character(length = n.length)
TIME <- character(length = n.length)
DATE <- character(length = n.length)
## 23 to 31
DTYPE <- character(length = n.length)
BL_TIME <- rep_len(NA_real_, n.length)
BL_UNIT <- rep_len(NA_integer_, n.length)
NORM1 <- rep_len(NA_real_, n.length)
NORM2 <- rep_len(NA_real_, n.length)
NORM3 <- rep_len(NA_real_, n.length)
BG <- rep_len(NA_real_, n.length)
SHIFT <- rep_len(NA_integer_, n.length)
TAG <- rep_len(NA_integer_, n.length)
## 32 to 67
LTYPE <- character(length = n.length)
LIGHTSOURCE <- character(length = n.length)
LPOWER <- NULL # derived from LIGHTPOWER
LIGHTPOWER <- rep_len(NA_real_, n.length)
LOW <- rep_len(NA_real_, n.length)
HIGH <- rep_len(NA_real_, n.length)
RATE <- rep_len(NA_real_, n.length)
TEMPERATURE <- rep_len(NA_real_, n.length)
MEASTEMP <- rep_len(NA_real_, n.length)
AN_TEMP <- rep_len(NA_real_, n.length)
AN_TIME <- rep_len(NA_real_, n.length)
TOLDELAY <- rep_len(NA_integer_, n.length)
TOLON <- rep_len(NA_integer_, n.length)
TOLOFF <- rep_len(NA_integer_, n.length)
IRR_TIME <- rep_len(NA_real_, n.length)
IRR_TYPE <- rep_len(NA_integer_, n.length)
IRR_UNIT <- rep_len(NA_integer_, n.length)
IRR_DOSERATE <- rep_len(NA_real_, n.length)
IRR_DOSERATEERR <- rep_len(NA_real_, n.length)
TIMESINCEIRR <- rep_len(NA_real_, n.length)
TIMETICK <- rep_len(NA_real_, n.length)
ONTIME <- rep_len(NA_real_, n.length)
OFFTIME <- rep_len(NA_real_, n.length)
STIMPERIOD <- rep_len(NA_integer_, n.length)
GATE_ENABLED <- rep_len(NA_real_, n.length)
ENABLE_FLAGS <- NULL # derived from GATE_ENABLED
GATE_START <- rep_len(NA_real_, n.length)
GATE_STOP <- rep_len(NA_real_, n.length)
PTENABLED <- rep_len(NA_real_, n.length)
DTENABLED <- rep_len(NA_real_, n.length)
DEADTIME <- rep_len(NA_real_, n.length)
MAXLPOWER <- rep_len(NA_real_, n.length)
XRF_ACQTIME <- rep_len(NA_real_, n.length)
XRF_HV <- rep_len(NA_real_, n.length)
XRF_CURR <- rep_len(NA_real_, n.length)
XRF_DEADTIMEF <- rep_len(NA_real_, n.length)
## 68 to 79
DETECTOR_ID <- rep_len(NA_integer_, n.length)
LOWERFILTER_ID <- rep_len(NA_integer_, n.length)
UPPERFILTER_ID <- rep_len(NA_integer_, n.length)
ENOISEFACTOR <- rep_len(NA_real_, n.length)
MARKPOS_X1 <- MARKPOS_Y1 <- rep_len(NA_real_, n.length)
MARKPOS_X2 <- MARKPOS_Y2 <- rep_len(NA_real_, n.length)
MARKPOS_X3 <- MARKPOS_Y3 <- rep_len(NA_real_, n.length)
EXTR_START <- rep_len(NA_real_, n.length)
EXTR_END <- rep_len(NA_real_, n.length)
## 80
SEQUENCE <- character(length = n.length)
#set variable for DPOINTS handling
results.DATA <- list()
##set list for RESERVED values
results.RESERVED <- rep(list(list()), n.length)
# Open Connection ---------------------------------------------------------
#open connection
con <- file(file, "rb")
if (verbose) {
cat("\n[read_BIN2R()] Importing ...")
cat("\n path: ", dirname(file))
cat("\n file: ", .shorten_filename(basename(file)))
cat("\n n_rec:", n.length)
cat("\n")
}
##set progress bar
if (txtProgressBar) {
pb <- txtProgressBar(min = 0, max = info$size, char = "=", style = 3)
}
##read data up to the end of con
##set ID
temp.ID <- 0
# LOOP --------------------------------------------------------------------
##start loop for import BIN data
while(length(temp.VERSION <- readBin(con, what="raw", 1, size=1, endian="little"))>0) {
##force version number
if(!is.null(forced.VersionNumber)){
temp.VERSION <- as.raw(forced.VersionNumber)
}
##print record ID for debugging purposes
if(verbose){
if(show.record.number == TRUE){
cat(temp.ID,",", sep = "")
if(temp.ID%%10==0){
cat("\n")
}
}
}
#empty byte position
seek.connection(con, 1, origin = "current")
## (1) Header size and structure
## LENGTH, PREVIOUS, NPOINTS
int.size <- if (temp.VERSION >= 05) 4 else 2
temp <- readBin(con, what = "int", 3, size = int.size, endian = "little")
temp.LENGTH <- temp[1]
temp.PREVIOUS <- temp[2]
temp.NPOINTS <- temp[3]
## skip record if not selected in n.records
## the first condition boosts the speed of reading if n.records is not used
if (!is.null(n.records) && !(temp.ID + 1) %in% n.records) {
temp.ID <- temp.ID + 1
seek.connection(con, temp.LENGTH - 3 * int.size - 2, origin = "current")
next()
}
## these must be set only after the n.records check
## we don't set VERSION now, as we must leave it set to NA in case we
## decide to skip the current record
LENGTH[id_row] <- temp.LENGTH
PREVIOUS[id_row] <- temp.PREVIOUS
NPOINTS[id_row] <- temp.NPOINTS
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## BINX FORMAT SUPPORT
if (temp.VERSION == 05 || temp.VERSION == 06 ||
temp.VERSION == 07 || temp.VERSION == 08) {
#for temp.VERSION == 08
#RECTYPE
if(temp.VERSION == 08){
temp.RECTYPE <- readBin(con, what = "int", 1, size = 1, endian = "little", signed = FALSE)
RECTYPE[id_row] <- temp.RECTYPE
## we can check for a specific value for temp.RECTYPE
if(inherits(ignore.RECTYPE[1], "numeric") && temp.RECTYPE == ignore.RECTYPE[1]) {
seek.connection(con, temp.LENGTH - 15, origin = "current")
if(verbose)
message("\n[read_BIN2R()] Record #", temp.ID + 1,
" skipped due to ignore.RECTYPE setting")
next()
}
if(temp.RECTYPE != 0 & temp.RECTYPE != 1 & temp.RECTYPE != 128) {
##jump to the next record by stepping the record length minus the already read bytes
seek.connection(con, temp.LENGTH - 15, origin = "current")
msg <- paste0("Byte RECTYPE = ", temp.RECTYPE,
" is not supported in record #", temp.ID + 1)
if (!ignore.RECTYPE) {
.throw_error(msg, ", set `ignore.RECTYPE = TRUE` to skip this record")
}
## skip to next record
if (verbose)
message("\n[read_BIN2R()] ", msg, ", record skipped")
temp.ID <- temp.ID + 1
next()
}
}
## RECTYPE == 128
## If the RECTYPE is 128, only the header bytes until here make any sense,
## the rest are just random bytes (e-mail K.B., 2024-07-04)
## the header length is 507, hence we have to jump 507 - 15 to get
## the data
## This is a very ugly construction and the function should be refactored
if (temp.RECTYPE == 128){
seek.connection(con, 492, origin = "current")
} else {
##(2) Sample characteristics
##RUN, SET, POSITION, GRAINNUMBER, CURVENO, XCOORD, YCOORD
temp <- readBin(con, what = "int", 7, size = 2, endian = "little")
RUN[id_row] <- temp[1]
SET[id_row] <- temp[2]
POSITION[id_row] <- temp[3]
GRAINNUMBER[id_row] <- temp[4]
CURVENO[id_row] <- temp[5]
XCOORD[id_row] <- temp[6]
YCOORD[id_row] <- temp[7]
##SAMPLE, COMMENT
SAMPLE[id_row] <- .read_string(con, 21)
COMMENT[id_row] <- .read_string(con, 81)
##(3) Instrument and sequence characteristic
##SYSTEMID
SYSTEMID[id_row] <- readBin(con, what = "integer", 1, size = 2, endian = "little")
## FNAME, USER, TIME, DATE
FNAME[id_row] <- .read_string(con, 101)
USER[id_row] <- .read_string(con, 31)
TIME[id_row] <- .read_string(con, 7)
DATE[id_row] <- .read_string(con, 7, force.size = 6)
##(4) Analysis
##DTYPE
DTYPE[id_row] <- readBin(con, what="int", 1, size=1, endian="little")
##BL_TIME
BL_TIME[id_row] <- readBin(con, what="double", 1, size=4, endian="little")
##BL_UNIT
BL_UNIT[id_row] <- readBin(con, what="int", 1, size=1, endian="little")
##NORM1, NORM2, NORM3, BG
temp <- readBin(con, what="double", 4, size=4, endian="little")
NORM1[id_row] <- temp[1]
NORM2[id_row] <- temp[2]
NORM3[id_row] <- temp[3]
BG[id_row] <- temp[4]
##SHIFT
SHIFT[id_row] <- readBin(con, what = "int", 1, size = 2, endian = "little")
##TAG
TAG[id_row] <- readBin(con, what = "int", 1, size = 1, endian = "little")
##RESERVED
temp.RESERVED1 <-readBin(con, what="raw", 20, size=1, endian="little")
##(5) Measurement characteristics
##LTYPE
##LTYPESOURCE
temp <- readBin(con, what = "integer", 2, size = 1, endian = "little")
LTYPE[id_row] <- temp[1]
LIGHTSOURCE[id_row] <- temp[2]
##LIGHTPOWER, LOW, HIGH, RATE
temp <- readBin(con, what="double", 4, size=4, endian="little")
LIGHTPOWER[id_row] <- temp[1]
LOW[id_row] <- temp[2]
HIGH[id_row] <- temp[3]
RATE[id_row] <- temp[4]
##TEMPERATURE
##MEASTEMP
temp <- readBin(con, what = "integer", 2, size = 2, endian = "little")
TEMPERATURE[id_row] <- temp[1]
MEASTEMP[id_row] <- temp[2]
##AN_TEMP
##AN_TIME
temp <- readBin(con, what = "double", 2, size = 4, endian = "little")
AN_TEMP[id_row] <- temp[1]
AN_TIME[id_row] <- temp[2]
##DELAY, ON, OFF
temp <- readBin(con, what="int", 3, size=2, endian="little")
TOLDELAY[id_row] <- temp[1]
TOLON[id_row] <- temp[2]
TOLOFF[id_row] <- temp[3]
##IRR_TIME
IRR_TIME[id_row] <- readBin(con, what="double", 1, size=4, endian="little")
##IRR_TYPE
IRR_TYPE[id_row] <- readBin(con, what="int", 1, size=1, endian="little")
##IRR_DOSERATE
IRR_DOSERATE[id_row] <- readBin(con, what="double", 1, size=4, endian="little")
##IRR_DOSERATEERR
if(temp.VERSION != 05)
IRR_DOSERATEERR[id_row] <- readBin(con, what="double", 1, size=4, endian="little")
##TIMESINCEIRR
TIMESINCEIRR[id_row] <- readBin(con, what="integer", 1, size=4, endian="little")
##TIMETICK
TIMETICK[id_row] <- readBin(con, what="double", 1, size=4, endian="little")
##ONTIME
##STIMPERIOD
temp <- readBin(con, what = "integer", 2, size = 4, endian = "little")
ONTIME[id_row] <- temp[1]
STIMPERIOD[id_row] <- temp[2]
##GATE_ENABLED
GATE_ENABLED[id_row] <- as.numeric(readBin(con, what="raw", 1, size=1, endian="little"))
##GATE_START
##GATE_STOP
temp <- readBin(con, what = "integer", 2, size = 4, endian = "little")
GATE_START[id_row] <- temp[1]
GATE_STOP[id_row] <- temp[2]
##PTENABLED
##DTENABLED
temp <- as.numeric(readBin(con, what = "raw", 2, size = 1, endian = "little"))
PTENABLED[id_row] <- temp[1]
DTENABLED[id_row] <- temp[2]
##DEADTIME, MAXLPOWER, XRF_ACQTIME, XRF_HV
temp <- readBin(con, what="double", 4, size=4, endian="little")
DEADTIME[id_row] <- temp[1]
MAXLPOWER[id_row] <- temp[2]
XRF_ACQTIME[id_row] <- temp[3]
XRF_HV[id_row] <- temp[4]
##XRF_CURR
XRF_CURR[id_row] <- readBin(con, what="integer", 1, size=4, endian="little")
##XRF_DEADTIMEF
XRF_DEADTIMEF[id_row] <- readBin(con, what="double", 1, size=4, endian="little")
###Account for differences between V5, V6 and V7
if(temp.VERSION == 06){
reserved2.len <- 24
}else if(temp.VERSION == 05){
reserved2.len <- 4
}else{
##DETECTOR_ID
DETECTOR_ID[id_row] <- readBin(con, what="int", 1, size=1, endian="little")
##LOWERFILTER_ID, UPPERFILTER_ID
temp <- readBin(con, what="int", 2, size=2, endian="little")
LOWERFILTER_ID[id_row] <- temp[1]
UPPERFILTER_ID[id_row] <- temp[2]
##ENOISEFACTOR
ENOISEFACTOR[id_row] <- readBin(con, what="double", 1, size=4, endian="little")
##CHECK FOR VERSION 07
if(temp.VERSION == 07){
reserved2.len <- 15
}else {
##MARKER_POSITION
###EXTR_START, EXTR_END
temp <- readBin(con, what = "double", 8, size = 4, endian = "little")
MARKPOS_X1[id_row] <- temp[1]
MARKPOS_Y1[id_row] <- temp[2]
MARKPOS_X2[id_row] <- temp[3]
MARKPOS_Y2[id_row] <- temp[4]
MARKPOS_X3[id_row] <- temp[5]
MARKPOS_Y3[id_row] <- temp[6]
EXTR_START[id_row] <- temp[7]
EXTR_END[id_row] <- temp[8]
reserved2.len <- 42
}
}# end RECTYPE 128
temp.RESERVED2 <- readBin(con, what = "raw", reserved2.len, size = 1,
endian = "little")
}
}
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## BIN FILE FORMAT SUPPORT
else if (temp.VERSION == 03 || temp.VERSION == 04) {
##LTYPE
LTYPE[id_row]<-readBin(con, what="int", 1, size=1, endian="little")
##LOW, HIGH, RATE
temp <- readBin(con, what="double", 3, size=4, endian="little")
LOW[id_row] <- temp[1]
HIGH[id_row] <- temp[2]
RATE[id_row] <- temp[3]
##XCOORD, YCOORD, TOLDELAY, TOLON, TOLOFF
temp <- readBin(con, what = "integer", 6, size = 2, endian = "little")
TEMPERATURE[id_row] <- temp[1]
XCOORD[id_row] <- temp[2]
YCOORD[id_row] <- temp[3]
TOLDELAY[id_row] <- temp[4]
TOLON[id_row] <- temp[5]
TOLOFF[id_row] <- temp[6]
##POSITION
##RUN
temp <- readBin(con, what = "integer", 2, size = 1, endian = "little",
signed = FALSE)
POSITION[id_row] <- temp[1]
RUN[id_row] <- temp[2]
## TIME, DATE, SEQUENCE, USER
TIME[id_row] <- .read_string(con, 7, force.size = 6)
DATE[id_row] <- .read_string(con, 7, force.size = 6)
SEQUENCE[id_row] <- .read_string(con, 9)
USER[id_row] <- .read_string(con, 9)
##DTYPE
DTYPE[id_row] <- readBin(con, what="int", 1, size=1, endian="little")
##IRR_TIME
IRR_TIME[id_row] <- readBin(con, what="double", 1, size=4, endian="little")
##IRR_TYPE
##IRR_UNIT
temp <- readBin(con, what = "integer", 2, size = 1, endian = "little")
IRR_TYPE[id_row] <- temp[1]
IRR_UNIT[id_row] <- temp[2]
##BL_TIME
BL_TIME[id_row] <- readBin(con, what="double", 1, size=4, endian="little")
##BL_UNIT
BL_UNIT[id_row] <- readBin(con, what="int", 1, size=1, endian="little")
##AN_TEMP, AN_TIME, NORM1, NORM2, NORM3, BG
temp <- readBin(con, what="double", 6, size=4, endian="little")
AN_TEMP[id_row] <- temp[1]
AN_TIME[id_row] <- temp[2]
NORM1[id_row] <- temp[3]
NORM2[id_row] <- temp[4]
NORM3[id_row] <- temp[5]
BG[id_row] <- temp[6]
##SHIFT
SHIFT[id_row] <- readBin(con, what="integer", 1, size=2, endian="little")
## SAMPLE, COMMENT
SAMPLE[id_row] <- .read_string(con, 21)
COMMENT[id_row] <- .read_string(con, 81)
##LIGHTSOURCE, SET, TAG
temp <- readBin(con, what="int", 3, size=1, endian="little")
LIGHTSOURCE[id_row] <- temp[1]
SET[id_row] <- temp[2]
TAG[id_row] <- temp[3]
##GRAIN
GRAINNUMBER[id_row] <- readBin(con, what="int", 1, size=2, endian="little")
##LPOWER
LIGHTPOWER[id_row] <- readBin(con, what="double", 1, size=4, endian="little")
##SYSTEMID
SYSTEMID[id_row] <- readBin(con, what="integer", 1, size=2, endian="little")
##Unfortunately an inconsitent BIN-file structure forces a differenciation ...
if(temp.VERSION == 03){
##RESERVED
temp.RESERVED1 <- readBin(con, what="raw", 36, size=1, endian="little")
##ONTIME, OFFTIME
temp <- readBin(con, what="double", 2, size=4, endian="little")
ONTIME[id_row] <- temp[1]
OFFTIME[id_row] <- temp[2]
##Enable flags #GateEnabled for v 06
GATE_ENABLED[id_row] <- as.numeric(readBin(con, what="raw", 1, size=1, endian="little"))
##ONGATEDELAY, OFFGATEDELAY
temp <- readBin(con, what="double", 2, size=4, endian="little")
GATE_START[id_row] <- temp[1]
GATE_STOP[id_row] <- temp[2]
##RESERVED
temp.RESERVED2<-readBin(con, what="raw", 1, size=1, endian="little")
}else{
##RESERVED
temp.RESERVED1<-readBin(con, what="raw", 20, size=1, endian="little")
##CURVENO
CURVENO[id_row] <- readBin(con, what="integer", 1, size=2, endian="little")
##TIMETICK
TIMETICK[id_row] <- readBin(con, what="double", 1, size=4, endian="little")
##ONTIME, STIMPERIOD
temp <- readBin(con, what="integer", 2, size=4, endian="little")
ONTIME[id_row] <- temp[1]
STIMPERIOD[id_row] <- temp[2]
##GATE_ENABLED
GATE_ENABLED[id_row] <- as.numeric(readBin(con, what="raw", 1, size=1, endian="little"))
##ONGATEDELAY, OFFGATEDELAY
temp <- readBin(con, what="double", 2, size=4, endian="little")
GATE_START[id_row] <- temp[1]
GATE_STOP[id_row] <- temp[2]
##PTENABLED
##RESERVED
temp <- readBin(con, what = "raw", 11, size = 1, endian = "little")
PTENABLED[id_row] <- as.numeric(temp[1])
temp.RESERVED2 <- temp[2:11]
}
}
## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## Unrecognised version
##
## We should already have raised a warning that the file is corrupt
## during the first scan of the BIN/BINX file: at that point we have
## set `n.records` so that we would stop reading before encountering
## again the record with unrecognised version number, so here we just
## assert that that is the case
stopifnot(temp.VERSION %in% VERSIONS.supported)
#DPOINTS
if(temp.RECTYPE != 128) {
temp.DPOINTS <- readBin(con, what = "integer", temp.NPOINTS, size = 4, endian = "little")
} else {
temp.DPOINTS <- lapply(1:temp.NPOINTS, function(x) {
list(
NOFPOINTS = readBin(con, what = "int", 1, size = 4, endian = "little"),
USEDFOR = as.logical(readBin(con, what = "raw", 48, size = 1, endian = "little")),
SHOWFOR = as.logical(readBin(con, what = "raw", 48, size = 1, endian = "little")),
ROICOLOR = readBin(con, what = "integer", 1, size = 4, endian = "little"),
X = readBin(con, what = "double", 50, size = 4, endian = "little"),
Y = readBin(con, what = "double", 50, size = 4, endian = "little"))
})
}
## ----------------------------------------------------------------------
## close the current record
temp.ID <- temp.ID + 1
ID[id_row] <- temp.ID
## we set VERSION only now to its real value: as we've got here, we have
## read the entire record and decided to keep it
VERSION[id_row] <- as.numeric(temp.VERSION)
## update the progress bar
if (txtProgressBar) {
setTxtProgressBar(pb, seek.connection(con, origin = "current"))
}
results.DATA[[id_row]] <- temp.DPOINTS
results.RESERVED[[id_row]][[1]] <- temp.RESERVED1
results.RESERVED[[id_row]][[2]] <- temp.RESERVED2
## update id row
id_row <- id_row + 1
}#endwhile::end loop
##close
if (txtProgressBar) {
close(pb)
}
## generate the final data.table
results.METADATA <- data.table(
ID,
SEL = as.logical(TAG),
VERSION,
LENGTH,
PREVIOUS,
NPOINTS,
RECTYPE,
RUN,
SET,
POSITION,
GRAIN = GRAINNUMBER,
GRAINNUMBER,
CURVENO,
XCOORD,
YCOORD,
SAMPLE,
COMMENT,
SYSTEMID,
FNAME,
USER,
TIME,
DATE,
DTYPE,
BL_TIME,
BL_UNIT,
NORM1,
NORM2,
NORM3,
BG,
SHIFT,
TAG,
LTYPE,
LIGHTSOURCE,
LPOWER = LIGHTPOWER,
LIGHTPOWER,
LOW,
HIGH,
RATE,
TEMPERATURE,
MEASTEMP,
AN_TEMP,
AN_TIME,
TOLDELAY,
TOLON,
TOLOFF,
IRR_TIME,
IRR_TYPE,
IRR_UNIT,
IRR_DOSERATE,
IRR_DOSERATEERR,
TIMESINCEIRR,
TIMETICK,
ONTIME,
OFFTIME,
STIMPERIOD,
GATE_ENABLED,
ENABLE_FLAGS = GATE_ENABLED,
GATE_START,
GATE_STOP,
PTENABLED,
DTENABLED,
DEADTIME,
MAXLPOWER,
XRF_ACQTIME,
XRF_HV,
XRF_CURR,
XRF_DEADTIMEF,
DETECTOR_ID,
LOWERFILTER_ID,
UPPERFILTER_ID,
ENOISEFACTOR,
MARKPOS_X1, MARKPOS_Y1,
MARKPOS_X2, MARKPOS_Y2,
MARKPOS_X3, MARKPOS_Y3,
EXTR_START,
EXTR_END,
SEQUENCE
)
## remove NA values created by skipping records
results.METADATA <- stats::na.omit(results.METADATA, cols = "VERSION")
##output
if(verbose)
message("\t >> ", length(results.DATA), " records read successfully\n")
## Record removals --------------------------------------------------------
## check if only the specified positions should be returned
if(!is.null(position)){
##check whether the position is valid at all
if (results.METADATA[, all(position %in% POSITION)]) {
keep.positions <- results.METADATA[, POSITION %in% position]
results.METADATA <- results.METADATA[keep.positions == TRUE, ]
results.DATA <- results.DATA[keep.positions]
results.RESERVED <- results.RESERVED[keep.positions]
if (verbose) {
message("[read_BIN2R()] Kept records matching 'position': ",
.collapse(position, quote = FALSE))
}
}else{
.throw_warning("At least one position number is not valid, ",
"valid position numbers are: ",
.collapse(results.METADATA[, unique(POSITION)],
quote = FALSE))
}
}
##check for position that have no data at all (error during the measurement)
if(zero_data.rm){
zero_data.check <- which(lengths(results.DATA) == 0)
##remove records if there is something to remove
if (length(zero_data.check) > 0) {
results.METADATA <- results.METADATA[-zero_data.check, ]
results.DATA[zero_data.check] <- NULL
results.RESERVED[zero_data.check] <- NULL
.throw_warning("Zero-data records detected and removed: ",
.collapse(zero_data.check, quote = FALSE))
}
}
## if nothing is left, return an empty object
if (nrow(results.METADATA) == 0) {
if (verbose)
message("[read_BIN2R()] Empty object returned")
return(set_Risoe.BINfileData())
}
##check for duplicated entries and remove them if wanted, but only if we have more than 2 records
##this check is skipped for results with a RECTYPE 128, which stems from camera measurements
if (n.length >= 2 && length(results.DATA) >= 2 && all(results.METADATA[["RECTYPE"]] != 128)) {
duplication.check <- suppressWarnings(which(c(
0, vapply(
2:length(results.DATA),
FUN = function(x) {
length(results.DATA[[x - 1]]) == length(results.DATA[[x]]) &&
all(results.DATA[[x - 1]] == results.DATA[[x]])
},
FUN.VALUE = 1
)
) == 1))
if (length(duplication.check) != 0) {
if (duplicated.rm) {
##remove records
results.METADATA <- results.METADATA[-duplication.check, ]
results.DATA[duplication.check] <- NULL
results.RESERVED[duplication.check] <- NULL
##message
if(verbose) {
message("[read_BIN2R()] Duplicated records detected and removed: ",
.collapse(duplication.check, quote = FALSE))
}
} else{
.throw_warning("Duplicated records detected: ",
.collapse(duplication.check, quote = FALSE),
"\n >> You should consider using 'duplicated.rm = TRUE'.")
}
}
}
## recalculate ID as some records may not have been read if n.records
## was set or they were dropped in one of the previous blocks
if (results.METADATA[, .N != n.length || max(ID) > n.length]) {
results.METADATA[, ID := 1:.N]
if (verbose)
message("[read_BIN2R()] The record index has been recalculated")
}
# Convert Translation Matrix Values ---------------------------------------
if (!show.raw.values) {
##LIGHTSOURCE CONVERSION
results.METADATA[, LIGHTSOURCE := unname(LIGHTSOURCE.lookup[LIGHTSOURCE])]
##LTYPE CONVERSION
results.METADATA[, LTYPE := unname(LTYPE.lookup[LTYPE])]
##DTYPE CONVERSION
results.METADATA[, DTYPE := unname(DTYPE.lookup[DTYPE])]
## check for oddly set LTYPES, this may happen in old BIN-file versions
if (results.METADATA$VERSION[1] == 3) {
results.METADATA[LTYPE == "OSL" & LIGHTSOURCE == "IR diodes/IR Laser",
LTYPE := "IRSL"]
}
##TIME CONVERSION, do not do for odd time formats as this could cause problems during export
results.METADATA[nchar(TIME) == 5,
TIME := paste0("0", TIME)]
results.METADATA[nchar(TIME) == 6,
TIME := format(as.POSIXct(TIME, format = "%H%M%S"),
"%H:%M:%S")]
}
## check for empty BIN-files names ... if so, set the name of the file as BIN-file name
## This can happen if the user uses different equipment
if (results.METADATA[, all(is.na(FNAME))]) {
results.METADATA[, FNAME := tools::file_path_sans_ext(basename(file))]
}
## produce S4 object for output
object <- set_Risoe.BINfileData(
METADATA = results.METADATA,
DATA = results.DATA,
.RESERVED = results.RESERVED)
## Fast Forward -----------------------------------------------------------
## set fastForward to TRUE if arguments to Risoe.BINfileData2RLum.Analysis
## were specified
if (!fastForward) {
dots <- names(list(...))
args <- dots[dots %in% names(formals(Risoe.BINfileData2RLum.Analysis))[-1]]
if (length(args) > 0) {
fastForward <- TRUE
.throw_warning("Additional arguments specified: ", .collapse(args),
", setting 'fastForward = TRUE'")
}
}
##return values
##with fast fastForward they will be converted directly to a list of RLum.Analysis objects
if(fastForward){
object <- Risoe.BINfileData2RLum.Analysis(object, ...)
##because we expect a list
if(!inherits(object, "list"))
object <- list(object)
}
return(object)
}
Luminescence/R/calc_gSGC.R 0000644 0001762 0000144 00000030274 14762554470 015001 0 ustar ligges users #' @title Calculate De value based on the gSGC by Li et al., 2015
#'
#' @description Function returns De value and De value error using the global standardised growth
#' curve (gSGC) assumption proposed by Li et al., 2015 for OSL dating of sedimentary quartz
#'
#' @details
#' The error of the De value is determined using a Monte Carlo simulation approach.
#' Solving of the equation is realised using [uniroot].
#' Large values for `n.MC` will significantly increase the computation time.
#'
#'
#' @param data [data.frame] (**required**):
#' input data of providing the following columns: `LnTn`, `LnTn.error`, `Lr1Tr1`, `Lr1Tr1.error`, `Dr1`
#' **Note:** column names are not required. The function expects the input data in the given order
#'
#' @param gSGC.type [character] (*with default*):
#' define the function parameters that
#' should be used for the iteration procedure: Li et al., 2015 (Table 2)
#' presented function parameters for two dose ranges: `"0-450"` and `"0-250"`
#'
#' @param gSGC.parameters [list] (*optional*):
#' option to provide own function parameters used for fitting as named list.
#' Nomenclature follows Li et al., 2015, i.e. `list(A, A.error, D0, D0.error,
#' c, c.error, Y0, Y0.error, range)`, where `range` is defines the interval
#' where the function is considered as valid, e.g. `range = c(0,250)`.\cr
#' Using this option overwrites the default parameter list of the gSGC, meaning the argument
#' `gSGC.type` will be without effect
#'
#' @param n.MC [integer] (*with default*):
#' number of Monte Carlo simulation runs for error estimation, see details.
#'
#' @param verbose [logical] (*with default*):
#' enable/disable output to the terminal.
#'
#' @param plot [logical] (*with default*):
#' enable/disable the plot output.
#'
#' @param ... parameters will be passed to the plot output
#'
#' @return Returns an S4 object of type [RLum.Results-class].
#'
#' **`@data`**\cr
#' `$ De.value` ([data.frame]) \cr
#' `.. $ De` \cr
#' `.. $ De.error` \cr
#' `.. $ Eta` \cr
#' `$ De.MC` ([list]) contains the matrices from the error estimation.\cr
#' `$ uniroot` ([list]) contains the [uniroot] outputs of the De estimations\cr
#'
#' **`@info`**\cr
#' `$ call`` ([call]) the original function call
#'
#'
#' @section Function version: 0.1.1
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum.Results-class], [get_RLum], [uniroot]
#'
#' @references
#' Li, B., Roberts, R.G., Jacobs, Z., Li, S.-H., 2015. Potential of establishing
#' a 'global standardised growth curve' (gSGC) for optical dating of quartz from sediments.
#' Quaternary Geochronology 27, 94-104. doi:10.1016/j.quageo.2015.02.011
#'
#' @keywords datagen
#'
#' @examples
#'
#' results <- calc_gSGC(data = data.frame(
#' LnTn = 2.361, LnTn.error = 0.087,
#' Lr1Tr1 = 2.744, Lr1Tr1.error = 0.091,
#' Dr1 = 34.4))
#'
#' get_RLum(results, data.object = "De")
#'
#' @md
#' @export
calc_gSGC<- function(
data,
gSGC.type = "0-250",
gSGC.parameters,
n.MC = 100,
verbose = TRUE,
plot = TRUE,
...
) {
.set_function_name("calc_gSGC")
on.exit(.unset_function_name(), add = TRUE)
## Integrity checks -------------------------------------------------------
.validate_class(data, "data.frame")
if (ncol(data) != 5)
.throw_error("'data' is expected to have 5 columns")
gSGC.type <- .validate_args(gSGC.type, c("0-250", "0-450"))
##rename columns for consistency reasons
colnames(data) <- c('LnTn', 'LnTn.error', 'Lr1Tr1', 'Lr1Tr1.error', 'Dr1')
## ensure errors are not negative
data$LnTn.error <- abs(data$LnTn.error)
data$Lr1Tr1.error <- abs(data$Lr1Tr1.error)
##============================================================================##
##DEFINE FUNCTION
##============================================================================##
##define function, nomenclature according to publication that should be solved
f <- function(x,A,D0,c,Y0,Dr1,Lr1Tr1,LnTn) {
(((A * (1 - exp( - Dr1 / D0))) + c * Dr1 + Y0)/Lr1Tr1) -
(((A * (1 - exp( - x/D0))) + c * x + Y0)/LnTn)
}
##set general parameters
if (!missing(gSGC.parameters)) {
A <- gSGC.parameters$A
A.error <- gSGC.parameters$A.error
D0 <- gSGC.parameters$D0
D0.error <- gSGC.parameters$D0.error
c <- gSGC.parameters$c
c.error <- gSGC.parameters$c.error
Y0 <- gSGC.parameters$Y0
Y0.error <- gSGC.parameters$Y0.error
range <- gSGC.parameters$range
}else{
if (gSGC.type == "0-450") {
A <- 0.723
A.error <- 0.014
D0 <- 65.1
D0.error <- 0.9
c <- 0.001784
c.error <- 0.000016
Y0 <- 0.009159
Y0.error <- 0.004795
range <- c(0.1,250)
}else if (gSGC.type == "0-250") {
A <- 0.787
A.error <- 0.051
D0 <- 73.9
D0.error <- 2.2
c <- 0.001539
c.error <- 0.000068
Y0 <- 0.01791
Y0.error <- 0.00490
range <- c(0.1,250)
}
}
##Define size of output objects
output.data <- data.table::data.table(
DE = numeric(length = nrow(data)),
DE.ERROR = numeric(length = nrow(data)),
ETA = numeric(length = nrow(data))
)
##set list for De.MC
output.De.MC <- vector("list", nrow(data))
##set list for uniroot
output.uniroot <- vector("list", nrow(data))
##============================================================================##
##CALCULATION
##============================================================================##
for(i in 1:nrow(data)){
Lr1Tr1 <- data[i, "Lr1Tr1"]
Lr1Tr1.error <- data[i,"Lr1Tr1.error"]
Dr1 <- data[i,"Dr1"]
Dr1.error <- data[i,"Dr1.error"]
LnTn <- data[i,"LnTn"]
LnTn.error <- data[i,"LnTn.error"]
##calculate mean value
temp <- try(uniroot(
f,
interval = c(0.1,450),
tol = 0.001,
A = A,
D0 = D0,
c = c,
Y0 = Y0,
Dr1 = Dr1,
Lr1Tr1 = Lr1Tr1,
LnTn = LnTn,
extendInt = 'yes',
check.conv = TRUE,
maxiter = 1000
), silent = TRUE)
if(!inherits(temp, "try-error")){
##get De
De <- temp$root
##calculate Eta, which is the normalisation factor
Eta <- ((A * (1 - exp( - Dr1 / D0))) + c * Dr1 + Y0)/Lr1Tr1
##--------------------------------------------------------------------------##
##Monte Carlo simulation for error estimation
##set matrix
temp.MC.matrix <- matrix(nrow = n.MC, ncol = 8)
##fill matrix
temp.MC.matrix[,1:6] <- matrix(rnorm(
n.MC * 6,
mean = c(LnTn, Lr1Tr1, A, D0, c, Y0),
sd = c(LnTn.error, Lr1Tr1.error, A.error, D0.error, c.error, Y0.error)
), ncol = 6, byrow = TRUE)
##run uniroot to get the De
temp.MC.matrix[,7] <- vapply(X = 1:n.MC, FUN = function(x){
uniroot(f,
interval = c(0.1,450),
tol = 0.001,
A = temp.MC.matrix[x,3],
D0 = temp.MC.matrix[x,4],
c = temp.MC.matrix[x,5],
Y0 = temp.MC.matrix[x,6],
Dr1 = Dr1,
Lr1Tr1 =temp.MC.matrix[x,2],
LnTn = temp.MC.matrix[x,1],
check.conv = TRUE,
extendInt = 'yes',
maxiter = 1000
)$root
}, FUN.VALUE = vector(mode = "numeric", length = 1))
##calculate also the normalisation factor
temp.MC.matrix[,8] <- (temp.MC.matrix[,3] * (1 - exp( - Dr1 / temp.MC.matrix[,4])) +
temp.MC.matrix[,5] * Dr1 + temp.MC.matrix[,6])/temp.MC.matrix[,2]
##re-name matrix
colnames(temp.MC.matrix) <- c("LnTn","Lr1Tr1","A","D0","c","Y0","De","Eta")
##get De error as SD
De.error <- sd(temp.MC.matrix[,7])
}else{
.throw_warning("No solution was found")
De <- NA
Eta <- NA
De.error <- NA
##set matrix
temp.MC.matrix <- matrix(nrow = n.MC, ncol = 8)
##fill matrix
temp.MC.matrix[,1:6] <- matrix(rnorm(
n.MC * 6,
mean = c(LnTn, Lr1Tr1, A, D0, c, Y0),
sd = c(LnTn.error, Lr1Tr1.error, A.error, D0.error, c.error, Y0.error)
), ncol = 6, byrow = TRUE)
}
# Plot output -------------------------------------------------------------
if (plot) {
##set plot settings
plot.settings <- list(
main = "gSGC and resulting De",
xlab = "Dose [a.u.]",
ylab = expression(paste("Re-norm. ", L[x]/T[x])),
xlim = NULL,
ylim = NULL,
lwd = 1,
lty = 1,
pch = 21,
col = "red",
grid = expression(nx = 10, ny = 10),
mtext = ""
)
plot.settings <- modifyList(plot.settings, list(...))
##graphical feedback
x <- NA
curve(
A * (1 - exp(-x / D0)) + c * x + Y0, from = 0, to = 500,
xlab = plot.settings$xlab,
ylab = plot.settings$ylab,
main = plot.settings$main,
xlim = plot.settings$xlim,
ylim = plot.settings$ylim,
lwd = plot.settings$lwd,
lty = plot.settings$lty
)
mtext(side = 3, plot.settings$mtext)
if(!is.null(plot.settings$grid)){
graphics::grid(eval(plot.settings$grid))
}
if(!inherits(temp, "try-error")){
if(temp$root < 450 & temp$root > 0){
points(temp$root,Eta*LnTn, col = plot.settings$col, pch = plot.settings$pch)
segments(De - De.error,Eta * LnTn,
De + De.error,Eta * LnTn)
hist <-
hist(
temp.MC.matrix[, 7],
freq = FALSE,
add = TRUE,
col = rgb(0, 0, 0, 0.2),
border = rgb(0, 0, 0, 0.5)
)
lines(hist$mids,hist$density)
}else{
if(temp$root < 450){
shape::Arrows(
x0 = 450,
y0 = par()$usr[4] - 0.2,
x1 = 500,
y1 = par()$usr[4] - 0.2,
arr.type = "triangle",
col = "red"
)
}else{
shape::Arrows(
x0 = 50,
y0 = par()$usr[4] - 0.2,
x1 = 0,
y1 = par()$usr[4] - 0.2,
arr.type = "triangle",
col = "red"
)
}
mtext(side = 1, text = "Out of bounds!", col = "red")
}
}else{
mtext(side = 1, text = "No solution found!", col = "red")
}
}
# Terminal output ---------------------------------------------------------
if (verbose) {
cat("\n[calc_gSGC()]")
cat("\n Corresponding De based on the gSGC\n")
cat(paste0("\n"," Ln/Tn:\t\t ",LnTn," \u00B1 ", LnTn.error,"\n"))
cat(paste0(""," Lr1/Tr1:\t ",Lr1Tr1," \u00B1 ", Lr1Tr1.error,"\n"))
cat(paste0(""," Dr1:\t\t ",Dr1,"\n"))
cat(paste0(""," f(D):\t\t ",A," * (1 - exp(-D /",D0,")) + c * D + ",Y0,"\n"))
cat(paste0(""," n.MC:\t\t ",n.MC,"\n"))
cat(paste0(" ------------------------------ \n"))
cat(paste0(" De:\t\t",round(De,digits = 2)," \u00B1 ",round(De.error,digits = 2),"\n"))
cat(paste0(" ------------------------------ \n"))
}
##============================================================================##
##CREATE OUTPUT OBJECTS
##============================================================================##
##needed for data.table
temp.De <- De
temp.De.error <- De.error
temp.Eta <- Eta
##replace values in the data.table with values
output.data[i, `:=` (DE = temp.De,
DE.ERROR = temp.De.error,
ETA = temp.Eta)]
rm(list = c('temp.De', 'temp.De.error', 'temp.Eta'))
##matrix - to prevent memory overload limit output
if(n.MC * nrow(data) > 1e6){
# nocov start
if(i == 1){
output.De.MC[[i]] <- temp.MC.matrix
}else{
output.De.MC[[i]] <- NA
}
.throw_warning("Only the first MC matrix is returned to prevent ",
"memory overload")
# nocov end
}else{
output.De.MC[[i]] <- temp.MC.matrix
}
output.uniroot[[i]] <- temp
}##end for loop
##============================================================================##
##OUTPUT RLUM
##============================================================================##
temp.RLum.Results <- set_RLum(
class = "RLum.Results",
data = list(
De = as.data.frame(output.data),
De.MC = output.De.MC,
uniroot = output.uniroot
),
info = list( call = sys.call())
)
return(temp.RLum.Results)
}
Luminescence/R/apply_Crosstalk.R 0000644 0001762 0000144 00000007110 14762554470 016377 0 ustar ligges users #' @title Apply crosstalk
#'
#' @description Add crosstalk, evenly spread in rook (top-right-bottom-left)
#' directions, to all grain whole locations on one measurement discs
#' (=on position on a measurement wheel in a reader). An
#' added crosstalk value of as example 0.2 means that 0.2 of the value of
#' the central grain is added to each grain in the rook directions. This is an additive
#' action: the central grain itself is not affected by this operation (but will on its
#' turn increase because of crosstalk from its neighbours).
#' This function is used for simulations: can this added crosstalk be detected?
#'
#' @details If an element in `object` is `NA`, it is internally set to 0, so it will not
#' be added.
#'
#' @param object [RLum.Results-class] or [numeric] (**required**): containing
#' a numerical vector of length 100, representing one or more measurement
#' discs ("positions") in a reader.
#' Each element in the vector represents one grain hole location on a disc.
#'
#' @param n_crosstalk [numeric] (*with default*): A single number quantifying the added
#' crosstalk. Defaults for testing purposes to 0.2. Can be any number, even negative,
#' but for realistic simulations we suggest something between 0 and 0.25.
#'
#' @keywords manip
#'
#' @return A vector of size 100, with the value at each grain hole location including simulated crosstalk.
#'
#' @author Anna-Maartje de Boer, Luc Steinbuch, Wageningen University & Research, 2025
#'
#' @references
#' de Boer, A-M., Steinbuch, L., Heuvelink, G.B.M., Wallinga, J., 2025.
#' A novel tool to assess crosstalk in single-grain luminescence detection.
#' Submitted.
#'
#' @examples
#' ## Create artificial disc observation
#' observations <- set_RLum(class = "RLum.Results",
#' data = list(vn_values = rep(x = c(1,2), each = 50))
#' )
#' hist(get_RLum(object = observations))
#'
#' ## Add crosstalk (with default set to 0.2), and visualize the difference
#' ## in the resulting histogram.
#' observations_with_simulated_crosstalk <- apply_Crosstalk(observations)
#' hist(observations_with_simulated_crosstalk)
#'
#' @md
#' @export
apply_Crosstalk <- function(object,
n_crosstalk = 0.2
) {
.set_function_name("apply_Crosstalk")
on.exit(.unset_function_name(), add = TRUE)
## Integrity checks -------------------------------------------------------
.validate_class(object, c("RLum.Results", "numeric", "integer"))
if (is.numeric(object)){
vn_values <- object
} else {
vn_values <- get_RLum(object)
}
.validate_length(vn_values, 100, name = "'object'")
.validate_class(n_crosstalk, c("numeric"))
.validate_length(n_crosstalk, 1)
vb_na_s <- is.na(vn_values)
vn_values[vb_na_s] <- 0
## Prepare multiplication matrix -----------------------
## Note: the physical appearance of a measurement disc,
## 10x10 grains, is hard coded here
df_disc_locations <- data.frame(location = 1:100,
x = rep(1:10, times = 10),
y = rep(1:10, each = 10))
# Calculate matrix with euclidean distances
mn_dist <- as.matrix(stats::dist(df_disc_locations[, c("x", "y")]))
## All distances equal to one are subject to crosstalk
mn_crosstalk <- ifelse(mn_dist == 1, yes = n_crosstalk, no = 0)
## The diagonal -- all distances equal to zero -- are one
diag(mn_crosstalk) <- 1
## Matrix calculations -----------------------
vn_sig_with_crosstalk <- as.numeric(mn_crosstalk %*% vn_values)
## Assign original NA's to output
vn_sig_with_crosstalk[vb_na_s] <- NA
return(vn_sig_with_crosstalk)
}
Luminescence/R/Analyse_SAR.OSLdata.R 0000644 0001762 0000144 00000064537 14762554470 016634 0 ustar ligges users #' @title Analyse SAR CW-OSL measurements (deprecated)
#'
#' @description The function analyses SAR CW-OSL curve data and provides a summary of the
#' measured data for every position. The output of the function is optimised
#' for SAR OSL measurements on quartz.
#'
#' The function works only for standard SAR protocol measurements introduced by
#' Murray and Wintle (2000) with CW-OSL curves. For the calculation of the
#' Lx/Tx value the function [calc_OSLLxTxRatio] is used.
#'
#' **Provided rejection criteria**
#'
#' `[recyling ratio]`: calculated for every repeated regeneration dose point.
#'
#' `[recuperation]`: recuperation rate calculated by comparing the `Lx/Tx` values of the zero
#' regeneration point with the `Ln/Tn` value (the `Lx/Tx` ratio of the natural
#' signal). For methodological background see Aitken and Smith (1988)
#'
#' `[IRSL/BOSL]`: the integrated counts (`signal.integral`) of an
#' IRSL curve are compared to the integrated counts of the first regenerated
#' dose point. It is assumed that IRSL curves got the same dose as the first
#' regenerated dose point. **Note:** This is not the IR depletion ratio
#' described by Duller (2003).
#'
#' @param input.data [Risoe.BINfileData-class] (**required**):
#' input data from a Risø BIN file, produced by the function [read_BIN2R].
#'
#' @param signal.integral [vector] (**required**):
#' channels used for the signal integral, e.g. `signal.integral=c(1:2)`
#'
#' @param background.integral [vector] (**required**):
#' channels used for the background integral, e.g. `background.integral=c(85:100)`
#'
#' @param position [vector] (*optional*):
#' reader positions that want to be analysed (e.g. `position=c(1:48)`.
#' Empty positions are automatically omitted. If no value is given all
#' positions are analysed by default.
#'
#' @param run [vector] (*optional*):
#' range of runs used for the analysis. If no value is given the range of the
#' runs in the sequence is deduced from the `Risoe.BINfileData` object.
#'
#' @param set [vector] (*optional*):
#' range of sets used for the analysis. If no value is given the range of the
#' sets in the sequence is deduced from the `Risoe.BINfileData` object.
#'
#' @param dtype [character] (*optional*):
#' allows to further limit the curves by their data type (`DTYPE`),
#' e.g., `dtype = c("Natural", "Dose")` limits the curves to this two data types.
#' By default all values are allowed.
#' See [Risoe.BINfileData-class] for allowed data types.
#'
#' @param keep.SEL [logical] (default):
#' option allowing to use the `SEL` element of the [Risoe.BINfileData-class] manually.
#' **NOTE:** In this case any limitation provided by `run`, `set` and `dtype`
#' are ignored!
#'
#' @param info.measurement [character] (*with default*):
#' option to provide information about the measurement on the plot
#' output (e.g. name of the BIN or BINX file).
#'
#' @param output.plot [logical] (*with default*):
#' enable/disable the plot output.
#'
#' @param plot_singlePanels [logical] (*with default*):
#' single plot output (`TRUE/FALSE`) to allow for plotting the results in
#' single plot windows. Requires `output.plot = TRUE`.
#'
#' @param cex.global [numeric] (*with default*):
#' global scaling factor.
#'
#' @param ... further arguments that will be passed to the function
#' [calc_OSLLxTxRatio] (supported: `background.count.distribution`, `sigmab`,
#' `sig0`; e.g., for instrumental error) and can be used to adjust the plot.
#' Supported" `mtext`, `log`
#'
#' @return
#' A plot (*optional*) and [list] is returned containing the
#' following elements:
#'
#' \item{LnLxTnTx}{[data.frame] of all calculated Lx/Tx values including signal, background counts and the dose points.}
#' \item{RejectionCriteria}{[data.frame] with values that might by used as rejection criteria. NA is produced if no R0 dose point exists.}
#' \item{SARParameters}{[data.frame] of additional measurement parameters obtained from the BIN file, e.g. preheat or read temperature
#' (not valid for all types of measurements).}
#'
#'
#' @note
#' Rejection criteria are calculated but not considered during the
#' analysis to discard values.
#'
#' **The analysis of IRSL data is not directly supported**. You may want to
#' consider using the functions [analyse_SAR.CWOSL] or
#' [analyse_pIRIRSequence] instead.
#'
#' **The development of this function will not be continued. We recommend to use the function [analyse_SAR.CWOSL] or instead.**
#'
#'
#' @section Function version: 0.2.18
#'
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)\cr
#' Margret C. Fuchs, HZDR, Freiberg (Germany)
#'
#' @seealso [calc_OSLLxTxRatio], [Risoe.BINfileData-class], [read_BIN2R], [fit_DoseResponseCurve]
#'
#' @references
#' Aitken, M.J. and Smith, B.W., 1988. Optical dating: recuperation
#' after bleaching. Quaternary Science Reviews 7, 387-393.
#'
#' Duller, G., 2003. Distinguishing quartz and feldspar in single grain
#' luminescence measurements. Radiation Measurements, 37 (2), 161-165.
#'
#' Murray, A.S. and Wintle, A.G., 2000. Luminescence dating of quartz using an
#' improved single-aliquot regenerative-dose protocol. Radiation Measurements
#' 32, 57-73.
#'
#' @keywords datagen dplot
#'
#' @examples
#' ##load data
#' data(ExampleData.BINfileData, envir = environment())
#'
#' ##analyse data
#' suppressWarnings( # silence the deprecation warning
#' output <- Analyse_SAR.OSLdata(input.data = CWOSL.SAR.Data,
#' signal.integral = c(1:5),
#' background.integral = c(900:1000),
#' position = c(1:1),
#' output.plot = TRUE)
#' )
#'
#' ##combine results relevant for further analysis
#' output.SAR <- data.frame(Dose = output$LnLxTnTx[[1]]$Dose,
#' LxTx = output$LnLxTnTx[[1]]$LxTx,
#' LxTx.Error = output$LnLxTnTx[[1]]$LxTx.Error)
#' output.SAR
#'
#' @md
#' @export
Analyse_SAR.OSLdata <- function(
input.data,
signal.integral,
background.integral,
position,
run,
set,
dtype,
keep.SEL = FALSE,
info.measurement = "unknown measurement",
output.plot = FALSE,
plot_singlePanels = FALSE,
cex.global = 1,
...
) {
.Deprecated("analyse_SAR.CWOSL")
.set_function_name("Analyse_SAR.OSLdata")
on.exit(.unset_function_name(), add = TRUE)
##============================================================================##
##CONFIG
##============================================================================##
##set colors gallery to provide more colors
col <- get("col", pos = .LuminescenceEnv)
##============================================================================##
##ERROR HANDLING
##============================================================================##
.validate_class(input.data, c("Risoe.BINfileData"))
sample.data <- input.data
if (missing(signal.integral)) {
.throw_error("No signal integral is given")
}
if (missing(background.integral)) {
.throw_error("No background integral is given")
}
##set values for run and set if they are not defined by the user
if(missing(position)==TRUE){position<-min(sample.data@METADATA[,"POSITION"]):max(sample.data@METADATA[,"POSITION"])}
if(missing(run)==TRUE){run<-min(sample.data@METADATA[,"RUN"]):max(sample.data@METADATA[,"RUN"])}
if(missing(set)==TRUE){set<-min(sample.data@METADATA[,"SET"]):max(sample.data@METADATA[,"SET"])}
if(missing(dtype)){dtype <- c("Natural",
"N+dose",
"Bleach",
"Bleach+dose",
"Natural (Bleach)",
"N+dose (Bleach)",
"Dose",
"Background")}
# Deal with extra arguments ----------------------------------------------------
##deal with addition arguments
extraArgs <- list(...)
background.count.distribution <-
if ("background.count.distribution" %in% names(extraArgs)) {
extraArgs$background.count.distribution
} else
{
"non-poisson"
}
sigmab <- if("sigmab" %in% names(extraArgs)) {extraArgs$sigmab} else
{NULL}
##============================================================================##
##CALCULATIONS
##============================================================================##
##loop over all positions
for (i in position){
##checking if position is valid
if(length(which(sample.data@METADATA["POSITION"]==i))>0){
##check if OSL curves are part of the data set
if(nrow(sample.data@METADATA[sample.data@METADATA[,"LTYPE"]=="OSL",]) == 0){
.throw_error("No 'OSL' curves found")
}
if(!keep.SEL){
##select all OSL data depending on the run and set
sample.data@METADATA[,"SEL"]<-FALSE
sample.data@METADATA[sample.data@METADATA[,"LTYPE"]=="OSL" &
sample.data@METADATA[,"RUN"]%in%run==TRUE &
sample.data@METADATA[,"SET"]%in%set==TRUE &
sample.data@METADATA[,"DTYPE"]%in%dtype==TRUE, "SEL"] <- TRUE
}
##grep all OSL curve IDs
OSL.curveID<-sample.data@METADATA[sample.data@METADATA["SEL"]==TRUE &
sample.data@METADATA["POSITION"]==i,"ID"]
##estimate LnLx.curveID and TnTx.curveID from records
LnLx.curveID<-OSL.curveID[seq(1,length(OSL.curveID),by=2)]
TnTx.curveID<-OSL.curveID[seq(2,length(OSL.curveID),by=2)]
##Provide Values For Growth Curve Fitting
##(1) get dose information
Dose<-sapply(1:length(LnLx.curveID),function(x){
Dose<-sample.data@METADATA[sample.data@METADATA["ID"]==LnLx.curveID[x],"IRR_TIME"]
})
##(2) set LxTx curves
LnLxTnTx.curves<-(sapply(1:length(LnLx.curveID),function(x){
##produce data.frames for Lx/Tx calculations
Lx.HIGH<-sample.data@METADATA[sample.data@METADATA[,"ID"]==LnLx.curveID[x],"HIGH"]
Lx.NPOINTS<-sample.data@METADATA[sample.data@METADATA[,"ID"]==LnLx.curveID[x],"NPOINTS"]
Tx.HIGH<-sample.data@METADATA[sample.data@METADATA[,"ID"]==TnTx.curveID[x],"HIGH"]
Tx.NPOINTS<-sample.data@METADATA[sample.data@METADATA[,"ID"]==TnTx.curveID[x],"NPOINTS"]
Lx.curve<-data.frame(x=seq(Lx.HIGH/Lx.NPOINTS,Lx.HIGH,by=Lx.HIGH/Lx.NPOINTS),
y=unlist(sample.data@DATA[LnLx.curveID[x]]))
Tx.curve<-data.frame(x=seq(Tx.HIGH/Tx.NPOINTS,Tx.HIGH,by=Tx.HIGH/Tx.NPOINTS),
y=unlist(sample.data@DATA[TnTx.curveID[x]]))
return(list(Lx.curve,Tx.curve))
}))
##(3) calculate Lx/Tx ratio
LnLxTnTx <- get_RLum(
merge_RLum(lapply(1:length(LnLxTnTx.curves[1, ]), function(k) {
calc_OSLLxTxRatio(
Lx.data = as.data.frame(LnLxTnTx.curves[1, k]),
Tx.data = as.data.frame(LnLxTnTx.curves[2, k]),
signal.integral = signal.integral,
background.integral = background.integral,
background.count.distribution = background.count.distribution,
sigmab = sigmab
)
})))
##finally combine to data.frame including the record ID for further analysis
LnLxTnTx <- cbind(LnLxTnTx,LnLx.curveID,TnTx.curveID)
##(4.1) set info concerning the kind of regeneration points
##generate unique dose id - this are also the # for the generated points
temp.DoseID<-c(0:(length(Dose)-1))
temp.DoseName<-paste("R",temp.DoseID,sep="")
temp.DoseName<-cbind(Name=temp.DoseName,Dose)
##set natural
temp.DoseName[temp.DoseName[,"Name"]=="R0","Name"]<-"Natural"
##set R0
temp.DoseName[temp.DoseName[,"Name"]!="Natural" & temp.DoseName[,"Dose"]==0,"Name"]<-"R0"
##find duplicated doses (including 0 dose - which means the Natural)
temp.DoseDuplicated<-duplicated(temp.DoseName[,"Dose"])
##combine temp.DoseName
temp.DoseName<-cbind(temp.DoseName,Repeated=temp.DoseDuplicated)
##correct value for R0 (it is not really repeated)
temp.DoseName[temp.DoseName[,"Dose"]==0,"Repeated"]<-FALSE
##(5) Combine all values in a data.frame
temp.LnLxTnTx<-data.frame(Name=temp.DoseName[,"Name"],
Dose=Dose,
Repeated=as.logical(temp.DoseName[,"Repeated"]))
LnLxTnTx<-cbind(temp.LnLxTnTx,LnLxTnTx)
LnLxTnTx[,"Name"]<-as.character(LnLxTnTx[,"Name"])
##(6) Calculate Recyling Ratio and Recuperation Rate
##(6.1)
##Calculate Recycling Ratio
if(length(LnLxTnTx[LnLxTnTx[,"Repeated"]==TRUE,"Repeated"])>0){
##identify repeated doses
temp.Repeated<-LnLxTnTx[LnLxTnTx[,"Repeated"]==TRUE,c("Name","Dose","LxTx")]
##find corresponding previous dose for the repeated dose
temp.Previous<-t(sapply(1:length(temp.Repeated[,1]),function(x){
LnLxTnTx[LnLxTnTx[,"Dose"]==temp.Repeated[x,"Dose"] &
LnLxTnTx[,"Repeated"]==FALSE,c("Name","Dose","LxTx")]
}))
##convert to data.frame
temp.Previous<-as.data.frame(temp.Previous)
##set column names
temp.ColNames<-sapply(1:length(temp.Repeated[,1]),function(x){
paste(temp.Repeated[x,"Name"],"/",
temp.Previous[temp.Previous[,"Dose"]==temp.Repeated[x,"Dose"],"Name"]
,sep="")
})
##Calculate Recycling Ratio
RecyclingRatio<-as.numeric(temp.Repeated[,"LxTx"])/as.numeric(temp.Previous[,"LxTx"])
##Just transform the matrix and add column names
RecyclingRatio<-t(RecyclingRatio)
colnames(RecyclingRatio) <- unique(temp.ColNames)
}else{RecyclingRatio<-NA}
##(6.2)
##Recuperation Rate
if("R0" %in% LnLxTnTx[,"Name"]==TRUE){
Recuperation<-round(LnLxTnTx[LnLxTnTx[,"Name"]=="R0","LxTx"]/LnLxTnTx[LnLxTnTx[,"Name"]=="Natural","LxTx"],digits=4)
}else{Recuperation<-NA}
##(6.3) IRSL
##Print IRSL Curves if IRSL curve is set
sample.data@METADATA[,"SEL"]<-FALSE
sample.data@METADATA[sample.data@METADATA["LTYPE"]=="IRSL" &
sample.data@METADATA[,"RUN"]%in%run==TRUE &
sample.data@METADATA[,"SET"]%in%set==TRUE,"SEL"]<-TRUE
##get IRSL curve ID & ID for Reg1 again
IRSL.curveID<-sample.data@METADATA[sample.data@METADATA["SEL"]==TRUE & sample.data@METADATA["POSITION"]==i,"ID"]
##if no IRSL curve the length of the object is 0
IRSL_BOSL <- NA
if(length(IRSL.curveID)>0){
##chose an IRSL curve with a dose of the first regeneration point
Reg1again.curveID<-LnLxTnTx[LnLxTnTx[,"Repeated"]==TRUE & LnLxTnTx[,"Dose"]==LnLxTnTx[2,"Dose"],"LnLx.curveID"]
if(length(Reg1again.curveID)>0){
##BOSL/IRSL
IRSL_BOSL<-round(sum(unlist(sample.data@DATA[IRSL.curveID])[signal.integral])
/sum(unlist(sample.data@DATA[Reg1again.curveID])[signal.integral]),digits=4)
}
}
##Combine the two values
if(exists("RejectionCriteria")==FALSE){
RejectionCriteria <- NULL
}
RejectionCriteria <- rbind(RejectionCriteria,
cbind(RecyclingRatio, Recuperation,IRSL_BOSL))
##============================================================================##
##PLOTTING
##============================================================================##
if(output.plot){
## deprecated argument
if ("output.plot.single" %in% names(list(...))) {
plot_singlePanels <- list(...)$output.plot.single
.throw_warning("'output.plot.single' is deprecated, use ",
"'plot_singlePanels' instead")
}
##set plot settings
plot.settings <- list(
mtext = sample.data@METADATA[sample.data@METADATA[,"ID"]==LnLx.curveID[1],"SAMPLE"],
log = ""
)
##modify arguments
plot.settings <- modifyList(plot.settings, list(...))
if (!plot_singlePanels) {
layout(matrix(c(1,2,1,2,3,4,3,5),4,2,byrow=TRUE))
}
##warning if number of curves exceed colour values
if(length(col)0){
##to ensure that the right TL curves are used the run and set number of the LnLx and TnTx curves are used
LnLx.SET<-sapply(LnLx.curveID,function(x){sample.data@METADATA[sample.data@METADATA["ID"]==x,"SET"]})
LnLx.RUN<-sapply(LnLx.curveID,function(x){sample.data@METADATA[sample.data@METADATA["ID"]==x,"RUN"]})
TnTx.SET<-sapply(TnTx.curveID,function(x){sample.data@METADATA[sample.data@METADATA["ID"]==x,"SET"]})
TnTx.RUN<-sapply(TnTx.curveID,function(x){sample.data@METADATA[sample.data@METADATA["ID"]==x,"RUN"]})
##get TL curve IDs in general considering the constraints
TL.curveID<-sapply(1:length(TnTx.curveID),function(x){results<-
sample.data@METADATA[sample.data@METADATA["SEL"]==TRUE & sample.data@METADATA["POSITION"]==i &
sample.data@METADATA["SET"]>=LnLx.SET[x] & sample.data@METADATA["RUN"]>=LnLx.RUN[x] &
sample.data@METADATA["SET"]<=TnTx.SET[x] & sample.data@METADATA["RUN"]<=TnTx.RUN[x],"ID"]})
##get maximum value of TL curves
TL.curveMax<-max(unlist(sample.data@DATA[TL.curveID]))
##get channel resolution (it should be the same for all values)
HIGH<-unique(sample.data@METADATA[sample.data@METADATA["ID"]==TL.curveID[1],"HIGH"])
NPOINTS<-unique(sample.data@METADATA[sample.data@METADATA["ID"]==TL.curveID[1],"NPOINTS"])
xaxt.values<-seq(HIGH/NPOINTS,HIGH,by=HIGH/NPOINTS)
##get heating rate
RATE<-unique(sample.data@METADATA[sample.data@METADATA["ID"]==TL.curveID[1],"RATE"])
##open plot area for TL curves
plot(NA,NA,
xlab="T [\u00B0C]",
ylab=paste("TL [cts/",HIGH/NPOINTS," \u00B0C]",sep=""),
xlim=c(HIGH/NPOINTS,HIGH),
ylim=c(1,TL.curveMax),
main="Cutheat - TL curves",
sub=paste("(",RATE," K/s)",sep=""),
log=if(plot.settings$log=="y" | plot.settings$log=="xy"){"y"}else{""}
)
##plot curves and get legend values
sapply(1:length(TL.curveID),function(x){
yaxt.values<-unlist(sample.data@DATA[TL.curveID[x]])
lines(xaxt.values,yaxt.values,col=col[x])
})
##plot legend
legend("topleft",as.character(LnLxTnTx$Name),lty=c(rep(1,length(TL.curveID))),
cex=0.8*cex.global,col=col, bg="white", bty="n")
##sample name
mtext(side=3,plot.settings$mtext,cex=0.7*cex.global)
}else{
plot(NA,NA,xlim=c(0,100),ylim=c(0,100), main="Cutheat - TL curves")
text(50,50,"no cutheat as TL curve detected")
}
##======================================================================##
##Print IRSL Curves if IRSL curve is set
if(is.na(IRSL_BOSL) == FALSE){
##get channel resolution (it should be the same for all values)
HIGH<-unique(sample.data@METADATA[sample.data@METADATA["ID"]==IRSL.curveID ,"HIGH"])
NPOINTS<-unique(sample.data@METADATA[sample.data@METADATA["ID"]==IRSL.curveID ,"NPOINTS"])
xaxt.values<-seq(HIGH/NPOINTS,HIGH,by=HIGH/NPOINTS)
##open plot IRSL curve
plot(NA,NA,
xlab="Time [s]",
ylab=paste("OSL and IRSL [cts/",HIGH/NPOINTS," s]",sep=""),
xlim=c(0,HIGH),
ylim=c(0,max(unlist(sample.data@DATA[Reg1again.curveID]))),
main="IRSLT"
)
##show integral limits
abline(v=xaxt.values[min(signal.integral)], lty=2, col="gray")
abline(v=xaxt.values[max(signal.integral)], lty=2, col="gray")
##print(length(sample.data@DATA[IRSL.curveID]))
lines(xaxt.values,unlist(sample.data@DATA[IRSL.curveID]),col="red")
lines(xaxt.values,unlist(sample.data@DATA[Reg1again.curveID[1]]),col="blue")
##legend
legend("topright",c("R1 again","IRSL"),lty=c(1,1),col=c("blue","red"), bty="n")
mtext(side=3,paste("IRSL/BOSL = ",IRSL_BOSL*100,"%",sep=""),
cex=.8*cex.global
)
}
if(((is.na(IRSL_BOSL)==TRUE) & length(IRSL.curveID)>0) |
((is.na(IRSL_BOSL)==FALSE) & length(IRSL.curveID)>0)){
##plot only IRSL curve
plot(xaxt.values,unlist(sample.data@DATA[IRSL.curveID]),
xlab="Time [s]",
ylab=paste("IRSL [cts/",HIGH/NPOINTS," s]",sep=""),
xlim=c(0,10),
ylim=c(0,max(unlist(sample.data@DATA[IRSL.curveID]))),
main="IRSL curve (10 s)",
col="red",
type="l"
)
}else{
plot(NA,NA,xlim=c(0,10), ylim=c(0,10), main="IRSL curve")
text(5,5,"no IRSL curve detected")
}
##=========================================================================
##Plot header
if (plot_singlePanels) {
mtext(side=3,paste("ALQ Pos. ",i,sep=""))
}else{
mtext(side=3,paste("ALQ Pos. ",i,sep=""),outer=TRUE,line=-2.5)
}
##Plot footer
mtext(side=4,info.measurement,outer=TRUE,line=-1.5,cex=0.6*cex.global, col="blue")
##output on terminal for plot
writeLines(paste("\n[Analyse_SAR.OSLdata()] >> Figure for position ",i," produced.",sep=""))
##reset mfrow
par(mfrow=c(1,1))
}#endif for output.plot
##preprate output of values
##==============================================================================
##Add LnLxTnTx values to the list
if(exists("LnLxTnTx_List")==FALSE){LnLxTnTx_List<-list()}
LnLxTnTx_List[[i]]<-LnLxTnTx
rm(LnLxTnTx)
}else{writeLines(paste("[Analyse_SAR.OSLdata()] >> Position ",i," is not valid and has been omitted!",sep=""))} #end if position checking
}#end for loop
##============================================================================##
##OUTPUT OF FUNCTION
##============================================================================##
##get further information from the position used
##this is what you get from the Risoe file
readTemp<-unique(sample.data@METADATA[sample.data@METADATA[,"POSITION"]==min(position) & sample.data@METADATA[,"LTYPE"]!="TL","TEMPERATURE"])
cutheat<-unique(sample.data@METADATA[sample.data@METADATA[,"POSITION"]==min(position) &
sample.data@METADATA[,"LTYPE"]=="TL","HIGH"])
if(length(cutheat)==0){cutheat=NA}
systemID<-unique(sample.data@METADATA[sample.data@METADATA[,"POSITION"]==min(position),"SYSTEMID"])
SARParameters<-data.frame(readTemp=readTemp,cutheat=cutheat,systemID=systemID)
return(list(LnLxTnTx=LnLxTnTx_List,
RejectionCriteria=RejectionCriteria,
SARParameters=SARParameters))
}
Luminescence/R/calc_CobbleDoseRate.R 0000644 0001762 0000144 00000042450 14762554470 017032 0 ustar ligges users #'@title Calculate dose rate of slices in a spherical cobble
#'
#'@description
#'
#'Calculates the dose rate profile through the cobble based on Riedesel and Autzen (2020).
#'
#'Corrects the beta dose rate in the cobble for the grain size following results
#'of Guérin et al. (2012). Sediment beta and gamma dose rates are corrected
#'for the water content of the sediment using the correction factors of Aitken (1985).
#'Water content in the cobble is assumed to be 0.
#'
#'
#'@details
#'
#'**The input table layout**
#'
#'\tabular{lll}{
#'COLUMN \tab DATA TYPE \tab DESCRIPTION\cr
#'`Distance` \tab `numeric` \tab distance from the surface of the cobble to the top of each rock slice in mm. The distance for each slice will be listed in this column\cr
#'`DistanceError` \tab `numeric` \tab Error on the distance in mm\cr
#'`Thickness` \tab `numeric` \tab Thickness of each slice in mm\cr
#'`TicknessError` \tab `numeric` \tab uncertainty of the thickness in mm.\cr
#'`Mineral` \tab `character` \tab `'FS'` for feldspar, `'Q'` for quartz, depending which mineral in the cobble is used for dating\cr
#'`Cobble_K` \tab `numeric` \tab K nuclide content in % of the bulk cobble\cr
#'`Cobble_K_SE` \tab `numeric` \tab error on K nuclide content in % of the bulk cobble\cr
#'`Cobble_Th` \tab `numeric` \tab Th nuclide content in ppm of the bulk cobble\cr
#'`Cobble_Th_SE` \tab `numeric` \tab error on Th nuclide content in ppm of the bulk cobble\cr
#'`Cobble_U` \tab `numeric` \tab U nuclide content in ppm of the bulk cobble\cr
#'`CobbleU_SE` \tab `numeric` \tab error on U nuclide content in ppm of the bulk cobble\cr
#'`GrainSize` \tab `numeric` \tab average grain size in µm of the grains used for dating\cr
#'`Density` \tab `numeric` \tab Density of the cobble. Default is 2.7 g cm^-3\cr
#'`CobbleDiameter` \tab `numeric` \tab Diameter of the cobble in cm.\cr
#'`Sed_K` \tab `numeric` \tab K nuclide content in % of the sediment matrix\cr
#'`Sed_K_SE` \tab `numeric` \tab error on K nuclide content in % of the sediment matrix\cr
#'`Sed_Th` \tab `numeric` \tab Th nuclide content in ppm of the sediment matrix\cr
#'`Sed_Th_SE` \tab `numeric` \tab error on Th nuclide content in ppm of the sediment matrix\cr
#'`Sed_U` \tab `numeric` \tab U nuclide content in ppm of the sediment matrix\cr
#'`Sed_U_SE` \tab `numeric` \tab error on U nuclide content in ppm of the sediment matrix\cr
#'`GrainSize` \tab `numeric` \tab average grain size of the sediment matrix\cr
#'`WaterContent` \tab `numeric` \tab mean water content of the sediment matrix in %\cr
#'`WaterContent_SE` \tab `numeric` \tab relative error on water content
#'}
#'
#'**Water content**
#'The water content provided by the user should be calculated according to:
#'
#'\deqn{(Wet\_weight - Dry\_weight) / Dry\_weight * 100}
#'
#'@param input [data.frame] (**required**): A table containing all relevant information
#'for each individual layer. For the table layout see details.
#'
#' @param conversion [character] (*with default*): dose rate conversion factors
#' to use, see [BaseDataSet.ConversionFactors] for the accepted values.
#'
#'@references
#'Riedesel, S., Autzen, M., 2020. Beta and gamma dose rate attenuation in rocks and sediment.
#'Radiation Measurements 133, 106295.
#'
#'@section Function version: 0.1.0
#'
#'@author Svenja Riedesel, Aberystwyth University (United Kingdom) \cr
#'Martin Autzen, DTU NUTECH Center for Nuclear Technologies (Denmark)
#'
#'@return The function returns an [RLum.Results-class] object for which the first element
#'is a [matrix] (`DataIndividual`) that gives the dose rate results for each slice
#'for each decay chain individually, for both, the cobble dose rate and the sediment
#'dose rate. The second element is also a [matrix] (`DataComponent`) that gives
#'the total beta and gamma-dose rates for the cobble and the adjacent sediment
#'for each slice of the cobble.
#'
#'@keywords datagen
#'
#'@seealso [convert_Concentration2DoseRate]
#'
#'@examples
#'## load example data
#'data("ExampleData.CobbleData", envir = environment())
#'
#'## run function
#'calc_CobbleDoseRate(ExampleData.CobbleData)
#'
#'@md
#'@export
calc_CobbleDoseRate <- function(input,conversion = "Guerinetal2011"){
.set_function_name("calc_CobbleDoseRate")
on.exit(.unset_function_name(), add = TRUE)
## Integrity checks -------------------------------------------------------
.validate_class(input, "data.frame")
.validate_not_empty(input)
if ((max(input[,1])>input$CobbleDiameter[1]*10) ||
((max(input[,1]) + input[length(input[,1]),3]) > input$CobbleDiameter[1]*10))
.throw_error("Slices outside of cobble: please ensure your distances ",
"are in mm and diameter is in cm")
## conversion factors: we do not use BaseDataSet.ConversionFactors directly
## as it is in alphabetical level, but we want to have 'Guerinetal2011'
## in first position, as that is our default value
BaseDataSet.ConversionFactors <- NULL
load(system.file("data", "BaseDataSet.ConversionFactors.rda",
package = "Luminescence"))
valid_conversion_factors <- c("Guerinetal2011", "Cresswelletal2018",
"AdamiecAitken1998", "Liritzisetal2013")
stopifnot(all(names(BaseDataSet.ConversionFactors) %in%
valid_conversion_factors))
conversion <- .validate_args(conversion, valid_conversion_factors)
# Calculate Dose Rate -----------------------------------------------------
SedDoseData <- matrix(data = NA, nrow = 1, ncol = 10)
CobbleDoseData <- matrix(data = 0, nrow = 1, ncol = 10)
CobbleDoseData <- input[1,5:12]
CobbleDoseData <- cbind(CobbleDoseData,0,0)
SedDoseData <- cbind(input[1,5],input[1,15:20],input[1,12],input[1,23:24])
CobbleDoseRate <- get_RLum(convert_Concentration2DoseRate(
input = CobbleDoseData, conversion = conversion))
SedDoseRate <- get_RLum(
convert_Concentration2DoseRate(input = SedDoseData, conversion = conversion))
## Distance should be from the surface of the rock to the top of the slice. Distances and thicknesses are in mm
N <- length(input$Distance)
Diameter <- input$CobbleDiameter[1]
### Calculate gamma attenuation coefficient for the cobbles internal dose rate
if (Diameter<25){
CobbleGammaAtt <-
(0.55 * exp(-0.45 * Diameter) + 0.09 * exp(-0.06 * Diameter)) * 10
}else {
CobbleGammaAtt <- 0.02
}
## Scale the density and infinite matrix gamma dose rates ----
Scaling <- input$Density[1] / 2.7
GammaEdge <- 0.5 * (1 - exp(-0.039 * Diameter))
GammaCentre <- 2 * GammaEdge
DiameterSeq <-
seq(0, Diameter * 10, by = 0.01) #Converts diameter into integer of 10 um
### Create matrices for use ----
Temp <- matrix(data = NA, nrow = length(DiameterSeq), ncol = 9)
DistanceError <- matrix(data = NA, nrow = N, ncol = 8)
ThicknessError <- matrix(data = NA, nrow = N, ncol = 8)
DataIndividual <- matrix(data = NA, nrow = N, ncol = 25)
DataComponent <- matrix(data = NA, nrow = N, ncol = 9)
DoseRates <- matrix(data = NA, nrow = 1, ncol = 24)
output <- matrix(list(), nrow = 2, ncol = 1)
### Calculate dose rate profiles through the rock ----
t <- Diameter * 10 - DiameterSeq
tGamma <- t
#Beta and gamma functions for the cobbles own dose rate
KBetaCobble <- function(x) (1 - 0.5 * exp(-3.77 * DiameterSeq))+(1-0.5*exp(-3.77*t))-1
ThBetaCobble_short <- function(x) (1 - 0.5 * exp(-5.36 * x * Scaling))+(1-0.5*exp(-5.36*t*Scaling))-1
ThBetaCobble_long <- function(x) (1 - 0.33 * exp(-2.36 * x * Scaling))+(1-0.33*exp(-2.36*t*Scaling))-1
UBetaCobble_short <- function(x) (1 - 0.5 * exp(-4.15 * x * Scaling))+(1-0.5*exp(-4.15*t*Scaling))-1
UBetaCobble_long <- function(x) (1 - 0.33 * exp(-2.36 * x * Scaling))+(1-0.33*exp(-2.36*t*Scaling))-1
GammaCobble <- function(x) {
(GammaCentre - GammaEdge * exp(-CobbleGammaAtt * x * Scaling)) +
(GammaCentre - GammaEdge * exp(-CobbleGammaAtt * tGamma * Scaling)) -
GammaCentre
}
#Beta and gamma functions for the sediment dose rates into the cobble
KBetaSed <- function(x) 2 - (1 - 0.5 * exp(-3.77 * x * Scaling)) - (1 - 0.5 * exp(-3.77 * t * Scaling))
ThBetaSed_short <- function(x) 2 - (1 - 0.5 * exp(-5.36 * x * Scaling)) - (1 - 0.5 * exp(-5.36 * t * Scaling))
ThBetaSed_long <- function(x) 2 - (1 - 0.33 * exp(-2.36 * x * Scaling)) - (1 - 0.33 * exp(-2.36 * t * Scaling))
UBetaSed_short <- function(x) 2 - (1 - 0.5 * exp(-4.15 * x * Scaling)) - (1 - 0.5 * exp(-4.15 * t * Scaling))
UBetaSed_long <- function(x) 2 - (1 - 0.33 * exp(-2.36 * x * Scaling)) - (1 - 0.33 * exp(-2.36 * t * Scaling))
GammaSed <- function(x) 2 - (1 - 0.5 * exp(-0.02 * x * Scaling)) - (1 - 0.5 * exp(-0.02 * tGamma *
Scaling))
Temp[, 1] <- DiameterSeq
Temp[, 2] <- KBetaCobble(DiameterSeq)
Temp[, 3] <- ThBetaCobble_long(DiameterSeq)
Temp[, 4] <- UBetaCobble_long(DiameterSeq)
Temp[, 5] <- GammaCobble(DiameterSeq)
Temp[, 6] <- KBetaSed(DiameterSeq)
Temp[, 7] <- ThBetaSed_long(DiameterSeq)
Temp[, 8] <- UBetaSed_long(DiameterSeq)
Temp[, 9] <- GammaSed(DiameterSeq)
TempThCob <- ThBetaCobble_short(DiameterSeq)
TempUCob <- UBetaCobble_short(DiameterSeq)
TempThSed <- ThBetaSed_short(DiameterSeq)
TempUSed <- UBetaSed_short(DiameterSeq)
n <- which(DiameterSeq >= (max(DiameterSeq)-0.15))[1]
Max <- length(DiameterSeq)
## Create the full matrix based on the short and long beta attenuations
Temp[0:16, 3] <- TempThCob[0:16]
Temp[n:Max, 3] <- TempThCob[n:Max]
Temp[0:16, 7] <- TempThSed[0:16]
Temp[n:Max, 7] <- TempThSed[n:Max]
Temp[0:16, 4] <- TempUCob[0:16]
Temp[n:Max, 4] <- TempUCob[n:Max]
Temp[0:16, 8] <- TempUSed[0:16]
Temp[n:Max, 8] <- TempUSed[n:Max]
colnames(Temp) <- c(
"Distance",
"KBetaCob",
"ThBetaCob",
"UBetaCob",
"GammaCob",
"KBetaSed",
"ThBetaSed",
"UBetaSed",
"GammaSed"
)
### Create data output matrices ----
Distances <- input$Distance / 0.01 + 1
Thicknesses <- input$Thickness / 0.01
MinDistance <- (input$Distance - input$DistanceError) / 0.01 + 1
MaxDistance <- (input$Distance + input$DistanceError) / 0.01 + 1
MinThickness <- (input$Thickness - input$ThicknessError) / 0.01
MaxThickness <- (input$Thickness + input$ThicknessError) / 0.01
for (i in 1:N){
Start <- Distances[i]
End <- Start+Thicknesses[i]
d_min <- MinDistance[i]
d_max <- MaxDistance[i]
t_min <- MinThickness[i]
t_max <- MaxThickness[i]
#Calculate errors ----
#Check if minimum distance from top is less than 0
if (MinDistance[i]<0){
d_min <- 0
}
j <- d_min+Thicknesses[i]
k <- d_max+Thicknesses[i]
for (l in 1:8){
m <- l + 1
if (d_min == Start){
DistanceError[i,l]<- abs(
(mean(Temp[d_max:k,m])-mean(Temp[Start:End,m]))/(2*mean(Temp[Start:End,m])))
} else if (k > Max){
DistanceError[i,l] <- abs(
(mean(Temp[Start:End,m])-mean(Temp[d_min:j,m]))/(2*mean(Temp[Start:End,m])))
} else {
DistanceError[i,l] <- abs(
mean((mean(Temp[d_max:k,m])-mean(Temp[Start:End,m])):(mean(Temp[Start:End,m])-mean(Temp[d_min:j,m])))/(2*mean(Temp[Start:End,m])))
}
j2 <- Start+t_min
k2 <- Start+t_max
if (k2 > Max){
ThicknessError[i,l] <- abs(
(mean(Temp[Start:End,m])-mean(Temp[Start:j2,m]))/(2*mean(Temp[Start:End,m])))
} else {
ThicknessError[i,l] <- abs(
mean((mean(Temp[Start:k2,m])-mean(Temp[Start:End,m])):(mean(Temp[Start:End,m])-mean(Temp[Start:j2,m])))/(2*mean(Temp[Start:End,m])))
}
}
### Calculate average dose rates ----
DataIndividual[i, 1] <- input[i, 1]
# Cobble K Beta
DataIndividual[i, 2] <- mean(Temp[Start:End, 2]) * CobbleDoseRate[1, 1]
DataIndividual[i, 3] <-
DataIndividual[i, 2] * sqrt(DistanceError[i, 1] ^ 2 + ThicknessError[i, 1] ^
2 + (CobbleDoseRate[1, 2] / CobbleDoseRate[1, 1]) ^ 2)
# Cobble Th Beta
DataIndividual[i, 4] <- mean(Temp[Start:End, 3]) * CobbleDoseRate[1, 3]
DataIndividual[i, 5] <-
DataIndividual[i, 4] * sqrt(DistanceError[i, 2] ^ 2 + ThicknessError[i, 2] ^
2 + (CobbleDoseRate[1, 4] / CobbleDoseRate[1, 3]) ^ 2)
# Cobble U Beta
DataIndividual[i, 6] <- mean(Temp[Start:End, 4]) * CobbleDoseRate[1, 5]
DataIndividual[i, 7] <- DataIndividual[i, 6] * sqrt(DistanceError[i, 3] ^ 2 + ThicknessError[i, 3] ^
2 + (CobbleDoseRate[1, 6] / CobbleDoseRate[1, 5]) ^ 2)
# Cobble K Gamma
DataIndividual[i, 8] <- mean(Temp[Start:End, 5]) * CobbleDoseRate[2, 1]
DataIndividual[i, 9] <- DataIndividual[i, 8] * sqrt(DistanceError[i, 4] ^ 2 + ThicknessError[i, 4] ^
2 + (CobbleDoseRate[2, 2] / CobbleDoseRate[2, 1]) ^ 2)
# Cobble Th Gamma
DataIndividual[i, 10] <- mean(Temp[Start:End, 5]) * CobbleDoseRate[2, 3]
DataIndividual[i, 11] <-
DataIndividual[i, 10] * sqrt(DistanceError[i, 4] ^ 2 + ThicknessError[i, 4] ^
2 + (CobbleDoseRate[2, 4] / CobbleDoseRate[2, 3]) ^ 2)
# Cobble U Gamma
DataIndividual[i, 12] <- mean(Temp[Start:End, 5]) * CobbleDoseRate[2, 5]
DataIndividual[i, 13] <-
DataIndividual[i, 12] * sqrt(DistanceError[i, 4] ^ 2 + ThicknessError[i, 4] ^
2 + (CobbleDoseRate[2, 6] / CobbleDoseRate[2, 5]) ^ 2)
# Sediment K Beta
DataIndividual[i, 14] <- mean(Temp[Start:End, 6]) * SedDoseRate[1, 1]
DataIndividual[i, 15] <-
DataIndividual[i, 14] * sqrt(DistanceError[i, 5] ^ 2 + ThicknessError[i, 5] ^
2 + (SedDoseRate[1, 2] / SedDoseRate[1, 1]) ^ 2)
# Sediment Th Beta
DataIndividual[i, 16] <- mean(Temp[Start:End, 7]) * SedDoseRate[1, 3]
DataIndividual[i, 17] <-
DataIndividual[i, 16] * sqrt(DistanceError[i, 6] ^ 2 + ThicknessError[i, 6] ^
2 + (SedDoseRate[1, 4] / SedDoseRate[1, 3]) ^ 2)
# Sediment U Beta
DataIndividual[i, 18] <- mean(Temp[Start:End, 8]) * SedDoseRate[1, 5]
DataIndividual[i, 19] <-
DataIndividual[i, 18] * sqrt(DistanceError[i, 7] ^ 2 + ThicknessError[i, 7] ^
2 + (SedDoseRate[1, 6] / SedDoseRate[1, 5]) ^ 2)
# Sediment K Gamma
DataIndividual[i, 20] <- mean(Temp[Start:End, 9]) * SedDoseRate[2, 1]
DataIndividual[i, 21] <-
DataIndividual[i, 20] * sqrt(DistanceError[i, 8] ^ 2 + ThicknessError[i, 8] ^
2 + (SedDoseRate[2, 2] / SedDoseRate[2, 1]) ^ 2)
# Sediment Th Gamma
DataIndividual[i, 22] <- mean(Temp[Start:End, 9]) * SedDoseRate[2, 3]
DataIndividual[i, 23] <-
DataIndividual[i, 22] * sqrt(DistanceError[i, 8] ^ 2 + ThicknessError[i, 8] ^
2 + (SedDoseRate[2, 4] / SedDoseRate[2, 3]) ^ 2)
# Sediment U Gamma
DataIndividual[i, 24] <- mean(Temp[Start:End, 9]) * SedDoseRate[2, 5]
DataIndividual[i, 25] <-
DataIndividual[i, 24] * sqrt(DistanceError[i, 8] ^ 2 + ThicknessError[i, 8] ^
2 + (SedDoseRate[2, 6] / SedDoseRate[2, 5]) ^ 2)
### Sum data into beta and gamma dose rates from cobble and sediment ----
DataComponent[i, 1] <- input[i, 1]
DataComponent[i, 2] <- DataIndividual[i, 2] + DataIndividual[i, 4] + DataIndividual[i, 6]
DataComponent[i, 3] <- DataComponent[i,2]*sqrt((DataIndividual[i,3]/DataIndividual[i,2])^2+(DataIndividual[i,5]/DataIndividual[i,4])^2+(DataIndividual[i,7]/DataIndividual[i,6])^2)
DataComponent[i, 4] <- DataIndividual[i, 8] + DataIndividual[i, 10] + DataIndividual[i, 12]
DataComponent[i, 5] <- DataComponent[i,4]*sqrt((DataIndividual[i,9]/DataIndividual[i,8])^2+(DataIndividual[i,11]/DataIndividual[i,10])^2+(DataIndividual[i,13]/DataIndividual[i,12])^2)
DataComponent[i, 6] <- DataIndividual[i, 14] + DataIndividual[i, 16] + DataIndividual[i, 18]
DataComponent[i, 7] <- DataComponent[i,6]*sqrt((DataIndividual[i,15]/DataIndividual[i,14])^2+(DataIndividual[i,17]/DataIndividual[i,16])^2+(DataIndividual[i,19]/DataIndividual[i,18])^2)
DataComponent[i, 8] <- DataIndividual[i, 20] + DataIndividual[i, 22] + DataIndividual[i, 24]
DataComponent[i, 9] <- DataComponent[i,8]*sqrt((DataIndividual[i,21]/DataIndividual[i,20])^2+(DataIndividual[i,23]/DataIndividual[i,22])^2 + (DataIndividual[i,25]/DataIndividual[i,24])^2)
}
colnames(DataIndividual) <-
c(
"Distance.",
"K Beta cobble",
"SE",
"Th Beta cobble",
"SE",
"U Beta cobble",
"SE",
"K Gamma cobble",
"SE",
"Th Gamma cobble",
"SE",
"U Gamma cobble",
"SE",
"K Beta sed.",
"SE",
"Th Beta sed.",
"SE",
"U Beta sed.",
"SE",
"K Gamma sed.",
"SE",
"Th Gamma sed.",
"SE",
"U Gamma sed.",
"SE"
)
colnames(DataComponent) <-
c(
"Distance",
"Total Cobble Beta",
"SE",
"Total Cobble Gamma",
"SE",
"Total Beta Sed.",
"SE",
"Total Gamma Sed.",
"SE"
)
DataIndividual[is.na(DataIndividual)] <- 0
DataComponent[is.na(DataComponent)] <- 0
# Return ------------------------------------------------------------------
return(
set_RLum(
class = "RLum.Results",
data = list(
DataIndividual = DataIndividual,
DataComponent = DataComponent,
input = input
),
info = list(
call = sys.call()
)))
}
Luminescence/R/calc_FastRatio.R 0000644 0001762 0000144 00000036504 14762554470 016114 0 ustar ligges users #' @title Calculate the Fast Ratio for CW-OSL curves
#'
#' @description
#' Function to calculate the fast ratio of quartz CW-OSL single grain or single
#' aliquot curves after Durcan & Duller (2011).
#'
#' This function follows the equations of Durcan & Duller (2011). The energy
#' required to reduce the fast and medium quartz OSL components to `x` and
#' `x2` % respectively using eq. 3 to determine channels L2 and L3 (start
#' and end). The fast ratio is then calculated from: \eqn{(L1-L3)/(L2-L3)}.
#'
#' @param object [RLum.Analysis-class], [RLum.Data.Curve-class] or [data.frame] (**required**):
#' x, y data of measured values (time and counts).
#'
#' @param stimulation.power [numeric] (*with default*):
#' Stimulation power in mW/cm²
#'
#' @param wavelength [numeric] (*with default*):
#' Stimulation wavelength in nm
#'
#' @param sigmaF [numeric] (*with default*):
#' Photoionisation cross-section (cm²) of the fast component.
#' Default value after Durcan & Duller (2011).
#'
#' @param sigmaM [numeric] (*with default*):
#' Photoionisation cross-section (cm²) of the medium component.
#' Default value after Durcan & Duller (2011).
#'
#' @param Ch_L1 [numeric] (*with default*):
#' An integer specifying the channel for L1.
#'
#' @param Ch_L2 [numeric] (*optional*):
#' An integer specifying the channel for L2.
#'
#' @param Ch_L3 [numeric] (*optional*):
#' A vector of length 2 with integer values specifying the start and end
#' channels for L3 (e.g., `c(40, 50)`), with the second component greater
#' than or equal to the first.
#'
#' @param x [numeric] (*with default*):
#' Percentage of signal remaining from the fast component.
#' Used to define the location of L2 and L3 (start).
#'
#' @param x2 [numeric] (*with default*):
#' Percentage of signal remaining from the medium component.
#' Used to define the location of L3 (end).
#'
#' @param dead.channels [numeric] (*with default*):
#' Vector of length 2 in the form of `c(x, y)`.
#' Channels that do not contain OSL data, i.e. at the start or end of measurement.
#'
#' @param fitCW.sigma [logical] (*optional*):
#' fit CW-OSL curve using [fit_CWCurve] to calculate `sigmaF` and `sigmaM` (**experimental**).
#'
#' @param fitCW.curve [logical] (*optional*):
#' fit CW-OSL curve using [fit_CWCurve] and derive the counts of L2 and L3
#' from the fitted OSL curve (**experimental**).
#'
#' @param plot [logical] (*with default*):
#' enable/disable the plot output.
#'
#' @param ... available options: `verbose` ([logical]).
#' Further arguments passed to [fit_CWCurve].
#'
#' @return
#' Returns a plot (*optional*) and an S4 object of type [RLum.Results-class].
#' The slot `data` contains a [list] with the following elements:
#'
#' \item{summary}{[data.frame] summary of all relevant results}
#' \item{data}{the original input data}
#' \item{fit}{[RLum.Results-class] object if either `fitCW.sigma` or `fitCW.curve` is `TRUE`}
#' \item{args}{[list] of used arguments}
#' \item{call}{[call] the function call}
#'
#' @section Function version: 0.1.1
#'
#' @author
#' Georgina E. King, University of Bern (Switzerland) \cr
#' Julie A. Durcan, University of Oxford (United Kingdom) \cr
#' Christoph Burow, University of Cologne (Germany)
#'
#' @references
#' Durcan, J.A. & Duller, G.A.T., 2011. The fast ratio: A rapid measure for testing
#' the dominance of the fast component in the initial OSL signal from quartz.
#' Radiation Measurements 46, 1065-1072.
#'
#' Madsen, A.T., Duller, G.A.T., Donnelly, J.P., Roberts, H.M. & Wintle, A.G., 2009.
#' A chronology of hurricane landfalls at Little Sippewissett Marsh, Massachusetts, USA,
#' using optical dating. Geomorphology 109, 36-45.
#'
#' **Further reading**
#'
#' Steffen, D., Preusser, F. & Schlunegger, 2009. OSL quartz age underestimation
#' due to unstable signal components. Quaternary Geochronology 4, 353-362.
#'
#'
#' @seealso [fit_CWCurve], [get_RLum], [RLum.Analysis-class],
#' [RLum.Results-class], [RLum.Data.Curve-class]
#'
#' @examples
#' # load example CW-OSL curve
#' data("ExampleData.CW_OSL_Curve")
#'
#' # calculate the fast ratio w/o further adjustments
#' res <- calc_FastRatio(ExampleData.CW_OSL_Curve)
#'
#' # show the summary table
#' get_RLum(res)
#'
#' @md
#' @export
calc_FastRatio <- function(object,
stimulation.power = 30.6,
wavelength = 470,
sigmaF = 2.6E-17,
sigmaM = 4.28E-18,
Ch_L1 = 1,
Ch_L2 = NULL,
Ch_L3 = NULL,
x = 1,
x2 = 0.1,
dead.channels = c(0,0),
fitCW.sigma = FALSE,
fitCW.curve = FALSE,
plot = TRUE,
...) {
.set_function_name("calc_FastRatio")
on.exit(.unset_function_name(), add = TRUE)
## Integrity checks - -----------------------------------------------------
.validate_class(object, c("RLum.Analysis", "RLum.Results", "RLum.Data.Curve",
"data.frame", "matrix"))
.validate_not_empty(object)
.validate_positive_scalar(Ch_L1, int = TRUE)
.validate_positive_scalar(Ch_L2, int = TRUE, null.ok = TRUE)
if (!is.null(Ch_L3)) {
.validate_class(Ch_L3, c("integer", "numeric"))
.validate_length(Ch_L3, 2)
.validate_positive_scalar(Ch_L3[1], int = TRUE, name = "'Ch_L3[1]'")
.validate_positive_scalar(Ch_L3[2], int = TRUE, name = "'Ch_L3[2]'")
if (Ch_L3[1] > Ch_L3[2]) {
.throw_error("'Ch_L3[2]' must be greater than or equal to 'Ch_L3[1]'")
}
}
.validate_positive_scalar(wavelength)
.validate_positive_scalar(sigmaF)
.validate_positive_scalar(sigmaM)
.validate_positive_scalar(x)
.validate_positive_scalar(x2)
.validate_class(dead.channels, c("integer", "numeric"))
.validate_length(dead.channels, 2)
if (any(dead.channels < 0)) {
.throw_error("All elements of 'dead.channels' should be non-negative")
}
## Input object handling -----------------------------------------------------
if (inherits(object, "RLum.Analysis"))
object <- get_RLum(object)
if (inherits(object, "RLum.Results"))
object <- get_RLum(object, "data")
if ((is.data.frame(object) || is.matrix (object)) && ncol(object) < 2) {
.throw_error("'object' should have at least two columns")
}
if (!inherits(object, "list"))
object <-list(object)
## Settings ------------------------------------------------------------------
settings <- list(verbose = TRUE,
n.components.max = 3,
fit.method = "LM",
output.terminal = FALSE,
info = list(),
fit = NULL)
# override defaults with args in ...
settings <- modifyList(settings, list(...))
## Calculations --------------------------------------------------------------
# iterate over all user provided objects and calculate the FR
fast.ratios <- lapply(object, function(obj) {
if (inherits(obj, "RLum.Data.Curve"))
A <- get_RLum(obj)
else
A <- obj
## Energy calculation
# P = user defined stimulation power in mW
# lambdaLED = wavelength of stimulation source in nm
P <- stimulation.power
lamdaLED <- wavelength
## Constants
## c = speed of light, h = Planck's constant
h <- 6.62607004E-34
c <- 299792458
I0 <- (P / 1000) / (h * c / (lamdaLED * 10^-9))
Ch_width <- max(A[ ,1]) / length(A[ ,1])
# remove dead channels
A <- as.data.frame(A[(dead.channels[1] + 1):(nrow(A)-dead.channels[2]), ])
A[ ,1] <- A[ ,1] - A[1,1]
# estimate the photo-ionisation crossections of the fast and medium
# component using the fit_CWCurve function
if (fitCW.sigma | fitCW.curve) {
fitCW.res <- try(fit_CWCurve(A, n.components.max = settings$n.components.max,
fit.method = settings$fit.method,
LED.power = stimulation.power,
LED.wavelength = wavelength,
verbose = settings$output.terminal,
plot = plot), outFile = stdout())
if (!inherits(fitCW.res, "try-error")) {
settings$fit <- fitCW.res
if (fitCW.sigma) {
sigmaF <- get_RLum(fitCW.res)$cs1
sigmaM <- get_RLum(fitCW.res)$cs2
if (settings$verbose) {
message("\n [calc_FitCWCurve()]\n")
message("New value for sigmaF: ", format(sigmaF, digits = 3, nsmall = 2))
message("New value for sigmaM: ", format(sigmaM, digits = 3, nsmall = 2))
}
}
if (fitCW.curve) {
nls <- get_RLum(fitCW.res, "fit")
A[ ,2] <- predict(nls)
}
} else {
settings["fit"] <- list(NULL)
if (settings$verbose)
.throw_message("Fitting failed, please call 'fit_CWCurve()' ",
"manually before calculating the fast ratio")
}
}
## The equivalent time in s of L1, L2, L3
# Use these values to look up the channel
t_L1 <- 0
if (is.null(Ch_L2))
t_L2 <- (log(x / 100)) / (-sigmaF * I0)
else
t_L2 <- A[Ch_L2, 1]
if (is.null(Ch_L3)) {
t_L3_start <- (log(x / 100)) / (-sigmaM * I0)
t_L3_end <- (log(x2 / 100)) / (-sigmaM * I0)
} else {
if (any(Ch_L3 > nrow(A))) {
.throw_error("Value in 'Ch_L3' (", .collapse(Ch_L3, quote = FALSE),
") exceeds number of available channels (", nrow(A), ")")
}
t_L3_start <- A[Ch_L3[1], 1]
t_L3_end <- A[Ch_L3[2], 1]
}
## Channel number(s) of L2 and L3
if (is.null(Ch_L2))
Ch_L2 <- which.min(abs(A[,1] - t_L2))
if (Ch_L2 <= 1) {
msg <- sprintf("Calculated time/channel for L2 is too small (%.f, %.f), NULL returned",
t_L2, Ch_L2)
settings$info <- modifyList(settings$info, list(L2 = msg))
.throw_warning(msg)
return(NULL)
}
Ch_L3st<- which.min(abs(A[,1] - t_L3_start))
Ch_L3end <- which.min(abs(A[,1] - t_L3_end))
## Counts in channels L1, L2, L3
# L1 ----
Cts_L1 <- A[Ch_L1, 2]
# L2 ----
if (Ch_L2 > nrow(A)) {
msg <- sprintf(paste("The calculated channel for L2 (%i) exceeds",
"the number of available channels (%i),",
"NULL returned"), Ch_L2, nrow(A))
settings$info <- modifyList(settings$info, list(L2 = msg))
.throw_warning(msg)
return(NULL)
}
Cts_L2 <- A[Ch_L2, 2]
# optional: predict the counts from the fitted curve
if (fitCW.curve) {
if (!inherits(fitCW.res, "try-error")) {
nls <- get_RLum(fitCW.res, "fit")
Cts_L2 <- predict(nls, list(x = t_L2))
}
}
# L3 ----
if (Ch_L3st >= nrow(A) | Ch_L3end > nrow(A)) {
msg <- sprintf(paste("The calculated channels for L3 (%i, %i) exceed",
"the number of available channels (%i).",
"\nThe background has instead been estimated from the last",
"5 channels."), Ch_L3st, Ch_L3end, nrow(A))
settings$info <- modifyList(settings$info, list(L3 = msg))
.throw_warning(msg)
Ch_L3st <- max(nrow(A) - 5, 1)
Ch_L3end <- nrow(A)
t_L3_start <- A[Ch_L3st,1]
t_L3_end <- A[Ch_L3end,1]
}
Cts_L3 <- mean(A[Ch_L3st:Ch_L3end, 2])
# optional: predict the counts from the fitted curve
if (fitCW.curve) {
if (!inherits(fitCW.res, "try-error")) {
nls <- get_RLum(fitCW.res, "fit")
Cts_L3 <- mean(predict(nls, list(x = c(t_L3_start, t_L3_end))))
}
}
# Warn if counts are not in decreasing order
if (Cts_L3 >= Cts_L2)
.throw_warning(sprintf("L3 contains more counts (%.f) than L2 (%.f)",
Cts_L3, Cts_L2))
## Fast Ratio
FR <- (Cts_L1 - Cts_L3) / (Cts_L2 - Cts_L3)
if (length(FR) != 1)
FR <- NA
## Fast Ratio - Error calculation
FR_se <- NA
FR_rse <- NA
if (!is.na(FR)) {
# number of channels the background was derived from
nBG <- abs(Ch_L3end - Ch_L3st)
# relative standard errors
rse_L1 <- sqrt(Cts_L1 + Cts_L3 / nBG) / (Cts_L1 - Cts_L3)
rse_L2 <- sqrt(Cts_L2 + Cts_L3 / nBG) / (Cts_L2 - Cts_L3)
# absolute standard errors
se_L1 <- rse_L1 * (Cts_L1 - Cts_L3)
se_L2 <- rse_L2 * (Cts_L2 - Cts_L3)
# absolute standard error on fast ratio
FR_se <- (sqrt((se_L1 / (Cts_L1 - Cts_L3))^2 + ((se_L2 / (Cts_L2 - Cts_L3))^2) )) * FR
FR_rse <- FR_se / FR * 100
}
## Return values -----------------------------------------------------------
summary <- data.frame(fast.ratio = FR,
fast.ratio.se = FR_se,
fast.ratio.rse = FR_rse,
channels = nrow(A),
channel.width = Ch_width,
dead.channels.start = as.integer(dead.channels[1]),
dead.channels.end = as.integer(dead.channels[2]),
sigmaF = sigmaF,
sigmaM = sigmaM,
I0 = I0,
stimulation.power = stimulation.power,
wavelength = wavelength,
t_L1 = t_L1,
t_L2 = t_L2,
t_L3_start = t_L3_start,
t_L3_end = t_L3_end,
Ch_L1 = as.integer(Ch_L1),
Ch_L2 = as.integer(Ch_L2),
Ch_L3_start = as.integer(Ch_L3st),
Ch_L3_end = as.integer(Ch_L3end),
Cts_L1 = Cts_L1,
Cts_L2 = Cts_L2,
Cts_L3 = Cts_L3)
fast.ratio <- set_RLum(class = "RLum.Results",
originator = "calc_FastRatio",
data = list(summary = summary,
data = obj,
fit = settings$fit,
args = as.list(sys.call(-2L)[-1]),
call = sys.call(-2L)),
info = settings$info
)
## Console Output ----------------------------------------------------------
if (settings$verbose) {
table.names <- c(
"Fast Ratio\t", " \U02EA Absolute error", " \U02EA Relative error (%)", "Channels\t",
"Channel width (s)", "Dead channels start", "Dead channels end",
"Sigma Fast\t", "Sigma Medium\t", "I0\t\t", "Stim. power (mW/cm^2)", "Wavelength (nm)",
"-\n Time L1 (s)\t", "Time L2 (s)\t", "Time L3 start (s)", "Time L3 end (s)",
"-\n Channel L1\t", "Channel L2\t", "Channel L3 start", "Channel L3 end\t",
"-\n Counts L1\t", "Counts L2\t", "Counts L3\t")
cat("\n[calc_FastRatio()]\n")
cat("\n -------------------------------")
for (i in 1:ncol(summary)) {
cat(paste0("\n ", table.names[i],"\t: ",
format(summary[1, i], digits = 2, nsmall = 2)))
}
cat("\n -------------------------------\n\n")
}
## Plotting -------------------------------------------------------------
if (plot)
try(plot_RLum.Results(fast.ratio, ...))
# return
return(fast.ratio)
}) # End of lapply
if (length(fast.ratios) == 1)
fast.ratios <- fast.ratios[[1]]
invisible(fast.ratios)
}
Luminescence/R/convert_CW2pPMi.R 0000644 0001762 0000144 00000021535 14762554470 016155 0 ustar ligges users #' Transform a CW-OSL curve into a pPM-OSL curve via interpolation under
#' parabolic modulation conditions
#'
#' Transforms a conventionally measured continuous-wave (CW) OSL-curve into a
#' pseudo parabolic modulated (pPM) curve under parabolic modulation conditions
#' using the interpolation procedure described by Bos & Wallinga (2012).
#'
#' The complete procedure of the transformation is given in Bos & Wallinga
#' (2012). The input `data.frame` consists of two columns: time (t) and
#' count values (CW(t))
#'
#' **Nomenclature**
#'
#' - P = stimulation time (s)
#' - 1/P = stimulation rate (1/s)
#'
#' **Internal transformation steps**
#'
#' (1)
#' log(CW-OSL) values
#'
#' (2)
#' Calculate t' which is the transformed time:
#' \deqn{t' = (1/3)*(1/P^2)t^3}
#'
#' (3)
#' Interpolate CW(t'), i.e. use the log(CW(t)) to obtain the count values for
#' the transformed time (t'). Values beyond `min(t)` and `max(t)`
#' produce `NA` values.
#'
#' (4)
#' Select all values for t' < `min(t)`, i.e. values beyond the time resolution
#' of t. Select the first two values of the transformed data set which contain
#' no `NA` values and use these values for a linear fit using [lm].
#'
#' (5)
#' Extrapolate values for t' < `min(t)` based on the previously obtained
#' fit parameters. The extrapolation is limited to two values. Other values at
#' the beginning of the transformed curve are set to 0.
#'
#' (6)
#' Transform values using
#' \deqn{pLM(t) = t^2/P^2*CW(t')}
#'
#' (7)
#' Combine all values and truncate all values for t' > `max(t)`
#'
#' **NOTE:**
#' The number of values for t' < `min(t)` depends on the stimulation
#' period `P`. To avoid the production of too many artificial data at the
#' raising tail of the determined pPM curve, it is recommended to use the
#' automatic estimation routine for `P`, i.e. provide no value for
#' `P`.
#'
#' @param values [RLum.Data.Curve-class] or [data.frame] (**required**):
#' [RLum.Data.Curve-class] or `data.frame` with measured curve data of type
#' stimulation time (t) (`values[,1]`) and measured counts (cts) (`values[,2]`)
#'
#' @param P [vector] (*optional*):
#' stimulation period in seconds. If no value is given, the optimal value is
#' estimated automatically (see details). Greater values of P produce more
#' points in the rising tail of the curve.
#'
#' @return
#' The function returns the same data type as the input data type with
#' the transformed curve values.
#'
#' `RLum.Data.Curve`
#'
#' \tabular{rl}{
#' `$CW2pPMi.x.t` \tab: transformed time values \cr
#' `$CW2pPMi.method` \tab: used method for the production of the new data points
#' }
#'
#' `data.frame`
#'
#' \tabular{rl}{
#' `$x` \tab: time\cr
#' `$y.t` \tab: transformed count values\cr
#' `$x.t` \tab: transformed time values \cr
#' `$method` \tab: used method for the production of the new data points
#' }
#'
#' @note
#' According to Bos & Wallinga (2012), the number of extrapolated points
#' should be limited to avoid artificial intensity data. If `P` is
#' provided manually, not more than two points are extrapolated.
#'
#' @section Function version: 0.2.2
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' Based on comments and suggestions from:\cr
#' Adrie J.J. Bos, Delft University of Technology, The Netherlands
#'
#' @seealso [convert_CW2pLM], [convert_CW2pLMi], [convert_CW2pHMi],
#' [fit_LMCurve], [RLum.Data.Curve-class]
#'
#' @references
#' Bos, A.J.J. & Wallinga, J., 2012. How to visualize quartz OSL
#' signal components. Radiation Measurements, 47, 752-758.
#'
#' **Further Reading**
#'
#' Bulur, E., 1996. An Alternative Technique For
#' Optically Stimulated Luminescence (OSL) Experiment. Radiation Measurements,
#' 26, 701-709.
#'
#' Bulur, E., 2000. A simple transformation for converting CW-OSL curves to
#' LM-OSL curves. Radiation Measurements, 32, 141-145.
#'
#' @keywords manip
#'
#' @examples
#'
#'
#' ##(1)
#' ##load CW-OSL curve data
#' data(ExampleData.CW_OSL_Curve, envir = environment())
#'
#' ##transform values
#' values.transformed <- convert_CW2pPMi(ExampleData.CW_OSL_Curve)
#'
#' ##plot
#' plot(values.transformed$x,values.transformed$y.t, log = "x")
#'
#' ##(2) - produce Fig. 4 from Bos & Wallinga (2012)
#'
#' ##load data
#' data(ExampleData.CW_OSL_Curve, envir = environment())
#' values <- CW_Curve.BosWallinga2012
#'
#' ##open plot area
#' plot(NA, NA,
#' xlim = c(0.001,10),
#' ylim = c(0,8000),
#' ylab = "pseudo OSL (cts/0.01 s)",
#' xlab = "t [s]",
#' log = "x",
#' main = "Fig. 4 - Bos & Wallinga (2012)")
#'
#' values.t <- convert_CW2pLMi(values, P = 1/20)
#' lines(values[1:length(values.t[, 1]), 1], values.t[, 2],
#' col = "red",lwd = 1.3)
#' text(0.03,4500,"LM", col = "red", cex = .8)
#'
#' values.t <- convert_CW2pHMi(values, delta = 40)
#' lines(values[1:length(values.t[, 1]), 1], values.t[, 2],
#' col = "black", lwd = 1.3)
#' text(0.005,3000,"HM", cex = .8)
#'
#' values.t <- convert_CW2pPMi(values, P = 1/10)
#' lines(values[1:length(values.t[, 1]), 1], values.t[, 2],
#' col = "blue", lwd = 1.3)
#' text(0.5,6500,"PM", col = "blue", cex = .8)
#'
#' @md
#' @export
convert_CW2pPMi<- function(
values,
P
) {
.set_function_name("convert_CW2pPMi")
on.exit(.unset_function_name(), add = TRUE)
## Integrity checks -------------------------------------------------------
##(1) data.frame or RLum.Data.Curve object?
.validate_class(values, c("data.frame", "RLum.Data.Curve"))
.validate_not_empty(values)
##(2) if the input object is an 'RLum.Data.Curve' object check for allowed curves
if (inherits(values, "RLum.Data.Curve")) {
if(!grepl("OSL", values@recordType) & !grepl("IRSL", values@recordType)){
.throw_error("recordType ", values@recordType,
" is not allowed for the transformation")
}
temp.values <- as(values, "data.frame")
}else{
temp.values <- values
}
# (3) Transform values ------------------------------------------------------
##log transformation of the CW-OSL count values
CW_OSL.log<-log(temp.values[,2])
##time transformation t >> t'
t<-temp.values[,1]
##set P
##if no values for P is set selected a P value for a maximum of
##two extrapolation points
if(missing(P)==TRUE){
i<-1
P<-1/i
t.transformed<-(1/3)*(1/P^2)*t^3
while(length(t.transformed[t.transformed2){
P<-1/i
t.transformed<-(1/3)*(1/P^2)*t^3
i<-i+1
}
}else{
t.transformed<-(1/3)*(1/P^2)*t^3
}
# (4) Interpolation ---------------------------------------------------------
##interpolate values, values beyond the range return NA values
CW_OSL.interpolated <- approx(t, CW_OSL.log, xout=t.transformed, rule=1 )
##combine t.transformed and CW_OSL.interpolated in a data.frame
temp<-data.frame(x=t.transformed, y = unlist(CW_OSL.interpolated$y))
# (5) Extrapolate first values of the curve ---------------------------------
##(a) - find index of first rows which contain NA values (needed for extrapolation)
temp.sel.id<-min(which(is.na(temp[,2])==FALSE))
##(b) - fit linear function
fit.lm <- stats::lm(y ~ x, data.frame(x = t[1:2], y = CW_OSL.log[1:2]))
##select values to extrapolate and predict (extrapolate) values based on the fitted function
x.i<-data.frame(x=temp[1:(min(temp.sel.id)-1),1])
y.i<-predict(fit.lm,x.i)
##replace NA values by extrapolated values
temp[1:length(y.i),2]<-y.i
##set method values
temp.method<-c(rep("extrapolation",length(y.i)),rep("interpolation",(length(temp[,2])-length(y.i))))
##print a warning message for more than two extrapolation points
if (temp.sel.id > 2) {
.throw_warning("t' is beyond the time resolution: only two data points ",
"have been extrapolated, the first ", temp.sel.id - 3,
" points were set to 0")
}
# (6) Convert, transform and combine values ---------------------------------
##unlog CW-OSL count values, i.e. log(CW) >> CW
CW_OSL<-exp(temp$y)
##transform CW-OSL values to pPM-OSL values
pPM<-(t^2/P^2)*CW_OSL
##combine all values and exclude NA values
temp.values <- data.frame(x=t, y.t=pPM, x.t=t.transformed, method=temp.method)
temp.values <- na.exclude(temp.values)
# (7) Return values ---------------------------------------------------------
##returns the same data type as the input
if(is(values, "data.frame") == TRUE){
values <- temp.values
return(values)
}else{
##add old info elements to new info elements
temp.info <- c(values@info,
CW2pPMi.x.t = list(temp.values$x.t),
CW2pPMi.method = list(temp.values$method))
newRLumDataCurves.CW2pPMi <- set_RLum(
class = "RLum.Data.Curve",
recordType = values@recordType,
data = as.matrix(temp.values[,1:2]),
info = temp.info)
return(newRLumDataCurves.CW2pPMi)
}
}
#' @rdname convert_CW2pPMi
#' @export
CW2pPMi <- function(values, P) {
.Deprecated("convert_CW2pPMi")
convert_CW2pPMi(values, P)
}
Luminescence/R/Luminescence-generics.R 0000644 0001762 0000144 00000054436 14762554470 017451 0 ustar ligges users ## --------------------------------------------------------------------------
#' @title Channel binning for RLum.Data S4 class objects.
#'
#' @description
#' The function provides a generalised access point for specific
#' [RLum.Data-class] objects. Depending on the input object, the corresponding
#' function will be selected.
#' Allowed arguments can be found in the documentations of the corresponding
#' [RLum.Data-class] class.
#'
#' @param object [RLum.Data-class] (**required**):
#' S4 object of class `RLum.Data`
#'
#' @param ... further arguments passed to the specific class method
#'
#' @return
#' An object of the same type as the input object provided.
#'
#' @section Function version: 0.2.0
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @note Currently only `RLum.Data` objects of class [RLum.Data.Curve-class]
#' and [RLum.Data.Spectrum-class] are supported.
#'
#' @seealso [RLum.Data.Curve-class], [RLum.Data.Spectrum-class]
#'
#' @examples
#'
#' ## load example data
#' data(ExampleData.CW_OSL_Curve, envir = environment())
#'
#' ## create RLum.Data.Curve object from this example
#' curve <-
#' set_RLum(
#' class = "RLum.Data.Curve",
#' recordType = "OSL",
#' data = as.matrix(ExampleData.CW_OSL_Curve)
#' )
#'
#' ## plot data without and with 2 and 4 channel binning
#' plot_RLum(curve)
#' plot_RLum(bin_RLum.Data(curve, bin_size = 2))
#' plot_RLum(bin_RLum.Data(curve, bin_size = 4))
#'
#' @keywords utilities
#'
#' @md
#' @export
setGeneric("bin_RLum.Data", function(object, ...) {
standardGeneric("bin_RLum.Data")
})
## --------------------------------------------------------------------------
#' @title General accessor function for Risoe.BINfileData objects
#'
#' @description
#' The function provides a generalised access point for specific
#' [Risoe.BINfileData-class] objects. Depending on the input object, the
#' corresponding function will be selected.
#' Allowed arguments can be found in the documentations of the corresponding
#' [Risoe.BINfileData-class] class.
#'
#' @param object [Risoe.BINfileData-class] (**required**):
#' S4 object of class `Risoe.BINfileData`
#'
#' @param ... further arguments passed to the specific class method
#'
#' @return
#' An object of the same type as the input object provided.
#'
#' @section Function version: 0.1.0
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [Risoe.BINfileData-class]
#'
#' @keywords utilities internal
#'
#' @md
#' @export
setGeneric("get_Risoe.BINfileData", function(object, ...) {
standardGeneric("get_Risoe.BINfileData")
})
## --------------------------------------------------------------------------
#' @title General accessor function for RLum S4 class objects
#'
#' @description
#' The function provides a generalised access point for specific
#' [RLum-class] objects. Depending on the input object, the corresponding
#' function will be selected.
#' Allowed arguments can be found in the documentations of the corresponding
#' [RLum-class] class.
#'
#' @param object [RLum-class] (**required**):
#' S4 object of class `RLum` or an object of type [list] containing only objects
#' of type [RLum-class]
#'
#' @param ... further arguments passed to the specific class method.
#'
#' @return
#' An object of the same type as the input object provided.
#'
#' @section Function version: 0.3.3
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum.Data.Curve-class], [RLum.Data.Image-class],
#' [RLum.Data.Spectrum-class], [RLum.Analysis-class], [RLum.Results-class]
#'
#' @keywords utilities
#'
#' @examples
#'
#' ## Example based using data and from the calc_CentralDose() function
#'
#' ## load example data
#' data(ExampleData.DeValues, envir = environment())
#'
#' ## apply the central dose model 1st time
#' temp1 <- calc_CentralDose(ExampleData.DeValues$CA1)
#'
#' ## get results and store them in a new object
#' temp.get <- get_RLum(object = temp1)
#'
#' @md
#' @export
setGeneric("get_RLum", function (object, ...) {
standardGeneric("get_RLum")
})
#' @describeIn get_RLum
#' Returns a list of [RLum-class] objects that had been passed to [get_RLum]
#'
#' @param class [character] (*optional*): allows to define the class that gets
#' selected if applied to a list, e.g., if a list consists of different type
#' of [RLum-class] objects, this arguments allows to make selection. If nothing
#' is provided, all RLum-objects are treated.
#'
#' @param null.rm [logical] (*with default*): remove empty and `NULL` objects.
#'
#' @md
#' @export
setMethod("get_RLum", signature = "list",
function(object, class = NULL, null.rm = FALSE, ...) {
## take care of the class argument
if (!is.null(class)) {
sel <- class[1] == vapply(object, function(x) class(x), character(1))
if (any(sel))
object <- object[sel]
rm(sel)
}
## make remove all non-RLum objects
selection <- lapply(seq_along(object), function(x) {
## get rid of all objects that are not of type RLum, this is better
## than leaving that to the user
if (inherits(object[[x]], what = "RLum")) {
## it might be the case the object already comes with empty objects,
## this would cause a crash
if (inherits(object[[x]], "RLum.Analysis") &&
length(object[[x]]@records) == 0)
return(NULL)
get_RLum(object[[x]], ...)
} else {
warning(paste0("[get_RLum()] object #",x," in the list was not of type 'RLum' and has been removed!"),
call. = FALSE)
return(NULL)
}
})
## remove empty or NULL objects after the selection ... if wanted
if (null.rm) {
## first set all empty objects to NULL ... for RLum.Analysis objects
selection <- lapply(1:length(selection), function(x) {
if (length(selection[[x]]) == 0 ||
(inherits(selection[[x]], "RLum.Analysis") &&
length(selection[[x]]@records) == 0))
return(NULL)
else
return(selection[[x]])
})
## get rid of all NULL objects
selection <- selection[!vapply(selection, is.null, logical(1))]
}
return(selection)
})
#' Method to handle NULL if the user calls get_RLum
#'
#' @describeIn get_RLum
#'
#' Returns `NULL`.
#'
#' @md
#' @export
setMethod("get_RLum", signature = "NULL",
function(object, ...) {
NULL
})
## --------------------------------------------------------------------------
#' @title Length retrieval function for RLum S4 class objects
#'
#' @description
#' The function provides a generalised access point for specific
#' [RLum-class] objects. Depending on the input object, the corresponding
#' function will be selected.
#' Allowed arguments can be found in the documentations of the corresponding
#' [RLum-class] class.
#'
#' @param object [RLum-class] (**required**):
#' S4 object of class `RLum`
#'
#' @return
#' An [integer] indicating the length of the object.
#'
#' @section Function version: 0.1.0
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso
#' [RLum.Data.Curve-class],
#' [RLum.Data.Image-class],
#' [RLum.Data.Spectrum-class],
#' [RLum.Analysis-class],
#' [RLum.Results-class]
#' @keywords utilities
#'
#' @md
#' @export
setGeneric("length_RLum", function(object) {
standardGeneric("length_RLum")
})
## --------------------------------------------------------------------------
#' @title Melt RLum-class objects into a flat data.frame
#'
#' @param object [RLum-class] (**required**):
#' S4 object of class `RLum`
#'
#' @param ... further arguments passed to the specific class method
#'
#' @return
#' A flat [data.frame].
#'
#' @section Function version: 0.1.0
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum.Data.Curve-class], [RLum.Analysis-class]
#'
#' @examples
#' data(ExampleData.XSYG, envir = environment())
#' melt_RLum(OSL.SARMeasurement[[2]][[1]])
#'
#' @keywords utilities
#'
#' @md
#' @export
setGeneric("melt_RLum", function(object, ...) {
standardGeneric("melt_RLum")
})
#' @describeIn melt_RLum
#' Returns a list a single [data.frame]
#'
#' @md
#' @export
setMethod("melt_RLum", signature = "list",
function(object, ...) {
## silently remove non-RLum objects
l <- .rm_nonRLum(object)
## just return NULL
if (length(l) == 0)
return(NULL)
## apply method in the objects and return the same
l <- lapply(object, function(x) {
t <- try(melt_RLum(x), silent = TRUE)
if (inherits(t, "try-error"))
return(NULL)
else
t
})
## remove NULL
l <- l[!vapply(l, is.null, logical(1))]
## now bind the data.frame
as.data.frame(data.table::rbindlist(l))
})
## --------------------------------------------------------------------------
#' @title Safe manipulation of object metadata
#'
#' @description
#' Generic functions for manipulation of metadata in [Risoe.BINfileData-class],
#' [RLum.Analysis-class] and [RLum.Data-class] objects.
#'
#' @param object (**required**) object to manipulate
#'
#' @param ... further arguments passed to the specific class method
#'
#' @param value the value to be assigned
#'
#' @author
#' Marco Colombo, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum.Data-class], [RLum.Analysis-class], [Risoe.BINfileData-class]
#'
#' @keywords utilities
#'
#' @examples
#'
#' ## load example data
#' data(ExampleData.BINfileData, envir = environment())
#'
#' ## show data
#' CWOSL.SAR.Data
#'
#' ## add a new field
#' add_metadata(CWOSL.SAR.Data,
#' info_element = "INSTITUTE") <- "Heidelberg University"
#'
#' ## rename a field
#' rename_metadata(CWOSL.SAR.Data,
#' info_element = "INSTITUTE") <- "INSTITUTION"
#'
#' ## replace all LTYPE to RSL
#' ## but only for the first position
#' replace_metadata(
#' object = CWOSL.SAR.Data,
#' info_element = "LTYPE",
#' subset = (POSITION == 1)) <- "RSL"
#'
#' ## replacing a field with NULL allows to remove that field
#' replace_metadata(CWOSL.SAR.Data,
#' info_element = "PREVIOUS") <- NULL
#'
#' ## show the modified data
#' CWOSL.SAR.Data
#'
#' @rdname metadata
#' @md
#' @export
setGeneric("add_metadata<-", function (object, ..., value) {
standardGeneric("add_metadata<-")
})
#' @rdname metadata
#' @export
setGeneric("rename_metadata<-", function (object, ..., value) {
standardGeneric("rename_metadata<-")
})
#' @rdname metadata
#' @export
setGeneric("replace_metadata<-", function (object, ..., value) {
standardGeneric("replace_metadata<-")
})
## --------------------------------------------------------------------------
#' @title Name retrieval function for RLum S4 class objects
#'
#' @description
#' The function provides a generalised access point for specific
#' [RLum-class] objects. Depending on the input object, the corresponding
#' function will be selected.
#' Allowed arguments can be found in the documentations of the corresponding
#' [RLum-class] class.
#'
#' @param object [RLum-class] (**required**):
#' S4 object of class `RLum`
#'
#' @return
#' A [character] vector.
#'
#' @section Function version: 0.1.0
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum.Data.Curve-class], [RLum.Data.Image-class],
#' [RLum.Data.Spectrum-class], [RLum.Analysis-class], [RLum.Results-class]
#'
#' @keywords utilities
#'
#' @aliases names_RLum
#'
#' @md
#' @export
setGeneric("names_RLum", function(object) {
standardGeneric("names_RLum")
})
#' @describeIn names_RLum
#' Returns a list of [RLum-class] objects that had been passed to [names_RLum]
#'
#' @md
#' @export
setMethod("names_RLum", signature = "list",
function(object) {
## apply method in the objects and return the same
lapply(object, function(x) {
if (inherits(x, "RLum")) {
return(names_RLum(x))
} else {
return(x)
}
})
})
## --------------------------------------------------------------------------
#' @title General replication function for RLum S4 class objects
#'
#' @description
#' The function replicates RLum S4 class objects and returns a list of such
#' objects.
#'
#' @param object [RLum-class] (**required**):
#' an [RLum-class] object
#'
#' @param times [integer] (*optional*):
#' number for times each element is repeated element
#'
#' @return
#' A [list] with the object repeated.
#'
#' @section Function version: 0.1.0
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum-class]
#'
#' @keywords utilities
#'
#' @md
#' @export
setGeneric("replicate_RLum", function (object, times = NULL) {
standardGeneric("replicate_RLum")
})
## --------------------------------------------------------------------------
#' @title General setter function for Risoe.BINfileData objects
#'
#' @description
#' The function provides a generalised access point for specific
#' [Risoe.BINfileData-class] objects. Depending on the input object, the
#' corresponding function will be selected.
#' Allowed arguments can be found in the documentations of the corresponding
#' [Risoe.BINfileData-class] class.
#'
#' @param METADATA x
#'
#' @param DATA x
#'
#' @param .RESERVED x
#'
#' @return
#' A [Risoe.BINfileData-class] object.
#'
#' @section Function version: 0.1
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [Risoe.BINfileData-class]
#'
#' @keywords utilities
#'
#' @md
#' @export
setGeneric("set_Risoe.BINfileData", function(METADATA = data.frame(),
DATA = list(), .RESERVED = list()) {
standardGeneric("set_Risoe.BINfileData")
})
## --------------------------------------------------------------------------
#' @title General setter function for RLum S4 class objects
#'
#' @description
#' The function provides a generalised access point for specific
#' [RLum-class] objects. Depending on the given class, the corresponding
#' method to create an object from this class will be selected.
#' Allowed additional arguments can be found in the documentations of the
#' corresponding [RLum-class] class:
#' - [RLum.Data.Curve-class],
#' - [RLum.Data.Image-class],
#' - [RLum.Data.Spectrum-class],
#' - [RLum.Analysis-class],
#' - [RLum.Results-class]
#'
#' @param class [character] (**required**):
#' name of the S4 class to create, must correspond to one of the [RLum-class]
#' classes.
#'
#' @param originator [character] (*automatic*):
#' contains the name of the calling function (the function that produces this object);
#' can be set manually.
#'
#' @param .uid [character] (*automatic*):
#' unique ID for this object, by default set using the internal C++ function
#' `create_UID`.
#'
#' @param .pid [character] (*with default*):
#' option to provide a parent id for nesting at will.
#'
#' @param ... further arguments passed to the specific class method
#'
#' @return
#' An object of the specified [RLum-class] class.
#'
#' @section Function version: 0.3.0
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum.Data.Curve-class], [RLum.Data.Image-class],
#' [RLum.Data.Spectrum-class], [RLum.Analysis-class], [RLum.Results-class]
#'
#' @keywords utilities
#'
#' @examples
#'
#' ## produce empty objects from each class
#' set_RLum(class = "RLum.Data.Curve")
#' set_RLum(class = "RLum.Data.Spectrum")
#' set_RLum(class = "RLum.Data.Spectrum")
#' set_RLum(class = "RLum.Analysis")
#' set_RLum(class = "RLum.Results")
#'
#' ## produce a curve object with arbitrary curve values
#' object <- set_RLum(
#' class = "RLum.Data.Curve",
#' curveType = "arbitrary",
#' recordType = "OSL",
#' data = matrix(c(1:100,exp(-c(1:100))),ncol = 2))
#'
#' ## plot this curve object
#' plot_RLum(object)
#'
#' @md
#' @export
setGeneric("set_RLum", function (class, originator, .uid = create_UID(),
.pid = NA_character_, ... ) {
.set_function_name("set_RLum")
on.exit(.unset_function_name(), add = TRUE)
.validate_class(class, "character")
class(class) <- as.character(class)
if (missing(originator)) {
if (is(sys.call(which = -1)[[1]], "language")) {
originator <- as.character(sys.call(which = -1)[[1]])
## account for calls using the double colons, in this case the vector
## is of length 3, not only 1
if (length(originator) == 3) {
originator <- originator[3]
}
} else {
originator <- NA_character_
}
}
standardGeneric("set_RLum")
})
## --------------------------------------------------------------------------
#' @title Smoothing of data for RLum S4-class objects
#'
#' @description
#' The function provides a generalised access point for specific
#' [RLum-class] objects. Depending on the input object, the corresponding
#' function will be selected.
#' Allowed arguments can be found in the documentations of the corresponding
#' [RLum-class] class. The smoothing is based on an internal function
#' called `.smoothing`.
#'
#' @param object [RLum-class] (**required**):
#' S4 object of class `RLum`
#'
#' @param ... further arguments passed to the specific class method
#'
#' @return
#' An object of the same type as the input object provided.
#'
#' @section Function version: 0.1.0
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @note
#' Currently only `RLum` objects of class `RLum.Data.Curve` and `RLum.Analysis`
#' (with curve data) are supported.
#'
#' @seealso [RLum.Data.Curve-class], [RLum.Analysis-class]
#'
#' @examples
#'
#' ## load example data
#' data(ExampleData.CW_OSL_Curve, envir = environment())
#'
#' ## create RLum.Data.Curve object from this example
#' curve <-
#' set_RLum(
#' class = "RLum.Data.Curve",
#' recordType = "OSL",
#' data = as.matrix(ExampleData.CW_OSL_Curve)
#' )
#'
#' ## plot data without and with smoothing
#' plot_RLum(curve)
#' plot_RLum(smooth_RLum(curve))
#'
#' @keywords utilities
#'
#' @md
#' @export
setGeneric("smooth_RLum", function(object, ...) {
standardGeneric("smooth_RLum")
})
#' @describeIn smooth_RLum
#' Returns a list of [RLum-class] objects that had been passed to [smooth_RLum]
#'
#' @md
#' @export
setMethod("smooth_RLum", signature = "list",
function(object, ...) {
## apply method in the objects and return the same
lapply(object, function(x) {
if (inherits(x, "RLum")) {
return(smooth_RLum(x,...))
} else {
return(x)
}
})
})
## --------------------------------------------------------------------------
#' @title Sort data for RLum S4-class objects
#'
#' @description
#' The function provides a generalised access point for specific
#' [RLum-class] objects. Depending on the input object, the corresponding
#' function will be selected.
#' Allowed arguments can be found in the documentations of the corresponding
#' [RLum-class] class.
#'
#' @param object [RLum-class] or [Risoe.BINfileData-class] (**required**):
#' S4 object of class `RLum.Analysis` or `Risoe.BINfileData`
#'
#' @param ... further arguments passed to the specific class method
#'
#' @return
#' An object of the same type as the input object provided.
#'
#' @section Function version: 0.1.0
#'
#' @author
#' Marco Colombo, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum.Analysis-class], [Risoe.BINfileData-class]
#'
#' @examples
#'
#' ## load example data
#' data(ExampleData.XSYG, envir = environment())
#' obj <- OSL.SARMeasurement$Sequence.Object[1:9]
#'
#' sort_RLum(obj, slot = "recordType")
#' sort_RLum(obj, info_element = "curveDescripter")
#'
#' @keywords utilities
#'
#' @md
#' @export
setGeneric("sort_RLum", function(object, ...) {
standardGeneric("sort_RLum")
})
## --------------------------------------------------------------------------
#' @title General structure function for RLum S4 class objects
#'
#' @description
#' The function provides a generalised access point for specific
#' [RLum-class] objects. Depending on the input object, the corresponding
#' function will be selected.
#' Allowed arguments can be found in the documentations of the corresponding
#' [RLum-class] class.
#'
#' @param object [RLum-class] (**required**):
#' S4 object of class `RLum`
#'
#' @param ... further arguments passed to the specific class method
#'
#' @return
#' Returns a [data.frame] with structure of the object.
#'
#' @section Function version: 0.2.0
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [RLum.Data.Curve-class], [RLum.Data.Image-class],
#' [RLum.Data.Spectrum-class], [RLum.Analysis-class], [RLum.Results-class]
#'
#' @keywords utilities
#'
#' @examples
#'
#' ## load example data
#' data(ExampleData.XSYG, envir = environment())
#'
#' ## show structure
#' structure_RLum(OSL.SARMeasurement$Sequence.Object)
#'
#' @md
#' @export
setGeneric("structure_RLum", function(object, ...) {
standardGeneric("structure_RLum")
})
#' @describeIn structure_RLum
#' Returns a list of [RLum-class] objects that were passed to [structure_RLum]
#'
#' @md
#' @export
setMethod("structure_RLum", signature = "list",
function(object, ...) {
## apply method in the objects and return the same
lapply(object, function(x) {
if (inherits(x, "RLum")) {
return(structure_RLum(x, ...))
} else {
return(x)
}
})
})
## --------------------------------------------------------------------------
#' @title Convenience data visualisation function
#'
#' @description
#' Invokes the [utils::View] function tailored to objects in the package.
#' If started from RStudio, it uses the RStudio viewer.
#'
#' @param object (**required**) object to view
#'
#' @param ... further arguments passed to the specific class method
#'
#' @seealso [utils::View()]
#'
#' @returns
#' `NULL` and opens the data viewer.
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @keywords utilities
#'
#' @md
#' @export
setGeneric("view", function (object, ... ) {
standardGeneric("view")
})
## ensure that we can use the internal RStudio view function
## https://stackoverflow.com/questions/48234850/how-to-use-r-studio-view-function-programatically-in-a-package
#' @md
#' @noRd
.view <- function(x, title) {
get("View", envir = as.environment("package:utils"))(x, title) # nocov
}
Luminescence/R/plot_ViolinPlot.R 0000644 0001762 0000144 00000017415 14762554470 016373 0 ustar ligges users #' @title Create a violin plot
#'
#' @description
#' Draws a kernel density plot in combination with a boxplot in its middle. The shape of the violin
#' is constructed using a mirrored density curve. This plot is especially designed for cases
#' where the individual errors are zero or too small to be visualised. The idea for this plot is
#' based on the 'volcano plot' in the ggplot2 package by Hadley Wickham and Winston Chang.
#' The general idea for the violin plot seems to have been introduced by
#' Hintze and Nelson (1998).
#'
#' The function is passing several arguments to the functions [plot],
#' [stats::density], [graphics::boxplot]:
#'
#' Supported arguments are:
#' `xlim`, `main`, `xlab`, `ylab`, `col.violin`, `col.boxplot`, `mtext`, `cex`, `mtext`
#'
#' **`Valid summary keywords`**
#'
#' `'n'`, `'mean'`, `'median'`, `'sd.abs'`, `'sd.rel'`, `'se.abs'`, `'se.rel'`.
#' `'skewness'`, `'kurtosis'`
#'
#' @param data [numeric] or [RLum.Results-class] (**required**):
#' input data for plotting. Alternatively a [data.frame] or a [matrix] can
#' be provided, but only the first column will be considered by the
#' function
#'
#' @param boxplot [logical] (*with default*):
#' enable/disable boxplot
#'
#' @param rug [logical] (*with default*):
#' enable/disable rug
#'
#' @param summary [character] (*optional*):
#' add statistic measures of centrality and dispersion to the plot.
#' Can be one or more of several keywords. See details for available keywords.
#'
#' @param summary.pos [numeric] or [character] (*with default*):
#' optional position keywords (cf. [legend]) for the statistical summary.
#' Alternatively, the keyword `"sub"` may be specified to place the summary
#' below the plot header. However, this latter option in only possible if
#' `mtext` is not used.
#'
#' @param na.rm [logical] (*with default*):
#' exclude NA values from the data set prior to any further operations.
#'
#' @param ... further arguments and graphical parameters passed to
#' [plot.default], [stats::density] and [boxplot]. See details for further
#' information.
#'
#' @note
#' Although the code for this function was developed independently and just the idea for the plot
#' was based on the 'ggplot2' package plot type 'volcano', it should be mentioned that, beyond this,
#' two other R packages exist providing a possibility to produces this kind of plot, namely:
#' `'vioplot'` and `'violinmplot'` (see references for details).
#'
#' @section Function version: 0.1.4
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @references
#' Daniel Adler (2005). vioplot: A violin plot is a combination of a box plot and a kernel density plot.
#' R package version 0.2 http://CRAN.R-project.org/package=violplot
#'
#' Hintze, J.L., Nelson, R.D., 1998. A Box Plot-Density Trace Synergism. The American Statistician 52, 181-184.
#'
#' Raphael W. Majeed (2012). violinmplot: Combination of violin plot with mean and standard deviation.
#' R package version 0.2.1. http://CRAN.R-project.org/package=violinmplot
#'
#' Wickham. H (2009). ggplot2: elegant graphics for data analysis. Springer New York.
#'
#' @seealso [stats::density], [plot], [boxplot], [rug], [calc_Statistics]
#'
#' @examples
#'
#' ## read example data set
#' data(ExampleData.DeValues, envir = environment())
#' ExampleData.DeValues <- convert_Second2Gray(ExampleData.DeValues$BT998,
#' c(0.0438,0.0019))
#'
#' ## create plot straightforward
#' plot_ViolinPlot(data = ExampleData.DeValues)
#'
#' @md
#' @export
plot_ViolinPlot <- function(
data,
boxplot = TRUE,
rug = TRUE,
summary = NULL,
summary.pos = "sub",
na.rm = TRUE,
...
) {
.set_function_name("plot_ViolinPlot")
on.exit(.unset_function_name(), add = TRUE)
## Integrity checks -------------------------------------------------------
.validate_class(data, c("RLum.Results", "data.frame", "matrix"))
.validate_not_empty(data)
.validate_class(summary.pos, "character")
if (inherits(data, "RLum.Results")) {
data <- get_RLum(data, "data")
}
if (is.data.frame(data) || is.matrix(data)) {
data <- data[, 1]
}
##Remove NA values
if(na.rm){
data <- na.exclude(data)
if(length(attr(data, "na.action")) > 0){
.throw_warning(length(attr(data, "na.action")), " NA values removed")
}
}
##stop if only one or 0 values are left in data
if(length(data) == 0){
.throw_warning("After NA removal, nothing is left from the data set")
return()
}
# Pre-calculations ----------------------------------------------------------------------------
##density for the violin
if(length(data)>1){
density <-
density(x = data,
bw = ifelse("bw" %in% names(list(...)),list(...)$bw,"nrd0"))
}else{
density <- NULL
.throw_warning("Single data point found, no density calculated")
}
##some statistical parameter, get rid of the weighted statistics
stat.summary <- list(suppressWarnings(calc_Statistics(as.data.frame(data), digits = 2)[["unweighted"]]))
names(stat.summary) <- "unweighted"
##make valid summary string
if(is.null(summary)){
summary <- c("n","median")
}
##at least show a warning for invalid keywords
if(!all(summary %in% names(stat.summary[[1]]))){
.throw_warning("Only keywords for weighted statistical measures ",
"are supported. Valid keywords are: ",
.collapse(names(stat.summary[[1]])))
}
##make sure that only valid keywords make it
summary <- summary[(summary %in% names(stat.summary[[1]]))]
stat.text <- .create_StatisticalSummaryText(stat.summary, keywords = summary, sep = " \n ")
stat.mtext <- .create_StatisticalSummaryText(stat.summary, keywords = summary, sep = " | ")
# Plot settings -------------------------------------------------------------------------------
##set default values
plot.settings <- list(
xlim = if(!is.null(density)){range(density$x)}else{c(data[1]*0.9, data[1]*1.1)},
main = "Violin Plot",
xlab = expression(paste(D[e], " [a.u.]")),
ylab = if(!is.null(density)){"Density"}else{" "},
col.violin = rgb(0,0,0,0.2),
col.boxplot = NULL,
mtext = ifelse(summary.pos != 'sub', "", stat.mtext),
cex = 1
)
##modify list accordingly
plot.settings <- modifyList(plot.settings, val = list(...))
# Plot ----------------------------------------------------------------------------------------
##open empty plot area
plot(
NA,NA,
xlim = plot.settings$xlim,
ylim = c(0.2,1.8),
xlab = plot.settings$xlab,
ylab = plot.settings$ylab,
yaxt = "n",
main = plot.settings$main,
cex = plot.settings$cex
)
##add polygon ... the violin
if(!is.null(density)){
polygon(
x = c(density$x, rev(density$x)),
y = c(1 + density$y / max(density$y) * 0.5,
rev(1 - density$y / max(density$y) * 0.5)),
col = plot.settings$col.violin,
border = plot.settings$col.violin
)
}
##add the boxplot
if(boxplot){
graphics::boxplot(
data,
outline = TRUE,
boxwex = 0.4,
horizontal = TRUE,
axes = FALSE,
add = TRUE,
col = plot.settings$col.boxplot
)
}
##add rug
if(rug){
graphics::rug(x = data)
}
##add mtext
if(!is.null(plot.settings$mtext)){
mtext(side = 3, text = plot.settings$mtext)
}
##add stat.text
if (summary.pos != "sub") {
valid_keywords <-
c(
"bottomright", "bottom", "bottomleft", "left", "topleft", "top", "topright", "right", "center"
)
if (any(
summary.pos %in% valid_keywords
)) {
legend(summary.pos, legend = stat.text, bty = "n")
}else{
.throw_warning("Value provided for 'summary.pos' is not ",
"a valid keyword, valid keywords are:",
.collapse(valid_keywords))
}
}
}
Luminescence/R/merge_RLum.Data.Curve.R 0000644 0001762 0000144 00000021216 14762554470 017221 0 ustar ligges users #' @title Merge function for RLum.Data.Curve S4 class objects
#'
#' @description This function allows to merge [RLum.Data.Curve-class] objects in different
#' ways without modifying the original objects. Merging is always applied on
#' the 2nd column of the object's data matrix.
#'
#' **Supported merge operations are:**
#'
#' `"mean"` (default)
#'
#' The mean over the count values is calculated using the function
#' [rowMeans].
#'
#' `"median"`
#'
#' The median over the count values is calculated using the function
#' [matrixStats::rowMedians].
#'
#' `"sum"`
#'
#' All count values will be summed up using the function [rowSums].
#'
#' `"sd"`
#'
#' The standard deviation over the count values is calculated using the function
#' [matrixStats::rowSds].
#'
#' `"var"`
#'
#' The variance over the count values is calculated using the function
#' [matrixStats::rowVars].
#'
#' `"min"`
#'
#' The min values from the count values is chosen using the function
#' [matrixStats::rowMins][matrixStats::rowRanges].
#'
#' `"max"`
#'
#' The max values from the count values is chosen using the function
#' [matrixStats::rowMins][matrixStats::rowRanges].
#'
#' `"append"`
#'
#' Appends count values of all curves to one combined data curve. The channel width
#' is automatically re-calculated, but requires a constant channel width of the
#' original data.
#'
#' `"-"`
#'
#' The row sums of the last objects are subtracted from the first object.
#'
#' `"*"`
#'
#' The row sums of the last objects are multiplied with the first object.
#'
#' `"/"`
#'
#' Values of the first object are divided by row sums of the last objects.
#'
#' @param object [list] of [RLum.Data.Curve-class] (**required**):
#' list of objects to be merged.
#'
#' @param merge.method [character] (**required**):
#' method for combining of the objects, e.g. `'mean'` (default), `'median'`,
#' `'sum'`, see details for
#' further information and allowed methods. Note: Elements in slot info will
#' be taken from the first curve in the list.
#'
#' @param method.info [numeric] (*optional*):
#' allows to specify how info elements of the input objects are combined,
#' e.g. `1` means that just the elements from the first object are kept,
#' `2` keeps only the info elements from the 2 object etc.
#' If nothing is provided all elements are combined.
#'
#' @return Returns an [RLum.Data.Curve-class] object.
#'
#' @note
#' The information from the slot `recordType` is taken from the first
#' object in the input list. The slot
#' 'curveType' is filled with the name `merged`.
#'
#' @section S3-generic support:
#'
#' This function is fully operational via S3-generics:
#' ``+``, ``-``, ``/``, ``*``, `merge`
#'
#' @section Function version: 0.2.1
#'
#' @author
#' Sebastian Kreutzer, Institute of Geography, Heidelberg University (Germany)
#'
#' @seealso [merge_RLum], [RLum.Data.Curve-class]
#'
#'
#' @keywords utilities internal
#'
#' @examples
#'
#' ##load example data
#' data(ExampleData.XSYG, envir = environment())
#'
#' ##grep first and 3d TL curves
#' TL.curves <- get_RLum(OSL.SARMeasurement$Sequence.Object, recordType = "TL (UVVIS)")
#' TL.curve.1 <- TL.curves[[1]]
#' TL.curve.3 <- TL.curves[[3]]
#'
#' ##plot single curves
#' plot_RLum(TL.curve.1)
#' plot_RLum(TL.curve.3)
#'
#' ##subtract the 1st curve from the 2nd and plot
#' TL.curve.merged <- merge_RLum.Data.Curve(list(TL.curve.3, TL.curve.1), merge.method = "/")
#' plot_RLum(TL.curve.merged)
#'
#' @md
#' @export
merge_RLum.Data.Curve<- function(
object,
merge.method = "mean",
method.info
) {
.set_function_name("merge_RLum.Data.Curve")
on.exit(.unset_function_name(), add = TRUE)
## Integrity checks -------------------------------------------------------
.validate_class(object, "list")
##(1) check if object is of class RLum.Data.Curve
num.objects <- length(object)
temp.recordType.test <- sapply(object, function(x) {
.validate_class(x, "RLum.Data.Curve",
name = "All elements of 'object'")
return(x@recordType)
})
##(2) Check for similar record types
record.types <- unique(temp.recordType.test)
if (length(record.types) > 1) {
.throw_error("Only similar record types are supported; you are trying to merge: ",
.collapse(record.types))
}
merge.method <- .validate_args(merge.method,
c("mean", "median", "sum", "sd", "var", "max",
"min", "append", "-", "*", "/"))
## Merge objects ----------------------------------------------------------
##merge data objects
##problem ... how to handle data with different resolution or length?
##(1) build new data matrix
## first find the shortest object
check.rows <- vapply(object, function(x) nrow(x@data), numeric(1))
if (length(check.rows) < 2) {
.throw_error("'object' contains no data")
}
num.rows <- min(check.rows)
## channel resolution of the first object: we need to round as there may
## otherwise be numerical artefacts that would make the step not unique
step <- round(diff(object[[1]]@data[, 1]), 1)[1]
## extract the curve values from each object
temp.matrix <- sapply(1:num.objects, function(x) {
## check the resolution (roughly)
if (round(diff(object[[x]]@data[, 1]), 1)[1] != step)
.throw_error("The objects do not seem to have the same channel resolution")
## limit all objects to the shortest one
object[[x]]@data[1:num.rows, 2]
})
## throw the warning only now to avoid printing it in case of error
if (length(unique(check.rows)) != 1) {
.throw_warning("The number of channels differs between the curves, the ",
"merged curve will have the length of the shortest object")
}
##(2) apply selected method for merging
if(merge.method == "sum"){
temp.matrix <- rowSums(temp.matrix)
}else if(merge.method == "mean"){
temp.matrix <- rowMeans(temp.matrix)
}else if(merge.method == "median"){
temp.matrix <- matrixStats::rowMedians(temp.matrix)
}else if(merge.method == "sd"){
temp.matrix <- matrixStats::rowSds(temp.matrix)
}else if(merge.method == "var"){
temp.matrix <- matrixStats::rowVars(temp.matrix)
}else if(merge.method == "max"){
temp.matrix <- matrixStats::rowMaxs(temp.matrix)
}else if(merge.method == "min"){
temp.matrix <- matrixStats::rowMins(temp.matrix)
}else if(merge.method == "append") {
temp.matrix <- sapply(temp.matrix, c)
}else if(merge.method == "-"){
if (num.objects > 2) {
temp.matrix <- temp.matrix[,1] - rowSums(temp.matrix[,-1])
}else{
temp.matrix <- temp.matrix[,1] - temp.matrix[,2]
}
}else if(merge.method == "*"){
if (num.objects > 2) {
temp.matrix <- temp.matrix[,1] * rowSums(temp.matrix[,-1])
}else{
temp.matrix <- temp.matrix[,1] * temp.matrix[,2]
}
}else if(merge.method == "/"){
if (num.objects > 2) {
temp.matrix <- temp.matrix[,1] / rowSums(temp.matrix[,-1])
}else{
temp.matrix <- temp.matrix[,1] / temp.matrix[,2]
}
## replace infinities with 0 and throw warning
id.inf <- which(is.infinite(temp.matrix) == TRUE)
if (length(id.inf) > 0) {
temp.matrix[id.inf] <- 0
.throw_warning(length(id.inf),
" 'inf' values have been replaced by 0 in the matrix")
}
}
## add back the first column to RLum.Data.Curve objects
#If we append the data of the second to the first curve we have to recalculate
#the x-values (probably time/channel). The difference should always be the
#same, so we just expand the sequence if this is true. If this is not true,
#we revert to the default behaviour (i.e., append the x values)
if (merge.method == "append") {
newx <- seq(from = min(object[[1]]@data[, 1]), by = step,
length.out = sum(check.rows))
temp.matrix <- cbind(newx, temp.matrix)
} else {
temp.matrix <- cbind(object[[1]]@data[1:num.rows, 1], temp.matrix)
}
##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
##merge info objects as simple as possible ... just keep them all ... other possibility
##would be to choose on the input objects
##unlist is needed here, as otherwise it would cause unexpected behaviour further using
##the RLum.object
if(missing(method.info)){
temp.info <- unlist(lapply(1:num.objects, function(x) {
object[[x]]@info
}), recursive = FALSE)
}else{
temp.info <- object[[method.info]]@info
}
## Build new RLum.Data.Curve object ---------------------------------------
temp.new.Data.Curve <- set_RLum(
class = "RLum.Data.Curve",
originator = "merge_RLum.Data.Curve",
recordType = object[[1]]@recordType,
curveType = "merged",
data = temp.matrix,
info = temp.info,
.pid = unlist(lapply(object, function(x) {
x@.uid
}))
)
return(temp.new.Data.Curve)
}
Luminescence/vignettes/ 0000755 0001762 0000144 00000000000 14762561726 014714 5 ustar ligges users Luminescence/vignettes/crosstalk.Rmd 0000644 0001762 0000144 00000033103 14762554470 017363 0 ustar ligges users ---
title: "Assessing crosstalk in single-grain luminescence detection"
output:
rmarkdown::html_vignette:
toc: true
author: "Luc Steinbuch, Anna-Maartje de Boer, Wageningen University & Research"
date: "February 2025"
vignette: >
%\VignetteIndexEntry{Assessing crosstalk in single-grain luminescence detection}
%\VignetteEngine{knitr::rmarkdown}
%\VignetteEncoding{UTF-8}
---
```{r, include = FALSE}
knitr::opts_chunk$set(
collapse = TRUE,
comment = "#>"
)
```
# Crosstalk
This vignette explores the crosstalk-related functions in the "Luminescence"
package, related to research paper "A novel tool to assess crosstalk in
single-grain luminescence detection", by Anna-Maartje de Boer, Luc Steinbuch,
Gerard Heuvelink and Jakob Wallinga.
Crosstalk in single-grain luminescence imaging (EMCCD) is the overlapping of luminescence signals from adjacent grains on a single-grain disc. The actual signal on one grain location influences the observed signal on a neighboring grain location which happens to be on the same measurement disc (one "position" in the reader). In this research and the shown functions, we define "neighboring" as rook-wise (horizontally and vertically) only, and we assume that all measurement discs have a regular grid of 10x10 grain locations.
```{r init}
library(Luminescence)
```
# Explore imaged luminescence signals from a single-grain disc (one "position" in the reader)
All grain location observations on one single-grain measurement disc are represented by a vector of 100 numbers. Here we simulate such a disc by randomly selecting from two normal distributions. The prefix "vn_" means: a vector of numbers:
```{r simulate_signal, fig.dim = c(8, 6), out.width="800px"}
vn_simulated <- sample(x = c(rnorm(n = 30, mean = 2000, sd = 500),
rnorm(n = 70, mean = 20, sd = 1)),
size = 100)
vn_simulated <- round(vn_simulated) # Because photons are discrete
head(vn_simulated, n = 25)
hist(vn_simulated,
main = "Simulated signal (histogram)",
xlab = "Photon counts",
ylab = "Frequency",
breaks = 30
)
```
## plot_SingleGrainDisc
Let's visualize the disc/position:
```{r show_disc_basic, fig.dim = c(7, 7), out.width="800px"}
par(mar = c(1, 4, 6, 4))
plot_SingleGrainDisc(object = vn_simulated,
main = "Simulated signal (measurement disc)"
)
```
Let's calculate Moran's I, and the associated pseudo-p, of our randomly ordered simulated disc:
```{r calculate_moransI}
calc_MoransI(object = vn_simulated)
calc_MoransI(object = vn_simulated, compute_pseudo_p = TRUE)
```
what changes if we add a serious amount, say 10%, of crosstalk?
```{r add_crosstalk, fig.dim = c(8, 6), out.width="800px"}
vn_simulated_with_crosstalk <- apply_Crosstalk(object = vn_simulated,
n_crosstalk = 0.10)
vn_simulated_with_crosstalk <- round(vn_simulated_with_crosstalk)
hist(vn_simulated_with_crosstalk,
main = "Simulated signal with crosstalk (histogram)",
xlab = "Photon counts",
ylab = "Frequency",
breaks = 30
)
plot_SingleGrainDisc(object = vn_simulated_with_crosstalk,
main = "Simulated signal with crosstalk (measurement disc)")
calc_MoransI(object = vn_simulated_with_crosstalk)
calc_MoransI(object = vn_simulated_with_crosstalk, compute_pseudo_p = TRUE)
```
Let's try several amounts of simulated crosstalk:
```{r test_different_amounts, fig.dim = c(8, 6), out.width="800px"}
df_MoransI <- data.frame(crosstalk = seq(from = 0,
to = 0.30,
length.out=50))
df_MoransI$MoransI <- NA
df_MoransI$pseudo_p <- NA
old.opts <- options(warn = -1) # silence warnings from compute_pseudo_p
for (i in 1:nrow(df_MoransI))
{
vn_simulated_with_crosstalk <- apply_Crosstalk(object = vn_simulated,
n_crosstalk = df_MoransI$crosstalk[i])
df_MoransI$MoransI[i] <- calc_MoransI(object = vn_simulated_with_crosstalk)
df_MoransI$pseudo_p[i] <-
calc_MoransI(object = vn_simulated_with_crosstalk, compute_pseudo_p = TRUE)
}
options(old.opts) # restore the default options
n_expected_I_no_spatial_autocorr <- calc_MoransI(1:100,
spatial_autocorrelation = FALSE)
##
plot(x = df_MoransI$crosstalk,
y = df_MoransI$MoransI,
ylim = range(
pretty(x = c(df_MoransI$MoransI, n_expected_I_no_spatial_autocorr))
),
## Set ylim manually to make sure the value for I for no crosstalk is visible
xlab = "Amount of added crosstalk",
ylab = "Calculated Moran's I"
)
graphics::grid()
abline(h = n_expected_I_no_spatial_autocorr,
col = "purple")
legend(x = "topleft",
legend = "Expected I if no spatial autocorrelation",
lty = "solid",
col = "purple",
cex = 0.8)
plot(x = df_MoransI$crosstalk,
y = df_MoransI$pseudo_p,
xlab = "Amount of added crosstalk",
ylab = "Generated pseudo-p of related Moran's I")
graphics::grid()
```
Please note that above two plots are subject to randomness; for a good assessment many simulations have to be performed.
# Moran scatterplot
A way to visualise spatial auto-correlation is the Moran scatterplot:
```{r show_`disc_extended_moran_scatterplot, fig.dim = c(8, 5), out.width="800px"}
plot_MoranScatterplot(object = vn_simulated,
main = "Moran scatterplot, simulated signal without crosstalk")
vn_simulated_with_crosstalk <- apply_Crosstalk(object = vn_simulated,
n_crosstalk = 0.25)
vn_simulated_with_crosstalk <- round(vn_simulated_with_crosstalk)
plot_MoranScatterplot(object = vn_simulated_with_crosstalk,
main = "Moran scatterplot, simulated signal with added crosstalk")
```
The plot area is divided into four quadrants using the mean in each dimension; the South-west and North-east quadrant represent a contribution to a positive spatial autocorrelation, while the North-west and South-east quadrants indicate a negative spatial correlation. Between the point, a least square line (which slopes indicates, but not exactly represents, Moran's I) is added, as well as an 1:1 line (which indicates a Moran's I of around 1, suggesting a perfect positive spatial correlation).
The internal function `.get_Neighbours()` was until now used on the
background, but we can explicitly call it to generate a dataframe with all
positions which are rook connected to each other (note that we need to use
the `Luminescence:::` prefix as this function is not exported by the package):
```{r adjacent_grain_locations, fig.dim = c(8, 5), out.width="800px"}
vn_simulated_with_holes <- c(rnorm(30, mean = 10, sd = 5),
rnorm(30, mean = 500, sd = 50),
rep(NA, times = 40)
)
df_Neighbours <- Luminescence:::.get_Neighbours(object = vn_simulated_with_holes)
head(df_Neighbours)
```
And we can plot the first disc, while indicating which borders are taken into account. The corresponding `adjacent_grain_locations` is calculated in the background:
```{r adjacent_grain_locations_show_disc, fig.dim = c(8, 5), out.width="800px"}
plot_SingleGrainDisc(object = vn_simulated_with_holes,
show_neighbours = TRUE,
show_location_ids = TRUE)
```
Also other functions, such as `calc_MoransI()`, work as long as the remaining grid does not become too sparse. Note that in this context all observations, even "islands" who do not border any other grains, are used for the calculation of Moran's I.
# Add borders with certain weight
One can manually change `df_Neighbours`, for example add the diagonal borders and attain a certain weight to it, and add it as argument to almost all functions. Assume that we want to add a few diagonal borders with weight 1/sqrt(2) to a full disc (note that the standard relative weight for rook borders is set to one):
```{r adjacent_grain_locations_add, fig.dim = c(8, 5), out.width="800px"}
df_Neighbours_with_diag <- Luminescence:::.get_Neighbours(object = vn_simulated)
for (i in c(1:9, 11:19, 21:29) )
{
df_Neighbours_with_diag <- rbind(df_Neighbours_with_diag,
c(i, i+11, 1/sqrt(2))
)
}
tail(df_Neighbours_with_diag)
plot_SingleGrainDisc(object = vn_simulated,
df_neighbours = df_Neighbours_with_diag,
show_neighbours = TRUE,
show_location_ids = TRUE)
```
To exclude all border effects, we can use the `ignore_borders` option
available in `calc_MoransI()` and `plot_SingleGrainDisc()`, which can
take out all border rows and columns when computing the data frame of
neighbours:
``` {r restrict_to_inner_8x8, fig.dim = c(8, 5), out.width="800px"}
vn_values_to_show <-
sample(x = c(rnorm(n = 30, mean = 2000, sd = 500),
rnorm(n = 70, mean = 20, sd = 1)),
size = 100)
## Set the outer rows to NA before adding crosstalk
vn_disc_border_locations <- c(1:10,
91:100,
seq(from = 11, to = 81, by = 10),
seq(from = 20, to = 90, by = 10)
)
vn_values_to_show[vn_disc_border_locations] <- NA
vn_values_to_show <- apply_Crosstalk(object = vn_values_to_show,
n_crosstalk = 0.15)
calc_MoransI(object = vn_values_to_show)
plot_SingleGrainDisc(object = vn_values_to_show,
show_neighbours = TRUE,
ignore_borders = TRUE)
calc_MoransI(object = vn_values_to_show,
ignore_borders = TRUE)
```
# Plot disc options
```{r show_disc_extended, fig.dim = c(8, 5), out.width="800px"}
plot_SingleGrainDisc(object = vn_simulated,
main = "",
legend = TRUE,
show_coordinates = TRUE,
show_location_ids = TRUE,
show_positioning_holes = FALSE)
```
When there is a wide range in values, it can be helpful to apply a logarithmic scale in plotting (note that the default is "square root"):
```{r show_disc_scales, fig.dim = c(8, 5), out.width="800px"}
plot_SingleGrainDisc(object = vn_simulated,
main = "Linear scale",
legend = TRUE,
show_coordinates = FALSE,
show_location_ids = FALSE,
show_positioning_holes = TRUE,
str_transform = "lin")
plot_SingleGrainDisc(object = vn_simulated,
main = "Logarithmic scale",
legend = TRUE,
show_coordinates = FALSE,
show_location_ids = FALSE,
show_positioning_holes = TRUE,
str_transform = "log")
```
# Moran scatterplot options
```{r show_scatterplot_options, fig.dim = c(8, 5), out.width="800px"}
vn_simulated <- c(rnorm(75, mean = 10, sd = 5),
rnorm(25, mean = 500, sd = 50) )
vn_simulated <- sample(size = 100, vn_simulated)
vn_simulated_with_crosstalk <- apply_Crosstalk(object = vn_simulated,
n_crosstalk = 0.15)
## Base use
plot_MoranScatterplot(object = vn_simulated,
main = "Without crosstalk")
plot_MoranScatterplot(object = vn_simulated_with_crosstalk,
main = "With crosstalk")
## Layout options
plot_MoranScatterplot(object = vn_simulated_with_crosstalk,
pch = "show_location_ids",
legend = FALSE,
log = "xy",
main = "With location ID's; and with log scales"
)
plot_MoranScatterplot(object = vn_simulated_with_crosstalk,
pch = "show_n_neighbours",
legend = FALSE,
str_y_def = "weighted_sum",
main = "With number of neighbours, and other y calculation"
)
```
# Moran's I function options
The function `calc_MoransI()` can return many intermediate calculation numbers:
```{r moransI_intermediate_numbers}
calc_MoransI(object = 1:100,
return_intermediate_values = TRUE)
```
If the weights (and thus the spatial pattern under investigation) and the
number of observations remain the same, this can be useful to understand what
is happening. For example, if we add crosstalk, we can see that the population
variance in most cases slightly increases (the values are indeed spatially
smoothed, but the average increases) but the spatial autocorrelation strongly
increases:
```{r moransI_intermediate_numbers_extended}
vn_simulated <- sample(x = c(rnorm(n = 30, mean = 2000, sd = 500),
rnorm(n = 70, mean = 20, sd = 1)),
size = 100)
vn_simulated <- round(vn_simulated)
vn_simulated_with_crosstalk <- apply_Crosstalk(object = vn_simulated,
n_crosstalk = 0.20)
vn_simulated_with_crosstalk <- round(vn_simulated_with_crosstalk)
df_compare <-
data.frame(Case = c("Without crosstalk", "With crosstalk"),
MoransI = c(calc_MoransI(object = vn_simulated),
calc_MoransI(object = vn_simulated_with_crosstalk)
),
PopulationVar =
c(calc_MoransI(object = vn_simulated,
return_intermediate_values = TRUE)$n_population_variance,
calc_MoransI(object = vn_simulated_with_crosstalk,
return_intermediate_values = TRUE)$n_population_variance),
SpatialAutoCor =
c(calc_MoransI(object = vn_simulated,
return_intermediate_values = TRUE)$n_average_auto_correlation,
calc_MoransI(object = vn_simulated_with_crosstalk,
return_intermediate_values = TRUE)$n_average_auto_correlation)
)
df_compare[,2] <- round(df_compare[,2],2)
(df_compare)
```
Luminescence/vignettes/S4classObjects.pdf.asis 0000644 0001762 0000144 00000000306 14762554470 021170 0 ustar ligges users %\VignetteIndexEntry{S4-class Object Structure in 'Luminescence'}
%\VignetteEngine{R.rsp::asis}
%\VignetteKeyword{PDF}
%\VignetteKeyword{HTML}
%\VignetteKeyword{vignette}
%\VignetteKeyword{package}
Luminescence/data/ 0000755 0001762 0000144 00000000000 14762554470 013613 5 ustar ligges users Luminescence/data/ExampleData.LxTxOSLData.rda 0000644 0001762 0000144 00000001476 14762554470 020546 0 ustar ligges users KhA I$5O4}i ZŚ(
EHh[UJ=͋I=8ZP ¾TFSj"%`HxDžO HGz_?3 9ǽ4K+ӟ?K+WB/D/e /2zeUЫWErzjҫWG
z
@㍜D^fz"""ZЋҋҋkJ^6zuA^'.z]uKK?A?$$$$$=MϦgӳ9 z=c<(KL.rn)G P]{D
ΡN0s J,>3
Pj} '&nN( N Ϡց) m`6.
0 ҜG3fP ^'X UAg-(ny*Z ˂8mx`<36<nH:' L&::!#X+OL /uLY6{B~n_Ŭ]01k4j1n6\< Ϊ^In0byV0 fΡvKM(Ud̸̙z&o\u};5ޏ~0f ?Փsެ1@e'y
Luminescence/data/BaseDataSet.ConversionFactors.rda 0000644 0001762 0000144 00000001250 14762554470 022067 0 ustar ligges users 7zXZ i"6 ! X
/j] )ThnRʠ3$ n/XsZTjBrꗝl,!}!3%^Ő3e4({4-XViGOVK̼DmIq#G;GA(G%bPGuxVH|(ݮ¬IhQ eR7) p0 ['U; }Йw͆io
2׃| Ȋ/|cxU?)7QB@llݜ5JnmxB.6En0pR-! 67:-|8i}T6
B y H^>0
YZ Luminescence/data/ExampleData.BINfileData.rda 0000644 0001762 0000144 00001241165 14762554470 020543 0 ustar ligges users BZh91AY&SY!">8 *@ (P @ 4 P̀i˥ mc0Zi`vU͚w jk]nֶ4&tLeS UU"
i{2[I٪t4[]w.۶-d ,CBdk4lV&IڥBK rc"ڻkatT
+Vmĥ/3Gn[\vݴvt9dݱEc"F]m 1JX6ܛgV;k-skT"v.۵m6huшR
`ڶ['XPR6RXjܷQ%hѶfD +@[
m5 .nc:̻c&Tzy8]]Ҵґfڭ)U&lRVι*è'khֺt.٭*6ƁSB7ll$m[cL
+%[e(Vآj6j5M,Y5R4l5KjSF(]5it&j
A&K# @0ATjWfVd fI$R!kYRSmhiJ(U:ݚfcb"հ 3*
-
@J:FU*%B6E(vaUڭd"u{U V4PLB!B!:jġT (PFT )95"G{uK EET
: dj@ 2+ Q
2 UC0j 2 #@ ЦN@J R " " TJ 4D% D@JT T"
)@
(
P +
PD*J( d ( P@(
h #@
i@4ɉS@Lf &L
0UT #@ L4ЍOiFh i
* @B E?U?SjCG&@ 40h LLѠa Fhd0T MM
i=SOʟ?T=@ 2 x 4Iz4d0 0@#&h
4d`4dbM1 & AiM0cHiOcS=I5&ڙO2M
mC?T2fSFMG=FdeS O)HdԊ?JR)JR )JR)JR)JR(J_ 4@ 4f
4 YGi՟m{{s9s9s9s9s9s9s9s9s9s9s9s9s9s9s9s9s9s9s`
4 {{{{{88889ܥt pʻ|U˿"b q q q q q q q q q q q q q q q q q q q q q q q q q q q q q q q q q q q q q y99999999999999999(*qo{!PS~ $
@ ū/aag'+/1nv%"M ԅړow i "@y\eo;BDtcv}Lӵ~q{r9|n>
פDȿ *
]̒hfp,MHe9 AF3HLܩ5eMZqd rF OhMu*&J)24Z[)j3q .'5:0L.Mwp}gkKXݦu7ӌ Qw.R >
AB" 9͛7L(pՂ₂(hH$""4RFc8uQ+Hh !&/b!qI!Q)t*a_.
uϱE˭Y6 ;\6i@s28m2FA"q$ 'I3$IR) 4L( &Gq]b%u!,ɘ$,H=aGO&'9!ai5RshC'1*XŦjO 9Ba,QJaBv!T3q/ԛ0Ɋ Aev
Il|TXYI4~Q ܖh=T^@4BʙԘD ,T`~LZ,F%P *S@l&FС iCYⲙ)u)Bq),?d'}cg%@Y6baXPҗ' JƠ.; @nH+lH II2niK9jg l(X-TMh|#Xɨe "`iZD%\iL[K`Xn{BnOY3\dB ,))'zΥs9Y4ȑ*(Ro\2F+p{)5dqXL ZJ ](rIBRah_whI\A^ JGSXf 4
DQhpdeg-;^P5"L-?+@ȄP]"r65jχ<1/ݿv wҐ&
$M"0Xc(jLs qI*k>QaZP*D ft)#)ؒJh4t<ҳ)ڤoS Y0'N#1Fp2 .V
Ġ
QTnA 4mHTIMAY Qd{ȶ( ud
R꠷Y+9*
P9sS
B!ov@5馚*X)Gy8f'!ީ* Ȇ~R ~L"Q1ȋbÕ <CGsT Cq]jtIJҫZXD:,(
< 12 846 fB`ϯG)bI"T8Cu$Bјʹ]kޠtdԨUcba1Xo& jp&j/ys(WFB,E IK'XeHkzEmzPMcINHPQ`ȡ@9huQT 筴 ^c*3=X|#5z)WB8VL:X<6YD&F4!eʲ 07XjwZrXhI-2bj-)îH)
<\VXLU r>ދMk\WQ1ޙanQ4 Y7olmkݲ{0uLp d$"
5
CB,P;!RgHMbsEʒw5#sCM.2ɤdr0XDeEDGWqr`ZuRVכZHRPʪ(Qy {
F.Ƣ-2yXV ĒrTiIaNK@JYQzV2u2 RaPMv iB tN RFz7 [>Rc59*8% mj՚kTeIu{,B% AERHM՜C'p0q4a M4ҀFIBS2HyVP(@)8dUtiBh)КF76F{T4 ֳ5@ $e)D'usM(/ScX/ZB
E
+`;®ÓA7
BbpE9A5cyHd@*pJqhm|<K6 !'uY(C9 R@i][3*
-'[
NB.աN*7
BhJI42m$ra5(l:AJEp/%v5 9P42uNStӝnVgaR> (3
=<ڒf95ޜ槼DS|qvp]!.SӮ*m{Sy k)n/ aN9W@-#K
:;q 8҂]W=( [Lt\ϒX64ʵ
O*ẃܸ(N`,uGJQ+XBhdT Ԙ%&C)RdVBY'Ie>UL@s$'lFF^ESɊ llץfL* OibA (iAPğ|f:B#B
^,ZU7 pRѬyf@
Zj ye0!x'JkoeVb̖$ ITuV3V
+:YTT`a8eP X߮xatZV7紸k*`(Ԩm%y`##57s<(VNt'J;IL3S߷s&V0 Z) xi>iV$z'óO# S^D SK0V@p2C${*NrC)aLPI&Y vaIT1ȼtI0 2|&E!&еop+ 5-&s#Z# lg
=UBJq9
jIf"l˳i+Za*R̾7%^V9R:k3`0G59(Ćl3YJbwzot"2pb'H : R.GǝvY3B\o+Uia%aa
[kޭaYrVAƥ*'DAuVJo7e^:*u&$K4[^,=GߢA(3V $ .Ac,2۱by&zKM&:h"gnvQ_ 0D.مi #M(̠| V#SSrNFioL+4 h B Ƒ tͥԹՈIS,U3 +JІFa $l;2\Cu|uP,bzVU>I⌁4QH xlÂ؍kW@3)WFh;VDtXRFߔ%IL-;sCe=KLA]lqEd5c8UߋRA
ckR颍Y}E+<9 c E
4W )iaHX%&7?%zq-!XZXj+ Jj(uP'=SJ֓+ZJo)fLF$A^7}@Vm\ R˝2y.bȁ䦤MWD,c:% Af2 mK( P#oZ+bݣ`h+(. EZ qMd$N帟|#@u8ǜde7ߡǟ2|zZ _$dNkjȗF@DŊMp0xYIr îMJmaYќr+LqOl*gW\ꮔqsz Rھ]Ig
7 u%oZ&@$(yney IWHPpD FdS\ be "[Sd:[& iVaNIC|cj
N3[1e;50:!:'eyD*"n@=ZA![4,MnX{
VbQ[W(P HJ1Z:<°E֗ӼH\iQIWfN~e=ZQ$x|L&C)#֧ftR\bT,LAp3̬'px:%EMDgY<=ڊRhT@@MI%RS%dVM1{سZ^|~U|;VBT0@J tz0q$)K<9J{ ]ciKM4z
еDFIO)E{Ef)N gc;2S'ІM?kY~Xi$OWomY_zj-LV2Uï2
8ŷlCXrf]Q)P2hȽ53h
eG?3y|avDCg72O 'XնkK,/Ӷk)cuAyP`Tz֠c;PuZL!ZqHwqP (4$VOTڽ뵳{dIV]w&YyLN5bk֊Fn?=XVtOlsTZHأ<4ZCwS":T̄9U0"
{ NV y>|O Bqt~:4NE}o7n28]_r$ʯRWco6
5ttEh2ݟ^oʽ Ѻx3&z }Bo캪wҵ9(}$ hԧ bCΨU KY*O M9ՙBqf03NQHj 2,Ih: 9bh}*mz 7 s
)ͭ%&%a@)Jm5LGRfo8Ƞ6 ARKIjI2ѽR,sYP#De\/$ `+f<٥-C
JZrNm4qD~Fvb[t:LBN
WapT;(tA #y5,N0-l1)2եJڮ@@h8xqѱӘ n#ثEX֏EPʄA@DVC etM4md)[}ը9 vvU
07^7 ~P&yHYK , @E -#27U~:$Ӆ{{O Ը}1 wnl{/DZ^b6 po;%J`j=Ht) 4B.2PZ*_o-\7z:G,\'8d~0>}:×[bmeçuf)0߭ 'qH,8tuH&IѸ2 ɋMEF K|[ I=r'ZQtD~= 7rm3d2a߀VZ&2dU}> o||~l ]H d * )(/Ira0'v)"?JfD H < ir
WKEWk6
ȴQ!X*sG')7Mm}L7םTl4"rvįkE m)am',Ai +{ ʢױ-@E K:HQyIQ0wfNpg fb7cP>YcObK_+kN[Ƀde$!Ģa"C^_PLRx]w>qPPR5/V
NA*9,aqo|,zg$)tRPe":͞d}בi#3:ׯ-BuF6P7hT6PpSpQN0ˇ xh^s! rq{SS>l|6g5t4^8$WVcD-b°>&}a ]8(J t[7Q=Z-#S0gRSF˶tV%|JZOk$~(f18pg:
8I_@ vZGt+uOP%TT6_aKhLG@sxxe~۩Cߌ7& |w7?mSߘk"hte Ref[YҬF+i#}jT->xj \+Q!#GW`Ebe\A}MRHF2xi^ihlmdb3}+M = +4euelK^3u\[E6V. }[(m5qoQ\D?$N[گXVb
߂|}Qt ʑ
{yڛ*kO|_S q=}_u 2^j3f 2S66i6D(*>'6 ͬ=" tRK[~?3*CkfM9 pc"VPFʀj?r8bوֹ\ /ص+h:iZdTxqaJ#\
Ӵ-h^&+V*ֽb@DUӓVj6Zuf `:kǨ6
J*R 3(R\\3S4\Txr1
ݑ !d4n[qM
"Yz-+!_]r'L(\?ljS< -NfwY .$8Sn*8ا,z([O U fTgbyЛU1㶌J>>>*j۔R;ݼV
! /ՅF:H^+ABs
;Se:(w9t`'Zh-&c d"GC~,sPyw6Xu`9^bFj%8[@˙|64Mk%D~e`{{Vh 8ݞXsn*8xsw9W͌(j?ZhЀdUL1{6+Cm ibɊ@1s*R*9uj䌖9Z6 UY9M.ߦRbӯBf ڇ^bN$Яyo# Qq vEtLih?Tj.U Rs8K7=F`
?=Αg[SPZ8ss%Kk2MPnW*sVDGHp5f|lE}sL[NXR{2*5& \PDǻ3i
x=k}'$.ǜ?M'UWtU:d !qfsNe*i+kkm%Z/~7AwR~vx'aiSl~' { Ү+ j&m:=iAi&S#
Z Шr UVz"7 lTWdD辥m6qL2c):+Ej [+HH8Hr/PtOJ*qwI[ew*7rRSD8>jE:٪@'hdc0%r2ÍzcHi̿-">iwq12D(GexWfҹȑd(i\,St8"2(-5Z y&xŽ0{ e4x0CĦb0vȼ˹HRΛ-
:W$K [> :;M@HFYm3*NF6+/F@ l}'s* Dh 5 Sc͇[A? ڷ|%|
l{╺ta1RAwqւ^FTeo1'miLM;MŨ!prIRUj:bn' j%a03DZ[^Axf齲[x'{\x(_yJt~E/s$n.
$}ClN/i)kO NjBS 'yV.52EEBRO!`p4*'-->!qOH2ɫq6v-i?% O{ B"H'zCb-840PXK&--kSxU"?28K<.y|bO5R_aVU@ƴp {;"4cWSҨNe[NC _6iN2+.xkwGJ4FqcO YđU wQRRS۞$q ad}eh'ہ`e9 ѝ61ߺ\.1$aQtAd 2 ş{5嶇%2LqjA]ɸJvqhVNU`ȌS.hnA`ijpV٘P$ ¨Z$REutGmA0㍁Bn.?PdCEaqC3x .4Hi9c(`hΞXGT Aع4i:(QX._]]+n&f@alٺ roLqIIK+:lFjB3L$+D04R(a3`
(tG$xK ?FΜf&Jz`(]cvM> .=v+ sNO]Ayg3/iޝ`v4wqnv]ݖSt,Ѯs?!Jv-1 zoc+uthc.C_ eX\
;?d'4
T\8u̕k{vzi}MFQ(4Aͷcѫ]Xm* V&aسݐ:DSLA;!v!7^o35"C\ fAA+^BC:KVEJ9,8hTa֯& _K<7M$%`**Ğ@e ﶯt$^ttP, Ԇ̣!" ߲ gܬʒ .cABȋ@YS26UO?Zl"{+ ,Pۻ *ib|hG3enP) X_ AKo=XǏr 2-y;
yolxGé۞5Rco8%k(Y ?k Hl ,z0s4ۥdC`V~,y#]\21Kt;7Je33^\6t<=w\\+uO 5&
}e%DFlGۦ{Qb̦vB Q'XO$EE1J$AThQ V-K>۞}zM>X}M+L]9ʭBx]ËM1馚d|eXk""4H՛-`tb6o,,XޠyTw$<z/wVH GzO|;Ug LyՔؠf"5eI\!(AM!Mɼ7S[ 1@J_aQ$xqPC ״_C]W K?uIyW+?P
Qqh~Y[ lzO2af
F0wR %:`{_!HYC$RkWc>iDewV`ǠDZ!
+ sK{8J_
Um;r]3?u ӆ fOE"%`dҚqcBb֕{֨ ߷ ř aHSHԒ5(I FDW6*YNZO:M x6YqkVxs6 ŁbGUL*B8lS JʪosMWweX /qGN8+DNޛ-U5dW]:ҙj8&! Kc3rvxsU|{( L3(A2$д̚rɞRR`sdɉ
mcD2bWGWz. pRN ( 1jȰZ 2 Ud m
O*wߡػ e 'Vd6" @yS+2zӾJ4j ;S cX=hXt$K2x L 2=W^h-I]q ^P/}
ٻ4vu^щ1F
ٱ5D@4RyYIHGUP}˵,ߜ'Koדٺ(t*)܇- a,4SR领֡
V>>M}^ XZM)ɸ4괇l &FeFT}c:ꥴ'F
h>Ex AA2X'ԞR@5
`(ڵ6-EOf5dU̺DVUR,D
"0t|+$ D)n+.J3S}猪Ŝv.RZFУGJV:Z ,_[Pa C91+ ^C)I!d)4R;N_?5>ipv'`eS.t;.ijoXsNV C@#Cl O{W|rՁ5dKeՌVA7=A{=?^JZֹ1[ǞJ]χvKS Η .7 8ift!2~j-ODҚAaG9؞Ј:lm" %lW6X9J) H#F=R&s`hǴ D Ŝk}HHw 4ČQC$l3֩B+3E:Cf'慹S/D[& m(tSW8-ԴT)> ?B cwk%3 0hY '
{lTQRnvUz'_k/Ռ>7|jTï,+G}Ch r^Ik=DCo#FI3#9pdžH3#-FN7QFs^,RmY%XAon7u"z*ڣJ|d,Nhjp
5a.lVK,L ~T10b#A7|ۺ HT!]CNrIozuuXx=o*
,]D\b)Dz' r&o}2kl%!D;R[mFcnO,%J9Sk
A81H xRٱm9 m
K (kHln3}
/4(Accr0#3>A[@+~fBO##1ِPMeAq-SUdKnD > =@mO?p6@<+ű8\zjXPF!
Mp>(U57ygx{gٵ jسӋdefklv,ޚ68װe{VƓg塳¯~S)5[gn Aˎ
~S+|0>@NV }9dN
{^5[u@Zۊ=s?x8"%%^5ũLU&eKLJt(ЧpĹ_e =-KC4YT TXˆ-7uRĪ=<.N&Z9|5^YNK+oFs43"f9 nqOb [ M; iơ4`"嬣HMGMLC{ͥBxGJ0l)A6TmfR3>JvjR=-+uv+\ S4,j=+ eV҈ZuЖΑIupd (u$"DAal-zM6 %Kޮ hD'fbV kD0% ;0Yx̂p@&m־ bpá\HOlAE?X(#,CÝbI2 #;j[ l \L :4 *t"Y-bf"B
;Z<i֜~:;).zePRU
zFﮆv3骱I0qdeEH=E8ozGDM@T
UW2
Wxbl>!= 6&ſ) mc43P:pU;ji;ddg7d}x} YQ\KL) v !zR44sZmT N
|fF>d#qx
5%WrɣB?# =ͩ͐ 'B v >}X(b=L ^5FZxv w Mj!k~yP ċu ^h$Q`z&f+fM MXDD+ Nw@]e͖즽6V*d iu>>ɜI}ti4Kv+J73: M1
l73nԺ-EƥPeH
dP>DBDjn
C:Oz>m]^_ 0?P8{1O*UUws +)йfJuB%k G7!o4lf cQ,NZ`}2DI >_tI *lp*
'Ψ((QD [ ud9&PʔU Ȭ AǙ}L(VmD+Q3 UF@ξnDj_ #N"Jl ](iX pA <$F@AK Rvq
5)h={*`n;vDң+^>ҝ֧1؋lrK!W)'OUˉ]-kLbuMg Ca?pTR[xwB:fkYŎ߁αsEYfdߚ{$997\}p~{4WY5a`XUkptLط4
=qk QiT1cT*H,!L'R|zKtߔKOLOwv =DseX'N0^a#,+,,:<}O';HMD$ ̵6aA
b`
s52Y
@170˼ ie3mFμ={xchW40gw1 6B 4e-▩%$k\,7l ^?# }! 5\ ҍH$B>Euc»yӚ?V-+qZB\ª
*:UWz\S%S g:M҈EnpI͕Jb⛂63ϟ3}|,Xdz`'FZ-l Q* V 5B㭹X_oe,!~il)AGE3k[ ۼiͣNph-=~GNk\>g?I1eT[ `Zh{XK @e3#RbXأӰ]( 1_eGimB&>V Ъ6h[Mq1;M0_? "Lȯf[5l#5Ј&^F!8E
W
5c
q;fZg2P1W֫'
=fd >K3;EMci>U*u,mTij`va*X1_uֵcWё ӓϿiQΞRL]R% KtMb\vk 3>ē wZq )};&~bGffZfj=Fynb67 &/E ;^;1 5"*Ts
'0Ɣ躡>tD-Qz>DxhȼN }Nzb5g
S.H<,vGvNTax4d3f$%}[;*7@x}[o9Db0pfH'SJ.S䄙 ԁn,m ڽTk+>֍t `PL4{挊_ǺtSԮ;|3n[MsG羽.c3H6VK}F[-oxI[lbh<.ճ3q-^N7 H4
SpHfE+udzK
<['M942žMOήpν|
dR7fN$&2Q6GzQoKu \ͪpҘ@*1BJmD*[@_uW:Bf -c0]{R8 TAp3ŜAm"L 8 I nk3<-TE*JǚUXXU=7StB(## 2:63byh]sb͞61GD U
0*
FU;)qz%D 1t풃c+r}#E^L"؎xF{-5. d֗jF0F" 8o<{0!ŦFFNN)|1]E8 y^Ṷ ô2-dNZ?̃6z9eۡ AۦnC aVJ@fp=uj Dm5;b~qeG(їۉmd[x7e)WTxݩ 9^0](ߪJ<ʒđ|Ŵ MD?Hb|NnL}g\`D5y\vb\V*%ix VQyI9ٰB`} x&2@':l]m!E j8}֧jZ` C5[ٻ"hҭ'440 }4Bw3cРyo,v~ףy:ݬͫ9' qv hx khhL t(7DQsT-g
pӗ0<õs̰^E;VB FϹPCd&lvD x]D/p7VHgB۬g?]qt980m nCD{>=4j ./7^2m 4gaDfGb'y$&ӮqJz2rboT\e7W' +vʐ_[ut4()l!M[e͆eaWD<q/hy`D0$Rz e>WzNWT<?o "xoKUZ
8Wr&e7Q- AH=7k-U!xkLN#``X7OfP
6%߇N2zU%JJ2/IK0}i*)wYZmBCA~Uuٺ?;f4F Qz<꺚#~7lBl %|-5P
{^
* aSYköR)wPaᢓ6m7c]gTCgw4='qø~m7jc3ՆE7Eo
OL_m! dEnN<G'GδP$/)m-f8n(3y@４2Cb Ãi&Xn 3C h0P% [X]o
#/yؒy~qk|2iwZk6U@d}'\5z:e:, 2sFC;Sa/~LݠJKǐLmҌ?> ;G}WG;=#PhA}WpDŽ-)]$OX6ٳ6ZtY ]$8&R}K!]ƃ bTkk^c_ [Q2in1
'RMl*6z` ěCM^^bN\AԙOOc$7Y |||
A rU3Fms*r.l2b g$q )Dρюfm$>9"Ͷ(w`b`=> /s^TTxaپs:'!{EѪdw@ EݕMbhTC߲H. iUs2ev=u{n` JE099 ^xDрEßve[ŐށxƊ1z=A4n
S? k nE*G^dMㆮZ)`'ˬ-@, |rvPÌZAj)},Ff,wP/L)w,75`)k-KL0YىpPQ$xyF+٬!ȫ8ɥ49%lM *wd !䳉Ma19 GmhKjq>\] L JKNHl*f oSē6Y@9[ 3ttoRyqG5=
dzWj])c
!+uH<Ȯ)Gt1(l#(z?Hٌ2 Қ@891
emP A58[
&'AnXt4ä ^x-1V
QX34NƁU t `Ǐ@p4SPWs]Vhk(@|UtY70V̵7>X"IWTk78 xE # Y@% hýNCW l)r<>z;Ti V{IµK!wڬbT00t=zp K ˷^I͙dD7E5:KYëk+%31"/pw0ƴYovV^.-O!Su(cL5x6j@-@(!`tg ps +CңcJ0D|kH 8ڪs7[l]U5J&:2E }tQ.c;jaC$ /
$FJc;9BycܕۚW Hzw- @KpjJtߙ t^2T!nu|q8/r<ROO%WE<ͧ\c0=MzhAlx (P](9o2YRDOcQZ\RJI:Fl3Ōy9p<9 _U^5Z9yu|JaT ; TADfδ a0V3r-RnB%AѶ]?U "eHnzX' ff Unb(*qe.iU@ t&fjqY) a,ZM D= Mg\tQ#'I%N_^◥Rp?IwU;Ut9 #9hi Y7$!e;^I|2PyWpk9
$^79S$U)HW] lk4ў\55(ʇ%I0J\!. Ȃ303Ib/5 npO6P& *Qp若tx%}>AuY*sl$mF[CC:OaGj6Ig1.9 g?Ae~V Mmt@PT]fJ
s:I);Y
S+w їe"WGC@{q/K9:aY4-qn9!! ]/T
̥O3WG],ݽ:9GaydXZ"CCn3p5f0\)t'~=T@j"0&$PUj. H9% >pɌ5$~LԳ׆etxO ie94֩ݕHL棒 q7 "n\@ӖUե c lkeʤhU ʇb'GNp0+8G-#puӾD1:! (ij 뗪>&~8AX=}-m^ Λ. Ґd梴.e54 6-b1ɂG Z7=LrrXRW2orľNI"5Mcgy)g}+ 12i[07M>Y4UCїc
=XIvB%vƆ-*Pn9э+-ax˗ěM^W#
P-L4 7|3^PdKh 4j&d/X*x. a֔N8#y8ODZ
i_T $g](vzߦK4 ;%(&*"t$`ƷXEsE8 4T ,!}qpQN.eY~!DCbU8R}_!{~siH=(.c>yAרT<]HQ\eԇ R=}G@3ssw]2#A2
]~o ~ e/>D/3ߔpu
ID(PEdjC !i&{$aݵieu2%ǁM5>@`'
'{(a24W:Ϋ:@{zZv8ٷؑ}b
R
2 z>k [αa0Kr2ymNs
xU\ +_n(Psfa`fv煠ib! 2 Pl I 暛ަy]~ጛ҄SXYbHz J1 O~9r4-\Sh@[290jS[jک`vr ri
E Ig Cj
`)OS;xtOVɲHy2z)";6'c29 ٜT (HB^qA+A푒A0~=_D7I^Y* s?w ,*L~[{_~ ɹRy]clt}!,sct)mA ) %@KRYSHGҥDֵցu]z=bb[y)!i?} "H Ca[uU>
Nu"2AyF5wCP oZ_z-\
34#ĈIAЦ@R y)apBi8Z{S@p `AJX7Ҿ M`*w>M衲(&Y&+`>=ls8e2ZUZW&QaSrBp*ޜ _E-aS
PȌd5CN@Gp/ ܓV\NW^_c&.j65Z9 ?_Q*`yʟ h6
2R=3SCC":vapAS>>P{Y>!j$ ۴(
'Β =}
:7%|~}č-S./jB>}~ QVA\5+I kw<>LZ(Cv쑧Aܚ q
qmaDgV M CB l
ɮeJdma)Î }u"MГ@S$^ N7k;1 xgA,tdĚ"ڋF97tQV,jiCw0Б!ϰS
2tN[]EO+7){XfWpsy-OGϔq fg,B
MU߶h-qƦtTЋP"_Y@2 /^F[Jo\(f$ځ,ie81d%BJ"aym f˳) y '=n29EŒGݙwC4M mS- 7C-/
IvgikOM7үÝx]mNA|94)
?5OKlj8%
^Gn!iٶǠ3&fC[M{GoVԥQǨV%d&19YI8սz' 8,hSuGHkF:i<5@E
f[PѦ~ݧ(mޗb<{[Z!-$AIt
D2ÐO5#@ ;n*M i횓 h.~bMnE* 6rΰ\pL`H3*~Pl݄5Y]ujeJvO4iwP~$ܫY6C2rzG (M`vd#}l %0>DJU
2.LQ!,~5r?: qqֺ̱
km/z/.xܔp 1$,ZDag
We)skTV OY B_ ^ E"N,ZX䕏(]Ko7R$yJf/ɂ CV&^)?'7g ;m1 -DT
O0S,Q'N)d{92
ia6EO>ˉtA蠙dZ l. )(~ 9ƄK)!v1'tZ]L7× " J*C,RAbv1,K`!}* F
"V |l.ol Mľ(p)b2a1 d:WR=imW T":2Jff>qJRvEuWD?y.ս>V;_OdL`v"
}3/Tx .}W$=&Hh_:ik&7/*Gea.(wKWD·0]&7B^еhH
fbSp#,4ƾyO'FnD1p~K'r Nj)
4P"0A ށ'Y5dh7 jVAknV$mVROAbηEsI 7!uGŀs{Utn$}q
8F*O etvsARzҰ
@?)< #䡢EpBxdʒjQ38w) ]`7,>!yjd ]khC&6.V WBGn CsLaeր߅2q[Z;P3M8;SՊMaH;5=jLA6g9hUP7J 29X`[ eK$nF _v0i@7@0-+ [.2TY
2q(\Do53: WjO92L6#-<4%P dX]F`!4.%|D'u B?n#n#3P+Y,bA{ѷ-V[h{-ױ)E}f1B #q 8W VK
@[֏o ;|3ckuʯ_DŚ` YBü ce nYy yXp ~e*9ۧIp8V;(HrGtzrQ5; Z>bͤF~]SHW_y^X=fVYfrc%84S1AԾ4@$dB tert(zN1ªLjwQf)0϶Z
Q1Y]c2|Q W̏ʭ'H\6BN9 9̒WHKFoG,HG 4 I ݑe wW cX50 szJڦ#1b!SBA|@Y6{)02~1ssgyF 6^&* I3b v |ynn9<
J$Qs 2tN
[]VeTT4A Cف)9҅(T `@ '(NG}8 `T*(ˊ뮨eR20W;;K@j TeZLǪ uX\ؽJKxJyJ'~ӴF%I4 5S~Dc"DE 0 8!á69j[#cs8
PL&OCTQɓ-^s:9r٬H $8MZA.[&?wtW1mÎ!ĥ SC-uՄaAӷ g^QI7j&Wf ] hM@䘅u&J`"hmԟ&<ID 5!/Q H=gQ'yA1J Hc;1ƥ>5omwE5qq3ECBȚAz.5\5ZDǦp^H Z>9UE8R4u!az+MnD&.+k]kY<MЗqBJ+\ y@u|U~>$GtpmhwsZdwax:H'3`gK:VO~w )8,UV ggX>J%1Sa%
K&q9zn4yߕF>/v x珒wဵ &ۮ=kPh! -~
3 h?_Ft#pkp <ŷ ) j}91t! 㦑!ϠN bon얺w4Jy8>R&avr G Q~##d$/Ktzl@eIcPhT!ח` ;Zs^{g)B)^,dw' Ȱ!QE>1GDjjFSk[| 3s=+3f~wa %,9bnFNqz/; $x!)*#Rr$?) <Ǵ T ȵ A&[h=z1" Gn^UTMIl$L1#=M1Ih~" -՚V4X(߶$4"ڣx]TV^ Ұ_J`#¸F3tk;v*3iV%&9N$(͏\
Yi&>vN̂i~C ]ZlfcE%d$|$gV V OYj t9/M,"A#UQ4r4,l I-9
ZKD^<^[vOP=,V1aFNzDBN /r [*-G=In/~r6nq--=kBgx5gȨ:rr%R&X,.!
6WL9)Naew7qP*R7X<@:@g b_/Ԅ/jܵt Y 1 aĒC.Eift
9{ԣu@V=KfDͤ -0=.AM*Ey [h~fR/Ѥç+ 8g~]Oy(B+;À1Lѧ;"-L|*Ċi=\"cYи~>. rz GW.gJywU&4e[& +i]+8Rl( 6:A"Q+;=+<
]@ta=~3(0~p:5
exWQB3_czl甓jxBjKh< az1'sdč="ɂasmވ5hLp{-2uWU3R( 1 E :*1U-hA;PUl[w2\Ѱ3Udz Oჹ3/x>cH$L rϮj0 a I'\ \58Z)IUx.QK( w6I=yQD@
#`{N}
G:eqUlWH} pM Ьs#Tx !
g=C O8|iSDBTF.rԜ
=G:5dE}ì7rxEw C, @9T.',
kqw' ^tHhg2~: S4߁FFDfM>QQwmlBb %!*,l9Pe˼
D8t ތU}k-; #?k]7S(^& LΫ 5 IDtnܘ35egM?nћP-BV Ƞo$:4=")mGuċHdC^Z
_4Ϙ]Ozp_⟈rي _~֪{"C!ھ e0=j3bٹܻ<]]JՔ19v6hk~t[muϩi-NJ72KE<mkp:βUqƖ H\hwږCϹ&Dh1Z'+oF, /0]rȬNH y6gNYBth93X}L` cIz(M.E< 6T3c᜵rZ)`_!=|f48R u(묟W/14%:H3%g= KJGFx0
S8 =cRS P3ot۸HbeqN#ߨElBݸ\b
̽tWSR569u^AWst=8tXZFcӘͲX*T.zmuYOBY0'IS}/YB
~ڟ "Q εM@zsl7پ} (
u5@TRK߬
[/r 5گJ*/YjΘYjM.v5O)!5D*OeL9X7켹"Vc7SjsH8@5k>Fx"6eDi{\:8YAenPP͛o
KUu=':bc>c{o)W Iv%ж)~q ~pΏ<0I"-gM<ݏ!&֒@BE@
T]ej9ZU.!kQ .>H醅179_:BmQԔP]I<}hRGzzh͚(k}w!ĥS¤*z
mm(s٭b Sȣ,L3yG Qm#=g٢'Qkץ-6-w\ykr J38qتCTħm~f,mq7oV>;DVit C( NdF2dZ;~!- ]C#Х+YFv6 |t.c۞7LG`?
R2z#Ŋ%u7: -;|3Qͱf
NK&~u#6`BSݳ;1wMׂɹPǣKNT g]16*o,6T>Y9zQyV8cE9Eco&F$g4 JZ\xl>ǘ20)> uOn aޚD\Ţlkٶ6[JHH
|MC}R|[F<"(NL<1nVf0mg)[\$|C
O5D0 a eQzTcw8@.g< ٶrv(0SeMyuLoܞ)f'$s1 L@Ͱ ="D!,-uMVV?}oco(M:pKQfLB?W4z/, U5ߣ
R b~HoL1Efh]tr7Bb7c]_
Tཅ` u,ڙRC-Iұ 6ׁC7
ՊqE rAOH)Z,c<y K= &iCPͶ<уFv R $kF4Sf dYUsU cVs=mנߣSV} iƻ>˰w$wblfvB9KDW8<}OQtmyM:] HQ}^}Au\1U& ` EOfDyRCJx)Hs WR@n=To R ΚF-x`I;,eqTMvHI=T3{c $e"OWB=؎V}ڴ0G˂_>JIr
iDO=n(;/Z,ڞ1?mWW_Ւ^U\v'"P &/q3*5$o`ZiZYH
,9x}\,1إ="r\:LFbXdPF-C>IA[Iʴa<xߤG&17[i`{0* FXOYЉE
/E9\*PAcR0۹ZiG E_RygD ھo%T [J٤|
4N !{dQ@v⛾KU#A3:m°&\6V vG ksgX
. wwef{GD§U& tbΗ]uA(p,Ej2ik]:2IW7t _&nD+m7x:%o^y ÔW g,Q|erya^> Dh7sijW2VVf 'h-WZ s!#x~B7ER #!:S
S >^!9f"S.g.[8v_|$ΣkU:ig!đ+
2w5%@iˠK'F9DŽ ]x4.l_%R:%uA= ^IjMևFM C[Z+7
;J3;^US.ۜ/E(R vHmc-2ҫW6Duz0K` SlA]Y ]ٻSk->e{4rzL=D5v IPxdˀf5$ ^#ګ yfm(¦
ա-)XsTˍ[,y;jqcSӓAXQHLb@ %&qؽr>0^
_ kUGȽ&<_`~&mRIkHb ,6=ZMb3Dt 8$Qs0uRQa⏫HL0E.ڹ(os EɶGeIHaOڤܪV NDu
еD g
S X)33 ]㰜wrZD$X}@``_ U'Bu!$5p`B,Y^W
]
xyml>xd jcC 6G3 F7aD>= +OSĵ7l?:<$h3!Jbݮ I@ ΒQS@vH(6fQA,bZQߙi
%7 -`90#Ӌo ~$'# `lsl0q@v3 <1`Z&?$?d}s; $nf)&zR܀ ME:?bFYac?.7G
G~Qt؏+? Ut?9x ̭p HXF2x(F*ԿA>awe2-4itA-'pHu N )Lnr[/ah X.l`pKrKg@
9v%!!:(,3 "H8F W6WKy
¨%KA~cӔ,p"N5F'd2alt-/H6q c$lTTW*=q%&H·$H:*xx.~.$ 99,lYAE_=2_GBH$nqs_B$I$,J#`:3KiU^9@ȯbG8wそ̷q~O@~՚[]l 9lh@i>+Nɬ¾e8TKR6`DER07 M/R]6H\xBNet|8SMBl5I
z #9FJ?;N0A 0nE%Jދa\ 9lBJy
XsDy?orw:ފ PEXCV)H壻3^f]Q x 1o͞L3![:orb^2nSSlNƐ`sg*c1(4Xb
3XV;J3,B$&kU gvJu-hLEQ8ܿ$7|4Ғ٥pZ߇(E'$ʠJ{˷ R 8Б}ǢOf%kX#
^1܀e3kp -&^+.tdݩϦ}d.ZbPl\=LH8B܂B `#N
}/9 n-Ǹ~Hm<94LY
vvA
ڵ.%.$
h"ࢣ"#mgcQ
,a9^<@!A dK r%N.`5"(
0PG A!ooN*'-&`;I6|o{PA3aa!pf`۠/_x/+CTҠb=;RBj{^υiW(\=mRq9R^xUb4\[CD x4J%N>#j P
a ]V\%Z-8)qvk(XԬvWވ: 3w[1x觤 wEˇV_+EBXv*% KEH3yk~ Di2XcuYnT8XG ϓ rJ;Uۥ;~ڠ$C#0Qx t7 O %pV攝b'f͒ JI|b}q_*3ܵW"|KYܑM־ª + brPUٲ)2x >bI`~b' ]uM*.f[ſ{_l1CW ,K>HѺem}s~,q5 $,M#f "4d"ڴSHOY# ucP*A{*}^upA/ : lD
d:kc[R
wc~$LlMO0b Fb bJ }`$*ܺ0 ]}m@ؚ :v0U5cQ( Q}p@tj'ih,8SwE#4P-y0P]e?f pd[y8}P
<>]# P+
:̈$iE
!ꍋLV4L]t*jj![K X2vmCdC;wje
As٭d3CꚲvQw k+AЦǣ4; ņ>2v]NBEToz~'FlLU22
~Xt
DZ(OS(k6k(J_Kv.λ,U#DMx$r3:+A3Xþy qu=e$쪈{G`|4BL=+D|m5m^nb b3ro4'{떼hU%离˚hs~*.zo48-')A& zGl!
+vI-T2<{EѤϦ-| {}5LU5⡐w
Q_w<G$"d B\FWPC%51` ltHTPϷ:]kM^<4^Hs>߈fB l4zD&Í;n ף 5P eͩ@
?hUS7cըAvU]7W-[a4LYq@(b !~dP
ԫZVN xȵ$^! &wdrBS'AZ/A%r1y/6B|TgrúK;ڜ+ lҲetEU? ,ضQk""ݴ8X}fza%ET)Y ݙ% a +ZYѦ/dF:z[}dAK';p4I9Z@M;॒eզxB0wЉ02rj0̠a;-N? ѿO>Q͝ `+%r k9JݧJawYE\MUR
!k$/tpX'ؒת2`S z1{`和|w,jQI#98(z Y)9̴w( C0}dkb+CX$ B`]|P wPB%jߊޚNs`h$j*A=\t< KuQG. *We^ӵ%z tD;|˿Zkr 8"^+Uf{OaiAp?F9P5nյ'D %v?й䷕<7nf8У
>^/!=Zjވ|:&dNh
҄{RCwRb$v߆
T>z@ u|Wh9vbmz֒jg|pI@cM
*IRE-
o.B^㴓"3L8dzAaED⎒B*5N :|Ygg8GVF'5ӒL}a #d?\ӅJ1\}bB(zΓ1
c /jzԔߌA`A b5KDK N2Uؽ 6`/j)^rol`Z-j{q+G^[-t0ߙD9S@J l(k;*a}AS*ā Jyz$bIncOBw Ewi# *q6nUA Yue- 8 PƵe -sQ*L&EQĖjE| =Q$'Wɔ ##^).UT*r4=ќ<`'5-5x0G!%jU w8Z<ƚ:I$:ہ3iQhB=NN !@˂)ޏY']+cxEL WHn`3+FՀuMD IK)"ٜʲ"MFOU`5)e?+4"XMAep;+bH@Wwʲ6 1֭][|̟P@n' ?Uo#-Nhg}q/OL"6\ %8-TgtDr;zg#<\t $":9JM,:jb4ܣaSp-mLMyVN*vjR{ QVca lT3w=xl YŨV= Ave7n̑G p- N@!??7(;m1w+QT|hqT:M9G#8:eHHxeg >4TR#$E4>#m͠G>^2 vY<;b=/o9uApzMKA(L'T GKk| 0!G{IN6,j~ $y$<2ˍj O2/U& QnE~Bljo\hK aw. ڿ;Nhi2W dvx{R߉O
d. zaQ'٢',6O~f&(!ܫ{JvQ~5'"#kWijh]Hyac]TUa;"dK1 87(&svO4 7RqseA f>0vrIqay}(q!'F`<SϞ &E#{T
ds*Y: nǍE}V+@_d/FcimTAQ5ƧTw_֔+ fHxŧ:J991 ƛ ^ɔQ@R}IM̫X[}8
9-l0 O AZq8tnUbonXɫ]i % cѶs9a]r$d?P|('@) }B[| Hݶ%Y !;ѫ֛)c{9iߏ0 絸y-)huە[<\TnH
#w9حEŔFVMGS4ڏ<Ǣ̭DaUc '!TP'& 9u iw|ow&oyn7;CsJw\(өn*DK1BSlGH(@܉Ӑp.*{G+%2-VBTbe뫳ͺMT%Y5m/
6GoR=%
[3+s0wX #;B v>J-GSp<,"
^fPnNZG@3/{c_[ Y$;`5 rKf Q"Z% f1)4[uYgjEk^+ ܽ{;'MISH>vvgP=yWOEPNt:W2h&ζV$zkF~P-xH;MxIQ֒[L(=?WJ[a ]&|L LnF@Y QmL +mWA 5:6{5T|jN#1pue+Ot-sLZH&zxH0~=jd
;2 2JiӶwT:qViZ`,˖r~;~-A
@Bz#Kuͨ
4j2ZDAt ~~?*5$ >
Z~
g4 L /BN꺁|9r @L;HH`a$` qČz@[0Z`^{~vC8cVg,9#3]YiVMvF Aa 054SФ *b[4Y@}s2̽5I*d eX3=~Zcu^:w >5?z",2`Hg5w* RdF]VE\ .B(Bpqy|[DE ٮͤRToC&eZPt|Ff:hnb4{m"%4u3 j]i=(꧷;^Mk(jmIԵv&|t\p}dxHjh ٮDm6{/\\Ԃ &L'D/iMXWx ; ׄMrM1tTe*ʸ:16bZph# D/K,>CDgaq?@i[0U
n"ʤ
7mݫ> F,n|j_hp|u]~`qxQWuA
sRגB"\ɧR5" 40yb idSq4\s@NjʸF*:B!q1 X\P)&>-H#(P 1W&6y7g;Q$v# kw:"8@4D_4{{+wGGcֶehk 'eQAldln
7bzeL:npC w6ż
Tt~,f 8c (ё:#Cvb+Jٓe$G̻ 8q2R1
@h?>TPuHPxQJa} a-¨QHqX]0x :kVh ` hdTHTHxxbK#)EȎ Z0m ƸUp1 9̳)ƽvU/Z̎mpx1+O"0t`+ >2E ؙfb١QFmCCQ9?5 F% ږ
iY1eH %jV:X&vfGucXBn+I1$`{nCx.qTL`f?"B0SmqgK,w\Bd6HJ
5Fk ? B槄{W۸møNIs92P-,ٌ%D1.;2N 5
{KZίJ(Pt.fSҾ*;M `4i9P@6Rc+N)`WEcz areWeKsa$gu; ZX^\B$|U
m"@ 0a1TpqJDe3l,MA#fR'thZnh*qJ@~-8SO
rt'Iyf }RH Dzȶjq[jZ;V,&rr
BL~n6ƫh] |6_ 9ME.ĖMB4^n؉6ٗ-u
HZ6j {U?uڳ.+F" ᢣ1_݂k,"q0落ɻӳVYUP=CX ul|aK`z.@J ƺg±RP%3wkV Ę[Ḡ*ז
R"Bs1`39$'ѕ8[ɯ_-yS0w4wwnX#J8f!Kjo}V0zYE5ac aô@Q9mP }mGFWR4b:Spo[M42 6(2`|*k508jNr*Ml) BN ֑P"Q"Yr4yina~OC:G?<!hٯ"on9֦%:?T ,VP/iw U,bV ǛllrtT[6" q mj9Q'P {H>,P0Alq1 ʠ >MCz Æ7%H;_~T3iձ?z.C,v
ʞXM*}5Cq KZ 1/28Jy춻AOi`uXCnj+ݪ6TB/ɹ~ .~!S7<.^ *J l
*|FutrPa!ӁT)Y / sR8nD.%UEpL-J&&QCl!W H2䉓WB'UQuZSA
l}zm]gj\aD ulp9FfN"NMZfY$)u^8}nC۠&Mpk!
7&ϊdf AgJf\y-_\%-r~5Oű.Gx,J}Ԛz})/5ZTD}8 '^]4+ۯ[Vt^B8.Ast%g
p@2 l@!_z=[
[Z=:z)x)( nQ늘/ WwxQ@,2[[jO 7#ԏ'ZDG9U Ђ$4A;۔o}<
0/t>Hb9l^_nN &|-bP`*h]k4N
w]lTD 96^
da"Ԧ>kQ Pk4B ЌBt Cks6[VΤb:8]zF\9X(@61Y lo9&^/U}Z0 &o_y+LWaLN(B* +j XT P{ x 1ڗU8`ƹࠔR:D5G=Q
@Izx-3!N洗 (z'%&/iƅ"BG[d_xVT*N os=} ڏ`J/NC y(ļ 'ᑮ
L$EP0f
Cp>)NE ,v8CYO>8ۘGblv rl)Q:3H3)H;t?"&=ژ9,ep Dm/72>WJ66sO#D'e|+^&]D
T4]z;>GJ5hu@Mra4މ5ʐs[G AXY*anl0(rDRʧZW%"W} FR`02Yѩ>>kOvL_J`r,{.<3p_k_97$l5vF[a
BݭHҐmЯ5<
+PR3}ySRpc UH4
S3pKL 1ܱ9>xTM)*1sl@&W**[b$?
[F
JwʩotLbD`MBє
ėGJsYB@kyX fo:$' Dؔ'ֺP+U M{& HhTRA' zS;cB${:CmC. Kqu%%~Ήo?JC!wwufm
>ǎJ >{aVa 5 jȆICY/WҾ qQ
.J\BΎpy!h
*34?cq;kBUB- 7 9"l Y4 aq4GsQ$Em"ps6ה{{ _8 j}ePčCvb "sn HyIjqa :ͳmswŻd<^~ޘ
aFl=ҡy8ط,5#ф]]ٹ
_E0+"W 5G2#oJX54l'*ݘ5BBLPMZYT5 >2k;@$@MnFT- zAkK4pqr:?abw ˶))sX
%1 LbD=hP V-DF;V\U
*;sw(rr3PuJ
rasW-HنသîHq[n
I32`tyTha1S,jk6o1U]8!7sA1̬ ,3$DJ 0'6X9X%L%}c ؼ/˃Qyڇ /f gXzw%6f\E)t57c
u5wi"zX&`vRJuSK5< ]Q5h7 ]h1B5rڨ(m/KK'OWUC̸QN۬mtthmoٚSp'E({U0eՄ^ .ᰪ;'c=z|k[ pP,[.ޗ{w0eV"IN^h}mۖ3Nn>߅M- lCs#:;4ҫn.Zx@._^]^?bU$Xڀ '{Kvkx#PG_qqm2P Wv&.heg^=fMMW㶁JjKzsY7ձ)o eh jB FV:R RSZ(< sGiv3 ҏSn&`w xL ډo8ء!+1bΫ cscMZEsG#
'u-b5K6rs9CLvĜGɞm-# ]£WUl`iu=<@^̏;l-湶*QuH,
f&Ck[O> ' S!\*C _φ ȈXQT_00dwqJ ~L{N3-xH̡k*m
1N[l§!m$JT?ayWA zmo_nvLtz]+ϦwTedA$n(6uoNH0 :`Hƥ[fWySqk/YQ Un g;8=;LJ` R¡4nsSW
jlQ}ܕTD2*}sY]/qS" ;VXfx`QsvL)2(:ON\%9{qch ݜsPl ]x qG@ E5
% WGR"X_(
^p䌛Δ-v +p^Ri,naIEe`0Aؠ
Hwh=lW,,Nw
Pz /mi PpYWNx4i
OaR^n6 ;"') o\"$w?/ SjAmc > /Fs65O26R
Gw^YY9bьzQٳHBYY5FÁ^! d=ڪ+)т\= E,ň+Bc'ҧ.-I #)E=5uY # ( du)& r`JVd~8YhUpY^3\a[9j$45Q <\]qn0s"ib-`}0^1bv7Q;7|틯cv|D!&ըELRZ1/*&z8ۣ>+ŖnO d:sjm*"r1аoUhGj3o*c>alIV͔ܥ8 ] uM>d'kl(dY@GB(L3`qa"wM/L;`? r%v -uU?8_B
G*5sl,OKO>ZUX!Qp9 ˋz8gЏڑS']OjNH;u :쭋E+.aJK=YٳB5]Q,}5xv03!jLyO;6o3tyc/a ѐ+j3į[l0 >J8Y -6[clϖ"JPO>g2VT!B't3ꍠ:f
4RY P3bw@S}3[14GY q%Vetp>U8yVWm
BJmi6v[8S۷ , ϥp
(!l' 4"I{ e
ޥ iNׄe %NxP(s"6BgnWǭYntU0+JkJ8{
88)
F!I %: '+CPG8M 9cPp J-=Qz YtlMog]fVUI$ #dIPV5P 9U M-%'XKʡ2ڞdm@&ƶ[
(]59==5CzJ"V ?%BJead4=*k6 (^9'D2 ku Ǜ<-v3,qHQ*TԺ(w,u3H4H
aIu'&= \ʅ W$_I2 :JF~es<
nNi;ѕ_si@4) 2[m]N>3[
$=TVSS\ p:bgnQppxhG:.͓Xm$6ߐU]֛[ < I4|β>GeVߨݶq!:)W;1g=n} 1DX":T vFq
S!9 3d9aL2-8#{)j~H1"@2&9p7gfM9ֹ#zpl868"[P.IQ?me۫pT INk='Q{IPw"vQb )ŨTSqylv4rx,ypS1 Kic&Llߙ7Î Ʞ"q_CX?݂!c>N sf t| UūܘR*95NJ @U "v2yWʺB]nCzv|GLd' .Nm:Fp=}mJk+챋ERbWyJrNv_*Q<oPx(H@a[ ^0 uy1uN?8 mt>kz/+]IE`BH &N)9ݭDj#k3`R-TEu>ܒ7U~, _ǫB tUgl&ƻCf}D'C0CL/l !} HF7)EkPa- i nAk]2㆚AZСS05=&1$DE- ƄcǍ .( **X6g,Rӵ7WRYQ`U1VcdVo`:j<:c~7;g( r/HX|G2Eɻ c7
7>5t rYFM-e°֔xSA ~ β Sn%^ᡞ fhN=S,ZP 估M@Y}Y+y!OI^ơ2m"z夥(2L8@g3:W"q8n;:G;SVBi8
R 1#WRtՏ虏19=Cfܕst?Yw"J
(P/Rat 8 $1&X*ry(v Ŵ䱝L>W(
%~2ҍS^V'\L#z%9=L M(A-T@#=8Zq',4".&,s5#I~hзU>H)oWXzkQ
Wdz0Άpa' Ӈunpj}LK[t&:!(8T%71Jrj:.+3ZBVmORQ9rLΐ >\ݓfX30
jfS Ҿ-ر^I02 MxҙXq!ƵG>&(c}H?E4la paށjُV. 4br8҂$.B ՝B(?INJPmhmzlC#J]x$h?xamL`FH0r͛c@b$r}
R0J^{Oy#69tTq%ID^\>oXI5G:LKh3a>z2Z)Ɍ:sЏ WVyr ? spZ&B
FwhJ},09lzPv~qɋ +stbwTr k
$z4&Ss=̈k
S"N;>&.:15ŧqOL}"2˛^Nā><U'9
"VN̏ 5 b#yZ*L,E3KqEvCIAϢg0]@EzM|dt-.}88 .+ŭŦ{Uaɓ̐Z'MhvxF#_ D,FS]9X=bcpX[Niu,ABTi˃hvi5`!8 r7fMS;A0:VyI,RyèR1#E4͇M&QVVCxO`t H嬥BPM "suŽZpFqrsE(H,h [.*$(
gi"+{jr`x +{~T5ȬКpslk$CeF !F6.Rx
4v8ȶ" nW ) m?X׀X>- MCb#܋#};6|F`C(TN
[96OE6U; ,(-YҰ(Ն;ɠӎۊm6}xgeBU@ +eO+KSr``Jw?3
<,> IgYB=+ֵ:Z\nfL
5* ]٬$vx*2|<oVߺ h"tlZ\AeH}Lع w
J
ݶn??*0T2Q`${ciY?ã=(fҿ+EvYt3o#d (Zdw2Ei
/4R tELCK=>2e'p}Pul (z5P_44x?&`qvl ~$68%NH/NE%o\
3x^\Ϥ ӶoH |t}vfx9N U ^:`y"+{QZdܗTCLӈ#暭~
=DԂÝ˽@SgHmK=c
Z3{G{`/=
äɉ9M^Z$ ,kۇ 83cwSK\A_|joYi ޣ$(uIK= *DK)njeY wTZ:[s)Ia(w}R&$po9kkU&[*`fZ*벭 Y\ J3[^y9^.jpS4gg7DlA ٕw}䩿ʼw
좒S[8 ٳ&ㅨe9 1ҕ>:@r1/$Xđ
a~55S0KKRkB0V` $ K)=! H2P
[,[ xY1`D|:Ulc\.!XbIE*t:텭,J!WqڷCm+熢U5)'](# N-m&=wB
DhfM;ݿ"-p1ޡSH +_gV:K 5 `Eq?4*#EC8ho@k nڑy]^`]Fy73/e+#K۫ ]U|C`A{QM-8jE%z]r6[^G ONoQ
>
|
f*`"WsdX {-QӞb Y-'bjL 9vpD,hmHuSqLd&fWR3 L [yMse OhDPH E+.V5XVdFK}hTMsV\(
7'}Ë}"E1 !yZ)
BF ru#v b4m^ uЛ#] >H 2.vǀRjɾ1MbTR_1
,J]uÛX$ލ_ QdA
B52JD
7[ \4?Y`{4j4PN% wIkg!eT`jީ]
@%)j:s#x|
Hv_# @3@@2gSԏª[5^> "*M Bu7|ḥ,Kwv/Y{Z#BH=ե]`^t amy-c\IG(np@߿B
YBwga=f C~;k# C쪷v/OGT8* K3?W?XɷL9BՓZN}[wW0ԡ)^5 30dMK ɵ WBqA;ߣQꫥ,rϦC?ր4Ck|nKKݸ/Wy?js +䇦h {Ai2ee3/'z^=@| X8ㄼͿ˥V{Tnm'HOsa;B_L̿+wYqf ̾t
5t>X L"C;ĂrceM
z@b\;ș<@GGަx4J[0gdZe1b)!?,"`i7m_kjSJ)̚Q] %r13*T@KX
J2A ~МXdZmZԽVVɞLE t)A/Wg&H`-y GaԵ.uӧ]}Vǟ滰{߈7
3$"[C@uZ^x%XyJJY;gf,0E6.ЬWe[sNhv?#z%*]/SW%n5\(:4#[`y"9%Oɦ
g
W'֨/99I*$Hpi]{&vN֫ qDv.P_]YϰEj h `KRgLB+ЉKJe4.rԛivOZď3(sI֚>F6/$s-qawM 0)ٖql-*C!DNpY2&zAM$ : U# \"Z y睯Pz鎪>hɄvWYrRN!#Z lܔ@JCU#2*gTJki xR]<b+L%
Ei `Ws %~ Qx6_u Cȱ.jw<й! eQi+_,L%%yQ~!/@zB#>06w%(I~Cu.RC;jRzY)&Eݵb@1b8U3Uu*HP)&Oul8tԿ7?=mZb,,VX\ ,''"Ғ2ګ/3x f Vlt.0l_^AP|smezTt_r~jhm)L+p/au+vU}i]HJY߈uwyZb" Ca ,i t$)q$
/@4@!Tp/4DHX
4-ւ}_c%Ь!,u +%y)p("-[9_MtE%!fdca&ܾ
benf*,Nj>7ri1۟GEc]}Kpϧ߳1ax)5h'!3m>K F_r` d}bOb*q43Ԭ |apg=q#Ԯ0^N**X\k g1,2j ALb f _ -&. @%)I-n%4B3pnu
%7D 8"sN22|
~s /$Q7$.lzZS 42 we>+"kF 0ww4`8y_c
`:x:J¯
9F kPΕp7M&$_x$Df#~_)mII5[ N131zl`)QqJOtw=yDόX5
XFtL
=D"ݥm;merɜswO+G GH§G#/ ?+/My)+{Py*j+_ep3{Mh ZŬ /bة7 7MDS7cT{H
&)G)
Ƒ#leqUPb/&lbU#{,uC~'E }
Iams0}Boww*H? Kޅ~͏ i4M2nlBvŊH& ).p{cFQX|mS$GE{HqQ"S)j#!`-UBA9$%Ҥ @Ef>$%.vUL-z6X akyy贎`/> L(Amה[@bN{R S5R/P1hs9,+{
oŦX^仉eDNHQ1GnIcA;(gn=p&O_(ۀYP=*Ԇ.D8)~W!W\
Rz5,$CW<Ƨ@;zt~$mIzΛ <89T#8VCrn8@?Z`ӢJ+24 z?l,q\ev6+R]* Jp&`N|R?J"\>A`Cg?zJ=; Lv` v! d=Q f47B3 8zfttx=kºLl `#n~9̤XbtZ9e*z!ҰeO
, nL~))4}v~vccRO`O̹klW~Szmաқچb$XaEK R`0{GVhLwaI0«)Q*, )#:P-CI E +inԲ8̍ u$y(}rёKA,uQi9WTp K[|⎫W1OAš٠]CLˢ yyf d--<ߍM\6uw(G \>90~zm*MDM8g TB$t)hwwdN HE7[c=WԫC6T~N lMj[^ A=F7kxapie\`Ҍӳz lʁ
^ j#"V).FXO )£X(RRyg&z>8Px;~;Zߣ>ǖFR
ɳT(/D0cJ 5t)ubk }!kP{8T _d[.1[BY
yt"%,&v.8ǒ"ӽHoa-6"
i&N#.TEL-6!P 8 "Ӯϑ< pvBZ4CO84 ˻ƟP7:^RoR.ڒUc҅]"n`Շ'܅ ѧ.je T"Z⨮ Q9 g~/I^~)Wr0R;5*O`ZѶ.A - Xcƣ{( ."Idʒ
"AuҤ.1`!uҨ l,hZlVŸk L XW ڍ |֜"ЦȊ bt2]u4|nir9N1 86XK4jգi ,
6 ]{QxP82b"rS/iyUB|fҪ{+#'ڊ h8l<ţN.Y| 9TĶ BgaiMS0r@#~nkMՠn`N 3j[T7q/7)9Qv3N~Dh 2^нeZmt
0uD2y9ǤCmn} &yZzg/r kIL/}5XdKfXD:EB`IܹZ{+:;vĹM뷯D$ImTdٵ?7Ncn)^AP!iܢ#9~ ׇ
;eVJ&=>+ ntos?}4}`gҝ ĈTXRMoT N
)*!Α<9(}+'r5ߌ}IuVw: C p9e3wiM녝V|#e$.;}}68Lq耸~+Nk
)k
^YvEzxb9/g
(4qS,L`*dU'u˗qՅ20]P]ϓ\R`l4]&MJ_Tk_^[u]]O7
qq|@gϰx: m:R3W`ڌ N0vTC w* WTc60|Z]>L3p{:h!'8=}6ӇLW,7QQΒޗVxGln#PQ
.H
ӽشV/
q+~jY\l~5ʨs݇'BCfiW0 u9)9jk^ %EZ<_<2o _E =hnޟ ӱt1P5({|@8}K*&*~a V =$~KE{/9 dc5kSCp/"3- w oxV8%@"q^. DD팹e!UjtQRPtzݽ|3Kx!+tgމk
T^uU<+ȹk.0<2)oR* jv.. hq8l 9r&s{ imO,@H^5j)9_H~W 0xGz86K3$
֧{z;7v||yHCMe6qύmfX,13y0CH.LIS Pg3*NEz1˒ʫ''wK._x P8t)cd_?x`O>UO>&z .5*" "95NȲ8MEC%:!뵂2I@/@"EKI4ZR 0
{mp ߉Ɓ`. %d.Oe\Eњhi!}N`2 _vt]e eX
v,-_Ȝ@
\Q{0q08 09hug9 ]3BDD5pެQ2œ-9ة֊9AL)du|b B(kMyKxYd ֳi :C^T32rX=Ș4mRW x:SӣKJZ/ATG{]2L# er;麎ཚ`/agPa+
6y70qX^=ݪߠ
h@9z熽.nC}|Čk o "Սqv S5sP$ g Ôb2=Vfjy[Ϊ'V2'~f}ny#VA~ʝmʄx.6B 㦯kq Vֻ]kE]en7^H acC2x:~ظt+ϟ& fbԩ *[Ǥ,vy&Za>}R- <Ԇ!bѫZZb7xm:E7;"i' : 2:_ ܉i3E7ύH.57`iXd5o
|Hnum ~䲹g UB++Q(6Cн3JK8S9[UONݒ/U< -ш:[HʌB Nmg*
TP\m acA 7X>h m<|>{ۇ~wSljL)[l|2nrC|(Cx.NljȨ,`U?c'!+%b&8`'^6P *;sn(S^#wT9Js Y_Kג"hF=W
>x ](
l2U(R#b׆"0]+8oC @|@>YT:td @4C'~EQ+,{9|~1U{ |>W:cVZ~kLү c;? xld.w,0@xWiK7Ih7J젨@Jֶ欷;xl1OpKw:>Uߪ1tRAW.@qhRg&> Dp B*Sq۾W!@J@ìAĐ u O
^L
FjHe [;0d.g5o٬Xw X1} ʡCuJ,MTsj,?FBI]B` %hp0I'=V!LUOUȱwc`>dkAp%hy`r3Gk1'ɧ3%ڦ ^Xk04 Ӓ]az$jNDDF _)&f 2;gD&(;;Vign=@WPv (ijw㈜;&`x_1jYCAD0)ݞ۴M쨱;_Po H>qiy
+!Ih0&12ǩUHL8
:T
qqHء!j 8Uxo z
. R1x5[g* t}:},3]X ;+C zL VIcL"0ak,U`n3JFH4[tx:
]XNeghں.@Eyr}?m[qi4 zqbYti7ahoL]
d47H[ZaWof@{C_^1usI& -p_ǞzfC=_5xm(_՞TrJS=+|ӗcDʭgpdYEyHMoZr e`$
33X9Hb(jGoPq#zױy:J4zz=IYR]]J: ^v/JYS87y_+s[84YR&14͗BO)ѭ
"?+L.VClI͉# ?;Z&!]]eKh PXɡqDfƠ & לh.R4,Ʀ82iafŚ y~# Qh`Rm'!dm Xp 7U80ߕT ZI/ NIQU ݮ !8*A02܉_yXV<#"D2"b0YO>
#҃j:4L&tmt˙Q rt Ve1D
:a9m*5ܵdS#M@]"l$ZCǍ[
oъ-hIq.!9UOs9h U
(l)0 ~-7|Ҁ)Ut-ߦ!P.7͝hFVw2*tq.([(xiϔ*jqRBGI
{:P
.fс7\ih2i:RrwD/ ofz()[W d*X(j|FsZGebl]yX9emZyTy^"
SfRfms~
Ż "nD~t1~τ!ĢL`;F )jVO;iQR3v(X4˱9
A=A8X`q(Р
X7R!wrySf"Bq.
˰SziT.>/R)DYc!t+d _kI u vpsKPk ^JcR&3d~p@7mM3
rj CtdaK3N|ScZQpQIնh!u( JU;8О^kjjV5Ըd3ȴ;ݸ: r+LLJ\vq+t=7;%G {KuTY# ΌjϙW'>09<"( Bic~4>ig)3$`װG 8A; 7D5SǸb5(r5*jG MaÊZM;P揄u狹]`Zs<P# ufۨo!Dx OI?= :tG&ѥ!jQ]}-ҺO㗩RUj)[% jU[(k̻Xi Ex5ήGGGjD[zaإC mu|3 G2R$~}~=+e/yv5.`!jMk@(ldk;j*0wgRC/#Sg/lyYY
OCtf°i=g +,-NHܚ!*-9Idr Q4Ɏ ؤDZU._?}Ne ]$}`[ l uL TOJ}tԐny7(>m8W߮!/&\N Ϙ='|JDkO+k_ 6' Bʢ
U3\t- xX A` ER ~^#zerDy85;wXj9 RVz8&9K>!3H2\
$zx⊔?)f
][Fbϴf`t3Z\"&;)dKqsWGRiڜ 7HH31[̓aqUYj") 0 g2'zN Kb쩌a%! F}Et?kp>髷ޖQJM҃9NpBc>Fu(,j ֮WE_ >mP/
oJyhϨgx/r%N{i>%@C~ު6BO3pF] GՈ f'_!ovI! 9.D_ZӤ
SW:Hs<fA,+!LTIs@5Er[}ws jKcL%@:IVÜιߋjE=(d5tTI[6_0v% ݿ1EMQ
`ܫ lf䊭=`h& 4qi,MzJV7pl=Bt1ea>%p PaM SǶ
"2}6W
4Fej F|w&*A+UsBk \tf>^o9) s()aK9~/8q7Qzos,~+"t@`;,q#:V3!2]g~%|MZkΘ!4ǤuAyd pIJҭ];ǩlU鉲M \_??ꈧiI>o( FBxAI1 >CIwP0&0R: XYB NtN Nٞ?3>s%\լ50lz5QIr7x2dHÌnλ;ҁ [쩨ҫN'LcdvwK&ΈF@ѶIDXcS]Y, ƽ=
SAcK 4 O ;4f(#E^itӼ2^)e$Qhi|A} N4
ܒ*3VPyX6 Q+'l5}1Qˍ6 +Cgd)ܝI>l@=7x
,4:dYڟFLG g樀S4 FCz)s1ZyzË!5 "m\l~~$yQgQ}nIֹ(k"k=f1@ Ȫ^WCyT˖eۿe
rj -E"OQЙ̩ 'WJ}q5 o|ӥmko 0
uN[6lD{9
1ڗm==]KKe #X[<٭zj ɐ}K+ Sߋg:' 3t(=5~A(e+O-< UڑG.id N
a߅w5 Г.xx`:hh. YN1БrBp] tl-)_5:P'^X*'| ^{1\i? -G ռjOHvv&MY7anLC1
OH^rqF* ߩ{:C /HRTItVU
];D`{U]Gƫ }IK[= X]nh _9?a 㽸)d}NNij6!
js{ PMmZ"LW=s3 "`Do0 z'lI,t¹f
|.R7=t-3.oឯPN2ۺq$8;g\0.=0!q~d! eKS\9̳W@Koz *=muaSEQix<*'BFASԽ]_{&R Q↋,tߚ \}&Ui=.>wSSW
\w ƑFk?YqSk^tVX6|FG
Y\P=ބf{9tw!yOz 1$ob 9mub3y [-_he=3
;,Sf]P2*t7AQhyfJ.;=&w"L.65=|[K% P^Qie"ڲx>=|@npa|q ۻ\0 xT IQVmnmS /~Aӛ +g]ρ>\s<Z.U:=_ߤ-
ޑScY7y'Nafm/C
`t9R (ǃշ]6 nPLz*dt(c
px
ÞRm)
1]ILQ|
"404~ -'kH62paV46[
VsI
@0&,
"7`!pH3x=yb
I7R )?=( ^Q :oجxO/CzI2#Vl`r:5gU! 3H.6Jd}5D%kAבt\5nTaFWA,=՚'bT\I1tz!;,$R`TXaWO|@*ٰe ̡DgҎ>NhUSUp ^.loIY")sdԭs({ J. `9 4>:{^#'KVM <pmi @eWZs`I+4 a S)%=% 7d+~ B V 6'4-.\o1pnkv2;LxhČ}@o d E :
FB}1xɵ7lP0-W2P{ag;SR\Vb5 3IJ {S;Dy`#F*+ U6" 40=
n*G&BOc,[x(ގy < MW7,eP5ys'jǀaxX,X]V>5JR
vQ$VZN " )vICWm/s [#0DIqf3"`,M za>N!bLy*Uv&w&s~)Qڢ{$I6 #9d 4f= a.>3I a\kXƅ0[k+,*7>/w Ũ!)?geZ @/Cr \O/uۢ4`*;86/^6H9
[V;J&OB pc Β&T5 8U <^Pb [&ֺuOQD.Wr5B!J6T6\ o &>)I@ځQ:D_Mך}Z#$ a)Ψ6DE^? {-\lVipz7y:`ɕf.hZ,٧=| Hl=V[CLyZ^srr5ڎd k. j:"՚kpyj3YU wƦn9 ƚ/ ~퐾?4
am&<߆Z`SpUX28<:c8ߊ[g C|Raʼn/jt+5PZț>CKr%L6&/g$Dֳ&u_۶A
]}! "۽z/\YJ;H:i'l(^O I]L٠AKU@T d
noZ @Gη%c]⠍ukձ*ɎG+
js`伙Z︌kRQYi DVSjl lbiG7ìvˆobUV'۷EזٜI T=uc{G(vB}I~u_ M0<sqk qWHwꗒU~1WZr,Ƿ[>9J@4O-Οu> w3CQҟ Ch*Ss <#G' Ruuon>]rƓ':aC` ]sU5{T4, Yb%l)cw[7LLnW?[K~h{s/wy{:U
T{ylDۑ >&cxm-^C۽g\]ôo<1_oCnVK? Y?jP7h3{SW?'t~kbP\)k
Z l&>~LvHXF,), g9B҈4UTEne#aj%)yB,BZ7,.6F+Dw
leӣ,/+ത rّ4eM#N ?2E]vjAK5^۟eJVx"22vp0gBse5P J{4\:I*щ?l֞!C(TrZ0fUҞq:kz42ONnZ6ҍZ 9.PCVjbW+c̙ѿ*[*Z5_}g )aAMZCVrͲ uTY!!l8h-yi\d J fHk(rrFMd֟0Pbreh3SRϑi B
C]Xbi R=2Ώ |Uwl
6
P1 BԕN \LA젌]S'zB*iH}t\M̩A~sK;;k+j'e90 u 4TC"ݎJd+\yP]bjM<9+s6`Vz]?z|b:-#,ts \9<i; 4c| O7Z VO^J/ |8; HNsm :EI& [{lܬJMM P՟E
hGzsq @a
.c-fqJSSF6s[aK3;l۫;eษ qn?S"DBM*|!E bw)'%0 Q;,] e| #u4UU
pu谨@Unw2 H_Ib)LWwUKm?0Z'ҭ/< N\7oI$b6a7\8 z {DS dž$ mW· 4Ҧ#9(zd-44$g_sѠ>ǫ/4qߣ
f ˓2Xr: Hy,|j+ck.*8^|iTq
tO fPIO~ Rq9);z+2)%:dD;}A[*4lQ#vyaXÜB3Dmbhÿ»mʻ`y9i@? W94 >TTNR_r{ЎA[m*}9RV9ܛ5"N s"-xd5{û oJU ^l]!0)
g V6z XZoa1Zr
-ΦףgɂU>sc7d+~ Ěd #|yv=Mq*ojAo1z!Dx|%\/DH}OQF
OZh0Δ$3yP n Y?
JՇ5=0]C^u{osڟ$2 ԏHWD[RI
vJ=9|µӧ!ga[4\6RX0j̧+=ʼn fTqϒ8~|09VJxjMi3I}6Ǽ3w{Ç\~g$[ysw(o 2 J hŃ YP"&X!>`(M%Kx[IAg2qx;Z]Jb)'u A6m}R\:5Tʌ1'!X1 ]= 3|ÕC؋m9
w
kZX~θ^t}H-Qߐuֿ̽4(W K6ij٢VU q@j4`U#f
CBXd?zyMѿd@߿u0kdXr1hm#nY샺5P `h"u `0M9(s Z.SI| ػ]x*@sHpϐ"_,)1R-[-Pރ4I
jWoΛ%Gc0\N
-R34 -e g۰ou_jWְgQ]08VDԤS"&[_ T^|(kaؐ itRFL6]L8<42wr6dJzL' D YwPL1"&Z TFm4*4tl('yPd~] ZZ
@| ]'N:T2ѥ%x=8ԱȨŞg'9gsEA"=W-\ (5]ş́]_w caED)A[L 2``5 ;쪆
Y|ghLr
n78Zhu6 xG4wl]TO*S\q4^}%KXcQUw هk۪1n ^Q<0< :ѽ$3
Uf]f V Y})<-D:ug N-S 3w5j5
qk*CˀI EDkw%ԲU7 {Ul8NlWVV_i=PPlX@,94w^Ynj @_5Vפ,䀦qS E^hlH|M_T=q]3g=qOʗ Y4y\,u:h{P,8p-'ei9CXtKk#$
|ITtPM{b0M䤴6B;f`VUsfå7N (=Ͽˑ9\W7u 7Aj֛C٢e]Ҝ3k\K"1ˆ80wL\Y $`o? ԊisYBi
#˥"0m)d
YIAkAF`EŽȏg 4n'"n=Z>[DHj2L IԳ[9io$]ߪ?bU>t }We)(D|04_Āx-5ې$=
D 9pC/W${ tinć/ Hؠ #v7Bm&!lSPr0ϩK0@<//s jL(jĪVP<KGffG("%!;lgudܴ @k"e96Bz9 )7 9q*OkCYk@D@LSLE&ʸ%MrEr xR$6s ]t% =An
T4`dM"ƲZލfBdREe _.mljhMrr{M!Ci1<<ӗUrT
cҫ3:vOu\*z\G~ubBsTg`L*A= K{;XcD֖% e]]Ba:}g ubp6) aKbG*.oZiJ>NF`-.jɟhfnV*tkjD{RcYUv\Q֖bRt~
\lfPTB[e$9DLKݢ'#VC6I͞)`L]z#
;7^qHNMiVEjw_$Srq Qv uy)hc oziDI^p-`ebB)E1ł'zNTlaEmhL" y|-ts[
SK*m 8 >'Dw !Y>Qoq7hAzʷռzBϻǻk ]k i$ OhT+]ÄpX@*
-Χm86_ԐF@=t-g8`. \hj} }bb[3u@~q|˴1R B!3X)LBnuQE{p5^ c 1_e} %
ꦑO )?V8`\8Bӊ}h8XeqcRa WZntZGk֦ei Bi7Aǹ׆q豓 :) >6=_u:xERn>C s)y:-2岐 i|m\ژʎNhG,Y\WuL F/j3e<<(=Zݼ,qIIg"ͳ 2|Dk8 x|}0Ay2([z>o>@wjǷEOT-mڡ(:g0XkǃL<=cͽN {jcCx E5aIGPo6 | 6 b
-QrޥyL}{Bg"T[l8uKhC*n2Ux`w).IE r
EjmY]SJͅ%ӆ>C CiyYLyB"`P@TBy]5VC,0:0K
=^#anc6gR{
`Tk\7WOO! R"O`Js! x%ɨq`!% 1DoJvJ௳ +k>b5x y{;H77IyElCR"HsITߺnѬ[ Y !2"ZY@l&Xv . #(B[v]BV"`]1
XOD\*I6D5Mx@OQ$o\<%5~B-hh[rNEȦʍMERV0bDS|" *5{EViw+:Z$ ̴uLD~qJ;'
1Q!q;~<> n; uST u5s+[(B(S&r4Ծa!l:_l Nx*-F6sY :@I4m [ƻtq<)AB w[<w2[I;_L G]a`5:9 CCVapy.kJ}"L
6 F}%*y|r!VgUoJ=p@=8R"ϪZ2X >~}:4T
ر:cl^GU G]OBIh VDD]kpQ]p66,4^I+V`U4=WYg<& Vf kŗj;qB +t$;:G+ =~Io'D]E0K:MSwɝYjגјw ;rcCZaf4\{.j1%rku܅Ks+z%S7Ŵ e܅ OE]e\ K=jg- t:JKKČ=И
v`ٶD<8#UUZQիVbڊϫrhUgxӞpĔ= q.{/kWnvũ+.ￓ"j=M -dU
QRDD_(' L J'?deEʐq?92ё,^ 1` 7|LKP22"+sa f~:ks2$Dy saϯb7j\]} w/k9#U+oN7˅#2-<]? TL(bԊ(NƯ:D.E
vЄd4@~+Aܾ= u8$qPmUixxpZg~ΕDT( c&8Dߌ)
@NzH=n@:gL"'RD ^m6ibv0LODh3 < 㗗Wp/5Pyn}vot
.6TFMt%;^|Sn5=5 Xp$uH m)XO{==1 )NqL0(UG(Tib'v讆 V.h٘,+">l遍HM㈶j(.3 ʅ:%3zvGi
LTS5)8[w]E*{:v[T'gHPO稰>d`qK0cX76
v6jixX2.(IߊczC~Q/[υEBB^6Tɯ|t˱ .Tpu`{.` mq$?PSxd=n~">
]'r;tV]x': ڥ{6^ ,ySDG{#};M& G:o 4̚.#xy\ٜWЋ /ꍷUE 8p?0yqQ!ur!;:CבE1D.b>nj:d YJx> I 9b>JtƣaA~zaŮ^M >\ϮBKm͞Ldh9 IFO ׃DMiDjk",f^/g|Lt9MĘd:%|0()rԭ'8te 7Ik|NP:j6kR8P_%N|^'`&];u v|v Yj1Cy7dv W ͐ ̢>ju!B 4a}-x8_hs0W$i؟i0J2IU s( U%m^ oyReUn魸V
[ٝmqGխKASm阃5@ 0Ζr T ͜ Y;CDFTEzH{اｓf!D (,cR=G"O#JGSt&gK=9Qѯ!nE}O;h[dXC2|ܽG،<hHk0 2頛/#EB d@
/û(lXa南Ye^#qɥӬWoOu; .몦6*jD\Yaʜ7O,1xRN3yl2csidJ+P7 $5=uTV樯kۉ]:ռhvG|f˄* ; +g
n
OU8@Z|K{.pQ2(}p(;lc'nir";(q&ȸ E}('a' xJg"ZAD|M6@+Q\j qgy!,VУp$'B1ߋ tnVzmC{/e &0
iޓp+?r5Y2l X3 7vNenv# fMF]GIßĘ5Pvܯ_}&HW}bzaFT_}Vx;}|Zx l,XmgхoH8^pK ܀~4zcҫ!<}2wZǺ5} iI/_>8ܗ
ֶ.}Yq`eNmV
OjMrKn]0Z^V=|w\9_
>]慘ջYGbÅڔhO*|+& haH.
ǯJDD^BZz{zf`0~&(G§mGaA϶{#hx.DG5 ɞQ=V++-fv77W?O*TBDT4Pm"78@)Fs8l? 9-T 8A\=q"t&> X?[xXΝ6JfP̫VBMM 3%aƹ"qEQ@ d9DӘ>IT:U~u dq .U 9}o,JDq"*]JE.$u Niv "9Ke hg
X-#-xpJ?{; K~i\Ƕ,dڠpb/`5xT}tDƟHg=_KGȱŰ*q*$)W딒--Z ZT62 \ _GMˉ\WE ôUrMm+Yh>A-}}kEqGnQ ƍjcAp&V
a QUN4Fmc}>Ϊ/5\-\rAfWX; xdPI=a0_QhLJ}"6h
#e
B [V"g1i~Q;akE7O/ >kNÛiI$ H}6l[u &Z:È6!P^\gt? ;? 4ǝܓe$L(pO(Mc=T Dic@ &0uו`Wв]kdK!fDn:6W QRwu'jEF n#\@Ŕ% 6 N7h=Wv/J˦OhN1͙)FϰD;zɞ4~d ZN;,>U=>CnS@#mLޗkJE7CNg "aQCxb]t$q D
3ՕEXa?[L}~@ſV /nXgY r!gߩ٣0w8w9W~<ob4ܙ,Ckǽ_Cƣ5UU
D)}/B1ه
Qh&W
TӬi ͰA@ Shg]>Ѳ|_x1 =GP4xQ(;$ե.& X6O6M lgnm{.
ilvK(ʯQ ݱl))m
8vuFDŘt&
K<_ +wR$?r⦩aG27_9 "~/}$\@ zPہ8xǹ'Gb-ng\H{*A?j "K=S^ +k2Dv`S? lV ^o9 1 ޕL+k4u|B J/\$M} ++f pqT)ˮNk^6hTTr{wdFVC^;K-3TFuD+Ps6/I]I!Ee u/ǃ,`h/l?$"
h>/#ߎr-Nv5Ut*]xG~ZY=Q$pF̭A:~~77%71)xQnU_77s 009iNdc3X6,v 88L+|c*a4 M'(TXh ==8 oڧj
G8@-OP 6X$RO_^!@$+pN1*f\EPEFQ@4pH ƉPUS *4sP 4@Re)W_ *8g0jk
:ٌDeJ![axa e3;&}p5廉# *E 6>hAk=0,<՟ ܓ`
/xvm ^/D z IZO~ JFAY'N{a.G)]VV߯
. L Lxߧ GϑUgChms5+i` }}-.J& I* ({. 8hWpT0m
l04ztO' qU<=|ʑDPO>YޕK.瘨0K-+ub&ȶzw"b CK-~<ը~=?8Q "ABW*Ku篜r\Ta^+<.{ޡ+Zeuԩ5ݝ 6 zHJl|8ԕbp rBAC7e-qH~ؾ2p5suq+H3S (z![ǥD.pbX>gsoup5TOTtf@*j4+صGn`eQ94A ̊ЏӛO饞x®݄QݢVO^F=hxn[o^ЬwF-N:k I!x^.um 'X\5m;ϧNNxWˊD\Ϡe}N^
XZ6®8PQv[u4UPN]aQ;xuv6]$ęWjPگH^^kLB~i`9]Ȏp#n ]+uSNINuһs{5jUZzUJPNU
?!hSO6
:}X,l" &
zGݞ;jۘQT]BD4 MR8rpVFDд}IưNȞ!1tUіl^kG> z!eqE< l60q̞R4`-s~r% Goes?K{Ԏ!0p̮A j_ƉCN$ ZN)cMs2'z} mQu
I)t80x9 =z3i
4^\Lk<#yAm S sO.
p]m˿w@ɷ9 ޒUNrtv[^'uozgYNr`~beM5 {X562<3Ki8!Wxh_Y|zۦj^)@G?[%G M*sjc=+䵳_)!~o/S"RN-{F#Jgvfq0y}ZP삻¼[|B8J驁Z-&ǹ{ㆺRv&h~=o լb&(G(~٬6cBtxyV; p>PeL_~־
zAc˒ԃF ֬Ė-Ak&<٣KBawFlDے~sE
ri *q
X{q/ժ}$9eYPMBuC?P(yM7.r쯔@XJB9~;^ _W/Ͷ\`r8JStsope W_9Vhe^15s^gh& F^jQl@cy 0pXT݇2 HtHmmOH :YeQ1)¯ߔa)=u|vO |oe?Wբ% MѣQ
p*' 0qDZ@`VvG!Ilv_Njw= 4ۛ(gвz <)3˖KHm7KLJ-+Il. jQ rpi3ݦfIϔ+{e Jzj{ sPs# ̀g :^ìcSXhP%&o7}+OʨOu%C&- 9HÊW 72JiuBֆ0*}'
1@E;0B5*婈Oހv$B
AFlxaU/N{mϺzç5pYtv8<3.y-v b;|{
2lHzZfMC/YJt lWy--gDҧzmB5 zZ|&UrRs=_}/уþ:7u9RX vY,% IU@}ۇzot)}J2p|u54Ϛg$XHMtxϗn-FEoW_#d"D}0Ldm
\o{K}AW땀1d f!ȁ/@S-p`%jq U_~q{(\m2~+ySEf_B툊UsZ:\?6mr<~=CgI֊Ԃ)E9-a4%y
rXB7X "=~ REJk:C_6:(q9BPՉiJ vR ޖmO%?ux>7Y6mUfHzS]wm3)'@t>f %+dDd6V2aU-k枷y}dϯlwMiAnPT=h틚 vaM U0N%P?5z1fxD(/q`;ԯ>4
\zEoуe= {P9B`e=x=WoT@ώ
POltE IR t7<˟|B|y! yU| j~`QӃN;4abo9/%\W54.2ˤVBxơeSڂ
_Ɲ]M Ea1X8.Â[uz+QU%S,]߯f$4 rϙ8V:)W3߽fA2asH"\k
أ 9b^ t)2AGk ykƽ5l{v}V i}KwF4sl W@Dw ʣXER'y-٦)es ZT g vCNY͖G8M77R!T77Q$ݩn7 j4SÊUqTBK=76
>t1X$vPJ.]OK Ey۽ tݡH:s=<kf?Sp
V.gvf 7 3sMLỉ<6uT 5Ȧ} g} x>Kӂo);.gw >!V#^Yh'Vimk Tٌ3 Ŋ(DBL}g °3ٍ?=IHV!Le4Y܌yO1(]~q !$"4m }Nեyb^-8^)r䊒R ' O$h1%uOr~Zoy U7ka u,ޜmg?m~&ۃ:g~ EV71ї:Qo &wr
W^堖SY ~0s1`UG+hz1aAnݑMLO{~9>ʹ x %ci&T9L̼i?yi[.Mse\$ا2 PDϖ \K maVa<(NJGٗdTl}u߶dwK:Z):ƇTSk&z .5U(98uQsN6g=Ct`p͇?NuK;\@#ɷFS ޖg83 Gr30e[FK',bo]@ BuRΡJK# u!&1heRpаeU槃, *{j89afaNj
Sm֚:b
(K ^ گ:ViQ'8UT. <"I] Ʋ@~a;DAVBv%.TΚ3Cb{秠 x?@t˧{h3;Wz&\wjY ey>͘M:UX`ŪWE8}~$`;RL?}zz& ㍱ b\z^JVCܐpK'ߎ =]0mYIW[}zeGpƟXǍ"8^^9 JU3jKO>\Cr7Oۢc=6pI{ ~¾ [7U:A>9xѣ$XJ56cYVIy
fga:Z-)s7/vI6 hC5p4]c/X [WӮ XE&kaT^R!'4(U]K
)b,+q/s*h^yf4:U"Ezx>y; 7\' qڏ[y3ӝ-χ ˘yxυ2TVP}X. } p^!~8oB5Mȗм.a=2Y-){ᗌwt3)$X
;Fh^c#+S"!LpD M\H1-n[yd6^qӝ,s(U'YK4 /M6 0 ?M)`V#o=g
Q*X%n~erT/ZA
A*2U5F.$,Go [=ݝ@,ϵl N |:h&2~ )7m]n| X^twR0,[ ~ޘOSXQ%!6 =2.{OBɆ[
RT̲>g Amm_
3{َ- g ridmafʻ3+<ǩts)K{ߵyJ1[dfżÎd |hVWoO~D۹I.@_T NE ׯQG"1~ϵn3MO~ggZcG ;>1GVY*vZ9d7 ){gۗY`UaFbb ?!BDn]¼sxqes'B廽Tj1`3YXK;c a &E =d1#-ϧ# c`d^WsʧԳ @b)o^_9"ډmo!QDg2[ut8qW<l}i:hX&{Wwח(H+~߂WSgy#w- =xWh? 64 zn>269nύn/G_ A /|u5Gߌ-_^lԀ 1,Cf3(]/E}Aͨ;bj{vց{z#z#E/4' Z@CC 60z3%sbT"y'{Ѹ,9ZҪ θΣ\yUAT<$< :&5IO=2Z1էL\)j7"iz^TF4צ:X{uUoo M+9[lr"̛,\UR\ue7_i#{=! 2Ϳ r.1_jcKaV%ͺц R^\ F#j\Zeg%jw!!7W6gx@1أPI|70X齃zN`sF !tO70$oPί VT}2~ 2ӳ=.y We o43<(! sR=]]n(_a&#y,qW~CW8,Y-^f «=M{c /DmJzEƬtE _M0ӕnrb7%~S~i8ָ zO>X$3jEpk[YWw}(}q8lAMuv
>y_j?K=UHϴ+~Ab}{C\ιZgWs G8 UԮVbcA*^WaatzߴiX~[fu>o}|X{Õ ]}tN
51_0ÿO,?Q81"T Bn4IՁ4p*
!!]E9i6j1(wpUJ|`m?<ܮ g |5Uzj =*vMVʗB_5Z}%ѿW_=Ϋ+Xfs W9vPPLtͼXs~B՟7`)A GخaZ浖Enz7,#Tbn] =VubJWcطxϔ XoD zC6i,,OqҌ8a[JkD B*T_!w>#:/R|#sx8mLeȜ^1U4:y|tb Y+,xYk5UId :?_r8a,t|u*so]LNbm? YU@J졜c<5h:$d.rD FgX^+?N *ћs9AVndF?]irMf+Ous҄n0Nh
6VfUdމ;1mk~\:sϢ#͔2t%3Ttk_5.Ho7˞;WEINbFIH j2 3y'@ 3,Ex gpݹ=tUAwג6d WYR2>m3ezȫzvyug ˓IW Kq{O59Cq .^c®\#mc:XI:Y^K|LJJ+ڊ.Tςl ܧ)GnMl;h i*X{DNhEJ
c87R?KĒ6[
ȔgG$+ DrB+zH6C'
)B
JeX7uEm[if Mo 2 g] T]4逴 z3kzcm \"Q]J^#y{||q# O>L[:eG<*KmS{p7}q.@zJ9«)+ˤb Y^LO
<ʲ;]5+,<,m Ig[{V:_e4+~ee |/}b 8
DŽ~5>S`|~ <3ΏgFqy^=O[vG> ~:{WW|&14GՐyZ}Q =-8X8,,<ʮNƁ l?|YCs8]dry`j sEܐtC=o˗GbgN)tYӴܐ[e|HI7^O2OnoQ" ?]v2Q~tpc~_woTߞᙝ59 J~p˽S~<}}=&kD/.`~ &Vevn8u k- 9,
)3XQ@>Me
VOuiGϴ 3]A(Wvk<;F?j|9wXquS;(:pZ{'_6SfO1p`LiEؘn1)j㗘-;3,-x='(\i|nǓ%4S??pNQ oiP O7[Ŷo ~ Ｑlm;ۯ`Z$.v9`.HE_efߙ{Z^ Mۻͯ_W}zKlxcҪ3?/# ,]*ψ|ˌ~x|Tzhm_ӭy?Þ 9o e#%Z^Z$"C̎C!߿ؔ~]X+7wO>\d ȭ{
Z*uTT?9UsO
@U3^;f$-Od\>RWf$ Y̊ TUP"\BeF
XY"1EQ +#KVJ"oxԁ}5 Ct/[PK,ÉA \J)LޏG\˕=ތQݰQ/p . Eւ=' x>2i*va>m 6[ ?>~?OU'|w=-s04?C]VN^6?]חY3**Xr3?KO[W6D^{ ;I癖?O\lwp qZgM0rmg_-Z/;LK7_*ϱm O _o *>;}γQ{x ھ쪴~ ^
Y 5|ϳҴߗ&DIQ
Ll a,]B3V(lܒsRX9%k ӓ]v#uAI}ΒhiGGiMs-he?$5[qp cڵ^Dɻ4qGkP,2-'n0S*NÍlJM ۩qcFBy8%.G{$daerJ"f'uL.e?=3j1?[8To4=oRÅqĄ@g,<ķO,)/Yԙz1Wܮt]A1+:KqcVzKҠ=:dxw~9˜ 1% z0fQSTEXO Jrw1gοwn9!;o]s]/ M /k]\.x(%Ve,V龔n? HX)aY _ZjbS7\p?pu8UI,Y=y(Vʽ~!p\&8P s|'V"{rA_ǜrv\g7gAM, F^l73K7~t2zLߥ~/O <=|_9iˇEoR_֨TmƾhQ>ynVh+sT*b3>)
ھRxO)Iv;'+bs u+Ժ+u:Uj&ss(\*EMȭYBhpq,3Bd%S
fxoVnF4BmrI 3B% kP/nEt*$XB
T"")n.^CM~h );8eƦj2+>)?x2l~Tge݅]E}v?OiW}b,[+ynǺ
!htT?5/AOi.ÕtbتeeD+04n#/ cT= !f_`^(4&TxV=#5_{T*9,8Sy
ʿivA a2]QX )9
z8C6D!.XXР&%UXrUTKllY` T+A9Aykdd4;rZG
OpϿ'_q_ |;r*9_a' s
44(EH~5l XUN?u/E9/q KW77/ߵu{\+Y ^^?~Mm S%;Շ Koo~?:+~ 濘ՏbBJpV_<:av5Yj`xҞ+GRW )[#S 뺆ǚ.[R6dһ(=ҁu[+jhP
܀υ
J OLŦGfU4X JXಂ2tZTG# %KRN\p uHt5IP* \#`U:S!LJ
\A`5.sJD1fC+wf<~tr/ [G_
QO%ggŜUUiW|4[B̧kE>>-礷Ms}oWLߥo/s|;>YNRґ7ȶu'z)"h'ue7zzQ:%1k;"j,` !ܩ)K i,jWkC6ݖ/QGfUnY,"oO+pLj<.6\d:o}ѰGa^7} =cI<`R7'[EW\ V|WG;sv,
܇Qίo}o5BH17kY#}v 3 $2ڀbԡBTŠ2jцĊ0TD`u|u 6X:#W80m]n"3AU!hZ]\*ɑ)jdTmGe3%9W 8 řuWZתR
ۉHor~< ~hajf1a;?{N +_fp` X y(ƽo=/Z(u'r_ì}
ϯǷ>K-`w. ==hJ Xg ƪzK&3SRL:˯s&U6D}͜Aݷwd0^ srb|M Rg@dI4# C*j]o.qKZ2WxoI9y*9O *ס]j R:DYEi̪vRZ6@5J_" -(9Eg=[ ??/bBa^ (+Oz6+SKsZ>wb;eNuU{u4:hk/ y"\j J֬FUzP'U @A^4ou }qkN U۔. }t? :y~L}
U|@_gc "el=9`9~ Z?(ZNfh}mR@fw%y|M?'[BIxׯhfb-KV 2{VW+NJa&a #D!ðjb̆EKLr)b]blDU"DxK3YhX]zƛJ`fEP 9vЏLme͙48 vPvc36PJ JRj +T RMVLާ+oߛۖZNU>H%~3 c" $*Cڃd^Ńyޓ$2M}x
[{Q`X⍛hr?n9U@X?hzsz~^MG a5#/ǡ<lf(uf ,"+% t<ʠ=s C\!^߬]c/rtUy/gW M9`:PX0 p": bui<+M V)GNkE ^9 u8)ˆPuNC6V_gG5|+ s9?7Jp+c݂Ȇa[El((T[(VUu4vt}1iCC$`0WA׆>(R Zߏ?uHmo])2}Z[==& K}L;qcğm'E LJINR ]$? _G=D/ -| ~飧 mdvn/G
;̫@IO5z8RqMkЁᡚKb =wN%/;ͯK='誹n
J:=a
ӮADV&m=r> } Jv<xv7~Zxސ![+j e!@d$ oSŃk i4ܩypCaХ5K&,6Y3f 4exJ#%xJgrx5U6['u~:vB "łXZTQ +Èʢ)&!Pa7͒
IU l9Noce~ O^4PcLWG3>|fD ^eKW?̠=x,˼L|*ajM h~0|wGJ.ek{iWF'Jo.Pi% ^%KJuS Fwݙp+![1hr =[#l3ė˕!+*13E.e`;F&TbGeH,'i@B%4l\+.@T-~^P=6n~ h{@6 J\ F9{bduLS^ }1]K
J'̷1 _NW "l)EIL>s[]Zc t櫴[ÔB
,YFSwql%;@ƶ1JĿ-d}wIV -yU7Xr&[1^<':}jAYdk -D,R[JL>ڱp5C!L@ k"dP^LJW۔ر5}.)] <>Y2m_z~WZk~t̕ .j RXcJ-o0 nD8LYI35I
|` ψ875&\D KaHfI
/&X:)fX&lHl^;dO=jX3aPXǬu" :Uj ~ǰWW SY
] LS'% =JjhԼH P.M%ۜP~J7k S+KQ!VڶS]j;eේ
[Y/gKӛ>Ne%'lP f!3D;JB(E "I$7
,Mi )4NquP-lD 0-SUcPxTp$sODz? l ~<'3; 0,,VkEr
Nf}%,
uw I+7گХ[ f", XGX{$s+TZ1u.a
T - V:e~3.uAڅu md ~e/ Q*v &*GA(UEGcˊT B43AScDY dtk&=^VH48"H+&uD{5=2QfS0
x[$AEV! qm)FIUpC%AHM%0 ^#'r`X (rD)܉o@Lh6Rz 1` (f["y.kj(/m(1"@>U9B`s*T"{DdvV6 ,R L4JayZ'BtH'IA7pj*4Q džn 3GAhl%Z 1d;h
}t7^"VA(orˠ23+^gbɭfJI/ujʞ@nP5J
,=%dI"XY &p0ݣ0L0mBnd&iqmN/xP .V:,$ƥ"
\jlZq|Vd}R7Y S #jK%>\ǻUB"V j?[=x8JC`/սyx
>~ȣ (gPa/N} )`9^K 4|m Hd>tzxs 87Mj@p(!c$]Huem>_"Mxjjp$,7Mpgzy$ 2/')D,dixYvS*vń'3?(\&,
~5 M( 3+MS]35TxRi[6NMtb[NJ Zִ*Ά;o6YD+(OAsNr9/1T.X ԓFZRcbK)bs5oM-rizPff\g2QY@#<=m!{'v#A C9m@TPP: L Ehb5AlմY#29^T. #&4HlHs%cv jlRwmEIc
֔i"9NiMI WTO
E(ڎ u3]j&ғkV$>O^MfaT dB_jDv-Rz;d qYE ;u J:H6UѰv 5JL`M
ڝ,a'Z`)Ort
4 6
LEc G?݅I[Y1- Y+"` 4A\Exh R_2nTGR20rƣhJ PwG~
\ٖQ W ͔IF^-PoXjb% :9K i( zmc42{$y } 5
â`͊ VI IK[b ZTYP! , h8aSCa0cD=0z[0vF0T$X|B\{L71̚Db+t(d|UQ l2))E``i"
r7|/)(~U{XϰZo<)D?
x@-`[IRT;&W i6JbU!r糀t1 _X˖g 8.d>*m )E
>*V?|q"%+>iX(HTScdhYd+ g S<,K>UMZAɠa"B\u:^r̃"πb`ʸ'xk%R:32A}\V1ądIN6~ay:heez95
˖ ʟo&U5as@Z
:Y.
M)m%yU@2J᷸10xz`?*.2,GyB k _b`'YP#{S!(Xv٩\VxGu4`K;P)pY -T{ ɡgZrj+[eu-:G KÂdـU
nݞbtnթ%uDKXZn]'; YJi-}5hL%@*F뢘LӌM%E FDxqqU :%.; 1:
jZY }+f]w1s{ θ[ba oD l$a5C,)(5.!RrYKr]5Zqt sD"?vت1 EPM{MjDk?_QiuLVu)R:CAMkʠ5 t (Wc?f|ÊrÒb*qƢ+a/mL f!xgx b-{fy5aw9xs2G97Ż,c(4pz&Z
n\Lv(v/Fe I@h uA{ xljB[>',;u
;M) B!Yb
,jbJ<8 cf>7A jtPir
6Fp.LQE
#dBqͩ+e W8M 6zj
vqV_Nf['p%W/#xā&b4,_!OuH>TqWsxp \)O 0jG|ܮFLRTj%r5|sVPDęiT/>
\8OO[1.V0!). c֛F3[OLer*A/6!$YVʇv>4
*;*hc*KLH;NB*gBouaD(!r摰6pF$·av0 ovzUC~,2a 6o(' H5@vL Z-l'tebK!8$$dՔFOl=+6:W
ũ7#}DJy#)hXa)@)L8 BC![2Q],B[1tR wKmjst f;0? nk X#OEE.Cٌ5fMؔ%,)l^ !
17
A-FVl]
5-@qQIQ5' 8S* !ţwkVJPl1܍2L 5tQԞ5c"P"vwJ H=FXiU5C[$b\Za7ā8p;|
E΄G'N Zc X1 tɋ:R7iCZVV+G̜{xcK,F6v#/F{lK
$ Z*.)a:d03S<0H KեeVFc,oU..(U8R2XN4]5-|h8dBʮA/p)dB#)a>ZՋXXm8B_!XKF2ERNFdB+ɝ,Z#SƋĴǟ5vV F᪇φr쑖eэQ`9 bq^V=R%/ݎ' n{8/"ٴjZlT
FJtn3s!qu0
?҅.FWPBlIZغe ZE &Vc1g0H v,TłHc\-qtKT sAz oWr+yh[o1ZQ Tjzb 5 =6F4Rp;gTzٚnh ޖ|G7U1fZxXRJ0w&f dq>E:QYI
a*!l'(;9%A5j LbgSzUmPT^|%J;\m&ӯǒY ##/((壊jfG~0
'&yCZvqսEކ|?S.YJL p6 @Õ ye&IxN5
dfU
aZ#IS|Q~h~L 2&>[1X(Β
N2ǭ
>*A̢"%d MDPp)DMj[ƯEK3 eɲ0 v)W *O"*& }^[KN;9NYKVfj˼\ϦUǀgs!Խz cٛ;; DL185#c< AT krf(SUux}rILJ)wEL,;:!ma-g[Y\`1}W0-֥O ,Vp dS̾rS%`8\ X^tox#Qe%\b\L$5qy .k !S)E"Ȟz"})IrcLP.># MmqDxvp1dˋ ah3b
Z$|uȇD6|$\X qD&gO-Ղ E ^rԕes87s- *n3SUVT76x؎@z"{K00ehŤT'0TZĢ[y,&kL"qv"pSŦ.
b\vLRɬxB>5۩ؠ*lw,״
I6:\@z9F:XQSś·Lin^! V`NubZQebV@ă܌&
q\hEU-cgč!*Ϋ8 QPdafأfdH|~ ZV yhb*yFTᢸix:0O'`%{U羍~
+¥vdl`5d
8jmSzn sIT uN )h&ڊ:Gu4{W^^яe0l *Άst ^N.Qwɛ By1kC.Jͬ]\
]-3]Pf: ;(aq̃]&Q~jMPc:U(R_i{35 H` JcO-3j⮉iBM NwVZέV] 9>桌Xl6}h:.vR%һnF7YŦ;f )Ŝ1I` @|'5ݳ{#6ݹ8*귦d6 Ȩ
cɰ*,r屹QnD)Y c|y ITlz43TpMUkKRsZ16Wʕ oy) i y
GwD֗M +ue+ zM zɚɉV20DLsp1cQBrXir6گ? #uTN`M`U3
ZlijW!
ցS)Nk^ҕ + 'z«-}1Cԅ75 gbT\U5e@wbnj5͍EDktZe îՎ
FP,߅CS1ͭ;)# Yl]MJoGhU1R= 4T(1݆E_y{fԐ鲵\x9hY_J *]HRY9֕o9&Ü=
3SSz:- YqNA [Ҁ݆{eouaSW#A>-&7͌A]rU#G0xؑCnFVN5 rE.QoqS')sO9NI(!73B1lDI+E "S4TMeiIiI t©e9)G#t\0ɫ0e
":cM,,iv,e#6 yjvWq (F
~G/4TLUku)黧pP%8eSi r%gW`Ǜ
o2^g0@\@ U8Y97 "ug,.hF>ٝz;
\yZZx{NHO59H|w ɯC1vIKS,sGyЫHus|m+B͂S>
4
384÷123 (-J<; zhh^:n6z.MLtVeӐӛkT.}h;˃`ql>VʀY5Tr>.:/d6f|MvCܨX+o)[=kŃ3HQqiq10G7;|. f-5ǒϿz a(Rhn1o+{MdVoh!yD;ۗk"A{Q[e܂ /Kc;'T.8w?{nz1z72t&>d'F JgeFp-"CW&]k&<{lԡ $V!^t sWBQk#x /Zr7j / wR0n*μ(L%pc&204Vd3 +-2?ppնX%) vB wuߕ!*)3`frDO;z\.xSԀeP3Ec.P+N륆 o_ZYMЙ=*>5XnZbj0wܼ E\Nga ~{Ly1aW>l Zjh$B-a T^
nxHJ8̙lE½eN9Ukؑieu7+mc'xT {6 1 rҪ;nJ(tb/!ʳVLc)j
ָgCtܨS{ ]m Ud'V" J^r7>_7j#}3`x&-ǯF?M-
4&ΕM`ȋװݸ2cp4\Е
=Fkq cb vE[Lདྷg 3{ŒwG=;~Nuŕ;M8zwY葭e>/06̙6ә@{zGi8cPq")}, LVSQ Jz(,[K;)+:1P^賮аƂQ# \UYZ} GqՁ-e=_Wu[kyK<2گc&%KK~`#LdƔ֙@xm7[mc4 K2ԾY^3}*8Pub
d`!ZD;SLCg nbip|^?xyqiM
]Fo2o ?ŒShu4hi z+1LMu_Pȼa,w\lRu H@Ig}BY!O\7+;bD=W?| ϥu}
\3v%fS9mvP,\lŧs sBbwùvkY̮''I:0m7Y.SS6TvFC2[/ kc6EC4*-& l` E2( Y5/vp_4DRA?ndԮs/FvOihӀ eXq?!lm#DX29Q)/+5 Cf#6A2` @ $ t .~cYcBK<$ CkL}$;Z A㝫\m8⋉ eWj}]EI
2Ƃ yM y)M3SH%_N*lV 59ޙ<7%Ah3 <$w`kP1v:-v~#b TR*6}f}>2q R09ƽlKK@vD7eF`cr*sd =9L 麀 !}K =7`i_ޣ+r+m/,GӉۑÖsIxБ˪J||0+-}[6vw*{ieFl-fwƺ\\Ġx
\?'D;tTgqaKf:S` v pu_yТlWs鷑54W1r ƦȤV$ALZ %Ur8~{hh/p>Kn[ " aGKYeթoԖ
,- d}?wc Y/XgIrndi#(y7/2!6,ے$%q)4LKS7'F*f%84 *m
3#1V0&^͐H%Eu^@_? :gd^u&Ͷ/h3z,/EJDǹ
x-ݚJѬǀսqW}t] %O®A ϶!4x4vPx
y 8mk*ݥ_1yכnq2epDOQf 4
I? +_V)4^U2)yx}ruyrC<>"}6dG`M
}Pnpfv]^?C &;t 7G3_Ng=ߝvb'~cdsLەʳo> \SYK;ԑ8 O#_J.7/hÝh:%3ZU.݁)G\q=ӖUcrl2y8T FyZcbXF쳢'?'YNaR%fx7cQ%[Oy/g%Ѡ쵶0ݿC-xݯ[^?@"4Tg wt3ɏlu
K18@b& 6Qk6~ 73@I! OA7D x~gKv%u$ &vsmygmh=MPB"\`)Jx瞄$q9_ )G+J0i
<=lzlhM"b{\m]]nw/"Ce%aSPsDY#45tt, 3
yot
o){^NܷX[7_성H:vx`3~-]n2CZv X5w/1Zs6
&fʝF\fvnw 4cV. m{` xg Vauy9 &{3e[p= [5W)p]Ip.N"chѸǩ2[V\wl 6kϜ(\\>& - uSv4iek0Dd%0')}f[ke|B"8f Jpm4mV+t77\4/+g>GbҘN!U+ɇF-:Q35ٍ8Jg1*2mt8c T %R 4rdqMQWGq>|\}:N;] `4g w|{s"W3Rʼi Y8U6W=o3kfܵZދH*7F,8;^vRm&VVO_h}ٗlE9p$G?b~`+3Y n'yKetQ*+t/N7Gvڬ<[Go'뎍&
{/ }og(j ĝX#/.FDx| Nã, i)1FKǺe 7QLb؊*K?MNǕ7 &NǩwZ~|^\Կ &W*x{^>mMhWWi .C~Ʈℑ?MF"(x0*?^lh~2}NG};H*Ҋ3H*ߜ#}&
oalWhN2abezma :'.G/ O$ ~gw r*'ʖkKNoպξ d_`{;$I p\'G/7J>t,>G<7ܰNSx91p.U/wWs;<ۉI]$.qJy:{ow:w!G]/J| 5 X]'ݑ_zE7uNwؠܭt|-Ϭ3z;+{E0iz%Or;O'ȅ~NDѶ-}.c)d|Nq3K?#sP0grrXZb !j=ikKiv +W,G~Ja?O.BjL5ҟz_Ow_^[Wyq}kuϸ7ϭN{/m3-GeYl ~cېM6=A
?ճW3}Q}^p)w'TWǮ' a:>r<Ũ֍}niF@!?#o
K_yi>fOU ;4-xU8`JPCC aR_K'/J {},
X S9nӒo:i`;+cyy oby
6:zA%I8i|7dzx.;N;d70<k;v : MVwŷ8ݓչ(jow
ڎPҹ6q=~g&L.7GFG L
._ccgi% g/-r( !ߛ+U q=/~la<ㇳƿLAl6a 4oMҾ/ R*p+K e(
7zYeL!I=\ 1\ ʝeg K ֡,p?Ca_PHv=}ú< O ܑn¿ P 2|ަ}o{?r+>G'&oR{63oAfOeCp ݣ wB.X ޔWzH{?gO9, U]jw`PlW{ W#Ҽ>T\|?pٝo/q*N]By߇h(>$3z* җlWe|v.?DgZw <{r~B+v4O2^z^^kgW CAuFRnz?svɗ77K}گN76'7{_a{?}n)3-doQ=_͏VT;C$.8vfv\.[ :'x6߬/
?It8)~gV 낗]{<.5=ҧS֩6}g -7Yݧ7>=??kv]Y{P~}?+u&d֟ 5̭o> f߯brw9[韁x 5?@$ $"I ?Џ
~ǵ >WCqiH֢ \'ީ>kUA~L{o|n/aϵ??#(Oi\oJ,ĘKaAh"m ,ޏ_o?1ysKqS;w 7s&o8{_^wGuW#^pz&G~]ooGT/uxz;7?
C/\=?|wS]럖\n^3|_(.iR /͊TΠ̪χyND/}?dV3= uanX._F??>;_
ws^oWoO#v=rut>WbJ?ZWz.<) Yُ7O~ kZo ޏ;=ng.[Gc t?a~/|e˝j k~/ j~WyA> @ :$U3 ŗ>W>g68 }f ]YݧxN7I[N }~Oȶ?{v1~{r{?TE@/Cus^e>| > t h܇0~W(:>g|=I"̟9*}@G~: ?rP_+H闁)XX|}r EY @(P??/
z~^s|_.~ov 7$y8 {8}O?7;ߕ|No?,3lz
}%O}|?,-N77SUw+e~a}пv
"eViMn[o1/t2?|Q_#l<c??{Կwy c~ozߋu/Z~__zf]fvʶR?_&mnv4LW ;~>z|~O~7g lP y#_ ._ OKXன|3 ;H $ 0Wx `۔Xo(t_?/owUcWp?aΌu~*.{_]_:<-c?>'eJ| ?x ~@ F~ߟ}ǂAc#rUݝ>>P{/w[YϞ//{vHi|7/>B>F1f]{#LM ('dO|zǥ7p|^/y?a*!?j0~)}v^ޕ }nJ7 wPWZwSok/x|*o2iotꯇ(S_^n}[>N/4 ƭ?Ӹ|og~?FW-Z`M>w D
W H B :V[kyvo ;<<|o{R|~gj>8 'x!h8]% 3PzHYQc fKMo 3&p}C9+@_uτC;^Uo_^όҫ=!T*ސ=m'² "@ Iꄓ'lp2gk'Qk[ + 6G_qG/Q ߍG]OKCwoŁM?ڢ }?/vm_T A H;S@$ $} ^2ɿeVTc/ℱc} 9gԀ \EEx>giOMJtr?E0@1.,Op b,6|6yڟ_a g $H H8X OLϣ/w;Pu7?8$"D !GK/?B}G~_y^{OoПv"@ "@ޙ?!u<8?0m醫^ H@ H@=9OםK _|?(֠~G Ģ*/'jv~?WTT?b/3A?}}_ ƻ;KoA^__ a5?Wb k:AD>?p|ϫ1E<~)XS_;O z'?+)Ν'|/00@.QPRTP D'?Cr ( b /" EUE~~}_W(#E~h"( B("}**H $ ~ q ;U? ?+ԯm .6IDTa 8 p$ Ol 9'ޔ}&V2)Ikq)2L!Ue(FXUu4JH AD]d#' GVQ&%!D +A$RvQbq's D BC !Q i'pxJR i hqwv941cr--0I|pƑ$`"D'fh`h`I܉J\aPVC)!C! @$h,҉ RJ"#yW&rVI)JJI$9#نg}_}g~XTJ1(+[& m2$]kRa ,9_\}_k mt
8qkU@"""$P @ TEHETYBFADaDPdEQG:9"""
idE @tX"-"," "B2 2"" "+""$
jW.1DTs e!$1H) R!IHRRD$E$Dd $I Id$@ AIBE B@.T*P*:*@I ` " #HH""* ȊHH ! $ " T
⨂ES "ȊH_D! D$)i D$RA$R@PP@ AC䬆7MN 2
(Ȭ) )"H2$ HȨ(,!$HI"+"H2(H- #HH(``>-dPB@ TdBEDQAPIYDT,H(X
X n/ g? 7F@$P$D$UD$T$RD$R@7ŭg ߽DH+ H*$ !" ""(H*Ȣ# ((bL^wgN * "
""$)
B@U]mPDoH! +"R"H,qKiǒ DA$EYDP
"
Y $$ O|~#+(h*9* _$AD D5(k5Tu+5~o~hjb( 6 P+|/W7?[?'; csD@d 9 R!}l Z 9_ @ +)
<}2 Q + #+ u ؠp"AmP33R8tq 9-L-#% Q '-?elEBȅx1}>6 P
M
n &dˇ b &h2 f3ٙ_@C0C033{3<~*(ffcED0 0\0M ڵsPLEE :@ H 8I{ճ &/ׯ^zׯ^t?|'|gUT@(;^}[=^J|S$P
b;],q@Em iH&NNG (".*"bad b . +yUW4-iAD~gb"+жD ooɾs: ~ 莎49Y HX-ceEQ ,Y:
B.Ck@ o/^<3);|뼧gDUP
oۯ_}or"ȼ'3Wkσ)d>n)JЭ/)+}.ҲVZ]JRՕA0"`IHHFDd$R@IHĐBF I$D{2ȡ"Z V!! BB2 Hi$$Ҳc dFBAd@ eg))J QPPHMMQP@@ЄHEH̀@̌DPo_J]9 o:G8u]6RJR$
Bh(
*j"" BDf M
đ FF E$dII BHb@HFI$dXHI $Y "0 FI$ BB@d$Y $IAI $H!BD$RAY$I+&ԅdj`Dh `"*HH`b
(DDRRMہSr=7۲)i)"*&jDJf*I}ֵRV]]ě᱒$I$ " $` RIIA$FH I#BBF" )Ȉ&$E3BA1S#%CD$30"""$"2$"3= ̌HQ PHHt$ 12"! ""P3D3"ЈPLLPA
ADĄ PU DTȌ
}o37
ooqt^ %u5 22$1#4R4K}u/.e_|e L.@@C3BdA @@ IH@@D t2%"B"43Cֵ]$](]IukZRo"&w
u)KuiKMHIUДĐHmM4M DD P HLt22B%## D Ĥ[*HHHK$kJHJ%&o5e5lJfJhDjfT/XV})u`a.KIph`*j*&k! ѐR+ukK+t!Jֳf P/ip i{$BFF*bF"B*$hD`f0+KK_}j (]@ҍkF_u )HnVmڊ(av!zSMZoKkZ!)*uԥBJRdFBVBVV!+)+JH_ZԒ]
RRTլ!}i*PխHDun[" (sN oC88^)uԺkJx" *)h CRR7)7_Iu닮JPV2\JJun.(Beh]R mڂ*@iX1 Dr##,:"!)h&jF` B""D&@@hFffF
@JHd":
)"*
&DF@ @$"DB2/YZPIJR_)I$iZRRnނ ;?NM6w)wUU'cU"#7`3sPR );D:#@+
""2#)D4JFGAGW`b4pWuWsC *2JRf9 8 2
#3
"FrXHg Ru$%6!RpgTК@ʲa#V)"M$b"$M "EF ) !dĂ(Ä.!Sarhdd8D ! ܌ T $*#G-!TVI,RFP0#g;0)j(ICPKFQHXآ@&T9(1IH d%#P),F$ i&C D ]̎
XF` "Q R!)9#(#C+"CC Ie#Ò´J" Ė $b b
l X٢LRHB#8cURb0 $B"DnfD"Es B ; J @ %"%%DT`8]XAZ:+ɢF"L!&y U$" iHMYJD(lHC93D K!RR2HHIdruxFF(D L&l*fpP"N2F DQUL*0''`Lji(FNn)C$1YA9403I\e%#a* )w[4tMaqA4 P bkN}
Y , =~ ^o߀ Hmmlm
mmmc$ 0u$HZl@ "@ H
% s~
n ")k D AI$XH$I$I$IbeAQ+DdYA"IEdYEd@肤$YEdVEdVEdVEdVEdVEdVEgQZdVAvEYdUVEYdVREI+͈%@ ƻ5O@[}F'>}q;
n.
ddd+z5LQA
J56߯5 ߎelfh hL>WzxI7 . } }[N# 8}y*cŝP% t'KAbZ3xxP ^ 28
C߅;xnEܫ
w\b^tn@ n
yLkؤhp $ $
$d0` 0` sx !'v x-kh#iˏ*(XFf3 <_frɾ &:D7]\&{[OG+_M{w DL3GxTCyGxt7x|~#teClm:G>>*s v||nK8uMIӣEK e[%mv] / Grnv< Q1Z_{#u-1P -lCQqp 0S 012A # vd Hj3)ߝ^c4hѢD HN ;'d5
2^ev9}zwu {=VUC8NoO^Vh . ] /G!DQ5 @:izn#w|j*p.w'w2Tw^`No MTN^8:8=;\)kg3?m Jv]kZp
/I
4GM k=^kb(vfedJ"d#dY.gD4T
pd3iU% !.>.#DQ p y^K}wB+8@@4:- c +!4ٳf͛4hѣF[-:Px؏r X1:ӳf*h#.Ynw<ۄϫ= fH tCR*g"@D5 AXvgNj Hպނ`*
`8a:NSj$v^}%U##.3E 3\<e-2 @rW!Lqs3 8L=y*!@1\EH:A,t
M*ah%[::ڙ35@HD$u 7:/hH $5ZZXZZZZZZZZZY ʾ bO=?}a
J.(8y}>@B#!mdz|/ jE J pppײn2 r1z= GR 7~%l7sq\@11c GA 05삖X8۔K69 DoV _Ǐ 3ļ y^ $r 7vN-%\]eڲdq/[0 2LLr?$.6UQ66 D |"s@sS2y ʥśs98]3qKk7~`bkuiay~^* ㉉_`Fbjۉ~:*E."g瀣^cxxS/)S0/4:| *[}-^xE4 R|\\L6uP0\ *y""`8 ʘ")Sֲal-!c` vfu2"
?1AY&SY8.F^ H @z ͡ hg ˼cj^vl ,vCE(UN) t4%V`RډJZ4J ]uїG'U5HM @UjJ%K56BH$uB $.ܩh44U"Sـ 飪!lh]DBCAf*AI A@(4 E-5 "@@@ KJ4
2+JRu)Z
04nU86ƁG@5lha4@
RkdRJ kEJA5 M
H@mCEPHE J.vmhPR65@ġFf2hkK`b5=ݙ
C%4ց@+#M$mXMh 02цV*()6f
kA-5k)ŭiB
h Z Jj̓hZX@ :u*WbT-VIR4EP*[jfE!j'HWMfjPQPM)TRT5U(I44)H62
MuD*t0T s"D@ %J*j)J B+Y Е 4@PL)(( R $
]; @ʀ ht4 鮔(
r 4h FA
N @ R@ P
@ I T!D*T$I"DU
* *E
( @
*~0M0C@ h
h d4&4iM04)``*U?24 @M4 & A24d 4 @&E6t".rjSe 9v)GN
`Qe@Ȝ-M]ӿ V$Ȯ,b Q5צS%h銐AU@O:[7}3֣̬ o0 ((eRchܪضea_;,ۇ@.0Z6 ċH*$oc%h ̔2h ISN R-* .bj\F ]f.k$k3dTMi<ZFqtZ
r{<- #3DT $Ƹ 5Ʋ|( +';Ո [- /
:SXpR(O1kOK&鑸Z$@0QA=58T@{OKD/POD|@SrW29T7% ]Q0!VF BU6IX,2 Sv
|RH=$O7 s'!
yX*G8(cly΅Sk[sM77稓hh\&1yZ sｓ OD qCk:I]gc
I qLߙE Yk҃ Մ-d}0mdCQ0Vu[!H$6Ubwo0D%IrNڦWyܢX P JS5nUi(SJL%rZ@C3Y`<(aKԛ+$v\Ԑ2Uy=
c1֞mS薚ԙa}+ >
/z Xƌ QH [
- 6*R蓄PBUB
-͂ ,H; I+U0$`{9%ZCqݶbڌ (XcaX9]qS=Jȁ60GQ 옅ηZMVTV@!ͽ}vO뭁/ +as}Kyy;s#ç] IeԬml3ǩ''6r t @q ܣxHLd KJ@vGBT
PXVZo0G˯C|m%$3iS ]xbDL R"Gq`1#GTFc M2c м }f}gV2,u0f?fMX:
ݩMZmgpD-F|M@0E>-m9d a(03(S v) Va8G[^0$B:nwP5!=ٳ-D6F&;Џyk!ٞ _,b`G:,IlhPoF0 lk"r$"v) ""݈NMM /`Ӟmm()d +<} ^fJG݉oTvaGb62w乽Myۂ| >q J~G.)9|v}RiPL) fv{+@5uQ]
L`6l-pު[(b%{8dnD2Zm ]y{K @GW:ͼ|w=2t܆Y=¾of4p i KӒ 껠,1^6,aSb}bBR9Yv>c u*.w/mD'jlj8,A3
Xip^}J9ݯ][ <-ǎռr\^I'8]i;;K6e0q+;#sӿg{=p \(9c4ۍeq^rD`GÙƂܽx@Xz;?`>LF=3w!GYgNV!(&
wb0<--Fv'm*2
fDz2Xu%<͇Ӳ-GDuWtn#:8ʾ/<%m2VI c3%jAUc
* *kr 04.X{\?cWb"<^.k!r\z$ro*dѫbvbW8b
'C 'mvѧNS^]${lQz~M:9bظ[˾G>ڷ[gl_)1W=kA<_ EC8+ŏ|[oSp
m>nu:qۮ3ĢgNb ԉ]GH .%X}95
!@ qa
ߢJ%h u&iD > й-%$3S1"б}:fe; =5ah#TFe
Bޅ-MDn('( D>M>0SA1&k),J> m|gIΔ42Z;r!r|0unչ'76[2v~U h[,Ѭ h1 = l,fegCf F/YW~G+-Z`[ WTV&H/tO[~',rGnޣ!+ࣲ:|ҪMWFl^sTt|
P0}h
nWCKdF&db(o5~{spϝツ;>ADva
v C;LZa$%"P̻-rX2Vf7wcWg~{:ٞh0#aѨy3~qO~<}t=`l2u-j:ۺq``ËaKo7͛$fH ?1Azj(
bLu>kBMAtGSgA ڶTF=SnBCN7|YjL}%z0lod}qWGJs fL@:]s.MXz([7[)nֻeƺjU.W"ap_5)&={c|x/Y,s (ϱ,3N0Ŭ7 [9թA[8BkIaFԒA%H
ҪVFe kϝԠ X!fM^>5s?n$.n5v
^ WN="yΕ8bUHB-Rzgmvָܝ|CM-6Tk_ܠ
0s. xR3i˯$nɝӜok֯ Mծ:]sGDxۆkmd~e"ǣǃYk>uj\r%,;R me~ uACߞ Y[xe
vo7"ȆclO .9윉>9^z_o> ^FsY'A
)("JzGJ%YgW+P;#gQA>N=rͳ^tEK0.1 X~*[9ű-s+: ckl]BFpў%l/*uS+}'o*lTÊ #9>>c'Ѧ{ _Msؼ8_CAQ0"&Dh yFs
[9:{8>2m ,\N) ԍޯd* U_ #T o+=uZPj#Wl T %aDLAR@u;4U$/lVf/ 5$x@a 2 7H~擨;[ʨ0}sJTJ M{3+9^x\Wj3/0#sk̀V꘎GYW"^j #kutVਡkX | ZMt W폿GvNK gfgy73u[\&MRxo=XmJgJCv
AȢ71 dYR϶CeA} (E veR Gٙ1!jtܕ.V \#`s_Z3\-}~7wO a&M Jᄥ'GC7ڡɈ~e04s`Rñp oDD$^9Y \~\, :
2XԬ j9K
qG8~L,4{y A`ː^;8m:ص"Ex2s&BX:I(I
3w&֪9F2A#P {or[؉L
~#} WGZbݐn!LfS*1`$u/rJ_>q=/7z ͷ%m_ u˜ |m.dn'\ϝۂ~l\G-)],ZJBYpv?YK?Sɯ1Ǧy>2 &jR;NM u>{wߍnwƶMc)T~>hCVI|3<)q>|T/ʍ)u c?C$&Ӵ E8&UÜ|RűqOX0r@\T!PoO7qwbI2B2:F`[Uwc A`"G)2 6TvB =|`y7e J8` V0>f>e9F"5m}o_D$|,M=|{f rBu99>AlXk?ɈqT| $ki eQܹCgf4\P=B2y\o1U;\kB1rN 0d^Si{M묚cpHGVb#Ed
Eqۑq"[BU-HKN삞3swhㄦ~J}Z1W+ %{UqˈGGyYo->d}+LS}}H;}tݱBuqv:_ȈLF!גarthbe6Rdߜي LL4t'%^jTe)BRя081`G9N6%rH r7>V8 Ik S۹ @+t,RLlYryR;:(4QTPLZ
cRZ\D ̀BY`A4z]v
R0A4̣l&kPy !{lNT v^ߗZuK|g7FA-C
\' Q>b}",X#kg F/iڴwap8 -q6C?i,'9C}GsKb {C8h+O3|b rݵٴ%@)E =))8wu ->ɇ;"5/r}>!u K_d>b_ͥ_
vv&u՝Tێ= $$N}Sگ mlB#@.
Y2Bc[4"D}Zp-Ƣԗ]m`1i<@5CVB;Ry~(еpc\ xic-KzuehLg5*9LK sT
Ӛf{B\+M $@g/0j
j7ރ2`dX_Y A yI(
EY Yh"g4K\DJaH &bJ hC.0 aAG qFAseuȑGbE῝7vBAm?4%=L\K11#ts7paʣjj;q lݹihRGx:G6ع{g8]m{+}s M2zqU[]_',X5ޮ+sN|??/Glz oh[9
"re{bw\+ /&OAV'ǩT ?3ADn*]+"ە(i]\ץşaH)EQ~X1JS,љ乶]Z"wab^ h:ut R^+Fj0!%5m״{cxDrx8AHFl@2Cۊ
TV[X >P0fA0
'8=Rq;TTRzθE:!G -tu;_?S~d*ӿCEVKS[³s
4*ڵw+Ez: ^rb _ 5]c<1zxÈƜևӏ x
kq,229(;b+jr#v3(WЎ*uyaA)e5 2Tp
7C tlaLh"wjuтsXbA'ل.kO'y UR0` `
ɒ-ՏNI{)g5 A&"f?6J0֑ @mg]
Kcd~\),AT˫/]@
hg>< џqAq`
6^¢GOx$ 4X7 q
Ir6#ANb-%Z jh3I|r
~#; W}xT#Eu˕Β0g 1 cf`!
عmjӡ}"4DAW],% ;F%az'g[%^FmpE疷T2yN˾@v @q ln'y4h1ѻ'Ҧ !eNto9
O<2ѹ>ӺpS`Þ$ r-CL9h%:
pű+/ArulڝraJ8c ɖ4ԟ.Wik{Gq~ Jq9ɪ y𖤁H!Y% 6T"'A'a\9N V
f ͷn-y̔ #H`r$?MIEćU? m9 ٻ#YP|7\xjx`r;wf瑪wR<[O6̆s~K$ dJ r@ V1N s=nd}aRe>[9?GEP_ZĒ 4j(at 8\ ĘE]*g%RiY|^`vjv
`heQ͋ 2#a/v<-b$CM\(LF!˂
P1 mO.\ QϢP0<| >+t+H
0hVJY: @7*P2ۮ9֯ ;_7*Y%hq9&1v}D
b3٫lJ>.fY&6^ӣZlW
tlKP=-+bG}<~|b
.QkƗjJ,ÞP6J@n?K;s7^⨝ N-4rCPS]ZN-9S\]ڛ"yia mAc>¨>xa
Q M2dxoeܺB7T̟u]B,G[o r:rg"`C\7RBz{t$tX =`@QRRD3 b8_GY (bZrGp3$ȬdbqQ%'.]!M L
J,@0]Mrsx{.1 Fh#,e
1H̙ۅ)G@B27Xx"pf$& g<
Yt\\oBÃZ(>ibl;Xўd4'2Hj, S7?zh \7;юJVV$I[+;ѿRPg!3 hɄnHrgjϊ2LW= vJiJςI;bt^lqQ1nxڢp*, >A p@j(s;"iX]e0v4G:aX֬\F*m3nR֢r{HY )r!*[ /J*U6vۢ-(%PVحqPDbyTC\UoQiğ,ZGA"nV
uHVH% ` e̙:#BfBH7V gf鍘\E\P.Bf *m4;LU
O^'De7H-%lNd* @Q\ NHUh+92 L 𩽖y _Bs,݃8@A H>vP)cFc(^rh6ԜoCExwazvݼ\ (nJ
ؐo V?d~ncM=tjp+ W0wxXX&DA3CUYn$Dx2hGfF, aa,zԞ6A :=0Kl Pə)l,UM&b&yOuZ {MZeGKF |=L_bZ,u_@R?,:uK6§x"+ k! j9 s- k2 N:b\/u+;qopgD* z-×yQw6k^VLSR(H|Ρr' 4K6-[I"I賱"3'=( m6XYLt"ITJV&mXhNk|N^3 !Q,/(ǩT1
`?.Vc<ܻ
rxz8wZ@JǚFR`d
ȴ " 2
`'ԙN]6U5F`(SR*hTٰIвQK 4]cݟ>ܿw5(d8P#0Ht$טϊ4N6e}cyS 4.np,&Lՙ
Xo4sFu'r$5oW;)$^w4I-`f"",Ȃ(y8U.c4nrqM^QCUlqDXAځ|,S[MLQ&QKO aƜ[ɋ{̄ro0MrR>h>zf* sX0wfYHPMT PP$֍6{Qpc;` `-9*oRxq 2S0= UTf̈́sQ9!r|A̦Lq)#lcOGA^VM/dzHbĊQH7M<<ؕi(elLMqee , $cP t`Ǐ@2ʬ
Iknj
@ wEZ- |b('V>Bgv..%=K f2 &'\bYr-pg?qϯ <\Ja~tbʋ+0ӏI1wcQ}2pxCV,&BcFl #g^[:/^^']T;2Ep.<✰d5d.\[%)㫋&Oar0 /?ļ:5 n(^7M⭈d҇݉DHN;L@xlDzUm "Yq 5z%ECҎ3
9h)4T ga*6&BsCyвc*p)ᒬl}/p` LzGbOAdh86Vu,oNvp9\v8` AAc\oKV5/33Da/a,Et!_)ehRq|AAu3ϩ!"7
'Oay.+26 )c
\@J'qC12~OFFW*iaj a|W(!;-[K
tW|& BYHRM 8&([ъ],xmBs4>4 xbʅ
̳5 lumMAUNBzPd <"y.ScwFϝꈰN[`^l U9r$>k5U$-P&&'8yZBMG ^ #؋hW.k& > ZDrbݺ dm {maU bƃ KW w=ud?>ӓUhf<%`_b,Ye^PXAyNF*Blf
2p"]"%.{!oŗH1 @ŃO#o1s>8%{.2U,њ@ XvbN[,Ћ:B $G;_tN
N.Y/Y_]N_iM4мħ).{CK`E} 4"*|R.FlNzM骗,w >a4HY?[Z
N@;qq W6#q@rI!W:mxHn hIt YѴUՊwb.$&ɏudWt 5_SO(BZ10M w6Q$hbA7?ިڭ-_
O.1JShb0\9+s
_ӊnkAHJS0NXN4@:w@X YA8| ˟mtirm}Vy%%mi=v%6k^]$ñ$6*c+5srDVʭX:LQe;dstOA/ 4*@9dY Ȓ&!X/TH%EjՉ[&/(*1$"}XL0[`8}.g:-v@c%+ pص9hM*E(,NmǭiX(YnO;7=Ĩݍrq70lA
T_x PE)BԵ
.30,Y
\o\{-V!!Ö;眆5`$Cxf IgP< Ėp;%wqd{5k*Lh)١1g\I6AcQ
Weg!5lg [s1!T] 8hv]P$8Ь؛9egSSkbf̦]\h K:wEu]8.$4[].4(WDE;mA`A Pӿ }|b {[6 h
Hd@j/Ӕtt݅3)LCgp&lp1ՇwdN6džpW7w#NEOU(p ^i>b/uz,%e xSp?5 |Ź` a 7iT%I5H,0Z#
/Xk٢#GG{ģg+PӭzQVx @P/#Vҹaut Zt fD 5HG8g?n>ࡇDS<@qQfxk$2@n¤}$1evżb%L^X&>qO5X<[v-"zZ T7yv`j-n2LRnci9 t HKL@z䎅ƓE +*f
(üal[wʦe*ez). S'yZh@]SI=q4эd`
7 `!(_! s)`| sn}p:&)T\"rKP6]64JՉ
F4ɷSy#`.O@ca;tHl蠕GuNhMxu,6_TMRċ\>82HaVfN JI
7NW2^_wڐ>\p
v#sǑuetme %q
Z-͆V1_a mZ+b 1^W
* ex;W K' jX[Y˵~[ƻ|ꆻ{ndzAiIn=w' r:4'G-?DTp^Mܞwy'49]_fږyMsF'KיGN^_:a"쁈(izeAWfըndyv'ZTc
ݼ[q,/v]b7h80}ohH#; P8 Ƙ_[ } >O~"ljRj IwJ'][¾U _ ̲nu2ku ` q<5 %ϱ%(#ia Roʍʹ$.iLxdB53Lk 6cI < kװD}6|"E-`=)ۿzfAsBl: !qk3. kA!&"g2 q
B ^b6<(#lJ/j;Ko I6-fN.qXkҺ m F<;hp Iw0̑Uvv0xa{
BGd|آ RѬ!4*$ZRQ@+ܚ,#]]^Y! f0EW: (m " &ewbQ=V{O`cziq99rCDהJJѱ *EL9tR5s9l,
j旁) EHړ=o#y̠υ"C,ccgUi]Dv :YZL0
BE5[TT^%dRN!.|hlqrT01g\WDJc#[vITл 0 {ZyEcCXEq=(0 s"2cv 2(Icԋ95'[Ë/~N`Ċ=Bou!IXl$ þ(+ l\h[Y`=WF?Dyp5L 1h Z
FJDbBhp`f
E
K/85.@|Ew-@^>FZabLsuՇN5%QY<
!rd,.;?? :8OMc$+#Sڡlǹ* SJ;{߷,*>fbQXcR asl|lH" kD%|#@>pW,dk=® ,8Q^y^hL2,a EB<_T圆&,(g1Ӯ ,/4\P xs8& -ORj<
ʏ_
PBϳZ(Vs fȊI{ʂz@ s ҉= ~fNc煭un/0d䷚ YP *_C8 ־ W}Ig/ Q /YYKEY<=>W
Gl Ԕs/1M5f9 %^x#1 T #_S+EL[ai48X!BI?F"f34#t
hPX0{AۛvRNf
.Mpub{q/F F(!7 }W;Dmz"H[%kP昖P 1
ޒ@(_Ψd/j%sY*龼ԡD2埉)hW5Dg'%ÿjYC g NNȯ5 ~nۜ1*A{P5M=cH[] 6AJ-~H@F6x6K
[܄>l\=uaa|P@NtW
dhJyp!do}I, Z7'LOʯ3DY@pؒ`fBr{(frlpM0'|zc=^$G
fN`HudMפ`ȧ6 e${L
FT-ǂf
8=BL:^8S$+'dQ\h&v1!Kˋ3E&t,8gN+\nWZE^J#Ƶ$ޛ-Xςa$$Pqc@漻۴*ٽAv. Y"Y8mo]7[p\-ʝ9E@*` ! Fl BqxhW:JYGQFqXOE{r|7I'%ʞ.W -*}OyMTW AX#bYD;*JW@
u.(b4+05i#Yc}FX*p# OdQ6EPyym6]L`}ǻG+ARD}D|̷p`ً: g<6ս*!h1]D#$1
.K y~n1AX9c*a,\e pF`
(x6ᤩ]oLeHdj\3Q͠FBiV
'tЀ@ۥ"P+W:nfQ)7otBҲ5m۬OMrSȁ,py&pT ]9VyQZ\ssI1 a M0Sg9-,tրq-blV- 9{ u\(E^c&/Tek :sj_|^:ÙyN|P,`ÌIs/.D
혤~ɑ$%D#jft&(] m
NZ}oaL2M%n,
6
YjH b)~x!n4PI7\3 A?8t` . gMv)jA!` ,#pZ6p2VpxI#-լ>Uc53D{@~ĩ.:LΚp`ه6Gcc= ř,N5IN%,].v! 90`sl?9A+nHE&FQ
tKk!~JLY d۟yYJ'=Y2.I48e4rܴCI}H$\Gp>W6f0pd52WYtf9km Bڕ6!D B!9Rx=pȄT\ +>h7wMN:[H:+J9i#/*3YԉCJLYiu V}mAdUYK5ipxYsFH?Ǘ3!zM$'5&գL'>
d 5V@ rF*h2T
##).&="Y61lEfR2h pG痏\ӌafP}ªL2:PZE7)!854rC3&VO'+7v'*!ҫ:91^dL@@RQ2ϥ%|hSȩ-eZn* 1x/)w-GxC+%B`P] 6& * ځ t( m y6}m:% :R!\bȄ_:כ'֏8h3 H%iM>`s~O) 9?F;%,Z28Ef %|A<
z砚X w^̙-1c}5Q>#I$h,R=KX#( ~[ bD D1IDdejɤL
&ԝ!F/~`VN,0B'AؓhC &Q
+C=-?f[e:C+uKA " @juwDFo:Pe&w&g&x7Vh "{ D=dbMjGA%2([!iwW$ 3r0D0镇~VϏŴ8
&
pNq݀ S(&Nӳ1S[05L|E5q<[ݰ:O5L !@)H8\ ;=^?YUwL 65~
fj QS+5GCb>!ZkU-N7%!`2&Z
t8d>5\Q( ņ@A.
k$ģd@H$neV) >(U=ީa:PX;-yϋ026qab7hVAZEOF CdӇ @51!7OvL֙ ƃԂL ILrK8D9vfh%bj!ş&
b_muÿvu5h.^c%*\6ZWNsLBٔ}(aFw5}F{9
W{cNfIS:g4mUi1dj͊c''Rq
O=&'ʸOl8N 2y eUZpG5KOqkT/QeZԴk`GGM) QYP#Hߓ>|,"ԎePA 7Zm`:w[_69n^'l`5D}Dmh]
_,`wIpF@54z(N[
^b2߭#+~L0"IDNy
cb|;mV32^Ϲ""5W+Ĥ7)cuxs*&RCQ#zľ B^{+ U
)m1h'ڐM=C1OKBP#x3 抙JM KPHi#ӺjTjC !YyK ] 3= s l`sgP·{`ʐ\.Z1%Ő
wgK.I(k.I {f4 }ݡAvnSŖ=-]l)JnbM`elRߚWu
ݯY0pg LIC+e[};ɻ@m@l35|дc e:msVE,|g,"\ډ 3]f8Yb. |ф )Z` ͻACRXaM\@3ξFu[뎍f96#og }m5@9kH%U p #]M91mp"'l8k3F:h\ 6'gA hrѝ [f'38&z-5 9vDS G 2B&VT+F{Y USfH ÕE$S/{|=29f %'# 2(4? uY_GC6m 7
4Co~
77;4B V8}P!v?n9ah0)ݔRw#& IΛÑSs@6drX9>K04ɯ1p4<)cV4ia
90GژM|Ӗ ı1T Hgs&Ce±Wq _FH{ mUP< ګM%$ج G=Jb-S(4C Y'A~r
~4T\ɎyjT%H0[4vP Oh 2z,msw>/kN8kƀbUSEq>l 9"ѯ|>h$HΎ= 8P,c &]v~pQs5ZNhlZC'!?2cR³$TI0ZMfv+ڼ:|Sj Qe !) ( %ӺNsv< n){a4-slɓZ 46!mrSP.T YL 4u. n!VCǬ5
\Bh"/s>?8': ZF귩l TDHLQhلҪЌ%XܻQ#l(jVWѵ92ƚՋD=U=oQuz PbTD)A U{jzCQ{X;\-'Blk
ӻ>#'b7#ߑ@"})j9SdŮG+P'Yq5gDVĮZ`Dǀ:'_P-Nw09 S0p& d|OksծvC薔V@'b
\(akFY,q-P^
u|<ï[AWSf&
zQ /!Gaw
ak&"NR7+I0vR9dYF<;LA DahQp&)fJX !١~t) ¼6nH)jAT>d]b- bN~3`8M8( JCcn
3x`VX]P":/_Q /jTyF(ʺABaC ;FPY!($e#%
CLXøꈁUpZi
GvpQad =6$h'h':;ꩣJ t`9V#kӒ(ʎ` n$S0LiK=)PL+]/ aKc #iGKd1CLP$ 0TFcX-Dv\wl@D8qv9k}ɉ?.,%]k.껞 ?6 C#P} ZI_$c̔{@Zrf̪hw`z:-J
y oUAsiN" K"<'Mx1Z.+3EYG*) l% y} 1a١cW/KX+ _H4i)ƛxs ҺitÝd1Ԋ ;e"" ϊ77+*D8(KT|߹{ٵs%n!h]8h Jqaĵl*SG;
=ㆈ+ƨZ ړ㖚u(
HUo&ȶ72`蛫Bw\"J=א_#6
5$+a,K?trCg&ұ i5, Xo; % 0u9BC]F?&UԟW^)3)a j*PcC *6a X\cu{[\TxZٛv3P@*rcs s/y#Nĭ| dQǾ}+
%ܔDnM;+oÂIyA莀pFvn!y/= vz4)߆b 1a UEܝ*' y!2:Xh0 i
D w'7~2>*"dk57}_vJ*5%{os;5$i|ë́'ae- f9_ Zcu" lAqpt_(DxA$}3 w>\[ 8 "ԨedUJbzxNpjd?PJAYLE5i$ hun1tEkK A$3ݸE\aj-|rf]ɐފ4 -$M ksaX f 1C ĪD˺7U8-f.ؕSi=,G{C % ñ+iPƽ+jA}¼]}`#0EPqz<h7 +\dG )f C$ `hd9 Sf(` U$f(sͦpzg+T+}R M$1I~LXتH?&Ԛ2eHI XE;.bMSIaFM|2ڹ=
CC9YMʤ -w1E =vFI L!
2/労Ƣ[/L"Q|hSClGLܔjDXE:kN`m4Vl(<% 8gc-h@i0?nˊl5jݶ17qNgpPo0xVg`!)] \pJ"~kӔAGQȿo&O>g8