Luminescence/0000755000176200001440000000000013125301541012657 5ustar liggesusersLuminescence/inst/0000755000176200001440000000000013125226556013650 5ustar liggesusersLuminescence/inst/CITATION0000644000176200001440000000435313041732307015003 0ustar liggesuserscitHeader("To cite the package 'Luminescence' in publications use:") citation(auto = meta) bibentry(bibtype = "Article", title = "A practical guide to the R package Luminescence", author = "Michael Dietze, Sebastian Kreutzer, Margret C. Fuchs, Christoph Burow, Manfred Fischer, Christoph Schmidt", year = "2013", journal = "Ancient TL", volume = "31", pages = "11-18") bibentry(bibtype = "Article", title = "Introducing an R package for luminescence dating analysis", author = "Sebastian Kreutzer, Christoph Schmidt, Margret C. Fuchs, Michael Dietze, Manfred Fischer, Markus Fuchs", year = "2012", journal = "Ancient TL", volume = "30", pages = "1-8") bibentry(bibtype = "Article", title = "Data processing in luminescence dating analysis: An exemplary workflow using the R package 'Luminescence'", author = "Margret C. Fuchs, Sebastian Kreutzer, Christoph Burow, Michael Dietze, Manfred Fischer, Christoph Schmidt, Markus Fuchs", year = "2015", journal = "Quaternary International", volume = "362", pages = "8-13", doi = "10.1016/j.quaint.2014.06.034") bibentry(bibtype = "Article", title = "A new R function for the Internal External Uncertainty (IEU) model", author = "Smedley, Rachel K", journal = "Ancient TL", year = "2015", volume = "33", number = "1", pages = "16-21") bibentry(bibtype = "Article", title = "The abanico plot: visualising chronometric data with individual standard errors", author = "Michael Dietze, Sebastian Kreutzer, Christoph Burow, Margret C. Fuchs, Manfred Fischer, Christoph Schmidt", year = "2016", journal = "Quaternary Geochronology", volume = "31", pages = "12-18", doi = "10.1016/j.quageo.2015.09.003") bibentry(bibtype = "Article", title = "Bayesian statistics in luminescence dating: The baSAR-model and its implementation in the R package 'Luminescence'", author = "Mercier, Norbert and Kreutzer, Sebastian and Christophe, Claire and Gu{\'e}rin, Guillaume and Guibert, P and Lahaye, Christelle and Lanos, Philippe and Philippe, Anne and Tribolo, Chantal", year = "2016", journal = "Ancient TL", volume = "34", pages = "14-21") Luminescence/inst/NEWS.Rd0000644000176200001440000004362113125226556014721 0ustar liggesusers\name{NEWS} \title{NEWS for the R Package Luminescence} \section{Changes in version 0.7.5 (30th June, 2017)}{ \subsection{Bugfixes and changes}{ \itemize{ \item \code{analyse_SAR.CWOSL()} \itemize{ \item If the signal integral was wrong, the default value was not set correctly (#46). } \item \code{calc_AverageDose()} \itemize{ \item Update documentation and add produced output, \item unify data.frame return output arguments (all capital letters). } \item \code{calc_FastRatio()} \itemize{ \item Update slot names, which led to an output error. } \item \code{extract_IrradiationTimes()} \itemize{ \item The exported BINX-file now works with the Analyst and the g-value can be calculated therein (thanks to Geoff Duller). } \item \code{plot_FilterCombinations()} \itemize{ \item Calculate optical density and return it, \item fix calclation of transmission window, \item improve plot output. } \item \code{plot_RadialPlot()} \itemize{ \item Fix error which occasionally occurred if a list of \code{data.frame}s are provided (thanks to Christina Neudorf for spotting the bug). } \item \code{read_BIN2R()} \itemize{ \item Improve error messages for corrupted BIN/BINX-files, \item ensure that the file connection is closed sufficiently. } \item \code{RisoeBINfileData2RLum.Analysis()} \itemize{ \item The grain selection was not accepted and caused a constant error (#45). } \item \code{use_DRAC()} \itemize{ \item The DRAC URL had changed; fixed. } } } \subsection{Miscellaneous}{ \itemize{ \item Fix package welcome message. } } } \section{Changes in version 0.7.4 (31st March, 2017)}{ \subsection{Changes in S4-classes and methods}{ \itemize{ \item \code{get_RLum} for \code{RLum.Analysis}-objects now returns an error and \code{NULL} if the \code{record.id} is not valid. } } \subsection{Bugfixes and changes}{ \itemize{ \item \code{analyse_baSAR()}{ \itemize{ \item The option to force the dose response curve trough the origin was not correctly implemented; fixed. } } \item \code{analyse_FadingMeasurement()}{ \itemize{ \item The function returned unreliable results since the time since irradiation had been doubled. This bug only affected Lx/Tx data imported from an XSYG-file. } } \item \code{analyse_SAR.TL()}{ \itemize{ \item A test code snippet made it into the final package. With this the Lx/Tx error was taken as fixed value (10/100) from the Lx/Tx value itself. The calculated error was not considered; corrected, \item function returns \code{NA} for the error if the background signals are similar and the error would become 0, \item new argument \code{integral_input} added to allow for an integral definition based on temperatures and not channels. } } \item \code{calc_TLLxTxRatio()}{ \itemize{ \item Arguments \code{Lx.data.background} and \code{Tx.data.background} are now pre-set to \code{NULL}, i.e. the function does not longer check for missing entries. } } \item \code{plot_KDE()}{ \itemize{ \item Further support for layout options as requested by Christopher Luethgens. } } \item \code{plot_GrowthCurve)}{ \itemize{ \item Rename argument options for argument \code{mode} to \code{'interpolation'} and \code{'extrapolation'} instead of \code{'regenerative'} and \code{'additive'}. \item fix a rather rare bug using the combination \code{fit.force_through_origin = FALSE} and \code{mode = "extrapolation"}, \item the graphical representation for \code{mode = "extrapolation"} was not correct (#38). } } \item \code{plot_RLum.Data.Spectrum)}{ \itemize{ \item Fixwrong axtick labels for interactive plot option (#39), \item correct manual. } } \item \code{plot_RLum.Analysis)}{ \itemize{ \item Add support for the argument 'type' of the argument 'combine = TRUE' is used. } } \item \code{read_BIN2R()}{ \itemize{ \item Correct minor bug while importing corrupt BIN-files, \item add support for internet connections, \item if a directory was provided the functions was trapped in an endless loop (#36) } } \item \code{write_R2BIN()}{ \itemize{ \item Argument 'BL_UNIT' was not correctly exported; fixed, \item export behaviour for BIN-file version 08 improved. } } } } \subsection{Miscellaneous}{ \itemize{ \item BIN-file example data sets can now be exported without error to BIN-files using \code{write_R2BIN()}. } } } \section{Changes in version 0.7.3 (8th Feburary, 2017)}{ \subsection{Bugfixes and changes}{ \itemize{ \item \code{Risoe.BINfileData()}{ \itemize{ \item Correct for mistakes in the manual. } } \item \code{write_R2BIN()}{ \itemize{ \item Correct for broken function (introduced with v0.7.0). } } } } \subsection{Miscellaneous}{ \itemize{ \item Correct wrong package date format. \item Add NEWS again to the package. } } } \section{Changes in version 0.7.2 (7th February (evening), 2017)}{ \itemize{ \item The CRAN check on the Solaris machines gave an error while performing the (on all other platform sucessful) unit tests. Consequently, and to reduce the load for the CRAN resources all tests are skipped on CRAN. \item This version never made it on CRAN! } } \section{Changes in version 0.7.1 (6th February (evening), 2017)}{ \itemize{ \item This release accounts for the CRAN check errors on the Solaris machines by preventing the unfortunate overload of the C++ function pow() with integer values. } } \section{Changes in version 0.7.0 (6th February (morning), 2017)}{ \subsection{New functions}{ \itemize{ \item \code{analyse_FadingMeasurement()}: Analyse fading measurements to calculate g-values and to estimate the density of recombination centres. \item \code{analyse_portableOSL()}: The function analyses CW-OSL curve data produced by a SUERC portable OSL reader and produces a combined plot of OSL/IRSL signal intensities, OSL/IRSL depletion ratios and the IRSL/OSL ratio. \item \code{calc_Kars2008()}: A function to calculate the expected sample specific fraction of saturation following Kars et al. (2008) and Huntley (2006). \item \code{calc_AverageDose()}: Function to calculate the average dose and their extrinsic dispersion. \item \code{convert_BIN2R()}: wrapper function around the functions \code{read_BIN2R()} and \code{write_RLum2CSV()} to convert a BIN-file to CSV-files; so far possible. \item \code{convert_Daybreak2R()}: wrapper function around the functions \code{read_Daybreak2R()} and \code{write_RLum2CSV()} to convert Daybreak measurement data (TXT-file, DATE-file) to CSV-files; so far possible. \item \code{convert_PSL2R()}: wrapper function around the functions \code{read_PSL2R()} and \code{write_RLum2CSV()} to convert a PSL-file (SUERC portable OSL reader file format) to CSV-files; so far possible. \item \code{convert_XSYG2R()}: wrapper function around the functions \code{read_XSYG2R()} and \code{write_RLum2CSV()} to convert XSYG-file to CSV-files; so far possible. \item \code{github_branches(), github_commits(), github_issues()}: R Interface to the GitHub API v3. These functions can be used to query a specific repository hosted on GitHub. \item \code{install_DevelopmentVersion()}: This function is a convenient method for installing the development version of the R package 'Luminescence' directly from GitHub. \item \code{PSL2Risoe.BINfileData()}: Converts an \code{RLum.Analysis} object produced by the function \code{read_PSL2R()} to an \code{Risoe.BINfileData} object. \item \code{read_PSL2R()}: Imports PSL files produced by a SUERC portable OSL reader into R. \item \code{smooth_RLum()}: wrapper function to call the corresponding methods to smooth data based on the function \code{zoo:rollmean}. \item \code{write_RLum2CSV()}: Exports \code{RLum}-objects to CSV-files to improve the compatibility to other software. Supported are only numerical values, i.e., \code{data.frame}, \code{matrix} and \code{numeric}. } } \subsection{New example data}{ \itemize{ \item \code{ExampleData.fading}: Example data set for fading measurements of the IR50, IR100, IR150 and IR225 feldspar signals of sample UNIL/NB123. It further contains regular equivalent dose measurement data of the same sample, which can be used to apply a fading correction to. These data were kindly provided by Georgina King. } } \subsection{Changes in S4-classes and methods}{ \itemize{ \item Method \code{get_RLum} for \code{RLum.Analysis}-objects did not respect \code{.pid}, fixed. \item Method \code{get_RLum} for \code{list}-objects now accepts lists with all kinds of \code{RLum}-objects. Previously, only lists of \code{RLum.Analysis}-objects were allowed. \item \code{plot_RLum} was not passing the argument \code{sub}, as it was fetched by the partial argument matching; fixed. \item \code{set_RLum} produced \code{NA} as originator, if the function calling the function \code{set_RLum()} was called from outside of the package using the double colons (e.g., \code{Luminescence::function()}); fixed. \item \code{smooth_RLum} add method support for \code{RLum.Data.Curve}, \code{RLum.Analysis} and \code{list} of this objects implemented. } } \subsection{Bugfixes and changes}{ \itemize{ \item \code{analyse_baSARL()}{ \itemize{ \item Due to a typo in the manual the \code{method_control} parameter \code{variable.names} was not working if correctly typed as written in the manual (in the manual: 'variables.names', but correct is 'variable.names'); typo corrected fixed, \item minor improvements and error corrections. } } \itemize{ \item \code{analyse_IRSAR.RF()}{ \itemize{ \item Add option for a vertical sliding of the RF_nat curve (\code{method_control = list(vslide_range = 'auto')}). This feature has beta status and usage for publication work is not recommended yet. By default no vertical sliding is applied, \item allow a parallel processing of MC runs by using the argument \code{method_control = list(cores = 'auto')}. } } \item \code{analyse_SAR.CWOSL()}{ \itemize{ \item Fix wrongly set threshold value for recuperation rate (#26), \item fix a rare bug for the combination 'recyling.ratio = NA' and more than one provided recyling point, \item a check has been implemented to refrain from using wrong rejection criteria keywords. } } \item \code{calc_AliquotSize()}{ \itemize{ \item Console output can now be suppressed via 'verbose = TRUE' (#24). } } \item \code{calc_CosmicDoseRate()}{ \itemize{ \item Console output can now be suppressed via 'verbose = TRUE' (#24). } } \item \code{calc_FastRatio()}{ \itemize{ \item New arguments 'Ch_L2' and 'Ch_L3' to allow the user to specify custom values for channels L2 and L3. Feature requested by A. Versendaal (#29). } } \item \code{calc_FadingCorr()}{ \itemize{ \item Fixed a bug where the function would crash when providing an \code{RLum.Results} object for \code{g_value}, \item new argument \code{interval} to control the age interval for solving the equation via \code{uniroot}. } } \item \code{calc_FiniteMixture()}{ \itemize{ \item Fixed a bug where certain arguments where not passed to `plot_RLum.Results` so that the plot was not as customisable as intended. Thanks to Daniele Questiaux for reporting the bug. } } \item \code{calc_MaxDose()}{ \itemize{ \item Fixed a bug in the console output, which provided wrong values for the asymmetric error on gamma (Note that the values in the output object were correct!). Thankfully reported by Xue Rui. } } \item \code{calc_Statistics()}{ \itemize{ \item The argument \code{n.MC} got a new value \code{NULL} which is now used as default. With this the basic statistical measures are in accordance with the expectations (e.g., the standard deviation is returned by default in the conventional way and not calculated using an MC simulation). } } \item \code{calc_OSLLxTxRatio()}{ \itemize{ \item Add argument \code{use_previousBG} to use the background of the Lx-curve to get the net signal of the Tx-curve (request #15). } } \item \code{fit_CWCurve()}{ \itemize{ \item Change order of \code{RLum.Results} output list elements, \item rename first element to \code{data}, \item add element slot 'info'. } } \item \code{fit_LWCurve()}{ \itemize{ \item Change order of \code{RLum.Results} output list elements, \item rename first element to \code{data}, \item add element slot 'info'. } } \item \code{model_LuminescenceSignals()}{ \itemize{ \item Update function arguments to account for changes in RLumModel version 0.2.0. } } \item \code{plot_DetPlot()}{ \itemize{ \item Correct negative y-axis, the minimum is now the real minimum. } } \item \code{plot_GrowthCurve()}{ \itemize{ \item Reduce number of confusing warning, \item add new argument \code{mode} to select the calculation mode of the function. This allows in particular to only fit data without calculating a De or calculating a De assuming an additive dose response curve, \item account for the very specifc case that all dose points are similar. The function stops with an error and returns NULL, \item under weird circumstances points on the growth curve were not plotted correctly; fixed. } } \item \code{plot_RadialPlot()}{ \itemize{ \item Sometimes the function crashed with an out of bonds error if more than one data set was provided; fixed, \item argument \code{negatives} caused an error if not set to \code{'remove'} and fix some errors around this option, \item De-adjustment for negative values optimised for large scatter. } } \item \code{plot_RLum.Analysis()}{ \itemize{ \item The usage of the argument \code{smooth} led to a crash; fixed. } } \item \code{plot_RLum.Data.Curve()}{ \itemize{ \item Function will not stop anymore if the curve contains \code{NA} values, but if the curve consists of only \code{NA} values. } } \item \code{plot_RLum.Data.Spectrum()}{ \itemize{ \item The interactive plot option was broken with the last update of the package 'plotly'; fixed. } } \item \code{plot_ViolinPlot()}{ \itemize{ \item The function erroneously produced a NA value warning; fixed. } } \item \code{read_BIN2R()}{ \itemize{ \item If BIN-files are automatically imported the function skipped non BIN-files without crashing if it is used in combination with the argument \code{pattern}, \item add new argument \code{irgnore.RECTYPE} to provide a solution for broken BIN-files are BIN-files with non documented entries. Furthermore the general behaviour for such cases had been optimised. } } \item \code{read_Daybreak2R()}{ \itemize{ \item Add support for DAT-files produced by at 1100 reader using the software (TLAPLLIC v.3.2). Thanks to Antoine Zink, \item minor error corrections and adding example code. } } \item \code{template_DRAC()}{ \itemize{ \item Fixed a typo in the column names (#28). } } \item \code{use_DRAC()}{ \itemize{ \item Now supports DRAC v1.2 and the newly introduced CSV input template. Older v1.1 excel sheet input templates are still supported, but users are highly encouraged to use the new CSV file. \item Columns in the output tables are now assigned proper classes (#27). } } } } } \subsection{Internals}{ \itemize{ \item The internal function converting BIN-file curves to RLum.Data.Curve() objects had been optimised and, amongst others, now uses a function written using Rcpp to create the curve matrix. The conversion now works ca. two times faster, \item add \code{`[<-]`} method for \code{RLum.Data.Curve} objects, \item a hint on how to cite a function is now added automatically to every major function manual page, \item add 'magrittr' to the package dependencies (imports) to further support the usage of this amazing pipe operator, \item thanks to Johannes Friedrich this release introduces regular unit tests using the package 'testthat' to improve the code quality and stability, \item add internal helper function \code{.smoothing}; no Rd entry. } } } Luminescence/inst/doc/0000755000176200001440000000000013125226556014415 5ustar liggesusersLuminescence/inst/doc/index.html0000644000176200001440000000307713125226556016421 0ustar liggesusers R package Luminescence - supplementary data

R package Luminescence - supplementary data

Luminescence/inst/doc/S4classObjects.pdf0000644000176200001440000044540713125226556017754 0ustar liggesusers%PDF-1.5 % 1 0 obj << /Type /ObjStm /Length 1055 /Filter /FlateDecode /N 15 /First 101 >> stream xVo6⾵C% Eؙݠq%NWl"l H4{$$nl{Ǔ19)&5PN*pI%3  3%Rp79q0f4|D̺\l^l0XKNvnvWtrM= Br.Rx;}]݇E~޵niA2t_v͝#/p_toѸְq:`m7cIS,pb*>2R?Gk냳v\MvwM֯Ue)owM 'eEVW3N(;E(ce~cǘۃ!<#ʯ!ьmw[m(|_u;ܟH'ϏކHeSWSlz7^WISrj CbrΫ u^oe @^>Ww$ګEl\K ~~//u)ëq|K#ǡ.Dmii(X/)0rYXUcэV{{L@]$ #8XS R熫2:fhh=yh=Zq^y!}׸lC(%sGdSzYL(JPaP2`IH|nW5˓ =5}lWk^9{ *aLPa۾"/:tty4j7[*?|]+*O|y 囹1iq"*$l0BwEu!d==TA:hUqQV{%G+ xKR_^8?///Ey:@K(å~1ƼXb[F{8)/WjmˡnAgH D %[^HllAR$2\&^ px./eLW*\%^ px/UJW9W 916h:\*/!P?φeendstream endobj 17 0 obj << /Subtype /XML /Type /Metadata /Length 1548 >> stream GPL Ghostscript 9.18 2016-05-23T11:34:44+02:00 2016-05-23T11:34:44+02:00 UnknownApplication endstream endobj 18 0 obj << /Filter /FlateDecode /Length 8344 >> stream x]Yq~_QЋO9C-K|BXޔfV\"Ȫp%@dV_vW|rs}tӋ Ttn~BY18{vtRLZDv Sq*ܾJrc'z~-҇ͅ0K5i,d]IٺㅚӿrީBYVr}(k-Pqޣo%TjUlOނ"кT%0sm˩f#쥉~z!oztXZQW{9hG7W{iMzigd}'f/,H(RLf/K(F׏Q/ v[+~i/*f8e+j$v:*b-XV)9p&eշZ>ơ<8jYI[âVLoc4ͅQZFzX+oOSx7{n%TkI AaoS01RädpF-6/>&:e2ijdMF,eTݻ=E F6TG{֙MU\Br-nn d<@'V_bQyT@UL {=eΚݟ1 B޴y>tvk801=zz~6{`crX@v/DeQ6QrIJ&FM*5NHa z t%fl<F`+UyH@c lP=ZX-sJ tpO57/8Kb}q0bU̓uX7d[biޜ{6eOSOc:wGC7cMh8xB^> ~ >{w}]4tq)4}Ƭk. 9nnH|`([X=[78DjGF,ۣ $[-͎"%DH(X.D, m3 [SBmZ6N@Y ="N~g+%KR :XV#ZP3FƙJbǛ 9vߤ>r9ձ&br(G0U}w+akXQ`t ~% >$njE>Huj6N` aɾt|v|dM|E(~ȷC;DrnAU"ТMB-hr6hal-",>8(% Ȣpd1Ԫ$syeEՕk%Ɉ2J*ûFéFbet>0GɶƸ<>﷎fA~}ʿkn㍾8M65=?M,pa x<~ǁ 1&64q`,L q?}[4L{5I$YGRaD(au4--&Scȿܸ!DY(J)' K @h~{Vts!%"! CaJy?㙜DY[ g(qrJH)Tg2KdtsCYGf$8o(Wpv=8-\(Q{uϹbe LqDXR[(iye;aV A/$>J+%saU6R0T03F/d\0FOH`((h$hd6y HƬe bu{BϱۚG5&,R-m+%:fj,a??1HTxw$sEscT\,¶yZe? <|s!a)b{y2PX.Ux_x= YU Y":=qeTXG*,ɢМd$gE.ǖ)7%Q®`!So.KDAD iVku E49>k#sfMWoqi)jK0ERds!aT041r^G5υM6B!ZJs' FSRuJS o9B8RG/ۦqPfHR :7Ҁ \Z'*ש|QJMsyU^8-?KAs̎Kf|wͰ`|;MWn*&SV (2LwtlZ08`ʪqHM:mD$Vj7vDz C0z%:{#ȋk$$MF/ԙ+H@lT^os~nƕФH[ym$ÌitجʜIE9UJ2aD/S/W`&x)ͫO,wj;gr[-SĈX&BY]rpOQkX]I\O&- TX Q5lB<b?%vT.z|/?z,|-)H׬;y3T2+jh#.UV"6~47on̻[4l$&jHxc|z`0ǝ},:2˗8i&,u͆V!-)";.AUh̀]H6͈%גZD' Zi@ܯ%ZW/il_Iڎ{igʧe"i |D 4w'4uSQQ"E"?ZCUR+\=IJ%@4dy3Dp@V@lSpS.M% :RTJ8H,ۡ&Hu  UHoݓY6tڝU=NWksv*J߼.LUr/ϲP8%*COFZw֍Ԫ{zֶg'v̦WdK/ܬ =/JbE:EF( tPuzBC#[V}>5#mj{ ,7ZñΊBƐ?TW (l5Ԫb(%Vm=3lwEmU &t. :O a ^WG, LIV;^7Ż'O(NrݯO2۵/Sd aZ@Ya%IZIIF]:]n=/$eƬ'aMV+].%$m2>{4#ܔ[CSl㺪n =v^asH\tW̥]|h,2|[Ż}]%#\y碝KagµoZlOHUNOl~}]CV ,D^fy쏓l ௪fэ SRm4nk Sƌ&bZ;>܊R%!o!jv TPy_7=%h#q(D%׭dС]S[c%-F(JRoPiVIF-]Ku+юnQI`JDYe7s$[Rqz5"N{B%׭D@` %Tߩ4o {ٝn,"%s-̟C)o)e q/z' d#| gرĶ)< Gáa%kf^n5e15hCi "R$H0fj)ûqWR~LнnkaL.w 9 n;,n͇VbIrNk4RZ.8OrG+ !'$uJ8sɛ0s@Krc/AXI.w"|>0$NyǢt~}(rIO(>ޖ8A\ۘZld%\n|Η=(͢K^2k9 RQا@%U;6d5aT7!WX{xYyxRMvBS >p؏Rˆ^^w844Z&iz?mv~*&|5i8@pŢYҌKSX\>O;䓟4(Ȍ4h+t-GwK?zUgYТ;kZB멜s\/\i#j#|\eQ Up'>\_;t;6^Z-A= ȊiH~\ ͉X%/0I,ԪU 3aU\FDٝlI0^i8-wͧr%ΧbȲ|>-FɜIA-֢/.`f 2;U]f=8*zJܤEZ1juIJ?t} 2M+noTK-~ z2xŚEo*Y!zkyl{!;̭-5v:=tǟH9>'[] ۾q*?9G_o? "? A{ϔVMaKL;(kȭGZ$"AYʥw4:)hkM\:2#\.]&H1dq{.^h˽i.Ybe] E&Mh%9Y C+]QVs".<\~b7TnXqjȨvӛ;?^ĶCN̏{DCܨti8RWW G{2^'[/}{Qޣ@jO[)Fe[dw L|ݷ9i7̙Ôd%[Ix&Jqsg|X6QSf[IùP2C@>1"=d=+{^L,z5~fhnLNWl?2'ggyDrwoWXϩss*C6 t0`J|4}4`C!=dܷz qbL%, E-rzWw& t턏Ӻdxِ@@>ifrƇU )`V5ߖ難߁mKa WT "K_PiHrP2 P5/歄Yw;Ov3gٌ,(_?SdY҇35LaMJEK˒?U?yMqo&p`ifoSM[&|owo/r0 |M.GCp-%Cǜ7; ܩ>4eY6<8>bi-iYzĘ9Szj*񎕭r-j8so2蹺&F:d~VO4 2?ðDQ5,xiƖCjc%dF',(uN!ǵۺ^>\u7[ En}n,$ǖn4ǩKGZ,a^__J\Cax;^{=Wz%gRG ^9,д $)V5{CGzNy&v/{~lrV.mx m= B60x ;ҹ!]L|Nxq6U`SVWMi[PV{܂~9N[P;xO`C\tHśЌ~kdmXƝN/de~c5#7BêcBe!CYDN_]wlDI<29~i&+뵄ebM6ʌ-ّ#5&ioH-Kٔx^,A*\ %rQ;}wtD1Er90)X@$eQM?dtYg:sO_jYk?O^uʎjU~Kj7 ~ݬWJGW߲@OTE!.em6@͆Z_7mQJ,#l*~&Kٶ^=.33*f ػ]n^~,ZE,YjV;!?KM_W3{ۿXd`FF/;\}mKpie?;ao;/EtIŁY/Ӧ*zt2y1)ۻeiօ~,uoTi=y~ӔRf|TK3+*"[%iU RZ~M? ^~UbP?~1$>ݨ[`Î[;}jA뚬IvW]-{Su˜mm4"v^,Nx\Lx֦M NlWp%ZhAzG7Fv#lDڌs Æ f>]10H.rl"m~z[B"l)~.UwHzu+Uߖc"Pj,"ȸy@,O?t*iy@0~,kC+͛}Z# y@".{~G).U=BjD? -,(-|/ۭ`~ ^i~eBwKYiv)/FgVHy!VRXZӼ^֗hRSRA&Q*SNSmtU~%Ysʂ|<)ɸ.{|4TRTERL˛dxE0/6Li8 *B ?Ȇ,sMUB\v(q[3 &=Ӝ Ϟrdܶol_Y=jvPz]x' ӲY^< %>< PT?!;Og5;KjiRlUo?z!L0} ]J ,N.۰{N:TbM5k;`{9O/ouendstream endobj 19 0 obj << /Filter /FlateDecode /Length 276 >> stream x]Mn0>o;N%MɢUƌ#1!޾o.ވ0Ӝί2oKMLn˽&#]NOs$1]㪚[\V0P=^tV޴{NZ&1QBj0& 9Ee=c~X;XY  vG`<2& &`snc/fD ,snd} "c0Zl0ps82NAшF6 ^~Oj쥯} z.W7x\{T690庬! Fendstream endobj 20 0 obj << /Filter /FlateDecode /Length1 73000 /Length 33764 >> stream x}`l;ݝ1ƶ$j-˶%ٖi^ݭt+ݞXh E B @ ^B iNJ޼y͛ٝ=& jpՓxZRzNB>{q^@7ۗ.VE~@9)K yb<4ćܶ#$b PwJ =d۔: 'Cӑ'i/`ʟRpexsn.o-Q =vq?k B?Ez [r斯 4l`'H:x<n׃_~ׂ~^.ǣp8c>n>|,Aiok?mfk[v"("ׁK=&aaSzQ}N p:bG`Lx) y`  -_~VV0/ms8(n58~UQ AuZpL܌mU[~$͡=f=MY -;~xeh[FUW܋ȃpX?}J( ѫn; \t׃UTƵYٱ]jN&H<?ԿׂwsWЉCy h>,<@˸*x ٣GI(E8joуajyV9ż@-b^[D w,*wq<7 /pdaԫƍHr(ρېп0084Q;$KE9.Y4ёgP-W7,!Ю'?n ?/V܎ƈ>E~6:dXpe}kAys̞5s}]wyi;NvVo3e*+#PY0AU%Q90<:iMtJӺihpfʣudRQP6ZbM`a}vZӴ&CC @&-8@*7q8`lxU`wct)֌r*ݜ[;՛P1URDFD]S7͸oгnz01-fTБM@9ݶmZBߺd7w3%#Ʋf>~"i݄[75'NzeHlja$6ٌbrd]OT:dHlqriM=Hd4T:}PIR2ܯj#7?\~ЅJ]KNQv.-;uH 'eita'I@'idqXL`-.s5wwODGOfN`ΣU#SBy9mXs5(ߴfO'Wp MF2#>1jvIk]'=y('Z\-Z֍L7o3-6rS08#C;Om9{4.m%`S˻m*gǣ~'ȷ -xxٌFH=>L']kq'}|)Gнs`Bu<Hԩ:eBЃMtT ΚnιΙЅs69NuP[Mn}۟GʧUD"'mbNToGzܕMkj!ZH}F'M'qL(9}fhdԴ}r4qNg`q7<3q*23M|U2 QS0YǺ~LH_I$YM+>I66d܂TbIḥO\uӚ(a{X4[}4^-okrTK頕ks3Ѷ@t&Ӻ7s[ @ zfd]3c&ku3Ikb${wՉ(ŝ htwzDgig$fFvY ЀWU>tT݇k+x#=8jAm 4GFGP=mZA6M#iSw7#Sۣfp!=DxOa}k"ܳU9#lQ~coHҐ.'&!5{I([V4=~H34f}^#F8͑~&*ƒGx#yGx_=@m͆oʦbsaDEl#QV"o_Kvl-=LBa<@( 0<Y`&x6kA[C瀙|s^|#rp b!\X^_`/+Kř C H!"ll+n͒&Fp3X)p 7n+;:8#l׽S^ CR{^^iQ m2KvuuB.Wue2Rf_vwz9PcJx!^İddXQ +`A!!P~ 20?2,*9aG`X@2EFnfX0r'2DdX yaB@E[k d Dʷe8g0e8p`rp*{4ÕL̕ O?d bmAEw TQCQ,#Apb/!@8RIp$~rMW#W3"e/%x"bHI,'V epn.lyp]#Zi|~:M?YZIu+]w~т!D6!=l"dqQjqf_4cLţQI#v#ꄳt[VߛO}|cO;?Tq4}S̾d!zufAhg.V*mgD[3цT*Jќ7rbLQ3գ0zn jQBu>3_0rF"jf13B/BT$^3n$sb'x2yta(kH0a;L>H]"3mClXOSRϥfd*P+wfىvh9{^gMOLFSpP5kLWO[ WfJc^BD7[Q$FmQvu4Ds~M̞jΙk͏Ο7w3YB:5 SR2yc&tO6zPDJ*Dzѓ3Ic̈́1K"Jϙ:Rש/ mxu-umb|"zcC4 x-r* ہ).|3}l,Wtgú/G'׹c%-&id ߝ=OdQ[փM\$xs?_9J>[|YD (@h @D@9 L$0Lۀj-lv@cT#v;]`7;{{` j@-s\0` `!["͓64>/Cui+}%w*A@p8PM{hWDz: Y b}YJ{X>ɮ#(  ǂp"8 F)T3pǃ3,p68 N$p!'s \~ . \ׁ F0 n7[6p; w߁p/x<G18x< O?g9GK7;|;=p x+B\p\WUq$n27ۆvTnGn3 +;7fqpsy|[-Fkb\ [̵rK6n)[εs+\uq[ʭts z>.ə\?74,.˭r\+pEn7m䆸a0pH(nw4w w,wwŧ oY~=|/A~#?GGGccTgiY9y _///___ 5 -=#?=$4Y9 ?/__??????;5 -w PЄʄ"BP!T Ua0I,Lm0UQ&$,"*&.!Lf{ 3YlF9\a0_{ {  Qh", MX*, a!t ]*aF     ]BB0^OH / )!-dK 녜 BQ !aX8L8\8B8R8J$-#+'/ ($, ?NN.~.\(BHXDppp+ J*okkQ&fVmfNw]=½}ƒC#£c'? ^^$$YxYxExUW3s KoW߅oo~~@D^DQDYTDU&ĠX&İ R'IdqX-n+n:vTqGq8]!)gѕIX'b@K[]'/.FIlcb Y,KURq\lW+SW5bV)>%>-A|F|V|N'%+_77ŷķwwŏďOOſ__.~-~#~+CE' $ɒ">p%M HAL Ia)"KRT%M&JiZVN^AJSiN.Үnti4S%͖jZN#͕IziPj&YI-"i*-ڤ2i.VJR%VKknitttttNҥ).%$CdJҀRF^Iy  ҠQäå##M1ұq ҉I҈tt34t L,l\<|҅/K_JJIK~-FZFVN^AQnnnn~+&.m~'%-#+'/= =(=$=,="=*=&=.=!^zRzJzZGyEOKҟWWHIKoHoJoIoKHJIKHJIKHJ>>&}%]ZFVO;{Gi dNeAeIeEVe(kr@erH\+*y~A!aQ1q Sgg?//_,,"*E~M~]~C~S~K~[~G~W~O~_@PHXDT7+7???[p H(@ESJP)SBJX(JRT)$e2EFVUSWvPTeGe2]Tf)VS(sy|^Y,TFIiVbJHY*K6eLY++Jҩt)[YStG+ Pz>%J2Q,%WrJ^)(Ee2lTa0pH(errrrrrrrr2L9M9]9C9S9K9[9G9W9O9_@r "bʥeʯ++_+QVQUSWnPnTF[[*)+;;)w)w+(*)+(*)+(*)+O(WTRV<<I}I5u M-m]=}C#cSgԯԿ_ߨߪP~~nre@B 2aV*8Nd8np;=FT#w;]p7;N3p&gX 8΃a=\{}p??\`#l0["% .rWJ;a\W5ƒx(\u0 `L `9X 0< G£&x4< $x2Sitx<φsy|x9^/_Ker+x^ kuzx›x+- 7;w.x7 !0|> ')4|> O%g2| _7-6| ߃#1~ ?/o+w5~  p4N5A5I5ES5iZ@ jeZH k\**m6QM֦hhڶvZTMvvvvvvЦk3=,mVjum6Ok }}Z֨5iZLkiVm֦-Ֆi˵vmvR:.mZ[ukkCCuhq-Z֧%5S2eZNkmڐ6mҎ֎юՎӎNNNNFSSiikghgjgigkhjikh?.~]]]RTL\vvvk75ڵu ڍڨvvvv[6vmvv;.n^>~A!aQ1q ړSgg?jk/h/j^E{M{]{C{S{K{[{G{W{O{_@PHXDT7+7ڷ?jik?h?j[ R@(5Z Xc}QOjBX9|!ab^YNxHd͚)}9Z$xI㰞欍`Z笌Nak*={ ɡlHi H 4NS'gl0d$JgeEi)nto696:RHu9 YWK f4F$1Ga#%1h*Ljr٠6yg#$kS}=.91ւJId5i51iZ&M%Xmg 9]^NjCN$#n)åv)LH^N5f-i34W FOigXi,ږ3l$IZ^鱜X^I-hAiO.V;FLtI/) )hSiSvYEhE$rfO*oTh#5u)=.zpX^K+8Lu:KI+介|gGƍfރ;=b *xG%(s}l fx Ği䌼GXIZNqPN3}zNE,6!quB[zVLyTa'hAX*X+J:ZC* :Scټ4+V`;1i~#>*Ta"q1.-QfH\X2$u&% O$t~Y_^ט 3ͯ0IK0ҺЩ憰"i MoE,kaCӝ o Ʀ] Œ>D؃Ӈ#%TAW2q gH6i*Ek)M4J* q}zd@ƌ YT8Cd@b)u2hy۩m'i'iZP3h70J Viݦz-wq3t3܌Pʶ\+ S[E.lvakhL[p\>ZXʅif Ww,¼;JunD@gޭ@'jLYG2Rz.78Q6rN#Vo[ãW.o$܀N:An(zmpa .4]=m {$%pmn 7~ kYWp_p_tx_? /yß/ 1&tф.79Fsȅ )xтE1kdQGW(;_=IF&bBFSFr"zw^3^F fH2eIznm$!`n` (.ãfRJ'4X!3d"ut<*Lu%:m.D ]DU8֓zV`d0m L$I>&x#3d-ʂVʠH3S!FҴefm][J]؅Pg760{^OQF}1 c=>D'͜ގy x4Q0vFhg([m{Y%szX tȚU{Y#2``1}fH9MtX5l džQa&mAXpА`^rgv%mBD"m@2Ō4"ʡv?\gʲG^2#<i]o9quBXղDB3FУ#A~@(.th}i>%I==Dp;DB'&r`)$LpH 5wHHz|,KCh~o%hHbBQB69nzkyðC:!jG a9}IAðv!:Vpq̕S)-c JCli 9;JCTW/Qn\v=sfH2L(1w@m-fM 2^vSZUMVN̶O^!`ڊHAm:LD>f |^(XB*L"_1[Zx5+qD<_+8fmfnK8kBx#?RNrNWNF)#w{ٽ!MY3̝2dϲ fCz$sqziUg qQ;MDI4aclv)ӊT۔րngk@  .JY!r脮g0e$HI ]  & By+oA YCL8 O'q1 җ.e!f B 8 +a$7H 2Psi!5 X=:$0keSĽ`e½V/up:4lPY栚Dha OZJ)Dc:¨S77ĥ:`JYO HEUB76\!=S4x3QE%40툛ta4mBÑ-E/4,3tL ׌[0qk4.8N&O*-Z_ܒ9@mBDD=P@gB^8dGJ'?L XC $Eg=D'ڴsTQWUt{ 6tF?K t *JE#a{^M {00;u?X9Co >ܷi17ή~9FH4F)#Vu4nXiԍҨƉ1u3Hn:(jwnwK[wUJJc>^,b^ 4'dY8Y.$\"\lj#ib!pmke]*:t .r]+zznV" v|r|vJ7=VM#qCw3khwP?ԗ2z)4K 4ϞS*#x]eCjMA|r;YBsJW;ͮI.äol84f . ~%BI_s+j2T'|Kͧ +ތ4F(@01O; UIS/S/1^{9hޜGfNIF%: &Zϳ3A>gSg<bГ+F*//;ko[-sy||oY F5ա9o.9yPQ(@}t/!^h`g\HȪ-dٖ 1&޼M`,U$@6US.] n989s{J)STyJ刧O $1FaEyԭ,Կ4673xА!W-|'6MMY4l2ntros*=2Rlys"6+b-W|s؂9sLA²&{"JOdxUL=~= ?w-zМ˾Ɇ˺ i iƢMM;n*f{]=5zJzbTb {/%dN1$Ff9)^)\(YݏLv>N=.Y51&i` Y6nW`/^LLF&5Y{{{^ʇݢEØD'8=F;(';|2rBIK7|!D 7x*{O1}jɴ'6|Sp3[Aw,eIW>dO1^zi215$U3Pwɖ\n0G)Pi_x6Ml(5R a7awÛÛƽN!") :++oQR|F+k )=\BK (cUG+9Vt5}bNjTOۍmK(Ƿ/9*ʧJDI)hp(@=_/êt*;޶k@R84YLs^.} NNۍujhO'1[cf 4'} ճp_[FJC2Crox 1w {=}e%(%:zϹ@ FI|RD|Bi %QMˆ tJKK$B''wK%h\#/O-OM!cFH 1/BQAR.9nChO(ˉP֡a6y=xd-hʝRu'{szR c:8=?3VeCMPKkbl͎Iͯ NN1h& ~9,5{:a= \he&CϓR9#F*CtV˫ɑeVdٙhBv3} :shtކD^:cMxN<3cl,MV,}5lSRskJ':8h) |2d¡80BSג)4MД__ϧK|_np:MZibҤ&MhR$I˞P~:9'\ͥK%}bЧ %~ZÛ 67*E^}4i[;{ۢiZ~|0qigi KwN1#,=)JQh$Ȣ >xHsJN/0DSrJKX+9JDS(HښK[hZ;YZ,m`i#KXR髛ֲ.B8m%ḧm365F~o?J&*yXv(JeS!ڙmXu>46ڀk!o6Mqz ?5Bx<EeeQ$o"y<29.t-.O)8^c  @ʩgj|&iGjg|ڍY?ٟg3|f>?ٟg3zf٫g꙽zf٫g꙽zf٫g꙽zf޶[껀_/`0 f_/`0 f70 ~70 ~70 ~70 ~72~#72n#62n#62n61Mn61Mn61Mn61n353^353{^343;Nى1;1f'Xb]cnٍ11f7Ƙgُ11fiav[fiavZfiavZXx2t2L6Xd ~&Lwܐ]z;bON%ذ)E>d+'ѓL3/=at#%K ,]6B4̝_9ˤZhZW# y͢esfۼRF!*,I̙zhl =)ʙܛܣg~ sA3}xy+MZ[3EmGF9huUgaU1dn`rF*ׁwQÍCB@砑b fXڂ7QM۵ZZZv-fe ;ǵBkkkceMT}{R:jkfCy0@9Sar,s@QGI'J,AI&1_aw2s OpdE1/Km v&Mfj[j^V[r5e t& u:]ʊoԥB]Jw22 ;HdQ K AF 8C __KZIfh-QD_0}* }'D(x3l~Zd)]Ĝ3s#kp =,w^ 5M?]|(-S9r8$ƫu|f#yfVw3^*NC[~y{:~ja&cvwvVaJ1ܙȃqMms!ߌ&,C*f*+=qbe yNqƈgE,qH췏Af(οQI 0pACe?堼6ڨC<;J bz'5W~Bh6mJ/ ?x,c$-`Si3xc;b e=Qo-s| e,e-C.LIlU}+A.(;ځ#o&>s;IrlnN@Ls6o]F[Kr3=ȏǝ.2z,M{E,on$P*5DIOw ^D%w/R )d^nHZAD;l3Q ,,ztuإU䛼JJ"oR) wfZTvWcajs)H5v cn=E˜SB#w!DBL!492Ϋ2>=FFOWI0k\ w)E~̖V#QEYTA,c!mnJhø =NxO,7uZ1"=[LZO )c8jb. dYN'B^,JҞb/:-<'1ŶEtPo0.測0a,ԅ@ؒ"] MY(tC_4wR=;"G5eбpJ9SSUN1rGN&X x κ8b{=Du8i.mI,.iZs~Պ m XQoR>j2jKb)l>s7jd9*r"5>ZʦVagOTĀTǀ[ñ7J]sh=ؓ V/IS'djMr_L5شk즵즵^ě֚MKeMpoZ*wi6Mk-JpTH|W`v mw;/Lܝ,obpKu#.λǍMN*`R eV]$ H5k\ض毵:})J3#P ( fLd;2sfjm:d\`~in&r6)hwy ^:OM%ruTKh͛d&C .E![v'(,(0m}[^OIڽٸPKI oB+T}nʫ ЮPJ+mX0c d&Iԍ 1r)@b{WХ} ?vNz ۃ2Qܡno=cj z7m ?+(X*ߙ ɥ 5i )]|TqIf°M 0T?O&T')L]8(bX~O67 ܃b~V*‡x$"@]0 d ѸJ4hhc=G=U2XѓB;hoWXsHӕihzztytPEvYwZFgM묂 ckhs•Lw4M|SVʺ#}=tE!T"x%Xq1Y #$@鏍oH?_7R#WBV_l%`SGsOIfNOm?$2^=to l J4͛b1:6uӱni ;uwn7Ԡ1 Av!!G~ۜ(r[>7h ܘKÍBd?/2$S>rGgݑ_$Lr x 7_4fFgO$8G >Cv|հ CI}u۱A1|F;; O"lG`翄~X>K o\bnl\иXD48lǮmjQMгnxa^EwǴx _ <όƎ e[Fk^}in߽/]ݾDŽȒrdRd^㡮ч3޾ȃ5Jd}B侅m _q =.X]Fw9x'^[a k`q-i5 k諱 *u^ˆݞFv5,e,`39 q!rx>l<F\H\l At+qDqmxe xNfBq.՘Σyjw&CX1zNb2 SB(d碬7v!| vrjFrqk3N^qE0>xnxބ]!~B!N#oFx?^GZ^D TV ~x4v~|c0'o?Oƣsn񪙈Uw#w0a<­:Cb@b:tix1KT S StSЧ]>>}21}>SY !d ~ %!M,<82AyKZ"\y# dn2f(u ׏(vȆp]In~Fj(R95*pX3]řH^՞8@&wJ^8zЅf94=W45#.~hy7Z@ 0KE t=@5 8j.plGoI*OXM~ teO 40?}K*a4(*onH>#RhN\ CvHhr(z[\w=&6й[xnH~!1a!^vp}H4@,G*%fHP"0ft|t*=ͼyvEouސp9@Zi%>IcySGQ*P&Oޠ a'Qu %:e"*è䄀9ܹySHdߩSeOēQ^96Ps@]@GFKu):C:rnЀ\ c2xNï'hnЙƎ2Es$;6kYb~u4 T>IuOUG&))iam"EG#udYߜn{oFYk5b5SZ,} cU22uN)LaQ(2l fA6Qc+޴ JuEU'[8?ֵ61HUni[,mCw`Ak}f5gyX,X'CzNτWx @S{e QW(^Y?O{Ёj@ZPM?gEXLacT n%CpIKb:19nj[p At v;J3c7m94:{w~"\=%%=ڗ0#GIq \Ad͢7u\ WlOaqo{h֋/w}x_^ew=f 8Ռy=t:̨؜֔F'渖Fqv t@Ls+OU?}d2]]t !S,0||z:+%SA,G*ե4Q=ճmldCWlCV(:mEs>*-U݁4ah:t,FV-W}FOENIyˡILP`#UcE"tNP4PRܣ/- ! nw9_\;[Xݸ)kDog @7?b2zfˉIȧPhc7truRg'P! ֲc*  zdL8u?c*9֯D#2)Q+U&V7ŋ;YT$YjE3"`E"qJ]wCtν{[Qxb [ynV_ dbH,D B2IAv ^pTW}!U4kپ%>m:<6Mw7w94ea0:]" tW`WCáL0ógA'z T eYUQ6t1ԥ 7 .9{2c.wi T,OGsu[$Mf)-6Gy6v"7# P,|[a2 NW[.{߯onyu==:uڹ|woկvش -?bZBX@&hWq?T!<&@0'cDX )*i(Jac!|?޽{-;?G#r -ٱeU"*ؽgBa\(Eş>_DԄLEn&l alŗT/$(=}iDBi>4sU .esFZI+n#mڣ,nTu u9d8}A9m_[ ya BdZF>(a JAj~Mp{a(MC淒BVM`hcS@a4nf6JW<9"lҷ =d@䥈m&?(ҽMp,mn~|ҙ?xfxǮ̓O5q3=w<::kqSl[qit& Ɗ*%:=u[cWOj ϦF]|ՙފ% ܡ<\AWјmB'_vw$Z)+W0`UAc\v<>>f;qQ@׆˺e "폪 Q.=v,ȓwD7y$ }NL>>OC!ͽX\rdI~Fu<"J@ѸWLzTT0 eE it!2 Jj13и**) Ń%iEeKKJl!XR̕jmd{wmZj/AZNL.ˇ`/k=޲?!h?/,jZ}g{61 m&jl+> 9*Sɖ3]3gtwz͍(أ==WeWG82Τj:h|_UbzN oD9p0$p׮٫P|"RΌgj9* A3ԡh~:;菓*șH:Ƌ 0DֵejHBTKܹ8msK/D&C>\)w ??i;~ȱwZ/m~SϷ1l[kVIBnO<DO>ED8ဏdzj^N2OC:Aurw2UR$q84^@ 0D'S;+tB/GD+R$[/R(&5f| z՛C"YZ=n$4]>]O]_bQᖷAX;^mذxOxi8<Ohs%pZZgJ|V"[`8q󛔸 !5"ɍUU0Jm۝[]WHK\ S`3kb#40#/XqX]"AHOPZFNۡ;"P*sjiK-NmvBUQ%$2Zk>])LGYcbTKB3*R[ fڙ%aHe.i ]rNZ[|*<쎆|+`ttVaV`]2[s\ҩ~]AcM|ǚ!V} "):l>a@hWJͰ 4+H]47ẎDA̅mױeE͍rzA}c%_ZX%,_:K^(Un =*e+׺' ό  eYaj SٹJ]W s(ՏWQ߯62oU'z2np5]J r CP½~3~cYumy-C-Pv[NEoȮ)N6ugAMȆNccccC\z2C>( A (0<ʃy:,ӿשCԮXgNm&uv=OfnWCaV\*ƕQ *#&"jC 6FV\,ȍf mSiJQ;uտA7ddDU$g[6Dļ„ݽ.hsvs ?ԌcϽt7h9Cz߹Ϣo1rCVƃi!oXmf8L1&.\((4+``;-@O.x@|Ul;rIKsZ)|O1qكXm(ޏ=pZY5l {5398@Oɽd3a(ZOl_==Ӓmz";RCW G #&0Ȋۋ6L`VBt>l󶪊% \mʎūrDE^'xʃA 99&v15fo2.5 ^jʋ #]GϭcpоOYb> =fD(byODU< (pКy@s|E$7'dFk77vWrmcBTu!9kE{SP?s;ҳp >OgtƤ̅ov%2kܑ77<1x6fc X{14(_L9  Jo9kz:s9f(X(xH]wl1?vǷ =(l:sp&שR*LUm{ܒۇ&f0wa2CzF4Eo=/DguuK}W]Ėw'{˷E+>|νl=Ҍ^}"A^G/zEFg_4` XgJ\8@Ѯw9 ֹa+ AޤNVMBmjzz|Dbsgq_J4/yCw}Ρ0"A_#cP3z=@(h֐XHD8ƗL[! @+o Gl6׎ 04Ҿy?|u] Zյ`K`珱ȿ~^l:~d5'8;:wfR0RN‡·7.'=ƿ Y PSЌ.(^\Pz=bNPYyyłIoM.h;nIMѿRb)M9To|fR֮-Tog{k(1Gp .ӥ'2}MGOu'I_6M*h:>ZWw P*SةnP@)Pz((s<eӧ5aXujz2Cj Qtbz$AaC'5.R,HӤmLb.RRLfOAG)O/ܹ-LKM[;l >޻wȹ'7{OWIg޵Pm$IOvTA3~Qfc;@ QF&<~bth/ $}'$:@8y߁hx\ybW-.e9gWjJU's*>%18 4 XDOIIQxҀqNi$l# ͽ'tlhDDv'MrvG_s=e}whZ@m-cዯ)c˭ qZ>`?b]S);\*xG eA]}HFDuNYQh^ FyuW%fjdA_fAMW=7=zE|$Uɩr2:ڷbgo;;XZIn[|i3< ҁW[:>7h]_ꟻn}[iz޹tMkCnB;rIn,6n1Xb3{2=$ο:q2g8=εEWϛl wE^VNBO0iBAPE &s҈V27(:zڨbRb#1ۀ * N|~w77?W {yAͳܿ軳'lkplR; 1ڣ4R^~253.|E◷Dl{ϏWg(,Ӏ V^ƺ_Z1^I V<'xMtȶMJ:r:~S2TpJYR9,ʜ,uaLaI&DgEEUje'STSTIKXD-!&SD7sȓV?msd2ۼW"{jŴFxpfxCk@a-o.-j', ;T1f)r`i r"6P@P ݄&l:yzyhPzqK?x txvhHsAR,!P_R iv뚜O(x/Ij.֙:[i|BbHӠ$zNsIN-K<Q(Ol!O`)8i.MG DD+)78 0S

6X8EVOM9a}~uS!(EI$A79gjx- _ǚ)Gqck*tB;ndCsIO'l0z:* :ik/J$4zh|PA=gwӥ|c{Tet1t^H2Nvb2Ћ1)o 6{`@[]iZ34I&$kV,}(ؼϲFNrs,*9F9>y- :& -bAt 5 sBՖǹ(lC'%%H'Y{ٹ%--6?oFqga]e:/@ ̀Pk9R&^1:c +NӒL`d>)ߠ(6;`kc w W0 jz3}a3-[ I])_o'"o-vbsR&;64cyJ6P'\d|jtSjJ͵$F@BЮ ]p}Gj7N87/ԭoC/e~&!nKG]ޡ}Պ&[ 8(3XKS*S8E6 @o&ԫv3C EdX3Tg{^ .(2?ޤ溺fȴm*ysutf-OtօD9Me1e'EjΣQs{iEg8§_*UgEsƹƙpḂ ̐ 8#.0jLFyM򸋝WbpI}Sn؞27C(߾#2GK9Nݿa$x.E]pS"=M*ߦcT'K*i4AbxxBx5<Ó@D&(R;LILc?3($&dKD iG֝i8]Ûmq푉mq9Rvӟ$Х | tz3aeZBef))uQqG"'yYVF&H"5PFiKMGpc%'"nVAV UTԫm*˪IOdMd&)Ajʊ.T& r@yb:UH I)Vb4eI٭HPE4}I*uu: ≎()8H8=kic%b~%C7(4@k!\i뱽Gs؇; űݗ#/ľ/;2#|' H/Kt;@'sg:AxF! :Hr@(#?-%MMSuI%hN \}Hb- * TUOA *SPr њ\9:XCQ5~q xOL7v2xb2 zGA=}Yv~EDnI%$UŐ~&Ymc(f 0,!t5H\&?#sT@;BFqg,xNm!:.q8I࿑ 2 7N$L&SԲ=mկ\G'&Պ R&91䗯I)"4X2ՖL@f;_lIy>Ɍk7l O9*pgj>p/&6ۇ>hv.sۄ7őR|;(2M MhMӞAbs\ ;opvyN+pxd~9챼7xy-}o@kCRvۥvi].mKۥvi].mKۥvi]7E+ؘD$~$&^?LSY$v ;t$3!E]ayi2\Ab?`UkV^7zr#Gt-G )WqyJKM-:q'b7ċ 4Jc|Ҏ't vZDnKI֧\CП U "r5\KJrF3n$2"7-JC/$o@HZ\S2Ox昃hE?pa%mt <l,i/}Nb q .q (Zd0aג7S 'oJnG챡7ikv4'a0f;Q%BLE> stream x]=n0 wB7b[\%Cd <\you3> stream x}`l;ݝJrV9ٲlؒmJe   @ 0 Z!{ڶ87޼y͛;s{Vv]ȿ/Bki=K{+=Dz}bU*/5KG''ީa9_qnKK2]L忚'SV\+ĉi}s604ɧ3FSc$Sy2kpLGμ.35N>'OS0?q)`KM?j+SٟUtX[*o#xZ[ >rAnx|x9:nEx {'}T#z3X1װ?E8p1M|0׃%7#g-s$VDn쿗'3=|Ԃjs!d]Tp3Oekh?w 9rȘ>J`)6 hoG{DTN_PEfp8lIf!(i9|gKqHt˟z7 {R/=Ux­4tfc܈ >rp#w2^p7o'V?yxr@k%8y8 24޿3%}\^=]2 z<}fX㽎y 1 Cxxx3'oѢUmK{ ϛ[_W;g3:mFwq2y Up,РȒ(Mܼ.?:yh& hQPQ=W&s&[,qs768eT] X0 }:r$frUr܄e \ՆqbK&hbӏhDFG#֕#HnufCC @Z-8@*r8`lkyU`wctIiAqC9nΖw*)Nͣ u"j.GIkg9r0=It$p-Œ۷\Xېn!dtXvi'M 5-(6;aգ(O-CbeïW #f##'DG/BzrO &#Gb5RoM2i6qGG}O?SG"/AJ, ~W39 U=T hႨ.TzX&DG@VZv)qvQO (ytQ'I@'idqXL`=.s6twODGi'Hj#X2mjzd=(Ι3WTڏ}rtd$32j5^?6t;-DH9830FyÓ(rr1I¤F6n$WDjP=|yE dncSVCo"oK{)#@>q#'h rhm_rW1o=4aDEHY=)~.н8t0l`xhA+Tg" Bzcx6(zk"D~`_<|?D01—37K}2q0!|RE:J@dǭ3Vɧ2CU[*ŎbA9%uo"|(2  NW Zbx%¶C^ vu BV׀ e3Rf:wݷ9Pgbx=°*)%dXV9 CSq:!A091\Dvf8"9ah3Ay|aXjv%#1,@1s*FaP 5PQ.2|"Awb Dwg8Y 0XpC.ˋ W0\ /` \,IH Oj OA|p5%ۃ )xEܦu VV+!Bp~+* .' :%>*&x ށȌbR?o8[@#H0@dNP iGs YDm,HX(݁rm] ,qi"_['wmn)"޶J`QwlfYh!}m_=X}*C%L *9T&4Js``K`ϩJm("iFRq>DӃX-Rm5C3m2EJb(F8R[׶qtQ 0ڏj@>x:ڵW p18>тM4wz|5H1Gnye7P&($݌:lxOoOrX=w~}Owf+;3څ MfFXmgES(GsFm2ˊq3G|TrzH빁;F Ց3|FkYѕzz&ttq0-$sf>a ; CYWG #oex@ўh;*`zz.0snS82&+1wvά9Znhݜڹ3,Y[7VΖ94cG%9XdkYz_2ŬƼ* & oH(G >+ڬZm`چsΙjΝ=j/.?oἅB:5SS2yctOzGb#z*ʛA;r 3Y#gZ2"m$dY@2'z2kIveMhl3q~3}zznFU:'g F]gW'QS.1QK8s+ufH3vpA|8X#1>\h=)vs{ЌBJL[xb24JYs^ݜw_T `yrDA\$+ itd_ڀ<_@#<$  @(T `"&)`;P ;Nh^ v5`0 v=? f`u|4`/7 EhNnBktmnEXBKA;tVU{'׀`Zp(؀كfdKjLЏf. 6')z p$ 8  ?ǂp"')TLp88y)p!5\ .8\A[p% \ Zpn7-fp nw=^p <#Qx<O3Y%2x ^7-6x #1| >/+5߂\\+*JM&q)v\5=#r;s5.4nWn7nwnnOn:7fssZr[-&kb\+[µqKvn[up+Ujpku\7;;;;;\r}\3~nKqi.Y\ȗ!>Gr D~?oW;;;Q~*3_Owww3,~6?z~.?/^>~"o>Ʒ%|o|?_ů;.~ _wCC q>|/'y3g|o????),<"3~????9: L,l\y _/__=~##+;'7g^>/C#c_gg////_*xADAdAT BBD(*JJ L& )vB ; 5.4aWa7awaaOa0C)f sZN AX(%-#+'/,&YhbBXX" Kva\X!t+UjSkuB^8P8H8X8D8T B! }BR0~a@H i!#XBV(䄼P&aP, a‘Oc '' ?FSS g~)'J8_@Ppppppr •Uk Fk? 7 7 [[? ww w w "/< <(<$<,<"<*<&<.))R4 ,)+mrR^*HEi4(ma0pH'Q1OcI#I)ҩϥӤӥ3_HgJgIgKHJΓ~%/] ](ZHXDTLtt[J*w5?Hҵu --ҟ[ۤۥ;;?KHJI*=%=-=#=+='Mz^zAzQzIzYzEzUuқ[;һ{҇G'ҧgҗW7ҷwVȜ˂,ʒ,ˊP#r\!WUyV>N>^>A>Q<"$,"*\>M>]>C|||||K%J2Q,%lTrJ^)(Ee2lVa0pH'Q1Oc)#I)ʩϕӔӕ3_(g*g)g+(*TS~\\ZHXDTLrr[J*w5?(ʵu --ʟ[۔ە;;?+(*)QWPTRVQUSWPT<<<<5j:ԴQ-5nTsj^-Eu:nVa0pH'Q1Oc՟#I)3_ggg窿TS^^ZHXDTLzz[J*w5?u ՛--[;;ջԻ?QWPTRVQUSWPT>>>>>M}^}A}Q}I}Y}E}Uu[;{G'gW7wV y(@JP T! ,!X+`%D8 NSvnw;`N; wpO8΀3,8΁ùp}~p6& [` p lKa;\Up5]p \ nCpa4`/Ih~8S0 3ЂY``np30x8< GcO8x<<GIdx <Og_3Ylx<χ Ebx ^/W+Uwjx =Gx# n7[6x; w?{>x?|>G18|> Og97<|_/W5:'| ߂ow=>~?O39~ _o;=nՀi&h&ih5M hAL ia-kZVM&jm;Z^AQIjSmm6]fi9ZVksy|m֠-iZ֬h1U[-ڴZL[:*m֩uik:[[mtGk z>-Z6,-mrZ^+hEm6mֆa0pH'Q1Oci#I)کϵӴӵ3_hgjgigkhj~]]ZHXDTLvv[J*w5?hڵu --ڟ[۴۵;;?khjiמО=====M{^{A{Q{I{Y{E{Uuڛ[;ڻ{ڇG'ڧgڗW7ڷwp> ĀJ@ 3VXSZ.ֆz?7HW/:D'Y6hf F_ j8g9k.9+}sؖ zɀBr(42RD0m&)e+Tn Y'hYc@ihx1ݛ26.͎䖸:~eCB֕f,RQI`QfH1G 1\6S#F3\p&MF<ݣ>a6 H<bD@4rF#$-k8X( '>=WL"UIBVA:N!Jc-Ӏb=y+e&<0b4 ",%LzEH1MBO)ԃlD[X~P̘4?:F0ߘDMFAj 3$G,:ؒԎq<= _^WuL+MaUҒV}i]ԋ sCX4f2oy]0 N݃Ɔ]cӮbIYZ@F+L8k3 VX4@j&%H\>)DP@Ucƅ,V!Rp|1:T崓jmV|(z^bs%]nnӁK] +Eqm4DFFg>=a ̬d(FHV;CFpQ\ևgd-*(.nLifCfD6.y-UJtDXC7)\V6@Nq('>` yHFoQs}6ި'%&7+L*Pӓ=FfJ[AfC &iGX9ۺН( nlbQ.轞f,`F|=O9s< Uh `bO&PI;ZXߨJ^ñ7hȚU{Y#6``1}fH9MtX5lMdžQa&mAXpА`^rgv%mBD"m@2Ō4"ʡv?\gʲG^2#<ih9quBXղDB+FZ4hzЄ7=K(X4xO@RO3*i=ɽI\f>Xs42)D͝(R0i=s5P3ڰBI>su a)>Z0ncQe~A@_efv0l] CB=v*e,aSiMQ9m|1gGiȖ <+͜.9s. IA4bT(ڡC̣EA 9n^ ʠiw77jх;vL[q9)yLtAL˘ \HZżIK2&`Y f%Id`Fhӹ&!W<#-t5l$2y7lrP"В5)Cv,`9jz'L2G9VunDtډOcFm1F;F;mG{2<9*5Kvm3T_B'C!{ c Re6A%<-q=G7 s߃L Gwk9+esV/kBșDw&[Y&$ΘA`9rHtVFLlkD5mdaH'6ӖD4HAn xG((fD%t{FW( *qDEr"cka$7HK -@ Z1 Iw$G }LϢФ> nGeh{\d!Z>q>_y91+膘_/{L'{v|4lg(LФxIm.]ִY)Bkr2'x*rΪdCAM`lU$@6US. n9_8rq=yJ@)CS*X=he?de]NR4cѦB!IP|o܆M=d'=B{1}QcLw'Yrnc EP\J/ Ҕw.s,G&' ]NOR'Vl`KkډxIX*HvjM=؋7.9=d-t^D!+QGV|G"aL"d{]NB>Yy9%ÛMOWƇldHP8S'|"OWrrpȧ-/4YnpcW(dKn7Y}F(ǴDsEB&6Tr+CNexJT^|B~0>c lC^wwBv]R{7V()Y>5\@n!-1ܪ>+:VD>V1ax'F%~s%LI48  잯aUbTlhXmo[U5 uh-M%cܩW[xsx>vccI֘Ղ} ͉dBoo1wzW>Ӈd DoW7{?^$Mxg ,R .c^-)3R:c sld-"7Ș&ᙖQz*m0bL 閑"!h74>5iA]:YO_dI!y.@k/QR+|T>Q"_PBIԆå%Et0bDzdƭ}ۢi^~|0ӯ]҅Z#@1FSc v=FX6&zRDnP=HM|001 _)a:%%L%V9%rNU9.D)/Q$u1Ҵn>K Y&6L_W?,ci}l8m%hΈmwmjO͍*}w+p;IJC]* lx*Ьk)?7zi@S[#7Hs\[+\f5M$_O3hJX)Vaˊ;ZN騢ya@DqN"68= #,WwN8[\ -$JA6w.4D~ / =K%@e1.eZ:PY^%Tҍ'FI-qx6RJ2X@҃<50]j_uL)dΫ/N˵-7@nR6 ;?g>3g>7g>;o>_/`0 f_/`0 ~50{ ^50{ ^50{ ^`cm`]/d2 Bf!_/d2 Bf!odFfodFfodFfodFfob&fob&fmbv&fmbv&fmfvffmfvffmfvffmfvfmaZfkaZfkavZf'Ęcvb~1֮1f7Ƙcvcn3ǘ2^+2;N+2;NkټX&g,r&LOܐSz;bߜ*K"a+S 2 DO 3ɼ #O ӎ.͡.6t!KY^Ӝ_;oA:hji}635F(3>2] QgKg7@cs8IQ\\2k۵u[iʠкyj 6ZdA:[b!s[mnr6 cq Qr#4RLu^=PK[;`Vp]u\u\ۮ] ׵ZvV(umsmsmA>j2zOJ'T]:O(g>VPQƉˬ&_I&1_iw2s Opde1/Km v&Mfj[j/Bjk\b)e2q}a2߷ t& u:]ʊoԥB]Jw22 ;HdQ [  Rr C ߇_KZIfh-QD_0VAnOzK{N/Qw;f9?R9wD֓-4EwC>هw8z)'6t%LX^10{EkOñJ94{ -Xʙ{u-ǭl'j񱼪n#7P8@uI ֖/!o*IeM^'Q&6tR>afVWT"ƫ֔GI%9[I6tC4 ͂` /xfd2|_j^ !6e2j\ )A9JK[h /IJFoɕePE-)4 # 2VFfMV YLT$FO H{i=lC fT xCA !=O1hUc4' ӗJ9UxTy4%TV ìl2cyX^yDAvGZ)g#zRq|~qIU5W8絚YgSwpzpm骖aCH[31s59 ggU~Ý|ׄܮ="#Ү0JSP/;%ryOe*o{mĀvRNq8X~.9sNJֲr|[m%!){XWꈳoHY Ogg66N8J*ʤ G|ZcA"oxy*d-bCb} FvtM~9r%/3w)F25EtU)a6Al:[Zǩ]yXKhǰi3WzY8J2F661vr!X628WھPR=!QTĆo~% }7R;2|$aH͍ փ "K34y^|À6˛i3JM{4OғJ>o;`d S[g$$Y6Ε(VBwD=ED:g:}wI^%%H);3~-*_u»1j l:\ cM徻2A8 @tJ^Lc=`v6r=Rh.HZ)䰔&#-)Q:bDmԸM^3Or/L (li1;굱;ے b8E}V 6MM\ aǩrQ5#Cѵ/xŤJݜ2c&Ʃ@q/\ )" {_l[DzXt3eْce ]E.|WL̐GoBuK4EC+$1 uSQ|,akK/QJcVYCK[٬I݌S@)'}8`IHxhpt z.Y@tb21ê@݄[(3 4ՓϺHDq{vDUSc-DON RnY]\\3EtgNw12 hl:RGBez>iniCy҃.'8^nNK~zwK|s|\_+H[bƩB5Eua9ttRX me~2r @1 &>2%zOGZJFxY *WЙzu /;K肟FZpdsZ979ﹲTb/-avHɦXe(y3mٗ,f3e%eNwXfAWmzΰz[3-nGUr}!=F"D}rjx/Ro0Ty3 U-$1<B(TbːLeyp)r]/b˫_Gej!QEN>F^,5dgUiݵm:cw8$߁| `857^n6z# ہ{qf1J!ޗoJ ИP3qY j<ŽHc+iQ7~)~OT؃ 4RO? ۖ,XA0CP?y Np֬X#p<,VE̸xgr\|h8pFJwgnEA _UR^qJSL>%Z+Ni kyt3UҼ+nyy5ձY}ϐ5gt !de,F!L"i2Z#P'Q2 "u>I5>-$.VI6ZkZVIevU k\ah)VUK\5Kjl^HZQ:V%vVAՒ)՞[.eތ@imN4 Q^E)=,&:L ~ADt8F4=i/tې/(0Xá!isR"IIƞ͎{|ꁾ)L,n.M( ;1c ?+~#_>]JDX&pe#p02Ս fJ6d{y("- yuNmMfβ6Y)Ef8vH4g!3G"a/p38 gR麭f!дnY 45f\xi9r4C K- 6#iuN1N׶u Km>1pj3dd SVވ16&T8 "24NT%8`Hx"8LTJ2.0Zu{sn?;bx_ gc8Ǡ=bڠ/ayZ#K5j8.p:?Z:>Btrքi(/A@43^[p8J]nuk׍<7SEqvt.:4;qc`j%P/ؐ[lBcx3eT"p o=Xѻ0G?@*uT#6*9&8E͈&F2ð1½Ќx 4=B෸qĿ!~ -o[ Ďsep00 ~"?' /s'"0!ֲw]vq;B9ζU=I* dc0vbǚ= Cf7"OY4۴s~;j;!Gxcl#3d?pYxGl2T-ejXduu"9MBZ}x-'AA=HE8Dn~//HT!D"(Lk3&^Rg.G=CB ^fhj&}W?v^>/0B>Sߥ?ꠕoc>!azV]dYkU,6Lp1&AbhZ ,*mOj $PI b4tA+`aX~heheQG=' .R^T,,T;E5xH] Z;[CĒ.c̗~u}䨾. ~.F~*~C$l.LTnz!zaʬ:F[d:{N͸2cCb` Dەb@lFk%5ۅĨalQ!qH!d, c6]±p>A?_kk;#a{V3 +_F wScߟ{|[xP,7?;/B`ͲhZ8>*2xS.F=J*tQaN(~ikn Q;hܒp@'(ԌV"XXZ `/ꫨ[c3cV0o5|Бj]_@ͅUff5堪I-`ҥQiX-TXi"Nw0M+"eǑO/S%^ԒC se{ysCM=sC!d;Ȱ1vPEE[qLـ*3<Z?| gIpz6{\c  Bc!R'ѯ W6}hח_x/r t7U~ޢ}J'i 1ℓLϴӋ+$ ^c0h ; &ɂ4 ӉpQ@f"Ovg(ȭ$ENp)3Aafv_$~}3;=I?*qS+3]l &H.H%!ME)%1Eqh㵩ڕh}X٣PQժ@ \@BLv 5FfKdd]=IfNEv),YbK.0ęĹ"|msQ cb^afY?3(),\,Ȉ;9⪰kѿh$3О)֘F`fRMsJzʝb1[RBjiV)# M`ln{kmIAQvm~%FU+X= hXFkְ8O1,B%Ş·A񘜢h<2}gݴ֣Y7^MM_xU &}Gzf^5/pkMouuN"=i&=.LQ tgpOG}#in%8\7 >0]РA dFmbfZwaKTS{'C(`Ncn-I+PA@1w?Xo_6S<ܻ{_c{ӗPADלttQb3IWVJǔViNFrS9^nvk*^aWI:,ry%!DFAQХ~ P)'0eg GgΒe/wCqv?-@68Cg+ͭ;v޴§}bwzʝ®y3P^dǑnr,(9Nz c>9]QmM1ezL^X&898]-m26 v1ʠDZ,5J1'88/w[l}}.$䮲bnV#SiB48_ `5rEhH0yFZFvA[0]=4;1ؠ =>2uy% Tֶ`fKm}jMlY-gHBd0#d- X948QMvT;Rj6É*䬷X5deTrRG_w`@Y^tFyStf@%G Ѿ+f]϶%}5Ќ!x̴4:' `fb圛sq9b6E lݗ*e4mXCu:LN-TɬZ%Hڇ+{`R 7՟/$2@3Dݷ{/v?yտ;o,[om֟zM@ yjz>:V7D,Oɨ- H7!qMnʣY_t@> SO?L}4j~ #ү$)2/_)ә!sQas8W8B\LAt Ye(.HEa0z+eq¬sDӬ!rFl*73טk{o?1K<$fK,HT%{WaC]sC+ Ɲ6bkFxA.̈hkCE0) o-I@/*>o(§7qA'qh?Mu8<ToAP(PaBB-O.*/J8{%0)Ca=ES{b^$ebE':ԝQvB/X~6F7A'׋ϟ&cT-JW?"'0?BOATH؆!oqԂ~m=dbx ̀Id(\9}!z Q,ixL أxop ׷(RzW/r|dܷvL/塖endstream endobj 23 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceGray /DecodeParms << /Columns 316 /Predictor 15 >> /Filter /FlateDecode /Height 236 /Subtype /Image /Width 316 /Length 566 >> stream x+ }S_ZTG틏ݗ~.1\8ymƛK}M@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@7cq xeo.<_<o,Jendstream endobj 24 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 316 /Predictor 15 >> /Filter /FlateDecode /Height 236 /SMask 23 0 R /Subtype /Image /Width 316 /Length 1620 >> stream xnZQ7 AyJpk4t# nTw߿>D -4#ZhFЌhB3fD ͈-4#ZhFЌhB3fD ͈-4#ZhFЌhB3fD ͈-4#ZhFЌhB3fD ͈-4#ZhFЌhB3fD ͈-4#ZhFЌhB3f)ɍvk p8Io1G;}xxpGiF{z|۷FD{5OOO5>|~Acu'ڂv1O0D7>m-D;F|KD[p юJCrii:vnWw5;_NgTg<|yռvy=~dv\dz¼,'Fg|BNN֏E}>/_h n*QȘ' 2,/رTphHW!4,W6m.hT7m3 gsyU2Z'?8-xѮL?ޅZ6^^!nYsRzrj}k3uXo^&іN./$uy2t2>;K۳IVю9xvw4֢=>=˷_[>i58ol߲#OW…'gggr/|r'iDph DK-- D[ Z@$mhI ђ@7F<N$mhI ״$pM[ Z@$mhI ђ@%h DK-- D[ Z@$mhI ђ@%h DK-- D[ Z@$mhI ђ@%h DK-- D[ Z@$mhI ђ@%h DK-- D[ Z@$mhI ђ@%h DK-- D[ Z@$mhI ђ@%h DK-- D[ Z@$mhI ڂ9nEֈh<-pMK״%h DK-- D[ Z@$mhI ђ@%h DK-- D[ Z@$mhI ђ@%h DK-- D[ Z@$mhI ђ@%h DK-- D[ Z@$mhI ђ@%h DK-- D[ Z@$mhI ђ@%h DK-- D[ Z@$mhI ђ@%h DK-- D[ Z`v{rEsx<5st{svb煴Fri$F \ ZhFЌhB3fD ͈-4#ZhFЌhB3fD ͈-4#ZhFЌhB3fD ͈-4#ZhFЌhB3fD ͈-4#ZhFЌhB3fD ͈-4#ZhFЌhB3fD ͈P8endstream endobj 25 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceGray /DecodeParms << /Columns 364 /Predictor 15 >> /Filter /FlateDecode /Height 345 /Subtype /Image /Width 364 /Length 826 >> stream x1nDԾ\9Gʋ03Jw!sD!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;4}_?5\ccq ۶7p!;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb*bcq eo.<_<6o;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cbexendstream endobj 26 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 364 /Predictor 15 >> /Filter /FlateDecode /Height 345 /SMask 25 0 R /Subtype /Image /Width 364 /Length 5618 >> stream xYsatWf\̒ʌ*S[=$~B??[ D DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DL!DLbCjm!ϧw!DF,!Rׯ_g p%Gf/"g p矫YBdrY>`uh]<B$Bd_7V?Bsu#?,!h!4Z|Y߰w SȳgF UH£HY(_[_vieњ6σΒ;;KzU[({[w} _o#?)|K!"5r"3]-t6w}G eѻ'4r  A_r0Dr<Ib[{"D3DJϺri ڹt߲\;ʲ߈ rTK;}^Yп@Uk=v}BY]6;m{TC܄~!h!Rr\_G X-- 7z.U5{BN ܚt9!r_xWWi˽Gfzeuwj>ߢ,ԧB !r.BdsEv{c,hfslfv"@w2>4AC:-V?AOayfw-ag0(umzufdKUesb*xz]YZg[uw~/ \S&" iu_N+ cY17>RWl0D1p}qB$a$DL3(Dj2p&"ꅆg"x1dD7L7^E&~ D`6zODπ7VoDʽTR&D:~H" AH籅4703m&{<+7/gzSIuOgac?HBM_'۠Ѽ{p􎶾LO%:%UwkFas*I!CY4ԑN%ת2<Z" ǪkatZʑxlPG:=~Jm" :Dz䚕x7{!.SԵFjAI!s ?έ,3S IK01cV! 3De8?v6՗JA$7o3~&bcG@L)H=W6댔ȆH|ݍ扌FIkJʎ_g9 " A?QEV˸sO1B$xG$"G$"G$"G$"G$"9}hH‰!!+0a[H‰!b#;!,&Ej) ߡK:ŊLM QМPJwgjL맫^Ytđ{ћ 7;dmm}l_ewN0TQeY}3 9! +1 Ϭf)VTЍ{њe!|G])(| Zpfc-DIW.q+T2ؔ3^[.3wLC+nj{^%KXP#" AQjuIG6B|&i2I 7Wc2ۋ>G<':!:)eM`3tj ?zj>ꅆg"fukeaLLx53)hS" DV g ԛ*8 n@x#7VS}^1$iHYw՗q$!0tFTvf %hلԕ3Ѭ^ٔq~&_E!rHH?>#u\/}`˽#i/L3 W &IlF8NA$\myF#tHˆH|I`DHBB$=="@$,!|H!xHD{" " #!yB*ٶT.\$Mp)H!bba&\!02yQ@;IѼa"|uYO++ DL~އ>3c{fj"T$B$"K=]GﬤGI%z>! "D3zv{}B_T>˲~7! Dz7V)C"3}B{!Dz7VWCwO1TrcD$ >)/M4(͏g<5" AԆ[?-" ;I8e/pqHI DI DI nm^" 7YpBoHHg3>p"n//^D#< Df֗#DxHI" " " H0f 7h!B$aѽ{<QE$<- A[#uV9B$7wY֓7s]ڌ3My0i|V_6}x 8XN1#FB",!9B$?$_<"r]q!R7R}!! ]HJ-P4TYQ>FȲ\ʲ!" S曣[H쏄$B$wcU>) >8W_^^#tIX!|U,eo3s'SW-"Xs" pB$a1!BA#ICO5gɫM"?o\M pB$!- 꺪3E)mF8 ! ^!"QetXF!#F8 ! " j%!BA#IX f&E=*DesBI<)KH|Y;BF8!0xOĿk%=s_EA#I錸69Rh&DF8!w{z벩 $Ռ*Q D67SB$"x"<|E$lU jF'HDI DIxP D."1%upDCfXJ\gQ]upA Di4U(EjH8l'"6陊!(2#h{=Y_^^SHWpH_  F$!j+e-D(8  !"QGsnK8%h"DpB$adoEۤOV!,sD+8DHDM+87VC$Bd9+|ĻSf1B$auSY%C9z+8Dg3" AέBw܀IUw"z *B$!(@c"D'xH!xH EG"I(Cu)_" 7%:+p,B$!UHZ~zW˛K'l WM"#DREޠ;?pFTzw:B"lI;ӬcGu\&:p0D(_AH`)f 5 s$^M !B"I,J\ggw e!DI$D }KRg"up B$a&DEL6A{Dg)_+ DfBŴ7nշ=aHBLjkҦa}.қ|A$wlW> /Filter /FlateDecode /Height 316 /Subtype /Image /Width 364 /Length 764 >> stream x1nDԾ\9Gʋ03Jw!sD!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;4}_?5\ccq ۶7p!;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vHP{]%=cǾ/xsI.y!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vd[endstream endobj 28 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 364 /Predictor 15 >> /Filter /FlateDecode /Height 316 /SMask 27 0 R /Subtype /Image /Width 364 /Length 4732 >> stream xnQvvb\L!C~Yb`Y/7f0ED)"L`SD""0ED)"L`SD""0ED)"L`SD""0ED)"L`SD""0ED)"L`SD""0ED)"L`SD""#F~"qm=nD~tex{{W=罗uكF?G9:+"W#rozrק%"_-~74]t=MH#EdY/ҮWHz2q2"W@{"HYoH` _e]w7M r;(ZY__D$@D%""- hH@KDW'"'-DDZ"pLjsSZ;LDv,rt;CEZoCDlT)FJ͸;ɐ^glێ3)kΔT''0qe"PE\s7~Z6 P\Wo$|q=fj/5l~5܀< i檘H~atJ qX.y=|t 6e͈bv=!m8ߢ(O(>"X \eLLe a9LZLS g !"_g_dHvLO ^z׭Ҏݢ8GD$?ysJj{~ H i%R`~Zڱ%I$i|uƔT[.ޛAD6[2B>r h];VD{I[MUYe5^˥H "s"ŏlCGcmDtt&?y̞VmN3^MHy"3Q7RzqlL?uS:OdUn)ܜYk_WINHD$ E$MDDD'H#'""- }Dz;FD1"z"b{6"ӮR1DP̱=5r Jܜg<H|~ D :0 (#mp!\/2Dw'"eDB<Oy]6(hpmOCD$`3"+L{;mW[?j"IDB["HB ~>7 jD.? ؿOd.7?v v@ AĥH3hAq}p;sp e]lnID'>sF hͣ6 D$h#FDܑ0" CqG"pH@KD#sG"0Wߣ)"MDf"rtw_<. lVyvV5N͓vV|w08cUa' /iGXҗi#+hc)WW' \^Dz"R>Xfg6#RzD$7@z;KBjW7-r@@y)Iڼ@YADc<ϑWӎ#rn9OFDl16-u{ #bK سOdazΞ>\v$ #"3?NDd쉈3$"'%Jy2ufiw牤X(_=z_0&".D$@D%""- hH@KDDZ" "D$@D%""- hH@KDDZ" "D$@D%"KD~$"-y{{YADDZ"` hH\|'sGqp"'"/3BDnjj\8 89ﲍF߻ԶzxbWN`D$H5ov^՗Ti/7.M"8D$HӲF )?UE$]z \"_1m8z[%k>j"‘Hי5J ]p"۱Zn2#)ADEDz;VOFOd=P~<:ޭyt&F꘮C "Wީ~f| "p H]u'"D$@D%"3kG%"gGA{D$`fⱉH@i.᱉H@/"xHEm2\#^DOpMFzEĎU v///&97 "R1akl!8Z"ΓP'w!"9":קEw[:վqբcy"pљAFpIXEqK3&JC57χ{gVl3Rݮ~fD$"jrmsY"I.D$PD$1._\;"%+kOa\"" 89(Qhq>D$`pjyqVD$7wzD%[2"巀|=~<qxx"vqVD$-D$}"+D$`pt\Kķ""ՖH*PɸD|'"0:SEdC8 ADV;+p$q9"g-܇OZ" "GĘF܅<"4.D$1'"љux' Zɳ]1 "~}"m0VОy|ӈ6"?ZWf%-㱂zϗ#bL#nOD6#>Sŵ' fWcq"u&}^i\]\[t}<'cq'"'"(+9yfȌiĵHYn/Q(VhFc47$"ѯ3w> /Filter /FlateDecode /Height 311 /Subtype /Image /Width 364 /Length 753 >> stream x1nDԾ\9Gʋ03Jw!sD!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;4}_?5\ccq ۶7p!;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cbo.y<}YƛK:p1;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Ck\Vendstream endobj 30 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 364 /Predictor 15 >> /Filter /FlateDecode /Height 311 /SMask 29 0 R /Subtype /Image /Width 364 /Length 4774 >> stream xn6an"y/m"ĄCxL[XȪ,)Au"Qǟ?!`!` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !` !`CǏ{p\Gf"OOO{ pHN8shACׯ_/>(Nߣ]ȞϮ_ Z{Ck"D"˿z.5~̓H>D?,BDP!\˃nI}z9Y"@*DBIc3np}PyZ,Y2#W@a>}XoF3DM7`7.&X6!xY}{{[\R">%1vRE=H" dk B$/[{U^ey9^b\w %BD!d\"ky~'i8Du[mzX== eeWV(~Iww"j.WJ!/![MwJ"D$"yjΌgE  Aj&qcbu9vXw"eDvD>7Ž\˽W!(÷mZD2Bd_ȞCF~cNELdnueCjXm !'߉Uagdu9c/;iR?IBd_wSK"B9Azg!" D"G#D"BDq"Bm"Gm2HHpPy)!R]A) \*)(ܛ nЛﮪ՜wNl4C$ُuRi56PJfjqY.,G/Eۃ3>ɟJTd)G?`s(;$AA3׵3?˚?+OϲMqB{8OʌS9Ҝ,]\!" ?5IRDfiN$yHᝈ=rꝈ?7dQ9:q= fH j]i S(!IDUG ڛ]" DRE4w7_&|\Lٸ8ӛMO7+~;OCDOêCG1m(Mʟ~!"8MC:P?݄DէRC!" Dl"' q"CD8,BDcT#;]%S"s,u*άev J!"=V;WD1xvD "J!"!" E , JQhw4({%;֮ c^(AD ]"fT'#_NRi =o(Ak"DҝȲVG3o _R^jv8*DBD0v&,ʠ93x\ -"~"~er}F5̚om(A-" 6D(A"H^vD""BA"=G렫!"BdhkAW3F{EfBR{HƯ3d䠄"DAg3{]5{gU%vR6O!.K߻o^Oש-T U#?n!"a2:Fz1R+GFFЮV3jvg2XW!*6UWuoM#Df=!k*8iV!"Cu} DRLnșTVÏ| Bj=\AWNG\짙\RRM4>"(Qmb&Dzm1UDŴCrl)RnS}y=!D#w"yyDqm{Ժ{n;:&";LGFD^mAfGNmewLq*Db?^m"~u x;+zuw6jV_zw" yzqjQԯcǙ`ڪl(jjCRFCxGrYx}}mΏۼ+SDIY Dpd8#މJ|ۗo"8BDkX qD=!Bz !kɽ?l w4ۙ ۙҌJNW8&BDH{]?z_n!"~q|`Q "J!" D"GfB +BDpvw"t}#D#zj ""n/2BD0"Rw"oTu!\]"DA,Kz!B* !"VK2$^"Y2Gj "!"`"J!" D"G")4UC^++JWE,BD07/ת^'iGzze; ]fM_ZQR 9uLv+e>y`d.^ߴ>o+[#!܉ S8})gH$\!"BJΔy0DL{B$zA/Dl!+D@Cp&ӼY___3T^GRAq?tvB$^gB`!"5ڰw"yKƹn>C.Aa拲2o6;"4b!"8LȈyuGP%Ze'qBΘ*~+9n~=ՖUfj!G.& E#DpQRG#D"kupCDESFP%J_A]"<BDX}ϩKBzzc)MD]"<BD`C>,{5"f "3D6%½"Dgd%#D{STw"䂽uHA8SHl"t{" D=Dp9`P~gPO!x!BM#giR9LBDRE3 z\W5=BDp#;,BD@s dAB8BD@!" D5V{j;ئh*BDlZu--  ;"#OX‰ "j@QЋu~,i=o'=S#DޫE^Oַ#o]Ѝ #%"A!jZlPp\U˵"I{RgJ .&YɻT.'B"BDH "8!"FHY?za=@ 3]++jx#DSFؾvΪԪ9ԛgCt6W ڷVqBD + DU (ņE'x> /Filter /FlateDecode /Height 204 /Subtype /Image /Width 364 /Length 526 >> stream x1nDԾ\9Gʋ03Jw!sD!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;4}_?5\ccq ۶7p!;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vHP{]%=cǾ/xsI.y!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vH!Cb;$vCAendstream endobj 32 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 364 /Predictor 15 >> /Filter /FlateDecode /Height 204 /SMask 31 0 R /Subtype /Image /Width 364 /Length 1513 >> stream xێHQw?(}! c5%0m."w(#}6:DhEDZDhEDZDhEDZDhEDZDhEDZDhEDZDhEDZDhEDZDhEDZDhEDZDhEDZDhED#Fwhs9Nr\ID^bR8#G۷oQ<=欈ϟ~~͛7޽_AǸ!ǛKӉH@DK3?~y^;>Nn>C,,ǫ#DDd4WGQ'ozе,=%"77a i6z&q^5܌fuDz]dzqDg潚 >Xm;C[H@D_no{syE"aL˙e}1=OFd}!΅%"^DֹYsM^""_$7¾dp{fy{ei^̝ՑID""2l +?ٻ Yٍ4"ID""2%GkoF~}gw~?&|ɛǒ>%"JD"D* T"D$ "PH@D@%";TOD$ "PH5\ T"D$ "PH@D@%"JD"D* T"D$ "PH@D@%"JD"D* T"D$ "PH@D@%"JD"D* T"D$ "PH@D@%"JD"D* T"D$ "PH`t:"\r^6gE "D$TD* T"D$ "PH@D@%"JD"D* T"D$ "PH@D@%"JD"D* T"D$ "PH@D@%"JD"D* T"D$ "PH@D@%"JD"D* T"D$ "PH@Dt>E zm4"ґ8 q#t9{ĈZDhEDZDhEDZDhEDZDhEDZDhEDZDhEDZDhEDZDhEDZDhEDZDhEDZDhEDZDh endstream endobj 33 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceGray /DecodeParms << /Columns 348 /Predictor 15 >> /Filter /FlateDecode /Height 260 /Subtype /Image /Width 348 /Length 644 >> stream x!EQT_\&Ӝ_r72>pe 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐyDz?|o.u\5qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7$nHܐ!qC 7o.u> /Filter /FlateDecode /Height 260 /SMask 33 0 R /Subtype /Image /Width 348 /Length 4349 >> stream xr&@YɃ?~$.'*S z.p#f͑ĥ/~  @ Ё)@RH:t @ Ё)@RH:t @ Ё)@RH:t @ Ё)@RH:t @ Ё)@RH:t @ Ё)@RH:Q ?~uJu)̰Iuooo T ?|uo?AL?-}>9*Z&3gl._{ڵ<$H!CJa_U+= o2uʖ)$xT)ld{L5`KU -CkWdNIA-p')$xT) ~A>x&m-g$U-|vtDVZCQokjqK{ Bme9D{nw4!۳B+Kwע2o}}}}mo!<ly~~7%ڦڶzAMJA;<*{iRHR3jWO%_rkU[!BKO Sy`=:էRՎ>K{ Be`_sx{c-m#,>}c)jce}B)$xT)M5w0/zRhyZ~ۧzvg*^Z q )Dt'7yrރ" IݦV&FCy~.`}H!Kxs.2`g&/2g 0}7)y1 sj|wr+i2g1ӟկl5Ӝw5)R H!R@ RH`B+ X) HV)$ 3ќA H!R@ SO!R@ r=dPvr ɲ\#84\@IA)mStsA:& Q*dYY?p3$H!BmB&>RD%&@l,R>J("A RPJ+.c4txZYA{T6Sː-Jޢ´5@ FFho7AM soF6qG[<6SR&RH);mC%nBu@s,u!6].W 'oJ}uRDej{0RhaCHA7PZ5Md.)d/$IJ X"BᶱORsT `W %{L6 R RHZ2w"bh()@ RHOʄd?/V)$HI>H!AR(IJl'5bF+37})$Tnd~A>@ A 9$It@ X+ X) HV)$@ H!@ կJ|?{lŎGL$G߲H!@ ݝ-np;)uy/"5w)$K´x;ǵtJݽTb=Dϭ\BJ X㻃>)Y#Z^]Z =Kc$%R] Rߺ;\tOңUI Kfu!R)$}-U+-.pstZ[FG)$> "ۀ X>X X`F pNt8`F ;$ DW)$8X *Z@ V 6ʈ})"J잹 RH`#/MnVR7Le\hT[()煙(i*BaK8 KJ/wzZAHِRH> B~Uu z QGcB  hܕBԧtmխHG#RH09PRbtdH)$H5f-SC7)$8~AӜxBdA RHiX) HV)$¥zQ2%QшI;|ζrW:e RԼC raĆ:!*&$*L/0|sH!0sRcO-Q.֌րɓȆZrވz`㩔aSne)|C6|,rF[e")Dw 8zyWKj_v18'R)$p_iGie}O;L) stgKAUBM@ RhzUPO D0j3O E R@ g\OAO>Hț 2$.C-sj))իѐz8X 3CT}݁3܁CR>D R<)$IqVܔ6R>[>NCn=sY;)t71va qVjg>A F!H!zR(nt*Y!ʷ)$>xTLs>` dF WQgn].RH@<X) HV)$@ H!R@ RHI)Jazuۇ{k+E6xR)@RH:t @ Ё)@RH:t @ Ё)@RH:t @ Ё)@RH:t @ Ё)@RH:t @ Ё)@RH:t cR3endstream endobj 35 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceGray /DecodeParms << /Columns 316 /Predictor 15 >> /Filter /FlateDecode /Height 328 /Subtype /Image /Width 316 /Length 750 >> stream x+ }S_ZTG틏ݗ~.1\8ymƛK}M@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@7cq xeo.<_<o&Ͷgendstream endobj 36 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 316 /Predictor 15 >> /Filter /FlateDecode /Height 328 /SMask 35 0 R /Subtype /Image /Width 316 /Length 5090 >> stream xr.g ?uI\aeb$` % %i@Z` -@0 H  i@Z` -@0 H  i@Z` -@0 H  i@Z` -@0 H  i@Z` -@0 H  i@Z` -@0 H  ƌC?92///g ?\w={mc .߿m1y7~^nii7f7/.B+{ӞJ>1WVK]/y1<4lZ]俺eBJ]Z~ r'_ "m:6N£v*i -:@Zu0Hia Fc08H 3fipM 35@Z'JIǽ^.c?zsN7ͅ!Л;M-:x*iorxzDByuPI smVؑޗҐ*0FoÂjY^[K1giT@OVwWɁVGNUPlU_9iy09sFv1H@K;13\QmXfVnC72:hJ{+__و<[+hߝJbS{מ'͑?~u WG~gCZ0DS1r6BO$Г|^a5^VK*\g#dYc} N“R:u0!Ԛ:m#t~sjۯi!t]Q4AP7i~،K.j !u^CmK[@Zvʧ<,R.wWߎ+ dH[Vn{d1.H`Ujgմ27˶5mYゴƯi󲎪ndž״e垴:PZuz Toi{ UiWr]{Օj=.+7O孚/:oi#I :og{)ӎKͻi n^͖?Op !  1i̟gi -:@Zu0Hia"+‰,~|||~~AZH 3 i7HgI@Z#n"Q`ʠ :Ҏ\ٞYrU&3HUm_jJ۫ie`z Qi夏r)=p! AZ[~̝ dց!ms1ys:W@up|`nAZ| @: 3fi -:GZ.Ma+ nۭ-H`s~,;l :%꾍t!mAZ=i@׊ց{@Z=iO0+*-x(= iu2iHi/bE)mR& Ceyׯ_{Ӟ4D !*} '1^q:GHb,;l:#: 03 @ZH 3vH ^ sum3{");:H[>ypr= i {$&ӅW/9)AQ6c=+"H`d.}iͥ M_H,DJ{1ѵt9B:X >]w,t#Or+HCipM!c 9xuPմIx(IaOցqz\IksznAZAN6 :gi@ZH 3q~~bWu'T'@< j0u`K'y,s뉂Q/`ց!m󒲲.FI'e涚83nAO^=^of=40]qEy@Z=iS?ndЫL_37_ÃV5z=4[Ik/W `MNMɸV i~ ?$H`V?v=Ejm*Giz#{Mu`wcԡ\e@zؼ'@$ =&v:o&qN68uU4<: O 3fiL.-9'iL.m3C@ZKK@Z:͕úuo.LVf3U)gx6ց-(%ݓ = .W%miJߩ}7cLep9$!@Z#S]9 f+iWN:8-XG =iu!- Q\Sl:J֛rg6ցѹ"!{Hau:WL:01snn!@ZQV #Ǘi@ZH 3nqi?f#nυ\!ʗ*yZnjt|Dց+/tԙz?$H`q3_^y/ifߝ<Љ h^oB;#W.ФwGAZ!rQCl# MhulIsH{"HiSݨwM[%. {SKf߽)-|i+@<)Cu\q H`nZ!yK7S@Z{.#@ZD3@: O 3fi -:@Zu0Hia"+‰,~|||~~Ȥ.g > /Filter /FlateDecode /Height 294 /Subtype /Image /Width 316 /Length 682 >> stream x+ }S_ZTG틏ݗ~.1\8ymƛK}M@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@7cq xeo.<_<o+PEendstream endobj 38 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 316 /Predictor 15 >> /Filter /FlateDecode /Height 294 /SMask 37 0 R /Subtype /Image /Width 316 /Length 3944 >> stream xrۺFj UrYFFG)adu %?|!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Z!Zˣ_52oOOOϏ~-8?׈vm(ѯu\B52i߾}{yׂl^~_ݞtGxs"Z1]/%֓^ZxdeωhvgP~YH['hO%Za "4r8/cuzPZ8啭W*YX9X./"{ mQ>G޸\n2Ng]K9%fooo<\z#D+8L;ՠJ|q[}oI3?qyEaÛ=6,pH2k|S.z,6}D F]RX#Z JW4F흪~:qn|8&p!}K8tvOqRf[}%B8Mh6'HՏ/}|zVwuW@*y%6ǹm*D+8^V!l\>i7J@cD[};ߚ\^ieϘޥJt;#ZxG V@ 3 ZbD+ Z̀hDh1#fpa5qDh133h1t :ѶY\ki]S!Z-n-U huBul1[n։n5 hHEշ%yGݺRD{D+H"F ڊw0mFiܘ! 6]d9ZV7Y#oѾ4Ej/(U-ǝoc"D+҆+ǗjKkV06\./Ǔdny|= tg硉WZ;T+ ZA{Z|vOz},j0Vf@ V@ 3 ZbD+ Z̀hDh1*fpa qDh133h1D, Fvl/ޓ#ZFdeޜ VZjB<%c#Gr32M.gnڿў Z;Z냗Ѷ6hG֎h[iRf#  [M.w<|僀hhcH^[܅+PE p#JD+xȔ<̀hDh1-M\-;!\-_b[D+9Yvlhic9"ZA+l` /eX ZA+O0$F'D ZHd<[Zlhid4Z+&#&VЉvtjKeGnDΎ(x3lzW> +WX|LYvlhƈ̀haD+ Z̀hD`h;C ?/m=%bokD+{m;Bނ#Zq28a%+?;&>uK`?V-wV9"*-?,phF{J  :+WAyGMwhSчaoooކ}1鄑zaU7Wǩ;'ZVPyΤ_._ B+6#\8>;ў L+YޥQ-nY7l 5ZvDCKLTzm/{a+ҏ|"ZA4+z.\~k_VUC`lٽ̺C,ھVwqkD+a{xgD+gB V@ v x "Z2AD+ep x܎hCLV0 h/I!LcD+hE xhշIߙވV3AͶ`jП іZ#0&?HH_ 3FNՏYuV;:*m-f3AV[rP%9^'ӎ0CD+hEkwгfGWeVmg'PCf*mmrhh[pMִ:gk[heV02{Lj}5f菎h=S1ChD+Xξ Bs0=3'A=iSȗw?7?ã5h[q y܂hbD+ Z̀hGI`h3: 揖93 ZA3+;_9H}>4:>>Q;D+Ƙ͸[qR3_>r 9#ZA|$}D}O#hV;[/oZ'GΔOuNzFXamhh#׍V'gݑe⽘?0\ry0[iu;ƣ}aЈV=.1[ sE|v^5&5Й?3LrDGj9V@khV0I89-f@ VP=^}[g t|ZnuPufo\C㳗x*D+LrpةZ wRʎ+<@8#_crlVzcysIF߀{McgC~<@hka=}evq#Fk>Gupˀ;Ѻ@)gΨlO]lD;=ǿo-;A)Vw+ܫlVjz,QFf[km+&Ga [;+a.30  :yyZ̀hD!c\VpUGy?\1収h=1=<.z\]H[b\#HCΉ޳-I%=`I|ƸD+<VX]qi`p4[q:y{_>>.Vۏq"Z|5Nm:5FBMN^=omKoL˸Qh['zO[>2.ND+%wzGD60kng7~S޷qc#Zއ1տ3LrC`j=<a4|LyZ̀hDh1-f@ V@ hϟȤ.nZp^l-01ZD 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8C3D 8?" endstream endobj 39 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceGray /DecodeParms << /Columns 396 /Predictor 15 >> /Filter /FlateDecode /Height 226 /Subtype /Image /Width 396 /Length 601 >> stream x!nDc>3|㋌_!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b2\ ~C.158ymƛ[}2b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"FoXxsK.12y~y .#F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b"F!b|Kendstream endobj 40 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 396 /Predictor 15 >> /Filter /FlateDecode /Height 226 /SMask 39 0 R /Subtype /Image /Width 396 /Length 3652 >> stream xr:a%9\dA92=:RQ.! n=7@T)RB#FH! 4B @h)RB#FH! 4B @h)RB#FH! 4B @h)RB#FH! 4B @h)RB#FH! 4B @h)RB#FH! 4B @hCMWLROOOn p/!5b Pn p/^__sNE˄!^h@Haů_#|۷o2}v`!]ߗebɩ\L@H9RqӨM9d`2!@HőS)}\-?ljCJ^5c|ɝBʁZTS9~Q"F.N s˿ )B*|&_^Re%| !@HQ%?Xu_^`<ҿӮÕەZ)B*kZ&^^^R!UBgY, OS05p-!5O{^p1_ʕ9UZBG@H9RATg:|>E˓ 5z=ݽ )B**ڻ{UBzRT_'+T;}År )B r )B r )B r )B r``>Fq )B rO >)B rR#ߪoJ;q&!E%GH9 6'n%1!ІTU?J\_()Y+gM~#UɁ충ǡ]F= #;eNrBZOr5 7Pfk$?ҽ#ur|76}RةBʡ}!Ϸ/ԻWm[p+) !u`'Tꦁs 6|:M )R AH9!V[fVz.J|1BjnaGrB'eOIS$p)` GH9R|!GH9R|!GH9l[uC=B:p+= 38_uRFH >̩~vCUv b/ڏ~eDH9!2?2"ߧ񑋴SW-.~0o"ud;EH9 I.ˏTocR|,\}Jjr^>ymM+Þ*Jjr,bҞ,_gCej+rwdPe$EH9Rm"!UV/<"OڋG3pQAf?.CHr){ #9)܄92xr[TTԑzv"10!@HR0!@HR0!@;`>B>IEH9gHq"VJ%[RUd$[RvH%(zlCH9TjJʵ(zRE-.]*gRyw81B.zw>)[4)WHw(z "Vk,eE?BaQ)B rXZLz8!@=)`>Bʁ#)`>Bʁ#)`>Ba ǧ'B fIh@H!@HRI'@HRTnWf󢃧y46LV  T.QDMјvӎɴanLDn})P!=NZJmi*U*cFB-@H9E䈘ƨrf2CJ]:guNu/Vnj*jΪ$=db 1Qwdѐ+l_U+֫:%eD̴6jfY)C9;y7'?vWI펗~eXT¨|QeV5r@W[ə:QZQmHmΨ#UCozNW$n{?6oV\%:s՘A!5hTcvH٫2gsH͎٪ufح-qGH9!>\53i?7Υbꏣe$Nw>Qz":Xk%Sѷ; jWN3ܫn$1b$F%1>ZLUXY쳷=`Ysoh+hG9iiҺ#ݩWdE v vCΤVTnIԏe>On gRƁJ[Ϥ&ϷG .=QgR#+gR%a1~!}R>1;]9,.6#"wpҦ>)CأNvVz@d߳wHGoӀNT }Bj#RջWaW|wmF2nH& ݳof^y]h7Ȟ{ Nk_&긶)* b 'Q3\I{|<.iC_->b?1>nz~*ucQG#9){Z= a?E=>k\ݙHH9lx|CWQ9O6|-Wvv(nH tk1!6!OxC*O#K;d_BaCHyӟtzI~Ț )IR0!@HR0!@HR0!{|7n ߜSn p/rB-2!nHh1 FH! 4B @h)RB#FH! 4B @h)RB#FH! 4B @h)RB#FH! 4B @h)RB#FH! 4B @h)RB#FH! 4B @h)(endstream endobj 41 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceGray /DecodeParms << /Columns 316 /Predictor 15 >> /Filter /FlateDecode /Height 138 /Subtype /Image /Width 316 /Length 398 >> stream x;nA@AHMcx[ 'zykZOwnsBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB?^v}k]zNk׺yWKz/W=xAn^WzӃӔ13.1////////////////////////t}s\8*p0endstream endobj 42 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 316 /Predictor 15 >> /Filter /FlateDecode /Height 138 /SMask 41 0 R /Subtype /Image /Width 316 /Length 1464 >> stream xN:Ea ЋJ/A,,,߇A`2 TJj7遵q Z@ bC- h1D !Z@ bC- h1D !Z@ bC- h1D !Z@ bC- h1D !Z@ bC- h1D !Z@ bC- h1D 10z C&Lmh,炛.OXAäцbf].O7|;a5F{4z.Y>hGhWt򗅺%ZQ!ZU٣}~~W><< WFbsцL٣MW6n у$Tu{t0[vit{ ц'z _c?}qxe->loc&Y1թgIJ Ü4. 3Tޑd6VkqiL#U;V2HQ8o~sϙ]r+7kOo)cqAVjmVq8|:4]tK_r?Fv܉s?6.,XE[;V±xDkm-8Z[6Utơj PK_N'S[O#C:`v@fӮh>k/{Մ+>>>t{}8\xq|Qc|Z`Ǐ=,]8T87wE/L'XO 8c 3Ωymm4sMyZבW|G63/9'hlwxr|<׳?Ȍs} W;δq+lWaˊ<Q>cmMq ϴݗÉ6fso|5m5RIѮ*O4KaR2ֺrMo젙yM'<mL[|B*d|c }bT*̹qc)̷6Fc k 'IӺ懄':r>љyGj4Ԙ쮩v|j``'=؁hnB}vr6mpDۇh1!Z G}mpDۇh1!Z G}mpDۇh1!Z G}mpDۇh1!Z G}mx\h1ʅXy=QXd-0pNC- h1D !Z@ bC- h1D !Z@ bC- h1D !Z@ bC- h1D !Z@ bC- h1D !Z@ bC- h1D !Z@ bib&tendstream endobj 43 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceGray /DecodeParms << /Columns 412 /Predictor 15 >> /Filter /FlateDecode /Height 186 /Subtype /Image /Width 412 /Length 546 >> stream xݱm@A*5c)VU1c:vx k6Lw[N88N88N88N88N88N88N88N88N88N88N88N8_zǹ}\9|>_}ׁsq7t\޸ց3Q83ԁ318sҁ3c8ڶάN88N88N88N88N88N88N88N88N88N88N88N88N88N88N88N88N88N88-k׺hYcpp 'pp 'pp 'pp 'pp 'pp 'pp 'pp 'pp 'pp 'pp 'pp 'endstream endobj 44 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 412 /Predictor 15 >> /Filter /FlateDecode /Height 186 /SMask 43 0 R /Subtype /Image /Width 412 /Length 4154 >> stream x]s۶@!?zHLz95/)Qs2 M -+YxAj @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j 8^^^?'TDy˗Gׯ߿Z"RFI\.6P'GIǏ6-5Զ7}m[~"!50Rϟ?kg?SW矏>;xjmD^;+^R"n'R{${I 9[YR׷.of6׋ ^b䡂v1źܦn?<?~l߾}kG60y=מRj[wr$(t&V#o߾'&j5h[LSC:ϕO83ǯ=ԴA*,wVМ τpk ۔Y=@j^,6zQ gS(M%5/{i1q@ As_fN_=ujuɫ=c yW)>)% ?ǬQQ gӜLyKbeۥ'h"hZ_`fДQ,ztn6^;@اkGj-F=8=赧[Fjm`0r Z<3'cE*Bj= 1 J87ǜR[C۵,3Iq/f&IM|!ҤY b+l:N2e+]X!ĩ@jk')&]Ojqgy TOa$ 5&prAxsA=5RC E?AurjA}@jko?Ez; 1ڏ8vAe>=Hm&5/\kC}ஙt)Ap3^H)@jk45}Xyҹe%TV135UL3cj]GսMa"V_~M\μpZjAc#μ|qnBxV@f6KdD_8Խ ƎR ޭmܗ-Z?筟y/]-\{y7I\FmǑHuAjkRk!myQfelSnU߬PkN-mx:2+8Hm8=RB^ yU]ʻmI1WP'nEW$GW08"t+~YqDVqf(LWp t#q3t[|e@jkiR!߂9 5c45SԄ{@j'5цfr`h8/܅֛cc+̗{aդ]rAk+E#8b+~̸!8bT!uyIj771u!zxzԛӽw#bEfօ^f4l?zRk vhջDTyL-NZx v_G4Hm Oj^M 8.vC(Qjf o0H2I[֜3Y^nֽh[3d(w7gfqK<~V,D Lo]aTڰY,Ԇ39RKSo.Ej)|b~Q^xG&x)v5.̏ RXZ^>3ksjm썶b"5oZzs3}0Լ7MCx#M^zJ۳9ښy'ULe$bdꍳ֛|3/ Oj\@u7C<ۼy\=^5=bRooNotn'efo~?^t įDS0Ȗzst̃iRuu3닕uKTeûniRCM{aEW c~={9oAjkH$Hm XH VDwNR[#(mzaDz:z>E]6+e-^ 8tUyԆ0`] O:iGԮW7xXL "7W84hf:E@ >l:(m&RLͻoXAjkhQLdl%T;Ϥe&Zt^״7G'CM:dz&3?R[c(5|<^ؤԮ51t3%CV^[@jkR;RgIy9qM0+͉g^(Z^\Tq&A1 5 !rJE9HG7Q L]\'`8ԝ녉UM7΢?fx38R?njÎ 5<]>M?3/ ^&bM4\zD!,ꂨS!e9q z_V/ tx&ow-ݥ&w.^^יSV~SRDx*!#@jkL߶K٤ݥ^!KM4}.fր+R6|{3O=ԎIyNbFXR[#Hhh`"Ӄ֠гcF8'Hm prZh7~Y-1n4Nҋq?wI 7f#Hm y:-Ib2*}xj:di󈎏?b|9 C?'!fDk#62㶁_2-#jzԛzHmˌQ]eFcŅ}ږDZBy/26SkdZl:t^fsRotgIͫ:agC 4'Gr kZl>i=q9#⥳>0 '#<~V, H`F^>POdfVP*R:/Wbc"|0aJ-('ă@_'UH3]cL|_*[d>RoN|917 ƪ3cYFjũu/{Xj33^eM͙7H bΩylO(6m{}K4F[3#5金fάO^[1ښa)ͬ 5f^ olU_=oZlCRo^ftϫ_SOߚU qP-a-G ?{ 8gZPO?ZG3ӘZ+7I[?FK-6'BzsgV*$ó@r>!5xHht_$H AjklR+R8'~3 }zy^{t_m[8@ا79@N'Aj @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j @j 9|endstream endobj 45 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceGray /DecodeParms << /Columns 359 /Predictor 15 >> /Filter /FlateDecode /Height 156 /Subtype /Image /Width 359 /Length 454 >> stream x!r1ZRe-m5^>TtN&M87qnĹs&M87qnĹs&M87qnĹs&M87qnĹs&M87qnĹs&M87qnĹiz=0=|}-cz~?喠9 494yihcBslhsМ;m<޶m3Ĺs&M87qnĹs&M87qnĹs&M87qnĹs&M87qnĹs&M87qn8׳^>g3clĹs&M87qnĹs&M87qnĹs&M87qnĹs&M87qnĹs&M87qnĹs&M87qnxendstream endobj 46 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 359 /Predictor 15 >> /Filter /FlateDecode /Height 156 /SMask 45 0 R /Subtype /Image /Width 359 /Length 2893 >> stream xr6*ɅĮ6mBw8#R$pI_L$ @CjА4 @CjА4 @CjА4 @CjА4 @CjА4 @CjА4 @CjА4 @CjА4 @CjА4 @CjА4 @CjА4 @CjМ15nWGO=a:ij<<۷Gӟ?_e `S׷7ٛ7Gӗ/_s 5#]18H ` ~N<4v!,yie>۫S֟(ޮgOL\Nr6,'S9{f.IB~yg&?|_+f/zz@j,qQ߳kM]"5cS.z9Ы%>2QfhjuJ^nujԗ5'rJ-Sֿ%|e0kmVT4K.Օ|{y:UF RfVZì] 5u5>,.HeX #3k֓,,8eeEMX~!uJcçf7ZQ[9k% 7%i"lE~?k`n{.H-# %ieQE@ƅ4g8PBEaRC2Rcu7Ջä梩a @jhVH ~ѿu_lclU;yw7<!?,JfERjUJ+U~>5sq9.CƧ Q kwzƬ,Q 6?v=Gp&;,]~61Ⱥ-D߹.p7\9~se 3Sw4j]%{kW/j2565K?ߤ2DjhSCv650] tU6?EsRbV;ϫ5͑H 05=|b%e+5C~aDV8|a!FRƒԘ , 792DjhfF] [nY!?fg FJ6VNjd1C.;ekCcC53@u[Lgq!?LiP 5kcA@S.k٦=*z̵BjhHs"5!5~7H ݩ<_0Dl ǮH ͙Scalˮ ǮH &X iJ 9˿~^&FS@85cR5|1gKpװw!RCSߡ4*fS#3C?U]vhk,%T()3!$Ajh|5/m":1ӱ38?X|1tFFBz,59 !4a6h5Re+Z6J;wFB@` >OVH M^c *NJ3CYZS0)5Udox2܇ 41v+kW1/3fPk7i.Gjh轶 !5CkΫ 54~:#TH R 54޾=q>VO;mj,~ut9|QΙΌ!5hH R!5hH R!5hH R!5hH R!5hH R!5hH R!5hH R!5hH R!5hH R!5hH R!5hH R!5hH Rendstream endobj 47 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceGray /DecodeParms << /Columns 310 /Predictor 15 >> /Filter /FlateDecode /Height 164 /Subtype /Image /Width 310 /Length 445 >> stream x1r@AUQ,UȘɷv_?g^_pn߾ڷwNnrlܦfsmr6u ݦg3ؖ}]љؖe]ёbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbNaGd />3x7VKlXlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTlTl/oڥendstream endobj 48 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 310 /Predictor 15 >> /Filter /FlateDecode /Height 164 /SMask 47 0 R /Subtype /Image /Width 310 /Length 2696 >> stream xv&@ǎ!\qҎ{z6 +$~); EBAQР(@hP 4(  EBAQР(@hP 4(  EBAQР(@hP 4(  EBAQР(@hP 4(  EBAQР(@hP 4(  EBAQР(@hP 4( :c*z/n |^&?|u(Qx&o??v{_:(<=󳼼|%`G(XkD=( IхLF&Ag'+t%YzE&>v[W9P45hzXnTnV#w[E,CԾKkiY=6{~Xb1~+j_̨iυ,07#vwd4=ګн(t&_[f'y}?KxZU*;GӔRr Աl,W9حg78h&E{uEs //KOh>%etQYU,7f*E5*EsG)Gmgk*l=E[riܫ:zsKh.i/e҈:DPbR &{N)=ȵK!Qz#+ŗEF/W#XrPJַWUZzc7s\߂vI,quSh|֧o};j> UK4tw~G24Eݫi%Ӄj6~,'҈:Dh\-hX}}G>Z9cFQTf(#+vG>T)_Nbrsyۢq~о9*MBTFWd㽱WndѕK7ƽAQ mrIcżyn}^W.m| (e'VOE}o=Б=}IAQ( >^+C›$4uq(crGr޴Okkwˣ?Y-ɥIjG&8R;@m6ϸhzܒu)I.(z64NbmvzAQUK; ʮZ˂hvfO,Yц2K1Nm^nFP ӥ^ZveZ1gY kWdeZªjɥjku)ѻ%O9FfE}h.UV4ٕ *Ü(qXfu] 9V*ArG+bFղ%=ꈢ>n+)HhĘZĹGQNAbK?QT-IgBHGY-udz?] 2]D_IL{کRuib<_nvpKT?a Lf/^Yo4AH&1JqWMJh|,ji*hɜj-cH<>s8N3~+ڌE}J/M /sPpȶ*9s/xZ.ΦkcpVe2~K:vSaW>]1F&Ku[ƴ깫X*wE4QW ]UEr8qN3~-M]0*;E$1lxy5A D*[2ģ芿Z8J/via|Mh<6]aEL_̌jxRPT4\eWYt5il.r moA~Ncڤ%Mzi*uk2P`ҥ̏ ۥWҩxmiyX9lWk59W֍q4W@ntcVP g>*(EKY}E} %|Fp 磂>AQ( >PE}( @Q8p0(E`PAQ( >Ew6CPƢd)$?"1wE'c EBAQР(@hP 4(  EBAQР(@hP 4(  EBAQР(@hP 4(  EBAQР(@hP 4(  EBAQР(@hP 4(  EBAQР(@hP 4( Ϳ"endstream endobj 49 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceGray /DecodeParms << /Columns 348 /Predictor 15 >> /Filter /FlateDecode /Height 332 /Subtype /Image /Width 348 /Length 833 >> stream x1r@EAZX>ڥm~˗.'7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap ^q]Oׅi]'Յ{I]Ӆ{)]';m=۶mg7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7Wp:>:^'t8N7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap 7 n0ap Mkendstream endobj 50 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 348 /Predictor 15 >> /Filter /FlateDecode /Height 332 /SMask 49 0 R /Subtype /Image /Width 348 /Length 6040 >> stream xr b?^cU0ipeI)K|C P)@R H4 h@ Ѐ)@R H4 h@ Ѐ)@R H4 h@ Ѐ)@R H4 h@ Ѐ)@R H4 h@ Ѐ)@R H4 hQ ߾}{tNc"3ׯ_yzR0~m¦s‚cR)?>xt^I᯿;7=%lRn^?'R,~}"/|E)y?}xl0Bvo뉼O}w7Zt+䉼RWȳxav);_Y.e6'}|tkS>ۄRvpb=Ӝݵ!OH䎘RpE_ϗ{bef)Hbn|yy6( vW\No29DEW3_x)#Ky{“RTs1.oza}L5-!e]0c1OJ ̟?Yud7\rA%Rp]P}>:֩{j){ng-Θ'>gA/+ԯ6^߫KS,lJ[kztoא$}f,3iK)EZ/|VM,3j zz$@B6@":.7x#v3KT׍LbG 1R0C!o%b)zSp )j2~H+SFeďNz{qF2KT4)RA RW)߻"ͧPS fm^[b+"_E}Ǭ)SK)Rm._W CٻBu܌-(˔r.ZI ]R6ܦ‰`p HAo]2 K!&\)\WS(1A 154a)$~][zP6tB 3%02ˆBX?,_oVO<\BI9aݜMB A.H!RA 1,RqVCUkf@YWwzN JY$ B`v(2 ._э ghVCƓA !B9q\CRŀ=Bį$s`@B,)Q)zEA 1ΒBޖ^S(1 B)8QK|7eNH!Rq-#"FB @ 1NO,QR"\RQyH!Rx8|u5H!RA 1,R`yB ˃b X) H)@ + NA’#@ 1,RHa7CD@q ZbজtK܇:VL'l~"@ 1nP#~ bJraBK?o"'D[A bG azf WK!OL^zm"H!) H)@ BBp8 S M03>w`t~zGNiI/?H!ƍ^#|KSJr=bQ{+:aL)/S Xš?|R!6+fvx~\ ϟ?K}8O덤a)Kg|by.x'W}SUIg'}< tgV@oN툋IRHH7C"R&|E%6Kk yefo$ԑB^4%H!Y i5{4̍}c%_OH,"Sr`< z(J}dcaB Spe+Ԏq`ϨvwO $No9@ 1OA'qzu~)B SeLA)l p,KPdz|p޳J3x O0,_oVOS*uednP@ 1Bfb X) N)`<ĝ{n& x !)` Kb^)8R0B+b0))(L Ha$vXx e;Q)H0H!)8I$u3ǁ|Rx N>]>Bb0Nb))`ʄ匧\ H!x b X) H)@ nz):ΒGR<<[ Oxj]f|\RQKAzZ_4 ]М6MG?dPVSՂ0hgcnd#yf 잗hNyK[)RaJ>Ij|)o%- *iSHVxjU#y&(j 7TMAO)ܛ"q.8PBH\W<^V4,ݼ*ZFX'jSHJ~>mGrdqzw/ noRP mS5;U>!\!gG-> Y x.] RH>|}<^c=/g)L |}<>0C 1f Gcy[bh)"RHx b|)p b8R~u̩}Y]fow+Y^gMV)>䙽N~[|# ]F-vv5@ 1zRx>/kTwA5X_.39H!Ʈ~BRTj`x }+E}0g7a B 7H7a w}Z&RѓB>/k ʒo-DH~xݤb  Ft3MBf.Yb }pƯxW>R+aA 1z_68_j#C3׉&92,<#H!ƱNjBS)84}Y@ 1O)@ > /Filter /FlateDecode /Height 188 /Subtype /Image /Width 366 /Length 520 >> stream x!rP @8ŹcL_>f/ˇ.}{; w4ipNÝ; w4ipNÝ; w4ipNÝ; w4ipNÝ; w4ipNÝ; w4ipN[n/:ϯ:9_c}^޸{zOx4=i{7a3oF޸ǝ~ypNÝ; w4ipNÝ; w4ipNÝ; w4ipNÝ; w4ipNÝ; w4ipNÝ; w4ipNÝ; w4ipNÝ; w4ipNÝ; w4ip%nkvE=4ipNÝ; w4ipNÝ; w4ipNÝ; w4ipNÝ; w4ipNÝ; w4ipNÝ; w7+"endstream endobj 52 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 366 /Predictor 15 >> /Filter /FlateDecode /Height 188 /SMask 51 0 R /Subtype /Image /Width 366 /Length 3892 >> stream xr6F"}/ړcL0# $>CS$XA\< 2 @J @J @J @J @J @J @J @J @J @J @J @J @J @J @J @J @J @J @J @J @J @J @J 8<==;ss\)m)~l #?~-7uMPl?lRtGMIwS߿o&H R@jrt)6_7]nt{\8zM!%?]Jdoo_fJ[m@Jک!dkݳy_IJd6H"/lEoy%z.TRGM@J@vyl-vrvO۳¶gdBk@߯v#Y9z5O)slUWy`>{QRUv~{A䑤}(mۣ^g>%EYƯ6 m34rO'9f7U%vi>:3^TGyHltm)LՌƠ.ۤ͞HJ,1&jH0o ɏyE^J̓%%Ìь'誝<ȴT#6#IID?Iko޶k66-%۞^[-yRS*=Edy %k|^@)Y)jI5 ;H_VJr5d )Y)pAJ@J\5d )Y)pAJ@J\5d )Y)pAJ@J\5d )Y)pAJ@J\5pn7wvvy"%k %wڑeo|+)RRrjH %kup#jeY:*'jg RLX3L<'KCgXE-Vҋ_r,Qt]U'Z zLɺB!%b[J.}.בEIuj4SLפly͸Q%+ϟ=d-U Yz)EHk{{ҊQ=()YCI2 Dd]mƒ;Vjne<:]4/`n(~"%[=\+%D'X?D\Z85n%GJְRwGw4n"ct5iy=J86{eqj*VVŔzcKZo S|au/l<;U6oؤ֌+\'G7khqno]=ѽ3WzfE^ng-fT%@MH_p* {Ot-ͻoGZ[L2*+%QDިw3>bMJj%vT14ӊ"n=^XUGRR+qijlU?u紸 dHJg}zvMa}v]U{AW&n2獕4өT>8Jܱ61II4V-Qת'#G*r i႔IIK]k5NYtrQΌI!kƍopg-9͓kٹz+0RRWNGSƑS*M%-sp4y)ќ#S6\0$b}Uf|'ݭBDѹHI=v} {*)Y)y fF RrGr^ %k %.HgKWA}2>.׾:HgKWxlFJ̵k RR"I^lĤpwÐcd>2>>E] 2o%ikRD&m>LECQJ%#3N{ܑf[m3W$)YCMQ۝W8d;~qlTv}2sFskټ`([R+/Z\y\;HCJ.z4ȃ(ٕ3B(ԉQpk?򀛠{!E["Wo1dAkף(iG=|+Renp7RɫQoN~@*[:dn^d +%uA{O8S6<Ͷ˝$wX|ko '{ q7DwTAJ(|(1J&~,=78vF©ahUȫT2l@J8{^IDn{bzV1JSwvo餝wt^©XK /f\drH%d >"$pAJ@JH*HH<HH R zdpȅ %k<$9\RFL~*%%L HvwQ2$ ]&](T4fDJdȶ7gן d :_)~onmwHs~m4siVbs#wg8/ʟ7Vfb5̇CWhTṫ*/b٤{%7ˮ@Jy0d +%-{17wnDȊ.8#娉^#Id9u[DS^cO@Jֈ߽ROUkq[bdapIdH6'Rrp/qaHKRҙ]aM> {{3q@r'jd{%y,, ŝp %k\"%- ]Ѽ8;æ ^)yc%Q?oΣMDž %kؕ'=1Nl'1b<op>@JְJz '5BO~ڝ`3Ad#qpm=.̧)Y\5d )Y)pAJ@J\56)3R tׯ_GlGi޶#m8b=Mp %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR %PR5Kendstream endobj 53 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceGray /DecodeParms << /Columns 605 /Predictor 15 >> /Filter /FlateDecode /Height 156 /Subtype /Image /Width 605 /Length 519 >> stream x+r@EZX-qT75>/~1uQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQu_};z]8ײ̯y|YD^Sy.VK]9Xu8/uh^by-.6Yi=RLӴ{.QuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQ55⟠0p}?`+uQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQuQulendstream endobj 54 0 obj << /BitsPerComponent 8 /ColorSpace /DeviceRGB /DecodeParms << /Colors 3 /Columns 605 /Predictor 15 >> /Filter /FlateDecode /Height 156 /SMask 53 0 R /Subtype /Image /Width 605 /Length 3681 >> stream xےОxR0!pD=}oٞZȭH?""Dr"\H.@$ E"Dr"\H.@$ E"Dr"\H.@$ E"Dr"\H.@$ E"Dr"\H.@$ E"Dr"\H.@$ b.>==Go0bn4߽ ?u=872}?[+GE\*4"r([]744~[:lܳz9g^Sϛ^c-5w꾢sӧo}~?}_7in51J眱xqN\h\i51w׶y=ZkrJcz8\}wtO*GүSPOeV66ՍTakE#i^{[.kEu\MZt){3rZptS4˷> C=m |i?imfP.Vk:Wu^VpJNYx8+',^گ̵meSG<Ƣף>wƙANeZauS㨯@.ɞ7{gSl5QT/+mׯa9l3'fS7![xYhqMCmI66+i2i/M\Ҷt'xna3;RoN.E.5roN.M.rqx?̩w^au)/5ݹtysڜc\]u&5†eN9Kftq5.Ϛsw7﮾^܊+w5}ksqWΙE.}IY'ee:\-Oka:џbgPUhO-aPKK]x{z=$t//L_>D|X̻ӉߏИ׼}akIm=|jܯQ~z]'ǫ,|u/ɬ7\ ͛?_@fʇXt>n[r:%.Ϳŷ&NF/5t5C{+'NDݴ6yOϥKm!i%Oe_5j +sl_Q^}dgF%+343ƸU&u7UN NtKhl +oϩ>at//zb)ͿݳՐlB}Po_?5yWn,ѵ^eG-T\g-7@kᝥ:wgcG- )bThն5Kh\ǟa79vsj.Nv&kH5Z+\wrM~OUK'7p}Nk[νv屻~Hk}qfR;KV+sĭ(r7ϫvu ח.>.iu1v2eg.۩.uK:֣[iZG/Bfrk.KE,;9P?Z@.j.nng`c{˝x\ |>tWc\\\#\\#\\#\\#\\#\\#\\#\\#\\#\\#\\#\\#\\#\\#\\#\\#\\#\\]uk5`x:7@6sފ\H.@$ E"Dr"\H.@$ E"Dr"\H.@$ E"Dr"\H.@$ E"Dr"\H.@$ E"Dr"\H.@$ E"Dr"\endstream endobj 55 0 obj << /Type /XRef /Length 161 /Filter /FlateDecode /DecodeParms << /Columns 5 /Predictor 12 >> /W [ 1 3 1 ] /Info 3 0 R /Root 2 0 R /Size 56 /ID [<0a47d6bfdd11302704c682e4ae4ec1b7>] >> stream xcb&F~0 $He?˔O@6[|Ň )D؂Hd ɘ f"MA$ 3 f±`.0:X)0D "EŋA'X\ D;5H=xmܙ`\ R,~l(}l{ endstream endobj startxref 149845 %%EOF Luminescence/tests/0000755000176200001440000000000013125227601014025 5ustar liggesusersLuminescence/tests/testthat.R0000644000176200001440000000010413041732307016004 0ustar liggesuserslibrary(testthat) library(Luminescence) test_check("Luminescence") Luminescence/tests/testthat/0000755000176200001440000000000013125301541015661 5ustar liggesusersLuminescence/tests/testthat/test_analyse_pIRIRSequence.R0000644000176200001440000000267713047374234023225 0ustar liggesuserscontext("analyse_pIRIRSequence") set.seed(1) data(ExampleData.BINfileData, envir = environment()) object <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos = 1) object <- get_RLum(object, record.id = c(-29, -30)) 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") 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 = FALSE, plot.single = TRUE, verbose = FALSE ) test_that("check class and length of output", { testthat::skip_on_cran() expect_is(results, "RLum.Results") expect_equal(length(results), 4) expect_is(results$LnLxTnTx.table, "data.frame") expect_is(results$rejection.criteria, "data.frame") }) test_that("check output", { testthat::skip_on_cran() expect_equal(round(sum(results$data[1:2, 1:4]), 2),7582.62) expect_equal(round(sum(results$rejection.criteria$Value), 2),3338.69) }) Luminescence/tests/testthat/test_calc_gSGC.R0000644000176200001440000000131513047374234020624 0ustar liggesuserscontext("calc_gSGC") set.seed(seed = 1) temp <- calc_gSGC(data = data.frame( LnTn = 2.361, LnTn.error = 0.087, Lr1Tr1 = 2.744, Lr1Tr1.error = 0.091, Dr1 = 34.4), plot = FALSE, verbose = FALSE ) test_that("check class and length of output", { testthat::skip_on_cran() expect_is(temp, class = "RLum.Results", info = NULL, label = NULL) expect_is(temp$De, class = "data.frame", info = NULL, label = NULL) expect_is(temp$De.MC, class = "list", info = NULL, label = NULL) expect_equal(length(temp), 3) }) test_that("check values from output example", { testthat::skip_on_cran() expect_equal(round(sum(temp$De), digits = 2), 30.39) expect_equal(round(sum(temp$De.MC[[1]]), 0), 10848) }) Luminescence/tests/testthat/test_calc_FuchsLang2001.R0000755000176200001440000000136013047374234022221 0ustar liggesuserscontext("calc_FuchsLang2001") data(ExampleData.DeValues, envir = environment()) temp <- calc_FuchsLang2001(ExampleData.DeValues$BT998, cvThreshold = 5, plot = FALSE, verbose = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 5) }) test_that("check values from output example 1", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(results$de, 2866.11) expect_equal(results$de_err, 157.35) expect_equal(results$de_weighted, 2846.66) expect_equal(results$de_weighted_err, 20.58) expect_equal(results$n.usedDeValues, 22) }) Luminescence/tests/testthat/test_write_RLum2CSV.R0000644000176200001440000000072413050140637021601 0ustar liggesuserscontext("write_RLumCSV") test_that("test errors and general export function", { testthat::skip_on_cran() ##test error expect_error(write_RLum2CSV(object = "", export = FALSE), regexp = "[write_RLum2CSV()] Object needs to be a member of the object class RLum!", fixed = TRUE) ##test export data("ExampleData.portableOSL", envir = environment()) expect_is(write_RLum2CSV(ExampleData.portableOSL, export = FALSE), "list") }) Luminescence/tests/testthat/test_plot_AbanicoPlot.R0000644000176200001440000001407713050334730022310 0ustar liggesuserscontext("plot_AbanicoPlot()") test_that("Test examples from the example page", { testthat::skip_on_cran() ## load example data and recalculate to Gray data(ExampleData.DeValues, envir = environment()) ExampleData.DeValues <- ExampleData.DeValues$CA1 ## plot the example data straightforward expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues)) ## now with linear z-scale expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, log.z = FALSE)) ## now with output of the plot parameters expect_is(plot_AbanicoPlot(data = ExampleData.DeValues, output = TRUE), "list") ## now with adjusted z-scale limits expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, zlim = c(10, 200))) ## now with adjusted x-scale limits expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, xlim = c(0, 20))) ## now with rug to indicate individual values in KDE part expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, rug = TRUE)) ## now with a smaller bandwidth for the KDE plot expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, bw = 0.04)) ## now with a histogram instead of the KDE plot expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, hist = TRUE, kde = FALSE)) ## now with a KDE plot and histogram with manual number of bins expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, hist = TRUE, breaks = 20)) ## now with a KDE plot and a dot plot expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, dots = TRUE)) ## now with user-defined plot ratio expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, plot.ratio = 0.5)) ## now with user-defined central value expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, z.0 = 70)) ## now with median as central value expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, z.0 = "median")) ## now with the 17-83 percentile range as definition of scatter expect_silent(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) expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, line = CAM, line.col = "darkgreen", line.label = "CAM")) ## now create plot with legend, colour, different points and smaller scale expect_silent(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 expect_silent(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 expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, bar.col = FALSE, ylab = "", y.axis = FALSE, error.bars = TRUE)) ## now with user-defined axes labels expect_silent(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 expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, stats = c("min", "max", "median"))) ## now with a brief statistical summary as subheader expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, summary = c("n", "in.2s"))) ## now with another statistical summary expect_silent(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 expect_silent(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 data.3 <- list(data.1, data.2) ## now the two data sets are plotted in one plot expect_silent(plot_AbanicoPlot(data = data.3)) ## now with some graphical modification expect_silent(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 expect_silent(plot_AbanicoPlot(data = ExampleData.DeValues, layout = "journal")) ## now with predefined layout definition and further modifications expect_silent(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 expect_is(plot_AbanicoPlot(data = ExampleData.DeValues, pch = NA, output = TRUE), "list") }) Luminescence/tests/testthat/test_RisoeBINfileData-class.R0000644000176200001440000000063213050144537023222 0ustar liggesuserscontext("RisoeBINfileData Class Tests") test_that("Check the example and the numerical values", { testthat::skip_on_cran() ##construct empty object temp <- set_Risoe.BINfileData(METADATA = data.frame(), DATA = list(), .RESERVED = list()) ##get function and check whether we get NULL expect_null(get_Risoe.BINfileData(temp)) ##check object expect_is(temp, class = "Risoe.BINfileData") }) Luminescence/tests/testthat/test_smooth_RLum.R0000644000176200001440000000127113047374234021330 0ustar liggesuserscontext("smooth_RLum") data(ExampleData.CW_OSL_Curve, envir = environment()) temp <- set_RLum( class = "RLum.Data.Curve", recordType = "OSL", data = as.matrix(ExampleData.CW_OSL_Curve) ) test_that("check class and length of output", { testthat::skip_on_cran() expect_is(temp, class = "RLum.Data.Curve", info = NULL, label = NULL) expect_is(smooth_RLum(temp), class = "RLum.Data.Curve", info = NULL, label = NULL) }) test_that("check values from output example", { testthat::skip_on_cran() expect_equivalent(round(mean(smooth_RLum(temp, k = 5)[,2], na.rm = TRUE), 0), 100) expect_equivalent(round(mean(smooth_RLum(temp, k = 10)[,2], na.rm = TRUE), 0), 85) }) Luminescence/tests/testthat/test_calc_CommonDose.R0000644000176200001440000000115413047374234022105 0ustar liggesuserscontext("calc_CommonDose") data(ExampleData.DeValues, envir = environment()) temp <- calc_CommonDose(ExampleData.DeValues$CA1, plot = FALSE, verbose = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 4) }) test_that("check values from output", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(round(results$de, digits = 5), 62.15999) expect_equal(round(results$de_err, digits = 7), 0.7815117) expect_true(temp@data$args$log) expect_equal(temp@data$args$sigmab, 0) }) Luminescence/tests/testthat/test_calc_HomogeneityTest.R0000755000176200001440000000113013047374234023166 0ustar liggesuserscontext("calc_HomogeneityTest") data(ExampleData.DeValues, envir = environment()) temp <- calc_HomogeneityTest(ExampleData.DeValues$BT998, verbose = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 4) }) test_that("check values from output example", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(results$n, 25) expect_equal(results$g.value, 0.008687915) expect_equal(results$df, 24) expect_equal(results$P.value, 1) }) Luminescence/tests/testthat/test_zzz.R0000644000176200001440000000046113050144537017710 0ustar liggesuserscontext("zzz") test_that("Test zzz functions ... they should still work", { testthat::skip_on_cran() ##get right answer expect_equal(get_rightAnswer(), 46) expect_equal(get_rightAnswer("test"), 46) ##get quote expect_silent(get_Quote()) ##tune data expect_warning(tune_Data(1:10)) }) Luminescence/tests/testthat/test_CW2pX.R0000644000176200001440000000516513047374234017771 0ustar liggesuserscontext("CW2X Conversion Tests") ##load data data(ExampleData.CW_OSL_Curve, envir = environment()) values <- CW_Curve.BosWallinga2012 test_that("Check the example and the numerical values", { testthat::skip_on_cran() values_pLM <- CW2pLM(values) values_pLMi <- CW2pLMi(values, P = 1/20) values_pLMi_alt <- CW2pLMi(values) values_pHMi <- CW2pHMi(values, delta = 40) values_pHMi_alt <- CW2pHMi(values) values_pHMi_alt1 <- CW2pHMi(values, delta = 2) values_pPMi <- CW2pPMi(values, P = 1/10) ##check conversion sum values expect_equal(round(sum(values_pLM), digits = 0),90089) expect_equal(round(sum(values_pLMi[,1:2]), digits = 0),197522) expect_equal(round(sum(values_pLMi_alt[,1:2]), digits = 0),197522) expect_equal(round(sum(values_pHMi[,1:2]), digits = 0),217431) expect_equal(round(sum(values_pHMi_alt[,1:2]), digits = 0),217519) expect_equal(round(sum(values_pHMi_alt1[,1:2]), digits = 0), 221083) expect_equal(round(sum(values_pPMi[,1:2]), digits = 0),196150) }) test_that("Test RLum.Types", { testthat::skip_on_cran() ##load CW-OSL curve data data(ExampleData.CW_OSL_Curve, envir = environment()) object <- set_RLum( class = "RLum.Data.Curve", data = as.matrix(ExampleData.CW_OSL_Curve), curveType = "measured", recordType = "OSL" ) ##transform values expect_is(CW2pLM(object), class = "RLum.Data.Curve") expect_is(CW2pLMi(object), class = "RLum.Data.Curve") expect_is(CW2pHMi(object), class = "RLum.Data.Curve") expect_is(CW2pPMi(object), class = "RLum.Data.Curve") ##test error handling expect_error(CW2pLMi(values, P = 0), regexp = "[CW2pLMi] P has to be > 0!", fixed = TRUE) expect_warning(CW2pLMi(values, P = 10)) expect_error(object = CW2pLM(values = matrix(0, 2))) expect_error(object = CW2pLMi(values = matrix(0, 2))) expect_error(object = CW2pHMi(values = matrix(0, 2))) expect_error(object = CW2pPMi(values = matrix(0, 2))) object@recordType <- "RF" expect_error(object = CW2pLM(values = object), regexp = "[CW2pLM()] recordType RF is not allowed for the transformation!", fixed = TRUE) expect_error(object = CW2pLMi(values = object), regexp = "[CW2pLMi()] recordType RF is not allowed for the transformation!", fixed = TRUE) expect_error(object = CW2pHMi(values = object), regexp = "[CW2pHMi()] recordType RF is not allowed for the transformation!", fixed = TRUE) expect_error(object = CW2pPMi(values = object), regexp = "[CW2pPMi()] recordType RF is not allowed for the transformation!", fixed = TRUE) }) Luminescence/tests/testthat/test_calc_Statistics.R0000644000176200001440000000607213047374234022200 0ustar liggesuserscontext("calc_Statistics") ## load example data data(ExampleData.DeValues, envir = environment()) ## calculate statistics and show output set.seed(1) temp <- calc_Statistics(ExampleData.DeValues$BT998, n.MCM = 1000) temp_alt1 <- calc_Statistics(ExampleData.DeValues$BT998, n.MCM = 1000, digits = 2) temp_alt2 <- calc_Statistics(ExampleData.DeValues$BT998, n.MCM = 1000, digits = NULL) temp_RLum <- set_RLum(class = "RLum.Results", data = list(data = ExampleData.DeValues$BT998)) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("list", "vector")) expect_equal(length(temp), 3) }) test_that("Test certain input scenarios", { expect_is(calc_Statistics(temp_RLum), "list") df <- ExampleData.DeValues$BT998 df[,2] <- 0 expect_warning(calc_Statistics(df)) }) test_that("check error messages", { testthat::skip_on_cran() expect_error(calc_Statistics(data = matrix(0,2)), regexp = "[calc_Statistics()] Input data is neither of type 'data.frame' nor 'RLum.Results'", fixed = TRUE) expect_error(calc_Statistics(data = df, weight.calc = "test")) }) test_that("check weighted values from output", { testthat::skip_on_cran() expect_equal(temp$weighted$n, 25) expect_equal(sum(unlist(temp_alt1)),24535.72) expect_equal(sum(unlist(temp_alt2)),24534.1) expect_equal(round(temp$weighted$mean, digits = 3), 2896.036) expect_equal(round(temp$weighted$median, digits = 2), 2884.46) expect_equal(round(temp$weighted$sd.abs, digits = 4), 240.2228) expect_equal(round(temp$weighted$sd.rel, digits = 6), 8.294885) expect_equal(round(temp$weighted$se.abs, digits = 5), 48.04457) expect_equal(round(temp$weighted$se.rel, digits = 6), 1.658977) expect_equal(round(temp$weighted$skewness, digits = 6), 1.342018) expect_equal(round(temp$weighted$kurtosis, digits = 6), 4.387913) }) test_that("check unweighted values from output", { testthat::skip_on_cran() expect_equal(temp$weighted$n, 25) expect_equal(round(temp$unweighted$mean, digits = 3), 2950.818) expect_equal(round(temp$unweighted$median, digits = 2), 2884.46) expect_equal(round(temp$unweighted$sd.abs, digits = 4), 281.6433) expect_equal(round(temp$unweighted$sd.rel, digits = 6), 9.544584) expect_equal(round(temp$unweighted$se.abs, digits = 5), 56.32866) expect_equal(round(temp$unweighted$se.rel, digits = 6), 1.908917) expect_equal(round(temp$unweighted$skewness, digits = 6), 1.342018) expect_equal(round(temp$unweighted$kurtosis, digits = 6), 4.387913) }) test_that("check MCM values from output", { expect_equal(temp$MCM$n, 25) expect_equal(round(temp$MCM$mean, digits = 3), 2950.992) expect_equal(round(temp$MCM$median, digits = 3), 2885.622) expect_equal(round(temp$MCM$sd.abs, digits = 4), 295.0737) expect_equal(round(temp$MCM$sd.rel, digits = 6), 9.999137) expect_equal(round(temp$MCM$se.abs, digits = 5), 59.01474) expect_equal(round(temp$MCM$se.rel, digits = 6), 1.999827) expect_equal(round(temp$MCM$skewness, digits = 3), 1286.082) expect_equal(round(temp$MCM$kurtosis, digits = 3), 4757.097) }) Luminescence/tests/testthat/test_calc_FastRatio.R0000644000176200001440000000267013047374234021742 0ustar liggesuserscontext("calc_FastRatio") data("ExampleData.CW_OSL_Curve") temp <- calc_FastRatio(ExampleData.CW_OSL_Curve, plot = FALSE, verbose = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 5) }) test_that("check values from output", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(round(results$fast.ratio, digits = 3), 405.122) expect_equal(round(results$fast.ratio.se, digits = 4), 119.7442) expect_equal(round(results$fast.ratio.rse, digits = 5), 29.55756) expect_equal(results$channels, 1000) expect_equal(round(results$channel.width, digits = 2), 0.04) expect_equal(results$dead.channels.start, 0) expect_equal(results$dead.channels.end, 0) expect_equal(results$sigmaF, 2.6e-17) expect_equal(results$sigmaM, 4.28e-18) expect_equal(results$stimulation.power, 30.6) expect_equal(results$wavelength, 470) expect_equal(results$t_L1, 0) expect_equal(round(results$t_L2, digits = 6), 2.446413) expect_equal(round(results$t_L3_start, digits = 5), 14.86139) expect_equal(round(results$t_L3_end, digits = 5), 22.29208) expect_equal(results$Ch_L1, 1) expect_equal(results$Ch_L2, 62) expect_equal(results$Ch_L3_start, 373) expect_equal(results$Ch_L3_end, 558) expect_equal(results$Cts_L1, 11111) expect_equal(results$Cts_L2, 65) expect_equal(round(results$Cts_L3, digits = 5), 37.66667) }) Luminescence/tests/testthat/test_calc_AverageDose.R0000644000176200001440000000127113071664642022231 0ustar liggesuserscontext("calc_AverageDose") data(ExampleData.DeValues, envir = environment()) temp <- calc_AverageDose(ExampleData.DeValues$CA1[1:56,], sigma_m = 0.1, plot = FALSE, verbose = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 3) }) test_that("check summary output", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(round(results$AVERAGE_DOSE, digits = 4), 65.3597) expect_equal(round(results$SIGMA_D, digits = 4), 0.3092) expect_equal(round(results$L_MAX, digits = 5), -19.25096) }) Luminescence/tests/testthat/test_replicate_RLum.R0000644000176200001440000000037613047374234021774 0ustar liggesuserscontext("replicate_RLum") test_that("Test replication of RLum-objects", { skip_on_cran() data(ExampleData.RLum.Analysis, envir = environment()) expect_silent(results <- rep(IRSAR.RF.Data[[1]], 5)) ##check expect_equal(length(results),5) }) Luminescence/tests/testthat/test_analyse_SARCWOSL.R0000644000176200001440000000272513047374234022036 0ustar liggesuserscontext("analyse_SAR.CWOSL") set.seed(1) data(ExampleData.BINfileData, envir = environment()) 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, exceed.max.regpoint = TRUE), plot = FALSE, verbose = FALSE ) test_that("check class and length of output", { testthat::skip_on_cran() expect_is(results, "RLum.Results") expect_equal(length(results), 4) expect_is(results$data, "data.frame") expect_is(results$LnLxTnTx.table, "data.frame") expect_is(results$rejection.criteria, "data.frame") expect_is(results$Formula, "expression") }) test_that("check De values", { testthat::skip_on_cran() expect_equal(object = round(sum(results$data[1:2]), digits = 2), 1717.47) }) test_that("check LxTx table", { testthat::skip_on_cran() expect_equal(object = round(sum(results$LnLxTnTx.table$LxTx), digits = 5), 20.92051) expect_equal(object = round(sum(results$LnLxTnTx.table$LxTx.Error), digits = 2), 0.34) }) test_that("check rejection criteria", { testthat::skip_on_cran() expect_equal(object = round(sum(results$rejection.criteria$Value), digits = 3), 1669.348) }) Luminescence/tests/testthat/test_fit_LMCurve.R0000644000176200001440000000312313047374234021235 0ustar liggesuserscontext("fit_LWCurve") ## Test 1 with NLS data(ExampleData.FittingLM, envir = environment()) fit <- fit_LMCurve(values = values.curve, values.bg = values.curveBG, n.components = 3, log = "x", start_values = data.frame(Im = c(170,25,400), xm = c(56,200,1500)), plot = FALSE) test_that("check class and length of output", { expect_equal(is(fit), c("RLum.Results", "RLum")) expect_equal(length(fit), 3) }) test_that("check values from output example", { testthat::skip_on_cran() expect_equal(fit$data$n.components, 3) expect_equal(round(fit$data$Im1, digits = 3), 169.44) expect_equal(round(fit$data$xm1, digits = 5), 49.00643) expect_equal(round(fit$data$b1, digits = 5), 1.66554) expect_equal(round(fit$data$`pseudo-R^2`, digits = 4), 0.9437) }) ## Test 2 with LM data(ExampleData.FittingLM, envir = environment()) fit <- fit_LMCurve(values = values.curve, values.bg = values.curveBG, n.components = 3, log = "x", fit.method = "LM", plot = FALSE) test_that("check class and length of output", { expect_equal(is(fit), c("RLum.Results", "RLum")) expect_equal(length(fit), 3) }) test_that("check values from output example", { testthat::skip_on_cran() expect_equal(fit$data$n.components, 3) expect_equal(round(fit$data$Im1, digits = 3), 169.437) expect_equal(round(fit$data$xm1, digits = 5), 49.00509) expect_equal(round(fit$data$b1, digits = 5), 1.66563) expect_equal(round(fit$data$`pseudo-R^2`, digits = 4), 0.9437) }) Luminescence/tests/testthat/test_calc_ThermalLifetime.R0000644000176200001440000000462113047374234023117 0ustar liggesuserscontext("calc_ThermalLifetime") ##EXAMPLE 1 ##calculation for two trap-depths with similar frequency factor for different temperatures E <- c(1.66, 1.70) s <- 1e+13 T <- 10:20 set.seed(1) temp <- calc_ThermalLifetime( E = E, s = s, T = T, output_unit = "Ma", verbose = FALSE ) test_that("check class and length of output example 1", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 2) }) test_that("check values from output example 1", { testthat::skip_on_cran() expect_equal(is(temp$lifetimes), c("array", "structure", "vector")) expect_equal(dim(temp$lifetimes), c(1, 2, 11)) ##check results for 10 °C results <- lapply(1:length(T), function(x){ temp$lifetimes[,,x] }) expect_equal(round(results[[1]], digits = 3), c("1.66" = 1115.541, "1.7" = 5747.042)) expect_equal(round(results[[2]], digits = 4), c("1.66" = 878.0196, "1.7" = 4497.3585)) expect_equal(round(results[[3]], digits = 4), c("1.66" = 692.2329, "1.7" = 3525.4738)) expect_equal(round(results[[4]], digits = 4), c("1.66" = 546.6658, "1.7" = 2768.3216)) expect_equal(round(results[[5]], digits = 4), c("1.66" = 432.4199, "1.7" = 2177.4436)) expect_equal(round(results[[6]], digits = 4), c("1.66" = 342.6069, "1.7" = 1715.5406)) expect_equal(round(results[[7]], digits = 4), c("1.66" = 271.8854, "1.7" = 1353.8523)) expect_equal(round(results[[8]], digits = 4), c("1.66" = 216.1065, "1.7" = 1070.1642)) expect_equal(round(results[[9]], digits = 4), c("1.66" = 172.0421, "1.7" = 847.2879)) expect_equal(round(results[[10]], digits = 4), c("1.66" = 137.1765, "1.7" = 671.9020)) expect_equal(round(results[[11]], digits = 4), c("1.66" = 109.5458, "1.7" = 533.6641)) }) ##EXAMPLE 2 ##profiling of thermal life time for E and s and their standard error E <- c(1.600, 0.003) s <- c(1e+13,1e+011) T <- 20 set.seed(1) temp <- calc_ThermalLifetime( E = E, s = s, T = T, profiling = TRUE, output_unit = "Ma", verbose = FALSE, plot = FALSE ) test_that("check class and length of output example 2", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 2) }) test_that("check values from output example 2", { testthat::skip_on_cran() expect_equal(is(temp$lifetimes), c("numeric", "vector")) expect_equal(length(temp$lifetimes), 1000) expect_equal(dim(temp$profiling_matrix), c(1000, 4)) }) Luminescence/tests/testthat/test_convert_X2CSV.R0000644000176200001440000000165013050140636021455 0ustar liggesuserscontext("convert_X2CSV") test_that("test convert functions", { testthat::skip_on_cran() ##test for errors expect_error(convert_BIN2CSV(file = "", export = FALSE), regexp = "[read_BIN2R()] File does not exist!", fixed = TRUE) expect_error(convert_Daybreak2CSV(file = "", export = FALSE), regexp = "[read_Daybreak2R()] file name does not seem to exist.", fixed = TRUE) #expect_error(convert_PSL2CSV(file = "", export = FALSE)) expect_error(suppressWarnings(convert_XSYG2CSV(file = "", export = FALSE))) ##test conversion itself ##BIN2CSV data(ExampleData.BINfileData, envir = environment()) expect_is(convert_BIN2CSV(subset(CWOSL.SAR.Data, POSITION == 1), export = FALSE), "list") ##XSYG2CSV data(ExampleData.XSYG, envir = environment()) expect_is(convert_XSYG2CSV(OSL.SARMeasurement$Sequence.Object[1:10], export = FALSE), "list") }) Luminescence/tests/testthat/test_Second2Gray.R0000644000176200001440000000136213047374234021201 0ustar liggesuserscontext("Second2Gray") data(ExampleData.DeValues, envir = environment()) results <- Second2Gray(ExampleData.DeValues$BT998, c(0.2,0.01)) results_alt1 <- Second2Gray(ExampleData.DeValues$BT998, c(0.2,0.01), error.propagation = "gaussian") results_alt2 <- Second2Gray(ExampleData.DeValues$BT998, c(0.2,0.01), error.propagation = "absolute") test_that("check class and length of output", { testthat::skip_on_cran() expect_is(results, class = "data.frame", info = NULL, label = NULL) }) test_that("check values from output example", { testthat::skip_on_cran() expect_equal(sum(results[[1]]), 14754.09) expect_equal(sum(results[[2]]), 507.692) expect_equal(sum(results_alt1[[2]]), 895.911) expect_equal(sum(results_alt2[[2]]), 1245.398) }) Luminescence/tests/testthat/test_analyse_baSAR.R0000644000176200001440000000253413047374234021527 0ustar liggesuserscontext("analyse_baSAR") ##Full check test_that("Full check of analyse_baSAR function", { skip_on_cran() set.seed(1) ##(1) load package test data set data(ExampleData.BINfileData, envir = environment()) ##(2) selecting relevant curves, and limit dataset CWOSL.SAR.Data <- subset(CWOSL.SAR.Data, subset = POSITION %in% c(1:3) & LTYPE == "OSL") ##(3) run analysis ##please not that the here selected parameters are ##choosen for performance, not for reliability results <- analyse_baSAR( object = CWOSL.SAR.Data, source_doserate = c(0.04, 0.001), signal.integral = c(1:2), background.integral = c(80:100), fit.method = "EXP", method_control = list(inits = list( list(.RNG.name = "base::Wichmann-Hill", .RNG.seed = 1), list(.RNG.name = "base::Wichmann-Hill", .RNG.seed = 2), list(.RNG.name = "base::Wichmann-Hill", .RNG.seed = 3) )), plot = FALSE, verbose = FALSE, n.MCMC = 1000, txtProgressBar = FALSE ) expect_is( results, class = "RLum.Results", info = NULL, label = NULL ) expect_is(results$summary, "data.frame") expect_is(results$mcmc, "mcmc.list") expect_is(results$models, "list") expect_equal(round(sum(results$summary[, c(6:9)]), 2), 504.69) }) Luminescence/tests/testthat/test_calc_MinDose.R0000755000176200001440000000207413047374234021405 0ustar liggesuserscontext("calc_MinDose") data(ExampleData.DeValues, envir = environment()) temp <- calc_MinDose(data = ExampleData.DeValues$CA1, sigmab = 0.1, verbose = FALSE, plot = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 9) }) test_that("check values from output example", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(round(results$de, digits = 5), 34.31834) expect_equal(round(results$de_err, digits = 6), 2.550964) expect_equal(results$ci_level, 0.95) expect_equal(round(results$ci_lower, digits = 5), 29.37526) expect_equal(round(results$ci_upper, digits = 5), 39.37503) expect_equal(results$par, 3) expect_equal(round(results$sig, digits = 7), 0.7287325) expect_equal(round(results$p0, digits = 8), 0.01053938) expect_equal(results$mu, NA) expect_equal(round(results$Lmax, digits = 5), -43.57969) expect_equal(round(results$BIC, digits = 4), 106.4405) }) Luminescence/tests/testthat/test_calc_FiniteMixture.R0000755000176200001440000000136013047374234022640 0ustar liggesuserscontext("calc_FiniteMixture") data(ExampleData.DeValues, envir = environment()) temp <- calc_FiniteMixture( ExampleData.DeValues$CA1, sigmab = 0.2, n.components = 2, grain.probability = TRUE, verbose = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 10) }) test_that("check values from output example 1", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(results$de[1], 31.5299) expect_equal(results$de[2], 72.0333) expect_equal(results$de_err[1], 3.6387) expect_equal(results$de_err[2], 2.4082) expect_equal(results$proportion[1], 0.1096) expect_equal(results$proportion[2], 0.8904) }) Luminescence/tests/testthat/test_calc_CentralDose.R0000644000176200001440000000132013047374234022240 0ustar liggesuserscontext("calc_CentralDose") data(ExampleData.DeValues, envir = environment()) temp <- calc_CentralDose( ExampleData.DeValues$CA1, plot = FALSE, verbose = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 5) }) test_that("check summary output", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(round(results$de, digits = 5), 65.70929) expect_equal(round(results$de_err, digits = 6), 3.053443) expect_equal(round(results$OD, digits = 5), 34.69061) expect_equal(round(results$OD_err, digits = 6), 3.458774) expect_equal(round(results$Lmax, digits = 5), 31.85046) }) Luminescence/tests/testthat/test_read_BIN2R.R0000644000176200001440000000333213050325753020663 0ustar liggesuserscontext("read_BIN2R") test_that("test the import of various BIN-file versions", { testthat::skip_on_cran() ##test for various erros expect_error(read_BIN2R(file = ""), "[read_BIN2R()] File does not exist!", fixed = TRUE) ##this test need an internet connect ... test for it if(!httr::http_error("https://github.com/R-Lum/Luminescence/tree/master/tests/testdata")){ ##try to import every format by using the files on GitHub ##V3 expect_is( read_BIN2R(file = "https://github.com/R-Lum/Luminescence/raw/master/tests/testdata/BINfile_V3.bin", txtProgressBar = FALSE), class = "Risoe.BINfileData") ##V4 expect_is( read_BIN2R(file = "https://github.com/R-Lum/Luminescence/raw/master/tests/testdata/BINfile_V4.bin", txtProgressBar = FALSE), class = "Risoe.BINfileData") ##V6 expect_is( read_BIN2R(file = "https://github.com/R-Lum/Luminescence/raw/master/tests/testdata/BINfile_V6.binx", txtProgressBar = FALSE), class = "Risoe.BINfileData") ##V7 expect_is( read_BIN2R(file = "https://github.com/R-Lum/Luminescence/raw/master/tests/testdata/BINfile_V7.binx", txtProgressBar = FALSE), class = "Risoe.BINfileData") ##V8 expect_is( read_BIN2R(file = "https://github.com/R-Lum/Luminescence/raw/master/tests/testdata/BINfile_V8.binx", txtProgressBar = FALSE), class = "Risoe.BINfileData") ##test further options ##n.records and fastForward expect_is( read_BIN2R(file = "https://github.com/R-Lum/Luminescence/raw/master/tests/testdata/BINfile_V4.bin", txtProgressBar = FALSE, n.records = 1, fastForward = TRUE, verbose = FALSE), class = "list") } }) Luminescence/tests/testthat/test_calc_IEU.R0000755000176200001440000000113313047374234020464 0ustar liggesuserscontext("calc_IEU") data(ExampleData.DeValues, envir = environment()) temp <- calc_IEU(ExampleData.DeValues$CA1, a = 0.2, b = 1.9, interval = 1, verbose = FALSE, plot = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 5) }) test_that("check values from output example", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(results$de, 46.67) expect_equal(results$de_err, 2.55) expect_equal(results$n, 24) }) Luminescence/tests/testthat/test_calc_AliquotSize.R0000644000176200001440000000225713047374234022320 0ustar liggesuserscontext("calc_AliquotSize") set.seed(1) temp <- calc_AliquotSize( grain.size = c(100,150), sample.diameter = 1, MC.iter = 100, plot = FALSE, verbose = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 2) expect_is(temp$summary, "data.frame") expect_is(temp$MC, "list") }) test_that("check summary output", { testthat::skip_on_cran() result <- get_RLum(temp) expect_equal(result$grain.size, 125) expect_equal(result$sample.diameter, 1) expect_equal(result$packing.density, 0.65) expect_equal(result$n.grains, 42) expect_equal(result$grains.counted, NA) }) test_that("check MC run", { testthat::skip_on_cran() expect_equal(round(temp$MC$statistics$n), 100) expect_equal(round(temp$MC$statistics$mean), 43) expect_equal(round(temp$MC$statistics$median), 39) expect_equal(round(temp$MC$statistics$sd.abs), 20) expect_equal(round(temp$MC$statistics$sd.rel), 45) expect_equal(round(temp$MC$statistics$se.abs), 2) expect_equal(round(temp$MC$statistics$se.rel), 5) expect_length(temp$MC$kde$x, 10000) expect_length(temp$MC$kde$y, 10000) }) Luminescence/tests/testthat/test_analyse_portableOSL.R0000644000176200001440000000120013047374234022752 0ustar liggesuserscontext("analyse_portableOSL") data("ExampleData.portableOSL", envir = environment()) merged <- merge_RLum(ExampleData.portableOSL) results <- analyse_portableOSL( merged, signal.integral = 1:5, invert = FALSE, normalise = TRUE, plot = FALSE ) test_that("check class and length of output", { testthat::skip_on_cran() expect_is(results, "RLum.Results") expect_equal(length(results), 3) expect_is(results$summary, "data.frame") expect_is(results$data, "RLum.Analysis") }) test_that("check output", { testthat::skip_on_cran() expect_equal(round(sum(results$summary), digits = 2), 70.44) }) Luminescence/tests/testthat/test_plot_GrowthCurve.R0000644000176200001440000000443613125226556022403 0ustar liggesuserscontext("plot_GrowthCurve") set.seed(1) data(ExampleData.LxTxData, envir = environment()) temp_EXP <- plot_GrowthCurve( LxTxData, fit.method = "EXP", output.plot = FALSE, verbose = FALSE, NumberIterations.MC = 10 ) temp_LIN <- plot_GrowthCurve( LxTxData, fit.method = "LIN", output.plot = FALSE, verbose = FALSE, NumberIterations.MC = 10 ) temp_EXPLIN <- plot_GrowthCurve( LxTxData, fit.method = "EXP+LIN", output.plot = FALSE, verbose = FALSE, NumberIterations.MC = 10 ) temp_EXPEXP <- plot_GrowthCurve( LxTxData, fit.method = "EXP+EXP", output.plot = FALSE, verbose = FALSE, NumberIterations.MC = 10 ) temp_QDR <- plot_GrowthCurve( LxTxData, fit.method = "QDR", output.plot = FALSE, verbose = FALSE, NumberIterations.MC = 10 ) test_that("check class and length of output", { testthat::skip_on_cran() expect_is(temp_EXP, class = "RLum.Results", info = NULL, label = NULL) expect_is(temp_EXP$Fit, class = "nls") expect_is(temp_LIN, class = "RLum.Results", info = NULL, label = NULL) expect_is(temp_LIN$Fit, class = "lm") expect_is(temp_EXPLIN, class = "RLum.Results", info = NULL, label = NULL) expect_is(temp_EXPLIN$Fit, class = "nls") expect_is(temp_EXPEXP, class = "RLum.Results", info = NULL, label = NULL) expect_is(temp_EXPEXP$Fit, class = "nls") expect_is(temp_QDR, class = "RLum.Results", info = NULL, label = NULL) expect_is(temp_QDR$Fit, class = "lm") }) test_that("check values from output example", { testthat::skip_on_cran() expect_equivalent(round(temp_EXP$De[[1]], digits = 2), 1737.88) expect_equal(round(sum(temp_EXP$De.MC, na.rm = TRUE), digits = 2), 17440.55) expect_equivalent(round(temp_LIN$De[[1]], digits = 2), 1811.33) expect_equal(round(sum(temp_LIN$De.MC, na.rm = TRUE), digits = 2),18238.02) expect_equivalent(round(temp_EXPLIN$De[[1]], digits = 2), 1791.53) expect_equal(round(sum(temp_EXPLIN$De.MC, na.rm = TRUE), digits = 2),17474.29) expect_equivalent(round(temp_EXPEXP$De[[1]], digits = 2), 1787.15) expect_equal(round(sum(temp_EXPEXP$De.MC, na.rm = TRUE), digits = 0), 7316) expect_equivalent(round(temp_QDR$De[[1]], digits = 2), 1666.2) expect_equal(round(sum(temp_QDR$De.MC, na.rm = TRUE), digits = 2), 14936.76) }) Luminescence/tests/testthat/test_calc_MaxDose.R0000755000176200001440000000212213047374234021401 0ustar liggesuserscontext("calc_MaxDose") data(ExampleData.DeValues, envir = environment()) temp <- calc_MaxDose(ExampleData.DeValues$CA1, sigmab = 0.2, par = 3, plot = FALSE, verbose = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 9) }) test_that("check values from output example", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(round(results$de, digits = 5), 76.57571) expect_equal(round(results$de_err, digits = 6), 7.569908) expect_equal(results$ci_level, 0.95) expect_equal(round(results$ci_lower, digits = 5), 69.65358) expect_equal(round(results$ci_upper, digits = 5), 99.32762) expect_equal(results$par, 3) expect_equal(round(results$sig, digits = 7), 0.5376628) expect_equal(round(results$p0, digits = 7), 0.6482137) expect_equal(results$mu, NA) expect_equal(round(results$Lmax, digits = 5), -19.79245) expect_equal(round(results$BIC, digits = 5), 58.86603) }) Luminescence/tests/testthat/test_calc_CosmicDoseRate.R0000644000176200001440000000344213047374234022710 0ustar liggesuserscontext("calc_CosmicDoseRate") temp <- calc_CosmicDoseRate(depth = 2.78, density = 1.7, latitude = 38.06451, longitude = 1.49646, altitude = 364, error = 10) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 3) }) test_that("check values from output example 1", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(results$depth, 2.78) expect_equal(results$density, 1.7) expect_equal(results$latitude, 38.06451) expect_equal(results$longitude, 1.49646) expect_equal(results$altitude, 364) expect_equal(round(results$total_absorber.gcm2, digits = 0), 473) expect_equal(round(results$d0, digits = 3), 0.152) expect_equal(round(results$geom_lat, digits = 1), 41.1) expect_equal(round(results$dc, digits = 3), 0.161) }) test_that("check values from output example 2b", { testthat::skip_on_cran() temp <- calc_CosmicDoseRate(depth = c(5.0, 2.78), density = c(2.65, 1.7), latitude = 12.04332, longitude = 4.43243, altitude = 364, corr.fieldChanges = TRUE, est.age = 67, error = 15) results <- get_RLum(temp) expect_equal(results$depth.1, 5) expect_equal(results$depth.2, 2.78) expect_equal(results$density.1, 2.65) expect_equal(results$density.2, 1.7) expect_equal(results$latitude, 12.04332) expect_equal(results$longitude, 4.43243) expect_equal(results$altitude, 364) expect_equal(round(results$total_absorber.gcm2, digits = 0), 1798) expect_equal(round(results$d0, digits = 4), 0.0705) expect_equal(round(results$geom_lat, digits = 1), 15.1) expect_equal(round(results$dc, digits = 3), 0.072) }) Luminescence/tests/testthat/test_write_R2BIN.R0000644000176200001440000000367313125226556021116 0ustar liggesuserscontext("write_R2BIN") # Unit test for write_BIN2R() function # # Problem: the tests are not allowed to write on the file system, therefore, we have to run this # manually, but we can test for some errors # # # Uncomment only to create new test data sets on the file system (for read_BIN2R()) # data(ExampleData.BINfileData, envir = environment()) # # ##empty RisoeBINfileData object # empty <- set_Risoe.BINfileData() # # ##replace the raw by numeric # CWOSL.SAR.Data@METADATA$VERSION <- as.numeric(CWOSL.SAR.Data@METADATA$VERSION) # CWOSL.SAR.Data@METADATA[] <- lapply(CWOSL.SAR.Data@METADATA, function(x){ # if(is.factor(x)){ # as.character(x) # }else{ # x # } # }) # # ##combing with existing BIN-file object # new <- as.data.frame( # data.table::rbindlist(l = list(empty@METADATA,CWOSL.SAR.Data@METADATA),fill = TRUE), # stringsAsFactors = FALSE) # # ##new object # new <- set_Risoe.BINfileData(METADATA = new, DATA = CWOSL.SAR.Data@DATA) # # ##replace NA values # new@METADATA[is.na(new@METADATA)] <- 0 # # ##replace RECTYPE # new@METADATA$RECTYPE <- 1 # # ##reduce files size considerably down to two records # new <- subset(new, ID == 1:2) # # ##create files # path <- "tests/testdata/" # write_R2BIN(object = new, file = paste0(path, "BINfile_V3.bin"), version = "03") # write_R2BIN(object = new, file = paste0(path, "BINfile_V4.bin"), version = "04") # write_R2BIN(object = new, file = paste0(path, "BINfile_V6.binx"), version = "06") # write_R2BIN(object = new, file = paste0(path, "BINfile_V7.binx"), version = "07") # write_R2BIN(object = new, file = paste0(path, "BINfile_V8.binx"), version = "08") test_that("write to empty connection", { testthat::skip_on_cran() ##catch errors expect_error(write_R2BIN(object = "a"), "[write_R2BIN()] Input object is not of type Risoe.BINfileData!", fixed = TRUE) expect_error(write_R2BIN(object = set_Risoe.BINfileData(), file = "")) }) Luminescence/tests/testthat/test_calc_FadingCorr.R0000644000176200001440000000230213050146416022045 0ustar liggesuserscontext("calc_FadingCorr") set.seed(1) temp <- calc_FadingCorr( age.faded = c(0.1,0), g_value = c(5.0, 1.0), tc = 2592000, tc.g_value = 172800, n.MC = 100, verbose = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 2) ##check the verbose mode expect_is(calc_FadingCorr( age.faded = c(0.1,0), g_value = c(5.0, 1.0), tc = 2592000, tc.g_value = 172800, n.MC = 1, verbose = TRUE), class = "RLum.Results") }) test_that("check values from output example 1", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(results$AGE, 0.1168) expect_equal(results$AGE.ERROR, 0.0035) expect_equal(results$AGE_FADED, 0.1) expect_equal(results$AGE_FADED.ERROR, 0) expect_equal(results$G_VALUE, 5.312393) expect_equal(round(results$G_VALUE.ERROR, 5), 1.01190) expect_equal(results$KAPPA, 0.02307143) expect_equal(results$KAPPA.ERROR, 0.00439463) expect_equal(results$TC, 8.213721e-05) expect_equal(results$TC.G_VALUE, 5.475814e-06) expect_equal(results$n.MC, 100) expect_equal(results$OBSERVATIONS, 100) expect_equal(results$SEED, NA) }) Luminescence/tests/testthat/test_merge_RLumDataCurve.R0000644000176200001440000000126413050144540022704 0ustar liggesuserscontext("merge_RLum.Data.Curve") test_that("Merge tests", { testthat::skip_on_cran() ##load example data data(ExampleData.XSYG, envir = environment()) TL.curves <- get_RLum(OSL.SARMeasurement$Sequence.Object, recordType = "TL (UVVIS)") TL.curve.1 <- TL.curves[[1]] TL.curve.3 <- TL.curves[[3]] ##check for error expect_error(merge_RLum.Data.Curve("", merge.method = "/")) ##check various operations expect_is(TL.curve.1 + TL.curve.3, "RLum.Data.Curve") expect_is(TL.curve.1 - TL.curve.3, "RLum.Data.Curve") expect_is(TL.curve.3 / TL.curve.1, "RLum.Data.Curve") expect_warning(TL.curve.3 / TL.curve.1) expect_is(TL.curve.1 * TL.curve.3, "RLum.Data.Curve") }) Luminescence/tests/testthat/test_Analyse_SAROSLdata.R0000644000176200001440000000100713047374234022366 0ustar liggesuserscontext("Test old Analyse_SAROSLdata()") test_that("full example test", { testthat::skip_on_cran() data(ExampleData.BINfileData, envir = environment()) 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 = FALSE) ##checks expect_is(output, "list") expect_length(output, 3) }) Luminescence/tests/testthat/test_names_RLum.R0000644000176200001440000000037213050144537021116 0ustar liggesuserscontext("names_RLum") test_that("Test whether function works", { testthat::skip_on_cran() data(ExampleData.RLum.Analysis, envir = environment()) expect_silent(names_RLum(IRSAR.RF.Data)) expect_is(names_RLum(IRSAR.RF.Data), "character") }) Luminescence/tests/testthat/test_PSL2RisoeBINfiledata.R0000644000176200001440000000050413047374234022623 0ustar liggesuserscontext("Test PSL2Risoe.BINfileData") test_that("simple test", { testthat::skip_on_cran() data("ExampleData.portableOSL", envir = environment()) merged <- merge_RLum(ExampleData.portableOSL) bin <- PSL2Risoe.BINfileData(merged) ##checks expect_is(bin, "Risoe.BINfileData") expect_equal(length(bin), 70) }) Luminescence/tests/testthat/test_plot_Functions.R0000644000176200001440000001134113060567611022063 0ustar liggesuserscontext("Test Various Plot Functions") test_that("test pure success of the plotting without warning or error", { testthat::skip_on_cran() ##distribution plots data(ExampleData.DeValues, envir = environment()) ExampleData.DeValues <- ExampleData.DeValues$CA1 expect_silent(plot_RadialPlot(ExampleData.DeValues)) expect_silent(plot_KDE(ExampleData.DeValues)) expect_silent(plot_Histogram(ExampleData.DeValues)) expect_silent(plot_ViolinPlot(ExampleData.DeValues)) ##plot NRT data("ExampleData.BINfileData", envir = environment()) data <- Risoe.BINfileData2RLum.Analysis(object = CWOSL.SAR.Data, pos = 8, ltype = "OSL") allCurves <- get_RLum(data) pos <- seq(1, 9, 2) curves <- allCurves[pos] expect_silent(plot_NRt(curves)) ##filter combinations filter1 <- density(rnorm(100, mean = 450, sd = 20)) filter1 <- matrix(c(filter1$x, filter1$y/max(filter1$y)), ncol = 2) filter2 <- matrix(c(200:799,rep(c(0,0.8,0),each = 200)), ncol = 2) expect_silent(plot_FilterCombinations(filters = list(filter1, filter2))) ##plot_Det data(ExampleData.BINfileData, envir = environment()) object <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos=1) expect_is( plot_DetPlot( object, signal.integral.min = 1, signal.integral.max = 3, background.integral.min = 900, background.integral.max = 1000, n.channels = 5, ), "RLum.Results" ) ##plot DRT data(ExampleData.DeValues, envir = environment()) expect_silent(plot_DRTResults(values = ExampleData.DeValues$BT998[7:11,], given.dose = 2800, mtext = "Example data")) ##plot RisoeBINFileData data(ExampleData.BINfileData, envir = environment()) expect_silent(plot_Risoe.BINfileData(CWOSL.SAR.Data,position = 1)) ##various RLum plots ##RLum.Data.Curve data(ExampleData.CW_OSL_Curve, envir = environment()) temp <- as(ExampleData.CW_OSL_Curve, "RLum.Data.Curve") expect_silent(plot(temp)) ##RLum.Data.Image data(ExampleData.RLum.Data.Image, envir = environment()) expect_silent(plot(ExampleData.RLum.Data.Image)) ##RLum.Data.Spectrum ------- data(ExampleData.XSYG, envir = environment()) expect_silent(plot(TL.Spectrum, plot.type="contour", xlim = c(310,750), ylim = c(0,300))) expect_silent(suppressWarnings(plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="persp", xlim = c(310,750), ylim = c(0,100), bin.rows=10, bin.cols = 1))) expect_silent(suppressWarnings(plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="multiple.lines", xlim = c(310,750), ylim = c(0,100), bin.rows=10, bin.cols = 1))) expect_silent(suppressWarnings(plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="interactive", xlim = c(310,750), ylim = c(0,300), bin.rows=10, bin.cols = 1))) expect_silent(suppressWarnings(plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="interactive", xlim = c(310,750), ylim = c(0,300), bin.rows=10, bin.cols = 1, type = "heatmap", showscale = TRUE))) expect_silent(suppressWarnings(plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="interactive", xlim = c(310,750), ylim = c(0,300), bin.rows=10, bin.cols = 1, type = "contour", showscale = TRUE))) expect_error(plot(TL.Spectrum, plot.type="contour", xlim = c(310,750), ylim = c(0,300), bin.cols = 0)) ##RLum.Analysis data(ExampleData.BINfileData, envir = environment()) temp <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos=1) expect_silent(plot( temp, subset = list(recordType = "TL"), combine = TRUE, norm = TRUE, abline = list(v = c(110)) )) ##RLum.Results grains<- calc_AliquotSize(grain.size = c(100,150), sample.diameter = 1, plot = FALSE, MC.iter = 100) expect_silent(plot_RLum.Results(grains)) }) test_that("test for return values, if any", { testthat::skip_on_cran() data(ExampleData.DeValues, envir = environment()) output <- plot_AbanicoPlot(ExampleData.DeValues, output = TRUE) expect_is(output, "list") expect_length(output, 10) }) Luminescence/tests/testthat/test_get_RLum.R0000644000176200001440000000164313047374234020601 0ustar liggesuserscontext("get_RLum") data(ExampleData.DeValues, envir = environment()) temp <- calc_CentralDose(ExampleData.DeValues$CA1, plot = FALSE, verbose = FALSE) temp_RLumDataCurve <- set_RLum(class = "RLum.Data.Curve") temp_RLumDataImage <- set_RLum(class = "RLum.Data.Image") temp_RLumDataSpectrum <- set_RLum(class = "RLum.Data.Spectrum") temp_RLumAnalysis <- set_RLum(class = "RLum.Analysis") temp_RLumResults <- set_RLum(class = "RLum.Results") test_that("check class and length of output", { testthat::skip_on_cran() expect_is(get_RLum(temp), class = "data.frame") expect_is(get_RLum(temp, data.object = "args"), class = "list") ##test objects expect_is(get_RLum(temp_RLumDataCurve), class = "matrix") expect_is(get_RLum(temp_RLumDataImage), class = "RasterBrick") expect_is(get_RLum(temp_RLumDataSpectrum), class = "matrix") expect_null(get_RLum(temp_RLumAnalysis)) expect_null(get_RLum(temp_RLumResults)) }) Luminescence/tests/testthat/test_calc_SourceDoseRate.R0000755000176200001440000000131113047374234022727 0ustar liggesuserscontext("calc_SourceDoseRate") temp <- calc_SourceDoseRate(measurement.date = "2012-01-27", calib.date = "2014-12-19", calib.dose.rate = 0.0438, calib.error = 0.0019) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 3) }) test_that("check values from output example 1", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(round(results$dose.rate, digits = 8), 0.04695031) expect_equal(round(results$dose.rate.error, digits = 9), 0.002036657) expect_equal(results$date, as.Date("2012-01-27")) }) Luminescence/tests/testthat/test_merge_RisoeBINfileData.R0000644000176200001440000000121613050144537023275 0ustar liggesuserscontext("merge_RisoeBINfileData") ##Full check test_that("Test merging", { skip_on_cran() ##expect error expect_error(merge_Risoe.BINfileData(input.objects = "data")) expect_error(merge_Risoe.BINfileData(input.objects = c("data", "data2"))) expect_error(merge_Risoe.BINfileData(input.objects = list("data", "data2")), regexp = "[merge_Risoe.BINfileData()] Input list does not contain Risoe.BINfileData objects!", fixed = TRUE) ##expect success data(ExampleData.BINfileData, envir = environment()) object1 <- CWOSL.SAR.Data object2 <- CWOSL.SAR.Data expect_is(merge_Risoe.BINfileData(c(object1, object2)), "Risoe.BINfileData") }) Luminescence/tests/testthat/test_fit_CWCurve.R0000644000176200001440000000135113047374234021237 0ustar liggesuserscontext("fit_CWCurve") data(ExampleData.CW_OSL_Curve, envir = environment()) fit <- fit_CWCurve(values = ExampleData.CW_OSL_Curve, main = "CW Curve Fit", n.components.max = 4, log = "x", plot = FALSE) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(fit), c("RLum.Results", "RLum")) expect_equal(length(fit), 3) }) test_that("check values from output example", { testthat::skip_on_cran() expect_equal(fit$data$n.components, 3) expect_equal(round(fit$data$I01, digits = 3), 2387.617) expect_equal(round(fit$data$lambda1, digits = 5), 4.59054) expect_equal(round(fit$data$`pseudo-R^2`, digits = 4), 0.9995) }) Luminescence/tests/testthat/test_template_DRAC.R0000644000176200001440000000045013050146416021453 0ustar liggesuserscontext("template_DRAC") ##Full check test_that("Check template creation ", { skip_on_cran() ##test success expect_is(template_DRAC(), "DRAC.list") expect_is(template_DRAC(notification = FALSE), "DRAC.list") expect_is(template_DRAC(nrow = 10, notification = FALSE), "DRAC.list") }) Luminescence/tests/testthat/test_verify_SingleGrainData.R0000644000176200001440000000051413047374234023437 0ustar liggesuserscontext("Test verify_SingleGrainData") test_that("Various function test", { testthat::skip_on_cran() data(ExampleData.XSYG, envir = environment()) output <- verify_SingleGrainData(OSL.SARMeasurement$Sequence.Object) ##return value expect_is(output, "RLum.Results") expect_is(output$selection_full, "data.frame") }) Luminescence/tests/testthat/test_calc_Kars2008.R0000644000176200001440000000350413047374234021255 0ustar liggesuserscontext("calc_Kars2008") set.seed(1) data("ExampleData.Fading", envir = environment()) fading_data <- ExampleData.Fading$fading.data$IR50 data <- ExampleData.Fading$equivalentDose.data$IR50 ddot <- c(7.00, 0.004) readerDdot <- c(0.134, 0.0067) rhop <- analyse_FadingMeasurement(fading_data, plot = FALSE, verbose = FALSE, n.MC = 10) kars <- calc_Kars2008( data = data, rhop = rhop, ddot = ddot, readerDdot = readerDdot, n.MC = 50, plot = FALSE ) test_that("check class and length of output", { testthat::skip_on_cran() ##rhop expect_is(rhop, class = "RLum.Results", info = NULL, label = NULL) expect_is(rhop$fading_results, "data.frame") expect_is(rhop$fit, "lm") expect_is(rhop$rho_prime, "data.frame") ##kars expect_is(kars, class = "RLum.Results", info = NULL, label = NULL) expect_is(kars$results, class = "data.frame", info = NULL, label = NULL) expect_is(kars$data, class = "data.frame", info = NULL, label = NULL) expect_is(kars$Ln, class = "numeric", info = NULL, label = NULL) expect_is(kars$fits, class = "list", info = NULL, label = NULL) }) test_that("check values from analyse_FadingMeasurement()", { expect_equal(round(sum(rhop$fading_results[,1:9]),0),415) expect_equal(round(sum(rhop$rho_prime),5),2e-05) expect_equal(round(sum(rhop$irr.times)), 2673108) }) test_that("check values from calc_Kars2008()", { testthat::skip_on_cran() expect_equal(round(sum(kars$results),0), 2417) expect_equal(round(sum(kars$data),0), 191530) expect_equal(round(sum(kars$Ln),4), 0.1585) expect_equal(round(sum(residuals(kars$fits$simulated)),4), 1.2386) expect_equal(round(sum(residuals(kars$fits$measured)),4), 0.1894) expect_equal(round(sum(residuals(kars$fits$unfaded)),4), 1.6293) }) Luminescence/tests/testthat/test_analyse_IRSARRF.R0000644000176200001440000000322113047374234021701 0ustar liggesuserscontext("analyse_IRSAR.RF") test_that("check class and length of output", { testthat::skip_on_cran() set.seed(1) data(ExampleData.RLum.Analysis, envir = environment()) results_fit <- analyse_IRSAR.RF(object = IRSAR.RF.Data, plot = FALSE, method = "FIT") results_slide <- analyse_IRSAR.RF(object = IRSAR.RF.Data, plot = FALSE, method = "SLIDE", n.MC = NULL) results_slide_alt <- analyse_IRSAR.RF( object = IRSAR.RF.Data, plot = FALSE, method = "SLIDE", n.MC = 10, method.control = list(vslide_range = 'auto', trace_vslide = TRUE), txtProgressBar = FALSE ) expect_equal(is(results_fit), c("RLum.Results", "RLum")) expect_equal(length(results_fit), 5) expect_equal(length(results_slide), 5) expect_is(results_fit$fit, class = "nls", info = NULL, label = NULL) expect_is(results_slide$fit, class = "nls", info = NULL, label = NULL) expect_length(results_slide$slide, 10) expect_equal(results_fit$data$DE, 623.25) expect_equal(results_fit$data$DE.LOWER, 600.63) expect_equal(results_slide$data$DE, 610.17) expect_equal(round(results_slide_alt$data$DE, digits = 0), 384) }) test_that("test controlled chrash conditions", { testthat::skip_on_cran() ##the sliding range should not exceed a certrain value ... test it data(ExampleData.RLum.Analysis, envir = environment()) expect_error( analyse_IRSAR.RF( object = IRSAR.RF.Data, plot = FALSE, method = "SLIDE", n.MC = 10, method.control = list(vslide_range = c(0,1e+08)), txtProgressBar = FALSE ), regexp = "[:::.analyse_IRSAR_SRS()] 'vslide_range' exceeded maximum size (1e+08)!", fixed = TRUE) }) Luminescence/tests/testthat/test_calc_OSLLxTxRatio.R0000755000176200001440000000171513047374234022324 0ustar liggesuserscontext("calc_OSLLxTxRatio") data(ExampleData.LxTxOSLData, envir = environment()) temp <- calc_OSLLxTxRatio( Lx.data = Lx.data, Tx.data = Tx.data, signal.integral = c(1:2), background.integral = c(85:100)) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 2) }) test_that("check values from output example", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(results$LnLx, 81709) expect_equal(results$LnLx.BG, 530) expect_equal(results$TnTx, 7403) expect_equal(results$TnTx.BG, 513) expect_equal(results$Net_LnLx, 81179) expect_equal(round(results$Net_LnLx.Error, digits = 4), 286.5461) expect_equal(results$Net_TnTx, 6890) expect_equal(round(results$Net_TnTx.Error, digits = 5), 88.53581) expect_equal(round(results$LxTx, digits = 5), 11.78215) expect_equal(round(results$LxTx.Error, digits = 7), 0.1570077) }) Luminescence/tests/testthat/test_analyse_SARTL.R0000644000176200001440000000117113050151227021445 0ustar liggesuserscontext("analyse_SAR.TL") ##Full check test_that("Test examples", { skip_on_cran() ##load data data(ExampleData.BINfileData, envir = environment()) ##transform the values from the first position in a RLum.Analysis object object <- Risoe.BINfileData2RLum.Analysis(TL.SAR.Data, pos=3) ##perform analysis ##TODO ... there is a warning expect_is(analyse_SAR.TL(object, signal.integral.min = 210, signal.integral.max = 220, log = "y", fit.method = "EXP OR LIN", sequence.structure = c("SIGNAL", "BACKGROUND")), "RLum.Results") }) Luminescence/tests/testthat/test_bin_RLumData.R0000644000176200001440000000116513047374234021363 0ustar liggesuserscontext("bin_RLum.Data") data(ExampleData.CW_OSL_Curve, envir = environment()) curve <- set_RLum( class = "RLum.Data.Curve", recordType = "OSL", data = as.matrix(ExampleData.CW_OSL_Curve) ) test_that("check class and length of output", { testthat::skip_on_cran() expect_is(bin_RLum.Data(curve), class = "RLum.Data.Curve", info = NULL, label = NULL) expect_length(bin_RLum.Data(curve)[,1], 500) }) test_that("check values from output example", { testthat::skip_on_cran() expect_equal(sum(bin_RLum.Data(curve)[,2]), 119200) expect_equal(sum(bin_RLum.Data(curve, bin = 5)[1,2]), 41146) }) Luminescence/tests/testthat/test_calc_TLLxTxRatio.R0000644000176200001440000000270013047374234022176 0ustar liggesuserscontext("calc_TLLxTxRatio") ##load package example data data(ExampleData.BINfileData, envir = environment()) ##convert Risoe.BINfileData into a curve object temp <- Risoe.BINfileData2RLum.Analysis(TL.SAR.Data, pos = 3) Lx.data.signal <- get_RLum(temp, record.id=1) Lx.data.background <- get_RLum(temp, record.id=2) Tx.data.signal <- get_RLum(temp, record.id=3) Tx.data.background <- get_RLum(temp, record.id=4) signal.integral.min <- 210 signal.integral.max <- 230 temp <- calc_TLLxTxRatio(Lx.data.signal, Lx.data.background, Tx.data.signal, Tx.data.background, signal.integral.min, signal.integral.max) test_that("check class and length of output", { testthat::skip_on_cran() expect_equal(is(temp), c("RLum.Results", "RLum")) expect_equal(length(temp), 1) }) test_that("check values from output", { testthat::skip_on_cran() results <- get_RLum(temp) expect_equal(length(results), 10) expect_equal(results$LnLx, 257042) expect_equal(results$LnLx.BG, 4068) expect_equal(results$TnTx, 82298) expect_equal(results$TnTx.BG, 2943) expect_equal(results$net_LnLx, 252974) expect_equal(round(results$net_LnLx.Error, digits = 2), 49468.92) expect_equal(results$net_TnTx, 79355) expect_equal(round(results$net_TnTx.Error,2), 21449.72) expect_equal(round(results$LxTx, digits = 6), 3.187877) expect_equal(round(results$LxTx.Error, digits = 6), 1.485073) }) Luminescence/src/0000755000176200001440000000000013125227600013451 5ustar liggesusersLuminescence/src/analyse_IRSARRF_SRS.cpp0000644000176200001440000001446413125227601017542 0ustar liggesusers//analyse_IRSARRF_SRS.cpp //author: Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) //version: 0.3.5 [2017-02-06] //Function calculates the squared residuals for the R function analyse_IRSAR.RF() //including MC runs for the obtained minimum. The function allows a horizontal and //a vertical sliding of the curve // #include #include // [[Rcpp::depends(RcppArmadillo)]] using namespace Rcpp; // [[Rcpp::export(".analyse_IRSARRF_SRS")]] RcppExport SEXP analyse_IRSARRF_SRS(NumericVector values_regenerated_limited, NumericVector values_natural_limited, NumericVector vslide_range, int n_MC, bool trace = false ){ //check for the vslide_range() if(vslide_range.length() > 1e+08){ stop("[:::.analyse_IRSAR_SRS()] 'vslide_range' exceeded maximum size (1e+08)!"); } //pre-define variables NumericVector residuals = values_natural_limited.length(); NumericVector results = values_regenerated_limited.size() - values_natural_limited.size(); NumericVector results_vector_min_MC = n_MC; //variables for the algorithm int v_length; int v_index; NumericVector v_leftright(2); //the virtual vector NumericVector t_leftright(2); //the test points NumericVector c_leftright(2); //the calculation //(1) calculate sum of the squared residuals // this will be used to find the best fit of the curves (which is the minimum) //initialise values v_length = vslide_range.length(); v_index = 0; v_leftright[0] = 0; v_leftright[1] = vslide_range.length() - 1; if(v_length == 1){ t_leftright[0] = 0; t_leftright[1] = 0; }else{ t_leftright[0] = v_length/3; t_leftright[1] = 2 * v_length/3; } //***TRACE**** if(trace == true){ Rcout << "\n\n [:::.analyse_IRSAR_SRS()]"; Rcout << "\n\n--- Inititalisation --- \n "; Rcout << "\n >> v_leftright: " << v_leftright; Rcout << "\n >> t_leftright: " << t_leftright; Rcout << "\n\n --- Optimisation --- \n "; Rcout << "\n ---------------------------------------------------------------------------------------------------------"; Rcout << "\n v_length \t\t v_leftright \t\t c_leftright \t\t\t\t absolute offset"; Rcout << "\n ---------------------------------------------------------------------------------------------------------"; } //start loop do { for (int t=0;t c_leftright[1]){ v_index = v_leftright[1]; //set index to right test index //update vector window (the right remains the same this time) v_leftright[0] = t_leftright[0]; //update window length v_length = v_leftright[1] - v_leftright[0]; }else{ v_length = 1; } //update test point index t_leftright[0] = v_leftright[0] + v_length/3; t_leftright[1] = v_leftright[0] + (2 * (v_length/3)); //***TRACE**** if(trace == true){ Rcout << "\n " << v_length << " \t\t\t " << v_leftright << " \t\t " << c_leftright << " \t\t\t " << vslide_range[v_index]; } } while (v_length > 1); //***TRACE**** if(trace == true){ Rcout << "\n ---------------------------------------------------------------------------------------------------------"; Rcout << "\n >> SRS minimum: \t\t " << c_leftright[0]; Rcout << "\n >> Vertical offset index: \t " << v_index + 1; Rcout << "\n >> Vertical offset absolute: \t " << vslide_range[v_index] << "\n\n"; } //(2) error calculation //use this values to bootstrap and find minimum values and to account for the variation //that may result from this method itself (the minimum lays within a valley of minima) // //using the obtained sliding vector and the function RcppArmadillo::sample() (which equals the //function sample() in R, but faster) //http://gallery.rcpp.org/articles/using-the-Rcpp-based-sample-implementation //this follows the way described in Frouin et al., 2017 ... still ... for (int i=0; i #include using namespace Rcpp; // [[Rcpp::export(".create_UID")]] CharacterVector create_UID() { //define variables CharacterVector random; time_t rawtime; struct tm * timeinfo; char timestamp [80]; //set date + timestamp (code snippet taken from C++ reference page) time (&rawtime); timeinfo = localtime (&rawtime); strftime (timestamp,80,"%Y-%m-%d-%I:%M.",timeinfo); //get time information and add a random number //according to the CRAN policy the standard C-function, rand(), even sufficient here, is not allowed random = runif(1); //combine and return results return timestamp + Rcpp::as(random); } Luminescence/src/Luminescence_init.c0000644000176200001440000000166213125227601017260 0ustar liggesusers#include #include #include // for NULL #include /* FIXME: Check these declarations against the C/Fortran source code. */ /* .Call calls */ extern SEXP Luminescence_analyse_IRSARRF_SRS(SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP Luminescence_create_RLumDataCurve_matrix(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP Luminescence_create_UID(); static const R_CallMethodDef CallEntries[] = { {"Luminescence_analyse_IRSARRF_SRS", (DL_FUNC) &Luminescence_analyse_IRSARRF_SRS, 5}, {"Luminescence_create_RLumDataCurve_matrix", (DL_FUNC) &Luminescence_create_RLumDataCurve_matrix, 10}, {"Luminescence_create_UID", (DL_FUNC) &Luminescence_create_UID, 0}, {NULL, NULL, 0} }; void R_init_Luminescence(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } Luminescence/src/create_RLumDataCurve_matrix.cpp0000644000176200001440000000526613125227601021554 0ustar liggesusers//create_RLumDataCurve_matrix.cpp //author: Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) //version: 0.1.0 [2016-06-28] //Function to create the RLum.Data.Curve() matrix ... faster than in R itself #include using namespace Rcpp; // ----------------------------------------------------------------------------------------------- // Define own function to create a sequence for the x-axis // .. but we do not export them to avoid side effects, as this function is not the same as the // .. base R function seq() // ..no export NumericVector seq(int from, int to, double length_out) { //set variables NumericVector sequence = length_out; double by = (to - from) / (length_out - 1); //loop and create sequence for (int i=0; i < length_out; ++i){ if(i == 0){ sequence[i] = from; }else{ sequence[i] = sequence[i-1] + by; } } return sequence; } // ----------------------------------------------------------------------------------------------- // The function we want to export // [[Rcpp::export(".create_RLumDataCurve_matrix")]] NumericMatrix create_RLumDataCurve_matrix( NumericVector DATA, int VERSION, int NPOINTS, String LTYPE, int LOW, int HIGH, int AN_TEMP, int TOLDELAY, int TOLON, int TOLOFF ){ //generate X vectors if(NPOINTS > 0){ //set needed vectors and predefine matrix NumericVector X = NPOINTS; NumericMatrix curve_matrix(NPOINTS, 2); //fill x column for the case we have a TL curve if(LTYPE == "TL" && VERSION >= 4){ //the heating curve consists of three vectors that needed to //be combined // //(A) - the start ramping NumericVector heat_ramp_start = seq(LOW,AN_TEMP,TOLDELAY); // //(B) - the plateau //B is simply TOLON // //(C) - the end ramping NumericVector heat_ramp_end = seq(AN_TEMP, HIGH, TOLOFF); //set index counters int c = 0; //fill vector for temperature for(int i = 0; i < X.length(); i++){ if(i < heat_ramp_start.length()){ X[i] = heat_ramp_start[i]; }else if(i >= heat_ramp_start.length() && i < heat_ramp_start.length() + TOLON){ X[i] = AN_TEMP; }else if(i >= heat_ramp_start.length() + TOLON){ X[i] = heat_ramp_end[c]; c++; } } }else{ X = seq(LOW, HIGH, NPOINTS); } //set final matrix curve_matrix.column(0) = X; curve_matrix.column(1) = DATA; return(curve_matrix); }else{ //set final matrix NumericMatrix curve_matrix(1, 2); curve_matrix(0,0) = NumericVector::get_na(); curve_matrix(0,1) = NumericVector::get_na(); return(curve_matrix); } } Luminescence/src/RcppExports.cpp0000644000176200001440000000551013125227601016450 0ustar liggesusers// Generated by using Rcpp::compileAttributes() -> do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include #include using namespace Rcpp; // analyse_IRSARRF_SRS RcppExport SEXP analyse_IRSARRF_SRS(NumericVector values_regenerated_limited, NumericVector values_natural_limited, NumericVector vslide_range, int n_MC, bool trace); RcppExport SEXP Luminescence_analyse_IRSARRF_SRS(SEXP values_regenerated_limitedSEXP, SEXP values_natural_limitedSEXP, SEXP vslide_rangeSEXP, SEXP n_MCSEXP, SEXP traceSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type values_regenerated_limited(values_regenerated_limitedSEXP); Rcpp::traits::input_parameter< NumericVector >::type values_natural_limited(values_natural_limitedSEXP); Rcpp::traits::input_parameter< NumericVector >::type vslide_range(vslide_rangeSEXP); Rcpp::traits::input_parameter< int >::type n_MC(n_MCSEXP); Rcpp::traits::input_parameter< bool >::type trace(traceSEXP); rcpp_result_gen = Rcpp::wrap(analyse_IRSARRF_SRS(values_regenerated_limited, values_natural_limited, vslide_range, n_MC, trace)); return rcpp_result_gen; END_RCPP } // create_RLumDataCurve_matrix NumericMatrix create_RLumDataCurve_matrix(NumericVector DATA, int VERSION, int NPOINTS, String LTYPE, int LOW, int HIGH, int AN_TEMP, int TOLDELAY, int TOLON, int TOLOFF); RcppExport SEXP Luminescence_create_RLumDataCurve_matrix(SEXP DATASEXP, SEXP VERSIONSEXP, SEXP NPOINTSSEXP, SEXP LTYPESEXP, SEXP LOWSEXP, SEXP HIGHSEXP, SEXP AN_TEMPSEXP, SEXP TOLDELAYSEXP, SEXP TOLONSEXP, SEXP TOLOFFSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type DATA(DATASEXP); Rcpp::traits::input_parameter< int >::type VERSION(VERSIONSEXP); Rcpp::traits::input_parameter< int >::type NPOINTS(NPOINTSSEXP); Rcpp::traits::input_parameter< String >::type LTYPE(LTYPESEXP); Rcpp::traits::input_parameter< int >::type LOW(LOWSEXP); Rcpp::traits::input_parameter< int >::type HIGH(HIGHSEXP); Rcpp::traits::input_parameter< int >::type AN_TEMP(AN_TEMPSEXP); Rcpp::traits::input_parameter< int >::type TOLDELAY(TOLDELAYSEXP); Rcpp::traits::input_parameter< int >::type TOLON(TOLONSEXP); Rcpp::traits::input_parameter< int >::type TOLOFF(TOLOFFSEXP); rcpp_result_gen = Rcpp::wrap(create_RLumDataCurve_matrix(DATA, VERSION, NPOINTS, LTYPE, LOW, HIGH, AN_TEMP, TOLDELAY, TOLON, TOLOFF)); return rcpp_result_gen; END_RCPP } // create_UID CharacterVector create_UID(); RcppExport SEXP Luminescence_create_UID() { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; rcpp_result_gen = Rcpp::wrap(create_UID()); return rcpp_result_gen; END_RCPP } Luminescence/NAMESPACE0000644000176200001440000001632213125227567014121 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("$",RLum.Analysis) S3method("$",RLum.Data.Curve) S3method("$",RLum.Results) S3method("$<-",DRAC.list) S3method("*",RLum.Data.Curve) S3method("+",RLum.Data.Curve) S3method("-",RLum.Data.Curve) S3method("/",RLum.Data.Curve) S3method("[",RLum.Analysis) S3method("[",RLum.Data.Curve) S3method("[",RLum.Data.Image) S3method("[",RLum.Data.Spectrum) S3method("[",RLum.Results) S3method("[<-",DRAC.list) S3method("[<-",RLum.Data.Curve) S3method("[[",RLum.Analysis) S3method("[[",RLum.Results) S3method("[[<-",DRAC.list) S3method(as.data.frame,DRAC.list) S3method(as.data.frame,RLum.Data.Curve) S3method(as.data.frame,RLum.Data.Spectrum) S3method(as.list,RLum.Analysis) S3method(as.list,RLum.Data.Curve) S3method(as.list,RLum.Results) S3method(as.matrix,RLum.Data.Curve) S3method(as.matrix,RLum.Data.Spectrum) S3method(dim,RLum.Data.Curve) S3method(dim,RLum.Data.Spectrum) S3method(hist,RLum.Analysis) S3method(hist,RLum.Data.Curve) S3method(hist,RLum.Data.Image) S3method(hist,RLum.Results) S3method(length,RLum.Analysis) S3method(length,RLum.Data.Curve) S3method(length,RLum.Results) S3method(length,Risoe.BINfileData) S3method(merge,RLum) S3method(names,RLum.Analysis) S3method(names,RLum.Data.Curve) S3method(names,RLum.Data.Image) S3method(names,RLum.Data.Spectrum) S3method(names,RLum.Results) S3method(names,Risoe.BINfileData) S3method(plot,RLum.Analysis) S3method(plot,RLum.Data.Curve) S3method(plot,RLum.Data.Image) S3method(plot,RLum.Data.Spectrum) S3method(plot,RLum.Results) S3method(plot,Risoe.BINfileData) S3method(plot,list) S3method(print,DRAC.highlights) S3method(print,DRAC.list) S3method(rep,RLum) S3method(row.names,RLum.Data.Spectrum) S3method(subset,RLum.Analysis) S3method(subset,Risoe.BINfileData) S3method(summary,RLum.Analysis) S3method(summary,RLum.Data.Curve) S3method(summary,RLum.Data.Image) S3method(summary,RLum.Results) S3method(unlist,RLum.Analysis) export(Analyse_SAR.OSLdata) export(CW2pHMi) export(CW2pLM) export(CW2pLMi) export(CW2pPMi) export(PSL2Risoe.BINfileData) export(Risoe.BINfileData2RLum.Analysis) export(Second2Gray) export(analyse_FadingMeasurement) export(analyse_IRSAR.RF) export(analyse_SAR.CWOSL) export(analyse_SAR.TL) export(analyse_baSAR) export(analyse_pIRIRSequence) export(analyse_portableOSL) export(app_RLum) export(apply_CosmicRayRemoval) export(apply_EfficiencyCorrection) export(bin.RLum.Data.Curve) export(bin_RLum.Data) export(calc_AliquotSize) export(calc_AverageDose) export(calc_CentralDose) export(calc_CommonDose) export(calc_CosmicDoseRate) export(calc_FadingCorr) export(calc_FastRatio) export(calc_FiniteMixture) export(calc_FuchsLang2001) export(calc_HomogeneityTest) export(calc_IEU) export(calc_Kars2008) export(calc_MaxDose) export(calc_MinDose) export(calc_OSLLxTxRatio) export(calc_SourceDoseRate) export(calc_Statistics) export(calc_TLLxTxRatio) export(calc_ThermalLifetime) export(calc_gSGC) export(convert_BIN2CSV) export(convert_Daybreak2CSV) export(convert_PSL2CSV) export(convert_XSYG2CSV) export(extract_IrradiationTimes) export(fit_CWCurve) export(fit_LMCurve) export(get_Layout) export(get_Quote) export(get_RLum) export(get_Risoe.BINfileData) export(get_rightAnswer) export(github_branches) export(github_commits) export(github_issues) export(install_DevelopmentVersion) export(is.RLum) export(is.RLum.Analysis) export(is.RLum.Data) export(is.RLum.Data.Curve) export(is.RLum.Data.Image) export(is.RLum.Data.Spectrum) export(is.RLum.Results) export(length_RLum) export(merge_RLum) export(merge_RLum.Analysis) export(merge_RLum.Data.Curve) export(merge_RLum.Results) export(merge_Risoe.BINfileData) export(model_LuminescenceSignals) export(names_RLum) export(plot_AbanicoPlot) export(plot_DRTResults) export(plot_DetPlot) export(plot_FilterCombinations) export(plot_GrowthCurve) export(plot_Histogram) export(plot_KDE) export(plot_NRt) export(plot_RLum) export(plot_RLum.Analysis) export(plot_RLum.Data.Curve) export(plot_RLum.Data.Image) export(plot_RLum.Data.Spectrum) export(plot_RLum.Results) export(plot_RadialPlot) export(plot_Risoe.BINfileData) export(plot_ViolinPlot) export(read_BIN2R) export(read_Daybreak2R) export(read_PSL2R) export(read_SPE2R) export(read_XSYG2R) export(replicate_RLum) export(report_RLum) export(sTeve) export(set_RLum) export(set_Risoe.BINfileData) export(smooth_RLum) export(structure_RLum) export(template_DRAC) export(tune_Data) export(use_DRAC) export(verify_SingleGrainData) export(write_R2BIN) export(write_RLum2CSV) exportClasses(RLum) exportClasses(RLum.Analysis) exportClasses(RLum.Data) exportClasses(RLum.Data.Curve) exportClasses(RLum.Data.Image) exportClasses(RLum.Data.Spectrum) exportClasses(RLum.Results) exportClasses(Risoe.BINfileData) exportMethods(bin_RLum.Data) exportMethods(get_RLum) exportMethods(get_Risoe.BINfileData) exportMethods(length_RLum) exportMethods(names_RLum) exportMethods(replicate_RLum) exportMethods(set_RLum) exportMethods(set_Risoe.BINfileData) exportMethods(show) exportMethods(smooth_RLum) exportMethods(structure_RLum) import(data.table) import(magrittr) import(methods) import(utils) importClassesFrom(raster,RasterBrick) importFrom(grDevices,adjustcolor) importFrom(grDevices,axisTicks) importFrom(grDevices,colorRampPalette) importFrom(grDevices,dev.off) importFrom(grDevices,gray.colors) importFrom(grDevices,rgb) importFrom(grDevices,topo.colors) importFrom(grDevices,xy.coords) importFrom(graphics,abline) importFrom(graphics,arrows) importFrom(graphics,axTicks) importFrom(graphics,axis) importFrom(graphics,barplot) importFrom(graphics,box) importFrom(graphics,boxplot) importFrom(graphics,contour) importFrom(graphics,curve) importFrom(graphics,frame) importFrom(graphics,grconvertX) importFrom(graphics,grconvertY) importFrom(graphics,grid) importFrom(graphics,hist) importFrom(graphics,layout) importFrom(graphics,legend) importFrom(graphics,lines) importFrom(graphics,mtext) importFrom(graphics,par) importFrom(graphics,persp) importFrom(graphics,plot) importFrom(graphics,plot.default) importFrom(graphics,points) importFrom(graphics,polygon) importFrom(graphics,rug) importFrom(graphics,segments) importFrom(graphics,text) importFrom(graphics,title) importFrom(httr,GET) importFrom(httr,accept_json) importFrom(httr,content) importFrom(httr,status_code) importFrom(parallel,makeCluster) importFrom(parallel,parLapply) importFrom(parallel,stopCluster) importFrom(raster,brick) importFrom(raster,contour) importFrom(raster,nlayers) importFrom(raster,plot) importFrom(raster,plotRGB) importFrom(raster,raster) importFrom(stats,approx) importFrom(stats,as.formula) importFrom(stats,coef) importFrom(stats,complete.cases) importFrom(stats,confint) importFrom(stats,density) importFrom(stats,dnorm) importFrom(stats,glm) importFrom(stats,lm) importFrom(stats,median) importFrom(stats,na.exclude) importFrom(stats,na.omit) importFrom(stats,nls) importFrom(stats,nls.control) importFrom(stats,pchisq) importFrom(stats,pnorm) importFrom(stats,predict) importFrom(stats,quantile) importFrom(stats,residuals) importFrom(stats,rnorm) importFrom(stats,runif) importFrom(stats,sd) importFrom(stats,setNames) importFrom(stats,smooth) importFrom(stats,smooth.spline) importFrom(stats,spline) importFrom(stats,t.test) importFrom(stats,uniroot) importFrom(stats,update) importFrom(stats,var) importFrom(stats,weighted.mean) useDynLib(Luminescence, .registration = TRUE) Luminescence/NEWS0000644000176200001440000004354413125227571013402 0ustar liggesusersNEWS for the R Package Luminescence Changes in version 0.7.5 (30th June, 2017): Bugfixes and changes: • ‘analyse_SAR.CWOSL()’ • If the signal integral was wrong, the default value was not set correctly (#46). • ‘calc_AverageDose()’ • Update documentation and add produced output, • unify data.frame return output arguments (all capital letters). • ‘calc_FastRatio()’ • Update slot names, which led to an output error. • ‘extract_IrradiationTimes()’ • The exported BINX-file now works with the Analyst and the g-value can be calculated therein (thanks to Geoff Duller). • ‘plot_FilterCombinations()’ • Calculate optical density and return it, • fix calclation of transmission window, • improve plot output. • ‘plot_RadialPlot()’ • Fix error which occasionally occurred if a list of ‘data.frame’s are provided (thanks to Christina Neudorf for spotting the bug). • ‘read_BIN2R()’ • Improve error messages for corrupted BIN/BINX-files, • ensure that the file connection is closed sufficiently. • ‘RisoeBINfileData2RLum.Analysis()’ • The grain selection was not accepted and caused a constant error (#45). • ‘use_DRAC()’ • The DRAC URL had changed; fixed. Miscellaneous: • Fix package welcome message. Changes in version 0.7.4 (31st March, 2017): Changes in S4-classes and methods: • ‘get_RLum’ for ‘RLum.Analysis’-objects now returns an error and ‘NULL’ if the ‘record.id’ is not valid. Bugfixes and changes: • ‘analyse_baSAR()’ • The option to force the dose response curve trough the origin was not correctly implemented; fixed. • ‘analyse_FadingMeasurement()’ • The function returned unreliable results since the time since irradiation had been doubled. This bug only affected Lx/Tx data imported from an XSYG-file. • ‘analyse_SAR.TL()’ • A test code snippet made it into the final package. With this the Lx/Tx error was taken as fixed value (10/100) from the Lx/Tx value itself. The calculated error was not considered; corrected, • function returns ‘NA’ for the error if the background signals are similar and the error would become 0, • new argument ‘integral_input’ added to allow for an integral definition based on temperatures and not channels. • ‘calc_TLLxTxRatio()’ • Arguments ‘Lx.data.background’ and ‘Tx.data.background’ are now pre-set to ‘NULL’, i.e. the function does not longer check for missing entries. • ‘plot_KDE()’ • Further support for layout options as requested by Christopher Luethgens. • ‘plot_GrowthCurve)’ • Rename argument options for argument ‘mode’ to ‘'interpolation'’ and ‘'extrapolation'’ instead of ‘'regenerative'’ and ‘'additive'’. • fix a rather rare bug using the combination ‘fit.force_through_origin = FALSE’ and ‘mode = "extrapolation"’, • the graphical representation for ‘mode = "extrapolation"’ was not correct (#38). • ‘plot_RLum.Data.Spectrum)’ • Fixwrong axtick labels for interactive plot option (#39), • correct manual. • ‘plot_RLum.Analysis)’ • Add support for the argument 'type' of the argument 'combine = TRUE' is used. • ‘read_BIN2R()’ • Correct minor bug while importing corrupt BIN-files, • add support for internet connections, • if a directory was provided the functions was trapped in an endless loop (#36) • ‘write_R2BIN()’ • Argument 'BL_UNIT' was not correctly exported; fixed, • export behaviour for BIN-file version 08 improved. Miscellaneous: • BIN-file example data sets can now be exported without error to BIN-files using ‘write_R2BIN()’. Changes in version 0.7.3 (8th Feburary, 2017): Bugfixes and changes: • ‘Risoe.BINfileData()’ • Correct for mistakes in the manual. • ‘write_R2BIN()’ • Correct for broken function (introduced with v0.7.0). Miscellaneous: • Correct wrong package date format. • Add NEWS again to the package. Changes in version 0.7.2 (7th February (evening), 2017): • The CRAN check on the Solaris machines gave an error while performing the (on all other platform sucessful) unit tests. Consequently, and to reduce the load for the CRAN resources all tests are skipped on CRAN. • This version never made it on CRAN! Changes in version 0.7.1 (6th February (evening), 2017): • This release accounts for the CRAN check errors on the Solaris machines by preventing the unfortunate overload of the C++ function pow() with integer values. Changes in version 0.7.0 (6th February (morning), 2017): New functions: • ‘analyse_FadingMeasurement()’: Analyse fading measurements to calculate g-values and to estimate the density of recombination centres. • ‘analyse_portableOSL()’: The function analyses CW-OSL curve data produced by a SUERC portable OSL reader and produces a combined plot of OSL/IRSL signal intensities, OSL/IRSL depletion ratios and the IRSL/OSL ratio. • ‘calc_Kars2008()’: A function to calculate the expected sample specific fraction of saturation following Kars et al. (2008) and Huntley (2006). • ‘calc_AverageDose()’: Function to calculate the average dose and their extrinsic dispersion. • ‘convert_BIN2R()’: wrapper function around the functions ‘read_BIN2R()’ and ‘write_RLum2CSV()’ to convert a BIN-file to CSV-files; so far possible. • ‘convert_Daybreak2R()’: wrapper function around the functions ‘read_Daybreak2R()’ and ‘write_RLum2CSV()’ to convert Daybreak measurement data (TXT-file, DATE-file) to CSV-files; so far possible. • ‘convert_PSL2R()’: wrapper function around the functions ‘read_PSL2R()’ and ‘write_RLum2CSV()’ to convert a PSL-file (SUERC portable OSL reader file format) to CSV-files; so far possible. • ‘convert_XSYG2R()’: wrapper function around the functions ‘read_XSYG2R()’ and ‘write_RLum2CSV()’ to convert XSYG-file to CSV-files; so far possible. • ‘github_branches(), github_commits(), github_issues()’: R Interface to the GitHub API v3. These functions can be used to query a specific repository hosted on GitHub. • ‘install_DevelopmentVersion()’: This function is a convenient method for installing the development version of the R package 'Luminescence' directly from GitHub. • ‘PSL2Risoe.BINfileData()’: Converts an ‘RLum.Analysis’ object produced by the function ‘read_PSL2R()’ to an ‘Risoe.BINfileData’ object. • ‘read_PSL2R()’: Imports PSL files produced by a SUERC portable OSL reader into R. • ‘smooth_RLum()’: wrapper function to call the corresponding methods to smooth data based on the function ‘zoo:rollmean’. • ‘write_RLum2CSV()’: Exports ‘RLum’-objects to CSV-files to improve the compatibility to other software. Supported are only numerical values, i.e., ‘data.frame’, ‘matrix’ and ‘numeric’. New example data: • ‘ExampleData.fading’: Example data set for fading measurements of the IR50, IR100, IR150 and IR225 feldspar signals of sample UNIL/NB123. It further contains regular equivalent dose measurement data of the same sample, which can be used to apply a fading correction to. These data were kindly provided by Georgina King. Changes in S4-classes and methods: • Method ‘get_RLum’ for ‘RLum.Analysis’-objects did not respect ‘.pid’, fixed. • Method ‘get_RLum’ for ‘list’-objects now accepts lists with all kinds of ‘RLum’-objects. Previously, only lists of ‘RLum.Analysis’-objects were allowed. • ‘plot_RLum’ was not passing the argument ‘sub’, as it was fetched by the partial argument matching; fixed. • ‘set_RLum’ produced ‘NA’ as originator, if the function calling the function ‘set_RLum()’ was called from outside of the package using the double colons (e.g., ‘Luminescence::function()’); fixed. • ‘smooth_RLum’ add method support for ‘RLum.Data.Curve’, ‘RLum.Analysis’ and ‘list’ of this objects implemented. Bugfixes and changes: • ‘analyse_baSARL()’ • Due to a typo in the manual the ‘method_control’ parameter ‘variable.names’ was not working if correctly typed as written in the manual (in the manual: 'variables.names', but correct is 'variable.names'); typo corrected fixed, • minor improvements and error corrections. • ‘analyse_IRSAR.RF()’ • Add option for a vertical sliding of the RF_nat curve (‘method_control = list(vslide_range = 'auto')’). This feature has beta status and usage for publication work is not recommended yet. By default no vertical sliding is applied, • allow a parallel processing of MC runs by using the argument ‘method_control = list(cores = 'auto')’. • ‘analyse_SAR.CWOSL()’ • Fix wrongly set threshold value for recuperation rate (#26), • fix a rare bug for the combination 'recyling.ratio = NA' and more than one provided recyling point, • a check has been implemented to refrain from using wrong rejection criteria keywords. • ‘calc_AliquotSize()’ • Console output can now be suppressed via 'verbose = TRUE' (#24). • ‘calc_CosmicDoseRate()’ • Console output can now be suppressed via 'verbose = TRUE' (#24). • ‘calc_FastRatio()’ • New arguments 'Ch_L2' and 'Ch_L3' to allow the user to specify custom values for channels L2 and L3. Feature requested by A. Versendaal (#29). • ‘calc_FadingCorr()’ • Fixed a bug where the function would crash when providing an ‘RLum.Results’ object for ‘g_value’, • new argument ‘interval’ to control the age interval for solving the equation via ‘uniroot’. • ‘calc_FiniteMixture()’ • Fixed a bug where certain arguments where not passed to `plot_RLum.Results` so that the plot was not as customisable as intended. Thanks to Daniele Questiaux for reporting the bug. • ‘calc_MaxDose()’ • Fixed a bug in the console output, which provided wrong values for the asymmetric error on gamma (Note that the values in the output object were correct!). Thankfully reported by Xue Rui. • ‘calc_Statistics()’ • The argument ‘n.MC’ got a new value ‘NULL’ which is now used as default. With this the basic statistical measures are in accordance with the expectations (e.g., the standard deviation is returned by default in the conventional way and not calculated using an MC simulation). • ‘calc_OSLLxTxRatio()’ • Add argument ‘use_previousBG’ to use the background of the Lx-curve to get the net signal of the Tx-curve (request #15). • ‘fit_CWCurve()’ • Change order of ‘RLum.Results’ output list elements, • rename first element to ‘data’, • add element slot 'info'. • ‘fit_LWCurve()’ • Change order of ‘RLum.Results’ output list elements, • rename first element to ‘data’, • add element slot 'info'. • ‘model_LuminescenceSignals()’ • Update function arguments to account for changes in RLumModel version 0.2.0. • ‘plot_DetPlot()’ • Correct negative y-axis, the minimum is now the real minimum. • ‘plot_GrowthCurve()’ • Reduce number of confusing warning, • add new argument ‘mode’ to select the calculation mode of the function. This allows in particular to only fit data without calculating a De or calculating a De assuming an additive dose response curve, • account for the very specifc case that all dose points are similar. The function stops with an error and returns NULL, • under weird circumstances points on the growth curve were not plotted correctly; fixed. • ‘plot_RadialPlot()’ • Sometimes the function crashed with an out of bonds error if more than one data set was provided; fixed, • argument ‘negatives’ caused an error if not set to ‘'remove'’ and fix some errors around this option, • De-adjustment for negative values optimised for large scatter. • ‘plot_RLum.Analysis()’ • The usage of the argument ‘smooth’ led to a crash; fixed. • ‘plot_RLum.Data.Curve()’ • Function will not stop anymore if the curve contains ‘NA’ values, but if the curve consists of only ‘NA’ values. • ‘plot_RLum.Data.Spectrum()’ • The interactive plot option was broken with the last update of the package 'plotly'; fixed. • ‘plot_ViolinPlot()’ • The function erroneously produced a NA value warning; fixed. • ‘read_BIN2R()’ • If BIN-files are automatically imported the function skipped non BIN-files without crashing if it is used in combination with the argument ‘pattern’, • add new argument ‘irgnore.RECTYPE’ to provide a solution for broken BIN-files are BIN-files with non documented entries. Furthermore the general behaviour for such cases had been optimised. • ‘read_Daybreak2R()’ • Add support for DAT-files produced by at 1100 reader using the software (TLAPLLIC v.3.2). Thanks to Antoine Zink, • minor error corrections and adding example code. • ‘template_DRAC()’ • Fixed a typo in the column names (#28). • ‘use_DRAC()’ • Now supports DRAC v1.2 and the newly introduced CSV input template. Older v1.1 excel sheet input templates are still supported, but users are highly encouraged to use the new CSV file. • Columns in the output tables are now assigned proper classes (#27). Internals: • The internal function converting BIN-file curves to RLum.Data.Curve() objects had been optimised and, amongst others, now uses a function written using Rcpp to create the curve matrix. The conversion now works ca. two times faster, • add ‘`[<-]`’ method for ‘RLum.Data.Curve’ objects, • a hint on how to cite a function is now added automatically to every major function manual page, • add 'magrittr' to the package dependencies (imports) to further support the usage of this amazing pipe operator, • thanks to Johannes Friedrich this release introduces regular unit tests using the package 'testthat' to improve the code quality and stability, • add internal helper function ‘.smoothing’; no Rd entry. Luminescence/data/0000755000176200001440000000000013067221132013572 5ustar liggesusersLuminescence/data/ExampleData.BINfileData.RData0000644000176200001440000250063713067221132020752 0ustar liggesusersBZh91AY&SYP">8 *@(P@4 P̀i˥mc0Zi`vU͚wjk]nֶ4&tLeSUU" i{2[ISCNurikRٶN4.AKvȍ5nd]+4) : n:-A@lbfJ]b1TvujmHMga7CfM4Zm62.ڴj,1unɶum]n6B(`rVCfZ( `mfMm5[-nu(QkIkU%{IpeVkVd@Pm-V3˶::rkijEG sۺi+A)mҕP-2j.iL띒!Z vk@p]ңlh4+kKmv.͢Fe4`Ҳ[+lնPh҉kHZ m*֫maSlTřJ[MQѭ!I6Z4bݯ{V MrjVZ`Rld0 #D@ƥvem&@jD BE"65k%--6ֆS٭j6 Q-[I:٠D]lhRT#lRf]km@R*(^%PhEδ"J(cJJLQte@R$wTTUNj)(F ,*  P3P  P 4  dt:4 - @  HABPD JB!  @P TB$QBP@ ( *4 bhhɉ04LLF)Ld  21UO4  $ɓJmmF64 SS6=D4zi 2h40#C fh0 Ɂ  iC0UO1$Ц=TSChiih hhD&zd4h 4dhhAڛS HiOz5=ԘRm!MژЦ_?:y" H *L?.#8Uh6X#8"$*y&s:gF!Rj-6 @oJs)5ԪBZs LPlo!j Moh%쏉NHCQ]iq9р *du.k蓃<+ZZ5`bw v P A0@ ݶl݅y:eCVؑ@KET @!DBJ31ǟ *qZ@@BL%u4_.C!ChS̰'Zo0J8;IJ(#1i;hDNbhE $v4=XEPU Kf2bh&]@Cij2)RgdGw%-Z)U 'e%&B#ydm&dʰr vEvv,D@Z<)Zٳ s]I L8%h %5U9>%FBWc+~TY\_tDcJ]-uqD  [ ),eZrv"AjD0,$ Z55v8vJIb;vڞPTJU9irɖԏeKE'qʼ h݊H5OzN+)72)٧, Aaw؏LxSyL &=xLSK+ zR֡)YW'c=՚^M9IsR )&M?7ig-Lͅ|+ESCkk5 `$TX +HVD"I`٠\\l ԯhU&kAe<0%$ZԮg+0U&9[U)Zk{Ηֺ`1[I#d{D1v8PI<0-?i޺!%rcg&bUz=VN71Yjpj'FG$-<o(yCXԈj2$;A@Qvmի>ƚlvLq߿J@(ݢ0Xc(hLsaI*k>SAaJP*D ft)#)ؒJh4t<ҳw)ڤoS Y0'۵{w$.L UԸBJ*t ՠ( ۳hBJj b$Իv7jP"> %An F(VsT+# a!Pr! SGC!Y5k6)a۷eK(7>ӆ`Br"M ge" vˈi%,9Q{B;@"Ώ S _MV]酥PPDIs € ( CYQ0a!C KiAfhj(~qbLw 6uLI aJ]gn\3YW+bT=Ό jC:2+$Íw o3e HYAň #id/HW i) j5(.Q}@^z[AQŕIiH6jfQ$@xݶӵeć! ؃hb=j#%a$TɉNrELQpbRf,kͨ-.F^umJ|OXzmI n%RW\Ȉ8{eo^픥sنc\h!!hIMXRbyݙ 87hGG2k,T6ߌZhAqnM###**&:;γFZгZݡJy@bK*◓E$&T7!0]MD Zd@13t$#Y\'6ғ% xe-Bev;2 EU$@۰]>uS0p1ϔNnJN Cڵf$luRbz]^DG&PQr2yY5g:I M$B۷jD I$A 9N!YCp$O7V]4j҄Bk sk=RwZ!y2$8`DoT De8eUP%N׭/ScX/ZB E +`®A7 BbpE9A5cyHd@*AnJohm{K6!'uY(C9R@i]᱋[3* -'[ NB.աN*7 BhJI42m$ra5(l="q?{B%{|o2 SӺTh:TJ ¦OOYNbM2wy*fQ4_&]\6(c5~뭔v䊚C-JF Xp)'0N:40FHtN5B4U],,s|*d bL Z;ڰi\Ս⠕ƀ  .€_]Rs k:ڱ6=eXȅSGCi(3)ţBZt8"Uf1ՊL`=I2LHd+Iv٫>Ɖ"2W:40{ HH|aeIҐNT0e7);Rejmhԕ@ l(AJԙ# -'dRkM I9B3$[c8T* 7,$2٪E%.YjiK2ؖ{D gmBH@l䢷3{2SUe+ш7 ߢLZO,ʦA#l&Dv-HUZS6gj tZ;c|ﴯORNcڸuެ[4nZ6}&{IY;p@'4/ZV*s ߏWt+*ϫGRn.h"H+NŵTx=$(!+>Q5bc^8"Y)ZS|O:b4{Y& /kB+l6=\J]'"5]ٌq@^'"EP!G(}ȴ"+VG(q0VP]95*' ִ:eנH!a>G" >1nGkY~i$NW_Z38 Z&e0cIǽ!w^%\67ӧٱ/)aətDC #"h͠z`5aLt yKT>.Sh.;МFկ.7+z٬ǣ~EIS7IB=F0"ֵڇa ӌ@Ӹ8LAI"|ʥV]m"M4bヒ22bu^R4ko5oD5J^B4I`bz|(F>p̖z=rH&9Υ3!n -iGfe~7|usmb6S1kk'΢MC_D[ ی:W܉+ԕ5Mmiek̼gdH4n;/;u'r}UP3c J֒P戢_Gp6'Dƶe8[uBPtbZMR|Zo)Xr311p@rrGQabL@GUW@3yE/aJ-/u'kgNe{+XⲠFʹ] M-gHV(%VyKJ+Z![9}.i ķ td"B#Bw QZ= F9 h!XaZkcvSeM!rekK1•t\;@#=ljiA+[v*CaV5T,EPP*09Y]%vٶŒpmV>mAӲd*/y@htaB̚I!e.rb*`?1|6NC( UnO.>ZwuR{ٹm`]鋏CZl[6we$K2zR=h\ds׵}xjfә=dz`-> $I폟i,1I <{%eLDaV{D< P86vO, 5>LZj-1 ^GR]j'EҚNo\u,xAMջ1שr4NGQ=$gJ!lzny'}^pE Q<_/M&mɎ(+Z!&%~{Wj85A'<)A,vP?qMȒzwwWb0RwUD:|8 o g1&d"*MdȪ|7 J0 #}`@TRP_M'^9ɄJn$DLb ]ty#L3yʸ)]-Y_4">bBlT_b}%O~amm(.-& iD^֊8SNXW-6.25KP*wH%Ά3:RwxRjL,Y?Vӌ]K-G^f !46VtmmD=el/C̶zv#6XAXt)RejI [tPF6oQ^c%M>[da2f)aڴ̌{HHڶ g!/;%|-i9m&Jk͔݄G)G^My}A2*JimweƉCAHl\ԿX58],IT`hMIC6z!%^|N1nq.m.`4,a-T]Bbwq\80g7Bs^@+ښc91$$,5k3 㜒GzUG0ٽ%yhʙ?"J6]#_+R6{\#E31Ã=쿭8Q:J`-C*2=~yX~R(Bj \ +G`*:.{3(XDsNe0c㹹js>śI7CCe GH (H+4 Εf1[I V]ʦhiQ]Jq :+* ])(T$aS'ƖĄ#<`醴MZ絅'DWUkrf1o9g aXyMCNhz' pbt+A5- zOIA0TՄ}{c_0X`#Dysmc 4(]5e7O89)eYUotF+0d ;_G\o:Nm<i= R{6}ΑYS;Сf Mkx+hX`Eyfm2 > xRUtMAOϪ28Αx_pXR!V|{_CsP-|S퓜W*o!m!"2?fZ ڍQF|PY f^js&3pȃGՕ@D^]koFe_s|pX-vI0b uJ hPkVG"nA[1W3獃1z`C< L.=Xp,9R"'%m4-~fF ՆʹDؐ)Uv`i4՚bY5 cxG%)EulwASJ.*D <9PWȏ\Q˃evhH7 -}&+LҗT@1pŰ6"K==y]ioZXK:Q@3֪_Gs},ZKip[ s jG\B2[9tvq2@Eޛ 0Zbґ%+Ue:m%ӀHo \%6v]J-p5eLENBTԣ$进iKliM?HMe0d& =ŢTF|9YZRX%WS}&"&+W>$;7W9 Bs6qhmR6Q'rx1,q(<&v dUػA4*3FR͘Ԥ<X;R4$^8Κ;^Ci]&$}cbcl[t(#YeQ .jCb'o8|xy-+!_<h',(\&?YԦy{Ĵ9d$0<8Ml# bm>P-Vt1Q#7BoVrckT31(cnSHGvX6H#lP0'VT!{_t 6MxIhiu?" V]`vqAccSMaՀsmy4m·.fڠ!6A8rҶYB[uPI;%Z_K;V`0vz`Jg amwήR_kW60C$Ƕj mB!W0ح /ыK&*Xm̩J_[+<ի2X {j4ۮt1Ud`7D~uINVM rjzj0SguU7B]f:e -E3$z˲+cKFOFF0UWQwb{Y6Qte7 壇T)*Kk@JyR5mMt_*NvgVX;$sŗk_Ս@{ƟHHFDgGuF$s=XnwUb8ñÂk* C]" wc6H",eϼ7{82h3Xr /QDOPٷ}{{Ph[XNKQ`(6;fi.CF[yD|1٧OvMD_#\٫5,=$xN60hi6ěQֆwgspcpT緞CC8[ۏMr5 恮*c}Mj ;1[ w"mMjC!8NdyW0 )`x5p . f#ZhT[xVCfhɲζ5"6]_k>7r|Oތ=iG{٣ ek[SkkiO~wu.:GFJ>ʋձi+Xe_j4Q|R")jMT:D1f.DndRm(5]fFDTRE- }ݴJ|Ol«xRO?y'Keˁyi>f5{hk's'+2"L 3vY;u\3(8Bs[d0D7 ,ى+dMt0=rN'S8瀺p@1)\: u)jP%E'l焥NeWzyVa'& J5k4\(YV@}|ֹc"? sK$v0`=z4MOӥV"DԞ̊kɃ"Q1Gq fZI c hU]){5Eq\v٤4\әJJIVߚgTaEu?\퓰Jb)l}dž {Ү+ j&m:=iAi&S# Z Шr UVz"7 lTWdD辥m6qL2c):+Ej [+HH8Hr/PtOJ*{q|/)[b;bnjL))Hg|5v"l q21]XU$@I$4f_Jч_u4uAh G@yFL+3gi\H2[Ng4[`cw:WiD]"VsfÍ [ AAS\=JOx0 wq҂^eFTo1'miLM;MŨ!prIRUj:bn'j%a03DZ[^Axf齲[qx'{?jJWjb[s1D1BbD7-Sb@M PMaJRڭx\vwAIPliMZDZ9!75qǗ@k)+DO3s%l`$v![6Z/5ƺ?km7-oAAєH(!IN&:Gu |sY+gmGJK(DAyR@}سz>]:À 5zMơR\`_P:g̳tS{p"l#`3>0{KE$*.<쁆A!OfU z-H?y7 N- ʬs <, 0_ 3@4W8U DZ*S议߸&q2MٽeRg"h <(r&v' B_|Le BT961cC5[9ن3CE}:J+%֢kKKu -;7CMRZ66=)8egW =CqA(\٦ih9jXzo &l!YN pS_Hߑӂ ڤO\5Lb벛pݘ.ɧåchk7:\sr:Wvumuw7籥vXǻ3#lf,Jw7;7& r \Rja'>'2$vnukU9r7.jIEwp?N@Va;>& alшL )6l}!ҚAIK U'< !Z=-aR=0-# ib|+T!)/}mX9jv=M$+U]I/ u!S~kw$(%k64THvE¾!WN>dIQL^a !k^RQqDDn6*d}g)`;lGa MyENN$X@^@NDJfz_(H8m,-Գmϔǧ| G9UZH\;sqai4>ݻv6ɦʱ ÌDDi'7fZ< !-$lXY@H#x7_ [ -=hW{,1SbMHQR`iVOQ/{{$5ϔC=aЃ44R&MoĀLhg+8)~uDBkA\&^} u_+g*j/, '^X@C(-EšgEn8JPiz1<Ɇ՚SL<)VJP,|#9g7)簓H^`!-ZJ;Gk# x7hHW-U?2PʮXmq׆(y062z)^)++$8ޔדgKS5Vnt@.}q*ٙ!(nԎ_e4I)YRmDEs`B(G셤ӬDڙ,Ak%ֻ>Zih1SbXX$uTb # pu0΀9j'9h$wz@qUTt -dD᪝鿂eSVEu`]M)|6bĶ37'kGJ5Ww* >"M Jɧ,1-/̖ 6Lf9DK c&*%p4uwt% 9=GKAzsh4FX A!-[[N;` WDlՄC~*efZWZww5 \&Zguckg NfYÀ9AfYgY 5Me+0";N6{# |57zfb18&(A6?b&_/+> )(J t0^13ypz=U;%jQ4P!jzGɱOkI97>VMtP( ʂog\Tdwh^MȠ]owv](3yfKzJQ&!ڀ{Ve ڦʿٗZJ׊P刐QRaDFBBd_9(5_tE})Fqy:XQT0h` _*@+\C~<<|#}8&%`PPc6)<D01?&Gif.DԌz`̪w 4necm i2 ֛8a5h}Hhm֡)x/JUW&4gKZ&0`zAYyǞ:PraT`qbIK^sItuipny nf'"iM` r BrɜOhD?\6wfs+uX{b,ii$D@ e 904c"b5xyB;GFbF(ڡ6TNPIlu˽Q&VɇZJ44 u-+U O.$]Ědi H &¯;/T*4UaI+lݚx c=n, 0 x_Ptdd[ђDk!1 Q9wS`Q׋:ԪVk> I}, ݶH=|mQ 3ܲqg4 8捅Ii+]&*1䛾Emjb$*Çde9e$o]XtuXx=#TY [t dS}UdN,vMdJCv"(4݀06XJ#+7r qb5Q>"!brW"HPו?ぃP6jfO+ ^iP1fvǾ1Mu`GEg }drdjW4AGVFcM cQh.'HZr TnV,8{z8Y<} 1XdX Rچ1nkYDB;Gif~^1 b-ծېzhjL#oO^‚8[kLMm K'Oo].8+lLӡ9X2 8>;{l& K|+xmǂj>gn(e:k{\VrW1T.2+\ģBlmm.h/ eSx]QcPo.߱jKPT#e;@=k`D{e;,D!θ~ ;_u.=.X,-;umZ>)Ӎi׭hD'YG~_lJ"`dS6mRmQN "f|rzZW-|V8i6YzV"@ʭ," *QHDr[T6l;JYS\ *NxF46aZK!6:va1 - .M %}&0#B)/tْ~QiG,%\Y# 6:%x$e-)%iGHvԶ >-]5!3g22thAUCEDZŠͲEZwx49 u#C w=Syu]x|ʠ4#<2/ Rb] gUc a<ʋyؐ zWTp"vFhή de& 6'4&}R.B{;lM"SUhfUu0*ḫ&wv&"*of 6gwsL!6A8=ĸ24S=0.8B hh$Bۺ5R,,z|&F-!$%3aNkWS gܶ%4 ~X~{WNCFV5Rb;?F \}³z)&sL|+ls6-yM{lTɊUd}3X}8yhǤU+4馄z14G[)`t;ѻ[R# CVjCI"x5aBZ\i 5 =jr'H-QpKOKT%\UW|W0 Α - jħT"V2 ~sr9A,!k] 58c$KdNY`Ę _ |"OM\ 1H͡ɰ2VCe JQ1L i༊P: yro_Jr+C0UTl Y&dJޒ?/||| B*ߴg 99K҆U'tB#Dhdѹ0Ϧ@܏=޷atE1γx3Mڳ Ik}+hB)E43A@;0FjXؕd[YbNJ.Sf~J\dH"{#a-()1p!rC`N![F4E]=UL g֮hPTxkʻS93q3͔B. tD: U$3 *q+6xIV (t' SjR+o]ЃƜj}cA5,WmHWBʼn2=$996[~: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Ӛ4 ǁq=+q:Ysq9  #0)"O2 z7D#uq"?FF!3 wJP,] 8Uڻݮe95iUbt9E4m.bbms<6WE>Kd#AJJ(aD^bk{Ab&a[Ɖk s 4hU_sqLVL%7J!3Lbfaކ&6Tn* n 0 RW>>WC0ZTO#85"kg^ZV|\R$ L)H%2Gm &7ЯRT-?8xYHw}~K`cw5yi uG~ɨ%sUOeO , xykϷoY S?"8%&%>Z;҉0L([x&x)Rcj )fQ7 fE} 4Xɫ`DI01I,HmmbQ'םWG8029~jH9¾Y8T43'F8Ui^a*i:ֱoRBAy7m|iS+ ~)W!ku#?[-֞A<9?tn$˿uմ)pPĔL%Ȝh 9LI9uݗ!x~C2iw)?4~ =fhL_j;&߼ ٥Ӊ! Lnͬ뀑޴=[]rG3j`'$ z{lA d'Ʒ]aw3𖱘`.*Uՠ6& y~m5T Kɪ"k QTш]o%c*,*BzW:!XjhlrE&Zi?QlG<# =f2kKH#~ YlZ7F b}LM##cx'h >Ȯ"M@/*VFaUG'-KdAI=[D YIK 7ZawxKB`0ZRX+Gc [8O T6Нɱ?82֔Rш{h`m- Fb inԐ/.Q%CeIbHbA"lŤ1>{'Bd7&^>e0CaRRP1nq+(LZy<ޤi!0>X<kF 6.ِޢJx>ykS5-DpɰQʐ!-qiVpEfx >!;1hPWzNWT<?oi@(ؗ~:[8lRQT++XGȾC'/  s Qf/HC-jA EU bsL_f>TsG)yt4G\+nٓڄR,|x_BH)8nxPf ^K <6Ɨ =smZ?sc jЫk =ADcE ;O/Ұ4N>aܔM;{k]f( ]+&GLEAs([WHgxPJl%ɐ{X۴ IxiQdPs{"`o{'hGǵdj(#os; 5{\6`F[4! UˤOd=kclRQmwkj&M-!I[Lr?X`ivkIڸCk(8:IcZ$F8>uWh7JhZ}NE͑LTt}"Y$@%7(91ltm'҇$\11ErY؎YL!kъ]a/ 17Nc{\d>/uҽS5L1`Hx5h۲M v[[Ir<"*wLǮ`)[&5 0s̵Kx7oYf/G8-aZJgߥ!mHiĉ E,$Tu89٨e NNqU+H-E?O%𴝞i!`₂E-eIi;1. :yJ5X({5$8x4<5d_-)6EN엁dl~5nۢ)؅135bEmeV1@DSXg&!Bv 7m"\=GKaA~SH-nt!5 @Uj+f;]*8΁Vuh88jJ}+j ~0SSʮ>? Yk$I4J ft8ocrD}}B} vdSMw݈jm7N\4@OZb=uJ{-#!josi8Vd=UQ·Wd){v2W`Y3ȦI{cU8uqTy-euf9XQW֋7-u߼eŴ]04 u iRoW|_Cah(,5Nl3NvHzTrr B/-ui#UN}" ymKFP|GB[(6Z|C%gmZ,5RsDq@EaUu1(RLvg2ZhCo,usX N塈|qin _ RQ?!7Wjۄ-|'RSI觖}gM(-#qRJ#N حN"<#;IK$wd)=1v)_|RN.j#~$~' - #?$7vRtV/Y~:"2Tjg!xk< {d=%:؊ r͂pԈ)ӞDP"6t ud8!ROgjaf_ &j'5'~᨟l$L>UC KhfVJ,,}PU.HD|husŽl|ϲb\r6>9ۆ#聄2$̕^uSclx&Z,W̳5}v>W19.'E3TI ẁ]^rujvi+t[|,s BB_f7KjNfFX5[{*ur#E%Egka>S.Ou85z4D`LH]p:x/pq ; AX=Hx^h%{$DRg0'~AQG%~Q (q'fuY B8wYL0|sa!XsKߴH/f\[T3ƻ R.<2%ZZZ Gx'$0C75lpUC(W_:[zHl![KZ|ϕpIHKHv`tt«,V]*OsƱ&Q:}>u{rŹ-u42܋e|MʊKCUFњs_efcY][!6b.TT6p1 3&(ac d VXX`f+L8 - wdʿ}uS~m݇ӶϵK{QO}f*4LE4Rɬ"ZJk^"&ypnykOH&TG&-p مd0A% a߻{׬bm&Ro\F('F46C,mh 545*1AX.>,Rk$$)*X$آL*!AFN5΅i ;rI8l-]J Sa@f zJʒfRCV^Y),ǣ2 T"=; Vdr_[6 l=/"ۉ ٝ`k+?WrԯxEo͇iU'YbbS9 wBqIztYߧ۷c;?ug>Is^۩;UQoua^A A9semS$8G fs\EHOD}gBJs"U8ZL&LRJT"aBTu n9 ~PhKS cCtr%-M #zg Y2{e:@#PA27(_e1CRGG gQ(1XA9Yb%TMyJӘوCV5" LYE2geN ̈K :j#i/ި.9rzUd02l 5 gE nJ\]yG{q*hFlt69g1DAENF5ީPuQ D |QtmF"[Dh-Bb\±~!;Q D9>!d˓Urje95zÚ9^N;Mk6t(-3ZHmaXZgzԐPaݩ\B^pxKa4u)ûY]RW3ƻ!%?wh=C0 CgJOQsDZܓ0yyz% ؕ [O׹^&Ui [eU {a-T=9,O)+iJ7N i_pw&ܳ< `XN>TChAr  5T\xd긂8(Jj2,?qt]1*)PѾ␽p9O$mWpC<`FXT*z~F.(2C䅩> @9s;qXVo7{}R]?bͲ܊"do8t:x_("_N5W!Gʴ}@ڴx_߸a]w 0gڽwXhF%<5gfr:J0ǞJ#I)7%4ëf!$p4pՋͣ9@e}&uSWzKݴ2BfFV$V+mʙ*X1A ']*ȚQ픉 ppu79ˆE`z2'Eٙ]R*uڼKK#zyfN`:zkL3D(,x8J-8d~<{l+p:Z)F8s3V7TFzvI^J8P^ `#x PD2Sv|dhuÝWtkiVREFj*IJWPQc\oxJN \鑓ZtÞ7P+­ Zsq@c33 s6ƛ/<-CK @ѕ Uf gM `7w43B dޔ'ʞ\_6͌#FGK!UL و{V8Ȧ(ӑlJRCGն ɅSRzܻVLET<+L8Wr(\L'&'ЄPS=@Wͭ6OlPW[JzQâ|VMCI>#bYFDB\cz \0/l OtCzit%NNɇ3G~Q2B؜ű7W'ܮoNpJv6G67A)"&@0M_t%4{P]*QM]k^qh|UתIS&%7(jV/Zd`9fu|[Q9P[#$l^ t>\ e0B;gi"\8 Ejc=-W7(F+ zch%@ xֶ(9TQn6H\9dlc3 !H?rp>i_f8s*,jW@>Aotb-K6^[J\~;Bg/BwtC,8ZI4 W\ L5/ m@J xPd1mŠBI7uI'ek?g6fS6\Mon'Emz~P W"[E2!U o6 ᓗJ'wڥ;NI@GiÀYA,0HC3 ƋZ`n0ꥍm%Hܩт|eAb^>P{Y>!j$۴( 'Β=} :7%|~<}6Z\ބ|yy42.hWy. ѱx J|D&P#N4A_T!6V4ېˆάLA3R%b}k]rE=qioP7/rS<^D繡&lIAZn wb΃Y 3N!ɉ5E/9*3snԭYwvӎ` aM##PCaЦ-+ dm<2VnR̮5B2Z)<@ ώXd"lZ7͍L詡(2E0Ie*5Y$_s/퟊ɦ5.Q\I/JXV&qC c)J2E0<=f R8Nzds?"(+ٗ|%Eh6 %2diڧ`[;0nZ_#֞o_LJ; ێrhSCI $k\9pKgs#NJ lݴ#Bm@fM6r- o)ĎmOJ&bZGvc!sq%{O>pX.(-@udy j΋dڶ-qR IiLt섣]Ľm,>8WۗT* i" Km"!nyKuUZi, HlԘHGxչt/lCr)Pɳu勀Bd&ELVf7V!ӫS/Wò}A$M˸. _bɷ y>ȃ֖=^yF2h#&1dn!)\I''bR,(Wypb c F\$ HC#ehm/@3[i{ys70ӀI&`~%s 8T@$])K_z}rr/wqb֠$.FZB[}\9%,CP1~LT\Ī/6oWQI D8>)pi7( Am=B$e"jyre:qK nݱɔ8P$K }&*}i\Mg b TgE%4EԑaveIF1kqUQ*W9Ld-6ɷapD UNד=Wl{=9[gc۽+}2qڻFe6CdzSmc9]+dBр43i3>ML7%p*"P\# cYn'ʿ{6 !EIF V6<U'!YO@2m@%4LP4)2(dɬ$k9+P&2t-N|fJٿSȶRc&.RL/hep\529{%iFΫFG@- ╢6L͹EToQ@L&daXH~1jm̍i7tkA9J,#:D~cJZ ökXU(dG=ԭj!qDZA'T5@-1t^<j̥&,ao?WrUK"Ê M NFLK3A,2LYG3-tTo]F,>Ct4p+(M45ݽm측LM ~7aaaJ6 aᎸtzu=Th!PzfVa.#s12HnލiG9& LK96bȍhK(hKR<&}NRk3k:ɍ3A6^/oe4]N$}۝1p n(dV=hvls"^rm'tpH" pLB'1C4Q "V& zЏ.u52 h\r 7P碲(cKS=SϾLHH6M(Y J-TJ!|HW!Mhlt~qs|7_yIPJg<9sӃ] .>3ӈ-78?t-|9;7 w):z$I|rd\E4B leGO yOb8ʉԇd0;Lu3wI˟2j%|}]y2N\B 4_U@ aTUB[kÍ֜Pp|&m4 k|֊4;E#18PYVMHHiiw+xdxmF9Ӟ2F ⡑ WN9MVIHWhWBiKp&lFcQ.*&x,L1bΰoGjGVs6\LDcZF3 Gg^ e\;u_m!=LJl:7+رhԦ6kbjIjdt 3ϣQD)VYIdECDfVDnzo< ZL` 2 Ynf¡]#{ xuXL(=5nSDjwWmQpϺGa$GT4v+6SjdNZ]db,݊:?* ݲe|LRSimv5O6/L]g-%rS@Oyx'\ m[:AM~4GUɺibMӥA$Aɗitj%&n+? A<%w|h`"tK[bVt3\Wiͦ]"LѾn&f6O 02ͅ,7~L "fW$M(yDo ) f!#@ 0Kqschl QgA!@!i{J"9DMRE;6D' P^vM'p+Yv-(%עXD ƿ(F֗hܰ|;}^T\QD!oa7 SlM(o lq:%.jpѴ 'eɘ05bFYb4i|Oh܈cy4nߨqAoK :-7:, jtVwC PQT'&iZEQ`F T~?6(d[;&ullZi 3ݢzja-@U0;'KN{E6l@s55'cxqӏttu%l>z8d];,YJ`^]x֩4rYS5k~Hפ1|̑$I/x@}~3+NO2?RhDa;=SwJ*ANj2o)Y=6y8ןn@Imp|wfšo&"0)1nBq'-ƏYvAkHZ HpT-fV@`KY.ѧRx=GCE 3L);%fɕ%ggqSnA"aނQ3E94KKI 4 FD+@f]g'B$*xG}ElQj e9U 1C(K'yhL:th 4/Q>9J hH#]sfy$!;,j~Fӆx@C5Tv1l@ #x1W؂" &"e O.xl2ѡVPڡi4&ZC ]qno:m޶''a9A@Dj3``FNBkk#츞BJj(#{0%':PؾJhcC$E Ш񴂒/SSCl Qeq]u ^ӊF[f gi`@aU~Dr֖ nZK@UItOIB?"DvķUi1fÓoȌsB (c܇#!t=5g-Ty4lc@s!!J DxP(}u92rݲ.zg,@b AS9,?[OIa S9c2{#Yqsy,ӵv[UNBh9'mtr=JT.U5\D?އZɫH%Ա vٹ!=8q8 {|eڰ(20vÌ)Q!iqn'3\Ə;(5N0|[CC$uǵ܍j ?4Ѱ!%7!Fc4dx t8ݎ xn>$ O368t$19 MMݒSO'>^bd5."NU?W(/`plnT S,pM :AgbNkb_l(E+ŌԘ8Y5! ?s(&=(8PmMHmk}t7t'x7brfloy#䠅7 M(i:4AzZGuc]D#E%UyWW1<]`sZnH*ǩ,=T%Z+e%b9 #yKejWt-R.FW, TG74trw82<àg 1%EgxpF)4dE{oXQWM'kLk:ٝwcOC>Q㟨,O=ʢ:D[ƚ v$ܘ#qy1벅sJ]`|&هH1dJ%ggq'al?_Ԧ{fFSx /0* F|k oMamO@MI`6M"/F$l@0V .mi\.eC@N jE$!'\eP*10'rʭ t6_K6j` 0w&b8BL`8YZ&sؠ6L8 0랁˔F}E)=cX݊)e`'#j3HS;!_liq/BLn"~^q*m*1:"A{S2Cqz4db|j!aZx Ghc*hBhPʈ[ZGT`tFoXuՐӣ{UOe*<7ay/SO>zBe6Lc@ȴ>!AKrZ;OUPR̼&;"BDl8uIba ǻ2ˏpϩZ(![T)[_MتTJaY@ʶ&<-  Y3x,5v͖{];9e^ ¸}x^ Ux.y}F6ڦ L|`‚Ei:p!/そ;Q1B`kp}ЦnZ~sY?)Rg!V۰f4V3j%pdt>gVJF|D ]Mf| Gnw' u׌m;-!sv@앰 E]=&BuM(Dnuq@^jz5A9L&Iqf> ce>"iKcbcb{ڈeHK{0uL٬ە5!W TQ0I-9P02P2ɟ.]Oi:FU$ \h?IlE)= iO&A9Xى̖T \**@Y|X-iZh4|L$M.NaUk0W.aAN#41֭+p8׵4ϷE-JH3J1Lcl`p*%RJ4 cu ܧr[wj q}ӏ.4xo,K'JZzV,ml=k: |9ўK0Om;%Ƅ'Ԛ;άt*ͫ \QAe6 f!XQbAD*9s8ˌ5g ԔH^[cțAa.k;g4UEDts֨qJ2+<&tI J=>4WCÙ5 &`<4\\StԌ|JCd#97TX s(˗xp@ C b7&Zw as/Ų=EqB;zƤ?f;vJf6SqM-麑 Z?GP؅ѻpo5z 'Ԧjls꼂k9{-q uI=E0?1͛ḛU7>5 ]?Y,n4U`N8^4  >=i1Dn;뱝jo}>6QHkE@QcYܷ^j#^T^5՝1K.ԛg]e^(jRBk5F7aTP s|ɿoys+K-(E7D(oL3hpkY|Dl+ʉ|Ӕ#p"tp/F=\ܠ60/*zNt*|7fS٤;> J!sQmLSD4: ٴynaEeZΚ yB MM%Rf*2!^sd.&]jB֢-\|37 )Pbox-)2rt2(y@uФabћ5PCJHTpQ3[-oħG4Y/%k@f,8 qFz!ENJ[mh Z|SD; fp6TO@NY!`nN}ev(;P9 ;(\$ew86C12Z GJV'>m(ߒ]vǷ=&nSQ:d(G5?K/fsQ-l+nu7ZwJf Sb(5dGLbFl g*vb鍊ϓr[GȖ88]bmUTzXmMiK|sh6qƊsLHSVh =h7=4}( 01eC`R|sz> 2ý4D$%gX'ml.6??&xD(Q(yՅc.ܭakWۜ")@S)8]IB88 k≴`>. ":$ʢ%Jq}nc3\3Ly@%lQ`@O +Q5=R̓NI2b`.=6zDe tBX[&&͌~! 0~߅5QԛPt̘M ~h!kN_U'Y'GkF:ޙb#l$кn5$n-)-~x{ L,8ݞY3nF.Zbqvm0o&p 1ԋJސSevYy"g=5{V69&M҆Ûm}}yﳣ`$H&y"SjQ滝:8 0f`m9*ȠP Ihd9ڞqoѩ>26z tΎ)_segRV؆&8g˃-r/PCb<ӮGzLa㼹C#)xy| Fi %7ک_Q]K] ndI`r< qvF,~h`;rC5_6t3V.##K 8\˓%"h+D!LcO\ ZjÐgWK ~Aq$#RьXT+RvN6W4AFtVUi VڻK5Sy@G?Vt}i-v:Ӎv }`ILz4Y<r6qDx!pjt%! cpc&딹RbE-RM5h2![{̈^R35#8Bz.;.5c[ZwYdҚ쐒{0GhgBI-|D{mT7cKq-+e~_sd+&9r7/&y>ʔXhN;jw|<j bάfҪ8$^=AԐL1xӉQ=6.Q#~LϊDidaV)*eܯނ6 rz6nE1j v.^Y>5S.'t( k}}H=+1`o хZ_ǀb `J\gڝ Ym..٥S"d%gh(*J%ޖ\ w4 9 J_`MS7vlϤ@>4n^ hLgÚ\jcS@v ˆ2D"c8-7f?o:+Z(z?WvE 1^6Ch KZC)dvɴekE#`& 醎7ī}^ZGǶvJa)uvDNc}kz/.M>/Lf/ZC ~&U]_ u&cn'8WIO㻒 8m"z販>W' i&ԛf߇Z ڽom}HP3;l3f$Ts(X>Dl0b4Yݽ{ %iZ|r%awͩ^%s@]u4rSwJNvtGFD< 2gZ cpҎNOV(@qocaͅƜXϓ|!>Q[Gc7gd郏 oO11 $QeK#Aߨ$.A$ws79LQ3Җ\uob('7Nx4l 4X@ u=$`V8ϾyY{İekD薪1pC{Adk7=k͚ԯV_wSv$YA.Yڵg|ǂȦэUITԱ3]ͪk.!5I`e^!7x* .h9 30"JY A!lCH(7a r-V< cn!y)C>p*$lXl#՚Hj'K'jq0$ėdqI #b=2@7L& +4Ro:F1V ')iKri;Gff0tHO=ctӔ{ Ed"yscS_ [?i˰(( I׹A`ױA6xZ]{nD1(b\Z c"v1<3!8S cl!zDGvѳi#bW,(2F "DY՟Vvqpsq Ycbj, <A#tusӜi&O9'dQqծj[JWw_iVE~ǘ9ý/ؿ e|FkgGKeG" I1ZvMfS)¢_‘'2(ܔḈbi}h!M\r@-ٚ062OcƞI&l׶va {*WKwGZbaF).)6{5Qp$;y &mg!DZ[ poAM~_9uzr zUW#cW fsB~@ġV :m Hu} 4x"ȭJ쐔\Ay MҪ|ϢRo2de`E6Rm[]Or`);'8m$p'} ͠Lhu0AJwj?]=FRigv-F?˯̂,R|ⴳFеu'JOexem)WA<3UdzSlf%_ la8@%њ!0H5+L6XAV!/įwmG?vH/xΚ24 TV:6i"/fRb6%6몯9 -lͱxci 66r3E,5m31"OfXP);NK&wiRۆtU CwM)-[jW 1>߭r)Xmx:O)L ܻp E"3 y+{5AB#LdKD!"TrVI)i}Pppp)1QY[ &pjiYf &퍻@Ym1;l3$.rthjT XGjH]Ok״07aMN'>JK3jP拒z\Bb~<i^V4DpY¡A6뾙˘d%h=#`a AqO]26%bY#CfMXB%,Bop=ag"v [2[4S92$j0$hr|<)KQ֗9'E1N.-e  Atf<\(n`ȨV+mW΄;~.i{Ho-oҜ:8fS t+; 7c k!yc._)Rj{t8|ޯs[Tx൐0(dv&A /)߼W'FԮ ѿdtBR_ $wԾy8pQ &i Cr2\mZISr'L^d:ɍ1D( w>ͯX: _MHU6"|O`b L|On5ڊ1[[o&u 1#1ıhpz>ðcz][zxtOD.\HEB6BlMT\c*1˨]K(VYuZ:5CaV4@hg)Qԉ((v.ײгt^G XILj-˜>EA[.Ѩp q`D@4ᢆafuFŦ+]WL`ah#YԱ)ի 5d8(j/=ĉgu7/W]rȟRd.rZ]QH{Bnfx,cdgwK}ÊiZSrwn i]2 ֲޡցMY;(;tX_SfњyFBT;.!"*7?Y E&T*ә ?,:jb-a'55vWbu/;Qr  Lg][v"&DW9F̠Oau<[V:2^UD=B#s>i &T>6n71wӎT7=p^Q4qN]{e]\ٴ9yzJ ɽ 7  I `N#Qz͐`ȃv*ZZ=l"VL=t>a*PN(/[@EcqD2E!Y.]#o{L+(R`g|ɡVwE^|S j}^Ug:_o]7֚iZi|Ѿ̅VhMl7ˇwmAG`@$3Le.M LAjоYP[,F Dd@ LERޥֻ6֒.CS4jsxc[P'}&^JiZeTtbFNZץvcw x=GRdidwvddqjgF(]HnNy!,S&6Lka4J3hUlCV Å[C3B$ɨ£2ņ3jB& I:J. F?G6ta&+v)af=r6piUH(fJ@tʙC `bK7^P<?TPYILU!J23o˾ܱF=$ZTJl:3T6'qg'2{։ܣ(q m- b mwCH檘A 2~*@czi;̓᠒aq@.-Gh'cD\,_Ֆ-{{NjW.j.Ì㤋Ez0THLc xޤ;9UvC6 "rM Ch9bTsN_ɖ#t%,e뜺NuJ8R#Qhg4n#gT)Gm`H]3=bhUBkJVXS/@,2aV 4>+Ȩ`Ԁpʔ#A+?l 텳5~3S5!uNLO-1LA^*SKj(KJ K#Spr/ޞDZpoD>2L'4GiB=Tߍ;ϙ1`:o*X[> R圻1MݞYU?!\#՞0P^X6_Q&J-4檥YK.el.Hzk"PU"4 sȤʖCgx7BMw"dZ"\\ZIhERi%97h4%J4+ z7LΝ3P vד:I B;' Iaer-Z۩ĞAf[A/=;4J_͓W4lM  5q4z"\AVy$1sBrXV x2=&nwRLTsjA<ɑ*@ojMP0&kI1lr(㉺zxrNU@5{h?^ "ax@ŞD%rc*ˣdhvuRXq4IhS٠qHMα䈿i_mL_>o>Ww(_>8#-oXA^d%e\6d 5doR0ab@<g1ٷ1ڧܡ;a"БBߌlY\7dZ_S:u(WcZ9_\"K "ˍ>VZDgbldD^S]G9 Tݚ_=#ue7{[58'Cx,#xuZR3N%@hUHH$~7AF,~tըY"ao`NUqPyn @>BRCꚐ6 fR1 #X4 ٘}~P2 {\ /nIEM #@x:[;J?LBW~oQ,v`b ˉWt !ѦuaHr-GS,qUTt^fxR2R,GW^LxpV+@X(mhy}Έj"W6sb] O6 +`@1͙=:y\ٟU _yq  xmYV=jpzj{w.#dup̳t,>-9Fi՛ʮHR'4v%ru +I[,># /ԇkUuh@Z35ƲŠNmaϰNOm͚ݾVn3N ]TRz.nʦq imSp1b؆Q4 +D+(HS"{A,c≆=VA];hd4| Ju^|'}fi0GHh|GI'!UaA}e=X:xveT(z^r(6J$Q`N9[Q@abCZZima')YǾQ7ˁ:HH-`3nxea|"d5^L8,z:,<޸ 1#<=[J ]A~vt4eW.>إ'7הK@\$Î#XODNXlz LQC}u VƔ죞kENEG[֯g  Ӵ+̺3%vEc:-/ŜpnPL繾њi;ݎnsʂA"ͧ}Z` aE3N07 PCOO1ǩx7=t:Mʋ"G 4odTu ݏV ^&ӁڨkN6(Wp=.̐-Nu5rrb47>')آ 3xVEq,rZa 3p0ܪcJܰ)Vqd9!J=>Ulr»HM%WQSN(R:約o};lJ;-C2wWw36SGF4sXxh }`kq\$!ZR)wct!A+iFyHܑ7Gyg]v"s5iѱZ%۫(~Fi3yE[t-î/ OwŰBO:&M9s0:߆(LNnv2 ~6QR{_!Tbʦ'["QHa \U$VJd[-u˷Wgyu\1'(1JK(k^1lDޥzJ4f$V`&$Fvl}[xY-K6E8l̡љ9Jf_`⾷Isw煱j@DK OVcRi(Ԋ5״dV{wO]}oΠ{vnu\ Xe:LMlb%I\֌[wl.񪒣$T7X_5HQ{{DEwP~}L;MX܌5 4fFVگtj# tl/j<НGb3 HUbV[ ̙%%gp+VMސa-{vd+eӛmcu㾬ҵOBY-G6巖wZ "(rF#S(Pk0JifeME8v=~TjI<}݊\i'9z>^Du0r/#=wѩVüIr<ayZq Ƭ&YrG%ig'/$Y]+3v Ϻ*"(`jhH8Tńi2 ;ezk8Tʰg͆zQ"u*5j|+tkY~DXd"kUkP({#LWPA\Ple2L]Iڥ2x#Dއ xL$lu0zo&i@E7M՞5̘6N%6_Jݤ*Q>vA ƛ)QȚcE鸩o 'J6Uqtcl7hĴG18!;eS ^X}bxl8o4`\ɗStrX2Szav\BM`.$cRWolc]ncE[QX im"X3:ɯ8j"EZ"6EͻI@" ySd[ZBbhyЃ!֔jt'U*{SaXͧ kͯUg`ڌccT&#}(ú~ Ҷa8&6EoHn͌xO=T7Flо;9!)1ЂK o1 aQ@Aּ[g>Jd:T1@~Y^ٞ Rh,GlI*Lsh#JƂdD43"2)^`D4NX>~5E 5iҌRCבWSC͓6s80emT^T>3m8Yzr=s57ǘX%಑O ~awSqe1:rE^.frR)7H^K/ r& J.;P,z,!w-O'˚Mq;=W*văhaqC^xX"pB|LusF 4&ы d̈́ŋ+!Y{qo9xԌL\'Q:8&xǩ\R3pݜbAFdێďf DSUҌ |pD=Z۫ӜuzԝGsѳoLi4Np݋ 0]1_*.Pvti~$DoFG`菻Dڳňi*fM 8y2lHǦT+Ak L8SBE!AE(Ra8 G#!atx[qrS"j&F[kS3Τ!,@ȧ "8k Valt2pKTk29Iw14>"wċWӍP5bd!fEݵAFL$_|ԁhh{jX6 osF|!AfC1"tw$^VR Zh`nX -5J Va U$VKwׄ7e=bUbMRӾe3O!F[4ZaN!Ş_.zԱ rA -!(*J r+{ _}{3v-x_]F]uLN_˙!vnffVA, w̆i݀0RB֧PL#ޒ՘p F;c]kֱrPxN5OphyYliiC+%n55YZ-THzv\iD鈒fZ{áu҃%%zF JR3A"utZiVQp ,:AOa!=[h󏶫XB*X 80уaiXo-濾ISP>"Wa~Ig̲,q+ȃXj$ >d!Vj@3$ Yȑ!=u >M|_zo*FgP8&;vrQ1 [S{궩+4) dpGo@4Kn@j<2G ;z߬Ghq5Ʊ\ѱEyS\tiFYTsW Nom`1M,?>z, p^Jˑ;Ks 3|:b=ẁ, n9 F|!}dm@x{vε1)ֹb~PDE];Kif؀ ‰: cAYb fQƖU@jmN1(Ef684AKNvzc&ظVT'm}pȑWL;XpżJ6s4MeZE剉|iSe܊{N*[NBr$p(P+/tRa}KSԧO]/% J2qS㴃o 1FK|C+sMV&x+HsU*T5vyarﻧ##a1Q̧>M+ 4{l+X#X 0(Dn'Z&ӂ5[3Q>GNl gg7¢99m般|5)ϫ0ZH44EZЁs)4#cP`brglc͖65mvDr7v_iLWaLN(B*+jXT P𺳯{ x1ڗU8`ƹࠔR:D5G=Q @Izx-3!N洗 (z'%&/iƅ"BG[d_xVT*Nos=} ڏ`J/NC y(ļ'ᑮ  L$EP0f Cp>)NE ,v8CYO>8ۘGblvrl)Q:3H3)H;t?"&=ژ9,ep Dm/72>WJ66sO#D'e|+^&]D T4]zP:>G J}4ZQUuŹ&KR0G{oDeH9٭׉#Fh [i,07Z6So9`\)eS|}H+#K|cxL,ԍV>:ozkKK7ypVJxH=#s3 8VHJZ pU[kR hnT"l1\1g%ّ jDH*qEOpӉᥞ0?dwad)[DÃ$6{ W<{i~*n"R/][u#7'l.l?l=n,Zez"|CD/3zq6,^!#Yϟ/%_`j09=wI`и/wL㛒I uDZ#j-܈!n$RiH6WFֆè)k)lαX\ܪu [g%P&ybDX Xto<*n&A ByV+\i-P;TX^KN7&1PK0;&VqbKrZ%9 ] 5rz7 J~ Iun wPD}Jۏ^JQ]n*MۦD}F]_X$L4*jŠٓp rƅJRp)1=Vˡ!A %gDb6FKFc%RM c=+k0s c5dC$!+_8{gEX.QP!YgGaS_K1¸}HLH6oꏬG08#A[~"]8 ke=5>bF;T1 s]cj $ű^|eCʆ,=PKb."dan1~G:^4=,qC; %j BD{.kXZ¹mTOw֔tǶꋄZa'a+q\(mh::46)y "̔qb׈2xj/pUf1O>a5idx8F(rY rWLM oK=2+G$/adp>6hun7vtZt^iUVHtXw ^.i|/NX쪀y~͇Bm@@_~5Zl#8(櫻EELh2_/ϳ&ʦ@5%NR9jؔ7|H[e 4PR!#+n)[))uSZv9[;mAEG)ط_M_⻏I&lqDַP{gU1-kdj"EFEh%99ɦ;^{WJNo#GV6~.aQ䪶qbpE:ĞXV QFfGhs\E}KZ|\{jFXyMz!-Y[.c!/i~؎D,(*/2;V&=JϞ59B-s;i7E,T#hVpt;4xvLF]v$5vK oHیy z*" Wt@8j~H,X/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ۣ>+ŖnOd: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,}5xv03!jLyO;6o3tyc/a ѐ+j3į[l0>J8Y -6[clϖ"JPO>g2VT!B't3ꍠ:f 4RY P3bw@S}3[14GYq%Vetp>U8yVWm BJmi6v[8S۷, ϥp (!l' 4"I{ e ޥ iNׄe %NxP(s"6BgnWǭYntU0+JkJ8{ 88) F!I%: '+CPG8M 9cPpJ-=QzYtlMog]fVUI$#dIPV5P ֋9UM-%'XKʡ2ڞdm@&ƶ[ (]59==5CzJ"V?%BJead4=*k6(^9'D2kuǛ<-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":TvFq S!9 3d9aL2-8#{)j~H1"@2&9p7gfM9ֹ#zpl868"[P.IQ?me۫pT INk='Q{IPw"vQb )ŨTSqylv4rx,ypS1Kic&Llߙ7ÎꞰ"q_CX?݂!c>Nsf t| UūܘR*Œ95NJ @U"v2yWʺB]nCzv|GLd'.Nm:Fp΀=}mJk+챋ERbWyJrNv_*Q<oPx(H@a[ ^0uy1uN?8 mt>kz/+]IE`BH&N)9ݭDj#k3`R-TEu>ܒ7U~,_ǫB tUgl΍&ƻCf}󺮁D'܎C0CL/l !} HF7)EkPa-inAk]2㆚AZСS05=&1$DE-՘ ƄcǍ.( **X6g,Rӵ7WRYQ`U1VcdVo`:j<:c~7;g( r/HX|G2Eɻ c7 7>5trYFM-e°֔xSA ~β Sn%^ᡞ ؄fhN=S,ZP估M@Y}Y+y!OI^ơ2m"z夥(2L8@g3:W"q8n;:G;SVBi8 R1#WRtՏ虏19=Cfܕst?Yw"J (P/Rat8$1&X*ry(v Ŵ䱝L>W( %~2ҍS^V'\L#z%9=LM(A޺-T@#=8Zq',4".&,s5#I~hзU>H)oWXzkQ Wdz0Άpa' Ӈunpj}LK[t&:!(8T%71Jrj:.+3ZBVmORQ9rLΐ>\ݓfX30 jfSҾ-ر^I02Mxҙ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ɋ +stbwTrk $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`!8r7fMS;A0:VyI,RyèR1#E4͇M&QVVCxO`tH嬥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 /4RtELCK=>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`W(/^u={j+WY%~e^ Wy im3fTF\>x4ޔ~x>%ǘW.j`dN>t35h,1:@~c^"ע͵lJWC~Śk4ѭP TWѡk$X;Dcڽh/Fn+ kD&߯<0n3H{6dV*ZZ[$L S|qqQ ׆9ݵ"!j*h"/+j3od4f^VG6V1$ ZpԋTJ4m\ ?Zu;#2?|u_#J(ulU:DM#Ȱ:P[ƣ=, nj@[bOE rYv Ѵڑ;!kTL̮g!`@ a7H@d*AR/iW.]Ьkdȍl#e YJrШ)Ț欹x/0<*eIi n*oL9{9D"v%\kԎL /;FScq@W0(BJ>"܎d_`qd|QVY opO2E]b,BaV3S ; uh%GG*8P(iWOQw ;07F<|i$d\7%X Փ|baM,b bXnMJ멇7IZ@Ȃkd Д#jZo2 8h~ibϣ.&PIWWhBp\'jmޠz{:xwxF:Un_zqMT@gb~Qor'$(H '$]ytaߩBSx@U#4ol+ۆa^\zH3~ !/t *45 nƘ=z:mGAa-:mBwRptV￶*^X ?$ZvCDd3/*f="%S*(w}kqr?A=Bfa\ț_v;+k*;y2wGVWKXCAL}h62=q4^"%Z:WUL>Fdg^Ohs7 Rzl9 j #q xJ&+e/"69NS<w#)҄~V)F$A|/[ j7=5}԰="-EӰ wܚqTY0[wӑ2/Xx#90ML i|`4!.bPS`B~YnDm͆o*)uݚS4\/3 J/g*7T5ƀ\09Â2d:87G!"ڵz=R^$$yDۚN/ 1vy#6k hLLPIN̳`!mR"sdv 3n !пbxm*tP3' 0+qYphDߧ1J^ &Ujdta #1* ߹/фwZ#9];\yȨQElJ!XĎdfiҪK-u49jH*Gm7CwH%lRU2a&uW9zm9񁳹/iGNhL>rqU=>bO2-mUt D_Qy4K6x6 gu\ǵϐfZ"rk+Ҥ4 ث`SEmOZd[{ |ot  tQFE}bX&oFAjq^SO*0"GנujRC1Ou/u*dHN!O#q m$&z%*1g1y"DzǸW l& .e<) d۬wY+vYLsAjAȒmc:)(t 0# 6_hdZ-Sc5δ:nmT9֞N[ 4;s(h<}ccG%wDL/$ؑA'd=~.vnsX!6.g[ڐ`H.q QZDBP lR jO @y1@6hڇ zsgG~㘰#{,!^G/Zk+ƠGPM'L]jZMRuv|ųy65EK;8:{. 8˷%6 "niv(jKӞJTQUĂGPn]iﰸ\>z杰aяNN%7nHu'ucB'ˣo}nR9f, o0ƣTD&q>c^ZI{LETP&z#/#.$`Xz\W\EP }l3AMP!s,A1vl#"eE$%"7~:廭qĦ\u .$9qDTqۉB0^bOW^vcD&Ұ5͞tKRp!6a٦Vq[yMhnl'+`W:cB6,O@]U!:R{M}Ү_^ɼdRk$o;xZ;-)&ciqf7^u/V82Cm،ׅ<*:1)I(9\RWX渺=!SΜ? hW[m,QY3xv:[T`y…yse9z/%%ouR?l;-}mY*rM:S{P,Y 0Q3Hc‡ aX)6Wiw#c-z Z Vz[qNdl`KE\92s b̾B]"m~[?[1ʊZiRJkh&=٨D{}W"NCwK7&"4V E}_&9UrvuUjUB]%{+7!/߷CF+Wه_?u/ODb& Q(ό[5q- ^A8 {գJL&zhҍ .)&Ue*88CE1XbJŨb #}-2ݺG9%܎Z2)h%xR2'*Xn}oQj;ࠁ 84[4titC/6<v ù,Euqr񾉲Kΰڥ<\b!b!߷"M^ 1vGݹD-=nnlCklgzzf*ѿzѾ wU k??#<yo . "3쫑 QZvoR4p`^R͙P)%8l^5~fpf[An^GVуׁ_z ɍv.r8!RXD)GKs244o]Fd T=xMt &t`L6h cꗆٝ8̔6eNak4Bi|Qm.mc@T(PFБQx`zһ萆hRKxs5$^;'2_R|ppfQ[}M>"%]#j/ C QNJ}%M7*YO UOxv$dQAm v5Gzi+/ߝd*dL-)tXF Q#hqzoMm :M qmW[KyF%:g7w Tfr 5Wt"Cp4hmK֚\7VVγQ';HoϿX=ҏ2w ZoLQ"!>mc)6IvpPYwT̉lȇ_Ch84HB2Xi;+O}gBQ<^nؗ)vh" Խ,6m+<-;@dpS06vGw=VA [$zY҂2%a-Γ[ Cpmzg憐,0:SjK I9ʁ)\ eD9 1sE%dNTF񘏿).jC!b9.8~)~pτlX`o)>iߓpE-~aUKk9A@O,G"EF*aWbsߗ]r>1z0F k9VT拵ɰ )Kꂀ-|kk|tfa#N/u RYGAU*V7צ| Qy":A:| ʈ~ᗎ2#E@_"*f:&+B+ n]O`M$$GO7\pj*9[UMD`j!@%B!Zwzъ:xb_%q/Sm_V""}ה\m3ƹU{Hu3 %:r-M}=$G@KMz@y=d(## v.S0>0%ceDO9\!3^糄)ht6=: ֝6lqƴ }(~N]eXC4-/ R@=2?ߎ1|eU[ȓ. uq~y-%fBe7-EW-[.e= ' _9ot 0\Iq0k@Ƣ-VCE'+~GFIfdwG`} -P7S)+C?E`d/64K_34oYyКg܏ݗ#o#=iLc|A9mk&`Of![UM*$Wl[ N5%3z*"#R˯08)!] s)c7SO MC Hxh,QP!7 `΁bz``nylRf} `@`sa TL*^c[`n*B`1X IY#v W{pB;fZHl5_S G1ݝYBYV]# nW'<DTtsz g`LhZ%YDaw |0 w78Ld6x# Nv*uCPyS Y8]_+E阇x6u*GJ1 1ݣ^Iְ&XOT{!Hf"zjւ=N!g;Țu ǎ)n *<7"olMpOJ}nD7,SÕ6AdʒgиL-F߿kqQgZi+'x *ffUM+h֋?CCMrV j9XURE^bC_bm~I$./J] GyCڿ>ShTE077P~\auD RK M#V mnf.RbCBt9,Yn_E%PJ%/+͐/i2eҫR TNASӯdmoF>gjAcKwb 2%|h$t#:9GFz 5+z#O1ϣߝ}Tt nE&Lmx !;P f=9**=K"d-mX4"862k(Tʢ\ۅc=׈F<}r}zz9BW5䈾Z'Qp~3CO@J[ J؅HL.0Jq|F5b4_%*U!9f7EP ߑTu ĨK_5ߥwLC^Gs~&ղ֟4"XF^&) %pRw~Mb"vһ(*<-v![ SΩϩ{wLk9TmUKP85BY ?B=y+@>Jm/P҂0q$GCד;}`N .[tvkGz> _BrFcRxeK=8SUڋ9Q* r7g1zSn;*,@×c*6R*g`n Z^DJn7HRZ"L-jLqUR ?-(7BU!uCpv\hpd\qR6(Hڇfk'"zN,`UsGh6A屋GFk^ at> ; ~NK& F=Pdž^(49seS 3XA44Xґ/  fŠ8u銭d-Gt[}XY51mpןg'@#dVYt#;0Dhy} S-r ̚K=yQ1 D~#.y<騶JFa3aѸt,ּ ;_quxÑ:"eC&*}v ͓fcޭM 1T=+.4̗o0#kq ˔3VoN;=(^8տ˷^[ED|~cvCA,Vqfr$r3Ci =g\*cjF2rA (ޭaؖ]FMoCz)6p >֘xUz>ِ~u|WCᎂW~] ƩT!c%|EJ E?/Djc,ɌM>eйb4kj‚ȏ qsb{?jEHWkYR(2hb&w\z}4 Ug$l hHT*ohE˵5glqUA]Oor.-o>^YjZp@pag˘0QOq_)\q . s hڜTgd21^{:F鎯)*lm¨`ic NܽƝ(ﱴK$"(Y~ y-% 2 >~Z"֑y5'^VDY[pְU(OxT+ `aȷ6R;l#0)e%duՠ,UD^M0 09᝶N)nxᰣͩrdUL<)H֤,M ]eƈ7i:=#.Og|wW5hI꽕u*(۾E@-( Ԉ]oCܮe:9TAYPKr06ޚU7y-ԩ{ iyXt+c8@'q<@%xq5.Z-BW픡e  eL!@\ZC];R Ӆ.{'@X֔obRAma!-]J,jb)'"WgF&ڕ{`5.3-' n+n܊J-MNQ^}H3>ڨgeUIϡ$ C;!Юqab<umL7u><94wN@- =TxCot>~ lRjlVg}IB+a w ‡4+](0uP:>t;M)HC^|pzXMGvMss$JBfJRNQ ֧5c<&H5;U0 VU%B/Aߔ46}-WcBnEKMp(}W372ߘk&@+ kw.L;m)M̢|At`$ؑ#|Oڑfޠ$'\/. ^[xst<ݽo%:l?A:樗gʺv1?̷0&ɧZoL A/"{%؋,uZP ?+FFj2q"<+isY1z"G@DŽsŘB&cvf:EZ-4Mg6бQj-(yȡ21I7 #"r_>7j͡_D˺rrjAGWs3]l܉7ȊeeyUclhzöm*o!.JJQ/-d&tXm▪Sr8E9,yWX>?V!H'-Y%0+Q +@sy~ "Q d4iltZn`_s b`ldS8``z<@UrVꩄ+ Gdr.G@*cE?nQڸޘv)vdb 'Q̼u9_f)}_JKol0ݨžKX&gZZ ڊ%Դ=VpkfS4ٵ05nzY& wӒ7&JiRm܀GAM2c>|Ӷ8Yg-WiI:X$rSҹ>>);o}-$;[?M 6ONwɄnimo>mS8ͽ6Pz.2@yv0/~Wlƈ5lg>|>y9TߗށFܴQi'N!;DjꖺJᯛW"E2YpB)T$ɅB@INj7ݛ]` ((RqCh hL~gi4DMok`$0w SɖN3皮ה 9<@ob g%]0b'5⪳PERR)`@eO7&.>0SÀJBݴ9L~ך}-Wo,4NsQ$T| |&)QWpQ6Y< !?$ \$29 |_slP3ޔ!QG;H_YnMl'iBƦ/2y!Yx<{zA:>1Ɩ=i $ wiɔiQ}F#΋_'ye%Sq $$Hlz-sBӅM`i.%wwTg0n#0l( UpVOM96ٜkctl Q h)BRb%uC4j?TDۨHLs(Q!UνǕ%y_x,0˷y[ȵO,w*3-ezN6*ךKKj ۲[2 58k^9rJ.א?baS1Vl19aU ir$c.z{p6 dAWcAG14y!Z?9Q3!5G$W(;υtN@gP{yjQׇP/W#f[x,P# 0\t:a Û O@#jA&\tgS'˨\c" l *ZSI 0kruaWN0TO:?Rc~;[B ;qKxԟ/LM_VonjbX ELU?S6\u>^_j s\2vW⒗wϕ¶zFx;.swG~ KK0{pS3igDmBXcup:۠E1u 2zg@EP` (Otؒ!X-s:$\sQ]ٜ52o{*[f]=_?metkT3Hq-Pw}θa8&]s?{pa%CM{14ɈB<ʗVsagql4*6Ui zz ÎMxTNzL e~- ' Y35t;[ZMR[z]|P U@>;?i5S"? &q~#yN謰mZT{ D|+ rCO8bH\;AsbdgB};1>9ZIzgtvX'̺e"U8n р6]zv{`L4D!\ nlj{'b!eKA 裢Ee4K}z&AV۝wHz`:Xmr?8>^6V6v|x&\ju{kqHZ#B`oN62_1)IE}Z sX].8Qn)mR6l?}]=0ݣ>PeJa(*$&r 2"Q0w!&}3DS}L('x„,"(>UZIl*1Y$T+r?]s$6݀_"XR*-)'J ^tZ"cXyD' ϶3}n2VbQ>+!$ZiQcl?2UV~& *alv^ErֹPy]HWVk݈IPEr\1$Ӂ'0<찑IQ`J]>lf,'2 zb{aWSqJ;H9WyLmWM¬.xٱ}%fLT짡ϓzOR̡(dy6|ӌgx< \ʉ-XW-4^auu\+!h $ΧIq& 1vtbLN{Pݓl&Ylu[$x8=q)򵏤L1Q :DVZm!^ !`{jվ0IYo5v鳍Rlݯ+11S,';%r5PA&ݳ߽B&P°\mA퇏3ݜ[MIr[z|_uMOgC8)U1TԈv~P5CT"# ?5-o1#z9H$\6Q\k @!ά)oK#e`atϑXd *iH*wEGoC1Xgꛡi88~8hN&E^ÎYnd a'MP^S̊M*c36<}:SE1粼UؚܛdzeGjoi<VZQ$<2BXb\ћf3 ֜e$qEc{m;T #MrdDm=h1Ľ1s1ms:HSxVb`xhxAHxnܛZ'"=?IF ^ 5*G'#$۽Ssv/N먥'`gjDLj l'}7^h>hLuԤg: lxh-SlT orgo[]Wn)&U`o5kw`Sf%"˱QZBn 2X럗 X;y}y?Pp1%u3f-VdRd-+-kt;<;GAKSO:ܕvϊ5ծWVĨ&:6$Og0k2 uIG7$Znƍ|C΁2o8uЭ~ڈ5I?NkGҒ.4fF&iGM6œ8/S4}tJQo /xn}*}YRDL @~)fc|Ep$F${Zx}>ShIVJxU \ ʲ)?;-hk?J5jGIC) m[ݪO\\O2gsFnhVz0M|9&` N c7j Z\6&!Qdnǘ=`!r!+"A =˪eʻqm5ZyAɖbO1K>FU0wa l.L4AvTba-P&R(K:<`pN/y]Uݲ4 ۟V¶d+kmBu KRVy8okq2 0]wNzx! G!s62Ci0M,l譪읗gV+$Rv9)I'̩6MP +>Y ;|#9ʹs֦Q$`~|anir*763CV} 51EG##$wd* _ǜQ+eMMgm,#VFn:o , )s⤃ZŸ=L 4{IdqG[Xtz>qUT6QAע£IaW;cߗt"B9$BZI3^U- 3\hWz_J@d$-9pߪ&xلW,s/}}oLFpRFǼ'΢^:{\|j7zJhq ʿ,1*V$.yv\)|1Xublbj1Zk+:^& Uxݐscj x 6 䩼c]NOCeˁTr=#C@9A=F1{4Sm=j}:Rtek\@'qd6{@j+Vl| w{8=2JW}j||˴&C RHU.÷LX)6'yTKIqǽnρMfz䩵`̸Hѧ`PFe0r %R6^0VR`gPY ~l*քB5W~ҘIGPMq_{s((aT#΍U92Lp@j,w37# b"ODB '0P.>Ev"DkCC´֖3߀0" _ER* @Tw peh3/|/DpJ ĨMZvh~zilZ%HYByлzޞSgAo87APwbndzZ*=hi':Hۖ{ T>}s>ta` Noi<;lR}06.^.=%}i&xA4ӃK~ =tB YBY4E[]Wچ7459Yp!_DWA #35)ÈEÀ8׫jg_ v$+yZ]#T?MWS ܍}b dQA7d HcևjM!F-]4 u 5|F3A+_$(g ӎ F8iz^m=Nf,m2*1g**vkYF4yOUKdJ du1g Wo]}/wGQEQ<(Pxp 3Xy@䢡it;*/Vms9h۱ M^=y)- =9hU\YMӀ; $sNAgU鮺Ml+FZAt6hEbkȌ{ᵎ 8]yGt +0[5"eVPzBH*w qYnVRodi;#a1oD# 0-IȡO|(Ϩk!VShRf,ZiwꪣؕrϢg<;_DmYk{ 1; & Mv l+N\,8 U<|/[b_!R6(":l=A 0 [tHvDMD7I05*yF-XDDN3 pu(O7O6VM=Z7 poIG#nULnJ7GE[CގH%|xƏ=h DT%cv B[u--'UE:;:ae`^'&{c/,v[aǦ`j 'aZx߅N]Mpu"?k~.7~8ښMoG)VF[U}/|_^-%@vF6w?@Rm!crA}?&p qڞUGzi/-ejʈTi깔Q\0nЖ2|j`Sm Oa< niqaP5f^FD<)pZ}u_4~d9Y'T'3w+I=Cn^?l/ ְ 24nUaiYt]EsbB@?ةBos)F/tmLڎ@ K!=pҡK+ǔkϨ%Ez1}>K*Ye29y) I/3}aeD U9FO5[s黗+L!"KІI71*<;ܚDŷtq,Az,Wt Ҩn/@vhIθ@k'նWXLҠIj 7fNՅBJwЖDȎ(o"KpEm&)j" ^a-|1ǧ̖R7iC,V`8PQm0TfcMrb=1T/jֵkI[u|[8ڼۋ>Bm&!lSPr0ϩK0@<//sjL(jĪVP<KGffG("%!;lgudܴ@k"e96Bz9)79q*OkCYk@D@LSLE&ʸ%MrEr xR$6s]t%=An T4`dM"ƲZލfBdREe_.mljhMrr{M!Ci1<<ӗUrT cҫ3:vOu\*z\G~u׍bBsTg`L*A=K{;XcD֖%e؄]]Ba:}gubp6)aKbG*.oZiJ>NF`-.jɟhfnV*tkjD{RcYUv\Q֖bRt~ \lfPTB[e$9DLKݢ'#VC6I͞)`L]z# ;7^qHNMiVEjw_$Srq Qv uy)hcoziDI^p-`ebB)E1ł'zNTlaEmhL" y|-ts[ SK*m8>'Dw!Y>Qoq7hAzʷռzBϻǻk]k i$ OhT+]ÄpX@* -Χm86_ԐF@=t-g8`.\hj}}bb[3u@~q|˴1R B!3X)LBnuQE{p5^c1_e} % ꦑO)?V8`\8Bӊ}h8XeqcRa WZntZGk֦eiBi7Aǹ׆q豓 :) >6=_u:xERn>C s)y:-2岐i|m\ژʎNhG,Y\WuLF/j3e<<(=Zݼ,qIIg"ͳ2|Dk8x|}0Ay2([z>o>@wjǷEOT-mڡ(:g0XkǃL<=cͽN {jcCxE5aIGPo6|6 b -QrޥyL}{Bg"T[l8uKhC*n2Ux`w).IEr EjmY]SJͅ%ӆ>CCiyYLyB޾"`P@TBy]5VC,0:0K =^#anc6gR{ `Tk󲨛\7WOO"C"rbA9ĜA*Rc yi)ErΔt_gDX Vײ|k639_*'*vxnnH ؇\D擅 ~u wX69̲8CK~eDbL8\LGP퀺DKU?&C۠Ϊ!*3${ᐁi{7qp3"D 7˟TeX|u 6hrm*qbtֽ&]ӊj/Q >20; ׎5Nm-.lY*h 1“V*i zy?0L C,2 $G%׷.v=VHv$tW8{+K~OGqۺܻ9`t): س/GՁW/o%1>1D8v'쵨i[M^]cLKSa( W:Joi> qj:˹ :5)H*9h zՀϚZ>t,.#km{M0mnKx3JpF>WbEDŵWTpx\M>3΋Il0o3Ŷ].TsaMyAࢳJU %Glxi8XS179f+Lw'[|7i4^ڟ =3_ 벉f1W2ۍ|$ k<)z;A\)-~ ^֮2uR+/)FV]&Dzƛ8[(e6nfV]7#/PN H8Nʋ%!y!*rd%#Yμb!yfg/9_8zh1>LiCS3'>NRTsyn i- ]xiNXJ ; ճ+;g̭m܏ jUcRϿ M럅je00G>MD[o߸Y!HG/deK{O~EW<tצdIOkq ^{4n¸93P^rG'zVޝo NFe[x);Z*Pũ4P^u\\ hNWM?W |z=pI%MrU7+Pn"Mdq5r+Rn{܀u'Ι|DN 5Ai]"7moWY`^/ g x>?//v1HᏜ^jLZ$߱( ]mʩNJv78Xk zkqLIK@RzzbTGhK֠XRQ՘.R_j`ס2qZZ5 +">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Ћ /ꍷUE8p?0yqQ!ur!;:CבE1D.b>nj:dYJx>I9b>JtƣaA~zaŮ^M>\ϮBKm͞Ldh9IFO׃DMiDjk",f^/g|Lt9MĘd:%|0()rԭ'8te7Ik|NP:j6kR8P_%N|^'`&];uv|vYj1Cy7dvWh~(BKuECr*O1<⟕l "4(yYm8"#N&.6iV) G=QP.Ƌ/[7n^FxH $ePZIM!E n2 \aݔ 6_,0In2|i+,mꛛ0%c}˶2{= Ud[3q0%@mfN do}gR"p3c#؜WD $X? &T4SRÔUXcOj^wY<+k 3c6*U++nM4L6+6m3jS"bN ˩$wDz~Tz!VG]Fj9>`ۗGvyy/9ᾯΏ >C̙&r-Ŷ83ՎG^%}COӬG̖6bˠp/픣?dwc_zÇH+="p9EDNKY!/:cyqLo S ]Zq5~V"lsyTYNG-i/FRnUFPMKK߽ivE@u]'\ݼ )'CɶEn1N4m{2u|f*+TTWG5aA.k4vr#3eML]aѳfPҌ}N[*Azv -n> %R8uL(D>ek1Έ4{ߓB\W"Oy>Mۆp;X-CcIme$sCtzDnK[e> r2u̧lyp+ώs'Y %.HT}J+;].ىB{.B`Ojݬos#e1UmJ4K'~ Cb40c~%""n/!P -i{==vʳI}u?qj#aS6ţcG4<_ "#dHਞȫ Q;LdwWa{*_e _Тr*W(l6 96NئC'YPlwf.y3ݩ ^?Ye-3S΢;:֒DİpxY'ɞq1Ē)Cj4F/$Ε}_FrH(+\zC d_[1""7b&'hȹJe>ґK5]@?~G{e>ZAݵR7YG"Z·)Kb^>9R7R߀Zx1K$%6M^dxF"&BKL>wSGӥzgJ:ָI)S%fq?V\?gq&!v H6yy h^+A1W,b1l<ʿ"J1U$KhVH4Du֕ ͪLwBT:3Y Ac"cZaG؃8_?҃+. Y?= "uup/o@ u'H\_>=h"ݚrE)řprsLZW6zmOxy;P>CxLҋ\yXJe*n42Ub!NAYfq;DYĿvѾm4 t!\c_U_ܞ0OWo|Ճr]m-[ڱJVwX=ѽTMi5OgFˇ`]Mof_J !G x#}266UDf[/ȭ&~@3"\,zx#nbou8@C3EwmȲ6SE\]SM񐾐)DϞY Aqo&і"$^!(U˟wsS_.qCNv^q>MAM:t _YU"!){P4=G A V?'5cw(DC]02𼳝ѡ2+,Ym|{by&rQ`W'9>V4i[$0qGD4﷿{g&L^#,M~:uIa֋Jg y@NVpgWRsuVm/^Ri8Sv}U~띻8d (qd@;5v6̬*gam5R2`l%#x1N Q'!kI.f()l94(=nYvyo|fjG z\mڛzovŒ:x h :T^,4A2U\IU ,Lbk~t>UC,;p\?[JgVw~Z.Kp~&n._nha|Q۔G㱣`tE\ #dG.gSXoO:tK W p7PYU&zT1~Xa7;Wx z} &;*=:x' '/P=m۴|8H{ScM߄r]\>oL.iUiBRgm?0l"  ڳ3M֥q7mo\HLV?}+Z>n@x[Z6Kf^<m}a/IccM} _-/(ܠL{twBxnUrpp C3 KTje?RRQ{$NT r~?H{>Pk%86 mLleujU 6㡯"âBAuE1g^KCAqN}~EòlG7?6&E+Mhbv8֊oО_>@|׌! E7 ҒHAl1 Ǯ뙪 ?VLuxLjYc56[w%MFOF`rCme !GTh d!Xx*X7:אx/rWy`r}ۇlB%5p~v~i;&IΙQykžP\{/ƁWb;hMS`+e,`ȖC̈Iul:=΢A)O# 8FFF ,/(K>8ms;Ow:o{$gK@{n^LМ c2Sʍ]`҉wyk = niu7/s,x{Z!i˵,#.LBXG\qVrŸ!Zbﭬě/ߜSDVZ(Sśl y!2nOߏ,waȐkh47  s^3l Dzv5ߘJ:emyǏ3՞kFi2#n 3mN*EnVj0r˱^u=S/1:q޻y$JyW]/5VpUa/p)m BᮢW 'TI8.ߴ5! :Q u\iway!Eݠ_5Qd^:uM# z)XAX\mX1 CQ^NcgLYP?vҡpm"ʾ:l1yu ٬T@E刮f;B'WR+eQo^}dAE9´wX}.{|G | o*ܦ"sFGUڙ9.Yn}6D£vWÄ**0sYtIqg+1~9=R_F'γ!|Bϑ SG`ps阮:x7i2X=Az/ϴFj+WQ*,UR!V^ca\M|7Y4`ʁ<ϼ}=eZb?m(zi PvIK\L4'Bmyl;3: 7G8]#"a3YhQ=^;AbZSyA W i4l[y1gα!Xk}|zXp0-B+nW;o HGq!<$,Mx|\{34ʲ9O2#XBxV;ehA!&Lp3 BW]~<]aE0DCzYhNvDlq0d \,DZ趆 ,3Ծ^lö7[,k~9ȶ$ 9ך1UҴmv!_dN˦G{=wR "Ǖ;YH1@!}t~V (3~ $<~T E/pzxg@(hґ2OjC?|Ahx{v瓴СXnu, ̋ 02a( BQlQl&kVA Z2n bZQJ,ȴ&xWou\BaigoF[(?D2_7c߿\ۻ열ƖTEU|֬q7Rcᢺ$#tڂujg85.vdlk=@,c`J=~Kux<0$- ˙e<ԫcFڣ@k5($R Q4BJQ8ZK4l#f8VqɢBx (]|?.,94•kG(6J\#f1+mdB罄`.ιiq“X׾|tsE³V|rO+Z0I 0 9z,NZlqCT-& Ek=u)f;y#++(tbX!YZNw~ 7̺wwE1e2YGB_''~.-#'>EU wYԯI邠VLv *X}$.b@& ]±P5e?TPXQ*GC< ʕgzU.hHMN܋%n\SBOS3O8?I׷rfdӊ_T 0psŎͺrĴ뙊8\.+@rq2DpQK m̓ <;|_I5H=*H@Uͼ|jڂx&lI\uրZ8,Ӿʅa7)6t`l4I)z~86AK#S@pXޞ\AŗփbEhEA{<5 ZT/b\6.V7iZ_hM5^}' 'b챳݉N<5g< ‚ye5sR*`La]iE Uq{͇ڝV 7CYż}]ńw*shO⽡oŜ Lk͹b,Պ@/s"۪ '܋W@wQ ,VF:X \*-מr`XNQsYQxzOHj( =:GR2vw { G[[1"Q)RV‡y  ͗ZXjOv/!bĭ >O$ܡ?o`; e8Pe?!Qљ`ЯbmG@[l.2+cB?Nm?z? OvDƟ@ΫFaIfhMc30a[w7yN.]k&v3oCU/ ^? d(ćήe7`J)ݝHg˝[~l]&ulc6`u |"B: {UMgIbY&n?hKbu(5vT2:"̲\ǗOjdNwh\<Oە %P";獵^ l<U0"ޮbo%Q٣0WhWZjbO\)@cm.D6R[LU&k'#vJ/ʹMf[_'TW o Al@~ <N1x_4I-qW+*X*-/oKfo"ya4ЊrSE y>}q7kfEN̟Y~{,*ݣCX[Ynu>B]<663z9O,j ۲wNE*2 pA:˔.)h$mE]p¢2h&£ۀvlIAۧ3,\+^ԡ_ʐ֘re qGE)5=wV댧^2緥v{~kM6lƜ]_6 LC9bЧڟmt1ܱX EttM73;pRqJ`r>zbf^|i R.xG0j@.4]rەor=ˀ3$> )I1y2~F',`F}mƩց޹UǕ4> 3;K\E^eS:uYwo5A^AKef5/7=3,|BquxM90?1rOZ&u𚎽^ANVIfu+Kl>=Um5/I^qwxGw ҕvD91ZK/\ ]}Hg#nY)"2e<.Xr{l׿ iy i0ýCsWBW?:lpVdP'-]w1 j!*plׁ1pN]aiWC`N7%Z% `;?s旅Jr؎g;˒ ${iG=nXNcLu9zڏ'[u0˵/Es*a޸_:r͆dF[fϺjEG.;gk:IO3M,zs]ǀlYuV|Xna`zܽ])[[4xD_E}|EKQsPjl1:<`<+uÝKyП(c2&/k_QQ݈GbSvA6"t HaٲU;#u~mD9"e4t|rqWYn8=r8wUX򲬨&R:UIۃlݨx;C>7@2NoTn+Ln IѨeA_OnV+};sې$;MC/\'5fo;vm3Y=obZHפ6%z5(GHf98d n3$BvӕWE%cO5=99B@3da?M,@4(lfz~䷄iq{>TGRܺ V$aa +_d%4xBkC~> "^!wr'@;!?tb0ƪk=xaӚkjRZdvoXG=]6$=- EPY&!b,}%y] ^ ж+󼖖cpiS6O\CqxҚdiG->Ks*g9)9{Rb/^ȗhSVѺAn,U;NMj,$*̠y>=7W:uJ8 J: tA S,T$}ۺ{_D˷}#pԢj^ґ"[@\&F2uvO}a6l X.z}=Œk`~ ]Ø23@ bl)薸w0 8*k8y=F6yj~QCbb<[/` !vE]ժ-}׋_wx t.w6?塳$lI-ʖk2@ڔD:ҼA]f4*_@vV+M JsJc࢔F)J8Ğ1FU9jZr$ YoKR6ӧW\O_b ,Y6$x=)j;Йg v?i?˞1XJ")Ο1˒1R #nS; 1 7 xܺWF=K>Kgàݳ,*ӼDz۸1۱汇J:3βQTC2DC+0Ъo5vO[<>2[϶;ⴠ(*4vCaP^ kmu*SeN'(њN }SzsMVJ<"FOѸSjW lzׅ\=_zӞ=(uˡ0]t+7 rg̨E'C"J뤊)U:eʾ!>ZZڼAp~? yH0(ܧ0ڱ7.+y^reLȫ!DcPIJr)AyNTS.\&s"D̈|c aw˭:=S啨ɒZJ.׳WU[g̜q+u㔫 o ճWAR젙v$E|.5vjQvwpD/MvIK^f#ֵOҀ<^ζv=K;+{pI4zdZanm9x_+plk ";h Q"TR]F{<lyN2oE*jY^[3[CKpfo;!,NnfV #&ԛЛ(nԷ{nuX )** %I jIj:hs;i%ET\'["ܼtJmyg:n`}C_9dOX)8fT+3IoF3Ιm&pĞG_seJo'X_@ڶ=D6=j ͅWt~H= h[KvI=B̝Q Ԩ׆] DHՎaXƟ$Ĥun2y,F<'.AFăΊn6>'NҼ/G||ܹBOrEI){]R 4ϧ?d7{X{*5 Ǻ^oNHe6ᶿ~3J|ٛ٘uy|Dw ʷ;S9Ckcmr/WnK)ԏ?d9dͪg|GC=FȷqnȂ'N=ȿfa紓eT]&w^_r ͟¼4՗YyKS]({]~Ldﶰ0'%#ly2N*y6^>k|oX2;ᥞZ&Ea͘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/vI6hC5p4]c/X [j,>π8/7!R&K^^z0x,єz;tMydŔ,D4/g LZ~ mZU8"&g$T`z`-Ls/I[8Ζ`r}* ,s&iBSY+_7{ힿ3(l`|7?XW9* ϕ*c#-Π{Awgڶ{OCJ4M|FtοS?>o, :;)Xto-oL'|( hǍRX=EdQS\-)u|YG𳏠6]oC|W946޳e]ݞyjs:9%oE}`N3Xa2yhr^Huܾ4++~"m ?{Ws'"(#Oژl~^F~{nфhӷ}-Y 5wՒQ\ cmj%kGUϛpùPA*BgՂxZQ;6X#M}tˠED suudU 2jBNd) T]RIQP )n*!$g)ԏ_ncBIKPC*zW^)(A/F+mقl^/|>A7p1Oڿ+O 4ǫMU4@SHr>,‰J elNҗrk(GDP~h~6nG8}/bRhTx>4ᔶ b4,yҫ$QB[Soo3Ctiݼ+RC=7lsҜѷgƷ?TΗZuw׎ :o/^wx@ ar!3ƔvH."Šu^f1u~d=i@|fXz )FcwJ:WV*GFzSAQRu u4*R ҐD KWYSM~Tr_61ԚtˬsHxboa_IȒe7Cdgz_2/%ٺLm6^emkqW] ,mЍΌ4xprg2_eB4VZ,t=+S Y ҿ9ux^mF_i vȨr7((cy֑EA >o_jtdFO -'x15kf#Ҽf**g-FjIl*07Ve ~]-GmI|DD Yka!CgǞtX )${jS(<$5cj):ong})֜tNSi?T+-m&Wo#LMyŧKy&R+X2/ʽt{G0Iǵd2keQT\U,F}t\~u4&wo,h=7ez>w_ʯx֥r: AR .SMJB3ǿmXﶋZpQN'x#dB;e5VʛrlĠ56TaJ"-NHoX>lB"}~gq@/C~0F1?@OJLםFR5 0t㤞Xmalsh?%݃WFá"4nf>ձ _HD5vPe}œݼ-r}4'<$BVyw|M1:C@ᷥU<-Z|ݕ7BXv91eOjjϞ?lwVe8|}:XWfgsD 6P" U:Wks,ga,s%.<,xM.ڨj;^pJ51?)k4d#'; E㸥+7OBO^=S2$){ϦmZO3+ϙo}MQJ5|[7wRf?Ywm~MТ^kfNk<ѓ%h+\/5CU$TuCʎ ̎Ka>I>{LqP~?f=Ğ6 ?Np)NVV@s2WsnAziD`cOEkXPͼ9|Zl @O$7J⇹qT%p`6_K 0_d 6<J񉎙WKu/ZF?ca}T1c٪+";w]WnSFPFDkUǪZI^jr`/ԡuTH~#RP}yq >e:Q6})MhYE[J d<.g_jOno 9*F_1ώ\d^:K>@{Ő;/ < f,Xo;]2nG4_z%n?3Nm i,Ym2 5 a;Q3}2GmD3bl~EA(+g?vZ3ng3H?*M,qG6+M.@aV NN}zP׍ Fʬ'u0-o+Nu9WVy]~_ }~Sښusj趩)A(i=?8\y?QC~$ /#(|>]67mb >{)NjurS(v{z gśe,/e~\yJ=ݹf[7c7?ߟϘ)w|uht= J_R!x0hzPH9WVxkS֐wYp\S;Ӧ3rQ}_ 6ˇ4S|Vq{C j!+=IB&,1rF#lQ$;U-0p ;Ѭe zŠ%'ƺҊ@q TK_ǜ _z6UkE 3_(4O}ys%q3jZQ ' FfÀ (::L^ez;t1DMzxO=f`D&&ש/T[FvMh_l샣;ҮU.jp8F}ҡU&J5q/n&3,Exgpݹ=tUAwג_SMUTݬ-mygJ;ݲ*9'/_ƖMO0t31Zjrp\2Dž\GVb! uMGU+8b$ 3tL55ߏ- WS]*˟nÐoS"/L'vct4qJZ2XڱZOwǖZ-) &uD%h$.IDQjNJjTtԱVR]d3Cu)♟Ǔu@x3LH~M:`-4^a޻'G1yzgW})Rm9*?#xǤ=⨓`S:<<'Vί~4ʆu?k4a=\;n}yŢː6a!az7 ~?2VW|#S:DSO2qWMJ -+hajհM ߙfb?c:Nr|.}7φX ~ќt}^WOiSݑ珮_F4 M&mdVTs3:K~( $4rӱ|?;nA#xy{PY,X%5)*+Qg$m;Q嘙.SF=ct7$hMׅ3̓ۛ;÷|.{?_n==,ߗ}QM_toWۇGN# o]s3L( 9v&KIJXQinNq%@\6j4-DZbp T/ ri/*>z I POng>@& 3<,jVL)U( ?4-NъX]J~;Pd߃ o߁,H"ҰFly 9GnqvS]xm.n m?Q}|pΚ%Zk?8eׂ)?>ľmn5 jIZPqwN+2Ȁrm{WS7Cz:e䇇كę OC(&'4\(ctRqN#`\xO.FO{|t5e>waujss χo,8?|tOw͸-=`V/?}y'ڸe0r4LqIn@딵v^TϝL{X{<~xz.4>l eɒHR\)۸'9|~6ϑzv}7Lf>(p|H%ӢfoƷm>Z>Vyv lkJQqU9 <SC$*oC巵bLwoTԌI_v!'g^Y=qY[F0ܟHH"axFek8´x=x f!B_6&[/OW&|9 yb5=w_f'.IAg\+Is^]Xq2vּ/?=_߱=›w^+sW&#ǥTgT_]7F?gaY)U˟wvȩ3rͿ[sj~<or1? FJ_l H>DC+(77Wo|P]9L[`UiM&#~sxᗷïhi>̆jb~2W5 (QΌ-ղ]`E2 bkvHJfKdFE<`c;/nj?_4Y5?195p;@R{4LJۗ+{У`_<=]?LzO<=}dTy<|%$]JlA~}@ ?95\ FNwf0z2Z`S_h٫? Pl)/g<2%aTTgzl,/맪q13wV3- GH~rG*=lΚa4ym1l|x}3ο[n2_j'v0'w=>yFoDUO/bv%q&qߕUe0Rj+3w|&W/6QR qBb"(vb(r\5 We L/nzZ{=k- ע#F>!FUhޭťV񦮦mkw (qHUkC)*JӭS oo~}E?n*ow۴Qc4 t8OZep&KA~dEEQ37$Ț*{o:jYK֊h5˽U_ T֓; .i{q[:1ӥ=8IT WO^ R$^7hd~WNks^U0rdoˣţ9 ~vܗ,оRGXPcUp?. MWAss[/bc đ~O!tJ\cPW!|yZ_{|M>*>;}γQ{xھ쪴~ ^ Y 5|ϳҹ *LYqNNt 3L Fc0YMkƎrL]ɮ}rI4|9O\2"9%?ɉnr zq4赠8ѐAG6 lJ86B%yʋ": є] *h%3̟m2ͨƶ_ ynQ \{il6 {1kOV[֑ZmlXMdS7fsSrL;?&O}q e<5/g :iά(UJflo޻>|gRfDz^Fr2?r{%EƱkٯp:_Jww]O˄EX #XW.s|Ė_xn3YQG MRc=@a~5OAxz!&ߏ'q}ϒ(vjAVn\Ioõ᠋6[>ݦ70o ~BBPЍ!8ǒ& z=NM/Vuy"`j)]Q-gA,gFKl7Q5┍ӭʚ>_KC~paY^YK>'s.VeY+U$@`aF/Ƴ-sNƿRK-L:S}߈*Q5je2d|=*$wPxZ|exjF!\zWeUBݑǺP>TNN\K@EKw)s'h"U\2]g Lu VFj%ZL}X69Ypk7AF.I9l2 |TO8RhO]ɢM"|f_]j Sl>n{ʘ\1nu5~? *E<<ZWД Kir W|MWa^DӃ o 2p[6r_!c7E_3?~F+h Hf#:K/JFXg"7K DiՔ>AF q{̋m$rL =/LWѨVxAx4=3o;E2o|z7c"*{ts^Jx_Br`@ǘxk1|0dOVtآp=P/Z. IJ`0=* kMZɈv0)Qo`$1}'A*"&th%\|R(q8h*ݒ[Ũ;YL"S^KU$X).YW;ʕJ"뎉Yjuk.Dį`"*eTH/zMJzNEk҂F5S OH] Ǟ+=!)@Uk).>0 yZ:U3try~_C*ͻxo;D<+kIבJmax9h QJ6'**UA7!I%o/#<pٮ}gt)VGǬy:lJ_x&|:ш×Cϗ*5Hn`Nrŀ!!{6ϳmSi?s$txol|Ѣ5 \8j@TN\8рT%1X!x|+ɱo`flϟс<@pc= ;i׭DS[_`:-ru VuW4)A<i6vC0$F0WdV8=y=io?%>Quybvy П})uψW;?F 8P z{^QWOx227fX^-o |ǝ[*.]$͹'>,蹨'^`SZ΁Jf/-++Y@⩈VS0FqY~pGw`^cmTϊg=L4ǎWCy(msо4KGiU2ƼőCq葜ϴGӐ?FMD)Nwh5Ȳ@(\ W۩O53GO[~؊r3汨1*Z]WeC{K,W@-xѽ@siDZo 8%WnS_ظ}ӊK<2^R91*QV y}xs'&7/wyk|Yk:CۉcLMIܕ4ko %^q].=X˗? Y^B]j+ų6#QW35痍ynS4/09V&zSSM:Vo0bŶgpE)=$uȨl'M$%"tŀ5iu*&+&oS-'*]R$oYJſFujz!AjbQ]Ie~&¼|,qFʹ9EwE*,y}f9?w/&#0 :ÊuB(4h k'/%Ld:-—LV(J$fCZ8AXVHRACh9yjT긌Z5cgjЪBh+)JC/#dmXx8nф5bB2-ԬkB-CJu%0XRJ`luᏩ: ý??]|tdzƶJ}Lh7xOI9DSo'oC6*?]|;r%ifƒD 6Z )X_N"xRQ(d^Au:7c<j%/e < f;] JKrj["6.C,RДNUJq"%Vzæ܂)I?}o]Nqv_J1ui闻PcWoU_>LJINR ]$?_G=D/-| ~飧 mdvn/G ;̫@IO5z8RqMkЁᡚKb=wN%/;ͯK='誹n J:>i+/Lr+^󁈥?D׌bq$/Bb4Lfbܬ8ʯMnҔ7L!OɩU=%vTQj vO& ZPBbSPj&* .J]@2PF6 ZЬEq5I*ΎYo85EE:J}YGj7VTŎ)"Yqe@;Dg1յ~R>@zmlΏ-}&U0emx# =G9=|f@."=) J ۝iHn~G|H*pԾYɈVErJ/͝"ȩ $/!YkTޛ{KNFmC(MPfɴ=9** s)#LTlYWމ*xNڸLM$-59HAHɎm jfv՞O\؎}(򠜶/r[\̿qfBI44Θ9eP%jJyn)S$XA`Ǜk(È0cb}t%:iAE .KqT qUIYR-8,B ,wd?Sa:T&$uRfAf=f YU'XS.BzwO3^g(B|t{Ww&w2*w~k\tSg28tZEr 9ExiG2W̕TU>Kyg)Ru(fNXo0Ͼ3@ 4zд &Ex;GV _PB^$lNP(p D, _uEd>gxW$?$G_ a_JeXuCke)Y)/();iHp0 m/m 4qX77;3EPzVF:gNsz/n )b*yf&?\LZHd36r*r.Nh©=RWAUM\c&qxNiV6DAzeǹ4JtAZsl*!YY:Qr-Qt|8'rҟi5+KƙK}0 gN}&9Ƽ@{-YUkx4T;+YhA >x`"FO?OU֕+?\ׇ|"O}v-]z \ Kz uCװ$"Rb1[#b !\nfRWI<>e>tҸu3w*P6lNoyqTU[Y)a!3bz [AM17WR@1 f=yM1u酊Wx]5՞G za]l?\y7p@]dPlȋ۰Me9 Zn*L[//)bk(\ Sz_>x|d5b ;o63Ոm 咀/lֶ \)̡ S0^%Sg(g,hFtÇ@``@NAwefЍ}Tj:vqQyYqʠh\9t]O9 .Eӻ^a26 ƊEsaҮ4xBdI<4`E >J̀˜pՊp0)^ruJ@fANf(R.l[fhGbVe+Lya;->cְpzwM)p Lg#KqL)٬Ji,ՌST_nCҷgN Tp.:ܲi(ރ]E8Y3Y5! dCP>fƒaT+EE:DDDV֭`i>*sa<<*cz.@a`%IФKGs@v"Pr9=8&H`8di{Ӯ2=w7e si59lflwz>$o !#s&PDsȰ6v ?~O^Yd臎-cf ^R.zY5y2ɔXxYHp.RW MbpCʠ4RZVVJ;AL+s-=(9J)mLS/+B2L@`j2|/QGJD^KnQN+(2* l3"{N$Z7m,շ"'oM3s 2ɬֽט֜{tчbw$%`Rv!YLfT%kBK.C P׼1.J- 1XN\gۗQ=NvUbb fVQ,hrP؟-+䧊g K-[!8~}gYE@F HdJJM3*U^vITy WԈa8˄c.ؖO2$,(~GTXU% A':V*JFn\cIXkZڻB ỈAcNL9NV'13;$} \a;Mk/>lzXGG#ww+0^T?T!Ftta KpR& 1*u}~CkIGcP Ӑj+aT+Ft\_¯ p~5_qK_n,;ﺫ:wuqiO $$Jثݦ ky',SJ \.dI $Ԩy$`K-;w3⥠6ؼs. E=ݸb׵.";DhG-*|H&lv)2%d4tFkˆ0dUK6Z6 å'ljM6 sP9`t{Y:\Ӝ %TuUf۝#67,* Je 7j[pYӼՠE&5}IwGzO Hl7z1?/ac?]~ێ26jLT>;k WLJd'qKh/qOʉB*fBE-ĊTT)%H "FJ)v_fhOwS91SxOV9TncKԆjUAuY|WM^*E@$I(@!yeݲܡQVc&S[Lh=_kH!bvDB-^pl@vkI('#%CJݺXj-{RD`W2"_i%܂-!FeNPԼMTuTTVCd!%JLDaV(& Cʛu-ju#-R5RmaZ,^LO(44 55ہ鍬2˩4oNt>42.d'Ib'< CP[ɨ{E k1^nZIyqMY"ybPym$gtBQ)e,ᠡ}C'%1%+f޽~Ī}6ʸ9B tz:@U 4Ngy 萚.L!AZYJB[(K> Km巘GĢ ImǣB,V3$@Tj-`QV|KnYVqE>[#!ɭv3#¾%RE76PfH`ѱȦd40Mt'&Bn+dV1V@rCX'lzʕV/,֖-'e8{X0öY@puҜ (WψKzKZesnM 8j4&@Fq*+K KsrދE( *d6 \oY%AIV[hQ؛U D&WӸ0^v('0U=\:SaBNM (DNuJJݧ4s9Ȯ^W4fM`)Ady%ئobc #ܓ+SQR/L  jVJ 5 }{:IN%@_FK:)1D?4뷡FW-RJ'K}4p$.*J:CXs0\M Pw㷬\HI!!LU 9dYɫ[B,% "\I&UFFoވs_E7LpQŪB+Ŏc.$qlK^XjR=ڂ*q#YZ8֭Ujr!Yxd_2̪`ڰS2s 3skE,j\1cjcHD{TokZ%59 lzgE W9ܖƮH4̳zŕ@ץݺ`I4 i:濥Lch2%Ro͵UA->5V-&dNJZJb(+'1F؜֬܃ 9 bKV̚yyfetLQ-hg<X- *uVQzo2b8.pVڽ_jA"qssGh^!<"V<|Ǯ56S)#;h땬o% &\!o@\N2h쮁FBڤ8\َm5Ý_=+ #WeL(^Jzr+daؕj&=ΗQ߁/܍OI[4[ZEy NXk!¡XHBQtg!jSy..ُҼAArx]v>/ W+181Ʀw KSZB1I2a_cԧQD p9;5`AZ;1ۙ48֡746QLJ +Z!dRԭ .6PihZXdFQڋzXf tZB]X3MRBGD9[Q׭9kkw H"'$b?SnK4]hF^NW|{J5b 7,2/iމl[A>N.s`XIX[Yڗ~ND2JZjKP CҏMUD `Ta๾g]|-ܰS npen\h_Y`&TFD4>'"cx3OʃvfQ[I..]Ol,dMG1% tp3r]-]5hjMGk3b9@wT7Ҿ0)S(R@4׮A )!fQPA{լ3$;G2s5xvu-/p6 Oj)Bl(PPqxL&FUQi3.f@ͻf^NR\RÓV%@ĒSa8'QS`9Ǫ#Ϟ1@1W,ɫ&?Ee:!>f) 2vc- 8DmA3L 'jMA19 !+$.9wnQIdRcATY]tj4zq #U4=#8p,U靯5aKa+Zc{]*៫e50by D[̍of e ?,+׸MLgc\F&h8Iyy5S5x6D;۪itDfi=ւP0>&0չy)LSW(r+\y`|&+BCy}u_7,_ 8h*fM`񱕌$)o֗)q_f0)rD8{rk5t.dAb*(nO?nG٣Oz5EJSB}c1,6& ܥ,f*ZY6y Nʃ)7GLOe4%#DťJɍ}s-?Ťdx:W>,!Q:G@.?^߀UUeV!4w,Q)]ߞ)P d{n+\i)`Vq$K3iO Բs5H'-B(Noa%l&sM9Ԫ4sܗlC]o0rB ~}#{Axd{j1iV U) NjvC了 `!SX1}< h#"=1~>`n汭Q;Fz/2Cf%G'} |jF3kB< ZG! p #]Èo%(wMX\H28~Re-05KNyolV"n#><"'wKk!&&$JT-hVtG!%!TQ44`{eUEת s>n( ]ÌUd T~N{r3sإHP&S9H|\ìGS]]BL~.$_irL(Jqcm&j[Fy+ܳ8bdapy.l-K Krd;ȷ&2LĹ!-ᰓY4XIfZo!dX_t< w-{fd?s'׍w?ɑ&d2XJ juqQhL^Zb)߿b Q5| ( lbtg*XX̴?PRfJb*UxRX<'h3F8 %?Owsá=v"lyDXqm%Xx=q0\l⡐ YWՓ 7B.?I "KFL*1 94%V .܉X,05[`S6mVwa:2+Et"Khc(tj`֣355YRK9 jNv:(y맿+uZ'@j3aR-X ؈`H*%r]䗚FN e--ؿ%ssmt4q(E&Lc Ii݌U*{|J+s(Cp%+fۓ.L2lHPx&:&˅ H t/d|a-z] Mss}`Fb*c El1$2vi΍Uz3ķ6n'.]*aO-CNhZpN{;չbۓ-K֮]m:ٮnE`+w$dJ=k-WL.Z872-\ߚ^fJvs͡zvJ%F s CU׵vXG`yqϺDv@M0#Na*tToSnTJѲ-UHѭz0…rN]Fg:QZjJm Ͳ&˚n&zfi%+SejtM˜7ƅx[ nfS v*NWFC猌I1XLs.rr۞/j3x+ǚL&pl[DEgAӦfFiVfg N%V^gKEȇS;Xۇ[@%p*Jʲ6tf[ _͹j`T߉dtK||{ jab3P:;џmM9QbP!jgHn$J̮+TYx=<"""N'܎ %2?,Qn˃57-^+TbVM寷%,azsX^ፅEm[ceX$D\Ect%!YKD.&ZQXOtCj5@?@UrI6 mÊaf#(¸Mi%caΝf"dZ눴= X!Vj1 I}H6H4T^BmaZHQ ?*O%ޕ$?Hlm:91ܙKɹ4ŋnԆOw@9ݖy2Įmh'dv]4ll5EoXۑ⿡I٪uu1+`<ʱ&ؘƼ.+9>]ރn;kL=4bd8z'!}M X}EFmbc`5yiv%Xc6S.RHһCqgkX43!)yh0^mSj \ Iͫïju檋u@yN/]! MnHan^eDy..章^N Tsf./R%h8bПKQgv"%<:Pr =MW"QleLTQIYMM UU Š'0-`GTI5[Ine]jj]r'g"Rj>Yp<~Z߯pS]%u0Z`R>ޝմ[9vlK׉$3"e!e6'$M`etp^uwe[_+R1*G ;GY/SzUDbi8`#^+KgAC ř^[88{=ٓC^aɠڨ8t1(1BՈ囈RWj1nזfLї\eL))"{('=v,]akgly)!yFq/ǎô}y"V,a7~KOL<9f:a?.9!:]r^~}aD]/sB/Ex g e= N#_W67F x=Z5 dr@\<>U|e$E޶LixnDZz)䈨q3KߵbࣁFui7zOԇ v[{=mDmv.'vnbv6,6L0Lv~dwiؠ7m []'9n9Y])^^9=1m\q%-DK& l(\۷!؄VCNߵUvYd&cζ(#Z[Z'Z# -6W9hK ])U}n`)]8e(X$eCfFmU66Fg+6UF%͑;W<-AM]bZ;Oϟ.xS`eÁ+g艑^rAN{.e+ef(Ʒ_l)⾔h)={I9x{ juoյ'cv*"[~fpٳo7*3Doj SL| Ɗ53 6yv[dOzٌ}s- ĭ*ɧE#F w:JVl^6WષR 7kbneY]s1x=׀⭮9Tn:;87>gY O N'[aWK%~n@BP[̓'GyzmPJE;m7.7? WNf}3'Jj su H425a׮ܤYUu^5oŅZzBg屹7˲>⿑TDW2-0}t7\߷6 N"9<}GKo}f\MFUWƅ=GL%-rYpot`]4<)8M\b[nn62O&UDn唗S>]_zr+;Ewxwʋ+įKȬqsn!/w}_ܩ߿G^A8vA7tNݨsg;'~~EFW@ddFeNs\vZ)= _c!,*軳 ~pFuYD Ӓ~ c8֚''Cbdjsz'Da\ <&cdP%ir8^f-U͝H!Ͷd *!7s!p5= hwym@$@0mЕiJya\?;C׈D=yz\{=ץj 6qZdASjdfI F۵runKGnNW]ߕz\(7xKz(F Ml%lnٳ: qFYkZzg"/1/^h;q6]zctd|x}mI0ГDh -15h3ЦWIT7ON7:wI=-]-Wx[rOtxre}g>'臔8 O:-GffuC<@Խojpl.7u#m  @$/KQ $@ j&t% ~u64Rsc!ӯm_IںZsҔHK\άf¯)2s2 ˄\x X9zQAًʣpqK D WEiTm{y {n[>r|yåj aaѕ9C ˇSf/T4alI+5ꝮJgTcg J޻>CV]{?]gdddW&&&D|sh)\:nZs`mzn6s/7cEc SuneX/n]Ntq1Z^@٢j¬tW2q0D ^* \OǻLS{y1T.NjcˈpӼS22ЁOt2^V(Sy֣+^h@s17+yNgSkB7Oo>-sa/8g7ߏĥ_HgpWx ,*!uC'xNPOyEO[% =mЉqxqyF헚>'+M `ϊ#=(}/u d%h FQn$;.#ss^LٮWRGGܙ|.0wcB̭2@7 8fe̫d%h_N#\zF-Z\ =zx}(zu[]{/+Ҝ30Y7}z*mvp,~CaNFbkא:EJ /tAwFL̝4v/:86&;n-VIc!jqmHF\g>̞1\ZFjܤC)[][T:2ہG1;{lĭc^m kҨLX3]1:X#WW~~WovOa3o7$dܼT_@:j8OOMμB;&U[_k1#ŧWxN*GnnB|^w/2ڒqLGT4swi5LjԒݹKвm we#M4ʛnx%~JeN >9]|b--6;*U켅U (\lGqy l+rbtmz&i_t돹czڱW?υndn$BW}#/ۣ-L :츋y[8۪,pf*.%IbB ױ8g ,Dqa^,{_o˗F/9LZwHw7݊[` ܿEUjƻ+j ׮G_ 6 Zt.V@ \7b4+Ckw<5\n7H2xmShYT|\`$Cz'*k)=o י tݗ ͵q N=[K?֓<.W+cEk^Gg5ByS,\pJ _Fx;W#$?a s営S[xoof(w!2/\;NɕǷ3ws+󴚱 ؗOh)Sװ@,Ϻ&2!>r +Hֶ{~N'V=vh1euw'o,'i4uM1Lb"Um6()i]z7A=,,˖Mx9t)Çt㜟;^ ЦOLy}IQlfD+~Y3S[Ѩ]! 17F_{蓩'TO'J?i]~2}ړK+/= h&uFy\Ur}f%h_hvߛ9N[_CE9]cΉq\e=~̎&dN#A2A*G c1ޟ;w?zbf.-m:C++q"%xk4v|?uP2QVLO}E Dj8 ӁzB Tac-q|I44q;y9o{_ֽ ZDQ,Gݷ[\pN t\orGqv\ujCn^׸%B9N}gYSV#`ۄ8ww/zsv~֐ʵfJ_=܋Χh-*bVW8oqž^CӫmsVڑ3ܵ9/oGrxfU?up)!᥯KG4bbMt5eq$9Z,*om܁WY#tA<oA}&GwP1vx,E )o#\zGoSLW6 S]_ܠ(qcѽa ϑ"'p',mb\Vsߴ/(<0B{ʥ"n8Zn4].V˽iݒ x (I qQz}T;hI2֖dIlī==.#c>r4+L+1owٙ=\ogIvw/;ųVο"ze8S^v=7˥_cR쪬4[.7xKܮDkhiq+Ϗ;f7&;˽o_("r.eEů`dl36De=e\lVs|L6R G2;E7'k9Ҭ\8rX=irz~{RnCQFOPaCs(pt*rA/w,ŋ\?Clv,3<꽲ރ}=!??pؗVءe Γo[~!>NGvMۣqqg[ '7-J irp<@umOuBepr+{f/O]V+p ?EG1QOE::7Բ/l;yUi?>ljcʯϺx_ &[-Q(aJ6tz.Wןܒ7 ݧ`KWsϫ\ +z}s'کqٚQ/x| _F XϛVoT:hv0|zsS|>%i3pt`cn?<} 7Z6ngB cr#eslUГi}n/x|C*kVɀo~'_om͏%7+w \&o(Qވ]hvfQz~Iڗxs@'XُuzŲ\;AMU(bxw'xla&XJ9^fyj|[1W&ǻR[3ɞL͔|mߨ湟CKeosz0avȩGP_;ʡ۷Ǵ^U쥭 3ݻ4&}~:s?Gos7}} E=g_KsOJVחW<(ޢo ۮX /lbQ_%D}/P~lӖG k [_k{}m3/!ɯ-d^y/[,l;n|7*®=n?~wt9Vo[t^u=NSL*m5K>g?-/9m)SUe 񖛧o~W3ͮb|‹~f~7qcyN7>ǃQE9?52~n%8DZ*a/u_3N8W վGY'Ok/b@f)˖|WZy&=nh$"x}%}݅06M%nܴpwK~<i2{h^6 VOzz mGJ8[yzGB|\S^3+;./rZZ1HjfszG0xQ W̢@ٔ>t,,1񝾬y%{T Tбifqy#udη;d/'U~F&{c((>Kge*KNMX>AgkxCj ?S69O䞋M;n6ޑ_kN}=w)_T w|X\)F[`/ɓ_i}P?T6lgƨG* wN#LX'I֗#{ןxwww|_e=^=j5;Ot+ogw~ת'WKGFO-T>oddhj_~.o3nesMᝇ/i]'r=1{O|剷'ukcҰK.tcu8;)ag*?zZmM瘨> OOy6OEmU 68XCQj&Y7ۃwݧS#_2nYYw#!~^_?XW4pzۨ|w2'\__(4m{=YS+rMΞ_&$'  ԾӍ($G'7{ޟ͆V9}Bg=Rέ9_wq}>N/cO30_adm MJ_|ɤŶd!xs$DK3k}>w~Zko=n'}/vHg;|U7_?r/s'=qxe?3W_0pW4osK|ߕ eOs\k%?EF2tDwp?cwA"23<텫]]5n~Hk~{Ga6N?7ϣC$3۾>/73m™99Ýɽ|ݾo[tuJ{1Gy~3b3v}?*\xOwޞS*Sism]_j?=>4{.kۄ>#N_翅h |·Gjo[~/}_~/|l?W][yb/o/_/K/[7ᕔ۳g{T/O3~ S7VGiDGDyCoғg_CX݅zyb6; 65'|߀$ $tCݫ߾3c:V|_ߓ&>;{ԗOη[~OԗIVUW?㵏|?W\'W/?E@~$T*"T;~O\ \ZT?}>[q7gPw>;oRP~/huk78>=|3w?2 <_?yۙzs7v_>g{x>}H Oyw~]G?PLߥ"#~ ؛+?Wq8I&yٟ-`x ݌o@/"&5#Sx&bWeEO_m@rYyNo|Ni'^_@|(/Wx?^ z 6%=7x?!8YGiy ٟrq:u̯p%Tӝgǽ6s9/|:?p_W+o4=$gm_7]?cq}.#K}g6>imO(?U7}\~oʷk7#c^|LM?J?ݟ }C-~g~gn>&lǹZ߯ _?r>R$ e7ahFo$'7xcF{`z:P9{յ#o!{?o ik;=.{kܟ7a>oح>'y?|?㈣?~K{y'~ F륁ϊI'k't~^y!?nh?|_wwWM/k|?آ}Z>^Bc<*>?f~#?7#|}.VC8~[_|~w 7/}T wN{oa|JT6khza(G}gE;;t?[?gr z_3|/}ǃBn "ٛB-$o>?/x#.(I3z/_f4?տ+}ug_c~O'^GNͭϿ?|=OFߑ_/[> iG|Q?3}_1f/{_UCo$ 0Mam+{Tlk4>w8|Oy ,[0? (89 کsh/I!vӉg1ծǕߡ}oJ>e>xBmQq׿B̯?yIAU،_Q>ܔna}|^5 ݆ 'r B1*uߪWWҥ?] /E>OH_`} z0{A~a=SV)/?\_z_C٣?ouʥa?X#AeQg?m6*{x '=L$b _wI<@PϘ{x=?ښa7OwL9~ۢ6n'v_?oo]O+K$ TWSvo_ߋ_ԯkϯ_μ9}T=>!i4;c?szڽ]Ï>b;:@$H>B4覠@5.<_hwWUZo|}>[4$HHXXWO+T &wΙVu?疽"@$H .o!./\=e_ݝ}ϧ&ϡC"D$@x&1@~7KsTEX?ր HϽ^W`Y/t|Yu8?/@Kߛ/Wa?;DT__O?mokTT9yԥD?*wAQ \!?X>ɢ?U@AAyK𢂈?ƈ[AUE^TBՔEQE!P >@$EADD?Z PoրW6C;e bj~PGLxi B I_-roJI[O+a ~8eK]dAUYJ]abM&vU 1Ð!d2a!DuebbRiCĊ vva9`쀂"=+A$RvQbq's"!!@@DI" "RA Gd3'qQ ȳiiK4$ `@EH+$i;3CCNN"U %2RI HBQ'vvp3AfH dH(dJV_~YΗ_|3IJRRI%0;ߖV;¥JVF.9Z7clm %ВZIal/ _[kWş.'K;]owH"$""*@R*`"* "2 #$ **) T; H( 2  ȃ"H 2"Ȓ**^tx\OQSH (H)$EEAidD$IADm)YY P$E@֠kR!tɏ.x"( T$RFAI Y  JD$L│!")"#  "HH! 2 H($HȲrP wmUUOx8QTБU 5 $HY)DE$TYdEQU!dP$ddDRDEIY) $YaXF/WD(IDRE $! )H+HHHȒ " "$H 7 Ln* !t@d$QY$IdR@RDdI$Q$PYBIDVDPdPZ@FPP\}**Z ȡ "Ȅ2*"( ) *" $XPr<|_30?;nHHH $22 H"H H #(oZ>=z#|V@URIdBDEEPUAEF@QdQT 6 * " ""$)  B@U]mP"7$EdADQ)D$EE ZAĊ" "," (dml ,HVj`>lf4CM/ Ȋ""MJURLf>ozhjb( 6 P+|W7?_?'~_H+" ,*rRS{Z 9^?@ +) Ҟs^>)_(CXc{V8"B''#0C1q0A1TSO^*+iAD~gb"+ж!}w}7ߓ}tCAA4xsl*Zk"Yu pD r\&עzz_zg0S133s2vsODUP gٯ[{=g򂈏*ʼ/}֔ JҷJhVVYJRKP.)JR~WHI$$$#"2 F) $$bHI !#$HH>2(H"?HHHH1Z@"I"Dtq$$d$d$BiJPR(BJD(D@D($DDB dBjhBD$"F@@f@ jfFD /_J]9o:8u]6RJR@S!45!D"C3mX!!H BI! BHIH0I$ !$!"$F## $!HH,!! 22 # 2 #! 2 HH2 $I2eqZdD250E"4S0TA$$0A1Q""vETܫz:y 6%6Jl.)"*cRQ5"%3B+ֵJVҷR뫰|62B$$$Q!$I! H2#$ $cHHN)Ȉ&$E3BA1S#%CD$30"""$"2$"3>fFd$@D(@$$= LH   ( (   (B[]>-߇{%t5 22$1#4R4%}K˫qYu画}+YBS@@C3BdAʠf FfBDD $FDf`` "DB=Hi}i}kZVt.I..)7|W} |ntۺRr"")! !nݻv" N肀bDbc {RĤ[*HHHK$kJHJ%&o5e,cP@D***)! )J_RR&n\B YX@˱c$3US$CAFBRKJЭխ/Ѕ+Z͛CbpYݳekJ 씤iR]|DT@UTETU"w֒.I/}HV$ntob_J5}/#HR5Yj(mQ3M5j/H Ǔ@MH Uk{uR q+ J5]R Z! ]YZVԄ(I!}kRHIt+yKJ]RVBVK ]z^p o8y.xR5+z))) ""etoY|/ R+$n7uDH&=P@DD  PTVq)B/FV+Zݨ"jL۷i&6֕Ddh(hJdD"]DHLA@DP LLԀH I @G !vB%R4!"+JR $!I%򑑺HV%)K." *ott4g{R}TL\݀Y@EHE*.H̎)_̨*%c#######U,"0I"Ȳ,"Ȳ,TZ"Ȳ,ȬȬȬȬȬȬߪ+X.H"*ȫ"*H"uxf/>On>qPqݥӡ]쌑Lq2OSz^")(!]F[棡Tq̿mm6ij8ޯm~Nay/8!8.7˙`9f=[]k1mgqU4uxΗ{@bp5Οıu;n緮y_&8pÇ8pÇkv]w|)w;Խ@AMǵ;cl }ٯO~j@"D6>V{[WL_v, T1}s !QC%]}/DrW$-,WO HCP]|8 M&@.@<<PQo<,dÈ'8@`a^Odܠ \7Yl- }]#zH6Xv$H"D$H"D߿~@$H  #4;~߽l6dk*lNo bg}N &seEed@rrrrrjA.p``n& <Ul  dyx+z߉D0@;l#el6!a 0` 0`tӧN"D4D3FqTADsUsD0;000;>H9ە\5喼DC1t-c{.ȁa,,;XgCh#iмK#7 |bBa;-ײ Y[ cfFZlېFRnvd(\###-YT61իLy#=c=8pÇ8pÇ 0` 0`˗.\(Nyg~@e~4C0,*:bXP1CWb!_G 0 y8=Ct6 ;6a1G  P)eoۏ=E4 N>~Ε!fݸ2e,ؿqigK{}~_~_n[t Ht(wPr [NP0G u;~-{yxS,\2-;"nFNΏGtDtG3<1YxF .a3 uG0۳fn; 6(%^؄@^zׯ^z׭ZjիVZjռ;o;jxWx^^O'dAc.ŸD ,@l%_z x@p h MUTMMFDl$l_d\̮f|^?efvgnߦ)fZ`^g8bcXssssssssssssssssun[EC:}/S"g瀣^cxx \rli)`ʭyoxxF>>>>>=MG|Ԡo_?qq l  0ZYZsFe]<^ cHq=!&eKx\iˠۥukq#! wk>_")*pa 8Ļpqgpaٮ`0&@ّ8F誌Gu"נzd0Lޘr!T`6%@Y3jd2X$nQW"PՀ+ɼ[Odwxa (NczOE6FP\"`t9s@%#X'sD0 S$HIUץI3Q,oLb(8$hSPcĨ( ~PTm`DLr#%ݘD'&J3|˴,DɩE!(2E#mK*H 0pI0DmN90ųW?'i*lÆ+B:mVF:i)TWYr&xA r1y;&WL)Jb SoV[x[R%Vِ_v1b컣9ŹAZ1!`#ނQeQepg g8m:L(- 1u!JiBG4<,Z[ plg(g\ԥEGH f8Řm(^!VQ=̄"Hm XնF 0ߌ. ѳJK]4d9b2˪e*!~ѣ!LB.1pRD=pW4* cCq͌\Ș*Pȳ aI)" CI@~h-@AF\y̶j6  r Zhii:dkx-(J--[B:s|M$=ol/V>-\td==0peNdY3CRoGS7QG&Z퇵a.Ap'A:L)[dYdtL+E!d}1r;R:#9+ UXA ' RA8^fw((/C0h9&9`{hE[kZmJҩ1\dÄ*!%aldJ%XR& Jc.I4ݗ0$+EE^@OaªuTFz%&X{_J,mzCϥ2KឡB1DbR)GDeGpxͶþJ:$P|Ks` $RJ8A.- -lIXDVwm+Vn`@i0TDA"Ҳ }*+MGhu"&!n3eָSA{o_hy:`pD<9 kRss{\WCYu+"n= F.* oau:\C87((&RҐ1P!1b”4U$ 8dј:n̼B`4/7YYէ *LپSg<v‚EjSE:֧m,vY\%x)Q$&v<0wf wvuO[na4|9YF(8=H,N׌ e9:/ p9Odl Q ,͑`#ZvgNf@ ސ3CY\/$+Fq,=H& us}5JU^T:X;E2 tت˚x~E~ʬ'Y4j؝Cml]/8i瓔׻k3bƯI%d=^SN{|e. ?Q0WJLkbokP;}%c<[Cϱ۳sά;q`Cv(YcXF5"Ec.k lCilI{AI0{O4.ja I9Hu,_NrٙlGgXZ*)H%bc5a S|J$9ŨSjf2O9hEY_3c8ϽDowCd,-C+g^zL*1@Dz壸z93/von?dѪk|'TہPӆ -VZa ^3#`UnR"mGd#!\KnrV+Vk|[~ÿeڕF+z狠}UȾco |{I^>X yBJ5sK/> Sý`1k zuja~x;.10RXQ$fDaRG0thbdGYfA' 1&-=^w @[9jp8i2} K&|:8օ9Ȧܭdyd(!f͠&Z/Ր:K-LK{<V'Iqy Jc+{{ _(#YCSk8\rR8!Ka˞ 6 :9?}W+>ߑߴ߬fà/G[E*; QQ7sf LSv؝y7z۷xMvӆbv|n@pGGFpOlZid(/;Yilۉ o"nۍ]W뽕㓳n!+sN0`u=xT]-|:'_83{a= (#\K%#sr9I,۲gh4Zo5@ä5guk尽W\'1qfHq9)B>ϥ>h=]{Z-f5܉K)Ԃ~[Ym;߂Pw罸5#~ xgeA=dm#U/|qnV16[8?U?cÉXQ+:8bj*$uԐm{~MI;ً|I0G#߁49;1\^b%ꦼL|`#Uȗy<`rx*(C'ꪨ1iS]1;cݓG`YkYc^ewV T)=q{OV{R4sY㒐݂F(H,blwBkdԳPYPz_G{ B]ATsfLHZcA38%dK:Vko__j ]ǯX}Ʉ=Flicxa)b 2rb1AL 0\a繱C$=CVG10"LJ,?x+ZRk&gY1tl^Nd֯d +a#oh@$l jM0R3P5 004zW.틘`:j=1Ō©ϜdQD:_=K iǶGhh"{A5eq54Dv-y@{^LɵP*A#@kLɼ8QLhHTui[ܥ"sq߆HmVظwdmSJLr} ,]t86 gϜOKㅞsmo=tqWH15s~r_s Ů?c7xviJWsr|3eҐ~>-,}RkqAOIZi}Ծ;NS6GpOsv[XUxc_) \O0 @x: ]y@j{9+=n 'sN5p0"Աl\S 7;x#[{LzЌxX%Hp< :ݵ>0o&=kgƍGRջ+s%϶9oNA}ѭȍ[_ho?oI, bOk?_B\NNtOq0b0|!{.aEn)rw.msPٍ"D92Ld^W!r[U{j8DS-EYƠ^Sfr@&!X'0՘QYk(i|Qox'x)Vcfk~B ^zrVt[llO ҇ۿ @m޺VvacxLstZӾIrv !ɪY.9{G(ܗ^Σכ}s=u_R%~] n@^ǝ;hR"6Ä``ѨuKg,,-W vXH%% (`>v6x,b9FMz 0PxQ𘇞e{8z8JF(z؃mokm ~P$ pm:wJu-}}uKlOfraȍ`K㜟}hCu~wG!pRb9:3icl{rCu݀ɝcgU6m{@- Dzq=Hq~*)KLoVxVx(fq%X>u{$pxmcС6s}N{bOO erՐ:^_ (n-Fbkb^>E3eޝsu2rjmʎy&+R\,Ct晞 o$ZeE ̤%,3 "1+VG!5EBRJFf:V@>EVZ"HY 0)=#n5sxI~؅R˰PnlhQpfEh${ؿ~xoM[`"0/ Oq-~W.dH3 qښ6mkoo{97nZu,1x^M.^$[w}F1w#&}+evLUoɮ0}4G'Dz} X#?HeZiZh&=Gnޗ57?ý-7#6sUvoﯻQOkgk}gh}k͹_N7Vvw\0yx9Țh\+q0BHbb&԰!᳕lQ gfPfbBX4hTa\IƬƇ'SMu YrAchZV!i*H9 Ns_=l"P9֯{LqcwlBTĪqmXbVc\xÌ̅׸oJe[䕵 ӔwT`sJj6[1( ~PXboV}dLABy< yv /%eqqcRtbuʤtC@xS"Us ),d=2({P0%k#ei-ZAxxZtV©CڣOW>3 g#wӟKwzr[DZ*1VNBȷ|؝NjɓC#{(q?cU iOQ J|n<父J3ZWW#5}gX| Qke0߃; A dET:3tfy.mlրj]`ؗsΝ]l8TQd M[u$8.n^:Pa9Q, P?c,8yT(bhL4ِL ITNq:޳QzzΈ}`?~ e8%NTߙ 6UR'f.f7 mFlQ^WqM}6v=(bqv^#01 u)š\sC e,}gh =Nذbڲk]/#zx/XyJp/x`iMDF ̣!\k4S]t`ia !c8f~g]s'cO=s{| `6 ؁:'d=v*=[ {~y+s{8xUj bvҀ*S)]4{; [~AxFؖ:|YX?#Nyp*,kJ{vžaLa50eB`+Hr /'2؎aX4©{?/ Ƭΐ?>׃B-+#o Vp[- v$8 4f\ϥGEeUT0sw2d ucӯ7 Cnf!SD x֥<<ښ5 Rd<|_1}`_~^:vU*`]b<2s njA੶ĠٸCf6.zniqH 'ܟP[8D/qU"g;5%*%ґnY]э4"@j!u"3}dRM*Cht&ۙ+( YBUR{%P$Fir6i(]rJڽhjFhW }\ZBHqǰ!Z%tdK<|-'ؐjFg&WO9  $qod嘀I8UDWgK$F:щppg0dc^p׾`Qnoo>y SP5$0`';ۉw'h@| jtnAy6 8`S$pnB>3nO40\P44Z bm1llj\~[6\FFAR=-2e 5'˧!ihZZ|ߠdoxCj8p|% rR$`#*djkVfhH 9I`38x3WNwhGxwzodF,-5m^s%d/Ru@p3|G'b[Axbw+:9  LXԆdS=ndHGpW6:0軚;A2Ne11Nt̗8!lTQ<Vx 㝇XjWPHifqlg[˱ONOsQT:Wֱ$9-2 $ (.X]1N<*%*1&"oWyʫ` TV_=;]dk=BX.ZsTsb̈npŮ]D nEXW%'l2oC7<;dCS˗.:layk3胆= *6:_<J |Ź7B,l,j' 1 6u&jyF ʸIZ \NI|Q.eXx0pvj:O26V`I#03 D_1[$FoJس}2E:XKZF1ڒp ۼDONMר'G@aӋMl4AWVNF<s3vHneXC82y-Ƌhy¸2Ln3&cJQz}q'5ȧ\'ى/@gV]24h> q`.ZX4gC' 6y u 6ޚ $ c !bVꯥNtoԔyd xmu3Z2a7Yڭ)o)]RN7)׳F/TmcLg$۞+vc zDO8PNrtȚ~8e{7ݨ~εXv5+=9 puL)8E۔{{?\"J ʕM`rAv g >AaT +\qT+U;c .UdCZYp!wPHA Bi:s&NЙ ՇٺcfW D8Yi:[M~Vs96\Z@$Gw3l)'(ɧ8M's2?.;>q,g% pȲcf&m{22jKp8 B;YJ٦٫-hbQ}Jyv]=ZiƓїcNv x8WOx3u]ǍJKPHi>3 ޖ䁱P r]ʨmqyƱϳ܄4 ǡ0u ĺ VHE,d&n J""FC=ds V%dqS}m&~> V&2ӯd8ӗ,Tc #K1tF=( `˕7.~B,5D&֐g롥ANI-צ]8b@xKX 2 N.cCSWl?w2 #U~"<Q?vo:nqIRĀSzzrb![3S\OmV Yxx1C2=39T 5M\9& ND$5ET^ksH$v C`?=OBdtaENHbܽc3)4\JH>-EyՓK$"R k5 %Zz[&|a'S{YBB,G#G311Lbb_Vk Յ5Й] eOA:F,L e܋\1xr~>$;~Xep-ء/J4bRLt?FD% !,0$I ѹ-jYז΋pU\!, 8,3 Y4Jx}"ܳD $ x;O70ՍiKkKQb/{h}(ub؄a,5 Arc`Y]1 WdF#'L:C4"x TF /Xy "O.v~Wˌepҳq6؁'2&J%uW⣛R`S7S,.o{@eN >D}%4rq\D+6UzcI[Zeph݉z{@ ZŧI0lI-4͆JF5pPID?تa 2 :7T'i'FCo*>2/ۖ%UXr/uո 2@V&h66YboD]KG*:Ŏm $xr$V -7R xbjZbVɋ# ms=hvV'.:fU(psv̏ZbȿKQN 8Ik{n4N˴8sro ,oŌ@@kq,9Uc3c5e@p4\NY/CT&w˟[~32vгy~t49iH Dl8еNpW)$$B u@ܰ(N767$c,k"k6-fDL#KY΋lIJ96-vnJl(qdf1 1V[(%k*7c\gM;:902CF,ǔ9@JAi-C@L:+K=cx9VB.3|1cp'9!a ^/هY$'E%*If-Ynzı:.J lh@ k7Rv XTf{YM[0h``8 V mHd,F,EGdN?ZT 4+6&fY57عC4)W13R]DWN ; /AK*J=Q|i}bj)!x9T+ǿoA ~Cl{R)/xaLS !\ ua&y]ÓQw6m:-qϦX=K]i8 z@>-2G)e./nX*XowU;0 Rm4MR L)osZ);Hn.xmxFC6(ېl}Y峅D^ Io!YJؗ&;Z#Mo.Gn@ijOʠca2Qd\K`LTF݌y8bN{#R/C%xZ*l]ٌxBaAc{$D+nDbj&`HaK, )KJЄ'1PJJ2.ah΍ڳc22,M\N4~H3Q\ E"NA.X!V%Y(1 POXf}jLph"6Ĺ)ш q 52^ŝˇ)-@0;0ņŇޤcpZĶhQ'r(h "?4FEU4P:T5= ՠtXq];8ց`0Cّ";`aq%(pۨ(a`Q#TY 谩=I>k$UofXָ1rbXBëCSWdrR @~u F>m†I`N Iq45`-#D< Hƽu1 DzdI93*$hNJđ;wL୵)$!')o,\XJ6LaEOĨ2lJ\-ųpҫ= !oz8(oIS/7ɫ.SmCݯgcDD-, g]`#5[?.TXNG-v;t#q@ʙ 0[-]YJmKG,TV7Z$TO\rM=4cY+J(,$Ga:qX4,۟w&(Ici)9+,@ y M7bB"2m,dHoj -*fpN%9-bD:(%j]uE]K iԬs.l1"t )n'SABRClGCMSL1:Ͼq]%m$xprcjj#Y&wCVhaW|"V؈ WJ^ǧR$!r_+ۙ"qZRcq|[ziN Qyu !S}$;7'1]|8 bgMWhW)^S`v!f?\ц 5F񎫨ib b<_^r{%Ā)pmdj.}ۙ<>]V²7o~K uݗX :[,~N33q)o./O߈lR] xpfdB/Ń#d+g3,۝LCX\d C!E3y$9JXeDGrI%2˚S&Lu͘H~7MKwX}m `Cނ!ِkЛ3NHlD>˃,ZDePce7Dj!Dș9&LB X.*>~"k ڦM@`˜FV4H>Ï-Nys|5L3$nUF݅.](i^CPQC?6(4k%b2M P#Jw&-^jhLcAvBB'q(MRQ2̸3fE1 uKOS.2kn@y^Éals/lp:i$uakDIg@O*AY'` ŮOaγy&=X _1`w kcoTz?[) $Ii`!HK0f|Z,z9OpotK#1q}"CZ bKHRVaHG`#U QT~j$5f:7(p$ ^}[HPOblȃEٶ M%Z r?6?fSO?/?]|3/n/ޒ\Eo(}4`n;`$JW \ASPS40= Sc{v4㈠vM\2c;Qz-k){_F(oɇ= -oss(Q.m_ɛ)mB$9,c>LJ`2ь+Lc}|d] N8Z Y̆H| = X=P`b-74#{bZtư)ll'krk܇YǺeM@#F/_xdOp8p#pB3H8$PxROZKFwxFNȼO\=?u?Rnp3mPoȔSӲ_\6 bQ3s>T}p\ʢyޘ =CiDva#Ո%Y t#Gc0 p@HR33Bs5S|LCV&%{",`s1yC` !p)9\F^©%- \>ܤVjԓ1=?w-xz]3hw9aWºl<=ݡuާHAɺ#§\Hnx6"x_]$~fC 5ջ콽. i%Y ؂@2͔X*D_-.I++eÈYF ՞w?EPAA>0U'}Z{Da hqz ȑɑܨiP,t e*QI"]x.ŏC(l'ttbEo,&@Cmi۩2܆ `Q$IZX t2g;~HLIKܗAmȬ. sڈo2Uqn0K^˺َ ![Z~nP$ bfw΍¸".;I7 p5Ԧ^ F&\ kAw t?`}pCj2|rڒ-LáHQbxV4_)ϣj} ~$n]X.\i :Qh>f&uU$?9*xވ7D}T9%"LBP5JW; "{cJo.(Q gJZ | AQpZcj羇)fS2+ fGo*㛮6 l Peş 'MtuFzif=u Rm(2э §!;8pA)7fvt)BAw*~R" Y65%hQf{;  Bj^+S&:35j" ,l& oQPKd!pR1d;7=Ji. `=[@`k夤ŀ;6eLv̝ 6\+]DAuxe'?@ n#g+D&'ZSލbO8>9,*qh'luPle=UZ7f\"v_;/qLj-?DGݦ Is3Q1*UYe44x&A] ?P:F0 +P `/B!>qlyXR͓gu_S[4 .'퇭l Ug6 wZ,l x al <fH־x>җO21s3iT̂ n!d:TO( A(+ BXNP[2y-tvtW$xUkV+ l$%{*(z83Q+e'OHjU\r;VKyDTL9GZlm PPJ~ s$`PeCm.@9zwTMBkh(~BWX b03fT @e6s=G0.S԰`]O6鉢J5BD dY5>CARDNf` q ޗ*u+!ׅt;+"I1tsw #XCsZ$uۼ'"pCGDK (]H1زu(kJ=bhA.Z 3QZn7CZh1iH 1&7g~Q_4q0.+][Pk3lVyʻD$&29 a ʼn8ùXJpQ+ `V; Xu=fdt"01Kf­M%)~ta)kՂ|ѮMj0K1sԑSHL $zۢBi ,^(Q qقAм0fe'1׎9 A8EfZ%clQjDɭƱ<)ӀJB 'U֪8bגil覉7V3I 5fy9. voPrB-#HykNAM EEr}nnNQku F0E1ћ^'./>0bμRQ|T`dQV^܁_4qIuU `@S^SUPqؖb;eʬ3rKPTQ03-Åi+$@E6b΀ oJzZ; |U4bħ4 +u3vjȃA Λcy4СhtM[v&&m\ KI\;8WNU^TpVRLq=h0cozNAoK$4*uKX[v Gű{~{1{hxx{'$A:tWɋ'YZ<N:f@p!J۠D2Qv B."sG%6VF#&-Iŏr`w ~M !b7q07-.|tPCR 4qͬ@ٌ43Y%| b̺]uFPi~ Q<ЈwT8O{\t!$/8m.JϚ. 9SVĆR ҲzeHʡLDF!5"yғL^e1!xMIh`5϶®vw*\AiѴE.LHcAH} lwٔZ%4Y'kp!,Lm emp pMd #$ ݼIʡy4ΎLgl#=&3x@r8 _&Z*pF6 YV[ʁ b Al$Q+qc>`5Ë́$76H;AEs) 3ǂGcM[z!AΉH!Am2X&:r!N5N D#w(IaZbydE*߬GNzюhIK:$Q`zjD _O&0V-旵&KDrMqTORqB !((KR3; GA*ߩF@.o Ri"Y3sii8Fkg{5 'x3QߘIy6$?d!"zICJ煐xOYNP2RGEHPj'δI2əɆ ՠd?ZrGb;i)nbu*SxIL Vm] ܥA /o:eaߨ~ճ1m._BgD5p!3qiw`*pTJ :⁴Dz5 f@416hQM\owl0NS lHP;R+tNĭ{dWOh]l!;E+2>!߃B +frT$ Qؼψnï(/ֳ{KhS"?n HX(̹@vO .tqQ*\9ǒg&v\8fa!wykzՆ! ̧@WHUJ)=Xﮪx dr]vu9\銉qzq/H=~PyU_mJE'zc 6{O}%#a S飒ЀT䮞 < ByRStiR!gz4&ڕ8Zf!F Va1^RBG\;"042!A2yj 'LIhd&-18Q‘0iҐ|o3݌qn{duR)'-bVm/T\̺٭B"+,%ߴU~)6ݺazwITfⳊuiy.9[e݃najo݄|Y dp L_@\k5U!3e5)Z>EIMR'sgg1&vX>?'?`w. |g[`tIuFxuo8\>06iف!-ub" J D_{*OH̜tX[J@3g) hjO`f=dC"b1HCI+ Ԇ .FGa'|Խ|Ж]Veq 4!1SHbDc@]6ZO(W$,sa,\K *@WœjdB-eQ|nx 86$OKӉSME= T/q 8%7 OH|"8MHAve[Sœt3a^kK{ܯ@5aϽ= (rkL\ % XU$?jXBflL_"dt1,fUI$ddboH!Wђ&~sEz{hv6+Ra *P}I27f7 Vy8ЧBb]@AkGV N2-! z d ĝ\| pWfk1>GYĵ7O5c^lZ t #T)B7BS=Ǥä) \]ϋ1)q`\xr[(C&Hb4k${O',󣤠,@' -uc]ߜ\ﯬDyֹ)Ӛ&drY}Ga @:J1jgItӢݥO5e:sĿkd \2dր$MM)[bܔ" :`VgS` KOx+<dŲߐ⦂Av$$W: 2V"wr@{A.]MW1"Kys5 BVG&+e_TI#gp9 >yڃQ0RU V5/9Bu櫱8K!BJ.N 6LlC#Ӗ< jFw͎͝Jn܉w؋V nv/p<﮳6|'Qlpj3j;Z;LɋU-F*q2BE3$FoNF#8n!'HH#(^d4m`s̼!\gxGӞhG"=48S4D4.Z-KR}/<a ͸cx`_> L~ NC3 A`@󳓃i3BJ!iđL`];Եz6#r̸@7)\qd\hp,7hiXg8vf UcQ(&Hpn]QD8O~ITFEf* i&o@I#hr)QĎ1VRHc5ٽ#b'fNk90PPw^~MWHFIڜocJ<2+T 51qE~b[D%'@lA(Œ #HWqdj>''EB\/s0Ӌe2.f ƸTsSNHtP#) +n]az=^d:bTɋň^8@4 [#6V;-   VS{c8whtzV_" A7K\w; ':cl mճJtJ_66n^k5)^9V#ߚȧW +Xga]T `cS=}a$rB2]#S/mNlL2cA2xj)bsǔP%ٱos) 8]%MӃ2Z٣64 Dž܎zXGHzU~1 Brq ϦN:}IFN,dVana:[U!.+@x6a4#= f~%w.2H0q`+/ZlU@AUmNlL/.1bAOqÔ]/ނ{!/Q/mF@s=v1|hڞPhejv^ EЛeot?OتP?ȟfZtq,TDkT$OzHIob&AXlJcMu ا~ZC_Zሜq[9Y}LUݼ5@u||jv"V=k"{s)'TkYc}4 >h#IX-14<V&\ $%5uRm~#VWMP L:+Iռf>fԆpʀNvUDsRB|֫&^S'ޫ8(*?1@ KL9, œ4o "-QW$xLV_PjRRRJ(TzZjҏ)2(1Axҡk ?(!lP{"wKқVwQ`J{!ٛz}7/Y /ᕲ͔f_3-1&M AkE"xk,Y+J8. hd8[LA5b!tS+vd)L0 W1h(ɭ`aS|UiWY:5qBؑAf9 K,%jPCV>VN3r`KWZPEL(9 &1* ]B.xԂԠ7>j"I`[NI8iP:c]ފeUfjOsx( .&n3tXڑpNHN]Vi rR;59O(cĚ-P|X257ny15yXioAEC*R`[6@- !\,@8bE& `BE/b ːJ,ȷKEVHrS,Z'9ݎ!S+˝c ~հsUTQsT%bж!}("]gMOux~?_N3'@}-~N*zg<#=.KsO)R褫$Ac jMA1+(d0Q:!~(&d S $|u+ 0Eo0Z5k]#z%4< |W ZQz \Kxf0h5U> ^Tj9jH|;n7Ơ2Bl1ɡ>胆lNY(|Q,d,y$ojcZA YpVvh_ D50 [ ZlbG;+خ;6N1`!&xRۂ0 !0i+WqH$Tc6C2ڕ"Q(2PF@P~NєHv AimV(: kcBݡXm)(OM s;%!Υhү/)U8"["ldyI*RhoJA6 KRHQR P LV {%W8&\]Z_rbO z yZ˰sz"͇TH+}RpW%8E!ٳ*9^΋R|UPgpbSO ^ yVFJL{Ŗctʊn! C^E9_j2Lk&zvhzO8gRL+ēx'(娩%28;FDfo+#Hb!TBdNÿ>eXyt=Vb]"PFkg@zǻa\-XMƨ(wMhXvV3O˳I4-EXy`j1̊i5 !CN\C0`>|*kXX 9d"\B1 <`Ɍy'f%/k\TSoa#A.v7Ud[#ݑWgdܴZ/Y>^MY!@\9w"D֛& V^BCCm[6˜F "5)H9Bש5&8ĆpL&$w8Wz/[ ayg,rYM|A2a2TT'Щv+/kPԱؼ) xH7v⺫RV GR :bZuquFt]0}(>u"?` H3M` :/.7U#F7|7z,vm#q[Z+}!N,.7ye(Xq-D2`oiJQ~t>|3pm q1v11D8妸i *$Rm[ɥ-ư X:&Н6c"ku1ͪt5=Mr@cI858K]&\ A0઴kK&V$8$Nfi= feE .mp#x!яɧc5'bdLĊ`-Gڳ puXAPNJ`eXf|h3@:W8U.(:F`(֭:1f݌:=c5 G(rHӨ+ba6qJmGw%N^jzz#"ݛ~AGݞ8F{C÷'t؃ XxGbUQw'nʉ^H`L"Ζ7ZCQ"- y<ߌIJOy {<215b❽ʍl^{@ sEi/vYmya qACd"|5FH\bg\<4p5:PI5_E j}b!x!O zNH*=Yn2&lީa?np,VSlZv6q[L]ZI(17nWwZf2q\Wrd7.g ,ac t B26xàXc|snhb1*Q2x+N Y%A+EKqQn`GDd0Jr?nq}`JZ_x+;8e_B<:b1 T^Z 3J*NJFūY*GX7>n-+ȴ߶ZQr/g&ɢSmϙ< Uh1_¤m! za> f1ϰWA=QU5Um1BK0IAKc%Tf2Ѻs\3M>^ 6N~ZCڐZd1?XlkYD?oGߪ]{<@W_OT+fObM?12Bw6"\@4/-Zpf$ RGpDqڨmn:J%DᮞU]82RKr2 :YXħ ȉ g)k]Bޟbcע-g r7T/$rR)7KIGu?n@.?n_谘<Y#:D` 1Ac @ TAJ_EIլSH-H9'$e$Disr@E 'Y\__gb"~[BMP!{5^$8 0ԱF\/ek_T&hÑUĎ0QՕIX<폭Oq֚.#mH>Гk7zQ-|0`2y݅Eų1J"6MGݜ}iMOʥrkӢq=H#`w1rQP7-?XL:lч4Jpp]̳Q>e~#Y0>%V]o! {ҡoKUɶ@f ǔ{:;HF{r|#&@))`hIM b%ws!"Bu(Rk\;8#@tDdh,8& w,Q 0ܖ4^.Л_,I2tE'AXЫUݞ"!}d<"0.oindM9p.C!b^T"Y8ێ{E#+.I&IOfxwx!X=x-#fY`HNIwtD[YsO[ڑ57Knos_N6kL"]Y=NηqF^y1PHN}A^Bw:ۜf܀6y:-Egp$BWqPSl(x`K-NɑXzJLGW('gof 966xX'x( #J,iY3Nb; ]@d E)=ZϕNw֪ۀviNsݪl+L t.$|Į,D~:S`&tTfLGrQ€EHĠ?vw0{(ѿz~]9 UҀTV+`HRDA/WԣH~ڲ"MB,KЬI%gg@D}dy w3W#(&Rq5-7$āFkȖ:%H.7Qf+B_rzDI}}ĕ챙8.DE+}̏?_4㫧TynR#>V (J"%ҁ >j. +:)NIbh9 F9tay&M )!RM1Gl0n݋nWQ4{^4 vdD?Jola5jiRs5u@Q`0 8|,nV  qă0UJ$'U7m['bkBȢ fW`kK ,2b j >6խfi $r1Fw 1*D;@\% 9Xg+qR;KʈqxߒH(] HIHպIx&s>b#xQ#RWq8r䏜SMFV r] B1c2EhY,!L1`s"&g$aP(þ`׶| p7| 7`EeziYclg9ƐKNEd yG=2 гqb7 76m"L9ՙ1y.k$iqڕ t~q'XÈ̡6`4rJDyo6ś  fdk3f,,e2\-) C^Fl X ,=5)˿=#iAM=H3e qauh]Q <+M͐7F =3bahRS<"pNk;+bwQX4smt"Ō[۵mgJAQϡ?|S.Poo_KzͦQv"4ix=JL!o ?QɄt_=t%9.n tDunPX*G5!аC嵐^LiCDŽJ1Y-&'qc_޺R* F#D1%r>K. ,gO$J*FQ߱MasuQ=賂0kÒu|J#qMi(؍/l6Wnq:2q#^ԑk 9 >.3u fSR=Lwn܉-q7CnR".}2dKZ>|(,iI1ȵz _:pZv-O%(1HZ@,`%@pNac)W"eF秷RG@#Uo倩D6qG(nN&^u/WQ2ODj<./:&JlogS fh p?7 P@[!+ѭT!p$oeT5< 1rVir_L5 $('*֬#U&e"l.rHs.3L1fzf(yn>bV:wv-3o e9 '90QH8vBً^(k39j“Abe5 F᳣'Xz3rр<&ۉ %cވt7$2`҉ ͆ę DG~Db#&(e- sjx)]>G8 bAiD3)2 ADHb֣rvN\~DƊ@}KX:0G=uH(UPt>IL <+LrY+0-zW¨Keh~QkO tyhLFHA~^:wY{fXŊÌ@h/C@1\t%ô\ђ%۞! jn*O!Y~7{/ Uz=oV䣕P+9. `=}+ƄF #E]J Ϙai|bV9?`ꫦyb,0?>iMEۺ6ُ`ZF=!E+4j\4KǂQ0ixX@)Jb6.}]} #l*~9aeYk(YY\-׷oíWLĦgI "d[8h~ZY0oRANz2v:6%AF>R!NkYy80 %uRJkV<|^Q8!I&%`,kwߛ5vSNw|:`;_ &6'yͷ;\xy;YLn;9{Y13 0\骁 K45:r&yRBl$udϕELj09M4z;j-,R,aZtIFB;qVF#*9`k6AmUɅSD|h4^ϣ T,,_ )CJ Z@} 1L+SwB 1GJhD.^9 6ԛM};"cIZ"&qA6}@ R %;RAd}mzU$\e+̶U-~|4s']+&}1-wxT#(p=Śq-"w? JD/^1&e2~uUxr/H؈DKp[MR؍)sFS+|ie\ cbdVJmkk|a.ع~J/*.C3. hownRພ E^& O\ik1ALPlPU|6p7縧E2쏖d31^<VyB-ħ)xg}=m1#5$k^?~O[y%{{XMfo;d[+M}6͋9ʦyte,քe_yp`[MjR5d9M Zc\BBG6MHu5̍8Nt:CCS~39 &y, qV-A5^78 BsG·`~9%a8U"HfaO ܄saTm։/IɈ<˂{%9.7V Jc Uv 1ɖc_=`}*1B>rf/%unȵ,cDCz֜JYQ%r)'|qtEcA deY\TҒmZ@ԊlH "ɔfNV|\$MZţgM?Xyb )z9G"+IH6 gј(񜘞S+/ԓr8')#;C< Zˮ+Bp[LJ0hYI ȻXv_nl5-G XAB6Vv}JT](w7|V7) MRj`(4 .>VMoyԒV+4΁ BX c/ Hv؏zA q>efɪN\.$Bs2|Mg8qUY3DjU1П#wCFA1(1Up~q>3 LXά֩ᗢ,A܆4vw@+cxH"/֜>96P7n_]qEFo@MžÛT/ޅHk&ƞO8_ ,Rnw+oyLuĶFAةqp*<ƏVC[ 2YpdUzB7tM=;$5ܹJ7Pt[_>ѼHʫ X$B ֒+ϞQ9ݒnEJ-`8scIJAeL%`aܖ+%HHiU譣CW{c᛻@"a@ f䘐H9#GUT;jz!}bG* X A`Ux;⯜{+if W5^(Lg)0SPDdq>痥8 (]wN&7OqM ưchAKL\0Rf&\z.OvvAA(r[f+)E2s#tɎ2\ VD7:-_=wLͬPx@T& : ) -k4#n{AvOm]זlro>tZc1D(Awaϕ/$B5"ɧq]'kYJ>Xpm!hSHTYx}B%!s֡&NghS:]EE~28t׬{i-yi㒂]4 '{{7IeP\_WViAR|&E:&:w9mhGlˢaf7Zw8b Ro Lݺ$@S`,ܢť 6XdwXG7@TF{2)qM{ ~H q~@,pIUDE/nvu1pkfQ+l=9Щ3 w7v_Q^RÖzn9p}wzTq;@[-"˸,SbRK<ՌP?1C2~Ngrm R~U4԰u 8*K=t+Wb;]ndf_'ҲX8y%_7OPոh%yg(ÒfnYl!aqД<#+v+#HBbjw>QJcs:5>/2MGTAU;NL{nk Zq;nuj'嶌鏏 fvA vXh>R68G38K֕6f6F++9U >lOnM`D5C ?QX'&Ql ҕJkP&VjArNTrwPb(U QKH:I<Ͷ+D1peUwX*NbM\`XZ3 ɉbG\vkRbtВdw(Wf=nϝ{fp۪w i UmS4]~5&V}}j4/j^Aze0ꈩUuv(3trx8E5NNѬC5YWL\K'i J{q# 5₽~*jALzdz/eUG^2$ <h8ne;R*%UYwC!T 5%g#@L'vGKWUlh Z0- g{Ua0OY+UP|jZ @Rq1 0zտS>#JD>OH7.KI683H%*;;蓃쬡y+ŝLCM:t{o'bS^-9%Eqy{Gp> )sipIg0Hczy .XHf6B#mL3 cW#d0jųر1JqUPѢ\>֓ 3 . VY9lJchh( Fg$N{A#PXlo`pN{Ē#PItdr$2('!MrX1fU=fo6Φ9Vw_c~RCϷa6Ko󁛫z?W%VFȳ#%{e5G'Ⱦa`X?{/xՓ<HE% /jX~\Kn'ٗ [Ec%Ѡ@#>`IR֢h~LWC:y`s'&ɯ--Ѻ ~H1r~Eҳ5ŰcyħMǪD} ;4(u&?3ƜO%do&I@rhśH`/90D^й}f iUԐgb:=_X328HLr!1_O׍/8r}v['hOhlVl/eQW`I` ^WZxTDYaJ¶BTJBc:lӊyJ*0&vge`ntc@OhRH#iٴҀxSX.Aq X&coN,1\*i͎a0T􇝿\pQFs}>qu%`.$^PrQϾ P dk11%lz4p(k2CN~ NL;4rM/b4>T PC((/r`V<-8Obh̦mCFPd\lQD*\p ;Ĭ3)`5.o 돴?_ۭ3U` q~-jXu^U$y+v)Ƙ$G\[knv tv+p;&d\ِ8~#O 2pVvu Gyɑ5xK.L͂wJ-]CUpSSij Gp0ilm3>- t0C|-6VyL6KT*օ.:\44[*gh`jD CE~CŧCsY}Ixs!(5(04zf5 9,xde$Q,JMХcŨۥ?p%F ;WjSgrKSr7c#$SQJn m]OIS*zA3`a= =<]B6|s"Dwe诒a>cX}B+5 E= e.0N}Y aA2hdi{1Րg1b c5=oȧ@=YrCeۂ sADY$jD sQDdu(F_:K@,HљOj_ {|DwЏ_'   ,IlHK/0ث]P+b#>I< rxR!xÛm'x!x#M21Q,dojP{0Ǿp <~AXZmx*P<}3ݗ~".k#v2b+4MjQ%qRsEȼl>Q} e^\s 'Ǟyߺ$2)Z=-#(0CrgؗyG دe赥CRwxIF- <E7H7`O#=n9MsُAFP%PuGL:!54IQd꺫B~6(2+AOXr1=Q\Hj :hw€vybG{${Wm"' 2(=ysvk6{{o[{+ob?&5;n2< BRڈCw쎉)@,dbOHw ȽBwR#Oi-k bz;JxV&RũC%UWvΔ4K9[.O/OUՎ]T?g ҳ1ϔ`-J'LT뮷u+N3!U} @(x`hQB3Lv@D-[[tzhJ:肂.6QA(1x M;8YKkj ocH=?"A-o]f\ !by`4E,~8BVX冬IG&dG@*߹פr1U,q]Y;{BBW-oة%@Sd|"jv OjJ`]iM`A7}ZU%q}JB`bE@'a >%9O{C:H5@]hS;B[wDg[c5bg%#B؟t bIf4$*ETY LUM9 9 xP (I߃v$ b뷻TP7Aiّ?bRO=j u\ye U47Wsx@"hm<@MC2 RB%'L&.~>;}zy,00e  ݲ B0A"q p'D%p.m4w^;7bep言,V bC YL\ f*D JRrNfJ,42&eWf!)7keP09Lu+z`Y:v~~OD)>e#ԅŦg\Ł|`n<0 OtXS$>[D:G y\)vxrp['z0s ?蹉1pwn}6\puMژ/RjsWy5O.j\N<6pT(ObeJǓt'"YXͯvs%ZDd$wֺHyx&~m]iTzH/U*Ϲ-lļiac 15Up%w5n)=E s1䪨-SEfu%ard%|7M50nQz dUJ&aQ(`wiݡGx#FWhaz l8dѪh/~&1ګ.?S;B+ rhu0χLǯ駰$ J:^{P=M,D/_0H7?/n9 $yѿ&C󾜲c}OCN ,@d1 C"j˞ڡ&Ⱥr =O> @Q?bq!HIY "bOF+]F,m zΩƢ| mq혆.5r% gi?Q8ڤ>P1E}֞ -@rtKYXBw|_ XO0I&)~Y~cJ9ŵwn2M@[Qv5 ! (TnWPHL^(qmJt*.y1("{J*zU0|c!+):%BRt^ 56O3Gg(L( Kb; ^q2;+QL0}u'nQ'X*&֧ӷ3#TbO8Y~US*<3KEq/ckBC1"g gh ,f-gowIPMˢl?f:d8|j H@$=MP1%iRQ'>"ZҪ辙'xD.(3'F4>$ΚvT"8w녠5FO q_-=_Z"+dYMPF̰vọEC3g1 cJ5ѽN:)ʯCG'CfF9ȩm~ q MtI18lFsHX$>ݰM(fRl@j2} lj7=NoeJ|h9Ζjsz[,% vT="Nɮ.ՙMZ>x)_jw %ӤBkY2Zjey`sk[Xp R%^^\M/r?d}r\#c""mcsd!sY% c֦*.റB.͐[[1̦,6x b)_;+**$Ha絞k|1x` X/_e# egW ^֥ Bk8@/{Ц` %oςzȿnx8`)PM{. BeRאM{i"_Ho]fPHo][ [p XR N V]Lv3-wԔ3d`>eC-,1г'PB An16?#*Z#i`#zؗ^Y ~ؾ,Ѷt9Bk/8r^=ITLCX(s ͨʈ|wH049Lt7vAWffYƃ`( Kե%GNp;9NKu,e_d zWpѓetAz'EWYH,+|J5o$^xkƩ%8|,Tt`6%0Z _"y9m.mm DHs6橣 ,sd N5͚;:q 1*̯MY1n&GurO Iƽ.,Ր<6+ G"VHW 4xF!#ij :`>j~][ LJI2-`Єi:yR~}g r+v-#)M9v&dTcadˤYϦ`fH`BkXc5뿚>Σ:& لs7$G"VD|KޅQwH5٩)῞95T=bHuTGpxEUX51 ύdk`"Pmնڔ+67gb9FZD5Ml0uԨC*B:LSS"-2vCMb*b;a pjܸضay]6 flvPB@[ S)_W4IzѹO(n {T=-\MRUf+= T=Q5#OrfxӐO]r{wjv$ ;0\{R!Bu8ﱥiU4 NὤPrqY$^rAaw)B-6-&JYFe5@~sC'+66BB~2Tij}@57!@BbTxeR/,mu:`?}.UL.OL=`N:Cl.=m9vIJ][r4ԆYGuzc~Vڬ X 5u[.V߰<GJIYb޸3JA SP(`N7GHPZ` bdDw{-<03s1СT_7yI\3߅Y7Yrs:lJignUj#SĀnsF쇹"QZ"HA Xep8_/=@maQRԻؠ$p]™"sy u\`X{3r7>`5P9<еDB tsdpHdJsY'ѨfXJsLo:AZH dvmv.rg}>w )>'X%a9`0eZn<DG3yTCzoIˇ]i~ҷIkӭ'dZч|0CoZIҒ6Z?!ao>tɽbW^˖\8)©PYiqd98ɉ曶{]ы@Vŭ7ٸO.`b Ň,!JjUBHX\J^L8HAIPZbr)AFrI] ZFiYl]7jUI쿤~>!Ri LC#bQgh|Rȩ4./ &Ʊ.Yl]f?]_>E ,#ď}(T]ġ褾3ES8- K3R,f"͏T,(*Ga[^ d _>MI<-@&<77ДXȏCd 呡P/;t5wӝQ'Pt1Etjh}k[47df@Sܪɗq֖ׄEz~$ zM;IDgaNLnpsASpS=m2]ulQcX.KL'QQDQ`Rں  v3 C,eOpuߧEs$6-^nOI L,ubx#Y=ŖSe6Op?HW_ݘcqzYzD0 &,Gaef5؉-:ll|o:U\%-*}GMsi FŜRzbMPhےo~Ȗ3܅1YkWok9-CX"/vD}o^/9L΁&3RlYFCAo1_=:^_G~7LUbM*4/D+y"RGl 1x:j_Qv5p >a]}kThp VV2÷ n#IAtH;^^}w$ !7uS׬$ 0YrׄkL7Ҳb_ OpšAΫW섅>X lSD8d{M/Yi b1a o5X˶Ql+h%DF,eB6n }?#<(χ8wF9eaLȘdDf11lKB\"JO0l]1B`tiot_% KGFd4+s~+;vqp2Lg;=l,r*IWϪR7^%'24EO >kJƠИYU qY{^>1xVW<NJ]4c,]/ZJ׎w  #~݂>;L'8({<{>PپiX&Y>U_y !]a {=&IOr'2n kA4HK$%+"VO8iCjЉČV/u=4K}(]w~e1OWRǡhqp!O9r.^5w.*tJLL&؂Wwѝ]ZkԁND{'܍6L3pu8T<L̜2+'k!I8dxs=U4  D(m83̔=JY@DC= (2kd;֨O.Huq%4S'Y2PM.g| c"RjԳDhfbWpsJ]k?y7}ژ0AOxj}FŮN0F>rAd,=jTbwGϖgGn'Ƴ4aCH\F;K8QyՏzo[}&…wZYE&2ҥF>>0S5JW99n(ޕ߽t,@lG 7VP΍UwRcB9}t.0BPo[y^!Ӎy{D.O5syV4KA'N\Ε|axn}Ph%'ov+;3: #gA7'-"t?'pbj }3ߤQr~I7B0DZ3+&9agp߇rp 3)p9$}7mPWM(S "Ԙ1cƌؓw_kE jR&~4ƒz>ww[P4 *sNF+͈c .JPysE: 1rU¸%-ix'inNEdE3za mTV 8ڍɖ a 뾼&cE70^QI=*#2؎p Kyϝ>Qm)JlJ@9o\"kMd1VsQMfAO}l\ҿ(¡P,@7=Yjy22t8~aR*ַfd"UC4A<ŁP"W։ XJfde^+')eҢ]nԃ puxd, vyc4 _Tf5XVwXQ<덼#"70t ?]E/PWDs3 >/Q VS+Φܨό𗵦繼Y&a!kMSlTPle#:Q%YoOjnacixeY\Ohd.?CљJZ"7nߔt8P\zwC0MQBVPWF= & ƙ[1sbGC,]=.zMy'EE< zDY/a~po:cnvWivfB=?ZNNJ<ӸA?0;^Үa`މ$~8?]MŘ=iOf{ wƾG`$tF\`Q{A X9&@V8+.+m6VEm@k:b\-?apQe<x%,!bsu\ 4}%KF2㨡0.4 |eFaG%1ggSj%z|2i0%$I0^'q-|mC3=dIdN_ݷͣXQkU^;J 9TB!>*9!8'KՋN(7.F]oj>)ƦΐJ?6So}#e|t )È`s\O{'Q Q෸ad{a=bgF=8'R`C@uabMA@G 忒&rԸFx/Ƴ m95(YL-) UB8Tmcs;f<Frv:aF7 t?bTk\ۮQr3\ IYGWn"(DEiZ^]l}3Yk#*p/^ͻBn}Nr8SX:tM: 0dӏD\cHߝI{UvCOIELLFl,~yHce_ 3ljQ9dI1CP6Z8Y*2ną!&e01)ZAoPlղ(CIFd Y_mA%J4;AyEKxǹ 0IAx@(c#߫;T]pSRhzפ*`N=x{΃@eq'5 ^*;r{3I' /<#pD)-串 )ҵՁ*F$+ {$OV ՜BvP5| @}Au!\{&/hf+\.E`2KasA՘ɻVQzD@K4Xe{gAUy;UNO1cQ"Mt,j#n_FWkhl!=hmҨp[U=}ֳ.&fUۦAUVX#/ߨv^JlWu&ç4ƬQ~pܹxIyk `TC(sD&ԬYIqJX| LXXe$nۃ}1LAps.Y&9~PF#4'F "d=!Gk)6MƄL|~)$6脣FY*T3)mct,Ѽq0 côh 'S* 39:Y# jM+gr1CspbDO JuKIę:W>)Y)ܕ0f`\HkwWc{E"&I,/wdf>!$b[T&gН*%\jNt[nqĎ&@aUgqf"Z>4O]0KnP㎘AZe/GY'#ņF` w8 ͔YR(`? yRxd1wSx=Xۮ55g/'[BEwUl)p;Yÿ_?#[0 wśY@Uyϩxܬw"Qa j& RHFc7wڋ$cpڶVcX!(Ȕ~ s OǪ<|N`육45Xtuvq r^ H>T9^b`` eeDjcX]"Uj$ZHhՙeZR僩]e×(($4F"Ҙ{2ɺs/]:z:t 934s CX@Hsf㲲vƟ h>F_b.t MZ>H|<凑ʐ 17;db.t׶F59fS5LHum;nAh>siޱe3JsƠa`SE+:~JܳF8oK7hLcWl A?:I?\βﯿ`nX/h]d9ǻw4lLFHNo0Cx$XQW>9/DNos!dq $ʳZѢ=yTy'\e(h>*Dl4w yx7V1~V齓&0vMx`ʈ]3m"{=LJg6P)$ޏⅠ&S4d/,-~~/e ?$7MUl=--db1"\"~ eK#?2X,* ?|7M[F^}{r7iʶum _XID}YɧiC$o^Z(WLj`8k,SuzaǶ :)GÏE {ZfpUTKCU4fɢ75O_<\JV c༊:hG;\GIQҹppѨ,EܪW=!Q)aE!DX{G:vj6TWXvqкMvNK=k94xL(ԓN3a(|?\ =-63{< 3S9?B8Bp͠63.o^B9gLe.I:lH-?o h,eC.V >F-о36A5̀_Rˍ9qivPf_ןƏ}:"]T2 n~B 鿼xKۭYf c9:j襮,\-5I',ojH Ojalfuǽl; +<^5 7-9L }T?ԉ8jEfi=n `Ů4ʀE'#ߘt'1'2#Dm񝃸LEY:G2 %t}́cHRtt^e gm IKJ]Fᕠ.bk2 0Ba K_=^#h6W[ E%N{ wQ40ڏm5LhBԤ< <HH5jOoqd{'EH6Cz -%ȉ$ݠc,[QQe'9u#r|ÑudqpOkXL)Rґb sx96"5\C)?8}&Im j+"-yE_+,V(Kɓ 60yXXi6h%~^#SCNL󕸘C®# GG,h"46;tfWW 솬="%7飍CGQ!bl WRuг衭ڠ|tCoP)10O5ްy 1[p[}ϑGAW߰T ?[|QExm:\)EloT⡈3 3͑:yW} ̧eb6BWSHrKVR98> Oy#/{ M:2Y=l F,o]z?¢q#SvةDŽ-6IAB`fNI65N}yXCJ!ƃ-?VB<$+XЧ>v:#['<%4r+ȇY*v~?|Xs̴n?kI(+̙.`'ʡOx~B[>jJ[M̙AB6TaƃJГɺ[=(n4jm;y7)R5&@1yY3"-ƥR`!;M^7CNM|.wiK?0g,(g!jbSs&7E\oZp(H.uV:AkYl)*[ţ7ND ŖDLjW:mǖ]; D뺙 2]tiE^/@J $Gc((:Ý硼Y/6#߼,ôZkIvkAZ 0Y!xӸrEd,iox ;҉TvبdӹRutja~)csc#؉@y| M\kq+?Y0w W컦zbrK|l_,/*`BaVn 9nwwܲ>V uJA~@h}[9#CKQVQwt5ruజP9KSoR}Гn踛 3g L*e! zt?#9wEmzRЭP\wEBG@URLI< 2{:nG5PU p@}eQ ^i&Q+J#tS]B/XafG- _Y ˸D̑VO^MڸQ6 N8A Wd`_ ^r2Ho;PMrz<(V]n݅I3q];nM - {PW o^GK >B]c ].sҙUR xlɀ̆fU_Yyjp-Ց͝F鈵$1VdÄ60_LҢqY\3`n{q<4b0at?HC| &9`E|D/[{~_WFZ/0k vkV|LT:Xll0ɔЃ:D,6֊1j0r9a"u!Ŋm mYٜWN_1N'Vd0!ғpք#x9r{u*= ^6Xҕ,wC|fELu|m| k?G6V۲AuU*\5s:oZߴj_:*dlÉ{?Ypѱ\*e Т~IB"[}X=LM1u shނ6 _y̏V3^JlI|Q<…cm^9dq8bȱn`É7 A7߹F,̚k+0ngim' 7|iqKK񕨞ew/WIrx XRVVDbDxpq2{`gnRْbwKbFpQy7iŀ?A~.~t/5곜[8Z}٨k_F}HeBЬB/5&ںBt)"Gm!;>+5?~ה ;I <%׃B9VOZ7CmNҀY+nk ?빖K|ez" c`bc8*9J[c<_Zv ɨN,z *Vh.ԲOx+bVe.\@ ̈ZXI-E ErSN X(?{ɳ/5p:%އF2yxoÁτ48#8[N'S)Cn%zg(.WAcH؅b~n^+!vҿ|B&K Y@A ;(p-8:#0[b<c-"=\TD2`9 Oya{x/2`[ 3ɖ 6 =#l(>6p]woT}z FK%ˢyJĚ?AN,5.\eg=f*ŗcfS+2F&rS,#@ܤ(밢ѪSajZg9&.0oN֟Cf_#>C "#. .`H"z`XY^48Q b{VbDgSʆhUݘ^b0@CU;jt#S.IDG|?eOt>&eoW"ج\̜>Tm:-9uE:`8qˊXٖ8ƱG5'ʬʍMsf^ WZٹwd,a֕1Yy,W3S[ iWgŋ 4l%ŴQh`vӈY#]Aj";XR Y!,=J&Eٌ eGsIK688 ]vmhXNٓu\\5g$ 1|pfQ,!h=AGGH⫿uh.62el]d#0 Ȳ(;?3\s^we0çƜt,y0yyoy{t܌)ʅ~ ٔ5k"^fAL s(|`rKJmJ|hW-b-b0{^K ""v.ǷgXb>G{lxĦ >tEF7F7ZFMVC`X8*0yF'L\q0*ԬA!<[~t#c8|SVc h\2hr09iyTr 6zPJ".(r:džPZ"T q^!pr-X' ʷx1LaPΉ0+̇WG2cZa&1L; LA59EF=?wZ^Pk p!|/!NvY0&S"cm *׍샌V B엮 &05_u^:>$~1Y6>2'})'3N6AVCqш;;fh$HtTGA@]А O$y@0ړʌ" U`wX覨>Vha /gJX Q uʝR\XD* I^7] EH/}" G[-**밁|Q):鴀w?1Ocн*:vk9s!#&A-v( ]ug$:@dΦh+)bS'pU@:os*X<%nYhuB|kd2{ 3f~ј膿  2LO(u};N2exh38 Y+.q3 =n9A"#a Ic5) }@x̛PbgK6[;E{dAlT !;'|:G [Æוav2lwhe-}m Xowp~GkSapʈ H3^ȾozHQ!FKzֆ +3!0|TgeR]0$QRPj%lQ`"-F!P';"`c5JB$^PO I8A{(c@_fV! Xl6·=ŀcԦu a}2HxR'kn.1a0s"_-op)Bީ}S"$`/k˦Y jʵgE~ EȵAwd1dsjiQo32rB2k$pLz#"F=VKy} ^O@3U\nXg}qi^B1D|FkFbnж3P#>lxSGD;OO<&-h+ mO/҅wk\l)9\s030\ g4r i1HRz5\pfqglϘgx2! P7DS0BO;z'H}S{5xr UE,c6%spbw,-&w70ST+a4@6H:ў@F0WJ<"]eTXD kρf_hD,@T#|FI9cX%GÅ>Mш޳!kdgn? <T3e&QbA+" ͢WM\S"Z"6WN*і|T]~#<8tA@2*PB8k4óS}Ca7 \Lzٌa @tS$߰}=D#?pP\+e$9Er\oW\DyE9/H*)/ABxsa7d- ;baqgm:)PARExxbxgއhR2q7<+~?0xO7I$#Ctx<2e5OXhom3KѾg a+v~R `G yWD8fcjh4-5@.3.ǁa]BWkDvU^cZM6B%骀f6TM,""ڀfwwzΗ8{X1K Kf?38R`k^ )v4%# d<݄™|L4EKjY:HhV*.Y4}CٷI7@]6[?sf _)Rbc<&si XFyFo=fjIpQYs5^3H4lwbPwEOF8 ^I Չ55>X~!3g\4bC5'Ӑ>û؉'̿Q*cV hL@X!IDp3aUp(@32H$ux ْS1rz%gdMC=|Dᩇ8yHyGB`(Zga ZLSk-bGL]._^%]X)@ʵJ<fv8^iG :FǧYm⑗9K-h%_ xW** fXuV, ʹAz;}tĬ/9Kr@oZ~fНyh9߁ζZO4p}d(`-7baF2 ]1L*q>_=xA Zx|C`K0d;PtmSe6Cur50&4$L+G 4RiH S5ϸY wvגVS?qV 0Y*w6XqV93#%{jE3E pv:i6$vaiaȄ4|HEN,j\|wn ϔw1yІ);!d <ؼఈ^|իlt /4=%#z` ܈fn#:)kZx/}Oi 2^"@jgR~^@nbw҂ȡ{~{y\`mu0 }S`ǔ@\*,V3k2^%6@`־'V?dkwx )1T!cso9 l_+KJVsTb*\U9$DORu^dDF90m:ZEn)jRܑr{Ǥ$ A< ɭn",q$S 6rB>Wƕ}UOKD7+M-;"ejZ"Yl(G>V m.{HR9IJ_n/Y!N9JdPRId5GI i2=pfe\&dchP"B9dtYGæ[s ‡rS cdvfnnF %ÆH/#!za|P AP@*bu4{ ̟Էwqc-YO$ArK0ЅqQ3Mq^ՙ[y+ BJgOI楈2x)T Ѓ9ƪ(Û5@;E)UtD :Y%q[K)|B<Sh-Lc{+XdCI(xV%v-@|ŚȆ!۪J$WB+Q"K+ٰ*3WWg%5>N!X3sx3 wfT40j H>28OGk}uc d8дksO/^]s'$9kͦ"&3:'S'4SEVZa[7AwwR"{骣Y!SvkP<[zd>rKKbybߒAIhP`T]M(<dB[d& g)'%*~!/:Wy? +6S7Je#\*3abpS[_ %y3̢ǏY6eccӊ(%Oɋ[0> k>0h]^?]ǶD7QW.,O60e'y5 p!AK^~P[6K'+*ͦE!tPGB ˰X$Lϯ୊HoFrfpnw:*U6A$4|xЗxkvzgV\D2"Ou5Q=ŤLd,[Az oNrAYXIv߿,@`_!4Y=4KRD*;Qc:'sЪI:ל^8[{{?Mz{u7k!e&HhAxkTF!Ef0{CjYW 7},zx?Bݒ*bKE%Lpa j]PI^#!>^ \" 3PmQ{;b`=+D =Il/ YV P{[)@J[OrO]%pY :s{̉,UPDZoQM MZ-@ܟDvQ妞z9{`h*P7>^ sзy=]-wP*Al[AsEwtk}0Q1[jCJg!^Q?eI(%ڃ={wD^{>&Z-aQ{-̘J{v#PǪe ul"3L GPǭ|<ঢ়ȪaK,|v× "j[1]BM'lJcVUb'Gq-I|1E2 }\G|IÕ=sw3ExCPʿqM1|M3Vޱ ~[ĘDȇfB~_ '-7js% $DGՅ0,l݃~B$gc3 ̡ E22I.bBxFm`о B6%奷6֊,CQ6kz+3}HjQ7bx1QT;wvHHI\c ;݆ BLΝZ2%F&4pgt fci-l<3$Q4cR[F8:vegRfw=5pN4!fdzw;+F${~jEn3$r`__;b%{OfywtQ‚貁Wǰ5ch'_97< ƝH{^D&h$'|d4.-;",/uɒe !2-@29;f]JtHLFf&_6r$4EDn \FDbn$(ى|kU좱C;Dt=^pv簨SFi5oU$2{;(Fên(3{iHmar̩4usEp2jQuEIf+c`;wR9\x$ ?=ހd_{oaGo5lQgCe^ql/fpܲ*"6{h|=5oWrwˋ;k {naFe]V,Ifhde]F9]P:eO6%|)#,ĩפ؆$t^Bqf .xM+X 0zK>xnI'HB䒐z/\wH:uwvhlr'|ku/^{CFP^n=*/i/՘+"z =J`xY79׼M"jwm.35~\mh^4;\x`#)0e/0Mv!TC⳯h4S mI|L_.>8 5g*E3yQOm{|w?z5/zj[wHYP=b&nfb--p\rsuz(٘+8r?ෝxԛ_,@dN{\n@k{Ss5zڏ Aޙ[A|цSpXQYZIQ<眰W}lr :7TRfxR֐s[r%pd5<``&y^a7C 3rf%{ #Hf k[BP yÍV{'&+|4<Ζ򌭶Tn_AAo{z;;d)@U*(}ŋ ˬ$tּfnHrʆp${ }'j2Yj@YO{c6e| 1p VE Y[l!']mI)D&kd,>_ATB[!S52;䡖%U#lߧk=}7a@ŔhzT7ϊ 9+9K86b,+Te`_CLM= $ofO4*ru'nB fW9Wj\PEŖs: D*5!e({AEul<4;9h ̦S՜"f/x>7`ԫ}w|YC=삧}Qw 荜,]Ykzp&#G" !)&$''dzƋy8p*S;k&@«+[â:3f.eDD?pSX KK0)~f؞ެ|2\a#YQ1'#7a)zaI!LOq xу3[\QEF~Ek8R&`E^elFVKxXu#.z6H[? z3i J}5&zqax``dAR1ʭ+0v*G$2ɢw%\&?>".oDSmys1N]9Y+vdb_V0ۜc,dƲTyst=^qN$ $yÛX)@! gHv=|b$W1+j4%fYOWCz[v;j :ޚdegK\ N/h(#7^RzT +2 `Ӧ[@7zf[bncrN>e.cvY 1_CLIѽy }JuikH:9 M7^`x>b2+yw-}%o? I~sSRY/47QN7q{ +DCI& JABc圷oHnժ45=|6OEM+PHvS - Q\%jF-aTz[&uܹ]fOS\Z$i:@aaW9,~ P@ޛMTI*uo Q$4P3aFld kY"H2g D4@I%-Cl)45DQq YvM4qeE<͉[9&Krsp@z1j+^1vG(oz}]3h1pԳ (pvYv׾o{,~QU'A SCbmeL[< u衸q%ِ)jO~jMy>wRRg@רOշCpt0z(wS:RaV'~Ѱ(-g]fq`0,JvTg#Ћ /<JK}sc'`=GR!1=g ^]ݞ-a VjO"HXӢ9kl7N4(}Lي WgNwXז#Dh}i+֑pa[Lilҽr3uc :tSˣܵwWŽ$z&CvrL,dJ^I8&mЬ͞j}8Xͨ>` K)OT31D3|eLNuF:@Q<ݎAGa8XU`Qe&gC5[)\ =Fuۀ#m{f-=;'71)N3ae+_huȺo\iNsq$N!62qIq>,ܣkCþ9SDi@S' D]+_E8enW$FAjD{r"&nC*>T3wί_ؤʘ)gᮕ( 8+ ~$75n/HgdѓJkHP_p"?zOLvƔ a>;ϋ=$lsSvp7zF5Ps8xO۳ ;J? ,nw 9/_i~|d2W["s Y'tuX@I<åMMSqNy[ $ȶ$|6R7>d/3ˉZ ‚U 3j Y*g&~En %&!!HNP%E:jq%26 r+LΆ +XCr^8+q&5t#2ԉDaP|.HZ B|x,sd'`bgSؒ8@kxѫtx.e?u4(o4h栦ϸTA z w/P*56mlV/J*?;OuEb:a6dUFq~37sp&ZN`kxҗR_07=A}}sȒ--1x> qL`VzT|2Va %GFv#Ķ9+`7C(~Y4 8DY*&t3iVPc5Byx\0ݲd Mlvp/hFzXbPm$\2Kd7GUkPI< $@ʙ,{SB^pčs}$=Ӵg/m=.up%|$ ?<2>< m^j#]8Cm*a9Cwo`Ҫk. Wޟԍ3IP`|NsҒz\xV(6ʃZ! wk3cY "㦊N@5wپvt%tbF4AQ}b<½S(ap҇JAd@&⌫Dk4o\q:tC)j? ϳJ\pdNN o!DA7=2Wo lreF'py# &&@t6Tpb흀N Tiz._SvsRXнXQãJ8vy9ΰ6K*Pg: ?,񺢆a?F ~BG Z(O`6cUui\ZAQFziX܌ +PP!ǛRVQTw±M\59t7#}&Rhu3js+fDnS>Vw~;k|O}w!3̬ۢoTgb1K5'̼7{ެ7/̢ntYB#es|9lN)]۝!ô^DG\w9x4vl~&|0< `(P)TDx BTz+a)ỌkɎ̧9'P{"to@ȁy`5>Br|$\M2g AchǨfu0(lnZzUo#̆--_+ x&%uFψm& X4]ҕ^5xYHLB g5-=,-(}B)%+h#:l*9m;R'(8[ř nJ݈U:{':_A]Dewk1ŝ"_ h>ZJG-EXj&;~|~^Qc^8]%3Mdr\ 2$Q-2>1ip.ܾ?v3Q'nna-t~R&UAl1޵gVh. ֧+E͓f+^n|a9q^VW[1 tiWsnK(7VCȈʋ֟%wE_חV?E(Ӟ[A" +%ȍϢ''3V-jI4y9 fAv]$LMòYۊ叾V]XQ ,ZS6;f.R5h`cX#]h Vj#}y8[Zj<|\?G[gy=X.8*#Ժ"aD)07(l%Ax EWij-U.Wp+fMg}-( Рvwm_B1} L UJG"̈`ĪNxsih,.D36G1bՅ[ex=$P3"$P7T<3J|R誌ry1f6!ym>%'~fc8Oٹi 䨔sT§фf3dۑxI=Z}(4FSE |>a.sM:pW!^$J# ,n^~);?3v#90|,[Wc̻څQtg\c!s2ٍbDo.aa7o_X7BB{¶փ6V3 F_O b~xY pg:nحilK|u)Wluɑ@̢t_$c*ӬG  voT*8W>־oY4Pbi\k5jA o=YhYIÕ+FWqeD䛈 3Q.$vl^˸KnW{#σU82AY~ѵ=rxtҙ$9 KHS.P*p\\ 5`vNB6[B2yʫhy)RIvKN 쬿E, ðzRtI, Y#!Ew0p3og„Mk`gE|m1H H7FcƔ*&UyQ{*^k]J ɞ)_@ݏ܇7[axYY*_ =&sc)Iܑ@j杼☱b٬o#@ǡ% e )Kȃ×?I]n?w]4e4,]M6y`r^l#'WxLTKe`ܽ}1 ^gG5[x2{ނfgV1JٳUht|L337I'{NChVFgߪK9KJXj/^Pٷ: D[EU -=B5#7k12-@b*_0C^X'.-9 Zcx7 hco V"zİ?a n BtOp(@mG gHХclGk FˬzFS6%W\p@2<ת;}\P˗T?! ̭B\4Ns{k;ʼnbyj[l_j*c&,O+뗫hSkgi s(24 "G@gx췃F -1x;:e3bm^c{+ &DNp cP,lªun{@r. J2d[9mK E֧2pW:VKgt\m\nN7(?ݱq`E9%c:r hEQ Nz+OmXF~D&?ytBq C^CkɅ[P0\,LdT p\3tN9LβQ!ȇ-\}A;+n췻v6k(0 ~/0,S91hhq^8LMh-ڶٿfJU%>yeNN%>-Pte4Ӝd[`D0X>oleʲ 'c>.߃oc~r, (Cy'U1iO_(>Mؓ9Z3&,b9W D;YH%?c # HȻb k%AIኾ>keNۆɜŗpX3S0w3OH(e(,`kΤK_2Y~pnJ1YҞ2s/"$a$rW:+eMoHKqO yj:f@i c[ *Uw3n hyO!ZFyQz?԰ȸ? slAXY0 bH  Vwn]KŽQ #tw*ozqaktI:¬R HD%FLa+D@Ȱ5GM\4e֮&-1@оRwUx0J3xzZ,?%1}鬳F rypM#OA.h3(#wwr>A5T_kZV8JT`*?p>x*xÉ>rW"f~wa RXM{ȩ3Zp˴m+3fNBaXRֵU50-uPFi7 PKhffP\ܑ-9@c^j(6aT bnq>U 0KnH&'2{u)ox0L9.?tL)&Y5v(H> ;,SijHyyotvW:e9^`a ;fl 1|UWVSȄ7lR I'x¼t8"s,D۔~fS\kIؓߎj?M?h|"8\O'T%x@jy1є-;"L{9cD0Ĺi·VE."؀-|"gSaE<9Ǥkl5m!{.*׆ҟd\,@.u%m斑8M+d`qmr\X)nHnA]b1U>tTT/QTHEL<ضEct%;_VX|i^953P{q~o=l ' 26PNF^($P'dFj8o ⍴Ob.DG]]f֐.9NA@8GnXllmH`O4^t?qT ȿVP(H@C2 0.w}f%vץfS?XeKYxt$_m6_PjFv}T]lp<\g{&A `a``ZJ2ʾeڇ뺌i/$Т[#(.3AHsKÈLji6a!+QΏw|ٖ7Ԏ4opc88YE5d0O6(yp马~I؞>#Ä@: r+qR}:i]GDRZ^M9W|6Ÿ1.^"0&f:Z$16>BFf8 zYR='>v]A?%" ][_Ā;[1vNk}9L^MbՒ"'ro]:H{̉(nh*#W\nr8 3 2 q2/Yzu<0|[$. Z_h[,VƒVˎ:+) ^+sz9&W0c `S!Mvw_7:~b'\qh}ٗsqNbW'|7t8=dM,+ t7Hξ*­Fmʑ-&1jYr7ӑB+Lk)8syg^K2=jȨ=ueZsוK `s/2xcV$8|OվwW <l?QDXK2TK=pty/LGgYˆ ѩlpFjV'&jD}6vF o(a:tW H8gh[kG|^Hq8?O#ЍFAL2YeFSK:پ͒/yZcO#.w#Kwi?X(z3ſ,uU\ ړF0M ߄^G<=q3r/)6=\[P$ v\*Ҩ rӯdنWo {o $?e3gmU'r}¡5.ELZnGԫwu ܚqDdje6;f/ݴ5i׼\3Ci_Cn 0BՖeƓN+r!!~tFx2vht%N?#t  *-&xwd {r؅4Σћl7􁫠f6$8E+ey0q_Εt[Z:G_إ)/kh\.08:?bK5,b"^siayѧ'!pdO3zŠXYuhPlKe!p#䗟baw_Bϋ`U @7)j%]^(#7\xxQ@b|%LVj~83^l?=pd3?ydcK#IYi邐f 4M֯45RԌ q+P#g:'?=G+ےz9 [KP@϶.\Mj9Yl=GybrZU`YW#F`2S_#˙tx+MgsrYy{{\ [úz'')ﳆo ܷ6'A:/dl@2 %;Rҏw %֘lNCrs:<֚O KF8!FfyK4 ^(|岲RMWYHw4+%=S{iH P+1voQ3O<Õ Q?dZDQ/h)TKkǼ6'Ubx m|F si'#tB -b3^2^Qyx6eY?ļYK>F8]#ޱE-4EL'ӟۄ{DKD9QZoJVb35,cbLP-21MYRmK_ 5'BX9Dy)#?>5nju|0>L|L4:_<5Nl=t:%>vm~_͸n;L{^Eqݻz (M0ϓɻu{sFθG*p߃ FLI.rc<\zoYa,4 ZG:v08^OJwH8Ut5Ck^(FaB6n)00O% ǖV$vI~qN:HdP&f 1Es ]?ZR"{Ue!!ʚh!h/_/޼Z4%γU%Ӻ"HD=@@Mklt DXX"jy*lRL=|{yi=nXޭ0ctˍE/w(gteq^V/jQ"JF-Ϻcp,qZ>{ֺ?ՕE&IJv{X@^*L`܍ +.s2i'?83q:J_ZS7[0G.gLipT"Q2BwejO6Qv&Xc8u׭2a붿[Y7woZ 3%;VE;C9fwqwt[Y'+ތ$n؜{PjlņHfFQIszOY>whW%aD7@ޙy5eyDC(_ \RwV|詶!\ SBp+cl&ak`5acrݣx.T>E s~u(9S-[d2O̻&h@#? $;& TZBSym(i]f&fIeU)P\&|f21x٠m e\]IlLDz+Ra]GS`0l7&:;P_Ac"\)в㚶ALܮVk=6zr֠lXÍf\*sJ-%3掂OVFpd>"x*H(ηFС$(a["'Aw2lHYplaq*t3ft(H`$F;/H7)lOsęm>aQō"{8we0,dz[ X,?7MkrZHԦtm~nWo=m]3Qg10zH=;+VcA ꬶ`K݋/uŽ $O 4]5R"`ݩ!w. ЌsolY :+ tNmJХoQz+{I Hz O>iXsفnl3ui(AD"e=Ikgbi)YgD\֧1WzMx+|¬:3w\z6~=0#*KWd$(S${oj9.lDESA~- QMQS:l>169 d,E\`%@.AGԽS+s9` 6/W $ AW$;n+@J&tEZ$9](޲ Iw#HzShlSkkʔ7Lk8$zj{hΙYI~N7r ٓ&|#6@O.B][wIK/)/qz%S._GW] Ƒ+xMF h`ܙT3YlbTE%[L<gdy'|F^m%1xp7W%={gnJ ͣ@̇y&(wX>G Ow |sS} ѹ* 'r:CD(Kʘ= -7<ޏHQw0(U0@m_7͍ X ,΂Z dV8O'Կ(B xqɛ"C0"MI)U`+EV Zl2tqqq9'eK?lcTAJܬ̧Y|o`2K:+D\ >Y *//2]`j$ Cg닁ZS *uRDֱgn#~1pi~)LBV*yjsbHOUCĽbl!$]A!@ƊiNr?c׶rWB :mOu mTL< CpH93mupE4b fPj(qJ>gZ],Ri-6)vҷ5=2TAt/M|,r>xX!t9p?z_e'_:Sc?3jhLu# YB9&̼-X{b;d!1o; }ppImJ<h.?];=I;V'c5o/-}\tPx*qu(emLyG?Ra۶B7.wMM6W1acqbhf'=,0iToc$! zf} ؾI%ٻSw-2ڻTޫp`[T9 %n&"~`NTiW!HaIJUA&Ae@Wwdv|UdqA? L:Vb,[e\mS=^$@Omݱ|&_@j_091VY~V,Eu)]S:͒8F2Auu7CPUs:H2[EOL0-cz:x&{OJ, ~7}wG:Ks8ܜ:Җڸ^C_T%XBk˾`Nhsg%C@3#V](4K`؊:g48U*TQ3ׇ9x*&ՔyܒBT6eO ]/*aD.Uº{cf\:L{P7Uutů1@ߙdpCg>,Zx'2Aǜ``4qDQA\hGu9c9)2Y]V1!+mBgKsL^KHBvA6f4 FSPA IyCwo2k#\+. X8{cdȲ5-ʣ9q:%7ju:z8>)QTZc&ˍ?fgM!Hs Z{+#rtҶT¹(gdz/ePCËpy2VCm·vR*_A_]${r[os[۬ta|WkXl̛*Ji4L;o{-(b*Gl[O'/x.9O7K?Sj0xzՇϑ-E' =Ill #q)v&+. ~A*PռLlâyA`\V;뙰66٦A$T0rg]Ǻq`M&= Q-,̛LG`jy!ز!^],lMGiFH>U:=ۂIy1kK(J)Z OP r_odja9̲A\$8,c,_FT)Š LP"5),4o4CXlޱ2B&ret-6E~$)*!,'pARAP`2ОE!Fhŭrl%FZK_@OO ).iu(Hx-Vt?:`./;΂ܲGx|w2 Q$U@\5&+/>CZ(kklo_ ATMId3 a39z9A <<>Ozp/Riy+j$:ثؒthKjR,a"a+'#̬]]NY]E&Z˅X^^~ӭ&}Hm{f2h0KSgX|YCL9]g6'P7UйKg_{i**Rp+ Mށ0/+3-ǧyRθ|Qg`8 ᾲAjDQ>#!o`t7YzG4OȘ OT(?Bv=%Dƹzl0bLJ> 3br=ْA)&Vu0:=zЄC EB\PC<۶;sS x .Խ<$~m֎CL\*{r ,}o.a36-:H $@f!AMKl;M{?2x|'l1=: BpV!N(ii8n[gg@I3jSߛ.*@Uȳ+AovxZexY# |G.EZG s(1Ȝ4 76 +H"Z- xbZCW[qHXp9 V[OE%n+1(ea ϝqjBOT0[h|Hؕe'eQSh7^Je%MVut]{H?ǕXB^.x$Ԉvq!arVCLNQ uBQfH!hш,$ S}?t c, Q%˞$>&6 1Wuޮ%X&u Q>>B\\eRJZҟzЪn(,WM rV˕2B\'Vk &,J9 `Pե|ρX978<\~&v.&*¿\p7}A\yKio {{0}uNCmO0SI:R 4j/ԍPc%uOEesT`m!Wll,4 &M}Tٚ(3݈mY-O+A[ 9?I$Zr3lac}2_MDQm(US{{v?URۢ%G{MG 5ꌬܸGh@<[TF[0g$iU a:kG$=1Sgw,0ӆDⲼ0m8]k&Jl7f(:&>|UջdIeLbLgrGxr=7Kz="Bɘl1s>[?;^(jE`1ZIۯ\hvycY(kdPI$ 'zDѢW‡Yj2L:NxLwa;˅k/mmaoM".΂ 28=U m(A7FLnG8gb1z$8eTw˥,ݹS dUt,_01b'Rsݛ+fM4T`rZ.|1urˆX$&r`̣Z Ʃ |k㚭z' 7~G]ːr~s~$ddAf&ID_y;BT8C y& (`Eiq 6&>qXeҤ?ڶ/˒-DeӉO  5s<HoMm|60gN`\P'~=b!e69]smef06S@]EWTeMX/CIy裻k_Irw[ȭ=:m>f 2LәHOMOa5|vȐ."e{TL PK"V: 7yŘML8& \+G֊RBWxO֩G&p~z2UA8[G8[WkP?1Kc1[9:S`]U+st0O=WCq4Yb3yQD7ZnOLپ_$p+x%Fa@}ߠN[LF#櫿(09_LqTu8#O3hsExJ6cɳ:0h`Kkq1 " WΏQJ>x;I'58V\1ݻUI&zy($6+"skt̕~I7`Je)-""z;K` a&Kz~zhuS),ΆsQjLٖkJ)Uv 7g3.3U ECAˌ3jܴ~0׬ʠD8g `^Na{{d'ؑM5:gs;=]R*U4BbN^HLg:vFJLA V1U?e&Qt~;u:wFz9=&ef,2tK ;&q$/RzD(y뛮W8L:SgWnAuY&/c36jۿ;C>Ňg٩މٚk Mpb)rV/HO}M6 ;32DCv<~&h$#+b,r \`7ީN-SOY|bt>߱m)lgvS;y?vz<^I[VxM?ͫs7@|l1vqYgɡqCJe ْ4ۈhSn癘$N*M?O}oC?F7Fem]?Hf3ݙ12ߕr]SgcΦpg%8*~uG -NX1#a@eha}%-ך{N>qxu?z0j]hudAݛʚ,>i!wY˽ObKkώ5wtd7n-7KS9.b/[5B^NNYRa݂PSϮ.7MBr!8I EimAG=LSeѻԒ^f?{N^mUG(q[E<*sLa1Ǚeޯb'ҍ1ML;su!hMVO\3:\G\O`1Cc|[U;l۩Yh8~#ʏJQ0`:B(oS.wus7f/nm+ <-YD,þV,+{%Hg5_3euB"RߒބOx6וMJ%ca7X_PaCmuXU[<*͝ۮWS"b;)fLm2WS r&̂&d j{-G8oΟKrR}HbG \[дUk`lH@h LꠞBUM|# W@iHj¸ ,\Gy-B ?T]t GYa%̜38&%Q6c9xTIԑmX &ǙnO( -"iSʪ@Ci(TqDZo|qv,f)wĭVEy{e=*zQ;zavtԚᝨھ0D{ I&\H5q?($Z_.=u00k T>x{}-/gۄU@VvIEYft8)YL jREr#X!Oj~*{I@#)].7*c_Ox۸R9ӴfhYT4wOXO‘l9j4v6~tGhEx|^-q6 [Moqe7Niҋd_TTۗʌMUHLcLࢄ‘zaU0)P,,g(rJ'Pi+~_x0~Vb. _d];ESQC"f1_]htcߧz')g8pSk؈Ͼ[gg rS_|F3r~x]7':s`5ݗa_ݨ*,%KgCGp@=n2D,Hc6輈4T*Υ &CzȆs)8O|Xߝ&*>~I'/y> 8\~-,<tQ!u=8$ ieRYWƲ}?[]qJIV\ędU *5GY0d1TeyܫvJO ',@,Fʹ 'ڃ݂7$eOw* 74/O\qG\mkXwpﵰbD}<4f|n0$/}4noer"40&%JGqMȀDmqCg:tpPa! AqvJt>mh"s kic\G~,h8N%BnH&^-;IxB9""%*q>)7Vg_Z =.03e(\^DL#Y[!3)u*LAE?˜kN詶ps9:5t:Y9r ?~%n[8"%-Fy4 B%%{|z״qŤI[TbdۭN:JkdZATDz=o롍6^x=!AU!QLH=4NQ7s\ ΰ-ẀeE58zxo2&bp\ Ph Y*OF,77q*n8j)Hďt4[؈󇏤<7ĕ>̟ynZ:Ѹů~+i/eIlYZ{ƛc^]b&7s)"o4B y=s7㎱YRF]m )ȓqZ\gzr'(:%,v,&Eʑ#zq/-2g9qj 8(6?/6Uk>@3YY)$yI"%r`XSwIO[gMS<I$A>m`ɖ G̝M̰C$VS'}*AB[?X4mZkQ"u3O+x61'숟UyFmnpJؒgvxg׺Y<"+5t\3>*>>xD23,3~wׯPgxy}: xRS3(iB+YB)نaBnY`PO3;p-1_;cO{DRDS99e<@&4՜J=D jt s%q1@w-LLد,(ݏNʧ,Y4a׾" XM.?JQO(hY_|"-`MͳA=Sت+>Qm^˧ô:"|zP(hTT߫8OoDtX^T0,o~w?w ƙ輓U˥X}uK#:2ҋ%YIQPjD0 aP瑩dya_!C>~2ˑ)锡;q84d%\c#3@Lf,H?$O)giuBZ݊;YBA`w{ic9>禠5aueśLU[u|~wM3UC'RyGiƟ|>~hzeu"TVZSqeZ;EO^ޘۭB Wz`J F&`m&v!kLWrH\gnx\jj{6y^qiUF1K Nˉ&\jHHﺳEvXQ2Ȟ%#w1]xFܵ‹hK۠3f-a T^uZ ͥf*$S;~W~GT*eV'xLYLVX<0-dm6hN,WvMX>(k̴ր0`q'v x. )(oɚKDp_>U|  /%Ye/PL _+o}Yvq}&#4 >ԑGG]_8|O#_>4qIOA\~VDN"Sd~Aǝc> 8c&  /"۰]Í*9QN{vTzCN ffkPFod<0eM~ W($CY.jVYY m.,u˫437ri"-X+*韈?PN@'>Dɏ> X.3q0UzO0u?'$(ycШ7G]s׌א⮧9X]H_,ގ_,:,;;rZ {y~3 e..M'XeI<g"Ԩ3Ҋ0bWn;< 0|3dxxb/YT<[j8q^M\*׸i.p>t:Tsq\;vyS-^'_tJ?l(7G ?p.D(C}KGI95QjLU[kT | ;;Y,{-N0iX_X;T( "NͪNуV)IJ@Z(1khn2#m3O`,Ȕz&40fJ cϋl)8`LZY䒐c}d1*%DVl z#RЊz+Hc"@!K!+;XWgsS3*{u'W ^<II@x?Q<=پ9q5W!AC̴c8fr6;:cydI 8Eh2o3Nrj* a=?Q'`*K@aEU6:r2@;OKKmm'28#˶C \.R.nv0|o1x=/!o%/%ev41b _o\qU[?\1OrIWG]cbP"~hD?(=ϒ}5.ܵٺ7.7ߊ=w#R2C"F-m(TRDp*+;/ѥVFXѽˆPO 70Uq[4Cg;`|%Ve'SڞX*?=}{_WNt)ƛw&*jj8bgq\AjL[ڧA`NTiCta]fPL?F h~m ?dj>Bi9[GZfhtI7 i v&kNmvp80gEM]XBGr>><5;⮻mÈ$$kcQZ)9A=vSݕ r' vOC5w&󅉬.p0`kR\ <'&]2W](&0pd]B:}Ѯy#Cnq9 XDyVeeyTϤ˪CSmcK*|rG㕃+7HFNo,DѹQe#I } Qb}&cDl0ŻO(-!SQ%#o]|g.g>F `qkӽKvfyQTꛛJKSeNG`ļA w3n$㇀VI=:a}]ef4_ ΂VJ͓*IʘH& į}}yPa/lFpumǠO.>q]J~G GYbY)45<CÃmTVR=-De&"vb%ʹ5Q(Ql4ͳ-tP 5bܲ!;9_ yvwg&ĥ򥗽#WHް:i*'( *lW_r=zx[Te_\ғkrQMLsÆ3 X?FaEx6iM6 fTG/ fꎇό,@;p_[G3vo^ʯ^B8mn8:nCQovRʻ\x7O-pdZ ?y{ٟ{UЀM+!(*zQQ@6 BXFL%ۣTUH3$OڕY ߋi!a4H$3t3-s%[pRj]NxfKQlƋ)0= |,e%-k졫̠jzo,(z/%B$tս7(a[S: y%o]Hs5vF9jf D&{z#ߨZb6q˶ %×Uz@ 8+-x9;>֝c j- -š Z,D+ G]]hՙX8XH;f_oFoC0~YZӐdpߌ ^+) y&UD&*R9k94cUP0Lp1yr7Xsa +ØL3Ex2ڃ@J:P\tE' qN ]jostַݠZw7AïC\%%^rcۓp!;m~~ߒ hF3I:4{Ƚ{+&/%t=3K5xSS#^#S8x"MWJ6z#äo=WetL޼͋!n偕J>\?`K< T !ESgAr(Q"vD[ga]"餋\Vs.'У;,AoOS{re^D7|nOp~j+#~3S>Gmy\JYϓp_䤑;DD&r dդ>_`sFS/frЖpw c'\Ϩd>j07ݻBh副Xۯ|WhN ,qŽՂryewB 4vqpث`PdٷﳬJdQ!z9y{JUd6qp9!m//NAqʇ8gw%k}y{UHZ 80)U]q5RT@4 =kh5%:@zQ2(LUevꚉͥP^Դ3f#>@&׫6n--y(Ss؏U1qiآu j\P0@D8CҧH>u߰Ay"^sWl~çqaH 9s~).Z? 7H$5'tLtcQ+ת ivW뱖UJ1[&]Tekߺf>1OϾg뉀aAo7@&~ w_(A4VMQ@\µaךP({5u22qa ~E`"h< 00Y,j's ` *f't[ފ{g/\|f` }(/%TAˈf0 |jqϔ3g{pir@~Sh:bJ<'h^47r+ ΃FEk`^M;ȳQEKaMWE:Q@xz4{ii*s,wwLÿ}9c^_} RJ!oձ~j'®cmSA|zN n$ȣ|]6=0Mg{Z$qdA!n,ۣC&u vnR$H7*s51]ɳ;_W ~A [~^OuF6U9I1́e?RMq:=t"cgױ?9 Y{)늯&57\An+묮\~I /klSuj}c7bSwDz4mbaX2N"4X~(l*BSU~:ȨeTI]uf;fmg27fEUiB,*X"Q*O Q{) wA e< },(KlV U|VK0YSr%&9$#) ~h{`N*NrJ9L\KF@ѡxUN)?̱)Q E}4-}s::|z>_zq49ׄ*ÑĢ\v` k35۹[Vs0Z`\RU{3=skqC ^,}X9-/4NzןZ̠[qGwQ1l|{rxԦUf#hqm0p ɇus5+ۣb!CMnQ~r>ܒqXy+YcB4%E8j[fWx]ElH<'䏑M2;[Nb-|OaY]ϒ=/[\onw{Nрအ`Z?A ÌL ̆Y.O_ȞLê\GZlg n6ϋ2<09aO"c2⊅ 1nj-yGLGeAhZv/%GCNeVg0o=EkUDpzyhNʣ{gVaxVBVҦ<8XkIMl 4zGǮ|u,eI.C\tNZG:|fa(#=V?9;6I)*7Q8Q]}M({!-PnVfrl6Dm+ExBWeKFmֽۓt7s[~Nql#$4~0*xxrh ÂȤs3!ސReᓆ`50ndr/aYi9"c.5Z5Wx} $yB88n,9کmۆc2C ;_78w ]pj tӢ'&rt+ڂhq(s"՛QpڪWSYo2>R }j|<> GEWdrwd%y{.^ъBr  =߇$D0 d/Ni!UY b#Y dG<i:qUi\GaٽZ-o0yUau[!!冓'2? k= E4C{K802J=\h~һ]0oSo׏o.ѴGYO0xs=!v˓1W2eD~*4LhUvr(_|~ Gv^%户Uz 0D O*tas=NZ1:Ù隲6 '{./6$QazYoX°T[FxUXx(zU+@OId!!ëf싺~ΐkk9bgNeGo{CrsYpMRwa߰sxx[_% "ݔn&B¯So&jΒV܂};O17, ,r7A|t\PҰ#u@,mkz˧ȇ[ 3Uz8u Ew`;Gds˶Ieuற(ffAy v9K'嗉Eg lrCtR`uI+ 4I~*AnՏ OgHJB' V_ ă}*g `n0k!M]gYXhou&n_^ioD7Q"Fmު\&;dL) 5 ~,<*v7EG,G7-;^pL{ex^JUS"I+CaOv%i٩9̕}#_B0_eFb^r-$LN~yym3 %~R,ТßppQI)h7_x i. xpOquHwO4ğ]-y=0*~:Qaaپ[Y`UTO,KԯK*PMu4'J%OTn6C(~x"=׀'P V!8+O}~<8bW՘jS 8W+wonn/i[;==۳R>]l{vmUB p@o -e='m9}mM( IEAiTؼ0vȓDWӞ1Bl L%J'v=it}1 :1L(|(zD^pO_V~)w񷀯ߜT7|ҭi$Gm.344ʌE K?uy[[09 '|{tNavF*k*퀪t 5ٙp܍"5aA*6 !- Z.`7RޏdVR2f-5i/_Oж%X(+xKv:m(00rcZBM" !TN~ї>{C,ݦF8K]՟Yiv5^ ۼnB?2m;8@h`%-]?mB7BXnME`7K4i wGmc{ſSP-J\F-om8p  ߺYId(sQ\ZX!ÆqFWҤE#n-7+rfOÞO@-'-r0咱[:#up?e!,`4SيzoK0K$4G-ג'ޙ=֟FM㵽ߦ]KoiD_ v}yU,>&Cze?[u!>>uEhz,*#`XZzu)w z}{,܏g,7BY܄:%rRaPQ .B'b7s7c f[>~m#޼`  -ۀbDypxAEIc3dfn4$C|Ђ̞(ST#cM\ub< B8v>+(9r5+OI1Ydk$e?L韧/~,6WaϋM訵^s(8oG*FE*b&S"M^ g2VUdP>u\8| Ǖv4͡-5íssPϷK{iԺ;X0#m?=|9?ߝ$^iվdvۯzMRQ8OABX'TSBLy.78A{m8Cux ᅫn>8S(mNoֺ)Ei|#y N(seĞ\REn'҈qWه;(rDii _M12[eLYi4sDqK3L<]67]m9ugLa'/I3.,8VqDE{K{!vm2,^-M7ig*Łc{)9(n<5 ;nGLZ~óSTncT=´\f!(Ğ,G,dIh1bv{޵t#CQd_w%Xdǖ=ԟfn2@zN l*&_>h `}Pr(3bmϾnB9 uC˷Z(Zqn] ǽO{6 ﯕ <W`[s:BJ P[jD@t5sg~_NRPz:B/QPs}ӻrrIr]dE2]Vykz*8‹zXKqMɎ&qiY("R6!--W7Xx3cqP?#2'Q2o*=r.H;_ .e,<{v\h닢,˷uKw0!X~|98J-|^۩ClhJNK1G!ITQ)៟k-D驙ᄍݠe4g|16@r{=둛uGQx_\^u>ݶp>z6* !T0+A$:z=AXA_V'EZt/ tSFC;|K߳J`yfmNX`RFE5OvA˛M J8E t Ecâ'o1x\o8z[_۾UI,ēT'xVU0@@j͑xG#_ݝ2QBm=30ꮉoo/Yong: m~z 濁MC+§sj63m\p`.dlpه٪_4znڹ:y#>;vK}A󱙽-}ق9x>OJNB/Aο J[ ?Ӎ3g3姎\|"  i?;3DM?Il?lܧߚg|-s`r%̮6H!8ٌg#fw:kc X4V*ˢ=|*O$cۿずK\21,ESUc7d.b%͊Հo֤^F%{ bCEH4cw3xڎ%pܤ|*ApWS1_U{/uYr ?)&-ߤ`Жnk.Qh u mQ'ux ] ?!JENP̟[Y>4E~l~w~@Z~PS ̞ Cp4]nr 0 hJ;:[BM1t(e ̘yqQE4#*pnG%.9KF6OjfY,I?õgG._h%Zۿ\\$4tcϚ=7'jY+sy?wx\C1"Ы+؋/{<׽Npe?z͋mA-^[)Ѵoqt eɥpˍ6ls?=48u\MJ`%U >M-+voLgړmɆOb=Ȫ誺cjuO!{ x a={T Hcf/F *4\s( N'{մ.,p޽ D* , /h,OB0ePe#LҸ3y_MlwF6j 3a! $S9bcrxbwrwR⋄yoʽ 䨼  ~nYKׂ8Ļ]ߏ7 حNGm+R7?dkCǰf0z'X`ˍ蜚1{͓+'d4$/Ӄ*[?ICV_(y|а| a:&2ADcniG_yHYS Qk> (wHFsy[No$ƯnewvMrjNykc6ɼ}K58㌶HB < {3'C._)$8;M ot&$ᶙ?^ߟ> gWɁR ;ZuθRi:4 wc Y4 `=_]'w%D?|\ ‡~?ҕ{,7ʹ댩s,5b/۠ $FPsStsl3z}s\)(X7 rV^^;ĺGIs*Ipz|=oZ?kו5TI#IV r_CJAgU`/%T H*& %U-VYFm6(J(7UqosP_܂Ջ=Y :#Ff{~뗙td7]vEO&֍bC5:DT  w.);~/~# sdh0fVYɆڧu++9%4.pܤ~s$$?jU!t, @淭 q쾕%xRaAuhq6A~a;g$b&8M|$PGNzsxg t4 WFJ;uYuH)髄sIEX*t+^8EԲg-Mߚmקۯy`Ftϧ@&叏 ހ! t =˰K23glCRVx\!&֘h'Ci۟s^txɷS$MǓUn .5krβ6VϤ)$=)ǿ~r}la4W=wx ML% O=`Cz !ʄ 4K^j`+clQna =꼳ؐ9R\Ϙ

i&GEstD 0'm+7D{d**.p'YDHf5laeMYk^9p|BLJ4yÛxxwLf뼪k= cM}/MGf4LY$K>[D"O1ii97C ԍ묿"uPQY^~ }Yo"0f%cvx@`zVӘoVXqz׵jm$k#I@$h&*=sxR)^3a,(90wH|ryWx'Ӕ~7n+ę_;zǓ|wKܡ;ƇA O,nHGdRlSun&_e%19aE uTaaҥG]aW zTuyM6x5P6wYN>=4&^١O~tӖqygy 嵼Vv<%ɧ\.=Qp jkyJ+i H$oC7A:g(zy:MJ= -0]m)EGLI%/"S9< ǎb-!7[-!єi|hH.휊Uu+ ӬYB{d<*Ea6=f:m}n'5n 1 C~oO?#e=>\g\qZD94ìE^ph*y9'%_g ~8I=(XSܼwHQ,tA aЛ&8ڤ6LAnR8dK!x(!KGm4>ڔ_UQ*Y=1el^z?V84؊G8+O!8"U=‡>AyQä24..̞I/H㷏:CbZ .ϻ;|Kb/^c\̓< C j'}8v'Cs-6POPlRu*Ԥŝׇ rQA$iF\܋xw溢u|_Z))=)S؞"ց *)~Di6D͞[kEVuT EVvVmmϜM%ED0CՈUO4zoaT ͬHcju9lnS1X4El[x("{&իg`P0e2:e) 7}Ì<Ԅߒ͑}rĻF7ÿ~[~G:DYDysQXq{d_ \*Ș:Fș/ؽT\([V_|<^ϷܨR̴0S8f2z`bDSaA cd8u}Q_adGf?8z 7I7;D.xnYc{%D]C|(,yC› u>[o.٦agiMe5-u ܝt GK;A8t+ VRkBK~:cyl3_԰wG-v{9,ow %pŔtB`Z%姥[YKT<{ p0(syzu@=5I5}GiǖN^'oѓnF?Z@[0+ErLt;IhmD%,7OȄU"5;`}k&"Ǝ4 .?a/Msd/|@i>7c$./bI\$WD=ӉNMRh 萛2٭I aQĈ>磭To}$⍢?Inm2~P.1F؎GI}~)5*`DAfLˬYcm4G*"oO1Z \D.֗: ^)S>]@~`쏟Sxg:/{EY|ɼ=OzJ YB>Jz*MUG/D-B$.2MyKk³ .=.fc=i龜',KF"`K]1^uH~see96OڟAK#vI[p׶P~ (a}i 5|ǜ8YK7uO)sȫoZȞ_9mz53@@PdoMr{u̢ Go~n{?zhEC)do+M_nl%M>FJ > AOx+) 5f 21W 7uF&ki{J(GM~NJ9<̋%I-DVi1sZ0B i+V-Z;EڐA: -zw *$Y/\ &8 dfO꬘<dY{mMO PYu6k dAQX|䭷pM? 7gw g"tOY#/遊+G2AT(4 {2@S?#ڴ|guܞn䫏`|.|:8ONչU<"Y몉[OWUP*a(#g䣣ÜJ\Pg~͒E_͕?>QLhngw6=~zi4^.zaώ:IOs9Z:xJۓρ/]N['@Wd1>HK6Gۇ|ߋ{fgҫbRPj 0>=%)9L 5Ks-" Z\^=NP~?˴ЄĖ:23.,G !,Z -OEZB6f Umo=?&p\ !.ඎ] Zq4XT%p2WMSMt0.P~rsEJG}^N64*ΙnE|B7z2_I''~V;W-Twܜ'||H<nPSŶ%_egF[yIjgHk#{jx*&vˍ,AxGPSG *ة·i/RVߦ\]$m;CKaV|3#]ҰsEsv?^is-^6qVc:k)~-"؞;Ջx]Eh;a;<`;xmS/_w <{rƭ8 a8rQB+9WE{N h ˺|hɸ{[lWrI|}a/z imRJT5DiE 2+Ə᧗nZ)O7Cwu.T|sJQa+MgŇtXû I)0΄3%Pƞ!0߱RT1ps= ,TwLt;tɧ:u `#Š(0 ![3#rʤ!I\uL*Sees_$Et5 ^ aR|p$jŰؾDލK؈˾$oϼY {>kZtEXM@ƈ6oOEF47ۑaFc{(|C [ar8d~|gWuNB$0x-ɐ0I`'~ͅw*rECιLA#=w:ufۤ%|4S*R<+۶sz%!j~* v*ezO ] O.%MeTu@aB&ld/Tea'Cgfl֜VdW6* +$٣d2c-@v3jɼ/1uwa{? u=Dv:~0 :ЯF8[dKC)8Wȸ%6ls߹/>e9w->[> "-p[SAB[&nS4:!*o؊>͘++/Wϖ@L';Mor0>_ G-t<E$3~rn~RL(;A|`Bᠽ}4vD_݅Î: KIMu؀抛ծnDt{U@ǜztG^x7%矏pZ 3T:E~rQ*⣳(z7u3W)MsOr@w-Æހ_H Q!$glʘt^B(VD-p78/@E7}W t(&^Gͪ$TJnXFVfAL2+RA8prꀏGt{G <@-a +9 I\ԚP-FD<*8@3ԭHqu˺$iW0 JeDvaJЫ-NS>1*D qHun+ah*k#G0,!XdI2bM/xŋzkZXnݪ~xr|dgoFqq=٨nL,#zwy)xo5vwrLcgTgs 7?woiwd ]}QV4b#1^K8&ə9̜C}=mI?c{)(H>7lۉh.t^МwHZ=,`ҩ/W+ide|Bj'*܄Eؿ>FᬲO/[_b ճ{)ȮQGhy >G5S:2HLuKWik/Ȇ&Iցf<@}7\QjA cQxNBo>i\yMu>B ㌙G4aP 2,岵K2*>1 ͆C~ŚlN*Fq/31X}J/zӓF'3[f(,ŨNEzbI |4*~{;#U{nZ=Bh#}jn+R߇EvZp?ϗn  =BGVM#8 7dL4E!O>VpV!+|eԚY(m["Kd{SC ~oyWA1P`[~WyI>>tP0Q2Q^eG)+rpł-^+\ Ҏt^bL:6+c5mW+W0J۞u >d]]loe |ܪTB6|:4agcŰU d͏V{빪i\%]$j5@3-RUg;)eQ=`שßy,A1戈+2|.2]Ү_vcPb{d_ k8Mڪ020b#Jt@k>r6JCn/_>10v>o:p>4o/X&Q w T_vT|_xY yNAy kWIe8x1Wt][sm1|Ae3rNN]$a1,NYMpL 1.ׄJb҂8@TfKU:pSԘ2%:AbSӕƯ??욞BZ~r?)I]_}%*MD)9r4w2,T`$:5,6*tm/:m_6 y1.8n+߇'WQ(>FCG%.^vS|o}Apd%ybrZI/h{M'Bpayg.~/ٮA̙C} /a=8O1-]v|FI|%PlI2z)ފUs'*N?; >Q=͟/>+Ut :E^]tVAŎˁ_wviV}#M,ol >SIh785֛T2&]t.ގ^/x½$`p!%XXJ`>ėf"] {^' k3[>d΂+3Tɡ꣜K>uRqi tԷrft+K5a/NvCg{3&JӯDD-cbBѓ@Vłfէ/$~c`Ӥu'! Վ eSfŵo-$H>ij؃8\*ݥRZG^SV Q l,#[ӛzVyɹk@!?trvrx)PhIG]YtH$j2~O|x 5ZĜ7ޫ3=VOxn7lX,ɳ{mE WϦ P~?oX!bq0C/ jT S= Gv5<#I2l#ҶtIrRhgX@ [5K\,XacT|YnS3ގ F m(YPً,sRHX5F5,Ia ^QQ.X?,{ J~glߦB{~e$۸[}'/m ~)ktK lzݑ˝S7_t} ̾4w[,`Y7w IĈBe߀WV9=9pwzpuLYOo#xv\ߥ6u$o5?/z΃#àkB/vD+ieQܚYm OKk @z~x|HOoKrld"#*3QD )O9`MԜX#\@b"HQba&iM^0J9^{9 V!FG(f@B9^)8cm}:#pAd}=.ˎvi@DJ]`9ۺWCU ;=- mFv;]kw9ωO-ASU_\$=,~(mh6+k5ɹ2EGmG!L"UQ3bŵ X07&mx.!p*BHZ]wxpʞuݹim;黃,3Q&68R%1ks7j si qѡhe91[5,1CxB0ocXwC CTPL?,G"W cr,ŪUvE@+9=P~~ zj'hŸFVs5rj | a~ $#?"CU7ŋshI?W~|ħ?(S֏Wm>B+ U@%2ޣ}8&$]?kZ#7yB<ԯy~z_zchk ign~:SgTAϽt$O} }6i 5j^bM>Ȣ?rs#&h0jCy좌Ǥ.,JuF_@fxHo࿠5T Ldi"ꣵcTn0hn DӅ5`J.Bd,W^ Y}lQ_y16Y+BzUݑ1_;a~t .ֿ>nJ9bxZ.5nc"s*fKv+.1T5xI_%E䓄WǺl.܀qT"{y*9 -ϝ;}ݥ~Ip!&. {p_>?\z,1O'e"1"Hp$drQ=4ïI%Asg3AzPPf2fˉg trjHL䌪K1o%B!-?"*,4+iWw~N_Vi=og%Y}ኑOIr}z%P/"O յt^Ih/>JQ]GB"x#KDHrHBݬ }\])) ™3Q%oQyn{u||H6t%)!?&Q<~BЯF×%GɻyufI? <䧠xɑ7u!៺!J|fUzFISH&-uQk5RLasz؇t.(@hPY@]5\,654h9'{`G> 4L@.UeZ O6L+9Zd80H Z9<8*7-h d8 lV]~XCl(éZНuRS%Tyme'`6 r <Ǐ#('&?J#/Ipr˲35Z4d3U+ϛ<$Ӟ'pZ8a%ߺ}-~X&;Y_M8U7Õj4`^{_]"YQSf=ܒ\4Ta_b Ȫ !;U!Y]6* Pl  gUChXtR&L-r@ q[(xEn/b73Ëc7j/CjѵQ7rU)!cR??gzP/O]y ܺ#ɩrŗ85aN ^;6T)aDxlZVLkˬk*VXYK ̠,eЃ aO[o^{TWY0oGҮ!xI|i7B(z+`$2 KCfPU v_n7n # =tϳc΀0]MvZS#/{>M#AvY^+V]R_8H$^Xi[Q 42]ڙSa9x:*cW_-9` i79fװ['颣F) İB "jY6 i(-d= ? lH+[ TGcVnd{7oIz:4qպl:LE?㷜x,iQ_pYrNIehY+75e35V[mtgX\^C4_j;fd$K!TV,`̜I=9*MRړnPA;+k!, 9zlNIYvâ9;lڧjq%{AՒl5s H"#pc^Y9d96_6Q;̼+(&:+x?+=,MzIaf ITȻ P_*W__n(Ln26`Ħd1wUÚ eȲfR. of^QJ5Э8y}aKϭP@\$,CRχtyxEʇy$N)>Q{CPk|AV}WX={z26Xju! _eɷKI__#,# G "oMbJ†:lxǜ"pGAv^N;‹oOޝW&y}ɁffM7T9r0k&ƈVa"~979W9d:Fr-L)C8"avt7"u_粯XK@V)Ry zǬzeM@U_Li+V}+&U8кPNjƀLZKrv=))oӐyplMykx~vid7OKҙsEמH ~$/8= MF*`(j8r\%QP٧iK遧*5 CqU*K{W:!'bʥq*Q0PR湎2']tle-k٤\uUЪ_!^ %9-Ni"{yM:|$Tc6Zb4|^dMf*fgN{!gip_8]6K5ӌe: ;O^hB"o!^+Q,6Slp]q͎ `Ke"`D-Huo$J8lӌLAo_ͶbSJ݀`#lqOzmVPm:DSRVvM5 $\Y:،T8`(JNh[&5dἡIjY#@g(,ȸv>Gx E]ʩ?P"{}YW'=Ǘ2QsMnA[FZdޜMnK/tgw12ˇrb@y 7[6;8@+{t+[&͗.Iđ0!K&:pG"xb;=A9B"T9kXm%I-iA !*+)ILR1ՕȂHI!XoT/*>!"KK{ֿF.(.M):. ӭ}zJ֝K875xB}. ?~xjy=GJwßӯMl9⭂ʹqI6nTn09&֧O[АU+)VRmV&4 Cˇ݉_BƊ7'[zW$Կy2ꜢE5Pw̚i`55)%:!Y/{!̃ܝiF!1J1Y SxM X:ѝ=W&6z,I2DWm!k"ckܳy (#T{Upomc`̽ ]d_ 'I9NO]~Z8d糶h^p-EcYѰk8r%+8TIC#d%=麝jQjF$ c%x6/ *,m5sYpu 9Y%TTޙvJuc<:q[=ͺD M1|9Xt/{mp*?b߁k0>3@ vGbZЙ;/!T+J^ qߛ:*{PlE==sKj<}kނeE0dn̙w)Tp|Bh]pY?.}$,t/Q+sG>LgtڡrR߳vfod2WlzsI05ULbX;i`3$l6z0]V`G*I,NaGHk/]w* Vʣ Vj^[+9S?mj:xI\,d<^Xq9b*TU 'HV+ņXM)mvMWA0DXDtb1$kXWP.`J&ФbU@׎J5 4\3i (dFs&Wē K%"Ļѩ^2<_w ѕc4 )>CtA Ҝ-G߱}.vូ y`'P*RC)j0e-LZۑN}[L;N- /YvQAEY諲I5=oX U˔6mv)]4`"T[ [![+Zgx2l^x;(+}P"a#T\>Dl(DO :u}pL!k Kpq jbƛPKPb1E\Mqj@}P|c(rX-&#joZ[Q!VcE0 YE6#=[bHxAa)9&#Qb!(@fO%HD816#Y Y/H>]yFn9J Gog*x7~ dplUL(ʪʸ+)uӒ~UY.V~%oh5r,PlSnb8gڧ{Hl*X -7M͏ '? W} 4/vw[8`]6k5 A*5/~Mׁˏ&[d짺˕X-uz]:nQ?5Qg֙)[\(xS5MkCy)f]GZX ]6bY"!G7# 硔$]92Ć|Edo`[V%]6©mp5%H1ËKW@j8*Jp"tBƨ7fU6˟S',à%[hP#$bi(u൧(dO S-s]BH& (=X} H YE˶6Ur?m)=a3F5ܕ-3Cd!22psa@$ 4bύK ZII7YXL^FYq&nzI^ՑDzۆe#D !)1 M]eHukKYM􋕠JL.l#Mʏ,)#ǵQu*/CzdžJN.QCd.B\#agIh MX *_e$UiD9_K kg+.f|?ִ¼$_=^U$R<4S;Y?uujhXAhZWku6ʳdZW/ILa(a*RˤBK&#pЬE0ef>2phdC #סholh"Wq>3X8.LG9lli4bv;G(w- [YL"7*XKH:jWQZ-CvzϨa1)jR\B9w.1 Ц_al5). bFzg \rRUH.΁jԒ~Hr #t%D"# 2a~ef˼:\ U@teVvfe5eS"3!lI< 5Z®:`k_&UXfuR.IsD^ͥQ< ioۈ&-7IR ([ն  e7.fe)2toFvdomJa N$̛wؤzm6M5 ^i​y,EYRR>A;UkKH!p[]bC P LZ7 A6D@ J`we/.jkFWW#_ W W)P# r \hFȜ5l'RUu 3o~efSľ-װI܄s?89+{t.j:z=5Km H \ĺf=MգM *Ē#|~لq4C1SJq1J4 csu>S,s'hٜt)3I)F)(;筏!Z!MK72 eph3Ūֶć.pHl(ۤx\>Z{|7 X$>tZ6QtwUl[hIPDJ \_|hj%%uJ|2Yޡ3Sl%>Z2UY_0ѣ]lj)DDt=H Z]"Q9Ck#yMr׉OUIנ4.@9"~Va1cU9 kUdAI 'hň .f^A6Qs&kZ+/=J:2:44e)G-x֨t6k9hoGNk.hE8`MZ,8Nqxb`;]ʾ,X+ ȭGF5+#~I,,LHHO+41qTG t\\L#`%#YlV+ 琲28,5ym*eAi];uVŁH yf(C6Mi2 ^!lYI o 06 ܒאW [tC4S:XީnO/ uf3#ϙ6+q/Ad=P,XQZOcoݕ"JE.E'`|l׍|>Pg_N2x\7'vz઩6L!Y59T<- %V[z$K k+u>u.g>Z.R.*M2;ĖFk 6JG4sE-ohR 7󗅎1Xe k@ăv0HuߣN&Ip^xPF?V8X0bxbr:oNM fG4Y2KI,ߟ$Z*4ӼRFZ5Fj򷲱D\kX>K޸TŬj#lbtm^1q2̆&Y:.,MY"bfSil&oOĹ+!ː#VFܢ58=ULn0;bkFk@L3͞BնznsK@z _˹ Ubla~EeKjC[.7g(J[)ZKn2/=$8XkZ>@k V鼡A֛N; kZ7BZ2#`HQR#8Ҝ}Mɾp[֬M &LYȄtR:L$s @QuKZlv(LB&u2a\% ܩ+3mvl0KTfm9)IR`5Tn~}unm~u2~JCMm);v9%7DF(3b%Z k0SZ{Y T˭Q*@%vZ C>X2ѳ-8H:\{ݭZl mShໝ]S%SxmHpãl{trFEf`h8YH6yݪئ` w1ׂk@ˡ|&*Ģ=5+XSSY|KUKBqūCxm_ JڔƥrR9oV-FKFDEЙn,PאUҰb㯆ڣڍ=yDBrMXmX2 6clN fJsΥ/6%@Q9P,4eS%4d1_ kYtYFmvMrZf|W#) u& i;lԧs"Z,5zc'Yt9/5P"PB dey>Zf+0(Vj2̉ƖS8xe=dk^Q4iZmMje U(Iz@؜A%[} 5L'=5|(eǭr^C<8J Skyf;cwx!ju<cO6֥ b͛iF­eUՑJ JZc r w;RsjuienkxR6P:,_d] wߏy̕L'l*_߃7be?f0Fc"@FZ=$Z44p(+)PCnB"r4o:mؙ蚾0` .T3uWZo`ت2/ӤL+g+%>eR> tdСTHё]Q If8(t/K<.&+ p:hq=~ljŠHa|YʌC!2PCli+?T*9& ZK8媱*^sVH\ Q*Np>x–j2 rlEٙ2ʾiTFmy(qkrl|:^)yʈ?^؞5CZoQ|ŻFXoaYV*}~ŒPEk뒕l#ȗtœ|>F,'\ǀ5{-kR zOuJ?G&GB/)Jy2<$7=P[>|m>7 ;NQ,Ս75/0W\da` A 3U۷\{jo”|xub$ QEyNC(̽_AN-W%ɀ)сtw#r#+O*L|Uֆ`툲cGpVfUp}f:E$8lBܘ$1^qX}HԋR#:$R@|s5%vFs}Ub tqp{ +pE({6c^rNxf\bc)8ft7;_E3hEPL,lqȕʋւZ[㗱q]~է1 ҕ*@tsއfJSMQI%4鹽aǪ YжAq- k]/Z\u3[3JmО k=hFAeʙw|йX?d4؃&ں=L$$${Beܩ PkbXƊ:[:LoGh7]LzCCo͜mJ- NaSw W׈I BO !^ PB̪NO/8t→(I&j`O+0KvYj쇯믅8ӞŵZ 6vv)fT_ Ə (vi7vv:s>f\{,isw>)- VՑe\vyc@o,7721jAnV3z͌艦n.ç^_pGk8zȺָIvOwn9Ul{{%o۽|@qMBEagzۘnqWAKAniS\ ?> oРspOm6,n^=4LXٟsFz+W \Haۄ֜쪋W;s0Msh׶dʨA'/xj1ڠ%J{/öjѸFT8/7cCIh` k9GMxUoBmA>D^6$~ln6}F3WswsY,2? |wG;ڋ GȢ=27m# έ@w '6ԓ2͍bu NvR VBO#It8|肟j>_LM,tr+Y6`a]CPi{.<fTcO]o?)ГՇf[ɫebt`2s Mi:׷{f3 [u0ǵ<VH]YX״6 pTw. wSfg7~ƺ`#aEd/ ܧ4UK6svRufɑmfo SoeEJ@b@䭼[m疖{WG^Ə~zAVf}NVKĬ͎--_6J3x}91m_&s$%]fnmP(=YVKxJk~urf])oQi4$1&z`3FFYWMWTnʊX2UT2D$3.Mc ;]yS*kHqopƟOMT&9y1{}ғOZ?@1*4/Yk Tn_spL-綈}rAsN[=7+k(siRλڵ>Ȧf򣦨l?g%UYOG5\ͤ#-ն\g>V{3|F[: ĿQ5U} [9go\,7am ۳0b\]^fͳ kM# v%e4uWozMdL8KV(: s=\;| v[0b~rLОR|9ngyw,0̬v15 rDVƃwZܡcW3Ao%ǭɶMjOd5͍]{~H֔kUoDVW)0i[?T\*{9|=Ft7TnG ;ד‘7MZcӴ۬|m9Eks4p9?oI[¸+}%Cm(<8: ^MI?4 Hn{yt&kѺi] EJnAGٕ8fgc,k4!ˉm/JfSuNK}e5Ԣ!t[a`,=F7@Jgq˻hNcE(ͽG"[٢e]˓o=}\K F="rfF..DAGx]9܋{qsʶ^PCkI9g]d:BlU"x tcAU d%ٱGE70ЩEv쫫p\]odY}-;uEON/{uଃ].ԛ%ٹۂFTjRfRjkMnȱݲ\ b)KFLCGWLft5Q{)|+-J=G{a+FݙU1c{{t9 {s-NKs~PˠNF;qf 1nFB۾QUx=9nr`ɹ#9 )Fbc_DuSwg즺6ltBh>O^R. %}i;zr4\򅝚hNxXN!}fV"՞f1\Lτ-heNCՐ =ؚRY8MK@n7q=QАk{Ws'%oiqnEs$z:kChjfjF^xO[u֘LlB^+nދvp2AوmҙSK<|&l"Ԕw l̯I͇8uoMcpŴ9neZ峅yVpd ׇFdvO5Kl Y-\,&=/jlO%#A|~^v]7?ԝ;yX jbo{'W6-$eަH7zR0b] .5k@߫4l8‹\ ba+pd,( D:޴Y/Iifr`Xlʘv,h]aE]+W|o:|$_Qk"}8Ra!Ύ\촿d=U6@ׇWmqQFz>< =f7x\e8z(+UڟuΜHjo lQph"^֗d*`U g6CaYYkM- msTN&)VwU;Mr:nj{VĊx00 ɢ[|ܽ&Eq-5{fqGoג|YL7]ы~<ҫ'5e\jk6-uĚKqA/w7_c[()+k]ZوJ7[qF/;Krif﬜K9gcf^=ӣsJP쬘]c/`}fU뭦՚ڏoJgr9Nz%3۱#gKg'Ca.v%9cy[;47aRG}46&lޒDɛJo_Ue;d z?1¹=/d5Wsubkgqs`8Ҭ=ZX.c{n/8nwܚ9 NV|tVF)f \+>~!8٢{.5R|LGN(M+]\_n߱f9aiY*͐2c[sRNS2~/URtu[X#jaĪRF5G8^sh'l0cMV> yW9Glz6x%?2k<ݯ5l!tk!G-ѳqqx܎q˳;EQb+rzξVSFFo_Kw࠳i6 COS[.lnWgXli]#w;<[^b❞kYx7g Llxag~t A SҼ⦽»9 iux4w;&|#3sD`p+[-*+3oV*W~p=>]!n8 >R;^Cʐ/1/'q\Ы hBKtjg:F3^:z޿xwVTs;[ԩY7MnRn{Nuٛt٣9se!/tf?>u'eu/7# or4^Iӏjv}m=_po^8qsRf<ͷRP FF]Tì/Ѩ6}.6|ق EEiGi8nB;G,)\.Bw^ΤdSV}xUgącvO^蝁%<- >xƊ }ƽ]"cY=ˌ4/L3N_\Z[Ο:o: gX5ۮq嫢][-g>o괋Z >u/u&vLebQJv8{K'=6]W`_Rpln?MM ?.~T>^mU;{A~Ot%_u[i@%;wrݮ8JrzwoQŝ+rs}$yYfdX{ZnKa_Rxu[>s_O[_ͽr?$O~ J9?ʞ{\-塲%"6_\zv_L NnyeC#~((vt.^DmNX9{%5ۇNWqDnyL2yv9~}Aۢt@밶ޗ/.YIy`-ԻҊ[3_aD(\L|~>O~O I t-u,+.6+KVw: eU) ƂL74Պ/?APw3b](B2qֶy-15Y%!NH=_'hϤlKՌYxVY'鹕OblcK,og/n57zOoy>ROݹR]:4;ִlsgD$~O㥩OebKn?/7r!F_5¯r_kV/ |K!>[}wwǕA"qSǺv >ϭ0$:߁F_y|Z$->/9ftǾsW[qib+P^eO#;-f\ndSuɋeE۬Q*kqq3ȵ컕;7?.6Ȭ2<_ڃkekqx?au<)\g͚YزW9OT]G# ?]D?cy\ ιrt2x%뭉йiy?%E۰UU8tOtނ!츐4;;ŘwR8J=XЙt"{S1wdTشo_TƛkwDsw?Fcga4ZWX/#o/7;O)j RaCb7TtzqjYjf)h4e X +^K¤g)FL9_T@$Iw|̲!2hk cZ;9 K$,{S%2i.tU˙s\\ G뮽Zv;1as'؅8{k[򺋻\svܝ^9 (~>fob=z[JGgboڶ󩡜? jΚ^ꚵ(s6_2$fove#;"昐v>h\ N} :\ޯ{eCgTVO~L'|4i8\7 $z97偕9ǖEgCգ< Kiv.(DoVcFxu,^{6{=]]lz;?+M;7 f[*0[e_qsv;4 ŗ3H~ۙޟfQ?vv~ڽ뺭o T͋jN>,rYqՍ\=NKs)ӻ Ic|&]g_Iםk t|Sx_UQƭN_b_BfבyU:+%KNLJw<*0&p"CpѕS~t_u}ݕ :MۈQ0w+ 0I{m G#Wݧy4W}*HaWQܤiyByNeO\g_c7{vweh^G6u)am'L/6gfT֝ x}%| _SspU쾚{ԇ!7@Ӳrp=>/#1$3ʙҮ<.k_@ׄg]y'krq/޷m?qws%g|q$ӓ}>[x<|M3P{bOaёZe,c8,E7V$ FҹVev=g\9lm9^;{~/3μ_9u-8cSl> t<b Y|Qz|OCyj-d{P{L3y}g7IO'kޡ| ? [wgaZk>>1wt;~ivTcRCI!::߰;דӇ$'=x6rl[6"}=饥1a mF\wJ|un.:V%-wN t +óե6| .^fxNƕ86Qe;ƥrރg `su{lmX>ڦ\.OZ{,V"X)q뷴 l/s4Z[Y^5 '.i캥V Iϙ??oTyݠBzS=t~^'g*QYeq- ߥ4_?QwG܁s|%@q?>W,쟯]Cݞ$= e=/Wjw=4|m_-o-tnds"ekiF|;6G.V,\]HV{< 4#)Ǎ l;5Z߁5sim(PcOC mkW6NW_kOtbx<'3;3+,xޣlo/p;z }_[CC۴{8|Ɗҏ8-xmd}ipv7/='rfݟgyWWD/՗%x25yݛL%oIV8tSsytN{ܖ2ty; N^3MLhvsP3oҥ>OK?ӹlzܟ7/ B<~$ 5w 7uG>ͭ~/3?IO7w0yr eڈ7wfW߉Sg(m~יAXz^~g9<)iߡ@_2z3OQzϷ>  p:g8 >Wi!;ۉ Rnc^~hAlWs,:uy ue8>@}g?g୵w DK~Kd·/z F?kW7KwK rcKG^?BO"Og%eW5r_gO<@y o<.$7 ssik~Oф넇Y ֜>'·_-=ƤW|iN !xa_)w+/m8<ϲ/r [tcz\y5}׮?׶㤉y-fxϹSRQW=Tо$o}rCC7z쒧%?'>_]{u_~w#S0gz׍7aft}NgԿw^3?o";yw;Tη/};<|'mng#\|\>e;gw?WFmyC].!@'{m?K|b}]>7^uPg7GG}/sB:_*|{]}3Z~y|݋d'ʫ{ %O31>^Gwl~罾lzN~74/0?ȝw[x]껥nN}/¥ٳ?W~}>jNzH{:^&huX:/ ߳<˪~(FYe9|zՁ \D!Rgrv;T@N/{;?YLc$OSGn@r}[u/ߕw^&,ꖇ[sm^<>VY?{ϹV_[KuTw?S'o ''c 4k\oN^*=cZڥ 'eB_ɷLym~|}Vݯ3ey~ gO+}Kmվ ٿ%=%oK{+WUhe<W]r]Ͻ<>Ow5;Tx_cu| ;OUxM=>bj?S\^ߪ3Ity7P>%kﶕ7>aj ǭmR2>We>]o/u؝]h/._U/gg&->;_gɟf-}} -ύbrK~~+ė;?<>eO+Wqsnx?|K,qWs;_G{>:g|^tDРCG|GAkCϵ#ւ>Pz~@?]30vAqs4 ~_[bt'$[{Gf+ҩ|4lTw/o}X<o>~~P?a#?y?bS}?yϳڿ+w_Qyߎ3>]@ۀ<~`O qD/Тn%=iּ.gMySe+8|ys?3W?Aş׺R?tA/JZ]b3~;؟|ON?7߷wS.IV?㪽mk9*h~uoUzo}g`Ay{?{KOִ=zyx7Gr>}<_q>ϙ%o}?;󹽋_C{띆F|>NZ;{?_?/uOp;VKK x4VPLϟiW^/~oyO#hNO9+?ku91sŬա۹ɗʣ?m^s/[x6Ϭ搾_=7xⅸ 2_GD<lo2 h=[|qy]O|/hK>ы;}}yoAPp񩞷l~vo|E q?'}}bg4?P ?2 O80?&S ;n7~~`=;&t&^Uv_ ?k vOt/~} 7|9JUC/hrG}Ny>f<۹1nz^q^W3mU>Sʄ/GEWn:\{.;>q_7t }~?b4~  z5 sxalO`?.22c{lp ڼ77~p\p:>Ͼ[+q ~(o*`v??yyZ?/?w}oł_3C_>{{߬O?q =G?/#'OO?8|C,˾>r_<n#9|IW}$?Q?=v7$~K?_?8}]~Ww<ꪧ?/G35օKk?sBU_a}_cD|ϧk3U?G񾗉AO?uU!z?O~'_t@o__+-"Yo~0vqeg@}v~s)#D8(~k(Qs1}T*mʪRA~EJ{DW`^*%?  H*Q"¡UX¨Q "kTV)*1J*فIE+xFV1CC# accc XŌ&0cF0'*]>"&101X–0`KQF1P%1V0E1b Wp]`*X1c cS b10&01$c !#*L`c1cX†Jvk7 ోı1,b,b&0Ĭ`1IPcĬb!XX+#1UV0Rc0J*v831 c"X0XXSUc c `+`XEc Bc;0+ m k b$cc,a1c11XJcĘcc `)1EĻgÇs©511 cccP)1Lb؊Hc\(ofa.U,b,bc1¬aTc!ULb121YN._K11Xĕ@uV1Iف b!Xģ+[#qxwF,aL`aLa a1”%TQ]O:aC1 @-E^1Hq];wgX1H S6j)Q 9R` pl[o}}VP8m8q:`nj1g c m-lMyzy.Ur\ZLqIVn6߯p6}u鹅TsU9<<x n fœ+QZ#UjӿGHxzEI:]PPuZHwIX.C@G ܪH[74(ZԂ;vzU 7#tۇ_G*xPH}RnGFi5wmWH:twp Í|@P\S=wJҴxB ϫJTk^Mr7MNEjSM{eE.`\褢WB~_+`VnnSu[-m.{@S\=:RJN}wt6MbR25nP[VszR!w]Ti5kWhBTjӎ2T+4!,NwE,<}T\oթ - 5Ϲ%n-=.I7{o0$锱3F4CN^vhd;',BZ\φPV~PhFWwwRJL kR˿ZE+qn7ܤK0f33ǗJIhSN_EAtҝ8ߣQhZZiDZ5 ZR`LoE)Yeˍt$7ݳ{s"n>im;=t5߇ PN.{4M;.^~jo]~^U|yܕ[mʊS#,c?UH╅]Uϯ"Į ^rw*NШRF}*q/.'I6qwJMlM8.|( g? Ycx|I: =_DtJuHʬlR6VzYʪ#5>_xG'dQwRV:s̕eVg7G_?U44qCDVj׍NWq\[*W3\jRkVDWE>y{%S2e9樹KKJjOE .FU8K}|œ'֒u9)<Ir<>™793,g^⓸뻗穧fU;jvVgT KVjUgBj{p88Ǻ$gϝ@jZZ*Rtz{;g(q,KË=y9\,9)Î3PVfy::Qis{*Bt8*,՛86zpmWCn*XnZQ4ZtǫE׎TBdy|׿Fէ<3Fk=8wp7~\K̈ȳY ׇ'\\)ZF9e}e3VL;Qtt}h55Ͻ-T՛AeK4ˮnmbd}jׇFo9wQV*2kW̗%s9fu>;UNqјYYc98MC+[ÇsQʜ7<{UVc+Lץyeθ>3{Roܦѽx{zQѫX/3LNӦK].L˫o[n޽/.~8S TwK]0%s1Uq&Tftl]qGת&8G2YǗtNxoޔh9I!/U]>'ot)OW nlߓyķoxVlѽlv۽]";de5I2JPb/#Wx("B@4RU4=PR Q"HGQ%:"t O-ʀEGdk:*jdYe5Z՚@Nkiiej6mM0MTSXb/#f 42ml6XU+Tր[e6իVTYkQ ֝dٳ+U*YJ mm(IVԚmXHCU'5Xm :$mjTjյMKKV Ml*ia :t:6ؚ թ3+  VUwgDLD"6dh" lv2)t$)U E ҃.iЙejiu5 1mT@[2PVVlQ@WGqPjPtԒ$P($*U[2R(*@G#H($u T Q@*(օ* @P42P tӠF((@(H@h P B(HH*E)BTR @(@A"(% JH((QB(mnPH@$((U0LL@4 Fh4ihhOF@4bhh4Sh 0 hd)L$Ѡ=A@@SI=J~zzh@!ѢG=@4S  hh4h A4 Mb Dhj2fL54hF4L y4̧LFMɡ&SLz$a>?G̿;1c1B I$I$I$! 1J?DDD3333333333333333333333]Z:Zf홙7e)ʷ{DDDDDDDDDDDDDDBb91"""""""""""""""""""""""""""""_IU?Gc,?g((((((((((((((((((((((((((((((((((((((((((5JJT@`|G`"<>?dyoExr2r3shU*P*k$l5v;-m~mnw[?콏ه~WUNާ>o_m>uy{}~u~6OE|6o 3|6l &$MUALޕ!TCI"54h6n!ޕbMD D"TQ[iu)V/ki:bU_\}5j)& ZdAAC<"FDA`Y vh၏O Rkm'j[8L: XH ;hձ(RJ:ۄy e-֎YY.lZiDDrF778$rR$9:p $~h„Ŭn1 "iTZiru3HTI# nJH(TRThd.m^dz|Y#VP(J-V҂=&j DrH1Fג]$[ y-24Q$ LsUVnjUmm&u.qztIJS-PFQQ'MըEtD'1B#M J#iL5 5b&l0jVXf6i~ DLW%Q^W^T=thi ťvD*%^#i MӐH&cڔ,IN'@[,2KpAAXcyK0iˡuUv.[KVjH@&m$f,OuB:i%&h]RVR5Er4Am* vúf6BSF57|Hc9e*nqQ`MQzgFS^!T*,Vح̡"<"ȭB&A(]`#LR,\)M.Sh4iN:464t팵E.*K&M$lu#HC)k|q$5P!|p  [ לqT/x1/r8CC)\ //zxZ+-ď|5 %gb=n K!).k-]Ӯ*--{|oi{窍|.tQ=GjҶosA}yb/'LW%U9yg=eg?|?{}cωA-6D!3Ŧ@): |o OKTuW,1#-&Ű`,TI-(&/MˆY9Hn6.eRʝf+b) UlFFSA؄2`S8g $r0ܦ Evri~Gzh1ѭ}Z悒9BPڄS^$S3K%RH 2!),U 07 TNXaPmuEs B(r1TT\4R!"FPhl ѥӇ"¡< =UVj VD+~ 0"EHp∫1FӦ8B5U iw߳A8= 3΍hbibR\vcMIr0DkF(q!(E[5E%5i12TA .9lP6:hkYi i i$mJW}%Q1*b$Dp!9XmtgoB 4 saqfT杭bnQYFA7Wa :(IIu!HTtɴS$D،L Q֍H1 =&d$J:/mRa5 A[RBF^iT&VʣMB((mA*3yaHAPAlJYlYB;4l!u LM(Zc%H)]X|݈i"$&~q{)41&' NPvX@ua Q% R ʬI *.K u jFwu mSb؛Yhh8OPny>߀lR1P `=v^A:싻x* 6H(ڶ uDRERAG0ɨ!wzzOKȏMUs]@n / nR# 3vTI(O*pꊵ>4;Qu g$m 'YH0t%Hc4m鶠0Ć6znݔs42ŕe2tS l%K"7u*"A*v;TTEa%2#fu6lAuJ\ıvЁ(@E`2E*Rc@hYeI)UCA )Xi*nХj&*p=&L!3`dĴP2"p$hd{U1h=.C/eikl @H:9(F"*}- 蛤؍Ph*+jMYmFTv賱#)q1) {Ңp/OlJɪE*&T[.cօmc͠܌Tm!/}#OtԺ&NӔض H]Or(-8*Sgңy$->u˵eauAv.EU+tǒ.'`$J ;#QNr2cEB )h WB$^ڧɲI"[#$z^(TJNPdH2ȭ77Ľ/:DR#q;4J/WnIFՕer#I VKRue$%8} aٸ4%7h]p~!hY"j&CB4>ʀT𩵺IU[vj@wBв!B۬xvWʇj2q*~˫xSHW^YNRE/jte*=wPL]͗Q[Xiy'0~ C4a7}V_VV=f"1RiMBJ aQTQ–f?%El#>^"g7mYK9xڶ*!!5(ÉA-͙'`LK((cY& ,4M|}|&ze-p٫ܼHSsrjJHtvvT>VW*E[wKYٓ;,溱+ =aҐ8I`QԡWOHZ'=>>UvݮR/N0 }MF*1kJ%s{MnuD0FqP{ ߳J9uȥw'mUصgvs͆$ S4a7[H,J1 cM{gxhS3 ^=xĺ'[SYp4ԞfV2 ;(MDaa(Uq#Y!W?e~Ya08N[,nM׆ eV\J{೗ą v8ZP'[?Y{j;Dz98O|ٴE#Ib.HII %P%睻0(ĆGU;6ͣFPy]8P;Y_/a\MP$" %%If D 1-u}m2 }}}=|#Z |g\,1(zrG}wvsyMj@)"Tb5 Oj֖sg0P *$)ՑQaPT`]fثI*"@$ !%V.דg{¸Uf=6`2Z"d$ڔې2)P8^5\[NriC>+vq|H @],\eyU̳ b@_UYlm 8* ڒ$/e[Rʻviaut(Qx],VWH|ITB1R\d%TH,R:)'R_ET©WdV%|YK s5.oA1A(^z< = Sz(d^>K59%[7zZ% .L56p0t[5Fۦ SvaQ{Seo 3BP%m :d"lIA b ːO`ʡ*SVv i֐LaJʠk95kOZ)@cK 3n`4u=2/ (a~[s3D(r V0{!לoʤ){MxgNb\^7{Z4DP12fZP\u3/&@ )ۻA j8ݵ(-V]J*B=&N1dG#GLN6º3 d~KHr;D]!eE> k\\YX9f$Y0V[3f|B= "nR.vWg-$|V.[72Y4XVQ$4% f# .jT(ikp"ZWJv7@@ Mk̛ߵU8m}צ΂;Q+́*cA:cRp8]嬶V ),d":<$8=&C1I -o IyҏX(W$βakdPRTd4UmotiMCNp f:a4 uسYN1bG)OTV-'ˠ4MW`p 9Co'1R_9`*YM8뒵jŘE!X ͮoTQA A"7sX3fŃM'cŽh!fLh"۠tFu@%b%S, R稯Nw*J,|;zt*CS$@ZSZ.Ӡ*T- R&1!!Tu2%g{h^'ҏ kً2c:e|i{?C]AQtݳһK8qV=*;,FUZR/D|iU aL,ܵH N,RuJHG}j'7p9a2`>(Th։h!rJ%ߣ{ԖX ș2Q Cdi( 0~щfe )pEu$uClFc.@g[<<[WWUk;讦]N4.Л!@̒hU7'm;|hqo;ɯ +^Za3NL I7i}G s +:IgTs2Rp*]yȎ1Nuηcwֻ5wM \ː-QyS Ϊ?"\{$ݿzqZ ko]Vsspۙ=L% 84`5NQШ%YU/x7w0 h>`gr9pLOh15ƮgPZRu`T^(+uUCFݜu]moUPO) eVv*ɸ, @NDW3j(P8$H&5N e#A QC LbMe$5d5dA9D :!4X8n4Vtgl'2r# ^r)ďJB0 ik ` Q~R-Sݣ%[yJp͒SZNUB4h,Vr̀^rJ if6 !FY}"zVk 1m; 볺 :ĉgx FN;RD*ʼ-g㫻#)H\!*8>qs,hV–AgZu3Søi|1Zioޙ'?= _`p4,~w*Ǚ&|<{ ɦAM} B!dt\"DwҪ(l !iKs (+kG_ ))=M/cE,U!R0qbʹ%>XF>vh#O!fxUznчv2EUhT+)‚r(8~J.szrGNVG.G ~7:y<ݲlG>v>:NnlMV{]J@ÈJ ׊v60*薩T^MUUKveBE |H!^Ri pmʫ,+KuR8aCpa=KPB[U A) x"be1m]ERjLX1 K yGgtuΊwq&GSa{(1*%4ʙJAReyk1bƢ9Jyuۻ]UC56_%mʀwP m7yM ^z|vPyVMyҾ>+?뫵uG~{:Q$kZ he(@^54+!+("{z0)j&vXJ+G~. ߌrwXߴu[戮/}eHN}8O(DLQ@r3 \Hւ X0j*$>I/"L L[ǰT2am 3BT@G z o2M v:5 SN?76np%$ 4bBDFX:DGzV&Ī"E1uKh(4lÉa5ҰWcD]jW($Ȑ*U `zIĩJ Jhi @7$&:FV:1ʊrtU8H6U`ґa䂔weVk }z#c0oK۸E4wD1f B}׵ 2׎6@I2B2W^Qf)΀y ~y9DmsxGЎj*V!GQ@ЖçM"rJ+k&#7BI gOpŨ"[S+O mA^p4 Zh.#`n wltx) o̴jυ$I>M&'6q-Kޗs#LujF[xDc|GP,3d-5&뽹qa ĔCF }'~-n%rƷ:^km}jQ=ݬkb{{P})p戅[d}4hkHA}|DYK42T0w %طt=dmɔRrʖ[iUi7ffV$ t6mC "zŧDRwZw3PC낸DUvbF2xM|w)y^ו|ؕǣHNS}4YC9Ll]{vȹѲϕ|v=K`u"Uo6kOxl:d_Ҹ$eOv{7;C&^A#ni6vF{VԶlwdYkLg-뵳pQI^Ώ;]Gsg.(O'fOW_w*O>T(<5'-daiIilQQAvȯ`a < ih[-*6+jUJqBV*YT V{SYk]ت;]g# csнBsY9GZ:`4#- kBTWzӲ]{^˞jAHl9z,3 ݢE7UlD ҔW"9O Aރ6V5AKYQA'*ҲdH7'[(!c>J/(|k<9^N4k$E3d#lx$aD"e3"uQh8Zg0]IfXJVޮAf iAUeãJF`H!6ܝ2EgI&ѐ][,ҠC>PhXy=@h16`(IڼEóJF+$4W7L-[[WI(٣JZ5-DE3BvR(΂>.WxI{R)}ށw 6Sܤsh|M +Oj^G2g@B5d~BZ후JB}IxKq>f Ǵr%msuK)΄;Q|0n@e6SgF)aHo Unqvȫ"kҚMGEx gq`}x΅*d׷%ZC;`&Mfz֔tjyNw摭bБUi=H^#n[&5+ ֻ` 2gyŵ}g3 bt~53ӧ~KJoM=kَK/K5]=&8|*pFUs_90\ڃu|YB=V*֬"O9^>o}l}s+LEtjٗa>ۋ3t 5.ݍy_.(E} AJfdF,`blB5@Ң6({k12t9XC@{ 7`?t^ C4+0Bk:j6Ul*/hb{V;H~tjܬ?&8EnemkVlx<2OLT&~m,qO6 tGpu)9(c6Q-aa\oj=U~_lnfzKfl8Jm>nX66=SlXlt>nE?n7X>5ߛ5˶2შ;j];hf{*Ed4k_ +W<|  J޵-ƙKU( c;*Hb@ Mh`&6N"9; ClnMk zM'2اX KDS\7PaQ4rik2kc@hl=^j$F"YrU*: DQaBm5v|!7kqvhYL#ҺJ{E)J RPc5?Iz#ڠr Rzk-@Z-/rn3 [hA 9,a* ZNVԦA4]O&mю1=-iQ CcX*(RiDڠvm& {{h72po~ܴՖ֚ͺy5{=KI}43r-)9qQ 7&H5 XFƠy/i3w=oݜC\Yݸ7aBq`iA ogOn^/tRdZĖFқV]D!(Ne "պo Sc݈L&'q#KgqA۠+M uo:; *)ʌj`HYLI)Ow磞W'>cqo H#Q*0V( .ST*u*BvYWiv+X [I2 hx}89HEɚhBb1geUkM,MfVԙCVekPdT vhR(raERPAQt21M LN'kΫ3)קvlAJf:HgJK0 2W-`$B&9}=UeW&@D1%H& {bx>q#}g1mS2-:z*Wc^'ئSF`71Abrh[:C'FҜ w:V45 fQh6PO(A}[CX(b^H74w|u^ylA $(Ԛ^˸Fyw{|m3-7V0 ʊ#"['^խ]٦S[)p!3m80j%&8rKG26°8djtQDEubٸO?W+WtY?I1`IwҜmI=! >g/34iAV5V3=k鈹L.SP{Cljfx-|2V19`}0 I/N{ٵ+3z52 6Q) 6%kp u\m 8X.)2&A9# -[ŎRq% ,4)!NgKE&%z&y\R]/; )٢D%@ϕءM7)_*E!a%K^G 3$v\=P=}>^GGW߅ᯁJ%KY1+R4{_Xm<%b{Ves/0uqrrDyv:#QZQ۲xİ#a  @eM̋yv)~s;AhIBC'߱:l{$ ]I(S_ J`k B:cn%E7\ *FF"%pjK5(nV Hr h4#NEhxT0hĦȺ=Wl}%E谁\V!pFB J|F"hB:!Ȳo3M(E2:MwyhÕ`֗b:ߕIJ飥fl筚8Jp:eʼUUB]Ye6;\a N0p3A$+هc32 cJ`NKϟOe&Sk rR@`i2823JɏHe. γP)~m;|lS 8a ڣJ]l)?rziW#z܂WBܴb:Oϫg`˝vGRkE"OR}*3s06|M4]*7j޲^Z˥?<}q][vE|IG6f5ۖL?JX o(ZvFMN !ҝeXdTVw 9JɎ߇*VTpGVJriYV~F1HJ3/3}wiֺMupHJTc3#<ߋ:xu+'e@bwiA)ԗ%O3&B\aaj2aЬ4C&A)b`kDą<,]cLz$M>)ǏV0y!X4=hNRYPGqW[ҊlpJД ,41kaqOpӮ>i]"; VEg؄[D{Y.EҔa7h&BYFU;EM GXʘP,":.X#%vKݗc;O ΄/s\=QrpPiO>T=4HSg`M̪T=9REQ4*C*PKՈZntyݑJtK*j"8oġ5.hNsU)zB˪q(͖A5˩ <*o~pv(SW2Ĝ&(OMC y ad*)ib)$ }-T\;б >0fLI%za9@l9hjxHBvz$ERԨBp~*M/,,ϐDT-ᴐkQWrZeZ|[Zユ1mt2SqW ^)mFu5yĪWӺ#<Q撫[Jt<$m1yVJ[Ny 8-ۊFڱo4U36 Uӗ4Kdi ɮHptEc}ƋBT_U{ϊ/` Ēu޳;0X'"֬M`zQ(weo[OfAՈ_$q]N\K!6G.q"A8…yDӘ>5*.S]r%jfXقJR:߈1$,C|,,+Dbw\u7T6̞xQ+UG ZNA1s^ZWLɂy0pOFCW Q..Р zsqJAuāp>vge.VgKzZ_ƞȼP3@R{NuMRk 1f%vh~jwxfG@581Ӿ#]%>,z9^*/r-Sogm)S9NInŭy6U$C {QNEs&2<.C.O܈͝phՊ\"QԙN⡷nEWTts)Eg *RdIT*z J@`'!OƼAG K#VXq"2MNrl%Z:}R25f|;˲)wU#`~cy5Mޚ1pI[n՛%h8֊p J؃6zgb }-457΁ J]#@ &pJUrJ1I0$!.-B\|W/8_7ێYˆ pe]%I2n0LaUA€J'K\|!9ktO [3Ѩ^{O v%NMAYf1! P@U͜.Eu..&{)T4CxA]|KiTh_S0{>ۘdi5:]͚ccbYI'jݒ6\5[ EwWrfG[K Kd/g*lN]ٰc5b}cW YAowwjDPlk S(TX~=>KF4$|Oʧ"+re\7_}3cvߍ֎vB•ZS)VF;&G"yL*TJ_bO1޴#%7Gk >'« fmTd̫K\pD4 -͖ivxcMqRęeOhݒ@'Te:Ϋ1Z)hS4nzd8.MN8L 4JY&܉o'4s IysY]NeV[mXI"ж4 Uv# Elz+EGlO6_w"ךaop$7MKPugY#4^lk%R ĠL5e۱,QIAbB.9`%ι*< xj'a8fNBFFDs-mxrigY ph*@-pԯs|U#iEJ+ux9V"aL\(!1R\P,#J%ei߄Vj5Ҷ|:åK`v@eH"cZXⱯ)Owcx!_G 79BSu7J*A+,?B;%#*8/XcH2ᤘΰ\MhM}}~=bCvw2'(&?)PQgT|ZgMJ֓r+2zƧk7  u፡P|K۞Bc8ߖ  -|"m AqۘMZ)X۔bh P<lhE׋O:,>Z֞Iy$쀀| Z.W_ň0łQw wFZ2I|FoF-eUGnҭU')6bR_nY lN `Xdިv{9跦M:]2V]9moz&1kǤ|އbm54jyh (菓nZ6jWA)lތ7Ɲݽcgi%J.dPvTra%6%,,VWC_j`ӆ($7>k;tO:m҆XYQmhbdJ6leԹVh)NJ>cHSZ)O,ռrQ(>OH,*Nz vK:+NH#2\V=,dt~x^`bݠ$40] W ׯW~iЄF,DMwa&\0-T%ӷ|8@KYs!9I$D?O<*LA_)?G!LmgI3E=>fj: av(!ŸȻtQUYEdJ1I)F=ғ7ZRTŐZ:B'9q rͧ:6|a)!>] "5)7o4W/) (V48{e[A^:CCfc,Q8DxwX$BWXL:Hyhxg[LWU,N44itwqV@J@ˆ5c8k^!۸2ӌ\@͟T ɳB;=#4}} [=zjmSѵ 1NJ )Jx#*$Ý*4\b 5*`˶uF^^uA&O>9{7!/T%ic2)MPoOXOx0 Y'ά("ڵA: #Po6C&װkm*}L(t^ =q_R K-4 ˊi)$sI1^eulK9;BOE}|:d\ & ^6ZH]4 OgoS~-|9JVQX~n/ej_xi:n}?1ޤªY $#!"qQ 4m㍞Bn.IW‡b58fGȐm}]+O! 9'SP*Qb?m sip #2{OWuMvW 9ugAom:q72+ZDL,AM7{D3D$*03 RוBS!O+ (4<=_u +MTF}vSq l{8CXQ$bF efDe9N ~% ]/Ue}&3Ӛb~nEk)^$4Gubh.-Ly€4xNj^d$7-q1)MnKuiLZSQWeA΂a}v \|um Ot7·|_Fc 7;0 Bٯه qqE_ Wt6nwA,7{ԏzÐ]{_]E?7 72| z}Di b^,U˲,Y>i=g>Qpe8*]O{*&־jOH MQosx#`V~+.PCʱ\TiյiExGVJmq'<4[7 ®}Ǎ4–ʤc43b\"(|ߟH.` Vn1JXwܐnBiS5RXa&)DRc1F0VBJ"">),g7@Sq]4[.arfaR%$n}|,}J]!s`@#TVTCsHkgi.^63:|.zoחrA3:a}9غE D}TZqJL $r>\x]|ܴzʘ/{|)xYgkWLYz׺J>'oIl-tORPs=ʦ'.Mn*,>\&Ԃȹ]qIZyTvyJlóffqYz_<#f>gB$!дe= KƮ^),) 2'ow W/ҮR&FzJزɭve95S\)86 1\tKnyʓ ebW0|{6]s(x%` *]U(I FDV5*Y~$5p2 kn ^%V*lAAЭ8]37zhWĵa`G]kWT?O3R5n'h5KH|4|,2 uoq'VspS*P,8nG|\dRź(y'8WSuEIsdȒ(0ȕhnֱpkGlI=GK̷ڮbVS\gr@9Y&_^=q{]&X20oz/_9m\6wPmI<OoZ9}-"=`˄(eʂ(q|ʦ84-ɬ`@*ypX#19|HU'9ę1>esM0P'"ntt+ZybףTc7RFkӾʈ5Vٟsk㕪B :G yG)G0ta/PoM00E|!1J)QK4BI:<3#VK -or3;{̔I-&+:m& W*ky\(@xZT).؅:$;piܝy9mkuK&F('aE0@24pw6#d*]M5_)kZ-KxDʼnz>$@$TNS '^5aX*Oύ4A!c4&'kRXs|$ Hj`5Cn֎IxM%֗L릪zK%G(PZV#Yʤi]rZ{kK(,w:?Vl"ϚmRM4@̺=Dfu HuLp `F2B0(NS1F Zg:كf'楹S/D[&VH'٦RҵP|yz6$K%A<_gjE wp' H JX,;Pkg , Fm͊9^d(l=3I}߲SAyO]\xruIh <\Js!ؖ6_ fAֈZ;4ԛVM(bN[m&lN:ڢ*kҍ{ {hIfN5aH(yE3kvDLɘAL~]Gڢ ,mt c% ;(̼,e0#T@~Zsp&T+Sn+(H:l{0o$Az^o}2kJ>h렓fM#7fvBe],န'aTcp<)lض䈁f%J\ Ϋ \\&b3IAΉt>dXXY2eێ*Kd$Ήe 8hZPŠ^JB}P3a &9 ! DH_B~:k{[rW1T.4IRw.ҍ qV K&bbm[BRX@Y_4s-Ҭ:U)ZlrkЫj"Jd.B4p+<;лetЖdI\}CE &@R 라eT7T!4͑Lږfy JX\tcȌr$(ĉgJU G-M׌I6Еm6'Yv 1s+89 (`PJ.prFHdd$rx{aLHz ΑN@aP=Χhu 0,Ua`f"]f,4-ZJ]yEzs2Be7x\o.B&`D,+օ%Eo k0q /đ&Ln3U" 3 .HLhYܔ2K`zd*oCؓNa~U(kyOj>I9hWz;{Dzrv~3 L@* vXMinT<} a@î1"\=\.Qv5:JE3A6}G`~򐗚3Z'mx֬ĆW. ghkFkJ -!O'{2 ^(*8"@(8qCa0`S6☬CcY-df9vh!Dt rBޟL%"R}l_(]ZD9ڄjS+f(uGq:!#r #nYtO}pF"'^Y14za<l:PgAl4'Ҋ~.6&}) 53`y qNmUhjPY /; _lXZ#۩~ְMh6MD" { xrۑ!W".>6*uZEbo&JHS÷$IrR }pTe 4veeΞKK8^[fAOSU cTd<$`S#1P܆9). mrp+ފ`ɨ.!x`h> P2G8&񘼛&-=">$bbQM0>"Zc8l<XKDO.4w@8;.TD=dKXyYC$vWM T,ݝ,X_x$q2?<;%T1mJȩ4ohXvC Z%*HxT128U,Pxf瞣b~ ƌMH Hi"f&owDC#l⁈(>JL cOsi}Cl {KU;/JO`ϩ }gMk^Y7=$#8߫'a}"I.;,<D` A ̪C+HF.  hjFJșBXp7!HeN 1i%aB(p"&n@?qs 4ɨ k]ʢǸ4I扢~Cb[ꗫ(M& 0W`+Nd:%`wԘ+w(*YN,S&b좠 H3j/]ov;pʽIqjvƶeKh=. *3[2vvm,i#x܂wB[T{ NV aLZHEʤqs9tve-(gALЩWD48 24YL kфsHp} /&l榖5Yk#)Kv ++kC+-%O]ʾ}W>jlj1bD):&hmQ]= ĥⰪ"uPא~p1ps}nL.1܌ݻv]z/>ۋ&n9YWy[ , ~UV/I-x\7Jj+>iPx E A]I2ZmER5W/;n=t%k -$W.t8QzSل }u(AuEGc&dr n+|}=V vBSܯ_O)3׬Ɠϯ)DssRL1n =ӎ 8}xo>Aj+|ōeMFKZ `&w8dx^ZB$̩G'ްX hyGO2קmׇ6q܏:UT%5@ aօBKLʤ>K%q"es7 R1(*!Xql'3a)fE^4zrf&o ns?[t)9u jhdHJCno)OO9aO?OyTgdž5 LrN ='wM ]`Km^e`:^1;f&h2VFH&# b',RakeMB[`nBǡ6fk}PF2Y+LJ>km KQWeQpGaH44@(w,FE?8qb`QG|ΆBgU֨bG41CҴ$ BbmA"[ ֨^~U啩p}Q3\i' bkI{,k{ 2/(ORf+ ץ%J8Y4ޢ$q/A-xpG@f*XMЫXVDcw+iUaaVOJ,5sb8`8͙~(7)e{hͭl,m0q:$qi4'`[-dm%t!5Df%0ͭ'M-jy9^aTN,OTO!ddVR|i06j5i0!8t8fx 93GgRj=Ã5QR@դ_9F0 uzZQ Ǭ&XaPGtmB# 'rlOEDvQڱ1L.m-kjmk)O(ڽڦ 댨_ z"f7,دy"B"NJ*XRe^@ܳOvLXV|ɊPGBH-LftS jAj#X 5o3$w̙U9E}&C0G%g K|fp?3QboV?_'^̐5dWg\t]1/F.pZT,_+ޖA#4D@6 '*06^#aQP跁A4>$+ kdW^qomyOA_\Ɓrpq<`֎'$}9$㡼qBw@t[(3~9 $ʍ֮]42oNZ5@o͏|׵ >(7jZ4XY$P~"LvyxӜ]__/G^C7\P'9-m5l;#lLzk797fV`aL z+q\6*oNwgm9.ߧYFŎ޸7H}>hrΎcMl8 s`6yt%Ʉqkr<6*ֵf rVaH$uO>sS,Ə;+̹H( E>TX,DP wP'ykE>q:y ^|gNphUgRo}(oYcD!K{a2rRu"$NQ=E\XYdMguBrбmt $EOPi咨)F*zl_QT,%-&0\0 @sAmAuSo#Vɶaܷ4L`GEyT&~hej`/ 0zB{-#qU4fNa3%\Z!Ǐe(zWi,_nھfzHp <~#SYh)lttOG;ڳSzm*?G8#'ФP NZ;xl:w|HԊC̉op-[Ӫ>I|XCx]/[|x!G!$-&XFX[IKnA`rt|79\Y T5Nˢ>JB#z]A*gJ<0Aij^v9 C8B3 Q;$8k{)LAшY簑lb"?__5DhAP-Y5V 0Xהiyvj`yDmBƌ+#[n2fuUg^cˌ)JsP 5fc;p bP9>d s`$b~vw]eXǜazIleuX(&t9UA+T)* (M>l85މEwݾ?r3¦9|KWk[Z;.IK4 `Bd 6X 7KSE9y@SYBv`b`=%WQ5LeLuKe'zm|Rw,Š@iC,f2Rǭ:tdAWD(3wb_r|江Zv">GY]"*JSx#`dbjܺhw̵oBanOw`rZkG:f]G,pugzZ]o#JoID8@^t܃G@Jei>2OFfY@m'gg^G""0ՏR+Hjo<8ZH"D-cv8Fr O+6[Q<Xx[NyFOLH@`=,f:I HmńO;u#֭qΆp!9ťN(7$"oē{T ~E:F:6kS6f ¥(xL]7lMPZˡC v9S$^٥FfŚT dA5!2s 7ј8EMwX7H-nt!4 @Uh+fI;]P#d\c ل :utxƂd7؆OzL6MYKVw5o9*dm[MZ͵U4 X+EYѣZeP*i .x'>(rF8TՒ嬮JfcbȊ_!Z,%FEDMղTc'fgeq?r2P>jk6\ } =)X,l&f֍ְ>ɢpsz" α̴ HU }=Ao-%eTO,l#-X(=W!Ji5Ah 0l"O'ҏPȴpd\'jeLeW6!Yq &LJHZs6%&Fj;uٛ3ؼxVVG=n7nigQA,mUP*gY$XuCe!?\LY1]" vG GC8zYG󦠴L]jrl Zܽ13 SV%ݠIYD AWے, 梙/> ݣA|bek&4 JpuJp Z`$"&`0l@AN|CMD) ]j$쭈?1\|J%QgB ^!Ïqp(a,HׇWU.iG~UWаU'!B8 ϝxkQ CiIg0- i ZM@޷2T3te:9gLe6Y9>rab}j-gjlQ*e#W펃4gMʆJdҿ0IZ2- /f ee Mø%Ji))ꨙKjJ[K?W5ZEhbjGbn|fgVU[$܃zmUVV.ɶg3'ˈÙS f`̀0: m~XQ! h±`k8HdU:$ŘSlrax Yx)]`ШD1 u3%\8k[}*"~<IA@[rz` #bhQVQeŁaKT6F]7r~fSmsOL[J; I*sU-=-ܳ̍n}Qw@L7ۂŬtg8i 9TG&-p مcpDRBku㻽ԋ{JZBDz')R.w8}~P|YL| HGn*W0Qnn" ,ne(WMވ*.v:,s l:$"Q@V Te$[C,XYOSN8]^'ٴ>e47F5e".8шMD h-HI]d6o]rs<̜ 1цRpE7 K=Az~.lO鯺V׭{8|u*ߋhzK!E9LNDwe' (G+w7'hZogĤA=DMݭoZLӹВ 5*Rѽ9k3$h_G=Pu= dTOd2  p q}'tHQO}';=SߤOBs KzäNB.}'15-rh)6gt4]>Z{ ##M渠ŀek9N71HT xe)8ػEJ AŸ2'(IzLH"ߠ#3Qfnq}}{s'rϫ^XIpFdk;'smL 7irygmYr )JeqjLלWƁsn&ո]V^ɋ˔fe5kibS2M*j*8X!gl!bc^qA.89fU"9:9Ҍ8X.m<=ьh2@5cOG$AbYX//zxa$CىKza!yE|8yǣ%"zkS1Ljɕ06SB܊H5 FȒAtI[ SLtZ䋗^pH=z[(p:X!S1TpΏhuoJKH<>v?/-IEj%k4FºZ mDhh2a%&Hq0%XsDu*wz{WZD% Ie nCꚤILrъ]#1c:gLسܕaMԆub@G@yȯxOdPqCؼth}o 1e1$,`a7XQ,@e6iؼ[ ҡ#\ߴjsnIm[0!"7%/8t::5<T>JPniۖz/QGN_ f`(2S&{-AUFt.` LLq!0Č0*H0(LQ_ {+ǢNtE49= qhq ` zBq4ϟG*4?"@`&] {WŭGx;P՜rYؖ GLddnr0Qg h2ufu_ǃUG2$d25Gȝ0(f7c¦fT!QBq1r&J1o#HgE Hk//Pmm}yݎu!:E֭)Ot vWio2sYפ3![g<\>Ϗ}LAN2ǎcNȲӆgAU/Bѯ*4ZŘB<%x[(z@6(HmkTHNT&W' $r##%{mYM_%버y!<ھi:hDIJWPQ *iٵ =6ιD,9 u\eu+_P$X!L 6dgHiMd-F Pt2BS u ԊrMl~ \]wCfqw"!#!N~rO9)Bi[q 2[]&xYo[Zv#,Pv8̧%#AZ| `Bi $\)rp=k-rkudn'QEFTDp~Lwޑa 67! މ1+pOp(s#8Z&;z8n qB&5i0ڣwx7 OrSxfت3n&gE_Z~P.V-(Fzyb5$pc^B 60i?mB:S,niE[$#5S—%SVߗu|t_x]oǝAZ[I6Y̜IM!8OqfWp9 %_0s ~{Hr;*>J6[kE88WjRtbF9CKV\#!{VH )$dfv|1we7`.*2Zȯ;8fa h?H8n6I00?^uf Qzbk߯٘Doy{džf*^tQ2密w \4!l.UnbgT+jbd7JVL(l+|ո[kxp-ncms}~ΔJ$ыlx]u`[Ϟ E>Y%i`gh}y6*R0; 4<釢v.{xp0^@J#ͽQ4Cڎws˚gs(9 7j{6fI<p@#@uytottY:LP.T& '$=,&A4r- yPlj1>>#T횓m:sImTnb _o!#TPIH'F "/s+?('1YapI!Ϻӭu2F` )̻s4w0?c<~L! d.򭃩Op ._!~?b3f%"HkoPCQx!-W>=RJ=Җ!1YhBoq bN;JU=2K 'c­4{K50QzE`>dV}wC팜U%oi @vWO>[4"uЃx+".1BYMK6(v.q&U2PJnp3}7vqv>&ij^]^d{uP{#-lz-`pzR0JqC@ض[iڸsN[st9)MDŽ":@ka2LMGql+oa^(TT>p^LDAN? EJev~DcPi Eg[.ۼЋS& l̳bLV(&㲑p>ZVҵo1O I[ArvXZ뎒4W q-0F|igC SKʜKͩETka@Lɭ+V+b]FSHIAWɌ5B ڎ3U fYZ*/p&"if2kџ5]mq`jjѲ] ;]mH3/ݖR)F{|[{'9'9_aN^[UN/K9_`TF+d9FѲ4x )Abdkki;qB̙@.msp蔈1~qGv:p>4Kq`°PYfNVa.V=y.=\t$HJ4%Ph%qb-GȌgǑXhKR('gF2$Y5n9\#v/w$Z *+<;-9UGxXs6E8Aʄk i҇V*%z}ơ>fUyn42 +~Vb:i43;HFz*q<)%2d JtH^;!&LdA1=YκIŮt4,@*qe^ R 4l#hL--Ȏ_NNOIsՔu 23jA:r >љ$(:*;!9%Ue-Sas( fnFqs8݆hVKMWIvgW 3xB,͡lbeȇn'3/X! v[үXռĹxnm\Vɮh,汛=5<\R\NAƮ&)[>y5ZubƉj^i{ |L@V"}-g8YqmerCS&E!J0Bf\G,_A !~,kV8*HM$ҨLM,Tz0iC\mQ"e'+Bs^eΓD3晉|ƻ>Q'Ѧ(3';_j9Ҷ>G" 0ZdB݈ȇ~3Euu$ ͹WωL&OOS=>h&;9|zLW7 Wn$}qh@PJ!-K֌b+ \й94NOPBQ'FL(֯X>:U]9sg:-8g/4AM =qM PB 07DG:)^l2(aɥ_AU%Ob =RU1i5A;hX R m1BZస\dsRĦ-[ERWxC4@:xCWӹZ{h94_u*!yhO,Bsd`owlB@%buC+"i&]'#/ȐI6y9wϮ#GtuZ>ԩUUKݕ=ic}fy>.}f1B #a 7ֱ1>deL%zV]n,Y$+%fJk@\󙟃L42^S08^ Gh *?!W'G G>_/!v|nLp YXgp^݌32Ҹ2s0vkVUWh5`G6؈Z33HȗPVmʛk|%Oѷ3[ݪXd =X#1}ΕGh&F+PX: I.¡T/ %uhQ}6q큆}>?phzNQ<"T֭}JKI*HL%*5}ugTuJޮ#0Y%1{?-Dum>RI'KVY!Od3q\=)ڵ*YBߌpASr).).孳nҡL|M@K~r|ĩdk.=\^g !E^[u Vfi " #& 9X=Q,miX183+$@ 7\;l-`N3Zw+]gt<8!0pF6Foo#.;%]V3o0+.\B{=jn~h|# {9!(C P>f~)<~F@©6~ W,h@S} L3Kjۨ\SH5$Ȉz%ưH[8+2jqNa &Rڎ±:f M%2FP6`TBB7q4[M{Ӆ5ju߱ʏc&G~pKGtN1X/2(],BVp.' CX` Nr6*'s,=[u xW+`+h JzyHXѧ>tY()cs])n_{1jw&X>Ξ 3s^Ba͋>fv.u.1t8 cOo-)"% ltRuڗKWIvUoue{\ZHg d=3i8~cyG,y`jd+k3#r<*=-83F(_HBfp>F?( Y<;!!D<Gt ) aONgBVMQ3@hxvO'p dU(>΅ uYI$5Ȯ(Х8r(L̪&jcI͹^]ʱ_K5vu+i H*{9]$2& B#Z}&R yjʶ;gr OY䲒Ƙ%;-Ų6AWv 3YT=+S&6%)hvxuY$LAI t| '^k6!gK;۩S;zSHsuSBt?IW럼v8ȕjYh׍䕁 8l=_/㭞u9M:aW= %ͷz ŠM3X Zd4*|]|Uz Ԋ r$TLt{(1iq)ǐ:!x+lɘ{A&;E s"|JOA(0kw Q>I'j$S|O]~|t 2mC) u7$]y,(W :/?+R2~ubx+Ĭ`s(l(uN6hVTJc{ꟋINpov U&ڹicɡBlo*#yn9jN.GlfB Y3Y.:{`TE EMTwpN;gIf#-[>6L|,ԡT[AzqyV-!Q5a[X"ڱlg<g}IY5|᜔u%h/C]`u.NHPp塉Lޤx,\0_/L !ؖ@8@}>\R7A ^5j*z̦"2Ai}g0}DApKL%?A/o֫[yrv!~RhuTϟg8ŽԮ8vXČB]ڹXƳ˖\ Ǿ: 0 ;q \bttq^p;NGc-g. =: -+Xqdҹ,=|ixյjH m:%5ᄃ&[Ǫem7zMξ$R66:󧹯 yGC^=Cq?H$*R9v2~? G+(]%ɖ>eg%Poa59uznYM3rjװ[5iKiL-)_Mrߤ+h/1tFO|T> ! 5S ,Ar"3/6]Յ|`|lO\|ÖJTۣș@Cg~*yYD0b 1X(ddurwۮղ+I|ԵN־R^}Β%Xq9lPCy|0k\֥nQ PkpK{xD$#x6*Q U$b)egE"!_:YY̍5{">qf|\&4>(˃vὦ$ O]pb,x g ,bDzc^rՁtғjsefLVIޘYZلeqʾ}'n]/=ԉGm~AۼC5l۬Eee-\z[+V|G<}3DC4FH>]V`UBPLFA|IAfHeY@*3M؝N*~3@rVxmtUQ6Gj+΀Ko7s]k{2iuNE#&'DsPJ* C#pC8!'P50=<<D\J<s{jwZV_HiA1t3tg &G[eI"P!HQC}@EodxþX\%6 Ga‹nS04մ(5X(ZV,~yc2,Ŭ",/ט|JU(IQj?;:ZaQބ o320^WR B(DpD4(-m,=t#&WSO1ESe-Dd">2Nn%Z$&Og]f컔DϛmoZ6$Jm k̎Mvi%líXe0 OaŻ- PFE;v_ x#u4̠p2N^DW!A*? )j)S&p ' u\$ؔa6Լ[$hc̡꼲 ֓0@g;"fX $`|79ؽ*` dp踈iSPjE`gM"r a0grsSsWMhTn<ΓIHq6݂?:v\sc-hX|y\6ʻGkXBaMQwh>Xyk`>\v-u`G:u7lXsU҅z$4=ݫD?ΕjFyՆ/5{+y&p ^x$֐=r;t$ݘkӏ4AgTm"isIž rԀNrz ^ȕJOudrT܄52g؆[1X@L9cwI4ܽj ';TJM4we)c5@75g;Sʼa٩>4@l܄s`iJyb^VLa"O/fH)ʤV3){Q?!|qv`t<#55k)6qR(|귈Yg +a,2[D̨8(7na|3NQ!UQ@dCqB5f4wqNS'%ÑHuKİ" <8ՠaa>? X(IW+nMj -*UT+'eCܤNZ{۱\ZiG E_Rs{? h颤X}P 7 ϴz%WQA(Lǎ:U޾/w3junw aN*3WV ;ź a=`*uRn]|^YgJwIxXhcwywJБ=.;:=:LKVLBU '}\Ы8卶T|D SM̫^iMH{?V9̝|'`Yp|KL=mxn6H@SЌ*D8lmJjT!WS-4W]] W#%uJuaVc&nL)/i"ex+?z P/3xЁqP=۹lhɮڑhb4 TC$|ѽ4H&x^1 ?F_~GhԽ^eW*#1:3u;*%"]0>tB2wU&pBSM9t}Ga.8i55 u"Pjiq )"wiƛ}GKlqc2bGJ7M*Jr^RЪ"X@^neɜuy<8c(KAw' a(:kYvE'N}Έ"X(J=b@] ,GugBb {ezZ(;imł<{joۡg$ͤ1Rm21w`-EfhAzLI,]%R>'t;ـzL O %)-6e>S*ґ m % +K7%Xbehxy60n,nI_'AGf@NUM+sՁSNyn6.'Be[1U/SXg%,X"a+t=Qم牦 &.:WֻJ}iWv*Wy--Ïj\9(Y.CAHv30?Kϲ8W9$ a֭ѸU'6*6~H)B;v f Y1Z%j~wV }ߵa8AV뻎r. ݩOMTWz4MC39{y/Y ib=lS)4K҂rax,rdk{zs'l"6Q:X#',(F`[Q$ˈ{>k釃zhEc! L dLv% gL(aH|\3igpzi-{8u~u_ȄU?7%A-H>Q$[-c ޿ 6K2V7 ֖AV!/ُ^ݵ 1 :hs RZ%/"/FYT"IMhBLpfߨmDƂ9)7B~^kV;HI0$GɱZL|y!=0Giɗ2u:sKyK6?9)<!B#@I[cx#%J\'3;ZT<%W }z؂$M#Cz6Z|vصw>7_) ʏoҺ/p!oWmNQ̽oRh{>$K{NG[(exkpÍf#ry6[NHSo~JfB. *9UuڕͺO~E&2 _r%Ng.`4"Sˣ2( u0PGJ . G S&`ۑ&u=Hk9SlxggȦڐB? _?=/R-8R}%NU6ά aQGB4Lg`!XFϹ~xJ:Zk,ӹZ;99ږp1E`L\&p<' 1WTJ% /_-PefRUٷIG-F j+Ʒ]* VbF*s f"@tتy(̦/KYx!JbZuc /QŶd|X?F`ypH`+KђPZѪ7%R93h-U'[!Coi8mwhAKԃisܿ"⡕r.jIBw~7<~o5_de'K߭0EMYa1x .ZxXsG"`3ĐIQK1Eذ\}hKEKRRÖsR4ȨH*NHP-y. IhdL!Ag-,$lx{rM@,7cB % -ҥVheZ,7!f8XMtfMfJ6sR$X)Gr]:42=D牄bT>?:z_,TۨP:A{# ҿ93naͶ+tbJ^eD DC2+57‡m z3guĹr 5k`^GUһ,3)6w(Imoego5h*8Xm'#O&GU<Ԙf9FM|Y΍3b jkbۥ9vN\=hN6jW[ ɋI.G?]D\ 4ى\k5NC5@Vb!-@4H9.Pض}lN|̽ ---vOqcaᲦa(؂̑zXAw a_6WK9&G%1E^}2>" V#9౧<+@cIj~f77m>Ioݠ$CM?b vk [,}G0~A9zXȯP4Xi= B6`nZ[TbG`6j[ݥ@O*#3KҌj֧0)` :(dcg-TxfXX5bF FL`2@@f(9}^BuRL&lR ^)Ҫk$m*ϫ&&O 7Ni!"FX2 ;%wA%'{x?Åp9ԂdA&a*% '%&!ki*.[A1k>}CgQ%ndZ յV)ȩRA:/ 2FS,p.ӞcAeaو. v$i,V[J3T`"yD+㝕oQ TXhf -$C[,ZvuFG@<*$|HԤE#vW"F:nBLoUĆ:tj\ CmN`QBƁ]HB' H߄0-h=n5<ƊG_=~6ߋp-q\9U < Ã)Kwh$p w)Nģܪ>C[p}* i׹e}~ qrv&fW7-i?1bIc*'KTC(|a\˥^˓Tj;ˡjQzo5wzt֦s1 (O-S7PrZ/{{v X; 1\՞!@QsI> f&tiqʆvs*F}|M|cJLd/Xt1\p]B"i:-!ކ$|d'd-og#Srd4 K*8_1nyIa;iVəo8nW/4 ӌx;iM+vp& RŀrN` T+z#t$qrn*ƨp1#1)'vwR1~ ch`ni#b4fh-0!n??i#FTNdzG+iX#IA:FFw5%x˲ҏʊjvkL(\eN} ?i1q#x 7Wx M4yVyNE$*to^D+(V# QCxޛb dwSUVVALjk [-з?r5l luu) )~soNk9;kȰ{`2ȏ4)z%r/0gij |C.mxjLqT~ l 0rraUp',}Jf)}UX>بPon q1i'3`a,38X5V=3L竗 PԐ؅g׾4KD}*]K{y f]S3}\l^B Vo#kH<\3ļVDҥʝFJ1,0YY،fn6pDP桇HRVFXjNx35gLyPšC?!^?_0e? #p^$8!tu,ykQRhq4ӣ$i@iS߸@7(%c"{/s$z'r:teգ~nJ-̐Z3P\RNҰ08ߺܨOk5%7/8с}}@MBOz&aʻ?PO\ÚfC| LnlϓѶ#_rF7hZSjMKn _$7~zSn8*$<";dȪ3SaD+ ;8n8*bD Pl bpࠖ#m Xv#ĩ.`0y'hc<7m`Ǟ !@R)z=f0 z|_0L`rG}6qAsoă)ڵٖO$o.D;Z Iʼn-[ֻC)e-e\(kzzq\o;f;g'b8alW)q:˗pY*B<@ B%|X Tib܈z%s+ E,iL} Ё]4F`ĶEwe@}alw$E`%զqFhFW`R /i@Lw5;(U]-jfLEW:#A"9yfsv_F k| Gq(lEs0R5%(|eڍap:Z/JK5zicR ͦw|a<ͭe)a{|l2OȞ l^7%P }g! %3#"q+{ZpOn2] h= 1 BNI࡮`Vm&G1!|*5ⱻ"!5>P$-漏`+]6gVB߅ywKᄮ}@t[ Ҩ&͠Kx-Y"n3s,gjdZc@oȬjG8ZɸC03&6b!j?a!gwZJ$l8NJ!KMX[F-qwv*p k~Ҫz5jr@/@a4( Eͨ3AG Wf^}5M[DHGDc\I^6Kt芵YPn D'ѓ@KUF gGٚHo?7}w; 2Ka,9Sg̣k XAǫ~`RD|u9; h 5&!XzÊ3fr yy :rA?YRYf+Vvs] mF v<85F\5 p ׍ Ё XؚlTdNyac5^jg?8pDܞDž4m.lڷw'V0 "OfQr d,.1N@3ɧv :KX7n$ ya!Ek@*3!XWhۚCCYX|l $5'#ʡ%lL(Î#,_eXi|1B2܂OcZ1w>2E`&@|7dN384'q ~vf,-ӯ# kNu\,K^Zt0)Z%~MN%Qd39;|:6/D&"T=}u[oQ(#LBS'JoJ[7AGdsIjku>'=oi%'NDE7yrl * o&禧WDޑU>*v u;<%(3z2ZuwDH&h2nW yA<S5dQKS,#0, JmI,38qeHLdRN7?(!7'iY@bs3j>wHyD&MTyvN/xB}nALei{]vXQ xiWtN猖ťi8δ٬C=G6uL/ i84̈ eH3aeVwnt]_xڞVc2ͧ_= J% Gn 1e{fWnXj t|$Vw[))v&1(e6՝uIvTD۵4J$z3%䨞狜ҦK!w[V)0QmUk/3AxxI޻bjJ3ѡ't5/Mt~]Xs;jVMZI$߹TbYi,*iZ+[!N(@VOB^R':`EVwc9y:/w4?`VPr/[(Rt'/K&r#g|WLLQh> VU3M깵Rn8jܣ?k%pM[[n*B"K3ۆM|V+rDQ6{\9bIg5 1@< [:Nu pj6q.Wͫ ׅY٢zV#H݌g'u`B 0rAmdVTYB9v9 CddE KAN%S/2e] SA:Tӱ u>Qppfq[1CqLX\wJ 7 "ֵ7D7dRF#d.5R+~SZRpyTbð3pYܰL 0T W'aD$"i[3EYz,oE錑 NJ>c+`  SgԀiu>8dR<8V緞I׷"xՓN!X$C ~z$!+ Y7c{P)Te M({Aq^g쓗9M 4q3ߺ0fhŽ:)J.Tg*z9& b2u/O>E,RXnw%2NL/Kh3 |ZMoX ģvcUm^ڦJf눷.cM:h=p7G׸ivb|A2ܴLBsFM't;xe Qˆ2A3Eo֥Vc.VyqrVF4(АtYh9>v[mH~H7)o,Ͽ˝ua:zoRTT_R2ף,J~i 6 1U5VpG1'E]in5ft2ZFzr6FO]մG*IaѺBb$9tPUЪ/󸚇Xu))NMyRX( [čsrUz|Zt1 \{Fd%Cv9"NmXD沄1!]MIq0RV87n9\n׻ m>&z_ oY7JVkr`>V [);5sBC#T>#BnbkpwB@H(91J O#呬ډP *tyX7z*n@f:>aFgW^_4Ů`Y!dJՅL/ehJ8GēuϕQ "qm܆< )NGO2qC`O3"NmN oHNHk\}!몊/IZvO7`ZxQ@ӝjQk }&KJ9R˧WHvjr gX#?GA糶P9f+w ~7~@XWz\}v!"ԭ 2ѫN~ v;v%s4jꃉv?+eTI3rDŽ55`=)z=XAH+2+G ąQd[ۣ4Z̀]{eC VJR:fW#z{}5t|]㖄FFs-9DoAٍ_)3ԏg#7nTNbKs]\Wj)ͻИ3c1TS6ĵSI_'&n y7Hd a`2_lO9;bF 4Z{j%x(u3b j͜-l=}l¢oC6].]{Ni).};;xiUFe2SQr [V|IfRoPu7ֳYdΓKmU5t˱NjPQ'tsd`T%P-l>DZޟ%cV AX91W]݀JO Jl!# |݄p ;7`qz񖘤8B+khjhS\i?2g9-+6UW8uZ0!}!.EԘ (؞%JZԓ6zcCijȪꪈ0ge>ȝY lmOlng5fA!+l-HFFŤ=&Sbr> <Я͹C=ai W47i^r(\eA%"o:~VI/zֲG(A!=j-D^]H;/ѳ϶CxG}nl25$#ښ'hܵ ,Y+s6ϵf @ f 7۹o7/??+ PQ13T 4FoQH# 4P-`|ƿO WTVٻT&* I əuQ 79)~>_N/D _DG1}L3BZ3) w4m?4/CZ7MwPN'#3FHzdzRD>WύzӲ ,a{k}kvaaA5ŷ z.7c=r uJiɞ-lP9HcBq&Ē* (Jݝ6DSm >@J0k#爔+p,9`er@(7ʝ'@JO:Z= :՘:rC_'QJIn/48%(X4AϹFz^vˏuuNXOLRqmRx1وR|/tvbH ؐ]ɡ!*|Sdqzd Pr7l6fYy (")!ĢY$&bZ˜9 j0;NWlDcy` mUw #ݬ<i5ؾ=mk_q8F9u(LzGi:ͲH@0G{oD iMaAX3љ*gM֚ x5sT*ÛY4ljdo"BtnVmsl K72y07_ȞV뭵 &Yko ܼ}tiX%*J^ٰ}Go sA ez'j=Mxs# ^/9G94j+OB{ۺg2XzYJ !<|eohbĥ7gmnpIz: 2?V039itXS(ˍ+2I$?rh4+|#r.%&j*~nܰFDp3PA{پzA :j7u*,fl0?x \e~uDSrܳۋ"C$ߙ6K82JSrE-{$-44ڣR4ˮ=l^wI?lkm <=cYieQ1$e Q)D4(΄<{g{2xu x˿]h %%7$s`Y˪d.($yQw*kV+y҃ 1a(K;6KjsR$2N='#B 0,10Qf`}$ID$:HΉj +Jz:GL!2:eHWdrG$ is5r9!tE Lg5<?ӑbzA|R1*o;n {9A4SW-ʫ#`a9\`~PKM"P-|ϗ| HFAhuðqU XyCR6Bϴn^\Ti}gԈgajO,!+&8e-݇XܴQ.[7r4% "p=- xs?5;]R8BOC+мZ }tBr:Xy^%Ƥsu^l &X!:y4plsg&"W P $+FDvKcD.,w h6]D6xٵ-Wܝwq 7)Njsb7\F|9r?^OL< nˤ6+SCqL\υ/56%5$Rj ֔?k|u5XֺQGU7!cDB?{GvԾG{tT*hWqJ9᱈`.%9Ⱦmj+ms3* e52EUYk '5zY! #M6XegUD]*WI! tNIz9(7Wc5LI1g/ҩPQ\Yw\Jm2M`AW#Iqch/6oy_M&Qwi17&{)ǷfȐ& 7gduu5EJ$:t!uO^,S3;,rZXɦmIgZ6$tkm^T"}!~ϗkAlWfg4Hrm4Yçj9F0Mmhxe"~;eyt)Z;ru5U7~΋?K9-8d0*R`@ ,Ab !L)I f W/ǀHEDAE]cw%࿫nC rM1bZh=j e% 0Чrm:b$#*cPՅG?ryK(YME~Br̖eJ_(L@YrHQ#dئ^db[[Ys/x #?R}Rt.P Ȗ#~_EP/~FaR׋AL#' A_s{a'HZj4z4<37J\e[A֛:*v.4Q[T(ف/C HXФ"Ltr x8oHr6|9ۀin8!ԌeNzoo$GLӧ^lYY ER`|zކ92YV 6^^\Pk=f*GD /O]Fu-a /K};H-NyIa@v.{j%w\{ޣ9( TAW$oURLJSGך]n~S]Y3Jgi%\¯`׮_'rb8+[PULf:sDpӑtOƵM` ft``A%ȓG\)ӉL'Fq 1RrP¹OHx(QlZ',ܝC>v椮 u|N 32A_%J9*?I N?MFQe; WQ2Vm;W gfq6'5 ]:O8; FC_ *^jMjg݈WJ%HhkuTq/̩N@Tt5G>of BG@^u)ӺdURCMuԌψan C4ʒK)s%Y0i2ӛu,s+ninDX<3= Ѓ㟭 @K0R@2h RQ_n$|HR$rw#*p]z6HFH|d7 A_g3(.INOR΀?M'f:Vst](x h^A(4|տΫ2G՛DY%)Px'=: PQR!iF"2R _iz :mGڥM'U5؟T; J0~Íq|NՌ{)8J! Y@xq QFa tRc(ɤ ʡM!w;!j+U\dd m/D/NAD̦?۬A$Z.#~gD5Rh_#_rAh=*)PK>PXy#(7\Rq*rbm#cٸ` ^a8PEH3CE-xRIсSHb7GDe/LJmF_zm v$ WG/Agŵ@-xy;/vtma_R =#9+1]N\%sk5>_SP>ͭƎ E22.i M}V.b?WƧ(OE`gBc KdW5,^B2lܧӜMx)X.Mh=Hͪ=Ol|q k8W8$B1!fJsH"Qer盓YE4[_g^+3 CYx9s% hZ lJU$&.!>T<1`lJ!l sm4-͂H aਇB^uBq}ZfJ(YG N&f#pMX3Msr"Rro1q^#YcIrQO&wT@*IT/z,V['L焋 8]ۖ2CrBYiM ;p"3\dzw}Q-tf2M镛]\#6ZUY4 (%)…a 0jc&y5yYʊS(zrCGnO` RK0(1kz>;rX[b`3`fCr1t,R ý7s()\VQ5j#j$c$ a3 0~y&a镌KFuC{ה@SUKTt|&4#I%f',%i8nDHժ=žbcc@^`@CG*qEt gyK'/Hnǜ1oM (ik)<91QGc%mUuD^'_<ú" 6a!/k*1`7jPQdF:!d aO |`_fz)v}k^vJ2 Iag[ư-g0HX+DG_IcCZj7ٰx49*Ӆ]clbyP4 cs&`S+S̉V߈Z֔H՝GiAmMP(+/R=QAmҕ3}n.u~-'ُ]5fb$^)s #/#Ed?9/MІq{ w^p߰ux^:U4:0@u::]d2xt-(ؤ S-['rs[np*(*Ҿ{).*Mϋtx@VHMD_ g5W{FEA9ؚO?٥ M51 nJ4QL0gҋ3rڑ XCIu|,V(XP+b3lDZ[E@M4 IЇ0#-E`a^qթﺂ{T8(YGQ5$#`pvܕL0o 2͛& 2!k|F_1AJrs8i gbW]<$|frsްh!]Ct =a+Ps&5}}='v!E{_}N՛g,ˁՓw@zֽi%+]9e_rڌYmqA2CN]n% rpnQO&{O?>@Qt2%5OƺEqݶjPE}>fʲnT[ #dq_bӉX .=8 Z&cm$ObӴ5T`r"iG:`y 5hޯ[bp7eʶL`ڴf@bu) \nW)̷ݿ>"fA/.kN +UXj /kWS]?d$[$†*r\yG{ ^smְ[rߢl -g1|b7asqOMx$gOXdAO5I_I}|,հ۽UaTvuZŗ}D@tк {R ͵' L$6XZjNk U2}\'k >~~32RZ(1@.ָbUZlbbh;hE1a[mID{?'rPf[9Ucɞ%o,͡bL'KeXBlZ9S=}b/ȽPiv!H|mXds"~&7=s&ͶűnMʷWvnfF(VRx5$Q+hufb˯ݒ-Eƹ J T@ɄAEJB6Kk(Ui+2YKpF!L'3 YGLìx ]ߴ;$o%`>1*u\E8C}qbK^Tw}nΓ(cS鉄n8Œ*fuG凝+b\Wp~@je 0(2>wjXv΋dX5 KU=@oʧP0Z#4U3ᄍ˺X-r㑬`[Oi>]Sx\I-puBQuq$'p>SY'Db9`(`CPD dԜ/6[ 3 6>|*ZC?"0Qn$ԳԷimS9Ja ÞhkgHPUd8-h巰Q+5Q#YCnoX*CdO\'nLȑ\[d#tN- zmTjwFn'L> 8\te8[-A3@"CL&2 Zb-q1 8H{B‚(XGo3Z9ͫ/fV֚/Zd6t d= G0@&A !-+)[>3tL%` {,2`9zZ!?P<'X;"_h|KlNLLGY)gY\ϩ&YIx鑁) ۩L;ii9SLQR2-.BuU]5V:b9[sNnɋeYGAzq%MiK\n3Hz4j4MdW )5朴_Iv5k;+?uȶ"'DyCWLX{Dwrpm|ds:(QCiC RtzDA$j#fƐMu,vf="[x`r՗v&%rM|4RJ8tp\|#^,G 6Gc k:V NKn /8bB :EJzu 5@e 3a{4+kiކ)D^_NdvlTTN7<^fL%&˰Ynv͢^aZ1!{}{ϑ18>BGBjK 3}>4,S+I@ϐcWRy M3Q,"H(:Bv_K<8vҲ5PSRk$tF |.>a=tr(:s !:]K}Yw ޮô2?"8͜K>B dgc@-/,d-6^&"2NW(- }fա7=v FCv*qOwq,o+71e:>'s%o݉u觎`[ÛH$z bىgy@O59w1B6%vg"0 l[dFPswulz\R5/Ihʛ1X>Y*AuQJ![vxcTޖ`R|ӣ#^Z2o?=ns6,hxmE<݋&bNQ{#&v Lt!jFR ,8cܺƎc;%:R.CW =|)nbix`܊ cY 5-#6lBݙOܟPCo.q4p/+X6_gAw&;\hQj^]uӬPMpBd9k\p 69>8'1 bJFǚhkyZYR'pgļ,{#eeZQ4LQ/ͱ3aZ'߾Lk) E+YI0S~dx1Flf=@gG+Ag`7}̈́'s Tip<\0EP{|f& w6C`Iաg:*lsI[>o,bo]᜗ 4*Hֳ^#i3EQ;}7颧ޯHݾoylU"82eˋR_3x[nPtה;[xp&KD:phz@9&^&*GӴz?<<QxDV`ʊ|Cc1RnjnndRz(϶y˘b*wkqhL$?Ƶ/0AJ^{ΖFЅX 8vV@]`ⓌbWHo;<= oL_,o~8Nʔ./-A-KnkK(>U潑є5:42K6&{6G䂾40f`m2NaӊDYXB}}xBJq s|zt74(edKۿlRȿsUa|5 X 0,H$zIZ. ~ތ:Lԝ%W{JDKO!2ɕ dS~s^ax~~ltn515=R?߫HBGڧ:glv?=Zpuw~.kKg3rm9g\f{2O.4s"nEO~_m(ѩt&[&) 2Z@rU$YUJ'UlX)YH_΢+ ' ؉CvY" i]=wŲr?>y:3Fۨ*R^嚝XCvHL;p5Rtku̔Z0Y`O bɇ/£X,pY)7o'F #)*wTmvhwrPʶ?Vz[gue|aj j{ vޘ%}谯3q%<{v&}Fq) "NiL 0UBѶ'A=Ba\A&Y{J.0}VɄ頩鮁f(Vj*玄toҨg+^wU*" JZ' Qď(hWhjأ sBxbgn[r1CwA*h:*\eC);Mѕ v* f:AzVRm"t]9hkZvDUӷd,`s] _m8TlAxv.A_x&QWstBK*:.G{&$4ij49G^Cp)qꪤQತlqI0ԝĪ`/-o =]BN~Z~_]}Wy/nx-c~}^F0#>[arAo9hQױr:*b P/3'DovN4p~ TwLj=&wNdq۹X'fMtEŲ>9Giwk4ʓ% xsС" WNJz7̅EzֶL ~З@Tf6jAOM}6 T8LdP'Ā_k;<|I.H_FR~Sߴh+ͣ,49T-$:0$6PɔQ'U 3"SGfS5jIuP(z>}#,<}|o]˵~:مV7P<%ݦCttg<چ*$ƯÆr`i؋0'u5IH•MY3x]4Th=>J}S O*QGzYYl.TJU h?0kN` vZmMҭt+THEt1@}zkEpq%=MƄ pm1c#Zi=P)U@ &.V0:rz? Fhmt@}j-׉_!W 5~74rZ3=2~Gˍ& /B 7pt1bjTJ'Ε_uMzr.Y{{aݲ}Qu@G8{Iic"!˷S }KO)A7ԕ 1HP&HY];M9@ &L&a,fvaH#&wVM/Y 3Bhzj?E>APJƙðZxEɿWSH7xP~Î~yd}4-3 ly8ȹ`I,۫Qf qyUoy?Y1<ͦaQ'"D<S{UHٞv@_/1.qЙ ČM;cRǻPXl;a6bRw4Ąw>Ղ +x ~V̺M,9b [w3(|y" H\sٔ S=e a8cr S~G5BQkgۑ_iB2+ ZMmN1r7Q ߱Ɓ`+tUqVЏ ˣ39l-ɐL`FpOp9~(t ,hx16Ӗwgn&}u"dUU-R0R=UPs1>ۿyQ`)_+7\X:vígGJMyo&pE'1LLr tPg.SG;[]s)Gio;~7Li'(t u1.OE;`F.ٽ<6*_S~C~A>H܋wss-ug񖼒MCK6hY]uFx6<" 㽧z yJ=hq8-nrFq>jyq$q^ʸZiE ?;Go_O Akyۛ7 dDT-acA V- R#Tcߠ77^!:G.ݤ'>R%nX$m&_uckWH~lY 61*g]_ Da_,%8iKYNW Ja?ޏ 1W6&_1L %(>8t'BJ۫<ܭ֢ՆvәJm[nf3tڵ Fdlx+|-.w$OUDH(tԁzyP!Nϯ;nRgd:P4Seê"Ѕ/>2m-T姷 0cCwZܿ_%?lL<\2^ ^kV%s7ƣ^ P02h5i &eW`5fGd{Mϩߟh$ C޼)ORYb/Ea1hh }[ojӽ_lm/-q_;{UaɌԌsFsdnƢ1"Oizh_I3z(6CC&u??3ؒLaS4Bt)H;YFɴŎ3yw+jY\؞F_w/-}L+&:(FQQuhb΋0̈I|ZK^p^Bϧ657È3-RycܨP*Z]IO,(!Tr4>o.&iSg7zώeú=y G[emdow<lE\ ~Kt_嵙-]Q̝BhSq/ϔ_XtXd'r: 5Bi>,{%>=ԉ `|Eӕ]tAlPgj ט.73}9Az9 XD5io ^z?߰hA oA:M փje^MӋ\t}!bB-PެMύ1XvyRW'W=Z5 62dA_sSjPeݚUYl&ahr LlL{d̈K_!v$.D_GC-gC@G<vm#heXQI_7fV&cqeDR-jXo(3#EBʬ];uMOXًh(2dul>vfZnM 8kK6PcHATYݗC" ӳz =ٻp~xnHnbAqs55%6MAI]c_L`cfQ1$DqWcyBL띗[ڒ#ɥC ?*Y/f,?֑r[&m qu4@{M7QBD/r@;4_:+2+q&Fr筞Pf:-' Ajr;__9[A>ÝЯZIl =5O0P1j%۸B (F*#|ՏǀnbFnx >ux]ڻEM)!Y pEh5\lgaIvbRʘ騇.Xa+M ? &fU-.F\-= mjIr^RG-+IcۖώY/յ@p4rHEPrG- ^rγD@>UA?FGQu+rO T'cIV멘dz`g:v$0JC.jgZ8̺,n5U-[Xwd7 iBrOonEϪPr/!QÈ$hj|k[>j Ҡye3^/]8נ}xJ7%央fPR¶sŽ{?<~QyyfO;rԉE6MMǡvu Q'txwW<^\}`\E䬉޺_)֖?0{ ,zCaAo)7VӭTe=}|#-> q3k|!zEKݏ~ME+H*ɐ_+B´ n|eaK B5q$S&g>C7/AX(DE_Z\$0vɵ?PM&ziaKAԄ~bNo V/ Jfi50RȁȞo q\}B(%:"=5Ӯ@j7k|7'isQ$\qU)vd/㆖gP9=<)أPvbb z b 8y+\>=^ـVia<4,'6mKlJ+$dZ[ddhq*1a w ­fZoIAV8Ayvz| ϝu:jURwY[uRpsbfgu qa"y;^3[%g <\W.N}qMR]`8v$Oӑ ОQ]);-3ŴfR1A%rYߑ3a\{"6XD08W*N2$j/͝IK[Y`tc㩐frJ +& *waewVn$Y  \TE1_Fts]ϯ,.YΨ0dha5] E-cVF@Q-S Z')[7W7A4kSti_~Jp%!r?g8ĺήة^/"^Or.lu!8nz;|s| @J"˳ˌ%Nwc&r)FQ@adUǪsʝ+ :$G2-?hC ARH!o_ ? aCȋW#m F'=V +p䎨fUdfv~v?_W#5pv7]Mr{3Wd԰>q@o `+AĪF}ԦbVƿFVƾ O~ G*F| Ϩx秎D~Ns-EN1Iuo[K٢؊g2R[\%$wH$)'DoiӷjB19p۾㴗CK{Q O=F!smj +yV 賘Gd쬣ƾE3fZ̿@lS맮տM g =oVj*{r(GݸvY0ue!]3nv=hQL ~/(亭_)Q_lģ&4[M7a})ҳE PoJ"m>mCfd> vQS'dM_!f}ΰrB??eSދWg.C- /3π.wGCRy<Ȩ_V]qүu"w(Jy,797rŐv! d)˓YS¾FRbfMx0M$Y#B4$ZJcILY=0P#iNBmZZELfGh.Pq[#}C]È/X#4~֊'cP9A(E)7ŦGq(o6T};M+t EH}ӑ&b#E_*M^}Q-ՑجJ@,ST4(8!"&gӜh4=In4Cl(WMU#яU9.s6P˳YJ?(\^p{mI/y]7&C>? ;==+ۮhQ3*~4\~ʻ! G\n.AS7ɩ3C2J_?/>' \7O)Uͳ^W?K2u2:LxhSi;GƉXe厢fQ.' g_@9Yt 0Vlz\YO%1?I,+$PPPѰƝIqԩgD/\q0>Vѣs@bO=u4OelN@?< O~|aQxk.Ad\[fNF[S4!{Zv;LhWSD[#!G*zĕtJ k@ S'UvXv["x dj*ەl3PprHWb' vq40AÕHZ -4Ҹyf|`m< ʅ# KӇ@mx^5E;&d a#k# i(4[Hh5.Oٸ<=#SKܧ;VOs3}-z6& m#'  73~ob$ߥS_N.:zg]Eu +E2G)dcٖՔLP/7Ф k˳擁R0%+N~xfu*:9L<yۏ|ahS0!X'?:ZCCP͐<7c\/'Iaq4ZadQd܈2QNUF2_tӔ< t¨{tNq@ͯٷj "I6U;6bO2j3YM֭R~QNP|٫wjOg#A(\L,#E}ZE ,cQI_G)ztت3Dd; ~(5n=e9n|uZ&X4 nvUZ!qW = \L`5d~IiҀ)]S67VivKA!tЛ%C`vUsWFy}2'ZF.ort/OH9;@N_j_P "OɇoT:tnC oWlE{yOo_,hGNܛUe---U&^\,S̃mvH$Ԅlx4&Z+;۩tOm0 4=3krooӯ|x^HA>GKiK:g}A?|_N<8D՟=/BhkB'T}LǀuQY!Ӳ[JLEA<2tbI(2kHP֔8tTQ(s J) -9'h(1dԒ| SŤQ3juy ݇#,PT?X[NrzMƬUÍ519CL/O>Q2]gB+P4[d& ]Kx,|KyߦoS^3-&m|#n%_ tx邭vAbt8b{J͟Y\~k>&lCF-Ul8iLφ$LldgBctd|xWZ(Pbr|NMg8 -7!kpde`[VvI4#.`s@@aFW/rSVhr9Jh *=jsfS[Jc0†c{sM:r8 %G F@9kfdi <ؑQОvå_>s,[@S$`yOV2{rZE^Jy TOp{!W~EB[=Rev|/Z/*Of^N `Y ol̩|$( T{szKstDNcHVLaЉI>LP ibs5GpoBZ]k6.*LMut6s`-L~ 埽đ% h,a݁{>f&u+itB7XNh|{w,vo}̞'sw8C^+^\kOI{v@zD5&wɀؒkGߺXh!y"׀LD مe w>S:}),ɷ^9[PԄqP3LׅgsJ}vx%d\o\ʄм$`"n%l4ze|mLZjj N e5fe^Oʛ5 y]Kj~Ok8;?: _B{@uur3H $&߼x5TV^^ș(C!=LqY2:30psYJ~>:hwl1EZn, þ.-u) 7Xw:ƭoКUƛ2MO]U8P sS^2f,镥&}~|he 9Eꩌatw;9M8o/8Cil+[scF8Eͣh?q3S_3)Qc}YFҝ d Gr]ZQ8q9N~~n3绩ǜ׍Ŝq4WA?SP${P\|`izǀӌŏFXMhguqK>!im+8(^9nISuo+pGrώw^驿Zc9~p8]VϟCXZ>Юo!Z|]>sU8VniV]z坿R5u_~d < r?>G_2Qv;TL>Ni)+. /mDlϗ 2ڌ!׶N}9 0 (|Xv8.|+HzeaTO˧"d+L\nhهMr>o"}/G2E'))e;-==Hi.V+y?n~\=㒀{ʔ"XN4%A6՛7OG~O _@A("/d( BU`ec)$b8Us 7GUz |& *.}X*( L@"c?7/R9䎖.fKGHyBj<b> 6] ! t#Ex/$fڅLBE H[z( ,wrF.y4z$ho&[32߿^"}f );.Rmh@h5 @$nư23^)эe8߄7!Wy He=N w& C9Ъ[|R<;:d=D8f%y-Ϫ1$j2al DZBBQE*pZF$C<)s$dבח <#"8Ļ5>[ޚ@?/8meAQ &sb Ld.4MKʶtl= RҊ$%#L|J0HdK2e(2˅ssɉ˔XS4, ^ѷ(5(')A*#5-Nah`5fI*Nz f"wWG)k,׎-9 M#ע/RrG b3 ŸpPoB?w_=<~ۗ]j=&T&a_D'kz *5(ggHv- -;-j.T>Zn\#*[,U ɶ*?."$ߏ=νx@vqC)RJ3ShZeYvTzSPu.v[D0Dާ^o!|1\}Vwm=q?8'ܽ?7v+K+ºob߬Nճ0"ɍrԙD!%zg÷/\]@=$[B@ϜWXnymvKP8ui l7l#է\6Zm[Q1U>FțIw!t<#vI}59vw;^ ]u9-RtH8 5pNdzwcLEfC!Az?h3$H|ϧ6"dޔ'w4f}|] }O .v^!Pn￵yꩉ7g:9r[NBG %o`铨9_E;sT?ݺs鄁S^di 5qD FLWF폕 =!cHxsEaƝL ʓ[;3 B-Z{R眽&>|_ö^^:e0RkcPDO햚דyHuvcS0|>薇4ͷ\_:md (V8 iZ.ٶ`_Jn-Z{k=?L_/ΌxEL.FNl].?6/S3BT7l9A$Ɵ!J}{͟KAW`EjEh豺TSNvIg.3LQ$@iQ)B6 HB5O<_72,KDxg a e$FE55;fotN#K !7fttKm1 [اt26<ZN`A3-nJԪ可*Π<gW$o!ْ޸^}PF'S6s›ǒ!SkӇ=< k}gED!)<{5T(#\~G4pE1SiWH44|OwdfI }MLshf| /1of%w \bѪ{ߎYuZeS{ŵS'|%</{_/mc?Eg"p<:+ \gUYj,="@K[ޕ7uiS4Yw{HM8:xYxF.b}3e#~6{>ٸ~.L giƦ6}~gL~>= 9qh $;T"ϐGF 4M빜0vƺ7*£?2w 䣐;aj\N-LfoMVġg6<pn(tcο)I"儆+W/>U%e}>޴b fRxҞnNJ`oEa3љ{jה~ܰʴpav5m bFJOwoɾckђ#}V^=QK ];zxպ81r Vnk(>=?^:ʵ|דӿocJ_Z'~],av4'8݊-zr(]^|a[e;ܽA0J [qz{9>HW_d}-^}v}B:(7p]22=&@O92qlvaHp/Ǻׄ]x>FI-! }ژ=[:|/bnJ)z|omcws|i}3{if_{OȵQ'}_t2R|.NIx^νj.B?d~ <3*6u_W{UZ9HЃ&KXq#I$*Yޚ _&V(>:>ׯ}Pd5_絟KLURIRFݍ(7J>hOYw&x13QPV.ڲ$֪6 {Lߧ>.4^s ^ffaW]* j4H5QBxʙ4y&O N M(ili0O^0̎ HsS'{d:B6𱧐7-[=wLrbS%h2תz*MuqR߭O^vjf+vr0v;:zm͌G-K89e:h񙭰6W8WfwC]Z?,wMgNYд¯Kr]_yjj:nv}Xim%|'He`JQDtP%E y*կ 1/Yu,8[ڻbѼVKE:u }^F\h~*(ILS0j5>4.A|ao6A'.~b Ӟ[W&9>^4Lb1C .1䨰}r6۟hl|MTo홪ȹcTDՑLG 's΅9YO]^f8Gg8tdomMo"Niה3vMiw]oNl~W.|ܢAtb~Q⓯bƧ87?KXμ4TЈ_xGaϯ~_,?S|!y4xyp.xԖ^Z/#nA?Ew`c(XKG6i^emD)5oN k$q1tQb\ozT:xܷ'  ѕ3@eZ9Xj>N[U_OD ?3_\[MR_לb<(5AԉklsuV#q|Q~u{0Bٯ*Y7Co3_yM9cEz˭QQ3җ{T8iy%#zet-}5&]^RuMKڮB/vtGϯ4tmq w۩X:YR*$Mhb=ϙ"=Jq`x736va29ϟ<$]A2JD[Pͥs*msx.x\9C? pv6@ ~p)a .0|䝭 ]k?A+Z$\z'egspuspJ6vIO2VP,̠B+Dc6_A(׻`c5D,phz&>XL)kxuh_uƹ5 /1CšԃәƻEY7>_?OOf<;q5ؼ8piB>az4_R OLAȘµ=:zRp rP"5:n>JMjKw#+[NhqDÜO@a!e[_U.ɚ_3VU~;) rs9v+>=nimJ^Nl]˸J}tީg}X~IRt:{^Чwha+D Ւe=_iR%J;o7%=R8EH尦<p&~דuc,`< ϬռN}%wƍ, BG|L0SSrxyU||/j}Y{v4Y 0S \  N0=VjzOm1|cVa5 r ]'xh¼wzvhg{iՋ:) G[4(c&mu=~ !jUƪ-t^pe9\F7V|]sJӱvĢKB?ԟǏakAn{ʭL<"U cS.sKnܸ׿f-:^وO)oq$cF]D‰|}Cilb5I˕edTaƽ9N̹og6/4'{D֮+cW6&x##jXKj\Zֺ|35W헣{˱;zQ|qr g|59ubz!0Ó7مobJm]l0[v[ǢϟggC}(+o}tO&&UsKӇt'㞷·{ńVa:m䰂E38/# 78yEC9 -{|Is޿nǵs+}~sl9/چAp-h@c(!j_öW,AvByT={'"Y_A:>os -5w<NW8? ?ߔnn^ɣϻ<_?OL.P=p+ ɫԐʌ͐W )~.k埶p~Eccߧ?'^'d)Q)4W$~"Ⱦa}J.{ȚeDaz̡L᪤\RE둓d> #}Bd]\|xGG :߳GTz=_懔/tE!M9˄s{_bp /? E I[}j}w#q. -6۩݄vN6Y۰*_L?%x~8X܍ Nq#:ץ7SQTyI8 >` zkÎrC ^$6cT,-TAg|=iYݟO]m'3 χF7=&̿4T1D'}a)4xm1+xq%#IokYYr/^W*I . 6h2/]"oUb99^/`[ ,8 ͍yk7_ ͶkgڜҠRffvYH}!8(Lm PPxv ۽Qt@,8)ħo~7zI>[gkA\tE W2wosgV*W]/dcO8}a];]cJ`I}LjIG>EaXɾJ ~XnL?C偧TGGӜ~}k?|\;r&קu0 d21䱹.?m#W/SF]:;; Jc|OI^T,Y\$h/E`Ñ-7 :1s.̟5a]R,2G@ȦGŴ> aJ$eD uvQO,Oz}+/Dp>࿦ fp)'jhnpH΄ ?_V*{6H%۞db]E`mԢrqDVL@ϊ> ?NWF¡ 5/X}ZodHK]]]._QKuUW;#M{% gzpMyx~k]Mrdhf aa"&-4KS%4&`v(x`YS ‘O)rN7(ǫ{ Ju@8YӌXD l:?\csR#Yf ۻT#,ﭵrqҤF!>|ot&VD\?xVi)nV'yq T`'5"Nޗ$7};6%;K5dz J"^'WAE$`lwh]׳6$l )Y ؽG^oc0$R7G?Ĵͺ9/# ʻ_ldz[eǍzg~>ɛW/ H:@_n76Pu;75}֥|#{kesш;x>ur>_ya9AOE Lcꯟ"fC-|{#)(tW6v4@he?1 f|, boULgJ#%g԰ކ=~>?582Cјb*1AAݥ?O_ >:/'v2$ފK{X-c_A ^^;Z%-T;/SV /<Rxtb!k  歳PqĂAC06{3Y"AEZbG]zQAkG`y[ㅿ6茦HףrLXD`p`yB`*$~k328r)r#;dGlb_]% C(j~կW/_Sv9[7x[vI, ڻ?TpO3 F3ꍷ'E1ߧrޓ'=9t|8c ʓ.81uBbF/$ i/|hg]A'=tjyvI:*>~0{iب#Hso66Rd%X0a4}k䘈 TG.[T+k_V0S\w/ʢX 'ٜe#s~!VzH,:)'o3l B="^?ϑ2Êe;k&7]":OQ'Ϧx#R'?y~VyA+߮Y A,!s*)G(?K{5#&S\('Tx.7#)('Jo蜓@uhTJQo=s ~T.-_g6V"AB \ 4ς T+iPtNl>M/[ܚY;۬ ^@ʣ_?ϐf7pm$<ێ]ߢv2G]mTBgΓv r+>fdݪUYϠQUW!dG_I?-/e̜~)(m3l̶- B0Y9A%lSo)[:V5F9JſA*9g j9jCl25VX5E7]i4jƱXQ;oIa%Ϡ)ttZ(׊0,E M[63M6,'omqV`-6bz(~>b$9;N5pSHĄz6>D6|p4Z0\YgMaA1yB|ȲXzjRc(Jԁ SQ߂|':}Dn>fͱE/؛|,٭i\;P~B!)[We(.1ng5LJ4r(؃tRux!5hM]:4&睐+,5G"QAZev1~VCu,"6pϽؙjRڽxWaG_?9/̞76ЗCn@<_r5cO?Mi.v`M-A",΢VM߿Lj/UA/aTg*]~P`!/I:|:^Nj[>l?.]yyZ迒?YgLv->x q`Y$; ׵<߂8|~X;Kkpcs0vr^}9TY;i{ȤvW{XԾ~l$6fuq=SZNtx$!G^Q[r]zMum=سG:qdS{GhXh,3i^r9x?ovG|N楢teӁ`:2!N@OGӑ-4>ķ|F6+C]rK>[&-OY~bgj_>˦bCyjO[^k_ySlD˼&_ʊN/@}9{'~7瑟uƦ~b%#2iKHOM}o/{|vހ/5'`W;_;sXSr0f3`45(acA\ +YDbCYXPH$\q<=>o|~esݡ]_J})uG6͉_ʩc1Tiˑ9#C>xpk܏zypCܿabp_z Qe!͗Zl_3/>QyBN_oLޛD;AM)*nW9QmvD,cOFrLC}h}V#_kO_nibcLoU >`nv4 m<迢l#R>j|+935G[Cul Gu:|Kс (|WL ǤtˠK>!λY}vnW|Xl<Y|'vObxE)o:_jlQֺh|0[wKyv B9sã[7ʨe7?uF2б0TDCHJ4M<ѠuJsJ MXo%'^+|~IuqGj E_n(+/̟;vn/rɒ+l@G3$bu,-O-z^RBu4Nx|]btJ~+ooJV6Ə"6w^fh|Co#pn.a )<rp~buiDg{mzM>a3'Op.ߕ}k ooG>;>-k|7 zsqL2qۊ-OiCOy8du4>h,J II $zCb(kVNw_``:zzr?T{l/p|7b=xYo^w_$䫑w-OLCM]1MO=t鞼!]~>9mnMHt|^Ϭ,t_N~ܟf}~/_|F_Igfg~^yv1!8C͌8q]# xɈT3ː+qxhpH(2~+#@7G2x 4 tۋK c(>ݳi__jzT/jnVO@n> 8!9%p!.SkDQQCac5O2w+,E_x^;̰O= @$g^pXf “#iOXͼM3e-BWa /QΡu_#zJSW/I5>/%o<7>Wl҄/筵:NR>a>uAe!XCrŏ4~}am>_k$|O#ye`uV3.w-zп?B7W_i-@ԟ3hh[ekK+>it5!<~E{wP Z{\ҷ%:^z1؁m9W\}¶gމ-th\3?gcnYٿg4žHKP]$={>{s(f;._HC*~Ja~ nF'tH^I:> ,}Ko˽=4_^=^8w_?5Oϣx.&ѻw˿cV2qFw 3S|3FtaW*nɿOdz&80sz~̾m'czU}PVQICyTg}3u fjd ٜ4j/f^2(SBtU8( h9q0x_ iBo6FoJ^5(_ 9+ H_E$jDz$ZxBqo38ٿz39۬5 |D/_,9}Xp!=Viӯتͽn^a~5 [[߭y1K~4]dۣ}2~46#oIv_ӟ_.=nCvȏagi4cLV$˂p0fs7͉^Kl& \O(k㬔34*ulw %?KH>Oƞ3/RZM q&)}^־&sQ/!׆.6n|%_}~QKڼY.BS ١=B\EYdCNF2XKV~3";SBF_,~ R}ځ2=ȞM~oU]ɣ7N5tw7l灧.nAO{f&"bp/1܆#.** vjF9fpB] [#شRBpطrOӨ O~JX$H_o4':;6EeS;Xcmqզ,jl.-# b0٥Y?ߋ|*H{ڞ=?0>~W7?<7׾_nGK^{9Z/xE]ktݔr35y4؎kܔ4w~Ls3޾c<_=i쯦7VIޯ*%ȡ}zˬ ̵f>I;:rW1OݥB O;p8`ts!5^ϐCFNdSRn/~ 󏉉=|ɯ] mI/.؉nQN;j롛/u@uRO/B͚߹Cm~sa`D ^jC#RBXTfl#xЋ%E2|Y8[=~)r5ߩ3b/~Z3tNm_4hR?? avoM?Vyq*b^;zޗ]H1P: ҏlOx_ƛ σ: bb0][IesF"v`?ܻd2W|aX<}_~Nw h @DMvWq*o7xَeNǧj?Ϟ/?g;' %oa1 `[1A-+BhcXyVOO R-ݣz_HQ(Ԋy%uq")՟aAG$pg";z 3]ZzD!Ph`}Q'?a߿vg-.~pˑꀝ`gOYY *fN:>;7>8a^}9߿TsĀo K41p}\S`lUG,oE}i>]Jk-"%݅r ?p8>~uB!LwlSZ,3J/DXܤ_~jo.Mgo2ML+׬S*]I~YP7ή/$qHPgvǠ+ZcĎQAd%y|֍ۼ ;Z(t2QI$eof}yy?__xPXp#7 A*?㟰bCj,<@ zỗO V[,`T)F68C#Zق)!7*5g@g࿻zV0vcxLHZUЈ0a En @g8$%@ J> 2 ĢH?w;g{/#_{KuO֟6ipi.Bײ7H}WXM -.sqo}=*XȕoiMO霺I;} ܞ@ZיY ݃V`bǏZK{-fZv6 %RS};Fkv :?Z}~ťqcGCo<[>Q/})_ڞɉMdHe󖬰,xJR c!ԗrk@V՗pP,I>l<_D߭@N]:}iWr0s?RgcCuhS=uK]LY-t_DVnIE'&z\K5* 'sa0|Rq)%]< *wehjN^"{B7 ᳍&1dh9a= ]9E56c-sCffR7pϒW)P3\'̛&E68i; jЌ~e`?H0arV럪>ϋ}vt 궓n:[of<^>/|{̯㟙 ~_ /^4gNzW` ?[AߒuS U =Ių5ne3Ƭ۬lBG}{|Vv̓PZ`c p-h rjl I7ag8ށ uEjЦOHu5imKM3Tח3B /ϐs2.8-d+\Oֿvz,^(rM='T͞ƂWfKJ7_OnؔZLz+~߈ė SH'Qñj`F o@}Yd*n/8 fb L[YPYvA;*@I"U,H,c<7 ZNM*f &&\Wн0i,pյ“ 袨d %cG/)-OGλ*pK@9[I&+IYZ,\#/۶љ/?:~_ׯP=lm78zQl齣}sꞒ D?_0So:p=S,'qMY!:5I L.dKF'*# uܻFJ-I,w?p)N^nm_ҹ>O#o4M3?M|i7~ }? EjߒWAf]cy}OX=dA,|Ŋuj,A{1 E.db0IӇ8OҌ=# "bM h!`k"<Ƨ9zxEI„ $C7L֩IG/&Ցu @?$si).3h5lIn3eۗ_([viPGG[@1XSj9Qp,{YP8 l?uߟ7 ڀw2kXc#{KcSU^z'ΕRV F_mOG;ChW[eeMO}ĥ0 &v_GЊހE1!F+ S-A%!Hư ZncUn^B^pp "$3Iedn{wL H9mWe(-x ƱZVv[S^hvی YЅ)pݓ6hWIfE60TmQG!5%0j֨b5Ubke +M::Nn1fdbҫ]voSO~lkŢCB+7%׫;?v]άh1&m~}K&z_ŝ׎ ᯄ2o=6no&R+ϣ1H\at¾ |(2M/]B1o ^R~xpbH:f-_,𐅀[dr_"|d@f2D 6Μ0,ݮDt*+m{~0o1*#KD68w:{i/]; >lxUOXd2&G"0!!hu격yx,aH$Aq-UY-/Sr!W .RR5mٖDDgͳ/ 0_Á/"S/wi`qUm0fHB^8ɯ36lIU-[e$4;m' X'JEYZP<14%nm&HװSrIVz7VsSOdHo:~?TU' U?7K] ۳-6Ʒon ˆKbJsqyPjꥣl9Uc\ k*YJ礥ǍCwth$dp侴0k5UZc%a a9&d [ dxac[ ,Ut+8qv9>9?YS9V; ^ |i.\{obF6]mŰIu"P2Q16Ljd)UP᧵IU$s!qJ8m ?)os@*C5r,ьr=kIvJvNYWq!ȄH59zzl#n 6.~]csֱu?a~)|0MG{xZ(x<\1p@8B.]OƼzO@d1t #ͭщN!,0(pn|ioaM1~#dk֟ WPf9_Mr0Z5UvCujM,dmz,3!X8g48 ΡrCE SiZjJ/"BRB2׷%jo9sw9JTy~߻RcKzwq~qѦVɬ-OǔLQ>`c(G>8eerIқ2C9 c$^t7)*up\q=m7 Мmvz{DZ5iDv{E18$× @HJUʀ!zSSp,G{(a@JCmÐQV̤.?uʈKUBymn%HC"`k+ HXM n A2ޝ6lقz&3f-/PnHgݪ(I**Jӎ&U:$AXH ai{h",|6$8 mcE%DѫPBѰh.&t6SZO.K9q,)ѬJ\AB{x 5nP2"շU<8v_`j Ok@EK7ZPX;2DZ%Vx2.M=XUj&uÆ(d* ۖ3f:muXE㊽%+ Ɍ@Md,sphe(k h̢c[ f^h}2ałnZĉ8xoLn4)Fi^pƺR)Dn04eƶWc0^6JI@~ R ^#F(1B [ + p̓"bPb ֟![O.i%;L_P\x@ƼO$Z vVrwF)Cőц[EYjc.pΩ禵b+FeE&yq=P=<*~5>x)}QhtqU$LG%Ѥ'2f*wPP X'~+t_fذSQ'YrA|j _3.SXTddЮGɻ]z{GrEoN⧙|nI+4$(e&7`@H12؉adv0V,AY ĆZ׊7oxjgڕz]x&KfdEm]vі0\0LqQM""ƈhK5ɨf$UXV;Sju4U(Û ^ղ.(6:& Ӣ-|a рXC Ac0ՎzqSG")Vd,X Il:)6N#.5_?& \'>jM'Ծ*LeX-١,, f Ʀ8Xl:*i9 #2}%IrMhQ8]dzMȸGj2P(V)/(Y%|16" !; xd?:k[܈=R͑d2Qnd.B{cJVŀ\u:kYXRՁk߰s$舤Ţ;YIsݘp W̊xB9-367j~3Q3бxKI?h>]oz_pǥf,] f yIk;28HHEAQb bH(ʑYv)'8+jaq (kjhz2n`ԣl #jM*X:lCXVLq*zuF/Nڊ0QV&tN>qHek@7%:99P*gHIHD;߮k:EZadU)JLT2ȮyiʄSxL0(;VMZGL׮vB :_X\UHJc: e%$-aėL\X, gbjn&WRjApKDBͿn~KpR/Zt58@$Zb *&1㵓 bw˷@td0\Q(w7z${}^[*Q企^VDy6בCNF'6=Ҹ~k96L01X[Xr BhF")gQsRJ#CU`¨etׄtÄ"7$6dB-ZLfwP[ox:Q 'yWsfLjA+.u 5aU2pUWTi/ b4ۑ߰Y ؚF'+6ִf8F;J`-d #"12o UZ+ J|A BD06 h^Cj5}xM3Ѫ!ό{XZ"s[OlCQˡ!-"J5fٸ7v&*C& Ӂr+9+bT%u&Ii @IƂ-2V!|L9MxojYZvJ@Uai(&CM &.%4&j *ݬ(VR9kB^XkzL҂14)AY{f1ijjՊ̆L`S3e&:;$E5WK  CCƃa4D3F~sy^deT GSۈ3Mdk݈TNynMӐ+ ?TZ 0K^L`@rVx)5,U2ё):*l޹"b,xXًf8990OD+}*HbNerybRnR$ y BҭXX5 RerAU #F!Qqwj-ЅpAfcוpˆ&Z8\MIWPV$F"DϜK/1EK#s2FDķ 9uf\ \Za8(1&$IOugbAdD!B6Ēj&stka|5rE(FFWtUWM5@ 6[zQ|K;|Ӣ0>W8 EQˏKi+8CqMvgfiV 3Hù A) 6S*:^WBA5$@(` u{ڍfVk`1\@F ls;Q }Ѯ&DjEqWGV,{0n(cl*Tx;Vzx8 =RXЌsC 1&5d90lݣg0~q,delqX.NKl揉yLB'F+⎤(1DJfx9n6[$Wvw-MluYLZ,3>M7BbXЄC:!(2ϏrGJ&L:ZNY=Do&5Sz MEy7l,l]a&GȤAk2c)bEtpcz 5G!'U9Ӧ; A <"t JM)hFǢ5,MF2*\1YVDj+NkGtN;ЏfDֳxU8{05v`^%P}:2śL(U7caVx[vP$Ĝ^Z.2_kXiO.՚4!1M5B-sb7g0ᙵ6 C2ފ R1%l-\I(\Z0ۘB#/#%$a~NVȆPWUĐ'؈HJs`-]PuU0xtlM^o{V}Đ\u.̀tkWdLjxV#:a(@y ږ9:/,QB#Q \q%]&S=ۄUo ıjwº^@.l-If8]e`FX^X!Ul'5V\AI<4RE.>86җ㚈Md*SK(g&ԐF~=p3^fڹ];v(Sv`,,B)j`7ՠ@wNZQ\<ȭ$H>==q R$|u] tiEX3[}FCxSЮrF "ZØb5j|lz|&@-fRƓ略,q$Ϣ&Bїbs;cq۶"8qQ<'ȐP6b:\>j~ XRPLDi$L+Date.# \VI/kD\hY&6؏9֦k$a#eVuU[e. h#V-Xr7c06h2!1mGCtT{Du#;q$n,I|cV-ZV8>D eo s &M'#XfpĂfƆF#9EJKK3&W;lʉ-)lqƒRCeAg?A)hDa5`bȧLX]8 b`Qr<\)G}F,PI>HĎo&󉓷0˰0jN("xHh'RX |l_~d+VУ&"Q1o ; [U=) MD8F7QӓpAQYrѯ9I@* yC VKVC(ȂSSخ)d }9[BԕSm2 TӬRȓʖFe'9fܤ[]uX,RR h,&&tYWDshDFQȋQJ7!"X4Ɉhy &mx0hrftsBn t}aW‹8(r1 e~ƂPrj]ʍ W5Ƌ24٢Z9o #ka\>k5,Kk)ŎMij4ŖB䎉x~k-ѤΧixk4Srɮ87q%o)͕"i(Y0Pg ю2`Ry(RaS_cmH`F4(ZfUdtjE5Ls+Brջ*+a=<+Q)(Fu',{MIy@.A20d«[i'c Yz6/P*+~Z'4-K>/bk]a d3N3ͳy^OڲmEByBLװ <|8kJyؓ/Qt6ZȊi"= X\_i+w$H3tRysG "-=`017^үھ *~u텋^G+xq2]-é@;e~h ^2 n gQ]K 0 nƱJV6>jzFk1E qi.NEWQ2MȽEg6twW"6'Ȧ)ɪo[) lTf@L,DQE3rH^Lqnu&p̾=饃)E3ץq;n-^D='fXM8IH -q:ᗀg6 t^60r.ވl[!_Ee;@VcФ8Q;S FlE:1mL*e1nӋҟ3HY__HBZ4cA {M޴"^E7[+m(X 4OQO IWshmiJ(!G+ a*H&qM{ Nf.5{Siی=u!\1Zz"#FǑ+ED#]~zQ szV3]BV\-pL"NoâL:1ɱiVnLE% r3M͓ZM:/4~d|SC%=T!F k /q|Í-Zf[/r1y*^&O`ZMt[2]rB350J%tq_LE^ E˘N82QlD( HT HW8xdi7Yi*NcOe(߼6Mo߼+':k? m|YKSO.EJJT tՇbQ$S?(pSEVag2E݊Q7.i!׸DÆnKna26WC%|qJn&X@ʼcV_DL_M +eddoa%2oJ6!x;__+bm,LCQ2*k14C&o JcJ|fv>xfFAL]S&Yh|:yEIˢ•Ue=vF`JFxE:ckrv{&0WM·UYik%F.nG\8;,6kd(ROjFh4eU HZ\~q™ ΂25sg(l$lA^ G9F$G)Mm4b!^I93b2XXKgr ˖'} xtU?-[Qfؕi/_lV5W][Ihғo_Xin  ߮^*Z0ZRԝ7%f%ZpiiubM_F)07\ SQr̗(2ZRUĆD 6ge4gJū:.T>*i-p NpDI7:?sI7!T0%yȕ3~Nr0툙]7OHBovdC2QZZmҘDs${b5ɤj'_~JwE˱HK̀;[aWKrq8)nqzܕ$%2CjEJkrSRU͋5 )]K][hJscˤyK;'#ݾ$?odߓ/ ]Xr# $0#e*)ChWJoĂ2nħe0M"[YR *JxW!m:N|̻./=~Fozܯ󓒮@\V#ϛ.N˵SPwMHEq^ Ly.u4 6OO hv/\X,=҃nT}C^:&m3)aQ%uuEpHKw5$u21,U\;;,W5"\FgIrqAt)!(XXOj ecJ3ipb|jMvh~KHcvx: 3>UNx&ڛzoTW6# ٸ l;Ms$JuOb4T]k"jl'ǴQzYKTg 5P(&y/s23xQ\0#(Nv|ZeS&sjtW1/eć`FR.eTOFJbţzs4ֻB@ɞ^.0o}>voR+OcM9-u@=E&) 0\7!6%D@$1䊬9 d,V6.|fu5aGȕ*f@y ^0q8S]b I:7J&!uכc1"& '^k_. ab/ }'ϢKτ"m[fH' )gm,CDʁ=V1$ɭz\d5[#Ov%6=񸠡mY5ěA؅60 mteSfߎ0$(%yy& s!ņ5AB xdIu+t$+i6\ΥP໲3tMh Fce9b9"5";rЖܑ%q_J! :zdZ~A9{{g4\YXzcj֕ɨ-:W@(L 90[{i0N(ywxp#lU|יſlivkL. o(d>qγ>,`da0mlI8dhD`a=$6a'( &d Mn&6_Aeq!XujIL? ,껿jPSp#r_ْ6]7Y|NY%FLf r9NAȂ*bTߌ~/BLS.'p FbUǓ b_}Û5Z2"!)&:Ņ*u]݆0'.Hhɜfs㼈z#FAqVk +'@pgRt1`JS \Ź1~KI{%,׳Uf6rkHɡu&1C0(Phɇȕp  .@:L(zIN{*JuЈl6OX"걝g]1ŏ%PFqd?=Zkcr~)#@ȋ  x#tW޵#a-cC͡ 2c+|\tԻjQ@8`;s+nI(྆Zhc1w BE+M'4.w5n؃1תDv-C5r"S6s$ŨѠI8Y|P-+.<,CWVSjUȸKie?`k]]:ɱ,an9Sz2Wjڐ7YUK٬6QFٶ&A4ٯ~C6ېCNR- Hh\9LY˦>޵d+dlY~&Z0*鵯+`qI\}l%L 29jF.88A )d,j8n.f;GMv?kf9 kU{emS!%1FA ,94{`tܖ."/{J`b6LU赕q9s.oØ=v-E[)njQlQ"7KlǍrc1;!IݡW٬pS%d*< ȋhcNkdϬ֟-}OxT[!DI3s.t%A`o[@bt%u=>[;ak LZ^lAܭ' &:.'&clni0OvCq%7!7YmcfLre9|fRE75dg1^İ+G҃k}&[p[xZ⚖8I/bֆ\c饮`{ ;cVNy6ry7 #eui${ii10jEX R0'f_a.k`/m4G{ۇ^}j΋{|XHl)j $ه{,M}-ȷ0egJM^6+#=KԺlcH)h5~ϐ7례sd{[wc~[%܌;{l{lO n..ԍnuqldIɹl uD/~(V,%&]}Vk:C1{JǺ@n/Fbޭ!qܓ펆ؿVsӕ|Y7A۵VM4r_NCH3P Ξ05=bÝY͝$V|\h+pPZ/8H5Yݭ~sm^J5iM2V;Kgsl_H HOLv[oY=.k /sVťBպ[vR]n~)-;6U]Hu8zdoM_ywk6#SkXٸ dNk'Y%?ڴlH5k[Fը9&q]F\,t)ѽ|R = +ҟ"V WT\ewN/i!hB#}yVy~7F̫ZrΤpa jU§zlMmp1r`*ޖ2-lttژP\s cOjҧ${(>-Fƺם*!#7x=x:w*ZHx~KOq7Ӟ@Q/{*=2=y1 ^X.ӫ~06{gz`7j9x-d)E}%CC_Tw~"H7#. 5Ğ˞V3 ;"3C -Z`ߐdLeÁ!]0gZ~.D ;r24ׯ_QnbD:hۉReu\0[[~潊&M}jF`zySDU]JY:+UyB.5ZN!ysprU/@G/~ӪL,pZcQ;P21}hll^侨7W1Z6#j̆^Y)<\-gV]`-8/v^ՏO<>"3}[GrEE*& A1vt0 H|YM0W'N~_nYn moF;&-Vf__﷣SO]BaBoBl2Sd}fQ9]\vpl/3AavVZⵔ\W \V炄?IEKo83N6uZqqϷ$]Fe߷}pq$E%{cZ [z> nFXqοRF kIX:yj.5j,"[MI^&zz>>>]I*oU?"Wo=KY9}rH-"B˾۷H֡W.xEbc'ri/&z75oNAv<y6,:`Ru$m}.퍦 I`vTv4"kdgxCcddTiF7&,^SjUNZ書nN*`Xof.Ӻhɠ3"7B[\q6fž3q9u6y W 3;m56J53Aߋ| +#R>YWz -Gtyz̀knEf&ǵ$kgA%H DǙCnۣ)T)i5^弨 hu>aE}04ecf6p)ur0̀=U1j`h>_}5z;lw}2Oy;e[>>`"x=>_o>QTΟ!ƳaqlX`c|]]Ac.'!2T|BVnCUY:D1|Ur.w2]3?Ĉ]v_K֖ӀEfٷ3M Q4mί&@7 ygʦaZ ͅ]пkoy]쒳 l11%Bg_z놣sԵkz/ &PcckmWc֠4ʉ7l>?S!v8:-07,B.9ؓ>M?ҶʆV ڱ x|.}:֕zqqάe;Nq=>i\(eF}!xDoiѕbRQק@TT[SCբCmӼΉ6۲7Uy]76?7滑:Y?q4K}< #:q #-#)ƾG5`wG`'qpexJ0Ӆ{7o8swţ1-w#.gҕ]]MwUx{mpqWcsOtHwu9?)}lǵ+Ág%N:vi\RSD Nv+^'@ @ z,owI"?%KE/r!U rγsYUxRR#T~&AfvcީineZppfWEu3/ߔmHq&o;Et jezkMe ]lx;4m*g}q9T^ &Wãȍ'6U5y7oD)ZS>58^ T׸K#:usu:$ht=7$/Ge}$JxgO~0_wA˞JK蟈7oQq 9 7gtzJK~a}kNV+er-n ɾ`dYO8O1oF,Q\ ZWm zT,datn N N@:-=g.ӯzG8 _M l10tJMWνlsG7:<lp?:f>y`{;s^j'{\M4Db;BM˵/i"w [݁u{:6вsp[)l2bXUK1zŶ_m>gX s Z6t3xFs8b>7nQԵ2>gO\ϻ޲辑QqGۏW%MR֟:GeKC;׶axS[T9 +s[&5yv#岉>fۗ_h/wq_ 3/q4O4F&OSab,+ސq˸Og*lNRg9==/=п^cZަb_;xqo4,^?W .^3tqwok򩈗BwsRcֺ[67_//SRq$YSFP\k+ oծE)Z{9mp{6&3:X;>FTq:X꣼UgK> =<:zGz9oFݍdJ#Mo[E:-85?4A_#ƩLGw'Sﵸ; Bf|.~"죷#\eoy]ۮ7AM|]W]iЗ(djl9>C2~kBrgێ's=o t'>|*?[g9|q.h׳'{T6a2W ԧ$/:/p{vC׷kocmx~-qk{unp?7hGVyN2.G(^xri;NxO~_/אඝ=Cjyn7Za-|ߛE]K{ 'H/lx]~uS>꺝-z?/_iW%l{ ~J:oӭiĩhly:C{CwGOW/gq{toOm҆=!h?/>ĮHo}&N۷J; *Jt~1컎a`-3<y|B*}_wtJmשGo;zct %z-Wjı OJ"y_H>+ u=wv:1!_y3w_hQ@ԩ068xGk>/B;ό+o<~oI߃eʛ[Lgc}s}G[Om_x_llhz|?q:_ߕku;Ї;ڍ t$-W;w_;_Ӂc vowqy֏u㔿p=rv{7/?bg>GXi; '~yվޥڻn#y_ﳹѡw*o?4q5?oMyv .ڻ\,y).ﶖK]w|w󺾿 Nw?gҫ3<αov:'6rwO|=7پdk/tMyzWcQWot/t'K:*~OދsgĴ8/˽s;WenV+a~,OKwYkܽne摽_ERe\ ǽv'E^ ?{u+ @?32SwuM3/:@vocc t/75צ^S9Q@㝻}/@ P@U(0T?:Q>skkG;{4"okW~M򉃽t;>>Sr5_${N><}Dgm^GGeڰ;iS`D=?'Wr> ậߟ:wtr(U;U0#>G|+>xPC`yD?'"~72~?\[bG{=uwye!PWr~/+.,/wGx_xGi[^}mϑOnv~͑/3 ,fxߐ^/ݎdlR;OcsH~_07foMCtKK 7,o|>*\z! (_?Ho|8P5_B| lK)^FY(!~W̯93_^sߟV}l߲~J/K{t~Px}k4_?cy22{_[ڻ67x~V8|xq<l.ڜ? ~h2~:|%=_7 {^s}Ro2̩>ߣ/~.m~KHuYeݵIciҵ<_CߋsV?S<~~OU~?7n[}U SM/`x.]Rb;7yCnOʧIҺ|}/".'<J_w^67sZW=?'sww{R'~#{}_#|~7W]''uxah*>8?w ǁ_/iCd;9P*[5*$eo  ~jN}w_O_C~f~{>W|kqsz=~[7}~>nu7:On1?)ݮ|zϽtߵs|;eWxc> O%/3qV|Ch: ~=N&Po{}{Jgg?!t?毻nO߼a=? kOR71yVr7>_gSWw黖Glp_SͼVߋM P28[ Gi1|t:G3h~O7ӣ ?aC (FtBfM|*1I~gYDL:cس-O-Ou?sx0Yݜ JPP@*TP*T?z}FśЗh6wqj|W|[CDKY:U݁; _v:ӱ *6}?yKH'}=FM}?sf_ 3!Cww>c;_հl=}ȝ/υCяo[vz^/԰7_~,9gk}uşO>(X_<:WuQyýe 'B!`zr? w)؂~|/=&HZ_equ||iT0(7>gy'p\TJ@6tT(rBUUts.=X_|_7/n;K]x=0wlaWl*z wC̭#'I8ޕ{m?םAkHw{]_mǷ'Y?c \#ξޞ vyRfQa;?߿}}corw@hx&f \#^=N/t1Ä3>B>~~oyɏ}>O*@D?w~_}{{O#K5v?sH0?]gu:JSr59d5oN?*Лw/]/N[RAR*P/i_vr9{_ȿ_[5>+A=!S]?ܫw'wodm]7x1eZթO7{{~Z`JR@qG+_?jlA-;wF5vɺ/]j~R ;}m~/{󼒖p;_'N /][#?Ϟ]ѕK~s\y_O_G>jw {=M|^vǘ/pA}K) *TP>/CoS[=\NäNO+g>Jvo}Ku;7xf_Q >;?e4Fk/]/-~!^'>@TR@cv> =]\^V~S4ylm{}?>vG'o)?_^'EK}vTWJRE/6~S>wm?j$@TJ95O1O{r{_o{zeM=ӵ^?|'붝}7}xT *W/Ugjqap=+d|x;]ᧇպ'KSs] @@TJ;my뷽"N,T JGs ~]j@k9_h_Ġ(!Bn<_T@TPھc}ķ/b`Ej "/m|K(}_K~6 ~_n?o" wǽ$T@<_?TU{~;WG*/o^/w_/_ws??zAOշK}c9"υ{(~fߨJ* w}/?.77v* _~~O{?3>]ߟQk?_~K=DEo?YZ7>N;u3sG=;_( ./}1DQ?nOo˴*'fyiɸ( ;k~|~z͠QW׀|fA~:PS*'NyE(u?+E@>DU/w@U|_fPQ!m}WE>naOE3h{_On{IDPȨʪp*¢D ~AT* $~E e"~dm((~{YT&UdVfA9CX_ETUG~wI;^ 8D?cx` 5GGtgq62s⟙lc}4>‰s_c# f8O2WIUUn]n+u_/7ŻN'!<'O'dɕtwj#|[Y/.XjI:(UNoQf366Gps{`{93[o{9f_3<κ'<"3Gokg%KgSa V;I8wf%HHظ.-G #H&#g7|ty{P7S5\ AҕDd(L蓫}SU7}W- -1o|X&LkUUS,,~~v>%NHlKu_7GuvtpFލ31mfQ{TFVD@TVAeD PQeIdDTP(fU"DRC*!hIi`!@bbňZhhh N0#N'T`( ` H(A(1"V((bQ#` c E1HD+~.% ", iB a HX 1HZ&b ZP BbRIFLcň1-!JbJGMҔ %E4P%(JmC\!M-4KKE 3HPb5LMb()Zqc a1PMRPUN,IJhR91 @mB8*)(.&jh J8cqRJS!3ChhjCĕE"R6l(&HbBAC)sF,ш")(i!j("i*'bhiq+@bi)4H c bXJih@Zh)b( \%3X)j &eh*(B1 b+,X!LHB͌E-44fEqCĨDP$HQCXRa N,JiPPR UCPUbKAT+bDT@4" mI) UJ ( ӊP(JZJ)L)HDzA?ts;sW=~*pPĸLEMI1TMPPP)Jb N )1 M4PK L8!h@F sBbj&18 $ )(1bH)*L@D!TR8 ň("B(j(41DU F'F!q@@-Bb) B)i)BsJq KP4;h X1Vh1)E .!1\T!M-( ApITR1R%*) EH)@-+Xd̈́qC0&lBPh(a1.1) ĸĘVi,`Q P4ДE*D%ETQ- -!H4QC)14@) )&"(ZY8Fh!AJh.%)h* hJ 5@bCE4e () (F(FT(Jii,6lٕ(hZ3N!$h)JhhR( B,`LDIH44U0$LM)j@ADHVՈ Bb"jhJ(3F*hR"T !Dhi \F&iDh Z(R8xmW9×}W(".5DEB4UIED)(JvhLKBSA CBRT5CaXTB1b60&*( () P8Jii)j((ĵB),a\AEKDT1 )Z@)ViB4 3X)hZJ (ZPJJBi%JZ)ik44BU8k4i*()*bJJ if̈́h8 Bf4P4l". *J VHiJJ JiE@Jӄ hqbPPBbBKHRH@4 mB1 !AH51ҔAKT#BUPILTPZCJR+%%)@T44-%b60&'!@bHRE 4 R45CU!CB%-AīKI BR bLBRBĪ#JPJRER!J  M JPRSH;A7Ϩٶ F̪((Q2!AG4(D(PDTKCTD+IPij%`)"Z(C%@b@д` ZhiFB%"ZP(Z*b\BV! 0% R$Kq bJĵJU "D!H AT4IC%% R-!J QJRb™ DsKFh  $HP4Tf%KICH(P4T81!)R4Fh@ĕBP +ATJ1%P KN!L@XQ P !BХ)(ZQURXiZ)B))J@ ZPĉiR%ZF  Iih)Jc P1 PH!C(R @552qtwD]- hhJRDQ@PQBRBRD24DRRIMCM ATCMP"P K@еCAF!qA@4S1"SATT%R4P ”R҅*@P @%RB@PBHҀb81 1!@4 BR Ё@!HBHbqĄ@(*PJ*4QF%ĔH̠(ҫH%ЃE)IIHL@HJAHBR%PjP9f5m\m56}|L5XS .n4&i RJ$A@mBf&F)+)1 a C@4 KIE HPRДA ELCP!JS@4CBPH5H(.i1Ѕ"f1 Ҏ$EP% BЅ R"SB +H+H% bC M* BJЀP Ћ4A3;ow-HncC`h*LJPDLUJ"q-(R9HP-TJDN%TP P4"PPPS@R-P#q PR1R!B@H4 @!M@foy4.C?/n(&(Bh)A@U( H%P.hJ c 1(bhPi ZTRA`E^^1< ]WrZB JBۓ!U3A))f T()E(h)i  BZJTiJUhTBU]3˫Wvz:PTRbEH@-(Ѐ!J @ !@"]CXշjի&Q7! 0D c!Fhi*TPiA!2]evwEMS@P#B(P*c͖SAT\pP*@ E˛*H"hAI@홏60o\hc59UE45;}!IJP% дHp؃1HQSpb3-ͭf88ˇ7.矡kQP*".TySX j.%ޏ|߷{:tӧNS*!N]Y(DJ{eTNEd31ou~>_#-z(mng9rEM0Ҋ(`rzൊ kL .y9z"D Qԋ ב~CrQQ@Ыs88=H AD@ԃjg֢!Zz:6O>J>>TTqpHxɥL!fƳ_?65t5k"k5g^#*gK5jE51dzcoC k"ZP&8]'6U4SA8N( t\s·;wP@W8p3z9M{~w=/|?G}G}G}GDC}_^H zz3~vfo{]k๹\"#ȃȇ'}q]콗o" ;$CuwSt۶7=*i&&e~7D M*GFwV_4 hAs33pHn_uZ˯_G^_; ppш7:]+}ޓ@2LAt ]ƥ@pH&FZdpMAArQL #]CbN(;jkF۰nokt&A4IF7y}= ;//#sG\( *p A&Iil@gC{q ʩRJ*I`@T( u_<UGl=ɽe6,$j.E@TQ) X1ng~ڕ|hp J&(@@*GjF)Z G`6gEQ4%0 RU$.׸n6@3ѯ6kE{C!ER@ RI#%:u*]8E h!I:tiDs9W3jcVG,*>=BB3#U E%1CQL$\P*\dum""`U  HŪ  :&p@ )Z*0aF45}5v22߄!E%QAY1%H⦒%jnDD"I( 6 iR hN)HDPɨRpB HT- A$ Iv͌ٱcX)!ļO><[;m wjhNdBM$7Ioy%UjQգJ]̥Lo{fXs6eecVcl\.,Lƕ+9s|-4|#p6wb[଺YNqy8%]qlJ\x#9EcrKj_+JMl |bl^qU$I<[u/KvCWG`oݭemrfrB5 rVldn!gq\ vXsgpSLJaٽ܎Pw{H/30ot.2n^Ůq_66yMܺ6{IKt6$7k{dJ'9^rs:G!]>>Sd ].WC_C؎c?n*nW~qk `Zk׮˃-=i|?qOވ.iix\U*qx|]kv]kv]v]kR@E@j  Њ+)8Cs=|;:3:ISp}W0f9A|S9L[ 96^GFgT<]~KQG~1B?A?#3N~u0PIK؂?(Đ.Fs`@'P:PzGiqt{s6E77}7Z{|4s{C=CUtPG{s;Iww|;w^wgr0 _;@PS;gi-HP*&BAv_cDΎ.#\G!dH@T&.hUZ07~/4=QkNrk9Η^Og@vuJ:<N3PCSN08:_pP `:ݣ^o"@8x9FsqWxmPzm p7 ,Xi3~~~~ywyw'x7!{]vOh>w7~x.Brrnx~ri,".H.NNO̺6Z m)9 @GNmA=p/v,fNc=ټ\]~y\톳Aj8rE"Jum'4umXQӔ38>|~ϟG.nmE{3VA &NE;OY%T5Muq\";õa`csFGp=OS>=Oz|}mmmmmmmmmmmmmmml,,,,,,'R@@U8 \>/,r@Mc&g,_Ѳc$==>W^x^/>9֋:GS唔@"dCddeeiS>AA !CPNyVѐĠ qa":ˣѵ.qyfC9mE̙@#w??byxoPWStz=yR@: Z/䩓g&Z8G r˓em`ukٳa@(PN +C@h]MǪ5vWU=ϺNfV,~]p8TJn >Yֆ@JzZw{wsZBJ (Js_r{s{w}6 lao{ >_؂;:A<6  TC', FQUSJ:@qtڍܹ/|-xw7ٷǖBhD:)ѿOZ N h ]iuej|/v;cx8 :5qvV)ҚCgm~ڛ#-s~qE77=\&}A tg5@Ѭ֍:~û :5f6wשcZGX##Qqp\r˗.\r˗(PB R8§@U8w 䁑Y=Yw>/E5)իVe/l MVDo{3gs94z҈D4>iP(n+˶oNv_]`"lSfa5j~_F:\(Q44z<:C8qϝ;3&q3qϻtDЉhѣ.ЦFFsF}|=[2S%FvP 4Q@4SZZZZZZZZZYF**T ---,:8xxxxxxxxxxxxxvlٳf̠*T*A=U *2 TP.:|;W}'T w]-Ye^E H#._ í]֪Xdde+,d{2A 74j8q@J]4o|7t5}uk zxooD55^?{j Hu=WP5ka:Р.NK}@.5:SőW%/3;8AxW8^ 8CPQSӤZb5u׳}@]7Wt7y6kA3 s jk f^}nnGH]&wsQ4&F֝g3{=g{>7x7@]bv^kЦuMGq]q:]~{DZ*Qս8 dFFZ'y@Ү&iս(4>*iGKåӳn[ k_͆.-zMHjգ<3+9N^ױT4l4pkw5.j5iӣ^hpj@5!pnj]o}&Qi85r{_;o n9p Zi'y`@ҥ}ϱ>cܪ<sP4zkoDԡt {/7pY}ࡸ.fM tt[C4:hp_Wv ˾f߆wR%g(_s2Q2C#h}.]IS˪s\{vk7w|5jP5!F.+:!Lsq{Mv5 ջnbŋ,Xbŋ,XB (lUR 9TAAcnjE:EZxo ,mt&>\Gfh@4YŻ.Jiie#._Ͽ7wxt뚂sT|tzn[nm ox|t?u@6u:v+T]WPVecUèY':&Қ+wV-FmWquW r UZ\^MB:QV.{T70;[  \DhdZ5ȄIMsr:e5/qPbp$}` @iK(U/掌gEكWwNj+l\ڊVv 96cl)Q-TrHS1rĒ]I HDRk$:fmB% *(CIB'fWF% TR!Jm(RP4QLL!RtISfI@bP(H )m2TkD ZR ERekS@iGFlĩ*H֒F5Ӯڔ Z IvȒ٨ jbM%J1lѬTU* )B6b(hٵtAURdFQjնP SWLͱ (hA))C5Ed֫[(MݳPfm-)Z2&CA5ͪQk+VbM*MVYXb2Ҫ4hM͍M6RTZZVIҭ2V )%e4TҚѳUSm R4m)jFb8*@;UfjJGC]BXZ,`aR :lԄ,aSVԪUiljڐc5`4ڲJ(ITkV- 4uBDhh: +,%Z@:ˠ6$M!N4J:aPPj(+6AC@v5)4:RC@bP(@hh(4 4:tS4:tH R@h1@ )  H I@ UT%RA"!RTB!(@U ( H>xb i &  M4ɦ2iAMOО*UOLhF@S!6M6h2S hOSC@` Bi0JmѠ44U?4M&)J~=@4* D&D~4444%Tǚ"iLi=COIؐz=Cjy@23P4Fz 4zOj=GS@ѡ=A4zSz3H`1dTV ȄRkC%v \"){iIvZF}0#)="Ɔ}bӚH`Cbp`r\L!rn'r sxx% @X >췙 ({]vzr bj7Ak B be ;HnLm7zjĿ۳ 8iTCn$*v$jtPqxcԚEZh^̨7(KFz"%'93be\3˺%UD ,yF5b(cTB5%\ VO;5NJ KD q#?^@n;'>UY搽q0'@`7$7~5˦ oM cnR7x␅;aid}6o0kJ. 6;]JԈpz246dˉ׳D^ɁEEW,"D2ȌfggîllkQ,2R%er sYJ{#3EjPOIDP @/(#(FeN(f"jѤ&0n Z{* ڕnŰ6E67(Oi7!=! TL*b#J {IY\^νApoY\\fl؁ӑ=%իKN(FEѠ8B:$ HP- ^$RDjC6Z#vuсى+;!( ·GU۝M T#IcziV̫dB)%)s ICM0h!x LY-mI9m[3ւF\^CFZFՐZRQUw#83l6](}ΦR;RmbR1pkVv+ne[جk\XQ 16PH9Y2wia/)w8kt03i(Еta0PQa[(!IOX !/qYa2n Cm021jcݚFݞmQY:쩆Um']J,dRYeL&NIʺr!`y?6$ s"(NJe ʪjF &. @J^'Lx %&[)k܂rQE20NIL: "Ĕ6t]z1bȯ⦱*V'UhݍPQPxG0 v#K90He^m-f e*93!',ݬ+M 6q]{nTK(<%,+Y yR&`nM "JhZRsb|6-ZqLK+ *1C sC-029ri! 1vN x2H\Jd݃! Im"yKribhLO.B'&\:,s|Jmc@~=:m-WqӮWc3${|%st} ydYIzD4aH TTSH ]WKxA:l)[dYdtL*Z[nq(}i` ʬ,:V č8p.*ɤ\*^%f?fc+ґHEԲ/iʡ,詊ԘQ)`TUHbI0đ,.ah$ ^X%L .DRi|D4,/K ]YVAb6( +C鱨P܆ RĤTD70(CB>0o5}Я0Y@;s`AHeb`@`l$ᱢ1.(X8[˥"!12HKeK3ј"@K  ٭@$iZ!3g_|!&w(d +""s~ʰ"s:CXnjFy:LW@_l6PlH v}BQr&'$*/ ꡆ D ^,Cnnd[O/kK:pxH;[ݷi0.Mtf`1BFmAgk<)Yg2MB@Wejn'"@duTFc H1ƴ2`kCrdu DXxd! EqdukmBxt: 1'*,g&xH,Nmx eKj*”rׂJxQflYL3%GC^rŖB{L`kYІ4K`$9F aIn8 '{rD5"")2'k=1bm;dLD@wc[= 40M*Dd¹LI".x66B1JȲE\A N/f E^v8o}ŏ)~AS'Ѡ4|>m6݀bξ֠YEwr'7tZ\-˟m3 %Xf5/n.I@1N/ ܭ,R ۞_,m!\rn3ձ@A[\lJ8 | Y^ȯ|`Bv"0<-'G#TwtiD=2h 2uFrVh1x5qAlP8&z wK#S% f쏋i)ҸWɤY)>Q_9 (N)i# `FFrj-60f^4*"B).xD>7qnsJ(r`q #[H v-v|W+l-nX0ei%{µmYK i;0̯m#@nwWUDŘ^tnEc`vǭKq:Fga]. 5]{9;%sYfp eDyLi!itDHm9ۚi< :$MOeiga ̻կ!C4&QCe"i~plxQqH엕IR@P]%<ˆЦ*qf㘽NMӱF\V:k1RE٨ښoi"cL5S`| Wk#8BCbdRZB`3L]습,b'6W`V>`в!عP?f֠6Ա؏׎{bT9|7o{-Ys(.8+ջ# F<Zy LO|=p8WfI.03S}?Qc[O ޘ1Zt&uD)߹Q),LyP/F `ݲb?|[w]FRLH]zIü?KM\|nR.aBCc!ܖlI0m6vCx?'gq5}ǃa9KK#" @W> %&;ݽܞ˛oq kmia0n1H! Q0A2td͑&RTyp&CXG8fAE[w12 >L5' yvt v'hQ~+!aҸ:+6xgve&S:CJF`+(-Q6:&ұ3$(9KT;;9& EhsA ^9G>*{` \Ss \b:@e۰!1Is nwN {k `v Y*J8N7RHfa^"s:؎!֯~P륱O)8 86;4A1v-x3CUx{{vpmLjN=Y^ǂHA!ox jY٢Ĝ۽sv,wY>iBBM֗uË5wLciNSsqe8z}.a -9U3)ͧEazƷDTهOs] pzWm9R3\`^MS#E !q 0Zֳ-Mh8 i;#qRz p߃aj12KfQRj!-yEղ6D BTPF %O.s7GKEGK:-9v)g֌6Q82w#H)ЪZ3٫\KѰ |gW1I&8^]9Z6GhllⷳBz+Dj;Dt~cxWEoϚ[iڵz#1:jFVKwAA[dF)"4^Pٰt"O£{H&*<4j.`1]\E ;a 2X┮9xLX!16fFcz뚯;[b%sIa5]Jnj/.7b'lg={:GYCz:.˱fݙ2Shgn+^-?sːBDǟyy[okogd>i/<(-id"ȝMLn6DL5~Jac+.5g]b C_L`ѭSL j^-\cF#s #_ VyV}#( Дˈ(>drk9 NJcr17=c"2!AƸ4`yg뫟xL7;1h2uwXlD# )/}13yqN'|7(P%c=p`ޗ:P`#dڽg/AcRn<ݟd.ݟpdhYO-x>'[Nq~l`PooPOQkddsm> 7{[^d빹B628ݫ?*)BrMrZMͳlO ׯ_,Uƥ Ir~Eo]x ̲y鹞3u.0c?)-E푱C_$Mnu*^;9=0s4o@gSXhRg}KZ?B SPtROh,_+1SOcJF\iI HgLݓ ]/#"%-DT(w6G]РXDvAOH( !Z^c$^l8mVrw鏡AXgM7> \p,:(œ1ŝLXvkxK=zJrȸ|_43=8r< mm_X8끿8DŽ\?h+8BpTw Ͷc  à;Q^s?%}<_J5y_TPZV}d޽ۗ#mf xXGa]4 n,zʽ߸ GuG<0\8^"c# @*T,>Ϟdzz"5>>02*xT95gxS,*9EE&&AVqO4<9Xa xf2&A`w`6Fv֌P p6! R5'rU(![8Tr0M"KBgII Jcgsqh̋J&ң J4#CH #X%1qYx;I/%ha2⧌A+Y5 qՍVΧ8gר(C(}TzNRR *#A,g(" /%KP%8}*-ao ~rI`8BY~)W8.⁃ZKmz Sۣ(lD[ `|gj+}[׭7wXvn#a AN*l$s%"cY.%<>s߻r:d[Ya fv|9j%^k>; "[6.%^B Y8 e4,~I~Ȭ'{]fP%#ӇFyJj\$lCʁ#7s9uR*6Xp2q]E8vj:X ZE,>Xy먏T˫dFuA@V4V3#&cѴ!lvޗ[jwr8;"Իvv-r/b띻ዎ`7;qU?9rWoqgy,E6T ZdNcY)^ R6KY8̫RqZVb|RcՍJ ԂuC%S8xN%*;prUbef@ 4i AEwi *H&BqZ&kI id&  AZs1ąhUFiTj+) ndy䒘L9{<$ʽ%Ҙr V05-'Z)oI4dA+ [ sp"kpb*ǹ|t_K))S6WNS$I RBJ4b \oƹXm$9w.zaKxC/sA?#I5o|Ifo:h Œ.DuC5Hzx(9\m|KJxtZz<-tᅡB7[ EI^#DU')6ݮJOcRRLC[1JD"*LN9 D:QU;'%vBk/yۛݳAq5Uv}^{Z:)@ i ;05e"D\U.So JaJ,űj~GB*ND^+zdž[zu DQ~aj8dWG+韑0 ek}}@tH3m@/`]^>,: ޿pL+).8ZclUjU:GnPְ`4đ+~| "MYDӺSb)#Ƹ9dC68N;k vނ-Jy ^tHuj9yx ul)>CNۀJͽ˟Iߞxssu]dg pq5#@=wvyOX]z1Ο Iwx|pfey$l"]?EeAA oh AWICaA].bLII9Iķ5֫ffc9? +lfDJU=3DVj1M¶F3 Mֵ9Juki bKcq58!f\>ԵTSuH*#X-X %`;|[ bjh8+^ћ-.}?'^b,EP FAcxYQ'y[!E"Oe]E4+YݗA&xO;fXU9 =IRhfc`혀 wS!+YnT?*k?(\>Ș1\AY|wfS bY䓥(C'n;_Ft$L(Xx!hbHC|;YSd ~;_Y7߰&'ݽz+|!6t\y0y2gH.#Ǽ?1~xYewo^9/8aRND6oZ뉟'ĺI1: ^RGp0A Da4 ^mv;ߤzO}G͋(68yq3h>E>5ZD|b=us>%Wi"J.=0)pӞiF~,9x Q軫j-d8rWe[㆛=RA`)ulDc˻|<5 *Xv"'W~CX% 8%Lu hA/ͼM); lt 'bS{K#~LYxΎ:xz @ `v7%$z?[cʈ[z\V&ylޙ@J2~pOy~v9"lPu;c]u|y(10G:Nގ71bYl7_"8"*ZA.Ff̂E+Ωe4f\3&r)[@sJ8+eڔmk&I]Hs Եdh JbӠ}(Ap@O [4d@yJn`lݰz%dԋl^Gj;K} w ʮ %4D z?3 ΉȇRV|W=94cd(ȮN5JJ wD 6pҿ5gbP^@ HDz3ҁ&19{8t `JIlY. YC1b%-؍Tcs1&MVap15T Ugs#@35B{'ۓBỶip3"XjL/Hmm\J&p}u>0}a+8`wFs Q0pr,J ߝs0 GڂJ¯yIT5f'e͛ ( l'\%@7y4]YDGD7e]΍".;1Lʪo-;xei&d ~r듢P#c-1Mr .[f%;lA!]6Tا<^pj *юM%T0#H~nz?oh6]$q}&Z% aQTW6%wnu:2D4lŅ~H+?B<$3x"n^&ĩ Pj<:%CQu ,qNc$Hvl[1!!t3,KOsxuĎt!dOJ KQ7 G !4r% w>]ˡqE y)qiF6 $ud"~,,QɎ--Yiȃ)mn(2r !@!F1*Ѡh=ubfb. ՘5%CW= trh؎ Szl򺩘 .Y FPSXܹ&M i-̔u`XwDg 3ͫQ&g@= 9.Xy@H@!'e*%^^hj,B}m ǯz]$Ea-l̀`+J2x#q:e)NNF1rVwn1A6$#ria J*SV.4DL% @ ZEǞ_KMғ}keHV@iԍ33MrIUVC7 gC6jJ5sF(/cN**N5`4`Z4fs5l78G)E/accox^2JpL/hAy a[ "*B &,Q/g`9/q,uIm_#rt a#/vK:=,a J,\#ф4~ i[ɝ:%⺁D(a8g˘MܟBm uM=BV'FZA]|qLli+m"0Ub^ 1gKN1؛zun)h_;2l"..M6|pU8V7si^74QCC B.L-rOYl% u p}BׂFR΃ ^f!f7H4܊Uh;9bcU?C Ց_ q]ҲrK SeS "Bp)0B oĚ`>忼9?3PR2 QXgߌAw)]Tfr%m|Ɯzdot>Ihbԅ9F,U@Ǻ !%a4 Ak=ؗ+X6ZoQ?7WZ\Mz PD젉NDd6){/wI@d2 (F XVf)592Tg}|1IyűU/0y~^fv{of=5}<1i̻/y8lvꁓ lW39*U;fuO/t RA|HC]+]|&x:۶i@aN%P+)xlE#Yk g" x(r'78Fo^r9.hҝмZHcLwzԨ+4j~ ?ζ14 y4A5i?;0I[$,7[>f8pȘ<*@ٛGX<")mrG" #Bf`S5g zA;ч"\9Sa{y )`09GiAbe̾28b$f\I4v?(2)^^l%ڛhBAAk0AO,u ވAjT"x> n,"Yvefhg9lv0QkĐ;Mvi}A|϶j'FAAN1WZrXҁɐZCLӍRvxd3()1զBڈVzFAY;amёtycc ,Ŀr+[8e@S&XO`1Fp6W3"vI:}λ .8'+hkyYLT~snF޿b"0iAX& ,8QNlU9B o\An}NJ*g&XN˸|qbKc/f ;/-3=z a`(IB€ãAgRт> uq p7jB%@8>SPrDZX,mpg9DK2\kk sgܡ42NQeV*mlH/ g|wZK{9.g' r5xy1x< AD(mPWvE eU\ ָ ִԸz(m! tfi_LuB.eҢ@W#˝QOɻ94J2J*e%d>oE_fgFI( ew <z>kSfL oo5FƑCFx@EkPOn ?֪•XpZIo6BAk}0R۳wƇ;0E@twNZkl/{횯iAF~ &S00AZ YE} 740kMBZNX ])W7wYH nz< `tH3&uB!U E,=t% w,qS؎ k A̢;Jɬfң"QUQ738K=UJ+)72:%fM\vcÚXƶa$.= ,3uy!!¢'7B(d-uKĂ= $-}Mt*-QIMԻ]!+2 %!.t\ȭ]f#Ϫ3H4c=&R s3ۦDQ08R?&Y0SLSY栯~(;(iƾzc^q 3nJƕVјWBĜ^;SgAZ(bhTWۻwN(.z20& U!{Pr2m~Q0"^\4=Lׄv;غ;ِ!l`K% ^Hnͻ}W+MzMP8]anw5(Wtr'deds_ ғigv}ZMl?;:CE &c,ŧe[5PwekLZ9np}d$uoyaC6}+Prp6)%J1 *С|B 5Ev::XVu]ߗ]IY2(ުԭ3- 4t @0*5X &!p$ܽ'mNH`.e>$<-HC 76WwrpJC*"BNT !"Ă6O9}~wtS}"< H,MFU`$"NTpN0PLFAFC0#\~ QZeibx4¹N+\} JwʃLUa~),=^ ̴&h.~N !b~ Vtɲ*d !@#Uv; rrr(Ue hN1}91Yy.OkCzFjX%;eUJC,E.Yt>sh?*j%qE ;[(0SrQjK_'p;103N_k&Ō*j'W:F"6uP{`i$s%&f546,[vÞvW2!)<*Ru *VQP~ÐCSD0-mW5g:oH]jWM1 0,Aj֝){oS^G NB Cspt8r-X@Wև/}~e'ŷ"*R jc81؍P ϰyn Č" &WɓqëGx)gNe L1_ihZP+O\-ƲCN#DZ}_anr~]}ǩbx߉|C3ɶmg@yW_k W.x䀥G(UUvE/|^46w xoA5fdr"|-Mr5E3ht#8.]\ cKq` `γWCHFFM. 4 &`$ Y$]VzuߓY::c*Ls\S3QNQnBL:&pd2㊾ h~0rv0![U_\+1RSvc>RT% P}g2I&er%\EL# 굵+]A+ӭ ΙEVQehFk5i!pMpnS]o]{_ 2ꎆF^u6RLٱ0j8!%Fpe!#'L2틢hWǢ\s7s)>r :e=|,t|`5c Viw֤{4X!}䫈HD|䚈s8 J:29gj, 9avw}5 "t9b!&-J=3.E؇H<3u{郎-9gr}#ԄL4ֱ+t Ũdu ɉ.9a mWMNڹH]5zjz&3@N1IԦ`K%!X$L}N} MTIVpy~3WP!Ųr"iņ}L[ 3S 3UCċ(XlCO[ $~XʖxS+ *΃ Ft+6]8Ԍ3.0fhI_7*04!쓻ُDnow+kXhmJgs r4R   Ҁ`,FkP!c͞"\lh-ГȿPBYe3Anb4; ͐@&׼ Y§}B^Tҧ јc p,EVv7 v+g|v]0V.+"i`'0A0%uXv}܉bZ-Uҽ!l)G<O S@{,51/#fnYq(pW:Hضb(k6T6XZԝG3IRzj4 T3 `r9cwRSG*-Ԧ\.'rcϿ0yoܔX8Ń'r .貍e9ШC_)~ G<Ϩt w43B2mɫ܏(?<(|]MbJ$dLNg2h^k./zsq  G9(I^HQ.ɾuKO*@0:6L΃Tz#R(ɜgC5Ӗ%*bqIdv=T(Ik73 LX-|/Ǎ]#409a%#:ĂMX8*QCw!.BemB|yEsX~B,Ѯ5 c?F& Ǯ;% [˚ܾr2\Z`ohj!Ϫ*b e$8P;&<mnٖR c֢k}lķ+֧{ϥ@Mhcu^uζy9 I0/B"/lnävft(2Mۋ`ahps?_H^5E.KWiame<~`3?1juŔ*LFf6!C$Qk5xJ b(*rZ_98&Wr*mjX`+N5 Zl pT>Y= (d54IЦtkjVRp+! uX (QlwJk"#TfXQ3}Rzxv}8$."ǧ&M5zt#! u< qvUF-l7A*1F=ϔ%Q/yE8rjcR0I#J]׬":8d"c&~ڃޒ'-4V2I{qP}^d 2^CΪR;Yfw9Gze]:r)7OdLj:MrYlfj L2 FT CdB ;R=¦8T-){n& Z8L8;jK!;''^ `@^5#\Ġ?I/U_}UWUz̠0`E Xzq0XK<ꎘxr-}V2#>53'д$dӄ8 9#gCkз>m 0,n~fعpm[2@' ݙ//:%;DS0-4\nFQlB^a(440+P÷eE3ɚc%EC"v" ,n3z2U?Mݵ0"2'~#Q< ct+bݣrfX=ϳh1pT_hV܎êaWv3i$.£=4TpuғS1}AmqLJL'#̺#5C5WƇ8҅{HdJٙIkaWp!na(QQ؎ܦP 2(31)o1#[6hJ/KϹtBG5m+g QC0O% PԌ)Ǔ c0 Q k7XSp/{z)gl)d)bQ E%Ŷݝ=2#"j mF۽ԗ0Ș"%q:caŌAXx3ؤIHw 'Qo.ib&R%o\ω!tMV0 XAYrjdJw T%AxI#&]c>At4Aִ IN-KPZ M !'Dt0}[=Rj!Zr\_k90u"`ٳ::;-z 32[LcVd NX0ZIAX1"*Շ TRpl%V*[v9zT12ŕᬑ0bM`xifMZ=64d8s~RjtBg8{ =gHOj;a>mjXTA>ź@-΂V¸c!rL&sX7C1e "V|*8,)@-~A _cNzJ6 S|&l1*<̰wɉ;~hfSF3$+HJPc54z7 -4VGEKgV')>,AzҎ?*b4'lFI72akp7X6'0s'IU gFxc/q/^Uj 4{\lƤ9sfyAiu` ~w=z6y*oD~U|UcJU5bRE%-<] ٦tfM[C,rI$@;N6}bC W#qc].*L T@H1 i|h Sx)BU*)xV6t+Hi%A~E r|L Kl"y_McqM>7m=ߐի t0aD>,9"YV GO͘Jt`hC q@ )t:Ȇ@s\Ӭs (8C3#Ur"ʶ{.o#4;~% h9-"x`v2ɑlCFNHJƪP%EhC[Oz> z]o&B e=i ța {F>2 pyv{,4 O.yaxjR9׃%'P`iW E| _( Be[CV@-{[ -Sh^_B>[~57;$ph AA8%qVTC1DƆF 9573OK!_U%mޏr Ynb?1"=teA|  ;Ľ#-3¬3o#$hB{l+ȴBۂ Zn5ι1~\A7k߬p4[#L =.Mb8P"Sx;ɀ#['5z FRܵ]D2r/ ) BSH9g; h.Wu[y7GSQ(Ƈu A&bi5 r>~]##L Z(x7:M+9n0$(@(]r)1!µTYPe'NhS@RIM<Z ;C$Y:A4KctqE˩M$af<봈)kN8B .}KDh}&QKC̢4ˡSW!]CKwBDTT'%UͨE̤al4g^=ţ{C܏CZG!SWg! Bb9hˆ֥MJ̚#'2it3t:>iG7K'6Clxi6R;8Zc,*+iQn`m2v$fmJE(r.~|Ee ;iDk [qWO<޺muF(, L,[spu;X):1~FH,wʔr:i,g˘F[Ya;0h1LO/ܫWE}*rqFA()Qڇ03O)d<vB0)2\⍈h%ۆ<ݝK]EAܞaif6G[e>{><2鏂`op]娰Y-:'#݉Q;W065h[Jb".%mCd98PVtMʕbJK M䎠,$^P +N]}&s^BOsujhF1҂B:$. ϒ=yxSu\e R4 ,CU:J4U33`R {) 0E S,ʂG0nj7QQ z#CC'$SI#+.[>ϭݘP~U5htRH7BIV2Q[73G# ^C9ע0#`ɀ$BQ+L=Բْ]G4ф3j7<Gr18/%ɮ<f Bۋg'i S[% {OT?}j$52H CrHDݸpd Ӯvq3 Y'5LmZiYjl+<ڗQ^au?_^?}jl莆a sVY+}d^˟AG^~4zZն^+uE6+ڰ(>H=ʙ8qBaG-- 1n;>ُrYl6?HvѼϒDvԷe1',wSezd]y,3zqvhWqIi'EM[e|Y` 0|bCo2֙u`LlGB>nTS!V¿s/#SWi2 M/υℇ xEVؿbwek:51wHw?T$#hf9mMA6+k,wi H ),mŰ,0emsz8l*6* xV5W'z MX,|@Ed,C7iQ"fNC0~w&q;V!S)\m$4x9ӘJaK9p5AΒF 2Td %lTV V-$bcq#w[S)پR( .@# VK|x+6.VGFj*xJwԊYx#کe}wn̅'DTDe>^uێ>/\j¥Z_-oqši5Lbh};CMs)϶C3m.p3/2 CûUJ-a)aRMkJg-EMIŘ !z7pp6xGXulպo90pfgL|z d Q_]WYWa<Ҡ[.Wz 7hwB[RN Xe+N1jJGl -+Z{AK.h9)o5,9E'և9Z4Ck9H~( n29vIb/r!P#kIT`QrJ/eI:=Ad\Yk9bo Ԝ704#D"@3]]~UBZ sCPFEB`3c R"M!Bb扇$brKOr_а +RuYPXu5TƇraOͩl Qj$ PSK t '?~"Yke$w1E%5ԙy `_ڛgk{i{?,8K 4j WܺH819˜ϳwQǶ;Ƭ tA9pRhQ&J3z6-FoIsR .1H4_;M EqUΊoBp@Ty0-7qlƎ?ؓ q(|+KZʷͅ/,; Z4ZFk ܦDYsdd5:H{ |cdmT`4;R q1!{u,A$$Ⱦz+[ -dRJ䧸u&|bAk3ztOas m߳"W.Yvsk5 tO@6ۢAO>,/ӧFshӡGޫ5 RK+2]pY ~>#=dήհrЛU-κkUK'p(`*e'u|a:uZ+XBV[\8-Ȧ# U[!6kEP\O+#I;JهgIn ,zY Ws啐pI4c͐NK$kH&wr{+#ڗ fY1í_"BQ "X1=,>yΎ{;a8hT 9Ĉ5-Cur3XF)<3 Oh'tb_2 R@Ơ0,_QY* P_FH,Qs]:MK!Kfi}@m [ '-T" ZiDqL "kIcS)G2e5W^:X.}}:YLl..v#NR!Q`w~kh!zآ ^47&&l9NȘMq)2`m>O-ǚW'$E_&~E[ ?׽ }4Z?4E..pxv!ۗrZ%9Cms2T7xfX`QNQ  }gj 7Mm8yMR1$:vit&R!r(4نS  Qo᭢'ou [ڟaYΥ%}ܳFŒ+F%±c P00<ЉqEaSs!@÷ Ea1,!kV'DQu' djm4@(Zue0Wƍ. j٪$Mn@h@ .~[O@y} P*7 E9׀R2xϳSdi6rqǹ)Vߓ9dž"n@[R]{O"#Ѡx}•cq/G X=dPss"3I\23${UghX9Oxq)KܯOI)0vZGe9դ1: ߺ;C1tPm,숎 AP:_2jVφ_r)ϼ5|-@9 ̋5bƾ.D#/3Eti"4@MR{rNЩ҂2|XhV0pY~! R鲊==oYa7oBćPYZ%h:eܒ]rC$M}xeIұ!+ivb'daJU))/3 ׮w5e=j;*n[17 DGr=>Y}Ƃ9d`TWM嗎n"p"SX}fUJ {Wg6t@P8;X"<6D61z9L6H9؛AJ%7alO?Oc36Nq p0=ٙTpg﵁#Iܴ,9P6?zK6Vk|]$Ӗ΀!y&<.+S}$Ff6+HRIDM wpD3ȗ}BSE7HtVafBC,y5 {X4рa_0ԍ6Iͨ\fB gMȍƙpbO3Jב2ZՃ[F񌯇`mB :OtwbI8:Q[>2ȝp!+Q2l7hJIWڋO2XjMzF[Mpi~q# ,NGC|,WOHA^ ށyp uĀı@[чuG񣂱sO sɞZyj8֢ qk,pY$ih!!6+d蘛:Ň^IIYN+j ~z)p!*Ki*WCN'<?urϟk+8B~^< @-K@K#ReN+pއϥ R.BuRHB3@-ʀnA+d(yv& ɵ;օ9wD7%oR; fNOLw&e)@ ,[)S=P'`gu\I״}apƄR-7 AsQiV?j7<$zP>]),Ss mbn."V7ZcE,fA sTP n", r2pkn7H,[w@(Xf OrW|AGt則)XNB&h\a0AYazˎjH~f{/iL \{1#o58;|2a L4F[\mjݱCR_^V%AsQ &G};u)gpњ- \NQ́3#7Q󡧬Mk2*Eϖќl%Tw(` Dҟ4kG|XȽ7=k8PRXhu:E!soByu0wd^)mcu(4IOkG5 SQ u a K}ĜВnڈ!O< /"ꓣ GfwI$W Z|#Ѧ3^sb8dcNպfx"]/1X:$䬌<!n2)'DZ6UhqvWCq|MVSYע7xhb #BS#8k EsƋަF9@"BaK lzlްFqYr'a!QaVTD/*`GO<5H cV+jXjA?U{AQEtiZdzCE}/!TU ˏӏ{o  E,ArK>S SZÊ3j)TF*`lpCLC: ~Ѹv QsGb\ߵ"xe2B ɌQ0(OV<ӑlXa7"#/2!6ix[{kM`[YTƆF89>s N^evRx>dpE'- ``mC BWj+SI`7j°3BhO%GDjn;R1`>A=+Dfl!شSWhMbV)$9…$;\#gdGHnMb TW :tC.Nfߜ 7tn}]IIzsG)('[A䡿`rn}mӕ:pd-^cސ0HA[|_/~x|s5d% / * M|:!kG @1k&!̪K\< ۪ݚ rIeTqhNOZeYC/ = 0DZ_$R,Vg%lE^4,s8nMtA,f/c4C /KБF5P-Sd0aLKU(aβܚl"א*O'Q:4n 5kn2]+cLUҎvpϦMa,J[B{ cF8pY[J ;fFŔ3x#~N-yQCGVugs..ӈ?TeX@%5Ph(bfSu]MAK rA!y:QD ؀q ,6*ˆ%trFoHxDJq$IūQ#f8ൽDZƻ96{yv~n<{mԫ̑FxCrwTKJ跖ЬgrR婽#DN7qs<~v^4ιL,J8H6"2Ϯz-+xZ`!A ^v@Mqp"S^"5+KHwh((ޤ\Z>)8rY{v>d >"[k5LOǰ^Ӎ`kedVh : CH%ޮS][@>5*ȗ @.\$\Px._3zں6\Z0IمQBJ2(s \>X"ݐj̳kju&ߓ|)EښeKS "t/QcKSLs#Pj:h41ڸD5 8Fn|7=S vRp(QՌ-zgStEC91kc Cd-kqD ԏhAi@Ylp*O>7ːe'7ѱ.x:( Q ]TdZt쌠|& `ؚH9|F8ܸiʻq0uh߷]#sM(C.=ٰG%A!Lޕ`B2s _J;-9)Kt: =Ll+ڣdžwc.`4ny'ymZdyDHa!Y\տ;6gvFg8a+z;4kP%˘m)"R-APb='>stndeӾ ;Ez p[{2lHb[D g|0 ?U\}w-+7',NS .GҶDa&4*_U8m+kbi$/4"fh7'ptaSF`< +%NWڌ$^j0(e -{&gR$xNCa,㌤,5(hB{`ܳ10<4错Y&/aysrȗ` [n̹AQSP\6ݑ0PS[8%M*\]HgguHcC4!nK3]I KJ@o>#9D8HﱪHK]'|mI@a/`X7וmh832YHΰNL<7v5Wr$7PWBΙ'B)Ѡ.q3B\ql6edI9 jJ54d~Ir#Ɋے@)I;wmlIGc,\ D*_EJCs da1'3/kȤugkӪ#'f$6)B'ߝ6ǣmU8~= 2; {RIR(lzNEgNLOK=,<Ûxv.0/h`q8aVg+x1HmÀm!LȓqvTiur,:Gȉ 3BE ,6yc<􋺾Ŗ[MjuY1dr<*պZViFO 4JF嵾[qsk۝Jz׌\$qkl00Q\gXSqtRS$|媦 zy0;iR ~&HԎ <UOHb22ra_O%CXzJXo8; /(G;Hܻnm?i2%4"y7;`$z:T ]_"&YyN69Jey2_W4/详>xޥŹV>?q}YM:q#/z)GƮ^g|oCwVDP`PHiH^6<d<ǡUȟw;(p bdz/j.Չ??/7} @r[QxiG h} 'Gs$N6!㓓`q6z|C lG_ ijE/ _/}t;0AB\btGRscI_#ׂ)@S7HJǦcDE+O1(]'"&mw@N.m`ȉznytqR %ߔA^b\1* ̴3H$hܴXĨsYA-c1 bs]ܱ9ixmd^c@╦84 fI_#69 <@)g\u}^`3=)jR=\M̬gi3qMJEl 'T u7}/ 6/YP0mg Ya(6"vB^-8SWk}#l93Ey_Y]5c̺͂eHg&ck13A|і*`&`2uB)>;_!,q"O8Þ>hPjWa$c;$6&;X!M1`bXA"*TD5`5r>tx%Sp2QacGAqқ1f{eLW^hنBoT46qH+_N%4_ M:pu ZŠy65ԇ8S?<++8T@ Yes*NFZ1 ``X;e+(J knq'jMyv:s'oLe A9.ymt;S`@ԂM6afR7}^vuz>G>#nh.OH>M1qԙ5N]XD5#t=^6{؟\aD6yp<;Z@`JPD躘!A7m\NDẎ~h./kKB^و@B2Şߨ5h g͹jKdbJ{hQ17û@;EA?Az3%TřA/Fz@}M Z~4Ǟ5D abXܒ9T%$IOc  T&jU`irnz3N<"QQwBazOmDm|C!u[YM$(}DYpX (jWDL]n`Lԛ ZصD0rieOe`GPCKmNBEzd#^S@:D,qN:~S &{p^bB*K+X7;ƨ2BE-9I}{MS4>+Ӛ4, / b @y ]Ֆm\Cfdoa324 lc|&BI)`p~beˉWEN x 6&\Nְ^2O`س) = MR2 ^?&i,>^ Z;_ ay şF$? ±lZ\ SZj08tI[eWLb&6&L^a#Zq/Qio؀8eit.RԨ/yMkE^V EN/n2ok#iTԁp;K\Gͯ+ ޺C$7lf4O.^Ttk,ܓ;TpQqY,kB8rɱ)U,bFtoN.x5@|& W xϺ̠Y+IQMR(. ūoZo#FWMe![jYt [K=\dʼ~8@mf,%B9-A |p`'> SkڕxI YjHpc lϯ 1yn_CUܹ!WYEe\ciPHE] vrX$`Vlb(B0|tU{X]^kv_U)J(⼕X\1Ks;K߄Y3*Go;m9?5 :cfֲrzH3\Wjm;J1.Oʠ6!$EQ]j"KdoNX_%)߳M؀W+$QH0d_hfgN;aϺ֦gDŞqH^tF޻kG_{?cX\դ2n_vL5ʾ/5 Sȧ{Nn8Z[&@EGC_vw+sgm '.,,\4 u9+l8'KqUl!U>.M@@l?KLEFWy\Z_*L "[:jƇ- %Cc[aZIOu@?sqEr0㮢( i*Et:Xk_#Ĝ]DsKJեLrPmߣ~sMG]iĸbHA;^UjBqK?>Qf Q?qN]Gtoܹ+ʑĽ뉅iU"f21>(hJq.+°#5@Y^CrX5'I۹5~])q˟@@lj}qzNً98i4@Fj)M[!Kц&CH`7e| ;4$X 906~~Qi$G'q&]o=8B7F="_!\܁Wx/qK-mQt;m9ya.&|J#o#fMJPz3;0zF](Hb[US{~Ot)x3r:gF^׃Rf2S^!` kBEpIuZͨG"X"wGؠiٷ3yvh ,jy.waIo^n ]JBGQ gRm1=M8 ㇰ7>\֌n\ӷ|l#+LLJ 4>)YI>y3JY] H_(/^$u"Mw@9GJ.E2֖8nԣtIBA{rT@`"x;' l%^:B1خ$,f"k5SJS=]ўqP#MSp /*G7N8dP+$H\8;b1qշ -%wxT FUm[Gt;) ~<|H#MFz t|AdVO5|,{%-*v&UEPQo~墱(MQ㈎Id\y&]el;Y(babj  ["#:O oo닏CyÊ,0?mؚ>_R"g2MwExqX8noy*B-"->f e[.G _N]IZs ,>Z̙eXxs*tҶd2Yʅ-;Y{X.ƈ5P,$P6]6{ZKSnkXN! y|mIW۔;UM*f\*q DB1Lfo,~*>~Wִ0uN\KlzGʆv@s'賏Ǖ|ɺq)^z){2) |5\HGb#hg|5&0A{&' 9}z,} YOAҝWsH 1m|3g%MQ{c[DƎYF;$W}p\etpkP\y8sc v7Absyc27zG2c[ӵ,c+§q.@:̟*AѠ\sS2qfwwv2R.O7+)5Ky@I>zx' KdޞRn.]ewo?)Pf' :]Ǝ .#„eZV 7>󘬭 <,2jC`w/fr06;&b-Ÿ{yVoQ WЏJ;dҍgN. tP:'}gv֟aƶߺ8! AT9R|+? |e/zd"|FqwPr^K4sX+7`D3_PsF84L/2غ%O"9Z?8CO LdP'ȕȪ"S'" hQ+O:kp3ԓVԀ,Zd)]&9k-^x}_bTjYPNqYUl9P z-4ƇڶS;d3$G] 8e m2UXPx8C4m&{E2*#ȆSPBtsNL6J)/V0Qd_JPV*+ 3p;Dj ruZл[( U:SHzgC1\\Q0.֩qp 1:|D! TWS2I"l xɺ`%(1ph$ 7 K>nFX1X"f'6A\PuPj(Ng^cD($nv>YF%ڠ*Q;$1rө9K:zOsٍBriGtqS4+g3:(p gxX@p,qUlKb3d=Pl\q=ã],Bz0mN ކ kyT1lדPZß8mYw!Z9s2+ʴ#wIWN'gq'^nCf:y@V5A#R&aM12s/@`W/. кYᕢamJl5rbi@\Z.︁WoBs!yFO)4å' \aDCA2гo{K{vb| 8zb.# O/ܟqRebn0KȦMR<[b#]~1 Bz -"۔,&"?E75?DCpgn056a4C栕S e9`*Zf"'[K) hcK3丆S㮌Sn7g"C Wx2|5O+Aay''N#cdC:JDRXBx Si,m6TWu< (gj{ 2HemB'N`7N<υ1I :zC 6S yOKb~s1W;S87YgpGKKW숙@ YuE Ry0rtX{ J ?|yvj8.)m|+lvdÛ?kSXh àOD-a! PX@eܐ)/s;.dV2V(H3LCwV/LgrW]w)~%~g( Y(v tcn䭠V_G DAmWCH K%(֞zrЍ!̗e:En.mhN茁5yC3V0?$kK"c "B͊nҵUYAdkbF-b$z 9t+e$0S1 ʶgDt':^ @ƐpϏ@^?@J XGYvW0Q|Bfk0,_uis-_I#ZvXQz`24} !|mY˚CFg!"MEGGfnT8zU$V7Eq@k<%X\2a7R[%LF1,J${bjp۳ +3b@׫z4iMLWi٦ ^eKr{jC`Xɞ(n AFDim#YU).s5Qp6 Y` nLvC;K$cD\ z }κr0;T\26ΗUn~L,9*u#9Eewn3)Im{;~a溜ɟ+N; Hkp !53+ ljPu>=z11 o 4cq{gja9E@&+"!jD}N#K)sɹJ `[*^G"Mc{8rs)TA Ǡ;eBaLڪvM0+WRWcf!=Pxy 9+87㩠JJS uA9pu?[E@zGvnhm'cxuӪ21HCV߼mFmZ)0HO <dY-΀Z55,]2Y #bs>ӂ`5D>@дIfBJ)z̕|=ǮGz9ѯ,fp17+% wksF OЪk:|Qhp1Sl;fEAj.DqN8ۯqXZ:B1'n}mњ[BFe+4XkWAS+clBWv+ԝhO_M~SO鱕I=Vdbm.ցՓFT(F H4o%0inGU#QbgǹEk] h)9L5TͰbGKXG5#(1aE-yiEPˑIdMNE"[#4Wي4 @5WZVLnCm &1`ӗ1ʂ<9X]1;q# E/|)8C'O1n:]Ru3Qko;>8 j='AoNo9UФZWBf?,{ 8u1[&sd&wqmLu-@$>WmrbDb8ϩnA@SL, t0Ç BNj۟9hِD4J,D}mfbiN&DqNs-ՙji ;XĎt0@!5]]ődZSb% *b$`;aB6fNx PpK@,j5bSnTЊ"65Gz%*( !*[1PM5:dL46kg  1Ed^˩1"wYu6%\l0˘#m:Fy!9Cz*PC&a.9 {-(›+%kU d$ʷG2 YJP1٥ -bo <"롧iaG'ϘZSx;`r(ϳ#cRǂ㍠Zu Z .۷vEm_b~(E6i~5(4>bNژ]+ 'ii#s]n\K |w0J*>_Ê8RfZQb PhVϪ΂:vAXch:v7!M`ѭ烐b/nv~;KXY̦dG$_Gx KZ|p LzzU]G4{*Z2cXXaMDG w2ɬ]c^#Í.$G9lx =$=x(2ivs!H ̧(qp@e_SG?8zyF|X>h6}f1 RO0]0p$7a УrXx6,3Nt#!@m& MnGM.1G<]:M"dJmzewJE),"+bbRJYȗXE 4kQtgVщ:;S%)\iԥ(*[m^,& 2#r$r=8' R@ mlБaaAew=Χ@Rtŏ kl]P/.` a(p~_HxR.lzVDէl:&^vsVHznH:ΫG |.ϡX~q$OS-y1q~֋q /t)/^!=a̪N+dF"ӄ* $֝ .~Җ h,pul57Լmr uYqT:ڏ & #RY-KSآ*44qDQas>䲂`ރ"nCj+V뭁'~/F1@9AX|#clx!I*#ONjDu{;0uLlj[*؊-E!"a \/_ (,=/)^3L! z]T.yGy{×n)#o"Uw`nLMF8T3A@ys T xv\B,UQ/䰴2W~٠a0i(AEgE{9'ar(8Tζa<hpli#)1 sg1 Tw!|"+xDO) }DcpTE&R:" nkF[W\}|_6cq50JZ6F%*Ei}"0w#[10qcUA Xyl.:VZM~`E?D J性Kb8MttȔ_.(G++T-WpxUo}Io'VtJ$ꂲAbp(9=q:aŮ%15+'+4%G8E+RU+98_㦄]bX2M" o=iz.ڻ~i=>wAQ&EEǸWPpnlTnJqb*dE{1Ng@W`i2 . KmͿCoi -26]DOnZxBt-©y.w'lQ涵*b@1\x(@jU0&h>M_'Y lRD_dnKWYD'W"]zA[գ )ĦN lxbqh 㞃K D V׵jhjm?L/E%ECkpj<\``o }P,$+*4VL>sfA؞pOD|\R\Jʨj<_]/7ɳnxr ^KIV8|Y`) dZ=~tf/%rzS#Е z -vGoaƂv%:@^EAN Tr} bFJA*$1m2ͭV369kBbn]LqiT p1ǩOJZVf/"bG &͑ Dvv([[͌_3SIݚfTN [>'uonJX[N~z~O6ե+ߺ6_ q vQLtA|O4ȴ W!z?60`KΎX כ2F_ur6~R$)Z١UvN!X0{LDP*ˉ0|*&Q<[f{(XG~T<]StfH AT-vWdkIr02%AЀ$!=s *4oW$%Z5? .;Ltk mb8J9 SG*Mlm 5HҘ.CE $=$--ɹ(cc6R|́Y>}v s.aD|ԉܝ?gA01SFXXx||)v1 r\8VˈOTu( 2P}s@)2^j9X(La[rb4Ş6>ZPb#&V2X]y M 5c&`ml䤱$O٪7iY7b\}C^5v-,l_NMWdĖ BTQTd$͂N펯;Ê?qygLv=%S3gh&0mdW zeЬa@"){d]'bia()WC"Rl= >Ӏ}3ɭj|F;Wuk5ź,@Ő :/f$Q_rR1)[peDr80BN껼n&'@X( CXßf$bbVļ΁Nźnݣg&z*dg oru{xV?48u4((*˥lR%њFӹK%Q 6Ki3ڏ NLJ`e%HKƲ؏X~U|tAm ,1e;8)rW#h ڬV3ckqZGWYf6Е5c+M &Ut^h$v>|.L&QKlY69 x;f?l@,N1Đ>GfZpt%a<¤I/l (s5rf- ;{A*  pI-f<#}٘t;AV!MYE" ns'^jt&uhA=3P9v}0F+-w&=Ɉo鐨gXGb7bdny*%o@\$ȦQd j%Pmw2B ڎX|߉((͘@PN$fG`uUrmhdMQH!Ms3l0ObT?U{/w)ڠ^za䳏2L>G; & 3HQm{}k8Um=GYtM֧zu&x`3&#Qy+{pVpAv\}C^H-2N?9ք< ^%1nRHvO+fi'X֚C!tkKPn  Q`cDcié/i c|U,E ~^$@⛩#Ha%*n󥠅a_C׉%= 0bꨃ }v :xL.B Fc)rWیB&W2NnE=LgͬTĮZ԰.oV1dY}Q폭'n:jfeԌ"=E[͚|mc 6>#:l\ zem0ڱQU5:h{$mO:9TI) w^ʦ}C;hҦ*2e̊S돤,m4g.!gST͙G}#@͍ CMɉ"zƷ1Rc[(^e\~wd-SG 2Xs{glGenVC 8C141b` ˄u6P -&p >"(ȧGO û{"c9=g:prNwqR<9'@ 0ΗasI`(w7!]J %)DHoF7 XsY|aCxFݍ/oyk@) uĹ<&_#}'J >^hS5vhre_MT^bJǑmM0E66g%B5~S|;ሇ^3*< >7ʃgجMXoD^" D0TʸPue}Q7hJVgz*5}09so:AH6>rlYb7ߤ':<="Om!QYVTs48 1I Dҽ.β\ vQ9U˜YA.Zkl!K Z$z!˨O>uٟQpPJ~OΞ[fPnK*$;!Cw&аBe yOw@y=$& Bړ[:F'! i̤r}[]Ȗh]78RGEo~@d?IƄm$ŜPwb g˥~l%NHGgRd p8#(ﻁ/;z4s:,)xn%NJG(-@<*^~/py*wV51o]Rr }!jw}mf hQ[<* 22@k;SG9B6DT+F0ح;Mc7 !]\Q^wPj&uDz fHyzݞMoTY>C۝[_ť%QmŠR;K3ld0ܖ/Jq[jϺ}MzVpWD C}xm6;{|^fE K(Z}:/DzȦ*X& &Lw6Jr?6 G 'ljsϞOm i';M%ipGi]'c:15YƷ!=)žQM7,K YkILXߣ*<וthy~6pٸr,%Ÿz-n$Yڟ1t";e,UF#o.?/X}&ŃvC2iHiS"QgV¦H`-tJui:-8tyt_og5kghB2Da~]wfl÷;xc[&ɡ1{ uQJygї* ˒W޾Cf<{LK`g FQ.* \rr=# 9KaH^6vq uiלA\_фJJŋ^L^ ""P\ qSّ}G!iQ@25qPa_IZ!NHJ>2rAhaRUŵON$ N 4(sWu ;"!7Q!cFӃ^JWv>B>0PWcu?^ClMpa#t˃S2|S$?F^pv\ENN_$LBQGqZ]B70NAƛtC#u3`1267.Ki`yuc+4o2-1LՈ .e矠}uSHVsf*E;_+kI{X%j8t'7:'"h :b,5ɡh~r$qK*nHR=oe 62+h|"]at(%U2X&I_B !fr^[SvyO^:z)z!ѳD۲\ M2aԳ{o7N]Ő}QZBÈn GtWb'Y(WWp纉q@{Vظ4ObusQ>$]Ke`%ek?EdPa`OwEDڹ/A@"KM^#翇C >U犫H,loo5U#C|qO*+#~:FS<\x"';nKº6sy#9h@Iܵ3N5xr^EKdO ?N񵑒ADefѢb/f.p=ޞu#RO8lSJ[] y:4 >`4i"(5cGa_U*I2_4d>y]/c/"g)^P{cg!QYRW.Tk#{75z_D~ɩ~>1aIc^f]ɷȨ" f7?paB{̕,~\U9`bBx0' ?;jX7Ͼ^ٛm2̘*ԣ:t9J?avܑacT)i`HڶM&y_]tS^>"sa!~y ed0֐l@XTAqևnqH}3_8r)u{W38/p@Ӭ t3 l> OdF_O-%7EX%eߚt赨{)u17(Xv< JC9,$Y>%`8RY6k [@H90!0@^21&;'j Ȋ5iG=&|G:^XU,neM U o0-uF->1-v.fqӄ3Les_Xv{~9@ܮ.G0#3UJ LQ\nn1OfK Sgr-y0I`(NR1KA7:]:|J9nʅwmc`c9xNӂ7C CZ;[ڨywʘStk=Φ_ kZZlÂO!sҲS6/2x{XSM*oc /e^^i4|(^9ۘIX+NQ倝cṣ^Y,N|kGdgiUbm۲YsO/p>p=۫yJO0 :R)o=]7pJ#>)ʠTD֖m &~ŦdfKpm^c:&yK¦|S-1Nu|ANāde8핥Qağ暊nJ'Wêy(>]X3ٖ nUPl4Fj6a7Bh=f=Lع}>Q ޴lqKYgǎ ;2h"DKX VZ)# cv֟`дޞ؟ŪH^EfnIӯܬ-Qeű!~Y- ;~T޸{tj^+IO'7I5MPFR@/؆hNWmoӆʊHixA\^:S'yq]1j(k~νaj-t!oA6=Fx>OL,b;Xr5ZV_ ;Y%6dG tpSEe<uϠfw< n#I9oHXqC.ka ;ͺtK`5kG[=)Әr@& 5{jVďםg>  Q[@VdoWpg?9 є8ͣzf5$0+UfuTLkmU2yGRxE<\ec4&rWLQņ6CZ7ݲ-DwF9uc̖' _*K1<{igx F \s%s$a@%'UOz|GD[1#ydELב&#GsTPy! S*.Z5nD0H=6E3FC gpRT!3I\63$Tn+\,i 048L{sM7PKe:#d]Ӏy $>'k91t&HO*m~F TƳk="^u7 V¶NX14<44~m1Ds@f,Xeif.k1zNhx3OzzڳuyaF.͟J"O=knyk Ų cHA^B bg%=.m3-Y̔ p.7,:(@0W՜4un,z c}j.6W jnq#l[/ܘ@=9uQ8m7҈~J6̵2\'R(6d&ioQ8FG*T4|rL&ۢLLlC U0@CG[]d|;7+ #NDK@ⴕW26ץVPTݤ| hBȡ !yL[}t28h;cх="H y+ ¾[q-/ 0;(:kn!8Ț+^Fi 8G؍HjD|SaqѮ:@RɕmV:)K,iF}.D^ ,_ݵz&v,O/׾.A LnҦW0sC}U"ZERSW u(?K60 qWƢ*&`L\T߄SXtߋC"SɭZJ{P/_[5XRލNg脓wp5h\B(EtBSEyˣzj]i<-_﫢| lMVb1}̝yԠܟ>kK;NCݝP3@E=>,Їbyʱ\*Oy~ZC7OIO6~0T]6~u:̶\952خ@+=D3f7~ 눾Wo|߱rd+t;yE)i.Oj- -<2Xi Wq Z4zP)'H1u@ue;u']̤zى G57nK<# 1tIS #W5;}SYwK9]J$Fa:ysM不^G3fllv#~T hxX=y&, uW'XxP]Ѧ .m)ֆTT>Q sCDߧsP 1XX'Mvl)؆OoDDul{Jud9U(bStYQy #BvtKMONM 43ņ@]mFzP.*d$ c%&4zmR y| +ԌQgĤ/P/V/A$I{V豟b:WEE}D]/1'O#o2'S&b MظY5y)e ?J :!ʼnq6ߘ?"`@GAD/ɹ7}ƎŇ$/v:щB m, cǗc GطCA/ DJ j<,K/&5f48r<Ot Ko sK &i]-[$.b ނkYp УP[}s-Dv.O̠}`v>ѪoGÍ1TtNoDݑ"(rs~y¬0'nӶ݋ 9D6%׀_te]]59^>/dvq58*>-]CDߑ_1U8H/_P4US0PVw&8ZQɇ,?b8yUQkS[Eg(/rhMߎu͘LPjK_TAҞjj0i^_L vXw;hO&n}h7YTw{lR݃x&oGAY>-qei o<"hRV<ߙ9ï5ƍ뾁t@Qs,;`ӥɆ{ouW ^W;hwFoB[)U8pIm. pJ qˆ $~I𓼾1ԋ +r\Ð#@qƾ~c9`h$욆lQ{nCOKE|8E"N_ ҹIwYJ`Վr@NHx)j Bu(J\g:4?=9B^{ͫ(ǝeM$}BaLʅVX"/l̲t K@gߦEkcvy`˛>l-mo0]pʹE80rx=pi 'jk|-]S(go'(R+;rݰWb轚!g]X<j71a/\ "NNp0%C"4nQ{=Ru䵰䤿ZSڎޢj`ElEr;Uq/h4Yh/(; KdSkɓ{r0^iE^(2mt'9T -Cp_$Ʃq 51cIMgpK8!˙MB,z/CY/ }gmmj7ÕhZǶQ{<kv.H!t,qϵì@a>C5Y\1aYjrQb3o[$S`'50q^8eH*^N8IB#Q9aa\X`9חH\\$Cz>ᔩCjE=7 ITXBv[5|0X Aԣ4W8CW{jhu=:VcfI!r\ŚcT}4?$ħx!S!=I|0\CG{,_Rv||V$:Ϩ1wZ}G_Me ҖQK\#yںb0-vtv@ˍtrx б2^Ä0PtP$I9nC_,t0SFPX'R"(N#o;e ExmusȤw`EXt0 n#=5dx7P6}2]p Ƿn˨|!OMqGi+,1VN=wmLGZcO=áBC2yv@2[}y62Q3cac=yQ/AD1溉Hy*xmj0 6^rU=NjHo>If! pj.0&X>B]xPD]`/,Z=)q|w7ksrRo<%ɯ{`<!’r`g7#m {@ ^Wi/jsF47q3$1riq$ 3P'+9xGޏaEaNH78&g޳g%^Qæmeܫ/07Z}<G S!WKftg5_:B+KH̔B'9 B,mX jUg6nԠ 8 /Jwv>I 6!qˮiImI\4 p7lGjl>W lO5sTﱰBe gdvU㺳cs]b- XۦǾ|<Ƌء}xj}u\h+tKȌ6V_`Ha x.99CPM/·Ҵe;W|J:Gqdŝ}`ctz XL$7 h!Y eu/X^XvC"U5LhݥNoNS`(,jZ@IVg#X%X3?@>bJG_<\;KQ6 =nZVQe tp(V`$f%!^}[Ҥ7l\ڔ^Q-.d_[wH"$MH"![Aj'wu|Og6x&俋k" Jm8̱Zy Ƙp?0O*',? *Ixd@$y-eo6Pذev5Yt(͘LlM/ny25~GN  95_^vٻ4<(3Q;)<c5 ~snX֘dGRsTyⴑɭOX"T5؞ ?'6U͝hf!u.C=a^M܃RNV @/"(8%C^VZ0,)}RS) G;lI UB#hhB;ݛ-%dJCyzd#t6M^lċŰ 0.@ˆݺ/9`hwo}b <YJ1Qegx%b_8Yb~*yب' 2e^'ŶXU3փ/30kl 0qz y20c^g"VL>♘&ATm]Xf.vRö5(fdcPT@g0JHE{Nu@@w"nVO>*M1A3GURGݵ冀"vc# R >Lu=!ށe8YSc$wsҡ :ujn ` sLEN/0ElGdLEH%@b<X O3SWDX * Nf tm`<pCUg)Cyz\Sn_R/N D)I T'z9kg^ 3 Y2.#C'DN-C1mdȂޅ؈L怟IAPu$?褏E:oF Ȕ]!t`fukp2OիU^C,2(OvPjwáh gqdRnꠛ \2Gi,׵zN敽7ܙTu<-l6[_5TNuGKT5(F`H-$vtXVm !rG]i˷ ]溣.m|)F"^lKɘ|,}ywaSѵLSl)& oj>0w%y*=:ƥ#bb9zYM־.F:d.}brL14>fx?3#M-R"57]g-}rx獖E_|dp8 1g#}".[4zj @Sy7-MtR haDfK2n䐆7h:-C rcO4Aܥi~ZcRȫ|( CF" $x? l4^HLyQfϾQΦ)s+GE~RԤ/Ng2nDs$|*h :xisE+J mqXՒ!mgs.q/GfԏT" hFaĜ)q/EMJ2kd51JY>.@sV$p ]&pܗITn^q 8.@rtF|F>g0$sKP\܌}<)ҽ.,cjHmn6& ;G[q9[r ./xUD>* }&XlO5 -5t;qpKtFh)f7{2WBd+%ВqY^kC(1v8Z#{W}=^x]Onv޼$[?a퍲V^リH7G^D *H4ΓB|Z<*bP]NOUؚNtv[pb#pa=󊅇cqPL?$=vs[B1szp$=4lY):xWWOi KFx<mOFǎWm52Gv މ_4ؒ7Gbr {)S [Lq'B9v9w[\/߂?@ q"cQ\~2XqGbXɯv a4>ڨ=/x=b_X}~͉x1Hp6h#ܪe&u.uÌhx%cY&pt^Ol|[Hw0G7)[*w4JDscT[Q7dKeQC` 4kdj;j8jԩ{jdX>_? rrOQąnQ}3Β'nԣ#x3GG۸:;'z}jp[m*`k{!ej)q}e &Ԃމj7wԅi<-5 M-3w#H<8zNj-{\xSZDr |s r}CaXBh- O"iI#:'ӀLu@v?1".g6/3_3gh%C#:.^ekTDAw|LY5 䇌!Ե&ĭJbVnAM:z7{U(l{IHdd&8P&u"8@|hG5I%@>P"mR?#?WrϛǻNr oPVeD`Oe]ӱ s{w&}:%Nܲ7LCYy:0aGz>h 'GT]1_C#gʼnGObpJW0ͳZiFS-ߙGʙTBGR()kok!9b[D{BP@k^a}$Έ?;_mDb7?48v,=JY}Tx[阩Qsh4ڥTO |gxoR-])!XClkizRfex c @6ǻ,$i-iS(bv{[Yz7AgIڙp)0 J 7V."#>-d s90x`,e(Zx*Ǣ傼G(jWp؏O] \g?l3 ob+ i{MAI'f`#<0I*o?HOwaI yg #3&8*P8Mh]#"5ie E|k(WS:B̊x41&?oj2 Ő-'ȸu q<v1U_ z#@6b=fH8jBZz\fJ;KTcT-ʗ5Jlذ x 2rc'$uҮ$VۿH٢8E҉G|6׏_Ѷ 74 b0rv׀IAE"R &#]'F#QRIj J/EK+֏;syLs wYt:ZrG-nLfvLиu6,~Ba7D֐l>mSJp\-Z( |Sݼzѹlv*Ir c3*hL/q"F#9*:ENP Yi"si-Jɦě Qe\KIA [5  8Y7RtGU,hə /R4Kη\-eQ;5YnUrov 7_ H0Yfdž^r#J?E.dcgF:Nf[7cIF/IE:/~Rb CXKGg^?haM!FlEbՅ,Hk0X$ >aeNac `N1Gq\r4kb(*z+ޢ|=,ZcɑNpavk_⾡t!esM 'Z odXFx))(#WPM oښx(e$B{c*hx"p~NiPpp‡Mfq= >#%LG63>Z}6z%1 ygaNY}l.݁F(;tiPMsTqSdp6}ߪ"/35쁫pԈ_;+ɳͲhL& u׵n=`B0̄MeUް{B }p֫Zsm4ʾk,YG ;Spt TUeQKϖT ٿ> ͽ ENd܈Mv݂Lcɻ5z91IcĮ!v[Ooȳ ^(uANl72.J˺B0E=X"P2[[nArUfi̲-zw>GvХrߟ8R1 JFn >~iy#dљks4W8cG!gQ|LV&5ܕ-o?'jtG\t!<7wU.Є#85:N=/j@f yU2ߏ+4Oc̷BNL:#SǃdEX3viBT9:D(w>SUU@;bfc%59yn88lޅc][F9HIr5vcwuRfˆgfJ䢼cGF*n~lqO}N2˪!,MOPs+v{rg}R*+?l^ձk#q.(BJ}^vTp8P7LIn qq'p,Dq<0,IKKX89c[KF TKfYw҄tt֖`VD@w.s 7/Lj6.&Ԡ|y$G8|D -{y {,)ve+*y\=Umk`i%!wg;A{`z4Tst3:ܕ*&C'ϕTw;.#m7f4XI,.(j}vVSϙ<w0C*F3bC+7TaOS|"`gv+z9{AUyV ~D!޹}Z Y}ɊDTyhmǴϾ[uLX yǀOP"Y\*v27ԂO.ki|[ OMjjJ&@plzsZomREy;w]I\#Ë V^J n{+ƙ_M>BPM3m0s=:iEћ*\wʣ59J=|zSҚ*N+ 31)(K\=(K )d r%řWP{hG_mTYFs_drۀ,J,r(^q.{IOnyIYʠߙ#7+upNp"_俾ڗ2Q+tsp灠r>!xcNL R8i -Z=kK_D@KfSk3"A\i2j#ZA*#3h`]jkFbcnU]x0paȞtv3k Ay-,?fg(gpc /o#$?q 0v aB_3[[e`|VuP\-v,]: )#oc,c9"èM9h]gZsMu"JTe5LHwɛI_?YڪQ hϡ:=k ;׍VdEn1^PFGX+Ղ M20 bRfNy1b:9[~DF.,ΒlКù!cGV$DWnSI^ֳ|\1s"g帉: ɞH67Z,Kk')-$Uf \/k]Hǯ ))"iUDTco>qU+6>6@3b.g'_F+nV BV j$ v݌K[,Oa:zp/T*`W z`ڙ梠^ɶbPeѸٰ"XB6 s= B˒%-w($0sW^9끚u-!x@LO]L0a pXuASG ڃ8԰ A.[~rZ_F{C*!H 4|ڳ-bp6_>+k09;oL)IMcL/iWn9dm#YJ~`rOI,jڒɌ |}p"=)IVhCz\vRF{ rt=.]VcV,JC Ũq@Ax|@(H+9Jz3Oi.Q{-jNϭS9"(HyvQxH%cG{,u_ ?JoH#3Isvڳ۪n \HՎ%yC[ >B]ϧ:xψ{}"sXP;dnӅQeDcI%xIe:U8H\Ӟt}8@_Ty/x{\LH8^/\/yQUܞ#"(pS܁V.yl)k?'TF[x ڒl?Zjb `:"gר@J ڧaQA%|ISO.X,~lIrL>[Tqln7,#HgHQ\E<+'ŶT([䖥wb'Sokm%`l>ي+~UL!| Oa|fa1dAw0]-0Y"ntG"xB5P rK 7u)menyJ2 Əx?t7*tXI?'@5ɟ:ℱL[mą̻at-+"B&/ "sk1:[HHuX*o^U3EBރKFɂg%P4^Y?|A_&|y|&A"WqD%-.\#^w@q-%$G(ȡxOZs,y|ʙK(FP 2[U!VYwfywϽ[s⯂j_moxck^#H~xh=PG>*HV$ΜvIY})`:.Fl<2C?̳_Ӌ|be }Rd"*=sWKkk)7'_efIYL%INu\u4/jZw|Zd2y]z(ZdGb}%@qrNr2nHN?U8h_ڝhE3#LGuȬQK dQt Td*#ۈy0}uE={ E 58Q8[[pCT-?O)NŎ9sr縄~ǎ-pܰBNgjau4$7F˕ɮXkUeҷ犰^<Р佉ucމ`2 Հ [D؇rT9%}Yv>HNPTZqtY%Ƀx~ hCDr7:N(⊵츺:] ]Kvw#ם*4عp(PxN%-7_ZUń[z+V%t+>Kr +2wK tu*C7KS#1B2qdb~HLio9M Z п^x5υzg־Y&h NF}9PrL#xϦA_0f2DGtV2a>V6q!N O @ ̩߃*(wfޡW&ăg~i!_Ps6!VzVH,+T:j >b-(X9tN(rwzNk I!L9xr'wK'OvzIXimU 4; yRORN?pp+=9ZˇpܰLW r7[QC`7B?^b%L'b0֪5rPbXT]W͟;bր[rtBn)-XB+XT_[7h$è6Nr]+T'a|`(!^Ti> >S='Ɯ%ƸnE۷`n īFUr7dn0A1qEp:!8Έ'h>Ev4ǛL Zgxzeu@Z1Z#|kxVP"g[;ŋ=@t/ͬid\QFc٨ܡr)AGY$!*/W^m No[vfF$ղRdgs oݙ$--Ϳ 'bm"UuYmNK?aDwƹ붱xhntQ[80J$;J0m%;IRS2M< &s gL EThn8Zk|`/~X>І^cS*.A-A{$4hȅDyjL9"Y?!W<'L4\]@B:\!djpNK68GD |"a{= !3繅x7qE5{os03vqo0SRT>b}u,2&)^?7 CcPMD2逛68XJf*z0Gg(T̽N;)1(pn):WJrE@Ę˝9LX`^aJ 3>΄5SQiuKfJ`P: L:qܑXqC2Lәo^;UYro՚R\kJ۟_A[҆^䟲Ko(L&WMM. tݰ_(wI§[^1zMgc7gt<Qyyxxg[)W {mRm BjZ-TkQ܎E+94Ke">zͲ3?$~%lsgl"us<ԥCTNa+DFGtjQ˜l:Յ#KV!̋oRmEo0PHc eL6b n+;IC\|4NYlBQTosҚՏ2afkt^g9 1 W&2)} {+vWmEgjS1ܻZÜ6m@iNEAHZ.S]+ q WQXkOK ё֘_c:|a swDk 9䙤Ф(|lXq teK?F!dfI&6J`tq d{G\ں(L[Pjc8fjȥ im֕sª[A4edҳnb>i^[V%(RE! )s6d\Nz7xSNMby Dm{~18GZʸ YM#^^0I77\]Ǔ,J29Q0t//Ϗ]Y;es4WV9JtRb9RjB.V3tOvI30,%OY*ܗU d{۞i(<ɇAeh2:2v}㛲<֭s算h',Qk988 Wt!(-=%QE]%HpwhdGlR qy {@|`^ޥҩ<$ovG;#dѷ4TM+ѻ:dU8bv1^<ݥs'naVڮwn5^.K| rTd^3VQL|%Y#NIj ]$U~Fts ]0 4Gͨv/#Nx(t==FLv3{{+ސ %sކ lܓ sݝ~pvVDHx K3!h걀ϊYc}su. mDngfvQVA) DоКyH]=u=T+8[]n0cMduWRGJ65:غaSjd agƠɠ''4A vU~[ʫ[Q`,&3()a^iۭSl_nؑ֋w1i/ur:^Nm u8n1[8~;RxƂl3I机eU3Rosɋ[D]p7ȔY^!vE2G˙{]R 8}dSnu Kq/.q`}ÿ(9A,U6{wLWL41"4jBY?DfBOE0K6[Fwonwrї忢e:db\5 z1#'~en!MS+[򳏩]!G_/&O[f } CjE*w͔z1ʆ4YuLDJ1`>l cnlV˲R.j/^nI=]8ĥ)8LR<&JL4ILtbh^̚;uӕb4hL$>7d&g9IuKBܓs(ቈ-tCz5@ZJ1Zohy,rKKkWZ\~AʄwƍIS֤a]=ꖲkw15AZxbCƣ6O9*ဣioyd>[Z+7q^-}/) h*NT3+g84Rm4BZ| ~m.>ӹ:-"3w9XѤvX^ox8n=шfя ^H;K0;)hOUt\ XEUJufC[Fy!f"dZn#iv9y XIUJyЊ9^=Zx:QK 0:إLh`_T@^a dr(I?xNnl]W 5` <@z,Zjn,AZ1鉝׫Xo ԟ x~g[z ѽ_R&Ry2ޢ@!(LfDn%'sêrxIG%٢KY=q-9v *BSXcye,Tu!ՂȩGpdG E6׃Qq3Bz(e9't1"#0w=P/yC:( y'ELs:aFQ$F۳J> .b}xױT.Av[ęr32^28O265D 4!.`tSlJ/(St[P`:{Ӳq]̅撤f|kJXz{J8~hmrFaκ7=>Z'49nj8 w֬9K賵S+8C H #RA#Pۥpi/qS g!Ɏp_TYsA6;omXH}9d ]`۳lpaP10 r3uP17beed;Ge(0wC#ڳ]RK]ݛ:vEW j%M5G{w6v\}"4S!s/#DFRRQH虏\) b>:zߝOIi0[ݾ]شjBkekJfVht]`RJ~5HVŨK=Vo*(ϥ2`hZ{uIk:Б7ܓHUQ=Gcs-\-([o}O(k^!)Td~ܨ0Ji _{l,ys:bzO6SuvQ7F,b3O{ӻgpV[)1R5ϿEKm|*̃ x9˕Dؔ&Y8 I.*;c]R,Pʇ0H.ɷ , 柵6fUrtn!M=P]Cc3uK?5yv OsLjl[V&#p4QB"\f|69@J[s3MbZ-ӤI+Ԍ洠^-l 2#UXZ\OjNe<5i9~^&+n\^2 ip֔>%yҞ'tq[%љXqZ+-H ׁ 'B7)b%#2]}X}0Ʒ&P}(D5 pVҟkqu,ry\/fIf_ZOśݤBT@Td :~ĩ?EG%sZh6&mڑIn?tEiu3Q*,v5i؟+NO>KHw{ܱ=`st`[UĦ? PC8a5UmUYeQr\)wYJe h=>:U@"'иAz^Izum;S;βƎ,ש4;?ު\wP60 9f Nk8C 5+ayڒk{0IxC㘏7i}_'}|Ļ@_f;iY>S§,8  @݌cSJ,WT~ ;u.PDIHFe"ϭMʮՒ ebh^:[R>`K@JF2NHQE}6u 1pOmGhDv{er^x9@dIM]˛eu=a~;Lk&{(\+Ʉvu th$c?w[n!|5kEzûazX,N'>jn87=?v\&XrhNþfmUly' t37{4x,y<jx!_6 HAiP[)bvL6!&8c~J,D8W_`x;m;)M7E*AEUʤþy~O#H\vco{-mh ~0jc!SIR~HnF=\MRb }t.;9?ՃD 6 \1iݬ;Ft{+NS[O/D/--6d֏FZo#7NtCU$co1zXuB(kpC&|`#CƧCx}㮥t~]זrgTn3i{'V2JJ0cC 9H 1 sB[Obj3=@(*["%#0,P@Af? t __S I:SЏK'i&v~8P.NH!|M,ŏ=W< :r9Hz=cosp5'iC=!!cGN@, *qZY+s|{u'"\шV\׫7LCF#>kWWh!4X-;iQ#x-n4K%窋lQFH(FN.8tǂMP $q6]0\ĆZgR`S-"# t^nzHEAx$1iEԹE!( Qfa.Α]'A}1͂qKn 9a̷#n4,LwUe=!{mhY F@:UNIROߝ9b9 04}Gދ™1-t"orsɦ?|9dH,1 Xl?sڑ'rV]^iCG:<u9)rEQn;e- 4:`W;oŦH죾'C Sf6f"MMg{W7ةOK.%eS$rP|ҰOnoux~cӚ ϮE7VJ"aߕbtM ] ER%h ÉGro qWGOіS:2 :-M*z Hex4?l=nx:W)[4o4]sj\Q$s|$I;2Ǫ\SqRA~7nty NvU1O]_=ca~(_TmF#2ܾ5(]y;VDl3PT_˹~Yi[kx pkf4e5t=xbѺxvi9;MDh>ftN>q=\ioвPX ۧVI'<.~Yh9ڎ}sL3\|!.>+ͪ0> u999:[$H>1X+n}2\<5rܞL4&U*4NNqd.I7cۣr$W`5pŊoZd/먍.~]OO8]Ԫc(Qt;} = g8b.pn s U%rx-؁۫Y636¶uzqgg٦^+/TnAiLKm^0p{RNJURqt B%G"ȳuJ`mw'^P,]".(4O2{ Mpkb(%d=0! YH?$4 ^P6J(K=G kӪ | #3~, OJϛW`"!c uXWVasP0w[.r4p#s }E_ܡY7&VDԺUiB2ŘK-~JLze~܀ 5j;؍ϵi0q<t8zv8PZE]LAwr/]>/wLē/X(օOۺS%>ń8ݼ¹MLJbz:_0fj<|ÔGe~jKY]C3vfq֔H발RAk G+߂´VFEGWƇI{_|J z*΍P4 1a;$ٙ1)Q)yrV[mv\!z ?AZPNUMpTQ]Znȁa5ϭBgNXpR\vl%Ezg|jGşebrBYb[|~' > )i+Bvgup"W>u.ǖ@?#l=gGr)p̎x QlS.'_Mڿ 8JPw@H < )Ws>D膳G&(+{'9|\ѫF 󷲷A77;œ[">6`XaHܩ /.LeKyOF0=ĆG1$ph ( Ɓ!s TX%uVu8;ķ!/:=݄aJ('\e5rc}[󽏑G/v,3cc$؛(;]$9q]U~sU )9g&neوxn͜a>Ͽ} Ga"B'J\7x.e`mSK:ln b._'=}F[4S:hE>&(*H ['qV䞂l.6KբD5j0u%Cb7#ۤ9ES<bDԬP :"JOcYΎg;hO=],3-Pu`m @Z8j/D6/d^O[{/=#Q{(awݵۍ;KKϵ,gm&R8 Yqew/[oxU@aX=^|p0)\}}#.a#PY͝<|0|jtUcJe]6y]=G$4%MM%:詓vR ^6)C7a 2}%F/dm66Mݫ|$N.7\3o2IX`j]},{KASD+Yy3 }U0;n坁WZ6c_dӍkUP^7нz(ry&ަgɼxtӫ3LcPa4L[*H`ԳM>?چy_?w瘝:を֤͗8&,czX艒1x%rwc?\^8-KnVG>dbSwoҷ~J-C#J ǁd0cI}*;{&|h^:ϩMbn,x ߈H<[T#jվYikN ܿ,u͞Zn݃o׉m:~KRA$A"AZYn t 8Ä hHNAC(;K J˥r1{ɑ~&O?ez-{IN e-j:`6RʖB)˥5IUAAb.#E!Px" 'wf6׆"(a)'XZY$BAܜC &OL^/+zsawvo茿M&Vsd!I}2Kw>5ib&9d J(DZNDiz,Ǜo V)nӎᖁ=~Mxٿl;KE+̀sqNo!n$\otH8u,?!Ĉb^=^ɧxkYmvN,P=K}wx %+r$#1|A,;'h~(j]t%+")r O LWzfq|7̕p;/z`Pc\_8㺜܈B-t1>OM͒REwmCN2G™DM< J[*{}3/j !Vx6D^W3KWTl΃{! ~ط6ϝ1E]e1`d*^Hpr!k=W+ufR*dk*?0H&z$GQKU*v3Ȗ^g N~xzmܰ~4xECn"Jvh$֊H |ۓ^WyߣO63q4 粤y\.ImPvH¯oZ1̎Ǘ7~u/HKyntAٿU_BY}RzR6x[?~S3N)_ˁGaڭd(>i6­ Vk Ma"mԡ,(cr< ~OWio݁xL&2ǁ XI =>y"_ nM+9n wI'u qt:fO*hlɛ%I`GTBlעͷU-` J\t q_-"VךGn鈕ŘlO?< lMC,pk5W>K者ߎ+`G4x7|TA\+_o3_|#tZ0IbJ ][ j37v.cUpk] \̠4u(モǟn2XLc,m> {M.!DGU>|yǑKg(hsI:g3ܵ 4t _o_TgJHC[.,7)Caq~[H lt9l񀓭U+neQ\+njVFޙ2P18vn}?R/iO$n~!hQH8Ȫͳ7=yV|&dYe:?*ݱyTi; ҩ鄓/ūĶ+u&Ϳhu#o&|zS(tJuo|KXU8s5v7|,7Yz9n ,g fd=Mzq|fG /,,cT),ܬ[.KVwz]maA1"Q t)VRG / e SR |ۚrLC,X}25OhǓVk 8!"ReN^(훻(swoL:QV)~ey"{ CCchboQ6>] 02;O׮_VGFw'%mkq;:q/>r̠T i($%z7LC $8 ^H)L^e'0V3Gblh0|;U;?E%z'h"0@֥6%Μx@{w<2Wy c-A\+Oo.HĹhZ@:IPk{ѭ`xNad}/cռ;#O/b^ =dH6H).Nq1'0Ƒ6^!bQtDkz7D @»*ZHE7&@B [ɽ&o"A{/wdNa8L.nd@4'%}3m :Yo鈣C[~})maRWG+v4Y;b9O3TCOSR掩P xGuWݶ_:M*q/Ԃ&0Cke>ણ["Y׬-x`Lc8~O1 /9n%ŌWچROaCw3v5yO\srzQq9eBDl_u]-)|d\ݺ>N?G+6"Kx;qP;Z,L.wWg?l^ԒιN ."KsMHf> :85,cgo=ς)ܱwvyAb>DS΅MK|,O0ڞ6º'&v3^EI,s*W\Ki[eTb|Q s;uFNPTK2Sza߷EU$7:{K'\/޶j Wi׋7u(Us|VXSmB/AJ;JlZXO]f)6{Oμ p.*3Z$Xɣ1s\܀`,Vn7VbOZJ~XT[ΝKWݻEym~+$R-Wo}NKz Wͺ_}4&dR7eQMN4%Cp*q68;'hD=9 K4@~ ൓q<"2olCCMeNAF:]FɊ@-wN+($r^#&/([ꪵ虫Gk' e5p:[=)xqwEnks"(@Gׇ'`J؝9-KG;̸09˃ת`P/JJBSklG? Ճ=)d3OtC=GmX8ʅ`Nb#ډmywNbħL<i껼\m}džv!Á46~c z EM _F0(Q+ǥ~m kU8.lbU%*Z1@, f™yMA Orۘۼ]AJ( =fK`+zJQr1k9 W,0_[/tJmp%gIep?.$Oќ)pΝ ұֶA 'ECwȀ=•aûk{a0 m^rϲIqwn6* ">T늜SLəQ2ԡ~x%"R4?Z$"6Bu1Ar#J@ry >"|wnI >Ya=9.,Lw4M9kr=%si@t1L9nIK4Jskl'JsEVɓ;>v9L?^v, {ƒR d< ڪUH [-qQOţnUdXsEgPwMB@T< xBI\W4RTrZ<:q=0.Pd)fQhZƌǓTg 񕩒]zlZ&rR#DpO>@j&4h7ʁ9_rtm/Rr/q'۰zN5[TcK*(@ș.S'*3{%~"B1!߇ 3C;*[IRNq"7 &F?[^r= 4F>a±v>J7ZXv0\[&y"7m+\lt`fpǻ cizI{_$/e(i)(gtХ^b3+ eE%G$Z4ZDy'=.9ڜˉ D69n4 {V+A٠3{O _}&s ωEw}vf|z [ی/ǰIՖLzu0)O@oA>yqJAzkkC8i+-;?<^~ c/VZ (gS\,! :Ci鋭Vt)RſYe̝0ZrmCBHZ+t!ifv}M,-Nk'm0GvL#F@QM((XhqfCT!4dk0>` ϤߎxP+} ?_ez;bM+N4;?aF G}+ɳx.;E!uWEn0^( ҬN,/ SV:xO-=^k~],1.O『N Mh@9yI$Qz"Z }7Ș*!Ĥ^/eXWL/mxRMz\;Ѝu̲S0|lݶ]IШZWa7~I@&N1=VHXa-괲TŊ {? ɖ|w[~R'mHty~g]dO׎WWEj1 7Cqczx4(%Lu#!A2:k~.-*3X2GC /b=t2R5ez7wĮ(a]&wYHl.[|%l&ILwE8q|*ĵR>l̊lD>1zF߀ٗiv%p&> O*#<<4|[mM3=Vt:ࠈp$0B@i#aH2QT.dx).&V6#;d Q9 / 4UlXϵ|]H4e\ u,O#-J ̸gυj7;_q/(ׁ)sW|Lw"s~AT롬*TH'AnrD^{I`ξ-if M͋Dj8jWB8G%T([*_ɾa6H ~Ÿչ)@*?#^ %$͋Y}sQ7>Ǖ1DGG6x~A^Ou8IkIx oX'k4OY8bI "vWX j9~jULL2V|C|վEMG9ZXYxUދZN^uR ?Z܎MˉZ$sߗ"1swfwGFgK#Jurdj?mIqhR azXKc[eCs*e_XB|ylxo Yi5; #] хsFdavaofi3 *}>x Y@ M },x5kex@c+*Բ̈ $y642/an,Z¼dL>O9=] =ݩ!ZUz? #hڦBiSWӻ5F051N 袘s%NC*`j*Zm XXm_k68b-Bo"R=KJpW$<4oXobНA\'{WF:ISkqf)m6sPG 57xþ}$5elE%vY>NvPJ;q-5O`Yd7K8V;鑰K վ_9uEP*e` 1\[[K&G9OOkYwSlt=*}=Ǿ֧=+RW6A #U]fS5O9r\ozXy xݜP6W `b8gو߃ k==4t͍äx Qi {h?u-*D(q8<yN185D L B3/wCn7> 1 oO+zeS=gDu/b#^ qT;/:`Ff* IU2Nvf fo< UjaOi}d=ENm|Gae DX͔4}Y8,aPҦXvgpt~OSQ [پCM(߿D87=p[=!^#b /AS%.<@;{-Vn3ySJ6_ja-U&99aʁK˴π*t+DS=@3_gy:0[ %d0١Omks͆ yG+Ɂw@*Y,3[cG vH{<8c=פ> TQ#?UѮ {kF}DYvQY%+GYvcSU!Od%p=?GZ!qLiK,]X.(Q~:xFwpnw1iKa.A C,tҸÃWBT#,вJ_=g7`9hWQ\hhq.;NWc^-Ks_;x1UPa6:ǎڼaG#Wx !H ~~U&VZf7N3B]qL&11fh)ܻ_6ÍjЛIkU{6ŵ!S] -xSaY97F.zW1D#V0]@!{;˼x ˯9Zٷ=)tn9F݇y묎3F|ghJݕt==E/ &\u3Wry(^Br*klc'qMi3”U:]?t+*rYNBj%rHVd0Iڈ/b&_,uyϸOI'C2n{ #ܦj`FҊ?ˀya&) !bͨjlK z@Di :p̮uH$+}%7ԗoKE,A *)JLDr&(hF#̿2/J4_!:|:?8er:G8~piLf?iPR&w[mWir*PU!A]rch+tew@`ק5^^I'f} э]m@ۦ$.5\L۔99!duy&?Gl<4Lvk ^^8f@Zg$qoXP_kĶ?iU/=9mME_mf!S^pԞ݋q ^"ghr ;n%Kh QܸR l=]ώveB)r9*{ CC~`e z-xq+^H6׃elݴP6:NKMPϼOU%'O./N cn`UEEx UA^D&ihC$\Os$j$<&^x`z6:U"5<\,1l:HW^N(·<_6k޲PLi+*{e׭?>w;Li\9 dE"wJ8J4J .U勭˚ͣIw*:Z]2[nΠžvG ݲ vB@iL9Ls0@G*.4PkG `Iܜ/u-%Uߦ_Pa4o{1-ޝ&R~jHs7sZ~> -ǫvTOx櫼Jn68%g?nWJJ|T-֝Kq-MP(N=ȏzώ+PӶNG-IX7~GR [6َ} K&%l9WdH^4]g4ɒJV+!@j*ߞ*l=>.66qԩDLN 빭gJYiNYFNݹi̚H pPz0Y& w6S_h ÄYΊ"Iܒ;>vp>s78㺝N[ݢpGL%h Iuj*ĕ\Aո˝xr.Jf, `{mܙInmzr$U/EJې].<]HKj}CʧU?n}m~ܹ4ܦ9xL dv"ߑ+؞'lݶ#7RJ4x,]{Š*@ESwMZ׽.%KNZӖC`Nzg(_ #h:+M).ߍPH )-ppͶPwہC4[ Px&ps߾ yx[- q9蠄YMQd֬ӐD' _cC#|G/KY\W(({|zYӰn=We`v _ (!9o6T*BxO!6?5Et9ZGet[4Q 3mYaJUXckeD%CiW;~s ƨ3Di&SH.,gQ~c:K[/Db|Jʅ4gۿGutᗒ#fF]ԃO0Kq۵ 9)uTBRKܸ`O!8X^:yg*Z׍sL0CF 82ϥQ>Ԣ,pXto2Tp>>bJW3l ƾTVݛ.v]Z,.zA$UaLH '9Jp8ۆRU|6nxeVtpl ?r7w⩯R&a`ra (0C3m .]v/#n ^rKuT="P?47d }ݴCt12sj^?i# 80IbFPĽw,)Ȳ բD:,ɏ(S!]uSN.2{B"E#%f@$̙Jv⮜ıy`T# AUd?#S܆|2K#BX>~,γXUBWe~N3Q|scDp 8(‘'v;FἍi4g?5;V\FצR/u:]h T8,\2jB:J'` N~K؉ !Y)@fm<T3o,Sp`m|*IXK4Z=.p Pk\$.1b&ֹMV[cY58A'DRۻ0SŏiםtㅤsGy]ڧY-[O6@* r<[L,# 7Ml[xK|hqxz KMyYNk3hgٻ)SVdm蘵p=^?"}ȴ7;Qmk@>G I(qmwX$Db'A] 03$ڰaכM8p mVv39#_Y e |or̝ՑTlVA+)^!Q4z+46qP51E~9A]Ppss2B/WCnK"Ɖ%&Ob]3O~Q9Xk!1nK53龉|B:`钩OF}ź-ߍ#  6?|)򆪉qsOˆ3fr6M9CU$!x^\o᣿L80>(NO\6e4@/Ӄ <'";@ iFQCVxrma{tڤ;9@IT溁sG^.& LKwJ"}6iOˌqJApm({kFit"t기g:{,? ׭X%Wf8~5ʡS:hTSQ>FI%#O;@k7%KJ~8h'&H堟_9V1$(KsP}YVAp~Sr)U!72'AXmmH |Mn+ߤ'X1n)&dQ_͏*>Do8_47%gd.7=ohɣrIQ3"(I g Ѿb ᙼ%_E%ڶ;~g=K"'?|{4Fz~N An%~p`jPJJVnu7V`&(7o!.=w.fK;Jt j+>-!n%m/çM1ёr"u.v1D(,t=6'roL*R>|>>!nvu D^dJuzTIx7am]1ۛjL' VT>܏w6S5Z}Zli bHBO& 1cQ{9ˉ_Q _lS *EqS2^_@I{AѓA8g.p *t|Y](Ț΋oXr8}C]N+r,D%CygqF 7=V,t} M/{o>o'/#HEZ. MIȘmOF&y0˧hk!GMέ)G↿ EowO$)(q{".<߼ iG+Foex<.o sWz~̮'%Vݵ/8 k̄6p"?A(r*)=4X><|$AP\A 8eb3 l8ʹGf[$F*E:#(FE?MLk5PMV9^ke8L됩u tX3Λ蒇dD Y>(EQ!'K%FBY?ZdO*b "*!ʘPꯧ7hC>OHojڰϠI=c יnni"P*ܙ։~Ks=SZ)u4fB#I9 x-Y{hiedXzPkÜ)āv7э?&ӗ,n pzDbˠ liq~ujl#D<ҙ˛AsПRKo~d߃>" bqvhIʜy#$~Viul܋OjAK'.S㣂Z?7LAw ڥї 2:6 Oɯ;qTO8pK҆߮*^ |-RӯǢ ôyb?֘-SN:ߪz$r$'srhvLJU笓;bY\dBR !cPJ*@'Dɍ-4"D 쵡u0;\=}TYrԞXJqH&ޏMAu;H8 Ku \xzޟ5HVZF͂ ȃWdכi|kj,O_-XosEie4-݊| ,3öšrY,ps}~xfh—qzu?<5Dzn0*%*|R%IHcfƒd=V+ X$CJİa06uS=d F N4H#f ]i]'?EEɄo?8*2t1R:>خ-6NF"9o& %Y?Sy L RۍKc SRh@@ذbdbL*mcn/cyFx0T}ß&R'WקϿ=!rzG7n0q8g[kxoc4u%΁LlřYSps5<`XLGJ dvcK[h PMXaT"V}k|8 nnkڞxk>b^SVQAa(M$rCXcm m#}~Y (T^S~LYA?EQ|ل;ʤa\ .\@(\>*l_Ք|o^V=o p`+<"2-5 Ď1ݫ0ϚW44* "n5#LS]h'7 @b1w)hɴ}:=A˩4B5Dn;tܪi|[ѷ rD])&z % &Z._7aWa$/tSi_YZ\C!}lYg];ډwlB5tj8]!}ސ\eiZZd!#_G춐JMhYu"+Hމqعy(f:=m _>0 ig}y`?1g=mW쪃ߊuHӃRl?#PoGx2CݨiQ̼79e8<]z[R!` cl(- ,s2eVrnG|U}%sYLO_ !uRH͐zjVua'~ |p#IT({-+:􉛊"f\ TǢLOHpQ_Z9zݖg30*/1ȿņ{2&CRb}~[g|~dvjml+\OӼDs!o -NBI0}vS7טQdH?+Hf8|4EO2Hqs1B93aʓ`ֶ'*?26Ӎc1Yp>2~0\eUg\fF}O5z yE*0@>)hH,鎫y醢MzWo)d^Qk ޟMm?w6΁ZE#_NW)BTɹfbuz8kN.g#cU3Ku]NQ@bRgi}\2/*xQCI|7770ɱ >/<)O G|69% H^-4LzD'av|x0Lͩ*)G{zߦ%{yE;k6^D8`Ijr`7u8C]udƒLళV(:f^,4ZKȐy!bȎ66`kR&; i#W8v$t{]°n st!56Seban},r !ٹcEV˖פO?k;WhޭQupǰ){}]q !rQistkY< mjw2dBI%J$_q8\8;Qͽ _^|]sۜspLİ ]:,BspyZ? ֮<>"m[󎗭Zyy\ 3f]Y%%Q1B{㗾TL?*go`o{aNzLvP!ʃA\!*6#(,ږV,?$c*L3Tcw|k}bm=1DI ?NGE47ـ;c'9n?E)i v 2_s<`BۚA_l^Ĥc2?<lW"f,R+yfUѻv'-,A]2^eB'ZQW$|ho|+$;&5sr? 5oUy5@78vB:'#$HQ0iJ a< ["}oЂ4@M Nw̟^z gt㌵g|BIppiCBV-k վOs#./>xmqYm'!n!kd G_S/Bd(g?3c~fr>ܖAIn4աWqYKл}&cٻ sŽFXXTiAZP]֔*7WEGpDˈޮ8Ӱ=HaX$ sQ/[2WXܷVB ?֛xz-_{݆seh: '(_>sqzj^IS`-wݡl(- /1]ΞѮ,R76~vu{'p{olLe%RU"&}7^{Ry,?!IV\a,-ݰ%XQ)+|z<=BJe` M|>3HuD L *BXG 17U f]vr(/ˏ+$.SOF[  @ fϽ83yI& /Dg[opRtGk?'F^;Ƌgna!uD{1iv{[xߵ1|k{ǒ^\C<)l.WЃS_z`pUDv䇛+pbI?`օm 2̈́ 7wE= Hg\|7iP%u̢ʢ2ڼzI*B!-!F. l N$jpJd_*e͠ `sJ@x/όbİJ@3'Vr$ȎJ}~dΐtܗ`$Ι/ͽ5C2BfGnf7HX ˭ f8`w7|Up<%?c^VE g=ˀTVA6cr3c4f8*0AQs}r\A_OwY5r9qz-i퇤;sԒ0ڶD+:'Ij j>y6kР:qY.!r@ZF[߸  B&4ŐJcj7Fd93,e|TP_EA )Rve7~#{Q߻~( ݰ,=K~9M,UW$4Wnq~.|9/4-is_ oݽpn#.ù3j *HaPl嘼?xFd7؞c{W=ƟQ2J0iwUY]T_|md]CK/~3ˉ{C g75!CַNJUK] }"c.]o)\3;[Jt] ]i.s0  q*F>>JK!9o7sދ|U{ی3.Uma3$xjTZDbeb0!dYsɈ쓸+vF]_NƂ/X4-vh*='no`^,[=VK]T4_ȵDyp\$/yA}XNAk;BOdV#XDfх.R4)\  xo3O~G3&04倏ۑBiABޝ b_^Gq[l>Thmgw/]8w NGbk:V?˖T$xǭŇkD=f1y2z?"iS4wRmԋ!w<_ 5RX$rju>Gۅ7@??"/{ iΉf ._h0`[DG<[[F[xzԗl.˯|A".bSt_ڰKLߎ4u^kc #߫f-Ph]O$3ӫ6]g%#iKr\#o gV̏pΗpb^=j`iΖBp8e%x3CT>@43:A%};\?;%nA,A;u+| f ^|CmD0|Jގ-L":` PgΪ(ؔpҦJnѲ& l&dT,wYb.('wFO"s~W4ptmBhtdvi)Նpch5l v}[ΐ2ܣFDy  89lA10Q>US~n%7Oݜ50Sᕍ 1$CM-~Cgw6#?@gaޙ"_Vk͵yL1Rݬxb 3nż1I+D3Z]Vdu#!g[gP:HǞ87"~@6ףK+dkٰ=3kb8 UO9SNDvA%gXnv+eFA;o3ݕG,PӴSM̃X3ULRJ/ym(Vl o+!woX|SʘB2r/+ ~1 qR8OkȥMdM#8 4׿uL-zَCXE,0 x{`)L DڊȴWa>O9(l緋0O]|~"usͳ11#I"OqOxvVr[+NU@JA_Lw4#|='Ë6u9Ayh;$. thxU™E1QY IJhDHjO j饑"!B`"&@xQC#?夘Lu܌?ygqX@%"@'ӴC >Fv&~XYM~y) =?*s>?&/TDž<&eG#kx(z$>v\Jn ,98l .~KE?bPanRr[s6ȲW-BU!g2~0Ar|`}oyW"8+Ax0&xג[@;&[CϷľ|I!nыj8="A=0wB1h*:y /a(lHVժD6)"?1vZsG4J@ofVUjqШ?]隲R02uw~^=O%2 Ko]K~ѦMV:^8 <TD:)OIlf>『$*-!nTkYS_m9%,fuKG\w?d!c*x[<ݛ?0i@%uFE"HF5#l*"tS$Dݜ#7yȊu]D|aX-[e}ykNhw_] ڽ d7 GO2 +$zUZwb"zUg8ddQwhtYeHm;;9/?RȽ1.8JcRuup;2 H&jgߺ{stG3p!=S0?{,-$[g GmsS_+rOi#dev?Fje>{A6GGnۀDEÉcuČWv%ه4k<_WfWɖ4Ô0L19p$t3?p,!S%FܸCNYMķ&/C l "LyKl58"q Oxt/wT˫=ȶ\wW/Kp˿uCtpA̿o9P*My>jSZBAF#=AB ,@,DJX/@HdCRت&y#ȵ,EO'<9z#1ٌ ?6 |;xѨGgiD(_3䠋V@467=ɥ笀4w{*y SI[y{jۭNo9Bm{9ƌN <$zHZ+%yUQ3Ǜ TxmťݷiGVtgx_\Ν'Jwj6k"9bXTU;Nhd ḛ|wMbfٮ814[$v-xսr?^͸7Bw=sТO ~O(FY{yeT^Ow6lW>.&(=ᡸ칏EaYMsRD$VD dnoqB'0?7:H֐hH˃#ىJ5?٦O~,xG'y ʁc8wABJ~1֢KL@jwComy- wln c=ࢱ ڷ^*n^ @VU <,ߏGbʨk؂ Xm G>8 *DDrC_((&>4s>@=el} ,c;wloվʋ8`"DcBMbZNDm%5}vna|nݏieRyVm w?;x/]Av~e༡]tjGRF"`VigũsӳWLԨ49|Cfypj,Vp~8^Z'!.\odf_"Jnv͸ҿ#~};.QQpox~׻UWu9>#&xӞbXJ Ppiʙ::vKf;bf܈1vԈS/DlPBZuR8?GFfcl(9-E"'YSh$0>}R?% rW]l@,ֶ=d%Es[ap>TO υY.nkˊ3Mȁo ;ǐLFxbk8nszQ6Py9Zc`Wr-~5}$>٧C=R_ѐ ;r׻_*Xusس`Wf}8ګz"q7 .|d]W2](7N׸YR=ˆ[lBp]e;95>6[*]<*ǤPa>>~e#:ԺU'FX}s}N]އSCG\}KP^-cq,1nw% LVs;ىe;n嫺V+jMipƘ,>y[/y,]@ %_',4eq1*0XO&y,U)ܑ<d}&\㷝᳇XK)ᵝJ#D n xe}1sEmNc^SUqdeT>OܫŇS߾.L眲q7?'LApl1 N,O\l)4;^a( T**?^\NZSoh(^';լfj G~S91&3J:>fE"0;diU'jTإm"6H0!vI<$a ʕC`AKs1V('F!#(RDٖT 01V'Q >t u5g?t]*C۝M`wW珻KӀ88q` xY/$G3 qjugcm8Nr*8~:7ZBVXȖUJgAݯ , BT5OXM_a5mz T*͹xo">Pk<欃5Ѕ3ktȿsM>e1F/o=ZcխhYTaF[O|s V kH+=Ǻ<{17.:-|;U|-63(T䗪kpԢV#,wҷ3:xMۉ=.Kıߔ[DO:Ɖ4Ww AYW,k !JuEb8L)ʒNZ%a#q,穚 ӽ7fqDe7fRamotKa'/"&o>JWRndX|Ȁ**-wl޿^Hn۽>䳉G8O/ei&Nf4c_G]zIIrnR'OG=/.r䝠Ë[?Wo׼ϔ1;tk9=/9^ i}_I΂l黵%`ds΄玵$ݩE' dwN_@$k0o\ӭ󵇦{Z{1rȄDIt;s{&(rjG@3m#1m9lUٷ8~2KwztC2Cdں;0 ޅ;.>QQD<,˜X8[ۻ\ׂ^B19ΐ]PT)"{APXRP"PTDjACNaQFDjZ(":Ў±'L(")XOEM, .s>jW{ܨ2^*gT}ﵿXWbUdEBwop4s9DS/jkݔN 9$7 5m'yC~ȺFc:D'ck xE7;ɿ4p"btz>Y7GH&zpE&Ff_~P(82q5(k+!"T4[HI>~V %[)`=NVXT??[B F\ŸS\'N觵uҩM~ơ~;wtZg&̞ ǀ~I ns$%BY[lHÇƭGf_w0fzo>,ĕĸJ<DŽDݺeq3c] fiu=ソk%l ؂]ly>|Ax8OJ+ \9z>7IMj^SBع!L: 1^?߁_sN@ff?5,#H7>I4Ӓ;&~gyVUn}!IIo&M>DGę\"lq4 F CQ]l:羸Yx13lP"kiс2s=9ڨw:Xݲ!eYGY)'0RRņs:u&e U/?·0Ց] "~4MzɒgG͕ssby q˳d>[dwɒgK%pc& 7r^)8j?Nij愙%}*Vqdzbޒv>KLT{b׭6h #,s8 ]By҃J3.\XIE>~n=1^ΪFġq EJp2U\9R7 * *B4'߄}󯾕=6Tp{A=h0SO~OC^ooԎ=\2=9(2g)Ub|/?6q\P)tvF0vFTgžjLjlv-/%U>L$|ܪz2Ŀ~Ɗ idX>)O,P\a iCxZmTiU S)ES 9Y_!ڸZyitBrϻIg_^.SEk,K0RXWtx>i,FW~kQWNIpH/phDJ_Βy!øқ+W$8QtۃVAd>3?4CxGr,b\?d%Qq:)PX` O v5$ݹ 7)i&v\gnl4e| Gyjy' y/ R#qj00Z9-M܉zk2l0|3p'n69#ߘkҥ]gD|wz:kf*`ǛLeMiϯ^5IIUq8{tG)bvJϨv3d֛0cCd+QG.kUB:bCRg |sS11qWS>u@&{)9~,EϏw[ʗ2]>'|Kk#`5+r%X`RǏ|g)snaܽ_3}G}8-ݍ#@"[?w|5Ŷ( *Qfz_.a4Crox0dž .T.oǟ;b?Q<wC|S54Y27 [/!QM3ǼG@|uѓSAQ< o .c1zbj$sr09n-LS&J-5V+@Md<>ϒ+XݻEXCyCdO vY \T1QIjݮwgM{M9sGR-[6Zcte~#=Yb5 7o^KwY[w\Ȟ1dN?yKfyHg7 gӵ/<_(oegDGruTxn/QЧ_'?S0.QlkRElwP_e`Ɇvx]t˻}B3i2!=1E:>2 {GhtAgt/H_x[+~|}oi=-縵R?q<ޙ8hΪe(g Y (sϒ:li*|>[MP>H<^J6?ENve镜m"HA֯|/ x6mbCasշ8 Љ3}+{hr ?^i a,©,+Z=_vg }-yKlH Bboo4^+wH9sZ)L6V kKT(=Qm0l`ٞ+4e^,)ϡrm+%.ضNG42Rca_v}v="rC쟚fxNx wZ ]hoz1nLL{:I.  o'LZe_|>~8p,ug4Si?MCsl_7`$陴Pi^cAˋۘ ݵ_@֟BTcG\@FusUĈ6,άoj=7<0zb9ǏJK/[eQOwE*!SnSL6;{V I#zvNZ`p/#:IܭABť[gѿ(խMZtP+ EdkeR]%|^qJ >鼋~yMu:!kyvRm袣lxmB=H:-X)-5h('Х )"YOEq"=ʕ`0sP!4f0EQBD+ܨM %j91rLY bzaY"9}4C^k~Sk\ȟ;-oW0!@iv<*'h2M//ܵ卾,Xp(.]դqI w`}HZvs O #g#{;ΡBLo_P%(2c_yBt4Ha, ![yU||9>ݞhG;9}E:+ —6<]T 'Ղs3]ࣴig=H=VBN#𐻪˓Acv:#3w2mс80<rhے~yJNdG4Q^2&ɌW })ød{;5Ci݈  ҕl[|&۴̂`4ҙ?˄&8)AonMu-irS t=<7WfS_(66?-Wr1]Q_/FQѴK?f"i%MOach0D 0^M9M6|Zl P(f;ً |,&d~;>NKghЗw9T=;o8㻲V<I;V:rϿ.g8ˬpt<Fa+D}勽8`QP ڦ>(uYzW45+]Ca?'/*v5Q:YQM`+~Ͼz#9lt`n^,]dREt\p=2V!+9c,W/ %&wWlH,))>fq'v_V(Qyav2:O3i0Hz~Vnч1[Z)0{gm}ϧUsSǤw1o|֢G`󠠉Âwz_Kih%Ma/Is9.[ qu/8ܾqlFaCP\Nd9X\1[j0tBF`A}D~R[ pt[H ȃhzinK ׷N9 YRbѝÁh OvjTlT@G+R`@ ƙfdЎs!KI*@&SO^HGc3<ΫA$j@8<~-$~lZfeNߙ(vg2LJu ht_ι>s*cy=gK?0NW͗H}p7+O6{~7t 'OE2 eB U-dil]pz{lA!Xm̖^v@Q n;UZ@VF"^ˢ\rUxw{Y{;JYFvz*n}ĉ[V}.s5UenoH<^)t >~l7 }݁0wwcEbʝ?fI6;B~ؒ|ǟ'lһM,1 @P߷2kp߼M#ymI(s'kbrܦ8|UhYKP[Df:ln^AR|pr5㏜w%-()Q!h<{R;x?/e~^E7Pkܵv\ 9K`֐S19Ny`G'zHZ("LAZYXSb(I `/d+ z<d|2SV/^ϵD" ^g ?~~5 9Pi Qqbi6=,k>%j%qhbb-˾(#.k._5mlc|(N+^*8tDyS $-RdڈA;˿ hS/t]Wq:$䙧{ ~Q٧Zor{Hn|5=R~b]}Wߧ2.V7sbuZgq%Yd7>Dý}$`B& Z&z^;b^d=dC0U'2M8bcWJ+^oA>&TN!p\[թ'I'y O\-\ߗ O==Bҗ?įCcɏ6N(DG { 2DrdU81P9Lvcͻ-G hJh} 7%@:63)DR)J:[$"0$<Tf8rbe$.&%n2%J -{rۙ1@>A j% >kT}e~l{Phkzhk~%>󚯻ErkzIVڻ7z<[-IUYKl l_ߥI Õ$vyO#O@TNܾ_ t-`'}1Su97_f Y{F;FHK`U_}Zc~ݎu@ܛnm,k3nJmp[OG*g"?ˠ% $k^ ucbx9TCvZ_6:a6l.zgԮ00ZtX@P]Ny]Fhi"_q3Mr Nt]/xtcC#4Tfxx+PO%nCi~-Dr TEC}nms}{W1z̢ǨcF)˓^ \RRP<3ƈ p's :4(~MʷO 1LnԏFbO<t}}y8 R%{Y:=~lG^}'ڎ|]?;@szh"ͨ}oGκyʇU0{ l\e_{?LJ̚<㻣W7}WEjz{W˟p/!YFR5?g&4]<+j_@ASaӳì(aNtthFZNpy8*պK]&#?uO<ňzbukPH MCˌr/Hq?>YTzwϱ[DN9 -zx{%߷em1aO_uo^M)~/~+þwJ7cmc`q]}g:oۻiOXY_w ٘3tQ/sɼ|tIZe}(pe:IǯnS[.z udLJS7CtأT@мٺosO;z- y%36nN?=z,)sĝE6 Lw..Y ޾_ 8k=A֗?]?O0rlѾ{[[E=ZBc8iCbY,8|'u:XX˷'Oov3DE:T4iLi2:Ʋ5j8SDM<Y0ߋ?g>tMͫ+H0t;x)?/}뾵 ݮUk Ik].0;Vo*{jZߓ )eYp $hs:ESŠc^Br\{ OEXP?{Yzek=-{nG\ \ &L\u72:L;ؿ 㧇Xaw v--||n jF}?h7mb.\=$TwꟖ %n'wXs' L]>gm彎J^\7_lӦu#fJ?ncxpᗖA5K8jK2\@r bMH`4KCcɤ^G 6 ?("(xn|7Gkͼ\ڸVs l<n&UVXmr\hUz\)&b)DY!7P$o kPfIDل(bsVC [ލ7v~9iϣ 7ҝ' vp/,I3g=Kpv菊~ॄ7sƋ&P܄1ӋyS Mnj7wO?yZ-P?,M C}N:`nqx;vNS}OGg[-h^2tw.G$qe{X]Ͳ~wH?\)U*9}Mj]HQ9+}ݻ'{ne_}+ɽM!=ݭ ΰW~1nSjatzs[+Oi^6Ooٽ%?yգepIhB-HȐح%SjYn-y9^I~}qчĄAʁSn\"Jo 56pt5[¸wt"Jqgs^R!_>:ǂv~T}_uÅ֢>= ,ctS5{osy,,}^N{Ώd}S_ {\s\3f\;2V<7 nf_?ݬVbch=^ILOA/pe;ZNN CCwV C lF%11T!@Ѕs`X;}br'l [_|v[wPha"n;~.)W~귡r6Qd3;ίf&uvx=W}db G=LȖ}$XaQsfHYFYiм.tT/EKWt{1 .n#|Gv/?kuM˞KHz)fk *fU }S{ ZYZ@ Q/4FeĮ[s@f{GD3U,٠̙;&(l|m{d^orJ62sd?QclIJ2|͹JaNO"a8n$^d)"He:Si d13"Bj,Ȉ#@zRZ_<Г0gNetԀ㒚lߊp'Vgp>۽<]lj(7tC_Aj7J)g-aA߂1=i2`cn{l=;3e1 oQ_4~d^vBE5~Urwse{ \ɦP.yWq?tv8V~?3XA5PɖCSdH/_&혌ϫ>FtVnsUs@mF_-wy*i/t9=ә75Z_lg^*ut+])EZa{(iP[\ JVA^?LܙF~xC}]r0ߒQ %KHKTMi LO!mhichcZJ7 &HXdF^Ҕȑ8 'S%(6 T̔=@ERd[k*Jf-$itj$t:[(HXN)6GggZ҆uitxV C7LyvM)#}rG.qI%~`L΁Q|Ç]$-40s^6Fau+~z>&l"0[u@~3zY,'Ƣ㷐[E8ulԪT 2h6TNxBBs֩5wBwP+2&*)"7F"'9 D>W!]թ. Jp0ȰENU c.0QUxt*z7Dinyez'#{FHJ㓛|rD Ӭ 3~v%Gw lX&{J/`~etҗ&^PlCrꎚvcb ȋF(Շ5*715cqeƁ|> h?rS=ޫp.NdWNpU=O/k co+N)yvϠݛZ,ATjU&ɜ?o997՜֛l_m:.t~>^ ndwFIs˖;Nʐ1:rkntEnV>6?Z4+5)BX& ͔X#\W OJS-m1`[XC[X暨!.jo쫬#eBgD; IE{81\!hh3ڽ3&"E@cx]'_'לu9S! .#}0+c)t&ꋀ4 Cv&}0i5ШYoWbo%Cڪ}=m~}jJxPrwkai>jovrހs*zMK ũhzTBF) R%Wf4Z-+!Uf|n1KOfbWOzPxRp*M˥E ƶTÓX|(e?s6̴k,Jr$3x2:;T$00ߥV*+iH&I~8Gq.WJ 4x vHΞ dWF*(,Vԥ0 ah B҃!5)GW%%J4Af$cBrQMRT^ɹkU2 TX͌fy4RIxڸ=} Rm$=+Ï k@;v,($uzixc/큗F^T95_1AJ`. 3*~!FWxUSGKpcؒ# 5U䊱K_+baiP "T4aڻ&['z 1 Kƅ~ cye~tl4;~`6*Q]QeP+?n^qznN:?*c_[\+>OLbWOp zn}q]ueR"׻ˡꃙ_/ٻ<؞R1/2ncn[_q 3иP\5<d* pŕ阽ZpnV[h-;x q~f|,љ7YcX]c/φq.O{͆|cDžō6oPu_|q]+mB65Ĩ~xq j0]#Wu'ǗC7Ÿ1vٰ>3q7.F)js`Giג(PHBe.U AOL'v^_kfz w~N8N2iG܈/5%MxBBr{<ۮn[/ N>!?DL&Sq>r^κ_d!K y:&݂(v5>c^7koIӴsgY 7_Ln5#~iG"pQ{Q!ԇُwz;=Z kZ+U@ۤ5+Ր +C%Ǹ|C#Xk%KC 9"?XR iڔ*d (ժRv;qDYyNpHN=ʻD< CrCqQP 0 Ƭ2"N'PJ5"L ,cZQ ~;8 ( t  "e0VI0)j9HFh G@k3B )d$uFFxL'7)-4& ,xCZZȀpx>]驏!Mw5_29 |ӏ/tZV<uN;G1ŅV)j)զ{I˭:Kԗ#5tƉi%6ߛV"YA|8D&bLfiC+LԪ=Z L͸F«tlPl#beQe@dȓ%XXj8&^1+ۅ0 3^֯g87%lDL致Ckf(C1D*PRhj'TMGIAgȰ*L"FllUIULhΩ8 %+f_B>/Vyc U ӣE[llY+HF,a J9\EWiij{ᢀy蒢NN!qβe2IK[ЌmD332!&^ti+;lREQ`gOFC!YDZxTm4M D{JYh$ER}>=,^yXd^S󌜧/wx8yK UH6>sWjjd,EoY%Ȯtv&*xN*q)͜,gFJf_ Fz btFÒ{:FOdā> ٪VTY)ʴo]>54^Hl}g ކD`\{-Z.]Mm{ ÃMRD}0V'jeAU`@@dYCfORAFMz)چ+iN*xI@Ԯ:G=heaD<[ROҭ q9Й {H:L(t8\Zn@+)V ۉR^9љH"[gLČQbjzn2iDʘHt9IB5'ZHn+TM+g~NޭlOHk y2{)aGhc)w*9EM|DƱK$IFʭZp ’ GCC"W r,5CX\L:49ړn^:9TlX(P6k!4(e@JAVaSo8qg2HAw߽ӱaGT֯]ɿqz<߳QƢU3eA]E u[mb[*@Z#ܒ!l(4%pVeOhE~WC2TJ(vYyv%]AsiʟR *5Bꭞ8l+XU͔"ךͅ%P""MNLsZ p/=Z7s+1Gm^8HQzU&׵gR'~mr)Ûw%k0- ,RPav,)W<~IUa( S.^UP&*# -5 K@dn6!UZ%=@mJ\,w= >|\t1<$-[|)ys[u{~F:i{.#'qa.vݧ24ME:ZGHQC/vwWAZA[H=m$WdbR^QbǡF ,h`1b.Ș,4K$p713rC{&U(DuYQ."xoJWpՄ'k P+T 5z0m/`NBl]V2|<9YmI22>sQىF[si|91b ckthu)'Z1 QgyG髺EiVlV̤03nqGN)-UCuPsIX0@DWsԋ=)+mUpp`7i)aÍg>zn#!V] mϧK[e `7mnX4ieD˴6*$()U=6m1U,PZ;JeQ*EiRhAͅVDU l@nD̋=0\+/zɢL6lcbÝ+lA6WݬE،5dJU :c5+N= :&JIGTEAL%Ktovݒ F ;oݭ[׷c К ұt2`H^""]c<,&0;^%In ,'aBQEk* $nj+W9HLs#A1cRMv4ń&S*T5s$= Qpa^EҦEkRC *@˱,$?(&r67qVRV/F6;m' ĊRBG$a2(]츿D@MJh8gdT[;5)rJ@rskxRKMKo0ځ0R45ACC si r" :6݆, ǗaJ]k5d& Hl6RiH)lŒʪǓm['l' ejHqTD<'0PsfҝE/vPu+2)^˷7drlOɶ*N5؀ .Au_i左dǍ.@ c-\b qJt @f;6uQ\4ۡ\dQpX!y͐ :LX _X鄺Yil5ڐofB뤊N3)GSky/aSTM>+KPǠek"GDqa& Byi< SjtepLl#dü."BelQn6*Oyc!;Њ-ñOvuy+cq+!GPhQƂȐ+\cGU5+.TrKD=,\摢)F=8# \54cĒ HЪbG̫ Sװm%_IH貒<1=΢'XdvrfZ5M)Gf(h2)X= bKr310gxR=jEH`"6lm@f#6|$=žH4kM:hL㔛w.$ő !Qi![5DɅN M.dMTδ܅QX< Z!_nm_גDDBs )-DI!; :e֢_86Njik4Zr \ ^42hhWթg3j&>DjG eHV2q&k!vTġ c3\"4X{jd)̛ HaL4Ǐܠ*{939PMz9-Jp3$] K=@<ʾ4EJrAtn@";~)Z!v%fz$L%ދrMD8RʒL򲵱>YL*4(˷r$cGu8yRc7 8)9T0ȉAAi,Q*9eL?~ kw&uBq - -$dƞ ^i$h")K]1:Th])*Ue&N|KFU $Q3}jrdpұjwNe85&yՕ@dJU[4և옽q b9t-f )N%8qR_GWMbPmPKPo*6c>w % *%pTk@Ban I >nV3P"1V_T>,כkUgYO i&ia gW\Dq\\e=4jMNl(/zHl~d4=|=l"*S{ӲLKBP2gK @d\J X<5jTc҄RayqX iȌJc\!J ciқ9hp;Z4R?PlKeRg*Z 5S['x=5Ê1uTdv6J+: 68ZYR8Y-%AN|uGTkIiлYgRԶd)pYm$uFNޓ@̓!+LJA@][ub\y'fwie>k0*j/^,S&)7콌w骈%5iĿQ ʢ|#p @)ɿ6JSoNR. !<ӵyNEy|Im,s+Ѭ2s6 l!i yJ.91DDd*;4PR32Er; qbp:`:6X?$y=:AOo/K\d2B?0 C^Dlg\y&"4Ocƛ?CM[{^qe/ FI‰Q 94rfI?fpr`6񬕉Hs^pYQ#FG\bx>&m! :Wo)jґ/%^2UOa)/lG""p*,tv$'; 婜QEdۍIEodUa1S DV21d QsadEf <[HQs"0eEa$?B6F0#bs& F*GlFv9c<*eBp2Si\8 hP筻J^!t+ tF+c^O/DAJRRlkit E9Rn&* (gh4 ASx;"u',HLL.O/{CReaNgP5WRB&nDL3V&`Ŭlh5Uk*6nHdznZhEfߕBkWk\'#<a>jFbk4j!Vak$FZkHx[F|d(9p@oֳ}K-"ЌqYKDDHyxΣ5UЊb[I7"<د#ap܎#P_Aj Z_X_grJ{d4=jIbfe_4sj;GG[ 7#%ۦGSE4WHUeaTRׁf"R[ %5͹ 44 AxY/Ag:6yN[ hF]Gaq*NwD\Jv*1jʔ^T |8W1yg9[>M:sΧ-Vu8&:3ZUA y}Zٺ%ck0( '1C&It{@M'2e͹wKpf7۱;Mცv˨A+2{)缦3|l1d%hbׅՙ݂^%vǏǖ֝mYP&XI#?ӫ-vy^l\n.\2:5(5a󍼾@d*?&Ol?X[{G4.J~c!LGFQ,.lbGZ+{8LيףgPѨVe'To%t:yԭDI\HmTቭ6EOsT#jj.D(zZt\w|^_WF;\×ט;>sSoxďsnV"{sdGL6};tTgqs8|9M]-9jMjׄ^)6FJPJ6q58eJ~g?GDRnhߎJEtpOWi{mb,oԿepy t׫f;a>V;? 3<\ `iƉ =<2–8oc!zV&l@_7';I!F J&Sk.1{С4>jfm .[> ki4y)C3_bzf.7h>wSLmݙ $]((\9L*ՕeJŦk@[jP&?dkd#fau'\ewlFt'1u7##xj+)`AXmۏfnWUE*FNˋ-X;iA!=j+t:YAkw'Qrsjiq{ņ}:-aѼ.f/ake?n;kEaDv͉ :FN6u#5f1[z>^}v&Ll8uw.a`O)|o2׼[=u!-puU*;UЈ L\ksA訂jL{)0)hyр5SˆiMa5C:|n%tSI iPӃ19Yp/}S,6*_>_dsv.J1طӑOuwqrҾ]\ĥKx";^_mp#mgN[WWm 'DfR1nWU5T@ߜZ2!RN.W樑Tii%H拉x|>zcbՌ, 0Rd 9nmq )IlŒQDӄY@{tF8;Sk["q$'sk\NL ַ;1y}} Ice1͛/'9( 1O[*p!uOb\b lїd;Qs>UM"Wp`$Փɻ3}ĝT^2v,2-oE 8E8!gZ=^w[F:$m 8QԾ76 $̌$ܣqMyb.NQaN:FWvӉl̃7E` PY<.1Tump\ /rcIշj/ذms=R9Ht -s[u8¼"P[m]bjAR?9vh{[1`CbLV'\Mħ#k)vsBT,:8d:mzG6^Jmoa,@u:ϪpSCmm-m%N@#j5g4\3'wV0{^=wqLi zE]$ku]<k8` #/߭;: I'vAۚ9)MU/o0\X)p̢[d~]{4_I~H?zy 66 -紛yu)}-Rf 9 <ݾj9'Wz}YZe5d-L˛a5:ꀥEp\ D *%@ ^^e/z_jjXy6U>6EǕa+p-Δs 7Nכ &Jizj^.z n=*_wQ M% LT%4UՇp$+Uw@~Բiul8N> Md/BIĥcA(D)M…W˙LVCb*s_ĥ5 [ʣ+Ӹ&t4z0mq3vĜ.M ?jUH(@p:Od^,mʙq ԣD}ƓŮ圬nѻs2yqZqT~JeHc13Z}J!& i+SiJ9D "0ptTnO2oGUpX;pql^4u&XJUiѿ1y!9*;m23rf/ʠWTԤ8ڋp_oHʗws4s8{=CS,ː cwyTP?AނO t]N;U(3LU\Ẽ &D:hszΈɊ,~:N"Z\PdpN1|u,E 7[0 hw"a7}ϨSij?٣O{}c;ݰf${7D{hX䫻į |* ~E&mdz/3[, uh#aAMXcq[Cw,r~-W/FWna(kJҡi~eCo~ݘD[m']GsŃ^g!l}hzHV!Cԛn{-sBSr =鋱A4-GŅSj֬3">ֻ[v L5_ܓ5bv Qp!;Bm͎dcew@7<Z VDS0ŔOр`~ yOpϟd%mńk}^JmcKpERlmʠ{7$!WSyJ㒣@G荺;y%8wVSX)(6o홗f=$݊6`x| .#Lޖ6i 0nDp(3sZS4 p^a8=L!㦀r+7:ʀEwM!G3Q A%-/YpraJN/;Mglj?iЕrWQ龱 M18>w&TQr)1qs\  eߓj9xQIj*p52iE:'ga!~y'UVJA9 =5bȢaՔOYԎ\q}Y7YˉzcU%PQyOj_wnF . <=sk B7[`s4bmFA{=Vې۲CuȚ؛\;pϝwr5[>PW%PNۿ*8nF[VN:1rӨh&"JpüYE-+gw^ulsBkv9N&]?}fU̟[Q_goFqoyD3C'pѡ?j2>J5֜x9,a@\rf@~T4maO#=)U[?RXOυw*Y2d;Nމ@3HxJY;|%~bO:{cdO`hW?qdx5ODIVSlTsޟpj1NR Q?ܞ2 xz)[1rz_kv|~wyNJz LqL7q7OE'B}zN.\\AZ*]ۦa'遟"krp/]&tۚmtsJ}ܾvb,coZNˌVzwpkDbvUոyOf^۞3+qlCO/re\~PΗi#ړ >Ի99 yOu]^d5f'uj˨+b/+ݽ೿YJe&A͇3ObׁV>g{ @y78kڠ-t3jOʃ+=2W~N{䘄XpBǕP,rd&NM ,݊$ń|OJP]MuP_iS)+E7?EJ +`|=pN>|\-qMLD95"ew`rdY? ׷bG '5oߓ#y{Lƣ6x;l\?Ɉ1.X.Xy01ᝋq:J;t8&gi=䲆Z[#ʒXYj9} ~ʼ%!(BNnel^+cec}=oc2xLCbUyg o?"oTZI~~5M>GW'v1wn,@:!~8P6{DdDRBoȬXW%14C!/^pz}x)> 8= 7+-ĩ+4uͶΆ^V9{^a2I]ܞG'u)gq-~Y.>#-Y}_"zv^oB"[[{S'(3dc{.~崑cM4Պn_͛^~gnTǎ>o."#:O0~;t3aM|όk;z}R8+xc]csuc}Cuz;dfJ\m.Igj.=F73 vEMRwB+ɋ_lO+O'phH =2+br>' P<~O𹊅+O_7xʳ:y}|ߋ˅ڊNt6XzCJ>e^SzǷvh'G-q6S/2.F4pqj67gµƿ\D_>EBWE&l0rr*ynZU:ITZ{F%D?2`>i O+nN^nf䓋i'gǜkt0t`eu8{n5p-NNJ& _?~_I{NOYc=8m7~c lǜ ؐ7PZ8QiJfiD-?UaYe p{}8 ̣5?ޱf=Q$F<^={}={i*~YN{+dܜ-aK\w2pV/bOݙi~(~}_7"۷ M+1lMq4S+$yqec0NӁ]xɖUeg6O{_.H[m^osNx]V!t=7.VSy#xK[&pR"Tao~_yu7WSk-~A)I̍b&+GsІ;S##ر1?0F[ٙVz}VTf7#1HY?}}O!+m? ' ^+D S8OF=~'j0Y}lwmWoq7HA˫ƱkNrazecxoMI=eAE߭ue?#Zݪ~AO?k5o׹Ň݁v '}jʻ6߱7jkrǶH=Nhu[Q>*cz.gmW0so;/hø|Os8r+v2#_;‘~gWo7 >W"O'b>7m}cO9Yy~/qx>/el8:*-Z=)?'g{bi<{/GK~y}x/rêW:{k57߾0I|߅w~>2|kWAw~gM^E;;7Ial6r?zG$ld5~K[XU6aAW7?ͮ}N!;( eywZ=wn <.xFE)hO6%I|޻g=_w~;K~^п*a;9_ǥJi~Nz0S~| 7/dxgENLdP~':_n'q6Gu~Urbcl?wr|=׉}|=_mp߰L┿Ze-fEz o]ד?G2 Nޠ,73~53c~̑ o+Ԗm޺?+c~4h'[+>N ^ s ՅeDr"+;r>G{a=W>S}1g&oH|^Q J:=u&/9=~ݡ,9Ky>pG)=ǂBU|oJ\{sۺ x< ~Kޞ_6C?O/7qf??}\Oy>/}<>w͹/Ueܼ;K9;_#f;/G4߹"{nzW}qI{w3~.uM-9H/R_Tzp%ݕ.Qqx} <}? =>;lz>o_'3 -?=/7ȉ=|n n|ϹW`%^9+VdZo/sg@<ѥ]VΟGw?gT@``nM|b};&> ] ~߷>~_Wk;̒7^֭]O~?|i~A귊=oO{\OgЋvV_%[_+ K:*?'p>ЙW}7}dҿFvRrf/>g$?|LN\v6;߿7~7_X;<;>/_~F_~j󹞪^gzDܼB{>]O~ާy<"Bɿoc'?Vt'aLƏG>}·2ɉc97nQg+1ʰW+s@ h000 0;mou]皈+[ tadfǥ2yݮ%n#'W'G{;XYh}喃A aHx<L^~?kmPLz3Ӱ3y߳ ~uorzHWLS?ݟ|Hz_3՞w?Oߎ'}M S}fKR3?Q@ykyiʙˁH:MA;7rgƩNmt>'~>@IAi m1X?K?"[}02@Z~OqXJO$=s_:05V'[]%-OF`#mѽy5οbgAwKG'ochbn{k&gu|Ma|y_ay\nVF$rT:v}q(?sa\&<#t;>#0o{oW -!=@7\_=_oo(/||o<?`+;~,?W~O?h.Ga?̣X"|/͸_c=O'}B''x 00;>#Z׍VoY~@ϸ#Sgx=>mw.ǓvU_g}n~.sul 0 c~0c7]/. *3>=v>?〢(|}?9O_*({]}.*{Y߇9-}EP#'ot'?>@@}Fߪ|_ip 0z .|oOEAWiP6zo1ʪ?nT'>=~j`C' (yD>7({omPGC|nDEEP؀AT |?~DP@ QgAoDUmTg"* "lf  ~PPtQYDD""^v"Ȫ$(mTy FDD$$ $ED  YDd$T dET$C@؟z{II$FDEd$I@$T$U$BDA$FARDTd;_CJh H!$2H $!"H" )"!"$ȢȠI")"H "2 2$HH(H RJl51ko/ $EM䄀" * " H H*Ȓ H+ "!( " H# "HH `t! $  HEYdP dPY$AFDP BE]W*O,"^"!"ȂH H(2,"22! 2 H(H " #  +0`ysoQ@RAFDUVE IT䈀H"&Ħ}OA\DDBAD $DYTYE$UI }E$VE$@0UHH2 *9s:TLA$AY@DDI4vsÅ%+ HH! H%)880pӿQ0I$D dPA@\t(UU$ITP"(@vlDRPUl*YrZqA$E)v4Zs%"H»`1mEP)T %h^& \P/QM44OKBH#M9:c"+*dsg0 i̫QDU _Su@.]K` FAtA4GGI<DTBolʪP2LT%)MJӟJP @S{X HYlM9wT nkH R04"P. kAQZU)pw`u ( @Q\.7P.n\?G7&À1BB AGm9hh/ CNT((#JUNaD 1NzAJ)k%E ttyw B{@H%+AA}Nuѻjm@66i V6@P2eLǃ"ӋWA4txwO=q rD0c8s]P[Ksx8 8R4Px9Qr9\E R*  l[-el(Yo/sJP)k;^E7{>"*MN6E6l3y") )K߳u.q/! *Ue1b]]56Wj q9>@h){T6MeK *  "n"[64Ӈ sgZjk@W?whGfp o38RJ%U.Zn߫JHjQÛ_0pyl4E6 %nUw(nwqN׃ !޾UhRp岋e6׆=\/rC#al-Ǐ?RR%QtK=7nB(Vl;'wǥV)(lf9{x0!Ethw*YBΡ}ח+%q%.%Q4dS&sAi}4jꩤgu `i*.7~w 9\ǚ|"5%5 R笠Μi1r9C!w)AKp2x,snU7+uLnPw*nvv)./_oXTb81sr'"dEpGb(hH@Z" RB4Q:Ah/qvyit8]tFn_JߑC wCEb,[j)mmWWb Rkx0jLfo4&M\ϋcpݝ=7S㪰"Dp7Fp֍M:(PJhY6sx,YB71AY&SYOjMxE)(H R@ @H=P(P@U&5P(@ (PJ(EP@P@@(JP( ((P(PLF44Ɉ L5<$4 !CF CDhL`U 2h M4(h172=Chhh ? $#Jih@@j$DD@ѠOTR OQ=M24d2h14dhh 4 &CC`EI dК@ИQңG, ??=7}FWc2u $k[!0K}*jFYW0C/JMH_xt.4UyQc„~J"dG}&j DrH1|kczk/rٕ'Rnw%սmvjƊb$1$ JMw"6p+2&NNH U>Rb+ʢa#+zDNꇪh)(F™j!hfrDp&{!B6 |ǠDEwZ{86Wh==c Ic#ilMIA7YpQ]U8,da]ACL=8!2޽|Ǜ.HE4-5I3aOnj3 tK&dibw0 .#M W?Uq.'m+-|}R=]U7! h' `7x}D]Gs4fWv SP~ۺ~ yϪ~a rCzHz 3N[>̯m%\N1 )(IbDP4ډɐ'o3sj˻g}26hkAbɃMAI$}%+np?8:t@ +eY $61UN0ȃ/7sW$=7-6-H=P(j,Ti j9-a,8[%-0ʄBLzO\$u n`"L2&njzXIOY],nqF8."fӅGbʋA̶ܶA H*&K#Ĉg t"QN3 Ԩe}(ԙ GDC0 BuljWxf"D] Ӓ)Rȵ*I!#^AXKN _DH2FyfIWV.j 9Z|䩌1|0z׍l#6bD H"dr}}iXd0D]><\SXȉu27AVW-2ƑIɝlfј] ":I[ "ir& 5N3_niԓ- ^;f\z( (3jW@˜- cT0t' .B4K(B!4PߎPhX`Zh|9zANK |!8mNC"&^j}ɩ:S[N/pagɆnK'ZזM*'}\R8^iqM zXpD9B=dSF:3)dvCI=M(3غO:`:8.3[PX GoI Td Z#65d)f5nU}B;u> VD ӂa}V"z"T@j K)Lk\nzI 7R,Kxa̓!/߽>񰭂 d}gD / mxmHƾlhI5~l!qi5"\99$ hN$$L8qJLDi&3>{ώi{0ć~ σ]xF쑆CK--H #)c2M6&EIqMq"i%Wٖc.v+g<RBy"C_\B$,8~k; L/ M\N>y$@:^0@b.Gi8&4Z.RR YȅH/ڇot1I:DW u8BA(Dp`H2d]hܱ]Vc.pD`W hgQ2Fb֒t8jq@y r,sdǰd5_Ya<9E0ȦS>Pqy=Gw9Qӱ%Its/;ѣ6Bo0,la>oPOa*c[}2M ӴFJJQu7H!FX0f{OwGZ!doS;jQSukqq{ S; {pP 0oo 9a0{<+߷:Ґ8I`pI(_H]avouHNi<|Ÿ)b1zUE;w7|}^ݡ>1JάJ qE&2 /Kʺ)+tH`w"t$J`dmy6 MH0K Fv1G<ӣV$`pAev8Ah̹6IOy2^8A.E2@#Y>sN8 "9_Y>sլ\M{!; $Y6aD3ҵ Ӿ=&%W P݈PP,kdVHo\ad\]POtX{rұ8 $ހO@G_gY7byHa 2 H,$ ؍pw3hUZ0 wc8p!!)*X CMW[&]^PDjI-Y.Lݷ7G'A\NXzn EwGXChfN7=ݪ~2t3HƩR)JܕF@XaQ @[č "@$ !%+KP.¸i=D^ "jqwHPr\ߓȈXԚe! WGX 54WkMΏ9sB1 3ylW,{JjAq!V;]Db5I 0˫S ܢQHQퟌ^d=I܁5uξ}?z>yAqpe?#FRj1dXH3K$fψFkgPVz$ A ;xF+$mrIbtT1$H B* FQ*믪v+l9:U+" [d9繻f $$ k-#%J$}k=@ G{aѾsһ {鴙eOH-<"9dN*I[524M!N)@fz}nU[,\+q,]tQh'02kgSb3}PfnIq BrLxC .N7[#\K><آEngBPJ"DA 1lE؇6ACH*.~th?E?pM]зz!7/I"5N BJ0'ŨydsRމR$BS0ldƒ*JyUdMb[}yr1=]@APь(|J pJtWDeu -&0Vu;y X>G &&מ˟1Iau"v:!+NK`FRЈ`k0d]!)[p J$@JB@,ru|L(,/IAvtf@|MGdw*˹xUa tr3JJ/5a4䤶D8rsm*RS Y ,gt}a(қGzĥ`Vѫ$^`#R T=^z@S~CeA|},V #F n"p hI=Rd"Ue#Okf13a,H&QJ0cU F%Q赿rM/ &Ke@ȝ%; n)JȄ4򾄉Б4y a0nXQ>zmdEH0Yj9WAØxe9R#U!I;uFS.=">xW./FKAOZzTѧ\9iXK F"2 E egT-jTSV^7 !L"!at]Ѯ^Ⱦ {tvD$+ؖR b֣ԅBSkzf5_6 8)zg̍L:q01ځ#ᕂȆD 0~WZ,/TiIGAd]anS[E\Ƌ$>~e[ٹϋ7kR 9{l^sQ{Wɓ)5kYxh1F~mDsW:k 5SATD.cMwQ3#!2pj'}7yK 4 ԏ(q֧v6 0Q${b  Zq,2,0 aU5br %@6)UbB3"_BZF:=~.>LcAEwP@E2PdfN(@t)"A%U U["4ՙ|@`lSB)a[=@) y@r;6Pi/n߬yKc lD 0QK#=ޕ0_Aj|r$ى)LN5p,R$К/mBz@EHoLc lnVܷZ8<`V(bHq׮oO};(fH d,n}LY>LϥJ> M|M(Qa! yBA SQEIA6=M$D(iISY K LL@5jpz¯yxax6}b[wcNP|-cVmĥ;nL 4f8,]Lj8~89;M{[x~e))J$̽x³0, Zײ'VM\Ӝm /#Q :xr&zP.X28K"<dms=N0ӃIbI̓e mAq[2̬0Iu[B5w_+^ק[fw2ӂ,Q7ܓ=z dqNE`M|J90O6^ >zY yՊ:1Ixxb1C iJ"Vh*9ŔUw&p]BN62KDKkcc!9gg3t_hy/9Gf3 NH P4aa40zfX+ ӦW}*.jTJF')R %N"RÔl3\3N2[*P EG&Wy.OEKW7Ä%p[j|nc=jeK`$$uQ #nR|ZGaG%E.w A߄[Q 1惙䗋y18& >hmWetaVAm^Oi&i z1Arg9.LPB9۱g9+&zhӔ$h/ZzOơOd)}˔lS|08ńa$cUrν58$zS$^dv`֊:r+ws?seZOJ yQ`{A}#gNÀU ^\3j*@nx8 X(@Z(-9RDu >^_:10 GyFbU8VLx@PWJo8yz+F w͂A;ɉ6ܬ(v$vJ\(@C sx+ ctc'VPa|1 `e{I(44!-E~54%kڌB,pg}N:5է&7AWa$Jv:;4 Sq-\ LE #:aҶ\iT i}bˠHW!U!%{a$e6%&H!ms=ɺ00B};yX^=CxvBp3-P̥͜`,VϬq= ]%98݀7h([ܮVQ:zzDJx:8 '" {> ZeBLP\1HC.>H"3_خ z|\VaQ~#O,L;kߙ xlfX3 ʼnK įo3H.(x| ߑ4goτ>y&fTlL L/ԥײ/K0艣NNBϜQLiF&1 $h{_g>zhNl aŬ `p[H# RچMǡ i& 6(¨  R%rtйŠp0B- p.+c\x<v璃"mF{Xqj*V(.CPMw5=k<\|$n!n'O9lw,GRurQe wKpk*w7llz8y"Z|XͶg,lي4a{,S S1Yd~g.g!*x"I4b^HbǏ?2Vo#;(2dLgS ̆F6YlMF|qx5%ۢZ`kCanmq9[HO0}vG+Wr۶R肄 <-[5S2uI@{K4 Zسh(plaXYG 6#|lk[g ߇|`;I!t‚eɩѡT"+=Lo/Cٻg(:K Y}D;)f:v'k"ҩڤ޼/v>vD%Oi<\({*v6~Y_]OLWM(hY\EDO he/hbo9f[ #}Yh;ؐybǑv {k׉RwxT5pz|[@H!"ٲA+d Hq HZDNwmMsW^z 2*Z'Kn&{ҝmryvwp~˾RXiNJݜ@y9U}Mx9վT;ZS"SϓwqmsU F*c'M( ӛ#;؈h#4@ɢ4 rl${sZ %&BCh59!zI.̬WDА i QzF0+e/<i He gs:@n AnG㌩iEHA Vŝ1hqӚ/ @˥M|Mru[^D2U+v>3Xsp !錦QۃDlp lk7讍d(<_NAFh>.Cb(ѕbUiX.ex:wd:8߲#pXvz|f--^Qxd0 2JuNNŚ$:Ѣ\knÎ[hgLdPFQ f=e4Լ(!ϫ4*ǸcvVX; e@&S_;R) ET G.*i'u Ev P&. b5vMcfӃҖԍ&m7F3@c<\])yÐSW .o4pQP ' 9킣ť"ٹU/sL 5Ler!kx lʶڈZb4y[o>]xZuf|֑f)Ý89!gz&P+$r00L~0yۛRZ`-4&FNGrhx=(yެ2`;nwaXX1cP6IZl&aٛjnQu.-&U;ulxkCлi-o{tSP{ F}ޡ^J !Iv&ooQb;Zsˑ4sL؃f2OiXѶӱ\̐سPZ#|O+Is!!w IWbľ6#U|kl8oOhC5+Utb0a h[5Gț޵}g/:9 Hηt,/YT6(\Jltj;)q`cOj_M@V]ź4pY?z+9³{-!vo7zx EjXqE";[66~cpx'Q[iZԁ?Y4~Tv6$ !$ǪU_~Nqq|s VwGU{,xlR2LZ7 (T))jkZeOÁJpuk`}HxġnQ%X#-9#~-= <|N~)l$̟Bjis_@Ѡժ^wqUd֥iO:j0Ōc`Bl gP);/5m96NQS!1ekd]&nѼ:+f؁s|ob(;F|94Z{'Qɼ1*թ.d| NjgcpPBrrSe:t<Z4R ?tCj(nvD>K 8Pļ !-3 ^T dv_cE^`x2t^xǬUۨN>Gukm|%7nkq m>4ⶮFqþieoKr^s=/cqr u4hAM bóŬqUr]Jsى@"Opc8t>4pKdRPM@Q:^4^r015Cc0= A;o37ޱ5`hѧ\F:Nj浜m=иpj]1Q],/NWW֬x,i{zqY]mPfunhƄ|\6n#3z*A(qWlH2C zJ>Cv9%(>Ma(ZIٱKmb+Ap[33bo2Jr1)L*{NjOjUě62ev\wf[D{vnpy|ߐYXu}j98RQWh"eulv]^LpY+B-`kZ"V1:-uCϞ>Y ` @ SD$0o1:hB O,J|,c_h!C$耽? Hmɹor{h-jK ΃R\!hZJ%);S%JKu ĹrJ`U' υ/7x+m(VW( #hZhDـ:p]J83y a <ɪ Q,PP/30e/xK-'|潐>)գӚOdxwĒ ̢tR){-A])2'W,Nr[ܴHC+FƵqN\2uo9 LgV$Uò-,Dh­޺o{*#pC[abIT ku0\`73r!+)&x:b]F% .PcOZrdH,F5;2pٽzݗ6?GS1xR  ̷\k 3s /c$8Bܒ4HTFCs֔K2b%[\9ȀMH"YEB ЏTߝr;VU96& 1grUj %1M I gʪ> wX Pb1!]/9Q_\ïn>Eb <+ʀfwiPC"x _W@8' %5@$c)dUb&=wk`WreL-Y|:vz[aunMl!Q!Wb!jټTIR#e vIMwtYւYb(@3`>3UDr}`A|@FSf!/OŸL: ШPtr0sFOY s bM0/O/xA"8_g{< |2* V€rct-JȐkAbR!7 y$Yb(&I7DqT:;P  ܘzj:_e ^2n=&'M‹(;33X`F4O=QƖ]m'f|.]YAMޙy$7b_KACrek8MpM!o ѝB<2@fĭ(#BfҼ9j#%2#OT֫lFomS-ؗ 寍dN=NO5,bz>{X]0T|v"IQnTڴyyLGVĻ&U'mB\["QㄞQIjKyu ٛ#nLIImEQJ 4bfZ3G\ذ˝&׌ulH0CbaF2N!ngkv߅vuv% u*Mq.ZFbW]KK'U D̋, UlJ )_n &̚`U'( O|FÊI$¿*XЇYl3p1No(; rok¤$a_Rf,8k5ObAs]40®9Z\hb љ+24[ϚX+ M UXftR*lE<\[8xU==y| / \., K]#)1Zs,atp2Y Y u4bxЅ_|>Mfghd~[Q6d8V2 , UYY|UaΫ23'(zxA`aL;Aqmёo+R0j1ɕƝo ]mf-6,Vuu-Q<}60~Y;D/Y)ոXVS'|;˩%|c[se26GE<ǿԐR6^A!Az\1PGumohS,< 5]K1H4UP&(Ц \hK@ 2"B V\ĮfpH6AF P69 prgqvsö֖?8ۥe1AuMD X℩"lglI;^)3PQYtIwqQVmD cC~V3- zQs9%q۫MCűDnʳY~c}h8ªT_}"):a P0Zԟ(]g Wm)_-+TZ4Iu!x1pܴ PY&=ue&.6`~ӭy g; #fhzAtg@x[+溻G3?w{#1/e4:*^Wɍ|}H;9&H%X8`Z^h*mݖM?L5;*֨o" dWY K}a d"CTAGX:t| $x' 1 TlbϜH֌@uWŪ` N]4w,&mBs >0"n5xHM҆*g`0p ƺF9Y]A^#eu jCl-e)Ah@xܸ"mTͺGY|3=7tC4MG݉3*"]B(ZR^(#t[Qry膻a8 bap\Ģ"9cW*Ę$TwÔD.%.8s@,>q챳'ŜCfU0§eAf-RH$AzX}kK`%dV0~頓\H#mm{ʞgt ~ @|SW"V3.x<{|J|]Gi|-L|Ԟ `p vvUj NqYՅF"iDY jFW(ul2f=ĈڲqaU&M%BJ뮱j]Ua!Z J PuI@ Z*HA vWrU&MB/vf[Ɩ=/ ݐ)5fT"`US@YZQ*I/06o 0ל¿ b"-Pk쮕{ ߓ4^9ׄk'@O:/pR1ԱBG7&ME\ D樕UU),lGبUq4wmGD Zxm *CE-ZW,}[3}n( \EC bv#eդIx+ 0ܪJM>X ' ?Seۂ<{,2֚6Ѥs\[Xbzʴ$C.:JAX{kԷRͱMsWtȻVh7p-dE/7.v.-'d#'M7 BpKXޕc 5p=Aevg)4+4Ab[m ;T61N 2xFV+d"{RρeE#F}"u%:KU9/^vUv=VAÎt  fD󫄹< Xendbb*Uq4 x ;;mqXak!8 M{Pb_c4d5Ņb*ZnsWY~ פj-ZRE8\*:X8HatRY r.MŕcG,P'uAmqKqy"bM"l[攋--e s¹㫦EX1R(<0IXϳ?Gx+^ Ŭ7*X5{dT<ɕh4Ȝ}tVlDT0,!7_9ëeƑ,} k@"UFQE`fPWx#zFE/|,BLW}dƒxD:]m7?0;,**XyKaж)Ψ-"-i>E<\ P _2Lo5:b + <|Vzn5ŀS5:wD&gR ̲5I!jT,A h~xor) G\ShqcA>dؒL(≓QjY!T#&^j^f΅XKpSɐ4"J/w$MFѶIFV;pE(06E(P0q3 YAwaDRcD3*ڋv 16# 7Z ǒEL }bDR3lLP`nKis+dD!%PmelK7 nΡb_!nCuٜqbTZ.KTr*Yhn;~8uy&<_}Op0Ҕ!7yʼiyƕ6{0럁$'6#]k8 $9tpMc:B.Jk FA-Bm*ʷ0B6%Z9Gvl`zYdk>@ZZ650rlo63}"4C|PHg%~47m=~kaγ*l4R-mu (]spmq&ZCc`hhb!"΁5ch;jG,Ng~ u#Al@Amk|z}REe϶&{Ň:&BڙW©%x@M$Cf)b\iʲd#',M.Y+l7`j{BN`A q j@xh&u,Z QBu7n-[}7!x*S 1Jݍ9/Wz'3ٿG{a z4-Yx\o@ƱT#=ڷ6kqoILlq:0=zļN;텤Yѭb4ˮS%I|&7wri&vj]D,ԗ9%>KO/"=Tu>ZodzPt'eA~Y <$wuO' 29cԕ.GɔֱSDJcŵ<\-p`bCctZ&:p UUB…N(iL:u 1\k:A=qtx|D/qM3O)Wm:㴯Rkɠ¦꣸nD12lh/Yc2oNd!17+j8 E,#Snz Bىiσnf\!LMXR4Y |-Uh mD_0!ɶHihi[TMU s5MԋxDE53ATDn>u M/"6ҀLPݣKQVHna8\8 ޺dmyi잺A Gn*`-MVkg,<P Cԡ\L6OC4JC㝶`^-:kDq4+|06Y*5R-? l@8v_!ԛр΅6߁z+v 8ռOoFzj"Dp-~9}1'; r>|SY%ܥ(;dIzI(rrV-Coq[RĂTKj6/A8 1r*ՎҶ%\b!)&_6lu~TBUU묈R(,F5ld]ǖQOj* MFd&_XrXn͍m} Tmn5aл&dbDGwg 62t-ͯލd4wEk!%(Z+j˨GV(bO}[Y `h`T̲n|ID&|F .#pFسR~÷.Eu.4<Gqn׌QTK> 7v'Zv]O@"NLUSǸfM4rWa)PN9,sjW-#$̺7p<KK E5 rpWPnUbMmK/#jIPXw~M|*Co3]z*a**6"mG3#.3Q72KR"D7ǖ곘C*= {u#zmRq69qFcXBUQ`Ea>Aً >3`gS1snr)`ױ#\!5 |FmfOܪr2x,m(9"֯-ƭv֮d'/-^BB_X})mc1gT P+酁$d^(aM'oTTk3ZQp^,lj) "(=5&{˖GWiVA6ww!+SV{d鈅k@^$T.rUk,4tkمX3N֩'7 [<<$N{ݻE吻xEoi_,6PTosJ]569gέ0 {^Vw4g<XFL0\rIJT# p4wyaeT"e&6avKVӳ*kmM6\ 2 c]YB =(vm%!q~wXQog|ArkJK`,t4ʁ:5zx" 4 e\ :lGZVV~ou3= OihX8Mߞjwf;pswUxTsw>K}O$vȽֺ<7g1x]^-:5ǮGg`OE$_B&9A1^U|d%=|5_EwPK#b`<1/hBC[~Z 0C9jS yzhȋ2-/EYZ{G\]їHdU<2J1p[#O*y%4dH @;JtO0P]*@m^I \.$9^{{8FI=}0ziAMO{ar74zKQF- ]>YӲu&EYՍ{ kD` VneI|`B\J yHzWTÍ{~~GU5N~ֻ .i"8{6yD5-"Ub dx6?A|s윗.̍Dk2VN/wGT=MQJzȭ-\e`CC|]<b tmT:Dhܠoe0.9nm﹡>N|_!]RE}ow% @I 0#pO^\Gэw/Z4 %ԦXwԺ awoϑ]/q=\Gy$c,7 o>@s'IFMbmt;L$b*ƅ#Mq 90x$1[=Њ)A+$M2E#RQ2sxEҐnF8 Y7h:w"VL; @2 0D.ӷgжόxߒeP WQk`bǝn g3/*|7-o_4rz EᎮt{πΗwNJB<:{cZX[7wp?U]}uiͿEPw0P\MGN 7쎞 XXW0paQ0~-LJ?@O"@.P(zJ -}LI$+:Z:Vl~sGF,vHK`Ȁx) sܴ~vbvwYvlLc`Uśi4G˗=g@Wשׁ!B#$W4gz,c(x\5NÜj-q;]b U8Fׯ}X+[C=+"ޟ:&"g޲OD=k?mk7HtQPh -OeEx+7; ;Rf?o:So#}y18,u0 pbl.A,i0x@ D/N`haё4T!(5/Qprrk;~#l-+]ꟻ4%m"AeOZCFY{tTa+^o3BJΗ<*2]-ļ^H^.G#/xg\!+Vy`I[^u9¼,8yo7[:||)Kv}[x-^fߑt` mp{)vHF?g~}t=9tH]hu+!b ϜTv~C;:|c~1Ս._y ;3ָKyAah%yTDt -es+ᝠ DAj9k-[-\="ؘ6M \4|bMtTqߛ,nV`ꃫ =c0\C$`μ4v ".` Ikz ?̂ ^%rl"xP6)-IQ7].}Ĉ2ƫea[7~fyԼʹ``!pȯVW_3vWc+[LdwRN"Vf66uH߽+]La$V2V?<z4\]ey pzo_Ϟ9h-壅ҿrK2wfz-m7Jyy;OwТp5R'sZ7UQZqPr7 OJߌ |l68^߲~fMg؁D_m{? V_x?=v͟׮t Ǯ(D9LC,0w a+ y|Ew ­(?UMt\vU\>jO'Uup>x*Ǖ֊&gBo;>Ndk;OMާ,⭙T;Rυe)p-IyR7xanM]Z亴Q5wxblsB<SWC0"h񵒀=elۑO;WY58kWnrUhQ;QmDٟkRkˣJP/*W|o׮Zo?uO[.1\5صcwacuvwMsR*Yή)pzoxv9Fm+m9w]ViSL>f'ώ]Spw|$]ݦpR{{$/zWu&C{Q_~i?*~xwnJ}ZA&^;)NUm4md΢W\+Ȋ}]r׏ =h_GX(f~ZX兑A~SZcɺ ~Z%칄Xz½BcspC ^e{I9 c"[7Wߥg+Z`"oғ$Nszf0͚n۵c1G7ܵq z4UZ]2 ˠt RFL1۬\g D1(T<\ % Ӧ+5|Lٍ%piN!zo'/WtbP% VlwsL –gj-[Wd|oP *Vڋj݃Q,m Ma筣ґ쇉ʸ arsǽKpj:n#=ߵzwq2QfU{n^dq>e|&oQR %Ąj-6ڟ忿dW{F_O/|]ڐ1{f81au sYHlc5>riBv{fy/Τu bڡ6.E!:e^IJ[$~2 E,~X; =S Wۣ[P ,~~/GnGݮ}|=Me};M&e%OIsEv0eԜ,=7 t5k49m)Y@R^Ỹ-}ȏ& \Z0t|m3J1{^)p[t5N8On`q`ZZZ{{$T W߻*܄OՋiH}:bGz Q0UY'@lHp 3Hm3Ծ>?lOҮ~9cÃiֶk4bכ*窃k7^ .VUGr!-"Qتc+EӉ*ȵ|KÜQX݅N(hSl9W;|0Vvw>w@ϔQ9{V}ģ-Hwp_#>##Uy^NWMuG$ GUuhO3L>5Bmc.vu0>?6܋un7#soJ+do9||d#E^/ΙK͸ʝ}|'z|~}+zuȨDk[Uet< -]"庪N}Ya-׻"_ya?ޢEPvk4ס^(wŠxtlߕ4+w#C0!h|7y FgU Bzж͌q :|qJRnEv\Uvӊ3=d]]>[+G-x_>/;!a@΁ -[Ȇ%~ݼ3lGg<6m ' 7K:9~qnGKhQr]e \Wsv֥zPs{^p%o- ^7C^e u!UH-zՏ0|`Dw/֯mP{kH=,JcGxR7T"4_u̸}z/x3OJFtz}}yΰ͞0@ )ٍv;èJ[_~|_Wz1POV4EO:|w꯷g;+OAdluӆfaz VS/Y0Fja8~ii\߲Aw%䏝`q]t8,1pt;O0m@RU\}Ň `>6`K?ɼQaQ%4E[S{/$*[m_5M^ x*H*:H>bߚFp~YRwE?I->H&|3BY?|c vfӧO/OBʆr˶ 1LnZuTsDKqV&GWHBe~A&^Hʮ~%/]?r^Xq!}ş_w3/4.{kݒ\_i%S.}72]Pw!: :߁%S>;̼KqO<}_ )NLi? L1^OǷi$z2IJ$ͻ2t~_ڰMĴV2YnS+g $F7P-1.DB!Q,gntO}]_ut>r{p}7:wsd6׾#|cvXݖTǫwNSgXAJB䯴 0ᄧF_*5 ~/GM^1Q#=1Y+ 1I+My g6ɺ2\)@Rw^_xFcs%`(v6 @-YlEk H{|7߂۰E>{vj+U/|G®g.'0Y3NyN #3\֥i!w%fhx+$O $;R}ސ݇ڛnɏ6~]@#C}vfQ\.aN8hQ2z0ZRh%#UnF÷ z:W쓀;C~l}(Y<@u8M29c>x_t/^޴qT6xwM޿Þ}r8~~W"Xo3u&3\ ҍu?8 Adi%"^"\'ޔpƮk'BWMD%2[^sl dTzҞFÑftSROŃ=PӖ̀±(QDOJxsGO$83zP<) T6ܘ`h@ߏqR}e nTҎ6v^ק$FŐMqJ$gS%r)-tc:! #.vy2"? ?㯇B,wS9;(g쪒i%"ݢiЋ,p⃗Z-u4fю27;n$JW5$)hQoZrȫh+aۯ:̳W P.Ԍ|3l^6: qOƝ%I%f:8*En;Ŏ2Z.QQ N=j 'CuB!<% mҒTg*cWCk|!ԼB؃nr.K4c *>f !SF56JTma,W/9*AlI|XxCHN4"zL2:=m\KiP1>`]8q.96zf '6GM  @|mGk&dtLk36nJ6BʈsTs +h[a(`=BN [ f\wG[l6b'G{ }B AU]0e9ú9ccX+HVL2V>@lKPYʳ\>Y oQ+sćՌӨ2MR_6lןPYSmԱ,~7j7 _";dą) LmAj*[X\ypd ~ PQp2<8(W '3QI++jTGI iA<;iJ[F1Lvv3 厘:ҏa %C"ba(숣;s#CLUXN^QIYJdU0Z֩XA[8\U$uO4кME%K"ٽ'sd$2#g"s@*r֮ng* UI^߉~ Qn%1!m .qY4<œmXl^Z׽ ĕ6 l$,Y|)a:q@\RϼUT5b3ơ 5f#)Fב_Qt҇c:2!7dbd2:֧cpFJfM8ؗI`c)v-a'lhƣ'F(+R-;-ݩOS}d:$98EIϐ b–2Y2D1Yl!.)m7v+(#4uk|syhɔT6Tڏ'8hej|(3]w1-b/JujƏ}$8\ IC^"C.~> 54k՛ѯ3*oCq q$xb\@?mz4$ )ނ@UQ/ ;TQEzAct釅L v{]2|fU )=-)U3lӖWN`׫*9,ZI+5v# Fo~ +rT̪QN;DA?Z%4zL߇Cӏc@-O kcVD$@;fOB Qh@ mwBJ,C:tL#6T1+RdqCԫ'5P(9%mG,cʣֹA mgZӊN ȹ`H;$\pfJѵT,94 O4FڹEªEl9MFtpd:9`5XV ':yʻe0ӄ &ۘlUMJ g@CHоj'KDزTH%gxiկs9HkB Hx@CGB˓p i6&գFmDIwƟ\_+-"qf.)tA\\V؍`w;!tV|op(^HLcC!m_}(8K駕lyp[1="V70M=Xhs#P/~tg:! :*mœL:r Kx,ĊT$VբՌ+m/[=l4!W\tw(,yMD%bX3?0: :d]*vR?[5+ј@+:JJ×|xJ )cj,\*򃍔(")Z zzNamreݷwE}d%Nt$CW]bd=qbyZ Jh}s5 %OէdeMpܵPKkDoN5 b7wG65Z;$b b%hed.^j fnb ெaINrt!b'cTٔoTi9QLp3/GM `~ѵ'UZP-ɪ?mcJHycsk-}Ы8uZd>}$Eɖٔ?mtEמ3j;Cz}^BFUÀ2-kAC>6ֶ 8bCB2!Xv -?Տy;y4num]Ղ;C Ю[=d+j.W>lyUdvC%21%QʋEWK᫚5QvNX(M*Dq%׭y!j!!$\] ESb :UCm-Kh v˄YOUݲiZ^҅9rV*Dځ]uW{s@K==TWzjK!VKZqJ$D"=5b̈F\s- iIr W%=<Īi^qU#Fou'0ῷ١ X&+V }5 VBC*T*3 dd9Kb \O#̇.3YC{12rG|>mt5bˆ̤᠘Jɑ'qFw2R[1eP-@^\sٓfG,+2vU!22YWeE;ʼn\{ r'ϡ?7\зN!pF>uu>Dg%&qww0ֺfX:\Tʜط? _F@F&iElSڠ2ٝǕk`ZDE;''tLڡdκ!Hr6&vm,Э V)$^Bo͆enËC5\ܫBiNFuA>;<ЌQPܰᙬ0n%f';s !+(T8 k[6l[I\!9(y"9ںY5w RvZ氅f3$ٶn4N9ۨlBf GU|K>|Ānqc uర33Q R5d&-qѺXtsra]7͇.(FV(lzbU0-YY|U֞c}URW,x>juf9,3or%(l2Z @N:EKrU' IYV_Pe͕/){O^ tg>|RFSvE>UD?2G=|oZ`/MߨDSF%lhD@ rU]u[s!ѾC }[]Q_bR^䔷Mg>@O*)n:l@4B=AUt]$̱:+ƩU򞋓>J6A{f')/[[T.a_mc*/bS{5?29[CKX'A'ȳ)IYq-65aiNGM6@t Wў wANΑA_C(b4SxX7ЉZ*I16<WfvyjKjfsFHz;j޵/bNzRr}>3x;G{F sU/ifUL!.F)H_'<&γ[K K5chU/]%Kv5InmK흙q3g\$긩"P_(bIB yh+Zsp{ \.t9fV4 Y=YAiZU8҇^ov|L5FrKcVbf7-t-Qщ{rZ,A/,ܞXګ c? N9Gu6]$U9^>Κ239LOdv{=l[]> ۊ(~,ny]o5?zGkܽDC%6`KtJJx^T:6Z9Z:nu=r>PL-tԵ5iEwiYQ4Hco@a_XiܚT-m=w]OCdgh_µnmvړֹ>?\l'fl,y+w;"׆bnkl!qs{-$wKY\FAe v ̱W'<|#E^V\>o+g1xјެXZ;Gȇ=xakk'PWqѦ?i@ڜ˟  LAծa{uQS荭@]wZg u.S_-a@ǞՖ;bIܣX+잟K9ӟΏeJGv"SS!Hkt-oZoV5N2!Q^b.+?kǬSё_bQ] F‹P0%/ dvR}bZNǤǭ ^zd׺'zݫ t.+KS3V9=O ?Y7هVO|X_*hvr5[o>糟C:Y%Oo?䞪6kU++ ZtSasBa }^Ǚǫ`%c#)s>߯U_$,CuJ1oirM7·~5y^b^:?>F-Ѯtm[vSd,M(t8JVj:ߋ;;ׇ*·Qq>Y2[.Zoϣ{sg;װζҠtxq2E/'M?ۯN7MCy[=_Zgآy }ƛy1_|~gwR>WI͜=`q}e?fү$]o_.H++EN.kNj|ZN3 0(}@"*x @D>'>P4'>'„ 78z ;~OMe;+7hFߵA>u }k.^WςpӇC 0ky׍:ˁoF57*>?>U~G_k]ZwlFcw뼒\zZ.oq+ty=9xumw͝Nj)sRR^u=?)Wzǭ}n2O./?r1 {wR † z=o77[y_L @Qa›w`sGpN7:@_n4Os4ҷj+=(RQ?/ᴧ?m'M ;WxGs?HW/q=Jp/|'_[wfgv޿P~ަ]ǹA5:: Gp}ywE$B^F.q>^As/p盺宇;en9}=bO;T~}sy7Vs7uJ߆%WC@EzL.f` (3rU@Sf y(8̶;'KW.8Wמ@.qpe%#9]|Z~٠^Hp,:vh|K_Y_FRҽun`o݌xmWʨy ~o`p|yK  ?r$r޿qZ;_==jO,}8 |]ý|9~W ۟] tm\0͍woh\+vA91N:<]O} ~ɥۭힿ#y?U~b(|A!!Al_k}c&j[dǖ+0`_;8@#LZȿ=A||sߟc~~?zϗy|/:o5:y.ΑczpU.Կc՛N~iKw-j yA 0@t> -yZp]{N G8hжR1H@ۉƪ;^G*˒pRΒg_#_E^V:7dzFm5{o{nOΰRGv)&Kr15.fZ^`|^ntCS`4uguN6{<S&\އ{b1k,pL"^ʴ2o_F"P<ځvz~'~o}?udAU:r <k xޯk'T̢㋰^>Ɵ}' \UƱVU0wp5V3];)y;Md~( a xy}gIs~Ru¾I5\//MJ=HqZz\;A,J}σd/79$ry?j[ rMԵяOS6eT&_v F hw?V8ʿ}nUqx>߽wg3ʽN?; 'x(EnO߯__O?^)mw5|}~? ۓiNbΕOQ9sm!o'm9OO=enw߸z5nr=_7]`?^㷵?y S #/v^WO NNo[\Ƽ"G#}~Zeox?3x>Etؒ7:{ YNN5Wmou_voMLlvo)|g=oxqNlqh|,q4;+oi7pE@Uw}|_35R5^qҢ>|+ߋ1ߒj?g3^2l yѕk#}z>uCA{m!B$.ϩhu/p/@m{~q[~sVb@@U/;=m}sive -ۛC/mx 겛Nv>_辷|@T~dF};0][ߝ"Kk[x@A/(x')۱{?y!G}|yj3+~zIO{@p?_aC|l A z>{11 o{E?P>^}@>?Ơ!A@+q L@?;}y2 AS@͡NsH wQC|ϵ ""c@OШwBM/걢mϓ??aT@d_T_@} QO^Zj֫J~Uڵ|g֯޶VVjUUe|roU-Uj(U=T}E_?QGb.F^BoQ51Pj1Nj:,A_};Y]TWE5ŋ!Nꍚ'ѣ_>OKbc5ӕs'9bŊFYڗvQF-sW  Ec24m#E\D[Y+srXwvcRW9lk#hoەnrmصrmW1dcj*Fܮj-.#DkA]]+s͍EhbZ5#QV6 ^5**61Dk&LEskǍs! VQ Q;\* -DW[-z F6QĖ*  sV-eݸZQoAW1ƹd6Jd5FιAlTSjŋ\r4IѢ0X5sXd5Ơ].nm֍F6c ݍ#[.WMb5b-5\F*"&b,kƙ"6 cj,hsZEmʹgnkE/͊.[n$mܹIQcbݪѫG(k%ݵ\w3W79VX-srɱj幱s EFQmr,lV#bTAt-XޝY`Ai!y#\1XW+Q(bhsX"\ە*ɭ鷊 sEWsW t1IT"-4h+rPF5Ԗ-,lQTXV,&]cKcrۛDFVwTZ#Qlbd* Ům^7&ŹWL+ōkFѪ1Fحͻ(EmXչVTZ5FFeZ6y܌fΨ*b`cvhƹͰlW5\Z5bbܶ54ĵh2bŢ5bƣmDiwjsQnm\ř\IEsEXܶhcj*b5F-rŨ\Q4M[F*湈ƻTZ2m@bZ+hcmƢ65xd7-k^O{1J׵;w{Bp!aDE 8nL)ׄ0˳ﺒ ! b8,}QB 4"B2 zѭ^bj8IeoD.*$@&MSImUT%uH?ҊF%uvuT(*f.*oX P׻i <T 3>:$ՔT 30Pű8Yw[_m`b9= `%cNΥ C)v2d,gUJºn刟v QF5w/s @-x :Ds kϯ_3i,(fLh(5 [wxkDbX3Q.UEb` Иn~gT4G؊"<x`X!ր`HowbTB#|˿y=$$/ܜ=E KDȦG&Bg%* 4)$'sMwzĴ`1".S*e _^wm Z1m>(pA'{GiwWc!0hɖE Nc璍f8`4N"`8p9nF|hX &К {;wC)MxȈ!s{Zzٔ 6_D ~zK^*z\ݫ~΅P.  V~'۫ADU/owM{v^]"ܗ3ctk_)Џ<@Hy;@ htcEp "Hlv;Zx:|%H;6#2d̵xHS|\7g2eifjo=e4 4,')o;󬊌 t@B(_.6腗mt꽍9N=5]Sq;|n˧_$&vAvԀ&RtL9wa^ywx>H)eǹrn\e'/e 4 ( y5Bعݯb 7hf:@Џ@OFQ48$ C=P-z"V&#q1}?m8 &e/sy~GsMWz5t򠁔7C½]烙^#rץ.|ʟ8 ;L{yw 3nsz !`˂NRXt\f#qwۏBiXېp-*AYrSy[P䁷 3*.e:ᛇ>}\/nކ( (6(31x,0fcQz%O=׊F3ZF8ffsZosy;13L WC$3 ,EAû4nqE"1rdHl/T7M$%+^,UPc9rLܦQШe<4y3`Z`'^sݚ1ÙTHi[;Mz4huPiqs9J^*oݛltd;}1ݗLSnszo?1Fb˗aW)rkn}kgI M&Oǿq&1匜{A<RI432Y˚(bg3gT%a]wboԈSNMP"{[g:n!V=ZVey^0@ ֲD!mu{_%EKmDjPj:fӣ7S}0.$FnM˶x4&h!m>wx|P ؗ;Ax']¥p\^q=lTy $HLvz ee29LUhc]M= ޱrP%z].*gf]PP4r钣&WSPRTm!$YXR1wk+ByJ7`LueϟtPf4CF|.n9m%*!M#g{1YZ[>C4C6x\axx_tOoHJрaw7ȫRԵXXjڈm{_i FMYq3~jYe +*4h8 g ֳTuJzvٞ2 uBJTuF_ B@$K45\@WYIN:'ex~#{WOՀҡZ]VV^@*J5iEٖJ0#]ݳs,m!fn%#\6 YPJ\#+:)vj"Nc58Yf1KDE(WpRaUַ%ŵj"ڄn1\je2_;pe,śzMgθ.I٣Zc]yq=z,=//k}!~kC"م4R4'q[ V׎xE~i$7'4XbGCJ#IMf &ջ;%fu|YMI̜ڎ!IտH +wGH.ϞݍJ-ULzJɱtLof!!%$|Iol>FJֲӖ`yWoR%@S2eUlx$ů +#゙L`+A{@YѱUˢRHqaBi&NȐ}F'`V),JYtY*ӌWJIUnċ+6' ƬRn"^p4byi)J$31&"v ?њ@^/gޭ٘a|]|S ĴNE\c #!A.CPҪ(%>UmPKqQ(`v^ᨽH] 78lg$%J;M,٢kpsG)\ƒk;݅@{%t|}|w=7ۢIv"b6ORZσplᵻ'YC-34puN'9꘩S#v~jo.uް`% <`4x<B7ti?Etn-!MӛR_zdu(4ei! 4=OYQG $G2Op)nxtz1ɽ(UX^ƌ2!N$Z 󺎀 I9悍gڼ-WEX\A"tuԙ.W)"Lj7f}~,tTfo_-hJ;ēШk벎()"o |{XNVooGP16WwVV>S;>n8o=۠9Gj,P:ys!CW3DlE$q #%2i)-LMvrPM}0|a۷}:po %YCӘؽ*OȾ  b@FMt8C(U'Zx;Ee oPb1\^&6XږC}QLocΊnlS19 'o @ [0^eg Xb1'SXgb*2 Q̦LE|n0mD%+Vۑvբ"-uA՛ G8l7,j)Rta< /^"{IQ VdQk眄A`!)enR0շ|k=[ufxb#DB u8-m.f9=I-ĥ2i9c-fl|cSFQ 2JdS>3+Ab!IظQWv&wb:5#^3XbHDvLL n)Oz Jͼ7 x{<1:8*/ 56IoJfx q % z e C:,!^ZŢNO(Bpq*nXLR+yܯ!#)ޠm /C hU3}$F)K.wkW{c`gDWtޏ+h JІqLjpU2?1<,&s.5՜UpШ%qXFF)&cwޯ}#iia1t-@,Jra?, Gw> :ף{@0B)Rių*IZ/Q@ƈóQyr|*lO{97%Բ3ɒq ‰C sf:sLXEБ&"Gy7ZP"tj{nS7ޭ 07Z1R [pP?;+m1'0σI3Ѱf҉7v[d`AG8x 碖g3PrbN{K32B[wJ,̃qxPYxWB_؞TN\L%K/= <%`!k}~[-ofS*bkpk!T<6vsʡtF3PKn1BVy6hQ07a؝yNs*@ lY8dc5@)Mعd}h?[184$ BVX5f4F 3 3+/B:nfGH+Vn1~bi#u,f_䋌LrƝT$ K[o LlSC*rE d-Ou2^~a:jwbSp 5#v".(2:rIM6pN{]1+H[ήW~"0V lQJ'n s2Ymia3ŋʰ(vy o46 M'YVSiArwy&yml4 5/>g[=4*Ȝם]e)RgC??iRš*TTv@H^z1R ͩ1XL;W5U4Fԛېd{`Bh|BDKL',eR.62 !.`N uѝ)dmK5 +Wo 8cЇ<?|\%T̇Z9x*v`ew9^"߼Rjg 9oQ' T|H8B%͚*BB83&a,';&eMkfA' 6>bH.a&*Ml#.E} v$`} mjⷌT92_q׊g y4"(7Aʯ3/EXrOr%`O6+A*[j p[fJ։Ho~tJ0M|3PfҔ~kL֯#J'TL)]h-D+ҍ}: XX2kDǓe1oW۸J2]w1e od? fw6e=s(nݳc!4=m^jC_x7m aq4# tf)♡w 7OnZ\Zu]1wk'|ڔRR0ݗA 0[;EQvpS@2aBѪzmD> x!6`k9;ϑ /HoZm{uF{Û93q: yrHFPѝHURT!r"Ub=Kcpn{FnEҋ #(BqsejY`a#<꜄ݯMfsCtMwE.l|&8.(O |[a“&mC,9`Z#hc :pa>v'`PČJdi*6UVQMT ;U r溂<3m[Cڭ\bmn7`鞆țB,U `աq^;f!PĻn)\R 0s`z|W,gAwcjis$~xM&*5@-wS+`Wa.p<žԴpWbԷqh2t)7~d7F ڐ R )!Ԯ3!x,lښsdcv+80mܛ^ نJ|EY@SY ъNvb3'uc2R7 Ш׎FMs՗dk\TBq%/i~TkvH*CRB3k8ݹɛ6NG >45,8ʴM/cE+RVSGCXwtv'=؝k{EFH:kw͠H/ǎo{vMvd(%]'vAyҋ-и}czkZ(7!t`kxdYNWqܹ;o8Lu<̪Y Μ4gy7JbjO$DFa胺kxM.٬b-,pwdx+*I^ȠTSq߼où%F, <>Êuŷ >ЯCmǨo|_n # Bvta6had5}X=̈QHή61R\Q5\*43U?ɣ?ѕ{mm# +-K\=$2.x*;jZnYySZ =>[h:id0ac>u[fuy$~[~-܂]ڧDh0ѥsϨQSm u:S;b~qoX]@1E[ZM \cQޓS,6x;dqV@ U (*U\aү1]K!ls5r&-=-}fp5 Gix.{ pPtf(:GzEevQ+^6;( *E"9gE<!`W}*2^%Գ1bfq*ngJo0;~a 8Ew1ZITl+KjzQ8$]WqC7/qAKb() y8ZskYo 4ʯnُ~Yp; !a5eslD$&kǞ U.QIkķRa=_2<`^(>cw*4HUpA 2)Z=\Ɩ6sGP [o-B$'Z62K` NWgНf16\8;a϶74S4!VFuNmO!??5sXbmJ0,pA.^f ".r $+K!^KS CӽsQJ vm8̄6cMܸ˧a@`a):l#?,TSEZ GoX` D`{&=Na샢#LF'^*<YDr!BȃR*94EGb־^Y6YǛ;`S,f 6Ǯ] jJK=lerv# thSD *9c |6z9Ep &_I4sG`4/f߉ V]VġɃX{-Wcċ\Cu:ziB#v94=0ۛH,캸N;htgwS &&KpsO;.jDP%KH(4Cg`S$x2)P<2~X\BTm; W/|$hR%)AZ$Q5Hӛݡ3w|F~)LդdeT53_`9 &V9 X a‹$E(AFjI{u:̘n]$ٳr3@JeEsk3i9:k Jx9vp<{hWKYkeHVjSz7BW^8c}M[e.`&H z"R0gZ5I$b~'4pUq/f,-[Ah!*]2`pzAn Hi;DU6Px̃'UIeɴ zkݶAX9mdm )+ýO?2fhݯ[ RJ{TXܹ 4k(1dуRĔPJj) Ŗ> snc)8xPc(>ef(<5"}^Ν!Kh3;-r}Mvܶ8Z*u\R41̃4rshbۇ=2w'a\ 6#:#A-ɛV: E16DG{: 2il! tjm =pҟFIcwZTp4>iˮ5e%fksrM߰SJvK=JdpS_%d+h|6YBIIUjK]F9K͓T; fU:ŜUя3Tv!: lF`AZdǒ.[@zW|.^:1dl ͩIj8O}R@ؤ;oҎ"\ZAC_9+yIV+ ̜H704]}uϙZ $76 .,d2 B!G$0:UJϑ*h^폗xAPgP1u36S A|ZD @̵;( uyR#X>PAxW80@#1ŇzĿ 7Ʈ>ޥ{0r1rp}ؽyãS⎓I3WLQ(Xz5xNd'{[5kIuG`&zG%ha̵TkW Za8fB̒aN-J(qK5o dC`3GRjaP X7|"D2m+뜚9lmMBMY@ųi8TOxevdŬT&}喴}ܘo#:, 9DL$O< -7Ŕ=(Bi "./8lTEي:NR*ɑ|k舞RYU!3&A سSDYr1O6Q&fR# qn/Hսʐ" #h-gNͼx!0Kۆ"硆$Oer&>0ΐcdD:o.F_|&a釨'YmB:Z oə0e`6tRlqkU3e+j.ңDg=h4%}d@fIE;2enCHQ.!DoGҒ7ᱜ))4$c"s0{y Z+"\j;.+j|'l /q,@!+lT0;NW|m h=+\H-n{̵V&WdžٻLݕq0 >7&s&~m;G@Qqtۢ!|Dsݯj"b4 EQ˯eZn s+IW ~a҉# _G]!$V<EXyadǭ)M|;?W(;i+{],upY%RQ)K|8j%  &)<{YG`R쌯% HwEs@vИn"^"Ykf)k! cM'lxH=y SNZ3Sr1P8 $&J(I/Rfq d Iw{uN}&HOK^| 2ׄF`^[ lTw:RըV[pNam*Q,ɂg ++C1iig+?w!{ c 8݂@]r{ F[Cq& F%!@^O3++nTJm-1[}'(2%diP8;v*AbNUCD9$ƃ7G$kҒ2҈uHh͗,2T|VuBuOtn}z~3Y>1'~@xp!n"+ h|>ġV1$5D6Ts*D 5a)a[~ :>͎'YM=^*p uFMYvX6J&O'*U}3m" z,nYل٨i+<3e7WfJD?X|4-n@89 sJ+ muĶ9 ut`U+.u`|zex W Kar%Ո_;hV·4Gv3xnumkv#6>hk/]Nm#f@IB .W>AyQ܅WO1Ke洷$ 6oWyf YX+C?B|i?YpG2T:u u>7(\5M.a 6 U.k/v?jKVGz#PLeNlRQdŔbdG@LNyw~:sdB]<ǕH5Iyv|EF[s|^6>:7lTmy>9n@"FƣKg gAqΔٔ K%#|Í:"48BmzŦ<%{6/Q8?lv]_)xmqH__Jo9}ҁ4}`8?ʶjA$J4@Zfޛf#@4B>^>Fə`6(.E{|'MqWht2Xiַ7Fk!$%"e`}F 89{Vwf\&yu# NK|>#¿"m(?9{ޑ ,Oi[? EMh+ H5;CSĚޯԶmnVw#6aQxwôqWMbbsѣSJՃSjod|s Q%mhV5O9#"O-+-w[mk/#_2r F9se1oҳcsyzXL8$z.ޖ`s]!]-DA͢>eݐbrw4RXyc`y߃ަ\=ܛBRF0CFm+ t-cFM.AKTļBM;-ZB鴙Ha6.!yïTK- R"p YYg@ѡ:zscwe/梂1RHFX6[6Ӄlܸ=?O؋rxI2U u?O/'lʤn跤-F29H]q r4S9Vsb/e~hV} 36"5@EÑ3eJ!mim+ZHeCb~9'wr"4@D d}LvdMxZevKR  k]d&PrZP$1w }vLɔ =o+l 1$y:J\AS-s!@gLҀIMv”Z"bC5~m4<0P=0+UZMsP@mk/`hm8R#{Hl T-GMd66@T3-%7:r6H H\AN)mnӶVj|4#XK1JàQ˻ ZLeZkxq"n\5)_8:*\Α[v5+a3b-{-*LMֆrusf7#q$7ݼYMIRMijvʁK0X6؝J= H͔eR~b~PԨ 69IH<*l~e SAMb|HUbj X9^mE{4X&Hp, VWFwRG3}i*{w#$IŻ4`;)8t^쑍̄%UY<Y` 1gtKOo5Hnqo, qlHc>+!I$^G^Bs˛y1O 5WuIQ!lzң+)Ҳ/S]R {[gȜت~H G*T{0\HjȖ.J2f44'$Yu#@g\*bDj4x:,)x$6Bbz@T3e !()CPӰTҖYPzAm)Bϣ DArΕv=\g.Q";~%u&O8̗G ?e.@l+ HX.} "iKTpAҋXEI2xޱm-Ry qwtcb 08w^وoA~8[^*)p"yتFBqjReg()}t_nBzU%͔v1F,q~YqZ11ecŷ)dyCЊUsX lkX':)PSR/؈(ԯ&YQ%1+p~j3{P qo(u4,@%8cc?k~.{-W|M7w j@ YԽBГ\"h>.njcUeZ$+~Og! [_W_":Nu<;;J%Ƃk)A0YZK孴<5w;;C" G$1vih4EvuƲk3/sCnmVGuEze> +!a8^SnO)|C8hYwuZd!:6hcr7)hP}ZCf-dvƫ}\Nj#&A=ֻMV<:>I`3WEFpW=L{7`]t>P#ov]UNkZ`2n39GhY}JibM-.VUYe;] Xljn<<O0k6U3|zHy {BԣBR;?8Boĝ xBt!bRm"Yς52+F!Vto&2iϥa1E;C׵M5qOӖ͹CQb7@e"np͍#:2C'"kԥ9c;t]$َόW7ɏkƖ98nX `k6A !Щ_*BUӂeCF9kfYh@qe ӈ NV`PԼ[ie%CA1_T߉s!qSa9<^{YJ_ o(6ݪ\?+xiNm5^y3Hj! "(Q0<mt2^p 35Y<pF8%pϘ7N-B3wd:1Ίu}6"ɗNRM)%`d}l|/ֻ㵺N#}nGjRX;Nxg"1?e܁[9}g+=9e~=3_Ւ:t0Rjl \NP#!$<邙 X$+ 1ds:Iн9"o7B iCl jAC <,A 2fMt,WPD\%ݨ[xϘT+G%[$!#쒓/K JA('i4gV#S?El B~D?Q2kk;lZ\ˣ ${̬G,sj0AECx4.BшpQ8 KԔ"2<U.21sXnD_R886jXdRε]ּUؕ.b\r&Ɠ|l$?t ՟I{AD:WH uχa3t jWs: ,HoirFRP(Kq`Ĥ,5`/dWCOx 􌌉-``Y IT:@~#(&Jl3p1U|AWNi#EAbLv`;KI+,7Ho]޺u" pbvt%9⌤E>^ N*f8zjA51R>R<>lo7;/ ~E!>2.e]T[]p | u?߶M1!9kPdp"-Ro[adf2oU]pF]ߥЧy}4&q~:}֭EQ?(5PZ:,  gԆ.iwV&"մ{3,%R'$>(OTÕL^é<(V6XIm?RzO" fua~-pqvkpَey2ceT|~bQFrRk\[F,#U 2-bmrڅ[CQe% %K9򜮹<F|E`!t9@L(Q`q4;xQ^T4(fchX+0*q̤eQVe7. ^j0Pq欭O4, %|(QW#=rK>cxΦ# 8B`/G_BG5tDkMvD;E><4z7>g]ā-&hyPTYR(PiA*~NMkzgqհP57 feR0d-~]bl\ -ar3sF4Z1ʨl dy?HI־f`7rg{n@`к~9,Y9.ODz2 IMw#dML#mZj!ߍEOn+߰| fKAd}cDZ@F-[Eʾ 6=G3sM315BXK!?*ڭdUҕ=aGc_k0o\a!yMjFa7|Tv6,T}uPa7χS+}$F ^}\s8h=pѶTJTtYA\9eY8斲I`ReXUZ`s|#pAbkᯒG|J6yl0-*zQY:K-- 29C1h2]M; As9r~:l_l<ȔL MKFĕk)"HË́8,EՂۊND ࡕ{NvR}ST?|UkUQ%<4[0ml#QFVEAߨ$Q̆Nd~q+/զđ!#K#QGӈz#'mTVoTdm:Ք2!WskyYLJ*!Qt-X /Y #p>> ,320p.侰n6E ^3B_FHPE a X}yv+F2cZY ,s/EQ虫'ncA7H (N,Ã%I+qAbMQJR!&観6ïvϕ45uol6l+BS v$ǔ#xFtI|uF57V| FJ W~楞$i.D9kr}m(g,(.oxI -& 7ʜEn#ha#.9 Dȟ2 BAv}&9Tޠxh;Ⱥn8Y'v:Y\B_Sϯ>*_ #.$@-f`1" Ac{C>9<%ROeD# {Ne8% E`Xw&<%ixKmNB@gfZVLbش3 >5?frga:P.:4 ͻ d?˒k*p aE󘉁.Xʠub*SBԀJDs1yAFG*RTP`6*Vjw$,fr\{ U}TX|7ؠ"*&T'ľaO}N}u+v 쨫hXΝNHRA7:SDHlB':NU;Wp~C%jUNsQcnuq *)86p):K5yͮ{p'zLe9ܦubB1s~kX\|$)^\i7svKPoYqGj[&'JeWc8uX:F-]jn2%0jjH%O(r|9=|Q(tI6#Eu@T- ^M2zVsyʵ@ )jp]x LC5{8!}7{d'8gUòrÊ;ܼˏ= {mjՐL`IP'M;\._34pauH@5RlƠުftlJ4bػ 3a`GYOIϤY7ngI烂82M[s0Bm>'ho +狗?nJN[7 ǨfqqM|sơKuj-ƨu} vje3azm[̓s͗bXiI?(;f]OϳcxB1:}rmw{ s5]vb|UhL'A葅k\}F%88Aىo9(C== IJ%">T!I]h]7FF[qCIT[8 ÌiNGS3v#䇔8Rml[M`SFNZu 'VɊ2H>HI? fBy*:W3^Gq}&OXS!}CE6J P}7WO7XVm CEYW<0FW1 vF#3b^/5B5k8ʘF@zv+f{:9($rj#,OXM9Vb/! ctp^852LO_ lCc=JeqnD~~-ҴZzی3<‹9gZqU?I/j`U.tԞ>]/{/MvW țRu`ʢ  _z%Z#;4˩12zoJѮagޣGۘa+YP:!6R$tëkgl@N[q8`Uy}2 C3op2p9I`<.RZom1Y\)]ɧg&N,B,Qd MR[2H-iah Ww/eI ѷ;Hxv*0"Ѭt%'h`^Q겗BiVn&fPj 2x>ԆA:.<ʴrb.B{^i7Q%N6}j_-2Hl#fI[h^ ю'XQ`أ@o\ҘA&:'9+*P+Ϳo1x!FEb^!`G,m d  z@+sE(+!h0 zYSR%%0h!KRҤ|n& g5vbH碜oW@NtM?>*BIx0K02Q']`cHFչ| n"EIՇl-oC+!y-Q%o}f3uBDSg 3~qL"G4D3Ғ] Sl3OIQR5#..oXt![ReuG/6{rMy/}LwR@> r!`fݎk~LGn\NK9.ꌒp\2~:kKb\rEٶ@P9㺵9ӓ$יdQ*D[~b5fL.&ʄ!$ѽQ ΛUˌȱ"Lq46砥V"Ԝ.x\ H;D@O3 |JӖ ڝNl!Ra:}K/|v&)z>6hAU'eJdd_k :u1Fk]z5:Y[{e>A*El{,:*⛰l!?2*!$'9A[skrz6 51E`p[y|4F˚R{ǧ@q U(y:e،>L8\y5;xw+Fk-6~.x{!龇j^3eoOy~3#Ѳ=6 JE2sbeY.E>3ױp Y9T0>GR9( \@RW,"q#@ɡ:f'b,4>Kf;m?Րy-HOa mHl0 3;+8I* .lf(^j>c#h|a l̵9Y8omu\+&:ab ~ ƼV$u/KKb= *o>${~J _l"5v3!⮽SMYO9)͢G+;Yo M " ]]څP&X;n.;DšZvR ͦ-Qk9[QfQ;Lzy⨒ MuIT306}LZ~JmH8%q2*8 ꀇ@T ؃s%K)Z.+'/Pu~nǶC]ͧBM+rL~W k[ ў:* ##L[OЍ;[r TkMSChQ4(Lm/[`9Kotmheߵ<\YPܦt9II)g|xgiF;٨Ńno˭}²@9cAB:'})#Խ`(N:eM6B2sëLQ֢;8S2?*-`C9p.m"xL`<#zU&8z!u1h iq՜޺95އqeV67ᦫRꪸۀ lΔ / eӂUbHBdr }Y|mf݉;QT/c&EcW}FJkי&ء#8.QWNyD}R q}xs9l>s 0{|*/P.2Ԍ!y@Zm'Gt^Kj@pyl$|>\{6YU7po[j0b sTF12& vԿ*7VpIݖ1GCTk ]j+Q9icp ZXe 6s-vgi7{Wom=:'#AP+DTÒ22Р`ŠvʴՌwe񴹕H v;%6HNJ]4iաSp 9A[СHd[iTw~(e&Y DJlL=!z!'$ )w6;/ 4lh٠𯕎LƬ _ad:ӾJ ܝ 8S_yN:?C%L`ݬ^괚!Vh%#!wPG/6jΏoQfF>no,o zA3$ ihfV4@y'ӧǬ{X}$=f{z;I/)ygms)10"-Gk$;l5k EJm AzjPbwZr>hSj9I8ZY.|eXI7{lL=\K7x@z]3FXV~靵br>K~1h.@8lԸ^g-K-AEY j僩j] 3]u!q^{.xNLZH۝5,.r T!&kĒx

ӎr2˲z.{./A-wSf,nc$^m\^k'/lAU~ i6l?0E5D L4 1M?|ٛ>{}CM}I'hf J-ܳdΤC炃5E{qQ{C レr c"j]Qt=?NguCG]t9X\ .?zH6S˶=pls )^Am(<5*S anlbBNXϳf#y=O݃ߜ ehK:1G[.9lr5lG+7{*ћ1 Q41փ앟Į[vw.׽=q0QtE,Ʒd|Qi^{lߜ*e_rS3Sn`Uifvo N.lSH)Lj@@d xeYJʱ=3Go µ.Gٷ*'zl@Zg׬ X\]&" Qn밖%2:=Z33)͗¹R-;nc}2pAxLPeL>L]8>fCO:#o,񮿠~e4 F# OTbV8ȗYD#ueR8b<G%DLX<4! p7YlԷ\,o$hKȺ̧k0@ծg~+Ȩᕓx^ S$n,AOΑd4o4j ğ㤼1ak'`sG~ߘiƳ+ Fj׻-~=; )z>2X!2$1 'BG2~35e1Kb2rÁ->|ۜmqjgDpdgPXd H ''-ŭO.h&yᱩGǽw$ v^&Peo[s_-gR.¿I ~^PSǙ k#B 9.wص<89ۨUž5x,(pSFJ-R)s~CvWD0[+?P1,}N|@?MY:LMh'ToRW6 "ԬL~¢)ηTTu:Z`#-IGgת`*R:NN~ 5*{TV}*^n,`WHK H/qFߞw])>=^6 _>#brd'!c >#o/h>4*T9XF|Rmyԛ p@9j~!@]cNXf{0ud"ft& }鑜pW](ЀP4saBpF0AX䱠J>ܤr&c%@rv.t8u|Upg_.޽7'Wq=L08> O~qٯWu6~}+;*I zc^;P^rJ [wʯ|wӬ-] )d)Ǟ9 f˵ih7nSu#Tv ʸ? @G-x3R~*MC1ZCN6Q.10;4ip+re'Q#4IQʬgyd.87I9eWM P'|mzggw!t*ͱ; ^4: rdE6i;XF~XkR&J|޷E wTr%=(\fXpaQB߉?D0rq|S5Lcvɺf+}h$`=ApҏYѥ(>w1|G򇯹{ ke"fXfɉ~~[# ]I?ڊN3l5A3ɄHbn8\CPU_Bu g EǓ㠣RFy)gNWݒkW>YH*VEw8PF)8ۉwI}n3A];37h6?aPŗ]=jPGhz4*H㰳јhRh2ŨrԼX*U Yԃ{Umie琍4* ⬒!4dbUay^*\_lsfҮ"k=^~kf^Jj l$rNdyTR NRu8Mufp]>qJ'Z).#Qc79]GD(bz;he .Lgv)n's>Y]/e6. LP{o.ba! ~ ̟'4?~ȩZ {#˙ +;;Mc;$r`Ws-I':t ef/~6cR-g>:Kq{se~aMɞspL?d<< :kl/r4a@\|>$<4rA ÝʗSOw{:.245/KՖ@R(wՃ4Fb[=.pS^^H+eLʩiZr[*zmb|$+z>>R8_ͷk'3xОtkh~<`!iN@&QC𻠀2<7ͱ2%R0WG.\(~Ncƈ/U n 8zS?]qǞwQEeg`}2|App595 W{B2cĨa)hM(S Ko73,wO!A|8K/2M )eAC52,X qr &/Ou~9B6C7}:kCbvQ_?)i`;:@WE٬U;5;S#KTQghٷ1%yS|P, -b=ZQ0&~RJwk=l>2rD' FDa@UJ4N|rm_%B/o}?s#u Gq(Kʄ#ӸO]T^A}Vïs+ݟܾrB_ yOW@>̉9 msHɸeIuc,}#K"q$>AT)l7aZ^7ELxh ʔ/ר)0:T^UKv pbR7U_3w(,Ə-FL^_~47Tgap]$=HH"RPhp'fi;{a_wxL΀GcI~dfeT5}fҍNVE,Ѵeň#o`]B+YH!=OSh@^邘a+9V#aBo9N ;4Ab5; ](ݣ C_Թ|x lN$.b/f&Ʀe,2d*vY|;~v  e dN.~zlI~[pIðߙgv -ۓTX_ç߻g'OޓR1)`JၚТ4<\: l:CTN($1]cǼ+̎3-,}ǺJkrIkЉ}5&, feP&7g?OR6:|_.I2I*61Rc,mWL3\_r2]Ak{X28rH3''̙hhL}vC3ffS:qn,~ҹu3ER +s$8++^kobLG$b*a@z}LJMMI6L/w˿0 :nHheS>'is.~b?@oG3 "%Ğ뻟E#x\fWoT̢vkfo(j'mԊ;%R53H uanWZFEZ'Yb b㦻ɘ3b!~r1,F_)o\ <8+P;C6Am6 d7㷘v]9UԵyĂEޡpMa0J̚h({g0w,;tA',+aOu.3hrE AY_.7ѝB #t[)gk#bUDO]fK;`=[Toֆy40Fi&[K#LiiUo0',WtFh;O#eC[+ R킗6/^8W[sB3a #.-4+ohG8A4FD3kM4q4 aTV"X p_@gp23y∺dhP"c7 4wُ.zfR_LE0 n+8hn'UapUCHt4C_a<2 ʼnu*Tm!DAO $ #@aFu#omd+Y 4Zq`%$"\xlAerBȅV5iF[CeMTHi_ ȪR$$(Lz1 5ӑЧHUizrif+cҁOګ;YQq\a￱<²Sm\ΩQLho=*7jGz#bW 8GzAI A @9J0,5T7\c.atОFۨ.ʁFI3|byj?'IA#*èQNeOBSM#(IUz{~KȖLpy  >p8lcys,bDޭKrE5Hl#'@ĘLI+Gz&;,TJ/~y@pAq']݄操A*ȺxceTzS `H&]pȧ(5Q 8; ")Q`i]0]0F!1ǃ֬[ !*7$Suhv7Y;g٪{QGƖIhYDv=ſjR*VWk0?w3+ !F(8SRrN<8 aQ.yYjt/k:n39M xӜ{Bϴo`ЦmnB= 0 Z1N?Eza{1OZfp@\vx('O0.S 9ׄd~V/\k8L|1*t|,qFj ;%S%[2൬Y1 b)DiFTq&9.7|*Ҫ hҧH8 zdtc 1,'x_KE-RR*W(r+8W>4={ 7.NE }f/Fckg'SI&h-Bj/zI-S N?/#Q#miUbi_VFMJ0loTh65j^G*a_`BG?.-C$Zx4/.aSEi- l.ș?(F(N>PƩ+\S % ! B#6> >1}J,u?iIil:*VW{WisWv6%Weaq6 Ms1oo.3*Or\Zv Fl4`m{Yr.xغSpzV"ypv妍 sw22.kc05^s2L[No)sk^f`$j$yNAu\u^pU&yU~ XT9$oE4$rů'mWƘ;8 CѾ)u?gitsn|j7#_51rڎLb.P7Ġx B1Bd,"6c*iJX@\8fmCPW]}:Sٓӆj>1 itvb3(-U~KÞ Oפ+=A) ^dT%fx&P-x??I,:MU0E "r#hü?##sE^Uzm@tknAc)\ ER"zԺ̺rFy҂;iBR59Mn2.r2"b_LE`ZЁ]Z $' 4μ^vp$fKQNvsC TUvWY4kY3T1{+<"v:cƻ#wX!J:0޻9%ܭ!翐2,Ŵ L(ڀ荝Ơ:(CL @DLM@&JHk #|{E>+-)`!Ghov{3rb'XW6 Od,!Tτ]J ,: #4![4@N:wgbeÇ@"vay\Xwt *ܪmYx{Z>"%**e˖leJQ@idOV41I |rx[EN쪉u$tfLMu':!S]2'6,`IQ<^k2Sb[v"w<,@i*%ţwm-aZ@Z-R6;!i/b"^*,-wiYiHj mvhYB$g$k@v:LjȊ_I q^lC@L##ډu Q[.v}\# o^Z‰;_6ϛV nQKZT&jrӷk<--] Jn +Wh$rL8n g'R4p xޚtSrIU$!2"A#X]>Ыf eFP\B)E]yAMx¤Τ6M ;֯'p1iU?wpRxzMr H Rbb zr+ P"oLAF5 k;FW:/]7@A>o>'= &|*/gQ?EUK:\h%J0bBVh? @,luB9S[F^9FDy ^mnυ ML&@bBahITlF)f ̂GYr6ʘRLC˖162Ly[^ r/?? t5tKqQO9`K:pPafxkv•rșG J$hKotnt쇬!62RUM"h͢1ho7[ëJF rƬIޕC*fL,j Վ@fH?oB#ɚvil5̀g MqDw90;jwmn`O1mzZ¥Y$^rCʟ_>ڵ`*\MxlԚE'{xU$Z:{ծZN]?giv 3EBE"'pZjB,9 ={*N"uTg+fs2L#R58;N%z ш{a_Orsy>8czGFcxFx&>IlsM\Ob%%&T I9F6 DL@)YI(F,DŬdOs{QhF\:Dkݐ/״/;r[yh ~f).Q Q1"&~rB7WENsce6w\˚vϽJk^$PGnKt` Yt_0w^b}E0><"oH4YRQ]0bMݍ7)F 嚬~_U GSe5bn(V\WWVV a1\W<@xmH#P5Ch=4FIgFx2DȀ\k?\gHD R!@KL,|"i$=:Y0E?B&z\Vn\ۇR. }MXBſOZٿmC٢fPψB:]:FJt_P *wzwA@6F$vׂ\So of"GTP;FkR+eM`J.f utvq9a*uF[KWA <rE9 g #E/9r-;xS%DslG[F:~1itvFCYu6gd yjNe%YnBV ו tM`h1+c fbIh'eY/awHM0gٻ5XHTxPDu4M9] Sl q.;=Ds~*Ev"~=s`}~tSKߗ.a=7pY(Gڹj³-Uծ8F߮B\w|~`^xvHBpi[Ư_Pk Ud%T\찪HT==R A[Ռ>ԩmcJ4-wu[>s..7W9d]_y aLs繊R`ԚG!^k{|Ѝ=T(dkj|EE6̀esCNm!_y^(#ŝܘȥ:o)#j%Vji\ZܤT#,dIkX,xE{vm#3B ą(s<4 Ӗ d> A8 ]D[L<5P1llT- ^a"(׈2݋{UXɐ|hx6i74 ,#%_v@Wֲ蘨3 Vn:m=HCtH=Z\C`)yyop7Y!`^EN(pCֺig$ .K13w0ֆiFGZR=OԛiMtG$5Уi'ݶr?~AHۗTڷdZ )ۉ5${j(S]G!{iYEK2Px fЀkp'0S]Nj&;EaS4{YUPo.W(. ZX$%֟OrفjeSIDB Ɲ 0ܖF@}vDH;=R-O'I)Ca8ҷ󙮄k"Ax=+@lW1EǏB\SS*QDEe ?Dq7ː@P%6 W-|BF;˔3zO2HH^`6+\ djlp ,yރ_(tUt+d:B6>lޒ6^+uv8oo8Ur1C{E^wX*B20`K7]eO\XØ8KN9f#^6[lԹFX w6#"eH 1r0:qb7¹=%Lr4/JO: 'BՏM0G &=S {!8 wأ$:C<D&yi5I?s5\#9X N-Iš4Na7%ҋxF/iA@ ?RfpuG|O~޴QfG.4 Ѻz'<Be!>X܂Hu>=H`ZqB 0"1a6@] R<ܝ{^lRMU C"%_@em_#p;[D^0UV o[uTkW/ [,er:pdItZщh@fUx}x;GFZN>8օQ t? |?Tu9j^ bIj_ifcDsJmƾu_]bDŽc؆c65%uF} g%#|a" (Fpg,!ō!:7&Dױk҃Zfeix=4ES}y~6{ Sw~TysEh&tx8B)j E_(bs[;Q67 l^iW#5 1Oͦ?AϬHS?ƁZvQ/b M-jOSt M9id0ݾm.wG9"o$n9'xH s@+k0iMi^6\ "':|O8C]aSrhH3AWnGur- 7ڂb77t+bK%Ozh &mѯ 5u& UW~3@48b^`Tϔu?fөHR ?ba;|Ӣ>S;fK-Y^)p7`n5ZD~pY=-کg8r&G8)@@o!ea-]< s| 䛨?F*(VT4g+̙QWq '!'Ts[YnSkHTCkA-aFE#Ֆ-y~ؙ83&ukSdž֩P^^22zGP_|.6$)ۻ,d(T*\VPf;9-1wfvYU-BW*V{|p$&teꎸuF)kM7pQ &#lޤ}(Mgϝ$;&lcR)D^c:^tmp,96Gu]AsSFrIژi{! ܻ跬`_7p+ŧ9%oF;x1Fj4V֮p{.S5,oe"3W06HN\%BK> ͵,ەaUKsHQH҇-b~9Pcgo'd*hh!t;u*Pzθ#G<9W/ZCy[VB ѓa:\KˤmQ hU43qL ,1qojWunJvEqPSSJ :G-L0p7m6@^F6_,юj@JFҫv~u~\[l zRE<<̠X ΘRR y At0!\ӹ+Z4TA6]*[̂_WzvF=$lD5ո+-ML'KC0csrXT@ib5 MŕFa1nLghST Ӗ+wzpBǓl݄\3VW[ f;);33+i# 5l$2:|k!)cEmu)Vbc7qȅY&&WG#F# U6ӴY`'9R`.jgNЙ2:<pgeYq.lh)}@\y1 #QnNeCYA57D*= y\-.}cZmݞ]id CzrǖAK*h55J1aZfQ4wU`;DdbO4eZBW<)KGǘ6ma2߸ɫ'˹&1!TQ:U^5-ٰ,=L>r5Z9#7xrh7uqA #T8#Y7K,onYH a 9[f+W?ZJe' ija|8a4ɋNA4Iue` +`|PǏXɫSiiG`e+'aZ-l΀92 }{m^VΪ‰IhH}JOɞ M-z菮 Ur'^Z[| h |N>u͜ŦAR树!uWRku4 FlĥKub}r$S2 !D9KCR{&\Een?;[Q s}ްZ2N^œͧZYfU/D^:GKN1 fSd:v]AW%Rt3q}\bSLgn7?sr:Gcjv9@drY!ୀ9 4(C=fnYwUcGY4H8k7'4m['tb1B¦_9ft{_p usx-;'eb#l]9:ڱ5JT̎d‚V,g6'eXv4_u60wӊ}hVB"(1Il6HUȊNE,Ɛ#3ǔhaMMKhk B'r>> @dFĂåL\ ,{ 2Ir4!нj 2Rv)f ~ 5΢s+{0 hvR6' U.vmh/l>}{`#؟uWuBafܺ8Cx")|St2뉯oiƻi3z)n.ĂpnHcH[ Cޚ,9`׶!rQJxLJ!nwe$&Qnamjاߜ!4RGwѵzCȿ}mHc7e9/#\ddxߣ[K ݛ&x 4X'RȄg,ܺvNxzr;k]\5RQdq,w+5uF f=#/=[uLLy3Fwy7A[G{g+q]3mf"&y(0u#Cd+-7KIv,gFm~##:h\Čf>U { 6&9Go.Z[)GfQ" a64RUel8ȹMjb+VVp' 8w5}ViU}jWtv\ƜTCw,1ݾUϵwUg Ti;Ef");cԈbѹqGNPTMl_<;DFg܂-"Zn*knw~n^t̶mkm.dT @ßj*X\}>:Tn9ni_׊GAakp@q9>$[IU߃_C8TCGB8iJ~L%"]`@rEl@Y՞.:=n3`)YxNDHp͡YmnPé${.,M ˿w2]nD(/q? M_r n2 3`pJK˕Z5쓖bVAǩN׸z J)J̶O-xo`X!;e:_G*:Ƅ>k9EjWApX-x~ /Nm2v@520x|?KeSNqҳ/A[BbLV'i_̥GQ@|0p Q:.%=}WbjGs_0FڌaUw,F-`En#Gi8v!!;rǩ꙯ob7C=3I: FWghB-Jg:p#ʒ=7*dS670^ت q~/mlZ:~ᖞ(Iˍ{}&{F(Z fBݍmvH큦$e}KFh#bW Sa'4|p5omh. Fq xnd1yE1azbBCF+~ܫ n-Il$I*CbDJs VD-)REVCTTMkໄXe^~<7 K{xE eS;)3qwH> &RbQA'6 rՖSfQ䫰%eoA!HoNKgE#Vtˢ Hl܃b[Pt OYBJwhbrU58u=̕Q-lFj1}|B#њԹW%a;l`t>OD33'BLR3L-Guʾ60t'uh"'G׽D]Z#HHݩ`+UtI)+Be!F"F"Okd&T=|_濥u2pNB$N5z ]y7b"fD#bcUKx+eO~`kD-wѭ?oI t[,|S۳f#1+k9}O7!ޯ u|ۥMH|71_16 :`|aW3Q#! 8"T0+}s z>' Js)]j߳pŷõ$ÝQ)C@2F%4>:_/o\dY a@a^벝{pԑNXniS<}1bY[8POj(m%kњ&!('ZA!Dc+r 3Ȣ B8Qa7 D0lIs5iEtwzw\y#wX;?Y>IYęyi~W<0uʘř$_U[nNq}=e)\diTXIƄűxYK EV0{` lEUJ[Dlλi* s?5$;tϕ$?"<ygnG M',| k,dרijA;ˁܨ̰3LV4Ƙy\'ttL lҶleɁ;+_l΂顈,B;p9.a.}90)n|,`lA\+;|n * λ9S 94:FTꛆOi I!`GC*D9r0<8r=(~> dKrca0 >Y`^7vlmT rܹxZ 18&.>rDm-DJF$,Hɥ 2'HP b1LI(A*#ؠc*3MSe9JU0xNg'g ԝH?+C^Èf_RLrA$04WNg3g*,yMDs{<ܮcUdpWEiPzA‰is*;(W3h<|aGP֠g-b$9"uŗ,!k⋽[/vgQ'WB'* h&?<$chʔWE1åŽuT}w^ ,vIib}M ,P[DH{!6s4\^aSyB)&v"a9;XQeXؿ6|Q?Y?잺wEa|/;]OX7x%-ukjF9Pn^0 бZ'Y7ɶS|h-$_ ~(n=y.Hm<#7 e^&O|f0hؖvT@UآUiڈ X9f|X־Xܶ[Oe)CrМ×#7:Pk,n4 fC'dYXrG_GNUvKiXۆ)9|.ɁT\TL^>|w-5ՉTqdf0O%8g/K?ݿpTl+b(g8v췞7-4;S6*W H=GWʾ0a*SQ|gς=<:'u(i7j|}7S{=/)'봾0匁p^)}D'h[/@ACnPt|mo9l=B8u("4kLD"G<>1oXU0Ꝟ:0DxxyMG-_IÀ)9ϙ/Sz}B~+]bDqof76Leg"[[;Ԭo(&d ݣ1ض y |vyGo/Yz:z@\k(b|h_z| S?Ʉ}нx NwPy;4nǭ=\ $-V2nH s.X'8E h|T彡n_/|_bq ELDPi-`+r. ˅DO3?'ocx#mb@Oȗ^YU݁U@x(#M*f]98qaE}Ȉ_j|sh|o)Z+24/gzD7( |pd-WFnAgZOa&,U"\p笪"  4љN{8WH)Şahugi|{!7d_p#&AwxB"ɍ q",X6xdV[}_w؉U"L1WѐmqjW~e|N hH"/ǡ/#&ο~(cbi?06Y| - ^J7 $_Cr<]5?ZNpqb f ϠɳmV`SޗKwz߾Eee(5hO @ (UoKlʊn/˩y%"8PjNoX˾RUF:&Ov-r.&WA>C<Hdx?ws]V|c3FP;/x-f0&}/ FY:e~^i,ģ9U*O0hݜ#J,5se5pZxsa9]Jp0'&v#l1iJ9(1Ӫ FY@l/@fUNߓ'ֹ-ryذ}}@S=xuM=Z჌I&?uojYgOIk} ǜ:W rzs.\2U>:43A΃7^a*cՉMzt-ЀZ&0yFv̦QyZo]sTkJN}Q]ln 5?%Z2ۇL 8ˡLƴ3dߪ)|b猟x|_zѐJe&7ͿVwupla49Bc0|Eo=YyL"Łyv9nAm c% G('oG[L$fd@r5žZ8ZH1`~$ú|IʎL''ׁ} 3l<FrD?w߅~"Aߪd&[tXwNbiFz6Cҹ]Ç ~ыx~HB"78QhâN`Ddfxz%}KhG|r@oSJy ٲW ˔Ty>/ke06q[Mx D -`^z5+| i GAR;jF +%fԘy׺f5רV(SbUboBugy/bt{~6~WR c,z2|RFf{|[O۩?˧MOAj8kTKњh(e5<);uԭ]֨cA#>ɛ_=qJ,ztNR_'W0 ?&4QZ-JzE~&Fɟp\ލho>VniM0UwRoWKb]gR<ݞ츻70jUZ%BQ路98">v hǿeؗ }^`^N.Oέ؄g}9 .io!G&N&2miF`^}ϗlPO$siM֘0 ` J S JB;|?e…EDC)Sa"A.ϲB2OOٳi($Ha㐬W؍A` Y ns\d{ˋS{Lw}/{}P?E/qsZd.Fd% "i,AK C#TAXtZ&Z=,pK8O+ -W dns🁡$q%p==O ܜjjFDž{|mǷ'ѩ,=n$K޼?3t|:rwT:jn?]r{ewϘPy=;a i7l*Mnyp}ɟbmg}kǑ"ghDbUMQoMc1t5gq I]ױ:L6ɡұ\a޴aci=J|1A PZ^Z.i9!-مe<܉hl^;&^z^mny~]uȘ)uR 25^T_mEIUԖ G|dn O)*X {`;H~'+W!Nإ.6G5͕NCfo4:s[tBTka|Nn$%#G>>HhLF0甍 NOr/%(lJӐc-U{x6ҭ$j+}_'jj-:: .Rd9N6_jj@~U<>#<`.ښDԓ|?'#f6=^SDF]sl!4-/%]Ot(3 Q~J%P^ e b_Nd ]3,T+y+uW]&6;Ggn)&4a:h?oir+fuRi\u*kMJl3ÇV~{؟+E8y^Cſ^L7?V2a<8OYfm3h AW:dZj˲ \>!d srn;?{:|y%2<%Y?-/ùծق9nr'jSy<A/d[:vT;[݇qs[+s{g&Y+:+]k@,|0y-py 3'%φ>e,u8lej!֘\ 5<HOnwfA[I!R}xnwm*'-uЛ8$ΐUz7t*[jyiE*&OE@Tj`EJ4'L>+]·|~UL?YOq%8ARf_lfO] k+GUoJ'="&e]s/ф: s>k`(T5٦:0'B&cؗ@i"5~+o;7yhTAK8ư0^ZECm-wn*i:yjw^^ t(T]Ch_7}pgjf 1֎p[Q v:Cܷ9eU[YK+1 svލ vkyi]./PYnq(nyCe:Y0MMl^tLɄ;m[ NCku?s=@G$Rf?՜ +b",'? z3;޿|iBТG?reZ^ٻo3}q'X/Ñ"jaI ٳiP RIMXFqG(hP7.ќv*qg ip?'MJ` Ҭ8=s'")Vof*n m,j`ھ{s ~}CT@H]w;X2İ(p@)Pl4QMF΢rT`x6_ZU$qPjЩ>øk(J?7*bhv|USAQ ޑ&iw:Nz}5g"4Җ0@!to۸Fΐ$K%3\w>ٻ]8m:/9%?SPbM@7[IeXd{\kOOM-+x Fkf&EYIVnz,n ,8W*d>֤Ex`t|0uϩu֝t 0NUa$|5Z@o|yz~ @{x9J1l"vYYfr^F;OZTMbt{1N<2HcJG,B{9TWMxu'R8 02ȵ *;AMp*wLY[\zqUb|jOӒ%P =fkJI7BU;ijS*`_< R/7W= KSRgг(<ҠelhX]k\bPꮲ,Dd9vH$3bxKGCr<<Ǒ}'OKn?ӄD^S~dGݾp[R7x%.6s?)\\>zzcɬ; Wi'遆VzmF~vnn@e#t,D(hF*MC?9G?_ۇC1沕RRٰwl*c:v8C Q/{y|+@^}N; +qwzv)y\1GE,!t^OHzZF:l)SK,:R'qgB.BLvBuTc{[7%<v$|oVLZCly46c35=!٬xkN3vw7 f튡Y@z/z0òx,r{_pzKj6+A2ve~•SHLg:wg/>0i~mL]Of.),9#}cX#O%?/wnmk>?m>\'R "?ypÒb YAvxkFuDu'nv\kPgތ K@ܠދGLj1b)l!tDCfJD\p\f7$?yԛq{׶BDRzQie;r7 Z2|B糖GUù#P޿ oSfC^#fvLA'iA=/ cR"KMVA`ߤfw #o|0W~DvAq^;\TITHCBePRKn D%̡**4"WK;臵28{qˀ4ӟ>V%>O ɍs 8%pl9 076s$-@,NwХH.@Vſ(*,5.hoCIIJwTdb5K]9W]pcw+Af<[§U. u̚6 5(?dn**xLR \6O1]z>!-h5'$d j9(Հ4q~9TYnۃvN2SrNO֧T&U"QH6_C=dbP2U$fdBQ:C!v|UL&=h!Bqj$׉4ym(fK#~=v;ys1\iIFC^4k$HSC `M79x[j+/ȝQ$l:Y^LU[kp;ҩtgXeC!d 5ꞥ5M m~(YIV{"F#Yqou?P'C5^R[JE1Œu.twa-qşh\b[ 9rK 0"KpF }dFYX7QH.! QmNG !\.)}3窱2 Wu T‚B5+](H}$1Y#*|:4h#fBѓq'_goMyy fԬUTad A/B JTkܻhqf7ׯH;"ɅDw޾gGᕱycaqQynkpIfGtsh(#`hFeZ}l hoO!aX>&v_>nNsDXPJF@aLH>!0:ݐd0U1Ðb^v odX8D7|* u&2'Z +gz|V.+5cx'СƅRs5Ũ_ŝ|$zI;.4Dϲד?ۼAN;,w"k ˳4E6?F5aC^*8Vr M6όb-*V 6{o`\&fHyM@?Z3YIH n{Q]MS"օn&"őߙ"u!Fz & PITagqNayTO~=-M]M/X~b}Cu+V!3Ǡv ]޵l缟Cъ@;.ǀ/]pywE|L )Ê. ɦv_/-)t"  \uC/a͐E+<pB[A^4:gxfL #CS1sjt6a3kqPx{-:zAttTJױ*f^etdu V+A3]"0Ψ w̻E|B?2= eg0lG7̨ #e LJD.Xl%W;}Z&/;20׋T饌0CǏfXqƕ3i_/kj mHhniωYIͅמ>RO@ ׂ*CD3~{r+3#3ΰT3ĘSc= ."+ 0$)ɒDUK ^K eN }ȖM wFA@n7diJ@kd`:3``9?1\'͚@Ze8fhIu;c%fA[ #y X`{`.䝍vk𫨮w}^UöڞN6 68vq aw!6FI!]g1wpPoX0~ 7P VU6r.6`H~#K#ŭVb^^" YX7θ$5,?N4=*qYxנa9;+,3"5Owg;7'8y H'Y52 !Ap iJ'H'\V՘h_$6qRV*3eٴV3 L30e8]*E7+%^#i?i,'%Z~O x5*uwB"٢Or #C! P~&yk7{mZ ~)٫aӿ,4N7TVKm:]%Bv 3k'n]u7Y]ef[IW sZ:2QRI V*si1CWi씒?Pv$?XJC~48!$ʒ/0sT3=30w,X.r3t%G/"=s%9\crֻAQ*^d0#P؏gtAq8'K(AzjbL!lDfH\ґh-\ə|W^JJNJrwyiqxaeCcIS^4(85G~LhH7wHQ{I99+b|K6&`# >w bz~b,+j,we.Ch>JO+ћsy[@?lM~h!qE N[-E=0~ZO3JQXO_Uą}?}.PmDW#i3}kᱛECDk/h**QK =4˖qQjT:xXbbo6?0;FJ^P0ꐸp[imbB2tʯFWwLGH_ICNΦSOZ|x yy{ʫ V\N&2nu,?6$l}j)^h>~1HyX  VMVn#c "Gx> ިq>k-Q- >PC`+sҠTrz=8m*[ vg6ck/Le݄:Wл{.I|r#;z1BWY+S΋{VRbc9(bS.cm~ofP:l5Ir غ-kUUGON-nE/\tQ^IK5*O|&tZ #ʭ)BfRܑV8FY-%MXX T 4ѝߡHkrE-UqQ.= D0AWVLXJ9o'fX|ȼ wu}(>&Zq49^ D  VVJA)yv:?z2Fm./#@AʿX{EGFx^|{D|Z.J)ٿXznܥxLWc=a:+tyl(栺wL3 $^ZWߣ:8/Ǒ&Oa=ظgE\>EăiM%4}nFTb "W::H1iRѾG}%0+" !}Benr%r8Qab׬&j+h57Ⱦ0E!^?ZJˁ>D{3P{hJۻCzԟ已N[@JċKl $!4f2v>z ;.H>W)g5sj:zu_9a)af{P-w {0znL᱊/=j"g$PG؝Nj ._mzt}viumzl Sd)k!&L`{t88Ev0fʶ60c5LT!>a4xέhMv*[hve4Jdk0X;DZ$O艹(C94g#!Y^lFTt^4+C 6}ZF W wPâ䅎Hw6<Ĺx-~&c \,Y/:,Q[9`EΖ#쥮^ɨu @R BVl,;15Ui4HM3quU=w6XˆA 6<;`Y^H̆7 cMJD%PS;,CG$#+. ԕVQ|T-1u{x|;Sp56 ):+'Ģ,N7B͈0qE7e=ǓVg%74. 91̘:]N@(uߣNhǡyk_nc+lO:qǺsqSY[Ë uZѭ j-*-O88b ]K7aƥ7z[mv>w_ۖr!!w}|Q 3Nj{ )N]kb˟''14Թ`)Wr1RHl(fpzpF3|8|66dMOYqn3CF5{b!L Q>.[A3ìbae;ZjHj  -?mNXɂ?[RS󱼃/QO.*T=vMĽ_\sA은l^Y2z-vڰlгvM֧5GNqf'2]$HٳOC4pF@ TB4b -+ym%cp¾أqJQ&<`-Nn usif,Gf)+3Pȷ8ԃ5&X 7ִ #c?&N6 F?;~¢3n*wm s}(}"i_Oq2U-gIS ;lW3nb|@_c &֣=!nk iji,OLI"XNh76?Kk o3ji~jm⦀:#kxjOҎј~) gןe]HG'F."AH|<$\L?E^ˈRlFoFV<{ЬJڍ{dh,4a..so||Mz][2VC[pFo3ơ@N$\JIkU\s.1^Z.|[w\rprZfFGBuMsE9QUNKJ] 9`n'. ~gl;O7$NˢQsq .e`d],--H@XaK0-6dȩ֝"J%CTclU*;5Ò c)7 a&dA 7mH< E7ɯRl?Iq?ż13Kl/6tHB yzTl@MBpS=T1é܍D zxa|GniůNZj7 e0mMk D5Į#CŢA|aU9K->:YѮFZg⻸<7dQ3E-Q%^u -mN)'|cR C >rm |QҦX 0}ͫ+L}eߟ~xtJo7O =Yhۂ=JκG<.g?񮒆h9L:і8)Rn\rx`TFLdl)lj@7"GåUa֠>[][0 hIھ # yȎ3s旈nʺId 6/~!aQ&23FL4@ KV7K|=ޣy}/ٺ:fu6e ]Y,j_3m4x+ա6x@=)Jrڏ _bXKtk[׸ C瑷- ,uY&aEuNMFøx7%t-0)2w5jMƩ@؊pf!uS9׊yIS9m`j/Awa];yɏG;2S\me)2:s.Ԏ`g҂Uʹyt驱ϴZܩ6#7e[+ab=$1¢7WQc&`^LC }Y e͊Su+0TØ핆RL1Di AXixAa z,ox"2 ܚMc@k)RFg `AAF9ޟ\qeVin6W0NH>_gP5 N5^sXIs̉dYqrͻw>C ]0!S4 Z)8U0~l PqBeףJT X-\B,w^8[j<6OI4֚P=)~Tc[IuWI:*-1  ^ZooLHs4'-ITMFJdȋs; 'ۭdN?7UD"UVdYЧ6􆫲rC(sO~O/i#luXVOh~#vng{a6RpM jwFx4Ʉ'r5_i!4F{_ZZ~w|îtGҬ9a|Q/3?ߑO^eDeeZko/cfdr/R়WN nWHZ8}^aKDfk/8Ą׏3fdx4s3@F:>ȇZTN4ɭSPZ .[NR$`ٯ}^\˶,:LܿwƝ IN8{mC/2̋}eluݶ12e5G|=Q!&#-JbȪ`u•3V/cQ5O000edYLqRRbKf)ge9JsoDSq"_o)4:(5/x?mJ 4`/VFc!c1BXv|~>їJE=eݴtrRʃ)#wQu7;sMQuY,^ǶLP7mÃ9am%k%o%8O:E*gSЂ" "WuUU__26LD(qێIPLJa sC"Dzc7sn.-7jK.{RBؗbx JNzZ$!-nVIO =Hd' Vj 'sAy!RB}:b'_ko)kT|uUcM3S6?5|X\!8īr&:n?ԣN#9 ·7UDYG٬: z7/'wR'CpXڗD>B0x4N437UT'L\2ڄ)|13fi5S}8th'79ɒ I+=4?IV'56 YBSoNZդi)֥9vm6YKFD w.[HK"b==& ޥ81+Mj<h7|Ȅޔسg .xz@"m2\9d_v68MۣF}vn{ ,=_%=䇝@`\zaƜS;GRiU%fyu@pG1GPտ1(mŷް;χ'ye]F}' # = Dh/`/1zQkL$OkNӦ6}JI~¤NS!Ep/nj_G!񲲅c"0HiE&"M?#HMG(℈Z'* cl)1boB[,MXMGھ2S^NkW+WsyEĀ"P{:`ҪW.jDxt_Ws=DVt$=Jw‚%3.e'պZ}{"E6gƅvS}9L/@nOq`uTzzqɚ0Q6-|[{u9+'i0 h2Ha𢙕0tcTгždj=l,jG[> &c ,i !];6_W;~#Kܱ1îܰŶJhW^߹ɈwMZWz{nİ o zVkxo[0}BB1|NVT )jMcV"(!DGSjx9Wy8LKw2wѴ$mg<- *dѰzi8O"O 5V|p^, %[9S[X_e+adV b;"V\Eppi~d(l Iuu,_%Mi}6F1Jl'uft&aa DPqvY@s FN-*E"c$G`H6Nft.Vx-oac Ek6g_;yuwr`G%d"I6H>"*HTODŨCĎaJm.;QV"0kf<%%u8Cr*Dsfo =0&fv7!K?OAm|*O+x?Bݭetq`3^VMpORm%3 xpKLJNKOV4Mo.,is(k^-oڥqb"(n~}C*σhxe)̦@oiMeG- ӹ6Z_*Yхݩ^9$SP1L kФ,o%*|fN3TgZNtqɘ49J >}1yx?o^S =;-'ah+H5$v1dqÿl/W ΊJ s_0S8179lV`[]RpzJe>@yWIDPe<$Z><;K0L/2N?y26rPaEk%[Gf$ [@zJ%E3F'$GהL+/ XފHh}}i%<ʸZ.De0EWI?el{'Ff8?4Rvz*0vx20, 2ơ@wi(igG\G#)l$P$ⅴNLirz DDs5"W[>OC ,w˽>C_Gơ?U:Kux1ы&)eSሐ˿3OOT:(3GX _#SJIG.قեLSI,&TS_V 0,~lv$x ,HE|K F$!o$M 7m}y{\' GLf7/oml+Ф$X- X X /dCUB> 50م)GaS r i;9i~dL7^ N  9z˜Y%Hl|}V-HIFЌ - ٫sLi̶hV>)'.&G^ uzLtc0v" +:oaEIԭ V$KC Ԗa­־EWBgsZxg 3VT<>ZH V ?%%79HD!T(y{j_LcZLY/Hfx\<&h`' <&: = %[tmHrp2 Upj5w</ʡ"15Xj'_#X ĴALsc33quѦ80pCуfܔLC߲s8Jfǀ͌?e nkڞQ$M—~ә'E 8x#\ɘ(:*ۓjAXv$ Ae411 J'Wc%iCp F 6݋$2gGGNj4ҒW7*‡;eʑxj\aDƘXM'0^ 4o̘X1JQps*">#e>ZTfb8(=3G ,CzJ8nBȁ VF:%mP7+f`uBR! `{O}[':^/˜O:c*Ԕ*m단\ O*u~R42Vʊsw[) R\xAB$evp]Tylkly!* B3Ӧܜ !Xoc'2}P`GUeSlgE}reXi168:'110E4`8xn @#hYA1}7I?-sX(}SWxJV# S!#Pf(hdyb rb}s٤ INׇՓU''CB zL.@gڷ>0VՋ(*F%dSYt z-Y>52neA#n[fNEwB[UCD((;|~zjFf!]= $#^S/=σJvD1[j*ެX`8~0Xy 7JC.TʥĀDTK S2K \Z4R_B*a~!.}!R~{f(dddF=U?{N8*z˽/'w%uV\,zrNAPeB)v&?ghrFa]91dNL(ApF{}Dy>sQB_OхB͏-b "kA^;kT˖ {TXħ,:vO{(_]> 4]68#1mnIcPb$?DRl@(ެ .88%lSa-r! UsBJ=du3JU{4'*W A4X&&w((Ȧ 6OG{F xj/1  _X;(5bG j./VP96I\1j>Wq`9ž쟃c ve=&!i^A>eJ.:[X4q%NP2]a4E`kQ$}-4JZI*, ĤĽU2 N-FG^'6j;`s:NX`C XahkD/-8TJ䛖%ɐ oa*ݻxI-](:?'͗5~#|(8+"k! g0T4#3[E:BB#)0U>K5Xv9s%O'ę RdnTn(pvrK<Τru}am %5dHp(01#\U]|)!)9,ϡ$۪ӮX(!}SywaG=Bш>:n[%ͩay71!םƭ)%?˸J;ʾ E{rbޞڄ+"ζ&5S=NLZ=I%rD(5(*+(iaJG "ZGU V뫓MO }/;i&n .pE˸z"xͿn!0)vMD6>T61T&h#)_/%h&NMӅ C7WQ:%z<^Y('URo*K[%e~P\*6TZ+Fl`iqR296-e(9x_ۤUS'v`@|GBGOJHV)#o6;.t guւ^*NNk$6{ &$ptLR:<6!%e)&RFcU-]ھL{L$5DhFIl HS ۘ?dFsY6Y SR߅RF>#f`_ R !jKf7/1G83Эa3rUFv-ߖp*4U@p֒y3Ұ/E)%)R Is a` sbB4\f#ZKeM'Jt ։úELB": t΁8CFF ub܄h"ie;PĒ"S$:+01|pA)1͊rV ߌ6R;%`e(Ӻ]BɝY.My ϗ.A"i ޗ\ D7?l=P7#0#+b>QiSi̚k}vΦ)͜!bk[A] ^ȏ52>H7L qt,74ll _\FxŇЋk i$!ް&*)_bn,ߙ}ިHU"aZaBׯ*r KjP8A@WOrJLi.U7J[G>2sejWzo4ս9L:c5, S^֒7c6XfG0;!?8˺t%w((>l C*NHg ]j@ L;if`b,JoXOAJATA-d)i@1_jIjQg:JjZTग़vqwwRѳ8sj<ՉXd$/N]a(8ŕ.L_krx<\{C٥DQÚ܈] ^'6 :t+dȂrHaM 2=$ ><tD"r@'rU}51yajYa Zڨ):ŸzUA t)EσDMBij%ϫĖw,3i$v0-+_xڨụI}ӯ܌m{{V~L ̗-b7ST\3jוFDFzS:[_91W NW)&ƟӔ7 MH H_HPzmί>ߐro LJYљx^@+سʭ< u fD 00l'v}g H+tS H* x4pٛՕ|FoT'ZMCd (;`gׄJK/c/cu1]4./LYEv--] xC0xk(f_XیLj˪XO+'jAtL뒢W[qCML<VT&TY8)2G, o`9Ocj{Z2C4-@pNXDk w p  #pz/&4+x ?ѫ}\b!YMȰzXVjSF̍Jbի]E585~I ѿA'O0_Me$/Gp x B֨:3Dsc.C̸76=1isHrU23gԆcG'3idž/|R/nSD9.$>T0dA3|j4 aU<<-T7QR · E׷>C\I8ذ|Ǣv(`TGx `P}h) |qT]7Mr|))Mktits:Wɍ~i?Sh}\c.i+CG5>b]m{: [&1ݨ{;GKcc,ˀe6"+te 䄊>'m B|5WDŰhf~2I;#+ C@Zofہ)v? U ~Lt%32hv-Mu~$,Wcԣ饖УHX 51[[ Q+=<6RRj˚͉I@Eh8ϣ }:PyS5q:9!Յ{z@' 1 SyP;h?c?c3rx"u%hTsZKK Xh 66M@D5xS]5g8f訲*̀D:o$M2Kk,>Ú[$dܔەt!z@1/[}9WGп4clĥ e>tJs$q4gi̍^`mؑ."qr@B?!nx}WXIWU n#Ы,ΑXV)o;S$~˰Hr_ NGgQ86`,>8נ;jR">2! u.,.!En51k/\ R@N)XT|:=SK+qQXo*-֜Q/|C_ڷ/Gh%([2J.-x2uu:&I͗l2 d[-`Jt/PC5pu yn;ijFV?TtXdS)/G̯r&?m~o@_Gh ;mC+W=Y~x4"3C6yʜ6PM^|=M*G}Wj4Tgj3#4t2?QiD6!g%Xz!|/>t-hm:fSӋ; *WMzyPV(i4: .ɿ6-T}lV;ЉڌF]Q~6!K:\2m{\U͐23Ֆ8U7!D.QEE4lW3YPBSp8>U;EaR AbbpHSE-y>h"@wl xCwѽb{5l"C5%OLpKݢq7C$AWQR1R*H"C)}q3huEeܛ#E5TҖ+i20pjBqJZ8ueU`6IX`+h":0 9*|(JxRRIǶuLOCzZ@`&?1Fpj]n}#"$&Ub%ᩡ8ĖqI4$yw E.3"be}$C +ff%-_&DQ?6@%wƲFVq"D'Oji*(ȀŹwg|?m8b%Uou#L(ٰhiEIv.%OJ1Yېaϐ᣺LDbXiŪ~=ΫRH!qp*?D"DQ#e__:G~8] E}e1$SRMjtq1;ZX|"¢EM*2QOL4<`Ek}1vr{4LxRIC@t("hMUۅ#mQ/ "4sE.~6':Z@pK>94Nd1fqԍ4ijpkФsCc.6qVߍ0m;[btLAC+y\ Xf+Yu-w-CMpL*x|E^:MY!|9LOV80XD߃{ܶs 4$vN,'+CFԭe|?~Č3r8) {nH%ѓz.QCwWBw(e+'GE庵_c,@qA\RPU-C b64p >1-YjF'H{{iAnȷwqMĐZTV iE@Z q÷RvFב^_X?LGc +hTMZ5 !!J44i]9u%;0x0URJY+҃x ?jRQD;S]!.uq&вɃ=:](X`ɢo HHvAu-+'4S$\_ I-^ mpQOFB@T m63BUyzyDl{#) |գQ:C iJ7-AJG[wD e }gH0PiĮ/q(o"h2;|{EQ}9btTf/ן`p]qgRKDU1^j4{?gq9t|Z}QE 5KXE;HjH|@| hE2@tBD2g;m:]>صasegsZ< ?=Ac " ?H тJQ'"JL."$PFH0Ƈd 0na&{H"YQ ;.$~X$P:59Oa^1y>Y>ޭtBtPVϓY1Ŏ{ 5x;F bv9 ]X&[7,$ae3$6Bwxͮ,# t(pmc̐> [4ypj2tQݱ(㱑@WHݔ5hUaBɓxu s-fgtW2֮:[]r`$"B)D.}Ө5`i"W,R}о$#|'\HEpusiJY60z=T/=6!oi+'Eۛà]tj+}E_d9)e L̄_uYn) iD"+ -`Ab=ⲹ,yA}y@^Yi\B/ H?"?oo/\ ʤ(y;A1*?:X>PDh9hi󑢵԰?z[(uI(7 !F)5$W%#Xjn-e,1V10 ^&E(-ʋTPi dco)W3%d;zٰ5t!HV`jNdI{ڠ&h\Ih͜i_Ee]T-H铲cW$ea n+ЫB$Yf_1 xgeiH]]!Ue@qq5Xi6adjswpXڳkEd'Rfie] z,h ꌧHbN r&۟ Jj\h8maIdA)7vP'IsMTbŌN01uO)mRND8%+B ~ 2DTSNj7P IP`mϢWşcaQhrvҹ9Y<C )aSb:䈤&Q보ewT7 ((ww:B7I1-5 js(+H it ܱLIFm%7 VtC_$3(Bjȸ$=.S`YbiZ^$"Jb@g:y#NY"GJZ?-rYrlx'tbZ呦 >05- [6KMIBt~z4uGOekkvUWm`u2SW1v%+%QlLBeٺZl=`h ; ],=BwF,´TAn|DP9}ˬ,uKk fz1ӵ`Ww~9NTzglO6~FU6 )Ɣ*R۔/ALF!0cMsTkav6R6zPJ(EI˷yŭY/$`j | \[{Qqsme4eM:+YXXxӜ$&%?@; AFveK6ml]2s7CE whj&X!lU_,Yp(s9>/%C%_=ҜgؖU'NSzx(U7WP7ePN5H $|)`%|ƛ<ύi@EU/|+ i؅M2 EƮމ(YATD Y:LIҰ"F(PsX(& +B1Dqh}ʨ1h X%jE}rDhsRZ4e-4W-mLhmܬD½xQq]Ms s]Чe$*>]^M@^(ϗ?jHP{F˩=ņ[\؏cSˊYs,zUȦoT.YyM)Y=X$@ h&B92 ].# (H*2 ~m3K ʩ$ LZZsEJ XV5+˿x16L%kl{*QtY Kc@{!}t7(*.*w/wÕ`)s2|=,R*2r[eQ$n:o`of:P.T,+r?U r#P(z0j=Qnh >Ҁ86Jt&j$ʵBncmj0!$+YZ Z{8?+cVNM׈Z[675 08rv֙SÛгa|QTKg_ ëR=JPX i=lMVA=q3ViI8ju,XtUS6jg1#MgHx)q,[<>A|e{Z|Bc0(Z4`6d_5wMthX."2Jw_x}B1dzMx5*ґD 7<^U&B=t0^o'5kƦ#oI†g`PxV*H*@5 oCWIh7TŽٷ8l]c(D`w-MN#&c(JdK!JMN%W#~Re-g:k8>28POAJ#M”ahlɾQ}&oZ%91Rzm-bE+>v;"k%@Git.^D,@C5Zb=ǡC_)Wig*QG^#z['CBDvmf_dmV1Ȏw %@40;/r3>dzk.DDñT:@F;LO.CӡN5dH?au'[6c8J2\0椂jvIП^~1+9%W÷*J4A<,YHV5ُBHa sv~qUێRon>7a(k T6g[`B-ftP"`!{E-KpMq^!~39 WJ8mB ԓg bu$jDkcIo&VK8yn_d)E8Fg#V 1#.ɸX~fc $9˱cS*e\\‹R ~iZ/dj4ơ)e"U8( gH.-2峹AwP^֨v G:3_HI UGкL=@W: .hlX=㲉wNLNAh&^Q\:Q! PQL$T;n `*$$)V^.as?ɹ] Im![_ [)P[^٭оBB5f @9wR<3O k>6k4rh2 zUZ*I S~0F}~Ry\`X990a<@e@ B$5ҶH~ "ՒU T jprCBɗ_WӒlL`{ԍnD'FŶOfJB# 2.cWb""Y:HA=OJ N>E/BHlSF;6( z뗐*, ar0"*Z'Kͫ!K E.$P{'·0׫QnBaXc8kto$M >3WC`(caq砠»\vʰ]>rRŊDn !F=_+CnNWn)UgȺ]H64u4"NaIp 2VNWE7ngK"XÝFv1UGP N!1XT|D;cC+_s-\J'q0/]HWs3ê ;B'D Lga]g&)8awy# `[ʩ]n*r(]36b\dfQtݟPX}#B8;L?g\S%J7 Uf!SGV2jh~ .B~iĉ pDw|paI.{zjy%dԆ@~HvA.ޚսL"!q@GH cա(+eŚ|%4Q+hjc׈Vl'}saX'ճ&mlsp $BSK[!Uh`?AtkLc^E8+/WɅĩw(fؔs:XHj=Lt'ui~9qٗ1vcb&j۠wT8~Rz#2u^q>ҏ Hh^_xG].Cj6ns-z5M82LaoPXAVئfU5Y 9; b+>[PحVOE&#2ův`δƬ6 >6se)>'37ϝڃ lg=#(ϑW߼ WN4g*ڛYY?P33 dZ2֚6u2&o6^P Fo:mF .*^r,[ u[`Jdiz0 hL qKuP$M ]( P$}Ѷ\eQ0^횈dpT{&0xbAdmon)b(3K1i=aj a:%:Y 3Rzz '+J ̍ceq~oJ6 •$K"a/pΜXʌh q") M$ V_k 0 yX]llhf3{mU*=؅eG2<+wH+`+2K:G#PVWDH8D8n89NGR L>05X9Bb6_+A5z4:@:ɼrlV8KC\ju.D "eؒ=ȸlu-_w?,&1jiz[ vU\5?LZ @9 9I<);Մڡ{\;^pvhq^ âC1H3} 6tH:ũrm~4Ǡ1AY7;B]{ W <7*=TƲLvbE3ɇF$l`c҆dP'{?8,/'_#}/)ە\~@o5. 5)AvS);9-P:NlsvgvԄjfl=U\'j0b=$n2>Ӝsk犜BlG:n|vg~'V*mPCiHMW_xL_õh~)aFoXv6b2PTN+IR$,\P@uy`Q[¡>PT005Ԡ/ y%?s+Qb+)GT&ػ`)4nuZŠ X"衜#-Ge'OReY͑2# .1ٺ1a-&Ĩ̈́Ey.\6֬[*7= R2(/g &H(KW.c@›5;Hzw<2Z@rh m筵*#d暑AyQy22'jі,OZ~mʏBwmlw}~2se.G`!"Adj!7a5!e,AK&l}MLKJ^Ѿ ?*̆,XY}AySokp܂z5iȬۆHR߲ PC%GfAq WajFx`VCF ] 싨B8N{Ki{§PI3SPbbq )1`+&*j_sLA)S,YX*FOĖ1G5T&bQ%*U'E[+*)&R {(х/nUPMUpqP 2vR2) rsM.2> Ong @HC y{"LZ3 15:\;$(M3Y̤d է*jYN&c,ljш[L$?"1NYHYZZӣllZY1i: nI>6YED_Z+šKC->;e:-laV ?lVGZ$WA!nUj}pAiy2KxzYtLl Bm%P`|=|]ܷ?3*V4e W9*2Utn=k ,Br=Y%>8;I7𥐃(2OJ:p%g3[^J-~L6ӺH‡[/݂Zt8iY nKbG<7V^tUwЗSƔ!j\dݺ5գeD"ؾ8u U Lp0pSZ)g e\x#ԈM:4`V+#X"F4.Vkg޾>ibD*mT)W4&SGDBQZ&"qZ)F!؟b+;ፊ74}t1]ۈxήڝz3_"F)jl2#{PY:Y<D'Ty@;uI/:lXB^mj:x-p\>0TvڻSxUNޔ^0Y9Nc̿&:miUA,8t+MՕz['ToBh4sؗb 5D Ěmԍ$fQ"JӌW7eؚÈ(.,9fWRP)Qj!YSV؂A>>BG8 qrL biLPwNpϟM l*d6 34F-2zptM\mԇ< T?(1@h%a<,'s(kϩ䤗ߗ2 fqcETY`шuK@6&s}o .n/jquf}ꈜT%lJCn_TT9$ʬfr.,ARpgA2u1tr#ڐGQ/[QPuBEr !=$˚{( :\f0 e2Ǝњe֥t$Ҫ;?.*TQ1)0 *id*X QU-mDI9qˢ;)Z#"0%*l뢐CBV#YFQѠ1mA YJ#/Z0:y+QCʃ*t~na @,o>\Ba]cg n ܌HgXGGRFeFP|>DA:,1tw"[ Z*r$dT,®plh'1Aߨ Hk#đ]#Ht9s5sgWzTit>FzƼ~Dtp,E۞}'tm_\Ka-{yedDhB$:Ğ$*2sZD0|E}/ă>3=O8>ߕT+-*NM;3Op&;fhgMԧ1I aK͇a$3ZTW Wl~q4Fi{7D&BPQ 6 oDR9l?8e t!`xk.´6(ϪC-(U:g_)(*[GK>lQl9f!Ŵ$4q\wiGfa c*Wy{CJgT.\{]]h Ѣ(P_G> a)$Ψ1 ʎuׁQ1ޒ Lz1?[gZc&!̘L9(h.B]S6Ȥ2(wJj ƙo B7ҐQr7tJͱ\ WynR|X`Hb >PFSI SOTz5ȸ+.}eRKSr džSSvOj)Nڬ؈.JI HX;qөy Gx/F\]Ct`9,!X2JxF?Nj4O%)am%4m X4[$;vyH*b1nG' q%∑}8E+RLC/Ϗ*! l.4k"lz+/"!4Ɲ4 ZM6%ND`dZL?2$+/bgXF,AAZZ˫$e:2C1 Q _`waM*oWJtS15q'T"Aby^#i-6r]{V{H'.5 UW\VIP/o}t"hRft$0"OTy#Ta3˔q*>e2N^8*"lfi# Rpq1W pr,QyJ)Hޏ SPE ݍΦ[lW. ݋{D*('ތ"tNX(#cĸ)o 90D32Z:Y%ίl cv^_.pnr/WѪOi8̥ȯΣ7~Ge?ڮێ=7{(4l.~ϛ"d_ex%\ZE6M+DվYtmOCȖ'>*5LGC5ڴ=9]NJC$^B>{\Vm8OUMjm=)FZ`fw lV:hJݛ7a롅l^L|"z`KX'Il\.z2r!%˒.j5.tT)g9m'ZV(cMMxS<<>ğq,O]z03 8ȁm+VixPne-vG+ȏ8͍7Bbʈ./a0ٙxk"&j.GLğZ#S&XE?'R=;&!GMJ́dy"ʍ1Yo7{7w7LmWGjc6Ҫ;x9KL>ⶽ1 Lј?N_&jYCcЗ M̘bFpաا2ẺAS<ρ3Cvf`1z[j{Ե%Sc^qzϾZ I@>.Ћ`th1擒Ԟs)|_xBR BclrV@v[_1b 3' MqX+ĚM"KVY֧]ʻR}IjSuS3'vsJXD k>Z ɻGP iFXrEnz <&|'ʔ=wѤjSN:1(ʻ@: Y5lϚ6g[OL}b4U Zm0'ԋ J]]9_x6O+PnT3v|P@nhLHu–5E+;({z1D7lGWݱ+Z͉8߷ +TKo [sC '/гb^V!F2Rڿ$("ԬU2CBBUW( [W%E^n,i$>ƮrɅD;ߥb^/Xvl{" ɍ *n*v_jy QNżP2WtVb5mp:CI^T3}vvcOn,3r-^Z0ajy׺t 6kaK M,`y\;,5L3dCqpG;Ijl|`>pVu!չ{:3@/,ͥ\5AɳxI' .e5Dr8Ƨoǝ # S4 \fjp/ Dy[/ϑS~2*M꼥&ifT? gdr8ޟ0V7ALJ29\QM8i6鿑aNnMnKӎr~S<0[63֩T3s Q:ԟfZm 7+RMv2)648lB<#`q1W" >!hdUrDkmzgڍgw- j) ŨNe\wX@S82m?z6M.>(:*Ke&iINw ZB{P͹EM? C'y gm潤{t*@|d+Ūnh^< & ?c! l6yR1% (Ԝq*Vk~EH dL&Z3Dz+|L5D99r:f.74_\ <*z f9 M矘nD'<|ۓԡmy߅nOχNh[ Cq}9.m*Oxiںcds_%dReč_n1LleNWN=(FPqM0Ȭ Q (8|0(ciH)jRH$,]j/+3) ]쇫5;f\ߐe3&sNJBrrW>_X!ĭ8no9)QPvat\gb/^kp#y'[eVaׅ&KZ[~Z-YDf8̎R>rI]?aAUuqg/[/غ+Ϩ2~k܍ZÇ Vfk([G 1!K8 E# 7d"PDC'* 5 tUS)=;@?jbY$:=;v[e8ҧă[[!m5+1>^uU?VuȽ]\4bUf>PNk$s%= .^)OoA@͋ KG3.}ƙ]O%HtT津,0>[)U26g}Q/fѹ5Ul OEU$-/(Ĉ R9.Ey~>N.*Dg!ݖPg%!BRtW}w"S{DY X1+Emtn/+bAř\9,*.Rq8)KYdh5jj`\xL>=XDg5d5JpR7{ˎ_@ˇlM"?Ds[tsxX.9ju55TvFAt*QhZu×my:-,0ƒR:L7ߨdzHjp!Ӎ2pk8L1y6G;B,I2t. ԃxkoRΕ%i:g&fU8*EYZNV uzw\` 5q'uy0V[5\I+k{kax+ըLc{P.e4TuZetqK0:^dKdžzwpra0t_5$buʲ:&cۀ«T42mWW%ZwGOv( hHd" "ҨU'Pƅ LQ&Ĵ=icYm0ԩ*9f Sɤd_ KI CPM+*bd2`Z{AC<>v"]ST׉΁X{Е)cnz`qzn3 ^%#'Đ)O};/ea>?0(r;:aM˸](ȐK/GL7+ogajB΃1F'$1 ňw]bpW,{-_b /{{/Yu@3iLdD>cӮI{Pc'|";)z̩M,Pg-]z՜tVjT2HB3G|9)IJֽ6H^e (D[85,ɴ6+6# +7_poFglwpsz]7 BKrsԺY^A4d7$PH:6Q7qyfҬʚ R *KK)?[L+]~Gp4ihE,Od!QM7_ivDB pLJn9zê#Z|+}L9g!AIKjg5tOd^'KIu.0mܻk4+yeF!-Lq#Zc`K QuöMgٝ`?|ݔûA)ұ!㷷!(D1, qKfKwW|4>jo1\Пx#AuUI`YkNL6ߧMgDd/P$z]_Y]ҟ0 J]HJi$Rg ĺ 3_ ڠ/*I?lӚ=쳢"aP2+f##( vʰgA.o;H_2MnT*^$ ʪg*9U|\Sn>#Vf'O{g-NklfSa)'y` [hS954:#e#gCەE{n"Ye?{yj5jʴzakR6͔I~ۓ˶ij 1q" uE;2mZ6Hl 7e%RZ_Ʋ'n&B=fF9@)n99-Iծ.)t$wW0 `?f:DA6z 8jxp)֙8u.d9Qu ?t/ ,fqRNڽչ)4{֘Y:4HGJZ :<\C[|I?W~zkG>fJN=ү̆u8&,%\~*ü"]3\,=gQ;|kn+x#4wd[9w|"mS Ҟ$wz0UT)Ĕ-N>OHC?h)L6J9_DY^8اZC@tjJl%YMS:DPA )X) iS3|F~ssmwx>jW:%@BܤV ; Nܹ8T,R"/ƣoKɺӿ-aQA)ELeà$Ҩ$V\nL~} S՚(:Xg}tJ`jt?*D`HAuE]]jlaMՏnUM /:D`}'%vqqLOg`[%;_M*Wfݿ0٢879-jwApz:aԪ=T00׶Ӫm\nQ}ٽ!au4HuiljGD~Yo4Yek Br"H6}%`+ }'xؤ5BlLʠv^92zw8N(mj9j^> [k_ws-hFX)Ol_0'd7] O}kQ9֓W!G4@Xñ/VДpJ[%oCHRw jaR uy<߾ 6F%"l60Ks?ch]bU&`tfNZTLաb)NQg4*CX7Hc] TT.:Ɨߗ; 8Liُq%1?҅!FOsj< GQ(: Yh/((Kf,` v00P {~t7m!D^J_%9+RbN?U6wN޷vL%1_/0K*;:ғ80 TOvÔ *p ]P8%Ofb% aȐ7-q9]Tˆ^:ێ2I@\4ߙC_Y>2h:[yr5 r'q9QiѿBN @^PUbkQJ#8!vߡ$=Vb^Ĕ@Ncf󃏊e^MC]'43o: 9!Ð銰\WD}JFTJlv$/{6ءҬ#qYE熊}BdwV8o#;.f%t|Xnh+>N+'O]$"1^66dP rkڋD>j&G?OKFďy~&xW"01.8&[J ,aUJAs|z/1T()#h@61.)peFqʁJH ْ#Մ- ieH;.g#w H?( _K})SW-W+} mb>d`A\/jOH+9t(1}UOY[uƇBƋ Ep:w&tXQuVg4ˀ[4Gb0+|.B0, f\=`tg[U!dck% !t\N0B l<8vk-޴D7_Pp_`V![틠e(l43TYyU( )s,)&P?"e:y]!9;@_z2~3 g_qgA+> atN]3t -!,QJCHS}"^fb/U/,]!II# C %I2):l.TROj(QRstsS⤟#U^e9%{2ks4.> U52]?QD_j{F~ $>e(0U:ɇLMI}, a!?v[N-< zT:Ge'įm7X/[CPtlASdqQcDFo*NhW2,{WXY!DX>B\XuÝ*9s/[}xvcڟlS#"xJFD_z>@d=9EWJ"Eϲ~kv DՀDR:ޣA`ƴ7^Fǖ{^ ki2fcNd&"q1K{@D]E x"N,?f=N 3>}̭c* G]kGHno%UW~`\G'8 ICbvJM<`FM$H=;z\}ޣoPFJ~,)$˦>74^QQz$NA!H<ҖuJTIKZ_4pGE(HH2wa!Mhi{M?/&q+aPzk UgGU)œSN' C6v <"4`&0>6̡bn`8gFbG {ɕ?zjZ(2pmYdQhl} ;,T=N}=67POaMx /&ʼnk̠YT[Ώ|L)1r/ 7XJ]0i\y,3J{. dWA3Ŕ"#Cu-RѮoGhŇ:|4YױYߩsH5[u?(m|Pt[d@~ ^x>TWEƜMӼٵS8p~a"-DD.Qy5YaE/"BO eͿwN{/Q*^CP]%ٖ;6@ed>CaBx} !(-BLj=j4.8ixBi58 J;jtqqcJl"eLr& {׈h184@e6І)'tJЊ3` !RSm cGaeG)`]ÑjҺ΃r$^MCtW{Fw_< u}sc]G!Rܤ|XX ?[彷;' abj F8_Tgruw; O0OigH?T9CD`Eb&QOlt>~n'Re/+ܗ_;HTy3#wÄʅBaX_ߩkʒ!,atM 0:o?"8? 2+7FLqר,rZ̿kd딕VBqdCJJJ~ Q!LAe"G?!׍ٿ-TV7K=g;yqQ ɼrfQduk %ّ,oכs}a 랎4}sĦejtUs r-x!j}G[NR Zצ4֩]%<]uח v 4}k곟bV9;Ӊ@2mkh;#O C͹k(Q?ܭ.N0}lk 9rGQ-qHàUp{?wjl%T*<\ɯ1֐xx&s=2]dŏ},O\E02^ӄKu&投r>t+8ݍr>j3= sov[PL2,:m֯_sr\^]NYQ,[[{lĻ94^CPTB̔[ٵЂ)N,4IZEvFZƹY nʏ(hm(~|mAmٙrB^d_r@<&$?*gS{XWMhG6-1X~,|QX5(6F6կt+^*I;GWmY)P^n~UW &ԎЅ&temafZ#;XXE@@u{v4ҩg;/AKl Ό~#^`̋;VM%un_e/CpI}Ƹ!.1;g!h2Ǜܶ*=PC_3:8o1G]cER4W/(!řw զCZ ܍\؏ikv9+*l4esuzlTžE3eybښO>( 6JA&`M9fDHQv}{CDҏcҐԹs%,H#eW-wbjɸZ֮I:  5eb6DG0>P8b \STͰAb3 K޲\HՐ3ǟӯԿay`:mc)*@okџw2Jĭ|f+TQ@' cq[WSe'>I9mWH @2I$=D tnLZ|?~j=(@H"0YHBIBJ$*JYd-|CT{Jn1aI'vY:u][?}o$D)X `މe2)e*,j.MɪUwIUO?΄HEa7h&Bk hKRmTvjYح#o_?w@60H$,"`d l a j/U;{~}.!̐3LՌ2@ Abg! ᑮRҘb"ՐQj/ǙsO9mj|Y$ 2K,C8f*P_pVD1KUSʋ_còTenBI$) ) x (@ؗ X (h Īk~~g?@D(LHb& BBR$0G[Bŭf_jW<|-.^|p{O+9HdU3E#U@3U&gU3‘!WuiQZzV\;vח-~oHI91uL@b2p -'}W bC44춺/oO9$2! ,YHJL)ZFFB2ejJ&5g+Rbe\r-.?||;df@dԦ6*&ЛIYBIĶZm۷,Ws#~s-А Đݴ!IU$܈pm ɢtҌmC> ?oO%-ݣ?c&0!^(! TofU'CCPzɔG'gi @ I &@M$Ҙij:ibJUb騩mիÍs}Iih@d4AB!zY!BU&ɤx:ITZv:>v]~C`F`)0 \ ky oTZ˿ϻجB85Qb jgRg)&r+9ݑիsiҳ9~ ؤ[QAH1dU`VC`Mla BGeUCb5G^ǏK>$ݶ0 VP62bn) n hb,m#tCיoxvϏ<ۤC@ "ݵ$7@͛6ڪ@;PʮvD4r7~Jߏwq!BbUS @&$H_*LEb"ZJֲQf&8>R"{x0CQ$,@@L ,L0%>Q"jj[q~'$g35((3Ak&bTJ`|ejrZ5;[VM6Wd}\~sqHCH88q"Q`qN"vӉi&ڭZV&*]mn;{8 `B`0%)auJ]zv)c0+wųqrbHLd!,)! $Ęa+XqڲVZ~ tr;NAȒd!R!  &Jd9TTdW}\R0y185w=|yH EB0B:/™ae }U"_ZZ33[^ F(0/`"^ MlE %m]{9_/w/~ n7!Ya)MZ7 Xi:MW6C{a&`hC0Yb 1HS l4[ea2ΚJVk˷M?'2d!I$(H"̖,Eu1E8(X“a]^~ko/=&&LM1aH,6 A6:7"3iy_/4&B)!@BY4 iшδBThU퍥UM6մӟ[~|wt77 צlܱTݹtt/HZ%*Qű6v|ǎ́!l!616!@5cblDkfɮ)'^f(٪KW%w|jћonߏ=*ò $ hXX$ VM 'IN4')B!5 Nڢmc_7|WK/pRKAjv4)+ U!j&@SU`=e,/Җ6NXv~ۘth@2d 4Xhl&R&l (4jEc*UJ,6WF3Fgw/ܝo>?'örMP"Br,Y:zÑmy ȌS Myw6i?ְ9 ag)$3!K p%Hf,@!*#U3h)ߺ={y}tI͂T`ɺICtSpnf⑆d{mklϗ|'dLLRL"a a,(`\6[ Y…¯.-)]~''2$V b4 @؃&lkE6blAM Se,[_ڷoyo??!$9 I Ȍ!ȤR[ %BpHS)kUco''[M[w[o3vzO7MēE0u XCtܬΩq7*;p)+VZW\\_{7m$&ІІh( VCjTHm6ԙIlK7Fk}>{@H1XLUf*P(`L6PFmT*m㶫]c;}wHCd$6 !؄!QX 'B^d8xKPSMn{[vo7 $s-*3 Y1idBff@0 lo1A]f͔s^>ooL&pBL:,E4`g.C9)3`YUlnȫ)['v=o%|ބ&hB hҚ"nXlafpo64! BcbcP蔀cR(c5"p jCQ{)1UGTUTaS kF/(Zg$3E@I L"5ܜ*57z5EU^y]^oY8SD0Hp z⪨ Sdo`>V={Uݍc0?g?O8~/@! :lHLXg"œ0c8zowR{rq7ܣѐM&P!$ dBe XdMcAdV-Vlچee?/;~߹:L^GE7 dP7&7ӆc|fSj+vo~O9pp1N@Vppp:<uxd J:kk-4s[?/Wߏ}7~Gr$!N@ (EUr-_!zqJBqCQ* m\|uǗw㿣w?749 9$Ej: TF1I-PR,Xr,T+3vصE9.)[|_r>]߻rq~Hj5Sd8q`4YFc;9Yw}bIڐ2r@&LF;Ft4(fȸբRuB׷\k_2_R@^קZuAF@AX h̒ *AC RR+UIаc: z$:sQTfZtUU9yo^OԘc$LI LYӐ,0DP5cf@ =Qƒb:|ݯ7(ug&B@В`,Y4@)ŐHNDδ*hNgl)#Ym)c˿캽~П $t) ր,)6[wMȨne.4U!jori>nKG|}pr!C9E1!ʤ9`' T0FKJZ0W8w}OD&0 d8R AƋZIfQLRRJX1$&,ba"*b)K6TGaе[QC6[loɗϔ]{=o;E6hCtzK0.E$$⊪@8ݻ&rNKTQxjE͑_B88-oy{G8МdIxz"TX8JLCxި7U3WjW0zGjb!°1)1(b"LVcT2!3l,"MHQN%rx̓"@$T%DdV($S"eTP%j\3p]_x+x~TpWkW C$q@ '/c, N(,F$5KfI$%Н T2KBvT=):T\Q:RzWs}'zf0[\o?](8~"yӗPrW  T$z>I`œbZCni ^B^zũAdcH:BZ˄@ײ)I$fH F( T. ^K]>^nHI'AЀ(,[ԈYE ,:"mRviQS RWrWvn>W=)$B{ d "BLIW|.)3Vtpjvmx BݝG0s{GS~b|cŠNj:$CXCxXW+:iks[j)+:Ers}^.sp]w^o__|$o!a@KYI)`o 0.ffoZ;k~vu՝'އ^>>?{>vg}s{wu.O!zH,JFC*A xS']ᖶ;G\58>ozv{ݯN^mIpnI"{MRhwҌ7X~MS4 Q7+:\:U[n~zSG#d$P!L$ P2U%U0Rc UY Zn2n kllVa7\Gqsفx t@!:$('P{)Bà^~t -u: ZRSk\طgs?`lW_?v7y^Knǽ-$9 H#" @C I%!0gےʱn9k8R/\G~ۿ-u~d А6BhEmw&dnElh)BCs>n-c{i>~ݻ?G}N|O4{Pj Œ꽤d؂X(H);D0{RhG+:.;{/p|Ww.y=~oK=mv:U ON As NR4Nf09DNhs gr'5wsr9Ǜޏy䓕>s])RM (Y:j;$ q>K{>IX"y2f1Hs,91HY,YVe9Q(Վe>]^0L@$ EQ! 1!b1XbaF(-T:6a-fԼ 7|]ϗ.qK @H, &d$IJ &@d*LP%"{I3qUwUӲoݫ?m!$6dI6 mY&ذ6Q@)4&6E,iUJY:YYRUacv_ AHH`1@` )&b0p8-BS{j=w?~c!$1S%!`N*IJ,&8 `c aCa1AiZT_!?ՋxO$f IfP3&j)3 *C+mߏ@! $)V7$(Xd&pnWt$E 蹵K.ډZݖ^׽>0 @!93b@C(gy-z=! .Xi4M )M)ҥ!ԬIBEb6C}x͈' SHfE 5<uN"> @70_L( QFJ9Rz_M?qqH8N2(`pP7@xPu\W!VqtUg^ǎwD!&RBa ɂF LpHe2i@~I3QL:psCϫkv}̀e$L!L2F*"e (Ldq,\%Սkj8jN)U{w?s!!BfE 3FL3)!3I f K$͎j1k&U>Ùy7VqB4ARMh i&a.&T\VEƘ|7}BaQULŁY33&jY # ]T5],\Wrk=mpM` I T*Y r qߓ\,Ƹ,&ꠂ(Ck]]pZwO_wkcxI!zI_TR$Eax oYU[ZS}'O[;WѤ M &M, ;<m,mm[1EҫmV}ݵϽLH zLP,,1$fľr,klL{z]7&+$$ Xzi c `1R`LdukamlR5cn.|dI @ꠄ 8HbC58 )/ *O/ol6l l$)!Ma, ڧenVV(o]{t|^@&Z!55Rk0ւ\keգXkZk+Ŧup=ws>}_HoڢndDz!M7uS.XwB].ݪΦx+?߯0BaI, N% a&jX(u9}{c|!n $ MfY7ݺmmKTN:Un(ϣ__ CI$ 8Bpp WZ%%ZWR=z(m:=r{}f!DP QrIS7b4MB9-fљQdʳ{w=N ;k@aU 𲥒L 4`媍{޶3y;|~'m I m ziPE%mi6l6)7ӾY繧5w/oc?k)K$P"䔪@f &Y%!ƄƖUŭMٌϷX XFM{@ B^aY5 ]";4׭]kONϋ/@7BBMSנ@ܨnQaeOމ7ZmU[vw^kw>2dBLJ22Q=8,((dC ͈,Uo-u%_{=}o@F$rɄ*Ȋ1"1$2,,jdU*x{s||~@! DaD⑀0Ŧ  D[-fSѺɱk= `{]}~ ! 0 $?"`/"E5Z_Vǘ_~dBBdbI0D2DY2!%3$1Q2GW nŮb6>־liZzw?||$9EXNTa)$DP'*Ȱ#RR)oͪ.wWsŽrc3?N!7CrBSq!n PnhM*BmUegVi1wà |p|}8I&d4 LC4TY#2dTUal6)sUiwJ}?$ڤ$j,@*M6 a@O\,,6UgQUJBϻv\|XFSH$ "ŚbҢY #:SmTUVڪZMnq_ьLUH@1Hɉ a$/Rl8ZY6l-}j|Os~nO{|BBdBTBe Y2 i(2\,՜\C)<ݸ3:<5$тD! e4c2eU$8ffVg&}]X6dv{_{:I$BObцU&hi q,PM-TfUH2z\ {>֬5?GkWk@]b@,!"!I4CIftRR9j*3Jˣ?J)W7BAeTR/y HW^a,/^k`EUVNkv:1v=y}_! @nF]&t XMۉHQs)'V--mւiOm:~xWЁ  SB44)@fdI9֕TeVZCYݎ~O넄 Z$PITVdD5 d8Yum(~AW׶ه?j/Y@2xRl+EDivr}?6w@ 1Y& `X!13c%X qno^_?$ QXBC),`c1C¤%RLe/imj5TcgɆ_O @E` S@8P0 EֳKU@TkW'oͳr}C Ap`#IL``CJŒIF&1ac[KM9"@2U $2D d&)%H0ʩYř<-jRb U9[-v:{xXnVА6! EzEڊ m" RmCM֙m$lcS0tEV^^~߻`6,EbRbA 5MoZڵk9NZV|g~-^RBB@2E@ 2QaR#+QXR2,헵x9l@$ q1TAQ1R&"d@0!]ZafXmMknCd“adnDSf+!pYٲ)moH_!zEe֠pDRPa?# JZwz}w>n߃;$!F!@4 3h+;T2~s`6) !5; "g-_CWjK[`kHIH1FC1 PK *«QFĸ8|/{^\Bd.B Za2He"`ñPjrJx3Yª>ן˫x?uos &D33XfdY8E3 ú_k({5UMn\xs{N?U I) HA3d*V!4&h C(-_k)*T[>=]{}|@! &,H`:Ɍ%ڊpC]je1jkfU^|<,{^=! IM'Z@-&hBgIchAtӿnu$Q@v2^,:AY:qzt?",S,ڨhpU~]_w;=ݟBpk`` CD tD؛pCv]ƋpNǟn.n?oۻ1@zb"Cą`BLjN.s~BMށ)oz"3| wMS-*ml=~Os|H^ DdBox簆l`즄SZlJu>z߮0I IM,R,XuRIpz:' EӇ5sr9RHfʼn#RIP,P70D3Ϊ5FeUY1h|y|08dbp,# 8xYjGU5 bo|y?/ʼn! V(E"CLQZJ EQ]TUvݛc}oLV=uB)&(b`"L@1(V\p1(ª͹mY;7}H64RTlvY g]ԛ "l%!MuxA>n $ B kdQMka)]M()Xݝ߷/g`HhH MmRTS6bm6^}<~}BnU U Pmڂ t;nnbSnꩶ̬QaqoLvC,Le`RT L!aUNkhKb[|;/G]ɫ IfH!EbC"d*d2f\.PVe.կV~!=߃$0Y 0b#$  pP/X^֠bޗ;.^zvo_f&jSd HR,`Ŋ3PYB31`d9 La4)H֔rn}r!ddAR@KdCL#!C#+.MU.r9qy|5=wI D n Bo v7oZw&oF/w}}>nw!  How5MX oc}X}+~./7q?c!bS$33H^T! 3'&1cVCao_lzPESda/Ős6]q{aYV1{,=߻ (Hh֢,і",dm4doIP=kl)Os_gd5 8a5&k!kTg]j:ʤ{9>;>'uc !$1RLXFAƀR b\V L[QUS*-%Yf nwr<#g~?$4ʼn+cBb L`c0Ccd8W1qZW%w!XHkTNJMa h0:遬-&uK(k5xϦX;<| rxBHBCFHiLK"A`iJL ^n4E+ZhtۭnNˏ_{;wߴj ThUӴ-Eګ6d46 f(USFN-Cl˽NΟ7zk<gH$::E Q1& لh6_l=y5}݋<_wċ22P ZLIEdBqnya"O[wf˼x~.?KlB@)SkIM2M6"ɶD,Ttn_/ø$۹0FBMJd ܛILCn1j)hn7u5nt~Mݟ:JM@w7ѹ7* g%*ɵ.j'|g} >#>"prE8P"6M<Luminescence/data/ExampleData.CW_OSL_Curve.RData0000644000176200001440000002624612517732767021123 0ustar liggesusersm lWYw՝nUݪ59SbH$Q lQF[n 4j-bkP@d !$^%yq:owoMMg}NU.xܳg/+*ی;PjI&W?wWԵn^wݷlf~J+W>;ߐ͓o{\>}ۿ:}//'O_5~ӛd_gG_87w37]o'ӟ>ɁON&79O38>K3}xq||<_"Oח˗ *_%__pAo8ofo7} B0pJnV-Em68o#߆ppw߁88N8.8.8p|=8>߇p\ @|8/0{7Mw37=x!ou{pK>^z/qqqq?q?q?E8.qp\888A8A8A8!8!8!8%8.q Kp< p< p< p<#p<#p<#p< ǣp< ǣp< ǣp\2 e8.qx x xp~sU~q\*\W>|7 \nϟ܀G7s?nu~^݀#G A8p# 3p1 3p1 3p1 p1 ,p1 ,p1 ,sp1sp1sp1sp1<p1<p1<p, p, p, p,"p,±"p,±"p,±Kp,Kp,Kp,2p,ñ 2p,ñ 2p,ñ +p +p +p p± *p± *p± *kpkpkpkpñ:pñ:pñ:plplplpl mB[~|? F~ㅮ]zUz#F?_yBozи!g|W|nyC.a8p# G0a8p# G0a8p# G0a8"pD#G8"pD#G8"pD#G8"pD# G(Q8pD# G(Q8pD# G(Q8pD#G 18bp#G 18bp#G 18bp &pl± &pl± &pl± &pl± &pl± &pl± G8q8p#G8q8p#G8q8p#G 8p$H#G 8p$H#G 8p$H#GI8p$H‘# G$I8p$H‘# G$I8p$H‘# G$I8؂c -8؂c -8؂c -8؂c -8؂c -8؂c -8H#G )8RpH#G )8RpH#G )8RpH# G4i8pHÑ# G4i8pHÑ# G4i8pHÑ#G 82pd#G 82pd#G 82pd#6plñ 6plñ 6plñ 6plñ 6plñ 6plñ 6Y8pd‘# G,Y8pd‘# G,Y8pd‘# G,Y8rp#G98rp#G98rp#G98rp~\_~Տ/~?NǛ[~?n~׏?ϑ|S|y̿̿g7??/p ߆mp>~8>_p-_8n{p ǃp/u]txJ{Vz _W\7C~n*ȵ}zm7/כzne.t B~۫y{z~t^[?kCnz=ku{:VOמaݎuӾst;Q#ݴ+dݮmX'x@ںiI׽:ӭF_o~]wJ7pխ[K7>U>;ѭusckrԭ[c^Jךڦyq蓢/9>0-,q9;?׆rosWjz s5݃e敺upDz'Ϊi+!UFnegQ55Y{rnX5G&49^\6!9G^!=R֣ǒ3enWksQc|Yr}f8e,ՊC3,')IG3f>fe7ϾV>?1ys1k>k^r $$ȓ3o8_st'_p͍t_J=ֹ×^WweI^c=7|ky˯qh㫟g>?F?s }Nx7o|`|{w>_|`y0N<o|Ybp][&߅Jo4ۓqVO=c;uŸߝ|W=Uo~u<|"78.Nqy=/s $'^7}N7x%םqg|nw֏˝Y?>wσ;px];T׹~] ?O.oE8Xc %8Xce? +p *ppñpl#sg>|}}8чO<}ՇO|}'>oo/s^8[pXpXpXpXpXpXpXpXpXpXpXpXpppppppppppppppppppppppppp8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p8p;p;p;p;p;p;p .p± .p± .p± .p± .p± .p± {p{p{p{p{p{ppñ>pñ>pñ>pñ>pñ>pñ>pqpqpqpq:8888C88C88C88C88C88C88#88#88#88#88#88#88#88c88c88c88c88c88c888N88N88N88N88N88N8S8N8S8N8S8N8S8N8S8N8S8N8388 388 388 388 388 388 38p 1c8p 1c8p Ä;c>pwh]> u u䍘ˉeȏ˅}Kܫ8]^~.q_E}=}# 8ȟV8ȣ.8ȧ^8ȫa8ȯ18ȳ8ȷ8Ȼ{߽xs 1C| 1C| 1C| 1C| 1C| 1|C| 1C| 1C| 1C| 1C| 1C| 1ǐωc>Fc>Fc>Fc>Fc>Fc>Fc>Fc>Fc>Fc>Fc>Fc>Fc>Fc1>c1>c1>c1>c1>c1>c1>c1>c1>c1>c1>c1>c)wtZ)Ug|JL臔 +WjyJ-I)Qjn붤ǸGOσ˟[KuݾoG[=UP?s+GB?~nTZ?_ۏ*^{nF?N~|nZR xUz?^z}kۡ'鏙_?j>`,o'(':Ӯۡ/ǸC2NѰϫb;2?`njy혹ǼޜbnO.\M^r^}:W9nkK^+3w1Gh5Є} wcQ~X'G-O<6>sOy&]}WWDV_>sùCk0Fk6^\ >}m1s}r܄F~øu.?Se_UȥUϨeԘۢeoV? tE7xOb̕W5S!FYu5]yb0n8SRSy7륯BAc@ĉOTyf2-y76Y+ɱam-EJOwyY;67ȝrߛj-ZjmIs6Q~.>􋓛 c{|cP?fI' 49I37W57+ބ՛7s?|1V=\cb%{䶨kzH~pywG9eMȞY#foL[9w.}[];#5s"jZ6J&6ͩr?]ٓj~do^k^1,rqRILOǵ0&G_kjKdexs9KHܚ$gy5CWPEozcrQ\H>ZVeeԴ Kw^M皚crVT?VIKfNS&a<iZ*k5=Y1Or%tme:TPVM䢚=Q̈́ax 0JH>jE$ b0ׄ1=3ORMHRd.$yqLd 9Vb_%[,kTjZ.k_AXK/גƉ1vWt?Z[M)9S羟ZY$gE}?L8E$Luminescence/data/ExampleData.Fading.RData0000644000176200001440000000533213041732307020071 0ustar liggesusersYgTj Ć"-"( beQ/XYbK$vbX{f֘ܓ{Gf63>Q3BPXZῖQ*5Ѿ_z0:Z[>wKG#fId-N?t 5!ρ}<M*}% >|㊡ n_U]׉[HZl;/  s@Jq6] C/\F:Mc0 #M(Jbsv[ZW~}xAWzhv↚9Ye% ~MV߃3L7 e{YnMݸ,'@GZ@gp+HIV}a{ZAgcfkZ i'{2tۗ~ tvwiFGӎN&+=ɥ_&?y>=$F1I .4dm>#US4Q6h58vx,?Ii"##"zѡS4ၚЈ SGIJkG^#2"B8!>Tk^b6c C {j;/:vR̦G6:mabtB٨08u|rb4<³ #Ocy}J.y?  S0+}mNНigu]x>-u v$wwudHI3"VW5&].C]ߪWٰBzwҲAP{Oze tźӛ{ׂSw| kٹ)v~Av zwx7 8_I|z_30ZTU,f *;g#F:Lqj.'@µ#UTƭi1 0H{Y:( MTIz6DiPbMO yT#84r2CmSsk9Mhz Ѡ璦_WPDƭR#gLs[/|;/?l|w4mO@6y©#dfx:J%ڷnvj$}]*ŝ4#dq.Y-RoaS_v>('l? iUҔ!}q2Y\ns:PqnX(6M$m,;,uPδht{H=6eIO&?CzY}+ƬɔM$nI 34fmc:t!\n {($QZ@Z?DϠ(JǂdOU{]X3F􅁉d@L~"#W+LLr-'ZjssEJ&Ȗ$rM)Ԍ!RѼc0rr)٦"^I+#> ~ݙ7RMg|%2l閁'']-#a)dU] _07í=~FdsFL)]%یqn΁vO^}F͟ǎ1?X㧁ےMDJfߐ-l\L?jx{A4?^H.ٖUВrˡC-X?$ɖ*oHlǞ92ۋȭgP f'nJ/qP[ t@ r8oSCq_Z"O>2kF6;^䥵_0kk u=6}v/Ez#ܙr*ԛ \@KenykO{ LB0\y9._}\!'Bp|JH0E:@cTɒ>~jd]"n' rzd Nv'~qYc&(n#OgAdEl<Υ"`\R8MDm4rO&MBCB7ePЋC jB"$‰@[Z[[.V>U RF&Б974L)%5-2}X@f f[ܛ?%P%hK ej볠e6pkl^AhgA(_~p~:2!! #Taız>oq@3/~A\@!;$UPQDHv0W\^%2 o4ycpO6o߹=n~~I|0*`^nw8K LA_TEa}tl9 p|DW'Zē-2\'?A<ʰ6د/ꈝ `d(RaA KR (@\,,`HS%;={\wYq҆y}!7kóh~y3_g^Cfד^%+(`)oo/{ W6P,QHĹy4~[FI: L柹精,\*&׷jGBgpOc|H4z2)AP4nŠFfrګR^y=4Qip_ޟdwq0kK9(ޛgԬEZ Xf׀nǜ=NB̃c ~~sf= -VR+ ]{:)gԒOsU=J,,V4Mo[MR0X' 1+= lҌp˱&w'i_,y*#MO{m`xMseS+GDZ̭~sDJ}ǘQhԼ |sIjsR?p`c^YQѭKwE:iyfhetjՠ[|9+?kN/͠U[oZCyq= Էy!_ޝWk^?&zT m t W2P$Cp ʱ0gjQn/>^^Hۼ_g^]Mtݛx[ G~!,jݯ@}=,Vsp+J&|񋐻ՕHr2y_ C! 8(5 0I<`z>gh/KꄎTIWR+m<#P|V#UAf T׽1T,ņ),'-C.) bİčgf ?  ~G2n. \bn+k3vVdtSsC_6#fnƒCH.lvn«YLA65v:o_Ks(5㬻f,+pc]-D'UQdqlk^v)C6~ R|VLg>Tߦv(NUQbk xNt%jJ%5q3 Ł&9giYF #UcGۄ 1+4]Z&G =rvPh1C)kxpS]yb˧uLe%%AG噆܆'k΢߰og+o!o9!c|JJ:LOxoE BՖƞ_zê^Sr7 p *L8}xϠGíQXcg%z5ϞO1.ceM`գ2:$4r ^3r1Dt+C-7Fk*r,QM$=?c|̬uiR4Eֱ=9i?JnRFv5ڸˡGEMapLdٳp—sBs:cNh!34q31KΩMe謻hn#lzO`R{}>=P8ͻo8ǨX˰`ӈ9,עp_q}>Q2in-z!ӻM?0U 鍫;heԋ`T/P6WN ra;5_Q6~v uȗq;}} 9)w(!*LWaYm˒G7ˢ^*4x9]]잉1R>XMĦ(y ޥړtjKK'{}g7eyWұAKF17WInZW3caA{j^fv8ᐇ|G$2/~yya~Bճ+H &bGzAv=O׍S=c~5nb|/x>מS~˧W1uL-[XGXK)f߮8+k:\陵S#5Э?~ ATx^z`&͒rQP<yzDN\~;Fz©35? wC/KčAC%=Y?rJLFoQojSzx2{\xc5 |\HMo p[k4^U\jryNZѶ1kSX,oa`]Ѧϒ,k ﻳI]h|wG!ǕnMG +tC؍͟y@ԓ ATP6ZT_ ɢX 3&ȕ K"mh9`9H'nLuminescence/data/ExampleData.XSYG.RData0000644000176200001440000022244512742377053017513 0ustar liggesusersBZh91AY&SYew]PQBP4PЉ*RRBTRT  n|'yRKP_l()r`:n{b]'٩Ô[ yzEum5mm,ݥ&]B펌4NKȑ!A$e$IE$F T$RTJRIHRR*TTTT2РUk -ZMT@ (5*ُ֒(V: dt譳jp@omu1=g @h [6³l\>!@Kչ @Ųknun6ĆHzO@ɧb44ѩ⧓jz=&SLFD~@J{h=zz&SMFLш j4 MѦ=?U4 4 OPh@1DA!DOFTzdUOT~$?J~TmCj=QjFɨzzjP=CښFz7C?&hIꔄOIT@4@MU=ROIU2=4m5ObhIhLS6Tڟ䞊OMڌ='zѪoMꍩMPS?T42 j&=M~ ?6TJhIT#='?T~ڦ̤S!OSoSIH7a24izU^z< 9cQ]@&H#(r۴PuUzJMc6;Y-o.mIDYTݝk|#FɴP%Q!F#wk& [ݬˮsVw"M%f$6YTZ1EKw;[˧rY#h0\j5@ lFU Tj]֝$Q+b˜94uַƴT IIhQ-gk|%h-6/}k:KP`6L" ѭ*5MMV#b5{.IRL[]o d˘4*[&ޖxk))kIF+#"¡Z̖#b8ԁ1i[xk#A*y[[^;kz) $h.BTڦ䕨5$P ld[\[yu_*K&rs]o}-r_Ql褘m0Pъ@ѵgמm9hɈͲ ׯ<ʬ].B QB.MfW{l&™%V"U6u=y{]XZ]n1S fvH7 (7bGPCqb湣nkd+uZbF+5sTls\;oy c[ƈ0ZKd F l(eQaVZ .jk[wo6[wzaHsJsMs\U\ j%,khŨEbجmZj-cXIl[hKF6F*4kE2AbV $FQmm)ګj#0hj565F6mUVdѵlkFVV+j1&mI(hEj5F+*mXFlmXŒcXh֌I[Ure&7LXشcFbţFŨQVmMa-F5mE1+Q[ۛh"ՍZ5V4Tr崚X4V*IZ1ڋlVXhnm-Fm%clsQj5,F(1lѲDEQQb4hLF2QF9xyz-r"1b`˔IhRli6(`2h(6(\0iibME,;mpkaF&ƈDjQb 6t4Q\]r FQY*Efh*TjeE.(r.nEѮhƐrlm j6#m%skm$\m N%(nn+RZWu4W7+\-Qc\*9\ъ6t #e% 0ܮD&rAlsFMr0mtMF˘[Iknck7;r6AT[uF G],Yr]LIF1X܁nj(HX4Xȕ)5tJhij@V]jfKZ$ Z5WWIp ESPjNs'ZBHDj9zwrikx (K[":U buyTTIa!A%N2q$+Ĥj5 J:k\BhQ iZ7z\E$)1QQmޟ=|z"൛֠1H,+DBHhV+#ӷry1 sV%Q˖w J#E.jc]_%c^mZ(_Ou^y/wH&PF:PBE5YT"I73f6M^"zUm{ƫԲDcF`.j:.EZr D[!F$d6 -A}a3KZ!A*_EaɐnBtJ9t;=mm=C|o74I6" DH;2h⋈#Ib,'9ܮ5/WxFIB0D_E$RGWW$$ޮ.sF%3_;C$hEz/",=w]d zVZ=]ݷ}{<3DHvD4m\;̠=|JiF! $!Q}F !5oP.D`ku[MWݷ=ǕA uM BI+_MFlW,ZN*8 hdJzYS!$ZIhŅBlEޭbLPOEB H5k赤:\h-F@HHA }/~&cU^]HH2%ֳz.]HHF "޵6-fTH0Foۛyv \؏zF7]`{/u|둧׿=&܂m/^;߾$k׿~:BI"oRkC7U0Znw;#ׯ}IK׷&5]뻻Luf1$s1Nޯ7ux5b!VnZPZrk5. M)Ծ~&0ȹjwU@,Kwb6mޯzK=E"}o VQh[Ԓ wkׯtcF6*׫Iz]7"_^u#Ah6w/Wu"4`Ʒ{wݷ>|zMm:k YƤ)]5 e>zy&Ӷ/W(nMݫ-ͮ޴XHdHnߩ&LZoz׆e=s$D4J(!A+YSL*#&FϯwTmniq0Z篾E>FnHo]3)E_=_ | AI$48fmג]&\O2v@D&`ْF! ^Va@Q%Gi(IkZ#k֥07BT$x)FD*:=8 Gesw߂}^|Fq x;a!Ah\`I!Hō-h1Ws8]!!Q3(YS(6-E~FAJ<!".^qCF$ "H6<֐I"!ƯnHCsF6W{rT*5PI SZA]mt66ۚM\*[:prەt;Qٹ5˗ߵIDB!dk\V+rܫlhnW.N辛+>6A jb\T1GG\8,i 0F'Z,+[ަ*H Z1z0++N/`T9{ȓ{ڗ:-q2Dkb)1HJˋݣ6zVp9X ^(O2/H6-e̒lNեx-a8U]Y +##fxfּ1] Nl)'y&f֥aJ Iv: B)Fuve[- έP\MpҫG9aPZpfnД_A;:K մ\xazK9jI)ݳ ҺxzJ~rp{μXb&uqZѐ/ڮr bUuv{ tֿJX2MJ6|59ny"4hy;z\lξ^ݽM_s{/ޣOj޶}yg]'Z_9 ,z6ZWž7R|{GN~޲t;~K~G>yjo/ۻDb0>vo^9 owlO8qOh:'||kz2on;}6 X>Zk]?y;6\שξ+J_۩mŽOgǞw~oFi{z Ozwg1\:@v>C z/o(^=af"%},IH{12Qu+\IMLlkc7ђmQѲRrzϨ\w,~7%._疛iSg$!C-N1 ڍGr*)ӹYpQR?ni#9k\>;ӷMKK]L~ώEBi^hۓ6b*1u+{{UGnEb6GJQ?':m2VGVan)$V1U;ʽCeg"4z :i#_QTU$żn bfGYLjJ:eot𴱚:tzb;C>T"j2ER:\/&J:[͸KTL4$]pcTpg+FK3mq mgͥ/o+ k[McZi[ș=]iqr!J㙇(>-d8R5_r.nՕ fWlxҶnaYTk5h w`ZI5$50w ܐ}k:5W ]YPLm%n}լϽe'>~*YkS/mf1sUi}47iGE]Fx=M.a#|K&^k8:HOM]pRo:;7YĮns;SV9_;=-U޿J]ufƧV}_eu銩)}Ǹ~5~Y@=cQu5ZD;M`Cߚ~ovbV_Do:>yw=|{p{7i&{߫طəaM7?Ɵʛj;>V_+-.G+kߛ渐 k!<zO$wuO E'oA'H/%~KtZ'Y[Vk1*kV?~__ޑ^5~ɥF.4h3)67K\;%w~?v8K'$@-h8] vi#yV;%~΅މѓsD0v<im,Ǝ[bO zGO X~ycEwa1\uvms(J4>[ӫLN#[Y|vk4c2{_^RNF2}5ҋLbB> |,RAD z>!,kخI=3o9&jya^0웦[-h_UVX*)^ٹZ:Pn*)<Ҧ%j67yh|xԒΐ#YYhXͱD cGZ8e55>]і07fLMVe/&)D|$MN !s]ils]E 5HN- q9'X>H l8ϿhVJ_"ؐמS7KFUfxO#DDiqF< D؎َfB=KUoHHqu4S:b-KnRЂe<XITiL[5'v8O5l.1 _vYߞLO:b҆$ĝ&DZ5Kcy%Z;Af`DzO..Oཙmn;4ͥPW> nvPJ$6ڧLvL6""ftL^*.- lj2ƑҸL(J;WcE6FBjgGSb 6QVsCLxCgst/I_8KuTILO O3nώ4:gZb ,Fuz-uɭ+:7I[N20˸i+ (F6oMvw#Xi1z+jKz`MkTkTwyyTMlؗ;JV`ZV0qCnz#a`3-0w{$I^Jk&SհtGk;Mg6[fX}_,QG'[/K+I+Qcۧ)6kChmI0-5۶‹Ukogqry!\fjΝV٫(mV$ívh+evyIrqtk늌ʝն9GzTS#͖8Ќ D~19{=c9\mI.:5;A-($\_c JgB#wqZўpIR MUF1l7 W[KWkqČC0KI-/,qY#0 ({'#;T/VT;b؄-aYϯ.s'G:~Avo57XU#ށұ }*q~1,jۦ鹴-ci5s_h)2v_V_[ do6sU<RjѓbkƆw0? el̎Cy5+Zo5ecCV»ֽOR(Fj0Vٵuª%<骙xxաg{R\fyMT)'c혭I*auXimZFq[½$FI8$-Ju3j&.x~'iґ씎[|A cO!cpD$Dvv u0*-oYl_Iϖˤd.a:Q"Z>wuy(jyVULsN66{Ph]맞Mk%*8O"7{J>TFڰ1)MdO}c%NlfH.rYS567Bc ڗLǝU/qLQ%E\R8) ޜYeC'Fo;1]%3ᆱ)t8FZ(^{R^Ryxw/|˼3R\g Wc/ܽ[;w Oc])+xLo(?2\,/ϳ7c 91ÛrFG7[WcƊ>Zd^5kq=cBqߟ8 [0Ƿ9q;=O< "wT^#$k,R0adto~1ݪk&U儌<,5 <ƣ;^&l#Us5~j^wQl`r2Μi_VYqM[Wm .٦mJmo\)}J ԗSźZfHsc>In9rj>֑Dhne@;4j(_<_Z{kN' YIaL2i{GEVc\qa,cZڔUu6d[)i}.5aN#z ӱV6,u0XhUx&{َ4zk|wQxī^m=K}XC7h-IśhUtmG>xưKx{o\Y>xy=͔2FqK\qfEO8!8 9L?CUV Z76_mo7KA7ST4=~뮫q~B \{'|Jin'vx=f߲I-xNJXwⓈhY~fmF3}5͙#^CN¹c5ߝ-u/SģUZp6@W'$"0;}!һuMMk=)K[/e'ް/7گ2Sk+[3%{5 W/=caGc!]c}ZXC@miߞs-Z|ڛf TIQ B`܉Ȁ.{n8>?g:~)Sؚ6 ZWowZ.g>wAc)^_3RD:ҵ$v^|Ze+Rȥ;zT5q+MgYɯQBM(o'#O[W'y{y9rxp-CGoSwd9$\Lcw)izhPJUe.#0s2ְykhԌnBcq֞Ɠ2l56Kmnˬ獸NF9۾Mˇ5MS!þ%uD_kuc޶yJLN[7[m}S}W=u;1_xmG~)ᥣ;ºIV+{Yr1}޲3?Crr\lf=f{Gmm̱(B9'_QewZ}r $ޔX7^8?_tk,=}/oyS~=&xN1}'h9zO$Ն$@7hҧ^C=דv}[׊imkhIo^2coo]XOdt;3>{6ڐB{E7I{O?/my/XI9᫔R_J{}̿LۄȀ-;/)%Ofx|+3M!i/n[yzJ'ҒϪ^9ĬfޮWJhRmۿlmAeA&~zOsjis_FN8.+x>qsD @.?ܧi<ٕw4|}iﹷ4OT%GhtˈBO߆1}ԜȈPȐb$8r&hM~=Nzi+liq3E1- >9C z3f5|M;?Z_?3Fw>mZU蠩x>OH3̉բuzm7žm}ǎ}ܦas3l%wq@;w{!eU}~և[jQڜ$wo:-ԫ%O;2-3Shk&9k*u]G5r z0U<{@q5Gg7Hҩ2 }{v7ޣ =MXq'x@/=z7S~{A ^[w_<7tn1 gjHs,D~ ׫{6sݼx8fO_m{z<~A*dR~e4hZݾ5mE=;N)/GcIݫ{Ɔ}v"YH ؚr=վQ.ǼnDTGj4{y"uw=p+[6vrae( 2p8.awvg{"-kMQJQX5#j$ Z L!W0ОyJ׌5[a'u"؟֮OhpvTSZqc@#xCUH*%)K|{{5- f~*ǵQ3>U qu![^;b ]w:Q6'tG^Mafx$ 3 5"ƽW']M'y~VZ#CF@K  !_:ysHPA!aZ#" z:q^f fcşUqu9Vl:ٟ^e^OcF׺{,D@ "w0tx딐"JN2Dac"0fV^}9J tIA1)S4 Nh)u9WSH @̫dS @7\&ّAaeHNC R;+:h,K+sI,b4NR#)$x$b|"#2 4QrٍMJ6v"z?SZ=yIoi-ĖKq%In$1%M(6AzsUR/IJ_^"@|ef/TY'uwM1gwsww8b뻻޿k|iHR&2IWQtZNJ=_K')LKdNzLq ʍ4@g&*7$ >NJsJO HUBXHi+$VPU~q4!4 /~_WNJuE'QR(aL40Qi.IkXsQj-rD0F i#((r9ErNQiQi,-QdQdQjEYRE9E.Qr,NQj,).U0VЬ) haL)0(+Z.QrG6mjډa-rۗrW9MU5sVbS i"˜S aMXIrL)4,),E.QrZ,Y, \(NQjQa.Qd.Qr\1Gd((⌇dRQQQQ(ʎ((K1QQQQGeN(8 ((W`#88T(JQQQ2((⌉2(⌣"QQQđQQU82U`p*p8\pH`p8*8Q81U`p8+8p"8 8K8pXWpApqIp`e 888 )`p(8Q.8p,ėp)r +$2LHK%ĸKUSq.%ĸL!d&IdJ2ZU2\KdIĸ\K.%ĸ\ĸXTq.%Sq.%ĸ ,$2LY&Iq-%0. *NTNTNTSp8⸮+ȦWeia,0 2ai!haS 0 + 0 0 %Vhi 0 2L0 0 0 TaRaeJ0 0ada"aaXa`0CJaJaRab 0 2a 0 2K 0 44aT440K 0 UVaa"aaXaeIhhT 0a0 0aba"aa0 2 $aa 2 0 0 2Faaab0CIL0 2aa&L2b, ^G#l~?WUJU߫W+RR4yw^|ϟ>|ϟHH +B $a I@$=SD @?d|E‡p$ҨJ)W9_9_9_)]R^rZy.{\`~?bGdddHO4NNN  8888 2)<9?: q{>7w/ϕ\yi-*4 =iOZzyM;cU?9(Dj-,K_'ՏGՏc#D}{^E{^EQ{=yGQ(*>H>H>H>H>H>H>IW;;;;NμμμzvG#qM*i KL0` I(1R-!:::>*Fi?2?oF~?OjuGL0O~G~;ۼ}[ucץ>C & rYRXI~u*Q~Z?4hѣF4hѣF4hѣF4hѢ9EϬz:KOz{ܞ'=Oz5A/sq95)Dܠaa`K `RW D5(#5uYWOSu>IO$,SS)Jy%R'c/'?.ZT~'$Nϴ=B:#:#:#E/qsB/eҎ>>>>>>>_/>[ \Ums#w4݀wSNI_Vt"VQT O%JtZ˟-@q]o.Tfj"kjS sHR hn@SZ>VJQ8hTZu+k+De3l~6O_6{DuW48|1É}|Hzȑf,LK>5F̂(B4KSKJ{)e=eOTNj%4nX[~CfZR|@X_6mQ6 oԶoSo{K4+Ҋ~QinЕ^GEp ZRrrrrrQ\eQ%Q>jɃ%|ľbe|֝i֝i֝iӨ-/_*MVKǹRsmӃ6H6\[$FV+R_{EƕuQXz'_KM!NVhEwO{w^OE91\U_h={@ɓzG=Q$C*'PN$)_oJ~4H94iτP)uIJЧIja'DtGDtGE| %:R#A1Q1q'[tGyiwۻU4]AP{Vα~5{]D bljI$srTوDx)Tx++^Yq9Ǐ؊| }u GNI֊bA4S4fh34љfif]}_>7uwm_㡰;N{uդm2M_ yQF 9"(h<)IL깅ε5q|jG]cUrsi纴ΎーGASЎ;e˅J^yS8EuYq6Kn'?ÿ8$ J`yDQf Jɸ`BI\B )Lai$ pm_;qtD[HLJ4 FWTN4 *+"FwXtwr|zJ ~ڂ! MyU[Uyq] A߯_Z3G2l[WsmF"rh "jy3XE vfJ)F )J"zno jN;(SBOԧE:QNܔs s s |œœœœœ%:QO`S=NAO<)yO {=}GQ}0}0}0~K~|~>iN:rgU}ջN>c\n5E5 Ս!$(^+JJ* )3э3T͞ 5H`dԤ$h%Aм-4 nqyK23="g<ׯZT׬gBUі3U 2KN 3t'\]'1<90fElU6RFDͥ p@:R,StDZMAQEIM'JVF"&2U֒H2JI^(jԂIRpUgg'fw&!#iH0VX؈}_B/Љ@֗s>aBdR.@̄M.s"yVҍIdj" j)4T! fUG ]B2:\MZ!)7|RWi'wxI?.R)HR*\(sLO>䐌xTs]02H0 (IADڎ$`ʀAe8@6[׼Tx<(4W㮷KⳭ_YT7g)۝"&AP &o59(`79g7Y7=4ԩѾ.jQߟ?\u<(AQ5va̛E/璎`r>֑EQ$(M%:>|#zdy:os@_΂}^P /Nxd_ P ߈^>5H?[({u Ȝn72(Z+w_Fߥ~S>/eCZu2\k L^ n%.2 aݿۂ@&\I \']M;)SyMJaNg«Uk5)L)SUk)aMG5.pSyM k򟞯[ĉwEm;Н|QwEk5VH4))Ujr)Nl߿yMQyERGQyE.EtZ^j( #HSQb mZ=nQzM pSUkK<ze^6CQiTBA8OHS)4{PyCT ZzDMV4lAAx(4øyM4)N6/M#h[U6mF,# ҃ʃTyꋸ/(^yթڲ-*Dbտ o)M7SUkZ/oSyM o)~⚫^7 Njm}j5hՖ)P$϶VښS~5Vo)M>W*EF"c1oSyM o)~⚫]8xTPyPyJ.$ HPRhmYXБA!HOM8Jq p }u{n!M7E/M[V3[Fc-mUbQZ$Z*Mo_^mM7›MUԦnڷϟ[^)6-h6cQTkEmnTl*(Vcl")1Mҷ))))o^^yhlmdPchƍ-IhkE6aZeEe!$<y/#:.Qy笮mRTQmTmHM jTLiӅ\8SyM87ޭB[Vڷ}}v@i",Q[IH1OJڰU# lm[5^GQyEE/<q(]6$1` Nӻ-Vrpfyr/J/J/<uɽx;3zupwn&O軸ssr睊481n)RFI=֪]KFA҃{PzC(<<(:PxRLb1FYa$k& -g(^y.QwE(u 6b $QhBI+Y)Aٶf͛k/(߿Sz o)iJL0ѨlQ baM$ڲlƑ$h[6^QyE/<q(]Ǎf[6ԚD5EE0P(P"h B +Y-Dћ) :/J/<}ym_VE&ŴG0w!5lUƳ() VUS&o0<U*_:"SRk3j"R2I3M!4`^ua =UWUz%fɵX0b5CyU6- 2XWL: 捛LKXMʩ`[0:5lfX2D&kyU9jL,lQb,VCA&AhD% sRE3``t :*SFhi  RlV`UM ED0:@آ[WSkt`t -`D(ʶO*T:@pkb+1Q 01,U-mWBV&MFh*Lڼp͍#hh*xCmQ#$K)"*Ɖ.s[60:鍦kKifl$jF$dF5<E%֬ 0JB" -hXJ0hl)7WZ@pml)09-!0:Y2Z-EFѡ 5 t 6Pt 4YͳRM@H%$&64#ʧ5mc-2`8ᵳfljZR)Eb5/ q[lm`tʎ.5C`t j*M&Ck6Vɵ.R!0:e $"hRX1%Kk$̬ 0 UEljmlbű UKnT:@9jSi1\d`8 CJc̑ͶmnCTuK)r#IfHHdM#hZݹfD-,IdK]%kfUj):KplTK%Y..%6Y]%%\K.zVbHj%H:KsؗIdKYkx6fb1RR,p)AZRt%ĺKͳR6ơHL(&Vt%s[ ,IdKfB-UʹIdKY.[Kml6c4MZm+]%q-Kaf$)(I#F1b\-4cRtK.&-F20@Z6ݶ CU^Z]%..mmm%tfkmtK.5+!!B5hmT-KUY.ĸlcb`JF0 C+ yku(S[%Y.ĸIscj2[XaDQAb,:Ͳlٴ.аB๭"%lکMSS5N61"C[`t-0t UQkFS& M6#lfaRilm岶o-Ū$M%Œgmmłض- iu%J"H)i-R\@ŋKxŤI4@٬]VKj:]VW+GVfX`H% -yI#fl͖ݷtQkHV IK͛WX؝VWUr8Y6VUͼm5Vm"f5j-fX516ͻLƢ"4$l͖ݳW1($d`HFeɨ&F#lmh1LرDɨV$&a6@6 I,k5,lKBHmFɱEE DFI*1EDPE&ɌTAha6%6H֊O6t4a "4" 5E QeDTmSSo6mnͺcF%QLkE b#mb-lmjlbZj1hi6h b+hlbQ@jmEU5QUTUQi6 L[mX-bXձVmSh6kbbXV-le6hm¶ѬmQTTQ-QTضѵb6KeRٴj-ͲVmlhZ(ѴjEQEZ1QZ"QƣEXZcjl6mF6m`Ki-MZ.blړj(ڣbljm[Cj꺮G2SiPIU$؅IeW0lmWUa&&JCXɊ5*:ju6Yffhy\fMY\ra-cW6kͭimb,$8K6mmmNU̗UrNVeS:W$a*s-꺮Iìṃbf۶kkX2(hI۪'+# YZfmm-a:W+g6brrNV:V45u]WRr9miDAK[ZSrNW+rf aW*yvUO/_6 0+  bIӀWT]!!!? )/WmERhG}}_ʪؾbՋ-,4qG0ڋ >RSܥO "H%<ŸnS }BiO4S)Js< OSJx%<x1_+b}>H?(+;;;w';#;#;#:y>I!iH$YhO-1KDNO7(A8Rs)^Q_5x a900nwllln-D 1JCȡ)?o}VXX_td=?*t={Anvfvgfvgfvg@}j D]__u'49rES U\?L? |)$%|']UbAʮJtUWHtHtƵ~ _ۋ$?5ߍ?_mɶkIkO*E@BA@pP XbU^) o) | %}Q>Gߨ}ҏp>ʃIIT#=A؝؝؝ӕ{~3Xª.?7qU>,,K % ;unFCB8$&0 zL]Uv ruhLStPM mĪOT/t+9EQQ`Y_^o[](`=}a.==G->ZOan_qv-K90*3/.ˤP s:svuZnDD*,̙f }\nstȫ\o^>Hy,渜-ŢX*B] "n, ?2|O7|.>ʾqժŽ>%ݧ?~ϼr4^?1SI+a>qaLuMCQƪ:]g݄C*Ҝԝyqj'{/?ߎ8u|SϜ jhs8UBMka^j7M|9?('BQzߕק9_~ ? q ~%Bqzt= 'ݥUrIҟjӨU-C*4K檎R}ffmh^fA*)Z57)אhq{U|P[*9=UE uP_"e$^JU/ȕ}~O ˜S aL)0+)0˜S aL)0˜\((((((((((R~ QUv;`v;`v;`v;`v;`v;`v;....ɬɬɬɬɬɬɬɬɭME֫X5MMMMMMMMMMMMMMMMMMO7L>)ќ1?lllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllm6mMSJs:SSBnS !O)=IO<)J}d)J}2dS>O8pS)O@S) ~O@ߔ z=N?TfS}բ_UGQT}U!GQT|<<={߯~M_.%b^(81QG4O>;|?s{c32{$$jVS/Sx3%>T)Rj[˦6.p:c֜ .v B.o8uJ~#Oƾ / iKQh={JMUɓ'&NMNLrNILqLzҝS }M*qoa#u8juIpOJԚh~kU$-$LOACEl7J?J/T+дʜR:8N/ɣu*W%;=e}:`v{!LNit.ըlG.{lԽт &h Ӏ nҧ6D[s[@eM#/-IG@UM:^'DbK)~\++ԹGZБ{8 )=U?awO?s$t&K'8 ͂p#}*r=yCUH "/B+y=KF/k?x Q4vTD#;I(K\3U/l=P);a鋢EGkc "ƂoFeRf!  ^*Wk D 3284.@AS330F`3DL-0zX$BʳEJS D":o}}D@p-ll H3!#`9R!6; qzZ֦((@mcT*$Ȁ,!c(d`"𑎥yo1ZOI*  \ İ@9+ n(fMjxwW8#b3ͥwHDLa꒕D]2 DTvVbמP2!i 4igim @V@D*| 6$!>D&Ԕ9R[ʇ‘{>1ymKU*q&Pu@!nu#INK],fAUfHHU`z͡%H k`f)0;vx0Dvh1 Э98buIJlC "Ј\F"s/585 {e7UO(A :j* MYZNݲ3dF`l0BftīllȈ J`f kd@`\7ˬɋۚ Q0Xȁk.U} EQc"!e\n;mz6 fl"En%f5""hhCF+ta%Ep3n` uXLF$@š<q]Bm@3>SY\xht|GΏWj~wpwvw}A!mmmm" X~LX$~CQ ?H+Ur\WghtA<~c7ZֵkZUUUUUUUUUUUUUUUUUUUUUUUU>NR.}KQl={`vgfvg=p{?E_֢꺟_VߚJ_Ȁ𕸜Uq98㚋|D\/uz'o\+d쩌:eH )r S7SqL)7n)8 paL)0PiA-A&jb(`b 1QQQQQQQQGj=z(G`v;`v;`v;`v;`v;`v;`vwKKKK5Y5Y5Y5Y5TKKKbuZkƱk7yxGNhώsgpFiS aMSe<ҜN }h)E>OSJz%=ODS)%=ODS=qO8S)y(_.O/|>9ώt}KZQj-EZQj-EZQj-EZQj-E-EEEF&FFMEEedVQYFEedVQS(ȫ0+0+0+0S%KU&Z-ZIDhբZKVW'?UX;D#N}I>%/|KXο͉+?]>c=Xf[b{7#=Te{ e^̹^=d( %Lj*fqXWPyJL̔댇JWt"q͈'1 +D- \C|sѪ58_͜U HH UPP _B>~y͓>6 v=?aW,"0 O,t=ՠNh xӪ:};ڑ0ZֵF !=q;_q_.OS)xG`}>UU];:4>x+ 0,R*Y4tD"kߜ V|]:3:3&vt 3h [0o}| dP@GU]tttp::s:s:y?v+ﴓqN)8|Gfh/wȤEo/oSx W[:1RlW5k7Uc C~{t_yE,J$(S) kݜޙ΀@S^P=GŸ^(g`(Usy$"­۪.BMV]u Ds>]nOy+Un %VKrXf¹*URU%Q*ysA޹Vh@Mq)7YzɫW yJ9SDЍ.䀀I+,pQn~vR<~G^k<讪_#ը:. -]X".KN%D$2(]Qh{Y;\"7_k޸?|2>tJeb// ^^r7|yx9ȹ so5D Q8:|#Gȏ">D| . M4M4M4M5KRmI&ЛBmwA  -;)@#yGyGy-o7~xoaU{_CA'3ºAz篡9)*{p={ 'm'm'm'mU؝؝a$P oAܞ~8;c20 L`ׯ˰J,)I`~uxαZX";:8]}$O S)xe<2O+Ê8ixq]Wnt={Aݥ;r :^~=k^𗄼'EuAͅ`0}>fzaqZORR>H)Ue#0l[TDMD / Df謒Y>`CW@_OdQ4n"WsxʽiT"T~|PȊ҃K>?ǩd.E6~/|jU|Sr{MˮZw7b^"bn/0 Yn;D;Ev3?=ϼ=͔aQmGM],,,nczn)ye*>eGϥ|>MW>IOf}ޟzt<_{nN[_Mp˹y<`OT%[%[%@<#ڹIJwGʼw{U@VX={ ARRRCٯfQQQOz p' ~ϵWf{^N=kڨT>oo^> ֞5 DP ljBH @/M @x7JK) x<5GQT|5GQ(p={Ľvv]ڝڝڝAOZu`@;}&Ǩ^~~~~~~~~~|3ϓ>L2vB1J=\Twn#Djiň$ _.NNn;#;#:c:c>ܧo.rAnn`u.9̐%\%\%@9"D$H"D$H-I$ ,,,,,,,,,,,,,,,+cdI Ԓ )b'_E> &} !;i8pÇ8py+PVIW-vR)׼ @L`4붚 =0ݕǽ}EQ w   j0}4}d 0]EӣN/>xRz" `j sNhkuNgrUi@秞OڃN4[l.JQhҵb4$@ #L1F i24C MS`ih41)&ICБ&RSѲDi=@h iS4h hCM@ O==#h@HBI56&fҕ2H 24h@4ѣC@@h44RC)2dS!0hLODɐLSA4ޥ1SB74#=(Li{R4iR=IF ?S z&dڌdjJ)zQm@@0#GѴ'S50A?TMTT~O*U?ʣPL'h4?F@4 566d7芡:cil,,H[DZԱh+U-XRQʢQQJFRʥmEVҢ6#Kcl-UkUEڌAE6[半ra:w"jؠ*eA6e' قXxU*NZG-Y.hB!B͒#e#NB)ڦ۫lم $܊ݑU-!T6ܴRWy-D5ݹͩPauĮ4]U< `r88R^ b )G*VLHͱblfn0)$x7^3l9 ja7 Pfsw\,sv7wI41rl13izl  j:ԑȳf3֡Cp58o\&& sw7!D jP5LZøP *:C[SV0CqMD [V:P3  jAJjE  BQ*D,"ABEd0ȡBZ (ZХjU`J ,K^ ,b4lZaidDCp2^G`2a1Fr9UYKr3AA9(Q DeCuBe [h,乖F,95ɘ )'&g%12*2b(reL[Kj3rdZҊKb[9)+Iɠ9(hG(#'&IPD*"DdpԳ8\&FAɔ8\1I܌f1,48V $3( i(LDf' ɓ b pS*Ŝ,C#P@X1-f܂̌"Fb J (QEE`HV d`,ER2EH(B d$TX, VT+*VdX H*ŐUVjX ,#@Q`,kUV + jVEQ@*) K-PYBTPn3Tm rл[a̡TyT-RP dCkǍc.MeN)^c-9hSE5q]%${j - fqg7 gW|tu9~5>ɬ!ɨHKL L @X&ڞ cCzxvqLne c9}~FBc߶IY ʊm&*_y>9tjm 17 \8QE!/H|0H jNNML44f1, !XYYX頤0` * Vky[d(V  e@Jeyhm$H*L7ՆBZ"0VNsH(BUlVK F%HiRaVAHkYYBXX$+RE+"T +T"k$RT1@ 4՘(嘊i ȡr@R(v1U"X hhA@u"쨡! 2ZECSi̺`Ig;Z+UН["eam aY%*H( BIP @AIfe+,%I^+gBgL>@㧦:c Zl`%IR@AB3 VD+76 tn6I40Rq+e~ Ȥ8@Yh h^+:/*b&!Vh.)Ҳ!mJ.3,F|L4U=)>N@YLIUXPSpYWT.X+p$P `F!ݷ,*.RώFE"1Qm e0Vm.I4ȱHb$ Z8!1"*W%CL(H"LXRN5W(EJT+&iS+1+XlyM&?s)1"+7Bg=mV@Fe@ CHfAcPY:CHmY&65IYm4{BN $K14ɡ3PYEWdĂ[wh(vwg27μgjf;`J| t*R|#!v!G  wHm"֣[La\BӫT 2贆+ \m"F)a䝳[:zIR*ʃZjw mE홪 .8}B'Vł.ětӿ]X''ҽ|f>eZ`ypjOVuR !4Q`ӬZmB)ĹMdj沆CoFV1ܓ֭TPS]qm7&3d֦|[[a*HE[4NXb͡X4*m1LQ~vXz&ɸ Q@]'D+X:V crz(U啗V *d=?2Ι EuqV+lTPo2bb,Lm}jY3i!mé ( nM>];7LFGFc`:id }̀TJT&3Lg۰3h M+>Yb}~08={5!lm5L: w_8W]_KMkV=}5tԬbE4`m=y^h=m~桯}mi*'\G9C=ofTn]v [ k"Ql|{zWL!b` 8lݺЍLys!ߚ' ڞx7iކ;ISh&[CHtg!;T.3ٛ}:gIS5 uwLrΓߪ LNkϞ|u'zVMgOo lev C td{=.i}]!"ulr_he{/>Id>t_Dz,.^ש@ank!F=>Kͼ^`fx +'ނ緟 */YU1|1Cf€Ǘ5iCP?U^*Bv7F[{אjQ>d+BGO&Uio" wy9)5i ]1Yx+sd,82wN/ufu>w JQt4ޡ@ [}Sxv:t RL D*7c^D7XVdefUva,6f k ٞ+4ټ/u {deI|ш/^YBN0pCCj]7:{eT =?F݀u[|K}_szKcBȾ0$`4G"xoGqo 9{M /N?cnJʲvidD^ɫ }iG(0/z[KKG=$X+n ļn``;j`Zs0ݟc$eɹ OrB\x\|āx4~sǛby.:<M͸Rs ͡탇m'2_oKrWT`0DC2]K&؟%H˱"ZyԊHJ9~q&HoQPW:1̜ zmN$ 32RG?ɵ =H`oϱn[m M(6LQ(RF$d&+2eks.)V_Y%('zpMH,,im8|Tc,ɷ7#? ;)k9E:cOX`dcQ,/PiOPO$vnIr?^"\Lɋ ۄ7-<Ɖx##&0`oqaBuE=,{Wx9ˆ_Y*; 'Sa+}u1ܳCAN67P 2":L<vhaK&^O+{LL>/KO񙚦`5H~1{O3}QQ&''o8&6ܡx#䞜_3味ӭ73WE.RQGLH{4cd1Â5Y02.~@11 Ȳ HL\cc#tȄ9|PP1R8 Ls`f(sF #0c&9cQJDpێhmc:#Xy_\ o]qPdHg%ܝ,u ޯMs~[4\^,\wMc.zٟj#!r:Y.H7=D9iKNz~{p̉S8tNH5ux|kepH ,0xҸO]^r>g*^dp>_03!s9)QGyyq6g,[ڼMӊ gK?ߡw:{w'/co9Z9㖚Xӫ4DmZ^>_KC0xyãN3U =Z✕0e3Y0bZs~n+1V;17ǧACC9+Z[d%gi\Q?s ,4s35t KNWfXLE t?½ K:kPM$Ŝ|(ۦ_ٕebҧ$E5LM8S1IP$0FB˱3OUơ hYC*-Y_f$ȋd5M e)aGT2c\C)ht3QvYKj35UIuľk-11.1uEoѰ2֢pLuqGBZCyLk#q% iOqM1I#SUzAe:-2=%t!1ձcV6t;*MKZ\6"oM1G0sГ2L{S#4 ݅S51(Kb6FS!OMd =]3U&k()6X51[ cJu787QiGhǩLt++b(3,vΫ†QL9paY\.Z =:`kKD\IwhN4# 2֢KG2X7C#mTVl>,iYhvn2x‡1\l>%m_lp#]>֎x͔}.6 B 5.'ǏqzJspaX>??aClq:Np\|UC5z߈x-2rN;[.a8f\uGoCb3n.W]7[O ?g$X9r^gŬޜgnZYr_Zu5swk )nJzlWXb~;~hY͹wX; 7GCYLWMa IX𻎳W} <ޯ;guW56w7#38SΡ@=ۍBpj=n3ﷹo6 ?ouiq[ct 1oe%2n*p7R!sw׻~tY\{!u<ڟ_5v^NmK?nl[=ϷVHR{!}^x}"{qzGS'ROD95nr 4:/O먘Z{qC?}7uOsk}rmU]:j`v搪\狾oxc?=Zu{\4O~É6TN>_i3xѿ]ߊӒՈo -)<=\M7 GM'.:93cr;N5e<ϓvqt˟vs]goLOg>f~l>ǍuwS; 57  o&l |*X݇RZ㞋9Թy_W o>˸9wxwcSg_wd/7|o͇θr68R>:]4ƸcjDTw\]祸.kr,nUDbk:/ xXSdpv~?x7>U\_K8݇ǟylF~<'?]v/9Mks{ 3+-XQW5>Wߗ{'0'&s)^k]nv֛߇&:_O?=||/ d3ߟo=WjaUS^6߿o^\O++͎Xt,W3xmq˱Ci9-`k}kC7U6wO:ϓ9Aاoôgbݻx?ovwro?'ݿgp +˳t5p<;{cրǚm.]=}麸nlÄ{zI ǶUvJ֝.~B%ʡ:O MzxpDUߋ""|qլwr i0vje-xxQaG1GU_#㲵8'aV}=zD%B(?OPdlJCD}6ۇI G—BtK@샘M:`侁izwA/\rm^+Gsl)aJ15$H]8ɢER&"OM>a+kb~1 1 G ۩ى ߿_֐JAHG#{t9oC9e{vafֽttAr<Gp{`PE@<_$CCڒ $s桜K$sW6,ׄ"Y~tjR+;?I"%3@Ä67Z(y#bPJtO-@iUUUUUUUUUUUUUUUT4;.e`D ] X\/۟ro>P%5:)+_=nNjF|GDž xcxO <'*\rUʹW%r\hi bmlJεra\PG{<|C 4W8MT o+Nڭ6#l-3%+ VV`{Mx'A^V(b,Tf;.٤47fݡ c\УA@>~"+vB TRUJU**4wN$18 $2thbHu:NSy1g2w:7F h;cb0IJhH۔lx # |,}/{-?W9||ow(t2F8EX$ P1 U #V(nm\+rUʹF\J⸮:{|?/P=BsuWdy* |-x~^2%,\Ep-=%}~Y;F"mR ?$~~CA\-˔SӶ$iWi# ]NmKfmA{@!Os־k흣d6^ѹIb-!,hARntQkX 5i#b.N:b2ƴ{;nnS,G!rG!r@r9(Q[5[5[3fl͙mH9y8aNcQ:$Gn\r+srRɫ;ʋ+AEe -@ᣣž+Gáwtw8G;y*kM0_t7^ni|6ז+n/f{/WÇJň uY .݆t[..p\N[:鎍0L0vt*.̈ʁ$]mF A֚˗Sa΄JbJYVf3O"E7ap,䪩R:Pqҵw9a&Ć(hH"Daց kE/3$XqcD H@pSvCQ6$H#l"ET [muoj$H"C !U)P hY.pf= Ё"D( B"cU<oXF  $H"m[l1һiq]kKË$HD8T@ͅd"u5Z&֧Oj5,%X<6S+9E. c0ff]gdʘ]*A<~I@:fs7̳VV,63e3D)pJ";fCLMV X2*宩'`,hP$n76 iK`gTنhʜVTnsT-0w,meNT[86iZLrѦV8&\, aNH'.n wR$0n7$H T Kޕt˥jvei-|BĂ hH"F@7Qm$^bHH"D$R /Z`60 ќ,h"D7!Btpv::Ftaa 9MHpe [-Ka,H"D JtR1uX"D"DMjoW,jQ! $H޶ Lqv! `"DPA3dJ\R6*֩9'e֢N]Lɓs90X33.宩˞$^Ukv; ؄@%z7B3C{ wdӒlćg[6nXefeݱ14yOiS"D a:SC )@8 e ]xi~66be4,"D$is2.dI\c\4 0 =OS%T,L&V $@zUi"LjivԭHeVF^j`ЁA *$ T QZ%]LD@ T&XUlN\4(@qBq7muo+P`D mNTKzZ̺ cA?[㇉XHvQ#D%0{HGԏ >zh(|(D$HIE:$G#G$y#G<=CHrW%bW%rW%w'$9$$TTkM11$'xlɧCsǨDcÎA#'$#d<6J H'ÎD\tfk|@AN)'-IQ2DA"P ;Q羛jC" G<@$M6N($J-DYzU|1P {%r+ t^%$&%#4+eVFeVvׄÓSB G$t%a"iܶ$$w\Qd4aG-ZZ3ʶZJI$JD862㞯ҺTrYLS>S8+30Uᛛ$ᙣx.33321A-a|"{illfdl Z])gG| 2!H8sDIoNOf W`odTN,,Wsmrk8333*nyb&en˗*rNn\)k[M0F1UMrM6lJrMrlE3ã՛|8tvx[μ A<>D 6KaQ$IxHDs;ɴWOMY\ AA= Y)"m%IIDM{뜫q\j]E Ar9'$%&<6JDuXb 7V%3 1hZC Ŷ8eZ.[V"Č@mtUZZD2em^d[-_Yλ;FL t:; As=Us&bs1mZEbj I.s5PB `sKlDD6J(^DAXHE^79*ɾ1CC] w Z[Lf\r[L~>t\{κ.hAP :IEBեKVVzx ٍ28As9D>2ㅫBղղեߝSUc!DA: >٧%ajI֖ݸLJʷZ]fmRWiMس =ZMPnƝs. &]wwu ot&}@ϛA ynS3Kxv5YYUoVY)YpcÛ 1n"bđx3u]ќdNl"HD4ttSkj[Zr݇&iNL77l.Vщvi[Z[Ej-6lS 8ilreM8nF<4h+Z^5-ij)"PH%3}r̜j*qE@A{M2 h%($JJ%ni;n*qrWrbE ;v'!"V-"ij&bjղզ~;+2 b 랏6JDnUչqјZaM}wo" A AoLS4jsEܮ0Z|ǫyb(bŋTr-3:T@/?~/fxq- ښ/n Kz1 t{h[0w6٘mvDPpf>U4U;"P,R:!6Uٺ:p-b-ew+Sv4妛pٺU pঘ[ueӃ\i˜SMܲ˗,0F 0!É @Was[-[-ZZijW.iz@#" y'eA"PH'mٶJJI[s9c}" 9䜄ڶեeFmKVc}m;ӹڪ44 @KR2rdL A!4%woNjmUUW:,q^i"lCh@}נ.9-[-[-ZZh֖$Gzk[T.!  ijUV- Wၘ[޺\dVo p9A -22եJZ㭾u]rM:,AA=RL4MPKHaW%xUUU8Ԗ(PZv ݜ9c4 ٗwVdEaCAlpїE6d.Xee喛(,[r[fYiNnÆNTM2GTˇaS)c0J&12J&sDD|_kHH  h&&)Q0dt) (HLcA001=>a(8W 0|rLc "a"1SH&S)\$ q a\$ALbcW A bcW 4S)3S a\$ mje"e"xLLE*D3HHS))R&R&1Dd#5T3GQo`=r 5CpanI`sS))e"e2R DD2HLRLDDD2HLR$LLLc)ȕ!"LDDD2HLIsS))e"e2#n 707)ULLLc)Tg5221R&S-HHLLLc)͑! g5221pa~OtCL`]XrCpCp6LE*vHkVa"D*ovd7nLUFDdMC) P,82A p7 7 *,"(D9 !j,tLS)g:&S)HAje2anEAEQTX"J-%jZTJB҇1-aCr1EXG kkhLSI#9Q1L%L$tLS)g:&S)БdFg:&S)D*a0X1QF d7l "0R(anajTXEC{n`EX%T3LT̍H !nC{n(!najA080lc0bM10`nnYJcc   Y Ph(mR x {l7 Xcl`c}ܸ  6JS UPv0`l`jUT60`nnZbLb0lc0a6JU10`nn\LUc`c"ox ZY6,`F1a*`c0Q}0`*Iw`Z4 ,C`;`Z4 7"T6 G2r3{jl*"&I8Ǝ\,C,s9cp {f浄fH7tr.sd@!ˌhZS,l39cJ:1̉!lMFj$"dh1%(AS%!3&J$ʩ23"KDV23"K@QQ̌Ȓ̔", 2RVFFXCIFdIbLUEG%dfDd K#,fLHd`de,@"FFX`+j%(2P LȒb("FFX0DIfFdIfJc&FdfL@Ȑ$!%23"Kdj%bd22dI0C0B*2`B*Z&S A@L, by hC4& %Z0BX a!Y0@(`f%dA&S Abad(aa0@Q & Q`Q 314D0BR )X`&XLIZ` QV*Xa"`(*(ȃUFHX,PUb(Q`H $QB@X()"ł(B BI( H* *1@"ȣ $E TVI"u 5-E),d_]$ڢ%PRB#" HȪ2,PXB, @Y H( T "1b` PU!Q,b"FEPb"R $PD Y,((,$P Xd" "Ȁ "$H]u * "QdY,") F bŊRH!)` "E ! (DPVAE" U$BI""" "Ȥ$+$F,@H*Ȳ" QV(,EB*#Ea$ " I Y## HE !"2 H((@,! X &$0$PPؖH*2(."* R@ĀB$A EDHbŃbEQb1U-EE [X*1QňEbf,b TV*Ux**TEU,"X"A(" DX*( " ##FȰED`"UE *PPDQU@PTE*1E(,aQV XXPb(1EUc,HR1FT(,@XTXXJ2EȠ(,E(HR,U`@XHE",X( DQ )Y$ Ad2(E!,X",c"B (H0 bȈ(ň E ( RbYA$$SúHC?1p׺6|*po.= `+D:ȿ/hELݴ@"1pNSӣ2kNS#o?^ĒQLBJ DCB >Q&H=AHw{]\>LCG] 6$V򱪛~Pb*U[VKtKtFD<;H@!9ueAۋj3k@>'5UUUUUUTm(ȁ= D4نA }3 m3% X{g,drm *"V-L0WU"L `-s@cbE73.r/d?IHҽwbi=pkZ`JMhI@%wD< byl7_*IBA=X@W@Nr9GQF#=uG(G~;ߎwwϘ;|qHS-Jԭ!5&Y<$ ?_A9>pAX+`V X`? 0@g`1fuɍ!e؄*1Qޑ*BT۔{}}i'>;-U$#& Es}*=PHD{w}|EC˜D9U:=NW^ֽ H  Z$zm$ V&~l \vB! OOtb; =)dœt$erW*Xdr;hA OM7bc\җT"E#jJd? cL˄X UV*X%bw'BAL~}بD%B7i-إ`t&f[K np:wY.8f߁cX]QlA,F# T u<I8?ruLdxZ8*NE z>Oѝ:Ȳ6UQx !+{HGY'AB$5?A .>_.|ܦ܎=C=cw A\J56s/…@C 17&1ZMZ  8B l bOT^|!$T3=L\q-.C gO;qx|BRH~"Q?7hhOOp䝲v'N88N"qD'8N8NU;哭N];h;AkpYU\\\ØZxHωS$8Jh4/WX^w}m°: @]B"j5~Q:i-߭ p5܄W"Lvy hg}[L<Ҕ Pxru$.=G=ܬ"!+CjI=è|ayzէ';]??HHv4-.`44bL1K3fS/:]IISy bS귈 QVh):K;9iYӄHYs/u+m ijV}nZO@$tK*`hx:@𒑿G`z>4,8#8#p8r*QrUʹW%ɥ.H6"K%M 3H}cK]ZV֕!ٔӝ>g f H60 }j,E:!ft e5㘐 xb-s_H%ઋU W=S #yt)*j/x}̓ьy0⏓]註PުzzzޛVLTPS(Tm lĜl9ndnT[ZOj=PjR`;ؿoikQJ_u"d23xJwJuuut RKGgֿ~1l}>y<=ycV/6 b5{}^e]:S]#;+vdzx޻%v/5-f $ovQSZւ%=5M6>9Ci\/75'92E=4Y!Z<>)pv-X8#y{\zI:y+EP9h'?Ō s%@>)}2 >z@uH/\id 3h[0E§ ٸ{!!]YdgT~Y;yMáTtf;E7sЧhKmED;\0ޓyg` KF8`g݈T\X>ưzM䃇=Ov*MEnݻ>އIZ=Wjr9jx$u˽ncؐG~z((*TA]}}}}}}}}}}}}}x8 5.qqqqqqqqqqqqqqqq bH"6wOONz: e2_eCK0IGK@ KNIщ$^f/!]X@_qor;d_D`$?!*U Pnfۛsh0~L {ׁ*A ''"U%tutW@]+z{6,ٛ&hf5uk47DweHbA$Yup!NC[mmmmmmfffffjOH$?`y{ׯ|Z'5__ኦu3wzj ۠+qJʩRT%lYRUJRb/1 G [_Pi$Qt]"HE....+zUW^Wy_TqrL ش40x3=LL.st&@6n|6i,e@{VmmmmmmmޚiaOUqf ?W:TI[[n[tp%3b斈-J 9IC9{;* z*q]TPVV,$񬚼\gRwh@)Ab>3@T*PBU * @Pr&Zؒ)=m튭D"muBӰAshA`)V% yV*ĉ X@0 @\߂m@PA>Y{xf*& gȾ\C9Dxj #ȐIC+UW *6hU}x\a#1~fL& !MH$͛BGiz:w@*Fo@"'OF*TR4MJ*TRJD PB ,,,,Ϛ6@?B (PB (PB (PB (PB (PB (PB AAAAYeYeYeQx|#Gȏdu:hQGG1?;dN8ii6i6i6i6i9DMMOB5'PRjMI5&Pj A7w;| 7➎ Ow~ DOX"D 0` 0`H"D$H$HHH DĊĀ H(Q(QDE""F"F"F"F"F"FB , ʋ:h oL"Hw~M KjjjZ5kTkVZjk7[_/a PhcxM bFg{_ NZzB0];û qٱ"!i0s:V~06s4J/C!oc> p12? h8 !I|hzo'Kvh5!/vv]e6NvBa1# N}w @I EGHKH: `A:=pL->aâaMqZm1c3C:zykIt c3iV @SZ^/zB+CNIߍI'W&аhYJ %MXB #>haK[F1l RUJU*T%IRT 8,B ڰJ :dAqIp?'ݘZ  J?|Ԙm/ӛv;^Ԇoz|0׊`0:Fxo'I4O2ݝv> n&C#tQ?lgz!iD:!1 ƁS;Y=P#z fGHڏ]$ڤ6C!>xȈ>m{!*vJt>?IZHGnQDC|+c+VG57zoCWFS/7w,H;9L49ZyNgĩiiiiiiiiiiiiii`TđŃ/uē" L>H\61===ƞ11y I+ W +ҝ|HZ/g7X]v۷nݻv l=|_7));8פ,1kiiB}G涖(Q{/?=kXu$- <Š0@MTWe]:gs?$,FKyș2z'y=/SpFh/) .Ŕ`c Ɩً 9M(W B>:8 JQ)xՅe k fAO>*TRJ*QJ*Tb,,,,,=蛞0B (PB (PB (PB (PB (PB (PB      ,,sH~uG#P#4H#r<|G֏Z!OuNpӱON|d :᧬K*8⣊*8⣊PqCPކoVoVoVoM7!}i 1"D$H"D$H"D$H"D$HXXXX`!B A"DDDDDDPXAatySׇyt;un:؜t*b:Ce“M~oԼtq:K~!8q6EKjmII?\WƑ`? Iʕ)L@o.۞v% [P)hUPBU T** ?$E(VDSGɏLȤ<Ax /%?/lGU%vEt!.H-{g7x(>{M^jBȩkֲo/uy@(4ƘjfI^!'X41~}d=ēA^zUWҼ&OQ b>F|'g͹ nDܡnCrnw= cE5IgQZhZ!eGcAF<$B08DgUF^}|er>HCiFFH'#GIywg:݊'5Rϑ}pD5Dit Q("(4e̻B%/& xpRweH$9,=gtF `w"B!i`Ǐ{z?w~νbLi磞z9sN:ӫN:Ӏ8 ѧ8 Nx/.lc2046MiM۷o' j&3Zٳ$6?+ߴ41VUV*X °'n`FרM- L6&16ź"cb4 HHB ! Db!XbXV",DwfyzVEE'p52ruf&dG+%[ZZRV, GejVP_I]wsp֣Zj֧z;ގ;xvNNN3FhhRz ]${Qw&ADZ IB@Z C+@paj\Ե&&-Vd Ki3 w0S*eL2Tʘ)b-$FyQ%8HLW7ou-CQ| |4JmL6 -P7\[m렑!%)Z9܁F,Ya@0spE CF5 10cbɚ9H, nR4 jp8PӶ;-PUMEAs »GxM~+Gf Ϭ4 NQ%$ZT[u{`]fm2jSf9ˎI-7by;xSO~Å}*ijX9dl㾯KfZ 52~,^nоSG󍹃xu$iun=x.ۂL愌e>Qu{YA0IOgVoHpzԉy4WبAgzg_č}cŲ|hl#+GSaʀ:R%"ڌM=關lP<{қ8W;bw 8bˑJK$kRӲ|eu-[<2vH)ktmHxVZcU%у bd"[Ls1HV h+7n7E-L|d)WOĆӬD"k|?&9 ܵ]!f"-pLcDg'vwdBݥշGa:j۞-,O6Z1*'G+۷%s}S$dſwsf@Y88e qÃR.fm1>8rt0ATE;_w$R>`#gPƁQ4e2"o<9_W}9ܐGqiI\6G4SDA뵳XHUO >i4@5GR@N~Ԑ),%|]}s0>JF~"3 {1K4’GsS8by/?"̆d`0DWPs3`%1QXNp\+j2t;g"_P%C1RxǴ$AWSsaYPFɭu*^('*x?I޲m@7}9x߆܅u"øYh݌^L#:1 ŐQYqLyW6ݟi(g\ $^4fE#_M͍PW4&6=FQvv+ק~:pT,(POmm]X9 S}0uNW+"D3j$iM8C$%z|DWblG|VTfI\2SQ?q>$E]5-1ÑRL~<{{7"yvPf':8Ɖd=}N+ |'x_y'fgtLPzʈ`֛o^5W'>7qϼeLcAmTIҧ?Eܬ^kklBYk5\\YéNmu~Ax6~òq> tʽC(""(^[GbQX~pq^g1=k~3\Y9n{;0I=6VXfm2{7ӄ28™yP K zKyt,VO#$Će`<84X& h1cIm n<iT?* ,[q'R$K:{uDlQ,NtHTc| )MJ;!qq|C+ [L-,}浪ݵ5S˜:.N+`T, <*u*!zk((BIkte=%Uv㏻(؟QwǺ=%Sb5iK7OfP<9SCBِj C*SxLRt]W-w/a?+8>)o]vK;NžcP AĽgyN,@s|A乻C렔vswzhFN`T:_#c̀0VW4F\[f1w'u'Z(⊄U?cVNj\C'q@zJ0+LsKt Z@ 9T$s˰DX:6j| 5vԏ_O յg l SԕFSzXq2慜}Pf)# HV(Lێ/' reJpfC.~l &9G*`H?f ,Q+@ xm|?Q- Й{*?{撟߫?M JA\NRY]eQ` S؃5Zb'1wi1ddǞ'|h軦EX;d$Î9g#%DR*|`j %6]>if R/8nyO}&S)ߧQsMo-!ꇸ\^6gB/$u&{ec \'!pMK˃D_;m7gfq8斚5xؙ=uZ?n{luʄ.),&]BK6m9yF fNdO29]X@,]ΚDgVp J[4lb3J ws|Yύ(,VEϕdTGXJtk791xj}5r{gywe|xܔt?s R_VweE} 'Lf7"+'qT@{pkl ߈CI|lQIdl[pG/´WL2_ڿ rhhap(w^iJ* /+y~bJvV.K2G['$ 9*UP L2hXfL{{zZyo!/w=lWՇ+j(,mC ]Na*Lv5&hB|/)nOBi26NV'|D-ſlٓ4ƶFh2Ӡ'Mfԋ(#ˎJaVH~>yg svXX?KT]5ciX[O|ThbȣML0i J켚p?!W,%kˋ✬GKe-;[K(|- o~@U.]\VkayC|X'}!`ĩBTI'{GsͰSp$5ddtO;UO Z?zߓ{W_p#'PJH2Ƹ-ݲ#|s7-KךO񙬂9)}8-™թ M8.?]C-#\ yC fu06! /gGʥ -+-G}( ܬ]gX(G>fo Ҏ^[$_2%/ m?iRWg2Y6O2oqnSڕ/JmQXھ {RnT [iv0{zcЇZi9FyN3EE }UK]2jyqiݹG ;;wJOYŧK ,-yP! X!VcuD7ҁJ^?~ymuϿd ǽ'Cb:xbbB!?M\{LrqZ!3^UC Ѓ}ҤCũ;H99疴㽞\7u[{msp'Dnre}_cv`inфbcuubδI(nSWҏG]Y휶Δ6Yz{lc^%,dŇMpPQt,"2 b*27]O~dn#ĂR; Ds0 YZLuminescence/data/datalist0000644000176200001440000000044013041732307015323 0ustar liggesusersBaseDataSet.CosmicDoseRate ExampleData.DeValues ExampleData.Fading ExampleData.FittingLM ExampleData.LxTxData ExampleData.LxTxOSLData ExampleData.BINfileData ExampleData.CW_OSL_Curve ExampleData.RLum.Analysis ExampleData.RLum.Data.Image ExampleData.XSYG ExampleData.portableOSLLuminescence/data/ExampleData.portableOSL.RData0000644000176200001440000007757013041732307021104 0ustar liggesusersBZh91AY&SY4Iko8pJH pH+57oF+Zg49Ns+5M;[NS{]X{gfvp6Z[(suCVdڰ4PF+&jve64&UE^ECvmJXص,+m@ɶHPk"[0 j f2VefmH4VDFڭn]1 FM &0 4 A4444`LT @&0LCFjiԟ{ԧ'!OSzEIOSS4z&`CA'@Rjԃ@4hMiƐ44 =R&4M 4@@4h hh JI4j z)Cd 6&MODiPԞ0Ѡ4LL2a2 2M6h i3m -|>r9sNvt:uu]d].Z뮜SMvt:uwrw+˷b.Ww];vRnҝt].wKtnv˻SHu]wAr;w\\뜝Mݷ]Eӥ%wJcu]s%u7KvW3vu|,>82|1W6`KD@YIdxP!0`QB!DIeʆHre\Hȁ(aC!Q/ 0BJ0fPD8PTx%HP2:8a QC$9`Jbp @($_on3욾a|v}3-+ӲS-.NE|z ǩN*AQvWd\T)`crI:fӳps̐xKqMeں:-IW|zyQ*eEH,S?q#$ ).,-7ԍZZ'f1}Yͅ!gRɁMEH 3sW#lbB< ug$'(j)Ux*pF(Bi[I6tC}!'>י[ VMvqa Z 7M)zcb&-:Svaty@*dI9_Bʝմt]nO't?EU "N6:޳h9ג.0mm .js4<Ӫ/!QM]!^P`/t֕'P$؉]$~-lIyhjCa9sɡGKl$J쳚U61)Vk:coUm>ʞ-R T..4TdPmVBsO:P\l\lG'}۲hǃzƺ ;\]^khxc[0OM{ =yIv^gro/8l|er+o2^/}-re598˶xھZgڳ9/ fA}t71w_fbHuGy[VħڷO{Fy_ϛw\۞ax]A M)y~z[k~m'DپW ]s/svi?{[drhV}7ď)5px~E_r/I^oڑ9: MY~7 l d5ʷ^ȪǗxbڹ&|wZޯ4v}f}kF&|jxfmm&}c︺e>NY$[Otg+5ĢJq_1?%חs~:.ݢ^֝vfrX:"Jpq? ժ+Vrk[z^=e}9N};;9wk MqYM/z0@`%hѩt{jJP֌R`W̼%.hzS]ilaVaLa0iҙ"5P4SY\i]6P. R6Ftk."tnqkVݢcp\)gۺ AUV[m5'׶g->%Mk Zu4%}XÉzo}ouNJ-nlھiLt랻<~9=?Iyw n9ύm8rzcq[q{gM=z[zc $q{pۍ2k_MMsr}޷n>RuWO r}{p~k g|mon]-ڞ{zmS-> W믋6bSd1iڜg/^ufM{|lὸKẋqǝnϰբ-#י=9PEzGϭ7ͩN]6>~}zn7Z9ڽ~cg:?^F᠙^ljҰ=U/{i~'ş^ƚ=AQ)xgIݍ矍y+3Su;#^Z۵鎻{ۧ#f[~)|q\Lg@=݃t>,+_iTrUa"G{v{M-Ӭg@NmϏ~on޸3=wo`5i㿊C)OL:wjךeڧ{zN5{7ߧjyR㞞ڻ}q[=auqs}GsǯC}}yǏr:p~yawх_ǾVb|=% n$$?` wD|1%g-P/- ʴEzd_HOZ+ =_0<#޸2-%2rsbH΢{_§X#Yp2sZKB$ lj&BO@DTQe%N$ (5AIe] "9%T S. 4PP_Y)$%1)N!ʰOE͌@!tKIpc%KFp^(d];- qUj҅a$ݯlI0B| bKdRE8鲴Y[Tѱ.װ%'lGU󁿦Dl?)c8i/MFBW$&Up(x<Rf8SG<^ }ѽcwKηT^Z]#n 5_{S{;bHtdsBo[>O| bY` zw Y*IgvL q C{ܗ7<4=p~sA{%#b8/}dc7UR]MMYk#{:j捱Mo 9ڜF3gwqgde EpMvu&/ ;)Ox'X/N0!ɁOwc,.nM5ijѻ^黶ΫHZɍ]S *42Yegxλ 3 ^&լ).ᵄĶ鱖g:(.ֿd L^7|x/('q.@_aTg_2( ۼw‹aqg@<5<N}N+/eg /6Oi@Lfvmę/vG 4l:e3 ~m?M@s>0,E/L: } t#/9Sɡ琮J:8:R}bt;mAfeSژm-q程>;߶;_x=ڢ_dHń ]4Y54ǿ#@s^pvրsYX@*yg?1x;."847e tbŸ%ӻy'Q8iC<WRkxw7{-"#N 0]P3j"Orws0fF jo<_Vǔ}_ l/g՗;Y@YuF;eh}Hgl!Zj8wF?[hϓj 'M:%<#3[ӵ2In: K%΁3aR?|9zUIܱ5V9%7 o[;<7Fq?TȝMۗ q`>NG0% ]$)c> L hpGԦ|!V(? ,*3nU)Gqu-)3׮ʒFw fڋc#1:~ ?{QɆT/ Q싧)vԤݍs;w1lGQ:}a+u;aC{uJ4|dDU mj=055T3VXa=3yJ,  6$~q~yC@D{ @I Qa6|aQQ `\~\+$E7-DlZ#d*Ȇ:N놤˻s%Iw wvl ugz *,  SYȅPIUT`(H]ܠt.^x#S^.;;vNg;ݭP $H(6 **׵{kt~ʅ%8NLeV a_ )߉wD;7pq$@q$Vg>\ћC3K8,$' b,E&ȱbc.F `!z \8P :P|PGD$a 08#xHp|]_T (PFY*mhEt\|a7xoF78p.PUŃ ‚ՉfƁ*Hy|nR߀EǷmO"9!~l!aph QItFnw*l\qIQEŽLX.ԉ_Qa&NFGXdcv~-Fqx.[+nvaؓl T`j6 w lʟXJFǧmnG;\K-ɫ{ );>C>`w@-8jvOD%kH }zEz ,p5Yߥf[e޽h.O6j,KDhtKfҔVEFxށݜ7f9K<SOLlb(JEK).sqwpq"ȉz,ׂ0b&"D". %pvuݺwn]ۮvХpq̎Tw1Xdq 0ފ)3֋T,5ydK)kRY@Cэ\8qZSI Uf ;4-%WVRUd*, EâEPEb@ b(HUTb@($@1y\ #$l"[V֯KUlU @`"ADP""PP""A "fBش (DP2b@DD(D "jA `P*EVQr UI@[hs>UA(Ci8u|$>-iƲH"_l4~2ŸRV޺'RTp abeeD/@X0nhw/y+F  V<*?`Vh.PEbX_fn|eAGJo \(&zNEB#z>v:/uWgsA wnAW AZ _[_A1ڶ6*]0]VrJT(HiD۔w8x\@gCAɗE4DT>=S#Y4iR~A˭KB^0\ֻg ?2ǷpEΚC+}wp>)xύ1f{k6]&O De P#ш`)z|x!W:C>4ͥˤrUoBIϩte]\G@\ ;qxQwA:ށ V qEOv2*" ( %RlDJ)MH'7о/|wھ*"w4H(2s X(' >fKmǑ54,A(4.XBwn!SKd" @~"3^9s/:;+@Dlj "%:>h*iw,D\~E#*cs YBrT(7#r4YQg[ rVlDT+mF)@P{X  %y@A>.Ir*51[0#Yi~"θc0w=N6U-id|/ 06 =aASԇ1KYR]%`%] qЋ..KC/!),v>dk&JԒi- d2I=q}fyD(z^;HY#ԧ&VmoюdeϮmT>huW`"{p+ ׊v̈́;hkx K i8b&cW+~S0r0ʗET+~DĨ|?>W_{gb!_A5psA4A4)< hSw9bI1%&LSeI[HGN3U,K]Pe 3`jmxɂAqcXFi-gh5Bc]ab??sY:E`,Q#hVޤ9c=焵duP|j-"ѕ:&T)"мV k}l'UQ;yzv7C{ _e5: AR@"2@ o%)B6Nz_ƣ:#_wvu ,:F46Gn7.1ߢrF'!<)ުR=b3b%ꊗHPLG@Nf7C%1#Jp.A@0uG@Bb) 5P4Cxyex<Quh*y Jy6/k`2#+GH<41{Q?d:pLKZd̑dLtއ~t\8yΚκ']xj-\i۱L#z ԰,]r}fS\huF8ܙX"0 B `ihW㋲ݏ:tA98X}iÀ}.*)0}>I41wxm῿ 9EwBB%仚oBݵ2%tt4] °q@F0qf&ozc*|o01nڛ?ba.?iX]Ujz$`pܫC_ |A"o@ Rj\ }Oo'Ǡ<r&B$"RLXԿ7!Σ:O.rU?vQEx HI6e*;d{EyV$]Z -k]գElI{&k]^nt lCyd{Esm AuJ}X>e{x(Dõ q2HEV a7@u"ڪZpI%Va&bnjɴ1/6ZTR% eZQ"N33RE$e/eR˖KTg ྱ@?l~x(%3r9*Lo r:g;Dog7Gv nCW>(!v/w4){^kMRzڵEZqh`Y2Ī}$F d'?d7bE"."Bin} n B[6N3 G8,Z"ͭ{VjZ=l2l&VBZzү{N%]CV&nlIZ.F61P8I PȂL<F٠n, wC9_%|L])!mLU8E2Č$$$7!Q2cR RB't A! !)WjAÜ<-CdU_4Kͅ5j-xuЂ{ZKR&ZGbj!4O{ | V\/`lONJ=-}T `vBaFWuzc6d{[&*UQ|ZZD֦JRZ⎬D̾d?a6`p^ү0y,J%|)q[=GӉ7]lb n7 ~M* .3'ovN/!\Z*"Fy1#UV1X 1+(4Ud)VYcj!f BݞzUmI-[Ywpl[0˟!I dBVKdH\0Yy5qpb)c !XߌeV>n,+f[|) \^k QCQXRw f[ZZ%ZЉ(vfm0bf&#vo]~Fߏ`wuVh{><uy !Fm7A5C`k48k Ak.ONly_XU F(.kǠ}tq:10ԙL'54F%;[ףpJ 8<<嘇[|5 as "?h)\5ơ^En9۔AS^$>>+vm-m`%xM){P/Ҙh"4LAy2T񥪖0b]/&Xi􀀢v:.H(Y"ξِ4J46$CςS,J4RHA P!d̕sE;Ȟ&3J6ajʽBNiqo$Ve@ffU./:,fQ! na1i94f/A/0SKI 0١aqu44y 7X"P"+5R"Bj)eBTRBDL2*R2 kZ 5'*?.^Z WZ\`Ҕiw$2g9D|ޜkNۘwy}j'>WWLjc@ " !$9伛k,U֢%A6bZYG7.ͺtYW$5Ęƶ,mEemR Lj/RkkTTjI5mF)-uضSnQm]zǥ[[WUkrdjߝ ^ɫV*ŵl[M[XՍb֗u-m[Z7x֨ZU+!j"H6в6c[oگWEkfgݫn]%H[k`)*wt[VId(Vc4kfe a "VAX@bƋ3ͭ IdI[dDc#MmB($J$45l$Z%hj6[5j#0jۑkntE5lv5lrVخ[.Z-l[[ 5lXUPckdlթVURf,j1E"m4k*٨ثd\IkcY+ljUڍj52Z Iآ5lLIjE DIRlQA[r4@HDcTID I!(1lђ4Q*1ʐ%3\t# h.nsV F墍,ıt 55%\FE3(4lmFwmUf65+]A,TlEiVX(hAhԖKT%*-jhbvr`Ŭj͊T[XfVpj[oyV把FQr1xZ^ b TcZ*XֱQFZlFI߱Ok6bƬlbZmc[cj6֋V5FuUUEbՍm^jksU֨TlhZZ&cUUXյukVڹ5UDZI'ZFDT* ]5Z{m[:Z;Zjlk1X95{=: i2I)ɓ %D!i1H$L`HM)D,iM% &̄M"$X %LiWa(J) JR24)4l=7O+hRLQ12`JJMd$ILF&Aff b%B61 O&&JB1I"(75Jʊ$!2IDJDh)b43AҒk;)(Y$B*JiId6Rb1,vWx^VҘIIFT,ix;&JǛƦ"Ʊcd `%kyyE;jhM$x(fk$F:%xŴ%+aKFHOKb[%FқREdi56dm&,%WXmEb41I i Im5%%^FěIFZTJMQIEXjM4mO*k&TLZ-TzUyzjY*Jt[x6M[uy~3sbz JPI$ r=UW rCW-QZdۖUkjkrmsTj-Zc[U2 :(Tꘊ*%"s+4$hUXd!\k^8ls%r:Or{NMjj Q^GբvWUOs ě[ S[C!pǒzAvKvp5%[C 'ޭ!yx{zZ7Q'`7\RV(`Qz*|Rp"S7 ŀٞY'w"|"X p+]lyh*7*}c/D4\OJ͛sz`yScQGmW`!_==="q'ASK CC u"P1^X?k+D QJ87>$Tͱ^6'ټgޛ`dq2>`%k‰,ɨ%X[RK"dd쩹TSQ#+Ű&0|a!0ddd'9-4.g)~`Y4=i>R:KX8v t YU*h# \ |`e:^]l-7#3&*r'eP5pl<_ ]=:xA`azӫgLZFVm] !UM[RD 5S kZwPDnZ0<{:C SH|aHcF_ѭhu>uy.&gFj\yMJIN$K5PN$J v=<3 <(` >c@'2%"]"]~ɀD ]Gژ.VDpdz][.{zL}Y;Ӏ-}Z`9uuxhhBM҇ v(o&k,U7y~o ﴕ! @ܭCIss"Vz"trPUhZD9RDz->֐5gt(U`-ԫśV?:'^&uڽKsHaTq׈H"E`Y'+Q2ԀV0z-Q$@kyC;,*,>>]CZo~*1Ȃ%'r"Z$I ])ͭD׾ݙ+|Vd][{.ĮR}uR = ӧ`VኧZu6BP4`@\Ʒb|U hJ^( ̘Crd|:ΈCy⹼9 _Ȉj1<~ n A7@VLX" \Qv;=j^b ܨP&612g @]lfUͦw$6R ma" g#9`\A`~9PpFp72wc@!fPD :Ao<+aHBA TIrn'|Œi1" L2aixa bh>h9`8Ǎ15s7 3 ?#;dj' ѯǟ4/@SUF%d{:A&+5>ś}~*;;9~4AD6bٍ܄TZW.}0*6yEٌ;%\rO$7i-AO6M4nKCJiK=@:%ʗT: 1ޕ.n eQ1D(6} y*P`zE@(JwD߁D|ՁUËoM'P&&& ڠV(_%`\MI[͍>u%Ùi+Çgkz%{&qR䭔^@A  w9?]5e/9}K¸/J$ .W/+GᏄP:@ޅz D8@ڂ c*膏y"2x0tlN~9B[-_liQ18˧E%E}d Z'C@~8"y3x}AsGw9b t NxP4ӊ@X"V(V wCqazz4g gf `,@&lJ  `?<&5a?yo:$қԝ%QE "o3l7/<~{R'8BVF)∗Q@(k? ~#gN{kr}?4/>Z?.8qX2qjqxȸ0qR31N݊Q1檌V GjT_ nr0tW.i$;m'yyA5sk>FH^l0T(Q18"v t⁦3~` YKI\MsB랜%ﳥҁP/@W P.'<*P+w "T w`"_Ddm:Ͽ@tCQ]O^z 爕%y~_PP-oG3(?uF-LxqA"t`X(KnX{@v?<{t#;8ucrqjP\j$C/_b_nL"n7PDx%` ^P1@ "W." 4gpT-W&Tza=yq<'nuDc 7؝i 0E1"Eݿ[AS! A+{&ݦwZvnF)[&xo LG{ R1@^GXo\=OPe4Un!@sgB@ǀ" <ӥȲ㿱 Q u:+ZT@c/ۘh HVHw0J@ J^2 ne'l{8 y6eT W;_aSCa'_zکN%i~i.yMYVE՘\0yn*JnhozcLp\vCIִL1k78,:>Wlgc/6(n&r ;4eb 'b]xlA._EfȄ*` a}vUEr Zc_a!n ElktqdYO8X~#ƪWMﯠu4`3Wn$sK~AH6Pw`Lw!,-:i YF,Qn# 4:cݒ-A@VNi  ou\jAoT߯Q!|3wq#ЯVy4ulܩKzEU>R:akNG/IEPtPN}M:uf6N(5I*? _ 9-V3DqtON+VwkDKqT'FܕDv91l8!XpbNOy>ܺŪx{7gS;M߅wB/v >IzAyWWi0R V!7߂g~4ģO}"V$cIXs8R_큟LJWɓL[v4Y̐Gl [6đXwz\{QdC /Tggةř?`""Z\S%\Op/#@dI:43:8 2 nKQ+IڴLY>[{(w ?o! eK 0u>̶zuyfuJU sVWy֯tīg݊4[D-*5T Ab]` e,djqER EVxd`+HaBR(M,GTjQC=6HG﬉צ}TZl\KT+t`SʁJ73R$I a48bp:9 7;Fԋ`UOѹ0xaж%%H3zv̼}<|_. /d c7 ,008 ,H>s(] $ʲ}Vu< 'eE7 Oo4}V󑞁^/Tۊ;v>isg1]'5FTʻpXwX.cw2+ϖ뽭}\$_>Gfn5iߣS;0Q?u8-s_[ bh6*o-^ݒQb֯Q]' BP(r>Y~ʊ^ Ez9چrIv?^`*RSNھ(lgOИK=rD :DL{7HA9he"Cc_[Ӟ@MtTzfQQK)E gPگ&yd́Aǡ e!XQg(Q~e:ܥj`bONPKs?mm*rѶ]K`FzH`(O'JP:X. K}ꢚ*"9 S읔^0}~gnWc1" 7w>B%ST?v!>Xs0Ll;8v5Q^;*S? T/ƨ$JT ȡ\DԊNuSmΟqDKcl72r^`-%)ܑrj;D9ڲP$/.JD8jB(gHG0u<\ 9J5L*\<p&dND^|8l>]~ /n?< (pt5Q9+}B]\n0l,/QE &OJr] ;TC;VM%KCa Q ww,ݛfO0 6TU6xpNfCр_bH2'_bgj' τ3"b(Ӣ0`vgrO)n{ 6"T(Q IvYDszzr45ϟĕx׊/ML@}ҧ!P=_"0n˖{mq ;9BOR!9X/JuK.w.7Y6fp KA:?mO \`FS>2"Eq-':7R[r?=+|B*r/jEXZQ7}$-&S0A/)i 5BEGk"[ F5- p0-!xk-ba0& @XM/'l *ŮpQPƪ"Ui ZBC+sP A0Do@a g՞# = !U;jpc?:ftL qfeSP8F9#X#R:0trTER99X)rgu+IS^全$aAQ%9^ɠ0b8>9-}B'Q?|*嘲`V_QQ1/IڂTfOqus|}=Xg`rk|&>K-QCix _߁'8u밃w'`BBPQ&= TL^j6^;>w7b b<\,DcAK&S<<~sEuIӮSkmD) ܥCvPӨādP`~PDj]׮^"r9 XA̋ 0&<},X;L49}?'7a>uoEew s+g$G_hT t1=5t*h6>OU;{!=bS?̓g٢a&$9%g};G܋jlSAC0[AjcT6퐼BL\!AIUK֡ް[:PN  uJ?*ʅʁ4 /&ڡ^*({uu,aDzLoU݇ϧE?GP% H~ *nMqnw&>1.{zcM`ulBBO7݁5*b1`ᤠ&>RԩdIV7" )'EMBzP ۔<߻v7t^4"yG OVi/?]$_ /ao=H\7L%HCyxԴ^%2EĹ`.w"FS t3tVwP~H㧓 &[lbghgJt+ a@4u8PNSwCʨ^^Ӯγ-pnG#:ćWm2E;HAPw*sẂދKK!03A;#XP1e)=q' ^䳎7(/ts25m(x;ԽˀtVOÖ8Q@լdkV+iE xSo&)< 0{~C[:<.JE=w& y!A v\OEbdgjs?؀ U|nze ,Y0~n=CD h川pœvd{ 1"Y斊y=#i.f\O6553Ul2W|:f4R5rD9 wX?}( ޕUj'o-aqr˪"A&ީ?MJ"]ZQ""H>\6*\‹H Z%zZmЭKebRRۨZn I 0;˨Vg6D6$üMV*O"kt8?t4KuoK֝Q F~[5qbEDUVN( +T oo~Ov\}[=3/u(R)ETY PYUJ "5BW6o3K"&z-zh^-t^EW״--lIyKmQbҮj(onv/TVKExk/Jb \ۑHwr6{ڮj;#E9oX}Sq|<-1ZAGT]'rXDS‡{PCikڂZ1Q_ }ACc̿لy#V"=Mu Qe@&zdz ǗK3F^jNnt-~WQѡHA>g0Z}|Nwtu#|}ҊY.Kщ?-61~,z\90T@oG( tK\˝SX8YE {9`_N8rUۼ"p?l!C0 BP%P" 9֘2 ELS%SY!{B "T=CCGNL>rFV̀#ndsGRw~e̹P@k_貃X'%h[]$eYB '7Yɛ{}3PO/`H } r! EsjUz8GTM#1T*z1,XĒ'E40 RApG|eL\)Ns@Nc7~ƘSϋQ!Z4O}8o.^ i1{hkYz΄Tz?nab&b6 7vi.8l|] Vyr}/&π' hxlS?c_OD\O̭U6$}N T iYuklCZX֡A׻npGTL~ }+U^&/D:( g̭8D (0@l$nK/E!mwW^i*4pl?%lIA9*g@20l#O 4MT<t3U> [` .>yL!l#cSKs( \P/o8P9!b˔zx%=͗l'W/Kw-Epj'~j".^iY\SeTdj=Hn5>`vw }Otʱs b|>M`Cq5:kwGdn\zggǙ/ (gqQ11 g1vem `tq9.j_bkLPۢOw_YKp艟X Bc^4GtXĶkE#D-3̎tR9xl|K']-U_'꣧DȜś6NeM]#Tk IeV˸jI92MFdV$k&ITI1UǘLV ܟh$_zioxq (@ i($BD I !4J rm_[RgʗJK9+1bgr44 'A?J|TB0:1j!ce=}z|LPԜ4kg|H=HqSK0= 2<Ӝ1^TK"/it+OA>vk^.+D:lPVqnwzpi~nif6'% >E\Ol @!(&rkx;HjG3C_-^`D95t"`Ԉ!ㅇQ'xq$xI X*$);l#Q. 7aN7/3d`2p[ɾXdi,igоha- [NGѮN#5w,i'jW1.s(iY[XV+dթEzY#,0|2 {s[uC !M.)اԺlkzw8*uaI2'_g/rP^je/kvryqjW=9y.S~Fp?gT 6PUxMdŴsf8"_JE iQVm$p5+E,TUIP88b3D"VT*>Z PP9T*8uHbyq='_3zvX+ "UEO"(H?Luminescence/data/BaseDataSet.CosmicDoseRate.RData0000644000176200001440000000154512517732767021523 0ustar liggesusersT{HSQmKmjIEE"QZ!E*{](cLzы^FER" r36 4{PhdAa{΢Ё{pz50 F1R(bW3B޶bMvW^]m &{aho$N̘ +s|>vYT kVuPWp|B%ߖz嗀/py oȯ+pH( Ј~<,/O4hRA'">!y mr>ߧ7%؊ThI3{'6__},_ڗr 8oMl8wQa`xO.TԬST%PĂ1.|b+ܙǁOʊq;f%\-B31q3ȶJAI}y߀Jth;qz_Ty@B3] H& |L2>}ǿ>}/@>}ǿ>}/O>}ǿ>}I>}ǿ>}oB>}ǿ>}@>}ǿ>}G>}ǿ>}E>}ǿ>}A>}ǿ>}_H>}ǿ>}ǿ>}ǿ>}ǿ>}ǿ>}ǿ>}ǿ>}ǿ>}ǿ>}ǿ>}ǿ>}ǿ>}ǿ>}u;q??;?????????????????????????????NCy?!C?!C u?W?!C?!C?!C?!C?!C?!C?!C?!C?!C?!Cg4?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C?!C#}A #G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G?#G_?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c?1c? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O? 'O?d^')SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?)SO?:~ 3g?c 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g? 3g?מ9s?r?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?9s?>o} /_ v,_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_ /_b^_zK/_%K/ٹ%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_%K/_W_ +W_ῢB +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_u}僂 +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_ +W_5*O5k_5kT_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_5k_ 7o *6o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o 7o-[o-[o-[o-[o-[o-[o-[o-[o-[o-[o-[o-[o-[o-[o-[o-[o-[o-[o-[o-k=2;둵Wu?L/T]t{Zr9W]vRW꽳josk|jNU}u7j =qomu߯n9Ɯ[[Ʊb<7{:Uxm~_6VW_{h }ܟW|_~ vڿY,/V~6_8xRkgkjjI㷺?ѸSÊ|zPulܦnmޠV{67ǭVջZõ;&ԏԆn{[63Y>9p 0CϨo[UyMyM_}TVݥnURlSc_S>oqSoU>lf=;p6;gǴG3 ճn㙍j˶q^⮱rڸSqN㎓i7?}sIb|J9gNgk'RN>#^͉Ah׮c6Ώzu: znq>r宻v̰>_$m]w] Xqs3y7.OgkUxu)8u׼]bT8uקXwl:S Ηܵ+li*+*TpajƳb]Zqr뮓꬯x8uצ[ kdLVӕÔYscw M59ʏo[{ߑjrXGo/{j˶s⮓rg}QI>VQ{ 笻Ǿ0 8gq8P}NW|~*+*swǎzNZ_kL+&vk9gq_[nf*_g+6Rop~.q):kXξz{iuI6%9*#.yZ'_R+/'h<*=5Wg{/R]h߳UչPۮS\Gh?{=紻&= k׷mVs᮵_ʡΡ5T8qk٭k.+.FտJmY|pr޳j!=^9Em>kܭq]1p>֌db룸kܬFmZ΁FF*Zzn:I =?V.s|k=Wxt@MeIn̯hܶEܸkS>ܭQw&֛]ɮԷ害+&?R]ְ]C;yvׄZJ]}w]Q][ɛ=(ەVpU,ܽou͡T3aȮX]sˋѼs5]o59+GcuV/*3}죵VtV]^ul}4ų[kk!#tk^s؜Fx+'zYeSeRWT,+UrZwctVqLSŴ}|ŵz7Nw-Qz:/5>Vל:H{;tBecdv7QR=Pu8w#?4V ~su=}.vwuk*&b[shhhNmݕz uЖrn뎫֮́RG46?Ӽ.e5{Oʟ`z:TcL㞤mS5v?Em5icV-W⮁6AqXWVgkw;}NXVv,I}ue~baӭيkn7:o;hMb`:Eq;;MQ65]g5U. cK7nlr`mMV|SrheSmuh̄vusLw{(k(k4>;fAߊqr:WB^X cI~bX{?Tŷq~;J~2'([j4^~n4V[_X|[ھQu'*6s66xdT~Yw;MyLwVlz˨+ƎXFi]>\Ksjsg?JdqZ0WU[)ini{kָ}}FXc4k,C f\i?; kk]?c*;il*G6;]c97h,nh~m9TTs4/㵿+);=T')Ӝ쯶S8e|>D}l-ubU5jüZCssdv 1vmL+~>fk|nXnm~\:O(yP[; U͛[RoYZc]9ڊi{ggCy[KYUjc-֓{`-k>χzMjwCykoktQihmD)6v^fg*~[Sg̞;:=NVnPfjobz6ӽ>[x;kl^R{) lmw(cV5(fo1I6>*W)jo]W9Isw3A4Ϊ]MSxs{{}n1l1.jwkR}qoqn~n[Rs4+Z}o]Kϧ)eV\:˖]V9ο;^RnXxlOGz4\9*/O]6jǎ'}gHwsw[]X\ ,1nw+ݵ_޽]| [GYyƾ7Uo9HuPagǚOݎ e4΍1ςМLQ~k$nuT򚳩sr"k{=Ƴ;]@um{Xj㵟lq7eEvM1Z84Xe1,XNVކ]ϧʿa)o{;nqoLJi_{s}zn4GŖDWu%o5tZ|֭,|lj^wy|?x'(cݎ+'y[j^&i8ܯ\m ų7Y}+opvx48ZS>WP>R=;^9Tmo+7W I[)Ufי=Tg5s]k>o7!. lTtQjkgp@zr鹧qʱ}-ߕaJ:v`tlZN}*w~ ubk><7p^~kh^VbY ͣY[˳͓˓f5Fn8V47nx+Nkk.l<+(8\lr\LoEo~*r~Dׇ[zon1%L1@cᮾkgq>Eu;IXmMBTYF-ͫ[j{QŵVU"1knn\}O9yYB%:_ݘS.'.o5vm9u[R}nn ߨo /u}(9 61W[r7o.63뻊8FkHǵcy#nnVk+v>JŰn7K/j|| Ëk^j{/Rѹa},or#:Fqh!7p 9 Pkk\me*]N\;+tc^)c]N^8WԚYśF+/?rum>WrӯyKm5МGZrn7G]K(ecWh.#֤ȫZcV!u8A=}<=/\wyt]]zLq؜.χh4WnhVN{Ovkjk^륔TAsP+iͬ>XN|"Gkr}}].Ž;wrmܩ{ 9q#Ji]<܎Ҷ57(^5u֦&u9tErjCtbrwsrgнwZ@<#\qyyC95'/ ̸sw]+O;gnu`Y?Fʝ->ւ^V#7_<<8Vc5FfWϭ45yvkxDޡ67-&X+jXt>Gn~yݘUV|j9xQ.Zv>5z>{EXI1ƚC[#.v1ui|=q}z7,Z@֓[kdCs-{u櫟4;vg֣iA,ضg55zxJ|Q9}}G>Gyf{Zk*Ѹpk#tx[U=>*7DV?Xd!Okm?ܭoo_Ua7V{ūc[h=RP|K?r7n].5HN]>pgwcq~\|uBhǹh G>Tnaykd-s8w 2Ϳm~ܬc<5T<؍!z;/]D795:59;] ]yJ^Ԙm{T>K~9ymhN9ZZǹ59rbC=ڍźTo{xK;ǭO]=BBݜ>//m~ݿn>V>5ڛ>ok}S1?->Cop~et|x.cyYqR(+:\1~V2~wxopx3|˛~\s}-)Ci~Е3_?ۆ{ZkP|Zq9ҭm=ZXN}S/)6~;LPZ`^=#>Xy6~~c9͙p1vϏ93j 7<5s3|i0rwoy#7p;#7p q;!?rwo;#7pFn{#7p ܽ ?rwo7rw;Gn#7pFn{#7p ܽ ?rwo7rw;Gn#7pFn{#7p ܽ ?rwo7rw;Gn#7pFn{9ufY?ur'g]Ҷ1];7ʪ`ݹ/}5|o}iwW>i?{PCm_֤.Jʢ\|w~g' ˶a}7~il[QmGhjCcXYuGiUz7z>Aa}'6nnVVpǿưZby?ok.e {9XWmW+~׸TVPk8Tg[]m ~͎4XIcm͍sb[M},WT5YE9_sh CYMTgm@mWS4cUh۷cujӏ_3?m>7ׅ\]cYFyZKoV|XTm:6km@hIP,Ǜ)4AcoeCe#Hnm9CMQ6ij{ݡxX=@s7~?i|hhLjm^KNTl ݱ߭C7`~ǫo?]oѸ7~xK(C9f!S5TgИ,Ϝ'̿X?YNUgkh^kqsMm8jgcb>4~-Yj{}1<SB?4>jgscr3IqY>7~k( 47VqmqLW3zƊ6f*ܜ6;+/35+ϹkXsop혍T6W 47挵iw(zŻDnLUl|md1{;)4G+͔>7Cg鹽7Wޞokp-՝]jkt׶Oj{[;NTLebspwmꧯb:k?i kskW?ǻ6C_q6W̳fjo>CUS3,{YuQ1yLwR_­qk?=P=Aw sAgiCc]Tl1MQyE򲃶}F>mz>SgU]Ki^ r^ձk,Kc>STrYl i~^Cqn1QY))9Fb|Ƽ\YG(7'\gszmbٜJu9ٵ׼6U[(j[=qy:T6j=(>ʃj ig{gi>lHSq[תA񾪳|aq\PO)9PU6?ۻu;B9R)C۸y9ҸkokxnXkXr>h UNP۶ŚSz}bOclvp7T}]6.hhۗߨ+_?F˫[뷼45C]TE`_]'K5@P_Re7zpb6iywacN|G/T5/8cbP̿Q謹(}[ƍoNo7Wzuxxl/Rj{{_7i^>oV~~8Iy_?1[(Q[Wj~/U/k WOric]7z3aܧ8So]'[7iw]kYsڻRu~X.Sܠ1[{jUznݪ6Z}Z O z{ߪrkϟ|ޤXl]Z)^f~6~w+;jv|ڶ){ʱgul1ܨϩ ϴ|'ʽmݫ6nT_Ҷ'5iY=rk94'x5Γqj}ʋCmܤޣlQNoϏjL4[5[?jae=껟eW'5տ`\nQQO*w*OVϮyDyz]~fAyXm=ݦZ1ݧVw޻bIپOk/4u;6[L{߻էu[oOݡ|n=Rn~6U ܸ/uךZ9ySq]q}\W߫[]oףwܿ9~]_j>PGeoPSc۵]-2`qZ<}Y~_kf~3C1}{GjZ[o)G/*{Z >V[o)>ְ]߹|E <ܧvnph]SWojM˓7Rl,?֥a׾;QbMy !ל|Ϳ3mk1Z+X}}%C6P{V?T>3n- Rgk.C* [a|czS#h_IsXkTwYxw|u֦ż`u2űrwkt1mUŰ|ҍ3VDzH=yu՛ +V9}Ckq΅mc*:Pm.͗WU[vsX]㝧1Tu\;uk~n~1?&F9s;rb9_Sk4V1Űp턚ŵ>.n}OU3a ~\E_Gvyn,ExcYY}[z\O_[7n,KUo ]\~m7PjgsƳChV-_y^=wXc[KcZu&*5=_KuTk~ꌗ84Y:*i |kkssͥbڴWkmzmǣ-4\O4+d9Z[r:CY\sѯI[m|F l+gz=V`Ubwcoͣ4[x󏃮~zPj컨5.n9go0YC7Ong_rjo>ô_Wۦ(5mm`vV.t\:in6Q64^w4g) h{k;LQM87,`l׳zk=n8Sw,+x͵w;ܓkmrlm~{f)_{1s+ޛmukqr9Fm5ƉCbc?GlM9]Ayck,11> $nreyc zmښ{rr`k7KӸ?8wTg(/gj)ߛhW6k$k֚rk(/kG*)-UpG?()ӁH4>M5|bY6{<~V8LmjiOھr7G[|V>,ƽ5*[Xų9Lc?@Xqmu?X1XNϛS ˧4QouY{Yӎ ghVwUԖV!cO<ǶoSZ+{6ǖjc7emԘO|;OszWt׭ǽSC@Y}ϩ1j0sꞬӘOQnW9ab;P1w/jw>IssbOV,V ^wN˙zm8A?M9|QU>QܶPNW,h>>W̳aj{}Ϡ񧊩ϣջGyb8RXRL(mDgkr3[y:Yc}bBQ窎ż]uVz摊|`nmưrgk+qznyc׽)dcUW۾W;ˉyn>>'mW[^V|mؾvR ϼn\r9MyX]ܞ:h<뽕oYwn}Pu#w*WMM^t-㕊3{j}r4K휩1^6:Ztop_K_hz~e7E>S_sEWAp|_>OU i['^֬=[7j<׼8Ssw6;V^^>k,'')bиEub؏BN{݃n=~]Z9uUS19AL/QyQzzb~?\}[Xs}c9V]R{)vEg5+wh g(=֨V_(f>d}P~ڹV3v~6v_{\͹lLuminescence/data/ExampleData.LxTxOSLData.RData0000644000176200001440000000147312517732767020773 0ustar liggesusersKlLQtڙ}KN_̽ %j4$T%,ڒR v6"ĊX`ei!oM=߈LM~=;۹ %VPp|(3񔹚H ԝz^|H gF+5zie㧽y"z~zJؿ~)8^9 zUӫ^ Zzuk^#F7s:yXDGg}Z̠iݬC\3hkyf}b <3Y*/ n1s~oVUw Cށ7V<>ěs8$WOkz@j Luminescence/R/0000755000176200001440000000000013125227601013064 5ustar liggesusersLuminescence/R/RLum.Data-class.R0000644000176200001440000000122713125226556016053 0ustar liggesusers#' Class \code{"RLum.Data"} #' #' Generalized virtual data class for luminescence data. #' #' #' @name RLum.Data-class #' #' @docType class #' #' @note Just a virtual class. #' #' @section Objects from the Class: A virtual Class: No objects can be created #' from it. #' #' @section Class version: 0.2.1 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\linkS4class{RLum}}, \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Data.Spectrum}} #' #' @keywords classes #' #' @examples #' #' showClass("RLum.Data") #' #' @export setClass("RLum.Data", contains = c("RLum", "VIRTUAL") ) Luminescence/R/get_Layout.R0000644000176200001440000006200313125226556015334 0ustar liggesusers#' Collection of layout definitions #' #' This helper function returns a list with layout definitions for homogeneous #' plotting. #' #' The easiest way to create a user-specific layout definition is perhaps to #' create either an empty or a default layout object and fill/modify the #' definitions (\code{user.layout <- get_Layout(data = "empty")}). #' #' @param layout \code{\link{character}} or \code{\link{list}} object #' (required): name of the layout definition to be returned. If name is #' provided the respective definition is returned. One of the following #' supported layout definitions is possible: \code{"default"}, #' \code{"journal.1"}, \code{"small"}, \code{"empty"}. User-specific layout #' definitions must be provided as a list object of predefined structure, see #' details. #' @return A list object with layout definitions for plot functions. #' @section Function version: 0.1 #' @author Michael Dietze, GFZ Potsdam (Germany) #' @examples #' #' ## read example data set #' data(ExampleData.DeValues, envir = environment()) #' #' ## show structure of the default layout definition #' layout.default <- get_Layout(layout = "default") #' str(layout.default) #' #' ## show colour definitions for Abanico plot, only #' layout.default$abanico$colour #' #' ## set Abanico plot title colour to orange #' layout.default$abanico$colour$main <- "orange" #' #' ## create Abanico plot with modofied layout definition #' plot_AbanicoPlot(data = ExampleData.DeValues, #' layout = layout.default) #' #' ## create Abanico plot with predefined layout "journal" #' plot_AbanicoPlot(data = ExampleData.DeValues, #' layout = "journal") #' #' @export get_Layout <- function( layout ) { ## pre-defined layout selections if(is.character(layout) == TRUE & length(layout) == 1) { if(layout == "empty") { layout = list( ## empty Abanico plot ------------------------------------------------- abanico = list( font.type = list( main = character(1), xlab1 = character(1), xlab2 = character(1), ylab = character(1), zlab = character(1), xtck1 = character(1), xtck2 = character(1), xtck3 = character(1), ytck = character(1), ztck = character(1), mtext = character(1), summary = character(1), # optionally vector stats = character(1), # optionally vector legend = character(1) # optionally vector ), font.size = list( main = numeric(1), xlab1 = numeric(1), xlab2 = numeric(1), xlab3 = numeric(1), ylab = numeric(1), zlab = numeric(1), xtck1 = numeric(1), xtck2 = numeric(1), xtck3 = numeric(1), ytck = numeric(1), ztck = numeric(1), mtext = numeric(1), summary = numeric(1), # optionally vector stats = numeric(1), # optionally vector legend = numeric(1) # optionally vector ), font.deco = list( main = character(1), xlab1 = character(1), xlab2 = character(1), xlab3 = character(1), ylab = character(1), zlab = character(1), xtck1 = character(1), xtck2 = character(1), xtck3 = character(1), ytck = character(1), ztck = character(1), mtext = character(1), summary = character(1), # optionally vector stats = character(1), # optionally vector legend = character(1) # optionally vector ), colour = list( main = numeric(1), # plot title colour xlab1 = numeric(1), # left x-axis label colour xlab2 = numeric(1), # right x-axis label colour xlab3 = numeric(1), # right x-axis label colour ylab = numeric(1), # y-axis label colour zlab = numeric(1), # z-axis label colour xtck1 = numeric(1), # left x-axis tick colour xtck2 = numeric(1), # right x-axis tick colour xtck3 = numeric(1), # right x-axis tick colour ytck = numeric(1), # y-axis tick colour ztck = numeric(1), # z-axis tick colour mtext = numeric(1), # subheader text colour summary = numeric(1), # statistic summary colour stats = numeric(1), # value statistics colour legend = numeric(1), # legend colour centrality = numeric(1), # Centrality line colour value.dot = numeric(1), # De value dot colour value.bar = numeric(1), # De value error bar colour value.rug = numeric(1), # De value rug colour poly.line = numeric(1), # polygon line colour poly.fill = numeric(1), # polygon fill colour bar.line = numeric(1), # polygon line colour bar.fill = numeric(1), # polygon fill colour kde.line = numeric(1), kde.fill = numeric(1), grid.major = numeric(1), grid.minor = numeric(1), border = numeric(1), background = numeric(1)), dimension = list( figure.width = numeric(1), # figure width in mm figure.height = numeric(1), # figure height in mm margin = numeric(4), # margin sizes in mm main.line = numeric(1), # line height in % xlab1.line = numeric(1), # line height in % xlab2.line = numeric(1), # line height in % xlab3.line = numeric(1), # line height in % ylab.line = numeric(1), # line height in % zlab.line = numeric(1), # line height in % xtck1.line = numeric(1), # line height in % xtck2.line = numeric(1), # line height in % xtck3.line = numeric(1), # line height in % ytck.line = numeric(1), # line height in % ztck.line = numeric(1), # line height in % xtcl1 = numeric(1), # tick length in % xtcl2 = numeric(1), # tick length in % xtcl3 = numeric(1), # tick length in % ytcl = numeric(1), # tick length in % ztcl = numeric(1), # tick length in % rugl = numeric(1), # rug length in % mtext = numeric(1), # line height in % summary.line = numeric(1) # line height in % )), ## empty KDE plot ----------------------------------------------------- kde = list( font.type = list( main = character(1), xlab = character(1), ylab1 = character(1), ylab2 = character(1), xtck = character(1), ytck1 = character(1), ytck2 = character(1), stats = character(1), # optionally vector legend = character(1) # optionally vector ), font.size = list( main = numeric(1), xlab = numeric(1), ylab1 = numeric(1), ylab2 = numeric(1), xtck = numeric(1), ytck1 = numeric(1), ytck2 = numeric(1), stats = numeric(1), # optionally vector legend = numeric(1) # optionally vector ), font.deco = list( main = character(1), xlab = character(1), ylab1 = character(1), ylab2 = character(1), xtck = character(1), ytck1 = character(1), ytck2 = character(1), stats = character(1), # optionally vector legend = character(1) # optionally vector ), colour = list( main = numeric(1), # plot title colour xlab = numeric(1), # x-axis label colour ylab1 = numeric(1), # primary y-axis label colour ylab2 = numeric(1), # secondary y-axis label colour xtck = numeric(1), # x-axis tick colour ytck1 = numeric(1), # primary y-axis tick colour ytck2 = numeric(1), # secondary y-axis tick colour box = numeric(1), # plot frame box line colour mtext = numeric(1), # subheader text colour stats = numeric(1), # statistic summary colour kde.line = numeric(1), # KDE line colour kde.fill = numeric(1), # KDE fill colour value.dot = numeric(1), # De value dot colour value.bar = numeric(1), # De value error bar colour value.rug = numeric(1), # De value rug colour boxplot.line = numeric(1), # boxplot line colour boxplot.fill = numeric(1), # boxplot fill colour mean.line = numeric(1), # mean line colour sd.bar = numeric(1), # sd-line colour background = numeric(1)), # background colour dimension = list( figure.width = numeric(1), # figure width in mm figure.height = numeric(1), # figure height in mm margin = numeric(4), # margin sizes in mm main.line = numeric(1), # line height in % xlab.line = numeric(1), # line height in % ylab1.line = numeric(1), # line height in % ylab2.line = numeric(1), # line height in % xtck.line = numeric(1), # line height in % ytck1.line = numeric(1), # line height in % ytck2.line = numeric(1), # line height in % xtcl = numeric(1), # tick length in % ytcl1 = numeric(1), # tick length in % ytcl2 = numeric(1), # tick length in % stats.line = numeric(1) # line height in % ) ) ) } else if(layout == "default") { layout = list( ## default Abanico plot ----------------------------------------------- abanico = list( font.type = list( main = "", xlab1 = "", xlab2 = "", ylab = "", zlab = "", xtck1 = "", xtck2 = "", xtck3 = "", ytck = "", ztck = "", mtext = "", summary = "", # optionally vector stats = "", # optionally vector legend = "" # optionally vector ), font.size = list( main = 12, xlab1 = 12, xlab2 = 12, xlab3 = 12, ylab = 12, zlab = 12, xtck1 = 12, xtck2 = 12, xtck3 = 12, ytck = 12, ztck = 12, mtext = 10, summary = 10, # optionally vector stats = 10, # optionally vector legend = 10 # optionally vector ), font.deco = list( main = "bold", xlab1 = "normal", xlab2 = "normal", xlab3 = "normal", ylab = "normal", zlab = "normal", xtck1 = "normal", xtck2 = "normal", xtck3 = "normal", ytck = "normal", ztck = "normal", mtext = "normal", summary = "normal", # optionally vector stats = "normal", # optionally vector legend = "normal" # optionally vector ), colour = list( main = 1, # plot title colour xlab1 = 1, # left x-axis label colour xlab2 = 1, # right x-axis label colour xlab3 = 1, # right x-axis label colour ylab = 1, # y-axis label colour zlab = 1, # z-axis label colour xtck1 = 1, # left x-axis tick colour xtck2 = 1, # right x-axis tick colour xtck3 = 1, # right x-axis tick colour ytck = 1, # y-axis tick colour ztck = 1, # z-axis tick colour mtext = 1, # subheader text colour summary = 1, # statistic summary colour stats = 1, # value statistics colour legend = 1, # legend colour centrality = 1, # Centrality line colour value.dot = 1, # De value dot colour value.bar = 1, # De value error bar colour value.rug = 1, # De value rug colour poly.line = NA, # polygon line colour poly.fill = adjustcolor("grey75", alpha.f = 0.6), # polygon fill colour bar.line = NA, # polygon line colour bar.fill = "grey60", # bar fill colour kde.line = 1, kde.fill = NA, grid.major = "grey80", grid.minor = "none", border = 1, background = NA), dimension = list( figure.width = "auto", # figure width in mm figure.height = "auto", # figure height in mm margin = c(10, 10, 10, 10), # margin sizes in mm main.line = 100, # line height in % xlab1.line = 90, # line height in % xlab2.line = 90, # line height in % xlab3.line = 90, # line height in % ylab.line = 100, # line height in % zlab.line = 70, # line height in % xtck1.line = 100, # line height in % xtck2.line = 100, # line height in % xtck3.line = 100, # line height in % ytck.line = 100, # line height in % ztck.line = 100, # line height in % xtcl1 = 100, # tick length in % xtcl2 = 100, # tick length in % xtcl3 = 100, # tick length in % ytcl = 100, # tick length in % ztcl = 100, # tick length in % rugl = 100, # rug length in % mtext = 100, # line height in % summary.line = 100 # line height in % )), ## default KDE plot --------------------------------------------------- kde = list( font.type = list( main = "", xlab = "", ylab1 = "", ylab2 = "", xtck = "", ytck1 = "", ytck2 = "", stats = "", # optionally vector legend = "" # optionally vector ), font.size = list( main = 14, xlab = 12, ylab1 = 12, ylab2 = 12, xtck = 12, ytck1 = 12, ytck2 = 12, stats = 12, # optionally vector legend = 12 # optionally vector ), font.deco = list( main = "bold", xlab = "normal", ylab1 = "normal", ylab2 = "normal", xtck = "normal", ytck1 = "normal", ytck2 = "normal", stats = "normal", # optionally vector legend = "normal" # optionally vector ), colour = list( main = 1, # plot title colour xlab = 1, # x-axis label colour ylab1 = 1, # primary y-axis label colour ylab2 = 1, # secondary y-axis label colour xtck = 1, # x-axis tick colour ytck1 = 1, # primary y-axis tick colour ytck2 = 1, # secondary y-axis tick colour box = 1, # plot frame box line colour mtext = 2, # subheader text colour stats = 1, # statistic summary colour kde.line = 1, # KDE line colour kde.fill = NULL, # KDE fill colour value.dot = 1, # De value dot colour value.bar = 1, # De value error bar colour value.rug = 1, # De value rug colour boxplot.line = 1, # boxplot line colour boxplot.fill = NULL, # boxplot fill colour mean.point = 1, # mean line colour sd.line = 1, # sd bar colour background = NULL), # background colour dimension = list( figure.width = "auto", # figure width in mm figure.height = "auto", # figure height in mm margin = c(10, 10, 10, 10), # margin sizes in mm main.line = 100, # line height in % xlab.line = 100, # line height in % ylab1.line = 100, # line height in % ylab2.line = 100, # line height in % xtck.line = 100, # line height in % ytck1.line = 100, # line height in % ytck2.line = 100, # line height in % xtcl = 100, # tick length in % ytcl1 = 100, # tick length in % ytcl2 = 100, # tick length in % stats.line = 100 # line height in % ) ) ) } else if(layout == "journal") { layout = list( ## journal Abanico plot ----------------------------------------------- abanico = list( font.type = list( main = "", xlab1 = "", xlab2 = "", ylab = "", zlab = "", xtck1 = "", xtck2 = "", xtck3 = "", ytck = "", ztck = "", mtext = "", summary = "", # optionally vector stats = "", # optionally vector legend = "" # optionally vector ), font.size = list( main = 8, xlab1 = 7, xlab2 = 7, xlab3 = 7, ylab = 7, zlab = 7, xtck1 = 7, xtck2 = 7, xtck3 = 7, ytck = 7, ztck = 7, mtext = 6, summary = 6, # optionally vector stats = 6, # optionally vector legend = 6 # optionally vector ), font.deco = list( main = "bold", xlab1 = "normal", xlab2 = "normal", xlab3 = "normal", ylab = "normal", zlab = "normal", xtck1 = "normal", xtck2 = "normal", xtck3 = "normal", ytck = "normal", ztck = "normal", mtext = "normal", summary = "normal", # optionally vector stats = "normal", # optionally vector legend = "normal" # optionally vector ), colour = list( main = 1, # plot title colour xlab1 = 1, # left x-axis label colour xlab2 = 1, # right x-axis label colour xlab3 = 1, # right x-axis label colour ylab = 1, # y-axis label colour zlab = 1, # z-axis label colour xtck1 = 1, # left x-axis tick colour xtck2 = 1, # right x-axis tick colour xtck3 = 1, # right x-axis tick colour ytck = 1, # y-axis tick colour ztck = 1, # z-axis tick colour mtext = 1, # subheader text colour summary = 1, # statistic summary colour stats = 1, # value statistics colour legend = 1, # legend colour centrality = 1, # Centrality line colour value.dot = 1, # De value dot colour value.bar = 1, # De value error bar colour value.rug = 1, # De value rug colour poly.line = NA, # polygon line colour poly.fill = adjustcolor("grey75", alpha.f = 0.6), # polygon fill colour bar.line = NA, # polygon line colour bar.fill = "grey60", # bar fill colour kde.line = 1, kde.fill = NA, grid.major = "grey80", grid.minor = "none", border = 1, background = NA), dimension = list( figure.width = 100, # figure width in mm figure.height = 100, # figure height in mm margin = c(10, 10, 10, 10), # margin sizes in mm main.line = 70, # line height in % xlab1.line = 30, # line height in % xlab2.line = 65, # line height in % xlab3.line = 30, # line height in % ylab.line = 30, # line height in % zlab.line = 40, # line height in % xtck1.line = 50, # line height in % xtck2.line = 50, # line height in % xtck3.line = 50, # line height in % ytck.line = 70, # line height in % ztck.line = 70, # line height in % xtcl1 = 50, # tick length in % xtcl2 = 50, # tick length in % xtcl3 = 50, # tick length in % ytcl = 50, # tick length in % ztcl = 70, # tick length in % rugl = 70, # rug length in % mtext = 100, # line height in % summary.line = 70, # line height in % pch = 50 # point size in % )), ## journal KDE plot --------------------------------------------------- kde = list( font.type = list( main = "", xlab = "", ylab1 = "", ylab2 = "", xtck = "", ytck1 = "", ytck2 = "", stats = "", # optionally vector legend = "" # optionally vector ), font.size = list( main = 8, xlab = 7, ylab1 = 7, ylab2 = 7, xtck = 7, ytck1 = 7, ytck2 = 7, stats = 7, legend = 7 ), font.deco = list( main = "bold", xlab = "normal", ylab1 = "normal", ylab2 = "normal", xtck = "normal", ytck1 = "normal", ytck2 = "normal", stats = "normal", # optionally vector legend = "normal" # optionally vector ), colour = list( main = 1, # plot title colour xlab = 1, # x-axis label colour ylab1 = 1, # primary y-axis label colour ylab2 = 1, # secondary y-axis label colour xtck = 1, # x-axis tick colour ytck1 = 1, # primary y-axis tick colour ytck2 = 1, # secondary y-axis tick colour box = 1, # plot frame box line colour mtext = 1, # subheader text colour stats = "#2062B3", # statistic summary colour kde.line = "#2062B3", # KDE line colour kde.fill = NULL, # KDE fill colour value.dot = 1, # De value dot colour value.bar = 1, # De value error bar colour value.rug = 1, # De value rug colour boxplot.line = 1, # boxplot line colour boxplot.fill = NULL, # boxplot fill colour mean.line = adjustcolor(col = 1, alpha.f = 0.4), # mean line colour sd.bar = adjustcolor(col = 1, alpha.f = 0.4), # sd bar colour background = NULL), dimension = list( figure.width = 80, # figure width in mm figure.height = 80, # figure height in mm margin = c(10, 10, 10, 10), # margin sizes in mm main.line = 70, # line height in % xlab.line = 30, # line height in % ylab1.line = 40, # line height in % ylab2.line = 30, # line height in % xtck.line = 50, # line height in % ytck1.line = 65, # line height in % ytck2.line = 50, # line height in % xtcl = 50, # tick length in % ytcl1 = 20, # tick length in % ytcl2 = 50, # tick length in % stats.line = 70 # line height in % ) ) ) } else { warning("Layout definition not supported! Default layout is used.") layout <- get_Layout(layout = "default") } } else if(is.list(layout) == TRUE) { ## user-specific layout definition assignment layout <- layout } ## return layout parameters return(layout) } Luminescence/R/calc_AliquotSize.R0000644000176200001440000004127013125226556016456 0ustar liggesusers#' Estimate the amount of grains on an aliquot #' #' Estimate the number of grains on an aliquot. Alternatively, the packing #' density of an aliquot is computed. #' #' This function can be used to either estimate the number of grains on an #' aliquot or to compute the packing density depending on the the arguments #' provided. \cr The following function is used to estimate the number of #' grains \code{n}: \cr \deqn{n = (\pi*x^2)/(\pi*y^2)*d} where \code{x} is the #' radius of the aliquot size (microns), \code{y} is the mean radius of the #' mineral grains (mm) and \code{d} is the packing density (value between 0 and #' 1). \cr #' #' \bold{Packing density} \cr\cr The default value for \code{packing.density} #' is 0.65, which is the mean of empirical values determined by Heer et al. #' (2012) and unpublished data from the Cologne luminescence laboratory. If #' \code{packing.density = "inf"} a maximum density of \eqn{\pi/\sqrt12 = #' 0.9068\ldots} is used. However, note that this value is not appropriate as #' the standard preparation procedure of aliquots resembles a PECC ("Packing #' Equal Circles in a Circle") problem where the maximum packing density is #' asymptotic to about 0.87. \cr #' #' \bold{Monte Carlo simulation} \cr\cr The number of grains on an aliquot can #' be estimated by Monte Carlo simulation when setting \code{MC = TRUE}. Each #' of the parameters necessary to calculate \code{n} (\code{x}, \code{y}, #' \code{d}) are assumed to be normally distributed with means \eqn{\mu_x, #' \mu_y, \mu_d} and standard deviations \eqn{\sigma_x, \sigma_y, \sigma_d}. #' \cr\cr For the mean grain size random samples are taken first from #' \eqn{N(\mu_y, \sigma_y)}, where \eqn{\mu_y = mean.grain.size} and #' \eqn{\sigma_y = (max.grain.size-min.grain.size)/4} so that 95\% of all #' grains are within the provided the grain size range. This effectively takes #' into account that after sieving the sample there is still a small chance of #' having grains smaller or larger than the used mesh sizes. For each random #' sample the mean grain size is calculated, from which random subsamples are #' drawn for the Monte Carlo simulation. \cr\cr The packing density is assumed #' to be normally distributed with an empirically determined \eqn{\mu = 0.65} #' (or provided value) and \eqn{\sigma = 0.18}. The normal distribution is #' truncated at \code{d = 0.87} as this is approximately the maximum packing #' density that can be achieved in PECC problem. \cr\cr The sample diameter has #' \eqn{\mu = sample.diameter} and \eqn{\sigma = 0.2} to take into account #' variations in sample disc preparation (i.e. applying silicon spray to the #' disc). A lower truncation point at \code{x = 0.5} is used, which assumes #' that aliqouts with smaller sample diameters of 0.5 mm are discarded. #' Likewise, the normal distribution is truncated at 9.8 mm, which is the #' diameter of the sample disc. \cr\cr For each random sample drawn from the #' normal distributions the amount of grains on the aliquot is calculated. By #' default, \code{10^5} iterations are used, but can be reduced/increased with #' \code{MC.iter} (see \code{...}). The results are visualised in a bar- and #' boxplot together with a statistical summary. #' #' @param grain.size \code{\link{numeric}} (\bold{required}): mean grain size #' (microns) or a range of grain sizes from which the mean grain size is #' computed (e.g. \code{c(100,200)}). #' #' @param sample.diameter \code{\link{numeric}} (\bold{required}): diameter #' (mm) of the targeted area on the sample carrier. #' #' @param packing.density \code{\link{numeric}} (with default) empirical value #' for mean packing density. \cr If \code{packing.density = "inf"} a hexagonal #' structure on an infinite plane with a packing density of \eqn{0.906\ldots} #' is assumed. #' #' @param MC \code{\link{logical}} (optional): if \code{TRUE} the function #' performs a monte carlo simulation for estimating the amount of grains on the #' sample carrier and assumes random errors in grain size distribution and #' packing density. Requires a vector with min and max grain size for #' \code{grain.size}. For more information see details. #' #' @param grains.counted \code{\link{numeric}} (optional) grains counted on a #' sample carrier. If a non-zero positive integer is provided this function #' will calculate the packing density of the aliquot. If more than one value is #' provided the mean packing density and its standard deviation is calculated. #' Note that this overrides \code{packing.density}. #' #' @param plot \code{\link{logical}} (with default): plot output #' (\code{TRUE}/\code{FALSE}) #' #' @param \dots further arguments to pass (\code{main, xlab, MC.iter}). #' #' @return Returns a terminal output. In addition an #' \code{\linkS4class{RLum.Results}} object is returned containing the #' following element: #' #' \item{summary}{\link{data.frame} summary of all relevant calculation #' results.} \item{args}{\link{list} used arguments} \item{call}{\link{call} #' the function call} \item{MC}{\link{list} results of the Monte Carlo #' simulation} #' #' The output should be accessed using the function #' \code{\link{get_RLum}} #' #' @section Function version: 0.31 #' #' @author Christoph Burow, University of Cologne (Germany) #' #' @references #' Duller, G.A.T., 2008. Single-grain optical dating of Quaternary #' sediments: why aliquot size matters in luminescence dating. Boreas 37, #' 589-612. #' #' Heer, A.J., Adamiec, G., Moska, P., 2012. How many grains #' are there on a single aliquot?. Ancient TL 30, 9-16. \cr\cr #' #' \bold{Further reading} \cr\cr #' #' Chang, H.-C., Wang, L.-C., 2010. A simple proof of Thue's #' Theorem on Circle Packing. \url{http://arxiv.org/pdf/1009.4322v1.pdf}, #' 2013-09-13. #' #' Graham, R.L., Lubachevsky, B.D., Nurmela, K.J., #' Oestergard, P.R.J., 1998. Dense packings of congruent circles in a circle. #' Discrete Mathematics 181, 139-154. #' #' Huang, W., Ye, T., 2011. Global #' optimization method for finding dense packings of equal circles in a circle. #' European Journal of Operational Research 210, 474-481. #' #' @examples #' #' ## Estimate the amount of grains on a small aliquot #' calc_AliquotSize(grain.size = c(100,150), sample.diameter = 1, MC.iter = 100) #' #' ## Calculate the mean packing density of large aliquots #' calc_AliquotSize(grain.size = c(100,200), sample.diameter = 8, #' grains.counted = c(2525,2312,2880), MC.iter = 100) #' #' @export calc_AliquotSize <- function( grain.size, sample.diameter, packing.density = 0.65, MC = TRUE, grains.counted, plot=TRUE, ... ){ ##==========================================================================## ## CONSISTENCY CHECK OF INPUT DATA ##==========================================================================## if(length(grain.size) == 0 | length(grain.size) > 2) { cat(paste("\nPlease provide the mean grain size or a range", "of grain sizes (in microns).\n"), fill = FALSE) stop(domain=NA) } if(packing.density < 0 | packing.density > 1) { if(packing.density == "inf") { } else { cat(paste("\nOnly values between 0 and 1 allowed for packing density!\n")) stop(domain=NA) } } if(sample.diameter < 0) { cat(paste("\nPlease provide only positive integers.\n")) stop(domain=NA) } if (sample.diameter > 9.8) warning("\n A sample diameter of ", sample.diameter ," mm was specified, but common sample discs are 9.8 mm in diameter.", call. = FALSE) if(missing(grains.counted) == FALSE) { if(MC == TRUE) { MC = FALSE cat(paste("\nMonte Carlo simulation is only available for estimating the", "amount of grains on the sample disc. Automatically set to", "FALSE.\n")) } } if(MC == TRUE && length(grain.size) != 2) { cat(paste("\nPlease provide a vector containing the min and max grain", "grain size(e.g. c(100,150) when using Monte Carlo simulations.\n")) stop(domain=NA) } ##==========================================================================## ## ... ARGUMENTS ##==========================================================================## # set default parameters settings <- list(MC.iter = 10^4, verbose = TRUE) # override settings with user arguments settings <- modifyList(settings, list(...)) ##==========================================================================## ## CALCULATIONS ##==========================================================================## # calculate the mean grain size range.flag<- FALSE if(length(grain.size) == 2) { gs.range<- grain.size grain.size<- mean(grain.size) range.flag<- TRUE } # use ~0.907... from Thue's Theorem as packing density if(packing.density == "inf") { packing.density = pi/sqrt(12) } # function to calculate the amount of grains calc_n<- function(sd, gs, d) { n<- ((pi*(sd/2)^2)/ (pi*(gs/2000)^2))*d return(n) } # calculate the amount of grains on the aliquot if(missing(grains.counted) == TRUE) { n.grains<- calc_n(sample.diameter, grain.size, packing.density) ##========================================================================## ## MONTE CARLO SIMULATION if(MC == TRUE && range.flag == TRUE) { # create a random set of packing densities assuming a normal # distribution with the empirically determined standard deviation of # 0.18. d.mc<- rnorm(settings$MC.iter, packing.density, 0.18) # in a PECC the packing density can not be larger than ~0.87 d.mc[which(d.mc > 0.87)]<- 0.87 d.mc[which(d.mc < 0.25)]<- 0.25 # create a random set of sample diameters assuming a normal # distribution with an assumed standard deviation of # 0.2. For a more conservative estimate this is divided by 2. sd.mc<- rnorm(settings$MC.iter, sample.diameter, 0.2) # it is assumed that sample diameters < 0.5 mm either do not # occur, or are discarded. Either way, any smaller sample # diameter is capped at 0.5. # Also, the sample diameter can not be larger than the sample # disc, i.e. 9.8 mm. sd.mc[which(sd.mc <0.5)]<- 0.5 if (sample.diameter <= 9.8) sd.mc[which(sd.mc >9.8)]<- 9.8 # create random samples assuming a normal distribution # with the mean grain size as mean and half the range (min:max) # as standard deviation. For a more conservative estimate this # is further devided by 2, so half the range is regarded as # two sigma. gs.mc<- rnorm(settings$MC.iter, grain.size, diff(gs.range)/4) # draw random samples from the grain size spectrum (gs.mc) and calculate # the mean for each sample. This gives an approximation of the variation # in mean grain size on the sample disc gs.mc.sampleMean<- vector(mode = "numeric") for(i in 1:length(gs.mc)) { gs.mc.sampleMean[i]<- mean(sample(gs.mc, calc_n( sample(sd.mc, size = 1), grain.size, sample(d.mc, size = 1) ), replace = TRUE)) } # create empty vector for MC estimates of n MC.n<- vector(mode="numeric") # calculate n for each MC data set for(i in 1:length(gs.mc)) { MC.n[i]<- calc_n(sd.mc[i], gs.mc.sampleMean[i], d.mc[i]) } # summarize MC estimates MC.q<- quantile(MC.n, c(0.05,0.95)) MC.n.kde<- density(MC.n, n = 10000) # apply student's t-test MC.t.test<- t.test(MC.n) MC.t.lower<- MC.t.test["conf.int"]$conf.int[1] MC.t.upper<- MC.t.test["conf.int"]$conf.int[2] MC.t.se<- (MC.t.upper-MC.t.lower)/3.92 # get unweighted statistics from calc_Statistics() function MC.stats<- calc_Statistics(as.data.frame(cbind(MC.n,0.0001)))$unweighted } }#EndOf:estimate number of grains ##========================================================================## ## CALCULATE PACKING DENSITY if(missing(grains.counted) == FALSE) { area.container<- pi*sample.diameter^2 if(length(grains.counted) == 1) { area.grains<- (pi*(grain.size/1000)^2)*grains.counted packing.density<- area.grains/area.container } else { packing.densities<- length(grains.counted) for(i in 1:length(grains.counted)) { area.grains<- (pi*(grain.size/1000)^2)*grains.counted[i] packing.densities[i]<- area.grains/area.container } std.d<- sd(packing.densities) } } ##==========================================================================## ##TERMINAL OUTPUT ##==========================================================================## if (settings$verbose) { cat("\n [calc_AliquotSize]") cat(paste("\n\n ---------------------------------------------------------")) cat(paste("\n mean grain size (microns) :", grain.size)) cat(paste("\n sample diameter (mm) :", sample.diameter)) if(missing(grains.counted) == FALSE) { if(length(grains.counted) == 1) { cat(paste("\n counted grains :", grains.counted)) } else { cat(paste("\n mean counted grains :", round(mean(grains.counted)))) } } if(missing(grains.counted) == TRUE) { cat(paste("\n packing density :", round(packing.density,3))) } if(missing(grains.counted) == FALSE) { if(length(grains.counted) == 1) { cat(paste("\n packing density :", round(packing.density,3))) } else { cat(paste("\n mean packing density :", round(mean(packing.densities),3))) cat(paste("\n standard deviation :", round(std.d,3))) } } if(missing(grains.counted) == TRUE) { cat(paste("\n number of grains :", round(n.grains,0))) } if(MC == TRUE && range.flag == TRUE) { cat(paste(cat(paste("\n\n --------------- Monte Carlo Estimates -------------------")))) cat(paste("\n number of iterations (n) :", settings$MC.iter)) cat(paste("\n median :", round(MC.stats$median))) cat(paste("\n mean :", round(MC.stats$mean))) cat(paste("\n standard deviation (mean) :", round(MC.stats$sd.abs))) cat(paste("\n standard error (mean) :", round(MC.stats$se.abs, 1))) cat(paste("\n 95% CI from t-test (mean) :", round(MC.t.lower), "-", round(MC.t.upper))) cat(paste("\n standard error from CI (mean):", round(MC.t.se, 1))) cat(paste("\n ---------------------------------------------------------\n")) } else { cat(paste("\n ---------------------------------------------------------\n")) } } ##==========================================================================## ##RETURN VALUES ##==========================================================================## # prepare return values for mode: estimate grains if(missing(grains.counted) == TRUE) { summary<- data.frame(grain.size = grain.size, sample.diameter = sample.diameter, packing.density = packing.density, n.grains = round(n.grains,0), grains.counted = NA) } # prepare return values for mode: estimate packing density/densities if(missing(grains.counted) == FALSE) { # return values if only one value for counted.grains is provided if(length(grains.counted) == 1) { summary<- data.frame(grain.size = grain.size, sample.diameter = sample.diameter, packing.density = packing.density, n.grains = NA, grains.counted = grains.counted) } else { # return values if more than one value for counted.grains is provided summary<- data.frame(rbind(1:5)) colnames(summary)<- c("grain.size", "sample.diameter", "packing.density", "n.grains","grains.counted") for(i in 1:length(grains.counted)) { summary[i,]<- c(grain.size, sample.diameter, packing.densities[i], n.grains = NA, grains.counted[i]) } } } if(!MC) { MC.n<- NULL MC.stats<- NULL MC.n.kde<- NULL MC.t.test<- NULL MC.q<- NULL } if(missing(grains.counted)) grains.counted<- NA call<- sys.call() args<- as.list(sys.call())[-1] # create S4 object newRLumResults.calc_AliquotSize <- set_RLum( class = "RLum.Results", data = list( summary=summary, MC=list(estimates=MC.n, statistics=MC.stats, kde=MC.n.kde, t.test=MC.t.test, quantile=MC.q)), info = list(call=call, args=args)) ##=========## ## PLOTTING if(plot==TRUE) { try(plot_RLum.Results(newRLumResults.calc_AliquotSize, ...)) } # Return values invisible(newRLumResults.calc_AliquotSize) } Luminescence/R/calc_AverageDose.R0000644000176200001440000004010213125226556016363 0ustar liggesusers#'Calculate the Average Dose and the dose rate dispersion #' #'This functions calculates the Average Dose and their extrinsic dispersion and estimates #'the standard errors by bootstrapping based on the Average Dose Model by Guerin et al., 2017 #' #'\bold{\code{sigma_m}}\cr #' #'The program requires the input of a known value of sigma_m, #'which corresponds to the intrinsic overdispersion, as determined #'by a dose recovery experiment. Then the dispersion in doses (sigma_d) #'will be that over and above sigma_m (and individual uncertainties sigma_wi). #' #' @param data \code{\linkS4class{RLum.Results}} or \link{data.frame} #' (\bold{required}): for \code{data.frame}: two columns with De #' \code{(data[,1])} and De error \code{(values[,2])} #' #' @param sigma_m \code{\link{numeric}} (\bold{required}): the overdispersion resulting from a dose recovery #' experiment, i.e. when all grains have received the same dose. Indeed in such a case, any #' overdispersion (i.e. dispersion on top of analytical uncertainties) is, by definition, an #' unrecognised measurement uncertainty. #' #' @param Nb_BE \code{\link{integer}} (with default): sample size used for the bootstrapping #' #' @param na.rm \code{\link{logical}} (with default): exclude NA values #' from the data set prior to any further operation. #' #' @param plot \code{\link{logical}} (with default): enables/disables plot output #' #' @param verbose \code{\link{logical}} (with default): enables/disables terminal output #' #' @param ... further arguments that can be passed to \code{\link[graphics]{hist}}. As three plots #' are returned all arguments need to be provided as \code{\link{list}}, #' e.g., \code{main = list("Plot 1", "Plot 2", "Plot 3")}. Note: not all arguments of \code{hist} are #' supported, but the output of \code{hist} is returned and can be used of own plots. \cr #' #' Further supported arguments: \code{mtext} (\code{character}), \code{rug} (\code{TRUE/FALSE}). #' #' @section Function version: 0.1.4 #' #' @author Claire Christophe, IRAMAT-CRP2A, Universite de Nantes (France), #' Anne Philippe, Universite de Nantes, (France), #' Guillaume Guerin, IRAMAT-CRP2A, Universite Bordeaux Montaigne, (France), #' Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne, (France) #' #' @seealso \code{\link{read.table}}, \code{\link[graphics]{hist}} #' #' @return The function returns numerical output and an (optional) plot. #' #' -----------------------------------\cr #' [ NUMERICAL OUTPUT ]\cr #' -----------------------------------\cr #' \bold{\code{RLum.Reuslts}}-object\cr #' #' \bold{slot:} \bold{\code{@data}} \cr #' #' [.. $summary : \code{data.frame}]\cr #' #' \tabular{lll}{ #' \bold{Column} \tab \bold{Type} \tab \bold{Description}\cr #' AVERAGE_DOSE \tab \code{numeric} \tab the obtained averge dose\cr #' AVERAGE_DOSE.SE \tab \code{numeric} \tab the average dose error \cr #' SIGMA_D \tab \code{numeric}\tab sigma \cr #' SIGMA_D.SE \tab \code{numeric}\tab standard error of the sigma \cr #' IC_AVERAGE_DOSE.LEVEL \tab \code{character}\tab confidence level average dose\cr #' IC_AVERAGE_DOSE.LOWER \tab \code{charcter}\tab lower quantile of average dose \cr #' IC_AVERAGE_DOSE.UPPER \tab \code{character}\tab upper quantile of average dose\cr #' IC_SIGMA_D.LEVEL \tab \code{integer}\tab confidence level sigma\cr #' IC_SIGMA_D.LOWER \tab \code{character}\tab lower sigma quantile\cr #' IC_SIGMA_D.UPPER \tab \code{character}\tab upper sigma quantile\cr #' L_MAX \tab \code{character}\tab maximum likelihood value #' } #' #' [.. $dstar : \code{matrix}]\cr #' #' Matrix with bootstrap values\cr #' #' [.. $hist : \code{list}]\cr #' #' Object as produced by the function histogram #' #' ------------------------\cr #' [ PLOT OUTPUT ]\cr #' ------------------------\cr #' #' The function returns two different plot panels. #' #' (1) An abanico plot with the dose values #' #' (2) A histogram panel comprising 3 histograms with the equivalent dose and the bootstrapped average #' dose and the sigma values. #' #' @references #' Guerin, G., Christophe, C., Philippe, A., Murray, A.S., Thomsen, K.J., Tribolo, C., Urbanova, P., #' Jain, M., Guibert, P., Mercier, N., Kreutzer, S., Lahaye, C., 2017. Absorbed dose, equivalent dose, #' measured dose rates, and implications for OSL age estimates: Introducing the Average Dose Model. #' Quaternary Geochronology 1-32. doi:10.1016/j.quageo.2017.04.002 #' #' \bold{Further reading}\cr #' #' Efron, B., Tibshirani, R., 1986. Bootstrap Methods for Standard Errors, Confidence Intervals, #' and Other Measures of Statistical Accuracy. Statistical Science 1, 54-75. #' #' @note This function has beta status! #' #' @keywords datagen #' #' @examples #' #'##Example 01 using package example data #'##load example data #'data(ExampleData.DeValues, envir = environment()) #' #'##calculate Average dose #'##(use only the first 56 values here) #'AD <- calc_AverageDose(ExampleData.DeValues$CA1[1:56,], #'sigma_m = 0.1) #' #'##plot De and set Average dose as central value #'plot_AbanicoPlot( #' data = ExampleData.DeValues$CA1[1:56,], #' z.0 = AD$summary$AVERAGE_DOSE) #' #'@export calc_AverageDose <- function( data, sigma_m = NULL, Nb_BE = 500, na.rm = TRUE, plot = TRUE, verbose = TRUE, ... ){ # Define internal functions ------------------------------------------------------------------ # function which compute mle's for data (yu,su) .mle <- function(yu , su, wu.start, sigma_d.start, delta.start){ ##set start parameters, otherwise the function will try to get them ##from the parent environment, which is not wanted ... delta.temp <- 0 sigma_d.temp <- 0 sigma_d <- sigma_d.start delta <- delta.start wu <- wu.start j <- 0 iteration_limit <- 10000 ##loop until convergence or the iteration limit is reached while(j < iteration_limit) { ##code by Claire; in the 2nd and 3rd line delta and sigma_d are replaced by delta.temp and ##sigma_d.temp; otherwise the iteration and its test for convergence will not work delta.temp <- exp( sum(wu*(yu+(0.5*(sigma_d^2)))) / sum(wu) ) sigma_d.temp <- sigma_d*sum( (wu^2) * (yu-log(delta.temp)+0.5*sigma_d^2)^2) / (sum( wu*(1+yu-log(delta.temp)+0.5*sigma_d^2))) wu <- 1/(sigma_d.temp^2 + su^2) ##break loop if convergence is reached ... if not update values if(is.infinite(delta.temp) | is.infinite(sigma_d.temp)){ break() }else if ( ##compare values ... if they are equal we have convergence all( c(round(c(delta, sigma_d), 4)) == c(round(c(delta.temp, sigma_d.temp), 4)) ) ) { break() } else{ ##update input values delta <- delta.temp sigma_d <- sigma_d.temp j <- j + 1 } } ##if no convergence was reached stop entire function; no stop as this may happen during the ##bootstraping procedure if(j == iteration_limit){ warning("[calc_AverageDoseModel()] .mle() no convergence reached for the given limits. NA returned!") return(c(NA,NA)) }else if(is.infinite(delta.temp) | is.infinite(sigma_d.temp)){ warning("[calc_AverageDoseModel()] .mle() gaves Inf values. NA returned!") return(c(NA,NA)) }else{ return(c(round(c(delta, sigma_d),4))) } } .CredibleInterval <- function(a_chain, level = 0.95) { ## Aim : estimation of the shortest credible interval of the sample of parameter a # A level % credible interval is an interval that keeps N*(1-level) elements of the sample # The level % credible interval is the shortest of all those intervals. ## Parameters : # a_chain : the name of the values of the parameter a # level : the level of the credible interval expected ## Returns : the level and the endpoints sorted_sample <- sort(a_chain) N <- length(a_chain) OutSample <- N * (1 - level) I <- cbind(sorted_sample[1:(OutSample + 1)] , sorted_sample[(N - OutSample):N]) l <- I[, 2] - I[, 1] # length of intervals i <- which.min(l) # look for the shortest interval return(c( level = level, CredibleIntervalInf = I[i, 1], CredibleIntervalSup = I[i, 2] )) } ##//////////////////////////////////////////////////////////////////////////////////////////////// ##HERE THE MAIN FUNCTION STARTS ##//////////////////////////////////////////////////////////////////////////////////////////////// # Integrity checks ---------------------------------------------------------------------------- if(!is(data, "RLum.Results") & !is(data, "data.frame")){ stop("[calc_AverageDose()] input is neither of type 'RLum.Results' nor of type 'data.frame'!") }else { if(is(data, "RLum.Results")){ data <- get_RLum(data) } } if(is.null(sigma_m)){ stop("[calc_AverageDose()] 'sigma_m' is missing but required") } # Data preparation ----------------------------------------------------------------------------- ##problem: the entire code refers to column names the user may not provide... ## >> to avoid changing the entire code, the data will shape to a format that ## >> fits to the code ##check for number of columns if(ncol(data)<2){ try(stop("[calc_AverageDose()] data set contains < 2 columns! NULL returned!", call. = FALSE)) return(NULL) } ##used only the first two colums if(ncol(data)>2){ data <- data[,1:2] warning("[calc_AverageDose()] number of columns in data set > 2. Only the first two columns were used.", call. = FALSE) } ##exclude NA values if(any(is.na(data))){ data <- na.exclude(data) warning("[calc_AverageDose()] NA values in data set detected. Rows with NA values removed!", call. = FALSE) } ##check data set if(nrow(data) == 0){ try(stop("[calc_AverageDose()] data set contains 0 rows! NULL returned!", call. = FALSE)) return(NULL) } ##data becomes to dat (thus, make the code compatible with the code by Claire and Anne) dat <- data ##preset column names, as the code refers to it colnames(dat) <- c("cd", "se") # Pre calculation ----------------------------------------------------------------------------- ##calculate yu = log(CD) and su = se(logCD) yu <- log(dat$cd) su <- sqrt((dat$se / dat$cd) ^ 2 + sigma_m ^ 2) # calculate starting values and weights sigma_d <- sd(dat$cd) / mean(dat$cd) wu <- 1 / (sigma_d ^ 2 + su ^ 2) delta <- mean(dat$cd) n <- length(yu) ##terminal output if (verbose) { cat("\n[calc_AverageDose()]") cat("\n\n>> Initialisation <<") cat(paste("\nn:\t\t", n)) cat(paste("\ndelta:\t\t", delta)) cat(paste("\nsigma_m:\t", sigma_m)) cat(paste("\nsigma_d:\t", sigma_d)) } # mle's computation dhat <- .mle(yu, su, wu.start = wu, sigma_d.start = sigma_d, delta.start = delta) delta <- dhat[1] sigma_d <- dhat[2] wu <- 1 / (sigma_d ^ 2 + su ^ 2) # maximum log likelihood llik <- sum(-log(sqrt(2 * pi / wu)) - (wu / 2) * ((yu - log(delta) + 0.5 * (sigma_d ^ 2)) ^ 2)) ##terminal output if(verbose){ cat(paste("\n\n>> Calculation <<\n")) cat(paste("log likelihood:\t", round(llik, 4))) } # standard errors obtained by bootstrap, we refer to Efron B. and Tibshirani R. (1986) # est ce qu'il faut citer l'article ici ou tout simplement dans la publi ? n <- length(yu) ##calculate dstar ##set matrix for I I <- matrix(data = sample(x = 1:n, size = n * Nb_BE, replace = TRUE), ncol = Nb_BE) ##iterate over the matrix and produce dstar ##(this looks a little bit complicated, but is far more efficient) dstar <- t(vapply( X = 1:Nb_BE, FUN = function(x) { .mle(yu[I[, x]], su[I[, x]], sigma_d.start = sigma_d, delta.start = delta, wu.start = wu) }, FUN.VALUE = vector(mode = "numeric", length = 2) )) ##exclude NA values dstar <- na.exclude(dstar) ##calculate confidence intervalls IC_delta <- .CredibleInterval(dstar[,1],0.95) IC_sigma_d <- .CredibleInterval(dstar[,2],0.95) IC <- rbind(IC_delta, IC_sigma_d) # standard errors sedelta <- sqrt ((1/(Nb_BE-1))*sum((dstar[,1]-mean(dstar[,1]))^2)) sesigma_d <- sqrt ((1/(Nb_BE-1))*sum((dstar[,2]-mean(dstar[,2]))^2)) ##Terminal output if (verbose) { cat("\nconfidence intervals\n") cat("--------------------------------------------------\n") print(t(IC), print.gap = 6, digits = 4) cat("--------------------------------------------------\n") cat(paste("\n>> Results <<\n")) cat("----------------------------------------------------------\n") cat(paste( "Average dose:\t ", round(delta, 4), "\tse(Aver. dose):\t", round(sedelta, 4) )) if(sigma_d == 0){ cat(paste( "\nsigma_d:\t ", round(sigma_d, 4), "\t\tse(sigma_d):\t", round(sesigma_d, 4) )) }else{ cat(paste( "\nsigma_d:\t ", round(sigma_d, 4), "\tse(sigma_d):\t", round(sesigma_d, 4) )) } cat("\n----------------------------------------------------------\n") } ##compile final results data frame results_df <- data.frame( AVERAGE_DOSE = delta, AVERAGE_DOSE.SE = sedelta, SIGMA_D = sigma_d, SIGMA_D.SE = sesigma_d, IC_AVERAGE_DOSE.LEVEL = IC_delta[1], IC_AVERAGE_DOSE.LOWER = IC_delta[2], IC_AVERAGE_DOSE.UPPER = IC_delta[3], IC_SIGMA_D.LEVEL = IC_sigma_d[1], IC_SIGMA_D.LOWER = IC_sigma_d[2], IC_SIGMA_D.UPPER = IC_sigma_d[3], L_MAX = llik, row.names = NULL ) # Plotting ------------------------------------------------------------------------------------ ##the plotting (enable/disable) is controlled below, as with this ##we always get a histogram object ##set data list data_list <- list(dat$cd, dstar[,1], dstar[,2]) ##preset plot arguments plot_settings <- list( breaks = list("FD", "FD", "FD"), probability = list(FALSE, TRUE, TRUE), main = list( "Observed: Equivalent dose", "Bootstrapping: Average Dose", "Bootstrapping: Sigma_d"), xlab = list( "Equivalent dose [a.u.]", "Average dose [a.u.]", "Sigma_d"), axes = list(TRUE, TRUE, TRUE), col = NULL, border = NULL, density = NULL, freq = NULL, mtext = list( paste("n = ", length(data_list[[1]])), paste("n = ", length(data_list[[2]])), paste("n = ", length(data_list[[3]]))), rug = list(TRUE, TRUE, TRUE) ) ##modify this list by values the user provides ##expand all elements in the list ##problem: the user might provid only one item, then the code will break plot_settings.user <- lapply(list(...), function(x){ rep(x, length = 3) }) ##modify plot_settings <- modifyList(x = plot_settings.user, val = plot_settings) ##get change par setting and reset on exit par.default <- par()$mfrow on.exit(par(mfrow = par.default)) par(mfrow = c(1,3)) ##Produce plots ##(1) - histogram of the observed equivalent dose ##(2) - histogram of the bootstrapped De ##(3) - histogram of the bootstrapped sigma_d ##with lapply we get fetch also the return of hist, they user might want to use this later hist <- lapply(1:length(data_list), function(x){ temp <- suppressWarnings(hist( x = data_list[[x]], breaks = plot_settings$breaks[[x]], probability = plot_settings$probability[[x]], main = plot_settings$main[[x]], xlab = plot_settings$xlab[[x]], axes = plot_settings$axes[[x]], freq = plot_settings$freq[[x]], plot = plot, col = plot_settings$col[[x]], border = plot_settings$border[[x]], density = plot_settings$density[[x]] )) if (plot) { ##add rug if (plot_settings$rug[[x]]) { rug(data_list[[x]]) } ##plot mtext mtext(side = 3, text = plot_settings$mtext[[x]], cex = par()$cex) } return(temp) }) # Return -------------------------------------------------------------------------------------- set_RLum( class = "RLum.Results", data = list( summary = results_df, dstar = as.data.frame(dstar), hist = hist ), info = list(call = sys.call()) ) } Luminescence/R/plot_RLum.Data.Spectrum.R0000644000176200001440000006660013125226556017615 0ustar liggesusers#' Plot function for an RLum.Data.Spectrum S4 class object #' #' The function provides a standardised plot output for spectrum data of an #' RLum.Data.Spectrum S4 class object #' #' \bold{Matrix structure} \cr (cf. \code{\linkS4class{RLum.Data.Spectrum}}) #' #' \itemize{ \item \code{rows} (x-values): wavelengths/channels (xlim, xlab) #' \item \code{columns} (y-values): time/temperature (ylim, ylab) \item #' \code{cells} (z-values): count values (zlim, zlab) } #' #' \emph{Note: This nomenclature is valid for all plot types of this #' function!}\cr #' #' \bold{Nomenclature for value limiting} #' #' \code{xlim}: Limits values along the wavelength axis\cr \code{ylim}: Limits #' values along the time/temperature axis\cr \code{zlim}: Limits values along #' the count value axis\cr #' #' \bold{Energy axis re-calculation} #' #' If the argument \code{xaxis.energy = TRUE} is chosen, instead intensity vs. #' wavelength the spectrum is plotted as intensiyt vs. energy. Therefore the #' entire spectrum is re-recaluated (e.g., Appendix 4 in Blasse and Grabmeier, #' 1994): #' #' The intensity of the spectrum (z-values) is re-calcualted using the #' following equation: #' #' \deqn{\phi_{E} = \phi_{\lambda} * \lambda^2 / (hc)} #' #' with \eqn{\phi_{E}} the intensity per interval of energy \eqn{E} (eV), #' \eqn{\phi_{\lambda}} the intensity per interval of wavelength \eqn{\lambda} #' (nm) and \eqn{h} (eV/s) the Planck constant and \eqn{c} (m/s) the velocity #' of light. #' #' For transforming the wavelength axis (x-values) the equation #' #' \deqn{E = hc/\lambda} #' #' is used. For further details please see the cited the literature.\cr #' #' \bold{Details on the plot functions} #' #' Spectrum is visualised as 3D or 2D plot. Both plot types are based on #' internal R plot functions. \cr #' #' \bold{\code{plot.type = "persp"}} #' #' Arguments that will be passed to \code{\link{persp}}: \itemize{ \item #' \code{shade}: default is \code{0.4} \item \code{phi}: default is \code{15} #' \item \code{theta}: default is \code{-30} \item \code{expand}: default is #' \code{1} \item \code{ticktype}: default is \code{detailed}, \code{r}: default is \code{10}} #' #' \emph{Note: Further parameters can be adjusted via \code{par}. For example #' to set the background transparent and reduce the thickness of the lines use: #' \code{par(bg = NA, lwd = 0.7)} previous the function call.} #' #' \bold{\code{plot.type = "single"}}\cr #' #' Per frame a single curve is returned. Frames are time or temperature #' steps.\cr #' #' \bold{\code{plot.type = "multiple.lines"}}\cr #' #' All frames plotted in one frame.\cr #' #' \bold{\code{plot.type = "transect"}}\cr #' #' Depending on the selected wavelength/channel range a transect over the #' time/temperature (y-axis) will be plotted along the wavelength/channels #' (x-axis). If the range contains more than one channel, values (z-values) are #' summed up. To select a transect use the \code{xlim} argument, e.g. #' \code{xlim = c(300,310)} plot along the summed up count values of channel #' 300 to 310.\cr #' #' \bold{Further arguments that will be passed (depending on the plot type)} #' #' \code{xlab}, \code{ylab}, \code{zlab}, \code{xlim}, \code{ylim}, #' \code{zlim}, \code{main}, \code{mtext}, \code{pch}, \code{type} ("single", "multiple.lines", #' "interactive"), \code{col}, #' \code{border}, \code{box} \code{lwd}, \code{bty}, \code{showscale} ("interactive") \cr #' #' @param object \code{\linkS4class{RLum.Data.Spectrum}} or \code{\link{matrix}} (\bold{required}): S4 #' object of class \code{RLum.Data.Spectrum} or a \code{matrix} containing count values of the spectrum.\cr #' Please note that in case of a matrix rownames and colnames are set automatically if not provided. #' #' @param par.local \code{\link{logical}} (with default): use local graphical #' parameters for plotting, e.g. the plot is shown in one column and one row. #' If \code{par.local = FALSE} global parameters are inherited. #' @param plot.type \code{\link{character}} (with default): plot type, for #' 3D-plot use \code{persp}, or \code{interactive}, for a 2D-plot \code{contour}, #' \code{single} or \code{multiple.lines} (along the time or temperature axis) #' or \code{transect} (along the wavelength axis) \cr #' #' @param optical.wavelength.colours \code{\link{logical}} (with default): use #' optical wavelength colour palette. Note: For this, the spectrum range is #' limited: \code{c(350,750)}. Own colours can be set with the argument #' \code{col}. #' #' @param bg.channels \code{\link{vector}} (optional): defines channel for #' background subtraction If a vector is provided the mean of the channels is #' used for subtraction. Note: Background subtraction is applied prior to #' channel binning #' #' @param bin.rows \code{\link{integer}} (with defaul): allow summing-up #' wavelength channels (horizontal binning), e.g. \code{bin.rows = 2} two #' channels are summed up #' #' @param bin.cols \code{\link{integer}} (with default): allow summing-up #' channel counts (vertical binning) for plotting, e.g. \code{bin.cols = 2} two #' channels are summed up #' #' @param rug \code{\link{logical}} (with default): enables or disables colour #' rug. Currently only implemented for plot type \code{multiple.lines} and #' \code{single} #' #' @param limit_counts \code{\link{numeric}} (optional): value to limit all count values to #' this value, i.e. all count values above this threshold will be replaced by this threshold. This #' is helpfull especially in case of TL-spectra. #' #' @param xaxis.energy \code{\link{logical}} (with default): enables or #' disables energy instead of wavelength axis. Note: This option means not only #' simnply redrawing the axis, insteadly the spectrum in terms of intensity is #' recalculated, s. details. #' #' @param legend.text \code{\link{character}} (with default): possiblity to #' provide own legend text. This argument is only considered for plot types #' providing a legend, e.g. \code{plot.type="transect"} #' #' @param \dots further arguments and graphical parameters that will be passed #' to the \code{plot} function. #' #' @return Returns a plot. #' #' @note Not all additional arguments (\code{...}) will be passed similarly! #' #' @section Function version: 0.5.3 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\linkS4class{RLum.Data.Spectrum}}, \code{\link{plot}}, #' \code{\link{plot_RLum}}, \code{\link{persp}}, \code{\link[plotly]{plot_ly}}, #' \code{\link{contour}} #' #' @references Blasse, G., Grabmaier, B.C., 1994. Luminescent Materials. #' Springer. #' #' @keywords aplot #' #' @examples #' #' #' ##load example data #' data(ExampleData.XSYG, envir = environment()) #' #' ##(1)plot simple spectrum (2D) - contour #' plot_RLum.Data.Spectrum(TL.Spectrum, #' plot.type="contour", #' xlim = c(310,750), #' ylim = c(0,300), #' bin.rows=10, #' bin.cols = 1) #' #' ##(2) plot spectrum (3D) #' plot_RLum.Data.Spectrum(TL.Spectrum, #' plot.type="persp", #' xlim = c(310,750), #' ylim = c(0,100), #' bin.rows=10, #' bin.cols = 1) #' #' ##(3) plot multiple lines (2D) - multiple.lines (with ylim) #' plot_RLum.Data.Spectrum(TL.Spectrum, #' plot.type="multiple.lines", #' xlim = c(310,750), #' ylim = c(0,100), #' bin.rows=10, #' bin.cols = 1) #' #' \dontrun{ #' ##(4) interactive plot using the package plotly ("surface") #' plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="interactive", #' xlim = c(310,750), ylim = c(0,300), bin.rows=10, #' bin.cols = 1) #' #' ##(5) interactive plot using the package plotly ("contour") #' plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="interactive", #' xlim = c(310,750), ylim = c(0,300), bin.rows=10, #' bin.cols = 1, #' type = "contour", #' showscale = TRUE) #' #' ##(6) interactive plot using the package plotly ("heatmap") #' plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="interactive", #' xlim = c(310,750), ylim = c(0,300), bin.rows=10, #' bin.cols = 1, #' type = "heatmap", #' showscale = TRUE) #' #' ##(7) alternative using the package fields #' fields::image.plot(get_RLum(TL.Spectrum)) #' contour(get_RLum(TL.Spectrum), add = TRUE) #' #' } #' #' @export plot_RLum.Data.Spectrum <- function( object, par.local = TRUE, plot.type = "contour", optical.wavelength.colours = TRUE, bg.channels, bin.rows = 1, bin.cols = 1, rug = TRUE, limit_counts = NULL, xaxis.energy = FALSE, legend.text, ... ){ # Integrity check ----------------------------------------------------------- ##check if object is of class RLum.Data.Spectrum if(class(object) != "RLum.Data.Spectrum"){ if(class(object) == "matrix"){ if(is.null(colnames(object))){ colnames(object) <- 1:ncol(object) } if(is.null(rownames(object))){ rownames(object) <- 1:nrow(object) } object <- set_RLum(class = "RLum.Data.Spectrum", data = object) message("[plot_RLum.Data.Spectrum()] Input has been converted to a RLum.Data.Spectrum object using set_RLum()") }else{ stop("[plot_RLum.Data.Spectrum()] Input object neither of class 'RLum.Data.Spectrum' nor 'matrix'") } } ##XSYG ##check for curveDescripter if("curveDescripter" %in% names(object@info) == TRUE){ temp.lab <- strsplit(object@info$curveDescripter, split = ";")[[1]] xlab <- if(xaxis.energy == FALSE){ temp.lab[2]}else{"Energy [eV]"} ylab <- temp.lab[1] zlab <- temp.lab[3] }else{ xlab <- if(xaxis.energy == FALSE){ "Row values [a.u.]"}else{"Energy [eV]"} ylab <- "Column values [a.u.]" zlab <- "Cell values [a.u.]" } # Do energy axis conversion ------------------------------------------------------------------- if (xaxis.energy) { temp.object.data <- sapply(1:ncol(object@data), function(x) { object@data[,x] * x ^ 2 / (4.13566733e-015 * 299792458e+09) }) ##preserve column and rownames colnames(temp.object.data) <- colnames(object@data) rownames(temp.object.data) <- 4.13566733e-015 * 299792458e+09 / as.numeric(rownames(object@data)) ##write back to original data object@data <- temp.object.data[order(as.numeric(rownames(temp.object.data))),] } ##deal with addition arguments extraArgs <- list(...) main <- if("main" %in% names(extraArgs)) {extraArgs$main} else {"RLum.Data.Spectrum"} zlab <- if("zlab" %in% names(extraArgs)) {extraArgs$zlab} else {ifelse(plot.type == "multiple.lines", ylab, zlab)} xlab <- if("xlab" %in% names(extraArgs)) {extraArgs$xlab} else {xlab} ylab <- if("ylab" %in% names(extraArgs)) {extraArgs$ylab} else {ifelse(plot.type == "single" | plot.type == "multiple.lines", "Luminescence [cts/channel]", ylab)} xlim <- if("xlim" %in% names(extraArgs)) {extraArgs$xlim} else {c(min(as.numeric(rownames(object@data))), max(as.numeric(rownames(object@data))))} ylim <- if("ylim" %in% names(extraArgs)) {extraArgs$ylim} else {c(min(as.numeric(colnames(object@data))), max(as.numeric(colnames(object@data))))} #for zlim see below mtext <- if("mtext" %in% names(extraArgs)) {extraArgs$mtext} else {""} cex <- if("cex" %in% names(extraArgs)) {extraArgs$cex} else {1} phi <- if("phi" %in% names(extraArgs)) {extraArgs$phi} else {15} theta <- if("theta" %in% names(extraArgs)) {extraArgs$theta} else {-30} r <- if("r" %in% names(extraArgs)) {extraArgs$r} else {10} shade <- if("shade" %in% names(extraArgs)) {extraArgs$shade} else {0.4} expand <- if("expand" %in% names(extraArgs)) {extraArgs$expand} else {0.6} border <- if("border" %in% names(extraArgs)) {extraArgs$border} else {NULL} box <- if("box" %in% names(extraArgs)) {extraArgs$box} else {TRUE} ticktype <- if("ticktype" %in% names(extraArgs)) {extraArgs$ticktype} else {"detailed"} log<- if("log" %in% names(extraArgs)) {extraArgs$log} else {""} type<- if("type" %in% names(extraArgs)) {extraArgs$type} else { if (plot.type == "interactive") { "surface" } else{ "l" } } pch<- if("pch" %in% names(extraArgs)) {extraArgs$pch} else {1} lwd<- if("lwd" %in% names(extraArgs)) {extraArgs$lwd} else {1} bty <- if("bty" %in% names(extraArgs)) {extraArgs$bty} else {NULL} sub<- if("sub" %in% names(extraArgs)) {extraArgs$sub} else {""} #for plotly::plot_ly showscale<- if("showscale" %in% names(extraArgs)) {extraArgs$showscale} else {FALSE} # prepare values for plot --------------------------------------------------- temp.xyz <- get_RLum(object) ##check for NULL column names if(is.null(colnames(temp.xyz))){ colnames(temp.xyz) <- 1:ncol(temp.xyz) } if(is.null(rownames(temp.xyz))){ rownames(temp.xyz) <- 1:nrow(temp.xyz) } ##check for the case of a single column matrix if(ncol(temp.xyz)>1){ ##reduce for xlim temp.xyz <- temp.xyz[as.numeric(rownames(temp.xyz)) >= xlim[1] & as.numeric(rownames(temp.xyz)) <= xlim[2],] ##reduce for ylim temp.xyz <- temp.xyz[, as.numeric(colnames(temp.xyz)) >= ylim[1] & as.numeric(colnames(temp.xyz)) <= ylim[2]] } ## wavelength x <- as.numeric(rownames(temp.xyz)) ## time/temp y <- as.numeric(colnames(temp.xyz)) # Background subtraction --------------------------------------------------- if(missing(bg.channels) == FALSE){ if(length(bg.channels) > 1){ temp.bg.signal <- rowMeans(temp.xyz[,bg.channels]) temp.xyz <- temp.xyz[,1:ncol(temp.xyz)] - temp.bg.signal }else{ temp.xyz <- temp.xyz[,1:ncol(temp.xyz)] - temp.xyz[,bg.channels] temp.xyz <- ifelse(temp.xyz < 0, mean(temp.xyz[,bg.channels]), temp.xyz) } ##set values < 0 to 0 temp.xyz <- ifelse(temp.xyz < 0, mean(temp.xyz[,bg.channels[1]]), temp.xyz) } # Channel binning --------------------------------------------------------- ##fatal checks if(bin.cols < 1 | bin.rows < 1){ stop("[plot_RLum.Data.Spectrum()] 'bin.cols' and 'bin.rows' have to be > 1!", call. = FALSE) } if(bin.rows > 1){ ##calculate n.rows n.rows <- nrow(temp.xyz) ##modulo operation for the number of groups bin.group.rest <- n.rows%%bin.rows ##define groups for binning bin.group <- rep(1:(n.rows/bin.rows), 1, each = bin.rows) ##add last group bin.group <- c(bin.group, rep(n.rows/bin.rows + 1, 1, each = bin.group.rest)) ##sum up rows temp.xyz <- rowsum(temp.xyz, bin.group) ##correct labelling x <- x[seq(1, n.rows, bin.rows)] ## to avoid odd plots remove last group if bin.rows is not a multiple ## of the row number if(bin.group.rest != 0){ temp.xyz <- temp.xyz[-nrow(temp.xyz),] x <- x[-length(x)] warning("Last wavelength channel has been removed due to binning.") } ##replace rownames rownames(temp.xyz) <- as.character(x) rm(bin.group.rest) } if(bin.cols > 1){ ##calculate n.cols n.cols <- ncol(temp.xyz) ##check for validity if(bin.cols > n.cols){ bin.cols <- n.cols warning("bin.cols > the number of columns. Value reduced to number of cols.") } ##modulo operation for the number of groups bin.group.rest <- n.cols%%bin.cols ##define groups for binning bin.group <- rep(1:(n.cols/bin.cols), 1, each = bin.cols) ##add last group bin.group <- c(bin.group, rep(n.cols/bin.cols + 1, 1, each = bin.group.rest)) ##sum up cols temp.xyz <- rowsum(t(temp.xyz), bin.group) temp.xyz <- t(temp.xyz) ##correct labeling y <- y[seq(1, n.cols, bin.cols)] ## to avoid odd plots remove last group if bin.cols is not a multiple ## of the col number if(bin.group.rest != 0){ temp.xyz <- temp.xyz[,-ncol(temp.xyz)] y <- y[-length(y)] warning("Last count channel has been removed due to column binning.") } ##replace colnames colnames(temp.xyz) <- as.character(y) } ##limit z-values if requested, this idea was taken from the Diss. by Thomas Schilles, 2002 if(!is.null(limit_counts)){ temp.xyz[temp.xyz[]>limit_counts] <- limit_counts } ##check for zlim zlim <- if("zlim" %in% names(extraArgs)) {extraArgs$zlim} else {range(temp.xyz)} # set color values -------------------------------------------------------- if("col" %in% names(extraArgs) == FALSE | plot.type == "single" | plot.type == "multiple.lines"){ if(optical.wavelength.colours == TRUE | (rug == TRUE & (plot.type != "persp" & plot.type != "interactive"))){ ##make different colour palette for energy valuesw if (xaxis.energy) { col.violet <- c(2.76, ifelse(max(xlim) <= 4.13, max(xlim), 4.13)) col.blue <- c(2.52, 2.76) col.green <- c(2.18, 2.52) col.yellow <- c(2.10, 2.18) col.orange <- c(2.00, 2.10) col.red <- c(1.57, 2.00) col.infrared <- c(1.55, ifelse(min(xlim) >= 1.55, min(xlim), 1.57)) #set colour palette col <- unlist(sapply(1:length(x), function(i){ if(x[i] >= col.violet[1] & x[i] < col.violet[2]){"#EE82EE"} else if(x[i] >= col.blue[1] & x[i] < col.blue[2]){"#0000FF"} else if(x[i] >= col.green[1] & x[i] < col.green[2]){"#00FF00"} else if(x[i] >= col.yellow[1] & x[i] < col.yellow[2]){"#FFFF00"} else if(x[i] >= col.orange[1] & x[i] < col.orange[2]){"#FFA500"} else if(x[i] >= col.red[1] & x[i] < col.red[2]){"#FF0000"} else if(x[i] <= col.infrared[2]){"#BEBEBE"} })) }else{ col.violet <- c(ifelse(min(xlim) <= 300, min(xlim), 300),450) col.blue <- c(450,495) col.green <- c(495,570) col.yellow <- c(570,590) col.orange <- c(590,620) col.red <- c(620,790) col.infrared <- c(790, ifelse(max(xlim) >= 800, max(xlim), 800)) #set colour palette col <- unlist(sapply(1:length(x), function(i){ if(x[i] >= col.violet[1] & x[i] < col.violet[2]){"#EE82EE"} else if(x[i] >= col.blue[1] & x[i] < col.blue[2]){"#0000FF"} else if(x[i] >= col.green[1] & x[i] < col.green[2]){"#00FF00"} else if(x[i] >= col.yellow[1] & x[i] < col.yellow[2]){"#FFFF00"} else if(x[i] >= col.orange[1] & x[i] < col.orange[2]){"#FFA500"} else if(x[i] >= col.red[1] & x[i] < col.red[2]){"#FF0000"} else if(x[i] >= col.infrared[1]){"#BEBEBE"} })) } ##find unique colours col.unique <- unique(col) ##if only one colour value, then skip gradient calculation as it causes ## an error if(length(col.unique) > 1){ ##set colour function for replacement colfunc <- colorRampPalette(col.unique) ##get index for colour values to be cut from the current palette col.unique.index <- sapply(1:length(col.unique), function(i) { max(which(col == col.unique[i])) }) ##remove last index (no colour gradient needed), for energy axis use the first value col.unique.index <- col.unique.index[-length(col.unique.index)] ##set borders for colour gradient recalculation col.unique.index.min <- col.unique.index - (50)/bin.rows col.unique.index.max <- col.unique.index + (50)/bin.rows ##set negative values to the lowest index col.unique.index.min[col.unique.index.min<=0] <- 1 ##build up new index sequence (might be better) col.gradient.index <- as.vector(unlist(( sapply(1:length(col.unique.index.min), function(j){ seq(col.unique.index.min[j],col.unique.index.max[j], by = 1) })))) ##generate colour ramp and replace values col.new <- colfunc(length(col.gradient.index)) col[col.gradient.index] <- col.new ##correct for overcharged colour values (causes zebra colour pattern) if (diff(c(length(col), nrow(temp.xyz))) < 0) { col <- col[1:c(length(col) - diff(c(length(col), nrow(temp.xyz))))] }else if(diff(c(length(col), nrow(temp.xyz))) > 0){ col <- col[1:c(length(col) + diff(c(length(col), nrow(temp.xyz))))] } } }else{ col <- "black" } }else{ col <- extraArgs$col } # Do log scaling if needed ------------------------------------------------- ##x if(grepl("x", log)==TRUE){x <- log10(x)} ##y if(grepl("y", log)==TRUE){y <- log10(y)} ##z if(grepl("z", log)==TRUE){temp.xyz <- log10(temp.xyz)} # PLOT -------------------------------------------------------------------- ##par setting for possible combination with plot method for RLum.Analysis objects if(par.local == TRUE){par(mfrow=c(1,1), cex = cex)} ##rest plot type for 1 column matrix if(ncol(temp.xyz) == 1){ plot.type = "single" warning("[plot_RLum.Data.Spectrum()] Single column matrix: plot.type has been automatically reset to 'single'") } ##do not let old code break down ... if(plot.type == "persp3d"){ plot.type <- "interactive" warning("[plot_RLum.Data.Spectrum()] 'plot.type' has been automatically reset to interactive!") } if(plot.type == "persp" && ncol(temp.xyz) > 1){ ## ==========================================================================# ##perspective plot ## ==========================================================================# persp(x, y, temp.xyz, shade = shade, phi = phi, theta = theta, xlab = xlab, ylab = ylab, zlab = zlab, zlim = zlim, scale = TRUE, col = col[1:(length(col)-1)], ##needed due to recycling of the colours main = main, expand = expand, border = border, box = box, r = r, ticktype = ticktype) ##plot additional mtext mtext(mtext, side = 3, cex = cex*0.8) }else if(plot.type == "interactive" && ncol(temp.xyz) > 1) { ## ==========================================================================# ##interactive plot and former persp3d ## ==========================================================================# ## Plot: interactive ---- ##http://r-pkgs.had.co.nz/description.html if (!requireNamespace("plotly", quietly = TRUE)) { stop("[plot_RLum.Data.Spectrum()] Package 'plotly' needed for this plot type. Please install it.", call. = FALSE) } ##set up plot p <- plotly::plot_ly( z = temp.xyz, x = as.numeric(colnames(temp.xyz)), y = as.numeric(rownames(temp.xyz)), type = type, showscale = showscale #colors = col[1:(length(col)-1)], ) ##change graphical parameters p <- plotly::layout( p = p, scene = list( xaxis = list( title = ylab ), yaxis = list( title = xlab ), zaxis = list(title = zlab) ), title = main ) print(p) on.exit(return(p)) }else if(plot.type == "contour" && ncol(temp.xyz) > 1) { ## ==========================================================================# ##contour plot ## ==========================================================================# contour(x,y,temp.xyz, xlab = xlab, ylab = ylab, main = main, col = "black" ) ##plot additional mtext mtext(mtext, side = 3, cex = cex*0.8) } else if(plot.type == "single") { ## ==========================================================================# ## single plot ## ==========================================================================# col.rug <- col col<- if("col" %in% names(extraArgs)) {extraArgs$col} else {"black"} for(i in 1:length(y)){ if("zlim" %in% names(extraArgs) == FALSE){zlim <- range(temp.xyz[,i])} plot(x, temp.xyz[,i], xlab = xlab, ylab = ylab, main = main, xlim = xlim, ylim = zlim, col = col, sub = paste( "(frame ",i, " | ", ifelse(i==1, paste("0.0 :", round(y[i], digits = 1)), paste(round(y[i-1], digits = 1),":", round(y[i], digits =1))),")", sep = ""), type = type, pch = pch) if(rug == TRUE){ ##rug als continous polygons for(i in 1:length(x)){ polygon(x = c(x[i],x[i+1],x[i+1],x[i]), y = c(min(zlim),min(zlim), par("usr")[3], par("usr")[3]), border = col.rug[i], col = col.rug[i]) } } } ##plot additional mtext mtext(mtext, side = 3, cex = cex*0.8) }else if(plot.type == "multiple.lines" && ncol(temp.xyz) > 1) { ## ========================================================================# ## multiple.lines plot ## ========================================================================# col.rug <- col col<- if("col" %in% names(extraArgs)) {extraArgs$col} else {"black"} ##change graphic settings par.default <- par()[c("mfrow", "mar", "xpd")] par(mfrow = c(1,1), mar=c(5.1, 4.1, 4.1, 8.1), xpd = TRUE) ##grep zlim if("zlim" %in% names(extraArgs) == FALSE){zlim <- range(temp.xyz)} ##open plot area plot(NA, NA, xlab = xlab, ylab = ylab, main = main, xlim = xlim, ylim = zlim, sub = sub, bty = bty) if(rug == TRUE){ ##rug als continous polygons for(i in 1:length(x)){ polygon(x = c(x[i],x[i+1],x[i+1],x[i]), y = c(min(zlim),min(zlim), par("usr")[3], par("usr")[3]), border = col.rug[i], col = col.rug[i]) } } ##add lines for(i in 1:length(y)){ lines(x, temp.xyz[,i], lty = i, lwd = lwd, type = type, col = col) } ##for missing values - legend.text if(missing(legend.text)){ legend.text <- as.character(paste(round(y,digits=1), zlab)) } ##legend legend(x = par()$usr[2], y = par()$usr[4], legend = legend.text, lwd= lwd, lty = 1:length(y), bty = "n", cex = 0.6*cex) ##plot additional mtext mtext(mtext, side = 3, cex = cex*0.8) ##reset graphic settings par(par.default) rm(par.default) }else if(plot.type == "transect" && ncol(temp.xyz) > 1) { ## ========================================================================# ## transect plot ## ========================================================================# ##sum up rows (column sum) temp.xyz <- colSums(temp.xyz) ##consider differences within the arguments #check for zlim zlim <- if("zlim" %in% names(extraArgs)) {extraArgs$zlim} else {c(0,max(temp.xyz))} #check for zlim zlab <- if("ylab" %in% names(extraArgs)) {extraArgs$ylab} else {paste("Counts [1/summed channels]")} plot(y, temp.xyz, xlab = ylab, ylab = zlab, main = main, xlim = ylim, ylim = zlim, col = col, sub = paste("(channel range: ", min(xlim), " : ", max(xlim), ")", sep=""), type = type, pch = pch) ##plot additional mtext mtext(mtext, side = 3, cex = cex*0.8) }else{ stop("[plot_RLum.Data.Spectrum()] Unknown plot type.") } } Luminescence/R/report_RLum.R0000644000176200001440000006640413125226556015503 0ustar liggesusers#' Create a HTML report for (RLum) objects #' #' This function creates a HTML report for a given object, listing its complete #' structure and content. The object itself is saved as a serialised .Rds file. #' The report file serves both as a convenient way of browsing through objects with #' complex data structures as well as a mean of properly documenting and saving #' objects. #' #' The HTML report is created with \code{\link[rmarkdown]{render}} and has the #' following structure: #' #' \tabular{ll}{ #' \bold{Section} \tab \bold{Description} \cr #' \code{Header} \tab A summary of general characteristics of the object \cr #' \code{Object content} \tab A comprehensive list of the complete structure #' and content of the provided object. \cr #' \code{Object structure} \tab Summary of the objects structure given as a table \cr #' \code{File} \tab Information on the saved RDS file \cr #' \code{Session Info} \tab Captured output from sessionInfo() \cr #' \code{Plots} \tab (optional) For \code{RLum-class} objects a variable number of plots \cr #' } #' #' The structure of the report can be controlled individually by providing one or more of the #' following arguments (all \code{logical}): #' #' \tabular{ll}{ #' \bold{Argument} \tab \bold{Description} \cr #' \code{header} \tab Hide or show general information on the object \cr #' \code{main} \tab Hide or show the object's content \cr #' \code{structure} \tab Hide or show object's structure \cr #' \code{rds} \tab Hide or show information on the saved RDS file \cr #' \code{session} \tab Hide or show the session info \cr #' \code{plot} \tab Hide or show the plots (depending on object) \cr #' } #' #' Note that these arguments have higher precedence than \code{compact}. #' #' Further options that can be provided via the \code{...} argument: #' #' \tabular{ll}{ #' \bold{Argument} \tab \bold{Description} \cr #' \code{short_table} \tab If \code{TRUE} only show the first and last 5 rows of lang tables. \cr #' \code{theme} \tab Specifies the Bootstrap #' theme to use for the report. Valid themes include "default", "cerulean", "journal", "flatly", #' "readable", "spacelab", "united", "cosmo", "lumen", "paper", "sandstone", "simplex", and "yeti". \cr #' \code{highlight} \tab Specifies the syntax highlighting #' style. Supported styles include "default", "tango", "pygments", "kate", "monochrome", #' "espresso", "zenburn", "haddock", and "textmate". \cr #' \code{css} \tab \code{TRUE} or \code{FALSE} to enable/disable custom CSS styling \cr #' } #' #' The following arguments can be used to customise the report via CSS (Cascading Style Sheets): #' #' \tabular{ll}{ #' \bold{Argument} \tab \bold{Description} \cr #' \code{font_family} \tab Define the font family of the HTML document (default: arial) \cr #' \code{headings_size} \tab Size of the

to
tags used to define HTML headings (default: 166\%). \cr #' \code{content_color} \tab Color of the object's content (default: #a72925). \cr #' } #' #' Note that these arguments must all be of class \code{\link{character}} and follow standard CSS syntax. #' For exhaustive CSS styling you can provide a custom CSS file for argument \code{css.file}. #' CSS styling can be turned of using \code{css = FALSE}. #' #' @param object (\bold{required}): #' The object to be reported on, preferably of any \code{RLum}-class. #' #' @param file \code{\link{character}} (with default): #' A character string naming the output file. If no filename is provided a #' temporary file is created. #' #' @param title \code{\link{character}} (with default): #' A character string specifying the title of the document. #' #' @param compact \code{\link{logical}} (with default): #' When \code{TRUE} the following report components are hidden: #' \code{@@.pid}, \code{@@.uid}, \code{'Object structure'}, \code{'Session Info'} #' and only the first and last 5 rows of long matrices and data frames are shown. #' See details. #' #' @param timestamp \code{\link{logical}} (with default): #' \code{TRUE} to add a timestamp to the filename (suffix). #' #' @param launch.browser \code{\link{logical}} (with default): #' \code{TRUE} to open the HTML file in the system's default web browser after #' it has been rendered. #' #' @param css.file \code{\link{character}} (optional): #' Path to a CSS file to change the default styling of the HTML document. #' #' @param quiet \code{\link{logical}} (with default): #' \code{TRUE} to supress printing of the pandoc command line. #' #' @param clean \code{\link{logical}} (with default): #' \code{TRUE} to clean intermediate files created during rendering. #' #' @param ... further arguments passed to or from other methods and to control #' the document's structure (see details). #' #' @section Function version: 0.1.0 #' #' @author #' Christoph Burow, University of Cologne (Germany) \cr #' #' @note #' This function requires the R packages 'rmarkdown', 'pander' and 'rstudioapi'. #' #' @seealso \code{\link[rmarkdown]{render}}, \code{\link[pander]{pander_return}}, #' \code{\link[pander]{openFileInOS}}, \code{\link[rstudioapi]{viewer}}, #' \code{\link{browseURL}} #' #' @return #' Writes a HTML and .Rds file. #' #' @export #' #' @examples #' #' \dontrun{ #' ## Example: RLum.Results ---- #' #' # load example data #' data("ExampleData.DeValues") #' #' # apply the MAM-3 age model and save results #' mam <- calc_MinDose(ExampleData.DeValues$CA1, sigmab = 0.2) #' #' # create the HTML report #' report_RLum(object = mam, file = "~/CA1_MAM.Rmd", #' timestamp = FALSE, #' title = "MAM-3 for sample CA1") #' #' # when creating a report the input file is automatically saved to a #' # .Rds file (see saveRDS()). #' mam_report <- readRDS("~/CA1_MAM.Rds") #' all.equal(mam, mam_report) #' #' #' ## Example: Temporary file & Viewer/Browser ---- #' #' # (a) #' # Specifying a filename is not necessarily required. If no filename is provided, #' # the report is rendered in a temporary file. If you use the RStudio IDE, the #' # temporary report is shown in the interactive Viewer pane. #' report_RLum(object = mam) #' #' # (b) #' # Additionally, you can view the HTML report in your system's default web browser. #' report_RLum(object = mam, launch.browser = TRUE) #' #' #' ## Example: RLum.Analysis ---- #' #' data("ExampleData.RLum.Analysis") #' #' # create the HTML report (note that specifying a file #' # extension is not necessary) #' report_RLum(object = IRSAR.RF.Data, file = "~/IRSAR_RF") #' #' #' ## Example: RLum.Data.Curve ---- #' #' data.curve <- get_RLum(IRSAR.RF.Data)[[1]] #' #' # create the HTML report #' report_RLum(object = data.curve, file = "~/Data_Curve") #' #' ## Example: Any other object ---- #' x <- list(x = 1:10, #' y = runif(10, -5, 5), #' z = data.frame(a = LETTERS[1:20], b = dnorm(0:9)), #' NA) #' #' report_RLum(object = x, file = "~/arbitray_list") #' } report_RLum <- function(object, file = tempfile(), title = "RLum.Report", compact = TRUE, timestamp = TRUE, launch.browser = FALSE, css.file = NULL, quiet = TRUE, clean = TRUE, ...) { ## ------------------------------------------------------------------------ ## ## PRE-CHECKS ---- # check if required namespace(s) are available if (!requireNamespace("rmarkdown", quietly = TRUE)) stop("Creating object reports requires the 'rmarkdown' package.", " To install this package run 'install.packages('rmarkdown')' in your R console.", call. = FALSE) if (!requireNamespace("pander", quietly = TRUE)) stop("Creating object reports requires the 'pander' package.", " To install this package run 'install.packages('pander')' in your R console.", call. = FALSE) if (!requireNamespace("rstudioapi", quietly = TRUE)) { warning("Creating object reports requires the 'rstudioapi' package.", " To install this package run 'install.packages('rstudioapi')' in your R console.", call. = FALSE) isRStudio <- FALSE } else { isRStudio <- TRUE } # check if files exist if (!is.null(css.file)) if(!file.exists(css.file)) stop("Couldn't find the specified CSS file at '", css.file, "'", call. = FALSE) ## ------------------------------------------------------------------------ ## ## STRUCTURE ---- structure <- list(header = TRUE, main = TRUE, structure = ifelse(compact, FALSE, TRUE), rds = TRUE, session = ifelse(compact, FALSE, TRUE), plot = TRUE) # specifying report components has higher precedence than the 'compact' arg structure <- modifyList(structure, list(...)) ## OPTIONS ---- options <- list(short_table = ifelse(compact, TRUE, FALSE), theme = "cerulean", highlight = "haddock", css = TRUE) options <- modifyList(options, list(...)) ## CSS DEFAULTS ---- css <- list(font_family = "arial", headings_size = "166%", content_color = "#a72925") css <- modifyList(css, list(...)) ## ------------------------------------------------------------------------ ## ## CREATE FILE ---- isTemp <- missing(file) # make sure the filename ends with .Rmd extension if (!grepl(".rmd$", file, ignore.case = TRUE)) file <- paste0(file, ".Rmd") # Timestamp: currently added as a suffix to the filename # if we were to change it to a prefix, we need to first figure out the filename # (i.e., separate it from the possible path) using the following regular # expression strsplit(string, "\\\\|\\\\\\\\|\\/|\\/\\/"). This looks for # \, \\, /, // and the last element is the filename. if (timestamp) file <- gsub(".rmd$", paste0(format(Sys.time(), "_%Y%b%d"), ".Rmd"), file, ignore.case = TRUE) # sanitize file name file <- gsub("\\\\", "\\/", file) file.html <- gsub(".rmd$", ".html", file, ignore.case = TRUE) file.rds <- gsub(".rmd$", ".Rds", file, ignore.case = TRUE) # Create and open the file file.create(file) tmp <- file(file, open = "w") # save RDS file saveRDS(object, file.rds) ## ------------------------------------------------------------------------ ## ## WRITE CONTENT ---- # HEADER ---- writeLines("---", tmp) writeLines("output:", tmp) writeLines(" html_document:", tmp) writeLines(" mathjax: null", tmp) writeLines(" title: RLum.Report", tmp) writeLines(paste(" theme:", options$theme), tmp) writeLines(paste(" highlight:", options$highlight), tmp) writeLines(" toc: true", tmp) writeLines(" toc_float: true", tmp) writeLines(" toc_depth: 6", tmp) if (!is.null(css.file)) writeLines(paste(" css:", css.file), tmp) writeLines(" md_extensions: -autolink_bare_uris", tmp) writeLines("---", tmp) # CASCADING STYLE SHEETS ---- if (options$css) { writeLines(paste0( "" ), tmp) } # INFO ---- # check if Luminescence package is installed and get details pkg <- as.data.frame(installed.packages(), row.names = FALSE) if ("Luminescence" %in% pkg$Package) pkg <- pkg[which(pkg$Package == "Luminescence"), ] else pkg <- data.frame(LibPath = "-", Version = "not installed", Built = "-") # Title writeLines(paste("

", title, "

\n\n
"), tmp) # write information on R, Luminescence package, Object if (structure$header) { writeLines(paste("**Date:**", Sys.time(), "\n\n", "**R version:**", R.version.string, "\n\n", "**Luminescence package** \n\n", "**  » Path:**", pkg$LibPath, "\n\n", "**  » Version:**", pkg$Version, "\n\n", "**  » Built:**", pkg$Built, "\n\n", "**Object** \n\n", "**  » Created:**", tryCatch(paste(paste(strsplit(object@.uid, '-|\\.')[[1]][1:3], collapse = "-"), strsplit(object@.uid, '-|\\.')[[1]][4]), error = function(e) "-"), "\n\n", "**  » Class:**", class(object), "\n\n", "**  » Originator:**", tryCatch(object@originator, error = function(e) "-"), "\n\n", "**  » Name:**", deparse(substitute(object)), "\n\n", "**  » Parent ID:**", tryCatch(object@.pid, error = function(e) "-"), "\n\n", "**  » Unique ID:**", tryCatch(object@.uid, error = function(e) "-"), "\n\n", "
"), tmp) if (isTemp) { writeLines(paste("
Save report"), tmp) writeLines(paste("Save data \n\n"), tmp) } }#EndOf::Header # OBJECT ---- elements <- .struct_RLum(object, root = deparse(substitute(object))) if (structure$main) { for (i in 1:nrow(elements)) { # SKIP ELEMENT? # hide @.pid and @.uid if this is a shortened report (default) if (elements$bud[i] %in% c(".uid", ".pid") && compact == TRUE) next # HEADER short.name <- elements$bud[i] links <- gsub("[^@$\\[]", "", as.character(elements$branch[i])) type <- ifelse(nchar(links) == 0, "", substr(links, nchar(links), nchar(links))) if (type == "[") type = "" # HTML header level is determined by the elements depth in the object # exception: first row is always the object's name and has depth zero if (i == 1) hlevel <- "#" else hlevel <- paste(rep("#", elements$depth[i]), collapse = "") # write header; number of dots represents depth in the object. because there # may be duplicate header names, for each further occurence of a name # Zero-width non-joiner entities are added to the name (non visible) writeLines(paste0(hlevel, " ", "", paste(rep("..", elements$depth[i]), collapse = ""), type, "", paste(rep("‌", elements$bud.freq[i]), collapse = ""), short.name[length(short.name)], ifelse(elements$endpoint[i], "", "{#root}"), "\n\n"), tmp) # SUBHEADER # contains information on Class, Length, Dimensions, Path writeLines(paste0("
",
                        "",
                        " 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 autoformatting
        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) { writeLines(pander::pander_return(rbind(head(table, 5), tail(table, 5)), caption = "shortened (only first and last five rows shown)"), tmp) next } } } # write table using pander and end each table with a horizontal line writeLines(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 ", file.rds, ".", "To import the object into your R session with the following command:", paste0("
",
                            "x <- readRDS('", 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('", file.rds,"') \n", plotCommand, "```"), tmp) if (inherits(object, "RLum.Results")) { # AGE MODELS ---- models <- c("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 & RENDER ---- close(tmp) on.exit(closeAllConnections()) rmarkdown::render(file, clean = clean, quiet = quiet) ## ------------------------------------------------------------------------ ## ## SHOW FILE ----- # SHOW REPORT IN RSTUDIOS VIEWER PANE ---- if (isRStudio) { 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)) } ## ------------------------------------------------------------------------ ## ## 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) { if (missing(root)) root <- deparse(substitute(x)) ## 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) { if (missing(root)) root <- deparse(substitute(x)) 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/read_PSL2R.R0000644000176200001440000002704713125226556015066 0ustar liggesusers#' Import PSL files to R #' #' Imports PSL files produced by a SUERC portable OSL reader into R \bold{(BETA)}. #' #' This function provides an import routine for the SUERC portable OSL Reader PSL format. #' PSL files are just plain text and can be viewed with any text editor. Due to the #' formatting of PSL files this import function relies heavily on regular expression to find and #' extract all relevant information. See \bold{note}. #' #' @param file \code{\link{character}} (\bold{required}): path and file name of the #' PSL file. If input is a \code{vector} it should comprise only \code{character}s representing #' valid paths and PSL file names. #' Alternatively the input character can be just a directory (path). In this case the #' the function tries to detect and import all PSL files found in the directory. #' #' @param drop_bg \code{\link{logical}} (with default): \code{TRUE} to automatically #' remove all non-OSL/IRSL curves. #' #' @param as_decay_curve \code{\link{logical}} (with default): Portable OSL Reader curves #' are often given as cumulative light sum curves. Use \code{TRUE} (default) to convert #' the curves to the more usual decay form. #' #' @param smooth \code{\link{logical}} (with default): \code{TRUE} to apply #' Tukey's Running Median Smoothing for OSL and IRSL decay curves. Smoothing is #' encouraged if you see random signal drops within the decay curves related #' to hardware errors. #' #' @param merge \code{\link{logical}} (with default): \code{TRUE} to merge all #' \code{RLum.Analysis} objects. Only applicable if multiple files are imported. #' #' @param ... currently not used. #' #' @return Returns an S4 \code{\linkS4class{RLum.Analysis}} object containing #' \code{\linkS4class{RLum.Data.Curve}} objects for each curve. #' #' @seealso \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Data.Curve}} #' #' @author Christoph Burow, University of Cologne (Germany) #' #' @section Function version: 0.0.1 #' #' @note Because this function relies heavily on regular expressions to parse #' PSL files it is currently only in beta status. If the routine fails to import #' a specific PSL file please report to so the #' function can be updated. #' #' @keywords IO #' #' @examples #' #' # (1) Import PSL file to R #' #' \dontrun{ #' FILE <- file.choose() #' temp <- read_PSL2R(FILE) #' temp #' } #' #' @export read_PSL2R <- function(file, drop_bg = FALSE, as_decay_curve = TRUE, smooth = FALSE, merge = FALSE, ...) { ## INPUT VALIDATION ---- if (length(file) == 1) { if (!grepl(".psl$", file, ignore.case = TRUE)) { file <- list.files(file, pattern = ".psl$", full.names = TRUE, ignore.case = TRUE) message("The following files were found and imported: \n", paste(file, collapse = "\n")) } } if (!all(file.exists(file))) stop("The following files do not exist, please check: \n", paste(file[!file.exists(file)], collapse = "\n"), call. = FALSE) ## MAIN ---- results <- vector("list", length(file)) for (i in 1:length(file)) { ## Read in file ---- doc <- readLines(file[i]) ## Document formatting ---- # remove lines with i) blanks only, ii) dashes, iii) equal signs doc <- gsub("^[ ]*$", "", doc) doc <- gsub("^[ -]*$", "", doc) doc <- gsub("^[ =]*$", "", doc) # the header ends with date and time with the previous line starting with a single slash lines_with_slashes <- doc[grepl("\\", doc, fixed = TRUE)] ## OFFENDING LINE: this deletes the line with sample name and time and date sample_and_date <- lines_with_slashes[length(lines_with_slashes)] sample <- gsub("[^0-9a-zA-Z\\-_]", "",strsplit(sample_and_date, "@")[[1]][1], perl = TRUE) date_and_time <- strsplit(strsplit(sample_and_date, "@")[[1]][2], " ")[[1]] date_and_time_clean <- date_and_time[date_and_time != "" & date_and_time != "/" & date_and_time != "PM" & date_and_time != "AM"] date <- as.Date(date_and_time_clean[1], "%m/%d/%Y") time <- format(date_and_time_clean[2], format = "%h:%M:%S") doc <- gsub(lines_with_slashes[length(lines_with_slashes)], "", fixed = TRUE, doc) # last delimiting line before measurements are only apostrophes and dashes lines_with_apostrophes <- doc[grepl("'", doc, fixed = TRUE)] doc <- gsub(lines_with_apostrophes[length(lines_with_apostrophes)], "", fixed = TRUE, doc) # finally remove all empty lines doc <- doc[doc != ""] ## Split document ---- begin_of_measurements <- grep("Measurement :", doc, fixed = TRUE) number_of_measurements <- length(begin_of_measurements) # Parse and format header header <- doc[1:(begin_of_measurements[1]-1)] header <- format_Header(header) # add sample name, date and time to header list header$Date <- date header$Time <- time header$Sample <- sample # Parse and format the easurement values measurements_split <- vector("list", number_of_measurements) # save lines of each measurement to individual list elements for (j in seq_len(number_of_measurements)) { if (j != max(number_of_measurements)) measurements_split[[j]] <- doc[begin_of_measurements[j]:(begin_of_measurements[j+1] - 1)] else measurements_split[[j]] <- doc[begin_of_measurements[j]:length(doc)] } # format each measurement; this will return a list of RLum.Data.Curve objects measurements_formatted <- lapply(measurements_split, function(x) { format_Measurements(x, convert = as_decay_curve, header = header) }) # drop dark count measurements if needed if (drop_bg) { measurements_formatted <- lapply(measurements_formatted, function(x) { if (x@recordType != "USER") return(x) }) measurements_formatted <- measurements_formatted[!sapply(measurements_formatted, is.null)] } # decay curve smoothing using Tukey's Running Median Smoothing (?smooth) if (smooth) { measurements_formatted <- lapply(measurements_formatted, function(x) { if (x@recordType != "USER") x@data[,2] <- smooth(x@data[ ,2]) return(x) }) } ## RETURN ---- results[[i]] <- set_RLum("RLum.Analysis", protocol = "portable OSL", info = header, records = measurements_formatted) }#Eof::Loop ## MERGE ---- if (length(results) > 1 && merge) results <- merge_RLum(results) ## RETURN ---- if (length(results) == 1) results <- results[[1]] return(results) } ################################################################################ ## HELPER FUNCTIONS ################################################################################ ## ------------------------- FORMAT MEASUREMENT ----------------------------- ## format_Measurements <- function(x, convert, header) { ## measurement parameters are given in the first line settings <- x[1] settings_split <- unlist(strsplit(settings, "|", fixed = TRUE)) # welcome to regex/strsplit hell settings_measurement <- trimws(gsub(".*: ", "", settings_split[which(grepl("Measure", settings_split))])) settings_stimulation_unit <- gsub("[^0-9]", "", settings_split[which(grepl("Stim", settings_split))]) settings_on_time <- as.integer(unlist(strsplit(gsub("[^0-9,]", "", settings_split[which(grepl("Off", settings_split))]), ","))[1]) settings_off_time <- as.integer(unlist(strsplit(gsub("[^0-9,]", "", settings_split[which(grepl("Off", settings_split))]), ","))[2]) settings_cycle <- na.omit(as.integer(unlist(strsplit(gsub("[^0-9,]", "", settings_split[which(grepl("No", settings_split))]), ","))))[1] settings_stimulation_time <- na.omit(as.integer(unlist(strsplit(gsub("[^0-9,]", "", settings_split[which(grepl("No", settings_split))]), ","))))[2] settings_list <- list("measurement" = settings_measurement, "stimulation_unit" = switch(settings_stimulation_unit, "0" = "USER", "1" = "IRSL", "2" = "OSL"), "on_time" = settings_on_time, "off_time" = settings_off_time, "cycle" = settings_cycle, "stimulation_time" = settings_stimulation_time) ## terminal counts are given in the last line terminal_count_text <- x[length(x)] terminal_count_text_formatted <- gsub("[^0-9]", "", unlist(strsplit(terminal_count_text, "/"))) terminal_count <- as.numeric(terminal_count_text_formatted[1]) terminal_count_error <- as.numeric(terminal_count_text_formatted[2]) ## parse values and create a data frame x_stripped <- x[-c(1, 2, length(x))] df <- data.frame(matrix(NA, ncol = 5, nrow = length(x_stripped))) for (i in 1:length(x_stripped)) { x_split <- unlist(strsplit(x_stripped[i], " ")) x_split <- x_split[x_split != ""] x_split_clean <- gsub("[^0-9\\-]", "", x_split) x_split_cleaner <- x_split_clean[x_split_clean != "-"] df[i, ] <- as.numeric(x_split_cleaner) } names(df) <- c("time", "counts", "counts_error", "counts_per_cycle", "counts_per_cycle_error") # shape of the curve: decay or cumulative if (convert) data <- matrix(c(df$time, df$counts_per_cycle), ncol = 2) else data <- matrix(c(df$time, df$counts), ncol = 2) # determine the stimulation type if (grepl("Stim 0", settings)) { recordType <- "USER" } if (grepl("Stim 1", settings)) { recordType <- "IRSL" } if (grepl("Stim 2", settings)) { recordType <- "OSL" } object <- set_RLum(class = "RLum.Data.Curve", originator = "read_PSL2R", recordType = recordType, curveType = "measured", data = data, info = list(settings = c(settings_list, header), raw_data = df)) return(object) } ## ---------------------------- FORMAT HEADER ------------------------------- ## format_Header <- function(x) { header_formatted <- list() # split by double blanks header_split <- strsplit(x, " ", fixed = TRUE) # check wether there are twice as many values # as colons; if there is an equal amount, the previous split was not sufficient # and we need to further split by a colon (that is followed by a blank) header_split_clean <- lapply(header_split, function(x) { x <- x[x != ""] n_elements <- length(x) n_properties <- length(grep(":", x, fixed = TRUE)) if (n_elements / n_properties == 1) x <- unlist(strsplit(x, ": ", fixed = TRUE)) return(x) }) # format parameter/settings names and corresponding values values <- vector(mode = "character") names <- vector(mode = "character") for (i in 1:length(header_split_clean)) { for (j in seq(1, length(header_split_clean[[i]]), 2)) { names <- c(names, header_split_clean[[i]][j]) values <- c(values, header_split_clean[[i]][j + 1]) } } # some RegExing for nice reading names <- gsub("[: ]$", "", names, perl = TRUE) names <- gsub("^ ", "", names) names <- gsub(" $", "", names) # for some weird reason "offset subtract" starts with '256 ' names <- gsub("256 ", "", names) # finally, replace all blanks with underscores names <- gsub(" ", "_", names) values <- gsub("[: ]$", "", values, perl = TRUE) values <- gsub("^ ", "", values) values <- gsub(" $", "", values) # return header as list header <- as.list(values) names(header) <- names return(header) }Luminescence/R/replicate_RLum.R0000644000176200001440000000132113125226556016123 0ustar liggesusers#' General replication function for RLum S4 class objects #' #' Function replicates RLum S4 class objects and returns a list for this objects #' #' @param object an object of class \code{\linkS4class{RLum}} (\bold{required}) #' #' @param times \code{\link{integer}} (optional): number for times each element is repeated #' element #' #' @return Returns a \code{\link{list}} of the object to be repeated #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso #' \code{\linkS4class{RLum}}, #' #' @keywords utilities #' #' @export setGeneric("replicate_RLum", function (object, times = NULL) { standardGeneric("replicate_RLum") }) Luminescence/R/template_DRAC.R0000644000176200001440000005375413125226556015641 0ustar liggesusers#' Create a DRAC input data template (v1.1) #' #' This function returns a DRAC input template (v1.1) to be used in conjunction #' with the use_DRAC() function #' #' @param nrow \code{\link{integer}} (with default): specifies the number of rows #' of the template (i.e., the number of data sets you want to submit) #' #' @param notification \code{\link{logical}} (with default): show or hide the #' notification #' #' @return A list. #' #' @author Christoph Burow, University of Cologne (Germany) #' #' @references #' #' Durcan, J.A., King, G.E., Duller, G.A.T., 2015. DRAC: Dose Rate and Age Calculator for trapped charge dating. #' Quaternary Geochronology 28, 54-61. doi:10.1016/j.quageo.2015.03.012 #' #' @seealso \code{\link{as.data.frame}} \code{\link{list}} #' #' @examples #' #' # create a new DRAC input input #' input <- template_DRAC() #' #' # show content of the input #' print(input) #' print(input$`Project ID`) #' print(input[[4]]) #' #' #' ## Example: DRAC Quartz example #' # note that you only have to assign new values where they #' # are different to the default values #' input$`Project ID` <- "DRAC-Example" #' input$`Sample ID` <- "Quartz" #' input$`Conversion factors` <- "AdamiecAitken1998" #' input$`External U (ppm)` <- 3.4 #' input$`errExternal U (ppm)` <- 0.51 #' input$`External Th (ppm)` <- 14.47 #' input$`errExternal Th (ppm)` <- 1.69 #' input$`External K (%)` <- 1.2 #' input$`errExternal K (%)` <- 0.14 #' input$`Calculate external Rb from K conc?` <- "N" #' input$`Calculate internal Rb from K conc?` <- "N" #' input$`Scale gammadoserate at shallow depths?` <- "N" #' input$`Grain size min (microns)` <- 90 #' input$`Grain size max (microns)` <- 125 #' input$`Water content ((wet weight - dry weight)/dry weight) %` <- 5 #' input$`errWater content %` <- 2 #' input$`Depth (m)` <- 2.2 #' input$`errDepth (m)` <- 0.22 #' input$`Overburden density (g cm-3)` <- 1.8 #' input$`errOverburden density (g cm-3)` <- 0.1 #' input$`Latitude (decimal degrees)` <- 30.0000 #' input$`Longitude (decimal degrees)` <- 70.0000 #' input$`Altitude (m)` <- 150 #' input$`De (Gy)` <- 20 #' input$`errDe (Gy)` <- 0.2 #' #' # use DRAC #' \dontrun{ #' output <- use_DRAC(input) #' } #' #' @export template_DRAC <- function(nrow = 1, notification = TRUE) { ## TODO: # 1 - allow mineral specific presets; new argument 'mineral' # 2 - add option to return the DRAC example data set if (nrow < 0 | nrow > 33) stop("'nrow' must be a number between 0 and 33.", call. = FALSE) ## LEGAL NOTICE ---- messages <- list("\n", "\t-------------------- IMPORTANT NOTE ------------------------\n", "\t This function returns a DRAC input template to be used in ", "\t conjunction with the use_DRAC() function. \n", "\t The template was reproduced with great care, but we do not", "\t take any responsibility and we are not liable for any ", "\t mistakes or unforeseen misbehaviour.", "\t Note that this template is only compatible with DRAC", "\t version 1.1. Before using this template make sure that", "\t this is the correct version, otherwise expect unspecified", "\t errors.\n", "\t Please ensure you cite the use of DRAC in your work,", "\t published or otherwise. Please cite the website name and", "\t version (e.g. DRAC v1.1) and the accompanying journal", "\t article:", "\t Durcan, J.A., King, G.E., Duller, G.A.T., 2015.", "\t DRAC: Dose rate and age calculation for trapped charge", "\t dating. Quaternary Geochronology 28, 54-61. \n", "\t Set 'notification = FALSE' to hide this message. \n", "\t-------------------- IMPORTANT NOTE ------------------------", "\n") if (notification) lapply(messages, message) # CREATE TEMPLATE ---- template <- list( `Project ID` = structure(rep("RLum", nrow), required = TRUE, allowsX = FALSE, key = "TI:1", description = "Inputs can be alphabetic, numeric or selected symbols (/ - () [] _). Spaces are not permitted."), # `Sample ID` = structure(rep("999", nrow), required = TRUE, allowsX = FALSE, key = "TI:2", description = "Inputs can be alphabetic, numeric or selected symbols (/ - () [] _). Spaces are not permitted."), # `Mineral` = structure(factor(rep("Q", nrow), c("Q", "F", "PM")), required = TRUE, allowsX = FALSE, key = "TI:3", description = "The mineral used for dating: quartz, feldspar or polymineral. Input must be 'Q', 'F' or 'PM'."), # `Conversion factors` = structure(factor(rep("Liritzisetal2013", nrow), c("AdamiecAitken1998", "Guerinetal2011", "Liritzisetal2013", "X")), required = FALSE, allowsX = TRUE, key = "TI:4", description = "The conversion factors required to calculate dose rates from radionuclide concentrations. Users have the option of datasets from Adamiec and Aitken (1998), Guerin et al. (2011) or Liritzis et al. (2013). Input must be 'AdamiecAitken1998', 'Guerinetal2011', 'Liritzisetal2013' or 'X' if conversion factors are not required."), # `External U (ppm)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:5", description = "Radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `errExternal U (ppm)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:6", description = "Radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `External Th (ppm)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:7", description = "Radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `errExternal Th (ppm)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:8", description = "Radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `External K (%)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:9", description = "Radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `errExternal K (%)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:10", description = "Radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `External Rb (ppm)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:11", description = "Radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `errExternal Rb (ppm)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:12", description = "Radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `Calculate external Rb from K conc?` = structure(factor(rep("Y", nrow), c("Y", "N")), required = FALSE, allowsX = FALSE, key = "TI:13", description = "Option to calculate a Rubidium concentration from Potassium, using the 270:1 ratio suggested by Mejdahl (1987). Input should be yes 'Y' or no 'N'."), # `Internal U (ppm)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:14", description = "Internal radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `errInternal U (ppm)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:15", description = "Internal radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `Internal Th (ppm)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:16", description = "Internal radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `errInternal Th (ppm)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:17", description = "Internal radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `Internal K (%)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:18", description = "Internal radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `errInternal K (%)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:19", description = "Internal radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `Rb (ppm)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:20", description = "Internal radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `errRb (ppm)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:21", description = "Internal radionuclide concentrations in parts per million for Uranium, Thorium and Rubidium and % for Potassium. Inputs must be 0 or positive and should not be left blank."), # `Calculate internal Rb from K conc?` = structure(factor(rep("Y", nrow), c("Y", "N", "X")), required = FALSE, allowsX = TRUE, key = "TI:22", description = "Option to calculate an internal Rubidium concentration from Potassium, using the 270:1 ratio suggested by Mejdahl (1987). Input should be yes 'Y' or no 'N'."), # `User external alphadoserate (Gy.ka-1)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:23", description = "Users may input directly measured values for external alpha, beta and gamma dose rates (in Gy.ka-1). Any positive inputs in these fields will override dose rates calculated from radionuclide concentrations. Inputs should be 0 or positive and should not be left blank"), # `errUser external alphadoserate (Gy.ka-1)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:24", description = "Users may input directly measured values for external alpha, beta and gamma dose rates (in Gy.ka-1). Any positive inputs in these fields will override dose rates calculated from radionuclide concentrations. Inputs should be 0 or positive and should not be left blank"), # `User external betadoserate (Gy.ka-1)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:25", description = "Users may input directly measured values for external alpha, beta and gamma dose rates (in Gy.ka-1). Any positive inputs in these fields will override dose rates calculated from radionuclide concentrations. Inputs should be 0 or positive and should not be left blank"), # `errUser external betadoserate (Gy.ka-1)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:26", description = "Users may input directly measured values for external alpha, beta and gamma dose rates (in Gy.ka-1). Any positive inputs in these fields will override dose rates calculated from radionuclide concentrations. Inputs should be 0 or positive and should not be left blank"), # `User external gamma doserate (Gy.ka-1)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:27", description = "Users may input directly measured values for external alpha, beta and gamma dose rates (in Gy.ka-1). Any positive inputs in these fields will override dose rates calculated from radionuclide concentrations. Inputs should be 0 or positive and should not be left blank"), # `errUser external gammadoserate (Gy.ka-1)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:28", description = "Users may input directly measured values for external alpha, beta and gamma dose rates (in Gy.ka-1). Any positive inputs in these fields will override dose rates calculated from radionuclide concentrations. Inputs should be 0 or positive and should not be left blank"), # `User internal doserate (Gy.ka-1)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:29", description = "Users may input an internal dose rate (either alpha, beta or the sum of the two; in Gy.ka-1). DRAC will assume that this value has already been corrected for attenuation. Inputs in this field will override dose rates calculated from radionuclide concentrations. Inputs should be 0 or positive and not left blank."), # `errUser internal doserate (Gy.ka-1)` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:30", description = "Users may input an internal dose rate (either alpha, beta or the sum of the two; in Gy.ka-1). DRAC will assume that this value has already been corrected for attenuation. Inputs in this field will override dose rates calculated from radionuclide concentrations. Inputs should be 0 or positive and not left blank."), # `Scale gammadoserate at shallow depths?` = structure(factor(rep("Y", nrow), c("Y", "N")), required = FALSE, allowsX = FALSE, key = "TI:31", description = "Users may choose to scale gamma dose rates for samples taken within 0.3 m of the ground surface. The scaling factors of Aitken (1985) are used. Input should be yes 'Y' or no 'N'."), # `Grain size min (microns)` = structure(rep(100, nrow), required = TRUE, allowsX = FALSE, key = "TI:32", description = "The grain size range analysed. DRAC can be used for the grain size ranges between 1 and 1000 microns. Inputs should range between 1 and 1000 and not be left blank."), # `Grain size max (microns)` = structure(rep(150, nrow), required = TRUE, allowsX = FALSE, key = "TI:33", description = "The grain size range analysed. DRAC can be used for the grain size ranges between 1 and 1000 microns. Inputs should range between 1 and 1000 and not be left blank."), # `alpha-Grain size attenuation` = structure(factor(rep("Brennanetal1991", nrow), c("Bell1980", "Brennanetal1991")), required = TRUE, allowsX = FALSE, key = "TI:34", description = "The grain size attenuation factors for the alpha dose rate. Users have the option of datasets from Bell (1980) and Brennan et al. (1991). Input must be 'Bell1980' or 'Brennanetal1991'."), # `beta-Grain size attenuation ` = structure(factor(rep("Guerinetal2012-Q", nrow), c("Mejdahl1979", "Brennan2003", "Guerinetal2012-Q", "Guerinetal2012-F")), required = TRUE, allowsX = FALSE, key = "TI:35", description = "The grain size attenuation factors for the beta dose rate. Users have the option of datasets from Mejdahl (1979), Brennan (2003) and Guerin et al. (2012) for quartz or feldspar. Input must be 'Mejdahl1979', 'Brennan2003', 'Guerinetal2012-Q' or 'Guerinetal2012-F' ."), # `Etch depth min (microns)` = structure(rep(8, nrow), required = TRUE, allowsX = FALSE, key = "TI:36", description = "The user defined etch depth range (microns). Inputs should range between 0 and 30 and not be left blank."), # `Etch depth max (microns)` = structure(rep(10, nrow), required = TRUE, allowsX = FALSE, key = "TI:37", description = "The user defined etch depth range (microns). Inputs should range between 0 and 30 and not be left blank."), # `beta-Etch depth attenuation factor` = structure(factor(rep("Bell1979", nrow), c("Bell1979", "Brennan2003", "X")), required = FALSE, allowsX = TRUE, key = "TI:38", description = "The etch depth attenuation factors for the beta dose rate. Users have the option of datasets from Bell (1979) and Brennan (2003). Input must be 'Bell1979' or 'Brennan2003'. Note: only the dataset of Bell (1980) is provided for attenuation of the alpha dose rate by etching."), # `a-value` = structure(rep(0, nrow), required = FALSE, allowsX = TRUE, key = "TI:39", description = "Alpha track efficiency value and uncertainty defined by the user. Inputs should be 0 or positive and not left blank."), # `erra-value` = structure(rep(0, nrow), required = TRUE, allowsX = TRUE, key = "TI:40", description = "Alpha track efficiency value and uncertainty defined by the user. Inputs should be 0 or positive and not left blank."), # `Water content ((wet weight - dry weight)/dry weight) %` = structure(rep(0, nrow), required = TRUE, allowsX = FALSE, key = "TI:41", description = "Sediment water content (%) over the burial period. Inputs should be 0 or positive and not be left blank."), # `errWater content %` = structure(rep(0, nrow), required = FALSE, allowsX = FALSE, key = "TI:42", description = "Sediment water content (%) over the burial period. Inputs should be 0 or positive and not be left blank."), # `Depth (m)` = structure(rep("X", nrow), required = FALSE, allowsX = TRUE, key = "TI:43", description = "Depth and uncertainty from which sample was extracted beneath the ground surface. Inputs should be 0 or positive and not left blank."), # `errDepth (m)` = structure(rep("X", nrow), required = FALSE, allowsX = TRUE, key = "TI:44", description = "Depth and uncertainty from which sample was extracted beneath the ground surface. Inputs should be 0 or positive and not left blank."), # `Overburden density (g cm-3)` = structure(rep(1.8, nrow), required = TRUE, allowsX = FALSE, key = "TI:45", description = "Density of the overlying sediment matrix from which the sample was taken. Inputs should be 0 or positive and not be left blank. The scaling calculation will use the overburden density and uncertainty provided."), # `errOverburden density (g cm-3)` = structure(rep(0.1, nrow), required = TRUE, allowsX = FALSE, key = "TI:46", description = "Density of the overlying sediment matrix from which the sample was taken. Inputs should be 0 or positive and not be left blank. The scaling calculation will use the overburden density and uncertainty provided."), # `Latitude (decimal degrees)` = structure(rep("X", nrow), required = FALSE, allowsX = TRUE, key = "TI:47", description = "Latitude and longitude of sample location (in degree decimals). Positive values should be used for northern latitudes and eastern longitudes and negative values for southern latitudes and western longitudes. Inputs should range from -90 to 90 degrees for latitudes and -180 to 180 degrees for longitude."), # `Longitude (decimal degrees)` = structure(rep("X", nrow), required = FALSE, allowsX = TRUE, key = "TI:48", description = "Latitude and longitude of sample location (in degree decimals). Positive values should be used for northern latitudes and eastern longitudes and negative values for southern latitudes and western longitudes. Inputs should range from -90 to 90 degrees for latitudes and -180 to 180 degrees for longitude."), # `Altitude (m)` = structure(rep("X", nrow), required = FALSE, allowsX = TRUE, key = "TI:49", description = "Altitude of sample location in metres above sea level. Input should be less than 5000 and not left blank."), # `User cosmicdoserate (Gy.ka-1)` = structure(rep("X", nrow), required = FALSE, allowsX = TRUE, key = "TI:50", description = "Users may input a cosmic dose rate (in Gy.ka-1). Inputs in these fields will override the DRAC calculated cosmic dose rate. Inputs should be positive or 'X' if not required, and not left blank."), # `errUser cosmicdoserate (Gy.ka-1)` = structure(rep("X", nrow), required = FALSE, allowsX = TRUE, key = "TI:51", description = "Users may input a cosmic dose rate (in Gy.ka-1). Inputs in these fields will override the DRAC calculated cosmic dose rate. Inputs should be positive or 'X' if not required, and not left blank."), # `De (Gy)` = structure(rep("X", nrow), required = FALSE, allowsX = TRUE, key = "TI:52", description = "Sample De and uncertainty (in Gy). Inputs should be positive or 'X' if not required, and not left blank."), # `errDe (Gy)` = structure(rep("X", nrow), required = FALSE, allowsX = TRUE, key = "TI:53", description = "Sample De and uncertainty (in Gy). Inputs should be positive or 'X' if not required, and not left blank.") # ) ## RETURN VALUE --- # add an additional DRAC class so we can define our own S3 method for as.data.frame class(template) <- c("DRAC.list", "list") invisible(template) }Luminescence/R/names_RLum.R0000644000176200001440000000203513125226556015261 0ustar liggesusers#' S4-names function for RLum S4 class objects #' #' Function calls object-specific names functions for RLum S4 class objects. #' #' The function provides a generalised access point for specific #' \code{\linkS4class{RLum}} objects.\cr Depending on the input object, the #' corresponding 'names' function will be selected. Allowed arguments can be found #' in the documentations of the corresponding \code{\linkS4class{RLum}} class. #' #' @param object \code{\linkS4class{RLum}} (\bold{required}): S4 object of #' class \code{RLum} #' @return Returns a \code{\link{character}} #' @section Function version: 0.1.0 #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' @seealso #' \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Data.Image}}, #' \code{\linkS4class{RLum.Data.Spectrum}}, #' \code{\linkS4class{RLum.Analysis}}, #' \code{\linkS4class{RLum.Results}} #' @keywords utilities #' @aliases names_RLum #' #' @export setGeneric("names_RLum", function(object) { standardGeneric("names_RLum") }) Luminescence/R/apply_EfficiencyCorrection.R0000644000176200001440000000640713125226556020527 0ustar liggesusers#' Function to apply spectral efficiency correction to RLum.Data.Spectrum S4 #' class objects #' #' The function allows spectral efficiency corrections for RLum.Data.Spectrum #' S4 class objects #' #' The efficiency correction is based on a spectral response dataset provided #' by the user. Usually the data set for the quantum efficiency is of lower #' resolution and values are interpolated for the required spectral resolution using #' the function \code{\link[stats]{approx}} #' #' If the energy calibration differes for both data set \code{NA} values are produces that #' will be removed from the matrix. #' #' @param object \code{\linkS4class{RLum.Data.Spectrum}} (\bold{required}): S4 #' object of class \code{RLum.Data.Spectrum} #' #' @param spectral.efficiency \code{\link{data.frame}} (\bold{required}): Data #' set containing wavelengths (x-column) and relative spectral response values #' (y-column) in percentage #' #' @return Returns same object as input #' (\code{\linkS4class{RLum.Data.Spectrum}}) #' #' @note Please note that the spectral efficiency data from the camera alone may not #' sufficiently correct for spectral efficiency of the entire optical system #' (e.g., spectrometer, camera ...). #' #' @section Function version: 0.1.1 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France),\cr Johannes Friedrich, University of Bayreuth (Germany) #' #' @seealso \code{\linkS4class{RLum.Data.Spectrum}} #' #' @references - #' #' @keywords manip #' #' @examples #' #' #' ##(1) - use with your own data (uncomment for usage) #' ## spectral.efficiency <- read.csv("your data") #' ## #' ## your.spectrum <- apply_EfficiencyCorrection(your.spectrum, ) #' #' @export apply_EfficiencyCorrection <- function( object, spectral.efficiency ){ # Integrity check ----------------------------------------------------------- ##check if object is of class RLum.Data.Spectrum if(class(object) != "RLum.Data.Spectrum"){ stop("[apply_EfficiencyCorrection()] Input object is not of type RLum.Data.Spectrum") } if(class(spectral.efficiency) != "data.frame"){ stop("[apply_EfficiencyCorrection()] Input object is not of type data.frame") } ## grep data matrix temp.matrix <- as(object, "matrix") ## grep efficency values temp.efficiency <- as.matrix(spectral.efficiency) # Apply method ------------------------------------------------------------ #set data for interpolation temp.efficiency.x <- as.numeric(row.names(temp.matrix)) temp.efficiency.interpolated <- approx( x = temp.efficiency[,1], y = temp.efficiency[,2], xout = temp.efficiency.x) ##correct for quantum efficiency temp.matrix <- vapply(X = 1:ncol(temp.matrix), FUN = function(x){ temp.matrix[,x]/temp.efficiency.interpolated$y*max(temp.efficiency.interpolated$y, na.rm = TRUE) }, FUN.VALUE = numeric(length = nrow(temp.matrix))) ##remove NA values temp.matrix <- na.exclude(temp.matrix) ##correct colnames colnames(temp.matrix) <- colnames(get_RLum(object)) # Return Output------------------------------------------------------------ temp.output <- set_RLum( class = "RLum.Data.Spectrum", recordType = object@recordType, curveType = object@curveType, data = temp.matrix, info = object@info) invisible(temp.output) } Luminescence/R/convert_Daybreak2CSV.R0000644000176200001440000000547113125226556017146 0ustar liggesusers#' Export measurement data produced by a Daybreak luminescence reader to CSV-files #' #' This function is a wrapper function around the functions \code{\link{read_Daybreak2R}} and #' \code{\link{write_RLum2CSV}} and it imports an Daybreak-file (TXT-file, DAT-file) #' and directly exports its content to CSV-files. If nothing is set for the argument \code{path} (\code{\link{write_RLum2CSV}}) #' the input folder will become the output folder. #' #' @param file \code{\link{character}} (\bold{required}): name of the Daybreak-file (TXT-file, DAT-file) to be converted to CSV-files #' #' @param \dots further arguments that will be passed to the function \code{\link{read_Daybreak2R}} and \code{\link{write_RLum2CSV}} #' #' @return The function returns either a CSV-file (or many of them) or for the option \code{export = FALSE} #' a list comprising objects of type \code{link{data.frame}} and \code{\link{matrix}} #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data}}, \code{\linkS4class{RLum.Results}}, #' \code{\link[utils]{write.table}}, \code{\link{write_RLum2CSV}}, \code{\link{read_Daybreak2R}} #' #' @keywords IO #' #' @examples #' #' \dontrun{ #' ##select your BIN-file #' file <- file.choose() #' #' ##convert #' convert_Daybreak2CSV(file) #' #' } #' #' @export convert_Daybreak2CSV <- function( file, ... ){ # General tests ------------------------------------------------------------------------------- ##file is missing? if(missing(file)){ stop("[convert_Daybreak2R()] file is missing!", call. = FALSE) } ##set input arguments convert_Daybreak2R_settings.default <- list( raw = FALSE, verbose = TRUE, txtProgressBar = TRUE, export = TRUE ) ##modify list on demand convert_Daybreak2R_settings <- modifyList(x = convert_Daybreak2R_settings.default, val = list(...)) # Import file --------------------------------------------------------------------------------- if(!inherits(file, "RLum")){ object <- read_Daybreak2R( file = file, raw = convert_Daybreak2R_settings$raw, verbose = convert_Daybreak2R_settings$raw, txtProgressBar = convert_Daybreak2R_settings$raw ) }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_Daybreak2R_settings$export), list(...)) arguments[duplicated(names(arguments))] <- NULL ##this if-condition prevents NULL in the terminal if(convert_Daybreak2R_settings$export == TRUE){ invisible(do.call("write_RLum2CSV", arguments)) }else{ do.call("write_RLum2CSV", arguments) } } Luminescence/R/analyse_FadingMeasurement.R0000644000176200001440000006705513125226556020346 0ustar liggesusers#' Analyse fading measurements and returns the fading rate per decade (g-value) #' #' The function analysis fading measurements and returns a fading rate including an error estimation. #' The function is not limited to standard fading measurements, as can be seen, e.g., Huntley and #' Lamothe 2001. Additionally, the density of recombination centres (rho') is estimated after #' Kars et al. 2008. #' #' All provided output corresponds to the \eqn{tc} value obtained by this analysis. Additionally #' in the output object the g-value normalised to 2-days is provided. The output of this function #' can be passed to the function \code{\link{calc_FadingCorr}}.\cr #' #' \bold{Fitting and error estimation}\cr #' #' For the fitting the function \code{\link[stats]{lm}} is used without applying weights. For the #' error estimation all input values, except tc, as the precision can be consdiered as sufficiently #' high enough with regard to the underlying problem, are sampled assuming a normal distribution #' for each value with the value as the mean and the provided uncertainty as standard deviation. \cr #' #' \bold{Density of recombination centres} #' #' The density of recombination centres, expressed by the dimensionless variable rho', is estimated #' by fitting equation 5 in Kars et al. 2008 to the data. For the fitting the function #' \code{\link[stats]{nls}} is used without applying weights. For the error estimation the same #' procedure as for the g-value is applied (see above). #' #' @param object \code{\linkS4class{RLum.Analysis}} (\bold{required}): input object with the #' measurement data. Alternatively, a \code{\link{list}} containing \code{\linkS4class{RLum.Analysis}} #' objects or a \code{\link{data.frame}} with three columns #' (x = LxTx, y = LxTx error, z = time since irradiation) can be provided. #' Can also be a wide table, i.e. a \code{\link{data.frame}} with a number of colums divisible by 3 #' and where each triplet has the before mentioned column structure. #' #' @param structure \code{\link{character}} (with default): sets the structure of the measurement #' data. Allowed are \code{'Lx'} or \code{c('Lx','Tx')}. Other input is ignored #' #' @param signal.integral \code{\link{vector}} (\bold{required}): vector with the #' limits for the signal integral. Not required if a \code{data.frame} with LxTx values are #' provided. #' #' @param background.integral \code{\link{vector}} (\bold{required}): vector with the #' bounds for the background integral. Not required if a \code{data.frame} with LxTx values are #' provided. #' #' @param t_star \code{\link{character}} (with default): method for calculating the time elasped #' since irradiaton. Options are: \code{'half'}, which is \eqn{t_star := t_1 + (t_2 - t_1)/2} (Auclair et al., 2003) #' and \code{'end'}, which takes the time between irradiation and the measurement step. Default is \code{'half'} #' #' @param n.MC \code{\link{integer}} (with default): number for Monte Carlo runs for the error #' estimation #' #' @param verbose \code{\link{logical}} (with default): enables/disables verbose mode #' #' @param plot \code{\link{logical}} (with default): enables/disables plot output #' #' @param plot.single \code{\link{logical}} (with default): enables/disables single plot #' mode, i.e. one plot window per plot. Alternatively a vector specifying the plot to be drawn, e.g., #' \code{plot.single = c(3,4)} draws only the last two plots #' #' @param \dots (optional) further arguments that can be passed to internally used functions (see details) #' #' @return An \code{\linkS4class{RLum.Results}} object is returned: #' #' Slot: \bold{@data}\cr #' #' \tabular{lll}{ #' \bold{OBJECT} \tab \code{TYPE} \tab \code{COMMENT}\cr #' \code{fading_results} \tab \code{data.frame} \tab results of the fading measurement in a table \cr #' \code{fit} \tab \code{lm} \tab object returned by the used linear fitting function \code{\link[stats]{lm}}\cr #' \code{rho_prime} \tab \code{data.frame} \tab results of rho' estimation after Kars et al. 2008 \cr #' \code{LxTx_table} \tab \code{data.frame} \tab Lx/Tx table, if curve data had been provided \cr #' \code{irr.times} \tab \code{integer} \tab vector with the irradiation times in seconds \cr #' } #' #' Slot: \bold{@info}\cr #' #' \tabular{lll}{ #' \bold{OBJECT} \tab \code{TYPE} \tab \code{COMMENT}\cr #' \code{call} \tab \code{call} \tab the original function call\cr #' #' } #' #' #' @section Function version: 0.1.5 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr #' Christoph Burow, University of Cologne (Germany) #' #' @note \bold{This function has BETA status and should not be used for publication work!} #' #' @keywords datagen #' #' @references #' #' Auclair, M., Lamothe, M., Huot, S., 2003. Measurement of anomalous fading for feldpsar IRSL using #' SAR. Radiation Measurements 37, 487-492. doi:10.1016/S1350-4487(03)00018-0 #' #' 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. doi:10.1139/cjes-38-7-1093 #' #' Kars, R.H., Wallinga, J., Cohen, K.M., 2008. A new approach towards anomalous fading correction for feldspar #' IRSL dating-tests on samples in field saturation. Radiation Measurements 43, 786-790. doi:10.1016/j.radmeas.2008.01.021 #' #' @seealso \code{\link{calc_OSLLxTxRatio}}, \code{\link{read_BIN2R}}, \code{\link{read_XSYG2R}}, #' \code{\link{extract_IrradiationTimes}} #' #' @examples #' #' ## load example data (sample UNIL/NB123, see ?ExampleData.Fading) #' data("ExampleData.Fading", envir = environment()) #' #' ##(1) get fading measurement data (here a three column data.frame) #' fading_data <- ExampleData.Fading$fading.data$IR50 #' #' ##(2) run analysis #' g_value <- analyse_FadingMeasurement( #' fading_data, #' plot = TRUE, #' verbose = TRUE, #' n.MC = 10) #' #' ##(3) this can be further used in the function #' ## to correct the age according to Huntley & Lamothe, 2001 #' results <- calc_FadingCorr( #' age.faded = c(100,2), #' g_value = g_value, #' n.MC = 10) #' #' #' @export analyse_FadingMeasurement <- function( object, structure = c("Lx", "Tx"), signal.integral, background.integral, t_star = 'half', n.MC = 100, verbose = TRUE, plot = TRUE, plot.single = FALSE, ... ){ # Integrity Tests ----------------------------------------------------------------------------- if (is(object, "list")) { if (!unique(sapply(object, class)) == "RLum.Analysis") { stop( "[analyse_FadingMeasurement()] 'object' expects an 'RLum.Analysis' object or a 'list' of such objects!" ) } } else if (class(object) == "RLum.Analysis") { object <- list(object) } else if(class(object) == "data.frame"){ if (ncol(object) %% 3 != 0) { stop("[analyse_FadingMeasurement()] 'object': if you provide a data.frame as input, the number of columns must be a multiple of 3.") } else { object <- do.call(rbind, lapply(seq(1, ncol(object), 3), function(col) { setNames(object[ , col:c(col+2)], c("LxTx", "LxTxError", "timeSinceIrr")) }) ) object <- object[complete.cases(object), ] } ##set table and object LxTx_table <- data.frame(LxTx = object[[1]], LxTx.Error = object[[2]]) TIMESINCEIRR <- object[[3]] irradiation_times <- TIMESINCEIRR object <- NULL }else{ stop( "[analyse_FadingMeasurement()] 'object' needs to be of type 'RLum.Analysis' or a 'list' of such objects!" ) } # Prepare data -------------------------------------------------------------------------------- if(!is.null(object)){ ##support read_XSYG2R() if(length(unique(unlist(lapply(object, slot, name = "originator")))) == 1 && unique(unlist(lapply(object, slot, name = "originator"))) == "read_XSYG2R"){ irradiation_times <- extract_IrradiationTimes(object = object) ##reduce irradiation times ... extract curve data TIMESINCEIRR <- unlist(lapply(irradiation_times, function(x) { ##get time since irradiation temp_TIMESINCEIRR <- x$irr.times[["TIMESINCEIRR"]][!grepl(pattern = "irradiation", x = x$irr.times[["STEP"]], fixed = TRUE)] ##substract half irradiation time temp_IRR_TIME <- x$irr.times[["IRR_TIME"]][!grepl(pattern = "irradiation", x = x$irr.times[["STEP"]], fixed = TRUE)] ##in accordance with Auclair et al., 2003, p. 488 ##but here we have no t1 ... this needs to be calculated ##set variables t1 <- temp_TIMESINCEIRR t2 <- temp_TIMESINCEIRR + temp_IRR_TIME if(t_star == "half"){ ##calculate t_star t_star <- t1 + (t2 - t1)/2 }else if (t_star == "end"){ ##set t_start as t_1 (so after the end of irradiation) t_star <- t1 }else{ stop("[analyse_FadingMeasurement()] Invalid value for t_star.") } return(t_star) })) ##clean object by removing the irradiation step ... and yes, we drop! object_clean <- unlist(get_RLum(object, curveType = "measured")) ##support read_BIN2R() }else if (length(unique(unlist(lapply(object, slot, name = "originator")))) == 1 && unique(unlist(lapply(object, slot, name = "originator"))) == "read_BIN2R"){ try(stop("[analyse_FadingMeasurement()] Analysing data imported from a BIN-file is currently not supported!", call. = FALSE)) return(NULL) ##not support }else{ try(stop("[analyse_FadingMeasurement()] Unknown or unsupported originator!", call. = FALSE)) return(NULL) } # Calculation --------------------------------------------------------------------------------- ##calculate Lx/Tx or ... just Lx, it depends on the patttern ... set IRR_TIME if(length(structure) == 2){ Lx_data <- object_clean[seq(1,length(object_clean), by = 2)] Tx_data <- object_clean[seq(2,length(object_clean), by = 2)] ##we need only every 2nd irradiation time, the one from the Tx should be the same ... all the time TIMESINCEIRR <- TIMESINCEIRR[seq(1,length(TIMESINCEIRR), by =2)] }else if(length(structure) == 1){ Lx_data <- object_clean Tx_data <- NULL }else{ try(stop("[analyse_FadingMeasurement()] I have no idea what your structure means!", call. = FALSE)) return(NULL) } ##calculate Lx/Tx table LxTx_table <- merge_RLum(lapply(1:length(Lx_data), function(x) { calc_OSLLxTxRatio( Lx.data = Lx_data[[x]], Tx.data = Tx_data[[x]], signal.integral = signal.integral, background.integral = background.integral, signal.integral.Tx = list(...)$signal.integral.Tx, background.integral.Tx = list(...)$background.integral.Tx, sigmab = list(...)$sigmab, sig0 = if( is.null(list(...)$sig0)){ formals(calc_OSLLxTxRatio)$sig0 }else{ list(...)$sig0 }, background.count.distribution = if( is.null(list(...)$background.count.distribution)){ formals(calc_OSLLxTxRatio)$background.count.distribution }else{ list(...)$background.count.distribution } ) }))$LxTx.table } ##create unique identifier uid <- .create_UID() ##normalise data to prompt measurement tc <- min(TIMESINCEIRR)[1] ##normalise if(length(structure) == 2 | is.null(object)){ LxTx_NORM <- LxTx_table[["LxTx"]] / LxTx_table[["LxTx"]][which(TIMESINCEIRR== tc)[1]] LxTx_NORM.ERROR <- LxTx_table[["LxTx.Error"]] / LxTx_table[["LxTx"]][which(TIMESINCEIRR == tc)[1]] }else{ LxTx_NORM <- LxTx_table[["Net_LnLx"]] / LxTx_table[["Net_LnLx"]][which(TIMESINCEIRR== tc)[1]] LxTx_NORM.ERROR <- LxTx_table[["Net_LnLx.Error"]] / LxTx_table[["Net_LnLx"]][which(TIMESINCEIRR == tc)[1]] } ##normalise time since irradtion TIMESINCEIRR_NORM <- TIMESINCEIRR/tc ##add dose and time since irradiation LxTx_table <- cbind( LxTx_table, TIMESINCEIRR = TIMESINCEIRR, TIMESINCEIRR_NORM = TIMESINCEIRR_NORM, TIMESINCEIRR_NORM.LOG = log10(TIMESINCEIRR_NORM), LxTx_NORM = LxTx_NORM, LxTx_NORM.ERROR = LxTx_NORM.ERROR, UID = uid ) # Fitting ------------------------------------------------------------------------------------- ##we need to fit the data to get the g_value ##sample for monte carlo runs MC_matrix <- cbind(LxTx_table[["TIMESINCEIRR_NORM.LOG"]], matrix(rnorm( n = n.MC * nrow(LxTx_table), mean = LxTx_table[["LxTx_NORM"]], sd = LxTx_table[["LxTx_NORM.ERROR"]] ), ncol = n.MC)) ##apply the fit fit_matrix <- vapply(X = 2:(n.MC+1), FUN = function(x){ ##fit stats::lm(y~x, data = data.frame( x = MC_matrix[,1], y = MC_matrix[,x]))$coefficients }, FUN.VALUE = vector("numeric", length = 2)) ##calculate g-values from matrix g_value.MC <- abs(fit_matrix[2, ]) * 1 / fit_matrix[1, ] * 100 ##calculate rho prime (Kars et al. 2008; proposed by Georgina King) ##s value after Huntley (2006) J. Phys. D. Hs <- 3e15 ##sample for monte carlo runs MC_matrix_rhop <- matrix(rnorm( n = n.MC * nrow(LxTx_table), mean = LxTx_table[["LxTx_NORM"]], sd = LxTx_table[["LxTx_NORM.ERROR"]] ), ncol = n.MC) ## calculate rho prime for all MC samples fit_vector_rhop <- apply(MC_matrix_rhop, MARGIN = 2, FUN = function(x) { tryCatch({ coef(minpack.lm::nlsLM(x ~ c * exp(-rhop * (log(1.8 * Hs * LxTx_table$TIMESINCEIRR))^3), start = list(c = x[1], rhop = 10^-5.5)))[["rhop"]] }, error = function(e) { return(NA) }) }) ## discard all NA values produced in MC runs fit_vector_rhop <- fit_vector_rhop[!is.na(fit_vector_rhop)] ## calculate mean and standard deviation of rho prime (in log10 space) rhoPrime <- data.frame( MEAN = mean(fit_vector_rhop), SD = sd(fit_vector_rhop), Q_0.025 = quantile(x = fit_vector_rhop, probs = 0.025), Q_0.16 = quantile(x = fit_vector_rhop, probs = 0.16), Q_0.84 = quantile(x = fit_vector_rhop, probs = 0.84), Q_0.975 = quantile(x = fit_vector_rhop, probs = 0.975), row.names = NULL ) ##for plotting fit <- stats::lm(y ~ x, data = data.frame(x = LxTx_table[["TIMESINCEIRR_NORM.LOG"]], y = LxTx_table[["LxTx_NORM"]])) fit_power <- stats::lm(y ~ I(x^3) + I(x^2) + I(x) , data = data.frame(x = LxTx_table[["TIMESINCEIRR_NORM.LOG"]], y = LxTx_table[["LxTx_NORM"]])) ##for predicting fit_predict <- stats::lm(y ~ x, data = data.frame(y = LxTx_table[["TIMESINCEIRR_NORM.LOG"]], x = LxTx_table[["LxTx_NORM"]])) ##calculate final g_value ##the 2nd term corrects for the (potential) offset from one g_value_fit <- abs(fit$coefficient[2]) * 1 / fit$coefficient[1] * 100 ##construct output data.frame g_value <- data.frame( FIT = g_value_fit, MEAN = mean(g_value.MC), SD = sd(g_value.MC), Q_0.025 = quantile(x = g_value.MC, probs = 0.025), Q_0.16 = quantile(x = g_value.MC, probs = 0.16), Q_0.84 = quantile(x = g_value.MC, probs = 0.84), Q_0.975 = quantile(x = g_value.MC, probs = 0.975) ) ##normalise the g-value to 2-days using the equation provided by Sebastien Huot via e-mail ##this means the data is extended k0 <- g_value[,c("FIT", "SD")] / 100 / log(10) k1 <- k0 / (1 - k0 * log(172800/tc)) g_value_2days <- 100 * k1 * log(10) names(g_value_2days) <- c("G_VALUE_2DAYS", "G_VALUE_2DAYS.ERROR") # Approximation ------------------------------------------------------------------------------- T_0.5.interpolated <- approx(x = LxTx_table[["LxTx_NORM"]], y = LxTx_table[["TIMESINCEIRR_NORM"]], xout = 0.5) T_0.5.predict <- stats::predict.lm(fit_predict,newdata = data.frame(x = 0.5), interval = "predict") T_0.5 <- data.frame( T_0.5_INTERPOLATED = T_0.5.interpolated$y, T_0.5_PREDICTED = (10^T_0.5.predict[,1])*tc, T_0.5_PREDICTED.LOWER = (10^T_0.5.predict[,2])*tc, T_0.5_PREDICTED.UPPER = (10^T_0.5.predict[,2])*tc ) # Plotting ------------------------------------------------------------------------------------ if(plot) { if (!plot.single[1]) { par.default <- par()$mfrow on.exit(par(mfrow = par.default)) par(mfrow = c(2, 2)) } ##get package col <- get("col", pos = .LuminescenceEnv) ##set some plot settings plot_settings <- list( xlab = "Stimulation time [s]", log = "", mtext = "" ) ##modify on request plot_settings <- modifyList(x = plot_settings, val = list(...)) ##get unique irradiation times ... for plotting irradiation_times.unique <- unique(TIMESINCEIRR) ##limit to max 5 if(length(irradiation_times.unique) >= 5){ irradiation_times.unique <- irradiation_times.unique[seq(1, length(irradiation_times.unique), length.out = 5)] } if (!is.null(object)) { if (length(structure) == 2) { if (is(plot.single, "logical") || (is(plot.single, "numeric") & 1 %in% plot.single)) { plot_RLum( set_RLum(class = "RLum.Analysis", records = object_clean[seq(1, length(object_clean), by = 2)]), combine = TRUE, col = c(col[1:5], rep( rgb(0, 0, 0, 0.3), length(TIMESINCEIRR) - 5 )), plot.single = TRUE, legend.text = c(paste(irradiation_times.unique, "s"), "others"), legend.col = c(col[1:length(irradiation_times.unique)], rgb(0, 0, 0, 0.3)), xlab = plot_settings$xlab, log = plot_settings$log, legend.pos = "outside", main = expression(paste(L[x], " - curves")), mtext = plot_settings$mtext ) ##add integration limits abline( v = range(signal.integral) * max(as.matrix(object_clean[[1]][, 1])) / nrow(as.matrix(object_clean[[1]])), lty = 2, col = "green" ) abline( v = range(background.integral) * max(as.matrix(object_clean[[1]][, 1])) / nrow(as.matrix(object_clean[[1]])), lty = 2, col = "red" ) } if (is(plot.single, "logical") || (is(plot.single, "numeric") & 2 %in% plot.single)) { plot_RLum( set_RLum(class = "RLum.Analysis", records = object_clean[seq(2, length(object_clean), by = 2)]), combine = TRUE, col = c(col[1:5], rep( rgb(0, 0, 0, 0.3), length(TIMESINCEIRR) - 5 )), plot.single = TRUE, legend.text = c(paste(irradiation_times.unique, "s"), "others"), legend.col = c(col[1:length(irradiation_times.unique)], rgb(0, 0, 0, 0.3)), xlab = plot_settings$xlab, log = plot_settings$log, legend.pos = "outside", main = expression(paste(T[x], " - curves")), mtext = plot_settings$mtext ) if (is.null(list(...)$signal.integral.Tx)) { ##add integration limits abline( v = range(signal.integral) * max(as.matrix(object_clean[[1]][, 1])) / nrow(as.matrix(object_clean[[1]])), lty = 2, col = "green" ) abline( v = range(background.integral) * max(as.matrix(object_clean[[1]][, 1])) / nrow(as.matrix(object_clean[[1]])), lty = 2, col = "red" ) } else{ ##add integration limits abline( v = range(list(...)$signal.integral.Tx) * max(as.matrix(object_clean[[1]][, 1])) / nrow(as.matrix(object_clean[[1]])), lty = 2, col = "green" ) abline( v = range(list(...)$background.integral.Tx) * max(as.matrix(object_clean[[1]][, 1])) / nrow(as.matrix(object_clean[[1]])), lty = 2, col = "red" ) } } } else{ if (is(plot.single, "logical") || (is(plot.single, "numeric") & 1 %in% plot.single)) { plot_RLum( set_RLum(class = "RLum.Analysis", records = object_clean), combine = TRUE, col = c(col[1:5], rep( rgb(0, 0, 0, 0.3), length(TIMESINCEIRR) - 5 )), plot.single = TRUE, legend.text = c(paste(irradiation_times.unique, "s"), "others"), legend.col = c(col[1:length(irradiation_times.unique)], rgb(0, 0, 0, 0.3)), legend.pos = "outside", xlab = plot_settings$xlab, log = plot_settings$log, main = expression(paste(L[x], " - curves")), mtext = plot_settings$mtext ) ##add integration limits abline( v = range(signal.integral) * max(as.matrix(object_clean[[1]][, 1])) / nrow(as.matrix(object_clean[[1]])), lty = 2, col = "green" ) abline( v = range(background.integral) * max(as.matrix(object_clean[[1]][, 1])) / nrow(as.matrix(object_clean[[1]])), lty = 2, col = "red" ) } ##empty Tx plot if (is(plot.single, "logical") || (is(plot.single, "numeric") & 2 %in% plot.single)) { plot( NA, NA, xlim = c(0, 1), ylim = c(0, 1), xlab = "", ylab = "", axes = FALSE ) text(x = 0.5, y = 0.5, labels = expression(paste("No ", T[x], " curves detected"))) } } }else{ if (is(plot.single, "logical") || (is(plot.single, "numeric") & 1 %in% plot.single)) { ##empty Lx plot plot( NA, NA, xlim = c(0, 1), ylim = c(0, 1), xlab = "", ylab = "", axes = FALSE ) text(x = 0.5, y = 0.5, labels = expression(paste("No ", L[x], " curves detected"))) } if (is(plot.single, "logical") || (is(plot.single, "numeric") & 2 %in% plot.single)) { ##empty Tx plot plot( NA, NA, xlim = c(0, 1), ylim = c(0, 1), xlab = "", ylab = "", axes = FALSE ) text(x = 0.5, y = 0.5, labels = expression(paste("No ", T[x], " curves detected"))) } } ##(2) Fading plot if (is(plot.single, "logical") || (is(plot.single, "numeric") & 3 %in% plot.single)) { plot( NA, NA, ylab = "Normalised intensity [a.u.]", xaxt = "n", xlab = "Time since irradition [s]", sub = expression(paste("[", log[10](t / t[c]), "]")), ylim = if (max(LxTx_table[["LxTx_NORM"]]) > 1.1) { c(0.1, max(LxTx_table[["LxTx_NORM"]]) + max(LxTx_table[["LxTx_NORM.ERROR"]])) } else{ c(0.1, 1.1) }, xlim = range(LxTx_table[["TIMESINCEIRR_NORM.LOG"]]), main = "Signal Fading" ) ##add axis axis(side = 1, at = axTicks(side = 1), labels = suppressWarnings(format((10 ^ (axTicks(side = 1)) * tc), digits = 0, decimal.mark = "", scientific = TRUE ))) mtext( side = 3, paste0( "g-value: ", round(g_value$FIT, digits = 2), " \u00b1 ", round(g_value$SD, digits = 2), " (%/decade) | tc = ", format(tc, digits = 4, scientific = TRUE) ), cex = par()$cex * 0.9 ) ##add curves x <- NA for (i in 1:n.MC) { curve(fit_matrix[2, i] * x + fit_matrix[1, i], col = rgb(0, 0.2, 0.4, 0.2), add = TRUE) } ##add master curve in red curve( fit$coefficient[2] * x + fit$coefficient[1], col = "red", add = TRUE, lwd = 1.5 ) ##add power law curve curve( x ^ 3 * fit_power$coefficient[2] + x ^ 2 * fit_power$coefficient[3] + x * fit_power$coefficient[4] + fit_power$coefficient[1], add = TRUE, col = "blue", lty = 2 ) ##addpoints points(x = LxTx_table[["TIMESINCEIRR_NORM.LOG"]], y = LxTx_table[["LxTx_NORM"]], pch = 21, bg = "grey") ##error bars segments( x0 = LxTx_table[["TIMESINCEIRR_NORM.LOG"]], x1 = LxTx_table[["TIMESINCEIRR_NORM.LOG"]], y0 = LxTx_table[["LxTx_NORM"]] + LxTx_table[["LxTx_NORM.ERROR"]], y1 = LxTx_table[["LxTx_NORM"]] - LxTx_table[["LxTx_NORM.ERROR"]], col = "grey" ) ##add legend legend( "bottom", legend = c("fit", "fit MC", "trend"), col = c("red", "grey", "blue"), lty = c(1, 1, 2), bty = "n", horiz = TRUE ) } if (is(plot.single, "logical") || (is(plot.single, "numeric") & 4 %in% plot.single)) { plot(density(g_value.MC), main = "Density: g-values (%/decade)") rug(x = g_value.MC) abline(v = c(g_value[["Q_0.16"]], g_value[["Q_0.84"]]), lty = 2, col = "darkgreen") abline(v = c(g_value[["Q_0.025"]], g_value[["Q_0.975"]]), lty = 2, col = "red") legend( "topleft", legend = c("HPD - 68 %", "HPD - 95 %"), lty = 2, col = c("darkgreen", "red"), bty = "n" ) } } # Terminal ------------------------------------------------------------------------------------ if (verbose){ cat("\n[analyse_FadingMeasurement()]\n") cat(paste0("\n n.MC:\t",n.MC)) cat(paste0("\n tc:\t",format(tc, digits = 4, scientific = TRUE), " s")) cat("\n---------------------------------------------------") cat(paste0("\nT_0.5 interpolated:\t",T_0.5$T_0.5_INTERPOLATED)) cat(paste0("\nT_0.5 predicted:\t",format(T_0.5$T_0.5_PREDICTED, digits = 2, scientific = TRUE))) cat(paste0("\ng-value:\t\t", round(g_value$FIT, digits = 2), " \u00b1 ", round(g_value$SD, digits = 2), " (%/decade)")) cat(paste0("\ng-value (norm. 2 days):\t", round(g_value_2days[1], digits = 2), " \u00b1 ", round(g_value_2days[2], digits = 2), " (%/decade)")) cat("\n---------------------------------------------------") cat(paste0("\nrho':\t\t\t", format(rhoPrime$MEAN, digits = 3), " \u00b1 ", format(rhoPrime$SD, digits = 3))) cat(paste0("\nlog10(rho'):\t\t", round(log10(rhoPrime$MEAN), 2), " \u00b1 ", round(rhoPrime$SD / (rhoPrime$MEAN * log(10, base = exp(1))), 2))) cat("\n---------------------------------------------------") } # Return -------------------------------------------------------------------------------------- return(set_RLum( class = "RLum.Results", data = list( fading_results = cbind( g_value, TC = tc, G_VALUE_2DAYS = g_value_2days[1], G_VALUE_2DAYS.ERROR = g_value_2days[2], T_0.5, UID = uid ), fit = fit, rho_prime = rhoPrime, LxTx_table = LxTx_table, irr.times = irradiation_times ), info = list(call = sys.call()) )) } Luminescence/R/write_R2BIN.R0000644000176200001440000011133513125226556015251 0ustar liggesusers#' Export Risoe.BINfileData into Risoe BIN-file #' #' Exports a Risoe.BINfileData object in a *.bin or *.binx file that can be #' opened by the Analyst software or other Risoe software. #' #' The structure of the exported binary data follows the data structure #' published in the Appendices of the Analyst manual p. 42.\cr\cr If #' \code{LTYPE}, \code{DTYPE} and \code{LIGHTSOURCE} are not of type #' \code{\link{character}}, no transformation into numeric values is done. #' #' @param object \code{\linkS4class{Risoe.BINfileData}} (\bold{required}): #' input object to be stored in a bin file. #' #' @param file \code{\link{character}} (\bold{required}): file name and path of #' the output file\cr [WIN]: \code{write_R2BIN(object, "C:/Desktop/test.bin")}, #' \cr [MAC/LINUX]: \code{write_R2BIN("/User/test/Desktop/test.bin")} #' #' @param version \code{\link{character}} (optional): version number for the #' output file. If no value is provided the highest version number from the #' \code{\linkS4class{Risoe.BINfileData}} is taken automatically.\cr\cr Note: #' This argument can be used to convert BIN-file versions. #' #' @param compatibility.mode \code{\link{logical}} (with default): this option #' recalculates the position values if necessary and set the max. value to 48. #' The old position number is appended as comment (e.g., 'OP: 70). This option #' accounts for potential compatibility problems with the Analyst software. #' #' @param txtProgressBar \link{logical} (with default): enables or disables #' \code{\link{txtProgressBar}}. #' @return Write a binary file. #' @note The function just roughly checks the data structures. The validity of #' the output data depends on the user.\cr\cr The validity of the file path is #' not further checked. \cr BIN-file conversions using the argument #' \code{version} may be a lossy conversion, depending on the chosen input and #' output data (e.g., conversion from version 08 to 07 to 06 to 04 or 03).\cr #' #' \bold{Warning}\cr #' #' Although the coding was done carefully it seems that the BIN/BINX-files #' produced by Risoe DA 15/20 TL/OSL readers slightly differ on the byte level. #' No obvious differences are observed in the METADATA, however, the #' BIN/BINX-file may not fully compatible, at least not similar to the once #' directly produced by the Risoe readers!\cr #' #' @section Function version: 0.4.2 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @note ROI definitions (introduced in BIN-file version 8) are not supported! There are furthermore #' ignored by the function \code{\link{read_BIN2R}}. #' #' @seealso \code{\link{read_BIN2R}}, \code{\linkS4class{Risoe.BINfileData}}, #' \code{\link{writeBin}} #' #' @references #' #' DTU Nutech, 2016. The Squence Editor, Users Manual, February, 2016. #' \url{http://www.nutech.dtu.dk/english/products-and-services/radiation-instruments/tl_osl_reader/manuals} #' #' @keywords IO #' #' @examples #' #' ##uncomment for usage #' #' ##data(ExampleData.BINfileData, envir = environment()) #' ##write_R2BIN(CWOSL.SAR.Data, file="[your path]/output.bin") #' #' @export write_R2BIN <- function( object, file, version, compatibility.mode = FALSE, txtProgressBar = TRUE ){ # Config ------------------------------------------------------------------ ##set supported BIN format version VERSION.supported <- as.raw(c(3, 4, 6, 7, 8)) # Check integrity --------------------------------------------------------- ##check if input object is of type 'Risoe.BINfileData' if(is(object, "Risoe.BINfileData") == FALSE){ stop("[write_R2BIN()] Input object is not of type Risoe.BINfileData!") } ##check if it fullfills the latest definition if(ncol(object@METADATA) != 80){ stop("[write_R2BIN()] The number of columns in your slot 'METADATA' does not fit to the latest definition. What you are probably trying to do is to export a Risoe.BINfileData object you generated by your own or you imported with an old package version some time ago. Please re-import the BIN-file using the function read_BIN2R().") } ##check if input file is of type 'character' if(is(file, "character") == FALSE){ stop("[write_R2BIN()] argument 'file' has to be of type character!") } # Check Risoe.BINfileData Struture ---------------------------------------- ##VERSION ##If missing version argument set to the highest value if(missing(version)){ version <- as.raw(max(as.numeric(object@METADATA[,"VERSION"]))) version.original <- version }else{ version.original <- as.raw(max(as.numeric(object@METADATA[,"VERSION"]))) version <- as.raw(version) object@METADATA[["VERSION"]] <- version ##Furthermore, entries length needed to be recalculated if(version.original != version){ ##stepping decision header.stepping <- switch(as.character(version), "08" = 507, "07" = 447, "06" = 447, "04" = 272, "03" = 272) object@METADATA[,"LENGTH"] <- sapply(1:nrow(object@METADATA), function(x){ header.stepping + 4 * object@METADATA[x,"NPOINTS"] }) object@METADATA[,"PREVIOUS"] <- sapply(1:nrow(object@METADATA), function(x){ if(x == 1){ 0 }else{ header.stepping + 4 * object@METADATA[x-1,"NPOINTS"] } }) } } ##check whether this file can be exported without problems due to the latest specifications if(ncol(object@METADATA) != 80){ stop("[write_R2BIN()] Your Risoe.BINfileData object seems not to be compatible with the latest specification of this S4-class object. You are probably trying to export a Risoe.BINfileData from your workspace you produced manually or with an old version.") } ##Check if the BINfile object contains of unsupported versions if((as.raw(object@METADATA[1,"VERSION"]) %in% VERSION.supported) == FALSE || version %in% VERSION.supported == FALSE){ ##show error message error.text <- paste("[write_R2BIN()] Writing BIN-files in format version (", object@METADATA[1,"VERSION"],") is currently not supported! Supported version numbers are: ", paste(VERSION.supported,collapse=", "),".",sep="") stop(error.text) } ##CHECK file name for version == 06 it has to be *.binx and correct for it if(version == 06 | version == 07 | version == 08){ ##grep file ending temp.file.name <- unlist(strsplit(file, "[:.:]")) ##*.bin? >> correct to binx if(temp.file.name[length(temp.file.name)]=="bin"){ temp.file.name[length(temp.file.name)] <- "binx" file <- paste(temp.file.name, collapse=".") } } ##SEQUENCE if (suppressWarnings(max(nchar(as.character(object@METADATA[,"SEQUENCE"]), type = "bytes"), na.rm = TRUE)) > 8) { stop("[write_R2BIN()] Value in 'SEQUENCE' exceed storage limit!") } ##USER if (suppressWarnings(max(nchar(as.character(object@METADATA[,"USER"]), type = "bytes"), na.rm = TRUE)) > 8) { stop("[write_R2BIN()] 'USER' exceed storage limit!") } ##SAMPLE if (suppressWarnings(max(nchar(as.character(object@METADATA[,"SAMPLE"]), type = "bytes"), na.rm = TRUE)) > 20) { stop("[write_R2BIN()] 'SAMPLE' exceed storage limit!") } ##enables compatibility to the Analyst as the the max value for POSITION becomes 48 if(compatibility.mode){ ##just do if position values > 48 if(max(object@METADATA[,"POSITION"])>48){ ##grep relevant IDs temp.POSITION48.id <- which(object@METADATA[,"POSITION"]>48) ##find unique values temp.POSITION48.unique <- unique(object@METADATA[temp.POSITION48.id,"POSITION"]) ##set translation vector starting from 1 and ending at 48 temp.POSITION48.new <- rep_len(1:48, length.out = length(temp.POSITION48.unique)) ##recaluate POSITION and update comment for(i in 1:length(temp.POSITION48.unique)){ object@METADATA[object@METADATA[,"POSITION"] == temp.POSITION48.unique[i],"COMMENT"] <- paste0(object@METADATA[object@METADATA[,"POSITION"] == temp.POSITION48.unique[i],"COMMENT"], "OP:",object@METADATA[object@METADATA[,"POSITION"] == temp.POSITION48.unique[i],"POSITION"]) object@METADATA[object@METADATA[,"POSITION"] == temp.POSITION48.unique[i],"POSITION"] <- temp.POSITION48.new[i] } } } ##COMMENT if(max(nchar(as.character(object@METADATA[,"COMMENT"]), type="bytes"))>80){ stop("[write_R2BIN()] 'COMMENT' exceed storage limit!") } # Tranlation Matrices ----------------------------------------------------- ##LTYPE LTYPE.TranslationMatrix <- matrix(NA, nrow=14, ncol=2) LTYPE.TranslationMatrix[,1] <- 0:13 LTYPE.TranslationMatrix[,2] <- c("TL", "OSL", "IRSL", "M-IR", "M-VIS", "TOL", "TRPOSL", "RIR", "RBR", "USER", "POSL", "SGOSL", "RL", "XRF") ##DTYPE DTYPE.TranslationMatrix <- matrix(NA, nrow=8, ncol=2) DTYPE.TranslationMatrix[,1] <- 0:7 DTYPE.TranslationMatrix[,2] <- c("Natural","N+dose","Bleach", "Bleach+dose","Natural (Bleach)", "N+dose (Bleach)","Dose","Background") ##LIGHTSOURCE LIGHTSOURCE.TranslationMatrix <- matrix(NA, nrow=8, ncol=2) LIGHTSOURCE.TranslationMatrix[,1] <- 0:7 LIGHTSOURCE.TranslationMatrix[,2] <- c("None", "Lamp", "IR diodes/IR Laser", "Calibration LED", "Blue Diodes", "White light", "Green laser (single grain)", "IR laser (single grain)" ) ##TRANSLATE VALUES IN METADATA ##LTYPE if(is(object@METADATA[1,"LTYPE"], "character") == TRUE | is(object@METADATA[1,"LTYPE"], "factor") == TRUE){ object@METADATA[,"LTYPE"]<- sapply(1:length(object@METADATA[,"LTYPE"]),function(x){ as.integer(LTYPE.TranslationMatrix[object@METADATA[x,"LTYPE"]==LTYPE.TranslationMatrix[,2],1]) }) } ##DTYPE if(is(object@METADATA[1,"DTYPE"], "character") == TRUE | is(object@METADATA[1,"DTYPE"], "factor") == TRUE){ object@METADATA[,"DTYPE"]<- sapply(1:length(object@METADATA[,"DTYPE"]),function(x){ as.integer(DTYPE.TranslationMatrix[object@METADATA[x,"DTYPE"]==DTYPE.TranslationMatrix[,2],1]) }) } ##LIGHTSOURCE if(is(object@METADATA[1,"LIGHTSOURCE"], "character") == TRUE | is(object@METADATA[1,"LIGHTSOURCE"], "factor") == TRUE){ object@METADATA[,"LIGHTSOURCE"]<- sapply(1:length(object@METADATA[,"LIGHTSOURCE"]),function(x){ as.integer(LIGHTSOURCE.TranslationMatrix[ object@METADATA[x,"LIGHTSOURCE"]==LIGHTSOURCE.TranslationMatrix[,2],1]) })} ##TIME object@METADATA[,"TIME"] <- sapply(1:length(object@METADATA[,"TIME"]),function(x){ as.character(gsub(":","",object@METADATA[x,"TIME"])) }) ##TAG and SEL ##in TAG information on the SEL are storred, here the values are copied to TAG ##before export object@METADATA[,"TAG"] <- ifelse(object@METADATA[,"SEL"] == TRUE, 1, 0) # SET FILE AND VALUES ----------------------------------------------------- con<-file(file, "wb") ##get records n.records <- length(object@METADATA[,"ID"]) ##output cat(paste("\n[write_R2BIN()]\n\t >> ",file,sep=""), fill=TRUE) ##set progressbar if(txtProgressBar==TRUE){ pb<-txtProgressBar(min=0,max=n.records, char="=", style=3) } # LOOP ------------------------------------------------------------------- ID <- 1 if(version == 03 || version == 04){ ## version 03 and 04 ##start loop for export BIN data while(ID<=n.records) { ##VERSION writeBin(as.raw(object@METADATA[ID,"VERSION"]), con, size = 1, endian="little") ##stepping writeBin(raw(length=1), con, size = 1, endian="little") ##LENGTH, PREVIOUS, NPOINTS writeBin(c(as.integer(object@METADATA[ID,"LENGTH"]), as.integer(object@METADATA[ID,"PREVIOUS"]), as.integer(object@METADATA[ID,"NPOINTS"])), con, size = 2, endian="little") ##LTYPE writeBin(object@METADATA[ID,"LTYPE"], con, size = 1, endian="little") ##LOW, HIGH, RATE writeBin(c(as.double(object@METADATA[ID,"LOW"]), as.double(object@METADATA[ID,"HIGH"]), as.double(object@METADATA[ID,"RATE"])), con, size = 4, endian="little") ##TEMPERATURE, XCOORD, YCOORD, TOLDELAY; TOLON, TOLOFF writeBin(c(as.integer(object@METADATA[ID,"TEMPERATURE"]), as.integer(object@METADATA[ID,"XCOORD"]), as.integer(object@METADATA[ID,"YCOORD"]), as.integer(object@METADATA[ID,"TOLDELAY"]), as.integer(object@METADATA[ID,"TOLON"]), as.integer(object@METADATA[ID,"TOLOFF"])), con, size = 2, endian="little") ##POSITION, RUN writeBin(c(as.integer(object@METADATA[ID,"POSITION"]), as.integer(object@METADATA[ID,"RUN"])), con, size = 1, endian="little") ##TIME TIME_SIZE <- nchar(object@METADATA[ID,"TIME"]) writeBin(as.integer(TIME_SIZE), con, size = 1, endian="little") writeChar(object@METADATA[ID,"TIME"], con, nchars =TIME_SIZE, useBytes=TRUE, eos = NULL) if(6-TIME_SIZE>0){ writeBin(raw(length = c(6-TIME_SIZE)), con, size = 1, endian="little") } ##DATE writeBin(as.integer(6), con, size = 1 , endian="little") suppressWarnings(writeChar(as.character(object@METADATA[ID,"DATE"]), con, nchars = 6, useBytes=TRUE, eos = NULL)) ##SEQUENCE ##count number of characters SEQUENCE_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"SEQUENCE"]), type = "bytes")) writeBin(SEQUENCE_SIZE, con, size = 1, endian="little") writeChar(as.character(object@METADATA[ID,"SEQUENCE"]), con, nchars = SEQUENCE_SIZE, useBytes=TRUE, eos = NULL) ##stepping if(8-SEQUENCE_SIZE>0){ writeBin(raw(length = (8-SEQUENCE_SIZE)), con, size = 1, endian="little") } ##USER USER_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"USER"]), type="bytes")) writeBin(USER_SIZE, con, size = 1, endian="little") writeChar(as.character(object@METADATA[ID,"USER"]), con, nchars = USER_SIZE, useBytes=TRUE, eos = NULL) ##stepping if(8-USER_SIZE>0){ writeBin(raw(length = (8-USER_SIZE)), con, size = 1, endian="little") } ##DTYPE writeBin(object@METADATA[ID,"DTYPE"], con, size = 1, endian="little") ##IRR_TIME writeBin(as.double(object@METADATA[ID,"IRR_TIME"]), con, size = 4, endian="little") ##IRR_TYPE, IRR_UNIT writeBin(c(object@METADATA[ID,"IRR_TYPE"], object@METADATA[ID,"IRR_UNIT"]), con, size = 1, endian="little") ##BL_TIME writeBin(as.double(object@METADATA[ID,"BL_TIME"]), con, size = 4, endian="little") ##BL_UNIT writeBin(as.integer(object@METADATA[ID,"BL_UNIT"]), con, size = 1, endian="little") ##AN_TEMP, AN_TIME, NORM1, NORM2, NORM2, BG writeBin(c(as.double(object@METADATA[ID,"AN_TEMP"]), as.double(object@METADATA[ID,"AN_TIME"]), as.double(object@METADATA[ID,"NORM1"]), as.double(object@METADATA[ID,"NORM2"]), as.double(object@METADATA[ID,"NORM3"]), as.double(object@METADATA[ID,"BG"])), con, size = 4, endian="little") ##SHIFT writeBin(as.integer(object@METADATA[ID,"SHIFT"]), con, size = 2, endian="little") ##SAMPLE SAMPLE_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"SAMPLE"]), type="bytes")) ##avoid problems with empty sample names if(SAMPLE_SIZE == 0){ SAMPLE_SIZE <- as.integer(2) object@METADATA[ID,"SAMPLE"] <- " " } writeBin(SAMPLE_SIZE, con, size = 1, endian="little") writeChar(as.character(object@METADATA[ID,"SAMPLE"]), con, nchars = SAMPLE_SIZE, useBytes=TRUE, eos = NULL) if((20-SAMPLE_SIZE)>0){ writeBin(raw(length = (20-SAMPLE_SIZE)), con, size = 1, endian="little") } ##COMMENT COMMENT_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"COMMENT"]), type="bytes")) ##avoid problems with empty comments if(COMMENT_SIZE == 0){ COMMENT_SIZE <- as.integer(2) object@METADATA[ID,"COMMENT"] <- " " } writeBin(COMMENT_SIZE, con, size = 1, endian="little") suppressWarnings(writeChar(as.character(object@METADATA[ID,"COMMENT"]), con, nchars = COMMENT_SIZE, useBytes=TRUE, eos = NULL)) if((80-COMMENT_SIZE)>0){ writeBin(raw(length = c(80-COMMENT_SIZE)), con, size = 1, endian="little") } ##LIGHTSOURCE, SET, TAG writeBin(c(as.integer(object@METADATA[ID,"LIGHTSOURCE"]), as.integer(object@METADATA[ID,"SET"]), as.integer(object@METADATA[ID,"TAG"])), con, size = 1, endian="little") ##GRAIN writeBin(as.integer(object@METADATA[ID,"GRAIN"]), con, size = 2, endian="little") ##LPOWER writeBin(as.double(object@METADATA[ID,"LPOWER"]), con, size = 4, endian="little") ##SYSTEMID writeBin(as.integer(object@METADATA[ID,"SYSTEMID"]), con, size = 2, endian="little") ##Further distinction needed to fully support format version 03 and 04 separately if(version == 03){ ##RESERVED 1 if(length(object@.RESERVED) == 0 || version.original != version){ writeBin(raw(length=36), con, size = 1, endian="little") }else{ writeBin(object@.RESERVED[[ID]][[1]], con, size = 1, endian="little") } ##ONTIME, OFFTIME writeBin(c(as.integer(object@METADATA[ID,"ONTIME"]), as.integer(object@METADATA[ID,"OFFTIME"])), con, size = 4, endian="little") ##GATE_ENABLED writeBin(as.integer(object@METADATA[ID,"GATE_ENABLED"]), con, size = 1, endian="little") ##GATE_START, GATE_STOP writeBin(c(as.integer(object@METADATA[ID,"GATE_START"]), as.integer(object@METADATA[ID,"GATE_STOP"])), con, size = 4, endian="little") ##RESERVED 2 if(length(object@.RESERVED) == 0 || version.original != version){ writeBin(raw(length=1), con, size = 1, endian="little") }else{ writeBin(object@.RESERVED[[ID]][[2]], con, size = 1, endian="little") } } else { ##version 04 ##RESERVED 1 if(length(object@.RESERVED) == 0 || version.original != version){ writeBin(raw(length=20), con, size = 1, endian="little") }else{ writeBin(object@.RESERVED[[ID]][[1]], con, size = 1, endian="little") } ##CURVENO writeBin(as.integer(object@METADATA[ID,"CURVENO"]), con, size = 2, endian="little") ##TIMETICK writeBin(c(as.double(object@METADATA[ID,"TIMETICK"])), con, size = 4, endian="little") ##ONTIME, STIMPERIOD writeBin(c(as.integer(object@METADATA[ID,"ONTIME"]), as.integer(object@METADATA[ID,"STIMPERIOD"])), con, size = 4, endian="little") ##GATE_ENABLED writeBin(as.integer(object@METADATA[ID,"GATE_ENABLED"]), con, size = 1, endian="little") ##GATE_START, GATE_STOP writeBin(c(as.integer(object@METADATA[ID,"GATE_START"]), as.integer(object@METADATA[ID,"GATE_STOP"])), con, size = 4, endian="little") ##PTENABLED writeBin(as.integer(object@METADATA[ID,"PTENABLED"]), con, size = 1, endian="little") ##RESERVED 2 if(length(object@.RESERVED) == 0 || version.original != version){ writeBin(raw(length=10), con, size = 1, endian="little") }else{ writeBin(object@.RESERVED[[ID]][[2]], con, size = 1, endian="little") } } ##DPOINTS writeBin(as.integer(unlist(object@DATA[ID])), con, size = 4, endian="little") #SET UNIQUE ID ID<-ID+1 ##update progress bar if(txtProgressBar==TRUE){ setTxtProgressBar(pb, ID) } } } ## ==================================================== ## version 06 if(version == 06 | version == 07 | version == 08){ ##start loop for export BIN data while(ID<=n.records) { ##VERSION writeBin(as.raw(object@METADATA[ID,"VERSION"]), con, size = 1, endian="little") ##stepping writeBin(raw(length=1), con, size = 1, endian="little") ##LENGTH, PREVIOUS, NPOINTS writeBin(c(as.integer(object@METADATA[ID,"LENGTH"]), as.integer(object@METADATA[ID,"PREVIOUS"]), as.integer(object@METADATA[ID,"NPOINTS"])), con, size = 4, endian="little") if(version == 08){ writeBin(as.integer(object@METADATA[ID,"RECTYPE"]), con, size = 1, endian="little") } ##RUN, SET, POSITION, GRAINNUMBER, CURVENO, XCOORD, YCOORD writeBin(c(as.integer(object@METADATA[ID,"RUN"]), as.integer(object@METADATA[ID,"SET"]), as.integer(object@METADATA[ID,"POSITION"]), as.integer(object@METADATA[ID,"GRAINNUMBER"]), as.integer(object@METADATA[ID,"CURVENO"]), as.integer(object@METADATA[ID,"XCOORD"]), as.integer(object@METADATA[ID,"YCOORD"])), con, size = 2, endian="little") ##SAMPLE SAMPLE_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"SAMPLE"]), type="bytes")) ##avoid problems with empty sample names if(SAMPLE_SIZE == 0){ SAMPLE_SIZE <- as.integer(2) object@METADATA[ID,"SAMPLE"] <- " " } writeBin(SAMPLE_SIZE, con, size = 1, endian="little") writeChar(as.character(object@METADATA[ID,"SAMPLE"]), con, nchars = SAMPLE_SIZE, useBytes=TRUE, eos = NULL) if((20-SAMPLE_SIZE)>0){ writeBin(raw(length = (20-SAMPLE_SIZE)), con, size = 1, endian="little") } ##COMMENT COMMENT_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"COMMENT"]), type="bytes")) ##avoid problems with empty comments if(COMMENT_SIZE == 0){ COMMENT_SIZE <- as.integer(2) object@METADATA[ID,"COMMENT"] <- " " } writeBin(COMMENT_SIZE, con, size = 1, endian="little") writeChar(as.character(object@METADATA[ID,"COMMENT"]), con, nchars = COMMENT_SIZE, useBytes=TRUE, eos = NULL) if((80-COMMENT_SIZE)>0){ writeBin(raw(length = c(80-COMMENT_SIZE)), con, size = 1, endian="little") } ##Instrument and sequence characteristics ##SYSTEMID writeBin(as.integer(object@METADATA[ID,"SYSTEMID"]), con, size = 2, endian="little") ##FNAME FNAME_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"FNAME"]), type="bytes")) ##correct for case that this is of 0 length if(length(FNAME_SIZE) == 0){FNAME_SIZE <- as.integer(0)} writeBin(FNAME_SIZE, con, size = 1, endian="little") if(FNAME_SIZE>0) { writeChar( as.character(object@METADATA[ID,"FNAME"]), con, nchars = FNAME_SIZE, useBytes = TRUE, eos = NULL ) } if((100-FNAME_SIZE)>0){ writeBin(raw(length = c(100-FNAME_SIZE)), con, size = 1, endian="little") } ##USER USER_SIZE <- as.integer(nchar(as.character(object@METADATA[ID,"USER"]), type="bytes")) writeBin(USER_SIZE, con, size = 1, endian="little") writeChar(as.character(object@METADATA[ID,"USER"]), con, nchars = USER_SIZE, useBytes=TRUE, eos = NULL) if((30-USER_SIZE)>0){ writeBin(raw(length = c(30-USER_SIZE)), con, size = 1, endian="little") } ##TIME TIME_SIZE <- nchar(object@METADATA[ID,"TIME"]) writeBin(as.integer(TIME_SIZE), con, size = 1, endian="little") writeChar(object@METADATA[ID,"TIME"], con, nchars =TIME_SIZE, useBytes=TRUE, eos = NULL) if(6-TIME_SIZE>0){ writeBin(raw(length = c(6-TIME_SIZE)), con, size = 1, endian="little") } ##DATE writeBin(as.integer(6), con, size = 1 , endian="little") suppressWarnings(writeChar(as.character(object@METADATA[ID,"DATE"]), con, nchars = 6, useBytes=TRUE, eos = NULL)) ##Analysis ##DTYPE writeBin(object@METADATA[ID,"DTYPE"], con, size = 1, endian="little") ##BL_TIME writeBin(as.double(object@METADATA[ID,"BL_TIME"]), con, size = 4, endian="little") ##BL_UNIT writeBin(as.integer(object@METADATA[ID,"BL_UNIT"]), con, size = 1, endian="little") ##NORM1, NORM2, NORM3, BG writeBin(c(as.double(object@METADATA[ID,"NORM1"]), as.double(object@METADATA[ID,"NORM2"]), as.double(object@METADATA[ID,"NORM3"]), as.double(object@METADATA[ID,"BG"])), con, size = 4, endian="little") ##SHIFT writeBin(as.integer(object@METADATA[ID,"SHIFT"]), con, size = 2, endian="little") ##TAG writeBin(c(as.integer(object@METADATA[ID,"TAG"])), con, size = 1, endian="little") ##RESERVED 1 if(length(object@.RESERVED) == 0 || version.original != version){ writeBin(raw(length=20), con, size = 1, endian="little") }else{ writeBin(object@.RESERVED[[ID]][[1]], con, size = 1, endian="little") } ##Measurement characteristics ##LTYPE writeBin(object@METADATA[ID,"LTYPE"], con, size = 1, endian="little") ##LIGHTSOURCE writeBin(c(as.integer(object@METADATA[ID,"LIGHTSOURCE"])), con, size = 1, endian="little") ##LIGHTPOWER, LOW, HIGH, RATE writeBin(c(as.double(object@METADATA[ID,"LIGHTPOWER"]), as.double(object@METADATA[ID,"LOW"]), as.double(object@METADATA[ID,"HIGH"]), as.double(object@METADATA[ID,"RATE"])), con, size = 4, endian="little") ##TEMPERATURE, MEASTEMP writeBin(c(as.integer(object@METADATA[ID,"TEMPERATURE"]), as.integer(object@METADATA[ID,"MEASTEMP"])), con, size = 2, endian="little") ##AN_TEMP, AN_TIME writeBin(c(as.double(object@METADATA[ID,"AN_TEMP"]), as.double(object@METADATA[ID,"AN_TIME"])), con, size = 4, endian="little") ##TOLDELAY; TOLON, TOLOFF writeBin(c(as.integer(object@METADATA[ID,"TOLDELAY"]), as.integer(object@METADATA[ID,"TOLON"]), as.integer(object@METADATA[ID,"TOLOFF"])), con, size = 2, endian="little") ##IRR_TIME writeBin(as.double(object@METADATA[ID,"IRR_TIME"]), con, size = 4, endian="little") ##IRR_TYPE writeBin(c(object@METADATA[ID,"IRR_TYPE"]), con, size = 1, endian="little") ##IRR_DOSERATE, IRR_DOSERATEERR writeBin(c(as.double(object@METADATA[ID,"IRR_DOSERATE"]), as.double(object@METADATA[ID,"IRR_DOSERATEERR"])), con, size = 4, endian="little") ##TIMESINCEIRR writeBin(c(as.integer(object@METADATA[ID,"TIMESINCEIRR"])), con, size = 4, endian="little") ##TIMETICK writeBin(c(as.double(object@METADATA[ID,"TIMETICK"])), con, size = 4, endian="little") ##ONTIME, STIMPERIOD writeBin(c(suppressWarnings(as.integer(object@METADATA[ID,"ONTIME"])), as.integer(object@METADATA[ID,"STIMPERIOD"])), con, size = 4, endian="little") ##GATE_ENABLED writeBin(as.integer(object@METADATA[ID,"GATE_ENABLED"]), con, size = 1, endian="little") ##GATE_START, GATE_STOP writeBin(c(as.integer(object@METADATA[ID,"GATE_START"]), as.integer(object@METADATA[ID,"GATE_STOP"])), con, size = 4, endian="little") ##PTENABLED, DTENABLED writeBin(c(as.integer(object@METADATA[ID,"PTENABLED"]), as.integer(object@METADATA[ID,"DTENABLED"])), con, size = 1, endian="little") ##DEADTIME, MAXLPOWER, XRF_ACQTIME, XRF_HV writeBin(c(as.double(object@METADATA[ID,"DEADTIME"]), as.double(object@METADATA[ID,"MAXLPOWER"]), as.double(object@METADATA[ID,"XRF_ACQTIME"]), as.double(object@METADATA[ID,"XRF_HV"])), con, size = 4, endian="little") ##XRF_CURR writeBin(c(as.integer(object@METADATA[ID,"XRF_CURR"])), con, size = 4, endian="little") ##XRF_DEADTIMEF writeBin(c(as.double(object@METADATA[ID,"XRF_DEADTIMEF"])), con, size = 4, endian="little") ##add version support for V7 if(version == 06){ ##RESERVED 2 if(length(object@.RESERVED) == 0 || version.original != version){ writeBin(raw(length=24), con, size = 1, endian="little") }else{ writeBin(object@.RESERVED[[ID]][[2]], con, size = 1, endian="little") } }else{ ##DETECTOR_ID writeBin(as.integer(object@METADATA[ID,"DETECTOR_ID"]), con, size = 1, endian="little") ##LOWERFILTER_ID, UPPERFILTER_ID writeBin(c(as.integer(object@METADATA[ID,"LOWERFILTER_ID"]), as.integer(object@METADATA[ID,"UPPERFILTER_ID"])), con, size = 2, endian="little") ##ENOISEFACTOR writeBin(as.double(object@METADATA[ID,"ENOISEFACTOR"]), con, size = 4, endian="little") ##VERSION 08 if(version == 07){ ##RESERVED 2 if(length(object@.RESERVED) == 0 || version.original != version){ writeBin(raw(length=15), con, size = 1, endian="little") }else{ writeBin(object@.RESERVED[[ID]][[2]], con, size = 1, endian="little") } }else{ ##MARKPOS POSITION and extraction writeBin( c( as.double(object@METADATA[ID, "MARKPOS_X1"]), as.double(object@METADATA[ID, "MARKPOS_Y1"]), as.double(object@METADATA[ID, "MARKPOS_X2"]), as.double(object@METADATA[ID, "MARKPOS_Y2"]), as.double(object@METADATA[ID, "MARKPOS_X3"]), as.double(object@METADATA[ID, "MARKPOS_Y3"]), as.double(object@METADATA[ID, "EXTR_START"]), as.double(object@METADATA[ID, "EXTR_END"]) ), con, size = 4, endian = "little" ) ##RESERVED 2 if(length(object@.RESERVED) == 0 || version.original != version){ writeBin(raw(length=42), con, size = 1, endian="little") }else{ writeBin(object@.RESERVED[[ID]][[2]], con, size = 1, endian="little") } } }#end if version decision ##DPOINTS writeBin(as.integer(unlist(object@DATA[ID])), con, size = 4, endian="little") #SET UNIQUE ID ID <- ID + 1 ##update progress bar if(txtProgressBar==TRUE){ setTxtProgressBar(pb, ID) } } } # ##close con close(con) # # ##close if(txtProgressBar==TRUE){close(pb)} ##output cat(paste("\t >> ",ID-1,"records have been written successfully!\n\n",paste="")) } Luminescence/R/RLum-class.R0000644000176200001440000000433713125226556015210 0ustar liggesusers#' @include replicate_RLum.R RcppExports.R NULL #' Class \code{"RLum"} #' #' Abstract class for data in the package Luminescence #' #' #' @name RLum-class #' #' @docType class #' #' @slot originator Object of class \code{\link{character}} containing the name of the producing #' function for the object. Set automatically by using the function \code{\link{set_RLum}}. #' #' @slot info Object of class \code{\link{list}} for additional information on the object itself #' #' @slot .uid Object of class \code{\link{character}} for a unique object identifier. This id is #' usually calculated using the internal function \code{.create_UID()} if the funtion \code{\link{set_RLum}} #' is called. #' #' @slot .pid Object of class \code{\link{character}} for a parent id. This allows nesting RLum-objects #' at will. The parent id can be the uid of another object. #' #' @note \code{RLum} is a virtual class. #' #' @section Objects from the Class: A virtual Class: No objects can be created #' from it. #' #' @section Class version: 0.4.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\linkS4class{RLum.Data}}, \code{\linkS4class{RLum.Analysis}} #' #' @keywords classes #' #' @examples #' #' showClass("RLum") #' #' @export setClass("RLum", slots = list( originator = "character", info = "list", .uid = "character", .pid = "character" ), contains = "VIRTUAL", prototype = prototype( originator = NA_character_, info = list(), .uid = NA_character_, .pid = NA_character_ ) ) # replication method for object class ------------------------------------------ #' @describeIn RLum #' Replication method RLum-objects #' #' @param object an object of class \code{\linkS4class{RLum}} (\bold{required}) #' #' @param times \code{\link{integer}} (optional): number for times each element is repeated #' element #' #' @export setMethod( "replicate_RLum", "RLum", definition = function(object, times = NULL) { ##The case this is NULL if (is.null(times)) { times <- 1 } lapply(1:times, function(x) { object }) } ) Luminescence/R/convert_BIN2CSV.R0000644000176200001440000000732713125226556016036 0ustar liggesusers#' Export Risoe BIN-file(s) to CSV-files #' #' This function is a wrapper function around the functions \code{\link{read_BIN2R}} and #' \code{\link{write_RLum2CSV}} and it imports a Risoe BIN-file and directly exports its content to CSV-files. #' If nothing is set for the argument \code{path} (\code{\link{write_RLum2CSV}}) the input folder will #' become the output folder. #' #' @param file \code{\link{character}} (\bold{required}): name of the BIN-file to be converted to CSV-files #' #' @param \dots further arguments that will be passed to the function \code{\link{read_BIN2R}} and \code{\link{write_RLum2CSV}} #' #' @return The function returns either a CSV-file (or many of them) or for the option \code{export == FALSE} #' a list comprising objects of type \code{link{data.frame}} and \code{\link{matrix}} #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data}}, \code{\linkS4class{RLum.Results}}, #' \code{\link[utils]{write.table}}, \code{\link{write_RLum2CSV}}, \code{\link{read_BIN2R}} #' #' @keywords IO #' #' @examples #' #' ##transform Risoe.BINfileData values to a list #' data(ExampleData.BINfileData, envir = environment()) #' convert_BIN2CSV(subset(CWOSL.SAR.Data, POSITION == 1), export = FALSE) #' #' \dontrun{ #' ##select your BIN-file #' file <- file.choose() #' #' ##convert #' convert_BIN2CSV(file) #' #' } #' #' @export convert_BIN2CSV <- function( file, ... ){ # General tests ------------------------------------------------------------------------------- ##file is missing? if(missing(file)){ stop("[convert_BIN2CSV()] file is missing!", call. = FALSE) } ##set input arguments convert_BIN2CSV_settings.default <- list( path = if(!is(file, "Risoe.BINfileData")){dirname(file)}else{NULL}, show.raw.values = FALSE, position = NULL, n.records = NULL, zero_data.rm = TRUE, duplicated.rm = FALSE, show.record.number = FALSE, txtProgressBar = TRUE, forced.VersionNumber = NULL, ignore.RECTYPE = FALSE, pattern = NULL, verbose = TRUE, export = TRUE ) ##modify list on demand convert_BIN2CSV_settings <- modifyList(x = convert_BIN2CSV_settings.default, val = list(...)) # Import file --------------------------------------------------------------------------------- if(!is(file, "Risoe.BINfileData")){ object <- read_BIN2R( file = file, show.raw.values = convert_BIN2CSV_settings$show.raw.values, position = convert_BIN2CSV_settings$position, n.records = convert_BIN2CSV_settings$n.records, zero_data.rm = convert_BIN2CSV_settings$zero_data.rm, duplicated.rm = convert_BIN2CSV_settings$duplicated.rm, fastForward = TRUE, show.record.number = convert_BIN2CSV_settings$show.record.number, txtProgressBar = convert_BIN2CSV_settings$txtProgressBar, forced.VersionNumber = convert_BIN2CSV_settings$forced.VersionNumber, ignore.RECTYPE = convert_BIN2CSV_settings$ignore.RECTYPE, pattern = convert_BIN2CSV_settings$pattern, verbose = convert_BIN2CSV_settings$verbose ) }else{ object <- Risoe.BINfileData2RLum.Analysis(file) } # Export to CSV ------------------------------------------------------------------------------- ##get all arguments we want to pass and remove the doubled one arguments <- c(list(object = object, export = convert_BIN2CSV_settings$export), list(...)) arguments[duplicated(names(arguments))] <- NULL ##this if-condition prevents NULL in the terminal if(convert_BIN2CSV_settings$export == TRUE){ invisible(do.call("write_RLum2CSV", arguments)) }else{ do.call("write_RLum2CSV", arguments) } } Luminescence/R/CW2pHMi.R0000644000176200001440000002662113125226556014377 0ustar liggesusers#' Transform a CW-OSL curve into a pHM-OSL curve via interpolation under #' hyperbolic modulation conditions #' #' This function transforms a conventionally measured continuous-wave (CW) #' OSL-curve to a pseudo hyperbolic modulated (pHM) curve under hyperbolic #' modulation conditions using the interpolation procedure described by Bos & #' Wallinga (2012). #' #' The complete procedure of the transformation is described in Bos & Wallinga #' (2012). The input \code{data.frame} consists of two columns: time (t) and #' count values (CW(t))\cr\cr #' #' \bold{Internal transformation steps}\cr\cr (1) log(CW-OSL) values\cr\cr (2) #' Calculate t' which is the transformed time:\cr \deqn{t' = #' t-(1/\delta)*log(1+\delta*t)} (3) Interpolate CW(t'), i.e. use the #' log(CW(t)) to obtain the count values for the transformed time (t'). Values #' beyond \code{min(t)} and \code{max(t)} produce \code{NA} values.\cr\cr (4) #' Select all values for t' < \code{min(t)}, i.e. values beyond the time #' resolution of t. Select the first two values of the transformed data set #' which contain no \code{NA} values and use these values for a linear fit #' using \code{\link{lm}}.\cr\cr (5) Extrapolate values for t' < \code{min(t)} #' based on the previously obtained fit parameters.\cr\cr (6) Transform values #' using\cr \deqn{pHM(t) = (\delta*t/(1+\delta*t))*c*CW(t')} \deqn{c = #' (1+\delta*P)/\delta*P} \deqn{P = length(stimulation~period)} (7) Combine all #' values and truncate all values for t' > \code{max(t)} \cr\cr \emph{The #' number of values for t' < \code{min(t)} depends on the stimulation rate #' parameter \code{delta}. To avoid the production of too many artificial data #' at the raising tail of the determined pHM curve, it is recommended to use #' the automatic estimation routine for \code{delta}, i.e. provide no value for #' \code{delta}.} #' #' @param values \code{\linkS4class{RLum.Data.Curve}} or #' \code{\link{data.frame}} (\bold{required}): #' \code{\linkS4class{RLum.Data.Curve}} or \code{\link{data.frame}} with #' measured curve data of type stimulation time (t) (\code{values[,1]}) and #' measured counts (cts) (\code{values[,2]}). #' @param delta \code{\link{vector}} (optional): stimulation rate parameter, if #' no value is given, the optimal value is estimated automatically (see #' details). Smaller values of delta 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. \item{list(list("RLum.Data.Curve"))}{package #' \code{\linkS4class{RLum} object} with two additional info elements: #' \tabular{rl}{ $CW2pHMi.x.t \tab: transformed time values \cr $CW2pHMi.method #' \tab: used method for the production of the new data points }} #' \item{list(list("data.frame"))}{with four columns: \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 \code{delta} is #' provided manually and more than two points are extrapolated, a warning #' message is returned. \cr\cr The function \code{\link{approx}} may produce #' some \code{Inf} and \code{NaN} data. The function tries to manually #' interpolate these values by calculating the \code{mean} using the adjacent #' channels. If two invalid values are succeeding, the values are removed and #' no further interpolation is attempted.\cr In every case a warning message is #' shown. #' @section Function version: 0.2.2 #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) \cr\cr Based on comments and suggestions from:\cr Adrie J.J. Bos, #' Delft University of Technology, The Netherlands\cr #' @seealso \code{\link{CW2pLM}}, \code{\link{CW2pLMi}}, \code{\link{CW2pPMi}}, #' \code{\link{fit_LMCurve}}, \code{\link{lm}}, #' \code{\linkS4class{RLum.Data.Curve}} #' @references Bos, A.J.J. & Wallinga, J., 2012. How to visualize quartz OSL #' signal components. Radiation Measurements, 47, 752-758.\cr #' #' \bold{Further Reading}\cr\cr 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) - simple transformation #' #' ##load CW-OSL curve data #' data(ExampleData.CW_OSL_Curve, envir = environment()) #' #' ##transform values #' values.transformed<-CW2pHMi(ExampleData.CW_OSL_Curve) #' #' ##plot #' plot(values.transformed$x, values.transformed$y.t, log = "x") #' #' ##(2) - load CW-OSL curve from BIN-file and plot transformed values #' #' ##load BINfile #' #BINfileData<-readBIN2R("[path to BIN-file]") #' data(ExampleData.BINfileData, envir = environment()) #' #' ##grep first CW-OSL curve from ALQ 1 #' curve.ID<-CWOSL.SAR.Data@@METADATA[CWOSL.SAR.Data@@METADATA[,"LTYPE"]=="OSL" & #' CWOSL.SAR.Data@@METADATA[,"POSITION"]==1 #' ,"ID"] #' #' curve.HIGH<-CWOSL.SAR.Data@@METADATA[CWOSL.SAR.Data@@METADATA[,"ID"]==curve.ID[1] #' ,"HIGH"] #' #' curve.NPOINTS<-CWOSL.SAR.Data@@METADATA[CWOSL.SAR.Data@@METADATA[,"ID"]==curve.ID[1] #' ,"NPOINTS"] #' #' ##combine curve to data set #' #' curve<-data.frame(x = seq(curve.HIGH/curve.NPOINTS,curve.HIGH, #' by = curve.HIGH/curve.NPOINTS), #' y=unlist(CWOSL.SAR.Data@@DATA[curve.ID[1]])) #' #' #' ##transform values #' #' curve.transformed <- CW2pHMi(curve) #' #' ##plot curve #' plot(curve.transformed$x, curve.transformed$y.t, log = "x") #' #' #' ##(3) - 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<-CW2pLMi(values, P=1/20) #' lines(values[1:length(values.t[,1]),1],CW2pLMi(values, P=1/20)[,2], #' col="red" ,lwd=1.3) #' text(0.03,4500,"LM", col="red" ,cex=.8) #' #' values.t<-CW2pHMi(values, delta=40) #' lines(values[1:length(values.t[,1]),1],CW2pHMi(values, delta=40)[,2], #' col="black", lwd=1.3) #' text(0.005,3000,"HM", cex=.8) #' #' values.t<-CW2pPMi(values, P=1/10) #' lines(values[1:length(values.t[,1]),1],CW2pPMi(values, P=1/10)[,2], #' col="blue", lwd=1.3) #' text(0.5,6500,"PM", col="blue" ,cex=.8) #' #' #' @export CW2pHMi<- function( values, delta ){ ##(1) data.frame or RLum.Data.Curve object? if(is(values, "data.frame") == FALSE & is(values, "RLum.Data.Curve") == FALSE){ stop("[CW2pHMi()] 'values' object has to be of type 'data.frame' or 'RLum.Data.Curve'!", call. = FALSE) } ##(2) if the input object is an 'RLum.Data.Curve' object check for allowed curves if(is(values, "RLum.Data.Curve") == TRUE){ if(!grepl("OSL", values@recordType) & !grepl("IRSL", values@recordType)){ stop(paste("[CW2pHMi()] recordType ",values@recordType, " is not allowed for the transformation!", sep=""), call. = FALSE) }else{ temp.values <- as(values, "data.frame") } }else{ temp.values <- values } # (1) 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 delta ##if no values for delta is set selected a delta value for a maximum of ##two extrapolation points if(missing(delta)==TRUE){ i<-10 delta<-i t.transformed<-t-(1/delta)*log(1+delta*t) while(length(t.transformed[t.transformed2){ delta<-i t.transformed<-t-(1/delta)*log(1+delta*t) i<-i+10 } }else{ t.transformed<-t-(1/delta)*log(1+delta*t) } # (2) 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)) ##Problem: I some cases the interpolation algorithm is not working properely ##and Inf or NaN values are returned ##fetch row number of the invalid values invalid_values.id <- c(which(is.infinite(temp[,2]) | is.nan(temp[,2]))) if(length(invalid_values.id) > 0){ warning(paste(length(invalid_values.id)," values have been found and replaced the mean of the nearest values." )) } ##interpolate between the lower and the upper value invalid_values.interpolated<-sapply(1:length(invalid_values.id), function(x) { mean(c(temp[invalid_values.id[x]-1,2], temp[invalid_values.id[x]+1,2])) } ) ##replace invalid values in data.frame with newly interpolated values if(length(invalid_values.id)>0){ temp[invalid_values.id,2]<-invalid_values.interpolated } # (3) 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<-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(length(y.i)>2){warning("t' is beyond the time resolution and more than two data points have been extrapolated!")} # (4) Convert, transform and combine values --------------------------------- ##unlog CW-OSL count values, i.e. log(CW) >> CW CW_OSL<-exp(temp$y) ##set values for c and P ##P is the stimulation period P<-max(temp.values[,1]) ##c is a dimensionless constant c<-(1+(delta*P))/(delta*P) ##transform CW-OSL values to pLM-OSL values pHM<-((delta*t)/(1+(delta*t)))*c*CW_OSL ##combine all values and exclude NA values temp.values <- data.frame(x=t,y.t=pHM,x.t=t.transformed,method=temp.method) temp.values <- na.exclude(temp.values) # (5) 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, CW2pHMi.x.t = list(temp.values$x.t), CW2pHMi.method = list(temp.values$method)) newRLumDataCurves.CW2pHMi <- set_RLum( class = "RLum.Data.Curve", recordType = values@recordType, data = as.matrix(temp.values[,1:2]), info = temp.info) return(newRLumDataCurves.CW2pHMi) } } Luminescence/R/plot_RLum.Results.R0000644000176200001440000011112413125226556016574 0ustar liggesusers#' Plot function for an RLum.Results S4 class object #' #' The function provides a standardised plot output for data of an RLum.Results #' S4 class object #' #' The function produces a multiple plot output. A file output is recommended #' (e.g., \code{\link{pdf}}). #' #' @param object \code{\linkS4class{RLum.Results}} (\bold{required}): S4 object #' of class \code{RLum.Results} #' #' @param single \code{\link{logical}} (with default): single plot output #' (\code{TRUE/FALSE}) to allow for plotting the results in as few plot windows #' as possible. #' #' @param \dots further arguments and graphical parameters will be passed to #' the \code{plot} function. #' #' @return Returns multiple plots. #' #' @note Not all arguments available for \code{\link{plot}} will be passed! #' Only plotting of \code{RLum.Results} objects are supported. #' #' @section Function version: 0.2.1 #' #' @author Christoph Burow, University of Cologne (Germany), Sebastian Kreutzer, IRAMAT-CRP2A, #' Universite Bordeaux Montaigne (France) #' #' @seealso \code{\link{plot}}, \code{\link{plot_RLum}}, #' #' @references # #' #' @keywords aplot #' #' @examples #' #' #' ###load data #' data(ExampleData.DeValues, envir = environment()) #' #' # apply the un-logged minimum age model #' mam <- calc_MinDose(data = ExampleData.DeValues$CA1, sigmab = 0.2, log = TRUE, plot = FALSE) #' #' ##plot #' plot_RLum.Results(mam) #' #' # estimate the number of grains on an aliquot #' grains<- calc_AliquotSize(grain.size = c(100,150), sample.diameter = 1, plot = FALSE, MC.iter = 100) #' #' ##plot #' plot_RLum.Results(grains) #' #' #' @export plot_RLum.Results<- function( object, single = TRUE, ... ){ ##============================================================================## ## CONSISTENCY CHECK OF INPUT DATA ##============================================================================## ##check if object is of class RLum.Data.Curve if(!is(object,"RLum.Results")){ stop("[plot_RLum.Results()] Input object is not of type 'RLum.Results'") } ##============================================================================## ## SAFE AND RESTORE PLOT PARAMETERS ON EXIT ##============================================================================## par.old <- par(no.readonly = TRUE) on.exit(par(par.old)) ##============================================================================## ## ... ARGUMENTS ##============================================================================## ##deal with addition arguments extraArgs <- list(...) ##main main <- if("main" %in% names(extraArgs)) {extraArgs$main} else {""} ##mtext mtext <- if("mtext" %in% names(extraArgs)) {extraArgs$mtext} else {""} ##log log <- if("log" %in% names(extraArgs)) {extraArgs$log} else {""} ##lwd lwd <- if("lwd" %in% names(extraArgs)) {extraArgs$lwd} else {1} ##lty lty <- if("lty" %in% names(extraArgs)) {extraArgs$lty} else {1} ##type type <- if("type" %in% names(extraArgs)) {extraArgs$type} else {"l"} ##pch pch <- if("pch" %in% names(extraArgs)) {extraArgs$pch} else {1} ##col col <- if("col" %in% names(extraArgs)) {extraArgs$col} else {"black"} ##============================================================================## ## PLOTTING ##============================================================================## #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~# ## CASE 1: Minimum Age Model / Maximum Age Model if(object@originator=="calc_MinDose" || object@originator=="calc_MaxDose") { ## single MAM estimate # plot profile log likelhood tryCatch({ suppressWarnings( bbmle::plot(object@data$profile, show.points=FALSE, plot.confstr=TRUE, onepage = single, ask = FALSE) ) }, error = function(e) { if (single) par(mfrow=c(2, 2)) param <- c("gamma", "sigma", "p0", "mu") for (i in param) { if (object@data$summary$par == 3 && i == "mu") break tryCatch({ bbmle::plot(object@data$profile, which = i) }, error = function(e) { message(paste("Unable to plot the Likelihood profile for:", i)) }) } par(mfrow=c(1,1)) }) ## bootstrap MAM estimates if(object@data$args$bootstrap==TRUE) { # save previous plot parameter and set new ones .pardefault<- par(no.readonly = TRUE) # get De-llik pairs pairs<- object@data$bootstrap$pairs$gamma # get polynomial fit objects poly.lines<- list(poly.three=object@data$bootstrap$poly.fits$poly.three, poly.four=object@data$bootstrap$poly.fits$poly.four, poly.five=object@data$bootstrap$poly.fits$poly.five, poly.six=object@data$bootstrap$poly.fits$poly.six) # define polynomial curve functions for plotting poly.curves<- list(poly.three.curve=function(x) { poly.lines$poly.three$coefficient[4]*x^3 + poly.lines$poly.three$coefficient[3]*x^2 + poly.lines$poly.three$coefficient[2]*x + poly.lines$poly.three$coefficient[1] }, poly.four.curve=function(x) { poly.lines$poly.four$coefficient[5]*x^4 + poly.lines$poly.four$coefficient[4]*x^3 + poly.lines$poly.four$coefficient[3]*x^2 + poly.lines$poly.four$coefficient[2]*x + poly.lines$poly.four$coefficient[1] }, poly.five.curve=function(x) { poly.lines$poly.five$coefficient[6]*x^5 + poly.lines$poly.five$coefficient[5]*x^4 + poly.lines$poly.five$coefficient[4]*x^3 + poly.lines$poly.five$coefficient[3]*x^2 + poly.lines$poly.five$coefficient[2]*x + poly.lines$poly.five$coefficient[1] }, poly.six.curve=function(x) { poly.lines$poly.six$coefficient[7]*x^6 + poly.lines$poly.six$coefficient[6]*x^5 + poly.lines$poly.six$coefficient[5]*x^4 + poly.lines$poly.six$coefficient[4]*x^3 + poly.lines$poly.six$coefficient[3]*x^2 + poly.lines$poly.six$coefficient[2]*x + poly.lines$poly.six$coefficient[1] }) ## --------- PLOT "RECYCLE" BOOTSTRAP RESULTS ------------ ## if(single==TRUE) { layout(cbind(c(1,1,2, 5,5,6), c(3,3,4, 7,7,8))) par(cex = 0.6) } else { layout(matrix(c(1,1,2)),2,1) par(cex = 0.8) } for(i in 1:4) { ## ----- LIKELIHOODS # set margins (bottom, left, top, right) par(mar=c(0,5,5,3)) # sort De and likelihoods by De (increasing) pairs<- pairs[order(pairs[,1]),] # remove invalid NA values pairs<- na.omit(pairs) plot(x=pairs[,1], y=pairs[,2], xlab="Equivalent Dose [Gy]", ylab="Likelihood", xlim=range(pretty(pairs[,1])), ylim=range(pretty(c(0, as.double(quantile(pairs[,2],probs=0.98))))), xaxt = "n", xaxs = "i", yaxs = "i", bty = "l", main="Recycled bootstrap MAM-3") axis(side = 1, labels = FALSE, tick = FALSE) # add subtitle mtext(as.expression(bquote(italic(M) == .(object@data$args$bs.M) ~ "|" ~ italic(N) == .(object@data$args$bs.N) ~ "|" ~ italic(sigma[b]) == .(object@data$args$sigmab) ~ "\u00B1" ~ .(object@data$args$sigmab.sd) ~ "|" ~ italic(h) == .(round(object@data$args$bs.h,1)) ) ), side = 3, line = 0.3, adj = 0.5, cex = if(single){0.5}else{0.8}) # add points points(x=pairs[,1], y=pairs[,2], pch=1, col = "grey80") # get polynomial function poly.curve<- poly.curves[[i]] # add curve to plot curve(poly.curve, from = min(pairs[,1]), to = (max(pairs[,1])), col = "black", add = TRUE, type = "l") # add legend legend<- c("Third degree", "Fourth degree", "Fifth degree", "Sixth degree") legend("topright", xjust = 0, legend = legend[i], y.intersp = 1.2, bty = "n", title = "Polynomial Fit", lty = 1, lwd= 1.5) ## ----- RESIDUALS # set margins (bottom, left, top, right) par(mar=c(5,5,0,3)) plot(x = pairs[,1], y = residuals(poly.lines[[i]]), ylim = c(min(residuals(poly.lines[[i]]))*1.2, as.double(quantile(residuals(poly.lines[[i]]),probs=0.99))), xlim=range(pretty(pairs[,1])), xaxt = "n", bty = "l", xaxs = "i", col = "grey80", ylab = "Fit residual", xlab = "Equivalent dose [Gy]") axis(side = 1, labels = TRUE, tick = TRUE) # add horizontal line abline(h = 0, lty=2) # calculate residual sum of squares (RSS) and add to plot rss<- sum(residuals(poly.lines[[i]])^2) mtext(text = paste("RSS =",round(rss,3)), adj = 1, side = 3, line = -2, cex = if(single){0.6}else{0.8}) ## ----- PROPORTIONS }##EndOf::Plot_loop # restore previous plot parameters par(.pardefault) ### TODO: plotting of the LOESS fit needs to be fleshed out ### possibly integrate this in the prior polynomial plot loop ### LOESS PLOT pairs<- object@data$bootstrap$pairs$gamma pred<- predict(object@data$bootstrap$loess.fit) loess<- cbind(pairs[,1], pred) loess<- loess[order(loess[,1]),] # plot gamma-llik pairs plot(pairs, ylim = c(0, as.double(quantile( pairs[,2],probs=0.99))), ylab = "Likelihood", xlab = "Equivalent dose [Gy]", col = "gray80") # add LOESS line lines(loess, type = "l", col = "black") ### ------ PLOT BOOTSTRAP LIKELIHOOD FIT par(mar=c(5,4,4,4)) xlim<- range(pretty(object@data$data[,1])) xlim[1]<- xlim[1]-object@data$data[which.min(object@data$data[,1]),2] xlim[2]<- xlim[2]+object@data$data[which.max(object@data$data[,1]),2] xlim<- range(pretty(xlim)) # empty plot plot(NA,NA, xlim=xlim, ylim=c(0,2), xlab="Equivalent dose [Gy]", ylab="", bty="l", axes=FALSE, xaxs="i", yaxs="i", yaxt="n") axis(side = 1) axis(side = 2, at = c(0,0.5,1)) mtext(text = "Normalised likelihood / density", side = 2, line = 2.5, adj = 0) # set the polynomial to plot poly.curve<- poly.curves[[1]] # three degree poly # plot a nice grey polygon as in the publication step<- 0.1 x<- seq(min(pairs[,1]), max(pairs[,1]), step) y<- poly.curve(x) # normalise y-values y<- y/max(y) x<- c(min(pairs[,1]), x, max(pairs[,1])) y<- c(0, y, 0) # cutoff negative y values neg<- which(y<0) y<- y[-neg] x<- x[-neg] # add bootstrap likelihood polygon to plot polygon(x, y, col = "grey80", border = NA) ### ----- PLOT MAM SINGLE ESTIMATE # symmetric errors, might not be appropriate mean<- object@data$summary$de sd<- object@data$summary$de_err x<- seq(mean-5*sd, mean+5*sd, 0.001) y<- dnorm(seq(mean-5*sd, mean+5*sd, 0.001), mean, sd) # normalise y-values y<- y/max(y) points(x, y, type="l", col="red") ## asymmetric errors x<- unlist(object@data$profile@profile$gamma$par.vals[,1]) y<- abs(unlist(object@data$profile@profile$gamma$z)) if(object@data$args$log == TRUE) { x<- exp(x) } # now invert the data by shifting y<- -y y<- y-min(y) y<- y/max(y) # fit a smoothing spline l<- spline(x = x, y = y, method = "n", n = 1000) # make the endpoints zero l$y[1]<- l$y[length(l$y)]<- 0 # add profile log likelihood curve to plot lines(l, col="blue", lwd=1) # add vertical lines of the mean values #points(x = 80, y = 100,type = "l") #### ------ PLOT DE par(new = TRUE) # sort the data in ascending order dat<- object@data$data[order(object@data$data[,1]),] x<- dat[,1] y<- 1:length(object@data$data[,1]) plot(x = x, y = y, xlim=xlim, ylim=c(0, max(y)+1), axes = FALSE, pch = 16, xlab = "", ylab="", xaxs="i", yaxs="i") axis(side = 4) mtext(text = "# Grain / aliquot", side = 4, line = 2.5) # get sorted errors err<- object@data$data[order(object@data$data[,1]),2] # fancy error bars arrows(x0 = x-err, y0 = y, x1 = x+err, y1 = y, code = 3, angle = 90, length = 0.05) ### ---- AUXILLARY # add legend legend("bottomright", bty = "n", col = c("grey80", "red", "blue", "black"), pch = c(NA,NA,NA,16), lty = c(1,1,1,1), lwd=c(10,2,2,2), legend = c("Bootstrap likelihood", "Profile likelihood (gaussian fit)","Profile likelihood", "Grain / aliquot"), ) }##EndOf::Bootstrap_plotting }#EndOf::CASE1_MinimumAgeModel-3 #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~# ## CASE 2: Central Age Model if(object@originator=="calc_CentralDose") { # get profile log likelihood data sig<- object@data$profile$sig*100 llik<- object@data$profile$llik # save previous plot parameter and set new ones .pardefault<- par(no.readonly = TRUE) # plot the profile log likeihood par(oma=c(2,1,2,1),las=1,cex.axis=1.2, cex.lab=1.2) plot(sig,llik,type="l",xlab=as.expression(bquote(sigma[OD]~"[%]")),ylab="Log likelihood",lwd=1.5) abline(h=0,lty=3) abline(h=-1.92,lty=3) title(as.expression(bquote("Profile log likelihood for" ~ sigma[OD]))) # find upper and lower confidence limits for sigma sigmax<- sig[which.max(llik)] tf<- abs(llik+1.92) < 0.05 sig95<- sig[tf] ntf<- length(sig95) sigL<- sig95[1] sigU<- sig95[ntf] # put them on the graph abline(v=sigL) abline(v=sigmax) abline(v=sigU) dx<- 0.006 dy<- 0.2 ytext<- min(llik) + dy res<- c(sigL,sigmax,sigU) text(res+dx,rep(ytext,3),round(res,2),adj=0) # restore previous plot parameters par(.pardefault) rm(.pardefault) }##EndOf::Case 2 - calc_CentralDose() #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~# ## CASE 3: Fuchs & Lang 2001 if(object@originator=="calc_FuchsLang2001") { ##deal with addition arguments extraArgs <- list(...) main <- if("main" %in% names(extraArgs)) {extraArgs$main} else {"Fuchs & Lang (2001)"} xlab <- if("xlab" %in% names(extraArgs)) {extraArgs$xlab} else {expression(paste(D[e]," [s]"))} ylab <- if("ylab" %in% names(extraArgs)) {extraArgs$ylab} else {"# Aliquots"} sub <- if("sub" %in% names(extraArgs)) {extraArgs$sub} else {""} cex <- if("cex" %in% names(extraArgs)) {extraArgs$cex} else {1} lwd <- if("lwd" %in% names(extraArgs)) {extraArgs$lwd} else {1} pch <- if("pch" %in% names(extraArgs)) {extraArgs$pch} else {19} ylim <- if("ylim" %in% names(extraArgs)) {extraArgs$ylim} else {c(1,length(object@data$data[,1])+3)} xlim <- if("xlim" %in% names(extraArgs)) {extraArgs$xlim} else {c(min(object@data$data[,1])-max(object@data$data[,2]), max(object@data$data[,1])+max(object@data$data[,2]))} mtext <- if("mtext" %in% names(extraArgs)) {extraArgs$mtext} else {"unknown sample"} # extract relevant plotting parameters o<- order(object@data$data[1]) data_ordered<- object@data$data[o,] usedDeValues<- object@data$usedDeValues n.usedDeValues<- object@data$summary$n.usedDeValues par(cex = cex, mfrow=c(1,1)) ##PLOT counter<-seq(1,max(o)) plot(NA,NA, ylim = ylim, xlim = xlim, xlab = xlab, ylab = ylab, main = main, sub = sub) ##SEGMENTS segments(data_ordered[,1]-data_ordered[,2],1:length(data_ordered[,1]), data_ordered[,1]+data_ordered[,2],1:length(data_ordered[,1]), col="gray") ##POINTS points(data_ordered[,1], counter,pch=pch) ##LINES ##BOUNDARY INFORMATION ##lower boundary lines(c( usedDeValues[length(usedDeValues[,1])-n.usedDeValues+1,1], #boundary_counter for incorporate skipped values usedDeValues[length(usedDeValues[,1])-n.usedDeValues+1,1]), c(min(o)-0.5,max(o)+0.5), col="red", lty="dashed", lwd = lwd) #upper boundary lines(c(max(usedDeValues[,1]),max(usedDeValues[,1])),c(min(o)-0.5,max(o)+0.5), col="red",lty="dashed", lwd = lwd) #plot some further informations into the grafik arrows( usedDeValues[length(usedDeValues[,1])-n.usedDeValues+1,1]+usedDeValues[length(usedDeValues[,1])-n.usedDeValues+1,1]*0.02, #x1 max(o)+0.5, #y1 max(usedDeValues[,1]-usedDeValues[,1]*0.02), #x2 max(o)+0.5, #y2, code=3, length=0.03) text( c( usedDeValues[length(usedDeValues[,1])-n.usedDeValues+1,1], usedDeValues[length(usedDeValues[,1])-n.usedDeValues+1,1]), c(max(o)+2,max(o)+2), labels=paste("used values = ", n.usedDeValues), cex=0.6*cex, adj=0) ##MTEXT mtext(side=3,mtext,cex=cex) } #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~# ## CASE 4: Finite Mixture Model if(object@originator == "calc_FiniteMixture") { if(length(object@data$args$n.components) > 1L) { ##deal with addition arguments extraArgs <- list(...) main <- if("main" %in% names(extraArgs)) {extraArgs$main} else {"Finite Mixture Model"} plot.proportions<- if("plot.proportions" %in% names(extraArgs)) {extraArgs$plot.proportions} else {TRUE} pdf.colors<- if("pdf.colors" %in% names(extraArgs)) {extraArgs$pdf.colors} else {"gray"} pdf.weight<- if("pdf.weight" %in% names(extraArgs)) {extraArgs$pdf.weight} else {TRUE} pdf.sigma<- if("pdf.sigma" %in% names(extraArgs)) {extraArgs$pdf.sigma} else {"sigmab"} # extract relevant data from object n.components<- object@data$args$n.components comp.n<- object@data$components sigmab<- object@data$args$sigmab BIC.n<- object@data$BIC$BIC LLIK.n<- object@data$llik$llik # save previous plot parameter and set new ones .pardefault<- par(no.readonly = TRUE) ## DEVICE AND PLOT LAYOUT n.plots<- length(n.components) #number of PDF plots in plotarea #1 seq.vertical.plots<- seq(from = 1, to = n.plots, by = 1) #indices ID.plot.two<- n.plots+if(plot.proportions==TRUE){1}else{0} #ID of second plot area ID.plot.three<- n.plots+if(plot.proportions==TRUE){2}else{1} #ID of third plot area #empty vector for plot indices seq.matrix<- vector(mode="integer", length=4*n.plots) #fill vector with plot indices in correct order cnt<- 1 seq<- seq(1,length(seq.matrix),4) for(i in seq) { seq.matrix[i]<- cnt seq.matrix[i+1]<- cnt seq.matrix[i+2]<- if(plot.proportions==TRUE){ID.plot.two}else{cnt} seq.matrix[i+3]<- ID.plot.three cnt<- cnt+1 } # create device layout layout(matrix(c(seq.matrix),4,n.plots)) # outer margins (bottom, left, top, right) par(oma=c(2.5,5,3,5)) # general plot parameters (global scaling, allow overplotting) par(cex = 0.8, xpd = NA) # define color palette for prettier output if(pdf.colors == "colors") { col.n<- c("red3", "slateblue3", "seagreen", "tan3", "yellow3", "burlywood4", "magenta4", "mediumpurple3", "brown4","grey", "aquamarine") poly.border<- FALSE } if(pdf.colors == "gray" || pdf.colors == "grey") { col.n<- gray.colors(length(n.components)*2) poly.border<- FALSE } if(pdf.colors == "none") { col.n<- NULL poly.border<- TRUE } ##-------------------------------------------------------------------------- ## PLOT 1: EQUIVALENT DOSES OF COMPONENTS ## create empty plot without x-axis for(i in 1:n.plots) { pos.n<- seq(from = 1, to = n.components[i]*3, by = 3) # set margins (bottom, left, top, right) par(mar=c(1,0,2,0)) # empty plot area plot(NA, NA, xlim=c(min(n.components)-0.2, max(n.components)+0.2), ylim=c(min(comp.n[pos.n,]-comp.n[pos.n+1,], na.rm = TRUE), max((comp.n[pos.n,]+comp.n[pos.n+1,])*1.1, na.rm = TRUE)), ylab="", xaxt="n", yaxt="n", xlab="") # add text in upper part of the plot ("k = 1,2..n") mtext(bquote(italic(k) == .(n.components[i])), side = 3, line = -2, cex=0.8) # add y-axis label (only for the first plot) if(i==1) { mtext(expression(paste("D"[e]," [Gy]")), side=2,line=2.7, cex=1) } # empty list to store normal distribution densities sapply.storage<- list() ## NORMAL DISTR. OF EACH COMPONENT options(warn=-1) #supress warnings for NA values # LOOP - iterate over number of components for(j in 1:max(n.components)) { # draw random values of the ND to check for NA values comp.nd.n<- sort(rnorm(n = length(object@data$data[,1]), mean = comp.n[pos.n[j],i], sd = comp.n[pos.n[j]+1,i])) # proceed if no NA values occured if(length(comp.nd.n)!=0) { # weight - proportion of the component wi<- comp.n[pos.n[j]+2,i] # calculate density values with(out) weights fooX<- function(x) { dnorm(x, mean = comp.n[pos.n[j],i], sd = if(pdf.sigma=="se"){comp.n[pos.n[j]+1,i]} else{if(pdf.sigma=="sigmab"){comp.n[pos.n[j],i]*sigmab}} )* if(pdf.weight==TRUE){wi}else{1} } # x-axis scaling - determine highest dose in first cycle if(i==1 && j==1){ max.dose<- max(object@data$data[,1])+sd(object@data$data[,1])/2 min.dose<- min(object@data$data[,1])-sd(object@data$data[,1])/2 # density function to determine y-scaling if no weights are used fooY<- function(x) { dnorm(x, mean = na.exclude(comp.n[pos.n,]), sd = na.exclude(comp.n[pos.n+1,])) } # set y-axis scaling dens.max<-max(sapply(0:max.dose, fooY)) }##EndOfIf::first cycle settings # override y-axis scaling if weights are used if(pdf.weight==TRUE){ sapply.temp<- list() for(b in 1:max(n.components)){ # draw random values of the ND to check for NA values comp.nd.n<- sort(rnorm(n = length(object@data$data[,1]), mean = comp.n[pos.n[b],i], sd = comp.n[pos.n[b]+1,i])) # proceed if no NA values occured if(length(comp.nd.n)!=0) { # weight - proportion of the component wi.temp<- comp.n[pos.n[b]+2,i] fooT<- function(x) { dnorm(x, mean = comp.n[pos.n[b],i], sd = if(pdf.sigma=="se"){comp.n[pos.n[b]+1,i]} else{if(pdf.sigma=="sigmab"){comp.n[pos.n[b],i]*sigmab}} )*wi.temp } sapply.temp[[b]]<- sapply(0:max.dose, fooT) } } dens.max<- max(Reduce('+', sapply.temp)) } # calculate density values for 0 to maximum dose sapply<- sapply(0:max.dose, fooX) # save density values in list for sum curve of gaussians sapply.storage[[j]]<- sapply ## determine axis scaling # x-axis (dose) if("dose.scale" %in% names(extraArgs)) { y.scale<- extraArgs$dose.scale } else { y.scale<- c(min.dose,max.dose) } # y-axis (density) if("pdf.scale" %in% names(extraArgs)) { x.scale<- extraArgs$pdf.scale } else { x.scale<- dens.max*1.1 } ## PLOT Normal Distributions par(new=TRUE) plot(sapply, 1:length(sapply)-1, type="l", yaxt="n", xaxt="n", col=col.n[j], lwd=1, ylim=y.scale, xlim=c(0,x.scale), xaxs="i", yaxs="i", ann=FALSE, xpd = FALSE) # draw colored polygons under curve polygon(x=c(min(sapply), sapply, min(sapply)), y=c(0, 0:max.dose, 0), col = adjustcolor(col.n[j], alpha.f = 0.66), yaxt="n", border=poly.border, xpd = FALSE, lty = 2, lwd = 1.5) } }##EndOf::Component loop #turn warnings on again options(warn=0) # Add sum of gaussians curve par(new = TRUE) plot(Reduce('+', sapply.storage),1:length(sapply)-1, type="l", yaxt="n", xaxt="n", col="black", lwd=1.5, lty = 1, ylim=y.scale, xlim=c(0,x.scale), xaxs="i", yaxs="i", ann=FALSE, xpd = FALSE) # draw additional info during first k-cycle if(i == 1) { # plot title mtext("Normal distributions", side = 3, font = 2, line = 0, adj = 0, cex = 0.8) # main title mtext(main, side = 3, font = 2, line = 3.5, adj = 0.5, at = grconvertX(0.5, from = "ndc", to = "user")) # subtitle mtext(as.expression(bquote(italic(sigma[b]) == .(sigmab) ~ "|" ~ n == .(length(object@data$data[,1])))), side = 3, font = 1, line = 2.2, adj = 0.5, at = grconvertX(0.5, from = "ndc", to = "user"), cex = 0.9) # x-axis label mtext("Density [a.u.]", side = 1, line = 0.5, adj = 0.5, at = grconvertX(0.5, from = "ndc", to = "user")) # draw y-axis with proper labels axis(side=2, labels = TRUE) } if(pdf.colors == "colors") { # create legend labels dose.lab.legend<- paste("c", 1:n.components[length(n.components)], sep="") if(max(n.components)>8) { ncol.temp<- 8 yadj<- 1.025 } else { ncol.temp<- max(n.components) yadj<- 0.93 } # add legend if(i==n.plots) { legend(grconvertX(0.55, from = "ndc", to = "user"), grconvertY(yadj, from = "ndc", to = "user"), legend = dose.lab.legend, col = col.n[1:max(n.components)], pch = 15, adj = c(0,0.2), pt.cex=1.4, bty = "n", ncol=ncol.temp, x.intersp=0.4) mtext("Components: ", cex = 0.8, at = grconvertX(0.5, from = "ndc", to = "user")) } } }##EndOf::k-loop and Plot 1 ##-------------------------------------------------------------------------- ## PLOT 2: PROPORTION OF COMPONENTS if(plot.proportions==TRUE) { # margins for second plot par(mar=c(2,0,2,0)) # create matrix with proportions from a subset of the summary matrix prop.matrix<- comp.n[pos.n+2,]*100 # stacked barplot of proportions without x-axis barplot(prop.matrix, width=1, xlim=c(0.2, length(n.components)-0.2), ylim=c(0,100), axes=TRUE, space=0, col=col.n, xpd=FALSE, xaxt="n") # y-axis label mtext("Proportion [%]", side=2,line=3, cex=1) # add x-axis with corrected tick positions axis(side = 1, labels = n.components, at = n.components+0.5-n.components[1]) # draw a box (not possible with barplot()) box(lty=1, col="black") # add subtitle mtext("Proportion of components", side = 3, font = 2, line = 0, adj = 0, cex = 0.8) } ##-------------------------------------------------------------------------- ## PLOT 3: BIC & LLIK # margins for third plot par(mar=c(2,0,2,0)) # prepare scaling for both y-axes BIC.scale<- c(min(BIC.n)*if(min(BIC.n)<0){1.2}else{0.8}, max(BIC.n)*if(max(BIC.n)<0){0.8}else{1.2}) LLIK.scale<- c(min(LLIK.n)*if(min(LLIK.n)<0){1.2}else{0.8}, max(LLIK.n)*if(max(LLIK.n)<0){0.8}else{1.2}) # plot BIC scores plot(n.components, BIC.n, main= "", type="b", pch=22, cex=1.5, xlim=c(min(n.components)-0.2, max(n.components)+0.2), ylim=BIC.scale, xaxp=c(min(n.components), max(n.components), length(n.components)-1), xlab=expression(paste(italic(k), " Components")), ylab=expression(paste("BIC")), cex.lab=1.25) # following plot should be added to previous par(new = TRUE) # plot LLIK estimates plot(n.components, LLIK.n, xlim=c(min(n.components)-0.2, max(n.components)+0.2), xaxp=c(min(n.components), max(n.components), length(n.components)-1), ylim=LLIK.scale, yaxt="n", type="b", pch=16, xlab="", ylab="", lty=2, cex = 1.5) # subtitle mtext("Statistical criteria", side = 3, font = 2, line = 0, adj = 0, cex = 0.8) # second y-axis with proper scaling axis(side = 4, ylim=c(0,100)) # LLIK axis label mtext(bquote(italic(L)[max]), side=4,line=3, cex=1.3) # legend legend(grconvertX(0.75, from = "nfc", to = "user"), grconvertY(0.96, from = "nfc", to = "user"), legend = c("BIC", as.expression(bquote(italic(L)[max]))), pch = c(22,16), pt.bg=c("white","black"), adj = 0, pt.cex=1.3, lty=c(1,2), bty = "n", horiz = TRUE, x.intersp=0.5) ## restore previous plot parameters par(.pardefault) } }##EndOf::Case 4 - Finite Mixture Model #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~# ## CASE 5: Aliquot Size if(object@originator=="calc_AliquotSize") { if(!is.null(object@data$MC$estimates)) { extraArgs <- list(...) main <- if("main" %in% names(extraArgs)) { extraArgs$main } else { "Monte Carlo Simulation" } xlab <- if("xlab" %in% names(extraArgs)) { extraArgs$xlab } else { "Amount of grains on aliquot" } # extract relevant data MC.n<- object@data$MC$estimates MC.n.kde<- object@data$MC$kde MC.stats<- object@data$MC$statistics MC.q<- object@data$MC$quantile MC.iter<- object@data$args$MC.iter # set layout of plotting device layout(matrix(c(1,1,2)),2,1) par(cex = 0.8) ## plot MC estimate distribution # set margins (bottom, left, top, right) par(mar=c(2,5,5,3)) # plot histogram hist(MC.n, freq=FALSE, col = "gray90", main="", xlab=xlab, xlim = c(min(MC.n)*0.95, max(MC.n)*1.05), ylim = c(0, max(MC.n.kde$y)*1.1)) # add rugs to histogram rug(MC.n) # add KDE curve lines(MC.n.kde, col = "black", lwd = 1) # add mean, median and quantils (0.05,0.95) abline(v=c(MC.stats$mean, MC.stats$median, MC.q), lty=c(2, 4, 3,3), lwd = 1) # add main- and subtitle mtext(main, side = 3, adj = 0.5, line = 3, cex = 1) mtext(as.expression(bquote(italic(n) == .(MC.iter) ~ "|" ~ italic(hat(mu)) == .(round(MC.stats$mean)) ~ "|" ~ italic(hat(sigma)) == .(round(MC.stats$sd.abs)) ~ "|" ~ italic(frac(hat(sigma),sqrt(n))) == .(round(MC.stats$se.abs)) ~ "|" ~ italic(v) == .(round(MC.stats$skewness, 2)) ) ), side = 3, line = 0.3, adj = 0.5, cex = 0.9) # add legend legend("topright", legend = c("mean","median", "0.05 / 0.95 quantile"), lty = c(2, 4, 3), bg = "white", box.col = "white", cex = 0.9) ## BOXPLOT # set margins (bottom, left, top, right) par(mar=c(5,5,0,3)) plot(NA, type="n", xlim=c(min(MC.n)*0.95, max(MC.n)*1.05), xlab=xlab, ylim=c(0.5,1.5), xaxt="n", yaxt="n", ylab="") par(bty="n") boxplot(MC.n, horizontal = TRUE, add = TRUE, bty="n") } }#EndOf::Case 5 - calc_AliqoutSize() #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~# ## CASE 6: calc_SourceDoseRate() if(object@originator=="calc_SourceDoseRate") { ##prepare data ##get data df <- get_RLum(object = object, data.object = "dose.rate") ##reduce the size for plotting, more than 100 points makes no sense if(nrow(df)>100) { df <- df[seq(1,nrow(df), length = 100),] } ##plot settings plot.settings <- list( main = "Source Dose Rate Prediction", xlab = "Date", ylab = paste0( "Dose rate/(",get_RLum(object = object, data.object = "parameters")$dose.rate.unit,")"), log = "", cex = 1, xlim = NULL, ylim = c(min(df[,1]) - max(df[,2]), max(df[,1]) + max(df[,2])), pch = 1, mtext = paste0( "source type: ", get_RLum(object = object, data.object = "parameters")$source.type, " | ", "half-life: ", get_RLum(object = object, data.object = "parameters")$halflife, " a" ), grid = expression(nx = 10, ny = 10), col = 1, type = "b", lty = 1, lwd = 1, segments = "" ) ##modify list if something was set plot.settings <- modifyList(plot.settings, list(...)) ##plot plot( df[,3], df[,1], main = plot.settings$main, xlab = plot.settings$xlab, ylab = plot.settings$ylab, xlim = plot.settings$xlim, ylim = plot.settings$ylim, log = plot.settings$log, pch = plot.settings$pch, col = plot.settings$pch, type = plot.settings$type, lty = plot.settings$lty, lwd = plot.settings$lwd ) if(!is.null(plot.settings$segments)){ segments( x0 = df[,3], y0 = df[,1] + df[,2], x1 = df[,3], y1 = df[,1] - df[,2] ) } mtext(side = 3, plot.settings$mtext) if(!is.null(plot.settings$grid)){ grid(eval(plot.settings$grid)) } }#EndOf::Case 6 - calc_SourceDoseRate() #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~# ## CASE 7: Fast Ratio if (object@originator=="calc_FastRatio") { # graphical settings settings <- list(main = "Fast Ratio", xlab = "t/s", ylab = "Signal/cts", cex = 1.0) settings <- modifyList(settings, list(...)) par(cex = settings$cex) # fetch data from RLum.Results object curve <- get_RLum(object, "data") if (inherits(curve, "RLum.Data.Curve")) curve <- get_RLum(curve) res <- get_RLum(object, "summary") fit <- get_RLum(object, "fit") # calculate the dead channel time offset offset <- res$dead.channels.start * res$channel.width # plot the OSL curve plot(curve, type = "p", main = settings$main, xlab = settings$xlab, ylab = settings$ylab) # plot points to show measured data points (i.e., the channels) points(curve[(res$dead.channels.start + 1):(nrow(curve) - res$dead.channels.end),], pch = 16) # plot dead channels as empty circles if (res$dead.channels.start > 0) points(curve[1:res$dead.channels.start,]) if (res$dead.channels.end > 0) points(curve[(nrow(curve) - res$dead.channels.end):nrow(curve), ]) # optional: plot fitted CW curve if (!is.null(fit)) { nls.fit <- get_RLum(fit, "fit") if (!inherits(fit, "try-error") & "fitCW.curve" %in% names(object@data$args)) { if (object@data$args$fitCW.curve == "T" | object@data$args$fitCW.curve == TRUE) { lines(curve[(res$dead.channels.start + 1):(nrow(curve) - res$dead.channels.end), 1], predict(nls.fit), col = "red", lty = 1) } } } lines(curve) # add vertical lines and labels for L1, L2, L3 L_times <- c(curve[res$Ch_L1, 1], curve[res$Ch_L2, 1], curve[res$Ch_L3_start, 1], curve[res$Ch_L3_end, 1]) + offset abline(v = L_times, lty = 2) text(L_times, max(curve[ ,2]) * 0.95, pos = c(4,4,2,2), labels = expression('L'[1], 'L'[2], 'L'[3['start']], 'L'[3['end']])) }#EndOf::Case7 - calc_FastRatio() } Luminescence/R/CW2pLM.R0000644000176200001440000001075013125226556014226 0ustar liggesusers#' Transform a CW-OSL curve into a pLM-OSL curve #' #' Transforms a conventionally measured continuous-wave (CW) curve into a #' pseudo linearly modulated (pLM) curve using the equations given in Bulur #' (2000). #' #' According to Bulur (2000) the curve data are transformed by introducing two #' new parameters P (stimulation period) and u (transformed time): #' \deqn{P=2*max(t)} \deqn{u=\sqrt{(2*t*P)}} The new count values are then #' calculated by \deqn{ctsNEW = cts(u/P)} and the returned \code{data.frame} is #' produced by: \code{data.frame(u,ctsNEW)} #' #' @param values \code{\linkS4class{RLum.Data.Curve}} or #' \code{\link{data.frame}} (\bold{required}): \code{RLum.Data.Curve} data #' object. Alternatively, a \code{data.frame} of the measured curve data of #' type stimulation time (t) (\code{values[,1]}) and measured counts (cts) #' (\code{values[,2]}) can be provided. #' @return The function returns the same data type as the input data type with #' the transformed curve values. #' #' \item{list(list("data.frame"))}{generic R data structure} #' \item{list(list("RLum.Data.Curve"))}{package \code{\linkS4class{RLum} #' object}} #' @note The transformation is recommended for curves recorded with a channel #' resolution of at least 0.05 s/channel. #' @section Function version: 0.4.1 #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' @seealso \code{\link{CW2pHMi}}, \code{\link{CW2pLMi}}, #' \code{\link{CW2pPMi}}, \code{\link{fit_LMCurve}}, \code{\link{lm}}, #' \code{\linkS4class{RLum.Data.Curve}} #' #' The output of the function can be further used for LM-OSL fitting: #' \code{\link{CW2pLMi}}, \code{\link{CW2pHMi}}, \code{\link{CW2pPMi}}, #' \code{\link{fit_LMCurve}}, \code{\linkS4class{RLum.Data.Curve}}, #' \code{\link{plot_RLum}} #' @references Bulur, E., 2000. A simple transformation for converting CW-OSL #' curves to LM-OSL curves. Radiation Measurements, 32, 141-145. #' #' \bold{Further Reading}\cr\cr Bulur, E., 1996. An Alternative Technique For #' Optically Stimulated Luminescence (OSL) Experiment. Radiation Measurements, #' 26, 701-709. #' @keywords manip #' @examples #' #' #' ##read curve from CWOSL.SAR.Data transform curve and plot values #' data(ExampleData.BINfileData, envir = environment()) #' #' ##read id for the 1st OSL curve #' id.OSL <- CWOSL.SAR.Data@@METADATA[CWOSL.SAR.Data@@METADATA[,"LTYPE"] == "OSL","ID"] #' #' ##produce x and y (time and count data for the data set) #' x<-seq(CWOSL.SAR.Data@@METADATA[id.OSL[1],"HIGH"]/CWOSL.SAR.Data@@METADATA[id.OSL[1],"NPOINTS"], #' CWOSL.SAR.Data@@METADATA[id.OSL[1],"HIGH"], #' by = CWOSL.SAR.Data@@METADATA[id.OSL[1],"HIGH"]/CWOSL.SAR.Data@@METADATA[id.OSL[1],"NPOINTS"]) #' y <- unlist(CWOSL.SAR.Data@@DATA[id.OSL[1]]) #' values <- data.frame(x,y) #' #' ##transform values #' values.transformed <- CW2pLM(values) #' #' ##plot #' plot(values.transformed) #' #' #' @export CW2pLM <- function( values ){ # Integrity Checks -------------------------------------------------------- ##(1) data.frame or RLum.Data.Curve object? if(is(values, "data.frame") == FALSE & is(values, "RLum.Data.Curve") == FALSE){ stop("[CW2pLM()] 'values' object has to be of type 'data.frame' or 'RLum.Data.Curve'!", call. = FALSE) } ##(2) if the input object is an 'RLum.Data.Curve' object check for allowed curves if(is(values, "RLum.Data.Curve") == TRUE){ if(!grepl("OSL", values@recordType) & !grepl("IRSL", values@recordType)){ stop(paste("[CW2pLM()] recordType ",values@recordType, " is not allowed for the transformation!", sep=""), call. = FALSE) }else{ temp.values <- as(values, "data.frame") } }else{ temp.values <- values } # Calculation ------------------------------------------------------------- ##curve transformation P<-2*max(temp.values[,1]) u<-((2*temp.values[,1]*P)^0.5) ##cw >> plm conversion, according Bulur, 2000 temp.values[,2]<-temp.values[,2]*(u/P) temp.values<-data.frame(u,temp.values[,2]) # Return values ----------------------------------------------------------- ##returns the same data type as the input if(is(values, "data.frame") == TRUE){ values <- temp.values return(values) }else{ newRLumDataCurves.CW2pLM <- set_RLum( class = "RLum.Data.Curve", recordType = values@recordType, data = as.matrix(temp.values), info = values@info) return(newRLumDataCurves.CW2pLM) } } Luminescence/R/install_DevelopmentVersion.R0000644000176200001440000000764313125226556020607 0ustar liggesusers#' Attempts to install the development version of the 'Luminescence' package #' #' This function is a convenient method for installing the development #' version of the R package 'Luminescence' directly from GitHub. #' #' This function uses \code{\link[Luminescence]{github_branches}} to check #' which development branches of the R package 'Luminescence' are currently #' available on GitHub. The user is then prompted to choose one of the branches #' to be installed. It further checks whether the R package 'devtools' is #' currently installed and available on the system. Finally, it prints R code #' to the console that the user can copy and paste to the R console in order #' to install the desired development version of the package.\cr\cr #' #' If \code{force_install=TRUE} the functions checks if 'devtools' is available #' and then attempts to install the chosen development branch via #' \code{\link[devtools]{install_github}}. #' #' @param force_install \code{\link{logical}} (optional): #' If \code{FALSE} (the default) the function produces and prints the required #' code to the console for the user to run manually afterwards. When \code{TRUE} #' and all requirements are fulfilled (see details) this function attempts to install #' the package itself. #' #' @return #' This function requires user input at the command prompt to choose the #' desired development branch to be installed. The required R code to install #' the package is then printed to the console. #' #' @examples #' #' \dontrun{ #' install_DevelopmentVersion() #' } #' #' @export install_DevelopmentVersion <- function(force_install = FALSE) { message("\n[install_DevelopmentVersion]\n") # check which branches are currently available # see ?github_branches for GitHub API implementation branches <- github_branches() index <- NULL # let user pick which branch he wants to install while(is.null(index)) { message(paste0("Which development branch do you want to install? \n", paste0(" [", 1:length(branches$BRANCH), "]: ", branches$BRANCH, collapse = "\n"))) message("\n [0]: ") index <- readline() if (index == 0) return(NULL) if (!index %in% seq_len(length(branches$BRANCH))) index <- NULL cat("\n") } # select the correct branch branch <- branches$BRANCH[as.numeric(index)] if (!force_install) { message("----\n", "Are all prerequisites installed? Make sure to have read\n", "https://github.com/R-Lum/Luminescence/blob/master/README.md\n", "----\n") message("Please copy and run the following code in your R command-line:\n") if (!requireNamespace("devtools", quietly = TRUE)) message("install.packages('devtools')") message(branches$INSTALL[as.numeric(index)], "\n") } else { reply <- NULL while(is.null(reply)) { message("Are all prerequisites installed?", " (https://github.com/R-Lum/Luminescence/blob/master/README.md)\n", " [n/N]: No\n", " [y/Y]: Yes\n") reply <- readline() if (reply == "n" || reply == "N") return(NULL) if (reply != "y" && reply != "Y") reply <- NULL } # check if 'devtools' is available and install if not if (!requireNamespace("devtools", quietly = TRUE)) { message("Please install the 'devtools' package first by running the following command:\n", "install.packages('devtools')") return(NULL) } # detach the 'Luminescence' package try(detach(name = "package:Luminescence", unload = TRUE, force = TRUE), silent = TRUE) # try to unload the dynamic library dynLibs <- sapply(.dynLibs(), function(x) x[["path"]] ) try(dyn.unload(dynLibs[grep("Luminescence", dynLibs)]), silent = TRUE) # install the development version devtools::install_github(paste0("r-lum/luminescence@", branch)) } } Luminescence/R/Second2Gray.R0000644000176200001440000001521413125226556015342 0ustar liggesusers#' Converting equivalent dose values from seconds (s) to gray (Gy) #' #' Conversion of absorbed radiation dose in seconds (s) to the SI unit gray #' (Gy) including error propagation. Normally used for equivalent dose data. #' #' Calculation of De values from seconds (s) to gray (Gy) \deqn{De [Gy] = De #' [s] * Dose Rate [Gy/s])} \cr #' #' Provided calculation error propagation methods for error calculation (with 'se' as the standard error #' and 'DR' of the dose rate of the beta-source):\cr #' #' #' \bold{(1) \code{omit}} (default)\cr #' #' \deqn{se(De) [Gy] = se(De) [s] * DR [Gy/s]} #' #' In this case the standard error of the dose rate of the beta-source is treated as systematic #' (i.e. non-random), it error propagation is omitted. However, the error must be considered during #' calculation of the final age. (cf. Aitken, 1985, pp. 242). This approach can be seen as #' method (2) (gaussian) for the case the (random) standard error of the beta-source calibration is #' 0. Which particular method is requested depends on the situation and cannot be prescriptive. #' #' \bold{(2) \code{gaussian}} error propagation \cr #' #' \deqn{se(De) [Gy] = \sqrt((DR [Gy/s] * se(De) [s])^2 + (De [s] * se(DR) [Gy/s])^2)} #' #' Applicable under the assumption that errors of De and se are uncorrelated. #' #' \bold{(3) \code{absolute}} error propagation \cr #' #' \deqn{se(De) [Gy]= abs(DR [Gy/s] * se(De) [s]) + abs(De [s] * se(DR) [Gy/s])} #' #' Applicable under the assumption that errors of De and se are not uncorrelated. #' #' @param data \code{\link{data.frame}} (\bold{required}): input values, #' structure: data (\code{values[,1]}) and data error (\code{values [,2]}) are #' required #' #' @param dose.rate \code{\linkS4class{RLum.Results}} or \code{\link{data.frame}} or \code{\link{numeric}} #' (\bold{required}): \code{RLum.Results} needs to be orginated from the #' function \code{\link{calc_SourceDoseRate}}, for \code{vector} dose rate in #' Gy/s and dose rate error in Gy/s #' #' @param error.propagation \code{\link{character}} (with default): error propagation method used for error #' calculation (\code{omit}, \code{gaussian} or \code{absolute}), see details for further #' information #' #' @return Returns a \link{data.frame} with converted values. #' #' @note If no or a wrong error propagation method is given, the execution of the function is #' stopped. Furthermore, if a \code{data.frame} is provided for the dose rate values is has to #' be of the same length as the data frame provided with the argument \code{data} #' #' @section Function version: 0.6.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France),\cr Michael Dietze, GFZ Potsdam (Germany),\cr Margret C. Fuchs, HZDR, #' Helmholtz-Institute Freiberg for Resource Technology #' (Germany) #' #' @seealso \code{\link{calc_SourceDoseRate}} #' #' @references #' #' Aitken, M.J., 1985. Thermoluminescence dating. Academic Press. #' #' @keywords manip #' #' @examples #' #' #' ##(A) for known source dose rate at date of measurement #' ## - load De data from the example data help file #' data(ExampleData.DeValues, envir = environment()) #' ## - convert De(s) to De(Gy) #' Second2Gray(ExampleData.DeValues$BT998, c(0.0438,0.0019)) #' #' #' #' #' #' ##(B) for source dose rate calibration data #' ## - calculate source dose rate first #' dose.rate <- calc_SourceDoseRate(measurement.date = "2012-01-27", #' calib.date = "2014-12-19", #' calib.dose.rate = 0.0438, #' calib.error = 0.0019) #' # read example data #' data(ExampleData.DeValues, envir = environment()) #' #' # apply dose.rate to convert De(s) to De(Gy) #' Second2Gray(ExampleData.DeValues$BT998, dose.rate) #' #' @export Second2Gray <- function( data, dose.rate, error.propagation = "omit" ){ # Integrity tests ----------------------------------------------------------------------------- ##(1) data.frame or RLum.Data.Curve object? if(!is(data, "data.frame")){ stop("[Second2Gray()] 'data' object has to be of type 'data.frame'!") } ##(2) numeric, data.frame or RLum.Data.Curve object? if(!is(dose.rate, "numeric") & !is(dose.rate, "RLum.Results") & !is(dose.rate, "data.frame")){ stop("[Second2Gray()] 'dose.rate' object has to be of type 'numeric', 'data.frame' or 'RLum.Results'!") } ##(3) last check to avoid problems if(is(dose.rate, "data.frame")){ if(nrow(dose.rate)!=nrow(data)){ stop("[Second2Gray()] the data frames in 'data' and 'dose.rate' need to be of similar length!") } } ##(4) check for right orginator if(is(dose.rate, "RLum.Results")){ if(dose.rate@originator != "calc_SourceDoseRate"){ stop("[Second2Gray()] Wrong originator for dose.rate 'RLum.Results' object.") }else{ ##check what is what if(!is(get_RLum(dose.rate, data.object = "dose.rate"), "data.frame")){ dose.rate <- data.frame( dose.rate <- as.numeric(get_RLum(dose.rate, data.object = "dose.rate")[1]), dose.rate.error <- as.numeric(get_RLum(dose.rate, data.object = "dose.rate")[2]) ) }else{ dose.rate <- get_RLum(dose.rate, data.object = "dose.rate") } } } # Calculation --------------------------------------------------------------------------------- De.seconds <- data[,1] De.error.seconds <- data[,2] De.gray <- NA De.error.gray <- NA if(is(dose.rate,"data.frame")){ De.gray <- round(De.seconds*dose.rate[,1], digits=2) }else{ De.gray <- round(De.seconds*dose.rate[1], digits=2) } if(error.propagation == "omit"){ if(is(dose.rate,"data.frame")){ De.error.gray <- round(dose.rate[,1]*De.error.seconds, digits=3) }else{ De.error.gray <- round(dose.rate[1]*De.error.seconds, digits=3) } }else if(error.propagation == "gaussian"){ if(is(dose.rate,"data.frame")){ De.error.gray <- round(sqrt((De.seconds*dose.rate[,2])^2+(dose.rate[,1]*De.error.seconds)^2), digits=3) }else{ De.error.gray <- round(sqrt((De.seconds*dose.rate[2])^2+(dose.rate[1]*De.error.seconds)^2), digits=3) } }else if (error.propagation == "absolute"){ if(is(dose.rate,"data.frame")){ De.error.gray <- round(abs(dose.rate[,1] * De.error.seconds) + abs(De.seconds * dose.rate[,2]), digits=3) }else{ De.error.gray <- round(abs(dose.rate[1] * De.error.seconds) + abs(De.seconds * dose.rate[2]), digits=3) } }else{ stop("[Second2Gray()] unsupported error propagation method!" ) } # Return -------------------------------------------------------------------------------------- data <- data.frame(De=De.gray, De.error=De.error.gray) return(data) } Luminescence/R/calc_OSLLxTxRatio.R0000644000176200001440000004374113125226556016466 0ustar liggesusers#' Calculate Lx/Tx ratio for CW-OSL curves #' #' Calculate Lx/Tx ratios from a given set of CW-OSL curves assuming late light background subtraction. #' #' The integrity of the chosen values for the signal and background integral is #' checked by the function; the signal integral limits have to be lower than #' the background integral limits. If a \link{vector} is given as input instead #' of a \link{data.frame}, an artificial \code{data.frame} is produced. The #' error calculation is done according to Galbraith (2002).\cr #' #' \bold{Please note:} In cases where the calculation results in \code{NaN} values (for #' example due to zero-signal, and therefore a division of 0 by 0), these \code{NaN} values are replaced #' by 0. #' #' \bold{sigmab}\cr #' #' The default value of \code{sigmab} is calculated assuming the background is #' constant and \bold{would not} applicable when the background varies as, #' e.g., as observed for the early light substraction method.\cr #' #' \bold{sig0}\cr #' #' This argument allows to add an extra component of error to the final Lx/Tx error value. #' The input will be treated as factor that is multiplied with the already calculated #' LxTx and the result is add up by: #' #' \deqn{se(LxTx) = \sqrt(se(LxTx)^2 + (LxTx * sig0)^2)} #' #' #' \bold{background.count.distribution}\cr #' #' This argument allows selecting the distribution assumption that is used for #' the error calculation. According to Galbraith (2002, 2014) the background #' counts may be overdispersed (i.e. do not follow a poisson distribution, #' which is assumed for the photomultiplier counts). In that case (might be the #' normal case) it has to be accounted for the overdispersion by estimating #' \eqn{\sigma^2} (i.e. the overdispersion value). Therefore the relative #' standard error is calculated as:\cr\cr (a) \code{poisson}\cr #' \deqn{rse(\mu_{S}) \approx \sqrt(Y_{0} + Y_{1}/k^2)/Y_{0} - Y_{1}/k} (b) #' \code{non-poisson}\cr \deqn{rse(\mu_{S}) \approx \sqrt(Y_{0} + Y_{1}/k^2 + #' \sigma^2(1+1/k))/Y_{0} - Y_{1}/k} #' #' \bold{Please note} that when using the early background subtraction method in #' combination with the 'non-poisson' distribution argument, the corresponding Lx/Tx error #' may considerably increase due to a high sigmab value. #' Please check whether this is valid for your data set and if necessary #' consider to provide an own sigmab value using the corresponding argument \code{sigmab}. #' #' @param Lx.data \code{\linkS4class{RLum.Data.Curve}} or \link{data.frame} #' (\bold{required}): requires a CW-OSL shine down curve (x = time, y = counts) #' #' @param Tx.data \code{\linkS4class{RLum.Data.Curve}} or \link{data.frame} #' (optional): requires a CW-OSL shine down curve (x = time, y = counts). If no #' input is given the Tx.data will be treated as \code{NA} and no Lx/Tx ratio #' is calculated. #' #' @param signal.integral \code{\link{vector}} (\bold{required}): vector with the #' limits for the signal integral. #' #' @param signal.integral.Tx \code{\link{vector}} (optional): vector with the #' limits for the signal integral for the Tx curve. If nothing is provided the #' value from \code{signal.integral} is used. #' #' @param background.integral \code{\link{vector}} (\bold{required}): vector with the #' bounds for the background integral. #' #' @param background.integral.Tx \code{\link{vector}} (optional): vector with the #' limits for the background integral for the Tx curve. If nothing is provided the #' value from \code{background.integral} is used. #' #' @param background.count.distribution \code{\link{character}} (with default): sets #' the count distribution assumed for the error calculation. Possible arguments #' \code{poisson} or \code{non-poisson}. See details for further information #' #' @param use_previousBG \code{\link{logical}} (with default): If set to \code{TRUE} the background #' of the Lx-signal is substracted also from the Tx-signal. Please note that in this case separat #' signal integral limits for the Tx signal are not allowed and will be reset. #' #' @param sigmab \code{\link{numeric}} (optional): option to set a manual value for #' the overdispersion (for LnTx and TnTx), used for the Lx/Tx error #' calculation. The value should be provided as absolute squared count values, #' e.g. \code{sigmab = c(300,300)}. Note: If only one value is provided this #' value is taken for both (LnTx and TnTx) signals. #' #' @param sig0 \code{\link{numeric}} (with default): allow adding an extra component of error #' to the final Lx/Tx error value (e.g., instrumental errror, see details). #' #' @param digits \code{\link{integer}} (with default): round numbers to the specified digits. If #' digits is set to \code{NULL} nothing is rounded. #' #' @return Returns an S4 object of type \code{\linkS4class{RLum.Results}}. #' #' Slot \code{data} contains a \code{\link{list}} with the following structure:\cr #' #' \bold{@data}\cr #' $LxTx.table (data.frame) \cr #' .. $ LnLx \cr #' .. $ LnLx.BG \cr #' .. $ TnTx \cr #' .. $ TnTx.BG \cr #' .. $ Net_LnLx \cr #' .. $ Net_LnLx.Error\cr #' .. $ Net_TnTx.Error\cr #' .. $ LxTx\cr #' .. $ LxTx.Error \cr #' $ calc.parameters (list) \cr #' .. $ sigmab.LnTx\cr #' .. $ sigmab.TnTx\cr #' .. $ k \cr #' #' \bold{@info}\cr #' $ call (original function call)\cr #' #' @note The results of this function have been cross-checked with the Analyst #' (vers. 3.24b). Access to the results object via \code{\link{get_RLum}}.\cr #' #' \bold{Caution:} If you are using early light subtraction (EBG), please either provide your #' own \code{sigmab} value or use \code{background.count.distribution = "poisson"}. #' #' #' @section Function version: 0.7.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\linkS4class{RLum.Data.Curve}}, #' \code{\link{Analyse_SAR.OSLdata}}, \code{\link{plot_GrowthCurve}}, #' \code{\link{analyse_SAR.CWOSL}} #' #' @references Duller, G., 2007. Analyst. #' \url{http://www.nutech.dtu.dk/english/~/media/Andre_Universitetsenheder/Nutech/Produkter\%20og\%20services/Dosimetri/radiation_measurement_instruments/tl_osl_reader/Manuals/analyst_manual_v3_22b.ashx}\cr #' #' Galbraith, R.F., 2002. A note on the variance of a background-corrected OSL #' count. Ancient TL, 20 (2), 49-51. #' #' Galbraith, R.F., 2014. A further note on the variance of a #' background-corrected OSL count. Ancient TL, 31 (2), 1-3. #' #' @keywords datagen #' #' @examples #' #' ##load data #' data(ExampleData.LxTxOSLData, envir = environment()) #' #' ##calculate Lx/Tx ratio #' results <- calc_OSLLxTxRatio(Lx.data, Tx.data, signal.integral = c(1:2), #' background.integral = c(85:100)) #' #' ##get results object #' get_RLum(results) #' #' @export calc_OSLLxTxRatio <- function( Lx.data, Tx.data = NULL, signal.integral, signal.integral.Tx = NULL, background.integral, background.integral.Tx = NULL, background.count.distribution = "non-poisson", use_previousBG = FALSE, sigmab = NULL, sig0 = 0, digits = NULL ){ ##--------------------------------------------------------------------------## ##(1) - integrity checks if(!is.null(Tx.data)){ ##(a) - check data type if(is(Lx.data)[1]!=is(Tx.data)[1]){ stop("[calc_OSLLxTxRatio()] Data type of Lx and Tx data differs!") } ##(b) - test if data.type is valid in general if(is(Lx.data)[1] == "RLum.Data.Curve"){ Lx.data <- as(Lx.data, "data.frame") Tx.data <- as(Tx.data, "data.frame") }else{ ##go further if((is(Lx.data)[1] != "data.frame" & is(Lx.data)[1] != "numeric") & is(Lx.data)[1] != "matrix"){ stop("[calc_OSLLxTxRatio()] Data type error! Required types are data.frame or numeric vector.") } } ##(c) - convert vector to data.frame if nescessary if(is(Lx.data)[1] != "data.frame" & is(Lx.data)[1] != "matrix"){ Lx.data <- data.frame(x=1:length(Lx.data),y=Lx.data) Tx.data <- data.frame(x=1:length(Tx.data),y=Tx.data) } ##(d) - check if Lx and Tx curves have the same channel length if(length(Lx.data[,2]) != length(Tx.data[,2])){ stop("[calc_OSLLxTxRatio()] Channel numbers of Lx and Tx data differ!")} }else{ Tx.data <- data.frame(x = NA,y = NA) ##support RLum.objects if(is(Lx.data)[1] == "RLum.Data.Curve"){ Lx.data <- as(Lx.data, "data.frame") } ##check for matrix if(is(Lx.data)[1] == "matrix"){ Lx.data <- as.data.frame(Lx.data) } ##no it should be a data.frame, if not, try to produce one if(is(Lx.data)[1]!="data.frame") { Lx.data <- data.frame(x = 1:length(Lx.data),y = Lx.data) } }#endif::missing Tx.data ##(e) - check if signal integral is valid if(min(signal.integral) < 1 | max(signal.integral>length(Lx.data[,2]))){ stop("[calc_OSLLxTxRatio()] signal.integral is not valid!")} ##(f) - check if background integral is valid if(min(background.integral)<1 | max(background.integral>length(Lx.data[,2]))){ stop(paste("[calc_OSLLxTxRatio()] background.integral is not valid! Max: ",length(Lx.data[,2]),sep=""))} ##(g) - check if signal and background integral overlapping if(min(background.integral)<=max(signal.integral)){ stop("[calc_OSLLxTxRatio()] Overlapping of 'signal.integral' and 'background.integral' is not permitted!")} ##(h) - similar procedure for the Tx limits if(all(c(!is.null(signal.integral.Tx),!is.null(background.integral.Tx)))){ if(use_previousBG){ warning("[calc_OSLLxTxRatio()] For option use_previousBG = TRUE independent Lx and Tx integral limits are not allowed. Integral limits of Lx used for Tx.", call. = FALSE) signal.integral.Tx <- signal.integral background.integral.Tx <- background.integral } if(min(signal.integral.Tx) < 1 | max(signal.integral.Tx>length(Tx.data[,2]))){ stop("[calc_OSLLxTxRatio()] signal.integral.Tx is not valid!")} if(min(background.integral.Tx)<1 | max(background.integral.Tx>length(Tx.data[,2]))){ stop(paste("[calc_OSLLxTxRatio()] background.integral.Tx is not valid! Max: ",length(Tx.data[,2]),sep=""))} if(min(background.integral.Tx)<=max(signal.integral.Tx)){ stop("[calc_OSLLxTxRatio()] Overlapping of 'signal.integral.Tx' and 'background.integral.Tx' is not permitted!")} } else if(!all(c(is.null(signal.integral.Tx),is.null(background.integral.Tx)))){ stop("[calc_OSLLxTxRatio()] You have to provide both: signal.integral.Tx and background.integral.Tx!") }else{ signal.integral.Tx <- signal.integral background.integral.Tx <- background.integral } ##check sigmab if (!is.null(sigmab)) { if (!is(sigmab, "numeric")) { stop("[calc_OSLLxTxRatio()] 'sigmab' has to be of type numeric.") } if (length(sigmab) > 2) { stop("[calc_OSLLxTxRatio()] Maximum allowed vector length for 'sigmab' is 2.") } } ##--------------------------------------------------------------------------## ##(2) - read data and produce background subtracted values ## calculate k value - express the background as mutiple value from the number ## of signal integral channels, however, it can be < 1 also n <- length(signal.integral) m <- length(background.integral) k <- m/n n.Tx <- length(signal.integral.Tx) ##use previous BG and account for the option to set different integral limits if(use_previousBG){ m.Tx <- m }else{ m.Tx <- length(background.integral.Tx) } k.Tx <- m.Tx/n.Tx ##LnLx (comments are corresponding variables to Galbraith, 2002) Lx.curve <- Lx.data[,2] Lx.signal <- sum(Lx.curve[signal.integral]) #Y.0 Lx.background <- sum(Lx.curve[background.integral]) #Y.1 Lx.background <- Lx.background*1/k #mu.B LnLx <- Lx.signal - Lx.background ##TnTx Tx.curve <- ifelse(is.na(Tx.data[,1])==FALSE, Tx.data[,2], NA) Tx.signal <- sum(Tx.curve[signal.integral.Tx]) ##use previous BG if(use_previousBG){ Tx.background <- Lx.background }else{ Tx.background <- sum(Tx.curve[background.integral.Tx])*1/k.Tx } TnTx <- (Tx.signal-Tx.background) ##--------------------------------------------------------------------------## ##(3) ## calculate Lx/Tx Errors according Galbraith (2002) and the personal ## communication of Galbraith (2014) via e-mail ## Nomenclature as stated in the articles ##(a) ## set Y.0 (sum OSL signal including the background) and ## Y.1 (total counts over m later channels) Y.0 <- Lx.signal Y.0_TnTx <- Tx.signal Y.1 <- sum(Lx.curve[background.integral]) Y.1_TnTx <- sum(Tx.curve[background.integral.Tx]) ##(b) estimate overdispersion (here called sigmab), see equation (4) in ## Galbraith (2002), Galbraith (2014) ## If else condition for the case that k < 2 if(round(k,digits = 1) >= 2 & ((min(background.integral) + length(signal.integral)*(2+1)) <= length(Lx.curve))){ ##(b)(1)(1) ## note that m = n*k = multiple of background.integral from signal.integral Y.i <- vapply(0:round(k,digits=0), function(i){ sum(Lx.curve[ (min(background.integral)+length(signal.integral)*i): (min(background.integral)+length(signal.integral)+length(signal.integral)*i)]) }, FUN.VALUE = vector(mode = "numeric", length = 1L)) Y.i <- na.exclude(Y.i) sigmab.LnLx <- abs(var(Y.i) - mean(Y.i)) ##sigmab is denoted as sigma^2 = s.Y^2-Y.mean ##therefore here absolute values are given }else{ ## provide warning if m is < 25, as suggested by Rex Galbraith ## low number of degree of freedom if (m < 25) { warning("[calc_OSLLxTxRatio()] Number of background channels for Lx < 25; error estimation might be not reliable!", call. = FALSE) } sigmab.LnLx <- abs((var(Lx.curve[background.integral]) - mean(Lx.curve[background.integral])) * n) } if (round(k.Tx, digits = 1) >= 2 & (( min(background.integral.Tx) + length(signal.integral.Tx) * (2 + 1) ) <= length(Tx.curve))) { ##(b)(1)(1) ## note that m.Tx = n.Tx*k.Tx = multiple of background.integral.Tx from signal.integral.Tx ## also for the TnTx signal Y.i_TnTx <- vapply(0:round(k.Tx, digits = 0), function(i) { sum(Tx.curve[(min(background.integral.Tx) + length(signal.integral.Tx) * i):( min(background.integral.Tx) + length(signal.integral.Tx) + length(signal.integral.Tx) * i )]) }, FUN.VALUE = vector(mode = "numeric", length = 1L)) Y.i_TnTx <- na.exclude(Y.i_TnTx) sigmab.TnTx <- abs(var(Y.i_TnTx) - mean(Y.i_TnTx)) } else{ ## provide warning if m is < 25, as suggested by Rex Galbraith ## low number of degree of freedom if (m.Tx < 25 && use_previousBG == FALSE) { warning("[calc_OSLLxTxRatio()] Number of background channels for Tx < 25; error estimation might be not reliable!", call. = FALSE) } sigmab.TnTx <- abs((var(Tx.curve[background.integral.Tx]) - mean(Tx.curve[background.integral.Tx])) * n.Tx) } ##account for a manually set sigmab value if (!is.null(sigmab)) { if (length(sigmab) == 2) { sigmab.LnLx <- sigmab[1] sigmab.TnTx <- sigmab[2] }else{ sigmab.LnLx <- sigmab[1] sigmab.TnTx <- sigmab[1] } } ##(c) ## Calculate relative error of the background subtracted signal ## according to Galbratith (2002), equation (6) with changes ## from Galbraith (2014), equation 6 ## Discussion with Rex Galbraith via e-mail (2014-02-27): ## Equation 6 is approriate to be implemented as standard if(background.count.distribution == "poisson"){ ##(c.1) estimate relative standard error for assuming a poisson distribution LnLx.relError <- sqrt((Y.0 + Y.1/k^2))/(Y.0-Y.1/k) ## rse(mu.s) TnTx.relError <- sqrt((Y.0_TnTx + Y.1_TnTx/k^2))/(Y.0_TnTx-Y.1_TnTx/k) }else{ ##(c.2) estimate relative standard error for a non-poisson distribution if(background.count.distribution != "non-poisson"){ warning("Unknown method for background.count.distribution. A non-poisson distribution is assumed!")} LnLx.relError <- sqrt(Y.0 + Y.1/k^2 + sigmab.LnLx*(1+1/k))/ (Y.0 - Y.1/k) TnTx.relError <- sqrt(Y.0_TnTx + Y.1_TnTx/k^2 + sigmab.TnTx*(1+1/k))/ (Y.0_TnTx - Y.1_TnTx/k) } ##(d) ##calculate absolute standard error LnLx.Error <- abs(LnLx*LnLx.relError) TnTx.Error <- abs(TnTx*TnTx.relError) ##we do not want to have NaN values, as they are mathematically correct, but make ##no sense and would result in aliquots that become rejected later if(is.nan(LnLx.Error)) LnLx.Error <- 0 if(is.nan(TnTx.Error)) TnTx.Error <- 0 ##combine results LnLxTnTx <- cbind( Lx.signal, Lx.background, Tx.signal, Tx.background, LnLx, LnLx.Error, TnTx, TnTx.Error ) ##--------------------------------------------------------------------------## ##(4) Calculate LxTx error according Galbraith (2014) #transform results in a data.frame LnLxTnTx <- as.data.frame((LnLxTnTx)) #add col names colnames(LnLxTnTx)<-c("LnLx", "LnLx.BG", "TnTx", "TnTx.BG", "Net_LnLx", "Net_LnLx.Error", "Net_TnTx", "Net_TnTx.Error") ##calculate Ln/Tx LxTx <- LnLxTnTx$Net_LnLx/LnLxTnTx$Net_TnTx ##set NaN if(is.nan(LxTx)) LxTx <- 0 ##calculate Ln/Tx error LxTx.relError <- sqrt(LnLx.relError^2 + TnTx.relError^2) LxTx.Error <- abs(LxTx * LxTx.relError) ##set NaN if(is.nan(LxTx.Error)) LxTx.Error <- 0 ##add an extra component of error LxTx.Error <- sqrt(LxTx.Error^2 + (sig0 * LxTx)^2) ##return combined values temp <- cbind(LnLxTnTx,LxTx,LxTx.Error) ##apply digits if wanted if(!is.null(digits)){ temp[1,] <- round(temp[1,], digits = digits) } calc.parameters <- list(sigmab.LnLx = sigmab.LnLx, sigmab.TnTx = sigmab.TnTx, k = k) ##set results object temp.return <- set_RLum( class = "RLum.Results", data = list( LxTx.table = temp, calc.parameters = calc.parameters), info = list(call = sys.call()) ) invisible(temp.return) } Luminescence/R/plot_RadialPlot.R0000644000176200001440000015720113125226556016316 0ustar liggesusers#' Function to create a Radial Plot #' #' A Galbraith's radial plot is produced on a logarithmic or a linear scale. #' #' Details and the theoretical background of the radial plot are given in the #' cited literature. This function is based on an S script of Rex Galbraith. To #' reduce the manual adjustments, the function has been rewritten. Thanks to #' Rex Galbraith for useful comments on this function. \cr Plotting can be #' disabled by adding the argument \code{plot = "FALSE"}, e.g. to return only #' numeric plot output.\cr #' #' Earlier versions of the Radial Plot in this package had the 2-sigma-bar #' drawn onto the z-axis. However, this might have caused misunderstanding in #' that the 2-sigma range may also refer to the z-scale, which it does not! #' Rather it applies only to the x-y-coordinate system (standardised error vs. #' precision). A spread in doses or ages must be drawn as lines originating at #' zero precision (x0) and zero standardised estimate (y0). Such a range may be #' drawn by adding lines to the radial plot ( \code{line}, \code{line.col}, #' \code{line.label}, cf. examples).\cr\cr #' #' 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: \code{"n"} (number of samples), #' \code{"mean"} (mean De value), \code{"mean.weighted"} (error-weighted mean), #' \code{"median"} (median of the De values), \code{"sdrel"} (relative standard #' deviation in percent), \code{"sdrel.weighted"} (error-weighted relative #' standard deviation in percent), \code{"sdabs"} (absolute standard deviation), #' \code{"sdabs.weighted"} (error-weighted absolute standard deviation), #' \code{"serel"} (relative standard error), \code{"serel.weighted"} ( #' error-weighted relative standard error), \code{"seabs"} (absolute standard #' error), \code{"seabs.weighted"} (error-weighted absolute standard error), #' \code{"in.2s"} (percent of samples in 2-sigma range), #' \code{"kurtosis"} (kurtosis) and \code{"skewness"} (skewness). #' #' @param data \code{\link{data.frame}} or \code{\linkS4class{RLum.Results}} #' object (required): for \code{data.frame} two columns: De (\code{data[,1]}) #' and De error (\code{data[,2]}). To plot several data sets in one plot, the #' data sets must be provided as \code{list}, e.g. \code{list(data.1, data.2)}. #' @param na.rm \code{\link{logical}} (with default): excludes \code{NA} #' values from the data set prior to any further operations. #' @param log.z \code{\link{logical}} (with default): Option to display the #' z-axis in logarithmic scale. Default is \code{TRUE}. #' @param central.value \code{\link{numeric}}: User-defined central value, #' primarily used for horizontal centering of the z-axis. #' @param centrality \code{\link{character}} or \code{\link{numeric}} (with #' default): measure of centrality, used for automatically centering the plot #' and drawing the central line. Can either be one out of \code{"mean"}, #' \code{"median"}, \code{"mean.weighted"} and \code{"median.weighted"} or a #' numeric value used for the standardisation. #' @param mtext \code{\link{character}}: additional text below the plot title. #' @param summary \code{\link{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 \code{\link{numeric}} or \code{\link{character}} (with #' default): optional position coordinates or keyword (e.g. \code{"topright"}) #' for the statistical summary. Alternatively, the keyword \code{"sub"} may be #' specified to place the summary below the plot header. However, this latter #' option is only possible if \code{mtext} is not used. #' @param legend \code{\link{character}} vector (optional): legend content to #' be added to the plot. #' @param legend.pos \code{\link{numeric}} or \code{\link{character}} (with #' default): optional position coordinates or keyword (e.g. \code{"topright"}) #' for the legend to be plotted. #' @param stats \code{\link{character}}: additional labels of statistically #' important values in the plot. One or more out of the following: #' \code{"min"}, \code{"max"}, \code{"median"}. #' @param rug \code{\link{logical}}: Option to add a rug to the z-scale, to #' indicate the location of individual values #' @param plot.ratio \code{\link{numeric}}: User-defined plot area ratio (i.e. #' curvature of the z-axis). If omitted, the default value (\code{4.5/5.5}) is #' used and modified automatically to optimise the z-axis curvature. The #' parameter should be decreased when data points are plotted outside the #' z-axis or when the z-axis gets too elliptic. #' @param bar.col \code{\link{character}} or \code{\link{numeric}} (with #' default): colour of the bar showing the 2-sigma range around the central #' value. To disable the bar, use \code{"none"}. Default is \code{"grey"}. #' @param y.ticks \code{\link{logical}}: Option to hide y-axis labels. Useful #' for data with small scatter. #' @param grid.col \code{\link{character}} or \code{\link{numeric}} (with #' default): colour of the grid lines (originating at [0,0] and stretching to #' the z-scale). To disable grid lines, use \code{"none"}. Default is #' \code{"grey"}. #' @param line \code{\link{numeric}}: numeric values of the additional lines to #' be added. #' @param line.col \code{\link{character}} or \code{\link{numeric}}: colour of #' the additional lines. #' @param line.label \code{\link{character}}: labels for the additional lines. #' @param output \code{\link{logical}}: Optional output of numerical plot #' parameters. These can be useful to reproduce similar plots. Default is #' \code{FALSE}. #' @param \dots Further plot arguments to pass. \code{xlab} must be a vector of #' length 2, specifying the upper and lower x-axes labels. #' @return Returns a plot object. #' @section Function version: 0.5.4 #' @author Michael Dietze, GFZ Potsdam (Germany),\cr Sebastian Kreutzer, #' IRAMAT-CRP2A, Universite Bordeaux Montaigne (France)\cr Based on a rewritten #' S script of Rex Galbraith, 2010 #' @seealso \code{\link{plot}}, \code{\link{plot_KDE}}, #' \code{\link{plot_Histogram}} #' @references Galbraith, R.F., 1988. Graphical Display of Estimates Having #' Differing Standard Errors. Technometrics, 30 (3), 271-281. #' #' Galbraith, R.F., 1990. The radial plot: Graphical assessment of spread in #' ages. International Journal of Radiation Applications and Instrumentation. #' Part D. Nuclear Tracks and Radiation Measurements, 17 (3), 207-214. #' #' 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. #' #' Galbraith, R.F. & Laslett, G.M., 1993. Statistical models for mixed fission #' track ages. Nuclear Tracks And Radiation Measurements, 21 (4), 459-470. #' #' Galbraith, R.F., 1994. Some Applications of Radial Plots. Journal of the #' American Statistical Association, 89 (428), 1232-1242. #' #' Galbraith, R.F., 2010. On plotting OSL equivalent doses. Ancient TL, 28 (1), #' 1-10. #' #' 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. #' @examples #' #' ## load example data #' data(ExampleData.DeValues, envir = environment()) #' ExampleData.DeValues <- Second2Gray(ExampleData.DeValues$BT998, c(0.0438,0.0019)) #' #' ## plot the example data straightforward #' plot_RadialPlot(data = ExampleData.DeValues) #' #' ## now with linear z-scale #' plot_RadialPlot(data = ExampleData.DeValues, #' log.z = FALSE) #' #' ## now with output of the plot parameters #' plot1 <- plot_RadialPlot(data = ExampleData.DeValues, #' log.z = FALSE, #' output = TRUE) #' plot1 #' plot1$zlim #' #' ## now with adjusted z-scale limits #' plot_RadialPlot(data = ExampleData.DeValues, #' log.z = FALSE, #' zlim = c(100, 200)) #' #' ## now the two plots with serious but seasonally changing fun #' #plot_RadialPlot(data = data.3, fun = TRUE) #' #' ## now with user-defined central value, in log-scale again #' plot_RadialPlot(data = ExampleData.DeValues, #' central.value = 150) #' #' ## now with a rug, indicating individual De values at the z-scale #' plot_RadialPlot(data = ExampleData.DeValues, #' rug = TRUE) #' #' ## now with legend, colour, different points and smaller scale #' plot_RadialPlot(data = ExampleData.DeValues, #' legend.text = "Sample 1", #' col = "tomato4", #' bar.col = "peachpuff", #' pch = "R", #' cex = 0.8) #' #' ## now without 2-sigma bar, y-axis, grid lines and central value line #' plot_RadialPlot(data = ExampleData.DeValues, #' bar.col = "none", #' grid.col = "none", #' y.ticks = FALSE, #' lwd = 0) #' #' ## now with user-defined axes labels #' plot_RadialPlot(data = ExampleData.DeValues, #' xlab = c("Data error (%)", #' "Data precision"), #' ylab = "Scatter", #' zlab = "Equivalent dose [Gy]") #' #' ## now with minimum, maximum and median value indicated #' plot_RadialPlot(data = ExampleData.DeValues, #' central.value = 150, #' stats = c("min", "max", "median")) #' #' ## now with a brief statistical summary #' plot_RadialPlot(data = ExampleData.DeValues, #' summary = c("n", "in.2s")) #' #' ## now with another statistical summary as subheader #' plot_RadialPlot(data = ExampleData.DeValues, #' summary = c("mean.weighted", "median"), #' summary.pos = "sub") #' #' ## now the data set is split into sub-groups, one is manipulated #' data.1 <- ExampleData.DeValues[1:15,] #' data.2 <- ExampleData.DeValues[16:25,] * 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_RadialPlot(data = data.3) #' #' ## now with some graphical modification #' plot_RadialPlot(data = data.3, #' col = c("darkblue", "darkgreen"), #' bar.col = c("lightblue", "lightgreen"), #' pch = c(2, 6), #' summary = c("n", "in.2s"), #' summary.pos = "sub", #' legend = c("Sample 1", "Sample 2")) #' #' @export plot_RadialPlot <- function( data, na.rm = TRUE, log.z = TRUE, central.value, centrality = "mean.weighted", mtext, summary, summary.pos, legend, legend.pos, stats, rug = FALSE, plot.ratio, bar.col, y.ticks = TRUE, grid.col, line, line.col, line.label, output = FALSE, ... ) { ## Homogenise input data format if(is(data, "list") == FALSE) {data <- list(data)} ## Check input data for(i in 1:length(data)) { if(is(data[[i]], "RLum.Results") == FALSE & is(data[[i]], "data.frame") == FALSE) { stop(paste("[plot_RadialPlot] Error: Input data format is neither", "'data.frame' nor 'RLum.Results'")) } else { if(is(data[[i]], "RLum.Results") == TRUE) { data[[i]] <- get_RLum(data[[i]], "data") } } } ## check data and parameter consistency-------------------------------------- if(missing(stats) == TRUE) {stats <- numeric(0)} if(missing(summary) == TRUE) { summary <- c("n", "in.2s") } if(missing(summary.pos) == TRUE) { summary.pos <- "sub" } if(missing(bar.col) == TRUE) { bar.col <- rep("grey80", length(data)) } if(missing(grid.col) == TRUE) { grid.col <- rep("grey70", length(data)) } if(missing(summary) == TRUE) { summary <- NULL } if(missing(summary.pos) == TRUE) { summary.pos <- "topleft" } if(missing(mtext) == TRUE) { mtext <- "" } ## check z-axis log-option for grouped data sets if(is(data, "list") == TRUE & length(data) > 1 & log.z == FALSE) { warning(paste("Option 'log.z' is not set to 'TRUE' altough more than one", "data set (group) is provided.")) } ## optionally, remove NA-values if(na.rm == TRUE) { for(i in 1:length(data)) { data[[i]] <- na.exclude(data[[i]]) } } ## 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)) { limits.z <- extraArgs$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(test = min(De.global) <= 0, yes = 1.1, no = 0.9) - z.span) * min(De.global), (1.1 + z.span) * max(De.global)) } ticks <- round(pretty(limits.z, n = 5), 3) De.delta <- ticks[2] - ticks[1] ## calculate correction dose to shift negative values 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 } } } else { De.add <- 0 } ## optionally add correction dose to data set and adjust error if(log.z == TRUE) { for(i in 1:length(data)) { data[[i]][,1] <- data[[i]][,1] + De.add } De.global <- De.global + De.add } ## calculate major preliminary tick values and tick difference extraArgs <- list(...) if("zlim" %in% names(extraArgs)) { limits.z <- extraArgs$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)) } ticks <- round(pretty(limits.z, n = 5), 3) De.delta <- ticks[2] - ticks[1] ## calculate and append statistical measures -------------------------------- ## z-values based on log-option z <- lapply(1:length(data), function(x){ if(log.z == TRUE) {log(data[[x]][,1])} else {data[[x]][,1]}}) if(is(z, "list") == FALSE) {z <- list(z)} data <- lapply(1:length(data), function(x) { cbind(data[[x]], z[[x]])}) rm(z) ## calculate se-values 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) if(is(se, "list") == FALSE) {se <- list(se)} data <- lapply(1:length(data), function(x) { cbind(data[[x]], se[[x]])}) rm(se) ## calculate central values if(centrality[1] == "mean") { z.central <- lapply(1:length(data), function(x){ rep(mean(data[[x]][,3], na.rm = TRUE), length(data[[x]][,3]))}) } else if(centrality[1] == "median") { z.central <- lapply(1:length(data), function(x){ rep(median(data[[x]][,3], na.rm = TRUE), length(data[[x]][,3]))}) } else if(centrality[1] == "mean.weighted") { z.central <- lapply(1:length(data), function(x){ sum(data[[x]][,3] / data[[x]][,4]^2) / sum(1 / data[[x]][,4]^2)}) } else if(centrality[1] == "median.weighted") { ## define function after isotone::weighted.median median.w <- function (y, w) { ox <- order(y) y <- y[ox] w <- w[ox] k <- 1 low <- cumsum(c(0, w)) up <- sum(w) - low df <- low - up repeat { if (df[k] < 0) k <- k + 1 else if (df[k] == 0) return((w[k] * y[k] + w[k - 1] * y[k - 1]) / (w[k] + w[k - 1])) else return(y[k - 1]) } } z.central <- lapply(1:length(data), function(x){ rep(median.w(y = data[[x]][,3], w = data[[x]][,4]), length(data[[x]][,3]))}) } else if(is.numeric(centrality) == TRUE & length(centrality) == length(data)) { z.central.raw <- if(log.z == TRUE) { log(centrality + De.add) } else { centrality + De.add } z.central <- lapply(1:length(data), function(x){ rep(z.central.raw[x], length(data[[x]][,3]))}) } else if(is.numeric(centrality) == TRUE & length(centrality) > length(data)) { z.central <- lapply(1:length(data), function(x){ rep(median(data[[x]][,3], na.rm = TRUE), length(data[[x]][,3]))}) } else { stop("Measure of centrality not supported!") } 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]}) if(is(precision, "list") == FALSE) {precision <- list(precision)} data <- lapply(1:length(data), function(x) { cbind(data[[x]], precision[[x]])}) rm(precision) ## calculate standard estimate std.estimate <- lapply(1:length(data), function(x){ (data[[x]][,3] - data[[x]][,5]) / data[[x]][,4]}) if(is(std.estimate, "list") == FALSE) {std.estimate <- list(std.estimate)} 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) ## generate global data set data.global <- cbind(data[[1]], rep(x = 1, times = nrow(data[[1]]))) colnames(data.global) <- rep("", 9) 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("", 9) 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") ## calculate global central value if(centrality[1] == "mean") { z.central.global <- mean(data.global[,3], na.rm = TRUE) } else if(centrality[1] == "median") { z.central.global <- median(data.global[,3], na.rm = TRUE) } else if(centrality[1] == "mean.weighted") { z.central.global <- sum(data.global[,3] / data.global[,4]^2) / sum(1 / data.global[,4]^2) } else if(centrality[1] == "median.weighted") { ## define function after isotone::weighted.mean median.w <- function (y, w) { ox <- order(y) y <- y[ox] w <- w[ox] k <- 1 low <- cumsum(c(0, w)) up <- sum(w) - low df <- low - up repeat { if (df[k] < 0) k <- k + 1 else if (df[k] == 0) return((w[k] * y[k] + w[k - 1] * y[k - 1])/(w[k] + w[k - 1])) else return(y[k - 1]) } } z.central.global <- median.w(y = data.global[,3], w = data.global[,4]) } else if(is.numeric(centrality) == TRUE & length(centrality == length(data))) { z.central.global <- mean(data.global[,3], na.rm = TRUE) } ## optionally adjust zentral value by user-defined value if(missing(central.value) == FALSE) { # ## adjust central value for De.add central.value <- central.value + De.add z.central.global <- ifelse(log.z == TRUE, log(central.value), central.value) } ## 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") } ## 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 warning for too small scatter if(max(abs(1 / data.global[6])) < 0.02) { small.sigma <- TRUE print(paste("Attention, small standardised estimate scatter.", "Toggle off y.ticks?")) } ## 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) { stop("Argmuent xlab is not of length 2!") } else {xlab <- extraArgs$xlab} } else { xlab <- c(if(log.z == TRUE) { "Relative standard error (%)" } else { "Standard error" }, "Precision") } 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)) { 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)) { limits.x <- extraArgs$xlim } else { limits.x <- c(0, max(data.global[,6])) } if(limits.x[1] != 0) { limits.x[1] <- 0 warning("Lower x-axis limit not set to zero, issue corrected!") } if("ylim" %in% names(extraArgs)) { limits.y <- extraArgs$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])), (0.8 + 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(2, length(data)) } lwd <- if("lwd" %in% names(extraArgs)) { extraArgs$lwd } else { rep(1, length(data)) } pch <- if("pch" %in% names(extraArgs)) { extraArgs$pch } else { rep(1, length(data)) } col <- if("col" %in% names(extraArgs)) { extraArgs$col } else { 1:length(data) } tck <- if("tck" %in% names(extraArgs)) { extraArgs$tck } else { NA } tcl <- if("tcl" %in% names(extraArgs)) { extraArgs$tcl } else { -0.5 } show <- if("show" %in% names(extraArgs)) {extraArgs$show} else {TRUE} if(show != TRUE) {show <- FALSE} fun <- if("fun" %in% names(extraArgs)) { extraArgs$fun } else { FALSE } ## define auxiliary plot parameters ----------------------------------------- ## optionally adjust plot ratio if(missing(plot.ratio) == TRUE) { if(log.z == TRUE) { plot.ratio <- 1 / (1 * ((max(data.global[,6]) - min(data.global[,6])) / (max(data.global[,7]) - min(data.global[,7])))) } else { plot.ratio <- 4.5 / 5.5 } } if(plot.ratio > 10^6) {plot.ratio <- 10^6} ## calculate conversion factor for plot coordinates f <- (max(data.global[,6]) - min(data.global[,6])) / (max(data.global[,7]) - min(data.global[,7])) * plot.ratio ## calculate major and minor z-tick values 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 == TRUE) { tick.values.major <- log(tick.values.major) tick.values.minor <- log(tick.values.minor) } ## calculate z-axis radius r.x <- limits.x[2] / max(data.global[,6]) + 0.05 r <- max(sqrt((data.global[,6])^2+(data.global[,7] * f)^2)) * r.x ## calculate major z-tick coordinates tick.x1.major <- r / sqrt(1 + f^2 * ( tick.values.major - z.central.global)^2) tick.y1.major <- (tick.values.major - z.central.global) * tick.x1.major tick.x2.major <- (1 + 0.015 * cex) * r / sqrt( 1 + f^2 * (tick.values.major - z.central.global)^2) tick.y2.major <- (tick.values.major - z.central.global) * tick.x2.major ticks.major <- cbind(tick.x1.major, tick.x2.major, tick.y1.major, tick.y2.major) ## calculate minor z-tick coordinates tick.x1.minor <- r / sqrt(1 + f^2 * ( tick.values.minor - z.central.global)^2) tick.y1.minor <- (tick.values.minor - z.central.global) * tick.x1.minor tick.x2.minor <- (1 + 0.007 * cex) * r / sqrt( 1 + f^2 * (tick.values.minor - z.central.global)^2) tick.y2.minor <- (tick.values.minor - z.central.global) * tick.x2.minor ticks.minor <- cbind(tick.x1.minor, tick.x2.minor, tick.y1.minor, tick.y2.minor) ## calculate z-label positions label.x <- 1.03 * r / sqrt(1 + f^2 * (tick.values.major - z.central.global)^2) label.y <- (tick.values.major - z.central.global) * tick.x2.major ## create z-axes labels if(log.z == TRUE) { label.z.text <- signif(exp(tick.values.major), 3) } else { label.z.text <- signif(tick.values.major, 3) } ## subtract De.add from label values if(De.add != 0) { label.z.text <- label.z.text - De.add } labels <- cbind(label.x, label.y, label.z.text) ## calculate coordinates for 2-sigma-polygon overlay polygons <- matrix(nrow = length(data), ncol = 8) for(i in 1:length(data)) { polygons[i,1:4] <- c(limits.x[1], limits.x[1], max(data.global[,6]), max(data.global[,6])) polygons[i,5:8] <- c(-2, 2, (data[[i]][1,5] - z.central.global) * polygons[i,3] + 2, (data[[i]][1,5] - z.central.global) * polygons[i,4] - 2) } ## calculate node coordinates for semi-circle user.limits <- if(log.z == TRUE) { log(limits.z) } else{ limits.z } ellipse.values <- seq(from = min(c(tick.values.major, tick.values.minor, user.limits[2])), to = max(c(tick.values.major, tick.values.minor, user.limits[2])), length.out = 500) ellipse.x <- r / sqrt(1 + f^2 * (ellipse.values - z.central.global)^2) ellipse.y <- (ellipse.values - z.central.global) * ellipse.x ellipse <- cbind(ellipse.x, ellipse.y) ellipse.lims <- rbind(range(ellipse[,1]), range(ellipse[,2])) ## check if z-axis overlaps with 2s-polygon polygon_y_max <- max(polygons[,7]) polygon_y_min <- min(polygons[,7]) z_2s_upper <- ellipse.x[abs(ellipse.y - polygon_y_max) == min(abs(ellipse.y - polygon_y_max))] z_2s_lower <- ellipse.x[abs(ellipse.y - polygon_y_min) == min(abs(ellipse.y - polygon_y_min))] if(max(polygons[,3]) >= z_2s_upper | max(polygons[,3]) >= z_2s_lower) { print("[plot_RadialPlot] Warning: z-scale touches 2s-polygon. Decrease plot ratio.") } ## 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] } ## recalculate axes limits if necessary limits.z.x <- range(ellipse[,1]) limits.z.y <- range(ellipse[,2]) 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(!("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 = 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)) { data_to_stats <- data[[i]] data_to_stats$De <- data_to_stats$De - De.add statistics <- calc_Statistics(data = data_to_stats) 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[[i]][,1], 0.25) De.stats[i,12] <- quantile(data[[i]][,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.density <- try(density(x = data[[i]][,1], kernel = "gaussian", from = limits.z[1], to = limits.z[2]), silent = TRUE) if(class(De.density) == "try-error") { De.stats[i,6] <- NA } else { 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("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 = ""), ""), 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("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 = ""), ""), 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 if(missing(summary.pos) == TRUE) { summary.pos <- c(limits.x[1], limits.y[2]) summary.adj <- c(0, 1) } else if(length(summary.pos) == 2) { summary.pos <- summary.pos summary.adj <- c(0, 1) } else if(summary.pos[1] == "topleft") { summary.pos <- c(limits.x[1], limits.y[2]) summary.adj <- c(0, 1) } else if(summary.pos[1] == "top") { summary.pos <- c(mean(limits.x), limits.y[2]) summary.adj <- c(0.5, 1) } else if(summary.pos[1] == "topright") { summary.pos <- c(limits.x[2], limits.y[2]) summary.adj <- c(1, 1) } else if(summary.pos[1] == "left") { summary.pos <- c(limits.x[1], mean(limits.y)) summary.adj <- c(0, 0.5) } else if(summary.pos[1] == "center") { summary.pos <- c(mean(limits.x), mean(limits.y)) summary.adj <- c(0.5, 0.5) } else if(summary.pos[1] == "right") { summary.pos <- c(limits.x[2], mean(limits.y)) summary.adj <- c(1, 0.5) }else if(summary.pos[1] == "bottomleft") { summary.pos <- c(limits.x[1], limits.y[1]) summary.adj <- c(0, 0) } else if(summary.pos[1] == "bottom") { summary.pos <- c(mean(limits.x), limits.y[1]) summary.adj <- c(0.5, 0) } else if(summary.pos[1] == "bottomright") { summary.pos <- c(limits.x[2], limits.y[1]) summary.adj <- c(1, 0) } ## convert keywords into legend placement coordinates if(missing(legend.pos) == TRUE) { legend.pos <- c(limits.x[1], limits.y[2]) legend.adj <- c(0, 1) } else if(length(legend.pos) == 2) { legend.pos <- legend.pos legend.adj <- c(0, 1) } else if(legend.pos[1] == "topleft") { legend.pos <- c(limits.x[1], limits.y[2]) legend.adj <- c(0, 1) } else if(legend.pos[1] == "top") { legend.pos <- c(mean(limits.x), limits.y[2]) legend.adj <- c(0.5, 1) } else if(legend.pos[1] == "topright") { legend.pos <- c(limits.x[2], limits.y[2]) legend.adj <- c(1, 1) } else if(legend.pos[1] == "left") { legend.pos <- c(limits.x[1], mean(limits.y)) legend.adj <- c(0, 0.5) } else if(legend.pos[1] == "center") { legend.pos <- c(mean(limits.x), mean(limits.y)) legend.adj <- c(0.5, 0.5) } else if(legend.pos[1] == "right") { legend.pos <- c(limits.x[2], mean(limits.y)) legend.adj <- c(1, 0.5) } else if(legend.pos[1] == "bottomleft") { legend.pos <- c(limits.x[1], limits.y[1]) legend.adj <- c(0, 0) } else if(legend.pos[1] == "bottom") { legend.pos <- c(mean(limits.x), limits.y[1]) legend.adj <- c(0.5, 0) } else if(legend.pos[1] == "bottomright") { legend.pos <- c(limits.x[2], limits.y[1]) legend.adj <- c(1, 0) } ## calculate line coordinates and further parameters if(missing(line) == FALSE) { line = line + De.add if(log.z == TRUE) {line <- log(line)} line.coords <- list(NA) for(i in 1:length(line)) { line.x <- c(limits.x[1], r / sqrt(1 + f^2 * (line[i] - z.central.global)^2)) line.y <- c(0, (line[i] - z.central.global) * line.x[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.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) for(i in 1:length(rug.values)) { rug.x <- c(r / sqrt(1 + f^2 * (rug.values[i] - z.central.global)^2) * 0.988, r / sqrt(1 + f^2 * (rug.values[i] - z.central.global)^2) * 0.995) rug.y <- c((rug.values[i] - z.central.global) * rug.x[1], (rug.values[i] - z.central.global) * rug.x[2]) rug.coords[[length(rug.coords) + 1]] <- rbind(rug.x, rug.y) } rug.coords[1] <- NULL } ## Generate plot ------------------------------------------------------------ ## check if plotting is enabled if(show == TRUE) { ## determine number of subheader lines to shif the plot if(length(summary) > 0 & summary.pos[1] == "sub") { shift.lines <- length(data) + 1 } else {shift.lines <- 1} ## setup plot area par(mar = c(4, 4, shift.lines + 1.5, 7), xpd = TRUE, cex = cex) ## create empty plot plot(NA, xlim = limits.x, ylim = limits.y, main = "", sub = sub, xlab = "", ylab = "", xaxs = "i", yaxs = "i", frame.plot = FALSE, axes = FALSE) ## add y-axis label mtext(side = 2, line = 2.5, at = 0, adj = 0.5, cex = cex, text = ylab) ## 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.col[1] != "none") { for(i in 1:length(data)) { polygon(x = polygons[i,1:4], y = polygons[i,5:8], lty = "blank", col = bar.col[i]) } } ## optionally, add grid lines if(grid.col[1] != "none") { for(i in 1:length(tick.x1.major)) { lines(x = c(limits.x[1], tick.x1.major[i]), y = c(0, tick.y1.major[i]), col = grid.col) } } ## optionally, plot central value lines if(lwd[1] > 0 & lty[1] > 0) { for(i in 1:length(data)) { x2 <- r / sqrt(1 + f^2 * ( data[[i]][1,5] - z.central.global)^2) y2 <- (data[[i]][1,5] - z.central.global) * x2 lines(x = c(limits.x[1], x2), y = c(0, y2), lty = lty[i], lwd = lwd[i], col = col[i]) } } ## optionally add further lines if(missing(line) == FALSE) { for(i in 1:length(line)) { lines(x = line.coords[[i]][1,], y = line.coords[[i]][2,], col = line.col[i]) text(x = line.coords[[i]][1,2], y = line.coords[[i]][2,2] + par()$cxy[2] * 0.3, labels = line.label[i], pos = 2, col = line.col[i], cex = cex * 0.9) } } ## overplot unwanted parts polygon(x = c(ellipse[,1], limits.x[2] * 2, limits.x[2] * 2), y = c(ellipse[,2], max(ellipse[,2]), min(ellipse[,2])), col = "white", lty = 0) ## add plot title title(main = main, line = shift.lines, font = 2) ## plot 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 <= limits.x[2]] ## axis with lables and ticks axis(side = 1, at = x.axis.ticks, lwd = 1, xlab = "") ## extend axis line to right side of the plot lines(x = c(max(x.axis.ticks, na.rm = TRUE), limits.x[2]), y = c(limits.y[1], limits.y[1])) ## draw closing tick on right hand side axis(side = 1, tcl = 0.5, lwd = 0, lwd.ticks = 1, at = limits.x[2], labels = FALSE) axis(side = 1, tcl = -0.5, lwd = 0, lwd.ticks = 1, at = limits.x[2], labels = FALSE) ## add upper axis label mtext(text = xlab[1], at = (limits.x[1] + limits.x[2]) / 2, side = 1, line = -3.5, cex = cex) ## add lower axis label mtext(text = xlab[2], at = (limits.x[1] + limits.x[2]) / 2, side = 1, line = 2.5, cex = cex) ## plot upper x-axis axis(side = 1, tcl = 0.5, lwd = 0, lwd.ticks = 1, at = x.axis.ticks[-1], labels = FALSE) ## remove first tick label (infinity) label.x.upper <- label.x.upper[1:(length(x.axis.ticks) - 1)] ## add tick labels axis(side = 1, lwd = 0, labels = label.x.upper, at = x.axis.ticks[-1], line = -3) ## plot minor z-ticks for(i in 1:length(tick.values.minor)) { lines(x = c(tick.x1.minor[i], tick.x2.minor[i]), y = c(tick.y1.minor[i], tick.y2.minor[i])) } ## plot major z-ticks for(i in 1:length(tick.values.major)) { lines(x = c(tick.x1.major[i], tick.x2.major[i]), y = c(tick.y1.major[i], tick.y2.major[i])) } ## plot z-axis lines(ellipse) ## plot z-values text(x = label.x, y = label.y, label = label.z.text, 0) ## plot z-label mtext(side = 4, at = 0, line = 5, las = 3, adj = 0.5, cex = cex, text = zlab) ## 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 = col[data.global[i,9]]) } } ## plot values 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 = col[i], pch = pch[i]) } ## optionally add min, max, median sample text if(length(stats) > 0) { text(x = stats.data[,1], y = stats.data[,2], labels = round(stats.data[,3], 1), pos = 2, cex = 0.85) } ## optionally add legend content if(missing(legend) == FALSE) { legend(x = legend.pos[1], y = 0.8 * legend.pos[2], xjust = legend.adj[1], yjust = legend.adj[2], legend = legend, pch = pch, col = col, text.col = col, cex = 0.8 * cex, bty = "n") } ## plot y-axis if(y.ticks == TRUE) { char.height <- par()$cxy[2] tick.space <- axisTicks(usr = limits.y, log = FALSE) tick.space <- (max(tick.space) - min(tick.space)) / length(tick.space) if(tick.space < char.height * 1.5) { axis(side = 2, at = c(-2, 2), labels = c("", ""), las = 1) axis(side = 2, at = 0, tcl = 0, labels = paste("\u00B1", "2"), las = 1) } else { axis(side = 2, at = seq(-2, 2, by = 2), las = 2) } } else { axis(side = 2, at = 0) } ## optionally add subheader text mtext(side = 3, line = shift.lines - 2, text = mtext, cex = 0.8 * cex) ## add summary content for(i in 1:length(data)) { if(summary.pos[1] != "sub") { text(x = summary.pos[1], y = 0.8 * summary.pos[2], adj = summary.adj, labels = label.text[[i]], cex = 0.8 * cex, col = col[i]) } else { if(mtext == "") { mtext(side = 3, line = shift.lines - 1 - i, text = label.text[[i]], col = col[i], cex = 0.8 * cex) } } } ##FUN by R Luminescence Team if(fun==TRUE){sTeve()} } if(output == TRUE) { return(list(data = data, data.global = data.global, xlim = limits.x, ylim = limits.y, zlim = limits.z, r = r, plot.ratio = plot.ratio, ticks.major = ticks.major, ticks.minor = ticks.minor, labels = labels, polygons = polygons, ellipse.lims = ellipse.lims)) } } Luminescence/R/RLum.Data.Image-class.R0000644000176200001440000002453313125226556017101 0ustar liggesusers#' @include get_RLum.R set_RLum.R names_RLum.R NULL #' Class \code{"RLum.Data.Image"} #' #' Class for representing luminescence image data (TL/OSL/RF). Such data are for example produced #' by the function \code{\link{read_SPE2R}} #' #' @name RLum.Data.Image-class #' #' @docType class #' #' @slot recordType Object of class \code{\link{character}} #' containing the type of the curve (e.g. "OSL image", "TL image") #' #' @slot curveType Object of class \code{\link{character}} containing curve type, allowed values #' are measured or predefined #' #' @slot data Object of class \code{\link[raster]{brick}} containing images (raster data). #' #' @slot info Object of class \code{\link{list}} containing further meta information objects #' #' @note The class should only contain data for a set of images. For additional #' elements the slot \code{info} can be used. #' #' @section Objects from the Class: Objects can be created by calls of the form #' \code{set_RLum("RLum.Data.Image", ...)}. #' #' @section Class version: 0.4.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\linkS4class{RLum}}, \code{\linkS4class{RLum.Data}}, #' \code{\link{plot_RLum}}, \code{\link{read_SPE2R}} #' #' @keywords classes #' #' @examples #' #' showClass("RLum.Data.Image") #' #' ##create empty RLum.Data.Image object #' set_RLum(class = "RLum.Data.Image") #' #' @importClassesFrom raster RasterBrick #' @export setClass( "RLum.Data.Image", slots = list( recordType = "character", curveType = "character", data = "RasterBrick", info = "list" ), contains = "RLum.Data", prototype = list ( recordType = character(), curveType = character(), data = raster::brick(raster::raster(matrix())), info = list() ) ) #################################################################################################### ###as() #################################################################################################### ##DATA.FRAME ##COERCE RLum.Data.Image >> data.frame AND data.frame >> RLum.Data.Image #' as() #' #' for \code{[RLum.Data.Image]} #' #' \bold{[RLum.Data.Image]}\cr #' #' \tabular{ll}{ #' \bold{from} \tab \bold{to}\cr #' \code{data.frame} \tab \code{data.frame}\cr #' \code{matrix} \tab \code{matrix} #' #' } #' #' @name as #' #' setAs("data.frame", "RLum.Data.Image", function(from,to){ new(to, recordType = "unkown curve type", curveType = "NA", data = as.matrix(from), info = list()) }) setAs("RLum.Data.Image", "data.frame", function(from){ data.frame(x = from@data@values[seq(1,length(from@data@values), by = 2)], y = from@data@values[seq(2,length(from@data@values), by = 2)]) }) ##MATRIX ##COERCE RLum.Data.Image >> matrix AND matrix >> RLum.Data.Image setAs("matrix", "RLum.Data.Image", function(from,to){ new(to, recordType = "unkown curve type", curveType = "NA", data = raster::brick(raster::raster(as.matrix(from))), info = list()) }) setAs("RLum.Data.Image", "matrix", function(from){ ##only the first object is convertec as.matrix(from[[1]]) }) #################################################################################################### ###show() #################################################################################################### #' @describeIn RLum.Data.Image #' Show structure of \code{RLum.Data.Image} object #' @export setMethod("show", signature(object = "RLum.Data.Image"), function(object){ x.rows <- object@data@ncols y.cols <- object@data@nrows z.range <- paste(min(object@data@data@min),":",max(object@data@data@max)) ##print information cat("\n [RLum.Data.Image]") cat("\n\t recordType:", object@recordType) cat("\n\t curveType:", object@curveType) cat("\n\t .. recorded frames:", length(object@data@data@names)) cat("\n\t .. .. pixel per frame:", x.rows*y.cols) cat("\n\t .. .. x dimension [px]:", x.rows) cat("\n\t .. .. y dimension [px]:", y.cols) cat("\n\t .. .. full pixel value range:", z.range) cat("\n\t additional info elements:", length(object@info)) #cat("\n\t\t >> names:", names(object@info)) } ) #################################################################################################### ###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 \code{[set_RLum]}\code{\link{character}}: name of the \code{RLum} class to create #' @param originator \code{[set_RLum]} \code{\link{character}} (automatic): #' contains the name of the calling function (the function that produces this object); can be set manually. #' @param .uid [\code{set_RLum}] \code{\link{character}} (automatic): sets an unique ID for this object #' using the internal C++ function \code{.create_UID}. #' @param .pid [\code{set_RLum}] \code{\link{character}} (with default): option to provide a parent id for nesting #' at will. #' @param recordType \code{[set_RLum]} \code{\link{character}}: record type (e.g. "OSL") #' @param curveType \code{[set_RLum]} \code{\link{character}}: curve type (e.g. "predefined" or "measured") #' @param data \code{[set_RLum]} \code{\link{matrix}}: raw curve data. If data is of type \code{RLum.Data.Image} #' this can be used to re-construct the object. #' @param info \code{[set_RLum]} \code{\link{list}}: info elements #' #' @return #' #' \bold{\code{set_RLum}}\cr #' #' Returns an object from class \code{RLum.Data.Image} #' #' @export setMethod( "set_RLum", signature = signature("RLum.Data.Image"), definition = function(class, originator, .uid, .pid, recordType = "Image", curveType = NA_character_, data = raster::brick(raster::raster(matrix())), 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 missing .uid if (missing(.uid)) { info <- data@.uid } ##check for missing .pid if (missing(.pid)) { info <- data@.pid } ##set empty clas form object newRLumDataImage <- new("RLum.Data.Image") ##fill - this is the faster way, filling in new() costs ... newRLumDataImage@recordType = recordType newRLumDataImage@curveType = curveType newRLumDataImage@data = data@data newRLumDataImage@info = info newRLumDataImage@.uid = data@.uid newRLumDataImage@.pid = data@.pid return(newRLumDataImage) } else{ ##set empty clas form 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 (RasterBrick) will be returned. #' #' @param object \code{[show_RLum]}\code{[get_RLum]}\code{[names_RLum]} an object #' of class \code{\linkS4class{RLum.Data.Image}} #' @param info.object \code{[get_RLum]} \code{\link{character}} name of the info object to returned #' #' @return #' #' \bold{\code{get_RLum}}\cr #' #' (1) Returns the data object (\code{\link[raster]{brick}})\cr #' (2) only the info object if \code{info.object} was set.\cr #' #' @export setMethod("get_RLum", signature("RLum.Data.Image"), definition = function(object, info.object) { ##Check if function is of type RLum.Data.Image if(is(object, "RLum.Data.Image") == FALSE){ stop("[get_RLum] Function valid for 'RLum.Data.Image' objects only!") } ##if missing info.object just show the curve values if(missing(info.object) == FALSE){ if(is(info.object, "character") == FALSE){ stop("[get_RLum] 'info.object' has to be a character!") } if(info.object %in% names(object@info) == TRUE){ unlist(object@info[info.object]) }else{ ##grep names temp.element.names <- paste(names(object@info), collapse = ", ") stop.text <- paste("[get_RLum] Invalid element name. Valid names are:", temp.element.names) stop(stop.text) } }else{ object@data } }) #################################################################################################### ###names_RLum() #################################################################################################### #' @describeIn RLum.Data.Image #' Returns the names info elements coming along with this curve object #' #' @return #' #' \bold{\code{names_RLum}}\cr #' #' Returns the names of the info elements #' #' @export setMethod("names_RLum", "RLum.Data.Image", function(object) { names(object@info) }) Luminescence/R/github.R0000644000176200001440000001470113125226556014504 0ustar liggesusers# ------------------------------------------------------------------------ # Author: Christoph Burow # Affiliation: University of Cologne # Date: 10/01/2017 # API version: v3 # Reference: https://developer.github.com/v3/ # ------------------------------------------------------------------------ #' GitHub API #' #' R Interface to the GitHub API v3. #' #' These functions can be used to query a specific repository hosted on GitHub. \cr #' #' #' @param user \code{\link{character}}: #' GitHub user name (defaults to 'r-lum'). #' #' @param repo \code{\link{character}}: #' name of a GitHub repository (defaults to 'luminescence'). #' #' @param branch \code{\link{character}}: #' branch of a GitHub repository (defaults to 'master'). #' #' @param n \code{\link{integer}}: #' number of commits returned (defaults to 5). #' #' @param verbose \code{\link{logical}}: #' print the output to the console (defaults to \code{TRUE}). #' #' @author Christoph Burow, University of Cologne (Germany) #' #' @section Function version: 0.1.0 #' #' @references #' #' GitHub Developer API v3. \url{https://developer.github.com/v3/}, last accessed: 10/01/2017. #' #' @examples #' #' \dontrun{ #' github_branches(user = "r-lum", repo = "luminescence") #' github_issues(user = "r-lum", repo = "luminescence") #' github_commits(user = "r-lum", repo = "luminescence", branch = "master", n = 10) #' } #' #' @name GitHub-API NULL # COMMITS ----------------------------------------------------------------- #' @rdname GitHub-API #' #' @details #' \code{github_commits} lists the most recent \code{n} commits of a specific #' branch of a repository. #' #' @return #' \code{github_commits}: \code{\link{data.frame}} with columns: #' \tabular{ll}{ #' [ ,1] \tab SHA \cr #' [ ,2] \tab AUTHOR \cr #' [ ,3] \tab DATE \cr #' [ ,4] \tab MESSAGE \cr #' } #' #' @export github_commits <- function(user = "r-lum", repo = "luminescence", branch = "master", n = 5) { # fetch available branches and check if provided branch exists branches <- github_branches(user, repo) if (!any(grepl(branch, branches$BRANCH))) stop("Branch ", branch, " does not exist.", call. = FALSE) # build URL and retrieve content sha <- branches$SHA[grep(paste0("^", branch, "$"), branches$BRANCH)] url <- paste0("https://api.github.com/repos/", user, "/", repo, "/commits?", "per_page=", n, "&sha=", sha) content <- github_getContent(url) # format output as data.frame output <- do.call(rbind, lapply(content, function(x) { data.frame(SHA = x$sha, AUTHOR = x$commit$author$name, DATE = x$commit$author$date, MESSAGE = x$commit$message, stringsAsFactors = FALSE) })) return(output) } # BRANCHES ---------------------------------------------------------------- #' @rdname GitHub-API #' #' @details #' \code{github_branches} can be used to list all current branches of a #' repository and returns the corresponding SHA hash as well as an installation #' command to install the branch in R via the 'devtools' package. #' #' @return #' \code{github_branches}: \code{\link{data.frame}} with columns: #' \tabular{ll}{ #' [ ,1] \tab BRANCH \cr #' [ ,2] \tab SHA \cr #' [ ,3] \tab INSTALL \cr #' } #' #' @export github_branches <- function(user = "r-lum", repo = "luminescence") { # build URL and retrieve content url <- paste0("https://api.github.com/repos/", user, "/", repo, "/branches") content <- github_getContent(url) # extract relevant information from server response branches <- sapply(content, function(x) x$name) sha <- sapply(content, function(x) x$commit$sha) # format output as data.frame output <- data.frame( BRANCH = branches, SHA = sha, INSTALL = paste0("devtools::install_github('r-lum/luminescence@", branches, "')"), stringsAsFactors = FALSE ) return(output) } # ISSUES ------------------------------------------------------------------ #' @rdname GitHub-API #' #' @details #' \code{github_issues} lists all open issues for a repository in valid YAML. #' #' @return #' \code{github_commits}: Nested \code{\link{list}} with \code{n} elements. #' Each commit element is a list with elements: #' \tabular{ll}{ #' [[1]] \tab NUMBER \cr #' [[2]] \tab TITLE \cr #' [[3]] \tab BODY \cr #' [[4]] \tab CREATED \cr #' [[5]] \tab UPDATED \cr #' [[6]] \tab CREATOR \cr #' [[7]] \tab URL \cr #' [[8]] \tab STATUS \cr #' } #' #' @export github_issues <- function(user = "r-lum", repo = "luminescence", verbose = TRUE) { # build URL and retrieve content url <- paste0("https://api.github.com/repos/", user,"/", repo, "/issues") content <- github_getContent(url) # format output as nested list issues <- lapply(content, function(x) { list( NUMBER = x$number, TITLE = x$title, BODY = gsub("\n", "", x$body), CREATED = x$created_at, UPDATED = x$updated_at, CREATOR = x$user$login, URL = x$url, STATUS = x$state, MILESTONE = x$milestone$title) }) # custom printing of the the issues-list as print.list produces unreadable # console output if (verbose) { tmp <- lapply(issues, function(x) { # limit width of description text DESCRIPTION <- "" for (i in seq_len(ceiling(nchar(x$BODY) / 100))) DESCRIPTION <- paste(DESCRIPTION, " ", substr(x$BODY, i*100-99, i*100), "\n") # print to console in valid YAML cat(paste0("---\n", 'title: "', x$TITLE, '"', "\n", "number: ", x$NUMBER, "\n", 'url: "', x$URL, '"', "\n", "created: ", x$CREATED, "\n", "updated: ", x$UPDATED, "\n", "creator: ", x$CREATOR, "\n", "status: ", x$STATUS, "\n", 'milestone: "', x$MILESTONE, '"', "\n", "description: >\n", DESCRIPTION, "\n\n\n")) }) } # return invisible as we explicitly print the output invisible(issues) } # HELPER ------------------------------------------------------------------ # This function queries the URL, checks the server response and returns # the content. github_getContent <- function(url) { response <- GET(url, accept_json()) if (status_code(response) != 200) stop("Contacting ", url, " had status code ", status_code(response), call. = FALSE) content <- content(response) return(content) } Luminescence/R/smooth_RLum.R0000644000176200001440000000412013125226556015464 0ustar liggesusers#' Smoothing of data #' #' Function calls the object-specific smooth functions for provided RLum S4-class objects. #' #' The function provides a generalised access point for specific #' \code{\linkS4class{RLum}} objects.\cr Depending on the input object, the #' corresponding function will be selected. Allowed arguments can be found #' in the documentations of the corresponding \code{\linkS4class{RLum}} class. The smoothing #' is based on an internal function called \code{.smoothing}. #' #' @param object \code{\linkS4class{RLum}} (\bold{required}): S4 object of #' class \code{RLum} #' #' @param ... further arguments passed to the specifc class method #' #' @return An object of the same type as the input object is provided #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @note Currenlty only \code{RLum} objects of class \code{RLum.Data.Curve} and \code{RLum.Analysis} (with curve data) are supported! #' #' @seealso #' \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Analysis}} #' #' @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 #' #' @export setGeneric("smooth_RLum", function(object, ...) { standardGeneric("smooth_RLum") }) # Method for smooth_RLum method for RLum objects in a list for a list of objects ------------------- #' @describeIn smooth_RLum #' Returns a list of \code{\linkS4class{RLum}} objects that had been passed to \code{\link{smooth_RLum}} #' #' #' @export setMethod("smooth_RLum", signature = "list", function(object, ...){ ##apply method in the objects and return the sampe lapply(object, function(x){ if(inherits(x, "RLum")){ return(smooth_RLum(x,...)) }else{ return(x) } }) }) Luminescence/R/set_RLum.R0000644000176200001440000000540413125226556014754 0ustar liggesusers#' General set function for RLum S4 class objects #' #' Function calls object-specific set functions for RLum S4 class objects. #' #' The function provides a generalised access point for specific #' \code{\linkS4class{RLum}} objects.\cr 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 \code{\linkS4class{RLum}} class: \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Data.Image}}, \code{\linkS4class{RLum.Data.Spectrum}}, #' \code{\linkS4class{RLum.Analysis}} and \code{\linkS4class{RLum.Results}} #' #' @param class \code{\linkS4class{RLum}} (\bold{required}): name of the S4 class to #' create #' #' @param originator \code{\link{character}} (automatic): contains the name of the calling function #' (the function that produces this object); can be set manually. #' #' @param .uid \code{\link{character}} (automatic): sets an unique ID for this object #' using the internal C++ function \code{.create_UID}. #' #' @param .pid \code{\link{character}} (with default): option to provide a parent id for nesting #' at will. #' #' @param \dots further arguments that one might want to pass to the specific #' set method #' #' @return Returns an object of the specified class. #' #' @section Function version: 0.3.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso #' \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Data.Image}}, #' \code{\linkS4class{RLum.Data.Spectrum}}, #' \code{\linkS4class{RLum.Analysis}}, #' \code{\linkS4class{RLum.Results}} #' #' @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) #' #' @export setGeneric("set_RLum", function (class, originator, .uid = .create_UID(), .pid = NA_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") }) Luminescence/R/calc_CentralDose.R0000644000176200001440000002501613125226556016410 0ustar liggesusers#' Apply the central age model (CAM) after Galbraith et al. (1999) to a given #' De distribution #' #' 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 \code{delta} and \code{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 \code{sigma} is #' calculated using eq. 18 and presented as a plot. Numerical values of the #' maximum likelihood approach are \bold{only} presented in the plot and \bold{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 \code{\linkS4class{RLum.Results}} or \link{data.frame} #' (\bold{required}): for \code{data.frame}: two columns with De #' \code{(data[,1])} and De error \code{(data[,2])} #' #' @param sigmab \code{\link{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). #' \bold{NOTE}: For the logged model (\code{log = TRUE}) this value must be #' a fraction, e.g. 0.2 (= 20 \%). If the un-logged model is used (\code{log = FALSE}), #' sigmab must be provided in the same absolute units of the De values (seconds or Gray). #' #' @param log \code{\link{logical}} (with default): fit the (un-)logged central #' age model to De data #' #' @param plot \code{\link{logical}} (with default): plot output #' #' @param \dots further arguments (\code{trace, verbose}). #' #' @return Returns a plot (optional) and terminal output. In addition an #' \code{\linkS4class{RLum.Results}} object is returned containing the #' following element: #' #' \item{summary}{\link{data.frame} summary of all relevant model results.} #' \item{data}{\link{data.frame} original input data} \item{args}{\link{list} #' used arguments} \item{call}{\link{call} the function call} #' \item{profile}{\link{data.frame} the log likelihood profile for sigma} #' #' The output should be accessed using the function #' \code{\link{get_RLum}} #' @section Function version: 1.3.2 #' @author Christoph Burow, University of Cologne (Germany) \cr Based on a #' rewritten S script of Rex Galbraith, 2010 \cr #' @seealso \code{\link{plot}}, \code{\link{calc_CommonDose}}, #' \code{\link{calc_FiniteMixture}}, \code{\link{calc_FuchsLang2001}}, #' \code{\link{calc_MinDose}} #' @references Galbraith, R.F. & Laslett, G.M., 1993. Statistical models for #' mixed fission track ages. Nuclear Tracks Radiation Measurements 4, 459-470. #' \cr \cr 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. \cr \cr Galbraith, R.F. & Roberts, R.G., #' 2012. Statistical aspects of equivalent dose and error calculation and #' display in OSL dating: An overview and some recommendations. Quaternary #' Geochronology 11, 1-27. \cr \cr \bold{Further reading} \cr \cr 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. \cr \cr 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. \cr \cr Cunningham, A.C. & Wallinga, J., 2012. #' Realizing the potential of fluvial archives using robust OSL chronologies. #' Quaternary Geochronology 12, 98-106. \cr \cr 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. #' \cr \cr 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) #' #' @export calc_CentralDose <- function(data, sigmab, log = TRUE, plot = TRUE, ...) { ## ============================================================================## ## CONSISTENCY CHECK OF INPUT DATA ## ============================================================================## if (!missing(data)) { if (!is(data, "data.frame") & !is(data, "RLum.Results")) { stop("[calc_CentralDose] Error: 'data' object has to be of type\n 'data.frame' or 'RLum.Results'!") } else { if (is(data, "RLum.Results")) { data <- get_RLum(data, "data") } } } try(colnames(data) <- c("ED", "ED_Error"), silent = TRUE) if (colnames(data[1]) != "ED" || colnames(data[2]) != "ED_Error") { cat(paste("Columns must be named 'ED' and 'ED_Error'"), fill = FALSE) stop(domain = NA) } if (!missing(sigmab)) { if (sigmab < 0 | sigmab > 1 & log) { cat(paste("sigmab needs to be given as a fraction between", "0 and 1 (e.g. 0.2)"), fill = FALSE) stop(domain = NA) } } ## ============================================================================## ## ... ARGUMENTS ## ============================================================================## options <- list(verbose = TRUE, trace = FALSE) options <- modifyList(options, list(...)) ## ============================================================================## ## 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) } # calculate starting values and weights sigma <- 0.15 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)) } # 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 (class(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 } #endif::try-error ## ============================================================================## ## 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 central dose [Gy]: ", format(out.delta, digits = 2, nsmall = 2))) cat(paste("\n SE [Gy]: ", 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 OD [Gy]: ", format(ifelse(log, sigma * out.delta, sigma), digits = 2, nsmall = 2))) cat(paste("\n SE [Gy]: ", 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 (class(sig) != "try-error") { format(out.sesigma * 100, digits = 2, nsmall = 2) } else { "-" })) cat(paste("\n-------------------------------------\n\n")) } ## ============================================================================## ## RETURN VALUES ## ============================================================================## if (class(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 = out.sigma, OD_err = out.sesigma * 100, Lmax = Lmax) call <- sys.call() args <- list(log = log, sigmab = sigmab) newRLumResults.calc_CentralDose <- set_RLum(class = "RLum.Results", data = list(summary = summary, data = data, args = args, call = call, profile = data.frame(sig = sig, llik = llik))) ## =========## PLOTTING if (plot && class(sig) != "try-error") try(plot_RLum.Results(newRLumResults.calc_CentralDose, ...)) invisible(newRLumResults.calc_CentralDose) } Luminescence/R/internals_RLum.R0000644000176200001440000001346713125226556016170 0ustar liggesusers#################################################################################################### ## INTERNAL HELPER FUNCTIONS ## #################################################################################################### #+++++++++++++++++++++ #+ .set_pid() + #+++++++++++++++++++++ #' Set unique id of the RLum.Analysis object as parent id for each RLum.Data object in the record list #' #' This function only applies on RLum.Analysis objects and was written for performance not #' usability, means the functions runs without any checks and is for internal usage only. #' #' @param \code{\linkS4class{RLum.Analysis}} (\bold{required}): input object where the function #' should be applied on #' #' @return #' Returns the same object as the input #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @examples #' #' ##example using self created data #' object <- set_RLum( #' "RLum.Analysis", #' records = list( #' set_RLum("RLum.Data.Curve"), #' set_RLum("RLum.Data.Curve"))) #' #' object <- .set_pid(object) #' #' @noRd .set_pid <- function(object){ object@records <- lapply(object@records, function(x) { x@.pid <- object@.uid return(x) }) return(object) } #+++++++++++++++++++++ #+ .warningCatcher() + #+++++++++++++++++++++ #' Catches warning returned by a function and merges them. #' The original return of the function is returned. This function is in particular #' helpful if a function returns a lot of warnings with the same content. #' #' @param expr \code{\link{expression}} (\bold{required}): the R expression, usually a #' function #' #' @return #' Returns the same object as the input and a warning table #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @examples #' #' f <- function() { #' warning("warning 1") #' warning("warning 1") #' warning("warnigs 2") #' 1:10 #' } #' print(.warningCatcher(f())) #' #' @noRd .warningCatcher <- function(expr) { ##set variables warning_collector <- list() env <- environment() ##run function and catch warnings results <- withCallingHandlers( expr = expr, warning = function(c) { assign(x = "warning_collector", value = c, envir = env) invokeRestart("muffleWarning") } ) ##set new warning messages with merged results if (length(warning_collector) > 0) { w_table <- table(as.character(unlist(warning_collector))) w_table_names <- names(w_table) for (w in 1:length(w_table)) { warning(paste( w_table_names[w], "This warning occurred", w_table[w], "times!" ), call. = FALSE) } } return(results) } #+++++++++++++++++++++ #+ .smoothing() + #+++++++++++++++++++++ #' Allows smmoothing of data based on the function zoo::rollmean #' #' The function just allows a direct and meaningfull access to the functionality of the zoo::rollmean() #' function. Arguments of the function are only partly valid. #' #' @param x \code{\link{numeric}} (\bold{required}): the object for which the smoothing should be #' applied. #' #' @param k \code{\link{integer}} (with default): window for the rolling mean; must be odd for rollmedian. #' If nothing is set k is set automatically #' #' @param fill \code{\link{numeric}} (with default): a vector defining the left and the right hand data #' #' @param align \code{\link{character}} (with default): specifying whether the index of the result should be #' left- or right-aligned or centered (default) compared to the rolling window of observations, allowed #' \code{"right"}, \code{"center"} and \code{left} #' #' @param method \code{\link{method}} (with default): defines which method should be applied for the #' smoothing: \code{"mean"} or \code{"median"} #' #' @return #' Returns the same object as the input and a warning table #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @examples #' #' v <- 1:100 #' .smoothing(v) #' #' @noRd .smoothing <- function( x, k = NULL, fill = NA, align = "right", method = "mean") { ##set k if (is.null(k)) k <- ceiling(length(x) / 100) if(method == "median" && k %%2 !=0) k <- k + 1 ##smooth data if(method == "mean"){ zoo::rollmean(x, k = k, fill = fill, align = align) }else if(method == "median"){ zoo::rollmedian(x, k = k, fill = fill, align = align) }else{ stop("[Luminescence:::.smoothing()] Unvalid input for 'method'!") } } #++++++++++++++++++++++++++++++ #+ Scientific axis annotation + #++++++++++++++++++++++++++++++ #' Bored of the 1e10 notation of large numbers in R? Already tried to force #' R to produce more fancy labels? Worry not, fancy_scientific() (written by #' Jack Aidley) is at your help! #' #' Source: #' http://stackoverflow.com/questions/11610377/how-do-i-change-the-formatting-of-numbers-on-an-axis-with-ggplot #' #' @param l \code{\link{numeric}} (\bold{required}): a numeric vector, i.e. the #' labels that you want to add to your plot #' #' @return #' Returns an expression #' #' @section Function version: 0.1.0 #' #' @author Jack Aidley #' #' @examples #' #' plot(seq(1e10, 1e20, length.out = 10), #' 1:10, #' xaxt = "n") #' #' axis(1, at = axTicks(1), #' labels = fancy_scientific(axTicks(1))) #' #' @noRd fancy_scientific <- function(l) { # turn in to character string in scientific notation l <- format(l, scientific = TRUE) # quote the part before the exponent to keep all the digits l <- gsub("^(.*)e", "'\\1'e", l) # turn the 'e+' into plotmath format l <- gsub("e", "%*%10^", l) # remove plus sign l <- gsub("\\+", "", l) # return this as an expression parse(text=l) } Luminescence/R/calc_CommonDose.R0000644000176200001440000001647413125226556016260 0ustar liggesusers#' Apply the (un-)logged common age model after Galbraith et al. (1999) to a #' given De distribution #' #' Function to calculate the common dose of a De distribution. #' #' \bold{(Un-)logged model} \cr\cr When \code{log = TRUE} this function #' calculates the weighted mean of logarithmic De values. Each of the estimates #' is weighted by the inverse square of its relative standard error. The #' weighted mean is then transformed back to the dose scale (Galbraith & #' Roberts 2012, p. 14).\cr\cr The log transformation is not applicable if the #' De estimates are close to zero or negative. In this case the un-logged model #' can be applied instead (\code{log = FALSE}). The weighted mean is then #' calculated using the un-logged estimates of De and their absolute standard #' error (Galbraith & Roberts 2012, p. 14). #' #' @param data \code{\linkS4class{RLum.Results}} or \link{data.frame} #' (\bold{required}): for \code{data.frame}: two columns with De #' \code{(data[,1])} and De error \code{(values[,2])} #' #' @param sigmab \code{\link{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). #' \bold{NOTE}: For the logged model (\code{log = TRUE}) this value must be #' a fraction, e.g. 0.2 (= 20 \%). If the un-logged model is used (\code{log = FALSE}), #' sigmab must be provided in the same absolute units of the De values (seconds or Gray). #' #' @param log \code{\link{logical}} (with default): fit the (un-)logged common #' age model to De data #' #' @param \dots currently not used. #' #' @return Returns a terminal output. In addition an #' \code{\linkS4class{RLum.Results}} object is returned containing the #' following element: #' #' \item{summary}{\link{data.frame} summary of all relevant model results.} #' \item{data}{\link{data.frame} original input data} \item{args}{\link{list} #' used arguments} \item{call}{\link{call} the function call} #' #' The output should be accessed using the function #' \code{\link{get_RLum}} #' @section Function version: 0.1.1 #' #' @author Christoph Burow, University of Cologne (Germany) #' #' @seealso \code{\link{calc_CentralDose}}, \code{\link{calc_FiniteMixture}}, #' \code{\link{calc_FuchsLang2001}}, \code{\link{calc_MinDose}} #' #' @references Galbraith, R.F. & Laslett, G.M., 1993. Statistical models for #' mixed fission track ages. Nuclear Tracks Radiation Measurements 4, 459-470. #' \cr\cr 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. \cr\cr Galbraith, R.F. & Roberts, R.G., #' 2012. Statistical aspects of equivalent dose and error calculation and #' display in OSL dating: An overview and some recommendations. Quaternary #' Geochronology 11, 1-27. \cr\cr \bold{Further reading} \cr\cr 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. \cr\cr 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. \cr\cr Cunningham, A.C. & Wallinga, J., 2012. #' Realizing the potential of fluvial archives using robust OSL chronologies. #' Quaternary Geochronology 12, 98-106. \cr\cr 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.\cr\cr 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 common dose model #' calc_CommonDose(ExampleData.DeValues$CA1) #' #' @export calc_CommonDose <- function( data, sigmab, log=TRUE, ... ) { ##============================================================================## ## CONSISTENCY CHECK OF INPUT DATA ##============================================================================## if(missing(data)==FALSE){ if(is(data, "data.frame") == FALSE & is(data,"RLum.Results") == FALSE){ stop("[calc_CentralDose] Error: 'data' object has to be of type 'data.frame' or 'RLum.Results'!") }else{ if(is(data, "RLum.Results") == TRUE){ data <- get_RLum(data, "data") } } } try(colnames(data)<- c("ED","ED_Error"), silent = TRUE) if(colnames(data[1])!="ED"||colnames(data[2])!="ED_Error") { cat(paste("Columns must be named 'ED' and 'ED_Error'"), fill = FALSE) stop(domain=NA) } if(!missing(sigmab)) { if(sigmab <0 | sigmab >1) { cat(paste("sigmab needs to be given as a fraction between", "0 and 1 (e.g. 0.2)"), fill = FALSE) stop(domain=NA) } } ##============================================================================## ## ADDITIONAL ARGUMENTS ##============================================================================## settings <- list(verbose = TRUE) settings <- modifyList(settings, list(...)) ##============================================================================## ## 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) } # calculate weights wu<- 1/su^2 delta<- sum(wu*yu)/sum(wu) n<- length(yu) #standard error sedelta<- 1/sqrt(sum(wu)) if (!log) { sedelta<- sedelta/delta } if (log){ delta<- exp(delta) } ##============================================================================## ## TERMINAL OUTPUT ##============================================================================## if (settings$verbose) { cat("\n [calc_CommonDose]") cat(paste("\n\n----------- meta data --------------")) cat(paste("\n n: ",n)) cat(paste("\n log: ",if(log==TRUE){"TRUE"}else{"FALSE"})) cat(paste("\n----------- dose estimate ----------")) cat(paste("\n common dose: ", round(delta,2))) cat(paste("\n SE: ", round(delta*sedelta, 2))) cat(paste("\n rel. SE [%]: ", round(sedelta*100,2))) cat(paste("\n------------------------------------\n\n")) } ##============================================================================## ## RETURN VALUES ##============================================================================## summary<- data.frame(de=delta, de_err=delta*sedelta) call<- sys.call() args<- list(log=log, sigmab=sigmab) newRLumResults.calc_CommonDose<- set_RLum( class = "RLum.Results", data = list(summary = summary, data = data, args = args, call = call)) invisible(newRLumResults.calc_CommonDose) } Luminescence/R/methods_DRAC.R0000644000176200001440000002136012626623604015455 0ustar liggesusers################################################################################## ## METHODS FOR S3 GENERICS ## ################################################################################## ## ---------------------------------------------------------------------------## ## DATA FRAME COERCION METHOD ## This is a method for the as.data.frame S3 generic. We need this to intercept the ## DRAC list object after it hast passed the actual list-method. After it was ## coerced to a data.frame we assign new column names (DRAC ID keys) and ## make sure that all columns are either of class 'character' or 'numeric'. ## Finally, we attach a further class name to identify it as a valid DRAC object ## when passed to use_DRAC #' @export as.data.frame.DRAC.list <- function(x, row.names = NULL, optional = FALSE, ...) { DF <- as.data.frame.list(x) colnames(DF) <- paste0("TI:", 1:ncol(DF)) for (i in 1:ncol(DF)) { if (is.factor(DF[ ,i])) DF[ ,i] <- as.character(DF[, i]) } class(DF) <- c("data.frame", "DRAC.data.frame") return(DF) } ## ---------------------------------------------------------------------------## ## PRINT METHOD #' @export print.DRAC.highlights <- function(x, ...) { x <- as.list(x) names <- names(x) mapply(function(el, name) { cat(paste0(attributes(el)$key, " = ", name,":\n ", paste(el, collapse = ",\n "), "\n")) }, x, names) } #' @export print.DRAC.list <- function(x, blueprint = FALSE, ...) { ## CASE 1: Pretty print the structure of the DRAC list if (!blueprint) { limit <- 80 for (i in 1:length(x)) { # for pretty printing we insert newlines and tabs at specified lengths ls <- attributes(x[[i]])$description ls.n <- nchar(ls) ls.block <- floor(ls.n / limit) strStarts <- seq(0, ls.n, limit) strEnds <- seq(limit-1, ls.n + limit, limit) blockString <- paste(mapply(function(start, end) { trimmedString <- paste(substr(ls, start, end), "\n\t\t\t") if (substr(trimmedString, 1, 1) == " ") trimmedString <- gsub("^[ ]*", "", trimmedString) return(trimmedString) }, strStarts, strEnds), collapse="") msg <- paste(attributes(x[[i]])$key, "=>",names(x)[i], "\n", "\t VALUES =", paste(x[[i]], collapse = ", "), "\n", "\t ALLOWS 'X' = ", attributes(x[[i]])$allowsX, "\n", "\t REQUIRED =", attributes(x[[i]])$required, "\n", "\t DESCRIPTION = ", blockString, "\n" ) if (!is.null(levels(x[[i]]))) { msg <- paste(msg, "\t OPTIONS = ", paste(levels(x[[i]]), collapse = ", "), "\n\n") } else { msg <- paste(msg, "\n") } cat(msg) } } ## CASE 2: Return a 'blueprint' that can be copied from the console to a ## script so the user does not need to write down all >50 fields by hand if (blueprint) { var <- as.list(sys.call())[[2]] names <- names(x) for (i in 1:length(x)) { # in case of factors also show available levels as comments so you don't # have to look it up if (is.factor(x[[i]])) options <- paste("# OPTIONS:", paste(levels(x[[i]]), collapse = ", ")) else options <- "" # determine if values need brackets (strings) if (is.numeric(x[[i]]) | is.integer(x[[i]])) values <- paste(x[[i]], collapse = ", ") if (is.character(x[[i]]) | is.factor(x[[i]])) values <- paste0("'", paste0(x[[i]], collapse = "', '"), "'") cat(paste0(var, "$`", names[i], "` <- c(", values,") ", options ,"\n")) } message("\n\t You can copy all lines above to your script and fill in the data.") } } ## ---------------------------------------------------------------------------## ## DOUBLE SQUARE BRACKETS METHOD #' @export `[[<-.DRAC.list` <- function(x, i, value) { ## REJECT ALL INADEQUATE CLASSES ---- acceptedClasses <- c("integer", "character", "numeric", "factor") if (is.na(match(class(value), acceptedClasses))) { warning(paste("I cannot use objects of class", class(value)), call. = FALSE) return(x) } ## CHECK INPUT LENGTH ---- length.old <- length(x[[i]]) length.new <- length(value) if (length.old != length.new) { warning(paste(names(x)[i], ": Input must be of length", length.old), call. = FALSE) return(x) } ## CHECK INPUT CLASS ---- class.old <- class(x[[i]]) class.new <- class(value) ## CHECK INPUT FIELDS THAT ALLOW 'X' ----- # the following checks apply to fields that are normally numeric, but also # accept 'X' as input. this EXCLUDES factors! if (class.old != "factor") { # some input fields allow 'X' as input, so in terms of R can be of class # "character" or "numeric/integer". hence, we check if input is "X" and # if the filed allows it. If so, we change the old class to "character". if (any(value == "X") && attributes(x[[i]])$allowsX) { if (any(is.na(as.numeric(value[which(value != "X")])))) { warning(paste("Cannot coerce <", value[which(value != "X")], "> to a numeric value.", "Input must be numeric or 'X'."), call. = FALSE) return(x) } class.old <- "character" } # where the input field is alreay "X" we have to check whether the new # non-character input is allowed if (any(x[[i]] == "X") && attributes(x[[i]])$allowsX) { if (any(is.na(as.numeric(value[which(value != "X")])))) { warning(paste("Cannot coerce <", value[which(value != "X")], "> to a numeric value.", "Input must be numeric or 'X'. \n"), call. = FALSE) return(x) } class.new <- "character" value <- as.character(value) } # when a numeric input field was inserted an "X" it was coerced to class # character. since we are now allowed to insert any character (later tests) # we need to make sure that the new input can be coerced to class numeric. # and if the new values are numeric, we coerce them to character if (attributes(x[[i]])$allowsX && class.old == "character") { if (any(is.na(as.numeric(value[which(value != "X")])))) { warning(paste("Cannot coerce <", value[which(value != "X")], "> to a numeric value.", "Input must be numeric or 'X'. \n"), call. = FALSE) return(x) } class.new <- "character" value <- as.character(value) } } # numeric input can be both of class 'integer' or 'numeric'. We will # allow any combination and reject only non-numeric/integer input if (class.old == "numeric" || class.old == "integer") { if (class.new != "numeric" && class.new != "integer") { warning(paste(names(x)[i], ": Input must be of class", class.old), call. = FALSE) return(x) } } # for 'factor' and 'character' elements only 'character' input is allowed if (class.old == "factor" || class.old == "character") { if (class.new != "character") { warning(paste(names(x)[i], ": Input must be of class", "character"), call. = FALSE) return(x) } } ## CHECK IF VALID OPTION ---- # in case of 'factor's the user is only allowed input that matches one of # the options specified by the factor levels. if it is a valid option, # the input is converted to a factor to keep the information. if (class.old == "factor") { levels <- levels(x[[i]]) if (any(`%in%`(value, levels) == FALSE)) { warning(paste(names(x)[i], ": Invalid option. Valid options are:", paste(levels, collapse = ", ")), call. = FALSE) return(x) } else { value <- factor(value, levels) } } ## WRITE NEW VALUES ---- # we strip our custom class and the attributes, pass the object to the default generic and # finally re-attach our class and attributes tmp.attributes <- attributes(x[[i]])[names(attributes(x[[i]])) != "class"] class(x) <- "list" x <- `[[<-`(x, i, value) attributes(x[[i]]) <- tmp.attributes if (class.old == "factor") class(x[[i]]) <- "factor" class(x) <- c("DRAC.list", "list") return(x) } ## ---------------------------------------------------------------------------## ## SINGLE SQUARE BRACKET METHOD #' @export `[<-.DRAC.list` <- function(x, i, value) { return(`[[<-`(x, i, value)) } ## ---------------------------------------------------------------------------## ## DOLLAR SIGN METHOD #' @export `$<-.DRAC.list`<- function(x, name, value) { # this is straightforward; retrieve the index and pass the object # to the custom [[<- function, which does the data verification index <- which(names(x) == name) x[[index]] <- value return(x) }Luminescence/R/calc_IEU.R0000644000176200001440000004021713125226556014627 0ustar liggesusers#' Apply the internal-external-uncertainty (IEU) model after Thomsen et al. #' (2007) to a given De distribution #' #' Function to calculate the IEU De for a De data set. #' #' This function uses the equations of Thomsen et al. (2007). The parameters a #' and b are estimated from dose-recovery experiments. #' #' @param data \code{\linkS4class{RLum.Results}} or \link{data.frame} #' (\bold{required}): for \code{data.frame}: two columns with De #' \code{(data[,1])} and De error \code{(values[,2])} #' #' @param a \code{\link{numeric}}: slope #' #' @param b \code{\link{numeric}}: intercept #' #' @param interval \code{\link{numeric}}: fixed interval (e.g. 5 Gy) used for #' iteration of Dbar, from the mean to Lowest.De used to create Graph.IEU #' [Dbar.Fixed vs Z] #' #' @param decimal.point \code{\link{numeric}} (with default): number of decimal #' points for rounding calculations (e.g. 2) #' #' @param plot \code{\link{logical}} (with default): plot output #' #' @param \dots further arguments (\code{trace, verbose}). #' #' @return Returns a plot (optional) and terminal output. In addition an #' \code{\linkS4class{RLum.Results}} object is returned containing the #' following element: #' #' \item{summary}{\link{data.frame} summary of all relevant model results.} #' \item{data}{\link{data.frame} original input data} \item{args}{\link{list} #' used arguments} \item{call}{\link{call} the function call} #' \item{tables}{\link{list} a list of data frames containing all calculation #' tables} #' #' The output should be accessed using the function #' \code{\link{get_RLum}}. #' #' @section Function version: 0.1.0 #' #' @author Rachel Smedley, Geography & Earth Sciences, Aberystwyth University #' (United Kingdom) \cr Based on an excel spreadsheet and accompanying macro #' written by Kristina Thomsen. #' #' @seealso \code{\link{plot}}, \code{\link{calc_CommonDose}}, #' \code{\link{calc_CentralDose}}, \code{\link{calc_FiniteMixture}}, #' \code{\link{calc_FuchsLang2001}}, \code{\link{calc_MinDose}} #' #' @references Smedley, R.K., 2015. A new R function for the Internal External Uncertainty (IEU) model. #' Ancient TL 33, 16-21. #' #' Thomsen, K.J., Murray, A.S., Boetter-Jensen, L. & Kinahan, J., #' 2007. Determination of burial dose in incompletely bleached fluvial samples #' using single grains of quartz. Radiation Measurements 42, 370-379. #' #' @examples #' #' ## load data #' data(ExampleData.DeValues, envir = environment()) #' #' ## apply the IEU model #' ieu <- calc_IEU(ExampleData.DeValues$CA1, a = 0.2, b = 1.9, interval = 1) #' #' @export calc_IEU <- function( data, a, b, interval, decimal.point = 2, plot = TRUE, ... ) { ##==========================================================================## ## CONSISTENCY CHECK OF INPUT DATA ##==========================================================================## if(missing(data)==FALSE){ if(is(data, "data.frame") == FALSE & is(data,"RLum.Results") == FALSE){ stop("[calc_IEU] Error: 'data' object has to be of type 'data.frame' or 'RLum.Results'!") }else{ if(is(data, "RLum.Results") == TRUE){ data <- get_RLum(data, "data") } } } ##==========================================================================## ## ... ARGUMENTS ##==========================================================================## extraArgs <- list(...) ## console output if ("verbose" %in% names(extraArgs)) { verbose <- extraArgs$verbose } else { verbose <- TRUE } # trace calculations if ("trace" %in% names(extraArgs)) { trace <- extraArgs$trace } else { trace <- FALSE } # TODO: main, xlab, ylab, xlim, ylim, pch, col ##============================================================================## ## CALCULATIONS ##============================================================================## empty <- NULL Table.Fixed.Iteration <- data.frame(matrix(nrow = 0, ncol = 9)) colnames(data) <- c("De", "De.Error") data <- data[order(data$De), ] Mean <- mean(data$De) Dbar <- round(Mean, decimal.point) Lowest.De <- round(data$De[1], decimal.point) # (a) Calculate IEU at fixed intervals of Dbar starting from the Mean and # subtracting the interval until Dbar is < Lowest.De; this creates a plot N <- nrow(data) Rank.number <- t(c(1:N)) De.Total.Error <- sqrt((data$De.Error^2) + (((a * Dbar) + b)^2)) Table.Calculations <- data.frame(Rank.number = c(Rank.number), De = c(data$De), De.Total.Error = c(De.Total.Error)) Z.top <- cumsum(Table.Calculations$De/(Table.Calculations$De.Total.Error^2)) Z.bottom <- cumsum(1/(Table.Calculations$De.Total.Error^2)) Z <- Z.top/Z.bottom Table.Calculations["Z"] <- Z temp <- NULL for (j in 1:N) { for (i in j) { Z <- Table.Calculations$Z[j] x <- ((Table.Calculations$De[1:i] - Z)^2)/((Table.Calculations$De.Total.Error[1:i])^2) y <- (sum(x)) temp <- rbind(temp, data.frame(y)) } } EXT.top <- temp EXT.bottom <- (Table.Calculations$Rank.number - 1) * Z.bottom EXT <- EXT.top/EXT.bottom INT <- 1/Z.bottom R <- sqrt(INT/EXT) R.Error <- (2 * (Table.Calculations$Rank.number - 1))^(-0.5) Table.IEU <- data.frame(Table.Calculations$Rank.number, Table.Calculations$De, Table.Calculations$De.Total.Error, Table.Calculations$Z, EXT.top, EXT, INT, R, R.Error) colnames(Table.IEU) <- c("Rank.number", "De", "De.Error", "Z", "EXT.top", "EXT", "INT", "R", "R.Uncertainty") Unity <- Table.IEU[R >= 1, ] Max <- max(Unity$Rank.number, na.rm = TRUE) Above.Z <- Table.IEU[Max, 4] Above.Error <- Table.IEU[Max, 6] Below.Z <- Table.IEU[Max + 1, 4] Below.Error <- Table.IEU[Max + 1, 6] Above.R <- Table.IEU[Max, 8] Below.R <- Table.IEU[Max + 1, 8] Slope <- (Above.R - Below.R)/(Above.Z - Below.Z) Intercept <- Above.R - (Slope * Above.Z) IEU.De <- round(((1 - Intercept)/Slope), decimal.point) IEU.Error <- max(sqrt(Above.Error), sqrt(Below.Error)) IEU.Error <- round(IEU.Error, decimal.point) n <- Max + 1 Dbar.Fixed <- Dbar - interval Dbar.Mean <- c(1, Dbar, Dbar.Fixed, IEU.De, IEU.Error, n, Below.R, a, b) repeat { if (Dbar.Fixed < Lowest.De) { break } else { Dbar <- Dbar.Fixed } De.Total.Error <- sqrt((data$De.Error^2) + (((a * Dbar) + b)^2)) Table.Calculations <- data.frame(Rank.number = c(Rank.number), De = c(data$De), De.Total.Error = c(De.Total.Error)) Z.top <- cumsum(Table.Calculations$De/(Table.Calculations$De.Total.Error^2)) Z.bottom <- cumsum(1/(Table.Calculations$De.Total.Error^2)) Z <- Z.top/Z.bottom Table.Calculations["Z"] <- Z temp <- NULL for (j in 1:N) { for (i in j) { Z <- Table.Calculations$Z[j] x <- ((Table.Calculations$De[1:i] - Z)^2)/((Table.Calculations$De.Total.Error[1:i])^2) y <- (sum(x)) temp <- rbind(temp, data.frame(y)) } } EXT.top <- temp EXT.bottom <- (Table.Calculations$Rank.number - 1) * Z.bottom EXT <- EXT.top/EXT.bottom INT <- 1/Z.bottom R <- sqrt(INT/EXT) R.Error <- (2 * (Table.Calculations$Rank.number - 1))^(-0.5) Table.IEU <- data.frame(Table.Calculations$Rank.number, Table.Calculations$De, Table.Calculations$De.Total.Error, Table.Calculations$Z, EXT.top, EXT, INT, R, R.Error) colnames(Table.IEU) <- c("Rank.number", "De", "De.Error", "Z", "EXT.top", "EXT", "INT", "R", "R.Uncertainty") Unity <- Table.IEU[R >= 1, ] Max <- max(Unity$Rank.number, na.rm = TRUE) Above.Z <- Table.IEU[Max, 4] Above.Error <- Table.IEU[Max, 6] Below.Z <- Table.IEU[Max + 1, 4] Below.Error <- Table.IEU[Max + 1, 6] Above.R <- Table.IEU[Max, 8] Below.R <- Table.IEU[Max + 1, 8] Slope <- (Above.R - Below.R)/(Above.Z - Below.Z) Intercept <- Above.R - (Slope * Above.Z) Zbar <- round(((1 - Intercept)/Slope), decimal.point) Zbar.Error <- max(sqrt(Above.Error), sqrt(Below.Error)) Zbar.Error <- round(IEU.Error, decimal.point) n <- Max + 1 Dbar.Fixed <- Dbar - interval Table.Fixed.Iteration <- rbind(Table.Fixed.Iteration, cbind(1, Dbar, Dbar.Fixed, Zbar, Zbar.Error, n, Below.R, a, b)) } Table.Fixed.Iteration <- rbind(Dbar.Mean, Table.Fixed.Iteration) colnames(Table.Fixed.Iteration) <- c(FALSE, "Dbar", "Dbar.Fixed", "Zbar", "Zbar.Error", "n", "Below.R", "a", "b") if (plot) { plot(Table.Fixed.Iteration$Dbar, Table.Fixed.Iteration$Zbar, type = "b", ylab = "Zbar, weighted mean (Gy)", xlab = "Dbar (Gy)", asp = 1/1) arrows(Table.Fixed.Iteration$Dbar, Table.Fixed.Iteration$Zbar + Table.Fixed.Iteration$Zbar.Error, Table.Fixed.Iteration$Dbar, Table.Fixed.Iteration$Zbar - Table.Fixed.Iteration$Zbar.Error, col = 1, angle = 90, length = 0.05, code = 3) abline(0, 1, untf = FALSE, lty = 3) } # (b) Calculate Dbar by iteration from [Dbar = Lowest.De] until [IEU.De = Dbar]; # this calculates the IEU De Dbar <- Lowest.De N <- nrow(data) Rank.number <- t(c(1:N)) De.Total.Error <- sqrt((data$De.Error^2) + (((a * Dbar) + b)^2)) Table.Calculations <- data.frame(Rank.number = c(Rank.number), De = c(data$De), De.Total.Error = c(De.Total.Error)) Z.top <- cumsum(Table.Calculations$De/(Table.Calculations$De.Total.Error^2)) Z.bottom <- cumsum(1/(Table.Calculations$De.Total.Error^2)) Z <- Z.top/Z.bottom Table.Calculations["Z"] <- Z temp <- NULL for (j in 1:N) { for (i in j) { Z <- Table.Calculations$Z[j] x <- ((Table.Calculations$De[1:i] - Z)^2)/((Table.Calculations$De.Total.Error[1:i])^2) y <- (sum(x)) temp <- rbind(temp, data.frame(y)) } } EXT.top <- temp EXT.bottom <- (Table.Calculations$Rank.number - 1) * Z.bottom EXT <- EXT.top/EXT.bottom INT <- 1/Z.bottom R <- sqrt(INT/EXT) R.Error <- (2 * (Table.Calculations$Rank.number - 1))^(-0.5) Table.IEU <- data.frame(Table.Calculations$Rank.number, Table.Calculations$De, Table.Calculations$De.Total.Error, Table.Calculations$Z, EXT.top, EXT, INT, R, R.Error) colnames(Table.IEU) <- c("Rank.number", "De", "De.Error", "Z", "EXT.top", "EXT", "INT", "R", "R.Uncertainty") Unity <- Table.IEU[R >= 1, ] Max <- max(Unity$Rank.number, na.rm = TRUE) Above.Z <- Table.IEU[Max, 4] Above.Error <- Table.IEU[Max, 6] Below.Z <- Table.IEU[Max + 1, 4] Below.Error <- Table.IEU[Max + 1, 6] Above.R <- Table.IEU[Max, 8] Below.R <- Table.IEU[Max + 1, 8] Slope <- (Above.R - Below.R)/(Above.Z - Below.Z) Intercept <- Above.R - (Slope * Above.Z) IEU.De <- round(((1 - Intercept)/Slope), decimal.point) IEU.Error <- max(sqrt(Above.Error), sqrt(Below.Error)) IEU.Error <- round(IEU.Error, decimal.point) n <- Max + 1 repeat { if (IEU.De <= Dbar) { break } else { Dbar <- IEU.De } De.Total.Error <- sqrt((data$De.Error^2) + (((a * Dbar) + b)^2)) Table.Calculations <- data.frame(Rank.number = c(Rank.number), De = c(data$De), De.Total.Error = c(De.Total.Error)) Z.top <- cumsum(Table.Calculations$De/(Table.Calculations$De.Total.Error^2)) Z.bottom <- cumsum(1/(Table.Calculations$De.Total.Error^2)) Z <- round((Z.top/Z.bottom), decimal.point) Table.Calculations["Z"] <- Z temp <- NULL for (j in 1:N) { for (i in j) { Z <- Table.Calculations$Z[j] x <- ((Table.Calculations$De[1:i] - Z)^2)/((Table.Calculations$De.Total.Error[1:i])^2) y <- (sum(x)) temp <- rbind(temp, data.frame(y)) } } EXT.top <- temp EXT.bottom <- (Table.Calculations$Rank.number - 1) * Z.bottom EXT <- EXT.top/EXT.bottom INT <- 1/Z.bottom R <- sqrt(INT/EXT) R.Error <- (2 * (Table.Calculations$Rank.number - 1))^(-0.5) Table.IEU <- data.frame(Table.Calculations$Rank.number, Table.Calculations$De, Table.Calculations$De.Total.Error, Table.Calculations$Z, EXT.top, EXT, INT, R, R.Error) colnames(Table.IEU) <- c("Rank.number", "De", "De.Error", "Z", "EXT.top", "EXT", "INT", "R", "R.Error") # to reduce the number of plots and increase perfomance # intermediate calculations are only plotted when trace = TRUE if (plot && trace) { ymin <- min(Table.IEU$R[2:nrow(Table.IEU)] - Table.IEU$R.Error[2:nrow(Table.IEU)]) ymax <- max(Table.IEU$R[2:nrow(Table.IEU)] + Table.IEU$R.Error[2:nrow(Table.IEU)]) ylim <- c(ifelse(ymin > 0, 0, ymin), ymax) plot(Table.IEU$Z, Table.IEU$R, type = "b", ylab = expression(paste("R = [", alpha["in"], "/", alpha["ex"],"]")), xlab = "Z [Gy]", ylim = ylim) arrows(Table.IEU$Z, Table.IEU$R + Table.IEU$R.Error, Table.IEU$Z, Table.IEU$R - Table.IEU$R.Error, col = 1, angle = 90, length = 0.05, code = 3) abline(1, 0, untf = FALSE, lty = 3) } Unity <- Table.IEU[R >= 1, ] Max <- max(Unity$Rank.number, na.rm = TRUE) Above.Z <- Table.IEU[Max, 4] Above.Error <- Table.IEU[Max, 6] Below.Z <- Table.IEU[Max + 1, 4] Below.Error <- Table.IEU[Max + 1, 6] Above.R <- Table.IEU[Max, 8] Below.R <- Table.IEU[Max + 1, 8] Slope <- (Above.R - Below.R)/(Above.Z - Below.Z) Intercept <- Above.R - (Slope * Above.Z) IEU.De <- round(((1 - Intercept)/Slope), decimal.point) IEU.Error <- max(sqrt(Above.Error), sqrt(Below.Error)) IEU.Error <- round(IEU.Error, decimal.point) n <- Max + 1 if (trace) { message(sprintf("[Iteration of Dbar] \n Dbar: %.4f \n IEU.De: %.4f \n IEU.Error: %.4f \n n: %i \n R: %.4f \n", Dbar, IEU.De, IEU.Error, n, Below.R)) } } # final plot if (plot) { ymin <- min(Table.IEU$R[2:nrow(Table.IEU)] - Table.IEU$R.Error[2:nrow(Table.IEU)]) ymax <- max(Table.IEU$R[2:nrow(Table.IEU)] + Table.IEU$R.Error[2:nrow(Table.IEU)]) ylim <- c(ifelse(ymin > 0, 0, ymin), ymax) plot(Table.IEU$Z, Table.IEU$R, type = "b", ylab = expression(paste("R = [", alpha["in"], "/", alpha["ex"],"]")), xlab = "Z [Gy]", ylim = ylim) arrows(Table.IEU$Z, Table.IEU$R + Table.IEU$R.Error, Table.IEU$Z, Table.IEU$R - Table.IEU$R.Error, col = 1, angle = 90, length = 0.05, code = 3) abline(1, 0, untf = FALSE, lty = 3) } Table.Results <- data.frame(Dbar, IEU.De, IEU.Error, n, a, b) colnames(Table.Results) <- c("Dbar", "IEU.De (Gy)", "IEU.Error (Gy)", "Number of De", "a", "b") ##==========================================================================## ## TERMINAL OUTPUT ##==========================================================================## if (verbose) { message(sprintf( "\n [calc_IEU] \n\n Dbar: %.2f \n IEU.De (Gy): %.2f \n IEU.Error (Gy): %.2f Number of De: %.0f \n a: %.4f \n b: %.4f", Table.Results[1], Table.Results[2], Table.Results[3], Table.Results[4], Table.Results[5], Table.Results[6])) } ##==========================================================================## ## RETURN VALUES ##==========================================================================## summary <- Table.Results[ ,c(-1, -5, -6)] colnames(summary) <- c("de", "de_err", "n") call <- sys.call() args <- list(a = a, b = b, interval = interval, decimal.point = decimal.point, plot = plot) newRLumResults.calc_IEU <- set_RLum( class = "RLum.Results", data = list(summary = summary, data = data, args = args, call = call, tables = list( Table.IEUCalculations = Table.IEU, Table.Fixed.Iteration = Table.Fixed.Iteration, Table.IEUResults = Table.Results ))) invisible(newRLumResults.calc_IEU) } Luminescence/R/calc_HomogeneityTest.R0000644000176200001440000000760113125226556017334 0ustar liggesusers#' Apply a simple homogeneity test after Galbraith (2003) #' #' A simple homogeneity test for De estimates #' #' For details see Galbraith (2003). #' #' @param data \code{\linkS4class{RLum.Results}} or \link{data.frame} #' (\bold{required}): for \code{data.frame}: two columns with De #' \code{(data[,1])} and De error \code{(values[,2])} #' @param log \code{\link{logical}} (with default): peform the homogeniety test #' with (un-)logged data #' @param \dots further arguments (for internal compatibility only). #' @return Returns a terminal output. In addition an #' \code{\linkS4class{RLum.Results}} object is returned containing the #' following element: #' #' \item{summary}{\link{data.frame} summary of all relevant model results.} #' \item{data}{\link{data.frame} original input data} \item{args}{\link{list} #' used arguments} \item{call}{\link{call} the function call} #' #' The output should be accessed using the function #' \code{\link{get_RLum}} #' @section Function version: 0.2 #' @author Christoph Burow, University of Cologne (Germany) #' @seealso \code{\link{pchisq}} #' @references Galbraith, R.F., 2003. A simple homogeneity test for estimates #' of dose obtained using OSL. Ancient TL 21, 75-77. #' @examples #' #' ## load example data #' data(ExampleData.DeValues, envir = environment()) #' #' ## apply the homogeneity test #' calc_HomogeneityTest(ExampleData.DeValues$BT998) #' #' @export calc_HomogeneityTest <- function( data, log=TRUE, ... ){ ##============================================================================## ## CONSISTENCY CHECK OF INPUT DATA ##============================================================================## if(missing(data)==FALSE){ if(is(data, "data.frame") == FALSE & is(data, "RLum.Results") == FALSE){ stop("[calc_FiniteMixture] Error: 'data' object has to be of type 'data.frame' or 'RLum.Results'!") } else { if(is(data, "RLum.Results") == TRUE){ data <- get_RLum(data, "data") } } } ##==========================================================================## ## ... ARGUMENTS ##==========================================================================## extraArgs <- list(...) ## set plot main title if("verbose" %in% names(extraArgs)) { verbose<- extraArgs$verbose } else { verbose<- TRUE } ##============================================================================## ## CALCULATIONS ##============================================================================## if(log==TRUE){ dat<- log(data) } else { dat<- data } wi<- 1/dat[2]^2 wizi<- wi*dat[1] mu<- sum(wizi)/sum(wi) gi<- wi*(dat[1]-mu)^2 G<- sum(gi) df<- length(wi)-1 n<- length(wi) P<- pchisq(G, df, lower.tail = FALSE) ##============================================================================## ## OUTPUT ##============================================================================## if(verbose == TRUE) { cat("\n [calc_HomogeneityTest]") cat(paste("\n\n ---------------------------------")) cat(paste("\n n: ", n)) cat(paste("\n ---------------------------------")) cat(paste("\n mu: ", round(mu,4))) cat(paste("\n G-value: ", round(G,4))) cat(paste("\n Degrees of freedom:", df)) cat(paste("\n P-value: ", round(P,4))) cat(paste("\n ---------------------------------\n\n")) } ##============================================================================## ## RETURN VALUES ##============================================================================## summary<- data.frame(n=n,g.value=G,df=df,P.value=P) call<- sys.call() args<- list(log=log) newRLumResults.calc_HomogeneityTest <- set_RLum( class = "RLum.Results", data = list( summary=summary, data=data, args=args, call=call )) invisible(newRLumResults.calc_HomogeneityTest) } Luminescence/R/app_RLum.R0000644000176200001440000000155013125226556014737 0ustar liggesusers#' Run Luminescence shiny apps (wrapper) #' #' Wrapper for the function \code{\link[RLumShiny]{app_RLum}} from the package #' \link[RLumShiny]{RLumShiny-package}. For further details and examples please #' see the manual of this package. #' #' @param app \code{\link{character}} (required): name of the application to start. See details for a list #' of available apps. #' @param ... further arguments to pass to \code{\link[shiny]{runApp}} #' #' @author Christoph Burow, University of Cologne (Germany) #' #' @section Function version: 0.1.1 #' #' @export app_RLum <- function(app = NULL, ...) { if (!requireNamespace("RLumShiny", quietly = TRUE)) stop("Shiny applications require the 'RLumShiny' package. To install", " this package run 'install.packages('RLumShiny')' in your R console.", call. = FALSE) RLumShiny::app_RLum(app, ...) }Luminescence/R/plot_RLum.Data.Image.R0000644000176200001440000001475413125226556017040 0ustar liggesusers#' Plot function for an \code{RLum.Data.Image} S4 class object #' #' The function provides a standardised plot output for image data of an #' \code{RLum.Data.Image}S4 class object, mainly using the plot functions #' provided by the \code{\link{raster}} package. #' #' \bold{Details on the plot functions} \cr #' #' Image is visualised as 2D plot usinng generic plot types provided by other #' packages. #' #' Supported plot types: \cr #' #' \bold{\code{plot.type = "plot.raster"}}\cr #' #' Uses the standard plot function for raster data from the package #' \code{\link[raster]{raster}}: \code{\link[raster]{plot}}. For each raster layer in a #' raster brick one plot is produced. #' #' Arguments that are passed through the function call:\cr #' #' \code{main},\code{axes}, \code{xlab}, \code{ylab}, \code{xlim}, \code{ylim}, #' \code{col} #' #' \bold{\code{plot.type = "plotRGB"}}\cr #' #' Uses the function \code{\link[raster]{plotRGB}} from the #' \code{\link[raster]{raster}} package. Only one image plot is produced as all layers #' in a brick a combined. This plot type is useful to see whether any signal #' is recorded by the camera.\cr Arguments that are passed through the function #' call:\cr #' #' \code{main},\code{axes}, \code{xlab}, \code{ylab}, \code{ext}, #' \code{interpolate}, \code{maxpixels}, \code{alpha}, \code{colNA}, #' \code{stretch}\cr #' #' \bold{\code{plot.type = "contour"}}\cr #' #' Uses the function contour plot function from the \code{\link{raster}} #' function (\code{\link[raster]{contour}}). For each raster layer one contour #' plot is produced. Arguments that are passed through the function call:\cr #' #' \code{main},\code{axes}, \code{xlab}, \code{ylab}, \code{xlim}, \code{ylim}, #' \code{col} #' #' @param object \code{\linkS4class{RLum.Data.Image}} (\bold{required}): S4 #' object of class \code{RLum.Data.Image} #' @param par.local \code{\link{logical}} (with default): use local graphical #' parameters for plotting, e.g. the plot is shown in one column and one row. #' If \code{par.local = FALSE} global parameters are inherited. #' @param plot.type \code{\link{character}} (with default): plot types. #' Supported types are \code{plot.raster}, \code{plotRGB} or \code{contour} #' @param \dots further arguments and graphical parameters that will be passed #' to the specific plot functions. #' @return Returns a plot. #' @note This function has been created to faciliate the plotting of image data #' imported by the function \code{\link{read_SPE2R}}. However, so far the #' function is not optimized to handle image data > ca. 200 MByte and thus #' plotting of such data is extremely slow. #' @section Function version: 0.1 #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' @seealso \code{\linkS4class{RLum.Data.Image}}, \code{\link{plot}}, #' \code{\link{plot_RLum}}, \code{\link[raster]{raster}}, #' @references - #' @keywords aplot #' @examples #' #' #' ##load data #' data(ExampleData.RLum.Data.Image, envir = environment()) #' #' ##plot data #' plot_RLum.Data.Image(ExampleData.RLum.Data.Image) #' #' @export plot_RLum.Data.Image <- function( object, par.local = TRUE, plot.type = "plot.raster", ... ){ # Integrity check ----------------------------------------------------------- ##check if object is of class RLum.Data.Image if(class(object) != "RLum.Data.Image"){ stop("[plot_RLum.Data.Image()] Input object is not of type RLum.Data.Image") } ##deal with addition arguments extraArgs <- list(...) ##TODO main <- if("main" %in% names(extraArgs)) {extraArgs$main} else {"RLum.Data.Image"} axes <- if("axes" %in% names(extraArgs)) {extraArgs$axes} else {TRUE} xlab <- if("xlab" %in% names(extraArgs)) {extraArgs$xlab} else {"Length [px]"} ylab <- if("ylab" %in% names(extraArgs)) {extraArgs$ylab} else {"Height [px]"} xlim <- if("xlim" %in% names(extraArgs)) {extraArgs$xlim} else {c(0,dim(get_RLum(object))[2])} ylim <- if("ylim" %in% names(extraArgs)) {extraArgs$ylim} else {c(0,dim(get_RLum(object))[1])} ##plotRGB::ext ext <- if("ext" %in% names(extraArgs)) {extraArgs$ext} else {NULL} ##plotRGB::interpolate interpolate <- if("interpolate" %in% names(extraArgs)) {extraArgs$interpolate} else {FALSE} ##plotRGB::stretch stretch <- if("stretch" %in% names(extraArgs)) {extraArgs$stretch} else {"hist"} ##plotRGB::maxpixels maxpixels <- if("maxpixels" %in% names(extraArgs)) {extraArgs$maxpixels} else {dim(get_RLum(object))[1]*dim(get_RLum(object))[2]} ##plotRGB::alpha alpha <- if("alpha" %in% names(extraArgs)) {extraArgs$alpha} else {255} ##plotRGB::colNA colNA <- if("colNA" %in% names(extraArgs)) {extraArgs$colNA} else {"white"} col <- if("col" %in% names(extraArgs)) {extraArgs$col} else {topo.colors(255)} cex <- if("cex" %in% names(extraArgs)) {extraArgs$cex} else {1} ##par setting for possible combination with plot method for RLum.Analysis objects if(par.local == TRUE){ par(mfrow=c(1,1), cex = cex) } ##grep raster if(plot.type == "plotRGB"){ ## ==========================================================================# ## standard raster plotRGB (package raster) ## ==========================================================================# raster::plotRGB( get_RLum(object), main = main, axes = TRUE, xlab = xlab, ylab = ylab, ext = ext, interpolate = interpolate, maxpixels = maxpixels, alpha = alpha, colNA = colNA, stretch = stretch) ## ==========================================================================# ## standard raster plot (package raster) ## ==========================================================================# }else if(plot.type == "plot.raster"){ plot(get_RLum(object), main = main, xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab, col = col) ## ==========================================================================# ## standard contour (package raster) ## ==========================================================================# }else if(plot.type == "contour"){ for(i in 1:raster::nlayers(get_RLum(object))){ raster::contour(raster::raster(get_RLum(object), layer = i), main = main, xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab, col = col) } }else{ stop("[plot_RLum.Data.Image()] Unknown plot type.") } } Luminescence/R/merge_RLum.Results.R0000644000176200001440000001053113125226556016715 0ustar liggesusers#' Merge function for RLum.Results S4-class objects #' #' Function merges objects of class \code{\linkS4class{RLum.Results}}. The slots in the objects #' are combined depending on the object type, e.g., for \code{\link{data.frame}} and \code{\link{matrix}} #' rows are appended. #' #' @note The originator is taken from the first element and not reset to \code{merge_RLum} #' #' @param objects \code{\link{list}} (required): a list of \code{\linkS4class{RLum.Results}} objects #' #' @section Function version: 0.2.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @export merge_RLum.Results <- function( objects){ ##------------------------------------------------------------- ##Some integrity checks ##check if input object is a list if(!is(objects, "list")){ stop("[merge_RLum.Results()] 'objects' has to of type 'list'!") }else{ ##check if objects in the list are of type RLum.Results temp.originator <- sapply(1:length(objects), function(x){ if(is(objects[[x]], "RLum.Results") == FALSE){ stop("[merge_RLum.Results()] Objects to merge have to be of type 'RLum.Results'!") } objects[[x]]@originator }) } ##check if originator is different if(length(unique(temp.originator))>1){ stop("[merge_RLum.Results()] 'RLum.Results' object originator differs!") } ##------------------------------------------------------------- ##merge objects depending on the data structure for(i in 1:length(objects[[1]]@data)){ ##++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##numeric vector or data.frame or matrix if(is(objects[[1]]@data[[i]], "data.frame")|| is(objects[[1]]@data[[i]], "numeric") || is(objects[[1]]@data[[i]], "matrix")){ ##grep elements and combine them into a list temp.list <- lapply(1:length(objects), function(x) { objects[[x]]@data[[i]] }) ##check whetger the objects can be combined by rbind if(length(unique(unlist(lapply(temp.list, FUN = ncol)))) > 1){ stop("[merge_RLum.Results()] Objects cannot be combined, number of columns differs.") } ##combine them using rbind or data.table::rbindList (depends on the data type) if(is(objects[[1]]@data[[i]], "numeric")){ objects[[1]]@data[[i]] <- unlist(temp.list) }else if(is(objects[[1]]@data[[i]], "matrix")){ objects[[1]]@data[[i]] <- do.call("rbind", temp.list) }else{ objects[[1]]@data[[i]] <- as.data.frame(data.table::rbindlist(temp.list)) } }else{ ##++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##all other elements ##grep elements and write them into a list objects[[1]]@data[[i]] <- lapply(1:length(objects), function(x){ objects[[x]]@data[[i]] }) ##unlist to flatten list if necessary for the elements if(is(objects[[1]]@data[[i]][[1]])[1] == "list"){ objects[[1]]@data[[i]] <- unlist(objects[[1]]@data[[i]], recursive = FALSE) } } }##end loop #return by setting a new RLum.Results (for the .uid) #the originator is not reset objects_merged <- set_RLum( class = "RLum.Results", originator = objects[[1]]@originator, data = objects[[1]]@data, info = unlist(lapply(objects, function(x) { x@info }), recursive = FALSE), .pid = unlist(lapply(objects, function(x) { x@.uid })) ) return(objects_merged) } Luminescence/R/RLum.Analysis-class.R0000644000176200001440000006733113125226556016775 0ustar liggesusers#' @include get_RLum.R set_RLum.R length_RLum.R structure_RLum.R names_RLum.R smooth_RLum.R NULL #' Class \code{"RLum.Analysis"} #' #' Object class to represent analysis data for protocol analysis, i.e. all curves, spectra etc. #' from one measurements. Objects from this class are produced, by e.g. \code{\link{read_XSYG2R}}, #' \code{\link{read_Daybreak2R}} #' #' #' @name RLum.Analysis-class #' #' @docType class #' #' @slot protocol Object of class \code{\link{character}} describing the applied measurement protocol #' #' @slot records Object of class \code{\link{list}} containing objects of class \code{\linkS4class{RLum.Data}} #' #' @note The method \code{\link{structure_RLum}} is currently just avaiblable for objects #' containing \code{\linkS4class{RLum.Data.Curve}}. #' #' @section Objects from the Class: Objects can be created by calls of the form #' \code{set_RLum("RLum.Analysis", ...)}. #' #' @section Class version: 0.4.8 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\link{Risoe.BINfileData2RLum.Analysis}}, #' \code{\linkS4class{Risoe.BINfileData}}, \code{\linkS4class{RLum}} #' #' @keywords classes methods #' #' @examples #' #' showClass("RLum.Analysis") #' #' ##set empty object #' set_RLum(class = "RLum.Analysis") #' #' ###use example data #' ##load data #' data(ExampleData.RLum.Analysis, envir = environment()) #' #' ##show curves in object #' get_RLum(IRSAR.RF.Data) #' #' ##show only the first object, but by keeping the object #' get_RLum(IRSAR.RF.Data, record.id = 1, drop = FALSE) #' #' @export setClass("RLum.Analysis", slots = list( protocol = "character", records = "list" ), contains = "RLum", prototype = list ( protocol = NA_character_, records = list() ) ) #################################################################################################### ###as() #################################################################################################### ##LIST ##COERCE RLum.Analyse >> list AND list >> RLum.Analysis #' as() - RLum-object coercion #' #' for \code{[RLum.Analysis]} #' #' \bold{[RLum.Analysis]}\cr #' #' \tabular{ll}{ #' \bold{from} \tab \bold{to}\cr #' \code{list} \tab \code{list}\cr #' } #' #' Given that the \code{\link{list}} consits of \code{\linkS4class{RLum.Analysis}} objects. #' #' @name as #' #' setAs("list", "RLum.Analysis", function(from,to){ new(to, protocol = NA_character_, records = from) }) setAs("RLum.Analysis", "list", function(from){ lapply(1:length(from@records), function(x){ from@records[[x]] }) }) #################################################################################################### ###show() #################################################################################################### #' @describeIn RLum.Analysis #' Show structure of \code{RLum.Analysis} object #' @export setMethod("show", signature(object = "RLum.Analysis"), function(object){ ##print cat("\n [RLum.Analysis]") ##show slot originator, for compatibily reasons with old example data, here ##a check if(.hasSlot(object, "originator")){cat("\n\t originator:", paste0(object@originator,"()"))} cat("\n\t protocol:", object@protocol) cat("\n\t additional info elements: ", if(.hasSlot(object, "info")){length(object@info)}else{0}) cat("\n\t number of records:", length(object@records)) #skip this part if nothing is included in the object if(length(object@records) > 0){ ##get object class types temp <- vapply(object@records, function(x){ is(x)[1] }, FUN.VALUE = vector(mode = "character", length = 1)) ##print object class types lapply(1:length(table(temp)), function(x){ ##show RLum class type cat("\n\t .. :",names(table(temp)[x]),":",table(temp)[x]) ##show structure ##set width option ... just an implementation for the tutorial output ifelse(getOption("width")<=50, temp.width <- 4, temp.width <- 7) ##set linebreak variable linebreak <- FALSE env <- environment() ##create terminal output terminal_output <- vapply(1:length(object@records), function(i) { if (names(table(temp)[x]) == is(object@records[[i]])[1]) { if (i %% temp.width == 0 & i != length(object@records)) { assign(x = "linebreak", value = TRUE, envir = env) } ##FIRST first <- paste0("#", i, " ", object@records[[i]]@recordType) ##LAST if (i < length(object@records) && !is.null(object@records[[i]]@info[["parentID"]]) && (object@records[[i]]@info[["parentID"]] == object@records[[i+1]]@info[["parentID"]])) { last <- " <> " }else { if(i == length(object@records)){ last <- "" }else if (linebreak){ last <- "\n\t .. .. : " assign(x = "linebreak", value = FALSE, envir = env) }else{ last <- " | " } } return(paste0(first,last)) } }, FUN.VALUE = vector(mode = "character", length = 1)) ##print combined output cat("\n\t .. .. : ", terminal_output, sep = "") }) }else{ cat("\n\t >> This is an empty object and cannot be used for further analysis! <<") } } )##end show method #################################################################################################### ###set_RLum() #################################################################################################### #' @describeIn RLum.Analysis #' Construction method for \code{\linkS4class{RLum.Analysis}} objects. #' #' @param class [\code{set_RLum}] \code{\link{character}} (\bold{required}): name of the \code{RLum} class to be created #' @param originator [\code{set_RLum}] \code{\link{character}} (automatic): contains the name #' of the calling function (the function that produces this object); can be set manually. #' @param .uid [\code{set_RLum}] \code{\link{character}} (automatic): sets an unique ID for this object #' using the internal C++ function \code{.create_UID}. #' @param .pid [\code{set_RLum}] \code{\link{character}} (with default): option to provide a parent id for nesting #' at will. #' @param protocol [\code{set_RLum}] \code{\link{character}} (optional): sets protocol type for #' analysis object. Value may be used by subsequent analysis functions. #' @param records [\code{set_RLum}] \code{\link{list}} (\bold{required}): list of \code{\linkS4class{RLum.Analysis}} objects #' @param info [\code{set_RLum}] \code{\link{list}} (optional): a list containing additional #' info data for the object #' #' \bold{\code{set_RLum}}:\cr #' #' Returns an \code{\linkS4class{RLum.Analysis}} object. #' #' @export setMethod( "set_RLum", signature = "RLum.Analysis", definition = function(class, originator, .uid, .pid, protocol = NA_character_, records = list(), info = list() ) { ##produce empty class object newRLumAnalysis <- new(Class = "RLum.Analysis") ##allow self set to reset an RLum.Analysis object if(is(records, "RLum.Analysis")){ #fill slots (this is much faster than the old code!) newRLumAnalysis@protocol <- if(missing(protocol)){records@protocol}else{protocol} newRLumAnalysis@originator <- originator newRLumAnalysis@records <- records@records newRLumAnalysis@info <- if(missing(info)){records@info}else{c(records@info, info)} newRLumAnalysis@.uid <- .uid newRLumAnalysis@.pid <- if(missing(.pid)){records@.uid}else{.pid} }else{ #fill slots (this is much faster than the old code!) newRLumAnalysis@protocol <- protocol newRLumAnalysis@originator <- originator newRLumAnalysis@records <- records newRLumAnalysis@info <- info newRLumAnalysis@.uid <- .uid newRLumAnalysis@.pid <- .pid } return(newRLumAnalysis) } ) #################################################################################################### ###get_RLum() #################################################################################################### #' @describeIn RLum.Analysis #' Accessor method for RLum.Analysis object. #' #' The slots record.id, recordType, curveType and RLum.type are optional to allow for records #' limited by their id (list index number), their record type (e.g. recordType = "OSL") #' or object type. #' #' Example: curve type (e.g. curveType = "predefined" or curveType ="measured") #' #' The selection of a specific RLum.type object superimposes the default selection. #' Currently supported objects are: RLum.Data.Curve and RLum.Data.Spectrum #' #' @param object \code{[show_RLum]}\code{[get_RLum]}\code{[names_RLum]}\code{[length_RLum]} #' \code{[structure_RLum]}] an object of class \code{\linkS4class{RLum.Analysis}} #' (\bold{required}) #' #' @param record.id [\code{get_RLum}] \code{\link{numeric}} or \code{\link{logical}} (optional): IDs of specific records. #' If of type \code{logical} the entire id range is assuemd and \code{TRUE} and \code{FALSE} indicates the selection. #' #' @param recordType [\code{get_RLum}] \code{\link{character}} (optional): record type (e.g., "OSL"). #' Can be also a vector, for multiple matching, e.g., \code{recordType = c("OSL", "IRSL")} #' #' @param curveType [\code{get_RLum}] \code{\link{character}} (optional): curve #' type (e.g. "predefined" or "measured") #' #' @param RLum.type [\code{get_RLum}] \code{\link{character}} (optional): RLum object type. #' Defaults to "RLum.Data.Curve" and "RLum.Data.Spectrum". #' #' @param get.index [\code{get_RLum}] \code{\link{logical}} (optional): return a numeric #' vector with the index of each element in the RLum.Analysis object. #' #' @param recursive [\code{get_RLum}] \code{\link{logical}} (with default): if \code{TRUE} (the default) #' and the result of the 'get_RLum' request is a single object this object will be unlisted, means #' only the object itself and no list containing exactly one object is returned. Mostly this makes things #' easier, however, if this method is used within a loop this might undesired. #' #' @param drop [\code{get_RLum}] \code{\link{logical}} (with default): coerce to the next possible layer #' (which are \code{RLum.Data}-objects), \code{drop = FALSE} keeps the original \code{RLum.Analysis} #' #' @param info.object [\code{get_RLum}] \code{\link{character}} (optional): name of the wanted info #' element #' #' @param subset \code{\link{expression}} (optional): logical expression indicating elements or rows #' to keep: missing values are taken as false. This argument takes precedence over all #' other arguments, meaning they are not considered when subsetting the object. #' #' @return #' #' \bold{\code{get_RLum}}:\cr #' #' Returns: \cr #' (1) \code{\link{list}} of \code{\linkS4class{RLum.Data}} objects or \cr #' (2) Single \code{\linkS4class{RLum.Data}} object, if only one object is contained and #' \code{recursive = FALSE} or\cr #' (3) \code{\linkS4class{RLum.Analysis}} ojects for \code{drop = FALSE} \cr #' #' @export setMethod("get_RLum", signature = ("RLum.Analysis"), function(object, record.id = NULL, recordType = NULL, curveType = NULL, RLum.type = NULL, protocol = "UNKNOWN", get.index = NULL, drop = TRUE, recursive = TRUE, info.object = NULL, subset = NULL) { if (!is.null(substitute(subset))) { # To account for different lengths and elements in the @info slot we first # check all unique elements info_el <- unique(unlist(sapply(object@records, function(el) names(el@info)))) envir <- as.data.frame(do.call(rbind, lapply(object@records, function(el) { val <- c(curveType = el@curveType, recordType = el@recordType, unlist(el@info)) # add missing info elements and set NA if (any(!info_el %in% names(val))) { val_new <- setNames(rep(NA, length(info_el[!info_el %in% names(val)])), info_el[!info_el %in% names(val)]) val <- c(val, val_new) } # order the named char vector by its names so we dont mix up the columns val <- val[order(names(val))] return(val) }) )) ##select relevant rows sel <- tryCatch(eval( expr = substitute(subset), envir = envir, enclos = parent.frame() ), error = function(e) { stop("\n\n [ERROR] Invalid subset options. \nValid terms are: ", paste(names(envir), collapse = ", ")) }) if (all(is.na(sel))) sel <- FALSE if (any(sel)) { object@records <- object@records[sel] return(object) } else { tmp <- mapply(function(name, op) { message(" ",name, ": ", paste(unique(op), collapse = ", ")) }, names(envir), envir) message("\n [ERROR] Invalid value, please refer to unique options given above.") return(NULL) } } ##if info.object is set, only the info objects are returned else if(!is.null(info.object)) { if(info.object %in% names(object@info)){ unlist(object@info[info.object]) }else{ ##check for entries if(length(object@info) == 0){ warning("[get_RLum] This RLum.Analysis object has no info objects! NULL returned!)") return(NULL) }else{ ##grep names temp.element.names <- paste(names(object@info), collapse = ", ") warning.text <- paste("[get_RLum] Invalid info.object name. Valid names are:", temp.element.names) warning(warning.text, call. = FALSE) return(NULL) } } } else { ##check for records if (length(object@records) == 0) { warning("[get_RLum] This RLum.Analysis object has no records! NULL returned!)") return(NULL) } ##record.id if (is.null(record.id)) { record.id <- c(1:length(object@records)) } else if (!is(record.id, "numeric") & !is(record.id, "logical")) { stop("[get_RLum()] 'record.id' has to be of type 'numeric' or 'logical'!") } ##logical needs a slightly different treatment ##Why do we need this? Because a lot of standard R functions work with logical ##values instead of numerical indicies if (is(record.id, "logical")) { record.id <- c(1:length(object@records))[record.id] } ##check if record.id exists if (FALSE %in% (abs(record.id) %in% (1:length(object@records)))) { try(stop("[get_RLum()] At least one 'record.id' is invalid!", call. = FALSE)) return(NULL) } ##recordType if (is.null(recordType)) { recordType <- unique(unlist(lapply(1:length(object@records), function(x) { object@records[[x]]@recordType }))) } else{ if (!is(recordType, "character")) { stop("[get_RLum()] 'recordType' has to be of type 'character'!") } } ##curveType if (is.null(curveType)) { curveType <- unique(unlist(lapply(1:length(object@records), function(x) { object@records[[x]]@curveType }))) } else if (!is(curveType, "character")) { stop("[get_RLum()] 'curveType' has to be of type 'character'!") } ##RLum.type if (is.null(RLum.type)) { RLum.type <- c("RLum.Data.Curve", "RLum.Data.Spectrum") } else if (!is(RLum.type, "character")) { stop("[get_RLum()] 'RLum.type' has to be of type 'character'!") } ##get.index if (is.null(get.index)) { get.index <- FALSE } else if (!is(get.index, "logical")) { stop("[get_RLum()] 'get.index' has to be of type 'logical'!") } ##get originator if (.hasSlot(object, "originator")) { originator <- object@originator } else{ originator <- NA_character_ } ##-----------------------------------------------------------------## ##a pre-selection is necessary to support negative index selection object@records <- object@records[record.id] record.id <- 1:length(object@records) ##select curves according to the chosen parameter if (length(record.id) > 1) { temp <- lapply(record.id, function(x) { if (is(object@records[[x]])[1] %in% RLum.type == TRUE) { ##as input a vector is allowed temp <- lapply(1:length(recordType), function(k) { ##translate input to regular expression recordType[k] <- glob2rx(recordType[k]) recordType[k] <- substr(recordType[k], start = 2, stop = nchar(recordType[k]) - 1) if (grepl(recordType[k], object@records[[x]]@recordType) == TRUE & object@records[[x]]@curveType %in% curveType) { if (!get.index) { object@records[[x]] } else{ x } } }) ##remove empty entries and select just one to unlist temp <- temp[!sapply(temp, is.null)] ##if list has length 0 skip entry if (length(temp) != 0) { temp[[1]] } else{ temp <- NULL } } }) ##remove empty list element temp <- temp[!sapply(temp, is.null)] ##check if the produced object is empty and show warning message if (length(temp) == 0) { warning("[get_RLum()] This request produced an empty list of records!") } ##remove list for get.index if (get.index) { return(unlist(temp)) } else{ if (!drop) { temp <- set_RLum( class = "RLum.Analysis", originator = originator, records = temp, protocol = object@protocol, .pid = object@.pid ) return(temp) } else{ if (length(temp) == 1 & recursive == TRUE) { return(temp[[1]]) } else{ return(temp) } } } } else{ if (get.index == FALSE) { if (drop == FALSE) { ##needed to keep the argument drop == TRUE temp <- set_RLum( class = "RLum.Analysis", originator = originator, records = list(object@records[[record.id]]), protocol = object@protocol, .pid = object@.pid ) return(temp) } else{ return(object@records[[record.id]]) } } else{ return(record.id) } } } }) #################################################################################################### ###structure_RLum() #################################################################################################### #' @describeIn RLum.Analysis #' Method to show the structure of an \code{\linkS4class{RLum.Analysis}} object. #' #' @param fullExtent [structure_RLum] \code{\link{logical}} (with default): extents the returned \code{data.frame} #' to its full extent, i.e. all info elements are part of the return as well. The default valule #' is \code{FALSE} as the data frame might become rather big. #' #' @return #' #' \bold{\code{structure_RLum}}:\cr #' #' Returns \code{\linkS4class{data.frame}} showing the structure. #' #' @export setMethod("structure_RLum", signature= "RLum.Analysis", definition = function(object, fullExtent = FALSE) { ##check if the object containing other elements than allowed if(length(grep(FALSE, sapply(object@records, is, class="RLum.Data.Curve")))!=0){ stop("[structure_RLum()] Only 'RLum.Data.Curve' objects are allowed!" ) } ##get length object temp.object.length <- length(object@records) ##ID temp.id <- 1:temp.object.length ##OBJECT TYPE temp.recordType <- c(NA) length(temp.recordType) <- temp.object.length temp.recordType <- sapply(1:temp.object.length, function(x){object@records[[x]]@recordType}) ##PROTOCOL STEP temp.protocol.step <- c(NA) length(temp.protocol.step) <- temp.object.length ##n.channels temp.n.channels <- sapply(1:temp.object.length, function(x){length(object@records[[x]]@data[,1])}) ##X.MIN temp.x.min <- sapply(1:temp.object.length, function(x){min(object@records[[x]]@data[,1])}) ##X.MAX temp.x.max <- sapply(1:temp.object.length, function(x){max(object@records[[x]]@data[,1])}) ##y.MIN temp.y.min <- sapply(1:temp.object.length, function(x){min(object@records[[x]]@data[,2])}) ##X.MAX temp.y.max <- sapply(1:temp.object.length, function(x){max(object@records[[x]]@data[,2])}) ##.uid temp.uid <- unlist(lapply(object@records, function(x){x@.uid})) ##.pid temp.pid <- unlist(lapply(object@records, function(x){x@.pid})) ##originator temp.originator <- unlist(lapply(object@records, function(x){x@originator})) ##curveType temp.curveType <- unlist(lapply(object@records, function(x){x@curveType})) ##info elements as character value if (fullExtent) { temp.info.elements <- as.data.frame(data.table::rbindlist(lapply(object@records, function(x) { x@info }), fill = TRUE)) } else{ temp.info.elements <- unlist(sapply(1:temp.object.length, function(x) { if (length(object@records[[x]]@info) != 0) { do.call(paste, as.list(names(object@records[[x]]@info))) } else{ NA } })) } ##combine output to a data.frame return( data.frame( id = temp.id, recordType = temp.recordType, curveType = temp.curveType, protocol.step = temp.protocol.step, n.channels = temp.n.channels, x.min = temp.x.min, x.max = temp.x.max, y.min = temp.y.min, y.max = temp.y.max, originator = temp.originator, .uid = temp.uid, .pid = temp.pid, info = temp.info.elements, stringsAsFactors = FALSE ) ) }) #################################################################################################### ###length_RLum() #################################################################################################### #' @describeIn RLum.Analysis #' Returns the length of the object, i.e., number of stored records. #' #' @return #' #' \bold{\code{length_RLum}}\cr #' #' Returns the number records in this object. #' #' @export setMethod("length_RLum", "RLum.Analysis", function(object){ length(object@records) }) #################################################################################################### ###names_RLum() #################################################################################################### #' @describeIn RLum.Analysis #' Returns the names of the \code{\linkS4class{RLum.Data}} objects objects (same as shown with the show method) #' #' @return #' #' \bold{\code{names_RLum}}\cr #' #' Returns the names of the record types (recordType) in this object. #' #' @export setMethod("names_RLum", "RLum.Analysis", function(object){ sapply(1:length(object@records), function(x){ object@records[[x]]@recordType}) }) #################################################################################################### ###smooth_RLum() #################################################################################################### #' @describeIn RLum.Analysis #' #' Smoothing of \code{RLum.Data} objects contained in this \code{RLum.Analysis} object #' \code{\link[zoo]{rollmean}} or \code{\link[zoo]{rollmedian}}. #' In particular the internal function \code{.smoothing} is used. #' #' @param ... further arguments passed to underlying methods #' #' @return #' #' \bold{\code{smooth_RLum}}\cr #' #' Same object as input, after smoothing #' #' @export setMethod( f = "smooth_RLum", signature = "RLum.Analysis", function(object, ...) { object@records <- lapply(object@records, function(x){ smooth_RLum(x, ...) }) return(object) } ) Luminescence/R/methods_RLum.R0000644000176200001440000004465613125226556015640 0ustar liggesusers################################################################################## ## METHODS FOR S3 GENERICS ## ################################################################################## ##CAUTION NOTE: ##(1) Please DO NOT access to the S4 objects by using the slots this causes inconsistent ## behaviour, please use the correspong RLum-methods instead! ## ##(2) Especially, please DO NOT include S3-methods for which no S4-method is implemented! Especially ##for coercing. ## ##(3) Finally, what ever you want to implemnt, check whether a S4-method exists, it should ##be just passed to this methods, not the opposite, otherwise this will yield in undesired behaviour. ## ##TODO: For this S3 generics so far no proper documentation exists ... we should consider ##to provide an overview within a separat document, as it becomes otherwise rather ##complicated for beginners to work with the documentation. ## ## -------------------- INTRODUCED WITH 0.5.0 ----------------------- ## #' methods_RLum #' #' Methods for S3-generics implemented for the package 'Luminescence'. #' This document summarises all implemented S3-generics. The name of the function #' is given before the first dot, after the dot the name of the object that is supported by this method #' is given, e.g. \code{plot.RLum.Data.Curve} can be called by \code{plot(object, ...)}, where #' \code{object} is the \code{RLum.Data.Curve} object. #' #' The term S3-generics sounds complicated, however, it just means that something has been implemented #' in the package to increase the usability for users new in R and who are not familiar with the #' underlying \code{RLum}-object structure of the package. The practical outcome is that #' operations and functions presented in standard books on R can be used without knowing the specifica #' of the R package 'Luminescence'. For examples see the example section. #' #' @param x \code{\linkS4class{RLum}} or \code{\linkS4class{Risoe.BINfileData}} (\bold{required}): input opject #' #' @param object \code{\linkS4class{RLum}} (\bold{required}): input opject #' #' @param y \code{\link{integer}} (optional): the row index of the matrix, data.frame #' #' @param z \code{\link{integer}} (optional): the column index of the matrix, data.frame #' #' @param i \code{\link{character}} (optional): name of the wanted record type or data object or row in the \code{RLum.Data.Curve} object #' #' @param j \code{\link{integer}} (optional): column of the data matrix in the \code{RLum.Data.Curve} object #' #' @param value \code{\link{numeric}} \bold{(required)}: numeric value which replace the value in the #' \code{RLum.Data.Curve} object #' #' @param drop \code{\link{logical}} (with default): keep object structure or drop it #' #' @param subset \code{[subset]} \code{\link{expression}} (\bold{required}): logical expression indicating elements or rows to keep, #' this function works in \code{\linkS4class{Risoe.BINfileData}} objects like \code{\link{subset.data.frame}}, but takes care #' of the object structure #' #' @param row.names \code{\link{logical}} (with default): enables or disables row names (\code{as.data.frame}) #' #' @param recursive \code{\link{logical}} (with default): enables or disables further subsetting (\code{unlist}) #' #' @param optional \code{\link{logical}} (with default): logical. If TRUE, setting row names and #' converting column names (to syntactic names: see make.names) is optional (see \code{\link[base]{as.data.frame}}) #' #' @param ... further arguments that can be passed to the method #' #' @note \code{methods_RLum} are not really new functions, everything given here are mostly just #' surrogates for existing functions in the package. #' #' @examples #' #' ##load example data #' data(ExampleData.RLum.Analysis, envir = environment()) #' #' @name methods_RLum NULL #################################################################################################### # methods for generic: plot() # ################################################################################################## #' @rdname methods_RLum #' @method plot list #' @export plot.list <- function(x, y, ...) { if (all(sapply(x, function(x) inherits(x, "RLum")))) { plot_RLum(object = x, ...) } else { if (missing(y)) y <- NULL plot.default(x, y, ...) } } #' @rdname methods_RLum #' @method plot RLum.Results #' @export plot.RLum.Results <- function(x, y, ...) plot_RLum(object = x, ...) #' @rdname methods_RLum #' @method plot RLum.Analysis #' @export plot.RLum.Analysis <- function(x, y, ...) plot_RLum(object = x, ...) #' @rdname methods_RLum #' @method plot RLum.Data.Curve #' @export plot.RLum.Data.Curve <- function(x, y, ...) plot_RLum(object = x, ...) #' @rdname methods_RLum #' @method plot RLum.Data.Spectrum #' @export plot.RLum.Data.Spectrum <- function(x, y, ...) plot_RLum(object = x, ...) #' @rdname methods_RLum #' @method plot RLum.Data.Image #' @export plot.RLum.Data.Image <- function(x, y, ...) plot_RLum(object = x, ...) #' @rdname methods_RLum #' @method plot Risoe.BINfileData #' @export plot.Risoe.BINfileData <- function(x, y, ...) plot_Risoe.BINfileData(BINfileData = x, ...) #################################################################################################### # methods for generic: hist() # ################################################################################################## #' @rdname methods_RLum #' @export hist.RLum.Results <- function(x, ...) plot_Histogram(data = x, ...) #' @rdname methods_RLum #' @export hist.RLum.Data.Image <- function(x, ...) hist(x =get_RLum(x)@data@values, ...) #' @rdname methods_RLum #' @export hist.RLum.Data.Curve <- function(x, ...) hist(as(get_RLum(x),"matrix")[,2]) #' @rdname methods_RLum #' @export hist.RLum.Analysis <- function(x, ...) lapply(1:length_RLum(x), function(z){ hist(as(get_RLum(x, record.id = z, ...),"matrix")[,2])}) #################################################################################################### # methods for generic: summary() # ################################################################################################## # methods for generic: summary() #' @rdname methods_RLum #' @method summary RLum.Results #' @export summary.RLum.Results <- function(object, ...) get_RLum(object = object, ...) #' @rdname methods_RLum #' @method summary RLum.Analysis #' @export summary.RLum.Analysis <- function(object, ...) lapply(object@records, function(x) summary(x@data)) #' @rdname methods_RLum #' @method summary RLum.Data.Image #' @export summary.RLum.Data.Image <- function(object, ...) summary(object@data@data@values) # summary.RLum.Data.Spectrum <- function(object, ...) #' @rdname methods_RLum #' @method summary RLum.Data.Curve #' @export summary.RLum.Data.Curve <- function(object, ...) summary(object@data, ...) #################################################################################################### # methods for generic: subset() # ################################################################################################## #' @rdname methods_RLum #' @method subset Risoe.BINfileData #' @param records.rm [subset] \code{\link{logical}} (with default): remove records from data set, can #' be disabled, to just set the column \code{SET} to \code{TRUE} or \code{FALSE} #' @export subset.Risoe.BINfileData <- function(x, subset, records.rm = TRUE, ...) { if(length(list(...))) warning(paste("Argument not supported and skipped:", names(list(...)))) ##select relevant rows sel <- tryCatch(eval( expr = substitute(subset), envir = x@METADATA, enclos = parent.frame() ), error = function(e) { stop("\n\nInvalid subset options. \nValid terms are: ", paste(names(x@METADATA), collapse = ", ")) }) ##probably everything is FALSE now? if (records.rm) { if (any(sel)) { x@METADATA <- x@METADATA[sel, ] x@DATA <- x@DATA[sel] x@METADATA[["ID"]] <- 1:length(x@METADATA[["ID"]]) return(x) } else{ return(NULL) } }else{ x@METADATA[["SEL"]] <- sel return(x) } } #' @rdname methods_RLum #' @method subset RLum.Analysis #' @export subset.RLum.Analysis <- function(x, subset, ...) { do.call(get_RLum, list(object = x, drop = FALSE, subset = substitute(subset))) } #################################################################################################### # methods for generic: bin() # ################################################################################################## #' @rdname methods_RLum #' @export bin.RLum.Data.Curve <- function(x, ...) bin_RLum.Data(x) #################################################################################################### # methods for generic: length() # ################################################################################################## #' @rdname methods_RLum #' @export length.RLum.Results <- function(x, ...) length_RLum(x) #' @rdname methods_RLum #' @export length.RLum.Analysis <- function(x, ...) length_RLum(x) #' @rdname methods_RLum #' @export length.RLum.Data.Curve <- function(x, ...) length_RLum(x) #' @rdname methods_RLum #' @export length.Risoe.BINfileData <- function(x, ...) length(x@METADATA$ID) #################################################################################################### # methods for generic: dim() # ################################################################################################## # methods for generic: dim() #' @rdname methods_RLum #' @export dim.RLum.Data.Curve <- function(x) dim(as(x, "matrix")) #' @rdname methods_RLum #' @export dim.RLum.Data.Spectrum <- function(x) dim(as(x, "matrix")) #################################################################################################### # methods for generic: rep() # ################################################################################################## #' @rdname methods_RLum #' @export rep.RLum <- function(x, ...) replicate_RLum(x, ...) #################################################################################################### # methods for generic: name() # ################################################################################################## #' @rdname methods_RLum #' @export names.RLum.Data.Curve <- function(x, ...) names_RLum(x) #' @rdname methods_RLum #' @export names.RLum.Data.Spectrum <- function(x, ...) names_RLum(x) #' @rdname methods_RLum #' @export names.RLum.Data.Image <- function(x, ...) names_RLum(x) #' @rdname methods_RLum #' @export names.RLum.Analysis <- function(x, ...) names_RLum(x) #' @rdname methods_RLum #' @export names.RLum.Results <- function(x, ...) names_RLum(x) #' @rdname methods_RLum #' @export names.Risoe.BINfileData <- function(x) as.character(x@METADATA$LTYPE) #################################################################################################### # methods for generic: row.name() # ################################################################################################## #' @rdname methods_RLum #' @export row.names.RLum.Data.Spectrum <- function(x, ...) rownames(as(x, "matrix")) #################################################################################################### # methods for generic: as.data.frame() # ################################################################################################## #' @rdname methods_RLum #' @export as.data.frame.RLum.Data.Curve <- function(x, row.names = NULL, optional = FALSE, ...) as(x, "data.frame") #' @rdname methods_RLum #' @export as.data.frame.RLum.Data.Spectrum <- function(x, row.names = NULL, optional = FALSE, ...) as(x, "data.frame") # for RLum.Results ... makes no sense and may yield in unpredictable behaviour #################################################################################################### # methods for generic: as.list() # ################################################################################################## #' @rdname methods_RLum #' @export as.list.RLum.Results <- function(x, ...) as(x, "list") #' @rdname methods_RLum #' @export as.list.RLum.Data.Curve <- function(x, ...) as(x, "list") #' @rdname methods_RLum #' @export as.list.RLum.Analysis <- function(x, ...) as(x, "list") #################################################################################################### # methods for generic: as.matrix() # ################################################################################################## #' @rdname methods_RLum #' @export as.matrix.RLum.Data.Curve <- function(x, ...) as(x, "matrix") #' @rdname methods_RLum #' @export as.matrix.RLum.Data.Spectrum <- function(x, ...) as(x, "matrix") # for RLum.Results ... makes no sense and may yield in unpredictable behaviour #################################################################################################### # methods for generic: is() #################################################################################################### #For this function no S4 method was written, as this would come at the cost of performance and #is totally unnecessary #' @rdname methods_RLum #' @export is.RLum <- function(x, ...) is(x, "RLum") #' @rdname methods_RLum #' @export is.RLum.Data <- function(x, ...) is(x, "RLum.Data") #' @rdname methods_RLum #' @export is.RLum.Data.Curve <- function(x, ...) is(x, "RLum.Data.Curve") #' @rdname methods_RLum #' @export is.RLum.Data.Spectrum <- function(x, ...) is(x, "RLum.Data.Spectrum") #' @rdname methods_RLum #' @export is.RLum.Data.Image <- function(x, ...) is(x, "RLum.Data.Image") #' @rdname methods_RLum #' @export is.RLum.Analysis <- function(x, ...) is(x, "RLum.Analysis") #' @rdname methods_RLum #' @export is.RLum.Results <- function(x, ...) is(x, "RLum.Results") #################################################################################################### # methods for generic: merge() #################################################################################################### #' @rdname methods_RLum #' @export merge.RLum <- function(x, y, ...) merge_RLum(append(list(...), values = c(x, y))) #################################################################################################### # methods for generic: unlist() #################################################################################################### #' @rdname methods_RLum #' @method unlist RLum.Analysis #' @export unlist.RLum.Analysis <- function(x, recursive = TRUE, ...){ temp <- get_RLum(object = x, recursive = recursive, ... ) if(recursive){ unlist(lapply(1:length(temp), function(x){ get_RLum(temp) }), recursive = FALSE) }else{ return(temp) } } #################################################################################################### # methods for generic: `+` #################################################################################################### #' @rdname methods_RLum #' #' @examples #' #' ##combine curve is various ways #' curve1 <- IRSAR.RF.Data[[1]] #' curve2 <- IRSAR.RF.Data[[1]] #' curve1 + curve2 #' curve1 - curve2 #' curve1 / curve2 #' curve1 * curve2 #' #' @export `+.RLum.Data.Curve` <- function(x, y) merge_RLum(list(x, y), merge.method = "sum") #################################################################################################### # methods for generic: `-` #################################################################################################### #' @rdname methods_RLum #' @export `-.RLum.Data.Curve` <- function(x, y) merge_RLum(list(x, y), merge.method = "-") #################################################################################################### # methods for generic: `*` #################################################################################################### #' @rdname methods_RLum #' @export `*.RLum.Data.Curve` <- function(x, y) merge_RLum(list(x, y), merge.method = "*") #################################################################################################### # methods for generic: `/` #################################################################################################### #' @rdname methods_RLum #' @export `/.RLum.Data.Curve` <- function(x, y) merge_RLum(list(x, y), merge.method = "/") #################################################################################################### # methods for generic: `[` #################################################################################################### #' @rdname methods_RLum #' @export `[.RLum.Data.Curve` <- function(x,y,z, drop = TRUE) {as(x, "matrix")[y,z, drop = drop]} #' @rdname methods_RLum #' @export `[.RLum.Data.Spectrum` <- function(x,y,z, drop = TRUE) {as(x, "matrix")[y,z, drop = drop]} #' @rdname methods_RLum #' @export `[.RLum.Data.Image` <- function(x,y,z, drop = TRUE) {as(x, "matrix")[y,z, drop = drop]} #' @rdname methods_RLum #' @export `[.RLum.Analysis` <- function(x, i, drop = FALSE) { if (is(i, "character")) { get_RLum(x, recordType = i, drop = drop) } else{ get_RLum(x, record.id = i, drop = drop) } } #' @rdname methods_RLum #' @export `[.RLum.Results` <- function(x, i, drop = TRUE) {get_RLum(x, data.object = i, drop = drop)} #################################################################################################### # methods for generic: `[<-` #################################################################################################### #' @rdname methods_RLum #' @export `[<-.RLum.Data.Curve` <- function(x, i, j, value){ x@data[i,j] <- value #this is without any S4-method, but otherwise the overhead it too high return(x) } #################################################################################################### # methods for generic: `[[` #################################################################################################### #' @rdname methods_RLum #' @export `[[.RLum.Analysis` <- function(x, i) { if (is(i, "character")) { get_RLum(x, recordType = i) } else{ get_RLum(x, record.id = i) } } #' @rdname methods_RLum #' @export `[[.RLum.Results` <- function(x, i) {get_RLum(x, data.object = i)} #################################################################################################### # methods for generic: `$` #################################################################################################### #' @rdname methods_RLum #' @export `$.RLum.Data.Curve` <- function(x, i) {get_RLum(x, info.object = i)} #' @rdname methods_RLum #' #' @examples #' #' ##`$` access curves #' IRSAR.RF.Data$RF #' #' @export `$.RLum.Analysis` <- function(x, i) {get_RLum(x, recordType = i)} #' @rdname methods_RLum #' @export `$.RLum.Results` <- function(x, i) {get_RLum(x, data.object = i)} Luminescence/R/extract_IrradiationTimes.R0000644000176200001440000003531013125226556020222 0ustar liggesusers#' Extract Irradiation Times from an XSYG-file #' #' 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. #' #' 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). \cr #' #' Typical application example: g-value estimation from fading measurements #' using the Analyst or any other self written script.\cr #' #' Beside the some simple data transformation steps the function applies the #' functions \code{\link{read_XSYG2R}}, \code{\link{read_BIN2R}}, #' \code{\link{write_R2BIN}} for data import and export. #' #' @param object \code{\link{character}} (\bold{required}) or #' \code{\linkS4class{RLum.Analysis}} object or \code{\link{list}}: path and file name of the XSYG #' file or an \code{\linkS4class{RLum.Analysis}} produced by the function #' \code{\link{read_XSYG2R}}; alternatively a \code{list} of \code{\linkS4class{RLum.Analysis}} can #' be provided. \cr #' #' \bold{Note}: If an \code{\linkS4class{RLum.Analysis}} is used, any input for #' the arguments \code{file.BINX} and \code{recordType} will be ignored! #' #' @param file.BINX \code{\link{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.\cr Note: The XSYG and the BINX-file have to be originate from the #' same measurement! #' #' @param recordType \code{\link{character}} (with default): select relevant #' curves types from the XSYG file or \code{\linkS4class{RLum.Analysis}} #' 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 #' \code{\link{get_RLum}}. The argument \code{recordType} works as #' described for this function. \cr #' #' Note: A wrong selection will causes a function error. Please change this #' argument only if you have reasons to do so. #' @param compatibility.mode \code{\link{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.\code{\link{write_R2BIN}} #' @param txtProgressBar \code{\link{logical}} (with default): enables #' \code{TRUE} or disables \code{FALSE} the progression bars during import and #' export #' #' @return An \code{\linkS4class{RLum.Results}} object is returned with the #' following structure:\cr .. $irr.times (data.frame)\cr #' #' 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 \code{file.BINX} is ignored.\cr #' #' In the self call mode (input is a \code{list} of \code{\linkS4class{RLum.Analysis}} objects #' a list of \code{\linkS4class{RLum.Results}} 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 separat sequences steps.\cr #' #' BINX-file 'Time Since Irradiation' value differs from the table output?\cr #' #' 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 \code{TIMESINCELAS.STEP}? \cr #' #' 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 #' (\code{\link{read_XSYG2R}}) do not change the order of entries for one step #' towards a correct time order. #' #' @section Function version: 0.3.1 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\linkS4class{RLum.Analysis}}, #' \code{\linkS4class{RLum.Results}}, \code{\linkS4class{Risoe.BINfileData}}, #' \code{\link{read_XSYG2R}}, \code{\link{read_BIN2R}}, \code{\link{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) #' #' @export extract_IrradiationTimes <- function( object, file.BINX, recordType = c("irradiation (NA)", "IRSL (UVVIS)", "OSL (UVVIS)", "TL (UVVIS)"), compatibility.mode = TRUE, txtProgressBar = TRUE ){ # SELF CALL ----------------------------------------------------------------------------------- if(is.list(object)){ ##show message for non-supported arguments if(!missing(file.BINX)){ warning("[extract_IrradiationTimes()] argument 'file.BINX' is not supported in the self call mode.", call. = FALSE) } ##extent arguments ##extent recordType if(is(recordType, "list")){ recordType <- rep(recordType, length = length(object)) }else{ recordType <- rep(list(recordType), length = length(object)) } ##run function results <- lapply(1:length(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 ----------------------------------------------------------------------------- ##check whether an character or an RLum.Analysis object is provided if(is(object)[1] != "character" & is(object)[1] != "RLum.Analysis"){ stop("[extract_IrradiationTimes()] Input object is neither of type 'character' nor of type 'RLum.Analysis'.") }else if(is(object)[1] == "character"){ ##set object to file.XSYG file.XSYG <- object ##XSYG ##check if file exists if(file.exists(file.XSYG) == FALSE){ stop("[extract_IrradiationTimes()] Wrong XSYG file name or file does not exsits!") } ##check if file is XML file if(tail(unlist(strsplit(file.XSYG, split = "\\.")), 1) != "xsyg" & tail(unlist(strsplit(file.XSYG, split = "\\.")), 1) != "XSYG" ){ stop("[extract_IrradiationTimes()] File is not of type 'XSYG'!") } ##BINX if(!missing(file.BINX)){ ##check if file exists if(file.exists(file.BINX) == FALSE){ stop("[extract_IrradiationTimes()] Wrong BINX file name or file does not exist!", call. = FALSE) } ##check if file is XML file if(tail(unlist(strsplit(file.BINX, split = "\\.")), 1) != "binx" & tail(unlist(strsplit(file.BINX, split = "\\.")), 1) != "BINX" ){ stop("[extract_IrradiationTimes()] File is not of type 'BINX'!", call. = FALSE) } } # Settings and import XSYG -------------------------------------------------------------------- temp.XSYG <- read_XSYG2R(file.XSYG, txtProgressBar = txtProgressBar) if(!missing(file.BINX)){ temp.BINX <- read_BIN2R(file.BINX, txtProgressBar = txtProgressBar) temp.BINX.dirname <- (dirname(file.XSYG)) } # Some data preparation ----------------------------------------------------------------------- ##set list temp.sequence.list <- list() ##select all analysis objects and combinde 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(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 <- vapply(X = 1:length_RLum(temp.sequence), FUN = function(x){ get_RLum(temp.sequence, record.id = x)@recordType }, FUN.VALUE = vector(mode = "character", length = 1)) #START time of each step temp.START <- unname(vapply(X = 1:length_RLum(temp.sequence), FUN = function(x){ get_RLum(get_RLum(temp.sequence, record.id = x), info.object = c("startDate")) }, FUN.VALUE = vector(mode = "character", length = 1))) ##DURATION of each STEP DURATION.STEP <- vapply(X = 1:length_RLum(temp.sequence), FUN = function(x){ # get_RLum(get_RLum(temp.sequence, record.id = x), info.object = c("endDate")) max(get_RLum(get_RLum(temp.sequence, record.id = x))[,1]) #print(get_RLum(temp.sequence, record.id = x)) }, FUN.VALUE = vector(mode = "numeric", length = 1)) #print(DURATION.STEP) ##a little bit reformatting. START <- strptime(temp.START, format = "%Y%m%d%H%M%S", tz = "GMT") ##Calculate END time of each STEP END <- START + DURATION.STEP ##add position number so far an XSYG file was the input if(exists("file.XSYG")){ POSITION <- rep(temp.sequence.position, each = length_RLum(temp.sequence)) }else if(!inherits(try( get_RLum( get_RLum(temp.sequence, record.id = 1), info.object = "position"), silent = TRUE), "try-error")){ ##DURATION of each STEP POSITION <- unname(sapply(1:length_RLum(temp.sequence), function(x){ get_RLum(get_RLum(temp.sequence, record.id = x),info.object = "position") })) }else{ POSITION <- NA } ##Combine the results temp.results <- data.frame(POSITION,STEP,START,DURATION.STEP,END) # Calculate irradiation duration ------------------------------------------------------------ ##set objects time.irr.duration <- NA IRR_TIME <- unlist(sapply(1:nrow(temp.results), function(x){ if(temp.results[x,"STEP"] == "irradiation (NA)"){ time.irr.duration <<- temp.results[x,"DURATION.STEP"] return(0) }else{ if(is.na(time.irr.duration)){ return(0) }else{ return(time.irr.duration) } } })) # Calculate time since irradiation ------------------------------------------------------------ ##set objects time.irr.end <- NA TIMESINCEIRR <- unlist(sapply(1:nrow(temp.results), function(x){ if(temp.results[x,"STEP"] == "irradiation (NA)"){ 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[-which(results[,"STEP"] == "irradiation (NA)"),] ##(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 thi ##paramter, to make the file compatible to the Analyst temp.BINX@METADATA[["TIMESINCEIRR"]] <- results.BINX[["IRR_TIME"]] + results.BINX[["TIMESINCEIRR"]] ##(2) compare entries in the BINX-file with the entries in the table to make sure ## that both have the same length if(!missing(file.BINX)){ if(nrow(results.BINX) == nrow(temp.BINX@METADATA)){ ##update BINX-file try <- write_R2BIN(temp.BINX, version = "06", file = paste0(file.BINX,"_extract_IrradiationTimes.BINX"), compatibility.mode = compatibility.mode, 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{ try( stop("[extract_IrradiationTimes()] XSYG-file and BINX-file did not contain similar entries. BINX-file update skipped!",call. = FALSE)) } } # Output -------------------------------------------------------------------------------------- return(set_RLum(class = "RLum.Results", data = list(irr.times = results))) } Luminescence/R/plot_RLum.R0000644000176200001440000001304013125226556015132 0ustar liggesusers#' 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 #' \code{\linkS4class{RLum}} 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}{ #' \bold{object} \tab \tab \bold{corresponding plot function} \cr #' #' \code{\linkS4class{RLum.Data.Curve}} \tab : \tab #' \code{\link{plot_RLum.Data.Curve}} \cr #' \code{\linkS4class{RLum.Data.Spectrum}} \tab : \tab #' \code{\link{plot_RLum.Data.Spectrum}}\cr #' \code{\linkS4class{RLum.Data.Image}} \tab : \tab #' \code{\link{plot_RLum.Data.Image}}\cr \code{\linkS4class{RLum.Analysis}} #' \tab : \tab \code{\link{plot_RLum.Analysis}}\cr #' \code{\linkS4class{RLum.Results}} \tab : \tab #' \code{\link{plot_RLum.Results}} } #' #' @param object \code{\linkS4class{RLum}} (\bold{required}): S4 object of #' class \code{RLum}. Optional a \code{\link{list}} containing objects of class \code{\linkS4class{RLum}} #' can be provided. In this case the function tries to plot every object in this list according #' to its \code{RLum} class. #' #' @param \dots further arguments and graphical parameters that will be passed #' to the specific plot functions. The only argument that is supported directly is \code{main} #' (setting the plot title). In contrast to the normal behaviour \code{main} can be here provided as #' \code{\link{list}} and the arguments in the list will dispatched to the plots if the \code{object} #' is of type \code{list} as well. #' #' @return Returns a plot. #' #' @note The provided plot output depends on the input object. #' #' @section Function version: 0.4.3 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\link{plot_RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Data.Curve}}, \code{\link{plot_RLum.Data.Spectrum}}, #' \code{\linkS4class{RLum.Data.Spectrum}}, \code{\link{plot_RLum.Data.Image}}, #' \code{\linkS4class{RLum.Data.Image}}, \code{\link{plot_RLum.Analysis}}, #' \code{\linkS4class{RLum.Analysis}}, \code{\link{plot_RLum.Results}}, #' \code{\linkS4class{RLum.Results}} #' #' @references # #' #' @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) #' #' #' @export plot_RLum<- function( object, ... ){ # Define dispatcher function ---------------------------------------------------------- ##check if object is of class RLum RLum.dispatcher <- function(object, ...) { if (inherits(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, ...), ##this 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, ...) ) }else{ stop(paste0( "[plot_RLum()] Sorry, I don't know what to do for object of type '", is(object)[1], "'." )) } } # Run dispatcher ------------------------------------------------------------------------------ ##call for the list, if not just proceed as normal if(is(object, "list")) { ##(1) get rid of objects which are not RLum objects to avoid errors object.cleaned <- object[sapply(object, inherits, what = "RLum")] ##(1.1) place warning message if (length(object) > length(object.cleaned)) { warning(paste0( length(object) - length(object.cleaned)," non 'RLum' object(s) removed from list." )) } ##(2) check if empty, if empty do nothing ... if (length(object.cleaned) != 0) { ## If we iterate over a list, this might be extremly useful to have different plot titles if("main" %in% names(list(...))){ if(is(list(...)$main,"list")){ main.list <- rep(list(...)$main, length = length(object.cleaned)) } } ##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.cleaned)) }else{ mtext <- NULL } }else{ mtext <- rep(list(...)$mtext, length.out = length(object.cleaned)) } if(exists("main.list")){ ##dispatch objects for (i in 1:length(object.cleaned)) { RLum.dispatcher(object = object[[i]], main = main.list[[i]], mtext = mtext[[i]], ...) } }else{ for (i in 1:length(object.cleaned)) { RLum.dispatcher(object = object[[i]], mtext = mtext[[i]], ...) } } } }else{ ##dispatch object RLum.dispatcher(object = object, ...) } } Luminescence/R/analyse_IRSAR.RF.R0000644000176200001440000022534013125226556016127 0ustar liggesusers#' Analyse IRSAR RF measurements #' #' Function to analyse IRSAR RF measurements on K-feldspar samples, performed #' using the protocol according to Erfurt et al. (2003) and beyond. #' #' The function performs an IRSAR analysis described for K-feldspar samples by #' Erfurt et al. (2003) assuming a negligible sensitivity change of the RF #' signal.\cr #' #' \bold{General Sequence Structure} (according to Erfurt et al. #' (2003)) \enumerate{ #' #' \item Measuring IR-RF intensity of the natural dose for a few seconds (\eqn{RF_{nat}}) #' \item Bleach the samples under solar conditions for at least 30 min without changing the geometry #' \item Waiting for at least one hour #' \item Regeneration of the IR-RF signal to at least the natural level (measuring (\eqn{RF_{reg}}) #' \item Fitting data with a stretched exponential function #' \item Calculate the the palaeodose \eqn{D_{e}} using the parameters from the #' fitting} #' #' Actually two methods are supported to obtain the \eqn{D_{e}}: \code{method = "FIT"} and #' \code{method = "SLIDE"}: #' #' \bold{\code{method = "FIT"}}\cr #' #' The principle is described above and follows the original suggestions by #' Erfurt et al., 2003. For the fitting the mean count value of the RF_nat curve is used. #' #' Function used for the fitting (according to Erfurt et al. (2003)): \cr #' #' \deqn{\phi(D) = \phi_{0}-\Delta\phi(1-exp(-\lambda*D))^\beta} #' with \eqn{\phi(D)} the dose dependent IR-RF flux, \eqn{\phi_{0}} the initial #' IR-RF flux, \eqn{\Delta\phi} the dose dependent change of the IR-RF flux, #' \eqn{\lambda} the exponential parameter, \eqn{D} the dose and \eqn{\beta} #' the dispersive factor.\cr\cr To obtain the palaeodose \eqn{D_{e}} the #' function is changed to:\cr \deqn{D_{e} = ln(-(\phi(D) - #' \phi_{0})/(-\lambda*\phi)^{1/\beta}+1)/-\lambda}\cr The fitting is done #' using the \code{port} algorithm of the \code{\link{nls}} function.\cr #' #' #' \bold{\code{method = "SLIDE"}}\cr #' #' For this method the natural curve is slided along the x-axis until #' congruence with the regenerated curve is reached. Instead of fitting this #' allows to work with the original data without the need of any physical #' model. This approach was introduced for RF curves by Buylaert et al., 2012 #' and Lapp et al., 2012. #' #' Here the sliding is done by searching for the minimum of the squared residuals. #' For the mathematical details of the implementation see Frouin et al., 2017 \cr #' #' \bold{\code{method.control}}\cr #' #' To keep the generic argument list as clear as possible, arguments to control the methods #' for De estimation are all preset with meaningful default parameters and can be #' handled using the argument \code{method.control} only, e.g., #' \code{method.control = list(trace = TRUE)}. Supported arguments are:\cr #' #' \tabular{lll}{ #' ARGUMENT \tab METHOD \tab DESCRIPTION\cr #' \code{trace} \tab \code{FIT}, \code{SLIDE} \tab as in \code{\link{nls}}; shows sum of squared residuals\cr #' \code{trace_vslide} \tab \code{SLIDE} \tab \code{\link{logical}} argument to enable or disable the tracing of the vertical sliding\cr #' \code{maxiter} \tab \code{FIT} \tab as in \code{\link{nls}}\cr #' \code{warnOnly} \tab \code{FIT} \tab as in \code{\link{nls}}\cr #' \code{minFactor} \tab \code{FIT} \tab as in \code{\link{nls}}\cr #' \code{correct_onset} \tab \code{SLIDE} \tab The logical argument shifts the curves along the x-axis by the first channel, #' as light is expected in the first channel. The default value is \code{TRUE}.\cr #' \code{show_density} \tab \code{SLIDE} \tab \code{\link{logical}} (with default) #' enables or disables KDE plots for MC run results. If the distribution is too narrow nothing is shown.\cr #' \code{show_fit} \tab \code{SLIDE} \tab \code{\link{logical}} (with default) #' enables or disables the plot of the fitted curve routinely obtained during the evaluation.\cr #'\code{n.MC} \tab \code{SLIDE} \tab \code{\link{integer}} (with default): #' This controls the number of MC runs within the sliding (assessing the possible minimum values). #' The default \code{n.MC = 1000}. Note: This parameter is not the same as controlled by the #' function argument \code{n.MC}. \cr #' \code{vslide_range} \tab \code{SLDE} \tab \code{\link{logical}} or \code{\link{numeric}} or \code{\link{character}} (with default): #' This argument sets the boundaries for a vertical curve #' sliding. The argument expects a vector with an absolute minimum and a maximum (e.g., \code{c(-1000,1000)}). #' Alternatively the values \code{NULL} and \code{'auto'} are allowed. The automatic mode detects the #' reasonable vertical sliding range (\bold{recommended}). \code{NULL} applies no vertical sliding. #' The default is \code{NULL}.\cr #' \code{cores} \tab \code{SLIDE} \tab \code{number} or \code{character} (with default): set number of cores to be allocated #' for a parallel processing of the Monte-Carlo runs. The default value is \code{NULL} (single thread), #' the recommended values is \code{'auto'}. An optional number (e.g., \code{cores} = 8) assigns a value manually. #' } #' #' #' \bold{Error estimation}\cr #' #' For \bold{\code{method = "FIT"}} the asymmetric error range is obtained by using the 2.5 \% (lower) and #' the 97.5 \% (upper) quantiles of the \eqn{RF_{nat}} curve for calculating the \eqn{D_{e}} error range.\cr #' #' For \bold{\code{method = "SLIDE"}} the error is obtained by bootstrapping the residuals of the slided #' curve to construct new natural curves for a Monte Carlo simulation. The error is returned in two #' ways: (a) the standard deviation of the herewith obtained \eqn{D_{e}} from the MC runs and (b) the confidence #' interval using the 2.5 \% (lower) and the 97.5 \% (upper) quantiles. The results of the MC runs #' are returned with the function output. \cr #' #' \bold{Test parameters}\cr #' #' The argument \code{test_parameters} allows to pass some thresholds for several test parameters, #' which will be evaluated during the function run. If a threshold is set and it will be exceeded the #' test parameter status will be set to "FAILED". Intentionally this parameter is not termed #' 'rejection criteria' as not all test parameters are evaluated for both methods and some parameters #' are calculated by not evaluated by default. Common for all parameters are the allowed argument options #' \code{NA} and \code{NULL}. If the parameter is set to \code{NA} the value is calculated but the #' result will not be evaluated, means it has no effect on the status ("OK" or "FAILED") of the parameter. #' Setting the parameter to \code{NULL} disables the parameter entirely and the parameter will be #' also removed from the function output. This might be useful in cases where a particular parameter #' asks for long computation times. Currently supported parameters are: #' #' \code{curves_ratio} \code{\link{numeric}} (default: \code{1.001}):\cr #' #' The ratio of \eqn{RF_{nat}} over \eqn{RF_{reg}} in the range of\eqn{RF_{nat}} of is calculated #' and should not exceed the threshold value. \cr #' #' \code{intersection_ratio} \code{\link{numeric}} (default: \code{NA}):\cr #' #' Calculated as absolute difference from 1 of the ratio of the integral of the normalised RF-curves, #' This value indicates intersection of the RF-curves and should be close to 0 if the curves #' have a similar shape. For this calculation first the corresponding time-count pair value on the RF_reg #' curve is obtained using the maximum count value of the RF_nat curve and only this segment (fitting to #' the RF_nat curve) on the RF_reg curve is taken for further calculating this ratio. If nothing is #' found at all, \code{Inf} is returned. \cr #' #' \code{residuals_slope} \code{\link{numeric}} (default: \code{NA}; only for \code{method = "SLIDE"}): \cr #' #' A linear function is fitted on the residuals after sliding. #' The corresponding slope can be used to discard values as a high (positive, negative) slope #' may indicate that both curves are fundamentally different and the method cannot be applied at all. #' Per default the value of this parameter is calculated but not evaluated. \cr #' #'\code{curves_bounds} \code{\link{numeric}} (default: \eqn{max(RF_{reg_counts})}:\cr #' #'This measure uses the maximum time (x) value of the regenerated curve. #'The maximum time (x) value of the natural curve cannot be larger than this value. However, although #'this is not recommended the value can be changed or disabled.\cr #' #'\code{dynamic_ratio} \code{\link{numeric}} (default: \code{NA}):\cr #' #'The dynamic ratio of the regenerated curve is calculated as ratio of the minimum and maximum count values. #' #'\code{lambda}, \code{beta} and \code{delta.phi} #'\code{\link{numeric}} (default: \code{NA}; \code{method = "SLIDE"}): \cr #' #'The stretched exponential function suggested by Erfurt et al. (2003) describing the decay of #'the RF signal, comprises several parameters that might be useful to evaluate the shape of the curves. #'For \code{method = "FIT"} this parameter is obtained during the fitting, for \code{method = "SLIDE"} a #'rather rough estimation is made using the function \code{\link[minpack.lm]{nlsLM}} and the equation #'given above. Note: As this procedure requests more computation time, setting of one of these three parameters #'to \code{NULL} also prevents a calculation of the remaining two. #' #' #' @param object \code{\linkS4class{RLum.Analysis}} or a \code{\link{list}} of \code{RLum.Analysis} objects (\bold{required}): input #' object containing data for protocol analysis. The function expects to find at least two curves in the #' \code{\linkS4class{RLum.Analysis}} object: (1) RF_nat, (2) RF_reg. If a \code{list} is provided as #' input all other parameters can be provided as \code{list} as well to gain full control. #' #' @param sequence_structure \code{\link{vector}} \link{character} (with #' default): specifies the general sequence structure. Allowed steps are #' \code{NATURAL}, \code{REGENERATED}. In addition any other character is #' allowed in the sequence structure; such curves will be ignored during the analysis. #' #' @param RF_nat.lim \code{\link{vector}} (with default): set minimum and maximum #' channel range for natural signal fitting and sliding. If only one value is provided this #' will be treated as minimum value and the maximum limit will be added automatically. #' #' @param RF_reg.lim \code{\link{vector}} (with default): set minimum and maximum #' channel range for regenerated signal fitting and sliding. If only one value is provided this #' will be treated as minimum value and the maximum limit will be added automatically. #' #' @param method \code{\link{character}} (with default): setting method applied #' for the data analysis. Possible options are \code{"FIT"} or \code{"SLIDE"}. #' #' @param method.control \code{\link{list}} (optional): parameters to control the method, that can #' be passed to the chosen method. These are for (1) \code{method = "FIT"}: 'trace', 'maxiter', 'warnOnly', #' 'minFactor' and for (2) \code{method = "SLIDE"}: 'correct_onset', 'show_density', 'show_fit', 'trace'. #' See details. #' #' @param test_parameters \code{\link{list} (with default)}: set test parameters. #' Supported parameters are: \code{curves_ratio}, \code{residuals_slope} (only for #' \code{method = "SLIDE"}), \code{curves_bounds}, \code{dynamic_ratio}, #' \code{lambda}, \code{beta} and \code{delta.phi}. All input: \code{\link{numeric}} #' values, \code{NA} and \code{NULL} (s. Details) #' #' (see Details for further information) #' #' @param n.MC \code{\link{numeric}} (with default): set number of Monte #' Carlo runs for start parameter estimation (\code{method = "FIT"}) or #' error estimation (\code{method = "SLIDE"}). This value can be set to \code{NULL} to skip the #' MC runs. Note: Large values will significantly increase the computation time #' #' @param txtProgressBar \code{\link{logical}} (with default): enables \code{TRUE} or #' disables \code{FALSE} the progression bar during MC runs #' #' @param plot \code{\link{logical}} (with default): plot output (\code{TRUE} #' or \code{FALSE}) #' #' @param plot_reduced \code{\link{logical}} (optional): provides a reduced plot output if enabled #' to allow common R plot combinations, e.g., \code{par(mfrow(...))}. If \code{TRUE} no residual plot #' is returned; it has no effect if \code{plot = FALSE} #' #' @param \dots further arguments that will be passed to the plot output. #' Currently supported arguments are \code{main}, \code{xlab}, \code{ylab}, #' \code{xlim}, \code{ylim}, \code{log}, \code{legend} (\code{TRUE/FALSE}), #' \code{legend.pos}, \code{legend.text} (passes argument to x,y in #' \code{\link[graphics]{legend}}), \code{xaxt} #' #' #' @return The function returns numerical output and an (optional) plot. #' #' -----------------------------------\cr #' [ NUMERICAL OUTPUT ]\cr #' -----------------------------------\cr #' \bold{\code{RLum.Reuslts}}-object\cr #' #' \bold{slot:} \bold{\code{@data}} \cr #' #' [.. $data : \code{data.frame}]\cr #' #' \tabular{lll}{ #' \bold{Column} \tab \bold{Type} \tab \bold{Description}\cr #' DE \tab \code{numeric} \tab the obtained equivalent dose\cr #' DE.ERROR \tab \code{numeric} \tab (only \code{method = "SLIDE"}) standard deviation obtained from MC runs \cr #' DE.LOWER \tab \code{numeric}\tab 2.5\% quantile for De values obtained by MC runs \cr #' DE.UPPER \tab \code{numeric}\tab 97.5\% quantile for De values obtained by MC runs \cr #' DE.STATUS \tab \code{character}\tab test parameter status\cr #' RF_NAT.LIM \tab \code{charcter}\tab used RF_nat curve limits \cr #' RF_REG.LIM \tab \code{character}\tab used RF_reg curve limits\cr #' POSITION \tab \code{integer}\tab (optional) position of the curves\cr #' DATE \tab \code{character}\tab (optional) measurement date\cr #' SEQUENCE_NAME \tab \code{character}\tab (optional) sequence name\cr #' UID \tab \code{character}\tab unique data set ID #' } #' #' [.. $De.MC : \code{numeric}]\cr #' #' A \code{numeric} vector with all the De values obtained by the MC runs.\cr #' #' [.. $test_parameters : \code{data.frame}]\cr #' #' \tabular{lll}{ #' \bold{Column} \tab \bold{Type} \tab \bold{Description}\cr #' POSITION \tab \code{numeric} \tab aliquot position \cr #' PARAMETER \tab \code{character} \tab test parameter name \cr #' THRESHOLD \tab \code{numeric} \tab set test parameter threshold value \cr #' VALUE \tab \code{numeric} \tab the calculated test parameter value (to be compared with the threshold)\cr #' STATUS \tab \code{character} \tab test parameter status either \code{"OK"} or \code{"FAILED"} \cr #' SEQUENCE_NAME \tab \code{character} \tab name of the sequence, so far available \cr #' UID \tab \code{character}\tab unique data set ID #' } #' #' [.. $fit : \code{data.frame}]\cr #' #' An \code{\link{nls}} object produced by the fitting.\cr #' #' [.. $slide : \code{list}]\cr #' #' A \code{\link{list}} with data produced during the sliding. Some elements are previously #' reported with the summary object data. List elements are: #' #' \tabular{lll}{ #' \bold{Element} \tab \bold{Type} \tab \bold{Description}\cr #' De \tab \code{numeric} \tab the final De obtained with the sliding approach \cr #' De.MC \tab \code{numeric} \tab all De values obtained by the MC runs \cr #' residuals \tab \code{numeric} \tab the obtained residuals for each channel of the curve \cr #' trend.fit \tab \code{lm} \tab fitting results produced by the fitting of the residuals \cr #' RF_nat.slided \tab \code{matrix} \tab the slided RF_nat curve \cr #' t_n.id \tab \code{numeric} \tab the index of the t_n offset \cr #' I_n \tab \code{numeric} \tab the vertical intensity offset if a vertical slide was applied \cr #' algorithm_error \tab \code{numeric} \tab the vertical sliding suffers from a systematic effect induced by the used #' algorithm. The returned value is the standard deviation of all obtained De values while expanding the #' vertical sliding range. I can be added as systematic error to the final De error; so far wanted.\cr #' vslide_range \tab \code{numeric} \tab the range used for the vertical sliding \cr #' squared_residuals \tab \code{numeric} \tab the squared residuals (horizontal sliding) #' } #' #' #' \bold{slot:} \bold{\code{@info}} \cr #' #' The original function call (\code{\link[methods]{language-class}}-object) #' #' The output (\code{data}) should be accessed using the #' function \code{\link{get_RLum}} #' #' ------------------------\cr #' [ PLOT OUTPUT ]\cr #' ------------------------\cr #' #' The slided IR-RF curves with the finally obtained De #' #' @note #' #' This function assumes that there is no sensitivity change during the #' measurements (natural vs. regenerated signal), which is in contrast to the #' findings by Buylaert et al. (2012). Furthermore: In course of ongoing research this function has #' been almost fully re-written, but further thoughtful tests are still pending! #' However, as a lot new package functionality was introduced with the changes made #' for this function and to allow a part of such tests the re-newed code was made part #' of the current package.\cr #' #' @section Function version: 0.7.2 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\linkS4class{RLum.Analysis}}, #' \code{\linkS4class{RLum.Results}}, \code{\link{get_RLum}}, #' \code{\link{nls}}, \code{\link[minpack.lm]{nlsLM}}, \code{\link[parallel]{mclapply}} #' #' #' @references Buylaert, J.P., Jain, M., Murray, A.S., Thomsen, K.J., Lapp, T., #' 2012. IR-RF dating of sand-sized K-feldspar extracts: A test of accuracy. #' Radiation Measurements 44 (5-6), 560-565. doi: 10.1016/j.radmeas.2012.06.021 #' #' Erfurt, G., Krbetschek, M.R., 2003. IRSAR - A single-aliquot #' regenerative-dose dating protocol applied to the infrared radiofluorescence #' (IR-RF) of coarse- grain K-feldspar. Ancient TL 21, 35-42. #' #' Erfurt, G., 2003. Infrared luminescence of Pb+ centres in potassium-rich #' feldspars. physica status solidi (a) 200, 429-438. #' #' Erfurt, G., Krbetschek, M.R., 2003. Studies on the physics of the infrared #' radioluminescence of potassium feldspar and on the methodology of its #' application to sediment dating. Radiation Measurements 37, 505-510. #' #' Erfurt, G., Krbetschek, M.R., Bortolot, V.J., Preusser, F., 2003. A fully #' automated multi-spectral radioluminescence reading system for geochronometry #' and dosimetry. Nuclear Instruments and Methods in Physics Research Section #' B: Beam Interactions with Materials and Atoms 207, 487-499. #' #' Frouin, M., Huot, S., Kreutzer, S., Lahaye, C., Lamothe, M., Philippe, A., Mercier, N., 2017. #' An improved radiofluorescence single-aliquot regenerative dose protocol for K-feldspars. #' Quaternary Geochronology 38, 13-24. doi:10.1016/j.quageo.2016.11.004 #' #' Lapp, T., Jain, M., Thomsen, K.J., Murray, A.S., Buylaert, J.P., 2012. New #' luminescence measurement facilities in retrospective dosimetry. Radiation #' Measurements 47, 803-808. doi:10.1016/j.radmeas.2012.02.006 #' #' Trautmann, T., 2000. A study of radioluminescence kinetics of natural #' feldspar dosimeters: experiments and simulations. Journal of Physics D: #' Applied Physics 33, 2304-2310. #' #' Trautmann, T., Krbetschek, M.R., Dietrich, A., Stolz, W., 1998. #' Investigations of feldspar radioluminescence: potential for a new dating #' technique. Radiation Measurements 29, 421-425. #' #' Trautmann, T., Krbetschek, M.R., Dietrich, A., Stolz, W., 1999. Feldspar #' radioluminescence: a new dating method and its physical background. Journal #' of Luminescence 85, 45-58. #' #' Trautmann, T., Krbetschek, M.R., Stolz, W., 2000. A systematic study of the #' radioluminescence properties of single feldspar grains. Radiation #' Measurements 32, 685-690. #' #' #' @keywords datagen #' #' #' @examples #' #' ##load data #' data(ExampleData.RLum.Analysis, envir = environment()) #' #' ##(1) perform analysis using the method 'FIT' #' results <- analyse_IRSAR.RF(object = IRSAR.RF.Data) #' #' ##show De results and test paramter results #' get_RLum(results, data.object = "data") #' get_RLum(results, data.object = "test_parameters") #' #' ##(2) perform analysis using the method 'SLIDE' #' results <- analyse_IRSAR.RF(object = IRSAR.RF.Data, method = "SLIDE", n.MC = 1) #' #' \dontrun{ #' ##(3) perform analysis using the method 'SLIDE' and method control option #' ## 'trace #' results <- analyse_IRSAR.RF( #' object = IRSAR.RF.Data, #' method = "SLIDE", #' method.control = list(trace = TRUE)) #' #' } #' #' @export analyse_IRSAR.RF<- function( object, sequence_structure = c("NATURAL", "REGENERATED"), RF_nat.lim = NULL, RF_reg.lim = NULL, method = "FIT", method.control = NULL, test_parameters = NULL, n.MC = 10, txtProgressBar = TRUE, plot = TRUE, plot_reduced = FALSE, ... ){ ##TODO ## - if a file path is given, the function should try to find out whether an XSYG-file or ## a BIN-file is provided ## - add NEWS for vslide_range ## - update documentary ... if it works as expected. # SELF CALL ----------------------------------------------------------------------------------- if(is.list(object)){ ##extent the list of arguments if set ##sequence_structure sequence_structure <- rep(list(sequence_structure), length = length(object)) ##RF_nat.lim RF_nat.lim <- rep(list(RF_nat.lim), length = length(object)) ##RF_reg.lim RF_reg.lim <- rep(list(RF_reg.lim), length = length(object)) ##method method <- rep(list(method), length = length(object)) ##method.control method.control <- rep(list(method.control), length = length(object)) ##test_parameters if(is(test_parameters[[1]], "list")){ test_parameters <- rep(test_parameters, length = length(object)) }else{ test_parameters <- rep(list(test_parameters), length = length(object)) } ##n.MC n.MC <- rep(list(n.MC), length = length(object)) ##main if("main"%in% names(list(...))){ if(is(list(...)$main, "list")){ temp_main <- rep(list(...)$main, length = length(object)) }else{ temp_main <- rep(list(list(...)$main), length = length(object)) } }else{ temp_main <- as.list(paste0("ALQ #",1:length(object))) } ##run analysis temp <- lapply(1:length(object), function(x){ analyse_IRSAR.RF( object = object[[x]], sequence_structure = sequence_structure[[x]], RF_nat.lim = RF_nat.lim[[x]], RF_reg.lim = RF_reg.lim[[x]], method = method[[x]], method.control = method.control[[x]], test_parameters = test_parameters[[x]], n.MC = n.MC[[x]], txtProgressBar = txtProgressBar, plot = plot, plot_reduced = plot_reduced, main = temp_main[[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 TESTS AND SEQUENCE STRUCTURE TESTS ##===============================================================================================# ##MISSING INPUT if(missing("object")){ stop("[analyse_IRSAR.RF()] No input 'object' set!") } ##INPUT OBJECTS if(!is(object, "RLum.Analysis")){ stop("[analyse_IRSAR.RF()] Input object is not of type 'RLum.Analysis'!") } ##CHECK OTHER ARGUMENTS if(!is(sequence_structure, "character")){ stop("[analyse_IRSAR.RF()] argument 'sequence_structure' needs to be of type character.") } ##n.MC if((!is(n.MC, "numeric") || n.MC <= 0) && !is.null(n.MC)){ stop("[analyse_IRSAR.RF()] argument 'n.MC' has to be of type integer and >= 0", call. = FALSE) } ##SELECT ONLY MEASURED CURVES ## (this is not really necessary but rather user friendly) if(!length(suppressWarnings(get_RLum(object, curveType= "measured"))) == 0){ object <- get_RLum(object, curveType= "measured", drop = FALSE) } ##INVESTIGATE SEQUENCE OBJECT STRUCTURE ##grep object strucute temp.sequence_structure <- structure_RLum(object) ##grep name of the sequence and the position this will be useful later on ##name if (!is.null(suppressWarnings(get_RLum(get_RLum(object, record.id = 1), info.object = "name")))) { aliquot.sequence_name <- get_RLum(get_RLum(object, record.id = 1), info.object = "name") }else{ aliquot.sequence_name <- NA } ##position if (!is.null(suppressWarnings(get_RLum(get_RLum(object, record.id = 1), info.object = "position")))){ aliquot.position <- get_RLum(get_RLum(object, record.id = 1), info.object = "position") }else{ aliquot.position <- NA } ##date if (!is.null(suppressWarnings(get_RLum(get_RLum(object, record.id = 1), info.object = "startDate")))){ aliquot.date <- get_RLum(get_RLum(object, record.id = 1), info.object = "startDate") ##transform so far the format can be identified if (nchar(aliquot.date) == 14) { aliquot.date <- paste(c( substr(aliquot.date, 1,4),substr(aliquot.date, 5,6), substr(aliquot.date, 7,8) ), collapse = "-") } }else{ aliquot.date <- NA } ##set structure values temp.sequence_structure$protocol.step <- rep(sequence_structure, length_RLum(object))[1:length_RLum(object)] ##check if the first curve is shorter than the first curve if (temp.sequence_structure[1,"n.channels"] > temp.sequence_structure[2,"n.channels"]) { stop( "[analyse_IRSAR.RF()] Number of data channels in RF_nat > RF_reg. This is not supported!" ) } ##===============================================================================================# ## SET CURVE LIMITS ##===============================================================================================# ##the setting here will be valid for all subsequent operations ##01 ##first get allowed curve limits, this makes the subsequent checkings easier and the code ##more easier to read RF_nat.lim.default <- c(1,max( subset( temp.sequence_structure, temp.sequence_structure$protocol.step == "NATURAL" )$n.channels )) RF_reg.lim.default <- c(1,max( subset( temp.sequence_structure, temp.sequence_structure$protocol.step == "REGENERATED" )$n.channels )) ##02 - check boundaris ##RF_nat.lim if (is.null(RF_nat.lim) || is.na(RF_nat.lim)) { RF_nat.lim <- RF_nat.lim.default }else { ##this allows to provide only one boundary and the 2nd will be added automatically if (length(RF_nat.lim) == 1) { RF_nat.lim <- c(RF_nat.lim, RF_nat.lim.default[2]) } if (min(RF_nat.lim) < RF_nat.lim.default[1] | max(RF_nat.lim) > RF_nat.lim.default[2]) { RF_nat.lim <- RF_nat.lim.default warning(paste0( "RF_nat.lim out of bounds, reset to: RF_nat.lim = c(", paste(range(RF_nat.lim), collapse = ":") ),")") } } ##RF_reg.lim ## if (is.null(RF_reg.lim)) { RF_reg.lim <- RF_reg.lim.default }else { ##this allows to provide only one boundary and the 2nd will be added automatically if (length(RF_reg.lim) == 1) { RF_reg.lim <- c(RF_reg.lim, RF_reg.lim.default[2]) } if (min(RF_reg.lim) < RF_reg.lim.default[1] | max(RF_reg.lim) > RF_reg.lim.default[2]) { RF_reg.lim <- RF_reg.lim.default warning(paste0( "RF_reg.lim out of bounds, reset to: RF_reg.lim = c(", paste(range(RF_reg.lim), collapse = ":") ),")") } } ##check if intervalls make sense at all if(length(RF_reg.lim[1]:RF_reg.lim[2]) < RF_nat.lim[2]){ RF_reg.lim[2] <- RF_reg.lim[2] + abs(length(RF_reg.lim[1]:RF_reg.lim[2]) - RF_nat.lim[2]) + 1 warning(paste0("Length intervall RF_reg.lim < length RF_nat. Reset to RF_reg.lim = c(", paste(range(RF_reg.lim), collapse=":")),")") } # Method Control Settings --------------------------------------------------------------------- ##===============================================================================================# ## SET METHOD CONTROL PARAMETER - FOR BOTH METHODS ##===============================================================================================# ## ##set supported values with default method.control.settings <- list( trace = FALSE, trace_vslide = FALSE, maxiter = 500, warnOnly = FALSE, minFactor = 1 / 4096, correct_onset = TRUE, show_density = TRUE, show_fit = FALSE, n.MC = if(is.null(n.MC)){NULL}else{1000}, vslide_range = NULL, cores = NULL ) ##modify list if necessary if(!is.null(method.control)){ if(!is(method.control, "list")){ stop("[analyse_IRSAR.RF()] 'method.control' has to be of type 'list'!") } ##check whether this arguments are supported at all if (length(which( names(method.control) %in% names(method.control.settings) == FALSE ) != 0)) { temp.text <- paste0( "[analyse_IRSAR.RF()] Argument(s) '", paste(names(method.control)[which(names(method.control) %in% names(method.control.settings) == FALSE)], collapse = " and "), "' are not supported for 'method.control'. Supported arguments are: ", paste(names(method.control.settings), collapse = ", ") ) warning(temp.text) rm(temp.text) } ##modify list method.control.settings <- modifyList(x = method.control.settings, val = method.control) } ##===============================================================================================# ## SET PLOT PARAMETERS ##===============================================================================================# ##get channel resolution (should be equal for all curves, but if not the mean is taken) resolution.RF <- round(mean((temp.sequence_structure$x.max/temp.sequence_structure$n.channels)),digits=1) plot.settings <- list( main = "IR-RF", xlab = "Time [s]", ylab = paste0("IR-RF [cts/", resolution.RF," s]"), log = "", cex = 1, legend = TRUE, legend.text = c("RF_nat","RF_reg"), legend.pos = "top", xaxt = "s" ##xlim and ylim see below as they has to be modified differently ) ##modify list if something was set plot.settings <- modifyList(plot.settings, list(...)) ##=============================================================================# ## ANALYSIS ##=============================================================================# ##grep first regenerated curve RF_reg <- as.data.frame(object@records[[ temp.sequence_structure[temp.sequence_structure$protocol.step=="REGENERATED","id"]]]@data) ##correct of the onset of detection by using the first time value if (method == "SLIDE" & method.control.settings$correct_onset == TRUE) { RF_reg[,1] <- RF_reg[,1] - RF_reg[1,1] } RF_reg.x <- RF_reg[RF_reg.lim[1]:RF_reg.lim[2],1] RF_reg.y <- RF_reg[RF_reg.lim[1]:RF_reg.lim[2],2] ##grep values from natural signal RF_nat <- as.data.frame(object@records[[ temp.sequence_structure[temp.sequence_structure$protocol.step=="NATURAL","id"]]]@data) ##correct of the onset of detection by using the first time value if (method == "SLIDE" & method.control.settings$correct_onset == TRUE) { RF_nat[,1] <- RF_nat[,1] - RF_nat[1,1] } ##limit values to fit range (at least to the minimum) RF_nat.limited<- RF_nat[min(RF_nat.lim):max(RF_nat.lim),] ##calculate some useful parameters RF_nat.mean <- mean(RF_nat.limited[,2]) RF_nat.sd <- sd(RF_nat.limited[,2]) RF_nat.error.lower <- quantile(RF_nat.limited[,2], 0.975, na.rm = TRUE) RF_nat.error.upper <- quantile(RF_nat.limited[,2], 0.025, na.rm = TRUE) ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++# ##METHOD FIT ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++# ## REGENERATED SIGNAL # set function for fitting ------------------------------------------------ fit.function <- as.formula(y ~ phi.0 - (delta.phi * ((1 - exp( -lambda * x )) ^ beta))) ##stretched expontial function according to Erfurt et al. (2003) ## + phi.0 >> initial IR-RF flux ## + delta.phi >> dose dependent change of the IR-RF flux ## + lambda >> exponential parameter ## + beta >> dispersive factor # set start parameter estimation ------------------------------------------ fit.parameters.start <- c( phi.0 = max(RF_reg.y), lambda = 0.0001, beta = 1, delta.phi = 1.5 * (max(RF_reg.y) - min(RF_reg.y)) ) if(method == "FIT"){ # start nls fitting ------------------------------------------------------- ##Monte Carlo approach for fitting fit.parameters.results.MC.results <- data.frame() ##produce set of start paramters phi.0.MC <- rep(fit.parameters.start["phi.0"], n.MC) lambda.MC <- seq(0.0001, 0.001, by=(0.001-0.0001)/n.MC) beta.MC <- rep(fit.parameters.start["beta"], n.MC) delta.phi.MC <- rep(fit.parameters.start["delta.phi"], n.MC) ##start fitting loop for MC runs for(i in 1:n.MC){ fit.MC <- try(nls( fit.function, trace = FALSE, data = list(x = RF_reg.x, y = RF_reg.y), algorithm = "port", start = list( phi.0 = phi.0.MC[i], delta.phi = delta.phi.MC[i], lambda = lambda.MC[i], beta = beta.MC[i] ), nls.control( maxiter = 100, warnOnly = FALSE, minFactor = 1 / 1024 ), lower = c( phi.0 = .Machine$double.xmin, delta.phi = .Machine$double.xmin, lambda = .Machine$double.xmin, beta = .Machine$double.xmin ), upper = c( phi.0 = max(RF_reg.y), delta.phi = max(RF_reg.y), lambda = 1, beta = 100 ) ), silent = TRUE ) if(inherits(fit.MC,"try-error") == FALSE) { temp.fit.parameters.results.MC.results <- coef(fit.MC) fit.parameters.results.MC.results[i,"phi.0"] <- temp.fit.parameters.results.MC.results["phi.0"] fit.parameters.results.MC.results[i,"lambda"] <- temp.fit.parameters.results.MC.results["lambda"] fit.parameters.results.MC.results[i,"delta.phi"] <- temp.fit.parameters.results.MC.results["delta.phi"] fit.parameters.results.MC.results[i,"beta"] <- temp.fit.parameters.results.MC.results["beta"] } } ##FINAL fitting after successful MC if(length(na.omit(fit.parameters.results.MC.results)) != 0){ ##choose median as final fit version fit.parameters.results.MC.results <- sapply(na.omit(fit.parameters.results.MC.results), median) ##try final fitting fit <- try(nls( fit.function, trace = method.control.settings$trace, data = data.frame(x = RF_reg.x, y = RF_reg.y), algorithm = "port", start = list( phi.0 = fit.parameters.results.MC.results["phi.0"], delta.phi = fit.parameters.results.MC.results["delta.phi"], lambda = fit.parameters.results.MC.results["lambda"], beta = fit.parameters.results.MC.results["beta"] ), nls.control( maxiter = method.control.settings$maxiter, warnOnly = method.control.settings$warnOnly, minFactor = method.control.settings$minFactor ), lower = c( phi.0 = .Machine$double.xmin, delta.phi = .Machine$double.xmin, lambda = .Machine$double.xmin, beta = .Machine$double.xmin ), upper = c( phi.0 = max(RF_reg.y), delta.phi = max(RF_reg.y), lambda = 1, beta = 100 ) ), silent = FALSE ) }else{ fit <- NA class(fit) <- "try-error" } # get parameters ---------------------------------------------------------- # and with that the final De if (!inherits(fit,"try-error")) { fit.parameters.results <- coef(fit) }else{ fit.parameters.results <- NA } ##calculate De value if (!is.na(fit.parameters.results[1])) { De <- suppressWarnings(round(log( -((RF_nat.mean - fit.parameters.results["phi.0"]) / -fit.parameters.results["delta.phi"] ) ^ (1 / fit.parameters.results["beta"]) + 1 ) / -fit.parameters.results["lambda"], digits = 2)) ##This could be solved with a MC simulation, but for this the code has to be adjusted ##The question is: Where the parameters are coming from? ##TODO De.error <- NA De.lower <- suppressWarnings(round(log( -((RF_nat.error.lower - fit.parameters.results["phi.0"]) / -fit.parameters.results["delta.phi"] ) ^ (1 / fit.parameters.results["beta"]) + 1 ) / -fit.parameters.results["lambda"],digits = 2)) De.upper <- suppressWarnings(round(log( -((RF_nat.error.upper - fit.parameters.results["phi.0"]) / -fit.parameters.results["delta.phi"] ) ^ (1 / fit.parameters.results["beta"]) + 1 ) / -fit.parameters.results["lambda"],digits = 2)) }else{ De <- NA De.error <- NA De.lower <- NA De.upper <- NA } } ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++# ##METHOD SLIDE - ANALYSIS ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++# else if(method == "SLIDE"){ ##convert to matrix (in fact above the matrix data were first transfered to data.frames ... here ##we correct this ... again) RF_nat.limited <- as.matrix(RF_nat.limited) RF_reg.limited <- matrix(c(RF_reg.x, RF_reg.y), ncol = 2) RF_nat <- as.matrix(RF_nat) ##DEFINE FUNCTION FOR SLIDING ##FIND MINIMUM - this is done in a function so that it can be further used for MC simulations # sliding() ----------------------------------------------------------------------------------- sliding <- function(RF_nat, RF_nat.limited, RF_reg.limited, n.MC = method.control.settings$n.MC, vslide_range = method.control.settings$vslide_range, trace = method.control.settings$trace_vslide, numerical.only = FALSE){ ##check for odd user input if(length(vslide_range) > 2){ vslide_range <- vslide_range[1:2] warning("[anlayse_IRSAR.RF()] method.control = list(vslide_range) has more than 2 elements. Only the first two were used!", call. = FALSE) } ##(0) set objects ... nomenclature as used in Frouin et al., please note that here the index ##is used instead the real time values t_max.id <- nrow(RF_reg.limited) t_max_nat.id <- nrow(RF_nat.limited) t_min.id <- 1 t_min <- RF_nat.limited[1,1] ##(1) calculate sum of residual squares using internal Rcpp function #pre-allocate object temp.sum.residuals <- vector("numeric", length = t_max.id - t_max_nat.id) ##initialise slide range for specific conditions, namely NULL and "auto" if (is.null(vslide_range)) { vslide_range <- 0 } else if (vslide_range[1] == "auto") { vslide_range <- -(max(RF_reg.limited[, 2]) - min(RF_reg.limited[, 2])):(max(RF_reg.limited[, 2]) - min(RF_reg.limited[, 2])) algorithm_error <- NA } else{ vslide_range <- vslide_range[1]:vslide_range[2] algorithm_error <- NULL } ##problem: the optimisation routine slightly depends on the chosen input sliding vector ##and it might get trapped in a local minimum ##therefore we run the algorithm by expanding the sliding vector if(!is.null(vslide_range) && vslide_range != 0){ ##even numbers makes it complicated, so let's make it odd if not already the case if(length(vslide_range) %% 2 == 0){ vslide_range <- c(vslide_range[1], vslide_range, vslide_range) } ##construct list of vector ranges we want to check for, this should avoid that we ##got trapped in a local minium median_vslide_range.index <- median(1:length(vslide_range)) vslide_range.list <- lapply(seq(1, median_vslide_range.index, length.out = 10), function(x){ c(median_vslide_range.index - as.integer(x), median_vslide_range.index + as.integer(x)) }) ##correct for out of bounds problem; it might occur vslide_range.list[[10]] <- c(0, length(vslide_range)) ##TODO ... this is not really optimal, but ok for the moment, better would be ##the algorithm finds sufficiently the global minium. ##now run it in a loop and expand the range from the inner to the outer part ##at least this is considered for the final error range ... temp_minium_list <- lapply(1:10, function(x){ .analyse_IRSARRF_SRS( values_regenerated_limited = RF_reg.limited[,2], values_natural_limited = RF_nat.limited[,2], vslide_range = vslide_range[vslide_range.list[[x]][1]:vslide_range.list[[x]][2]], n_MC = 0, #we don't need MC runs here, so make it quick trace = trace)[c("sliding_vector_min_index","vslide_minimum", "vslide_index")] }) ##get all horizontal index value for the local minimum (corresponding to the vslide) temp_hslide_indices <- vapply(temp_minium_list, function(x){ x$sliding_vector_min_index}, FUN.VALUE = numeric(length = 1)) ##get also the vertical slide indicies temp_vslide_indicies <- vapply(temp_minium_list, function(x){ x$vslide_index}, FUN.VALUE = numeric(length = 1)) ##get all the minimum values temp_minium <- vapply(temp_minium_list, function(x){x$vslide_minimum}, FUN.VALUE = numeric(length = 1)) ##get minimum and set it to the final range vslide_range <- vslide_range[ vslide_range.list[[which.min(temp_minium)]][1]:vslide_range.list[[which.min(temp_minium)]][2]] ##get all possible t_n values for the range expansion ... this can be considered ##as somehow systematic uncertainty, but it will be only calculated of the full range ##is considered, otherwise it is too biased by the user's choice ##ToDo: So far the algorithm error is not sufficiently documented if(!is.null(algorithm_error)){ algorithm_error <- sd(vapply(1:length(temp_vslide_indicies), function(k){ temp.sliding.step <- RF_reg.limited[temp_hslide_indices[k]] - t_min matrix(data = c(RF_nat[,1] + temp.sliding.step, RF_nat[,2] + temp_vslide_indicies[k]), ncol = 2)[1,1] }, FUN.VALUE = numeric(length = 1))) }else{ algorithm_error <- NA } }else{ algorithm_error <- NA } ##now run the final sliding with the identified range that corresponds to the minium value temp.sum.residuals <- .analyse_IRSARRF_SRS( values_regenerated_limited = RF_reg.limited[,2], values_natural_limited = RF_nat.limited[,2], vslide_range = vslide_range, n_MC = if(is.null(n.MC)){0}else{n.MC}, trace = trace ) #(2) get minimum value (index and time value) index_min <- which.min(temp.sum.residuals$sliding_vector) t_n.id <- index_min if (is.null(vslide_range)) { I_n <- 0 } else{ I_n <- vslide_range[temp.sum.residuals$vslide_index] } temp.sliding.step <- RF_reg.limited[t_n.id] - t_min ##(3) slide curve graphically ... full data set we need this for the plotting later RF_nat.slided <- matrix(data = c(RF_nat[,1] + temp.sliding.step, RF_nat[,2] + I_n), ncol = 2) t_n <- RF_nat.slided[1,1] ##the same for the MC runs of the minimum values if(!is.null(n.MC)) { t_n.MC <- vapply( X = 1:length(temp.sum.residuals$sliding_vector_min_MC), FUN = function(x) { ##get minimum for MC t_n.id.MC <- which( temp.sum.residuals$sliding_vector == temp.sum.residuals$sliding_vector_min_MC[x] ) ##there is low change to get two indicies, in ##such cases we should take the mean temp.sliding.step.MC <- RF_reg.limited[t_n.id.MC] - t_min if(length(temp.sliding.step.MC)>1){ t_n.MC <- (RF_nat[, 1] + mean(temp.sliding.step.MC))[1] }else{ t_n.MC <- (RF_nat[, 1] + temp.sliding.step.MC)[1] } return(t_n.MC) }, FUN.VALUE = vector(mode = "numeric", length = 1) ) } else{ t_n.MC <- NA_integer_ } ##(4) get residuals (needed to be plotted later) ## they cannot be longer than the RF_reg.limited curve if((t_n.id+length(RF_nat.limited[,2])-1) >= nrow(RF_reg.limited)){ residuals <- (RF_nat.limited[1:length(t_n.id:nrow(RF_reg.limited)),2] + I_n) - RF_reg.limited[t_n.id:nrow(RF_reg.limited), 2] }else{ residuals <- (RF_nat.limited[,2] + I_n) - RF_reg.limited[t_n.id:(t_n.id+length(RF_nat.limited[,2])-1), 2] } ##(4.1) calculate De from the first channel ... which is t_n here De <- round(t_n, digits = 2) De.MC <- round(t_n.MC, digits = 2) temp.trend.fit <- NA ##(5) calculate trend fit if(length(RF_nat.limited[,1]) > length(residuals)){ temp.trend.fit <- coef(lm(y~x, data.frame(x = RF_nat.limited[1:length(residuals),1], y = residuals))) }else{ temp.trend.fit <- coef(lm(y~x, data.frame(x = RF_nat.limited[,1], y = residuals))) } ##return values and limited if they are not needed if (numerical.only == FALSE) { return( list( De = De, De.MC = De.MC, residuals = residuals, trend.fit = temp.trend.fit, RF_nat.slided = RF_nat.slided, t_n.id = t_n.id, I_n = I_n, algorithm_error = algorithm_error, vslide_range = if(is.null(vslide_range)){NA}else{range(vslide_range)}, squared_residuals = temp.sum.residuals$sliding_vector ) ) }else{ return(list(De = De, De.MC = De.MC)) } }##end of function sliding() ##PERFORM sliding and overwrite values slide <- sliding( RF_nat = RF_nat, RF_nat.limited = RF_nat.limited, RF_reg.limited = RF_reg.limited ) ##write results in variables De <- slide$De residuals <- slide$residuals RF_nat.slided <- slide$RF_nat.slided I_n <- slide$I_n # ERROR ESTIMATION # MC runs for error calculation --------------------------------------------------------------- ##set residual matrix for MC runs, i.e. set up list of pseudo RF_nat curves as function ##(i.e., bootstrap from the natural curve distribution) if(!is.null(n.MC)){ slide.MC.list <- lapply(1:n.MC,function(x) { ##also here we have to account for the case that user do not understand ##what they are doing ... if(slide$t_n.id + nrow(RF_nat.limited)-1 > nrow(RF_reg.limited)){ cbind( RF_nat.limited[1:length(slide$t_n.id:nrow(RF_reg.limited)),1], (RF_reg.limited[slide$t_n.id:nrow(RF_reg.limited) ,2] + sample(residuals, size = length(slide$t_n.id:nrow(RF_reg.limited)), replace = TRUE) ) ) }else{ cbind( RF_nat.limited[,1], (RF_reg.limited[slide$t_n.id:(slide$t_n.id + nrow(RF_nat.limited)-1) ,2] + sample(residuals, size = nrow(RF_nat.limited), replace = TRUE) ) ) } }) if(txtProgressBar){ ##terminal output fo MC cat("\n\t Run Monte Carlo loops for error estimation\n") ##progress bar pb<-txtProgressBar(min=0, max=n.MC, initial=0, char="=", style=3) } ##set parallel calculation if wanted if(is.null(method.control.settings$cores)){ cores <- 1 }else{ ##case 'auto' if(method.control.settings$cores == 'auto'){ if(parallel::detectCores() <= 2){ warning("[analyse_IRSAR.RF()] For the multicore auto mode at least 4 cores are needed!", call. = FALSE) cores <- 1 }else{ cores <- parallel::detectCores() - 2 } }else if(is.numeric(method.control.settings$cores)){ if(method.control.settings$cores > parallel::detectCores()){ warning(paste0("[analyse_IRSAR.RF()] What do you want? Your machine has only ", parallel::detectCores(), " cores!"), call. = FALSE) } ##assign them anyway, it is not our problem cores <- parallel::detectCores() }else{ try(stop("[analyse_IRSAR.RF()] Invalid value for control argument 'cores'. Value set to 1", call. = FALSE)) cores <- 1 } ##return message message(paste("[analyse_IRSAR.RF()] Multicore mode using", cores, "cores...")) } ##run MC runs De.MC <- unlist(parallel::mclapply(X = 1:n.MC, FUN = function(i){ temp.slide.MC <- sliding( RF_nat = RF_nat, RF_reg.limited = RF_reg.limited, RF_nat.limited = slide.MC.list[[i]], numerical.only = TRUE ) ##update progress bar if (txtProgressBar) { setTxtProgressBar(pb, i) } ##do nothing else, just report all possible values return(temp.slide.MC[[2]]) }, mc.preschedule = TRUE, mc.cores = cores )) ##close if(txtProgressBar){close(pb)} ##calculate absolute deviation between De and the here newly calculated De.MC ##this is, e.g. ^t_n.1* - ^t_n in Frouin et al. De.diff <- diff(x = c(De, De.MC)) De.error <- round(sd(De.MC), digits = 2) De.lower <- De - quantile(De.diff, 0.975, na.rm = TRUE) De.upper <- De - quantile(De.diff, 0.025, na.rm = TRUE) }else{ De.diff <- NA_integer_ De.error <- NA_integer_ De.lower <- NA_integer_ De.upper <- NA_integer_ De.MC <- NA_integer_ } }else{ warning("Analysis skipped: Unknown method or threshold of test parameter exceeded.") } ##===============================================================================================# ## TEST PARAMETER ##===============================================================================================# ## Test parameter are evaluated after all the calculations have been done as ## it should be up to the user to decide whether a value should be taken into account or not. ##(0) ##set default values and overwrite them if there was something new ##set defaults TP <- list( curves_ratio = 1.001, intersection_ratio = NA, residuals_slope = NA, curves_bounds = ceiling(max(RF_reg.x)), dynamic_ratio = NA, lambda = NA, beta = NA, delta.phi = NA ) ##modify default values by given input if(!is.null(test_parameters)){TP <- modifyList(TP, test_parameters)} ##remove NULL elements from list TP <- TP[!sapply(TP, is.null)] ##set list with values we want to evaluate TP <- lapply(TP, function(x){ data.frame(THRESHOLD = as.numeric(x), VALUE = NA, STATUS = "OK", stringsAsFactors = TRUE) }) ##(1) check if RF_nat > RF_reg, considering the fit range ##TP$curves_ratio if ("curves_ratio" %in% names(TP)) { TP$curves_ratio$VALUE <- sum(RF_nat.limited[,2]) / sum(RF_reg[RF_nat.lim[1]:RF_nat.lim[2], 2]) if (!is.na(TP$curves_ratio$THRESHOLD)) { TP$curves_ratio$STATUS <- ifelse(TP$curves_ratio$VALUE > TP$curves_ratio$THRESHOLD, "FAILED", "OK") } } ##(1.1) check if RF_nat > RF_reg, considering the fit range ##TP$intersection_ratio if ("intersection_ratio" %in% names(TP)) { ##It is, as always, a little bit more complicated ... ##We cannot just normalise both curves and compare ratios. With increasing De the curve ##shape of the RF_nat curve cannot be the same as the RF_reg curve at t = 0. Therefore we ##have to find the segment in the RF_reg curve that fits to the RF_nat curve ## ##(1) get maximum count value for RF_nat IR_RF_nat.max <- max(RF_nat.limited[,2]) ##(2) find corresponding time value for RF_reg (here no limited) IR_RF_reg.corresponding_id <- which.min(abs(RF_reg[,2] - IR_RF_nat.max)) ##(3) calculate ratio, but just starting from the point where both curves correspond ##in terms of intensiy, otherwise the ratio cannot be correct ##the boundary check is necessary to avoid errors if((IR_RF_reg.corresponding_id + length(RF_nat.lim[1]:RF_nat.lim[2])) > length(RF_reg[,2])){ TP$intersection_ratio$VALUE <- Inf }else{ TP$intersection_ratio$VALUE <- abs(1 - sum((RF_nat.limited[, 2] / max(RF_nat.limited[, 2]))) / sum(RF_reg[IR_RF_reg.corresponding_id:(IR_RF_reg.corresponding_id + length(RF_nat.lim[1]:RF_nat.lim[2]) - 1), 2] / max(RF_reg[IR_RF_reg.corresponding_id:(IR_RF_reg.corresponding_id + length(RF_nat.lim[1]:RF_nat.lim[2]) - 1), 2]))) if (!is.na(TP$intersection_ratio$THRESHOLD)) { TP$intersection_ratio$STATUS <- ifelse(TP$intersection_ratio$VALUE > TP$intersection_ratio$THRESHOLD, "FAILED", "OK") } rm(IR_RF_nat.max, IR_RF_reg.corresponding_id) } } ##(2) check slop of the residuals using a linear fit ##TP$residuals_slope if ("residuals_slope" %in% names(TP)) { if (exists("slide")) { TP$residuals_slope$VALUE <- abs(slide$trend.fit[2]) if (!is.na(TP$residuals_slope$THRESHOLD)) { TP$residuals_slope$STATUS <- ifelse( TP$residuals_slope$VALUE > TP$residuals_slope$THRESHOLD, "FAILED", "OK") } } } ##(3) calculate dynamic range of regenrated curve ##TP$dynamic_ratio if ("dynamic_ratio"%in%names(TP)){ TP.dynamic_ratio <- subset(temp.sequence_structure, temp.sequence_structure$protocol.step == "REGENERATED") TP$dynamic_ratio$VALUE <- TP.dynamic_ratio$y.max/TP.dynamic_ratio$y.min if (!is.na(TP$dynamic_ratio$THRESHOLD)){ TP$dynamic_ratio$STATUS <- ifelse( TP$dynamic_ratio$VALUE < TP$dynamic_ratio$THRESHOLD , "FAILED", "OK") } } ##(4) decay parameter ##TP$lambda if ("lambda"%in%names(TP) & "beta"%in%names(TP) & "delta.phi"%in%names(TP)){ fit.lambda <- try(minpack.lm::nlsLM( fit.function, data = data.frame(x = RF_reg.x, y = RF_reg.y), algorithm = "LM", start = list( phi.0 = fit.parameters.start["phi.0"], delta.phi = fit.parameters.start["delta.phi"], lambda = fit.parameters.start["lambda"], beta = fit.parameters.start["beta"] ), lower = c( phi.0 = .Machine$double.xmin, delta.phi = .Machine$double.xmin, lambda = .Machine$double.xmin, beta = .Machine$double.xmin ), upper = c( phi.0 = max(RF_reg.y), delta.phi = max(RF_reg.y), lambda = 1, beta = 100 ) ), silent = TRUE ) if(!inherits(fit.lambda, "try-error")){ temp.coef <- coef(fit.lambda) TP$lambda$VALUE <- temp.coef["lambda.lambda"] TP$beta$VALUE <- temp.coef["beta.beta"] TP$delta.phi$VALUE <- temp.coef["delta.phi.delta.phi"] if (!is.na( TP$lambda$THRESHOLD)){ TP$lambda$STATUS <- ifelse(TP$lambda$VALUE <= TP$lambda$THRESHOLD, "FAILED", "OK") } if (!is.na( TP$beta$THRESHOLD)){ TP$beta$STATUS <- ifelse(TP$beta$VALUE <= TP$beta$THRESHOLD, "FAILED", "OK") } if (!is.na( TP$delta.phi$THRESHOLD)){ TP$delta.phi$STATUS <- ifelse(TP$delta.phi$VALUE <= TP$delta.phi$THRESHOLD, "FAILED", "OK") } } } ##(99) check whether after sliding the ##TP$curves_bounds if (!is.null(TP$curves_bounds)) { if(exists("slide")){ ## add one channel on the top to make sure that it works TP$curves_bounds$VALUE <- max(RF_nat.slided[RF_nat.lim,1]) + (RF_nat[2,1] - RF_nat[1,1]) if (!is.na(TP$curves_bounds$THRESHOLD)){ TP$curves_bounds$STATUS <- ifelse(TP$curves_bounds$VALUE >= floor(max(RF_reg.x)), "FAILED", "OK") } }else if(exists("fit")){ TP$curves_bounds$VALUE <- De.upper if (!is.na(TP$curves_bounds$THRESHOLD)){ TP$curves_bounds$STATUS <- ifelse(TP$curves_bounds$VALUE >= max(RF_reg.x), "FAILED", "OK") } } } ##Combine everything in a data.frame if(length(TP) != 0) { TP.data.frame <- as.data.frame( cbind( POSITION = as.integer(aliquot.position), PARAMETER = c(names(TP)), do.call(data.table::rbindlist, args = list(l = TP)), SEQUENCE_NAME = aliquot.sequence_name, UID = NA ) ) ##set De.status to indicate whether there is any problem with the De according to the test parameter if ("FAILED" %in% TP.data.frame$STATUS) { De.status <- "FAILED" }else{ De.status <- "OK" } }else{ De.status <- "OK" TP.data.frame <- NULL } ##===============================================================================================# ## PLOTTING ##===============================================================================================# if(plot){ ##get internal colour definition col <- get("col", pos = .LuminescenceEnv) if (!plot_reduced) { ##grep par default and define reset def.par <- par(no.readonly = TRUE) on.exit(par(def.par)) ##set plot frame, if a method was choosen if (method == "SLIDE" | method == "FIT") { layout(matrix(c(1, 2), 2, 1, byrow = TRUE), c(2), c(1.3, 0.4), TRUE) par( oma = c(1, 1, 1, 1), mar = c(0, 4, 3, 0), cex = plot.settings$cex ) } }else{ if(plot.settings[["cex"]] != 1){ def.par <- par()[["cex"]] on.exit(par(def.par)) par(cex = plot.settings[["cex"]]) } } ##here control xlim and ylim behaviour ##xlim xlim <- if ("xlim" %in% names(list(...))) { list(...)$xlim } else { if (plot.settings$log == "x" | plot.settings$log == "xy") { c(min(temp.sequence_structure$x.min),max(temp.sequence_structure$x.max)) }else{ c(0,max(temp.sequence_structure$x.max)) } } ##ylim ylim <- if("ylim" %in% names(list(...))) {list(...)$ylim} else {c(min(temp.sequence_structure$y.min), max(temp.sequence_structure$y.max))} ##open plot area plot( NA,NA, xlim = xlim, ylim = ylim, xlab = ifelse((method != "SLIDE" & method != "FIT") | plot_reduced, plot.settings$xlab," "), xaxt = ifelse((method != "SLIDE" & method != "FIT") | plot_reduced, plot.settings$xaxt,"n"), yaxt = "n", ylab = plot.settings$ylab, main = plot.settings$main, log = plot.settings$log, ) if(De.status == "FAILED"){ ##build list of failed TP mtext.message <- paste0( "Threshold exceeded for: ", paste(subset(TP.data.frame, TP.data.frame$STATUS == "FAILED")$PARAMETER, collapse = ", "),". For details see manual.") ##print mtext mtext(text = mtext.message, side = 3, outer = TRUE, col = "red", cex = 0.8 * par()[["cex"]]) warning(mtext.message) } ##use scientific format for y-axis labels <- axis(2, labels = FALSE) axis(side = 2, at = labels, labels = format(labels, scientific = TRUE)) ##(1) plot points that have been not selected points(RF_reg[-(min(RF_reg.lim):max(RF_reg.lim)),1:2], pch=3, col=col[19]) ##(2) plot points that has been used for the fitting points(RF_reg.x,RF_reg.y, pch=3, col=col[10]) ##show natural points if no analysis was done if(method != "SLIDE" & method != "FIT"){ ##add points points(RF_nat, pch = 20, col = "grey") points(RF_nat.limited, pch = 20, col = "red") ##legend if (plot.settings$legend) { legend( plot.settings$legend.pos, legend = plot.settings$legend.text, pch = c(19, 3), col = c("red", col[10]), horiz = TRUE, bty = "n", cex = .9 * par()[["cex"]] ) } } ##Add fitted curve, if possible. This is a graphical control that might be considered ##as useful before further analysis will be applied if (method.control.settings$show_fit) { if(!is(fit.lambda, "try-error")){ fit.lambda_coef <- coef(fit.lambda) curve(fit.lambda_coef[[1]]- (fit.lambda_coef[[2]]* ((1-exp(-fit.lambda_coef[[3]]*x))^fit.lambda_coef[[4]])), add=TRUE, lty = 2, col="red") rm(fit.lambda_coef) }else{ warning("[analyse_IRSAR.RF()] No fit possible, no fit shown.") } } ## ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++# ## PLOT - METHOD FIT ## ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++# if(method == "FIT"){ ##dummy to cheat R CMD check x<-NULL; rm(x) ##plot fitted curve curve(fit.parameters.results["phi.0"]- (fit.parameters.results["delta.phi"]* ((1-exp(-fit.parameters.results["lambda"]*x))^fit.parameters.results["beta"])), add=TRUE, from = RF_reg[min(RF_reg.lim), 1], to = RF_reg[max(RF_reg.lim), 1], col="red") ##plotting to show the limitations if RF_reg.lim was chosen ##show fitted curve GREY (previous red curve) curve(fit.parameters.results["phi.0"]- (fit.parameters.results["delta.phi"]* ((1-exp(-fit.parameters.results["lambda"]*x))^fit.parameters.results["beta"])), add=TRUE, from = min(RF_reg[, 1]), to = RF_reg[min(RF_reg.lim), 1], col="grey") ##show fitted curve GREY (after red curve) curve(fit.parameters.results["phi.0"]- (fit.parameters.results["delta.phi"]* ((1-exp(-fit.parameters.results["lambda"]*x))^fit.parameters.results["beta"])), add=TRUE, from = RF_reg[max(RF_reg.lim), 1], to = max(RF_reg[, 1]), col="grey") ##add points points(RF_nat, pch = 20, col = col[19]) points(RF_nat.limited, pch = 20, col = col[2]) ##legend if (plot.settings$legend) { legend( plot.settings$legend.pos, legend = plot.settings$legend.text, pch = c(19, 3), col = c("red", col[10]), horiz = TRUE, bty = "n", cex = .9 * par()[["cex"]] ) } ##plot range choosen for fitting abline(v=RF_reg[min(RF_reg.lim), 1], lty=2) abline(v=RF_reg[max(RF_reg.lim), 1], lty=2) ##plot De if De was calculated if(is.na(De) == FALSE & is.nan(De) == FALSE){ lines(c(0,De.lower), c(RF_nat.error.lower,RF_nat.error.lower), lty=2, col="grey") lines(c(0,De), c(RF_nat.mean,RF_nat.mean), lty=2, col="red") lines(c(0,De.upper), c(RF_nat.error.upper,RF_nat.error.upper), lty=2, col="grey") lines(c(De.lower, De.lower), c(0,RF_nat.error.lower), lty=2, col="grey") lines(c(De,De), c(0, RF_nat.mean), lty=2, col="red") lines(c(De.upper, De.upper), c(0,RF_nat.error.upper), lty=2, col="grey") } ##Insert fit and result if(is.na(De) != TRUE & (is.nan(De) == TRUE | De > max(RF_reg.x) | De.upper > max(RF_reg.x))){ try(mtext(side=3, substitute(D[e] == De, list(De=paste( De," (",De.lower," ", De.upper,")", sep=""))), line=0, cex=0.8 * par()[["cex"]], col="red"), silent=TRUE) De.status <- "VALUE OUT OF BOUNDS" } else{ if ("mtext" %in% names(list(...))) { mtext(side = 3, list(...)$mtext) }else{ try(mtext( side = 3, substitute(D[e] == De, list( De = paste(De," [",De.lower," ; ", De.upper,"]", sep = "") )), line = 0, cex = 0.7 * par()[["cex"]] ), silent = TRUE) } De.status <- "OK" } if (!plot_reduced) { ##==lower plot==## par(mar = c(4.2, 4, 0, 0)) ##plot residuals if (is.na(fit.parameters.results[1]) == FALSE) { plot( RF_reg.x, residuals(fit), xlim = c(0, max(temp.sequence_structure$x.max)), xlab = plot.settings$xlab, yaxt = "n", xaxt = plot.settings$xaxt, type = "p", pch = 20, col = "grey", ylab = "E", log = "" ) ##add 0 line abline(h = 0) } else{ plot( NA, NA, xlim = c(0, max(temp.sequence_structure$x.max)), ylab = "E", xlab = plot.settings$xlab, xaxt = plot.settings$xaxt, ylim = c(-1, 1) ) text(x = max(temp.sequence_structure$x.max) / 2, y = 0, "Fitting Error!") } } } ## ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++# ## PLOT - METHOD SLIDE ## ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++# else if(method == "SLIDE"){ ##(0) density plot if (method.control.settings$show_density) { ##showing the density makes only sense when we see at least 10 data points if (!is.na(De.MC) && length(unique(De.MC)) >= 15) { ##calculate density De.MC density.De.MC <- density(De.MC) ##calculate transformation function x.1 <- max(density.De.MC$y) x.2 <- min(density.De.MC$y) ##with have to limit the scaling a little bit if (RF_nat.limited[1,2] > max(RF_reg.limited[,2]) - (max(RF_reg.limited[,2]) - min(RF_reg.limited[,2]))*.5) { y.1 <- max(RF_reg.limited[,2]) - (max(RF_reg.limited[,2]) - min(RF_reg.limited[,2]))*.5 }else{ y.1 <- RF_nat.limited[1,2] } y.2 <- par("usr")[3] m <- (y.1 - y.2) / (x.1 + x.2) n <- y.1 - m * x.1 density.De.MC$y <- m * density.De.MC$y + n rm(x.1,x.2,y.1,y.2,m,n) polygon(density.De.MC$x, density.De.MC$y, col = rgb(0,0.4,0.8,0.5)) }else{ warning("[analyse_IRSAR.RF()] Narrow density distribution, no density distribution plotted!", call. = FALSE) } } ##(1) plot unused points in grey ... unused points are points outside of the set limit points( matrix(RF_nat.slided[-(min(RF_nat.lim):max(RF_nat.lim)),1:2], ncol = 2), pch = 21, col = col[19] ) ##(2) add used points points(RF_nat.slided[min(RF_nat.lim):max(RF_nat.lim),], pch = 21, col = col[2], bg = col[2]) ##(3) add line to show the connection between the first point and the De lines(x = c(RF_nat.slided[1,1], RF_nat.slided[1,1]), y = c(.Machine$double.xmin,RF_nat.slided[1,2]), lty = 2, col = col[2] ) ##(4) add arrow at the lowest y-coordinate possible to show the sliding if (plot.settings$log != "y" & plot.settings$log != "xy") { shape::Arrows( x0 = 0, y0 = ylim[1], y1 = ylim[1], x1 = RF_nat.slided[1,1], arr.type = "triangle", arr.length = 0.3 * par()[["cex"]], code = 2, col = col[2], arr.adj = 1, arr.lwd = 1 ) } ##(5) add vertical shift as arrow; show nothing if nothing was shifted if (plot.settings$log != "y" & plot.settings$log != "xy" & I_n != 0) { shape::Arrows( x0 = (0 + par()$usr[1])/2, y0 = RF_nat[1,2], y1 = RF_nat[1,2] + I_n, x1 = (0 + par()$usr[1])/2, arr.type = "triangle", arr.length = 0.3 * par()[["cex"]], code = 2, col = col[2], arr.adj = 1, arr.lwd = 1 ) } ##TODO ##uncomment here to see all the RF_nat curves produced by the MC runs ##could become a polygone for future versions #lapply(1:n.MC, function(x){lines(slide.MC.list[[x]], col = rgb(0,0,0, alpha = 0.2))}) ##plot range choosen for fitting abline(v=RF_reg[min(RF_reg.lim), 1], lty=2) abline(v=RF_reg[max(RF_reg.lim), 1], lty=2) if (plot.settings$legend) { legend( plot.settings$legend.pos, legend = plot.settings$legend.text, pch = c(19, 3), col = c("red", col[10]), horiz = TRUE, bty = "n", cex = .9 * par()[["cex"]] ) } ##write information on the De in the plot if("mtext" %in% names(list(...))) { mtext(side = 3, list(...)$mtext) }else{ try(mtext(side=3, substitute(D[e] == De, list(De=paste0(De," [", De.lower, " ; ", De.upper, "]"))), line=0, cex=0.7 * par()[["cex"]]), silent=TRUE) } if (!plot_reduced) { ##==lower plot==## ##RESIDUAL PLOT par(mar = c(4, 4, 0, 0)) plot( NA, NA, ylim = range(residuals), xlim = xlim, xlab = plot.settings$xlab, type = "p", pch = 1, col = "grey", xaxt = plot.settings$xaxt, ylab = "E", yaxt = "n", log = ifelse( plot.settings$log == "y" | plot.settings$log == "xy", "", plot.settings$log ) ) ##add axis for 0 ... means if the 0 is not visible there is labelling axis(side = 4, at = 0, labels = 0) ##add residual indicator (should circle around 0) col.ramp <- colorRampPalette(c(col[19], "white", col[19])) col.polygon <- col.ramp(100) if (plot.settings$log != "x") { shape::filledrectangle( mid = c((xlim[2]) + (par("usr")[2] - xlim[2]) / 2, max(residuals) - diff(range(residuals)) / 2), wx = par("usr")[2] - xlim[2], wy = diff(range(residuals)), col = col.polygon ) } ##add 0 line abline(h = 0, lty = 3) ##0-line indicator and arrows if this is not visible ##red colouring here only if the 0 point is not visible to avoid too much colouring if (max(residuals) < 0 & min(residuals) < 0) { shape::Arrowhead( x0 = xlim[2] + (par("usr")[2] - xlim[2]) / 2, y0 = max(residuals), angle = 270, lcol = col[2], arr.length = 0.4, arr.type = "triangle", arr.col = col[2] ) } else if (max(residuals) > 0 & min(residuals) > 0) { shape::Arrowhead( x0 = xlim[2] + (par("usr")[2] - xlim[2]) / 2, y0 = min(residuals), angle = 90, lcol = col[2], arr.length = 0.4, arr.type = "triangle", arr.col = col[2] ) } else{ points(xlim[2], 0, pch = 3) } ##add residual points if (length(RF_nat.slided[c(min(RF_nat.lim):max(RF_nat.lim)), 1]) > length(residuals)) { temp.points.diff <- length(RF_nat.slided[c(min(RF_nat.lim):max(RF_nat.lim)), 1]) - length(residuals) points(RF_nat.slided[c(min(RF_nat.lim):(max(RF_nat.lim) - temp.points.diff)), 1], residuals, pch = 20, col = rgb(0, 0, 0, 0.4)) } else{ points(RF_nat.slided[c(min(RF_nat.lim):max(RF_nat.lim)), 1], residuals, pch = 20, col = rgb(0, 0, 0, 0.4)) } ##add vertical line to mark De (t_n) abline(v = De, lty = 2, col = col[2]) ##add numeric value of De ... t_n axis( side = 1, at = De, labels = De, cex.axis = 0.8 * plot.settings$cex, col = "blue", padj = -1.55, ) ##TODO- CONTROL PLOT! ... can be implemented in appropriate form in a later version if (method.control.settings$trace) { par(new = TRUE) plot( RF_reg.limited[1:length(slide$squared_residuals),1], slide$squared_residuals, ylab = "", type = "l", xlab = "", xaxt = plot.settings$xaxt, axes = FALSE, xlim = xlim, log = "y" ) } } } }#endif::plot # Return -------------------------------------------------------------------------------------- ##=============================================================================# ## RETURN ##=============================================================================# ##catch up worst case scenarios ... means something went wrong if(!exists("De")){De <- NA} if(!exists("De.error")){De.error <- NA} if(!exists("De.MC")){De.MC <- NA} if(!exists("De.lower")){De.lower <- NA} if(!exists("De.upper")){De.upper <- NA} if(!exists("De.status")){De.status <- NA} if (!exists("fit")) { if (exists("fit.lambda")) { fit <- fit.lambda }else{ fit <- list() } } if(!exists("slide")){slide <- list()} ##combine values for De into a data frame De.values <- data.frame( DE = De, DE.ERROR = De.error, DE.LOWER = De.lower, DE.UPPER = De.upper, DE.STATUS = De.status, RF_NAT.LIM = paste(RF_nat.lim, collapse = ":"), RF_REG.LIM = paste(RF_reg.lim, collapse = ":"), POSITION = as.integer(aliquot.position), DATE = aliquot.date, SEQUENCE_NAME = aliquot.sequence_name, UID = NA, row.names = NULL, stringsAsFactors = FALSE ) ##generate unique identifier UID <- .create_UID() ##update data.frames accordingly De.values$UID <- UID if(!is.null(TP.data.frame)){ TP.data.frame$UID <- UID } ##produce results object newRLumResults.analyse_IRSAR.RF <- set_RLum( class = "RLum.Results", data = list( data = De.values, De.MC = De.MC, test_parameters = TP.data.frame, fit = fit, slide = slide ), info = list(call = sys.call()) ) invisible(newRLumResults.analyse_IRSAR.RF) } Luminescence/R/read_Daybreak2R.R0000644000176200001440000003605213125226556016146 0ustar liggesusers#' Import measurement data produced by a Daybreak TL/OSL reader into R #' #' Import a TXT-file (ASCII file) or a DAT-file (binary file) produced by a Daybreak reader into R. #' The import of the DAT-files is limited to the file format described for the software TLAPLLIC v.3.2 #' used for a Daybreak, model 1100. #' #' @param file \code{\link{character}} or \code{\link{list}} (\bold{required}): path and file name of the #' file to be imported. Alternatively a list of file names can be provided or just the path a folder #' containing measurement data. Please note that the specific, common, file extension (txt) is likely #' leading to function failures during import when just a path is provided. #' #' @param raw \code{\link{logical}} (with default): if the input is a DAT-file (binary) a #' \code{\link[data.table]{data.table}} instead of the \code{\linkS4class{RLum.Analysis}} object #' can be returned for debugging purposes. #' #' @param verbose \code{\link{logical}} (with default): enables or disables terminal feedback #' #' @param txtProgressBar \code{\link{logical}} (with default): enables or disables #' \code{\link{txtProgressBar}}. #' #' @return A list of \code{\linkS4class{RLum.Analysis}} objects (each per position) is provided. #' #' @note \bold{[BETA VERSION]} This function still needs to be tested properly. In particular #' the function has underwent only very rough rests using a few files. #' #' @section Function version: 0.3.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France), \cr #' Anotine Zink, C2RMF, Palais du Louvre, Paris (France)\cr #' \cr The ASCII-file import is based on a suggestion by Willian Amidon and Andrew Louis Gorin #' #' @seealso \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data.Curve}}, #' \code{\link[data.table]{data.table}} #' #' @references - #' #' @keywords IO #' #' @examples #' #' \dontrun{ #' file <- file.choose() #' temp <- read_Daybreak2R(file) #' #' } #' #' @export read_Daybreak2R <- function( file, raw = FALSE, verbose = TRUE, txtProgressBar = TRUE ){ ##TODO ## - run tests ## - check where the warning messages are comming from ## - implement further integegrity tests (ASCII import) # 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 Daybreaks-txt files in the # directory and import them, if this is detected, we proceed as list if(is(file, "character")) { ##If this is not really a path we skip this here if (dir.exists(file) & length(dir(file)) > 0) { if(verbose){ cat("[read_Daybreak2R()] Directory detected, trying to extract '*.txt' files ...\n") } file <- as.list(paste0(file,dir( file, recursive = FALSE, pattern = ".txt" ))) } } ##if the input is already a list if (is(file, "list")) { temp.return <- lapply(1:length(file), function(x) { read_Daybreak2R( file = file[[x]], txtProgressBar = txtProgressBar ) }) ##return return(temp.return) } # Integrity checks ---------------------------------------------------------------------------- ##check if file exists if(!file.exists(file)){ stop("[read_Daybreak2R()] file name does not seem to exist.", call. = FALSE) } ##check for file extension ... distinguish between TXT and DAT if(substr(file, start = nchar(file) - 3, stop = nchar(file)) == ".DAT"){ # Read DAT-file ------------------------------------------------------------------------------ ##screen file to get information on the number of stored records con<-file(file,"rb") file.data <- file.info(file) max.pt<-readBin(con,what="int",6,size=2,endian="little")[6] file.size<-file.data$size n.length<-file.size/(190+8*(max.pt+1)) ##190 is is size of the header for each data set close(con) ##import data con <- file(file, "rb") ##pre-define data.table results.DATA <- data.table::data.table( ID = integer(length = n.length), MAXPT = integer(length = n.length), SPACING = integer(length = n.length), NDISK = integer(length = n.length), NRUN = integer(length = n.length), D1 = integer(length = n.length), NPT = integer(length = n.length), NATL = logical(length = n.length), TLRUN = logical(length = n.length), BEFORE_IRRAD = logical(length = n.length), SHIFT = double(length = n.length), RAMPRATE = double(length = n.length), GRATE = double(length = n.length), BRATE = double(length = n.length), ARATE = double(length = n.length), GAMMADOSE = double(length = n.length), BETADOSE = double(length = n.length), ALPHADOSE = double(length = n.length), BLEACHINGTIME = double(length = n.length), GRUNIT = character(length = n.length), BRUNIT = character(length = n.length), ARUNIT = character(length = n.length), BFILTER = character(length = n.length), GSOURCE = character(length = n.length), BSOURCE = character(length = n.length), ASOURCE = character(length = n.length), IRRAD_DATE = character(length = n.length), RUNREMARK = character(length = n.length), DATA = list() ) ##TERMINAL FEEDBACK if(verbose){ cat("\n[read_Daybreak2R()]") cat(paste("\n >> Importing:", file[1],"\n")) } ##PROGRESS BAR if(txtProgressBar & verbose){ pb <- txtProgressBar(min=0,max=n.length, char = "=", style=3) } ##LOOP over file i <- 1 while (i> Importing:", file[1],"\n")) } ##PROGRESS BAR if(txtProgressBar & verbose){ pb <- txtProgressBar(min=0,max=length(data.list), char = "=", style=3) } ##(2) ##Loop over the list to create RLum.Data.Curve objects RLum.Data.Curve.list <- lapply(1:length(data.list), function(x){ ##get length of record record.length <- length(data.list[[x]]) ##get header length until the argument 'Points' header.length <- grep(pattern = "Points", x = data.list[[x]]) if(length(header.length)>0){ temp.meta_data <- unlist(strsplit(data.list[[x]][2:header.length], split = "=", fixed = TRUE)) }else{ temp.meta_data <- unlist(strsplit(data.list[[x]][2:length(data.list[[x]])], split = "=", fixed = TRUE)) } ##get list names for the info element list info.names <- temp.meta_data[seq(1,length(temp.meta_data), by = 2)] ##info elements info <- as.list(temp.meta_data[seq(2,length(temp.meta_data), by = 2)]) names(info) <- info.names ##add position, which is 'Disk' info <- c(info, position = as.integer(info$Disk)) if(length(header.length)>0){ ##get measurement data temp.data <- unlist(strsplit(unlist(strsplit( data.list[[x]][12:length(data.list[[x]])], split = "=" )), split = ";")) ##grep only data of interest point.x <- suppressWarnings(as.numeric(gsub("^\\s+|\\s+$", "", temp.data[seq(2, length(temp.data), by = 4)]))) point.y <- suppressWarnings(as.numeric(gsub("^\\s+|\\s+$", "", temp.data[seq(3,length(temp.data), by = 4)]))) ##combine it into a matrix data <- matrix(c(point.x,point.y), ncol = 2) }else{ ##we presume this should be irradiation ... if ("IrradTime" %in% names(info)) { point.x <- 1:as.numeric(info$IrradTime) point.y <- rep(1, length(point.x)) data <- matrix(c(point.x,point.y), ncol = 2) } } ##update progress bar if (txtProgressBar & verbose) { setTxtProgressBar(pb, x) } ##return RLum object return( set_RLum( class = "RLum.Data.Curve", originator = "read_Daybreak2R", recordType = sub(" ", replacement = "_", x = info$DataType), curveType = "measured", data = data, info = info ) ) }) ##close ProgressBar if(txtProgressBar & verbose){close(pb)} ##(3) ##Now we have to find out how many aliquots we do have positions.id <- sapply(RLum.Data.Curve.list, function(x){ get_RLum(x, info.object = "position") }) ##(4) ##now combine everyting in an RLum.Analysis object in accordance to the position number RLum.Analysis.list <- lapply(unique(positions.id), function(x){ ##get list ids for position number n <- which(positions.id == x) ##make list temp.list <- lapply(n, function(x){ RLum.Data.Curve.list[[x]] }) ##put in RLum.Analysis object object <- set_RLum( class = "RLum.Analysis", originator = "read_Daybreak2R", protocol = "Custom", records = temp.list ) ##set parent id of records object <- .set_pid(object) return(object) }) ##TERMINAL FEEDBACK if(verbose){ cat(paste0("\n ",length(unlist(get_RLum(RLum.Analysis.list))), " records have been read sucessfully!\n")) } return(RLum.Analysis.list) } } Luminescence/R/plot_DRTResults.R0000644000176200001440000006513113125226556016276 0ustar liggesusers#' Visualise dose recovery test results #' #' The function provides a standardised plot output for dose recovery test #' measurements. #' #' Procedure to test the accuracy of a measurement protocol to reliably #' determine the dose of a specific sample. Here, the natural signal is erased #' and a known laboratory dose administered which is treated as unknown. Then #' the De measurement is carried out and the degree of congruence between #' administered and recovered dose is a measure of the protocol's accuracy for #' this sample.\cr In the plot the normalised De is shown on the y-axis, i.e. #' obtained De/Given Dose. #' #' @param values \code{\linkS4class{RLum.Results}} or \code{\link{data.frame}}, #' (\bold{required}): input values containing at least De and De error. To plot #' more than one data set in one figure, a \code{list} of the individual data #' sets must be provided (e.g. \code{list(dataset.1, dataset.2)}). #' #' @param given.dose \code{\link{numeric}} (optional): given dose used for the #' dose recovery test to normalise data. If only one given dose is provided #' this given dose is valid for all input data sets (i.e., \code{values} is a #' list). Otherwise a given dose for each input data set has to be provided #' (e.g., \code{given.dose = c(100,200)}). If no \code{given.dose} values are #' plotted without normalisation (might be useful for preheat plateau tests). #' Note: Unit has to be the same as from the input values (e.g., Seconds or #' Gray). #' #' @param error.range \code{\link{numeric}}: symmetric error range in percent #' will be shown as dashed lines in the plot. Set \code{error.range} to 0 to #' void plotting of error ranges. #' #' @param preheat \code{\link{numeric}}: optional vector of preheat #' temperatures to be used for grouping the De values. If specified, the #' temperatures are assigned to the x-axis. #' #' @param boxplot \code{\link{logical}}: optionally plot values, that are #' grouped by preheat temperature as boxplots. Only possible when #' \code{preheat} vector is specified. #' #' @param mtext \code{\link{character}}: additional text below the plot title. #' #' @param summary \code{\link{character}} (optional): adds numerical output to #' the plot. Can be one or more out of: \code{"n"} (number of samples), #' \code{"mean"} (mean De value), \code{"mean.weighted"} (error-weighted mean), #' \code{"median"} (median of the De values), \code{"sdrel"} (relative standard #' deviation in percent), \code{"sdabs"} (absolute standard deviation), #' \code{"serel"} (relative standard error) and \code{"seabs"} (absolute #' standard error). #' #' @param summary.pos \code{\link{numeric}} or \code{\link{character}} (with #' default): optional position coordinates or keyword (e.g. \code{"topright"}) #' for the statistical summary. Alternatively, the keyword \code{"sub"} may be #' specified to place the summary below the plot header. However, this latter #' option in only possible if \code{mtext} is not used. #' #' @param legend \code{\link{character}} vector (optional): legend content to #' be added to the plot. #' #' @param legend.pos \code{\link{numeric}} or \code{\link{character}} (with #' default): optional position coordinates or keyword (e.g. \code{"topright"}) #' for the legend to be plotted. #' @param par.local \code{\link{logical}} (with default): use local graphical #' parameters for plotting, e.g. the plot is shown in one column and one row. #' If \code{par.local = FALSE}, global parameters are inherited, i.e. parameters #' provided via \code{par()} work #' @param na.rm \code{\link{logical}}: indicating wether \code{NA} values are #' removed before plotting from the input data set #' @param \dots further arguments and graphical parameters passed to #' \code{\link{plot}}. #' @return A plot is returned. #' #' @note Further data and plot arguments can be added by using the appropiate R #' commands. #' @section Function version: 0.1.10 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France), Michael Dietze, GFZ Potsdam (Germany) #' #' @seealso \code{\link{plot}} #' #' @references Wintle, A.G., Murray, A.S., 2006. A review of quartz optically #' stimulated luminescence characteristics and their relevance in #' single-aliquot regeneration dating protocols. Radiation Measurements, 41, #' 369-391. #' #' @keywords dplot #' #' @examples #' #' #' ## read example data set and misapply them for this plot type #' data(ExampleData.DeValues, envir = environment()) #' #' ## plot values #' plot_DRTResults(values = ExampleData.DeValues$BT998[7:11,], #' given.dose = 2800, mtext = "Example data") #' #' ## plot values with legend #' plot_DRTResults(values = ExampleData.DeValues$BT998[7:11,], #' given.dose = 2800, #' legend = "Test data set") #' #' ## create and plot two subsets with randomised values #' x.1 <- ExampleData.DeValues$BT998[7:11,] #' x.2 <- ExampleData.DeValues$BT998[7:11,] * c(runif(5, 0.9, 1.1), 1) #' #' plot_DRTResults(values = list(x.1, x.2), #' given.dose = 2800) #' #' ## some more user-defined plot parameters #' plot_DRTResults(values = list(x.1, x.2), #' given.dose = 2800, #' pch = c(2, 5), #' col = c("orange", "blue"), #' xlim = c(0, 8), #' ylim = c(0.85, 1.15), #' xlab = "Sample aliquot") #' #' ## plot the data with user-defined statistical measures as legend #' plot_DRTResults(values = list(x.1, x.2), #' given.dose = 2800, #' summary = c("n", "mean.weighted", "sd")) #' #' ## plot the data with user-defined statistical measures as sub-header #' plot_DRTResults(values = list(x.1, x.2), #' given.dose = 2800, #' summary = c("n", "mean.weighted", "sd"), #' summary.pos = "sub") #' #' ## plot the data grouped by preheat temperatures #' plot_DRTResults(values = ExampleData.DeValues$BT998[7:11,], #' given.dose = 2800, #' preheat = c(200, 200, 200, 240, 240)) #' ## read example data set and misapply them for this plot type #' data(ExampleData.DeValues, envir = environment()) #' #' ## plot values #' plot_DRTResults(values = ExampleData.DeValues$BT998[7:11,], #' given.dose = 2800, mtext = "Example data") #' ## plot two data sets grouped by preheat temperatures #' plot_DRTResults(values = list(x.1, x.2), #' given.dose = 2800, #' preheat = c(200, 200, 200, 240, 240)) #' #' ## plot the data grouped by preheat temperatures as boxplots #' plot_DRTResults(values = ExampleData.DeValues$BT998[7:11,], #' given.dose = 2800, #' preheat = c(200, 200, 200, 240, 240), #' boxplot = TRUE) #' #' @export plot_DRTResults <- function( values, given.dose = NULL, error.range = 10, preheat, boxplot = FALSE, mtext, summary, summary.pos, legend, legend.pos, par.local = TRUE, na.rm = FALSE, ... ){ ## Validity checks ---------------------------------------------------------- ##avoid crash for wrongly set boxlot argument if(missing(preheat) & boxplot == TRUE){ warning("[plot_DRTResults()] Option 'boxplot' not valid without any value in 'preheat'. Reset to FALSE.") boxplot <- FALSE } if(missing(summary) == TRUE) {summary <- NULL} if(missing(summary.pos) == TRUE) {summary.pos <- "topleft"} if(missing(legend.pos) == TRUE) {legend.pos <- "topright"} if(missing(mtext) == TRUE) {mtext <- ""} ## Homogenise and check input data if(is(values, "list") == FALSE) {values <- list(values)} for(i in 1:length(values)) { if(is(values[[i]], "RLum.Results")==FALSE & is(values[[i]], "data.frame")==FALSE){ stop(paste("[plot_DRTResults()] Wrong input data format", "(!= 'data.frame' or 'RLum.Results')")) } else { if(is(values[[i]], "RLum.Results")==TRUE){ values[[i]] <- get_RLum(values[[i]])[,1:2] } } } ## Check input arguments ---------------------------------------------------- for(i in 1:length(values)) { ##check for preheat temperature values if(missing(preheat) == FALSE) { if(length(preheat) != nrow(values[[i]])){ stop("[plot_DRTResults()] number of preheat temperatures != De values!") } } ##remove NA values; yes Micha, it is not that simple if(na.rm == TRUE){ ##currently we assume that all input data sets comprise a similar of data if(!missing(preheat) & i == length(values)){ ##find and mark NA value indicies temp.NA.values <- unique(c(which(is.na(values[[i]][,1])), which(is.na(values[[i]][,2])))) ##remove preheat entries preheat <- preheat[-temp.NA.values] } values[[i]] <- na.exclude(values[[i]]) } } ## create global data set values.global <- NULL n.values <- NULL for(i in 1:length(values)) { values.global <- rbind(values.global, values[[i]]) n.values <- c(n.values, nrow(values[[i]])) } ## Set plot format parameters ----------------------------------------------- extraArgs <- list(...) # read out additional arguments list main <- if("main" %in% names(extraArgs)) {extraArgs$main} else {"Dose recovery test"} xlab <- if("xlab" %in% names(extraArgs)) {extraArgs$xlab} else { ifelse(missing(preheat) == TRUE, "# Aliquot", "Preheat temperature [\u00B0C]") } ylab <- if("ylab" %in% names(extraArgs)) {extraArgs$ylab} else {if(!is.null(given.dose)){ expression(paste("Normalised ", D[e], sep="")) }else{expression(paste(D[e], " [s]"), sep = "")}} xlim <- if("xlim" %in% names(extraArgs)) {extraArgs$xlim} else {c(1, max(n.values) + 1)} ylim <- if("ylim" %in% names(extraArgs)) {extraArgs$ylim} else {c(0.75, 1.25)} #check below for further corrections if boundaries exceed set range cex <- if("cex" %in% names(extraArgs)) {extraArgs$cex} else {1} pch <- if("pch" %in% names(extraArgs)) {extraArgs$pch} else { abs(seq(from = 20, to = -100)) } fun <- if("fun" %in% names(extraArgs)) {extraArgs$fun} else {FALSE} ## calculations and settings------------------------------------------------- ## normalise data if given.dose is given if(!is.null(given.dose)){ if(length(given.dose) > 1){ if(length(values) < length(given.dose)){ stop("[plot_DRTResults()] 'given.dose' > number of input data sets!") } for(i in 1:length(values)) { values[[i]] <- values[[i]]/given.dose[i] } }else{ for(i in 1:length(values)) { values[[i]] <- values[[i]]/given.dose } } } ##correct ylim for data set which exceed boundaries if((max(sapply(1:length(values), function(x){max(values[[x]][,1], na.rm = TRUE)}))>1.25 | min(sapply(1:length(values), function(x){min(values[[x]][,1], na.rm = TRUE)}))<0.75) & ("ylim" %in% names(extraArgs)) == FALSE){ ylim <- c( min(sapply(1:length(values), function(x){ min(values[[x]][,1], na.rm = TRUE) - max(values[[x]][,2], na.rm = TRUE)})), max(sapply(1:length(values), function(x){ max(values[[x]][,1], na.rm = TRUE) + max(values[[x]][,2], na.rm = TRUE)}))) } ## optionally group data by preheat temperature if(missing(preheat) == FALSE) { modes <- as.numeric(rownames(as.matrix(table(preheat)))) values.preheat <- list(NA) values.boxplot <- list(NA) for(i in 1:length(modes)) { for(j in 1:length(values)) { values.preheat[[length(values.preheat) + 1]] <- cbind(values[[j]][preheat == modes[i],], preheat[preheat == modes[i]]) values.boxplot[[length(values.boxplot) + 1]] <- values[[j]][preheat == modes[i],1] } j <- 1 } values.preheat[[1]] <- NULL values.boxplot[[1]] <- NULL modes.plot <- rep(modes, each = length(values)) } else {modes <- 1} ## assign colour indices col <- if("col" %in% names(extraArgs)) {extraArgs$col} else { if(missing(preheat) == TRUE) { rep(seq(from = 1, to = length(values)), each = length(modes)) } else { rep(seq(from = 1, to = length(values)), length(modes)) } } ## calculate and paste statistical summary label.text = list(NA) if(summary.pos[1] != "sub") { n.rows <- length(summary) for(i in 1:length(values)) { stops <- paste(rep("\n", (i - 1) * n.rows), collapse = "") label.text[[length(label.text) + 1]] <- paste(stops, paste( ifelse("n" %in% summary == TRUE, paste("n = ", nrow(values[[i]]), "\n", sep = ""), ""), ifelse("mean" %in% summary == TRUE, paste("mean = ", round(mean(values[[i]][,1]), 2), "\n", sep = ""), ""), ifelse("mean.weighted" %in% summary == TRUE, paste("weighted mean = ", round(weighted.mean(x = values[[i]][,1], w = 1 / values[[i]][,2]), 2), "\n", sep = ""), ""), ifelse("median" %in% summary == TRUE, paste("median = ", round(median(values[[i]][,1]), 2), "\n", sep = ""), ""), ifelse("sdrel" %in% summary == TRUE, paste("sd = ", round(sd(values[[i]][,1]) / mean(values[[i]][,1]) * 100, 2), " %", "\n", sep = ""), ""), ifelse("sdabs" %in% summary == TRUE, paste("sd = ", round(sd(values[[i]][,1]), 2), "\n", sep = ""), ""), ifelse("serel" %in% summary == TRUE, paste("se = ", round(calc_Statistics(values[[i]])$unweighted$se.rel, 2), " %\n", sep = ""), ""), ifelse("seabs" %in% summary == TRUE, paste("se = ", round(calc_Statistics(values[[i]])$unweighted$se.abs, 2), "\n", sep = ""), ""), sep = ""), stops, sep = "") } } else { for(i in 1:length(values)) { label.text[[length(label.text) + 1]] <- paste( "| ", ifelse("n" %in% summary == TRUE, paste("n = ", nrow(values[[i]]), " | ", sep = ""), ""), ifelse("mean" %in% summary == TRUE, paste("mean = ", round(mean(values[[i]][,1]), 2), " | ", sep = ""), ""), ifelse("mean.weighted" %in% summary == TRUE, paste("weighted mean = ", round(weighted.mean(x = values[[i]][,1], w = 1 / values[[i]][,2]), 2), " | ", sep = ""), ""), ifelse("median" %in% summary == TRUE, paste("median = ", round(median(values[[i]][,1]), 2), " | ", sep = ""), ""), ifelse("sdrel" %in% summary == TRUE, paste("sd = ", round(sd(values[[i]][,1]) / mean(values[[i]][,1]) * 100, 2), " %", " | ", sep = ""), ""), ifelse("sdabs" %in% summary == TRUE, paste("sd = ", round(sd(values[[i]][,1]), 2), " | ", sep = ""), ""), ifelse("serel" %in% summary == TRUE, paste("se = ", round(calc_Statistics(values[[i]])$unweighted$se.rel, 2), " % | ", sep = ""), ""), ifelse("seabs" %in% summary == TRUE, paste("se = ", round(calc_Statistics(values[[i]])$unweighted$se.abs, 2), " | ", sep = ""), ""), sep = "") } } ## remove dummy list element label.text[[1]] <- NULL ## convert keywords into summary placement coordinates if(missing(summary.pos) == TRUE) { summary.pos <- c(xlim[1], ylim[2]) summary.adj <- c(0, 1) } else if(length(summary.pos) == 2) { summary.pos <- summary.pos summary.adj <- c(0, 1) } else if(summary.pos[1] == "topleft") { summary.pos <- c(xlim[1], ylim[2]) summary.adj <- c(0, 1) } else if(summary.pos[1] == "top") { summary.pos <- c(mean(xlim), ylim[2]) summary.adj <- c(0.5, 1) } else if(summary.pos[1] == "topright") { summary.pos <- c(xlim[2], ylim[2]) summary.adj <- c(1, 1) } else if(summary.pos[1] == "left") { summary.pos <- c(xlim[1], mean(ylim)) summary.adj <- c(0, 0.5) } else if(summary.pos[1] == "center") { summary.pos <- c(mean(xlim), mean(ylim)) summary.adj <- c(0.5, 0.5) } else if(summary.pos[1] == "right") { summary.pos <- c(xlim[2], mean(ylim)) summary.adj <- c(1, 0.5) }else if(summary.pos[1] == "bottomleft") { summary.pos <- c(xlim[1], ylim[1]) summary.adj <- c(0, 0) } else if(summary.pos[1] == "bottom") { summary.pos <- c(mean(xlim), ylim[1]) summary.adj <- c(0.5, 0) } else if(summary.pos[1] == "bottomright") { summary.pos <- c(xlim[2], ylim[1]) summary.adj <- c(1, 0) } ## convert keywords into legend placement coordinates if(missing(legend.pos) == TRUE) { legend.pos <- c(xlim[2], ylim[2]) legend.adj <- c(1, 1) } else if(length(legend.pos) == 2) { legend.pos <- legend.pos legend.adj <- c(0, 1) } else if(legend.pos[1] == "topleft") { legend.pos <- c(xlim[1], ylim[2]) legend.adj <- c(0, 1) } else if(legend.pos[1] == "top") { legend.pos <- c(mean(xlim), ylim[2]) legend.adj <- c(0.5, 1) } else if(legend.pos[1] == "topright") { legend.pos <- c(xlim[2], ylim[2]) legend.adj <- c(1, 1) } else if(legend.pos[1] == "left") { legend.pos <- c(xlim[1], mean(ylim)) legend.adj <- c(0, 0.5) } else if(legend.pos[1] == "center") { legend.pos <- c(mean(xlim), mean(ylim)) legend.adj <- c(0.5, 0.5) } else if(legend.pos[1] == "right") { legend.pos <- c(xlim[2], mean(ylim)) legend.adj <- c(1, 0.5) } else if(legend.pos[1] == "bottomleft") { legend.pos <- c(xlim[1], ylim[1]) legend.adj <- c(0, 0) } else if(legend.pos[1] == "bottom") { legend.pos <- c(mean(xlim), ylim[1]) legend.adj <- c(0.5, 0) } else if(legend.pos[1] == "bottomright") { legend.pos <- c(xlim[2], ylim[1]) legend.adj <- c(1, 0) } ## Plot output -------------------------------------------------------------- ## determine number of subheader lines to shif the plot shift.lines <- if(summary.pos[1] == "sub" & mtext == "") { length(label.text) - 1 } else {1} ## setup plot area if(par.local){ if (shift.lines <= 0) shift.lines <- 1 par.default <- par()[c("mfrow", "cex", "oma")] par(mfrow = c(1, 1), cex = cex, oma = c(0, 1, shift.lines - 1, 1)) } ## optionally plot values and error bars if(boxplot == FALSE) { ## plot data and error if(missing(preheat) == TRUE) { ## create empty plot plot(NA,NA, xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab, xaxt = "n", main = "") ##add x-axis ... this avoids digits in the axis labeling axis(side = 1, at = 1:(nrow(values[[1]])+1), labels = 1:(nrow(values[[1]])+1)) ## add title title(main = main, line = shift.lines + 2) ## add additional lines if (!is.null(given.dose)) { abline(h = 1) if (error.range > 0) { ## error range lines abline(h = 1 * (1 + error.range / 100), lty = 2) abline(h = 1 * (1 - error.range / 100), lty = 2) ## error range labels text( par()$usr[2], (1 + error.range / 100) + 0.02, paste("+", error.range , " %", sep = ""), pos = 2, cex = 0.8 ) text( par()$usr[2], (1 - error.range / 100) - 0.02, paste("-", error.range , "%", sep = ""), pos = 2, cex = 0.8 ) } } ## add data and error bars for(i in 1:length(values)) { points(x = c(1:nrow(values[[i]])), y = values[[i]][,1], pch = if(nrow(values[[i]]) == length(pch)){ pch } else { pch[i] }, col = if(nrow(values[[i]]) == length(col)){ col } else { col[i] }, cex = 1.2 * cex) arrows(c(1:nrow(values[[i]])), values[[i]][,1] + values[[i]][,2], c(1:nrow(values[[i]])), values[[i]][,1] - values[[i]][,2], angle = 90, length = 0.075, code = 3, col = if(nrow(values[[i]]) == length(col)){ col } else { col[i] }) ## add summary content if(summary.pos[1] != "sub") { text(x = summary.pos[1], y = summary.pos[2], adj = summary.adj, labels = label.text[[i]], cex = 0.8 * cex, col = if(nrow(values[[i]]) == length(col)){ "black" } else { col[i] }) } else { if(mtext == "") { mtext(side = 3, line = - i + 2.5, text = label.text[[i]], col = if(nrow(values[[i]]) == length(col)){ "black" } else { col[i] }, cex = cex * 0.8) } } } } else { ## option for provided preheat data ## create empty plot plot(NA,NA, xlim = c(min(modes.plot) * 0.9, max(modes.plot) * 1.1), ylim = ylim, xlab = xlab, ylab = ylab, main = "", axes = FALSE, frame.plot = TRUE) ## add axes axis(1, at = modes.plot, labels = modes.plot) axis(2) ## add title title(main = main, line = shift.lines + 2) ## add additional lines if (!is.null(given.dose)) { abline(h = 1) if (error.range > 0) { ## error range lines abline(h = 1 * (1 + error.range / 100), lty = 2) abline(h = 1 * (1 - error.range / 100), lty = 2) ## error range labels text( par()$usr[2], (1 + error.range / 100) + 0.02, paste("+", error.range , " %", sep = ""), pos = 2, cex = 0.8 ) text( par()$usr[2], (1 - error.range / 100) - 0.02, paste("-", error.range , "%", sep = ""), pos = 2, cex = 0.8 ) } } ## plot values for(i in 1:length(values.preheat)) { points(x = values.preheat[[i]][,3], y = values.preheat[[i]][,1], pch = pch[i], col = col[i], cex = 1.2 * cex) arrows(values.preheat[[i]][,3], values.preheat[[i]][,1] + values.preheat[[i]][,2], values.preheat[[i]][,3], values.preheat[[i]][,1] - values.preheat[[i]][,2], angle = 90, length = 0.075, code = 3, col = col[i]) } } } ## optionally, plot boxplot if(boxplot == TRUE) { ## create empty plot boxplot(values.boxplot, names = modes.plot, ylim = ylim, xlab = xlab, ylab = ylab, xaxt = "n", main = "", border = col) ## add axis label, if necessary if (length(modes.plot) == 1) { axis(side = 1, at = 1, labels = modes.plot) } else if (length(modes.plot) > length(unique(modes.plot))){ ticks <- seq(from = 1 + ((length(values.boxplot)/length(unique(modes.plot)) - 1)/2), to = length(values.boxplot), by = length(values.boxplot)/length(unique(modes.plot))) axis( side = 1, at = ticks, labels = unique(modes.plot) ) ##polygon for a better graphical representation of the groups polygon.x <- seq( 1,length(values.boxplot), by = length(values.boxplot) / length(unique(modes.plot)) ) polygon.step <- unique(diff(polygon.x) - 1) for (x.plyg in polygon.x) { polygon( x = c(x.plyg,x.plyg,x.plyg + polygon.step, x.plyg + polygon.step), y = c( par()$usr[3], ylim[1] - (ylim[1] - par()$usr[3]) / 2, ylim[1] - (ylim[1] - par()$usr[3]) / 2, par()$usr[3] ), col = "grey", border = "grey" ) } }else{ axis(side = 1, at = 1:length(unique(modes.plot)), labels = unique(modes.plot)) } ## add title title(main = main, line = shift.lines + 2) ## add additional lines abline(h = 1) if(error.range > 0){ ## error range lines abline(h = 1 * (1 + error.range / 100), lty = 2) abline(h = 1 * (1 - error.range / 100), lty = 2) ## error range labels text(par()$usr[2], (1 + error.range / 100) + 0.02, paste("+", error.range ," %", sep = ""), pos = 2, cex = 0.8) text(par()$usr[2], (1 - error.range / 100) - 0.02, paste("-", error.range ,"%", sep = ""), pos = 2, cex = 0.8) } ## plot data and error for(i in 1:length(values)) { ## add summary content if(summary.pos[1] != "sub") { text(x = summary.pos[1], y = summary.pos[2], adj = summary.adj, labels = label.text[[i]], cex = 0.8 * cex, col = if(nrow(values[[i]]) == length(col)){ "black" } else { col[i] }) } else { if(mtext == "") { mtext(side = 3, line = - i + 2.5, text = label.text[[i]], col = if(nrow(values[[i]]) == length(col)){ "black" } else { col[i] }, cex = cex * 0.8) } } } } ## optionally add legend content if(missing(legend) == FALSE) { legend(x = legend.pos[1], y = legend.pos[2], xjust = legend.adj[1], yjust = legend.adj[2], legend = legend, col = unique(col), pch = unique(pch), lty = 1, cex = cex * 0.8) } ## optionally add subheader text mtext(side = 3, line = shift.lines, text = mtext, cex = 0.8 * cex) ##reset par() if(par.local){ par(par.default) rm(par.default) } ##FUN by R Luminescence Team if(fun == TRUE) {sTeve()} } Luminescence/R/plot_RLum.Data.Curve.R0000644000176200001440000001607713125226556017102 0ustar liggesusers#' Plot function for an RLum.Data.Curve S4 class object #' #' The function provides a standardised plot output for curve data of an #' RLum.Data.Curve S4 class object #' #' Only single curve data can be plotted with this function. Arguments #' according to \code{\link{plot}}. #' #' @param object \code{\linkS4class{RLum.Data.Curve}} (\bold{required}): S4 #' object of class \code{RLum.Data.Curve} #' #' @param par.local \code{\link{logical}} (with default): use local graphical #' parameters for plotting, e.g. the plot is shown in one column and one row. #' If \code{par.local = FALSE}, global parameters are inherited. #' #' @param norm \code{\link{logical}} (with default): allows curve normalisation #' to the highest count value #' #' @param smooth \code{\link{logical}} (with default): provides an automatic curve smoothing #' based on \code{\link[zoo]{rollmean}} #' #' @param \dots further arguments and graphical parameters that will be passed #' to the \code{plot} function #' #' @return Returns a plot. #' #' @note Not all arguments of \code{\link{plot}} will be passed! #' #' @section Function version: 0.2.3 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\link{plot}}, \code{\link{plot_RLum}} #' #' @references # #' #' @keywords aplot #' #' @examples #' #' #' ##plot curve data #' #' #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.Data.Curve object #' plot_RLum.Data.Curve(temp) #' #' #' @export plot_RLum.Data.Curve<- function( object, par.local = TRUE, norm = FALSE, smooth = FALSE, ... ){ # Integrity check ------------------------------------------------------------- ##check if object is of class RLum.Data.Curve if(class(object) != "RLum.Data.Curve"){ stop("[plot_RLum.Data.Curve()] Input object is not of type RLum.Data.Curve") } ##stop for NA values if (!all(is.na(object@data))) { ##set labeling unit if(!is.na(object@recordType)){ lab.unit <- if (object@recordType == "OSL" | object@recordType == "IRSL" | object@recordType == "RL" | object@recordType == "RF" | object@recordType == "LM-OSL" | object@recordType == "RBR") { "s" } else if (object@recordType == "TL") { "\u00B0C" } else { "Unknown" } }else{ lab.unit <- "Unknown" } if(!is.na(object@recordType)){ lab.xlab <- if (object@recordType == "OSL" | object@recordType == "IRSL" | object@recordType == "RL" | object@recordType == "RF" | object@recordType == "RBR" | object@recordType == "LM-OSL"){ "Stimulation time" } else if (object@recordType == "TL") { "Temperature" } else { "Independent" } }else{ lab.xlab <- "Independent" } ##XSYG ##check for curveDescripter if ("curveDescripter" %in% names(object@info)) { temp.lab <- strsplit(object@info$curveDescripter, split = ";", fixed = TRUE)[[1]] xlab.xsyg <- temp.lab[1] ylab.xsyg <- temp.lab[2] } else{ xlab.xsyg <- NA ylab.xsyg <- NA } ##normalise curves if argument has been set if (norm) { object@data[,2] <- object@data[,2] / max(object@data[,2]) } ##deal with additional arguments extraArgs <- list(...) main <- if ("main" %in% names(extraArgs)) { extraArgs$main } else { object@recordType } xlab <- if ("xlab" %in% names(extraArgs)) { extraArgs$xlab } else { if (!is.na(xlab.xsyg)) { xlab.xsyg } else { paste0(lab.xlab, " [", lab.unit, "]") } } ylab <- if ("ylab" %in% names(extraArgs)) { extraArgs$ylab }else if (!is.na(ylab.xsyg)) { ylab.xsyg } else if (lab.xlab == "Independent") { "Dependent [unknown]" } else { paste( object@recordType, " [cts/", round(max(object@data[,1]) / length(object@data[,1]),digits = 2) , " ", lab.unit,"]", sep = "" ) } sub <- if ("sub" %in% names(extraArgs)) { extraArgs$sub } else { if ((grepl("TL", object@recordType) == TRUE) & "RATE" %in% names(object@info)) { paste("(",object@info$RATE," K/s)", sep = "") } if ((grepl("OSL", object@recordType) | grepl("IRSL", object@recordType)) & "interval" %in% names(object@info)) { paste("(resolution: ",object@info$interval," s)", sep = "") } } cex <- if ("cex" %in% names(extraArgs)) { extraArgs$cex } else { 1 } type <- if ("type" %in% names(extraArgs)) { extraArgs$type } else { "l" } lwd <- if ("lwd" %in% names(extraArgs)) { extraArgs$lwd } else { 1 } lty <- if ("lty" %in% names(extraArgs)) { extraArgs$lty } else { 1 } pch <- if ("pch" %in% names(extraArgs)) { extraArgs$pch } else { 1 } col <- if ("col" %in% names(extraArgs)) { extraArgs$col } else { 1 } ylim <- if ("ylim" %in% names(extraArgs)) { extraArgs$ylim } else { c(min(object@data[,2], na.rm = TRUE),max(object@data[,2], na.rm = TRUE)) } xlim <- if ("xlim" %in% names(extraArgs)) { extraArgs$xlim } else { c(min(object@data[,1]),max(object@data[,1])) } log <- if ("log" %in% names(extraArgs)) { extraArgs$log } else { "" } mtext <- if ("mtext" %in% names(extraArgs)) { extraArgs$mtext } else { "" } fun <- if ("fun" %in% names(extraArgs)) { extraArgs$fun } else { FALSE } ##to avoid problems with plot method of RLum.Analysis plot.trigger <- if ("plot.trigger" %in% names(extraArgs)) { extraArgs$plot.trigger } else { FALSE } ##par setting for possible combination with plot method for RLum.Analysis objects if (par.local == TRUE) { par(mfrow = c(1,1), cex = cex) } ##smooth if(smooth){ k <- ceiling(length(object@data[, 2])/100) object@data[, 2] <- zoo::rollmean(object@data[, 2], k = k, fill = NA) } ##plot curve plot( object@data[,1], object@data[,2], main = main, xlim = xlim, ylim = ylim, xlab = xlab, ylab = ylab, sub = sub, type = type, log = log, col = col, lwd = lwd, pch = pch, lty = lty ) ##plot additional mtext mtext(mtext, side = 3, cex = cex * 0.8) if (fun == TRUE) { sTeve() } }else{ warning("[plot_RLum.Data.Curve()] Curve contains only NA-values, nothing plotted.", call. = FALSE) } } Luminescence/R/merge_Risoe.BINfileData.R0000644000176200001440000001501413125226556017521 0ustar liggesusers #' Merge Risoe.BINfileData objects or Risoe BIN-files #' #' Function allows merging Risoe BIN/BINX files or Risoe.BINfileData objects. #' #' The function allows merging different measurements to one file or one #' object.\cr The record IDs are recalculated for the new object. Other values #' are kept for each object. The number of input objects is not limited. \cr #' #' \code{position.number.append.gap} option \cr #' #' If the option \code{keep.position.number = FALSE} is used, the position #' numbers of the new data set are recalculated by adding the highest position #' number of the previous data set to the each position number of the next data #' set. For example: The highest position number is 48, then this number will #' be added to all other position numbers of the next data set (e.g. 1 + 48 = #' 49)\cr #' #' However, there might be cases where an additional addend (summand) is needed #' before the next position starts. Example: \cr #' #' Position number set (A): \code{1,3,5,7}\cr Position number set (B): #' \code{1,3,5,7} \cr #' #' With no additional summand the new position numbers would be: #' \code{1,3,5,7,8,9,10,11}. That might be unwanted. Using the argument #' \code{position.number.append.gap = 1} it will become: #' \code{1,3,5,7,9,11,13,15,17}. #' #' @param input.objects \code{\link{character}} with #' \code{\linkS4class{Risoe.BINfileData}} objects (\bold{required}): Character vector #' with path and files names (e.g. \code{input.objects = c("path/file1.bin", #' "path/file2.bin")} or \code{\linkS4class{Risoe.BINfileData}} objects (e.g. #' \code{input.objects = c(object1, object2)}). Alternatively a \code{list} is supported. #' #' #' @param output.file \code{\link{character}} (optional): File output path and #' name. \cr If no value is given, a \code{\linkS4class{Risoe.BINfileData}} is #' returned instead of a file. #' #' #' @param keep.position.number \code{\link{logical}} (with default): Allows #' keeping the original position numbers of the input objects. Otherwise the #' position numbers are recalculated. #' #' #' @param position.number.append.gap \code{\link{integer}} (with default): Set #' the position number gap between merged BIN-file sets, if the option #' \code{keep.position.number = FALSE} is used. See details for further #' information. #' #' #' @return Returns a \code{file} or a \code{\linkS4class{Risoe.BINfileData}} #' object. #' #' #' @note The validity of the output objects is not further checked. #' #' #' @section Function version: 0.2.7 #' #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' #' @seealso \code{\linkS4class{Risoe.BINfileData}}, \code{\link{read_BIN2R}}, #' \code{\link{write_R2BIN}} #' #' #' @references Duller, G., 2007. Analyst. #' #' #' @keywords IO manip #' #' #' @examples #' #' #' ##merge two objects #' data(ExampleData.BINfileData, envir = environment()) #' #' object1 <- CWOSL.SAR.Data #' object2 <- CWOSL.SAR.Data #' #' object.new <- merge_Risoe.BINfileData(c(object1, object2)) #' #' #' @export merge_Risoe.BINfileData <- function( input.objects, output.file, keep.position.number = FALSE, position.number.append.gap = 0 ){ # Integrity Checks -------------------------------------------------------- if(length(input.objects) < 2){ stop("[merge_Risoe.BINfileData()] At least two input objects are needed!") } if(is(input.objects, "character") == TRUE){ for(i in 1:length(input.objects)){ if(file.exists(input.objects[i])==FALSE){ stop("[merge_Risoe.BINfileData()] File ",input.objects[i]," does not exist!", call. = FALSE) } } }else{ if(is(input.objects, "list") == TRUE){ for(i in 1:length(input.objects)){ if(is(input.objects[[i]], "Risoe.BINfileData") == FALSE){ stop("[merge_Risoe.BINfileData()] Input list does not contain Risoe.BINfileData objects!") } } }else{ stop("[merge_Risoe.BINfileData()] Input object is not a 'character' nor a 'list'!") } } # Import Files ------------------------------------------------------------ ##loop over all files to store the results in a list ##or the input is already a list if(is(input.objects, "character") == TRUE){ temp <- lapply(input.objects, read_BIN2R) }else{ temp <- input.objects } # Get POSITION values ------------------------------------------------------- ##grep maximum position value from the first file temp.position.max <- max(temp[[1]]@METADATA[, "POSITION"]) ##grep all position values except from the first file temp.position.values <- unlist(sapply(2:length(temp), function(x){ temp <- temp[[x]]@METADATA[, "POSITION"] + temp.position.max + position.number.append.gap assign(x = "temp.position.max", value = max(temp), envir = parent.env(environment())) return(temp) })) temp.position.values <- c(temp[[1]]@METADATA[, "POSITION"], temp.position.values) # Get overall record length ----------------------------------------------- temp.record.length <- sum(sapply(1:length(temp), function(x){ length(temp[[x]]@METADATA[,"ID"]) })) # Merge Files ------------------------------------------------------------- ##loop for similar input objects for(i in 1:length(input.objects)){ if(exists("temp.new.METADATA") == FALSE){ temp.new.METADATA <- temp[[i]]@METADATA temp.new.DATA <- temp[[i]]@DATA if(inherits(try(temp[[i]]@.RESERVED, silent = TRUE), "try-error")){ temp.new.RESERVED <- list() }else{ temp.new.RESERVED <- temp[[i]]@.RESERVED } }else{ temp.new.METADATA <- rbind(temp.new.METADATA, temp[[i]]@METADATA) temp.new.DATA <- c(temp.new.DATA, temp[[i]]@DATA) if(inherits(try(temp[[i]]@.RESERVED, silent = TRUE), "try-error")){ temp.new.RESERVED <- c(temp.new.RESERVED, list()) }else{ temp.new.RESERVED <- c(temp.new.RESERVED, temp[[i]]@.RESERVED) } } } ##SET RECORD ID in METADATA temp.new.METADATA$ID <- 1:temp.record.length ##SET POSITION VALUES if(keep.position.number == FALSE){ temp.new.METADATA$POSITION <- temp.position.values } ##TODO version number? # Produce BIN file object ------------------------------------------------- temp.new <- set_Risoe.BINfileData( METADATA = temp.new.METADATA, DATA = temp.new.DATA, .RESERVED = temp.new.RESERVED ) # OUTPUT ------------------------------------------------------------------ if(missing(output.file) == FALSE){ write_R2BIN(temp.new, output.file) }else{ return(temp.new) } } Luminescence/R/plot_Risoe.BINfileData.R0000644000176200001440000002133713125226556017405 0ustar liggesusers#' Plot single luminescence curves from a BIN file object #' #' Plots single luminescence curves from an object returned by the #' \link{read_BIN2R} function. #' #' \bold{Nomenclature}\cr #' #' See \code{\link{Risoe.BINfileData-class}} #' #' \bold{curve.transformation}\cr #' #' 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 \code{ltype} #' \code{OSL} and \code{IRSL}.\cr #' #' \bold{Irradiation time}\cr #' #' Plotting the irradiation time (s) or the given dose (Gy) requires that the #' variable \code{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 BINfileData \link{Risoe.BINfileData-class} (\bold{required}): #' requires an S4 object returned by the \link{read_BIN2R} function. #' @param position \link{vector} (optional): option to limit the plotted curves #' by position (e.g. \code{position = 1}, \code{position = c(1,3,5)}). #' @param run \link{vector} (optional): option to limit the plotted curves by #' run (e.g., \code{run = 1}, \code{run = c(1,3,5)}). #' @param set \link{vector} (optional): option to limit the plotted curves by #' set (e.g., \code{set = 1}, \code{set = c(1,3,5)}). #' @param sorter \link{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 \link{character} (with default): option to limit the plotted #' curves by the type of luminescence stimulation. Allowed values: #' \code{"IRSL"}, \code{"OSL"},\code{"TL"}, \code{"RIR"}, \code{"RBR"} #' (corresponds to LM-OSL), \code{"RL"}. All type of curves are plotted by #' default. #' @param curve.transformation \link{character} (optional): allows transforming #' CW-OSL and CW-IRSL curves to pseudo-LM curves via transformation functions. #' Allowed values are: \code{CW2pLM}, \code{CW2pLMi}, \code{CW2pHMi} and #' \code{CW2pPMi}. See details. #' @param dose_rate \link{numeric} (optional): dose rate of the irradition #' source at the measurement date. If set, the given irradiation dose will be #' shown in Gy. See details. #' @param temp.lab \link{character} (optional): option to allow for different #' temperature units. If no value is set deg. C is chosen. #' @param cex.global \link{numeric} (with default): global scaling factor. #' @param \dots 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.1 #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France),\cr Michael Dietze, GFZ Potsdam (Germany) #' @seealso \code{\link{Risoe.BINfileData-class}},\code{\link{read_BIN2R}}, #' \code{\link{CW2pLM}}, \code{\link{CW2pLMi}}, \code{\link{CW2pPMi}}, #' \code{\link{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() #' #' @export plot_Risoe.BINfileData<- function( BINfileData, position, run, set, sorter = "POSITION", ltype = c("IRSL","OSL","TL","RIR","RBR","RL"), curve.transformation, dose_rate, temp.lab, cex.global = 1, ... ){ ##check if the object is of type Risoe.BINfileData if(class(BINfileData)!="Risoe.BINfileData"){stop("Wrong object! Object of type Risoe.BINfileData needed.")} temp<-BINfileData # Missing check ---------------------------------------------------------------- ##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} # 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((temp@METADATA[i,"LTYPE"] == "OSL" | temp@METADATA[i,"LTYPE"] == "IRSL") & missing(curve.transformation) == FALSE){ if(curve.transformation=="CW2pLM"){ values.xy <- CW2pLM(values.xy) }else if(curve.transformation=="CW2pLMi"){ values.xy <- CW2pLMi(values.xy)[,1:2] }else if(curve.transformation=="CW2pHMi"){ values.xy <- CW2pHMi(values.xy)[,1:2] }else if(curve.transformation=="CW2pPMi"){ values.xy <- CW2pPMi(values.xy)[,1:2] }else{ warning("Function for curve.transformation is unknown. No transformation is performed.") } } ##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()} } Luminescence/R/read_BIN2R.R0000644000176200001440000013161313125226556015033 0ustar liggesusers#' Import Risoe BIN-file into R #' #' Import a *.bin or a *.binx file produced by a Risoe DA15 and DA20 TL/OSL #' reader into R. #' #' The binary data file is parsed byte by byte following the data structure #' published in the Appendices of the Analyst manual p. 42.\cr\cr For the #' general BIN-file structure, the reader is referred to the Risoe website: #' \code{http://www.nutech.dtu.dk/} #' #' @param file \code{\link{character}} or \code{\link{list}} (\bold{required}): path and file name of the #' BIN/BINX file (URLs are supported). If input is a \code{list} it should comprise only \code{character}s representing #' each valid path and BIN/BINX-file names. Alternatively the input character can be just a directory (path), in this case the #' the function tries to detect and import all BIN/BINX files found in the directory. #' #' @param show.raw.values \link{logical} (with default): shows raw values from #' BIN file for \code{LTYPE}, \code{DTYPE} and \code{LIGHTSOURCE} without #' translation in characters. Can be provided as \code{list} if \code{file} is a \code{list}. #' #' @param n.records \link{raw} (optional): limits the number of imported #' records. Can be used in combination with \code{show.record.number} for #' debugging purposes, e.g. corrupt BIN-files. Can be provided as \code{list} if \code{file} is a \code{list}. #' #' @param zero_data.rm \code{\link{logical}} (with default): remove erroneous data with no count #' values. As such data are usally not needed for the subsequent data analysis they will be removed #' by default. Can be provided as \code{list} if \code{file} is a \code{list}. #' #' @param duplicated.rm \code{\link{logical}} (with default): remove duplicated entries if \code{TRUE}. #' This may happen due to an erroneous produced BIN/BINX-file. This option compares only #' predeccessor and successor. Can be provided as \code{list} if \code{file} is a \code{list}. #' #' @param position \code{\link{numeric}} (optional): imports only the selected position. Note: #' the import performance will not benefit by any selection made here. #' Can be provided as \code{list} if \code{file} is a \code{list}. #' #' @param fastForward \code{\link{logical}} (with default): if \code{TRUE} for a #' more efficient data processing only a list of \code{RLum.Analysis} objects is returned instead #' of a \link{Risoe.BINfileData-class} object. Can be provided as \code{list} if \code{file} is a \code{list}. #' #' @param show.record.number \link{logical} (with default): shows record number #' of the imported record, for debugging usage only. Can be provided as \code{list} if \code{file} is a \code{list}. #' #' @param txtProgressBar \link{logical} (with default): enables or disables #' \code{\link{txtProgressBar}}. #' #' @param forced.VersionNumber \code{\link{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 \code{list} if \code{file} is a \code{list}.\cr #' Note: The usage is at own risk, only supported BIN-file versions have been tested. #' #' @param ignore.RECTYPE \code{\link{logical}} (with default): this argument allows to ignore values #' in the byte 'REGTYPE' (BIN-file version 08), in case there are not documented or faulty set. #' If set all records are treated like records of 'REGYPE' 0 or 1. #' #' @param pattern \code{\link{character}} (optional): argument that is used if only a path is provided. #' The argument will than be passed to the function \code{\link{list.files}} used internally to #' construct a \code{list} of wanted files #' #' @param verbose \code{\link{logical}} (with default): enables or disables verbose mode #' #' @param \dots further arguments that will be passed to the function #' \code{\link{Risoe.BINfileData2RLum.Analysis}}. Please note that any matching argument #' automatically sets \code{fastForward = TRUE} #' #' @return Returns an S4 \link{Risoe.BINfileData-class} object containing two #' slots:\cr \item{METADATA}{A \link{data.frame} containing all variables #' stored in the bin-file.} \item{DATA}{A \link{list} containing a numeric #' \link{vector} of the measured data. The ID corresponds to the record ID in #' METADATA.}\cr #' #' If \code{fastForward = TRUE} a list of \code{\linkS4class{RLum.Analysis}} object is returned. The #' internal coercing is done using the function \code{\link{Risoe.BINfileData2RLum.Analysis}} #' #' #' @note The function works for BIN/BINX-format versions 03, 04, 06, 07 and 08. The #' version number depends on the used Sequence Editor.\cr\cr #' #' \bold{ROI data sets introduced with BIN-file version 8 are not supported and skipped durint #' import.} #' #' #' @section Function version: 0.15.6 #' #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France), Margret C. Fuchs, HZDR Freiberg, (Germany) #' #' #' @seealso \code{\link{write_R2BIN}}, \code{\linkS4class{Risoe.BINfileData}}, #' \code{\link[base]{readBin}}, \code{\link{merge_Risoe.BINfileData}}, \code{\linkS4class{RLum.Analysis}} #' \code{\link[utils]{txtProgressBar}}, \code{\link{list.files}} #' #' #' @references #' DTU Nutech, 2016. The Squence Editor, Users Manual, February, 2016. #' \url{http://www.nutech.dtu.dk/english/products-and-services/radiation-instruments/tl_osl_reader/manuals} #' #' #' @keywords IO #' #' #' @examples #' #' #' ##(1) import Risoe BIN-file to R (uncomment for usage) #' #' #FILE <- file.choose() #' #temp <- read_BIN2R(FILE) #' #temp #' #' @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, ... ){ # 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 if (is(file, "character")) { if (is.null(pattern)) { ##If this is not really a path we skip this here if (dir.exists(file) & length(dir(file)) > 0) { if (verbose) { cat( "[read_BIN2R()] Directory detected, trying to extract '*.bin'/'*.binx' files ...\n" ) } file <- as.list(c( paste0(file, dir( file, recursive = FALSE, pattern = ".bin" )), paste0(file, dir( file, recursive = FALSE, pattern = ".binx" )), paste0(file, dir( file, recursive = FALSE, pattern = ".BIN" )), paste0(file, dir( file, recursive = FALSE, pattern = ".BINX" )) )) } }else{ file <- as.list(list.files(file, pattern = pattern, full.names = TRUE, recursive = TRUE)) } } if (is(file, "list")) { ##extend list of parameters ##position position <- if(is(position, "list")){ rep(position, length = length(file)) }else{ rep(list(position), length = length(file)) } ##n.records n.records <- if(is(n.records, "list")){ rep(n.records, length = length(file)) }else{ rep(list(n.records), length = length(file)) } ##zero_data.rm zero_data.rm<- if(is(zero_data.rm, "list")){ rep(zero_data.rm, length = length(file)) }else{ rep(list(zero_data.rm), length = length(file)) } ##duplicated.rm duplicated.rm <- if(is(duplicated.rm, "list")){ rep(duplicated.rm, length = length(file)) }else{ rep(list(duplicated.rm), length = length(file)) } ## show.raw.values show.raw.values <- if(is( show.raw.values, "list")){ rep( show.raw.values, length = length(file)) }else{ rep(list( show.raw.values), length = length(file)) } ## show.record.number show.record.number <- if(is(show.record.number, "list")){ rep(show.record.number, length = length(file)) }else{ rep(list(show.record.number), length = length(file)) } ##forced.VersionNumber forced.VersionNumber <- if(is(forced.VersionNumber, "list")){ rep(forced.VersionNumber, length = length(file)) }else{ rep(list(forced.VersionNumber), length = length(file)) } temp.return <- lapply(1:length(file), function(x) { temp <- read_BIN2R( file = file[[x]], fastForward = fastForward, position = position[[x]], n.records = n.records[[x]], duplicated.rm = duplicated.rm[[x]], show.raw.values = show.raw.values[[x]], show.record.number = show.record.number[[x]], txtProgressBar = txtProgressBar, forced.VersionNumber = forced.VersionNumber[[x]], verbose = verbose, ... ) }) ##return if (fastForward) { return(unlist(temp.return, recursive = FALSE)) }else{ return(temp.return) } } # Config -------------------------------------------------------------------------------------- ##set file_link for internet downloads file_link <- NULL on_exit <- function(){ ##unlink internet connection if(!is.null(file_link)){ unlink(file_link) } ##close connection if(!is.null(con)){ close(con) } } on.exit(expr = on_exit()) # Integrity checks ------------------------------------------------------ ##check if file exists if(!file.exists(file)){ ##check whether the file as an URL if(grepl(pattern = "http", x = file, fixed = TRUE)){ if(verbose){ cat("[read_BIN2R()] URL detected, checking connection ... ") } ##check URL if(!httr::http_error(file)){ if(verbose) cat("OK") ##dowload file file_link <- tempfile("read_BIN2R_FILE") download.file(file, destfile = file_link, quiet = ifelse(verbose, FALSE, TRUE), mode = "wb") }else{ cat("FAILED") con <- NULL stop("[read_BIN2R()] File does not exist!", call. = FALSE) } }else{ con <- NULL stop("[read_BIN2R()] File does not exist!", call. = FALSE) } } ##check if file is a BIN or BINX file if(!(TRUE%in%(c("BIN", "BINX", "bin", "binx")%in%sub(pattern = "%20", replacement = "", x = tail( unlist(strsplit(file, split = "\\.")), n = 1), fixed = TRUE)))){ try( stop( paste0("[read_BIN2R()] '", file,"' is not a file or not of type 'BIN' or 'BINX'! Skipped!"), call. = FALSE)) return(NULL) } ##set correct file name of file_link was set if(!is.null(file_link)){ file <- file_link } # Config ------------------------------------------------------------------ ##set supported BIN format version VERSION.supported <- as.raw(c(03, 04, 06, 07, 08)) # Short file parsing to get number of records ------------------------------------------------- #open connection con<-file(file, "rb") ##get information about file size file.size <- file.info(file) ##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) } ##stop input if wrong VERSION if((temp.VERSION%in%VERSION.supported) == FALSE){ if(temp.ID > 0){ if(is.null(n.records)){ warning(paste0("[read_BIN2R()] BIN-file appears to be corrupt. Import limited to the first ", temp.ID," record(s).")) }else{ warning(paste0("[read_BIN2R()] BIN-file appears to be corrupt. 'n.records' reset to ", temp.ID,".")) } ##set or reset n.records n.records <- temp.ID break() }else{ ##show error message error.text <- paste("[read_BIN2R()] BIN-format version (",temp.VERSION,") of this file seems to be not supported or the BIN-file is broken.! Supported version numbers are: ",paste(VERSION.supported,collapse=", "),".",sep="") ##show error stop(error.text) } } #empty byte position EMPTY<-readBin(con, what="raw", 1, size=1, endian="little") if(temp.VERSION == 06 | temp.VERSION == 07 | temp.VERSION == 08){ ##GET record LENGTH temp.LENGTH <- readBin(con, what="int", 1, size=4, endian="little") STEPPING <- readBin(con, what="raw", temp.LENGTH-6, size=1, endian="little") }else{ ##GET record LENGTH temp.LENGTH <- readBin(con, what="int", 1, size=2, endian="little") STEPPING <- readBin(con, what="raw", temp.LENGTH-4, size=1, endian="little") } temp.ID<-temp.ID+1 if(!is.null(n.records) && temp.ID == n.records){ break() } } ##set n.records if(is.null(n.records)){ n.records <- temp.ID } rm(temp.ID) # 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)" ) ##PRESET VALUES temp.CURVENO <- NA temp.FNAME <- NA temp.MEASTEMP <- NA temp.IRR_UNIT <- NA temp.IRR_DOSERATE <- NA temp.IRR_DOSERATEERR <- NA temp.TIMESINCEIRR <- NA temp.TIMETICK <- NA temp.ONTIME <- NA temp.OFFTIME <- NA temp.STIMPERIOD <- NA temp.GATE_ENABLED <- raw(length = 1) temp.ENABLE_FLAGS <- raw(length = 1) temp.GATE_START <- NA temp.GATE_STOP <- NA temp.GATE_END <- NA temp.PTENABLED <- raw(length = 1) temp.DTENABLED <- raw(length = 1) temp.DEADTIME <- NA temp.MAXLPOWER <- NA temp.XRF_ACQTIME <- NA temp.XRF_HV <- NA temp.XRF_CURR <- NA temp.XRF_DEADTIMEF <- NA temp.DETECTOR_ID <- NA temp.LOWERFILTER_ID <- NA temp.UPPERFILTER_ID <- NA temp.ENOISEFACTOR <- NA temp.SEQUENCE <- NA temp.GRAIN <- NA temp.GRAINNUMBER <- NA temp.LIGHTPOWER <- NA temp.LPOWER <- NA temp.RECTYPE <- 0 temp.MARKPOS_X1 <- NA temp.MARKPOS_Y1 <- NA temp.MARKPOS_X2 <- NA temp.MARKPOS_Y2 <- NA temp.MARKPOS_X3 <- NA temp.MARKPOS_Y3 <- NA temp.EXTR_START <- NA temp.EXTR_END <- NA ##SET length of entire record n.length <- n.records ##initialise data.frame results.METADATA <- data.table::data.table( ##1 to 7 ID = integer(length = n.length), SEL = logical(length = n.length), VERSION = numeric(length = 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 = integer(length = n.length), SET = integer(length = n.length), POSITION = integer(length = n.length), GRAIN = integer(length = n.length), GRAINNUMBER = integer(length = n.length), CURVENO = integer(length = n.length), XCOORD = integer(length = n.length), YCOORD = integer(length = n.length), SAMPLE = character(length = n.length), COMMENT = character(length = n.length), #18 to 22 SYSTEMID = integer(length = 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 = numeric(length = n.length), BL_UNIT = integer(length = n.length), NORM1 = numeric(length = n.length), NORM2 = numeric(length = n.length), NORM3 = numeric(length = n.length), BG = numeric(length = n.length), SHIFT = integer(length = n.length), TAG = integer(length = n.length), ##32 to 67 LTYPE = character(length = n.length), LIGHTSOURCE = character(length = n.length), LPOWER = numeric(length = n.length), LIGHTPOWER = numeric(length = n.length), LOW = numeric(length = n.length), HIGH = numeric(length = n.length), RATE = numeric(length = n.length), TEMPERATURE = numeric(length = n.length), MEASTEMP = numeric(length = n.length), AN_TEMP = numeric(length = n.length), AN_TIME = numeric(length = n.length), TOLDELAY = integer(length = n.length), TOLON = integer(length = n.length), TOLOFF = integer(length = n.length), IRR_TIME = numeric(length = n.length), IRR_TYPE = integer(length = n.length), IRR_UNIT = integer(length = n.length), IRR_DOSERATE = numeric(length = n.length), IRR_DOSERATEERR = numeric(length = n.length), TIMESINCEIRR = numeric(length = n.length), TIMETICK = numeric(length = n.length), ONTIME = numeric(length = n.length), OFFTIME = numeric(length = n.length), STIMPERIOD = integer(length = n.length), GATE_ENABLED = numeric(length = n.length), ENABLE_FLAGS = numeric(length = n.length), GATE_START = numeric(length = n.length), GATE_STOP = numeric(length = n.length), PTENABLED = numeric(length = n.length), DTENABLED = numeric(length = n.length), DEADTIME = numeric(length = n.length), MAXLPOWER = numeric(length = n.length), XRF_ACQTIME = numeric(length = n.length), XRF_HV = numeric(length = n.length), XRF_CURR = numeric(length = n.length), XRF_DEADTIMEF = numeric(length = n.length), #68 to 79 DETECTOR_ID = integer(length = n.length), LOWERFILTER_ID = integer(length = n.length), UPPERFILTER_ID = integer(length = n.length), ENOISEFACTOR = numeric(length = n.length), MARKPOS_X1 = numeric(length = n.length), MARKPOS_Y1 = numeric(length = n.length), MARKPOS_X2 = numeric(length = n.length), MARKPOS_Y2 = numeric(length = n.length), MARKPOS_X3 = numeric(length = n.length), MARKPOS_Y3 = numeric(length = n.length), EXTR_START = numeric(length = n.length), EXTR_END = numeric(length = n.length), ##80 SEQUENCE = character(length = n.length) ) #end set data table #set variable for DPOINTS handling results.DATA<-list() ##set list for RESERVED values results.RESERVED <- rep(list(list()), n.length) # Open Connection --------------------------------------------------------- ##show warning if version number check has been cheated if(!is.null(forced.VersionNumber)){ warning("Argument 'forced.VersionNumber' has been used. BIN-file version might be not supported!") } #open connection con <- file(file, "rb") ##get information about file size file.size<-file.info(file) ##output if(verbose){cat(paste("\n[read_BIN2R()]\n\t >> ",file,sep=""), fill=TRUE)} ##set progressbar if(txtProgressBar & verbose){ pb<-txtProgressBar(min=0,max=file.size$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) } ##stop input if wrong VERSION if((temp.VERSION%in%VERSION.supported) == FALSE){ ##show error message error.text <- paste("[read_BIN2R()] BIN-format version (",temp.VERSION,") of this file is currently not supported! Supported version numbers are: ",paste(VERSION.supported,collapse=", "),".",sep="") stop(error.text) } ##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 EMPTY<-readBin(con, what="raw", 1, size=1, endian="little") # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # BINX FORMAT SUPPORT ----------------------------------------------------- if(temp.VERSION == 06 | temp.VERSION == 07 | temp.VERSION == 08){ ##(1) Header size and strucutre ##LENGTH, PREVIOUS, NPOINTS, LTYPE temp <- readBin(con, what="int", 3, size=4, endian="little") temp.LENGTH <- temp[1] temp.PREVIOUS <- temp[2] temp.NPOINTS <- temp[3] #for temp.VERSION == 08 #RECTYPE if(temp.VERSION == 08){ temp.RECTYPE <- readBin(con, what="int", 1, size=1, endian="little", signed = FALSE) if(temp.RECTYPE != 0 & temp.RECTYPE != 1){ ##jump to the next record by stepping the record length minus the alread read bytes STEPPING <- readBin(con, what = "raw", size = 1, n = temp.LENGTH - 15) if(temp.RECTYPE == 128){ warning(paste0("[read_BIN2R()] ROI definition in data set #",temp.ID+1, "detected, but currently not supported, record skipped!", call. = FALSE)) }else{ if(!ignore.RECTYPE){ stop(paste0("[read_BIN2R()] Byte RECTYPE = ",temp.RECTYPE," is not supported in record #",temp.ID+1,"! Check your BIN-file!"), call. = FALSE) }else{ if(verbose) cat(paste0("\n[read_BIN2R()] Byte RECTYPE = ",temp.RECTYPE," is not supported in record #",temp.ID+1,", record skipped!")) temp.ID <- temp.ID + 1 } } next } } ##(2) Sample characteristics ##RUN, SET, POSITION, GRAINNUMBER, CURVENO, XCOORD, YCOORD temp <- readBin(con, what="int", 7, size=2, endian="little") temp.RUN <- temp[1] temp.SET <- temp[2] temp.POSITION <- temp[3] temp.GRAINNUMBER <- temp[4] temp.CURVENO <- temp[5] temp.XCOORD <- temp[6] temp.YCOORD <- temp[7] ##SAMPLE, COMMENT ##SAMPLE SAMPLE_SIZE<-readBin(con, what="int", 1, size=1, endian="little") temp.SAMPLE<-readChar(con, SAMPLE_SIZE, useBytes=TRUE) #however it should be set to 20 #step forward in con if(20-c(SAMPLE_SIZE)>0){ STEPPING<-readBin(con, what="raw", (20-c(SAMPLE_SIZE)), size=1, endian="little") } ##COMMENT COMMENT_SIZE<-readBin(con, what="int", 1, size=1, endian="little") temp.COMMENT<-readChar(con, COMMENT_SIZE, useBytes=TRUE) #set to 80 (manual) #step forward in con if(80-c(COMMENT_SIZE)>0){ STEPPING<-readBin(con, what="raw", (80-c(COMMENT_SIZE)), size=1, endian="little") } ##(3) Instrument and sequence characteristic ##SYSTEMID temp.SYSTEMID <- readBin(con, what="int", 1, size=2, endian="little") ##FNAME FNAME_SIZE<-readBin(con, what="int", 1, size=1, endian="little") ##correct for 0 file name length if(length(FNAME_SIZE)>0){ temp.FNAME<-readChar(con, FNAME_SIZE, useBytes=TRUE) #set to 100 (manual) }else{ FNAME_SIZE <- 0 } #step forward in con if(100-c(FNAME_SIZE)>0){ STEPPING<-readBin(con, what="raw", (100-c(FNAME_SIZE)), size=1, endian="little") } ##USER USER_SIZE<-readBin(con, what="int", 1, size=1, endian="little") ##correct for 0 user size length if (length(USER_SIZE) > 0) { temp.USER <- readChar(con, USER_SIZE, useBytes = TRUE) #set to 30 (manual) }else{ USER_SIZE <- 0 } #step forward in con if(30-c(USER_SIZE)>0){ STEPPING<-readBin(con, what="raw", (30-c(USER_SIZE)), size=1, endian="little") } ##TIME TIME_SIZE<-readBin(con, what="int", 1, size=1, endian="little") ##time size corrections for wrong time formats; set n to 6 for all values ##accoording the handbook of Geoff Duller, 2007 if(length(TIME_SIZE)>0){ temp.TIME<-readChar(con, TIME_SIZE, useBytes=TRUE) }else{ TIME_SIZE <- 0 } if(6-TIME_SIZE>0){ STEPPING<-readBin(con, what="raw", (6-TIME_SIZE), size=1, endian="little") } ##DATE DATE_SIZE<-readBin(con, what="int", 1, size=1, endian="little") ##date size corrections for wrong date formats; set n to 6 for all values ##accoording the handbook of Geoff Duller, 2007 DATE_SIZE<-6 temp.DATE<-readChar(con, DATE_SIZE, useBytes=TRUE) ##(4) Analysis ##DTYPE temp.DTYPE<-readBin(con, what="int", 1, size=1, endian="little") ##BL_TIME temp.BL_TIME<-readBin(con, what="double", 1, size=4, endian="little") ##BL_UNIT temp.BL_UNIT<-readBin(con, what="int", 1, size=1, endian="little") ##NORM1, NORM2, NORM3, BG temp <- readBin(con, what="double", 4, size=4, endian="little") temp.NORM1 <- temp[1] temp.NORM2 <- temp[2] temp.NORM3 <- temp[3] temp.BG <- temp[4] ##SHIFT temp.SHIFT<- readBin(con, what="integer", 1, size=2, endian="little") ##TAG temp.TAG <- 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 temp.LTYPE <- readBin(con, what="int", 1, size=1, endian="little") ##LTYPESOURCE temp.LIGHTSOURCE <- readBin(con, what="int", 1, size=1, endian="little") ##LIGHTPOWER, LOW, HIGH, RATE temp <- readBin(con, what="double", 4, size=4, endian="little") temp.LIGHTPOWER <- temp[1] temp.LOW <- temp[2] temp.HIGH <- temp[3] temp.RATE <- temp[4] ##TEMPERATURE temp.TEMPERATURE <- readBin(con, what="int", 1, size=2, endian="little") ##MEASTEMP temp.MEASTEMP <- readBin(con, what="integer", 1, size=2, endian="little") ##AN_TEMP temp.AN_TEMP <- readBin(con, what="double", 1, size=4, endian="little") ##AN_TIME temp.AN_TIME <- readBin(con, what="double", 1, size=4, endian="little") ##DELAY, ON, OFF temp <- readBin(con, what="int", 3, size=2, endian="little") temp.TOLDELAY <- temp[1] temp.TOLON <- temp[2] temp.TOLOFF <- temp[3] ##IRR_TIME temp.IRR_TIME <- readBin(con, what="double", 1, size=4, endian="little") ##IRR_TYPE temp.IRR_TYPE <- readBin(con, what="int", 1, size=1, endian="little") ##IRR_DOSERATE temp.IRR_DOSERATE <- readBin(con, what="double", 1, size=4, endian="little") ##IRR_DOSERATEERR temp.IRR_DOSERATEERR <- readBin(con, what="double", 1, size=4, endian="little") ##TIMESINCEIRR temp.TIMESINCEIRR <- readBin(con, what="integer", 1, size=4, endian="little") ##TIMETICK temp.TIMETICK <- readBin(con, what="double", 1, size=4, endian="little") ##ONTIME temp.ONTIME <- readBin(con, what="integer", 1, size=4, endian="little") ##STIMPERIOD temp.STIMPERIOD <- readBin(con, what="integer", 1, size=4, endian="little") ##GATE_ENABLED temp.GATE_ENABLED <- readBin(con, what="raw", 1, size=1, endian="little") ##GATE_START temp.GATE_START <- readBin(con, what="integer", 1, size=4, endian="little") ##GATE_STOP temp.GATE_STOP <- readBin(con, what="integer", 1, size=4, endian="little") ##PTENABLED temp.PTENABLED <- readBin(con, what="raw", 1, size=1, endian="little") ##DTENABLED temp.DTENABLED <- readBin(con, what="raw", 1, size=1, endian="little") ##DEADTIME, MAXLPOWER, XRF_ACQTIME, XRF_HV temp <- readBin(con, what="double", 4, size=4, endian="little") temp.DEADTIME <- temp[1] temp.MAXLPOWER <- temp[2] temp.XRF_ACQTIME <- temp[3] temp.XRF_HV <- temp[4] ##XRF_CURR temp.XRF_CURR <- readBin(con, what="integer", 1, size=4, endian="little") ##XRF_DEADTIMEF temp.XRF_DEADTIMEF <- readBin(con, what="double", 1, size=4, endian="little") ###Account for differences between V6 and V7 if(temp.VERSION == 06){ ##RESERVED temp.RESERVED2<-readBin(con, what="raw", 24, size=1, endian="little") }else{ ##DETECTOR_ID temp.DETECTOR_ID <- readBin(con, what="int", 1, size=1, endian="little") ##LOWERFILTER_ID, UPPERFILTER_ID temp <- readBin(con, what="int", 2, size=2, endian="little") temp.LOWERFILTER_ID <- temp[1] temp.UPPERFILTER_ID <- temp[2] ##ENOISEFACTOR temp.ENOISEFACTOR <- readBin(con, what="double", 1, size=4, endian="little") ##CHECK FOR VERSION 08 if(temp.VERSION == 07){ ##RESERVED for version 07 temp.RESERVED2<-readBin(con, what="raw", 15, size=1, endian="little") }else{ ##MARKER_POSITION temp <- readBin(con, what="double", 6, size=4, endian="little") temp.MARPOS_X1 <- temp[1] temp.MARPOS_Y1 <- temp[2] temp.MARPOS_X2 <- temp[3] temp.MARPOS_Y2 <- temp[4] temp.MARPOS_X3 <- temp[5] temp.MARPOS_Y3 <- temp[6] ###EXTR_START, EXTR_END temp <- readBin(con, what="double", 2, size=4, endian="little") temp.EXTR_START <- temp[1] temp.EXTR_END <- temp[2] temp.RESERVED2<-readBin(con, what="raw", 42, size=1, endian="little") } } #DPOINTS temp.DPOINTS<-readBin(con, what="integer", temp.NPOINTS, size=4, endian="little") }else if(temp.VERSION == 04 | temp.VERSION == 03){ ## ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ##START BIN FILE FORMAT SUPPORT (vers. 03 and 04) ##LENGTH, PREVIOUS, NPOINTS, LTYPE temp <- readBin(con, what="int", 3, size=2, endian="little") temp.LENGTH <- temp[1] temp.PREVIOUS <- temp[2] temp.NPOINTS <- temp[3] ##LTYPE temp.LTYPE<-readBin(con, what="int", 1, size=1, endian="little") ##LOW, HIGH, RATE temp <- readBin(con, what="double", 3, size=4, endian="little") temp.LOW <- temp[1] temp.HIGH <- temp[2] temp.RATE <- temp[3] temp.TEMPERATURE<-readBin(con, what="integer", 1, size=2, endian="little") ##XCOORD, YCOORD, TOLDELAY, TOLON, TOLOFF temp <- readBin(con, what="integer", 5, size=2, endian="little") temp.XCOORD <- temp[1] temp.YCOORD <- temp[2] temp.TOLDELAY <- temp[3] temp.TOLON <- temp[4] temp.TOLOFF <- temp[5] ##POSITION temp.POSITION<-readBin(con, what="int", 1, size=1, endian="little") ##RUN temp.RUN<-readBin(con, what="int", 1, size=1, endian="little") ##TIME TIME_SIZE<-readBin(con, what="int", 1, size=1, endian="little") ##time size corrections for wrong time formats; set n to 6 for all values ##accoording the handbook of Geoff Duller, 2007 TIME_SIZE<-6 temp.TIME<-readChar(con, TIME_SIZE, useBytes=TRUE) ##DATE DATE_SIZE<-readBin(con, what="int", 1, size=1, endian="little") ##date size corrections for wrong date formats; set n to 6 for all values ##accoording the handbook of Geoff Duller, 2007 DATE_SIZE<-6 temp.DATE<-readChar(con, DATE_SIZE, useBytes=TRUE) ##SEQUENCE SEQUENCE_SIZE<-readBin(con, what="int", 1, size=1, endian="little") temp.SEQUENCE<-readChar(con, SEQUENCE_SIZE, useBytes=TRUE) #step forward in con if(8-SEQUENCE_SIZE>0){ STEPPING<-readBin(con, what="raw", (8-c(SEQUENCE_SIZE)),size=1, endian="little") } ##USER USER_SIZE<-readBin(con, what="int", 1, size=1, endian="little") temp.USER<-readChar(con, USER_SIZE, useBytes=FALSE) #step forward in con if(8-c(USER_SIZE)>0){ STEPPING<-readBin(con, what="raw", (8-c(USER_SIZE)), size=1, endian="little") } ##DTYPE temp.DTYPE<-readBin(con, what="int", 1, size=1, endian="little") ##IRR_TIME temp.IRR_TIME<-readBin(con, what="double", 1, size=4, endian="little") ##IRR_TYPE temp.IRR_TYPE<-readBin(con, what="int", 1, size=1, endian="little") ##IRR_UNIT temp.IRR_UNIT<-readBin(con, what="int", 1, size=1, endian="little") ##BL_TIME temp.BL_TIME<-readBin(con, what="double", 1, size=4, endian="little") ##BL_UNIT temp.BL_UNIT<-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") temp.AN_TEMP <- temp[1] temp.AN_TIME <- temp[2] temp.NORM1 <- temp[3] temp.NORM2 <- temp[4] temp.NORM3 <- temp[5] temp.BG <- temp[6] ##SHIFT temp.SHIFT<-readBin(con, what="integer", 1, size=2, endian="little") ##SAMPLE SAMPLE_SIZE<-readBin(con, what="int", 1, size=1, endian="little") temp.SAMPLE<-readChar(con, SAMPLE_SIZE, useBytes=TRUE) #however it should be set to 20 #step forward in con if(20-c(SAMPLE_SIZE)>0){ STEPPING<-readBin(con, what="raw", (20-c(SAMPLE_SIZE)), size=1, endian="little") } ##COMMENT COMMENT_SIZE<-readBin(con, what="int", 1, size=1, endian="little") temp.COMMENT<-readChar(con, COMMENT_SIZE, useBytes=TRUE) #set to 80 (manual) #step forward in con if(80-c(COMMENT_SIZE)>0){ STEPPING<-readBin(con, what="raw", (80-c(COMMENT_SIZE)), size=1, endian="little") } ##LIGHTSOURCE, SET, TAG temp <- readBin(con, what="int", 3, size=1, endian="little") temp.LIGHTSOURCE <- temp[1] temp.SET <- temp[2] temp.TAG <- temp[3] ##GRAIN temp.GRAIN<-readBin(con, what="integer", 1, size=2, endian="little") ##LPOWER temp.LPOWER<-readBin(con, what="double", 1, size=4, endian="little") ##SYSTEMID temp.SYSTEMID<-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") temp.ONTIME <- temp[1] temp.OFFTIME <- temp[2] ##Enable flags #GateEnabled for v 06 temp.ENABLE_FLAGS <- readBin(con, what="raw", 1, size=1, endian="little") temp.GATE_ENABLED <- temp.ENABLE_FLAGS ##ONGATEDELAY, OFFGATEDELAY temp <- readBin(con, what="double", 2, size=4, endian="little") temp.GATE_START <- temp[1] temp.GATE_STOP <- 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 temp.CURVENO <- readBin(con, what="integer", 1, size=2, endian="little") ##TIMETICK temp.TIMETICK <- readBin(con, what="double", 1, size=4, endian="little") ##ONTIME, STIMPERIOD temp <- readBin(con, what="integer", 2, size=4, endian="little") temp.ONTIME <- temp[1] temp.STIMPERIOD <- temp[2] ##GATE_ENABLED temp.GATE_ENABLED <- readBin(con, what="raw", 1, size=1, endian="little") ##ONGATEDELAY, OFFGATEDELAY temp <- readBin(con, what="double", 2, size=4, endian="little") temp.GATE_START <- temp[1] temp.GATE_END <- temp[2] temp.GATE_STOP <- temp.GATE_END ##PTENABLED temp.PTENABLED <- readBin(con, what="raw", 1, size=1, endian="little") ##RESERVED temp.RESERVED2<-readBin(con, what="raw", 10, size=1, endian="little") } #DPOINTS temp.DPOINTS<-readBin(con, what="integer", temp.NPOINTS, size=4, endian="little") }else{ stop("[read_BIN2R()] Unsupported BIN/BINX-file version.") } #endif:format support ##END BIN FILE FORMAT SUPPORT ## ==========================================================================# #SET UNIQUE ID temp.ID <- temp.ID+1 ##update progress bar if(txtProgressBar & verbose){ setTxtProgressBar(pb, seek(con,origin="current")) } ##set for equal values with different names if(!is.na(temp.GRAINNUMBER)){temp.GRAIN <- temp.GRAINNUMBER} if(!is.na(temp.GRAIN)){temp.GRAINNUMBER <- temp.GRAIN} if(!is.na(temp.LIGHTPOWER)){temp.LPOWER <- temp.LIGHTPOWER} if(!is.na(temp.LPOWER)){temp.LIGHTPOWER <- temp.LPOWER} temp.SEL <- if(temp.TAG == 1){TRUE}else{FALSE} ##replace values in the data.table with values results.METADATA[temp.ID, `:=` ( ID = temp.ID, SEL = temp.SEL, VERSION = as.numeric(temp.VERSION), LENGTH = temp.LENGTH, PREVIOUS = temp.PREVIOUS, NPOINTS = temp.NPOINTS, RECTYPE = temp.RECTYPE, RUN = temp.RUN, SET = temp.SET, POSITION = temp.POSITION, GRAIN = temp.GRAIN, GRAINNUMBER = temp.GRAINNUMBER, CURVENO = temp.CURVENO, XCOORD = temp.XCOORD, YCOORD = temp.YCOORD, SAMPLE = temp.SAMPLE, COMMENT = temp.COMMENT, SYSTEMID = temp.SYSTEMID, FNAME = temp.FNAME, USER = temp.USER, TIME = temp.TIME, DATE = temp.DATE, DTYPE = as.character(temp.DTYPE), BL_TIME = temp.BL_TIME, BL_UNIT = temp.BL_UNIT, NORM1 = temp.NORM1, NORM2 = temp.NORM2, NORM3 = temp.NORM3, BG = temp.BG, SHIFT = temp.SHIFT, TAG = temp.TAG, LTYPE = as.character(temp.LTYPE), LIGHTSOURCE = as.character(temp.LIGHTSOURCE), LPOWER = temp.LPOWER, LIGHTPOWER = temp.LIGHTPOWER, LOW = temp.LOW, HIGH = temp.HIGH, RATE = temp.RATE, TEMPERATURE = temp.TEMPERATURE, MEASTEMP = temp.MEASTEMP, AN_TEMP = temp.AN_TEMP, AN_TIME = temp.AN_TIME, TOLDELAY = temp.TOLDELAY, TOLON = temp.TOLON, TOLOFF = temp.TOLOFF, IRR_TIME = temp.IRR_TIME, IRR_TYPE = temp.IRR_TYPE, IRR_UNIT = temp.IRR_UNIT, IRR_DOSERATE = temp.IRR_DOSERATE, IRR_DOSERATEERR = temp.IRR_DOSERATEERR, TIMESINCEIRR = temp.TIMESINCEIRR, TIMETICK = temp.TIMETICK, ONTIME = temp.ONTIME, OFFTIME = temp.OFFTIME, STIMPERIOD = temp.STIMPERIOD, GATE_ENABLED = as.numeric(temp.GATE_ENABLED), ENABLE_FLAGS = as.numeric(temp.ENABLE_FLAGS), GATE_START = temp.GATE_START, GATE_STOP = temp.GATE_STOP, PTENABLED = as.numeric(temp.PTENABLED), DTENABLED = as.numeric(temp.DTENABLED), DEADTIME = temp.DEADTIME, MAXLPOWER = temp.MAXLPOWER, XRF_ACQTIME = temp.XRF_ACQTIME, XRF_HV = temp.XRF_HV, XRF_CURR = temp.XRF_CURR, XRF_DEADTIMEF = temp.XRF_DEADTIMEF, DETECTOR_ID = temp.DETECTOR_ID, LOWERFILTER_ID = temp.LOWERFILTER_ID, UPPERFILTER_ID = temp.UPPERFILTER_ID, ENOISEFACTOR = temp.ENOISEFACTOR, MARKPOS_X1 = temp.MARKPOS_X1, MARKPOS_Y1 = temp.MARKPOS_Y1, MARKPOS_X2 = temp.MARKPOS_X2, MARKPOS_Y2 = temp.MARKPOS_Y2, MARKPOS_X3 = temp.MARKPOS_X3, MARKPOS_Y3 = temp.MARKPOS_Y3, SEQUENCE = temp.SEQUENCE )] results.DATA[[temp.ID]] <- temp.DPOINTS results.RESERVED[[temp.ID]][[1]] <- temp.RESERVED1 results.RESERVED[[temp.ID]][[2]] <- temp.RESERVED2 ##BREAK ##stop loop if record limit is reached if (!is.null(n.records)) { if (n.records == temp.ID) { break() } } ##reset values temp.GRAINNUMBER <- NA temp.GRAIN <- NA }#endwhile::end lopp ##close if(txtProgressBar & verbose){close(pb)} ##output if(verbose){cat(paste("\t >> ",temp.ID," records have been read successfully!\n\n", sep=""))} # Further limitation -------------------------------------------------------------------------- if(!is.null(position)){ ##check whether the position is valid at all if (all(position %in% results.METADATA[["POSITION"]])) { results.METADATA <- results.METADATA[which(results.METADATA[["POSITION"]] %in% position),] results.DATA <- results.DATA[results.METADATA[["ID"]]] ##re-calculate ID ... otherwise it will not match results.METADATA[["ID"]] <- 1:length(results.DATA ) ##show a message message("[read_BIN2R()] The record index has been recalculated!") }else{ valid.position <- paste(unique(results.METADATA[["POSITION"]]), collapse = ", ") warning( paste0( "Position limitation omitted. At least one position number is not valid, valid position numbers are: ", valid.position ) ) } } ##check for position that have no data at all (error during the measurement) if(zero_data.rm){ zero_data.check <- which(sapply(results.DATA, length) == 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 ##recalculate record index results.METADATA[["ID"]] <- 1:nrow(results.METADATA) warning( paste0( "\n[read_BIN2R()] ", length(zero_data.check), " zero data records detected and removed: ", paste(zero_data.check, collapse = ", "), ". \n\n >> Record index re-calculated." ) ) } } ##check for duplicated entries and remove them if wanted, but only if we have more than 2 records if (n.records > 1) { duplication.check <- suppressWarnings(which(c( 0, vapply( 2:length(results.DATA), FUN = function(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 ##recalculate record index results.METADATA[["ID"]] <- 1:nrow(results.METADATA) ##message if(verbose) { message( paste0( "[read_BIN2R()] duplicated record(s) detected and removed: ", paste(duplication.check, collapse = ", "), ". Record index re-calculated." ) ) } } else{ warning( paste0( "[read_BIN2R()] duplicated record(s) detected: ", paste(duplication.check, collapse = ", "), ". \n\n >> You should consider 'duplicated.rm = TRUE'." ) ) } } } ##produce S4 object for output object <- set_Risoe.BINfileData( METADATA = results.METADATA, DATA = results.DATA, .RESERVED = results.RESERVED) # Convert Translation Matrix Values --------------------------------------- if (!show.raw.values) { ##LIGHTSOURCE CONVERSION object@METADATA[["LIGHTSOURCE"]] <- unname(LIGHTSOURCE.lookup[object@METADATA[["LIGHTSOURCE"]]]) ##LTYPE CONVERSION object@METADATA[["LTYPE"]] <- unname(LTYPE.lookup[object@METADATA[["LTYPE"]]]) ##DTYPE CONVERSION object@METADATA[["DTYPE"]] <- unname(DTYPE.lookup[object@METADATA[["DTYPE"]]]) ##CHECK for oddly set LTYPES, this may happen in old BIN-file versions if (object@METADATA[["VERSION"]][1] == 3) { object@METADATA[["LTYPE"]] <- sapply(1:length(object@METADATA[["LTYPE"]]), function(x) { if (object@METADATA[["LTYPE"]][x] == "OSL" & object@METADATA[["LIGHTSOURCE"]][x] == "IR diodes/IR Laser") { return("IRSL") } else{ return(object@METADATA[["LTYPE"]][x]) } }) } ##TIME CONVERSION, do not do for odd time formats as this could cause problems during export if (TIME_SIZE == 6) { object@METADATA[["TIME"]] <- format(strptime(as.character(object@METADATA[["TIME"]]), "%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(all(is.na(object@METADATA[["FNAME"]]))){ object@METADATA[["FNAME"]] <- strsplit(x = basename(file), split = ".", fixed = TRUE)[[1]][1] } # Fast Forward -------------------------------------------------------------------------------- ## set fastForward to TRUE if one of this arguments is used if(any(names(list(...)) %in% names(formals(Risoe.BINfileData2RLum.Analysis))[-1]) & fastForward == FALSE) { fastForward <- TRUE warning("[read_BIN2R()] automatically reset '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(!is(object, "list")){ object <- list(object) } } return(object) } Luminescence/R/get_RLum.R0000644000176200001440000001001613125226556014733 0ustar liggesusers#' General accessor function for RLum S4 class objects #' #' Function calls object-specific get functions for RLum S4 class objects. #' #' The function provides a generalised access point for specific #' \code{\linkS4class{RLum}} objects.\cr Depending on the input object, the #' corresponding get function will be selected. Allowed arguments can be found #' in the documentations of the corresponding \code{\linkS4class{RLum}} class. #' #' @param object \code{\linkS4class{RLum}} (\bold{required}): S4 object of #' class \code{RLum} or an object of type \code{\link{list}} containing only objects of type #' \code{\linkS4class{RLum}} #' #' @param \dots further arguments that will be passed to the object specific methods. For #' furter details on the supported arguments please see the class #' documentation: \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Data.Spectrum}}, \code{\linkS4class{RLum.Data.Image}}, #' \code{\linkS4class{RLum.Analysis}} and \code{\linkS4class{RLum.Results}} #' #' @return Return is the same as input objects as provided in the list. #' #' @section Function version: 0.3.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso #' \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Data.Image}}, #' \code{\linkS4class{RLum.Data.Spectrum}}, #' \code{\linkS4class{RLum.Analysis}}, #' \code{\linkS4class{RLum.Results}} #' #' @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) #' #' #' @export setGeneric("get_RLum", function (object, ...) {standardGeneric("get_RLum") }) # Method for get_RLum method for RLum objects in a list for a list of objects ------------------- #' @describeIn get_RLum #' Returns a list of \code{\linkS4class{RLum}} objects that had been passed to \code{\link{get_RLum}} #' #' @param null.rm \code{\link{logical}} (with default): option to get rid of empty and NULL objects #' #' @export setMethod("get_RLum", signature = "list", function(object, null.rm = FALSE, ...){ selection <- lapply(1:length(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(is(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(is(selection[[x]], "RLum.Analysis") && length(selection[[x]]@records) == 0){ return(NULL) }else{ return(selection[[x]]) } }) ##get rid of all NULL objects selection <- selection[!sapply(selection, is.null)] } return(selection) }) Luminescence/R/RisoeBINfileData-class.R0000644000176200001440000004354313125226556017377 0ustar liggesusers#' @include get_Risoe.BINfileData.R set_Risoe.BINfileData.R NULL #' Class \code{"Risoe.BINfileData"} #' #' S4 class object for luminescence data in R. The object is produced as output #' of the function \code{\link{read_BIN2R}}. #' #' #' @name Risoe.BINfileData-class #' #' @docType class #' #' @slot METADATA Object of class "data.frame" containing the meta information for each curve. #' #' @slot DATA Object of class "list" containing numeric vector with count data. #' #' @slot .RESERVED Object of class "list" containing list of undocumented raw values for internal use only. #' #' @note #' #' \bold{Internal METADATA - object structure} #' #' This structure is compatible with BIN-files version 03-08, however, it does not follow (in its #' sequential arrangment) the manual provided by the manufacturer, #' but an own structure accounting for the different versions. #' #' \tabular{rllll}{ #' \bold{#} \tab \bold{Name} \tab \bold{Data Type} \tab \bold{V} \tab \bold{Description} \cr #' [,1] \tab ID \tab \code{numeric} \tab RLum \tab Unique record ID (same ID as in slot \code{DATA})\cr #' [,2] \tab SEL \tab \code{logic} \tab RLum \tab Record selection, not part official BIN-format, triggered by TAG\cr #' [,3] \tab VERSION \tab \code{raw} \tab 03-08 \tab BIN-file version number \cr #' [,4] \tab LENGTH \tab \code{integer} \tab 03-08 \tab Length of this record\cr #' [,5] \tab PREVIOUS \tab \code{integer} \tab 03-08 \tab Length of previous record\cr #' [,6] \tab NPOINTS \tab \code{integer} \tab 03-08 \tab Number of data points in the record\cr #' [,7] \tab RECTYPE \tab \code{integer} \tab 08 \tab Record type \cr #' [,8] \tab RUN \tab \code{integer} \tab 03-08 \tab Run number\cr #' [,9] \tab SET \tab \code{integer} \tab 03-08 \tab Set number\cr #' [,10] \tab POSITION \tab \code{integer} \tab 03-08 \tab Position number\cr #' [,11] \tab GRAIN \tab \code{integer} \tab 03-04 \tab Grain number\cr #' [,12] \tab GRAINNUMBER \tab \code{integer} \tab 06-08 \tab Grain number\cr #' [,13] \tab CURVENO \tab \code{integer} \tab 06-08 \tab Curve number\cr #' [,14] \tab XCOORD \tab \code{integer} \tab 03-08 \tab X position of a single grain\cr #' [,15] \tab YCOORD \tab \code{integer} \tab 03-08 \tab Y position of a single grain\cr #' [,16] \tab SAMPLE \tab \code{factor} \tab 03-08 \tab Sample name\cr #' [,17] \tab COMMENT \tab \code{factor} \tab 03-08 \tab Comment name\cr #' [,18] \tab SYSTEMID \tab \code{integer} \tab 03-08 \tab Risoe system id\cr #' [,19] \tab FNAME \tab \code{factor} \tab 06-08 \tab File name (*.bin/*.binx)\cr #' [,20] \tab USER \tab \code{facotr} \tab 03-08 \tab User name\cr #' [,21] \tab TIME \tab \code{character} \tab 03-08 \tab Data collection time (hh-mm-ss)\cr #' [,22] \tab DATE \tab \code{factor} \tab 03-08 \tab Data collection date (ddmmyy)\cr #' [,23] \tab DTYPE \tab \code{character} \tab 03-08 \tab Data type\cr #' [,24] \tab BL_TIME \tab \code{numeric} \tab 03-08 \tab Bleaching time\cr #' [,25] \tab BL_UNIT \tab \code{integer} \tab 03-08 \tab Bleaching unit (mJ, J, secs, mins, hrs)\cr #' [,26] \tab NORM1 \tab \code{numeric} \tab 03-08 \tab Normalisation factor (1)\cr #' [,27] \tab NORM2 \tab \code{numeric} \tab 03-08 \tab Normalisation factor (2)\cr #' [,28] \tab NORM3 \tab \code{numeric} \tab 03-08 \tab Normalisation factor (3)\cr #' [,29] \tab BG \tab \code{numeric} \tab 03-08 \tab Background level\cr #' [,30] \tab SHIFT \tab \code{integer} \tab 03-08 \tab Number of channels to shift data\cr #' [,31] \tab TAG \tab \code{integer} \tab 03-08 \tab Tag, triggers SEL\cr #' [,32] \tab LTYPE \tab \code{character} \tab 03-08 \tab Luminescence type\cr #' [,33] \tab LIGHTSOURCE \tab \code{character} \tab 03-08 \tab Light source\cr #' [,34] \tab LPOWER \tab \code{numeric} \tab 03-08 \tab Optical stimulation power\cr #' [,35] \tab LIGHTPOWER \tab \code{numeric} \tab 06-08 \tab Optical stimulation power\cr #' [,36] \tab LOW \tab \code{numeric} \tab 03-08 \tab Low (temperature, time, wavelength)\cr #' [,37] \tab HIGH \tab \code{numeric} \tab 03-08 \tab High (temperature, time, wavelength)\cr #' [,38] \tab RATE \tab \code{numeric} \tab 03-08 \tab Rate (heating rate, scan rate)\cr #' [,39] \tab TEMPERATURE \tab \code{integer} \tab 03-08 \tab Sample temperature\cr #' [,40] \tab MEASTEMP \tab \code{integer} \tab 06-08 \tab Measured temperature\cr #' [,41] \tab AN_TEMP \tab \code{numeric} \tab 03-08 \tab Annealing temperature\cr #' [,42] \tab AN_TIME \tab \code{numeric} \tab 03-08 \tab Annealing time\cr #' [,43] \tab TOLDELAY \tab \code{integer} \tab 03-08 \tab TOL 'delay' channels\cr #' [,44] \tab TOLON \tab \code{integer} \tab 03-08 \tab TOL 'on' channels\cr #' [,45] \tab TOLOFF \tab \code{integer} \tab 03-08 \tab TOL 'off' channels\cr #' [,46] \tab IRR_TIME \tab \code{numeric} \tab 03-08 \tab Irradiation time\cr #' [,47] \tab IRR_TYPE \tab \code{integer} \tab 03-08 \tab Irradiation type (alpha, beta or gamma)\cr #' [,48] \tab IRR_UNIT \tab \code{integer} \tab 03-04 \tab Irradiation unit (Gy, Rads, secs, mins, hrs)\cr #' [,49] \tab IRR_DOSERATE \tab \code{numeric} \tab 06-08 \tab Irradiation dose rate (Gy/s)\cr #' [,50] \tab IRR_DOSERATEERR \tab \code{numeric} \tab 06-08 \tab Irradiation dose rate error (Gy/s)\cr #' [,51] \tab TIMESINCEIRR \tab \code{integer} \tab 06-08 \tab Time since irradiation (s)\cr #' [,52] \tab TIMETICK \tab \code{numeric} \tab 06-08 \tab Time tick for pulsing (s)\cr #' [,53] \tab ONTIME \tab \code{integer} \tab 06-08 \tab On-time for pulsing (in time ticks)\cr #' [,54] \tab OFFTIME \tab \code{integer} \tab 03 \tab Off-time for pulsed stimulation (in s) \cr #' [,55] \tab STIMPERIOD \tab \code{integer} \tab 06-08 \tab Stimulation period (on+off in time ticks)\cr #' [,56] \tab GATE_ENABLED \tab \code{raw} \tab 06-08 \tab PMT signal gating enabled\cr #' [,57] \tab ENABLE_FLAGS \tab \code{raw} \tab 06-08 \tab PMT signal gating enabled\cr #' [,58] \tab GATE_START \tab \code{integer} \tab 06-08 \tab Start gating (in time ticks)\cr #' [,59] \tab GATE_STOP \tab \code{ingeter} \tab 06-08 \tab Stop gating (in time ticks), 'Gateend' for version 04, here only GATE_STOP is used\cr #' [,60] \tab PTENABLED \tab \code{raw} \tab 06-08 \tab Photon time enabled\cr #' [,61] \tab DTENABLED \tab \code{raw} \tab 06-08 \tab PMT dead time correction enabled\cr #' [,62] \tab DEADTIME \tab \code{numeric} \tab 06-08 \tab PMT dead time (s)\cr #' [,63] \tab MAXLPOWER \tab \code{numeric} \tab 06-08 \tab Stimulation power to 100 percent (mW/cm^2)\cr #' [,64] \tab XRF_ACQTIME \tab \code{numeric} \tab 06-08 \tab XRF acquisition time (s)\cr #' [,65] \tab XRF_HV \tab \code{numeric} \tab 06-08 \tab XRF X-ray high voltage (V)\cr #' [,66] \tab XRF_CURR \tab \code{integer} \tab 06-08 \tab XRF X-ray current (uA)\cr #' [,67] \tab XRF_DEADTIMEF \tab \code{numeric} \tab 06-08 \tab XRF dead time fraction\cr #' [,68] \tab DETECTOR_ID \tab \code{raw} \tab 07-08 \tab Detector ID\cr #' [,69] \tab LOWERFILTER_ID \tab \code{integer} \tab 07-08 \tab Lower filter ID in reader\cr #' [,70] \tab UPPERFILTER_ID \tab \code{integer} \tab 07-08 \tab Uper filter ID in reader\cr #' [,71] \tab ENOISEFACTOR \tab \code{numeric} \tab 07-08 \tab Excess noise filter, usage unknown \cr #' [,72] \tab MARKPOS_X1 \tab \code{numeric} \tab 08 \tab Coordinates marker position 1 \cr #' [,73] \tab MARKPOS_Y1 \tab \code{numeric} \tab 08 \tab Coordinates marker position 1 \cr #' [,74] \tab MARKPOS_X2 \tab \code{numeric} \tab 08 \tab Coordinates marker position 2 \cr #' [,75] \tab MARKPOS_Y2 \tab \code{numeric} \tab 08 \tab Coordinates marker position 2 \cr #' [,76] \tab MARKPOS_X3 \tab \code{numeric} \tab 08 \tab Coordinates marker position 3 \cr #' [,77] \tab MARKPOS_Y3 \tab \code{numeric} \tab 08 \tab Coordinates marker position 3 \cr #' [,78] \tab EXTR_START \tab \code{numeric} \tab 08 \tab usage unknown \cr #' [,79] \tab EXTR_END \tab \code{numeric} \tab 08 \tab usage unknown\cr #' [,80] \tab SEQUENCE \tab \code{character} \tab 03-04 \tab Sequence name #' } V = BIN-file version (RLum means that it does not depend on a specific BIN #' version)\cr #' #' Note that the \code{Risoe.BINfileData} object combines all values from #' different versions from the BIN-file, reserved bits are skipped, however, #' the function \code{\link{write_R2BIN}} reset arbitrary reserved bits. Invalid #' values for a specific version are set to \code{NA}. Furthermore, the #' internal R data types do not necessarily match the required data types for #' the BIN-file data import! Data types are converted during data import.\cr #' #' \bold{LTYPE} values #' #' \tabular{rll}{ [,0] \tab TL \tab: Thermoluminescence \cr [,1] \tab OSL \tab: #' Optically stimulated luminescence \cr [,2] \tab IRSL \tab: Infrared #' stimulated luminescence \cr [,3] \tab M-IR \tab: Infrared monochromator #' scan\cr [,4] \tab M-VIS \tab: Visible monochromator scan\cr [,5] \tab TOL #' \tab: Thermo-optical luminescence \cr [,6] \tab TRPOSL \tab: Time Resolved #' Pulsed OSL\cr [,7] \tab RIR \tab: Ramped IRSL\cr [,8] \tab RBR \tab: Ramped #' (Blue) LEDs\cr [,9] \tab USER \tab: User defined\cr [,10] \tab POSL \tab: #' Pulsed OSL \cr [,11] \tab SGOSL \tab: Single Grain OSL\cr [,12] \tab RL #' \tab: Radio Luminescence \cr [,13] \tab XRF \tab: X-ray Fluorescence } #' #' \bold{DTYPE} values \tabular{rll}{ [,0] \tab 0 \tab Natural \cr [,1] \tab 1 #' \tab N+dose \cr [,2] \tab 2 \tab Bleach \cr [,3] \tab 3 \tab Bleach+dose \cr #' [,4] \tab 4 \tab Natural (Bleach) \cr [,5] \tab 5 \tab N+dose (Bleach) \cr #' [,6] \tab 6 \tab Dose \cr [,7] \tab 7 \tab Background } #' #' \bold{LIGHTSOURCE} values \tabular{rll}{ [,0] \tab 0 \tab Non \cr [,1] \tab #' 1 \tab Lamp \cr [,2] \tab 2 \tab IR diodes/IR Laser \cr [,3] \tab 3 \tab #' Calibration LED \cr [,4] \tab 4 \tab Blue Diodes \cr [,5] \tab 5 \tab White #' lite \cr [,6] \tab 6 \tab Green laser (single grain) \cr [,7] \tab 7 \tab IR #' laser (single grain) } #' #' (information on the BIN/BINX file format are kindly provided by Risoe, DTU #' Nutech) #' #' @section Objects from the Class: Objects can be created by calls of the form #' \code{new("Risoe.BINfileData", ...)}. #' #' @section Function version: 0.3.3 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso #' \code{\link{plot_Risoe.BINfileData}}, \code{\link{read_BIN2R}}, #' \code{\link{write_R2BIN}},\code{\link{merge_Risoe.BINfileData}}, #' \code{\link{Risoe.BINfileData2RLum.Analysis}}, #' #' @references Risoe DTU, 2013. The Sequence Editor User Manual - Feb 2013 and Risoe DTU, 2016. The #' Sequence Editor User Manual - Feburar 2016 #' #' \code{http://www.nutech.dtu.dk/} #' #' @keywords classes #' #' @examples #' #' showClass("Risoe.BINfileData") #' #' @export setClass("Risoe.BINfileData", slots = list( METADATA = "data.frame", DATA = "list", .RESERVED = "list" ), prototype = prototype( METADATA = data.frame( ID = integer(), SEL = logical(), VERSION = integer(), LENGTH = integer(), PREVIOUS = integer(), NPOINTS = integer(), RECTYPE = integer(), RUN = integer(), SET = integer(), POSITION = integer(), GRAIN = integer(), GRAINNUMBER = integer(), CURVENO = integer(), XCOORD = integer(), YCOORD = integer(), SAMPLE = character(), COMMENT = character(), SYSTEMID = integer(), FNAME = character(), USER = character(), TIME = character(), DATE = character(), DTYPE = character(), BL_TIME = numeric(), BL_UNIT = integer(), NORM1 = numeric(), NORM2 = numeric(), NORM3 = numeric(), BG = numeric(), SHIFT = integer(), TAG = integer(), LTYPE = character(), LIGHTSOURCE = character(), LPOWER = numeric(), LIGHTPOWER = numeric(), LOW = numeric(), HIGH = numeric(), RATE = numeric(), TEMPERATURE = numeric(), MEASTEMP = numeric(), AN_TEMP = numeric(), AN_TIME = numeric(), TOLDELAY = integer(), TOLON = integer(), TOLOFF = integer(), IRR_TIME = numeric(), IRR_TYPE = integer(), IRR_UNIT = integer(), IRR_DOSERATE = numeric(), IRR_DOSERATEERR = numeric(), TIMESINCEIRR = numeric(), TIMETICK = numeric(), ONTIME = numeric(), OFFTIME = numeric(), STIMPERIOD = integer(), GATE_ENABLED = numeric(), ENABLE_FLAGS = numeric(), GATE_START = numeric(), GATE_STOP = numeric(), PTENABLED = numeric(), DTENABLED = numeric(), DEADTIME = numeric(), MAXLPOWER = numeric(), XRF_ACQTIME = numeric(), XRF_HV = numeric(), XRF_CURR = numeric(), XRF_DEADTIMEF = numeric(), DETECTOR_ID = integer(), LOWERFILTER_ID = integer(), UPPERFILTER_ID = integer(), ENOISEFACTOR = numeric(), MARKPOS_X1 = numeric(), MARKPOS_Y1 = numeric(), MARKPOS_X2 = numeric(), MARKPOS_Y2 = numeric(), MARKPOS_X3 = numeric(), MARKPOS_Y3 = numeric(), EXTR_START = numeric(), EXTR_END = numeric(), SEQUENCE = character(), stringsAsFactors=FALSE ), DATA = list(), .RESERVED = list() ) ) ##set generic S4 function for object #' @describeIn Risoe.BINfileData #' Show structure of RLum and Risoe.BINfile class objects #' @export setMethod(f = "show", signature = signature(object = "Risoe.BINfileData"), definition = function(object){ if(nrow(object@METADATA) != 0){ version<-paste(unique(object@METADATA[,"VERSION"]), collapse = ", ") systemID<-paste(unique(object@METADATA[,"SYSTEMID"]), collapse = ", ") filename <- as.character(object@METADATA[1,"FNAME"]) records.overall<-length(object@DATA) records.type<-table(object@METADATA[,"LTYPE"]) user<-paste(unique(as.character(object@METADATA[,"USER"])), collapse = ", ") date<-paste(unique(as.character(object@METADATA[,"DATE"])), collapse = ", ") run.range<-range(object@METADATA[,"RUN"]) set.range<-range(object@METADATA[,"SET"]) grain.range <- range(object@METADATA[,"GRAIN"]) pos.range<-range(object@METADATA[,"POSITION"]) records.type.count <- sapply(1:length(records.type), function(x){paste( names(records.type)[x],"\t(n = ",records.type[x],")",sep="") }) records.type.count <- paste(records.type.count, collapse="\n\t ") ##print cat("\n[Risoe.BINfileData object]") cat("\n\n\tBIN/BINX version ", version) if(version>=6){ cat("\n\tFile name: ", filename) } cat("\n\tObject date: ", date) cat("\n\tUser: ", user) cat("\n\tSystem ID: ", ifelse(systemID == 0,"0 (unknown)", systemID)) cat("\n\tOverall records: ", records.overall) cat("\n\tRecords type: ", records.type.count) cat("\n\tPosition range: ",pos.range[1],":",pos.range[2]) cat("\n\tGrain range: ",grain.range[1],":",grain.range[2]) cat("\n\tRun range: ",run.range[1],":",run.range[2]) cat("\n\tSet range: ",set.range[1],":",set.range[2]) }else{ cat("\n[Risoe.BINfileData object]") cat("\n\n >> This object is empty!<<") } }#end function )#end setMethod # constructor (set) method for object class ----------------------------------- #' @describeIn Risoe.BINfileData #' The Risoe.BINfileData is normally produced as output of the function read_BIN2R. #' This construction method is intended for internal usage only. #' #' @param METADATA Object of class "data.frame" containing the meta information #' for each curve. #' #' @param DATA Object of class "list" containing numeric vector with count data. #' #' @param .RESERVED Object of class "list" containing list of undocumented raw #' values for internal use only. #' @export setMethod(f = "set_Risoe.BINfileData", signature = signature("ANY"), definition = function(METADATA, DATA, .RESERVED) { if(length(METADATA) == 0){ new("Risoe.BINfileData") }else{ new( "Risoe.BINfileData", METADATA = METADATA, DATA = DATA, .RESERVED = .RESERVED ) } }) # accessor (get) method for object class ----------------------------------- #' @describeIn Risoe.BINfileData #' Formal get-method for Risoe.BINfileData object. It does not allow accessing #' the object directly, it is just showing a terminal message. #' #' @param object an object of class \code{\linkS4class{Risoe.BINfileData}} #' #' @param ... other arguments that might be passed #' #' @export setMethod("get_Risoe.BINfileData", signature= "Risoe.BINfileData", definition = function(object, ...) { cat("[get_Risoe.BINfileData()] No direct access is provided for this object type. Use the function 'Risoe.BINfileData2RLum.Analysis' for object coercing.") })##end setMethod ##-------------------------------------------------------------------------------------------------## ##=================================================================================================## Luminescence/R/get_Risoe.BINfileData.R0000644000176200001440000000214213125226556017177 0ustar liggesusers#' General accessor function for RLum S4 class objects #' #' Function calls object-specific get functions for RisoeBINfileData S4 class objects. #' #' The function provides a generalised access point for specific #' \code{\linkS4class{Risoe.BINfileData}} objects.\cr Depending on the input object, the #' corresponding get function will be selected. Allowed arguments can be found #' in the documentations of the corresponding \code{\linkS4class{Risoe.BINfileData}} class. #' #' @param object \code{\linkS4class{Risoe.BINfileData}} (\bold{required}): S4 object of #' class \code{RLum} #' @param \dots further arguments that one might want to pass to the specific #' get function #' @return Return is the same as input objects as provided in the list. #' @section Function version: 0.1.0 #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' @seealso #' \code{\linkS4class{Risoe.BINfileData}} #' @keywords utilities #' #' @export setGeneric( name = "get_Risoe.BINfileData", def = function(object, ...) { standardGeneric("get_Risoe.BINfileData") }, package = "Luminescence" ) Luminescence/R/set_Risoe.BINfileData.R0000644000176200001440000000176313125226556017223 0ustar liggesusers#' General accessor function for RLum S4 class objects #' #' Function calls object-specific get functions for RisoeBINfileData S4 class objects. #' #' The function provides a generalised access point for specific #' \code{\linkS4class{Risoe.BINfileData}} objects.\cr Depending on the input object, the #' corresponding get function will be selected. Allowed arguments can be found #' in the documentations of the corresponding \code{\linkS4class{Risoe.BINfileData}} class. #' #' @param METADATA x #' @param DATA x #' @param .RESERVED x #' #' @return Return is the same as input objects as provided in the list. #' @section Function version: 0.1 #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' @seealso #' \code{\linkS4class{Risoe.BINfileData}} #' @keywords utilities #' #' @export setGeneric("set_Risoe.BINfileData", function(METADATA = data.frame(), DATA = list(), .RESERVED = list()) { standardGeneric("set_Risoe.BINfileData") }, package = "Luminescence" ) Luminescence/R/fit_LMCurve.R0000644000176200001440000011203313125226556015376 0ustar liggesusers#' Nonlinear Least Squares Fit for LM-OSL curves #' #' The function determines weighted nonlinear least-squares estimates of the #' component parameters of an LM-OSL curve (Bulur 1996) for a given number of #' components and returns various component parameters. The fitting procedure #' uses the function \code{\link{nls}} with the \code{port} algorithm. #' #' \bold{Fitting function}\cr\cr The function for the fitting has the general #' form: \deqn{y = (exp(0.5)*Im_1*x/xm_1)*exp(-x^2/(2*xm_1^2)) + ,\ldots, + #' exp(0.5)*Im_i*x/xm_i)*exp(-x^2/(2*xm_i^2))} where \eqn{1 < i < 8}\cr This #' function and the equations for the conversion to b (detrapping probability) #' and n0 (proportional to initially trapped charge) have been taken from Kitis #' et al. (2008): \deqn{xm_i=\sqrt{max(t)/b_i}} \deqn{Im_i=exp(-0.5)n0/xm_i}\cr #' \bold{Background subtraction}\cr\cr Three methods for background subtraction #' are provided for a given background signal (\code{values.bg}).\cr #' \code{polynomial}: default method. A polynomial function is fitted using #' \link{glm} and the resulting function is used for background subtraction: #' \deqn{y = a*x^4 + b*x^3 + c*x^2 + d*x + e}\cr \code{linear}: a linear #' function is fitted using \link{glm} and the resulting function is used for #' background subtraction: \deqn{y = a*x + b}\cr \code{channel}: the measured #' background signal is subtracted channelwise from the measured signal.\cr\cr #' \bold{Start values}\cr #' #' The choice of the initial parameters for the \code{nls}-fitting is a crucial #' point and the fitting procedure may mainly fail due to ill chosen start #' parameters. Here, three options are provided:\cr\cr \bold{(a)} If no start #' values (\code{start_values}) are provided by the user, a cheap guess is made #' by using the detrapping values found by Jain et al. (2003) for quartz for a #' maximum of 7 components. Based on these values, the pseudo start parameters #' xm and Im are recalculated for the given data set. In all cases, the fitting #' starts with the ultra-fast component and (depending on \code{n.components}) #' steps through the following values. If no fit could be achieved, an error #' plot (for \code{plot = TRUE}) with the pseudo curve (based on the #' pseudo start parameters) is provided. This may give the opportunity to #' identify appropriate start parameters visually.\cr\cr \bold{(b)} If start #' values are provided, the function works like a simple \code{\link{nls}} #' fitting approach.\cr\cr \bold{(c)} If no start parameters are provided and #' the option \code{fit.advanced = TRUE} is chosen, an advanced start paramter #' estimation is applied using a stochastical attempt. Therefore, the #' recalculated start parameters \bold{(a)} are used to construct a normal #' distribution. The start parameters are then sampled randomly from this #' distribution. A maximum of 100 attempts will be made. \bold{Note:} This #' process may be time consuming. \cr\cr \bold{Goodness of fit}\cr\cr The #' goodness of the fit is given by a pseudoR^2 value (pseudo coefficient of #' determination). According to Lave (1970), the value is calculated as: #' \deqn{pseudoR^2 = 1 - RSS/TSS} where \eqn{RSS = Residual~Sum~of~Squares} \cr #' and \eqn{TSS = Total~Sum~of~Squares}\cr\cr \bold{Error of fitted component #' parameters}\cr\cr The 1-sigma error for the components is calculated using #' the function \link{confint}. Due to considerable calculation time, this #' option is deactived by default. In addition, the error for the components #' can be estimated by using internal R functions like \link{summary}. See the #' \link{nls} help page for more information.\cr \emph{For more details on the #' nonlinear regression in R, see Ritz & Streibig (2008).} #' #' @param values \code{\linkS4class{RLum.Data.Curve}} or \link{data.frame} #' (\bold{required}): x,y data of measured values (time and counts). See #' examples. #' #' @param values.bg \code{\linkS4class{RLum.Data.Curve}} or \link{data.frame} #' (optional): x,y data of measured values (time and counts) for background #' subtraction. #' #' @param n.components \link{integer} (with default): fixed number of #' components that are to be recognised during fitting (min = 1, max = 7). #' #' @param start_values \link{data.frame} (optional): start parameters for lm #' and xm data for the fit. If no start values are given, an automatic start #' value estimation is attempted (see details). #' #' @param input.dataType \link{character} (with default): alter the plot output #' depending on the input data: "LM" or "pLM" (pseudo-LM). See: \link{CW2pLM} #' #' @param fit.method \code{\link{character}} (with default): select fit method, #' allowed values: \code{'port'} and \code{'LM'}. \code{'port'} uses the 'port' #' routine usint the funtion \code{\link{nls}} \code{'LM'} utilises the #' function \code{nlsLM} from the package \code{minpack.lm} and with that the #' Levenberg-Marquardt algorithm. #' #' @param sample_code \link{character} (optional): sample code used for the #' plot and the optional output table (mtext). #' #' @param sample_ID \link{character} (optional): additional identifier used as #' column header for the table output. #' #' @param LED.power \link{numeric} (with default): LED power (max.) used for #' intensity ramping in mW/cm^2. \bold{Note:} This value is used for the #' calculation of the absolute photoionisation cross section. #' #' @param LED.wavelength \link{numeric} (with default): LED wavelength in nm #' used for stimulation. \bold{Note:} This value is used for the calculation of #' the absolute photoionisation cross section. #' #' @param fit.trace \link{logical} (with default): traces the fitting process #' on the terminal. #' #' @param fit.advanced \link{logical} (with default): enables advanced fitting #' attempt for automatic start parameter recognition. Works only if no start #' parameters are provided. \bold{Note:} It may take a while and it is not #' compatible with \code{fit.method = "LM"}. #' #' @param fit.calcError \link{logical} (with default): calculate 1-sigma error #' range of components using \link{confint}. #' #' @param bg.subtraction \link{character} (with default): specifies method for #' background subtraction (\code{polynomial}, \code{linear}, \code{channel}, #' see Details). \bold{Note:} requires input for \code{values.bg}. #' #' @param verbose \link{logical} (with default): terminal output with #' fitting results. #' #' @param plot \link{logical} (with default): returns a plot of the #' fitted curves. #' #' @param plot.BG \link{logical} (with default): returns a plot of the #' background values with the fit used for the background subtraction. #' #' @param \dots Further arguments that may be passed to the plot output, e.g. #' \code{xlab}, \code{xlab}, \code{main}, \code{log}. #' #' @return #' Various types of plots are returned. For details see above.\cr #' Furthermore an \code{RLum.Results} object is returned with the following structure:\cr #' #' data:\cr #' .. $data : \code{data.frame} with fitting results\cr #' .. $fit : \code{nls} (nls object)\cr #' .. $component.contribution.matrix : \code{list} component distribution matrix\cr #' #' info:\cr #' .. $call : \code{call} the original function call\cr #' #' Matrix structure for the distribution matrix:\cr #' #' Column 1 and 2: time and \code{rev(time)} values\cr #' Additional columns are used for the components, two for each component, #' containing I0 and n0. The last columns \code{cont.} provide information on #' the relative component contribution for each time interval including the row #' sum for this values. #' #' @note The pseudo-R^2 may not be the best parameter to describe the goodness #' of the fit. The trade off between the \code{n.components} and the pseudo-R^2 #' value currently remains unconsidered. \cr #' #' The function \bold{does not} ensure that the fitting procedure has reached a #' global minimum rather than a local minimum! In any case of doubt, the use of #' manual start values is highly recommended. #' #' @section Function version: 0.3.2 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\link{fit_CWCurve}}, \code{\link{plot}}, \code{\link{nls}}, #' \code{\link[minpack.lm]{nlsLM}}, \code{\link{get_RLum}} #' #' @references Bulur, E., 1996. An Alternative Technique For Optically #' Stimulated Luminescence (OSL) Experiment. Radiation Measurements, 26, 5, #' 701-709. #' #' Jain, M., Murray, A.S., Boetter-Jensen, L., 2003. Characterisation of #' blue-light stimulated luminescence components in different quartz samples: #' implications for dose measurement. Radiation Measurements, 37 (4-5), #' 441-449. #' #' Kitis, G. & Pagonis, V., 2008. Computerized curve deconvolution analysis for #' LM-OSL. Radiation Measurements, 43, 737-741. #' #' Lave, C.A.T., 1970. The Demand for Urban Mass Transportation. The Review of #' Economics and Statistics, 52 (3), 320-323. #' #' Ritz, C. & Streibig, J.C., 2008. Nonlinear Regression with R. R. Gentleman, #' K. Hornik, & G. Parmigiani, eds., Springer, p. 150. #' #' @keywords dplot models #' #' @examples #' #' #' ##(1) fit LM data without background subtraction #' data(ExampleData.FittingLM, envir = environment()) #' fit_LMCurve(values = values.curve, n.components = 3, log = "x") #' #' ##(2) fit LM data with background subtraction and export as JPEG #' ## -alter file path for your preferred system #' ##jpeg(file = "~/Desktop/Fit_Output\%03d.jpg", quality = 100, #' ## height = 3000, width = 3000, res = 300) #' data(ExampleData.FittingLM, envir = environment()) #' fit_LMCurve(values = values.curve, values.bg = values.curveBG, #' n.components = 2, log = "x", plot.BG = TRUE) #' ##dev.off() #' #' ##(3) fit LM data with manual start parameters #' data(ExampleData.FittingLM, envir = environment()) #' fit_LMCurve(values = values.curve, #' values.bg = values.curveBG, #' n.components = 3, #' log = "x", #' start_values = data.frame(Im = c(170,25,400), xm = c(56,200,1500))) #' #' @export fit_LMCurve<- function( values, values.bg, n.components = 3, start_values, input.dataType = "LM", fit.method = "port", sample_code = "", sample_ID = "", LED.power = 36, LED.wavelength = 470, fit.trace = FALSE, fit.advanced = FALSE, fit.calcError = FALSE, bg.subtraction = "polynomial", verbose = TRUE, plot = TRUE, plot.BG = FALSE, ... ){ # (0) Integrity checks ------------------------------------------------------- ##(1) data.frame or RLum.Data.Curve object? if(is(values, "data.frame") == FALSE & is(values, "RLum.Data.Curve") == FALSE){ stop("[fit_LMCurve()] 'values' object has to be of type 'data.frame' or 'RLum.Data.Curve'!") }else{ if(is(values, "RLum.Data.Curve") == TRUE && ( values@recordType!="RBR" & values@recordType!="LM-OSL")){ stop("[fit_LMCurve()] recordType should be 'RBR' or 'LM-OSL'! Consider as(object,'data.frame') if you had used the pseudo transformation functions.") }else if(is(values, "RLum.Data.Curve") == TRUE){ values <- as(values,"data.frame") } } ##(2) data.frame or RLum.Data.Curve object? if(missing(values.bg)==FALSE){ if(is(values.bg, "data.frame") == FALSE & is(values.bg, "RLum.Data.Curve") == FALSE){ stop("[fit_LMCurve()] 'values.bg' object has to be of type 'data.frame' or 'RLum.Data.Curve'!") }else{ if(is(values, "RLum.Data.Curve") == TRUE && values@recordType!="RBR"){ stop("[fit_LMCurve()] recordType should be 'RBR'!") }else if(is(values.bg, "RLum.Data.Curve") == TRUE){ values.bg <- as(values.bg,"data.frame") } } } ## Set plot format parameters ----------------------------------------------- extraArgs <- list(...) # read out additional arguments list log <- if("log" %in% names(extraArgs)) {extraArgs$log} else {""} xlim <- if("xlim" %in% names(extraArgs)) {extraArgs$xlim} else {c(min(values[,1]),max(values[,1]))} ylim <- if("ylim" %in% names(extraArgs)) {extraArgs$ylim} else { if(input.dataType=="pLM"){ c(0,max(values[,2]*1.1)) }else{ c(min(values[,2]),max(values[,2]*1.1)) } } xlab <- if("xlab" %in% names(extraArgs)) {extraArgs$xlab} else { if(input.dataType=="LM"){"Time [s]"}else{"u [s]"} } ylab <- if("ylab" %in% names(extraArgs)) {extraArgs$ylab} else { if(input.dataType=="LM"){ paste("LM-OSL [cts/",round(max(values[,1])/length(values[,1]),digits=2)," s]",sep="") }else{"pLM-OSL [a.u.]"} } main <- if("main" %in% names(extraArgs)) {extraArgs$main} else {"Default"} cex <- if("cex" %in% names(extraArgs)) {extraArgs$cex} else {0.8} fun <- if("fun" %in% names(extraArgs)) {extraArgs$fun} else {FALSE} ##============================================================================## ## BACKGROUND SUBTRACTION ##============================================================================## # ##perform background subtraction if background LM measurment exists if(missing(values.bg)==FALSE){ #set graphical parameters par.default <- par(mfrow=c(1,1), cex=1.5*cex) ##check if length of bg and signal is consistent if(length(values[,2])!=length(values.bg[,2])){stop("[fit_LMCurve] Length of values and values.bg differs!")} if(bg.subtraction=="polynomial"){ #fit polynom function to background glm.fit<-glm(values.bg[,2] ~ values.bg[,1]+I(values.bg[,1]^2)+I(values.bg[,1]^3)) glm.coef<-coef(glm.fit) #subtract background with fitted function values[,2]<-values[,2]- (glm.coef[4]*values[,1]^3+glm.coef[3]*values[,1]^2+glm.coef[2]*values[,1]+glm.coef[1]) writeLines("[fit_LMCurve] >> Background subtracted (method=\"polynomial\")!") ##plot Background measurement if needed if(plot.BG==TRUE){ plot(values.bg, ylab="LM-OSL [a.u.]", xlab="Time [s]", main="Background") curve((glm.coef[4]*x^3+glm.coef[3]*x^2+glm.coef[2]*x+glm.coef[1]),add=TRUE,col="red",lwd=2) text(0,max(values.bg[,2]),paste("y = ", round(glm.coef[4],digits=2), "*x^3+", round(glm.coef[3],digits=2), "*x^2+", round(glm.coef[2],digits=2), "*x+", round(glm.coef[1],digits=2), sep=""),pos=4) mtext(side=3,sample_code,cex=.8*cex) } }else if(bg.subtraction=="linear"){ #fit linear function to background glm.fit<-glm(values.bg[,2] ~ values.bg[,1]) glm.coef<-coef(glm.fit) ##substract bg values[,2]<-values[,2]-(glm.coef[2]*values[,1]+glm.coef[1]) writeLines("[fit_LMCurve.R] >> Background subtracted (method=\"linear\")!") ##plot Background measurement if needed if(plot.BG){ plot(values.bg, ylab="LM-OSL [a.u.]", xlab="Time [s]", main="Background") curve((glm.coef[2]*x+glm.coef[1]),add=TRUE,col="red",lwd=1.5) text(0,max(values.bg[,2]),paste("y = ", round(glm.coef[2],digits=2), "*x+", round(glm.coef[1],digits=2), sep=""),pos=4) mtext(side=3,sample_code,cex=.8*cex) }#endif::plot BG }else if(bg.subtraction=="channel"){ values[,2]<-values[,2]-values.bg[,2] writeLines("[fit_LMCurve.R] >> Background subtracted (method=\"channel\")!") if(plot.BG==TRUE){ plot(values.bg, ylab="LM-OSL [a.u.]", xlab="Time [s]", main="Background") mtext(side=3,sample_code,cex=.8*cex) } }else{stop("Error: Invalid method for background subtraction")} ##reset par values par(par.default) rm(par.default) } ##============================================================================## ## FITTING ##============================================================================## ##------------------------------------------------------------------------## ##set function for fit equation (according Kitis and Pagonis, 2008) ##////equation used for fitting////(start) fit.equation<-function(Im.i,xm.i){ equation<-parse( text=paste("exp(0.5)*Im[",Im.i,"]*(values[,1]/xm[",xm.i,"])*exp(-values[,1]^2/(2*xm[",xm.i,"]^2))", collapse="+",sep="")) return(equation) } ##////equation used for fitting///(end) ##------------------------------------------------------------------------## ##set formula elements for fitting functions ## the upper two funtions should be removed ... but chances are needed ... TODO ##////equation used for fitting////(start) fit.formula <- function(n.components){ Im <- paste0("Im.",1:n.components) xm <- paste0("xm.",1:n.components) as.formula(paste0("y ~ ", paste("(exp(0.5) * ", Im, "* x/", xm, ") * exp(-x^2/(2 *",xm,"^2))", collapse=" + "))) } ##////equation used for fitting///(end) ##------------------------------------------------------------------------## ##automatic start parameter estimation ##set fit function fit.function<-fit.equation(Im.i=1:n.components,xm.i=1:n.components) if(missing(start_values)){ ##set b (detrapping) values for a 7-component function taken from Jain et al. (2003) b.pseudo<-c(32,2.5,0.65,0.15,0.025,0.0025,0.00030) ##calculate xm parameters from values set based on the pseudo curves xm.pseudo<-sqrt(max(values[,1])/b.pseudo) ##the Im values obtaind by calculating residuals xm.residual<-sapply(1:length(b.pseudo),function(x){abs(values[,1]-xm.pseudo[x])}) xm.residual<-cbind(xm.residual,values[,1]) Im.pseudo<-sapply(1:length(xm.pseudo),function(x){ min(xm.residual[which(xm.residual[,x]==min(xm.residual[,x])),8])#8 is time index }) ##set additional variables b.pseudo_start<-1 b.pseudo_end<-0 fit.trigger<-FALSE while(fit.trigger==FALSE){ xm <- xm.pseudo[b.pseudo_start:(n.components + b.pseudo_end)] Im <- Im.pseudo[b.pseudo_start:(n.components + b.pseudo_end)] if(fit.advanced){ ##---------------------------------------------------------------## ##MC for fitting parameter ##make the fitting more stable by small variations of the parameters ##sample input parameters values from a normal distribution xm.MC<-sapply(1:length(xm),function(x){ xm.MC<-sample(rnorm(30,mean=xm[x],sd=xm[x]/10), replace=TRUE) }) Im.MC<-sapply(1:length(xm),function(x){ Im.MC<-sample(rnorm(30,mean=Im[x],sd=Im[x]/10), replace=TRUE) }) ##---------------------------------------------------------------## for(i in 1:length(xm.MC[,1])){ ##NLS ##try fit fit<-try(nls(y~eval(fit.function), trace=fit.trace, data=data.frame(x=values[,1],y=values[,2]), algorithm="port", start=list(Im=Im.MC[i,],xm=xm.MC[i,]),#end start values input nls.control( maxiter=500 ),#end nls control lower=c(xm=min(values[,1]),Im=0), upper=c(xm=max(values[,1]),Im=max(values[,2]*1.1)) ),# nls silent=TRUE)# end try ##graphical output if(i==1){cat(paste("[fit_LMCurve()] >> advanced fitting attempt (#", b.pseudo_start,"): ",sep=""))} cat("*") if(inherits(fit,"try-error") == FALSE){break} }#end::forloop cat("\n") }else{ if(fit.method == "port") { fit <- try(nls( y ~ eval(fit.function), trace = fit.trace, data = data.frame(x = values[,1],y = values[,2]), algorithm = "port", start = list(Im = Im,xm = xm),#end start values input nls.control(maxiter = 500),#end nls control lower = c(xm = 0,Im = 0) ),# nls silent = TRUE) # end try }else if (fit.method == "LM") { ##re-name for method == "LM" names(Im) <- paste0("Im.", 1:n.components) names(xm) <- paste0("xm.", 1:n.components) start.list <- c(as.list(Im), as.list(xm)) lower <- vapply(start.list, function(x) { start.list[[x]] <- 0 }, FUN.VALUE = vector(mode = "numeric", length = 1)) fit <- try(minpack.lm::nlsLM( fit.formula(n.components), data = data.frame(x = values[,1], y = values[,2]), start = start.list, lower = lower, trace = fit.trace, control = minpack.lm::nls.lm.control(maxiter = 500) ), silent = TRUE) }else{ stop("[fit_LMCurve()] unknow method for 'fit.method'") } }#endifelse::fit.advanced if(inherits(fit,"try-error")==FALSE){fit.trigger<-TRUE} else{ if((n.components+b.pseudo_end)==7){fit.trigger<-TRUE }else{ b.pseudo_start<-b.pseudo_start+1 b.pseudo_end<-b.pseudo_end+1 }#endif::maximum loops }#endif::try-error }#end:whileloop fit trigger }else{#endif::missing start values ##------------------------------------------------------------------------## fit<-try(nls(y~eval(fit.function), trace=fit.trace, data.frame(x=values[,1],y=values[,2]), algorithm="port", start=list(Im=start_values[,1],xm=start_values[,2]),#end start values input nls.control(maxiter=500), lower=c(xm=0,Im=0), #upper=c(xm=max(x),Im=max(y)*1.1)# set lower boundaries for components )# nls )# end try }#endif::startparameter ##------------------------------------------------------------------------## ##grep parameters if(inherits(fit,"try-error")==FALSE){ parameters<-coef(fit) ##write parameters in vectors and order parameters Im<-parameters[1:(length(parameters)/2)] Im.names <- names(Im) xm<-parameters[(1+(length(parameters)/2)):length(parameters)] xm.names <- names(xm) ##order parameters o <- order(xm) xm <- xm[o] names(xm) <- xm.names Im <- Im[o] names(Im) <- Im.names if (verbose){ ##print rough fitting information - use the nls() control for more information writeLines("\n[fit_LMCurve()]") writeLines(paste("\nFitting was done using a ",n.components, "-component function:\n",sep="")) ##print parameters print(c(xm, Im)) #print some additional information writeLines("\n(equation used for fitting according Kitis & Pagonis, 2008)") }#end if ##============================================================================## ## Additional Calculations ##============================================================================## ##calculate stimulation intensity Schmidt (2008) ##Energy - E = h*v h<-6.62606957e-34 #in W*s^2 - Planck constant ny<-299792458/(LED.wavelength/10^9) #frequency of the light E<-h*ny ##transform LED.power in W/cm^2 LED.power<-LED.power/1000 stimulation_intensity<-LED.power/E ##calculate b and n from the equation of Bulur(1996) to compare results ##Using Equation 5 and 6 from Kitis (2008) b<-as.vector(max(values[,1])/xm^2) #detrapping probability n0<-as.vector((Im/exp(-0.5))*xm) ##CALCULATE 1- sigma CONFIDENCE INTERVAL ##------------------------------------------------------------------------## b.error<-rep(NA, n.components) n0.error<-rep(NA, n.components) if(fit.calcError==TRUE){ ##option for confidence interval values.confint<-confint(fit, level=0.68) Im.confint<-values.confint[1:(length(values.confint[,1])/2),] xm.confint<-values.confint[((length(values.confint[,1])/2)+1):length(values.confint[,1]),] ##error calculation b.error<-as.vector(abs((max(values[,1])/xm.confint[,1]^2)-(max(values[,1])/xm.confint[,2]^2))) n0.error<-as.vector(abs(((Im.confint[,1]/exp(-0.5))*xm.confint[,1]) - ((Im.confint[,2]/exp(-0.5))*xm.confint[,2]))) } ##------------------------------------------------------------------------## ##calculate photoionisation cross section and print on terminal ##using EQ (5) in Kitis cs<-as.vector((max(values[,1])/xm^2)/stimulation_intensity) rel_cs<-round(cs/cs[1],digits=4) ##coefficient of determination after law RSS <- sum(residuals(fit)^2) #residual sum of squares TSS <- sum((values[,2] - mean(values[,2]))^2) #total sum of squares pR<-round(1-RSS/TSS,digits=4) ##============================================================================## ## COMPONENT TO SUM CONTRIBUTION MATRIX ##============================================================================## ##+++++++++++++++++++++++++++++++ ##set matrix ##set polygon matrix for optional plot output component.contribution.matrix <- matrix(NA, nrow = length(values[,1]), ncol = (2*length(xm)) + 2) ##set x-values component.contribution.matrix[,1] <- values[,1] component.contribution.matrix[,2] <- rev(values[,1]) ##+++++++++++++++++++++++++++++++ ##set 1st polygon ##1st polygon (calculation) y.contribution_first <- (exp(0.5)*Im[1]*values[,1]/ xm[1]*exp(-values[,1]^2/(2*xm[1]^2))/ (eval(fit.function))*100) ##avoid NaN values (might happen with synthetic curves) y.contribution_first[is.nan(y.contribution_first)==TRUE] <- 0 ##set values in matrix component.contribution.matrix[,3] <- 100 component.contribution.matrix[,4] <- 100-rev(y.contribution_first) ##+++++++++++++++++++++++++++++++ ##set polygons in between ##polygons in between (calculate and plot) if (length(xm)>2){ y.contribution_prev <- y.contribution_first i<-2 ##matrix stepping k <- seq(3, ncol(component.contribution.matrix), by=2) while (i<=length(xm)-1) { y.contribution_next<-(exp(0.5)*Im[i]*values[,1]/ xm[i]*exp(-values[,1]^2/(2*xm[i]^2))/ (eval(fit.function))*100) ##avoid NaN values y.contribution_next[is.nan(y.contribution_next)==TRUE] <- 0 ##set values in matrix component.contribution.matrix[, k[i]] <- 100-y.contribution_prev component.contribution.matrix[, k[i]+1] <- rev(100-y.contribution_prev- y.contribution_next) y.contribution_prev <- y.contribution_prev + y.contribution_next i<-i+1 }#end while loop }#end if ##+++++++++++++++++++++++++++++++ ##set last polygon ##last polygon (calculation) y.contribution_last<-(exp(0.5)*Im[length(xm)]*values[,1]/ xm[length(xm)]*exp(-values[,1]^2/ (2*xm[length(xm)]^2))/ (eval(fit.function))*100) ##avoid NaN values y.contribution_last[is.nan(y.contribution_last)==TRUE]<-0 component.contribution.matrix[,((2*length(xm))+1)] <- y.contribution_last component.contribution.matrix[,((2*length(xm))+2)] <- 0 ##change names of matrix to make more easy to understand component.contribution.matrix.names <- c("x", "rev.x", paste(c("y.c","rev.y.c"),rep(1:n.components,each=2), sep="")) ##calculate area for each component, for each time interval component.contribution.matrix.area <- sapply( seq(3,ncol(component.contribution.matrix),by=2), function(x){ matrixStats::rowDiffs(cbind(rev(component.contribution.matrix[,(x+1)]), component.contribution.matrix[,x])) }) ##append to existing matrix component.contribution.matrix <- cbind( component.contribution.matrix, component.contribution.matrix.area, rowSums(component.contribution.matrix.area) ) ##set final column names colnames(component.contribution.matrix) <- c( component.contribution.matrix.names, paste(c("cont.c"),rep(1:n.components,each=1), sep=""), "cont.sum") ##============================================================================## ## Terminal Output (advanced) ##============================================================================## if (verbose){ ##write fill lines writeLines("------------------------------------------------------------------------------") writeLines("(1) Corresponding values according the equation in Bulur, 1996 for b and n0:\n") for (i in 1:length(b)){ writeLines(paste("b",i," = ",format(b[i],scientific=TRUE)," +/- ",format(b.error[i],scientific=TRUE),sep="")) writeLines(paste("n0",i," = ",format(n0[i],scientific=TRUE)," +/- ",format(n0.error[i],scientific=TRUE),"\n",sep="")) }#end for loop ##write photoionisation cross section on terminal for (i in 1:length(cs)){ writeLines(paste("cs from component.",i," = ",format(cs[i],scientific=TRUE, digits=4), " cm^2", "\t >> relative: ",round(cs[i]/cs[1],digits=4),sep="")) }#end for loop writeLines(paste( "\n(stimulation intensity value used for calculation: ",format(stimulation_intensity,scientific=TRUE)," 1/s 1/cm^2)",sep="")) writeLines("(errors quoted as 1-sigma uncertainties)") writeLines("------------------------------------------------------------------------------\n") #sum of squares writeLines(paste("pseudo-R^2 = ",pR,sep="")) }#end if ##============================================================================## ## COMPOSE RETURN VALUES (data.frame) ##============================================================================## ##write output table if values exists if (exists("fit")){ ##set data.frame for a max value of 7 components output.table <- data.frame(NA,NA,NA,NA,NA,NA,NA,NA, NA,NA,NA,NA,NA,NA,NA,NA, NA,NA,NA,NA,NA,NA,NA,NA, NA,NA,NA,NA,NA,NA,NA,NA, NA,NA,NA,NA,NA,NA,NA,NA, NA,NA,NA,NA,NA,NA,NA,NA, NA,NA,NA,NA,NA,NA,NA,NA) output.tableColNames<-c("Im1","xm1", "b1","b1.error","n01","n01.error", "cs1","rel_cs1", "Im2","xm2", "b2","b2.error","n02","n02.error", "cs2","rel_cs2", "Im3","xm3", "b3","b3.error","n03","n03.error", "cs3","rel_cs3", "Im4","xm4", "b4","b4.error","n04","n04.error", "cs4","rel_cs4", "Im5","xm5", "b5","b5.error","n05","n05.error", "cs5","rel_cs5", "Im6","xm6", "b6","b6.error","n06","n06.error", "cs6","rel_cs6", "Im7","xm7", "b7","b7.error","n07","n07.error", "cs7","rel_cs7") ##write components in output table i<-0 k<-1 while(i<=n.components*8){ output.table[1,i+1]<-Im[k] output.table[1,i+2]<-xm[k] output.table[1,i+3]<-b[k] output.table[1,i+4]<-b.error[k] output.table[1,i+5]<-n0[k] output.table[1,i+6]<-n0.error[k] output.table[1,i+7]<-cs[k] output.table[1,i+8]<-rel_cs[k] i<-i+8 k<-k+1 } ##add pR and n.components output.table<-cbind(sample_ID,sample_code,n.components,output.table,pR) ###alter column names colnames(output.table)<-c("ID","sample_code","n.components",output.tableColNames,"pseudo-R^2") ##----------------------------------------------------------------------------## }#endif::exists fit }else{ output.table <- NA component.contribution.matrix <- NA writeLines("[fit_LMCurve] Fitting Error: Plot without fit produced!") } ##============================================================================## ## PLOTTING ##============================================================================## if(plot){ ##cheat the R check routine x <- NULL; rm(x) ##grep package colour gallery col <- get("col", pos = .LuminescenceEnv) ##change xlim values in case of the log plot the avoid problems if((log == "x" | log == "xy") && xlim[1] == 0){ warning("[fit_LMCurve()] x-axis limitation change to avoid 0 values for log-scale!", call. = FALSE) xlim <- c(2^0.5/2 * max(values[,1])/length(values[,1]), xlim[2]) } ##set plot frame par.default <- par(no.readonly = TRUE) layout(matrix(c(1,2,3),3,1,byrow=TRUE),c(1.6,1,1), c(1,0.3,0.4),TRUE) par(oma=c(1,1,1,1),mar=c(0,4,3,0), cex=cex) ##==uppper plot==## ##open plot area plot( NA, NA, xlim = xlim, ylim = ylim, xlab = "", xaxt = "n", main = main, log = log, ylab = ylab )#endplot mtext(side=3,sample_code,cex=0.8*cex) ##plotting measured signal points(values[, 1], values[, 2], pch = 20, col = rgb(0.4, 0.4, 0.4, 0.5)) ##==pseudo curve==##------------------------------------------------------# ##curve for used pseudo values if(inherits(fit,"try-error")==TRUE & missing(start_values)==TRUE){ fit.function<-fit.equation(Im.i=1:n.components,xm.i=1:n.components) Im<-Im.pseudo[1:n.components] xm<-xm.pseudo[1:n.components] ##draw pseudo curve lines(values[,1],eval(fit.function), lwd=2, col="red", lty=2) axis(side=1) mtext(side=1,xlab, cex=.9*cex,line=2) mtext(side=4,paste(n.components, " component pseduo function is shown",sep=""),cex=0.7, col="blue") ##draw information text on plot text(min(values[,1]),max(values[,2]),"FITTING ERROR!",pos=4) ##additional legend legend("topright",c("pseudo sum function"),lty=2,lwd=2,col="red",bty="n") } ##==pseudo curve==##------------------------------------------------------## ##plot sum function if(inherits(fit,"try-error")==FALSE){ lines(values[,1],eval(fit.function), lwd=2, col="black") legend.caption<-"sum curve" curve.col<-1 ##plot signal curves ##plot curve for additional parameters for (i in 1:length(xm)) { curve(exp(0.5)*Im[i]*x/xm[i]*exp(-x^2/(2*xm[i]^2)),col=col[i+1], lwd=2,add=TRUE) legend.caption<-c(legend.caption,paste("component ",i,sep="")) curve.col<-c(curve.col,i+1) } ##plot legend legend(if(log=="x"| log=="xy"){ if(input.dataType=="pLM"){"topright"}else{"topleft"}}else{"topright"}, legend.caption,lty=1,lwd=2,col=col[curve.col], bty="n") ##==lower plot==## ##plot residuals par(mar=c(4.2,4,0,0)) plot(values[,1],residuals(fit), xlim=xlim, xlab=xlab, type="l", col="grey", ylab="Residual", lwd=2, log=log) ##ad 0 line abline(h=0) ##------------------------------------------------------------------------# ##++component to sum contribution plot ++## ##------------------------------------------------------------------------# ##plot component contribution to the whole signal #open plot area par(mar=c(4,4,3.2,0)) plot(NA,NA, xlim=xlim, ylim=c(0,100), ylab="Contribution [%]", xlab=xlab, main="Component contribution to sum curve", log=if(log=="xy"){"x"}else{log}) stepping <- seq(3,length(component.contribution.matrix),2) for(i in 1:length(xm)){ polygon(c(component.contribution.matrix[,1], component.contribution.matrix[,2]), c(component.contribution.matrix[,stepping[i]], component.contribution.matrix[,stepping[i]+1]), col = col[i+1]) } rm(stepping) ##reset par par(par.default) rm(par.default) ##------------------------------------------------------------------------## }#end if try-error for fit if(fun==TRUE){sTeve()} } ##----------------------------------------------------------------------------- ##remove objects try(unlist("parameters")) ##============================================================================# ## Return Values ##============================================================================# newRLumResults.fit_LMCurve <- set_RLum( class = "RLum.Results", data = list( data = output.table, fit = fit, component.contribution.matrix = list(component.contribution.matrix) ), info = list(call = sys.call()) ) invisible(newRLumResults.fit_LMCurve) } Luminescence/R/Risoe.BINfileData2RLum.Analysis.R0000644000176200001440000002402213125226556021005 0ustar liggesusers#' Convert Risoe.BINfileData object to an RLum.Analysis object #' #' Converts values from one specific position of a Risoe.BINfileData S4-class #' object to an RLum.Analysis object. #' #' The \code{\linkS4class{RLum.Analysis}} object requires a set of curves for #' specific further protocol analyses. However, the #' \code{\linkS4class{Risoe.BINfileData}} usually contains a set of curves for #' different aliquots and different protocol types that may be mixed up. #' Therefore, a conversion is needed. #' #' @param object \code{\linkS4class{Risoe.BINfileData}} (\bold{required}): #' \code{Risoe.BINfileData} object #' #' @param pos \code{\link{numeric}} (optional): position number of the #' \code{Risoe.BINfileData} object for which the curves are stored in the #' \code{RLum.Analysis} object. If \code{length(position)>1} a list of \code{RLum.Analysis} objects #' is returned. If nothing is provided every position will be converted. If the position is not valid \code{NA} is #' returned. #' #' @param grain \code{\link{vector}, \link{numeric}} (optional): grain number from #' the measurement to limit the converted data set (e.g., \code{grain = #' c(1:48)}). Please be aware that this option may lead to unwanted effects, as the output #' is strictly limited to the choosen grain number for all position numbers #' #' @param run \code{\link{vector}, \link{numeric}} (optional): run number from #' the measurement to limit the converted data set (e.g., \code{run = #' c(1:48)}). #' #' @param set \code{\link{vector}, \link{numeric}} (optional): set number from #' the measurement to limit the converted data set (e.g., \code{set = #' c(1:48)}). #' #' @param ltype \code{\link{vector}, \link{character}} (optional): curve type #' to limit the converted data. Commonly allowed values are: \code{IRSL}, \code{OSL}, #' \code{TL}, \code{RIR}, \code{RBR} and \code{USER} (see also \code{\linkS4class{Risoe.BINfileData}}) #' #' @param dtype \code{\link{vector}, \link{character}} (optional): data type to #' limit the converted data. Commonly allowed values are listed in \code{\linkS4class{Risoe.BINfileData}} #' #' @param protocol \code{\link{character}} (optional): sets protocol type for #' analysis object. Value may be used by subsequent analysis functions. #' #' @param keep.empty \code{\link{logical}} (with default): If \code{TRUE} (default) #' an \code{RLum.Analysis} object is returned even if it does not contain any #' records. Set to \code{FALSE} to discard all empty objects. #' #' @param txtProgressBar \link{logical} (with default): enables or disables #' \code{\link{txtProgressBar}}. #' #' @return Returns an \code{\linkS4class{RLum.Analysis}} object. #' #' @note The \code{protocol} argument of the \code{\linkS4class{RLum.Analysis}} #' object is set to 'unknown' if not stated otherwise. #' #' @section Function version: 0.4.2 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\linkS4class{Risoe.BINfileData}}, \code{\linkS4class{RLum.Analysis}}, \code{\link{read_BIN2R}} #' #' @references # #' #' @keywords manip #' #' @examples #' #' ##load data #' data(ExampleData.BINfileData, envir = environment()) #' #' ##convert values for position 1 #' Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos = 1) #' #' @export Risoe.BINfileData2RLum.Analysis<- function( object, pos = NULL, grain = NULL, run = NULL, set = NULL, ltype = NULL, dtype = NULL, protocol = "unknown", keep.empty = TRUE, txtProgressBar = FALSE ){ # Integrity Check --------------------------------------------------------- if (!is(object,"Risoe.BINfileData")){ stop("[Risoe.BINfileData2RLum.Analysis()] Input object is not of type 'Risoe.BINfileData'.") } if (!is.null(pos) && !is(pos,"numeric")){ stop("[Risoe.BINfileData2RLum.Analysis()] Argument 'pos' has to be of type numeric.") } if (is.null(pos)) { pos <- unique(object@METADATA[["POSITION"]]) } else{ ##get and check valid positions and remove invalid numbers from the input positions.valid <- unique(object@METADATA[, "POSITION"]) if (length(setdiff(pos, positions.valid)) > 0) { warning( paste0( "[Risoe.BINfileData2RLum.Analysis()] invalid position number skipped: ", paste(setdiff(pos, positions.valid), collapse = ", ") ), call. = FALSE ) pos <- intersect(pos, positions.valid) } } # Grep run and set data --------------------------------------------------- ##grain if (is.null(grain)) { grain <- unique(object@METADATA[,"GRAIN"]) }else{ grain.valid <- unique(object@METADATA[,"GRAIN"]) if(length(setdiff(grain, grain.valid)) > 0){ warning(paste0("[Risoe.BINfileData2RLum.Analysis()] Invalid grain number skipped: ", paste(setdiff(grain, grain.valid), collapse = ", ")), call. = FALSE) grain <- intersect(grain, grain.valid) } } ##run if (is.null(run)) { run <- unique(object@METADATA[["RUN"]]) } else{ if (TRUE %in% unique(unique(object@METADATA[["RUN"]]) %in% run) != TRUE) { ##get and check valid positions run.valid <- paste(as.character(unique(object@METADATA[, "RUN"])), collapse = ", ") stop( paste( "[Risoe.BINfileData2RLum.Analysis()] run = ", run, " contain invalid run(s). Valid runs are: ", run.valid, sep = "" ) ) } } #set if(is.null(set)){set <- unique(object@METADATA[["SET"]]) } else{ if(TRUE %in% unique(unique(object@METADATA[["SET"]]) %in% set) != TRUE){ ##get and check valid positions set.valid <- paste(as.character(unique(object@METADATA[,"SET"])), collapse=", ") stop(paste("[Risoe.BINfileData2RLum.Analysis] set = ", set, " contain invalid set(s). Valid sets are: ", set.valid, sep="")) } } ##ltype if (is.null(ltype)) { ltype <- unique(object@METADATA[["LTYPE"]]) } else{ if (TRUE %in% unique(unique(object@METADATA[, "LTYPE"]) %in% ltype) != TRUE) { ##get and check valid positions ltype.valid <- paste(as.character(unique(object@METADATA[, "LTYPE"])), collapse = ", ") stop( paste( "[Risoe.BINfileData2RLum.Analysis] ltype = ", ltype, " contain invalid ltype(s). Valid ltypes are: ", ltype.valid, sep = "" ) ) } } ##dtype if (is.null(dtype)) { dtype <- unique(object@METADATA[["DTYPE"]]) } else{ if (TRUE %in% unique(unique(object@METADATA[, "DTYPE"]) %in% dtype) != TRUE) { ##get and check valid positions dtype.valid <- paste(as.character(unique(object@METADATA[, "DTYPE"])), collapse = ", ") stop( paste( "[Risoe.BINfileData2RLum.Analysis] dtype = ", dtype, " contain invalid dtype(s). Valid dtypes are: ", dtype.valid, sep = "" ) ) } } # Select values and convert them----------------------------------------------------------- ##set progressbar to false if only one position is provided if(txtProgressBar & length(pos)<2){ txtProgressBar <- FALSE } ##This loop does: ## (a) iterating over all possible positions ## (b) consider grains in all possible positions ## (c) consider other selections ## (d) create the RLum.Analysis objects ##set progress bar if(txtProgressBar){ pb<-txtProgressBar(min=min(pos),max=max(pos), char="=", style=3) } object <- lapply(pos, function(pos){ ##update progress bar if(txtProgressBar){ setTxtProgressBar(pb, value = pos) } ##if no grain information is given, we select all grains in the particular position if(is.null(grain)){ grain <- unique(object@METADATA[object@METADATA[["POSITION"]] == pos, "GRAIN"]) } ##loop over the grains and produce RLum.Analysis objects object <- lapply(grain, function(grain){ ##select data ##the NA is necessary, as FI readers like to write a NA instead of 0 in the column ##and this causes some trouble if(is.na(grain)){ temp_id <- object@METADATA[ object@METADATA[["POSITION"]] == pos & object@METADATA[["RUN"]] %in% run & object@METADATA[["SET"]] %in% set & object@METADATA[["LTYPE"]] %in% ltype & object@METADATA[["DTYPE"]] %in% dtype , "ID"] }else{ temp_id <- object@METADATA[ object@METADATA[["POSITION"]] == pos & object@METADATA[["GRAIN"]] == grain & object@METADATA[["RUN"]] %in% run & object@METADATA[["SET"]] %in% set & object@METADATA[["LTYPE"]] %in% ltype & object@METADATA[["DTYPE"]] %in% dtype , "ID"] } ##create curve object object <- set_RLum( class = "RLum.Analysis", records = lapply(temp_id,function(x) { .Risoe.BINfileData2RLum.Data.Curve(object, id = x) }), protocol = protocol, originator = "Risoe.BINfileData2RLum.Analysis" ) if (!keep.empty && length(object@records) == 0) return(NULL) ##add unique id of RLum.Analysis object to each curve object as .pid using internal function .set_pid(object) return(object) }) return(object) }) ##this is necessary to not break with previous code, i.e. if only one element is included ##the output is RLum.Analysis and not a list of it if(length(object) == 1){ # special case: single grain data with only 1 position produces a nested list # the outer one is of length 1, the nested list has length 100 (100 grains) if (is.list(object[[1]]) && length(object[[1]]) > 1) invisible(unlist(object)) else invisible(object[[1]][[1]]) }else{ invisible(unlist(object)) } } Luminescence/R/bin_RLum.Data.R0000644000176200001440000000305713125226556015603 0ustar liggesusers#' Channel binning - method dispatchter #' #' Function calls the object-specific bin functions for RLum.Data S4 class objects. #' #' The function provides a generalised access point for specific #' \code{\linkS4class{RLum.Data}} objects.\cr Depending on the input object, the #' corresponding function will be selected. Allowed arguments can be found #' in the documentations of the corresponding \code{\linkS4class{RLum.Data}} class. #' #' @param object \code{\linkS4class{RLum.Data}} (\bold{required}): S4 object of #' class \code{RLum.Data} #' #' @param ... further arguments passed to the specifc class method #' #' @return An object of the same type as the input object is provided #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @note Currenlty only \code{RLum.Data} objects of class \code{RLum.Data.Curve} are supported! #' #' @seealso #' \code{\linkS4class{RLum.Data.Curve}} #' #' @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 #' #' @export setGeneric("bin_RLum.Data", function(object, ...) { standardGeneric("bin_RLum.Data") }) Luminescence/R/merge_RLum.Data.Curve.R0000644000176200001440000002222613125226556017214 0ustar liggesusers#' Merge function for RLum.Data.Curve S4 class objects #' #' Function allows merging of RLum.Data.Curve objects in different ways #' #' This function simply allowing to merge \code{\linkS4class{RLum.Data.Curve}} #' objects without touching the objects itself. Merging is always applied on #' the 2nd colum of the data matrix of the object.\cr #' #' \bold{Supported merge operations are #' \code{\linkS4class{RLum.Data.Curve}}}\cr #' #' \code{"sum"}\cr #' #' All count values will be summed up using the function \code{\link{rowSums}}. #' #' \code{"mean"}\cr #' #' The mean over the count values is calculated using the function #' \code{\link{rowMeans}}. #' #' \code{"median"}\cr #' #' The median over the count values is calculated using the function #' \code{\link[matrixStats]{rowMedians}}. #' #' \code{"sd"}\cr #' #' The standard deviation over the count values is calculated using the function #' \code{\link[matrixStats]{rowSds}}. #' #' \code{"var"}\cr #' #' The variance over the count values is calculated using the function #' \code{\link[matrixStats]{rowVars}}. #' #' \code{"min"}\cr #' #' The min values from the count values is chosen using the function #' \code{\link[matrixStats]{rowMins}}. #' #' \code{"max"}\cr #' #' The max values from the count values is chosen using the function #' \code{\link[matrixStats]{rowMins}}. #' #' \code{"append"}\cr #' #' 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. #' #' \code{"-"}\cr #' #' The row sums of the last objects are subtracted from the first object. #' #' \code{"*"}\cr #' #' The row sums of the last objects are mutliplied with the first object. #' #' \code{"/"}\cr #' #' Values of the first object are divided by row sums of the last objects. #' #' @param object \code{\link{list}} of \code{\linkS4class{RLum.Data.Curve}} #' (\bold{required}): list of S4 objects of class \code{RLum.Curve}. #' #' @param merge.method \code{\link{character}} (\bold{required}): method for #' combining of the objects, e.g. \code{'mean'}, \code{'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 \code{\link{numeric}} (optional): allows to specify how #' info elements of the input objects are combined, e.g. \code{1} means that #' just the elements from the first object are kept, \code{2} keeps only the #' info elements from the 2 object etc. If nothing is provided all elements #' are combined. #' #' @return Returns an \code{\linkS4class{RLum.Data.Curve}} object. #' #' @note The information from the slot 'recordType' is taken from the first #' \code{\linkS4class{RLum.Data.Curve}} object in the input list. The slot #' 'curveType' is filled with the name \code{merged}. #' #' @section S3-generic support: #' #' This function is fully operational via S3-generics: #' \code{`+`}, \code{`-`}, \code{`/`}, \code{`*`}, \code{merge} #' #' @section Function version: 0.2.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\link{merge_RLum}}, \code{\linkS4class{RLum.Data.Curve}} #' #' @references - #' #' @keywords utilities #' #' @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) #' #' @export merge_RLum.Data.Curve<- function( object, merge.method = "mean", method.info ){ # Ingegrity checks ---------------------------------------------------------------------------- ##(1) check if object is of class RLum.Data.Curve temp.recordType.test <- sapply(1:length(object), function(x){ if(is(object[[x]], "RLum.Data.Curve") == FALSE){ temp.text <- paste( "[merge_RLum.Data.Curve()]: At least object", x, "is not of class 'RLum.Data.Curve'!") stop(temp.text) } ##provide class of objects return(object[[x]]@recordType) }) ##(2) Check for similar record types if(length(unique(temp.recordType.test))>1){ stop.text <- paste0("[merge_RLum.Data.Curve()] only similar record types are supported, you are trying to merge: ", paste0("'",unique(temp.recordType.test),"'", collapse = ", ")) stop(stop.text) } # Merge objects ------------------------------------------------------------------------------- ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ##merge data objects ##problem ... how to handle data with different resoultion or length? ##(1) build new data matrix ##first find shortest object check.length <- sapply(1:length(object),function(x){ nrow(object[[x]]@data) }) temp.matrix <- sapply(1:length(object), function(x){ ##check if the objects are of equal length if (length(unique(check.length)) != 1) { ##but we have to at least check the x-range if (object[[x]]@data[x,1] != object[[1]]@data[x,1]) { stop( "[merge_RLum.Data.Curve()] The objects seem not to have the same channel resolution!" ) } warning("[merge_RLum.Data.Curve()] The number of channels between the curves differes. Resulting curve has the length of shortest curve.") ##if this is ok, we cann continue and shorten the rest of the objects return(object[[x]]@data[1:min(check.length),2]) #stop("[merge_RLum.Data.Curve()] Input objects have to be of similar length.") ##find out which curve is the shortest element }else{ object[[x]]@data[,2] } }) ##(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(ncol(temp.matrix) > 2){ temp.matrix <- temp.matrix[,1] - rowSums(temp.matrix[,-1]) }else{ temp.matrix <- temp.matrix[,1] - temp.matrix[,2] } }else if(merge.method == "*"){ if(ncol(temp.matrix) > 2){ temp.matrix <- temp.matrix[,1] * rowSums(temp.matrix[,-1]) }else{ temp.matrix <- temp.matrix[,1] * temp.matrix[,2] } }else if(merge.method == "/"){ if(ncol(temp.matrix) > 2){ temp.matrix <- temp.matrix[,1] / rowSums(temp.matrix[,-1]) }else{ temp.matrix <- temp.matrix[,1] / temp.matrix[,2] } ##get index of inf values id.inf <- which(is.infinite(temp.matrix) == TRUE) ##replace with 0 and provide warning temp.matrix[id.inf] <- 0 warning(paste0(length(id.inf), " 'inf' values have been replaced by 0 in the matrix.")) }else{ stop("[merge_RLum.Data.Curve()] unsupported or unknown merge method!") } ##add first column #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" & length(unique(diff(object[[1]]@data[,1])))) { step <- unique(diff(object[[1]]@data[,1])) newx <- seq(from = min(object[[1]]@data[,1]), by = step, length.out = sum(check.length)) temp.matrix <- cbind(newx, temp.matrix) } else { temp.matrix <- cbind(object[[1]]@data[1:min(check.length),1], temp.matrix) } ##~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ##merge info objects as simple as possible ... just keep them all ... other possiblity ##would be to chose on the the input objects ##unlist is needed here, as otherwise i would cause unexpected bevavhiour further using ##the RLum.object if(missing(method.info)){ temp.info <- unlist(lapply(1:length(object), 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 object ------------------------------------------------------------------------------- return(temp.new.Data.Curve) } Luminescence/R/plot_GrowthCurve.R0000644000176200001440000016454113125226556016547 0ustar liggesusers#' Fit and plot a growth curve for luminescence data (Lx/Tx against dose) #' #' A dose response curve is produced for luminescence measurements using a #' regenerative or additive protocol. The function supports interpolation and #' extraxpolation to calculate the equivalent dose. #' #' \bold{Fitting methods} \cr\cr For all options (except for the \code{LIN}, \code{QDR} and #' the \code{EXP OR LIN}), the \code{\link[minpack.lm]{nlsLM}} function with the #' \code{LM} (Levenberg-Marquardt algorithm) algorithm is used. Note: For historical reasons #' for the Monte Carlo simulations partly the function \code{\link{nls}} using the \code{port} algorithm. #' #' The solution is found by transforming the function or using \code{\link{uniroot}}. \cr #' #' \code{LIN}: fits a linear function to the data using #' \link{lm}: \deqn{y = m*x+n} #' #' \code{QDR}: fits a linear function to the data using #' \link{lm}: \deqn{y = a + b * x + c * x^2} #' #' \code{EXP}: try to fit a function of the form #' \deqn{y = a*(1-exp(-(x+c)/b))} Parameters b and c are approximated by a #' linear fit using \link{lm}. Note: b = D0\cr #' #' \code{EXP OR LIN}: works for some cases where an \code{EXP} fit fails. If #' the \code{EXP} fit fails, a \code{LIN} fit is done instead. \cr #' #' \code{EXP+LIN}: tries to fit an exponential plus linear function of the #' form: \deqn{y = a*(1-exp(-(x+c)/b)+(g*x))} The De is calculated by #' iteration.\cr \bold{Note:} In the context of luminescence dating, this #' function has no physical meaning. Therefore, no D0 value is returned.\cr #' #' \code{EXP+EXP}: tries to fit a double exponential function of the form #' \deqn{y = (a1*(1-exp(-(x)/b1)))+(a2*(1-exp(-(x)/b2)))} This fitting #' procedure is not robust against wrong start parameters and should be further #' improved.\cr\cr #' #' \bold{Fit weighting}\cr #' #' If the option \code{fit.weights = TRUE} is chosen, weights are calculated using #' provided signal errors (Lx/Tx error): \deqn{fit.weights = 1/error/(sum(1/error))}\cr #' #' \bold{Error estimation using Monte Carlo simulation}\cr #' #' Error estimation is done using a Monte Carlo (MC) simulation approach. A set of Lx/Tx values is #' constructed by randomly drawing curve data from samled from normal #' distributions. The normal distribution is defined by the input values (mean #' = value, sd = value.error). Then, a growth curve fit is attempted for each #' dataset resulting in a new distribution of single De values. The \link{sd} #' of this distribution is becomes then the error of the De. With increasing #' iterations, the error value becomes more stable. \bold{Note:} It may take #' some calculation time with increasing MC runs, especially for the composed #' functions (\code{EXP+LIN} and \code{EXP+EXP}).\cr Each error estimation is #' done with the function of the chosen fitting method. \cr #' #' \bold{Subtitle information}\cr #' #' To avoid plotting the subtitle information, provide an empty user mtext \code{mtext = ""}. #' To plot any other subtitle text, use \code{mtext}. #' #' @param sample \code{\link{data.frame}} (\bold{required}): data frame with #' three columns for x=Dose,y=LxTx,z=LxTx.Error, y1=TnTx. The column for the #' test dose response is optional, but requires 'TnTx' as column name if used. For exponential #' fits at least three dose points (including the natural) should be provided. #' #' @param na.rm \code{\link{logical}} (with default): excludes \code{NA} values #' from the data set prior to any further operations. #' #' @param mode \code{\link{character}} (with default): selects calculation mode of the function. #' (A) \code{"interpolation"} (default) calculates the De by interpolation, #' (B) \code{"extrapolation"} calculates the De by extrapolation and #' (C) \code{"alternate"} calculates no De and just fits the data points. Please note that #' for option \code{"regenrative"} the first point is considered as natural dose #' #' @param fit.method \code{\link{character}} (with default): function used for #' fitting. Possible options are: \code{LIN}, \code{QDR}, \code{EXP}, \code{EXP OR LIN}, #' \code{EXP+LIN} or \code{EXP+EXP}. See details. #' #' @param fit.force_through_origin \code{\link{logical}} (with default) allow to force #' the fitted function through the origin. For \code{method = "EXP+EXP"} the function will #' go to the origin in either case, so this option will have no effect. #' #' @param fit.weights \code{\link{logical}} (with default): option whether the #' fitting is done with or without weights. See details. #' #' @param fit.includingRepeatedRegPoints \code{\link{logical}} (with default): #' includes repeated points for fitting (\code{TRUE}/\code{FALSE}). #' #' @param fit.NumberRegPoints \code{\link{integer}} (optional): set number of #' regeneration points manually. By default the number of all (!) regeneration #' points is used automatically. #' #' @param fit.NumberRegPointsReal \code{\link{integer}} (optional): if the #' number of regeneration points is provided manually, the value of the real, #' regeneration points = all points (repeated points) including reg 0, has to #' be inserted. #' #' @param fit.bounds \code{\link{logical}} (with default): set lower fit bounds #' for all fitting parameters to 0. Limited for the use with the fit methods #' \code{EXP}, \code{EXP+LIN} and \code{EXP OR LIN}. Argument to be inserted #' for experimental application only! #' #' @param NumberIterations.MC \code{\link{integer}} (with default): number of #' Monte Carlo simulations for error estimation. See details. #' #' @param output.plot \code{\link{logical}} (with default): plot output #' (\code{TRUE/FALSE}). #' #' @param output.plotExtended \code{\link{logical}} (with default): If #' \code{TRUE}, 3 plots on one plot area are provided: (1) growth curve, (2) #' histogram from Monte Carlo error simulation and (3) a test dose response #' plot. If \code{FALSE}, just the growth curve will be plotted. #' \bold{Requires:} \code{output.plot = TRUE}. #' #' @param output.plotExtended.single \code{\link{logical}} (with default): #' single plot output (\code{TRUE/FALSE}) to allow for plotting the results in #' single plot windows. Requires \code{output.plot = TRUE} and #' \code{output.plotExtended = TRUE}. #' #' @param cex.global \code{\link{numeric}} (with default): global scaling #' factor. #' #' @param txtProgressBar \code{\link{logical}} (with default): enables or disables txtProgressBar. #' If \code{verbose = FALSE} also no txtProgressBar is shown. #' #' @param verbose \code{\link{logical}} (with default): enables or disables terminal feedback. #' #' @param \dots Further arguments and graphical parameters to be passed. Note: #' Standard arguments will only be passed to the growth curve plot. Supported: #' \code{xlim}, \code{ylim}, \code{main}, \code{xlab}, \code{ylab} #' #' @return Along with a plot (so far wanted) an \code{RLum.Results} object is returned containing, #' the slot \code{data} contains the following elements:\cr #' #' \tabular{lll}{ #' \bold{DATA.OBJECT} \tab \bold{TYPE} \tab \bold{DESCRIPTION} \cr #' \code{..$De} : \tab \code{data.frame} \tab Table with De values \cr #' \code{..$De.MC} : \tab \code{numeric} \tab Table with De values from MC runs \cr #' \code{..$Fit} : \tab \code{\link{nls}} or \code{\link{lm}} \tab object from the fitting for \code{EXP}, #' \code{EXP+LIN} and \code{EXP+EXP}. In case of a resulting linear fit when using \code{LIN}, \code{QDR} or #' \code{EXP OR LIN} \cr #' \code{..$Formula} : \tab \code{\link{expression}} \tab Fitting formula as R expression \cr #' \code{..$call} : \tab \code{call} \tab The original function call\cr #' } #' #' @section Function version: 1.9.5 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France), \cr Michael Dietze, GFZ Potsdam (Germany) #' #' #' @seealso \code{\link{nls}}, \code{\linkS4class{RLum.Results}}, #' \code{\link{get_RLum}}, \code{\link[minpack.lm]{nlsLM}}, \code{\link{lm}}, \code{uniroot} #' #' @examples #' #' ##(1) plot growth curve for a dummy data.set and show De value #' data(ExampleData.LxTxData, envir = environment()) #' temp <- plot_GrowthCurve(LxTxData) #' get_RLum(temp) #' #' ##(1a) to access the fitting value try #' get_RLum(temp, data.object = "Fit") #' #' ##(2) plot the growth curve only - uncomment to use #' ##pdf(file = "~/Desktop/Growth_Curve_Dummy.pdf", paper = "special") #' plot_GrowthCurve(LxTxData) #' ##dev.off() #' #' ##(3) plot growth curve with pdf output - uncomment to use, single output #' ##pdf(file = "~/Desktop/Growth_Curve_Dummy.pdf", paper = "special") #' plot_GrowthCurve(LxTxData, output.plotExtended.single = TRUE) #' ##dev.off() #' #' ##(4) plot resulting function for given intervall x #' x <- seq(1,10000, by = 100) #' plot( #' x = x, #' y = eval(temp$Formula), #' type = "l" #' ) #' #' ##(5) plot using the 'extrapolation' mode #' LxTxData[1,2:3] <- c(0.5, 0.001) #' print(plot_GrowthCurve(LxTxData,mode = "extrapolation")) #' #' ##(6) plot using the 'alternate' mode #' LxTxData[1,2:3] <- c(0.5, 0.001) #' print(plot_GrowthCurve(LxTxData,mode = "alternate")) #' #' @export plot_GrowthCurve <- function( sample, na.rm = TRUE, mode = "interpolation", fit.method = "EXP", fit.force_through_origin = FALSE, fit.weights = TRUE, fit.includingRepeatedRegPoints = TRUE, fit.NumberRegPoints = NULL, fit.NumberRegPointsReal = NULL, fit.bounds = TRUE, NumberIterations.MC = 100, output.plot = TRUE, output.plotExtended = TRUE, output.plotExtended.single = FALSE, cex.global = 1, txtProgressBar = TRUE, verbose = TRUE, ... ) { ##1. check if sample is data.frame if(is.data.frame(sample)==FALSE){ stop("\n [plot_GrowthCurve()] Sample has to be of type data.fame!") } ##2. check if sample contains a least three rows if(length(sample[,1])<3 & fit.method != "LIN"){ stop("\n [plot_GrowthCurve()] At least two regeneration points are needed!") } ##2.1 check for inf data in the data.frame if(any(is.infinite(unlist(sample)))){ warning("[plot_GrowthCurve()] The input data contain at least one Inf value. NULL returned!") return(NULL) } ##2.2 check whether the dose value is equal all the time if(sum(abs(diff(sample[[1]]))) == 0){ try(stop("[plot_GrowthCurve()] All points have the same dose. NULL returned!", call. = FALSE)) return(NULL) } ## optionally, count and exclude NA values and print result if(na.rm == TRUE) { n.NA <- sum(!complete.cases(sample)) if (n.NA == 1) { warning("[plot_GrowthCurve()] 1 NA value excluded.") } else if (n.NA > 1) { warning(paste(" [plot_GrowthCurve()]", n.NA, "NA values excluded.")) } sample <- na.exclude(sample) ##Check if anything is left after removal if(nrow(sample) == 0){ warning("[plot_GrowthCurve()] Sorry, after NA removal nothing is left from the data set! NULL returned") return(NULL) } } ##3. verbose mode if(!verbose){ txtProgressBar <- FALSE } ##4. check for Inf values ##remove rownames from data.frame, as this could causes errors for the reg point calculation rownames(sample) <- NULL ##NULL values in the data.frame are not allowed for the y-column if(length(sample[sample[,2]==0,2])>0){ sample[sample[,2]==0,2]<-0.0001 warning(paste("[plot_GrowthCurve()]", length(sample[sample[,2]==0,2]), "values with 0 for Lx/Tx detected; replaced by 0.0001.")) } ##1. INPUT #1.0.1 calculate number of reg points if not set if(is.null(fit.NumberRegPoints)){ fit.NumberRegPoints<-length(sample[-1,1]) } if(is.null(fit.NumberRegPointsReal)){ fit.RegPointsReal <- which(!duplicated(sample[,1]) | sample[,1] != 0) fit.NumberRegPointsReal <- length(fit.RegPointsReal) } #1.1 Produce dataframe from input values, two options for different modes if(mode == "interpolation"){ xy<-data.frame(x=sample[2:(fit.NumberRegPoints+1),1],y=sample[2:(fit.NumberRegPoints+1),2]) y.Error<-sample[2:(fit.NumberRegPoints+1),3] }else if (mode == "extrapolation" || mode == "alternate") { xy <- data.frame( x = sample[1:(fit.NumberRegPoints+1),1], y = sample[1:(fit.NumberRegPoints+1),2]) y.Error <- sample[1:(fit.NumberRegPoints+1),3] }else{ stop("[plot_GrowthCurve()] Unknown input for argument 'mode'") } ##1.1.1 produce weights for weighted fitting if(fit.weights){ fit.weights <- 1 / abs(y.Error) / sum(1 / abs(y.Error)) if(is.na(fit.weights[1])){ fit.weights <- NULL warning("fit.weights set to NULL as the error column is invalid or 0.") } }else{ fit.weights <- rep(1, length(abs(y.Error))) } #1.2 Prepare data sets regeneration points for MC Simulation if (mode == "interpolation") { data.MC <- t(vapply( X = seq(2, fit.NumberRegPoints + 1, by = 1), FUN = function(x) { sample(rnorm( n = 10000, mean = sample[x, 2], sd = abs(sample[x, 3]) ), size = NumberIterations.MC, replace = TRUE) }, FUN.VALUE = vector("numeric", length = NumberIterations.MC) )) #1.3 Do the same for the natural signal data.MC.De <- numeric(NumberIterations.MC) data.MC.De <- sample(rnorm(10000, mean = sample[1, 2], sd = abs(sample[1, 3])), NumberIterations.MC, replace = TRUE) }else{ data.MC <- t(vapply( X = seq(1, fit.NumberRegPoints + 1, by = 1), FUN = function(x) { sample(rnorm( n = 10000, mean = sample[x, 2], sd = abs(sample[x, 3]) ), size = NumberIterations.MC, replace = TRUE) }, FUN.VALUE = vector("numeric", length = NumberIterations.MC) )) } #1.3 set x.natural x.natural <- vector("numeric", length = NumberIterations.MC) x.natural <- NA ##1.4 set initialise variables De <- NA De.Error <- NA ##============================================================================## # FITTING ---------------------------------------------------------------------- ##============================================================================## ##3. Fitting values with nonlinear least-squares estimation of the parameters ##set functions for fitting #EXP fit.functionEXP <- function(a,b,c,x) {a*(1-exp(-(x+c)/b))} fit.formulaEXP <- y ~ a * (1 - exp(-(x+c)/b)) #EXP+LIN fit.functionEXPLIN<-function(a,b,c,g,x) {a*(1-exp(-(x+c)/b)+(g*x))} fit.formulaEXPLIN <- y ~ a*(1-exp(-(x+c)/b)+(g*x)) #EXP+EXP fit.functionEXPEXP<-function(a1,a2,b1,b2,x){(a1*(1-exp(-(x)/b1)))+(a2*(1-exp(-(x)/b2)))} fit.formulaEXPEXP <- y ~ (a1*(1-exp(-(x)/b1)))+(a2*(1-exp(-(x)/b2))) ##input data for fitting; exclude repeated RegPoints if (fit.includingRepeatedRegPoints == FALSE) { data <- data.frame(x = xy[[1]][!duplicated(xy[[1]])], y = xy[[2]][!duplicated(xy[[1]])]) fit.weights <- fit.weights[!duplicated(xy[[1]])] data.MC <- data.MC[!duplicated(xy[[1]]),] xy <- xy[!duplicated(xy[[1]]),] }else{ data <- data.frame(xy) } ## for unknown reasons with only two points the nls() function is trapped in ## an endless mode, therefore the minimum length for data is 3 ## (2016-05-17) if((fit.method == "EXP" | fit.method == "EXP+LIN" | fit.method == "EXP+EXP" | fit.method == "EXP OR LIN") && length(data[,1])<=2){ ##set to LIN fit.method <- "LIN" warning("[plot_GrowthCurve()] fitting using an exponential term requires at least 3 dose points! fit.method set to 'LIN'") if(verbose){ if(verbose) message("[plot_GrowthCurve()] fit.method set to 'LIN', see warnings()") } } ##START PARAMETER ESTIMATION ##--------------------------------------------------------------------------## ##general setting of start parameters for fitting ##a - estimation for a a the maxium of the y-values (Lx/Tx) a <- max(data[,2]) ##b - get start parameters from a linear fit of the log(y) data ## (suppress the warning in case one parameter is negative) fit.lm <- lm(suppressWarnings(log(data$y))~data$x) b <- as.numeric(1/fit.lm$coefficients[2]) ##c - get start parameters from a linear fit - offset on x-axis fit.lm<-lm(data$y~data$x) c <- as.numeric(abs(fit.lm$coefficients[1]/fit.lm$coefficients[2])) #take slope from x - y scaling g <- max(data[,2]/max(data[,1])) #set D01 and D02 (in case of EXp+EXP) D01 <- NA D01.ERROR <- NA D02 <- NA D02.ERROR <- NA ##--------------------------------------------------------------------------## ##to be a little bit more flexible the start parameters varries within a normal distribution ##draw 50 start values from a normal distribution a start values if (fit.method != "LIN") { a.MC <- rnorm(50, mean = a, sd = a / 100) if (!is.na(b)) { b.MC <- rnorm(50, mean = b, sd = b / 100) } else{ b <- NA } c.MC <- rnorm(50, mean = c, sd = c / 100) g.MC <- rnorm(50, mean = g, sd = g / 1) ##set start vector (to avoid errors witin the loop) a.start <- NA b.start <- NA c.start <- NA g.start <- NA } ##--------------------------------------------------------------------------## #===========================================================================## #QDR# if (fit.method == "QDR"){ ##Do fitting with option to force curve through the origin if(fit.force_through_origin){ ##linear fitting ... polynomial fit <- lm(data$y ~ 0 + I(data$x) + I(data$x^2), weights = fit.weights) ##give function for uniroot De.fs <- function(x, y) { 0 + coef(fit)[1] * x + coef(fit)[2] * x ^ 2 - y } }else{ ##linear fitting ... polynomial fit <- lm(data$y ~ I(data$x) + I(data$x^2), weights = fit.weights) ##give function for uniroot De.fs <- function(x, y) { coef(fit)[1] + coef(fit)[2] * x + coef(fit)[3] * x ^ 2 - y } } ##solve and get De if (mode == "interpolation") { De.uniroot <- try(uniroot(De.fs, y = sample[1, 2], lower = 0, upper = max(sample[, 1]) * 1.5), silent = TRUE) if (!inherits(De.uniroot, "try-error")) { De <- round(De.uniroot$root, digits = 2) if (verbose) { if (mode != "alternate") { writeLines(paste0("[plot_GrowthCurve()] Fit: ", fit.method, " (", mode,") ", "| De = ", De)) } } } else{ if (verbose) writeLines("[plot_GrowthCurve()] no solution found for QDR fit") De <- NA } }else if (mode == "extrapolation"){ De.uniroot <- try(uniroot(De.fs, y = 0, lower = -1e06, upper = max(sample[, 1]) * 1.5), silent = TRUE) if (!inherits(De.uniroot, "try-error")) { De <- round(abs(De.uniroot$root), digits = 2) if (verbose) { if (mode != "alternate") { writeLines(paste0("[plot_GrowthCurve()] Fit: ", fit.method, " (", mode,") ", "| De = ", De)) } } } else{ if (verbose) writeLines("[plot_GrowthCurve()] no solution found for QDR fit") De <- NA } }else{ De <- NA } # +++++++++++++++++++++++++++++++++++++++++ ##set progressbar if(txtProgressBar){ cat("\n\t Run Monte Carlo loops for error estimation of the QDR fit\n") pb<-txtProgressBar(min=0,max=NumberIterations.MC, char="=", style=3) } #start loop for Monte Carlo Error estimation fit.MC <- sapply(1:NumberIterations.MC, function(i){ data <- data.frame(x=xy$x, y=data.MC[,i]) if(fit.force_through_origin){ ##linear fitting ... polynomial fit.MC <- lm(data$y ~ 0 + I(data$x) + I(data$x^2), weights = fit.weights) ##give function for uniroot De.fs.MC <- function(x, y) { 0 + coef(fit.MC)[1] * x + coef(fit.MC)[2] * x ^ 2 - y 0 + coef(fit.MC)[1] * x + coef(fit.MC)[2] * x ^ 2 - y } }else{ ##linear fitting ... polynomial fit.MC <- lm(data$y ~ I(data$x) + I(data$x^2), weights = fit.weights) ##give function for uniroot De.fs.MC <- function(x, y) { coef(fit.MC)[1] + coef(fit.MC)[2] * x + coef(fit.MC)[3] * x ^ 2 - y } } if (mode == "interpolation") { ##solve and get De De.uniroot.MC <- try(uniroot( De.fs.MC, y = data.MC.De[i], lower = 0, upper = max(sample[, 1]) * 1.5 ), silent = TRUE) if (!inherits(De.uniroot.MC, "try-error")) { De.MC <- round(De.uniroot.MC$root, digits = 2) } else{ De.MC <- NA } }else if (mode == "extrapolation"){ ##solve and get De De.uniroot.MC <- try(uniroot( De.fs.MC, y = 0, lower = -1e6, upper = max(sample[, 1]) * 1.5 ), silent = TRUE) if (!inherits(De.uniroot.MC, "try-error")) { De.MC <- round(abs(De.uniroot.MC$root), digits = 2) } else{ De.MC <- NA } }else{ De.MC <- NA } ##update progress bar if(txtProgressBar) setTxtProgressBar(pb, i) return(De.MC) }) if(txtProgressBar) close(pb) x.natural<- fit.MC } #===========================================================================## #EXP# if (fit.method=="EXP" | fit.method=="EXP OR LIN" | fit.method=="LIN"){ if((is.na(a) | is.na(b) | is.na(c)) && fit.method != "LIN"){ warning("[plot_GrowthCurve()] Fit could not applied for this data set. NULL returned!") return(NULL) } if(fit.method!="LIN"){ ##FITTING on GIVEN VALUES## # --use classic R fitting routine to fit the curve ##try to create some start parameters from the input values to make ## the fitting more stable for(i in 1:50){ a <- a.MC[i] b <- b.MC[i] c <- c.MC[i] fit.initial <- suppressWarnings(try(nls( y ~ fit.functionEXP(a, b, c, x), data = data, start = c(a = a, b = b, c = c), trace = FALSE, algorithm = "port", lower = c(a = 0, b > 0, c = 0), nls.control( maxiter = 100, warnOnly = TRUE, minFactor = 1 / 2048 ) ), silent = TRUE )) if(class(fit.initial)!="try-error"){ #get parameters out of it parameters<-(coef(fit.initial)) b.start[i]<-as.vector((parameters["b"])) a.start[i]<-as.vector((parameters["a"])) c.start[i]<-as.vector((parameters["c"])) } } ##used median as start parameters for the final fitting a <- median(na.exclude(a.start)) b <- median(na.exclude(b.start)) c <- median(na.exclude(c.start)) #FINAL Fit curve on given values fit <- try(minpack.lm::nlsLM( formula = fit.formulaEXP, data = data, start = list(a = a, b = b,c = c), weights = fit.weights, trace = FALSE, algorithm = "LM", lower = if (fit.bounds) { c(0,0,0) }else{ c(-Inf,-Inf,-Inf) }, upper = if (fit.force_through_origin) { c(Inf, Inf, 0) }else{ c(Inf, Inf, Inf) }, control = minpack.lm::nls.lm.control(maxiter = 500) ), silent = TRUE ) if (inherits(fit, "try-error") & inherits(fit.initial, "try-error")){ if(verbose) writeLines("[plot_GrowthCurve()] try-error for EXP fit") }else{ ##this is to avoid the singular convergence failure due to a perfect fit at the beginning ##this may happen especially for simulated data if(inherits(fit, "try-error") & !inherits(fit.initial, "try-error")){ fit <- fit.initial rm(fit.initial) } #get parameters out of it parameters <- (coef(fit)) b <- as.vector((parameters["b"])) a <- as.vector((parameters["a"])) c <- as.vector((parameters["c"])) #calculate De if(mode == "interpolation"){ De <- suppressWarnings(round(-c-b*log(1-sample[1,2]/a), digits=2)) }else if (mode == "extrapolation"){ De <- suppressWarnings(round(abs(-c-b*log(1-0/a)), digits=2)) }else{ De <- NA } #print D01 value D01<-round(b,digits=2) if (verbose) { if (mode != "alternate") { writeLines(paste0( "[plot_GrowthCurve()] Fit: ", fit.method, " (", mode, ")", " | De = ", De, " | D01 = ", D01 )) } } ##Monte Carlo Simulation # --Fit many curves and calculate a new De +/- De_Error # --take De_Error #set variables var.b<-vector(mode="numeric", length=NumberIterations.MC) var.a<-vector(mode="numeric", length=NumberIterations.MC) var.c<-vector(mode="numeric", length=NumberIterations.MC) #start loop for (i in 1:NumberIterations.MC) { ##set data set data <- data.frame(x = xy$x,y = data.MC[,i]) fit.MC <- try(minpack.lm::nlsLM( formula = fit.formulaEXP, data = data, start = list(a = a, b = b,c = c), weights = fit.weights, trace = FALSE, algorithm = "LM", lower = if (fit.bounds) { c(0,0,0) }else{ c(-Inf,-Inf,-Inf) }, upper = if (fit.force_through_origin) { c(Inf, Inf, 0) }else{ c(Inf, Inf, Inf) }, control = minpack.lm::nls.lm.control(maxiter = 500) ), silent = TRUE ) #get parameters out of it including error handling if (class(fit.MC)=="try-error") { x.natural[i] <- NA }else { #get parameters out parameters<-coef(fit.MC) var.b[i]<-as.vector((parameters["b"])) #D0 var.a[i]<-as.vector((parameters["a"])) #Imax var.c[i]<-as.vector((parameters["c"])) #calculate x.natural for error calculation if(mode == "interpolation"){ x.natural[i]<-suppressWarnings( round(-var.c[i]-var.b[i]*log(1-data.MC.De[i]/var.a[i]), digits=2)) }else if(mode == "extrapolation"){ x.natural[i]<-suppressWarnings( abs(-var.c[i]-var.b[i]*log(1-0/var.a[i]))) }else{ x.natural[i] <- NA } } }#end for loop ##write D01.ERROR D01.ERROR <- sd(var.b, na.rm = TRUE) ##remove values rm(var.b, var.a, var.c) }#endif::try-error fit }#endif:fit.method!="LIN" #======================================================================== #LIN# ##two options: just linear fit or LIN fit after the EXP fit failed #set fit object, if fit objekt was not set before if(exists("fit")==FALSE){fit<-NA} if ((fit.method=="EXP OR LIN" & class(fit)=="try-error") | fit.method=="LIN" | length(data[,1])<2) { ##Do fitting again as just allows fitting through the origin if(fit.force_through_origin){ fit.lm<-lm(data$y ~ 0 + data$x, weights = fit.weights) #calculate De if(mode == "interpolation"){ De <- round((sample[1,2]/fit.lm$coefficients[1]), digits=2) }else{ De <- 0 } }else{ fit.lm<-lm(data$y ~ data$x, weights = fit.weights) #calculate De if(mode == "interpolation"){ De <- round((sample[1,2]-fit.lm$coefficients[1])/fit.lm$coefficients[2], digits=2) }else if(mode == "extrapolation"){ De <- round(abs((0-fit.lm$coefficients[1])/fit.lm$coefficients[2]), digits= 2) } } ##remove vector labels De <- as.numeric(as.character(De)) if (verbose) { if (mode != "alternate") { writeLines(paste0( "[plot_GrowthCurve()] Fit: ", fit.method, " (", mode, ") ", "| De = ", De )) } } #start loop for Monte Carlo Error estimation for (i in 1:NumberIterations.MC) { data <- data.frame(x=xy$x, y=data.MC[,i]) if(fit.force_through_origin){ ##do fitting fit.lmMC <- lm(data$y ~ 0 + data$x, weights=fit.weights) #calculate x.natural if(mode == "interpolation"){ x.natural[i]<-round((data.MC.De[i]/fit.lmMC$coefficients[1]), digits=2) }else if (mode == "extrapolation"){ x.natural[i] <- 0 } }else{ ##do fitting fit.lmMC <- lm(data$y~ data$x, weights=fit.weights) #calculate x.natural if(mode == "interpolation"){ x.natural[i]<-round((data.MC.De[i]-fit.lmMC$coefficients[1])/ fit.lmMC$coefficients[2], digits=2) }else if (mode == "extrapolation"){ x.natural[i]<-round(abs((0-fit.lmMC$coefficients[1])/ fit.lmMC$coefficients[2]), digits=2) } } }#endfor::loop for MC #correct for fit.method fit.method<-"LIN" ##set fit object if(fit.method=="LIN"){fit<-fit.lm} }else{fit.method<-"EXP"}#endif::LIN }#end if EXP (this includes the LIN fit option) #=========================================================================== #=========================================================================== #EXP+LIN# else if (fit.method=="EXP+LIN") { ##try some start parameters from the input values to makes the fitting more stable for(i in 1:length(a.MC)){ a<-a.MC[i];b<-b.MC[i];c<-c.MC[i];g<-g.MC[i] ##---------------------------------------------------------## ##start: with EXP function fit.EXP<-try(nls(y~fit.functionEXP(a,b,c,x), data=data, start=c(a=a,b=b,c=c), trace=FALSE, algorithm="port", lower=c(a=0,b>10,c=0), nls.control(maxiter=100,warnOnly=FALSE,minFactor=1/1048) ),silent=TRUE) if(class(fit.EXP)!="try-error"){ #get parameters out of it parameters<-(coef(fit.EXP)) b<-as.vector((parameters["b"])) a<-as.vector((parameters["a"])) c<-as.vector((parameters["c"])) ##end: with EXP function ##---------------------------------------------------------## } fit<-try(nls(y~fit.functionEXPLIN(a,b,c,g,x), data=data, start=c(a=a,b=b,c=c,g=g), trace=FALSE, algorithm="port", lower = if(fit.bounds==TRUE){lower=c(a=0,b>10,c=0,g=0)}else{c()}, nls.control(maxiter=500,warnOnly=FALSE,minFactor=1/2048) #increase max. iterations ),silent=TRUE) if(class(fit)!="try-error"){ #get parameters out of it parameters<-(coef(fit)) b.start[i]<-as.vector((parameters["b"])) a.start[i]<-as.vector((parameters["a"])) c.start[i]<-as.vector((parameters["c"])) g.start[i]<-as.vector((parameters["g"])) } }##end for loop ##used mean as start parameters for the final fitting a<-median(na.exclude(a.start)) b<-median(na.exclude(b.start)) c<-median(na.exclude(c.start)) g<-median(na.exclude(g.start)) ##perform final fitting fit <- try(minpack.lm::nlsLM( formula = fit.formulaEXPLIN, data = data, start = list(a = a, b = b,c = c, g = g), weights = fit.weights, trace = FALSE, algorithm = "LM", lower = if (fit.bounds) { c(0,10,0,0) }else{ c(-Inf,-Inf,-Inf,-Inf) }, upper = if (fit.force_through_origin) { c(Inf, Inf, 0, Inf) }else{ c(Inf, Inf, Inf, Inf) }, control = minpack.lm::nls.lm.control(maxiter = 500) ), silent = TRUE ) #if try error stop calculation if(class(fit)!="try-error"){ #get parameters out of it parameters<-(coef(fit)) b<-as.vector((parameters["b"])) a<-as.vector((parameters["a"])) c<-as.vector((parameters["c"])) g<-as.vector((parameters["g"])) #problem: analytically it is not easy to calculate x, #use uniroot to solve that problem ... readjust function first if (mode == "interpolation") { f.unirootEXPLIN <- function(a, b, c, g, x, LnTn) { fit.functionEXPLIN(a, b, c, g, x) - LnTn } temp.De <- try(uniroot( f = f.unirootEXPLIN, interval = c(0, max(xy$x) * 1.5), tol = 0.001, a = a, b = b, c = c, g = g, LnTn = sample[1, 2], extendInt = "yes", maxiter = 3000 ), silent = TRUE) if (class(temp.De) != "try-error") { De <- round(temp.De$root, digits = 2) } else{ De <- NA } }else if(mode == "extrapolation"){ f.unirootEXPLIN <- function(a, b, c, g, x, LnTn) { fit.functionEXPLIN(a, b, c, g, x) - LnTn } temp.De <- try(uniroot( f = f.unirootEXPLIN, interval = c(-1e06, max(xy$x) * 1.5), tol = 0.001, a = a, b = b, c = c, g = g, LnTn = 0, extendInt = "yes", maxiter = 3000 ), silent = TRUE) if (class(temp.De) != "try-error") { De <- round(abs(temp.De$root), digits = 2) } else{ De <- NA } }else{ De <- NA } if (verbose) { if (mode != "alternate") { writeLines(paste0( "[plot_GrowthCurve()] Fit: ", fit.method, " (", mode, ")" , " | De = ", De )) } } ##Monte Carlo Simulation for error estimation # --Fit many curves and calculate a new De +/- De_Error # --take De_Error #set variables var.b <- vector(mode="numeric", length=NumberIterations.MC) var.a <- vector(mode="numeric", length=NumberIterations.MC) var.c <- vector(mode="numeric", length=NumberIterations.MC) var.g <- vector(mode="numeric", length=NumberIterations.MC) ##set progressbar if(txtProgressBar){ cat("\n\t Run Monte Carlo loops for error estimation of the EXP+LIN fit\n") pb<-txtProgressBar(min=0,max=NumberIterations.MC, char="=", style=3) } #start Monto Carlo loops for(i in 1:NumberIterations.MC){ data <- data.frame(x=xy$x,y=data.MC[,i]) ##perform MC fitting fit.MC <- try(minpack.lm::nlsLM( formula = fit.formulaEXPLIN, data = data, start = list(a = a, b = b,c = c, g = g), weights = fit.weights, trace = FALSE, algorithm = "LM", lower = if (fit.bounds) { c(0,10,0,0) }else{ c(-Inf,-Inf,-Inf, -Inf) }, control = minpack.lm::nls.lm.control(maxiter = 500) ), silent = TRUE ) #get parameters out of it including error handling if (class(fit.MC)=="try-error") { x.natural[i]<-NA }else { parameters <- coef(fit.MC) var.b[i] <- as.vector((parameters["b"])) var.a[i] <- as.vector((parameters["a"])) var.c[i] <- as.vector((parameters["c"])) var.g[i] <- as.vector((parameters["g"])) #problem: analytical it is not easy to calculate x, #use uniroot to solve this problem if (mode == "interpolation") { temp.De.MC <- try(uniroot( f = f.unirootEXPLIN, interval = c(0, max(xy$x) * 1.5), tol = 0.001, a = var.a[i], b = var.b[i], c = var.c[i], g = var.g[i], LnTn = data.MC.De[i] ), silent = TRUE) if (class(temp.De.MC) != "try-error") { x.natural[i] <- temp.De.MC$root } else{ x.natural[i] <- NA } } else if (mode == "extrapolation"){ temp.De.MC <- try(uniroot( f = f.unirootEXPLIN, interval = c(-1e6, max(xy$x) * 1.5), tol = 0.001, a = var.a[i], b = var.b[i], c = var.c[i], g = var.g[i], LnTn = 0 ), silent = TRUE) if (class(temp.De.MC) != "try-error") { x.natural[i] <- abs(temp.De.MC$root) } else{ x.natural[i] <- NA } }else{ x.natural[i] <- NA } } ##update progress bar if(txtProgressBar) setTxtProgressBar(pb, i) }#end for loop ##close if(txtProgressBar) close(pb) ##remove objects rm(var.b, var.a, var.c, var.g) }else{ #print message if (verbose) { if (mode != "alternate") { writeLines(paste0( "[plot_GrowthCurve()] Fit: ", fit.method, " | De = NA (fitting FAILED)" )) } } } #end if "try-error" Fit Method } #End if EXP+LIN #========================================================================== #=========================================================================== #EXP+EXP# else if (fit.method=="EXP+EXP") { a1.start <- NA a2.start <- NA b1.start <- NA b2.start <- NA ## try to create some start parameters from the input values to make the fitting more stable for(i in 1:50) { a1 <- a.MC[i];b1 <- b.MC[i]; a2 <- a.MC[i] / 2; b2 <- b.MC[i] / 2 fit.start <- try(nls( y ~ fit.functionEXPEXP(a1,a2,b1,b2,x), data = data, start = c( a1 = a1,a2 = a2,b1 = b1,b2 = b2 ), trace = FALSE, algorithm = "port", lower = c(a1 > 0,a2 > 0,b1 > 0,b2 > 0), nls.control( maxiter = 500,warnOnly = FALSE,minFactor = 1 / 2048 ) #increase max. iterations ),silent = TRUE) if (class(fit.start) != "try-error") { #get parameters out of it parameters <- coef(fit.start) a1.start[i] <- as.vector((parameters["a1"])) b1.start[i] <- as.vector((parameters["b1"])) a2.start[i] <- as.vector((parameters["a2"])) b2.start[i] <- as.vector((parameters["b2"])) } } ##use obtained parameters for fit input a1.start <- median(a1.start, na.rm = TRUE) b1.start <- median(b1.start, na.rm = TRUE) a2.start <- median(a2.start, na.rm = TRUE) b2.start <- median(b2.start, na.rm = TRUE) ##perform final fitting fit <- try(minpack.lm::nlsLM( formula = fit.formulaEXPEXP, data = data, start = list(a1 = a1, b1 = b1, a2 = a2, b2 = b2), weights = fit.weights, trace = FALSE, algorithm = "LM", lower = if (fit.bounds) { c(0,0,0,0) }else{ c(-Inf,-Inf,-Inf, -Inf) }, control = minpack.lm::nls.lm.control(maxiter = 500) ), silent = TRUE ) ##insert if for try-error if (class(fit)!="try-error") { #get parameters out of it parameters <- (coef(fit)) b1 <- as.vector((parameters["b1"])) b2 <- as.vector((parameters["b2"])) a1 <- as.vector((parameters["a1"])) a2 <- as.vector((parameters["a2"])) ##set D0 values D01 <- round(b1,digits = 2) D02 <- round(b2,digits = 2) #problem: analytically it is not easy to calculate x, use uniroot if (mode == "interpolation") { f.unirootEXPEXP <- function(a1, a2, b1, b2, x, LnTn) { fit.functionEXPEXP(a1, a2, b1, b2, x) - LnTn } temp.De <- try(uniroot( f = f.unirootEXPEXP, interval = c(0, max(xy$x) * 1.5), tol = 0.001, a1 = a1, a2 = a2, b1 = b1, b2 = b2, LnTn = sample[1, 2], extendInt = "yes", maxiter = 3000 ), silent = TRUE) if (class(temp.De) != "try-error") { De <- round(temp.De$root, digits = 2) } else{ De <- NA } ##remove object rm(temp.De) }else if (mode == "extrapolation"){ stop("[plot_GrowthCurve()] mode 'extrapolation' for this fitting method currently not supported!") } else{ De <- NA } #print D0 and De value values if(verbose){ if(mode != "alternate"){ writeLines(paste0("[plot_GrowthCurve()] Fit: ", fit.method, " | De = ", De, "| D01 = ",D01, " | D02 = ",D02)) } } ##Monte Carlo Simulation for error estimation # --Fit many curves and calculate a new De +/- De_Error # --take De_Error from the simulation # --comparison of De from the MC and original fitted De gives a value for quality #set variables var.b1<-vector(mode="numeric", length=NumberIterations.MC) var.b2<-vector(mode="numeric", length=NumberIterations.MC) var.a1<-vector(mode="numeric", length=NumberIterations.MC) var.a2<-vector(mode="numeric", length=NumberIterations.MC) ##progress bar if(txtProgressBar){ cat("\n\t Run Monte Carlo loops for error estimation of the EXP+EXP fit\n") pb<-txtProgressBar(min=0,max=NumberIterations.MC, initial=0, char="=", style=3) } #start Monto Carlo loops for (i in 1:NumberIterations.MC) { #update progress bar if(txtProgressBar) setTxtProgressBar(pb,i) data<-data.frame(x=xy$x,y=data.MC[,i]) ##perform final fitting fit.MC <- try(minpack.lm::nlsLM( formula = fit.formulaEXPEXP, data = data, start = list(a1 = a1, b1 = b1, a2 = a2, b2 = b2), weights = fit.weights, trace = FALSE, algorithm = "LM", lower = if (fit.bounds) { c(0,0,0,0) }else{ c(-Inf,-Inf,-Inf, -Inf) }, control = minpack.lm::nls.lm.control(maxiter = 500) ), silent = TRUE ) #get parameters out of it including error handling if (class(fit.MC)=="try-error") { x.natural[i]<-NA }else { parameters <- (coef(fit.MC)) var.b1[i] <- as.vector((parameters["b1"])) var.b2[i] <- as.vector((parameters["b2"])) var.a1[i] <- as.vector((parameters["a1"])) var.a2[i] <- as.vector((parameters["a2"])) #problem: analytically it is not easy to calculate x, here an simple approximation is made temp.De.MC <- try(uniroot( f = f.unirootEXPEXP, interval = c(0,max(xy$x) * 1.5), tol = 0.001, a1 = var.a1[i], a2 = var.a2[i], b1 = var.b1[i], b2 = var.b2[i], LnTn = data.MC.De[i] ), silent = TRUE) if (class(temp.De.MC) != "try-error") { x.natural[i] <- temp.De.MC$root }else{ x.natural[i] <- NA } } #end if "try-error" MC simulation } #end for loop ##write D01.ERROR D01.ERROR <- sd(var.b1, na.rm = TRUE) D02.ERROR <- sd(var.b2, na.rm = TRUE) ##remove values rm(var.b1, var.b2, var.a1, var.a2) }else{ #print message if(verbose){ writeLines(paste0("[plot_GrowthCurve()] Fit: ", fit.method, " | De = NA (fitting FAILED)")) } } #end if "try-error" Fit Method ##close if(txtProgressBar) if(exists("pb")){close(pb)} #=========================================================================== } #End if Fit Method #Get De values from Monto Carlo simulation #calculate mean and sd (ignore NaN values) De.MonteCarlo<-round(mean(na.exclude(x.natural)),digits=2) #De.Error is Error of the whole De (ignore NaN values) De.Error <- sd(na.exclude(x.natural)) ##choose format in dependency of the size of the error De.Error <- ifelse(De.Error <= 0.01, format(De.Error, scientific = TRUE, digits = 2), round(De.Error, digits = 2)) # Formula creation -------------------------------------------------------- if(!is(fit,"try-error") & !is.na(fit[1])){ if(fit.method == "EXP") { f <- parse(text = paste0(format(coef(fit)[1], scientific = TRUE), " * (1 - exp( - ( x + ", format(coef(fit)[3], scientific = TRUE), ") / ", format(coef(fit)[2], scientific = TRUE), "))")) } if(fit.method == "EXP+LIN") { f <- parse(text = paste0(format(coef(fit)[1], scientific = TRUE), " * (1-exp(-(x+", format(coef(fit)[3], scientific = TRUE), ") / ", format(coef(fit)[2], scientific = TRUE), ")+(", format(coef(fit)[4], scientific = TRUE), " * x))")) } if(fit.method == "EXP+EXP") { f <- parse(text = paste0(format(coef(fit)[1], scientific = TRUE), " * (1 - exp( -x / ", format(coef(fit)[3], scientific = TRUE), ")) + ", format(coef(fit)[2], scientific = TRUE), " * (1 - exp( -x / ", format(coef(fit)[4], scientific = TRUE), "))")) } if(fit.method == "LIN" & fit.force_through_origin) { f <- parse(text = paste0(format(fit.lm$coefficients[1], scientific = TRUE), " * x")) } if(fit.method == "LIN" & !fit.force_through_origin) { f <- parse(text = paste0(format(fit.lm$coefficients[2], scientific = TRUE), "* x + ", format(fit.lm$coefficients[1], scientific = TRUE))) } if(fit.method == "QDR" & fit.force_through_origin) { f <- parse(text = paste0(format(coef(fit)[1], scientific = TRUE), " * x ", " + ", format(coef(fit)[2], scientific = TRUE), " * x^2" )) } if(fit.method == "QDR" & !fit.force_through_origin) { f <- parse(text = paste0(format(coef(fit)[1], scientific = TRUE), " + ", format(coef(fit)[2], scientific = TRUE), " * x ", " + ", format(coef(fit)[3], scientific = TRUE), " * x^2" )) } }else{ f <- NA } ##============================================================================## # PLOTTING --------------------------------------------------------------------- ##============================================================================## ##5. Plotting if plotOutput==TRUE if(output.plot) { # Deal with extra arguments ----------------------------------------------- ##deal with addition arguments extraArgs <- list(...) main <- if("main" %in% names(extraArgs)) {extraArgs$main} else {"Growth curve"} xlab <- if("xlab" %in% names(extraArgs)) {extraArgs$xlab} else {"Dose [s]"} ylab <- if("ylab" %in% names(extraArgs)) {extraArgs$ylab} else { if(mode == "regenration"){ expression(L[x]/T[x]) }else{ "Luminescence [a.u.]" } } if("cex" %in% names(extraArgs)) {cex.global <- extraArgs$cex} ylim <- if("ylim" %in% names(extraArgs)) { extraArgs$ylim } else { if(fit.force_through_origin | mode == "extrapolation"){ c(0-max(y.Error),(max(xy$y)+if(max(xy$y)*0.1>1.5){1.5}else{max(xy$y)*0.2})) }else{ c(min(xy$y)-max(y.Error),(max(xy$y)+if(max(xy$y)*0.1>1.5){1.5}else{max(xy$y)*0.2})) } } xlim <- if("xlim" %in% names(extraArgs)) {extraArgs$xlim} else { if(mode != "extrapolation"){ c(0,(max(xy$x)+if(max(xy$x)*0.4>50){50}else{max(xy$x)*0.4})) }else{ if(!is.na(De)){ c(-De * 2,(max(xy$x)+if(max(xy$x)*0.4>50){50}else{max(xy$x)*0.4})) }else{ c(-min(xy$x) * 2,(max(xy$x)+if(max(xy$x)*0.4>50){50}else{max(xy$x)*0.4})) } } } fun <- if("fun" %in% names(extraArgs)) {extraArgs$fun} else {FALSE} ##set plot check plot_check <- NULL ##cheat the R check x<-NULL; rm(x) #PAR #open plot area if(output.plot== TRUE & output.plotExtended== TRUE & output.plotExtended.single == FALSE ){ ####grep recent plot parameter for later reset par.default.complex <- par(no.readonly = TRUE) on.exit(par(par.default.complex)) ##set new parameter layout(matrix(c(1,1,1,1,2,3), 3, 2, byrow=TRUE), respect=TRUE) par(cex=0.8*cex.global) }else{ par.default.single <- par(no.readonly = TRUE)$cex on.exit(par(cex = par.default.single)) par(cex=cex.global) } #PLOT #Plot input values ##Make selection to support manual number of reg points input if(exists("fit.RegPointsReal")==TRUE){ ##here the object sample has to be used otherwise the first regeneration point is not plotted. temp.xy.plot <- sample[fit.RegPointsReal,] }else{ temp.xy.plot <- xy[1:fit.NumberRegPointsReal,] } plot_check <- try(plot( temp.xy.plot[, 1:2], ylim = ylim, xlim = xlim, pch = 19, xlab = xlab, ylab = ylab ), silent = TRUE) if (!is(plot_check, "try-error")) { if(mode == "extrapolation"){ abline(v = 0, lty = 1, col = "grey") } #ADD HEADER title(main = main, line = 3) #CURVE #plot fitted curve if (fit.method == "EXP+LIN") { try(curve(a * (1 - exp(-(x + c) / b) + (g * x)), lwd = 1.5, add = TRUE)) } else if (fit.method == "LIN" & fit.force_through_origin) { curve(fit.lm$coefficients[1] * x, lwd = 1.5, add = TRUE) } else if (fit.method == "LIN") { curve(fit.lm$coefficients[2] * x + fit.lm$coefficients[1], lwd = 1.5, add = TRUE) } else if (fit.method == "QDR" & fit.force_through_origin) { curve(coef(fit)[1] * x + coef(fit)[2] * x ^ 2, lwd = 1.5, add = TRUE) } else if (fit.method == "QDR") { curve(coef(fit)[1] + coef(fit)[2] * x + coef(fit)[3] * x ^ 2, lwd = 1.5, add = TRUE) } else if (fit.method == "EXP") { try(curve(fit.functionEXP(a, b, c, x), lwd = 1.5, add = TRUE)) } else if (fit.method == "EXP+EXP") { try(curve(fit.functionEXPEXP(a1, a2, b1, b2, x), lwd = 1.5, add = TRUE)) } ##POINTS #Plot Reg0 and Repeated Points #Natural value if(mode == "interpolation"){ points(sample[1, 1:2], col = "red") segments(sample[1, 1], sample[1, 2] - sample[1, 3], sample[1, 1], sample[1, 2] + sample[1, 3], col = "red") }else if (mode == "extrapolation"){ points(x = -De, y = 0, col = "red") } #Repeated Point points(xy[which(duplicated(xy[, 1])), 1], xy[which(duplicated(xy[, 1])), 2], pch = 2) #Reg Point 0 points(xy[which(xy == 0), 1], xy[which(xy == 0), 2], pch = 1, cex = 1.5 * cex.global) ##ARROWS #y-error Bars segments(xy$x, xy$y - y.Error, xy$x, xy$y + y.Error) ##LINES #Insert Ln/Tn if (mode == "interpolation") { if (is.na(De)) { lines( c(0, max(sample[, 1]) * 2), c(sample[1, 2], sample[1, 2]), col = "red", lty = 2, lwd = 1.25 ) } else{ try(lines( c(0, De), c(sample[1, 2], sample[1, 2]), col = "red", lty = 2, lwd = 1.25 ), silent = TRUE) } try(lines(c(De, De), c(0, sample[1, 2]), col = "red", lty = 2, lwd = 1.25), silent = TRUE) try(points(De, sample[1, 2], col = "red", pch = 19), silent = TRUE) } else if (mode == "extrapolation"){ if(!is.na(De)){ lines(x = c(-De, -De), y = c(0, par()$usr[1]), col = "red", lty = 2) lines(y = c(0,0), x = c(0, -De), col = "red", lty = 2) } } ## check/set mtext mtext <- if ("mtext" %in% names(list(...))) { list(...)$mtext } else { if(mode != "alternate"){ substitute(D[e] == De, list(De = paste( De, "\u00B1", De.Error, " | fit: ", fit.method ))) }else{ "" } } ##TEXT #Insert fit and result try(mtext(side = 3, mtext, line = 0.5, cex = 0.8 * cex.global), silent = TRUE) #write error message in plot if De is NaN try(if (De == "NaN") { text( sample[2, 1], 0, "Error: De could not be calculated!", adj = c(0, 0), cex = 0.8, col = "red" ) }, silent = TRUE) ##LEGEND #plot legend if (mode == "interpolation") { legend( "topleft", c("REG point", "REG point repeated", "REG point 0"), pch = c(19, 2, 1), cex = 0.8 * cex.global, bty = "n" ) }else{ legend( "bottomright", c("Dose point", "Dose point rep.", "Dose point 0"), pch = c(19, 2, 1), cex = 0.8 * cex.global, bty = "n" ) } ##plot only if wanted if (output.plot == TRUE & output.plotExtended == TRUE) { ##HIST #try to plot histogramm of De values from the Monte Carlo simulation if (output.plotExtended.single != TRUE) { par(cex = 0.7 * cex.global) } ##(A) Calculate histogram data try(histogram <- hist(x.natural, plot = FALSE), silent = TRUE) #to avoid errors plot only if histogram exists if (exists("histogram") && length(histogram$counts) > 2) { ##calculate normal distribution curves for overlay norm.curve.x <- seq(min(x.natural, na.rm = TRUE), max(x.natural, na.rm = TRUE), length = 101) norm.curve.y <- dnorm( norm.curve.x, mean = mean(x.natural, na.rm = TRUE), sd = sd(x.natural, na.rm = TRUE) ) ##plot histogram histogram <- try(hist( x.natural, xlab = xlab, ylab = "Frequency", main = expression(paste(D[e], " from MC simulation")), freq = FALSE, border = "white", axes = FALSE, ylim = c(0, max(norm.curve.y)), sub = paste( "n = ", NumberIterations.MC, ", valid fits =", length(na.exclude(x.natural)) ), col = "grey" ), silent = TRUE) if (!is(histogram, "try-error")) { ##add axes axis(side = 1) axis( side = 2, at = seq(min(histogram$density), max(histogram$density), length = 5), labels = round(seq( min(histogram$counts), max(histogram$counts), length = 5 ), digits = 0) ) ##add norm curve lines(norm.curve.x, norm.curve.y, col = "red") ##add rug rug(x.natural) ##write De + Error from Monte Carlo simulation + write quality of error estimation try(mtext(side = 3, substitute(D[e[MC]] == De, list( De = paste( De.MonteCarlo, "\u00B1", De.Error, " | quality = ", round((1 - abs(De - De.MonteCarlo) / De) * 100, digits = 1), "%" ) )), cex = 0.6 * cex.global), silent = TRUE) }else{ plot_check <- histogram } } else { plot_check <- try(plot( NA, NA, xlim = c(0, 10), ylim = c(0, 10), main = expression(paste(D[e], " from Monte Carlo simulation"))), silent = TRUE ) if(!is(plot_check,"try-error")){ text(5, 5, "not available") } }#end ifelse ##PLOT #PLOT test dose response curve if available if not plot not available #plot Tx/Tn value for sensitiviy change if (!is(plot_check, "try-error")) { if ("TnTx" %in% colnames(sample) == TRUE) { plot( 1:length(sample[, "TnTx"]), sample[1:(length(sample[, "TnTx"])), "TnTx"] / sample[1, "TnTx"], xlab = "SAR cycle", ylab = expression(paste(T[n] / T[x])), main = "Test dose response", type = "o", pch = 20, ) ##LINES #plot 1 line lines(c(1, length(sample[, "TnTx"])), c(1, 1), lty = 2, col = "gray") } else { plot( NA, NA, xlim = c(0, 10), ylim = c(0, 10), main = "Test dose response" ) text(5, 5, "not available\n no TnTx column") }#end if else } ## FUN by R Luminescence Team if (fun == TRUE) { sTeve() } }#endif::output.plotExtended }#end if plotOutput ##reset graphic device if the plotting failed! if(is(plot_check, "try-error")){ try(stop("[plot_GrowthCurve()] Figure margins too large, nothing plotted, but results returned!", call. = FALSE),) dev.off() } } ##RETURN - return De values and parameter output <- try(data.frame( De = De, De.Error = De.Error, D01 = D01, D01.ERROR = D01.ERROR, D02 = D02, D02.ERROR = D02.ERROR, De.MC = De.MonteCarlo, Fit = fit.method ), silent = TRUE ) ##make RLum.Results object output.final <- set_RLum( class = "RLum.Results", data = list( De = output, De.MC = x.natural, Fit = fit, Formula = f ), info = list( call = sys.call() ) ) invisible(output.final) } Luminescence/R/RLum.Data.Curve-class.R0000644000176200001440000004047013125226556017141 0ustar liggesusers#' @include get_RLum.R set_RLum.R names_RLum.R length_RLum.R bin_RLum.Data.R smooth_RLum.R NULL #' Class \code{"RLum.Data.Curve"} #' #' Class for representing luminescence curve data. #' #' @name RLum.Data.Curve-class #' #' @docType class #' #' @slot recordType Object of class "character" containing the type of the curve (e.g. "TL" or "OSL") #' #' @slot curveType Object of class "character" containing curve type, allowed values are measured or predefined #' #' @slot data Object of class \code{\link{matrix}} containing curve x and y data. #' 'data' can also be of type \code{RLum.Data.Curve} to change object values without deconstructing the object. #' For example: \code{set_RLum(class = 'RLum.Data.Curve', #' data = Your.RLum.Data.Curve, recordType = 'never seen before')} #' would just change the recordType. Missing arguements the value is taken from the input object #' in 'data' (which is already an RLum.Data.Curve object in this example) #' #' #' @note The class should only contain data for a single curve. For additional #' elements the slot \code{info} can be used (e.g. providing additional heating #' ramp curve). Objects from the class \code{RLum.Data.Curve} are produced by other #' functions (partyl within \code{\linkS4class{RLum.Analysis}} objects), #' namely: \code{\link{Risoe.BINfileData2RLum.Analysis}}, \code{\link{read_XSYG2R}} #' #' @section Create objects from this Class: Objects can be created by calls of the form #' \code{set_RLum(class = "RLum.Data.Curve", ...)}. #' #' @section Class version: 0.5.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\linkS4class{RLum}}, \code{\linkS4class{RLum.Data}}, #' \code{\link{plot_RLum}}, \code{\link{merge_RLum}} #' #' @keywords classes #' #' @examples #' #' showClass("RLum.Data.Curve") #' #' ##set empty curve object #' set_RLum(class = "RLum.Data.Curve") #' #' @export setClass("RLum.Data.Curve", slots = list( recordType = "character", curveType = "character", data = "matrix" ), contains = "RLum.Data", prototype = list ( recordType = NA_character_, curveType = NA_character_, data = matrix(data = 0, ncol = 2) ) ) #################################################################################################### ###as() #################################################################################################### ##LIST ##COERCE RLum.Data.Curve >> list AND list >> RLum.Data.Curve #' as() - RLum-object coercion #' #' for \code{[RLum.Data.Curve]} #' #' \bold{[RLum.Data.Curve]}\cr #' #' \tabular{ll}{ #' \bold{from} \tab \bold{to}\cr #' \code{list} \tab \code{list} \cr #' \code{data.frame} \tab \code{data.frame}\cr #' \code{matrix} \tab \code{matrix} #' #' } #' #' @param from \code{\linkS4class{RLum}} or \code{\link{list}}, \code{\link{data.frame}}, \code{\link{matrix}} #' (\bold{required}): object to be coerced from #' #' @param to \code{\link{character}} (\bold{required}): class name to be coerced to #' #' @seealso \code{\link[methods]{as}} #' #' @note Due to the complex structure of the \code{RLum} objects itself a coercing to standard #' R data structures will be always loosely! #' #' @name as #' setAs("list", "RLum.Data.Curve", function(from,to){ new(to, recordType = "unkown curve type", curveType = NA_character_, data = matrix(unlist(from), ncol = 2), info = list()) }) setAs("RLum.Data.Curve", "list", function(from){ list(x = from@data[,1], y = from@data[,2]) }) ##DATA.FRAME ##COERCE RLum.Data.Curve >> data.frame AND data.frame >> RLum.Data.Curve setAs("data.frame", "RLum.Data.Curve", function(from,to){ new(to, recordType = "unkown curve type", curveType = NA_character_, data = as.matrix(from), info = list()) }) setAs("RLum.Data.Curve", "data.frame", function(from){ data.frame(x = from@data[,1], y = from@data[,2]) }) ##MATRIX ##COERCE RLum.Data.Curve >> matrix AND matrix >> RLum.Data.Curve setAs("matrix", "RLum.Data.Curve", function(from,to){ new(to, recordType = "unkown curve type", curveType = NA_character_, data = from, info = list()) }) setAs("RLum.Data.Curve", "matrix", function(from){ from@data }) #################################################################################################### ###show() #################################################################################################### #' @describeIn RLum.Data.Curve #' Show structure of \code{RLum.Data.Curve} object #' @export setMethod("show", signature(object = "RLum.Data.Curve"), function(object){ ##print information cat("\n [RLum.Data.Curve]") cat("\n\t recordType:", object@recordType) cat("\n\t curveType:", object@curveType) cat("\n\t measured values:", length(object@data[,1])) cat("\n\t .. range of x-values:", suppressWarnings(range(object@data[,1]))) cat("\n\t .. range of y-values:", suppressWarnings(min(object@data[,2], na.rm = TRUE)), suppressWarnings(max(object@data[,2], na.rm = TRUE)), if(anyNA(object@data[,2])){"(contains NA values)"}else{""} ) cat("\n\t additional info elements:", length(object@info)) #cat("\n\t\t >> names:", names(object@info)) } ) #################################################################################################### ###set_RLum() #################################################################################################### #' @describeIn RLum.Data.Curve #' Construction method for RLum.Data.Curve object. The slot info is optional #' and predefined as empty list by default. #' #' @param class [\code{set_RLum}] \code{\link{character}} (\bold{required}): name of the \code{RLum} class to create #' @param originator [\code{set_RLum}] \code{\link{character}} (automatic): contains the name of the calling function #' (the function that produces this object); can be set manually. #' @param .uid [\code{set_RLum}] \code{\link{character}} (automatic): sets an unique ID for this object #' using the internal C++ function \code{.create_UID}. #' @param .pid [\code{set_RLum}] \code{\link{character}} (with default): option to provide a parent id for nesting #' at will. #' @param recordType [\code{set_RLum}] \code{\link{character}} (optional): record type (e.g., "OSL") #' @param curveType [\code{set_RLum}] \code{\link{character}} (optional): curve type (e.g., "predefined" or "measured") #' @param data [\code{set_RLum}] \code{\link{matrix}} (\bold{required}): raw curve data. #' If \code{data} itself is a \code{RLum.Data.Curve}-object this can be used to re-construct the object #' (s. Details) #' @param info [\code{set_RLum}] \code{\link{list}} (optional): info elements #' #' @return #' #' \bold{\code{set_RLum}}\cr #' #' Returns an \code{\linkS4class{RLum.Data.Curve}} object. #' #' @export setMethod( "set_RLum", signature = signature("RLum.Data.Curve"), definition = function(class, originator, .uid, .pid, recordType = NA_character_, curveType = NA_character_, data = matrix(0, ncol = 2), info = list()) { ##The case where an RLum.Data.Curve object can be provided ##with this RLum.Data.Curve objects can be provided to be reconstructed if (is(data, "RLum.Data.Curve")) { ##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 missing .uid if(missing(.uid)){ .uid <- data@.uid } ##check for missing .pid if(missing(.pid)){ .pid <- data@.pid } ##check for missing originator if(missing(originator)){ originator <- data@originator } ##set empty class from object newRLumDataCurve <- new("RLum.Data.Curve") ##fill - this is the faster way, filling in new() costs ... newRLumDataCurve@recordType <- recordType newRLumDataCurve@curveType <- curveType newRLumDataCurve@data <- data@data newRLumDataCurve@info <- info newRLumDataCurve@originator <- originator newRLumDataCurve@.uid <- .uid newRLumDataCurve@.pid <- .pid return(newRLumDataCurve) }else{ ##set empty class form object newRLumDataCurve <- new("RLum.Data.Curve") ##fill - this is the faster way, filling in new() costs ... newRLumDataCurve@originator <- originator newRLumDataCurve@recordType <- recordType newRLumDataCurve@curveType <- curveType newRLumDataCurve@data <- data newRLumDataCurve@info <- info newRLumDataCurve@.uid <- .uid newRLumDataCurve@.pid <- .pid return(newRLumDataCurve) } } ) #################################################################################################### ###get_RLum() #################################################################################################### #' @describeIn RLum.Data.Curve #' Accessor method for RLum.Data.Curve object. The argument info.object is #' optional to directly access the info elements. If no info element name is #' provided, the raw curve data (matrix) will be returned. #' #' @param object [\code{show_RLum}][\code{get_RLum}][\code{length_RLum}][\code{names_RLum}] an object of #' class \code{\linkS4class{RLum.Data.Curve}} (\bold{required}) #' @param info.object [\code{get_RLum}] \code{\link{character}} (optional): name of the wanted info #' element #' #' @return #' #' \bold{\code{get_RLum}}\cr #' #' (1) A \code{\link{matrix}} with the curve values or \cr #' (2) only the info object if \code{info.object} was set.\cr #' #' @export setMethod("get_RLum", signature("RLum.Data.Curve"), definition = function(object, info.object = NULL) { ##Check if function is of type RLum.Data.Curve if(is(object, "RLum.Data.Curve") == FALSE){ stop("[get_RLum] Function valid for 'RLum.Data.Curve' objects only!") } ##if info.object == NULL just show the curve values if(!is.null(info.object)) { if(info.object %in% names(object@info)){ unlist(object@info[info.object]) }else{ ##check for entries if(length(object@info) == 0){ warning("[get_RLum] This RLum.Data.Curve object has no info objects! NULL returned!)") return(NULL) }else{ ##grep names temp.element.names <- paste(names(object@info), collapse = ", ") warning.text <- paste("[get_RLum] Invalid info.object name. Valid names are:", temp.element.names) warning(warning.text, call. = FALSE) return(NULL) } } }else{ object@data } }) #################################################################################################### ###length_RLum() #################################################################################################### #' @describeIn RLum.Data.Curve #' Returns the length of the curve object, which is the maximum of the #' value time/temperature of the curve (corresponding to the stimulation length) #' #' @return #' \bold{\code{length_RLum}}\cr #' #' Number of channels in the curve (row number of the matrix) #' #' @export setMethod("length_RLum", "RLum.Data.Curve", function(object){ max(object@data[,1]) }) #################################################################################################### ###names_RLum() #################################################################################################### #' @describeIn RLum.Data.Curve #' Returns the names info elements coming along with this curve object #' #' @return #' #' \bold{\code{names_RLum}}\cr #' #' Names of the info elements (slot \code{info}) #' #' @export setMethod("names_RLum", "RLum.Data.Curve", function(object){ names(object@info) }) #################################################################################################### ###bin_RLum.Data() #################################################################################################### #' @describeIn RLum.Data.Curve #' Allows binning of specific objects #' #' @param bin_size [\code{bin_RLum}] \code{\link{integer}} (with default): set number of channels #' used for each bin, e.g. \code{bin_size = 2} means that two channels are binned. #' #' @return #' #' \bold{\code{bin_RLum.Data}}\cr #' #' Same object as input, after applying the binning. #' #' @export setMethod(f = "bin_RLum.Data", signature = "RLum.Data.Curve", function(object, bin_size = 2) { ##check for invalid bin_size values if (!is.null(bin_size) && bin_size > 0) { ##set stepping vector stepping <- seq(1, nrow(object@data), by = bin_size) ##get bin vector bin_vector <- object@data[, 2] ##set desired length of the vector ##to avoid add effects later length(bin_vector) <- suppressWarnings(prod(dim(matrix( bin_vector, ncol = length(stepping) )))) ##define new matrix for binning bin_matrix <- matrix(bin_vector, ncol = length(stepping)) ##calcuate column sums and replace matrix ##this is much faster than anly apply loop object@data <- matrix(c(object@data[stepping], colSums(bin_matrix, na.rm = TRUE)), ncol = 2) ##set matrix return(set_RLum(class = "RLum.Data.Curve", data = object)) } else{ warning("Argument 'bin_size' invald, nothing was done!") ##just return the object return(object) } }) #################################################################################################### ###smooth_RLum() #################################################################################################### #' @describeIn RLum.Data.Curve #' Smoothing of RLum.Data.Curve objects using the function \code{\link[zoo]{rollmean}} or \code{\link[zoo]{rollmedian}}. #' In particular the internal function \code{.smoothing} is used. #' #' @param k [\code{smooth_RLum}] \code{\link{integer}} (with default): window for the rolling mean; must be odd for rollmedian. #' If nothing is set k is set automatically #' #' @param fill [\code{smooth_RLum}] \code{\link{numeric}} (with default): a vector defining the left and the right hand data #' #' @param align [\code{smooth_RLum}] \code{\link{character}} (with default): specifying whether the index of the result should be #' left- or right-aligned or centered (default) compared to the rolling window of observations, allowed #' \code{"right"}, \code{"center"} and \code{left} #' #' @param method [\code{smooth_RLum}] \code{\link{character}} (with default): defines which method should be applied for the #' smoothing: \code{"mean"} or \code{"median"} #' #' @return #' #' \bold{\code{smooth_RLum}}\cr #' #' Same object as input, after smoothing #' #' @export setMethod( f = "smooth_RLum", signature = "RLum.Data.Curve", function(object, k = NULL, fill = NA, align = "right", method = "mean") { object@data[,2] <- .smoothing( x = object@data[,2], k = k, fill = fill, align = align, method = method) ##return via set function to get a new id set_RLum(class = "RLum.Data.Curve", originator = "smooth_RLum", data = object) } ) Luminescence/R/plot_NRt.R0000644000176200001440000001742513125226556014771 0ustar liggesusers#' Visualise natural/regenerated signal ratios #' #' This function creates a Natural/Regenerated signal vs. time (NR(t)) plot #' as shown in Steffen et al. 2009 #' #' This function accepts the individual curve data in many different formats. If #' \code{data} is a \code{list}, each element of the list must contain a two #' column \code{data.frame} or \code{matrix} containing the XY data of the curves #' (time and counts). Alternatively, the elements can be objects of class #' \code{\linkS4class{RLum.Data.Curve}}. #' Input values can also be provided as a \code{data.frame} or \code{matrix} where #' the first column contains the time values and each following column contains #' the counts of each curve. #' #' @param data a \code{\link{list}}, \code{\link{data.frame}}, \code{\link{matrix}} or #' \code{\linkS4class{RLum.Analysis}} object (\bold{required}). X,Y data of measured values #' (time and counts). See details on individual data structure. #' #' @param log \code{\link{character}} (optional): logarithmic axes #' (\code{c("x", "y", "xy")}). #' #' @param smooth \code{\link{character}} (optional): apply data smoothing. Use #' \code{"rmean"} to calculate the rolling where \code{k} determines the width #' of the rolling window (see \code{\link{rollmean}}). #' \code{"spline"} applies a smoothing spline to each curve #' (see \code{\link{smooth.spline}}) #' #' @param k \code{\link{integer}} (with default): integer width of the rolling #' window. #' #' @param legend \code{\link{logical}} (with default): show or hide the plot legend. #' #' @param legend.pos \code{\link{character}} (with default): keyword specifying #' the position of the legend (see \code{\link{legend}}). #' #' @param ... further parameters passed to \code{\link{plot}} (also see \code{\link{par}}). #' #' #' @author Christoph Burow, University of Cologne (Germany) #' #' @seealso \code{\link{plot}} #' #' @return Returns a plot and \code{\linkS4class{RLum.Analysis}} object. #' #' @references #' Steffen, D., Preusser, F., Schlunegger, F., 2009. OSL quartz underestimation due to #' unstable signal components. Quaternary Geochronology, 4, 353-362. #' #' @examples #' #' ## load example data #' data("ExampleData.BINfileData", envir = environment()) #' #' ## EXAMPLE 1 #' #' ## convert Risoe.BINfileData object to RLum.Analysis object #' data <- Risoe.BINfileData2RLum.Analysis(object = CWOSL.SAR.Data, pos = 8, ltype = "OSL") #' #' ## extract all OSL curves #' allCurves <- get_RLum(data) #' #' ## keep only the natural and regenerated signal curves #' pos <- seq(1, 9, 2) #' curves <- allCurves[pos] #' #' ## plot a standard NR(t) plot #' plot_NRt(curves) #' #' ## re-plot with rolling mean data smoothing #' plot_NRt(curves, smooth = "rmean", k = 10) #' #' ## re-plot with a logarithmic x-axis #' plot_NRt(curves, log = "x", smooth = "rmean", k = 5) #' #' ## re-plot with custom axes ranges #' plot_NRt(curves, smooth = "rmean", k = 5, #' xlim = c(0.1, 5), ylim = c(0.4, 1.6), #' legend.pos = "bottomleft") #' #' ## re-plot with smoothing spline on log scale #' plot_NRt(curves, smooth = "spline", log = "x", #' legend.pos = "top") #' #' ## EXAMPLE 2 #' #' # you may also use this function to check whether all #' # TD curves follow the same shape (making it a TnTx(t) plot). #' posTD <- seq(2, 14, 2) #' curves <- allCurves[posTD] #' #' plot_NRt(curves, main = "TnTx(t) Plot", #' smooth = "rmean", k = 20, #' ylab = "TD natural / TD regenerated", #' xlim = c(0, 20), legend = FALSE) #' #' ## EXAMPLE 3 #' #' # extract data from all positions #' data <- lapply(1:24, FUN = function(pos) { #' Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos = pos, ltype = "OSL") #' }) #' #' # get individual curve data from each aliquot #' aliquot <- lapply(data, get_RLum) #' #' # set graphical parameters #' par(mfrow = c(2, 2)) #' #' # create NR(t) plots for all aliquots #' for (i in 1:length(aliquot)) { #' plot_NRt(aliquot[[i]][pos], #' main = paste0("Aliquot #", i), #' smooth = "rmean", k = 20, #' xlim = c(0, 10), #' cex = 0.6, legend.pos = "bottomleft") #' } #' #' # reset graphical parameters #' par(mfrow = c(1, 1)) #' #' #' @export plot_NRt <- function(data, log = FALSE, smooth = c("none", "spline", "rmean"), k = 3, legend = TRUE, legend.pos = "topright", ...) { ## DATA INPUT EVALUATION ----- if (inherits(data, "list")) { if (length(data) < 2) stop(paste("The provided list only contains curve data of the natural signal"), call. = FALSE) if (all(sapply(data, class) == "RLum.Data.Curve")) curves <- lapply(data, get_RLum) } else if (inherits(data, "data.frame") || inherits(data, "matrix")) { if (ncol(data) < 3) stop(paste("The provided", class(data), "only contains curve data of the natural signal"), call. = FALSE) if (is.matrix(data)) data <- as.data.frame(data) curves <- apply(data[2:ncol(data)], MARGIN = 2, function(curve) { data.frame(data[ ,1], curve) }) } else if (inherits(data, "RLum.Analysis")) { RLum.objects <- get_RLum(data) if (!any(sapply(RLum.objects, class) == "RLum.Data.Curve")) stop(paste("The provided RLum.Analysis object must exclusively contain RLum.Data.Curve objects."), call. = FALSE) curves <- lapply(RLum.objects, get_RLum) if (length(curves) < 2) stop(paste("The provided RLum.Analysis object only contains curve data of the natural signal"), call. = FALSE) } ## BASIC SETTINGS ------ natural <- curves[[1]] regCurves <- curves[2:length(curves)] time <- curves[[1]][ ,1] ## DATA TRANSFORMATION ----- # calculate ratios NR <- lapply(regCurves, FUN = function(reg, nat) { nat[ ,2] / reg[ ,2] }, natural) # smooth spline if (smooth[1] == "spline") { NR <- lapply(NR, function(nr) { smooth.spline(nr)$y }) } if (smooth[1] == "rmean") { NR <- lapply(NR, function(nr) { zoo::rollmean(nr, k) }) time <- zoo::rollmean(time, k) } # normalise data NRnorm <- lapply(NR, FUN = function(nr) { nr / nr[1] }) ## EXTRA ARGUMENTS ----- # default values settings <- list( xlim = if (log == "x" || log == "xy") c(0.1, max(time)) else c(0, max(time)), ylim = range(pretty(c(min(sapply(NRnorm, min)), max(sapply(NRnorm, max))))), xlab = "Time [s]", ylab = "Natural signal / Regenerated signal", cex = 1L, main = "NR(t) Plot") # override defaults with user settings settings <- modifyList(settings, list(...)) ## PLOTTING ---------- # set graphical parameter par(cex = settings$cex) # empty plot if (is.na(pmatch(log, c("x", "y", "xy")))) log <- "" do.call(plot, modifyList(list(x = NA, y = NA, log = log, xaxs = "i", yaxs = "i"), settings)) # horizontal line abline(h = 1, lty = 3, col = "grey") col <- 1:length(NRnorm) # add N/R lines mapply(FUN = function(curve, col) { points(time, curve, type = "l", col = col) }, NRnorm, col) # add legend if (legend) { labels <- paste0("N/R", 1:length(NRnorm)) ncol <- ifelse(length(NRnorm) > 4, ceiling(length(NRnorm) / 4) , 1) legend(legend.pos, legend = labels, col = col, lty = 1, ncol = ncol, cex = 0.8, bty = "n") } ## RETURN VALUES ---- obj <- set_RLum("RLum.Analysis", protocol = "UNKNOWN", records = mapply(FUN = function(curve, id) { set_RLum("RLum.Data.Curve", recordType = paste0("N/R", id), curveType = "NRt", data = matrix(c(time, curve), ncol = 2), info = list( data = curves, call = sys.call(-6L), args = as.list(sys.call(-6L)[-1]) )) }, NRnorm, seq_len(length(NRnorm))) ) invisible(obj) } Luminescence/R/apply_CosmicRayRemoval.R0000644000176200001440000002413313125226556017646 0ustar liggesusers#' Function to remove cosmic rays from an RLum.Data.Spectrum S4 class object #' #' The function provides several methods for cosmic ray removal and spectrum #' smoothing for an RLum.Data.Spectrum S4 class object #' #' \bold{\code{method = "Pych"}} \cr #' #' This method applies the cosmic-ray removal algorithm described by Pych #' (2003). Some aspects that are different to the publication: \itemize{ #' \item For interpolation between neighbouring values the median and not the #' mean is used. \item The number of breaks to construct the histogram is set #' to: \code{length(number.of.input.values)/2} } For further details see #' references below. #' #' \bold{\code{method = "smooth"}} \cr #' #' Method uses the function \code{\link{smooth}} to remove cosmic rays.\cr #' #' Arguments that can be passed are: \code{kind}, \code{twiceit}\cr #' #' \bold{\code{method = "smooth.spline"}} \cr Method uses the function #' \code{\link{smooth.spline}} to remove cosmic rays.\cr Arguments that can be #' passed are: \code{spar}\cr #' #' \bold{How to combine methods?}\cr #' #' Different methods can be combined by applying the method repeatedly to the #' dataset (see example). #' #' @param object \code{\linkS4class{RLum.Data.Spectrum}} (\bold{required}): S4 #' object of class \code{RLum.Data.Spectrum} #' #' @param method \code{\link{character}} (with default): Defines method that is #' applied for cosmic ray removal. Allowed methods are \code{smooth}, the default, #' (\code{\link{smooth}}), \code{smooth.spline} (\code{\link{smooth.spline}}) #' and \code{Pych}. See details for further information. #' #' @param method.Pych.smoothing \code{\link{integer}} (with default): Smoothing #' parameter for cosmic ray removal according to Pych (2003). The value defines #' how many neighboring values in each frame are used for smoothing (e.g., #' \code{2} means that the two previous and two following values are used). #' #' @param method.Pych.threshold_factor \code{\link{numeric}} (with default): Threshold #' for zero-bins in the histogram. Small values mean that more peaks are removed, but signal #' might be also affected by this removal. #' #' @param MARGIN \code{\link{integer}} (with default): on which part the function cosmic ray removal #' should be applied on: 1 = along the time axis (line by line), 2 = along the wavelength axis (column by #' column). Note: This argument currently only affects the methods \code{smooth} and \code{smooth.spline} #' #' @param verbose \code{\link{logical}} (with default): Option to suppress #' terminal output., #' #' @param plot \code{\link{logical}} (with default): If \code{TRUE} the #' histograms used for the cosmic-ray removal are returned as plot including #' the used threshold. Note: A separat plot is returned for each frame! #' Currently only for \code{method = "Pych"} a graphical output is provided. #' #' @param \dots further arguments and graphical parameters that will be passed #' to the \code{smooth} function. #' #' @return Returns same object as input #' (\code{\linkS4class{RLum.Data.Spectrum}}) #' #' @note - #' #' @section Function version: 0.2.1 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\linkS4class{RLum.Data.Spectrum}}, \code{\link{smooth}}, #' \code{\link{smooth.spline}}, \code{\link{apply_CosmicRayRemoval}} #' #' @references Pych, W., 2003. A Fast Algorithm for Cosmic-Ray Removal from #' Single Images. Astrophysics 116, 148-153. #' \url{http://arxiv.org/pdf/astro-ph/0311290.pdf?origin=publication_detail} #' #' @keywords manip #' #' @examples #' #' #' ##(1) - use with your own data and combine (uncomment for usage) #' ## run two times the default method and smooth with another method #' ## your.spectrum <- apply_CosmicRayRemoval(your.spectrum, method = "Pych") #' ## your.spectrum <- apply_CosmicRayRemoval(your.spectrum, method = "Pych") #' ## your.spectrum <- apply_CosmicRayRemoval(your.spectrum, method = "smooth") #' #' @export apply_CosmicRayRemoval <- function( object, method = "smooth", method.Pych.smoothing = 2, method.Pych.threshold_factor = 3, MARGIN = 2, verbose = FALSE, plot = FALSE, ... ){ # Integrity check ----------------------------------------------------------- ##check if object is of class RLum.Data.Spectrum if(class(object) != "RLum.Data.Spectrum"){ stop("[apply_CosmicRayRemoval()] Input object is not of type RLum.Data.Spectrum") } ##deal with addition arguments extraArgs <- list(...) kind <- if("kind" %in% names(extraArgs)) {extraArgs$kind} else {"3RS3R"} twiceit <- if("twiceit" %in% names(extraArgs)) {extraArgs$twiceit} else {TRUE} spar <- if("spar" %in% names(extraArgs)) {extraArgs$spar} else {NULL} # Apply method ------------------------------------------------------------ ## +++++++++++++++++++++++++++++++++++ (smooth) ++++++++++++++++++++++++++++## if(method == "smooth"){ ##apply smooth object.data.temp.smooth <- apply( X = object@data, MARGIN = MARGIN, FUN = stats::smooth, kind = kind, twiceit = twiceit ) ##rotate output matrix if necessary if(MARGIN == 1){ object.data.temp.smooth <- t(object.data.temp.smooth) } ## +++++++++++++++++++++++++++++++++++ (smooth.spline) +++++++++++++++++++++## }else if(method == "smooth.spline"){ ##write the function in a new function to acess the data more easily temp_smooth.spline <- function(x, spar){ stats::smooth.spline(x, spar = spar)$y } ##apply smooth.spline object.data.temp.smooth <- apply( X = object@data, MARGIN = MARGIN, FUN = temp_smooth.spline, spar = spar ) ##rotate output matrix if necessary if(MARGIN == 1){ object.data.temp.smooth <- t(object.data.temp.smooth) } ## +++++++++++++++++++++++++++++++++++ (Pych) ++++++++++++++++++++++++++++++## }else if(method == "Pych"){ ## grep data matrix object.data.temp <- object@data ## apply smoothing object.data.temp.smooth <- sapply(X = 1:ncol(object.data.temp), function(x){ ##(1) - calculate sd for each subframe temp.sd <- sd(object.data.temp[,x]) ##(2) - correct estimation of sd by 1-sigma clipping temp.sd.corr <- sd(object.data.temp[ object.data.temp[,x] >= (mean(object.data.temp[,x]) - temp.sd) & object.data.temp[,x] <= (mean(object.data.temp[,x]) + temp.sd) , x]) ##(3) - construct histogram of count distribution temp.hist <- hist(object.data.temp[,x], breaks = length(object.data.temp[,x])/2, plot = FALSE) ##(4) - find mode of the histogram (e.g. peak) temp.hist.max <- which.max(temp.hist$counts) ##(5) - find gaps in the histogram (bins with zero value) temp.hist.zerobin <- which(temp.hist$counts == 0) ##(5.1) ##select just values right from the peak temp.hist.zerobin <- temp.hist.zerobin[ (temp.hist.max[1] + 1):length(temp.hist.zerobin)] ##(5.2) ##select non-zerobins temp.hist.nonzerobin <- which(temp.hist$counts != 0) temp.hist.nonzerobin <- temp.hist.nonzerobin[ temp.hist.nonzerobin >= (temp.hist.zerobin[1]-1)] ##(6) - find the first gap which is wider than the threshold temp.hist.nonzerobin.diff <- diff( temp.hist$breaks[temp.hist.nonzerobin]) ## select the first value where the thershold is reached ## factor 3 is defined by Pych (2003) temp.hist.thres <- which( temp.hist.nonzerobin.diff >= method.Pych.threshold_factor * temp.sd.corr)[1] ##(7) - use counts above the threshold and recalculate values ## on all further values if(!is.na(temp.hist.thres)){ object.data.temp[,x] <- sapply(1:nrow(object.data.temp), function(n){ if(c(n + method.Pych.smoothing) <= nrow(object.data.temp) & (n - method.Pych.smoothing) >= 0){ ifelse( object.data.temp[n,x] >= temp.hist$breaks[temp.hist.thres], median(object.data.temp[(n-method.Pych.smoothing): (n+method.Pych.smoothing),x]), object.data.temp[n,x]) }else{ object.data.temp[n,x] } }) } ##(8) - return histogram used for the removal as plot if(plot){ plot(temp.hist, xlab = "Signal intensity [a.u.]", main = "Cosmic-ray removal histogram") abline(v = temp.hist$breaks[temp.hist.thres], col = "red") if(!is.na(temp.hist$breaks[temp.hist.thres])){ legend("topright", "threshold" ,lty = 1, lwd = 1, col = "red", bty = "n") mtext(side = 3, paste0("Frame: ", x, " (", colnames(object.data.temp)[x], ")")) }else{ mtext(side = 3, paste0("Frame: ", x, " (", colnames(object.data.temp)[x], ") - no threshold applied!")) } } ##(9) - return information on the amount of removed cosmic-rays if(verbose){ #sum up removed counts values above the threshold sum.corrected.channels <- try( sum(temp.hist$counts[temp.hist.thres:length(temp.hist$counts)]), silent = TRUE) if(is(sum.corrected.channels)[1] == "try-error"){sum.corrected.channels <- 0} cat("[apply_CosmicRayRemoval()] >> ") cat(paste(sum.corrected.channels, " channels corrected in frame ", x, "\n", sep = "")) } ##return object return(object.data.temp[,x]) })#end loop }else{ stop("[apply_CosmicRayRemoval()] Unkown method for cosmic ray removal.") } # Correct row and column names -------------------------------------------- colnames(object.data.temp.smooth) <- colnames(object@data) rownames(object.data.temp.smooth) <- rownames(object@data) # Return Output------------------------------------------------------------ temp.output <- set_RLum( class = "RLum.Data.Spectrum", recordType = object@recordType, curveType = object@curveType, data = object.data.temp.smooth, info = object@info) invisible(temp.output) } Luminescence/R/convert_PSL2CSV.R0000644000176200001440000000541413125226556016057 0ustar liggesusers#' Export PSL-file(s) to CSV-files #' #' This function is a wrapper function around the functions \code{\link{read_PSL2R}} and #' \code{\link{write_RLum2CSV}} and it imports an PSL-file (SUERC portable OSL reader file format) #' and directly exports its content to CSV-files. #' If nothing is set for the argument \code{path} (\code{\link{write_RLum2CSV}}) the input folder will #' become the output folder. #' #' @param file \code{\link{character}} (\bold{required}): name of the PSL-file to be converted to CSV-files #' #' @param \dots further arguments that will be passed to the function \code{\link{read_PSL2R}} and \code{\link{write_RLum2CSV}} #' #' @return The function returns either a CSV-file (or many of them) or for the option \code{export = FALSE} #' a list comprising objects of type \code{link{data.frame}} and \code{\link{matrix}} #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data}}, \code{\linkS4class{RLum.Results}}, #' \code{\link[utils]{write.table}}, \code{\link{write_RLum2CSV}}, \code{\link{read_PSL2R}} #' #' @keywords IO #' #' @examples #' #' \dontrun{ #' ##select your BIN-file #' file <- file.choose() #' #' ##convert #' convert_PSL2CSV(file) #' #' } #' #' @export convert_PSL2CSV <- function( file, ... ){ # General tests ------------------------------------------------------------------------------- ##file is missing? if(missing(file)){ stop("[convert_PSL2R()] file is missing!", call. = FALSE) } ##set input arguments convert_PSL2R_settings.default <- list( drop_bg = FALSE, as_decay_curve = TRUE, smooth = FALSE, merge = FALSE, export = TRUE ) ##modify list on demand convert_PSL2R_settings <- modifyList(x = convert_PSL2R_settings.default, val = list(...)) # Import file --------------------------------------------------------------------------------- if(!inherits(file, "RLum")){ object <- read_PSL2R( file = file, drop_bg = convert_PSL2R_settings$drop_bg, as_decay_curve = convert_PSL2R_settings$as_decay_curve, smooth = convert_PSL2R_settings$smooth, merge = convert_PSL2R_settings$merge ) }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_PSL2R_settings$export), list(...)) arguments[duplicated(names(arguments))] <- NULL ##this if-condition prevents NULL in the terminal if(convert_PSL2R_settings$export == TRUE){ invisible(do.call("write_RLum2CSV", arguments)) }else{ do.call("write_RLum2CSV", arguments) } } Luminescence/R/RLum.Results-class.R0000644000176200001440000002735013125226556016650 0ustar liggesusers#' @include get_RLum.R set_RLum.R length_RLum.R names_RLum.R NULL #' Class \code{"RLum.Results"} #' #' Object class contains results data from functions (e.g., \code{\link{analyse_SAR.CWOSL}}). #' #' @name RLum.Results-class #' #' @docType class #' #' @slot data Object of class "list" containing output data #' #' @note The class is intended to store results from functions to be used by #' other functions. The data in the object should always be accessed by the #' method \code{get_RLum}. #' #' @section Objects from the Class: Objects can be created by calls of the form #' \code{new("RLum.Results", ...)}. #' #' @section Class version: 0.5.1 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\linkS4class{RLum}}, \code{\link{plot_RLum}}, \code{\link{merge_RLum}} #' #' @keywords classes methods #' #' @examples #' #' showClass("RLum.Results") #' #' ##create an empty object from this class #' set_RLum(class = "RLum.Results") #' #' ##use another function to show how it works #' #' ##Basic calculation of the dose rate for a specific date #' dose.rate <- calc_SourceDoseRate( #' measurement.date = "2012-01-27", #' calib.date = "2014-12-19", #' calib.dose.rate = 0.0438, #' calib.error = 0.0019) #' #' ##show object #' dose.rate #' #' ##get results #' get_RLum(dose.rate) #' #' ##get parameters used for the calcualtion from the same object #' get_RLum(dose.rate, data.object = "parameters") #' #' ##alternatively objects can be accessed using S3 generics, such as #' dose.rate$parameters #' #' @export setClass( Class = "RLum.Results", slots = list(data = "list"), contains = "RLum", prototype = list (data = list()) ) #################################################################################################### ###as() #################################################################################################### ##LIST ##COERCE RLum.Results >> list AND list >> RLum.Results #' as() - RLum-object coercion #' #' for \code{[RLum.Results]} #' #' \bold{[RLum.Results]}\cr #' #' \tabular{ll}{ #' \bold{from} \tab \bold{to}\cr #' \code{list} \tab \code{list}\cr #' } #' #' Given that the \code{\link{list}} consits of \code{\linkS4class{RLum.Results}} objects. #' #' @name as #' #' setAs("list", "RLum.Results", function(from,to){ new(to, orginator = "coercion", data = from) }) setAs("RLum.Results", "list", function(from){ from@data }) #################################################################################################### ###show() #################################################################################################### #' @describeIn RLum.Results #' Show structure of \code{RLum.Results} object #' @export setMethod("show", signature(object = "RLum.Results"), function(object) { ##data elements temp.names <- names(object@data) if (length(object) > 0) { temp.type <- sapply(1:length(object@data), function(x) { paste("\t .. $", temp.names[x], " : ", is(object@data[[x]])[1], sep = "") }) } else{ temp.type <- paste0("\t .. $", temp.names, " : ", is(object@data)[1]) } temp.type <- paste(temp.type, collapse = "\n") ##print information cat("\n [RLum.Results]") cat("\n\t originator: ", object@originator, "()", sep = "") cat("\n\t data:", length(object@data)) cat("\n", temp.type) cat("\n\t additional info elements: ", length(object@info)) }) #################################################################################################### ###set_RLum() #################################################################################################### #' @describeIn RLum.Results #' Construction method for an RLum.Results object. #' #' @param class [\code{set_RLum}] \code{\link{character}} \bold{(required)}: name of the \code{RLum} class to create #' @param originator [\code{set_RLum}] \code{\link{character}} (automatic): contains the #' name of the calling function #' (the function that produces this object); can be set manually. #' @param .uid [\code{set_RLum}] \code{\link{character}} (automatic): sets an unique ID for this object #' using the internal C++ function \code{.create_UID}. #' @param .pid [\code{set_RLum}] \code{\link{character}} (with default): option to provide a parent id for nesting #' at will. #' @param data [\code{set_RLum}] \code{\link{list}} (optional): a list containing the data to #' be stored in the object #' @param info [\code{set_RLum}] \code{\link{list}} (optional): a list containing additional #' info data for the object #' @return #' #' \bold{\code{set_RLum}}:\cr #' #' Returns an object from the class \code{\linkS4class{RLum.Results}}\cr #' #' @export setMethod("set_RLum", signature = signature("RLum.Results"), function(class, originator, .uid, .pid, data = list(), info = list()) { ##create new class newRLumReuslts <- new("RLum.Results") ##fill object newRLumReuslts@originator <- originator newRLumReuslts@data <- data newRLumReuslts@info <- info newRLumReuslts@.uid <- .uid newRLumReuslts@.pid <- .pid return(newRLumReuslts) }) #################################################################################################### ###get_RLum() #################################################################################################### #' @describeIn RLum.Results #' Accessor method for RLum.Results object. The argument data.object allows #' directly accessing objects delivered within the slot data. The default #' return object depends on the object originator (e.g., \code{fit_LMCurve}). #' If nothing is specified always the first \code{data.object} will be returned. #' #' Note: Detailed specification should be made in combination with the originator slot in the #' receiving function if results are pipped. #' #' @param object [\code{get_RLum}] \code{\linkS4class{RLum.Results}} (required): an object of class #' \code{\linkS4class{RLum.Results}} to be evaluated #' #' @param data.object [\code{get_RLum}] \code{\link{character}} or #' \code{\link{numeric}}: name or index of the data slot to be returned #' #' @param info.object [\code{get_RLum}] \code{\link{character}} (optional): name of the wanted info #' element #' #' @param drop [\code{get_RLum}] \code{\link{logical}} (with default): coerce to the next possible layer #' (which are data objects, \code{drop = FALSE} keeps the original \code{RLum.Results} #' #' @return #' #' \bold{\code{get_RLum}}:\cr #' #' Returns: \cr #' (1) Data object from the specified slot \cr #' (2) \code{\link{list}} of data objects from the slots if 'data.object' is vector or \cr #' (3) an \code{\linkS4class{RLum.Results}} for \code{drop = FALSE}.\cr #' #' #' @export setMethod( "get_RLum", signature = signature("RLum.Results"), definition = function(object, data.object, info.object = NULL, drop = TRUE) { ##if info.object is set, only the info objects are returned if (!is.null(info.object)) { if (info.object %in% names(object@info)) { unlist(object@info[info.object]) } else{ ##check for entries if (length(object@info) == 0) { warning("[get_RLum] This RLum.Results object has no info objects! NULL returned!)") return(NULL) } else{ ##grep names temp.element.names <- paste(names(object@info), collapse = ", ") warning.text <- paste("[get_RLum] Invalid info.object name. Valid names are:", temp.element.names) warning(warning.text, call. = FALSE) return(NULL) } } } else{ if (!missing(data.object)) { ##++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##CASE1: data.object is of type 'character' if (is(data.object, "character")) { #check if the provided names are available if (all(data.object %in% names(object@data))) { ##account for multiple inputs if (length(data.object) > 1) { temp.return <- sapply(data.object, function(x) { object@data[[x]] }) } else{ temp.return <- list(data.object = object@data[[data.object]]) } } else{ error.message <- paste0( "[get_RLum()] data.object(s) unknown, valid names are: ", paste(names(object@data), collapse = ", ") ) stop(error.message) } } ##++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##CASE2: data.object is of type 'numeric' else if (is(data.object, "numeric")) { ##check if index is valid if (max(data.object) > length(object@data)) { stop("[get_RLum] 'data.object' index out of bounds!") } else if (length(data.object) > 1) { temp.return <- lapply(data.object, function(x) { object@data[[x]] }) } else{ temp.return <- list(object@data[[data.object]]) } ##restore names as that get los with this method names(temp.return) <- names(object@data)[data.object] } ##++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##CASE3: data.object is of an unsupported type else{ stop("[get_RLum] 'data.object' has to be of type character or numeric!") } ##the CASE data.object is missing } else{ ##return always the first object if nothing is specified temp.return <- object@data[1] } ##CHECK whether an RLum.Results object needs to be produced ... ##This will just be the case if the funtion havn't returned something before if (drop) { ##we need to access the list here, otherwise we get unexpected behaviour as drop = TRUE ##should always return the lowest possible element here return(temp.return[[1]]) } else{ return(set_RLum( "RLum.Results", originator = object@originator, data = temp.return )) } } } ) #################################################################################################### ###length_RLum() #################################################################################################### #' @describeIn RLum.Results #' Returns the length of the object, i.e., number of stored data.objects #' #' @return #' #' \bold{\code{length_RLum}}\cr #' #' Returns the number of data elements in the \code{RLum.Results} object. #' #' @export setMethod("length_RLum", "RLum.Results", function(object){ length(object@data) }) #################################################################################################### ###names_RLum() #################################################################################################### #' @describeIn RLum.Results #' Returns the names data.objects #' #' @return #' #' \bold{\code{names_RLum}}\cr #' #' Returns the names of the data elements in the object. #' #' @export setMethod("names_RLum", "RLum.Results", function(object){ names(object@data) }) Luminescence/R/calc_FuchsLang2001.R0000644000176200001440000002121213125226556016354 0ustar liggesusers#' Apply the model after Fuchs & Lang (2001) to a given De distribution. #' #' This function applies the method according to Fuchs & Lang (2001) for #' heterogeneously bleached samples with a given coefficient of variation #' threshold. #' #' \bold{Used values} \cr If the coefficient of variation (c[v]) of the first #' two values is larger than the threshold c[v_threshold], the first value is #' skipped. Use the \code{startDeValue} argument to define a start value for #' calculation (e.g. 2nd or 3rd value).\cr #' #' \bold{Basic steps of the approach} \cr #' #' (1) Estimate natural relative variation of the sample using a dose recovery #' test\cr (2) Sort the input values ascendingly\cr (3) Calculate a running #' mean, starting with the lowermost two values and add values iteratively.\cr #' (4) Stop if the calculated c[v] exceeds the specified \code{cvThreshold}\cr #' #' @param data \code{\linkS4class{RLum.Results}} or \link{data.frame} #' (\bold{required}): for \code{data.frame}: two columns with De #' \code{(data[,1])} and De error \code{(values[,2])} #' @param cvThreshold \link{numeric} (with default): coefficient of variation #' in percent, as threshold for the method, e.g. \code{cvThreshold = 3}. See #' details. #' @param startDeValue \link{numeric} (with default): number of the first #' aliquot that is used for the calculations #' @param plot \link{logical} (with default): plot output #' \code{TRUE}/\code{FALSE} #' @param \dots further arguments and graphical parameters passed to #' \code{\link{plot}} #' @return Returns a plot (optional) and terminal output. In addition an #' \code{\linkS4class{RLum.Results}} object is returned containing the #' following elements: #' #' \item{summary}{\link{data.frame} summary of all relevant model results.} #' \item{data}{\link{data.frame} original input data} \item{args}{\link{list} #' used arguments} \item{call}{\link{call} the function call} #' \item{usedDeValues}{\link{data.frame} containing the used values for the #' calculation} #' @note Please consider the requirements and the constraints of this method #' (see Fuchs & Lang, 2001) #' @section Function version: 0.4.1 #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) Christoph Burow, University of Cologne (Germany) #' @seealso \code{\link{plot}}, \code{\link{calc_MinDose}}, #' \code{\link{calc_FiniteMixture}}, \code{\link{calc_CentralDose}}, #' \code{\link{calc_CommonDose}}, \code{\linkS4class{RLum.Results}} #' @references Fuchs, M. & Lang, A., 2001. OSL dating of coarse-grain fluvial #' quartz using single-aliqout protocols on sediments from NE Peloponnese, #' Greece. In: Quaternary Science Reviews 20, 783-787. #' #' Fuchs, M. & Wagner, G.A., 2003. Recognition of insufficient bleaching by #' small aliquots of quartz for reconstructing soil erosion in Greece. #' Quaternary Science Reviews 22, 1161-1167. #' @keywords dplot #' @examples #' #' #' ##load example data #' data(ExampleData.DeValues, envir = environment()) #' #' ##calculate De according to Fuchs & Lang (2001) #' temp<- calc_FuchsLang2001(ExampleData.DeValues$BT998, cvThreshold = 5) #' #' @export calc_FuchsLang2001 <- function( data, cvThreshold=5, startDeValue=1, plot=TRUE, ... ){ # Integrity Tests --------------------------------------------------------- if(missing(data)==FALSE){ if(is(data, "data.frame") == FALSE & is(data,"RLum.Results") == FALSE){ stop("[calc_FuchsLang2001] 'data' has to be of type 'data.frame' or 'RLum.Results'!") } else { if(is(data, "RLum.Results") == TRUE){ data <- get_RLum(data, "data") } } } # Deal with extra arguments ----------------------------------------------- ##deal with addition arguments extraArgs <- list(...) verbose <- if("verbose" %in% names(extraArgs)) {extraArgs$verbose} else {TRUE} ##============================================================================## ##PREPARE DATA ##============================================================================## ##1. order values in acending order write used D[e] values in data.frame o <- order(data[1]) # o is only an order parameter data_ordered <- data[o,] # sort values after o and write them into a new variable ##2. estimate D[e] # set variables usedDeValues<-data.frame(De=NA,De_Error=NA,cv=NA) endDeValue<-startDeValue # if the frist D[e] values are not used write this information in the data.frame if (startDeValue!=1) { n <- abs(1-startDeValue) # write used D[e] values in data.frame usedDeValues[1:n,1]<-data_ordered[1:n,1] usedDeValues[1:n,2]<-data_ordered[1:n,2] usedDeValues[1:n,3]<-"skipped" } ##=================================================================================================## ##LOOP FOR MODEL ##=================================================================================================## # repeat loop (run at least one time) repeat { #calculate mean, sd and cv mean<-round(mean(data_ordered[startDeValue:endDeValue,1]),digits=2) #calculate mean from ordered D[e] values sd<-round(sd(data_ordered[startDeValue:endDeValue,1]),digits=2) #calculate sd from ordered D[e] values cv<-round(sd/mean*100, digits=2) #calculate coefficent of variation # break if cv > cvThreshold if (cv>cvThreshold & endDeValue>startDeValue){ # if the first two D[e] values give a cv > cvThreshold, than skip the first D[e] value if (endDeValue-startDeValue<2) { # write used D[e] values in data.frame usedDeValues[endDeValue,1]<-data_ordered[endDeValue,1] usedDeValues[endDeValue,2]<-data_ordered[endDeValue,2] usedDeValues[endDeValue-1,3]<-"not used" # go to the next D[e] value startDeValue<-startDeValue+1 } else { usedDeValues[endDeValue,1]<-data_ordered[endDeValue,1] usedDeValues[endDeValue,2]<-data_ordered[endDeValue,2] usedDeValues[endDeValue,3]<-paste("# ",cv," %",sep="") break #break loop } }#EndIf else { # write used D[e] values in data.frame usedDeValues[endDeValue,1]<-data_ordered[endDeValue,1] usedDeValues[endDeValue,2]<-data_ordered[endDeValue,2] # first cv values alway contains NA to ensure that NA% is not printed test if(is.na(cv)==TRUE) { usedDeValues[endDeValue,3]<-cv } else { usedDeValues[endDeValue,3]<-paste(cv," %",sep="") } }#EndElse # go the next D[e] value until the maximum number is reached if (endDeValue= \Theta} #' #' With \eqn{\Theta} an arbitray, user defined, threshold. Values above the threshold indicating curves #' comprising a signal.\cr #' #' Note: the absolute difference of \eqn{E(X)} and \eqn{Var(x)} instead of the ratio was chosen as #' both terms can become 0 which would result in 0 or \code{Inf}, if the ratio is calculated. #' #' @param object \code{\linkS4class{Risoe.BINfileData}} or \code{\linkS4class{RLum.Analysis}} #' (\bold{required}): input object. The function also accepts a list with objects of allowed type. #' #' @param threshold \code{\link{numeric}} (with default): numeric threshold value for the allowed difference between #' the \code{mean} and the \code{var} of the count values (see details) #' #' @param cleanup \code{\link{logical}} (with default): if set to \code{TRUE} curves indentified as #' zero light level curves are automatically removed. Ouput is an object as same type as the input, i.e. #' either \code{\linkS4class{Risoe.BINfileData}} or \code{\linkS4class{RLum.Analysis}} #' #' @param cleanup_level \code{\link{character}} (with default): selects the level for the cleanup #' of the input data sets. Two options are allowed: \code{"curve"} or \code{"aliquot"}. If \code{"curve"} #' is selected every single curve marked as \code{invalid} is removed. If \code{"aliquot"} is selected, #' curves of one aliquot (grain or disc) can be marked as invalid, but will not be removed. An aliquot #' will be only removed if all curves of this aliquot are marked as invalid. #' #' @param verbose \code{\link{logical}} (with default): enables or disables the terminal feedback #' #' @param plot \code{\link{logical}} (with default): enables or disables the graphical feedback #' #' @return The function returns #' #' -----------------------------------\cr #' [ NUMERICAL OUTPUT ]\cr #' -----------------------------------\cr #' \bold{\code{RLum.Reuslts}}-object\cr #' #' \bold{slot:} \bold{\code{@data}}\cr #' \tabular{lll}{ #' \bold{Element} \tab \bold{Type} \tab \bold{Description}\cr #' \code{$unique_pairs} \tab \code{data.frame} \tab the unique position and grain pairs \cr #' \code{$selection_id} \tab \code{numeric} \tab the selection as record ID \cr #' \code{$selection_full} \tab \code{data.frame} \tab implemented models used in the baSAR-model core \cr #' } #' #'\bold{slot:} \bold{\code{@info}}\cr #' #' The original function call\cr #' #' \bold{Output variation}\cr #' #' For \code{cleanup = TRUE} the same object as the input is returned, but cleaned up (invalid curves were removed). #' This means: Either an \code{\linkS4class{Risoe.BINfileData}} or an \code{\linkS4class{RLum.Analysis}} #' object is returned in such cases. An \code{\linkS4class{Risoe.BINfileData}} object can be exported #' to a BIN-file by using the function \code{\link{write_R2BIN}}. #' #' @note This function can work with \code{\linkS4class{Risoe.BINfileData}} objects or #' \code{\linkS4class{RLum.Analysis}} objects (or a list of it). However, the function is highly optimised #' for \code{\linkS4class{Risoe.BINfileData}} objects as it make sense to remove identify invalid #' grains before the conversion to an \code{\linkS4class{RLum.Analysis}} object.\cr #' #' The function checking for invalid curves works rather robust and it is likely that Reg0 curves #' within a SAR cycle are removed as well. Therefore it is strongly recommended to use the argument #' \code{cleanup = TRUE} carefully. #' #' @section Function version: 0.2.0 #' #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' #' @seealso \code{\linkS4class{Risoe.BINfileData}}, \code{\linkS4class{RLum.Analysis}}, #' \code{\link{write_R2BIN}}, \code{\link{read_BIN2R}} #' #' @references - #' #' @keywords manip datagen #' #' @examples #' #' ##01 - basic example I #' ##just show how to apply the function #' data(ExampleData.XSYG, envir = environment()) #' #' ##verify and get data.frame out of it #' verify_SingleGrainData(OSL.SARMeasurement$Sequence.Object)$selection_full #' #' ##02 - basic example II #' data(ExampleData.BINfileData, envir = environment()) #' id <- verify_SingleGrainData(object = CWOSL.SAR.Data, #' cleanup_level = "aliquot")$selection_id #' #' \dontrun{ #' ##03 - advanced example I #' ##importing and exporting a BIN-file #' #' ##select and import file #' file <- file.choose() #' object <- read_BIN2R(file) #' #' ##remove invalid aliquots(!) #' object <- verify_SingleGrainData(object, cleanup = TRUE) #' #' ##export to new BIN-file #' write_R2BIN(object, paste0(dirname(file),"/", basename(file), "_CLEANED.BIN")) #' } #' #' @export verify_SingleGrainData <- function( object, threshold = 10, cleanup = FALSE, cleanup_level = 'aliquot', verbose = TRUE, plot = FALSE ){ ##three types of input are allowed: ##(1) RisoeBINfileData ##(2) RLum.Analysis ##(3) List of RLum.Analysis # Self Call ----------------------------------------------------------------------------------- if(is(object, "list")){ results <- lapply(1:length(object), function(x) { verify_SingleGrainData( object = object[[x]], threshold = threshold, cleanup = cleanup, cleanup_level = cleanup_level, verbose = verbose ) }) ##account for cleanup if(cleanup){ return(results) }else{ return(merge_RLum(results)) } } ##++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##RisoeBINfileData if(is(object, "Risoe.BINfileData")){ ##run test on DATA slot ##MEAN + SD temp.results_matrix <- lapply(X = object@DATA, FUN = function(x){ c(mean(x), var(x)) }) temp.results_matrix <- do.call(rbind, temp.results_matrix) ##DIFF temp.results_matrix_RATIO <- temp.results_matrix[,2]/temp.results_matrix[,1] ##SEL temp.results_matrix_VALID <- temp.results_matrix_RATIO > threshold ##combine everything to in a data.frame selection <- data.frame( POSITION = object@METADATA$POSITION, GRAIN = object@METADATA$GRAIN, MEAN = temp.results_matrix[, 1], VAR = temp.results_matrix[, 2], RATIO = temp.results_matrix_RATIO, THRESHOLD = rep_len(threshold, length(object@DATA)), VALID = temp.results_matrix_VALID ) ##get unique pairs for POSITION and GRAIN for VALID == TRUE unique_pairs <- unique( selection[selection[["VALID"]], c("POSITION", "GRAIN")]) if(cleanup_level == "aliquot"){ selection_id <- sort(unlist(lapply(1:nrow(unique_pairs), function(x) { which( .subset2(selection, 1) == .subset2(unique_pairs, 1)[x] & .subset2(selection, 2) == .subset2(unique_pairs, 2)[x] ) }))) }else{ ##reduce data to TRUE selection selection_id <- which(selection[["VALID"]]) } ##select output on the chosen input if(cleanup){ ##selected wanted elements object@DATA <- object@DATA[selection_id] object@METADATA <- object@METADATA[selection_id,] object@METADATA$ID <- 1:length(object@DATA) ##print message selection_id <- paste(selection_id, collapse = ", ") if(verbose){ cat(paste0("\n[verify_SingleGrainData()] Risoe.BINfileData object reduced to records: \n", selection_id)) cat("\n\n[verify_SingleGrainData()] Risoe.BINfileData object record index reset.") } ##return return_object <- object }else{ return_object <- set_RLum( class = "RLum.Results", data = list( unique_pairs = unique_pairs, selection_id = selection_id, selection_full = selection), info = list(call = sys.call()) ) } ##++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##RLum.Analysis and list with RLum.Analysis objects ## ... and yes it make sense not to mix that up with the code above }else if(is(object,"RLum.Analysis")){ ##first extract all count values from all curves object_list <- lapply(get_RLum(object), function(x){ ##yes, would work differently, but it is faster x@data[,2] }) ##MEAN + SD temp.results_matrix <- lapply(X = object_list, FUN = function(x){ c(mean(x), var(x)) }) temp.results_matrix <- do.call(rbind, temp.results_matrix) ##DIFF temp.results_matrix_RATIO <- temp.results_matrix[,2]/temp.results_matrix[,1] ##SEL temp.results_matrix_VALID <- temp.results_matrix_RATIO > threshold ##get structure for the RLum.Anlaysis object temp_structure <- structure_RLum(object, fullExtent = TRUE) ##now we have two cases, depending on where measurement is coming from if (object@originator == "Risoe.BINfileData2RLum.Analysis") { ##combine everything to in a data.frame selection <- data.frame( POSITION = temp_structure$info.POSITION, GRAIN = temp_structure$info.GRAIN, MEAN = temp.results_matrix[, 1], VAR = temp.results_matrix[, 2], RATIO = temp.results_matrix_RATIO, THRESHOLD = rep_len(threshold, length(object_list)), VALID = temp.results_matrix_VALID ) ##get unique pairs for POSITION and GRAIN for VALID == TRUE unique_pairs <- unique( selection[selection[["VALID"]], c("POSITION", "GRAIN")]) } else if (object@originator == "read_XSYG2R") { ##combine everything to in a data.frame selection <- data.frame( POSITION = if(any(grepl(pattern = "position", names(temp_structure)))){ temp_structure$info.position}else{ NA }, GRAIN = NA, MEAN = temp.results_matrix[, 1], VAR = temp.results_matrix[, 2], RATIO = temp.results_matrix_RATIO, THRESHOLD = rep_len(threshold, length(object_list)), VALID = temp.results_matrix_VALID ) ##get unique pairs for POSITION for VALID == TRUE unique_pairs <- unique( selection[["POSITION"]][selection[["VALID"]]]) } else{ stop("[verify_SingleGrainData()] I don't know what to do object 'originator' not supported!") } ##set up cleanup if(cleanup_level == "aliquot") { if (object@originator == "read_XSYG2R") { if(!is.na(unique_pairs)){ selection_id <- sort(unlist(lapply(1:nrow(unique_pairs), function(x) { which(.subset2(selection, 1) == .subset2(unique_pairs, 1)[x]) }))) }else{ selection_id <- NA } } else if (object@originator == "Risoe.BINfileData2RLum.Analysis") { selection_id <- sort(unlist(lapply(1:nrow(unique_pairs), function(x) { which( .subset2(selection, 1) == .subset2(unique_pairs, 1)[x] & .subset2(selection, 2) == .subset2(unique_pairs, 2)[x] ) }))) } } else{ ##reduce data to TRUE selection selection_id <- which(selection[["VALID"]]) } ##return value ##select output on the chosen input if(cleanup && !is.na(selection_id)){ ##print message if(verbose){ selection_id <- paste(selection_id, collapse = ", ") cat(paste0("[verify_SingleGrainData()] RLum.Analysis object reduced to records: ", selection_id)) } ##selected wanted elements if (length(selection_id) == 0) { object <- set_RLum( class = "RLum.Analysis", originator = object@originator, protocol = object@protocol, records = list(), info = list( unique_pairs = unique_pairs, selection_id = selection_id, selection_full = selection) ) } else{ object <- set_RLum( class = "RLum.Analysis", records = get_RLum(object, record.id = selection_id, drop = FALSE), info = list( unique_pairs = unique_pairs, selection_id = selection_id, selection_full = selection) ) } ##return return_object <- object }else{ if(is.na(selection_id)){ warning("[verify_SingleGrainData()] selection_id is NA, nothing removed, everything selected!") } return_object <- set_RLum( class = "RLum.Results", data = list( unique_pairs = unique_pairs, selection_id = selection_id, selection_full = selection), info = list(call = sys.call()) ) } }else{ stop(paste0("[verify_SingleGrainData()] Input type '", is(object)[1], "' is not allowed for this function!"), call. = FALSE) } # Plot ---------------------------------------------------------------------------------------- if(plot){ ##plot area plot( NA, NA, xlim = c(1,nrow(selection)), ylim = range(selection[["RATIO"]]), log = "y", xlab = "Record index", ylab = "Calculated ratio [a.u.]", main = "Record selection" ) ##plot points above the threshold points(x = which(selection[["VALID"]]), y = selection[["RATIO"]][selection[["VALID"]]], pch = 20, col = "darkgreen") points(x = which(!selection[["VALID"]]), y = selection[["RATIO"]][!selection[["VALID"]]], pch = 20, col = rgb(0,0,0,0.5)) abline(h = threshold, col = "red", lty = 1, lwd = 2) mtext( side = 3, text = paste0( "(total: ", nrow(selection), " | valid: ", length(which(selection[["VALID"]])), " | invalid: ", length(which(!selection[["VALID"]])), ")"), cex = 0.9 * par()$cex) } # Return -------------------------------------------------------------------------------------- return(return_object) } Luminescence/R/calc_Statistics.R0000644000176200001440000001727713125226556016351 0ustar liggesusers#' Function to calculate statistic measures #' #' This function calculates a number of descriptive statistics for estimates #' with a given standard error (SE), most fundamentally using error-weighted approaches. #' #' The option to use Monte Carlo Methods (\code{n.MCM}) allows calculating #' all descriptive statistics based on random values. The distribution of these #' random values is based on the Normal distribution with \code{De} values as #' means and \code{De_error} values as one standard deviation. Increasing the #' number of MCM-samples linearly increases computation time. On a Lenovo X230 #' machine evaluation of 25 Aliquots with n.MCM = 1000 takes 0.01 s, with #' n = 100000, ca. 1.65 s. It might be useful to work with logarithms of these #' values. See Dietze et al. (2016, Quaternary Geochronology) and the function #' \code{\link{plot_AbanicoPlot}} for details. #' #' @param data \code{\link{data.frame}} or \code{\linkS4class{RLum.Results}} #' object (required): for \code{data.frame} two columns: De (\code{data[,1]}) #' and De error (\code{data[,2]}). To plot several data sets in one plot the #' data sets must be provided as \code{list}, e.g. \code{list(data.1, data.2)}. #' #' @param weight.calc \code{\link{character}}: type of weight calculation. One #' out of \code{"reciprocal"} (weight is 1/error), \code{"square"} (weight is #' 1/error^2). Default is \code{"square"}. #' #' @param digits \code{\link{integer}} (with default): round numbers to the #' specified digits. If digits is set to \code{NULL} nothing is rounded. #' #' @param n.MCM \code{\link{numeric}} (with default): number of samples drawn #' for Monte Carlo-based statistics. \code{NULL} (the default) disables MC runs. #' #' @param na.rm \code{\link{logical}} (with default): indicating whether NA #' values should be stripped before the computation proceeds. #' #' @return Returns a list with weighted and unweighted statistic measures. #' #' @section Function version: 0.1.7 #' #' @keywords datagen #' #' @author Michael Dietze, GFZ Potsdam (Germany) #' #' @examples #' #' ## load example data #' data(ExampleData.DeValues, envir = environment()) #' #' ## show a rough plot of the data to illustrate the non-normal distribution #' plot_KDE(ExampleData.DeValues$BT998) #' #' ## calculate statistics and show output #' str(calc_Statistics(ExampleData.DeValues$BT998)) #' #' \dontrun{ #' ## now the same for 10000 normal distributed random numbers with equal errors #' x <- as.data.frame(cbind(rnorm(n = 10^5, mean = 0, sd = 1), #' rep(0.001, 10^5))) #' #' ## note the congruent results for weighted and unweighted measures #' str(calc_Statistics(x)) #' } #' #' @export calc_Statistics <- function( data, weight.calc = "square", digits = NULL, n.MCM = NULL, na.rm = TRUE ) { ## Check input data if(is(data, "RLum.Results") == FALSE & is(data, "data.frame") == FALSE) { stop("[calc_Statistics()] Input data is neither of type 'data.frame' nor 'RLum.Results'", call. = FALSE) } else { if(is(data, "RLum.Results")) { data <- get_RLum(data, "data")[,1:2] } } ##strip na values if(na.rm){ data <- na.exclude(data) } ## handle error-free data sets if(ncol(data) == 1) { data <- cbind(data, rep(NA, length(data))) } ## replace Na values in error by 0 data[is.na(data[,2]),2] <- 0 if(sum(data[,2]) == 0) { warning("[calc_Statistics()] All errors are NA or zero! Automatically set to 10^-9!", call. = FALSE) data[,2] <- rep(x = 10^-9, length(data[,2])) } if(weight.calc == "reciprocal") { S.weights <- 1 / data[,2] } else if(weight.calc == "square") { S.weights <- 1 / data[,2]^2 } else { stop ("[calc_Statistics()] Weight calculation type not supported!", call. = FALSE) } S.weights <- S.weights / sum(S.weights) ## create MCM data if (is.null(n.MCM)) { data.MCM <- cbind(data[, 1]) } else { data.MCM <- matrix(data = rnorm( n = n.MCM * nrow(data), mean = data[, 1], sd = data[, 2] ), ncol = n.MCM) } ## calculate n S.n <- nrow(data) ## calculate mean S.mean <- mean(x = data[,1], na.rm = na.rm) S.wg.mean <- weighted.mean(x = data[,1], w = S.weights, n.rm = na.rm) S.m.mean <- mean(x = data.MCM, na.rm = na.rm) ## calculate median S.median <- median(x = data[,1], na.rm = na.rm) S.wg.median <- S.median S.m.median <- median(x = data.MCM, na.rm = na.rm) ## calculate absolute standard deviation S.sd.abs <- sd(x = data[,1], na.rm = na.rm) S.wg.sd.abs <- sqrt(sum(S.weights * (data[,1] - S.wg.mean)^2) / (((S.n - 1) * sum(S.weights)) / S.n)) S.m.sd.abs <- sd(x = data.MCM, na.rm = na.rm) ## calculate relative standard deviation S.sd.rel <- S.sd.abs / S.mean * 100 S.wg.sd.rel <- S.wg.sd.abs / S.wg.mean * 100 S.m.sd.rel <- S.m.sd.abs / S.m.mean * 100 ## calculate absolute standard error of the mean S.se.abs <- S.sd.abs / sqrt(S.n) S.wg.se.abs <- S.wg.sd.abs / sqrt(S.n) S.m.se.abs <- S.m.sd.abs / sqrt(S.n) ## calculate relative standard error of the mean S.se.rel <- S.se.abs / S.mean * 100 S.wg.se.rel <- S.wg.se.abs / S.wg.mean * 100 S.m.se.rel <- S.m.se.abs / S.m.mean * 100 ## calculate skewness S.skewness <- 1 / S.n * sum(((data[,1] - S.mean) / S.sd.abs)^3) S.m.skewness <- 1 / S.n * sum(((data.MCM - S.m.mean) / S.m.sd.abs)^3) ## calculate kurtosis S.kurtosis <- 1 / S.n * sum(((data[,1] - S.mean) / S.sd.abs)^4) S.m.kurtosis <- 1 / S.n * sum(((data.MCM - S.m.mean) / S.m.sd.abs)^4) ## create list objects of calculation output S.weighted <- list(n = S.n, mean = S.wg.mean, median = S.wg.median, sd.abs = S.wg.sd.abs, sd.rel = S.wg.sd.rel, se.abs = S.wg.se.abs, se.rel = S.wg.se.rel, skewness = S.skewness, kurtosis = S.kurtosis) if(!is.null(digits)) { S.weighted <- sapply(names(S.weighted), simplify = FALSE, USE.NAMES = TRUE, function(x) { round(S.weighted[[x]], digits = digits)}) } S.unweighted <- list(n = S.n, mean = S.mean, median = S.median, sd.abs = S.sd.abs, sd.rel = S.sd.rel, se.abs = S.se.abs, se.rel = S.se.rel, skewness = S.skewness, kurtosis = S.kurtosis) if(!is.null(digits)){ S.unweighted <- sapply(names(S.unweighted), simplify = FALSE, USE.NAMES = TRUE, function(x) { round(S.unweighted [[x]], digits = digits)}) } S.MCM <- list(n = S.n, mean = S.m.mean, median = S.m.median, sd.abs = S.m.sd.abs, sd.rel = S.m.sd.rel, se.abs = S.m.se.abs, se.rel = S.m.se.rel, skewness = S.m.skewness, kurtosis = S.m.kurtosis) if(!is.null(digits)){ S.MCM <- sapply(names(S.MCM), simplify = FALSE, USE.NAMES = TRUE, function(x) { round(S.MCM [[x]], digits = digits)}) } list(weighted = S.weighted, unweighted = S.unweighted, MCM = S.MCM) } Luminescence/R/get_Quote.R0000644000176200001440000001060313125226556015153 0ustar liggesusers#' Function to return essential quotes #' #' This function returns one of the collected essential quotes in the #' growing library. If called without any parameters, a random quote is #' returned. #' #' @param ID \code{\link{character}}, qoute ID to be returned. #' @param author \code{\link{character}}, all quotes by specified author. #' @param separated \code{\link{logical}}, return result in separated form. #' @return Returns a character with quote and respective (false) author. #' @section Function version: 0.1.1 #' @author Michael Dietze, GFZ Potsdam (Germany) #' @examples #' #' ## ask for an arbitrary qoute #' get_Quote() #' #' @export get_Quote <- function( ID, author, separated = FALSE ) { ## definition of the ever growing quote data set quotes <- rbind( c("Anonymous student hotel employee", "Let me double check this."), c("The ordinary reviewer", "I love it when a plan comes together."), c("A tunnelling electron", "God does not play dice."), c("Goldfinger", "You cannot get this machine better and cheaper than from us."), c("A PhD supervisor", "Live long and in prosper."), c("A PhD supervisor", "You are not depressive, you simply have a crappy life."), c("A trapped charge", "I want to break free."), c("The R-package Luminescence manual", "Call unto me, and I will answer thee, and will shew thee great things, and difficult, which thou knowest not."), c("A stimulated feldspar grain", "I'm so excited and I just can't hide it."), c("The true age", "How many roads..."), c("The undecided OSL component", "Should I stay or should I go?"), c("A fluvially transported quartz grain at night", "Always look at the bright side of life."), c("An arctic sediment outcrop", "Marmor, Stein und Eisen bricht..."), c("A common luminescence reader customer", "If anything can go wrong, it will."), c("A blue LED to a trapped electron", "Resistance is futile."), c("A trapped electron to a yellow LED", "Well, that's all?"), c("A weathering rock", "Who wants to live forever?"), c("A new pIRIR derivative", "20000 miles below the sea."), c("Robert Oppenheimer", "I want this thing to work by just pressing one button."), c("An arbitrary member of the CRAN team", "No shirt, no shoes, no service!"), c("Rubber mallet to steel cylinder", "Let's rock and roll."), c("A data import function", "Better late than never."), c("A luminescence lab staff member to its customer", "Tell me the age, I tell you the price."), c("The NSA", "O'zapft is."), c("The natural dose", "You only live once."), c("A Windows user", "An apple a day keeps the doctor away."), c("The authors of sTeve", "We love to entertain you."), c("Any arbitrary independent OSL device manufacturer", "Sure it will work, it was me who built it!"), c("Response to the reviewer", "You are right, it was just a guess."), c("An aliquot disc", "The answer [...] is: 48"), c("Push Pin", "Made of used sample carriers"), c("A motivated R-Team member", "We are doing this not just for statistical reasons, there is real science behind it!"), c("An enthusiastic cabaret artist", "Political elections are like brushing teeth: if you don't do it, things become brown."), c("An unbiased reviewer", "The data is too poor to be published in QG, try a higher ranked journal."), c("R Team member, asked about statistical details", "No idea, I'm just here for visualisation."), c("An arbitrary unexperienced RLum-user", "Little by little, the bird builds its nest."), c("The answer to life, the universe and everything", "get_rightAnswer()"), c("Der Tatortreiniger", "Dreck ist nur Materie am falschen Ort."), c("Die Ex vom Tatortreiniger", "Das Ziel ist im Weg.") ) ## Check input data if(missing(ID) == TRUE & missing(author) == TRUE) { ID <- sample(x = seq(from = 1, to = nrow(quotes)), size = 1) } else if(missing(ID) == TRUE) { ID <- seq(from = 1, to = nrow(quotes))[quotes[,1] == author] } ## check for correct ID and generate qoute if(length(ID) < 1 | ID > nrow(quotes)) { quote.out <- "Sorry, but this was an impossible task!" } else { ## generate qoute(s) if(separated == FALSE) { quote.out <- paste(quotes[ID,1], ": '", quotes[ID,2], "'", sep = "") } else { quote.out <- quotes[ID,] } } ## return quotes return(quote.out) } Luminescence/R/RcppExports.R0000644000176200001440000000140713125227545015511 0ustar liggesusers# Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 .analyse_IRSARRF_SRS <- function(values_regenerated_limited, values_natural_limited, vslide_range, n_MC, trace = FALSE) { .Call('Luminescence_analyse_IRSARRF_SRS', PACKAGE = 'Luminescence', values_regenerated_limited, values_natural_limited, vslide_range, n_MC, trace) } .create_RLumDataCurve_matrix <- function(DATA, VERSION, NPOINTS, LTYPE, LOW, HIGH, AN_TEMP, TOLDELAY, TOLON, TOLOFF) { .Call('Luminescence_create_RLumDataCurve_matrix', PACKAGE = 'Luminescence', DATA, VERSION, NPOINTS, LTYPE, LOW, HIGH, AN_TEMP, TOLDELAY, TOLON, TOLOFF) } .create_UID <- function() { .Call('Luminescence_create_UID', PACKAGE = 'Luminescence') } Luminescence/R/tune_Data.R0000644000176200001440000000517713125226556015135 0ustar liggesusers#' Tune data for experimental purpose #' #' The error can be reduced and sample size increased for specific purpose. #' #' @param data \code{\link{data.frame}} (\bold{required}): input values, #' structure: data (\code{values[,1]}) and data error (\code{values [,2]}) are #' required #' #' @param decrease.error \code{\link{numeric}}: factor by which the error #' is decreased, ranges between 0 and 1. #' #' @param increase.data \code{\link{numeric}}: factor by which the error #' is decreased, ranges between 0 and inf. #' #' @return Returns a \code{\link{data.frame}} with tuned values. #' #' @note You should not use this function to improve your poor data set! #' #' @section Function version: 0.5.0 #' #' @author Michael Dietze, GFZ Potsdam (Germany) #' #' @seealso # #' #' @references # #' #' @keywords manip #' #' @examples #' ## load example data set #' data(ExampleData.DeValues, envir = environment()) #' x <- ExampleData.DeValues$CA1 #' #' ## plot original data #' plot_AbanicoPlot(data = x, #' summary = c("n", "mean")) #' #' ## decrease error by 10 % #' plot_AbanicoPlot(data = tune_Data(x, decrease.error = 0.1), #' summary = c("n", "mean")) #' #' ## increase sample size by 200 % #' #plot_AbanicoPlot(data = tune_Data(x, increase.data = 2) , #' # summary = c("n", "mean")) #' #' #' @export tune_Data <- function( data, decrease.error = 0, increase.data = 0 ){ if(missing(decrease.error) == FALSE) { error.rel <- data[,2] / data[,1] data[,2] <- error.rel * (1 - decrease.error) * data[,1] } if(missing(increase.data) == FALSE) { n <- round(x = increase.data * 100, digits = 0) i.new <- sample(x = 1:nrow(data), size = n, replace = TRUE) x.new <- rnorm(n = n, mean = data[i.new, 1], sd = data[i.new, 2]) e.new <- rnorm(n = n, mean = data[i.new, 2], sd = data[i.new, 2] * 0.05) x.merge <- c(data[,1], x.new) e.merge <- c(data[,2], e.new) e.merge <- e.merge[order(x.merge)] x.merge <- x.merge[order(x.merge)] data.out <- data.frame(x.merge, e.merge) names(data.out) <- names(data) data <- data.out } info <- Sys.info() user <- info[length(info)] os <- info[1] warning(paste("Dear ", user, ", these activities on your ", os, " machine have been tracked and will be submitted to ", "the R.Lum data base. Cheating does not pay off! [", Sys.time(), "]", sep = "")) return(data) } Luminescence/R/analyse_pIRIRSequence.R0000644000176200001440000007072413125226556017363 0ustar liggesusers#' Analyse post-IR IRSL sequences #' #' The function performs an analysis of post-IR IRSL sequences including curve #' fitting on \code{\linkS4class{RLum.Analysis}} objects. #' #' #' To allow post-IR IRSL protocol (Thomsen et al., 2008) measurement analyses #' this function has been written as extended wrapper function for the function #' \code{\link{analyse_SAR.CWOSL}}, facilitating an entire sequence analysis in #' one run. With this, its functionality is strictly limited by the #' functionality of the function \code{\link{analyse_SAR.CWOSL}}.\cr #' #' \bold{If the input is a \code{list}}\cr #' #' If the input is a list of RLum.Analysis-objects, every argument can be provided as list to allow #' for different sets of parameters for every single input element. #' For further information see \code{\link{analyse_SAR.CWOSL}}. #' #' #' @param object \code{\linkS4class{RLum.Analysis}} (\bold{required}) or \code{\link{list}} of #' \code{\linkS4class{RLum.Analysis}} objects: input object containing data for analysis. If a \code{\link{list}} #' is provided the functions tries to iteratre over the list. #' #' @param signal.integral.min \code{\link{integer}} (\bold{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 \code{\link{integer}} (\bold{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 \code{\link{integer}} (\bold{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 \code{\link{integer}} (\bold{required}): #' upper bound of the background integral. Provide this value as vector for #' different integration limits for the different IRSL curves. #' #' @param dose.points \code{\link{numeric}} (optional): a numeric vector #' containing the dose points values. Using this argument overwrites dose point #' values in the signal curves. #' #' @param sequence.structure \link{vector} \link{character} (with default): #' specifies the general sequence structure. Allowed values are \code{"TL"} and #' any \code{"IR"} combination (e.g., \code{"IR50"},\code{"pIRIR225"}). #' Additionally a parameter \code{"EXCLUDE"} is allowed to exclude curves from #' the analysis (Note: If a preheat without PMT measurement is used, i.e. #' preheat as non TL, remove the TL step.) #' #' @param plot \code{\link{logical}} (with default): enables or disables plot #' output. #' #' @param plot.single \code{\link{logical}} (with default): single plot output #' (\code{TRUE/FALSE}) to allow for plotting the results in single plot #' windows. Requires \code{plot = TRUE}. #' #' @param \dots further arguments that will be passed to the function #' \code{\link{analyse_SAR.CWOSL}} and \code{\link{plot_GrowthCurve}} #' #' @return Plots (optional) and an \code{\linkS4class{RLum.Results}} object is #' returned containing the following elements: #' #' \tabular{lll}{ #' \bold{DATA.OBJECT} \tab \bold{TYPE} \tab \bold{DESCRIPTION} \cr #' \code{..$data} : \tab \code{data.frame} \tab Table with De values \cr #' \code{..$LnLxTnTx.table} : \tab \code{data.frame} \tab with the LnLxTnTx values \cr #' \code{..$rejection.criteria} : \tab \code{\link{data.frame}} \tab rejection criteria \cr #' \code{..$Formula} : \tab \code{\link{list}} \tab Function used for fitting of the dose response curve \cr #' \code{..$call} : \tab \code{\link{call}} \tab the original function call #' } #' #' The output should be accessed using the function #' \code{\link{get_RLum}}. #' #' @note Best graphical output can be achieved by using the function \code{pdf} #' with the following options:\cr \code{pdf(file = "...", height = 15, width = #' 15)} #' #' @section Function version: 0.2.2 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\link{analyse_SAR.CWOSL}}, \code{\link{calc_OSLLxTxRatio}}, #' \code{\link{plot_GrowthCurve}}, \code{\linkS4class{RLum.Analysis}}, #' \code{\linkS4class{RLum.Results}} \code{\link{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.single = TRUE) #' #' #' ##(3) Perform pIRIR analysis (for this example with quartz OSL data!) #' ## Alternative for PDF output, uncomment and complete for usage #' \dontrun{ #' pdf(file = "...", height = 15, width = 15) #' 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() #' } #' #' @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.single = FALSE, ... ){ # SELF CALL ----------------------------------------------------------------------------------- if(is.list(object)){ ##make live easy if(missing("signal.integral.min")){ signal.integral.min <- 1 warning("[analyse_pIRIRSequence()] 'signal.integral.min' missing, set to 1", call. = FALSE) } if(missing("signal.integral.max")){ signal.integral.max <- 2 warning("[analyse_pIRIRSequence()] 'signal.integral.max' missing, set to 2", call. = FALSE) } ##now we have to extend everything to allow list of arguments ... this is just consequent signal.integral.min <- rep(list(signal.integral.min), length = length(object)) signal.integral.max <- rep(list(signal.integral.max), length = length(object)) background.integral.min <- rep(list(background.integral.min), length = length(object)) background.integral.max <- rep(list(background.integral.max), length = length(object)) sequence.structure <- rep(list(sequence.structure), length = length(object)) if(!is.null(dose.points)){ if(is(dose.points, "list")){ dose.points <- rep(dose.points, length = length(object)) }else{ dose.points <- rep(list(dose.points), length = length(object)) } }else{ dose.points <- rep(list(NULL), length(object)) } ##run analysis temp <- 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.single = plot.single, main = ifelse("main"%in% names(list(...)), list(...)$main, 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) } } # General Integrity Checks --------------------------------------------------- ##GENERAL ##MISSING INPUT if(missing("object")==TRUE){ stop("[analyse_pIRIRSequence()] No value set for 'object'!") } ##INPUT OBJECTS if(is(object, "RLum.Analysis")==FALSE){ stop("[analyse_pIRIRSequence()] Input object is not of type 'RLum.Analyis'!") } ##CHECK ALLOWED VALUES IN SEQUENCE STRUCTURE temp.collect.invalid.terms <- paste(sequence.structure[ (!grepl("TL",sequence.structure)) & (!grepl("IR",sequence.structure)) & (!grepl("EXCLUDE",sequence.structure))], collapse = ", ") if(temp.collect.invalid.terms != ""){ stop("[analyse_pIRIRSequence()] ", temp.collect.invalid.terms, " not allowed in sequence.strucutre!") } # Deal with extra arguments ------------------------------------------------------------------- ##deal with addition arguments extraArgs <- list(...) mtext.outer <- if("mtext.outer" %in% names(extraArgs)) {extraArgs$mtext.outer} else {"MEASUREMENT INFO"} 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 {.7} # 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 allow 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 ) ##compile warning message temp.sequence.rm.warning <- paste( temp.sequence.structure[temp.sequence.rm.id, "recordType"], collapse = ", ") temp.sequence.rm.warning <- paste( "Record types are unrecognised and have been removed:", temp.sequence.rm.warning) warning(temp.sequence.rm.warning) } ##(2) Apply user sequence structure ##get sequence structure temp.sequence.structure <- structure_RLum(object) ##set values to structure data.frame temp.sequence.structure[, "protocol.step"] <- rep( sequence.structure, nrow(temp.sequence.structure)/2/length(sequence.structure)) ##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 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<- table(grepl("TL", sequence.structure))["TRUE"] if(is.na(n.TL)) {n.TL<- 0} n.loops <- as.numeric(length(grepl("TL", 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.single == FALSE & plot == TRUE){ ##first (Tx,Tn, Lx,Ln) temp.IRSL.layout.vector.first <- c(3,5,6,7,3,5,6,8) ##middle (any other Lx,Ln) if(n.loops > 2){ temp.IRSL.layout.vector.middle <- vapply( 2:(n.loops - 1), FUN = function(x) { offset <- 5 * x - 1 c((offset):(offset + 3), (offset):(offset + 2), offset + 4) }, FUN.VALUE = vector(mode = "numeric", length = 8) ) } ##last (Lx,Ln and legend) temp.IRSL.layout.vector.last <- c( ifelse(n.loops > 2,max(temp.IRSL.layout.vector.middle) + 1, max(temp.IRSL.layout.vector.first) + 1), ifelse(n.loops > 2,max(temp.IRSL.layout.vector.middle) + 2, max(temp.IRSL.layout.vector.first) + 2), ifelse(n.loops > 2,max(temp.IRSL.layout.vector.middle) + 4, max(temp.IRSL.layout.vector.first) + 4), ifelse(n.loops > 2,max(temp.IRSL.layout.vector.middle) + 5, max(temp.IRSL.layout.vector.first) + 5), ifelse(n.loops > 2,max(temp.IRSL.layout.vector.middle) + 1, max(temp.IRSL.layout.vector.first) + 1), ifelse(n.loops > 2,max(temp.IRSL.layout.vector.middle) + 2, max(temp.IRSL.layout.vector.first) + 2), ifelse(n.loops > 2,max(temp.IRSL.layout.vector.middle) + 4, max(temp.IRSL.layout.vector.first) + 4), ifelse(n.loops > 2,max(temp.IRSL.layout.vector.middle) + 6, max(temp.IRSL.layout.vector.first) + 6)) ##options for different sets of curves if(n.loops > 2){ temp.IRSL.layout.vector <- c(temp.IRSL.layout.vector.first, temp.IRSL.layout.vector.middle, temp.IRSL.layout.vector.last) }else{ temp.IRSL.layout.vector <- c(temp.IRSL.layout.vector.first, 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.backbround.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.single = temp.plot.single, output.plotExtended.single = TRUE, cex.global = cex, ... ) ##TODO should be replaced be useful explizit arguments ##check whether NULL was return if (is.null(temp.results)) { warning("[plot_pIRIRSequence()] An error occurred, analysis skipped. Check your sequence!", call. = FALSE) 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 additionals-------------------------------------------------------- ##============================================================================## if(plot){ ##plot growth curves plot(NA, NA, xlim = range(get_RLum(temp.results.final, "LnLxTnTx.table")$Dose), ylim = c( if(min(get_RLum(temp.results.final, "LnLxTnTx.table")$LxTx)- max(get_RLum(temp.results.final, "LnLxTnTx.table")$LxTx.Error) < 0){ min(get_RLum(temp.results.final, "LnLxTnTx.table")$LxTx)- max(get_RLum(temp.results.final, "LnLxTnTx.table")$LxTx.Error) }else{0}, max(get_RLum(temp.results.final, "LnLxTnTx.table")$LxTx)+ max(get_RLum(temp.results.final, "LnLxTnTx.table")$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(get_RLum(temp.results.final, "LnLxTnTx.table")$Dose)*1.05, length = 100) for(j in 1:length(pIRIR.curve.names)){ ##dose points temp.curve.points <- get_RLum( temp.results.final,"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 <- get_RLum(temp.results.final, "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(get_RLum(temp.results.final, "LnLxTnTx.table"))/ n.loops), ylim = 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)){ 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.single == FALSE){par(def.par)} }##end plot == TRUE ##============================================================================## # Return Values ----------------------------------------------------------- ##============================================================================## return(temp.results.final) } Luminescence/R/plot_DetPlot.R0000644000176200001440000002637013125226556015640 0ustar liggesusers#' Create De(t) plot #' #' Plots the equivalent dose (De) in dependency of the chosen signal integral (cf. Bailey et al., 2003). #' The function is simply passing several arguments to the function \code{\link{plot}} and the used #' analysis functions and runs it in a loop. Example: \code{legend.pos} for legend position, #' \code{legend} for legend text.\cr #' #' \bold{method}\cr #' #' The original method presented by Baiely et al., 2003 shifted the signal integrals and slightly #' extended them accounting for changes in the counting statistics. Example: \code{c(1:3, 3:5, 5:7)}. #' However, here also another method is provided allowing to expand the signal integral by #' consectutively expaning the integral by its chosen length. Example: \code{c(1:3, 1:5, 1:7)} #' #' Note that in both cases the integral limits are overlap. The finally applied limits are part #' of the function output.\cr #' #' @param object \code{\linkS4class{RLum.Analysis}} (\bold{required}): input #' object containing data for analysis #' #' @param signal.integral.min \code{\link{integer}} (\bold{required}): lower #' bound of the signal integral. #' #' @param signal.integral.max \code{\link{integer}} (\bold{required}): upper #' bound of the signal integral. #' #' @param background.integral.min \code{\link{integer}} (\bold{required}): #' lower bound of the background integral. #' #' @param background.integral.max \code{\link{integer}} (\bold{required}): #' upper bound of the background integral. #' #' @param method \code{\link{character}} (with default): method applied for constructing the De(t) plot. #' \code{shift} (the default): the chosen signal integral is shifted the shine down curve, #' \code{expansion}: the chosen signal integral is expanded each time by its length #' #' @param signal_integral.seq \code{\link{numeric}} (optional): argument to provide an own #' signal integral sequence for constructing the De(t) plot #' #' @param analyse_function \code{\link{character}} (with default): name of the analyse function #' to be called. Supported functions are: \code{'analyse_SAR.CWOSL'}, \code{'analyse_pIRIRSequence'} #' #' @param analyse_function.control \code{\link{list}} (optional): arguments to be passed to the #' supported analyse functions (\code{'analyse_SAR.CWOSL'}, \code{'analyse_pIRIRSequence'}) #' #' @param n.channels \code{\link{integer}} (optional): number of channels used for the De(t) plot. #' If nothing is provided all De-values are calculated and plotted until the start of the background #' integral. #' #' @param show_ShineDownCurve \code{\link{logical}} (with default): enables or disables shine down #' curve in the plot output #' #' @param respect_RC.Status \code{\link{logical} (with default)}: remove De-values with 'FAILED' RC.Status #' from the plot (cf. \code{\link{analyse_SAR.CWOSL}} and \code{\link{analyse_pIRIRSequence}}) #' #' @param verbose \code{\link{logical} (with default)}: enables or disables terminal feedback #' #' @param \dots further arguments and graphical parameters passed to #' \code{\link{plot.default}}, \code{\link{analyse_SAR.CWOSL}} and \code{\link{analyse_pIRIRSequence}}. #' See details for further information. #' #' @return A plot and an \code{\linkS4class{RLum.Results}} object with the produced De values #' #' \code{@data}: #' \tabular{lll}{ #' \bold{Object} \tab \bold{Type} \tab \bold{Description}\cr #' De.values \tab \code{data.frame} \tab table with De values \cr #' signal_integral.seq \tab \code{numeric} \tab integral sequence used for the calculation #' } #' #' \code{@info}: #' #' \tabular{lll}{ #' \bold{Object} \tab \bold{Type} \tab \bold{Description}\cr #' call \tab \code{call} \tab the original function call #' } #' #' #' #' @note The entire analysis is based on the used analysis functions, namely #' \code{\link{analyse_SAR.CWOSL}} and \code{\link{analyse_pIRIRSequence}}. However, the integrity #' checks of this function are not that thoughtful as in these functions itself. It means, that #' every sequence should be checked carefully before running long calculations using serveral #' hundreds of channels. #' #' @section Function version: 0.1.1 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @references #' #' Bailey, R.M., Singarayer, J.S., Ward, S., Stokes, S., 2003. Identification of partial resetting #' using De as a function of illumination time. Radiation Measurements 37, 511-518. #' doi:10.1016/S1350-4487(03)00063-5 #' #' @seealso \code{\link{plot}}, \code{\link{analyse_SAR.CWOSL}}, \code{\link{analyse_pIRIRSequence}} #' #' @examples #' #' \dontrun{ #' ##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) #' #' plot_DetPlot(object, #' signal.integral.min = 1, #' signal.integral.max = 3, #' background.integral.min = 900, #' background.integral.max = 1000, #' n.channels = 5, #' ) #' } #' #' @export plot_DetPlot <- function( object, signal.integral.min, signal.integral.max, background.integral.min, background.integral.max, method = "shift", signal_integral.seq = NULL, analyse_function = "analyse_SAR.CWOSL", analyse_function.control = list(), n.channels = NULL, show_ShineDownCurve = TRUE, respect_RC.Status = FALSE, verbose = TRUE, ... ) { # Integrity Tests ----------------------------------------------------------------------------- ##get structure object.structure <- structure_RLum(object) # Set parameters ------------------------------------------------------------------------------ ##set n.channels if(is.null(n.channels)){ n.channels <- ceiling( (background.integral.min - 1 - signal.integral.max) / (signal.integral.max - signal.integral.min) ) } analyse_function.settings <- list( sequence.structure = c("TL", "IR50", "pIRIR225"), dose.points = NULL, mtext.outer = "", plot = FALSE, plot.single = FALSE ) analyse_function.settings <- modifyList(analyse_function.settings, analyse_function.control) # Analyse ------------------------------------------------------------------------------------- ##set integral sequence if (is.null(signal_integral.seq)) { signal_integral.seq <- seq(signal.integral.min, background.integral.min - 1, by = signal.integral.max - signal.integral.min) } if(analyse_function == "analyse_SAR.CWOSL"){ results <- merge_RLum(lapply(1:n.channels, function(x){ analyse_SAR.CWOSL( object = object, signal.integral.min = if(method == "shift"){signal_integral.seq[x]}else{signal_integral.seq[1]}, signal.integral.max = signal_integral.seq[x+1], background.integral.min = background.integral.min, background.integral.max = background.integral.max, dose.points = analyse_function.settings$dose.points, mtext.outer = analyse_function.settings$mtext.outer, plot = analyse_function.settings$plot, plot.single = analyse_function.settings$plot.single, verbose = verbose ) })) } else if(analyse_function == "analyse_pIRIRSequence"){ results <- merge_RLum(lapply(1:n.channels, function(x){ analyse_pIRIRSequence( object = object, signal.integral.min = if(method == "shift"){signal_integral.seq[x]}else{signal_integral.seq[1]}, signal.integral.max = signal_integral.seq[x+1], background.integral.min = background.integral.min, background.integral.max = background.integral.max, dose.points = analyse_function.settings$dose.points, mtext.outer = analyse_function.settings$mtext.outer, plot = analyse_function.settings$plot, plot.single = analyse_function.settings$plot.single, sequence.structure = analyse_function.settings$sequence.structure, verbose = verbose ) })) } else{ stop("[plot_DetPlot()] 'analyse_function' unknown!") } # Plot ---------------------------------------------------------------------------------------- ##get De results if(analyse_function == "analyse_pIRIRSequence"){ pIRIR_signals <- unique(get_RLum(results)$Signal) }else{ pIRIR_signals <- NA } ##run this in a loop to account for pIRIR data df_final <- lapply(1:length(pIRIR_signals), function(i){ ##get data.frame df <- get_RLum(results) ##further limit if(!is.na(pIRIR_signals[1])){ df <- df[df$Signal == pIRIR_signals[i],] } ##add shine down curve, which is by definition the first IRSL/OSL curve ##and normalise on the highest De value OSL_curve <- as(get_RLum(object, recordType = "SL")[[i]], "matrix") ##limit to what we see OSL_curve <- OSL_curve[1:signal_integral.seq[n.channels + 1],] m <- ((min(df$De - df$De.Error, na.rm = TRUE)) - (max(df$De, na.rm = TRUE) + max(df$De.Error, na.rm = TRUE))) / (min(OSL_curve[, 2], na.rm = TRUE) - max(OSL_curve[, 2], na.rm = TRUE)) n <- (max(df$De, na.rm = TRUE) + max(df$De.Error, na.rm = TRUE)) - m * max(OSL_curve[, 2]) OSL_curve[, 2] <- m * OSL_curve[, 2] + n rm(n, m) ##set plot settings plot.settings <- list( ylim = c(min(df$De - df$De.Error, na.rm = TRUE), (max(df$De, na.rm = TRUE) + max(df$De.Error, na.rm = TRUE))), xlim = c(min(OSL_curve[, 1]), max(OSL_curve[, 1])), ylab = expression(paste(D[e] / s, " and ", L[n]/(a.u.))), xlab = "Stimulation time [s]", main = "De(t) plot", pch = 1, mtext = ifelse(is.na(pIRIR_signals[1]), "", paste0("Signal: ",pIRIR_signals[i])), cex = 1, legend = c(expression(L[n]-signal), expression(D[e])), legend.pos = "bottomleft" ) plot.settings <- modifyList(plot.settings, list(...)) ##general settings par(cex = plot.settings$cex) ##open plot area plot( NA, NA, xlim = plot.settings$xlim, ylim = plot.settings$ylim, xlab = plot.settings$xlab, ylab = plot.settings$ylab, main = plot.settings$main ) if (show_ShineDownCurve) { lines(OSL_curve, type = "b", pch = 20) } ##set x-axis df_x <- OSL_curve[seq(signal.integral.max, signal_integral.seq[n.channels+1], length.out = nrow(df)),1] #combine everything to allow excluding unwanted values df_final <- cbind(df, df_x) if (respect_RC.Status) { df_final <- df_final[df_final$RC.Status != "FAILED", ] } ##TodDo:color failed points red ##plot points and error bars points(df_final[, c("df_x", "De")], pch = plot.settings$pch) segments( x0 = df_final$df_x, y0 = df_final$De + df_final$De.Error, x1 = df_final$df_x, y1 = df_final$De - df_final$De.Error ) ##set mtext mtext(side = 3, plot.settings$mtext) ##legend legend( plot.settings$legend.pos, legend = plot.settings$legend, pch = c(plot.settings$pch, 20), bty = "n" ) ##set return return(df_final) }) ##merge results return(set_RLum( class = "RLum.Results", data = list( De.values = as.data.frame(data.table::rbindlist(df_final)), signal_integral.seq = signal_integral.seq ), info = list(call = sys.call()) )) } Luminescence/R/calc_FastRatio.R0000644000176200001440000003520213125226556016077 0ustar liggesusers#' Calculate the Fast Ratio for CW-OSL curves #' #' 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 \code{x} and #' \code{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 \code{\linkS4class{RLum.Analysis}}, #' \code{\linkS4class{RLum.Data.Curve}} or \code{\link{data.frame}} #' (\bold{required}): x, y data of measured values (time and counts). #' #' @param stimulation.power \code{\link{numeric}} (with default): Stimulation power in mW/cm^2 #' #' @param wavelength \code{\link{numeric}} (with default): Stimulation wavelength in nm #' #' @param sigmaF \code{\link{numeric}} (with default): Photoionisation cross-section (cm^2) of the #' fast component. Default value after Durcan & Duller (2011). #' #' @param sigmaM \code{\link{numeric}} (with default): Photoionisation cross-section (cm^2) of the #' medium component. Default value after Durcan & Duller (2011). #' #' @param Ch_L1 \code{\link{numeric}} (with default): An integer specifying the channel for L1. #' #' @param Ch_L2 \code{\link{numeric}} (optional): An integer specifying the channel for L2. #' #' @param Ch_L3 \code{\link{numeric}} (optional): A vector of length 2 with integer #' values specifying the start and end channels for L3 (e.g., \code{c(40, 50)}). #' #' @param x \code{\link{numeric}} (with default): \% of signal remaining from the fast component. #' Used to define the location of L2 and L3 (start). #' #' @param x2 \code{\link{numeric}} (with default): \% of signal remaining from the medium component. #' Used to define the location of L3 (end). #' #' @param dead.channels \code{\link{numeric}} (with default): Vector of length 2 in the form of #' \code{c(x, y)}. Channels that do not contain OSL data, i.e. at the start or end of #' measurement. #' #' @param fitCW.sigma \code{\link{logical}} (optional): fit CW-OSL curve using \code{\link{fit_CWCurve}} #' to calculate \code{sigmaF} and \code{sigmaM} (experimental). #' #' @param fitCW.curve \code{\link{logical}} (optional): fit CW-OSL curve using \code{\link{fit_CWCurve}} #' and derive the counts of L2 and L3 from the fitted OSL curve (experimental). #' #' @param plot \code{\link{logical}} (with default): plot output (\code{TRUE}/\code{FALSE}) #' #' @param ... available options: \code{verbose} (\code{\link{logical}}). Further #' arguments passed to \code{\link{fit_CWCurve}}. #' #' @return Returns a plot (optional) and an S4 object of type \code{\linkS4class{RLum.Results}}. #' The slot \code{data} contains a \code{\link{list}} with the following elements:\cr #' #' \item{summary}{\code{\link{data.frame}} summary of all relevant results} #' \item{data}{the original input data} #' \item{fit}{\code{\linkS4class{RLum.Results}} object if either \code{fitCW.sigma} or \code{fitCW.curve} is \code{TRUE}} #' \item{args}{\code{\link{list}} of used arguments} #' \item{call}{\code{\link{call}} the function call} #' #' @section Function version: 0.1.1 #' #' @author #' Georgina King, University of Cologne (Germany) \cr #' Julie A. Durcan, University of Oxford (United Kingdom) \cr #' Christoph Burow, University of Cologne (Germany) \cr #' #' @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. \cr\cr #' #' 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. \cr\cr #' #' \bold{Further reading} \cr\cr #' #' Steffen, D., Preusser, F. & Schlunegger, 2009. OSL quartz age underestimation #' due to unstable signal components. Quaternary Geochronology 4, 353-362. #' #' #' @seealso \code{\link{fit_CWCurve}}, \code{\link{get_RLum}}, \code{\linkS4class{RLum.Analysis}}, #' \code{\linkS4class{RLum.Results}}, \code{\linkS4class{RLum.Data.Curve}} #' #' @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) #' #' @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, ...) { ## Input verification -------------------------------------------------------- if (!is.null(Ch_L3) && length(Ch_L3) != 2) stop("Input for 'Ch_L3' must be a vector of length 2 (e.g., c(40, 50).", call. = FALSE) ## Input object handling ----------------------------------------------------- if (inherits(object, "RLum.Analysis")) object <- get_RLum(object) if (inherits(object, "RLum.Results")) object <- get_RLum(object, "data") 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 # h = 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, output.terminal = settings$output.terminal, plot = plot)) settings$fit <- fitCW.res if (fitCW.sigma) { if (!inherits(fitCW.res, "try-error")) { 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)) } } else { if (settings$verbose) message("Fitting failed! Please call 'fit_CWCurve()' manually before ", "calculating the fast ratio.") } } if (fitCW.curve) { if (!inherits(fitCW.res, "try-error")) { nls <- get_RLum(fitCW.res, "fit") A[ ,2] <- predict(nls) } } } ## 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 { 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). Returned NULL.", t_L2, Ch_L2) settings$info <- modifyList(settings$info, list(L2 = msg)) warning(msg, call. = FALSE) 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) is equal", "to or larger than the number of available channels (%i).", "Returned NULL."), Ch_L2, nrow(A)) settings$info <- modifyList(settings$info, list(L2 = msg)) warning(msg, call. = FALSE) 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) are equal to or", "larger than 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)) warning(msg, call. = FALSE) Ch_L3st <- nrow(A) - 5 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) warning(sprintf("L3 contains more counts (%.f) than L2 (%.f).", Cts_L3, Cts_L2), call. = FALSE) ## Fast Ratio FR <- (Cts_L1 - Cts_L3) / (Cts_L2 - Cts_L3) if (length(FR) != 1) FR <- NA ## Fast Ratio - Error calculation 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 } else { FR_se <- NA FR_rse <- NA } ## 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/read_XSYG2R.R0000644000176200001440000006376213125226556015226 0ustar liggesusers#' Import XSYG files to R #' #' Imports XSYG files produced by a Freiberg Instrument lexsyg reader into R. #' #' \bold{How does the import function work?}\cr\cr The function uses the #' \code{\link{xml}} package to parse the file structure. Each sequence is #' subsequently translated into an \code{\linkS4class{RLum.Analysis}} #' object.\cr\cr #' #' \bold{General structure XSYG format}\cr\cr \code{}\cr \code{ }\cr \code{ }\cr \code{ }\cr \code{ }\cr \code{ #' x0 , y0 ; x1 , y1 ; x2 , y2 ; x3 , y3}\cr \code{ }\cr \code{ #' }\cr \code{ }\cr \code{ }\cr\cr So far, each #' XSYG file can only contain one \code{}, but multiple #' sequences. \cr\cr Each record may comprise several curves.\cr\cr #' #' \bold{TL curve recalculation}\cr #' #' On the FI lexsyg device TL curves are recorded as time against count values. #' Temperature values are monitored on the heating plate and stored in a #' separate curve (time vs. temperature). If the option #' \code{recalculate.TL.curves = TRUE} is chosen, the time values for each TL #' curve are replaced by temperature values.\cr #' #' Practically, this means combining two matrices (Time vs. Counts and Time vs. #' Temperature) with different row numbers by their time values. Three cases #' are considered: #' #' HE: Heating element\cr PMT: Photomultiplier tube\cr Interpolation is done #' using the function \code{\link{approx}}\cr #' #' CASE (1): \code{nrow(matrix(PMT))} > \code{nrow(matrix(HE))} \cr #' #' Missing temperature values from the heating element are calculated using #' time values from the PMT measurement.\cr #' #' CASE (2): \code{nrow(matrix(PMT))} < \code{nrow(matrix(HE))} \cr #' #' Missing count values from the PMT are calculated using time values from the #' heating element measurement.\cr #' #' CASE (3): \code{nrow(matrix(PMT))} == \code{nrow(matrix(HE))} \cr #' #' A new matrix is produced using temperature values from the heating element #' and count values from the PMT. \cr #' #' \emph{Note: Please note that due to the recalculation of the temperature #' values based on values delivered by the heating element, it may happen that #' mutiple count values exists for each temperature value and temperature #' values may also decrease during heating, not only increase. }\cr #' #' \bold{Advanced file import}\cr #' #' To allow for a more efficient usage of the function, instead of single path to a file just #' a directory can be passed as input. In this particular case the function tries to extract #' all XSYG-files found in the directory and import them all. Using this option internally the function #' constructs as list of the XSYG-files found in the directory. Please note no recursive detection #' is supported as this may lead to endless loops. #' #' @param file \code{\link{character}} or \code{\link{list}} (\bold{required}): path and file name of the #' XSYG file. If input is a \code{list} it should comprise only \code{character}s representing each valid #' path and xsyg-file names. Alternatively the input character can be just a directory (path), in this case the #' the function tries to detect and import all xsyg files found in the directory. #' #' @param recalculate.TL.curves \link{logical} (with default): if set to #' \code{TRUE}, TL curves are returned as temperature against count values (see #' details for more information) Note: The option overwrites the time vs. count #' TL curve. Select \code{FALSE} to import the raw data delivered by the #' lexsyg. Works for TL curves and spectra. #' #' @param fastForward \code{\link{logical}} (with default): if \code{TRUE} for a #' more efficient data processing only a list of \code{RLum.Analysis} objects is returned. #' #' @param import \code{\link{logical}} (with default): if set to \code{FALSE}, only #' the XSYG file structure is shown. #' #' @param pattern \code{\link{regex}} (with default): optional regular expression if \code{file} is #' a link to a folder, to select just specific XSYG-files #' #' @param txtProgressBar \link{logical} (with default): enables \code{TRUE} or #' disables \code{FALSE} the progression bar during import #' #' @return \bold{Using the option \code{import = FALSE}}\cr\cr A list #' consisting of two elements is shown: \item{Sample}{\link{data.frame} with #' information on file.} \item{Sequences}{\link{data.frame} with information on #' the sequences stored in the XSYG file}.\cr\cr \bold{Using the option #' \code{import = TRUE} (default)} \cr\cr A list is provided, the list elements #' contain: \item{Sequence.Header}{\link{data.frame} with information on the #' sequence.} \item{Sequence.Object}{\code{\linkS4class{RLum.Analysis}} #' containing the curves.} #' #' @note This function is a beta version as the XSYG file format is not yet #' fully specified. Thus, further file operations (merge, export, write) should #' be done using the functions provided with the package \code{\link{xml}}.\cr #' #' \bold{So far, no image data import is provided!}\cr Corresponding values in #' the XSXG file are skipped. #' #' #' @section Function version: 0.5.8 #' #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' #' @seealso \code{\link{xml}}, \code{\linkS4class{RLum.Analysis}}, #' \code{\linkS4class{RLum.Data.Curve}}, \code{\link{approx}} #' #' #' @references Grehl, S., Kreutzer, S., Hoehne, M., 2013. Documentation of the #' XSYG file format. Unpublished Technical Note. Freiberg, Germany \cr\cr #' #' \bold{Further reading} \cr\cr XML: \url{http://en.wikipedia.org/wiki/XML} #' #' #' @keywords IO #' #' @examples #' #' #' ##(1) import XSYG file to R (uncomment for usage) #' #' #FILE <- file.choose() #' #temp <- read_XSYG2R(FILE) #' #' ##(2) additional examples for pure XML import using the package XML #' ## (uncomment for usage) #' #' ##import entire XML file #' #FILE <- file.choose() #' #temp <- XML::xmlRoot(XML::xmlTreeParse(FILE)) #' #' ##search for specific subnodes with curves containing 'OSL' #' #getNodeSet(temp, "//Sample/Sequence/Record[@@recordType = 'OSL']/Curve") #' #' ##(2) How to extract single curves ... after import #' data(ExampleData.XSYG, envir = environment()) #' #' ##grep one OSL curves and plot the first curve #' OSLcurve <- get_RLum(OSL.SARMeasurement$Sequence.Object, recordType="OSL")[[1]] #' #' ##(3) How to see the structure of an object? #' structure_RLum(OSL.SARMeasurement$Sequence.Object) #' #' #' @export read_XSYG2R <- function( file, recalculate.TL.curves = TRUE, fastForward = FALSE, import = TRUE, pattern = ".xsyg", txtProgressBar = 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 xsyg/XSYG files in the # directory and import them, if this is detected, we proceed as list if(is(file, "character")) { ##If this is not really a path we skip this here if (dir.exists(file) & length(dir(file)) > 0) { message("[read_XSYG2R()] Directory detected, trying to extract '*.xsyg' files ...\n") file <- as.list(paste0(file,dir( file, recursive = TRUE, pattern = pattern ))) } } if (is(file, "list")) { temp.return <- lapply(1:length(file), function(x) { read_XSYG2R( file = file[[x]], recalculate.TL.curves = recalculate.TL.curves, fastForward = fastForward, import = import, txtProgressBar = txtProgressBar ) }) ##return if (fastForward) { if(import){ return(unlist(temp.return, recursive = FALSE)) }else{ return(as.data.frame(data.table::rbindlist(temp.return))) } }else{ return(temp.return) } } # Consistency check ------------------------------------------------------- ##check if file exists if(!file.exists(file)){ warning("[read_XSYG2R()] Wrong file name or file does not exist, nothing imported!") return(NULL) } #TODO to be included again in a future version, if the format is given in the file itself # ##check if file is XML file # if(tail(unlist(strsplit(file, split = "\\.")), 1) != "xsyg" & # tail(unlist(strsplit(file, split = "\\.")), 1) != "XSYG" ){ # # warning("[read_XSYG2R()] File is not of type 'XSYG', nothing imported!") # return(NULL) # # } # (0) config -------------------------------------------------------------- #version.supported <- c("1.0") #additional functions ##get curve values get_XSYG.curve.values <- function(curve.node){ ##Four steps ##(1) split string to paris of xy-values ##(2) split string to xy-values itself ##(3) convert to numeric ##(4) create matrix curve.node <- t( vapply( strsplit( strsplit( XML::xmlValue(curve.node), split = ";", fixed = TRUE)[[1]], split = ",", fixed = TRUE), FUN = as.numeric, FUN.VALUE = c(1,1L))) } get_XSYG.spectrum.values <- function(curve.node){ ##1st grep wavelength table wavelength <- XML::xmlAttrs(curve.node)["wavelengthTable"] ##string split wavelength <- as.numeric(unlist(strsplit(wavelength, split = ";", fixed = TRUE))) ##2nd grep time values curve.node <- unlist(strsplit(XML::xmlValue(curve.node), split = ";", fixed = TRUE)) curve.node <- unlist(strsplit(curve.node, split = ",", fixed = TRUE), recursive = FALSE) curve.node.time <- as.numeric(curve.node[seq(1,length(curve.node),2)]) ##3rd grep count values curve.node.count <- as.character(curve.node[seq(2,length(curve.node),2)]) ##remove from pattern... curve.node.count <- do.call("gsub", list(pattern="[[]|[]]", replacement=" ", x=curve.node.count)) ##4th combine to spectrum matrix spectrum.matrix <- matrix(0,length(wavelength),length(curve.node.time)) spectrum.matrix <- sapply(1:length(curve.node.time), function(x){ as.numeric(unlist(strsplit(curve.node.count[x], "[|]"))) }) ##change row names (rows are wavelength) rownames(spectrum.matrix) <- round(wavelength, digits=3) ##change column names (columns are time/temp values) colnames(spectrum.matrix) <- round(curve.node.time, digits=3) return(spectrum.matrix) } # (1) Integrity tests ----------------------------------------------------- ##parse XML tree using the package XML temp <- try(XML::xmlRoot(XML::xmlTreeParse(file, useInternalNodes = TRUE)), silent = TRUE) ##show error if(is(temp, "try-error") == TRUE){ warning("[read_XSYG2R()] XML file not readable, nothing imported!)") return(NULL) } # (2) Further file processing --------------------------------------------- ##==========================================================================## ##SHOW STRUCTURE if(import == FALSE){ ##sample information temp.sample <- as.data.frame(XML::xmlAttrs(temp), stringsAsFactors = FALSE) ##grep sequences files ##set data.frame temp.sequence.header <- data.frame(t(1:length(names(XML::xmlAttrs(temp[[1]])))), stringsAsFactors = FALSE) colnames(temp.sequence.header) <- names(XML::xmlAttrs(temp[[1]])) ##fill information in data.frame for(i in 1:XML::xmlSize(temp)){ temp.sequence.header[i,] <- t(XML::xmlAttrs(temp[[i]])) } ##additional option for fastForward == TRUE if(fastForward){ ##change column header temp.sample <- t(temp.sample) colnames(temp.sample) <- paste0("sample::", colnames(temp.sample)) output <- cbind(temp.sequence.header, temp.sample) }else{ output <- list(Sample = temp.sample, Sequences = temp.sequence.header) } return(output) }else{ ##==========================================================================## ##IMPORT XSYG FILE ##Display output message(paste0("[read_XSYG2R()]\n Importing: ",file)) ##PROGRESS BAR if(txtProgressBar){ pb <- txtProgressBar(min=0,max=XML::xmlSize(temp), char = "=", style=3) } ##loop over the entire sequence by sequence output <- lapply(1:XML::xmlSize(temp), function(x){ ##read sequence header temp.sequence.header <- as.data.frame(XML::xmlAttrs(temp[[x]]), stringsAsFactors = FALSE) colnames(temp.sequence.header) <- "" ###----------------------------------------------------------------------- ##LOOP ##read records >> records are combined to one RLum.Analysis object temp.sequence.object <- unlist(lapply(1:XML::xmlSize(temp[[x]]), function(i){ ##get recordType temp.sequence.object.recordType <- try(XML::xmlAttrs(temp[[x]][[i]])["recordType"], silent = TRUE) ##the XSYG file might be broken due to a machine error during the measurement, this ##control flow helps; if a try-error is observed NULL is returned if(!inherits(temp.sequence.object.recordType, "try-error")){ ##correct record type in depending on the stimulator if(temp.sequence.object.recordType == "OSL"){ if(XML::xmlAttrs(temp[[x]][[i]][[ XML::xmlSize(temp[[x]][[i]])]])["stimulator"] == "ir_LED_850" | XML::xmlAttrs(temp[[x]][[i]][[ XML::xmlSize(temp[[x]][[i]])]])["stimulator"] == "ir_LD_850"){ temp.sequence.object.recordType <- "IRSL" } } ##loop 3rd level lapply(1:XML::xmlSize(temp[[x]][[i]]), function(j){ ##get values temp.sequence.object.curveValue <- temp[[x]][[i]][[j]] ##get curveType temp.sequence.object.curveType <- as.character( XML::xmlAttrs(temp[[x]][[i]][[j]])["curveType"]) ##get detector temp.sequence.object.detector <- as.character( XML::xmlAttrs(temp[[x]][[i]][[j]])["detector"]) ##get stimulator temp.sequence.object.stimulator <- as.character( XML::xmlAttrs(temp[[x]][[i]][[j]])["stimulator"]) ##get parentID temp.sequence.object.parentID <- as.numeric( XML::xmlAttrs(temp[[x]][[i]][[j]])["partentID"]) ##get additional information temp.sequence.object.info <- as.list(XML::xmlAttrs(temp.sequence.object.curveValue)) ##add stimulator and detector and so on temp.sequence.object.info <- c(temp.sequence.object.info, partentID = temp.sequence.object.parentID, position = as.integer(as.character(temp.sequence.header["position",])), name = as.character(temp.sequence.header["name",])) ## TL curve recalculation ============================================ if(recalculate.TL.curves == TRUE){ ##TL curve heating values is stored in the 3rd curve of every set if(temp.sequence.object.recordType == "TL" && j == 1){ #grep values from PMT measurement or spectrometer if("Spectrometer" %in% temp.sequence.object.detector == FALSE){ temp.sequence.object.curveValue.PMT <- get_XSYG.curve.values( temp[[x]][[i]][[j]]) ##round values (1 digit is technical resolution of the heating element) temp.sequence.object.curveValue.PMT[,1] <- round( temp.sequence.object.curveValue.PMT[,1], digits = 1) #grep values from heating element temp.sequence.object.curveValue.heating.element <- get_XSYG.curve.values( temp[[x]][[i]][[3]]) }else{ temp.sequence.object.curveValue.spectrum <- get_XSYG.spectrum.values( temp.sequence.object.curveValue) ##get time values which are stored in the row labels temp.sequence.object.curveValue.spectrum.time <- as.numeric( colnames(temp.sequence.object.curveValue.spectrum)) ##round values (1 digit is technical resolution of the heating element) temp.sequence.object.curveValue.spectrum.time <- round( temp.sequence.object.curveValue.spectrum.time, digits = 1) } #grep values from heating element temp.sequence.object.curveValue.heating.element <- get_XSYG.curve.values( temp[[x]][[i]][[3]]) if("Spectrometer" %in% temp.sequence.object.detector == FALSE){ #reduce matrix values to values of the detection temp.sequence.object.curveValue.heating.element <- temp.sequence.object.curveValue.heating.element[ temp.sequence.object.curveValue.heating.element[,1] >= min(temp.sequence.object.curveValue.PMT[,1]) & temp.sequence.object.curveValue.heating.element[,1] <= max(temp.sequence.object.curveValue.PMT[,1]),] }else{ #reduce matrix values to values of the detection temp.sequence.object.curveValue.heating.element <- temp.sequence.object.curveValue.heating.element[ temp.sequence.object.curveValue.heating.element[,1] >= min(temp.sequence.object.curveValue.spectrum.time) & temp.sequence.object.curveValue.heating.element[,1] <= max(temp.sequence.object.curveValue.spectrum.time),] } ## calculate corresponding heating rate, this makes only sense ## for linear heating, therefore is has to be the maximum value ##remove 0 values (not measured) and limit to peak heating.rate.values <- temp.sequence.object.curveValue.heating.element[ temp.sequence.object.curveValue.heating.element[,2] > 0 & temp.sequence.object.curveValue.heating.element[,2] <= max(temp.sequence.object.curveValue.heating.element[,2]),] heating.rate <- (heating.rate.values[length(heating.rate.values[,2]), 2] - heating.rate.values[1,2])/ (heating.rate.values[length(heating.rate.values[,1]), 1] - heating.rate.values[1,1]) ##round values heating.rate <- round(heating.rate, digits=1) ##add to info element temp.sequence.object.info <- c(temp.sequence.object.info, RATE = heating.rate) ##PERFORM RECALCULATION ##check which object contains more data if("Spectrometer" %in% temp.sequence.object.detector == FALSE){ ##CASE (1) if(nrow(temp.sequence.object.curveValue.PMT) > nrow(temp.sequence.object.curveValue.heating.element)){ temp.sequence.object.curveValue.heating.element.i <- approx( x = temp.sequence.object.curveValue.heating.element[,1], y = temp.sequence.object.curveValue.heating.element[,2], xout = temp.sequence.object.curveValue.PMT[,1], rule = 2) temperature.values <- temp.sequence.object.curveValue.heating.element.i$y count.values <- temp.sequence.object.curveValue.PMT[,2] ##CASE (2) }else if((nrow(temp.sequence.object.curveValue.PMT) < nrow(temp.sequence.object.curveValue.heating.element))){ temp.sequence.object.curveValue.PMT.i <- approx( x = temp.sequence.object.curveValue.PMT[,1], y = temp.sequence.object.curveValue.PMT[,2], xout = temp.sequence.object.curveValue.heating.element[,1], rule = 2) temperature.values <- temp.sequence.object.curveValue.heating.element[,2] count.values <- temp.sequence.object.curveValue.PMT.i$y ##CASE (3) }else{ temperature.values <- temp.sequence.object.curveValue.heating.element[,2] count.values <- temp.sequence.object.curveValue.PMT[,2] } ##combine as matrix temp.sequence.object.curveValue <- as.matrix(cbind( temperature.values, count.values)) ##set curve identifier temp.sequence.object.info$curveDescripter <- "Temperature [\u00B0C]; Counts [a.u.]" }else{ ##CASE (1) here different approach. in contrast to the PMT measurements, as ## usually the resolution should be much, much lower for such measurements ## Otherwise we would introduce some pseudo signals, as we have to ## take care of noise later one if(length(temp.sequence.object.curveValue.spectrum.time) != nrow(temp.sequence.object.curveValue.heating.element)){ temp.sequence.object.curveValue.heating.element.i <- approx( x = temp.sequence.object.curveValue.heating.element[,1], y = temp.sequence.object.curveValue.heating.element[,2], xout = temp.sequence.object.curveValue.spectrum.time, rule = 2, ties = -2) temperature.values <- temp.sequence.object.curveValue.heating.element.i$y ##check for duplicated values and if so, increase this values if(anyDuplicated(temperature.values)>0){ temperature.values[which(duplicated(temperature.values))] <- temperature.values[which(duplicated(temperature.values))]+1 warning("read_XSYG2R()] Temperatures values are found to be duplicated and increased by 1 K") } ##CASE (2) (equal) }else{ temperature.values <- temp.sequence.object.curveValue.heating.element[,2] } ##reset values of the matrix colnames(temp.sequence.object.curveValue.spectrum) <- temperature.values temp.sequence.object.curveValue <- temp.sequence.object.curveValue.spectrum ##change curve descriptor temp.sequence.object.info$curveDescripter <- "Temperature [\u00B0C]; Wavelength [nm]; Counts [1/ch]" } }##endif }##endif recalculate.TL.curves == TRUE ##Set RLum.Data objects if("Spectrometer" %in% temp.sequence.object.detector == FALSE){ if(is(temp.sequence.object.curveValue, "matrix") == FALSE){ temp.sequence.object.curveValue <- get_XSYG.curve.values(temp.sequence.object.curveValue) } set_RLum( class = "RLum.Data.Curve", originator = "read_XSYG2R", recordType = paste(temp.sequence.object.recordType, " (", temp.sequence.object.detector,")", sep = ""), curveType = temp.sequence.object.curveType, data = temp.sequence.object.curveValue, info = temp.sequence.object.info) }else if("Spectrometer" %in% temp.sequence.object.detector == TRUE) { if(is(temp.sequence.object.curveValue, "matrix") == FALSE){ temp.sequence.object.curveValue <- get_XSYG.spectrum.values(temp.sequence.object.curveValue) } set_RLum( class = "RLum.Data.Spectrum", originator = "read_XSYG2R", recordType = paste(temp.sequence.object.recordType, " (",temp.sequence.object.detector,")", sep = ""), curveType = temp.sequence.object.curveType, data = temp.sequence.object.curveValue, info = temp.sequence.object.info) } }) }else{ return(NULL) }##if-try condition }), use.names = FALSE) ##if the XSYG file is broken we get NULL as list element if (!is.null(temp.sequence.object)) { ##set RLum.Analysis object temp.sequence.object <- set_RLum( originator = "read_XSYG2R", class = "RLum.Analysis", records = temp.sequence.object, protocol = as.character(temp.sequence.header["protocol",1]) ) ##set parent uid of RLum.Anlaysis as parent ID of the records temp.sequence.object <- .set_pid(temp.sequence.object) ##update progress bar if (txtProgressBar) { setTxtProgressBar(pb, x) } ##merge output and return values if(fastForward){ return(temp.sequence.object) }else{ return(list(Sequence.Header = temp.sequence.header, Sequence.Object = temp.sequence.object)) } }else{ return(temp.sequence.object) } })##end loop for sequence list ##close ProgressBar if(txtProgressBar ){close(pb)} ##show output informatioj if(length(output[sapply(output, is.null)]) == 0){ message(paste("\t >>",XML::xmlSize(temp), " sequence(s) loaded successfully.\n"), sep = "") }else{ message(paste("\t >>",XML::xmlSize(temp), " sequence(s) in file.", XML::xmlSize(temp)-length(output[sapply(output, is.null)]), "sequence(s) loaded successfully. \n"), sep = "") warning(paste0(length(output[sapply(output, is.null)])), " incomplete sequence(s) removed.") } ##output invisible(output) }#end if ##get rid of the NULL elements (as stated before ... invalid files) return(output[!sapply(output,is.null)]) } Luminescence/R/model_LuminescenceSignals.R0000644000176200001440000000277613125226556020346 0ustar liggesusers#' Model Luminescence Signals (wrapper) #' #' Wrapper for the function \code{\link[RLumModel]{model_LuminescenceSignals}} from the package #' \link[RLumModel]{RLumModel-package}. For the further details and examples please #' see the manual of this package. #' #' @inheritParams RLumModel::model_LuminescenceSignals #' #' @author Johannes Friedrich, University of Bayreuth (Germany),\cr #' Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaige (France), \cr #' #' #' @section Function version: 0.1.3 #' #' @export model_LuminescenceSignals <- function(model, sequence, lab.dose_rate = 1, simulate_sample_history = FALSE, plot = TRUE, verbose = TRUE, show_structure = FALSE, own_parameters = NULL, own_state_parameters = NULL, own_start_temperature = NULL, ...) { if (!requireNamespace("RLumModel", quietly = TRUE)) stop("Simulation of luminescence signals requires the 'RLumModel' package.", " To install this package run 'install.packages('RLumModel')' in your R console.", call. = FALSE) RLumModel::model_LuminescenceSignals ( model = model, sequence = sequence, lab.dose_rate = lab.dose_rate, simulate_sample_history = simulate_sample_history , plot = plot, verbose = verbose, show_structure = show_structure, own_parameters = NULL, own_state_parameters = NULL, own_start_temperature = NULL, ... ) } Luminescence/R/PSL2Risoe.BINfileData.R0000644000176200001440000001762113125226556017011 0ustar liggesusers#' Convert portable OSL data to an Risoe.BINfileData object #' #' Converts an \code{RLum.Analysis} object produced by the function \code{read_PSL2R()} to #' an \code{Risoe.BINfileData} object \bold{(BETA)}. #' #' This function converts an \code{\linkS4class{RLum.Analysis}} object that was produced #' by the \code{\link{read_PSL2R}} function to an \code{\linkS4class{Risoe.BINfileData}}. #' The \code{Risoe.BINfileData} can be used to write a Risoe BIN file via #' \code{\link{write_R2BIN}}. #' #' @param object \code{\linkS4class{RLum.Analysis}} (\bold{required}): #' \code{RLum.Analysis} object produced by \code{\link{read_PSL2R}} #' #' @param ... currently not used. #' #' @return Returns an S4 \code{\linkS4class{Risoe.BINfileData}} object that can #' be used to write a BIN file using \code{\link{write_R2BIN}}. #' #' @seealso \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{Risoe.BINfileData}} #' #' @author Christoph Burow, University of Cologne (Germany) #' #' @section Function version: 0.0.1 #' #' @keywords IO #' #' @examples #' #' # (1) load and plot example data set #' data("ExampleData.portableOSL", envir = environment()) #' plot_RLum(ExampleData.portableOSL) #' #' # (2) merge all RLum.Analysis objects into one #' merged <- merge_RLum(ExampleData.portableOSL) #' merged #' #' # (3) convert to RisoeBINfile object #' bin <- PSL2Risoe.BINfileData(merged) #' bin #' #' # (4) write Risoe BIN file #' \dontrun{ #' write_R2BIN(bin, "~/portableOSL.binx") #' } #' #' @export PSL2Risoe.BINfileData <- function(object, ...) { ## INTEGRITY CHECKS ---- if (!inherits(object, "RLum.Analysis")) stop("Only objects of class 'RLum.Analysis' are allowed.", call. = FALSE) if (!all(sapply(object, class) == "RLum.Data.Curve")) stop("The 'RLum.Analysis' object must only contain objects of class 'RLum.Data.Curve'.", call. = FALSE) if (!all(sapply(object, function(x) x@originator) == "read_PSL2R")) stop("Only objects originating from 'read_PSL2R()' are allowed.", call. = FALSE) ## EXTRACT CURVE INFORMATION ---- curves <- get_RLum(object) ## COLLECT META INFORMATION ---- META <- do.call(rbind, lapply(curves, function(x) { NPOINTS <- as.integer(x@info$settings$stimulation_time) LTYPE <- x@info$settings$stimulation_unit COMMENT <- x@info$settings$measurement HIGH <- x@info$settings$stimulation_time DATE <- format(x@info$settings$Date, format = "%d%m%y") TIME <- x@info$settings$Time if (nchar(TIME) < 8) TIME <- paste0("0", TIME) SAMPLE <- x@info$settings$Sample FNAME <- x@info$settings$Filename SEQUENCE <- strtrim(paste(x@info$settings$Run_Name, x@info$settings$Sample_no), 8) return(data.frame(NPOINTS = NPOINTS, LTYPE = LTYPE, COMMENT = COMMENT, HIGH = HIGH, DATE = DATE, TIME = TIME, SAMPLE = SAMPLE, FNAME = FNAME, SEQUENCE = SEQUENCE)) })) ## SAVE DATA ---- DATA <- lapply(curves, function(x) { as.integer(x@data[ ,2]) }) # SAVE METADATA ---- METADATA <- data.frame(ID = seq(1, length(curves), 1), SEL = rep(TRUE, length(curves)), VERSION = rep(7, length(curves)), LENGTH = 447 + 4 * META$NPOINTS, PREVIOUS = 447 + 4 * META$NPOINTS, NPOINTS = META$NPOINTS, RUN = seq(1, length(curves), 1), SET = rep(1, length(curves)), POSITION = rep(1, length(curves)), GRAIN = rep(0, length(curves)), GRAINNUMBER = rep(0, length(curves)), CURVENO = rep(0, length(curves)), XCOORD = rep(0, length(curves)), YCOORD = rep(0, length(curves)), SAMPLE = META$SAMPLE, COMMENT = META$COMMENT, SYSTEMID = rep(0, length(curves)), FNAME = META$FNAME, USER = rep("RLum", length(curves)), TIME = META$TIME, DATE = META$DATE, DTYPE = rep("Natural", length(curves)), BL_TIME = rep(0, length(curves)), BL_UNIT = rep(0, length(curves)), NORM1 = rep(0, length(curves)), NORM2 = rep(0, length(curves)), NORM3 = rep(0, length(curves)), BG = rep(0, length(curves)), SHIFT = rep(0, length(curves)), TAG = rep(1, length(curves)), LTYPE = META$LTYPE, LIGHTSOURCE = rep("None", length(curves)), LPOWER = rep(100, length(curves)), LIGHTPOWER = rep(100, length(curves)), LOW = rep(0, length(curves)), HIGH = META$HIGH, RATE = rep(0, length(curves)), TEMPERATURE = rep(0, length(curves)), MEASTEMP = rep(0, length(curves)), AN_TEMP = rep(0, length(curves)), AN_TIME = rep(0, length(curves)), TOLDELAY = rep(0, length(curves)), TOLON = rep(0, length(curves)), TOLOFF = rep(0, length(curves)), IRR_TIME = rep(0, length(curves)), IRR_TYPE = rep(0L, length(curves)), IRR_UNIT = rep(0, length(curves)), IRR_DOSERATE = rep(0, length(curves)), IRR_DOSERATEERR = rep(0, length(curves)), TIMESINCEIRR = rep(-1, length(curves)), TIMETICK = rep(1e-07, length(curves)), ONTIME = rep(0, length(curves)), OFFTIME = rep(NA, length(curves)), STIMPERIOD = rep(0, length(curves)), GATE_ENABLED = rep(0, length(curves)), ENABLE_FLAGS = rep(0, length(curves)), GATE_START = rep(0, length(curves)), GATE_STOP = rep(0, length(curves)), PTENABLED = rep(0, length(curves)), DTENABLED = rep(0, length(curves)), DEADTIME = rep(0, length(curves)), MAXLPOWER = rep(0, length(curves)), XRF_ACQTIME = rep(0, length(curves)), XRF_HV = rep(0, length(curves)), XRF_CURR = rep(0, length(curves)), XRF_DEADTIMEF = rep(0, length(curves)), SEQUENCE = META$SEQUENCE, DETECTOR_ID = rep(NA, length(curves)), LOWERFILTER_ID = rep(NA, length(curves)), UPPERFILTER_ID = rep(NA, length(curves)), ENOISEFACTOR = rep(NA, length(curves)), MARKPOS_X1 = rep(0, length(curves)), MARKPOS_Y1 = rep(0, length(curves)), MARKPOS_X2 = rep(0, length(curves)), MARKPOS_Y2 = rep(0, length(curves)), MARKPOS_X3 = rep(0, length(curves)), MARKPOS_Y3 = rep(0, length(curves)), EXTR_START = rep(0, length(curves)), EXTR_END = rep(0, length(curves)), RECTYPE = rep(0, length(curves))) ## CREATE Risoe.BINfileData OBJECT ---- bin <- set_Risoe.BINfileData(METADATA = METADATA, DATA = DATA, .RESERVED = list()) ## RETURN VALUE ---- return(bin) } Luminescence/R/calc_MinDose.R0000644000176200001440000010772413125226556015552 0ustar liggesusers#' Apply the (un-)logged minimum age model (MAM) after Galbraith et al. (1999) #' to a given De distribution #' #' Function to fit the (un-)logged three or four parameter minimum dose model #' (MAM-3/4) to De data. #' #' \bold{Parameters} \cr\cr #' This model has four parameters: \cr\cr #' \tabular{rl}{ \code{gamma}: \tab minimum dose on the log scale \cr #' \code{mu}: \tab mean of the non-truncated normal distribution \cr #' \code{sigma}: \tab spread in ages above the minimum \cr \code{p0}: \tab #' proportion of grains at gamma \cr } If \code{par=3} (default) the #' 3-parametric minimum age model is applied, where \code{gamma=mu}. For #' \code{par=4} the 4-parametric model is applied instead.\cr\cr #' #' \bold{(Un-)logged model} \cr\cr #' In the original version of the minimum dose model, the basic data are the natural #' logarithms of the De estimates and relative standard errors of the De #' estimates. The value for \code{sigmab} must be provided as a ratio #' (e.g, 0.2 for 20 \%). This model will be applied if \code{log=TRUE}. \cr\cr #' #' If \code{log=FALSE}, the modified un-logged model will be applied instead. This #' has essentially the same form as the original version. \code{gamma} and #' \code{sigma} are in Gy and \code{gamma} becomes the minimum true dose in the #' population. \bold{Note} that the un-logged model requires \code{sigmab} to be in the same #' absolute unit as the provided De values (seconds or Gray). \cr\cr #' #' While the original (logged) version of the mimimum dose #' model may be appropriate for most samples (i.e. De distributions), the #' modified (un-logged) version is specially designed for modern-age and young #' samples containing negative, zero or near-zero De estimates (Arnold et al. #' 2009, p. 323). \cr\cr #' #' \bold{Initial values & boundaries} \cr\cr #' The log likelihood calculations use the \link{nlminb} function for box-constrained #' optimisation using PORT routines. Accordingly, initial values for the four #' parameters can be specified via \code{init.values}. If no values are #' provided for \code{init.values} reasonable starting values are estimated #' from the input data. If the final estimates of \emph{gamma}, \emph{mu}, #' \emph{sigma} and \emph{p0} are totally off target, consider providing custom #' starting values via \code{init.values}. \cr In contrast to previous versions #' of this function the boundaries for the individual model parameters are no #' longer required to be explicitly specified. If you want to override the default #' boundary values use the arguments \code{gamma.lower}, \code{gamma.upper}, #' \code{sigma.lower}, \code{sigma.upper}, \code{p0.lower}, \code{p0.upper}, #' \code{mu.lower} and \code{mu.upper}. \cr\cr #' #' \bold{Bootstrap} \cr\cr #' When \code{bootstrap=TRUE} the function applies the bootstrapping method as #' described in Wallinga & Cunningham (2012). By default, the minimum age model #' produces 1000 first level and 3000 second level bootstrap replicates #' (actually, the number of second level bootstrap replicates is three times #' the number of first level replicates unless specified otherwise). The #' uncertainty on sigmab is 0.04 by default. These values can be changed by #' using the arguments \code{bs.M} (first level replicates), \code{bs.N} #' (second level replicates) and \code{sigmab.sd} (error on sigmab). With #' \code{bs.h} the bandwidth of the kernel density estimate can be specified. #' By default, \code{h} is calculated as \cr \deqn{h = #' (2*\sigma_{DE})/\sqrt{n}} \cr #' #' \bold{Multicore support} \cr\cr #' This function supports parallel computing and can be activated by \code{multicore=TRUE}. #' By default, the number of available logical CPU cores is determined #' automatically, but can be changed with \code{cores}. The multicore support #' is only available when \code{bootstrap=TRUE} and spawns \code{n} R instances #' for each core to get MAM estimates for each of the N and M boostrap #' replicates. Note that this option is highly experimental and may or may not #' work for your machine. Also the performance gain increases for larger number #' of bootstrap replicates. Also note that with each additional core and hence #' R instance and depending on the number of bootstrap replicates the memory #' usage can significantly increase. Make sure that memory is always availabe, #' otherwise there will be a massive perfomance hit. \cr\cr #' #' \bold{Likelihood profiles} #' #' The likelihood profiles are generated and plotted by the \code{bbmle} package. #' The profile likelihood plots look different to ordinary profile likelihood as \cr\cr #' "[...] the plot method for likelihood profiles displays the square root of #' the the deviance difference (twice the difference in negative log-likelihood from #' the best fit), so it will be V-shaped for cases where the quadratic approximation #' works well [...]." (Bolker 2016). \cr\cr #' For more details on the profile likelihood #' calculations and plots please see the vignettes of the \code{bbmle} package #' (also available here: \url{https://CRAN.R-project.org/package=bbmle}). #' #' @param data \code{\linkS4class{RLum.Results}} or \link{data.frame} #' (\bold{required}): for \code{data.frame}: two columns with De \code{(data[ #' ,1])} and De error \code{(data[ ,2])}. #' #' @param sigmab \code{\link{numeric}} (\bold{required}): 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). #' \bold{NOTE}: For the logged model (\code{log = TRUE}) this value must be #' a fraction, e.g. 0.2 (= 20 \%). If the un-logged model is used (\code{log = FALSE}), #' sigmab must be provided in the same absolute units of the De values (seconds or Gray). #' See details. #' #' @param log \code{\link{logical}} (with default): fit the (un-)logged minimum #' dose model to De data. #' #' @param par \code{\link{numeric}} (with default): apply the 3- or #' 4-parametric minimum age model (\code{par=3} or \code{par=4}). The MAM-3 is #' used by default. #' #' @param bootstrap \code{\link{logical}} (with default): apply the recycled #' bootstrap approach of Cunningham & Wallinga (2012). #' #' @param init.values \code{\link{numeric}} (optional): a named list with #' starting values for gamma, sigma, p0 and mu (e.g. \code{list(gamma=100 #' sigma=1.5, p0=0.1, mu=100)}). If no values are provided reasonable values #' are tried to be estimated from the data. #' #' @param level \code{\link{logical}} (with default): the confidence level #' required (defaults to 0.95). #' #' @param plot \code{\link{logical}} (with default): plot output #' (\code{TRUE}/\code{FALSE}) #' #' @param multicore \code{\link{logical}} (with default): enable parallel #' computation of the bootstrap by creating a multicore SNOW cluster. Depending #' on the number of available logical CPU cores this may drastically reduce #' the computation time. Note that this option is highly experimental and may not #' work on all machines. (\code{TRUE}/\code{FALSE}) #' #' @param \dots (optional) further arguments for bootstrapping (\code{bs.M, #' bs.N, bs.h, sigmab.sd}). See details for their usage. Further arguments are #' \code{verbose} to de-/activate console output (logical), \code{debug} for #' extended console output (logical) and \code{cores} (integer) to manually #' specify the number of cores to be used when \code{multicore=TRUE}. #' #' @return Returns a plot (optional) and terminal output. In addition an #' \code{\linkS4class{RLum.Results}} object is returned containing the #' following elements: #' #' \item{summary}{\link{data.frame} summary of all relevant model results.} #' \item{data}{\link{data.frame} original input data} \item{args}{\link{list} #' used arguments} \item{call}{\link{call} the function call} #' \item{mle}{\link{mle2} object containing the maximum log likelhood functions #' for all parameters} \item{BIC}{\link{numeric} BIC score} #' \item{confint}{\link{data.frame} confidence intervals for all parameters} #' \item{profile}{\link{profile.mle2} the log likelihood profiles} #' \item{bootstrap}{\link{list} bootstrap results} #' #' The output should be accessed using the function \code{\link{get_RLum}} #' #' @note The default starting values for \emph{gamma}, \emph{mu}, \emph{sigma} #' and \emph{p0} may only be appropriate for some De data sets and may need to #' be changed for other data. This is especially true when the un-logged #' version is applied. \cr Also note that all R warning messages are suppressed #' when running this function. If the results seem odd consider re-running the #' model with \code{debug=TRUE} which provides extended console output and #' forwards all internal warning messages. #' #' @section Function version: 0.4.4 #' #' @author Christoph Burow, University of Cologne (Germany) \cr Based on a #' rewritten S script of Rex Galbraith, 2010 \cr The bootstrap approach is #' based on a rewritten MATLAB script of Alastair Cunningham. \cr Alastair #' Cunningham is thanked for his help in implementing and cross-checking the #' code. #' #' @seealso \code{\link{calc_CentralDose}}, \code{\link{calc_CommonDose}}, #' \code{\link{calc_FiniteMixture}}, \code{\link{calc_FuchsLang2001}}, #' \code{\link{calc_MaxDose}} #' #' @references Arnold, L.J., Roberts, R.G., Galbraith, R.F. & DeLong, S.B., #' 2009. A revised burial dose estimation procedure for optical dating of young #' and modern-age sediments. Quaternary Geochronology 4, 306-325. \cr\cr #' #' Galbraith, R.F. & Laslett, G.M., 1993. Statistical models for mixed fission #' track ages. Nuclear Tracks Radiation Measurements 4, 459-470. \cr\cr #' #' 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. \cr\cr #' #' Galbraith, R.F., 2005. Statistics for #' Fission Track Analysis, Chapman & Hall/CRC, Boca Raton. \cr\cr #' #' Galbraith, R.F. & Roberts, R.G., 2012. Statistical aspects of equivalent dose and error #' calculation and display in OSL dating: An overview and some recommendations. #' Quaternary Geochronology 11, 1-27. \cr\cr #' #' Olley, J.M., Roberts, R.G., Yoshida, H., Bowler, J.M., 2006. Single-grain optical dating of grave-infill #' associated with human burials at Lake Mungo, Australia. Quaternary Science #' Reviews 25, 2469-2474.\cr\cr #' #' \bold{Further reading} \cr\cr #' #' 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. \cr\cr #' #' Bolker, B., 2016. Maximum likelihood estimation analysis with the bbmle package. #' In: Bolker, B., R Development Core Team, 2016. bbmle: Tools for General Maximum Likelihood Estimation. #' R package version 1.0.18. https://CRAN.R-project.org/package=bbmle \cr\cr #' #' 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. \cr\cr #' #' Cunningham, A.C. & Wallinga, J., 2012. Realizing the potential of fluvial archives using robust OSL chronologies. #' Quaternary Geochronology 12, 98-106. \cr\cr #' #' 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. #' \cr\cr Rodnight, H., 2008. How many equivalent dose values are needed to #' obtain a reproducible distribution?. Ancient TL 26, 3-10. \cr\cr #' #' #' @examples #' #' ## Load example data #' data(ExampleData.DeValues, envir = environment()) #' #' # (1) Apply the minimum age model with minimum required parameters. #' # By default, this will apply the un-logged 3-parametric MAM. #' calc_MinDose(data = ExampleData.DeValues$CA1, sigmab = 0.1) #' #' \dontrun{ #' # (2) Re-run the model, but save results to a variable and turn #' # plotting of the log-likelihood profiles off. #' mam <- calc_MinDose(data = ExampleData.DeValues$CA1, #' sigmab = 0.1, #' plot = FALSE) #' #' # Show structure of the RLum.Results object #' mam #' #' # Show summary table that contains the most relevant results #' res <- get_RLum(mam, "summary") #' res #' #' # Plot the log likelihood profiles retroactively, because before #' # we set plot = FALSE #' plot_RLum(mam) #' #' # Plot the dose distribution in an abanico plot and draw a line #' # at the minimum dose estimate #' plot_AbanicoPlot(data = ExampleData.DeValues$CA1, #' main = "3-parameter Minimum Age Model", #' line = mam,polygon.col = "none", #' hist = TRUE, #' rug = TRUE, #' summary = c("n", "mean", "mean.weighted", "median", "in.ci"), #' centrality = res$de, #' line.col = "red", #' grid.col = "none", #' line.label = paste0(round(res$de, 1), "\U00B1", #' round(res$de_err, 1), " Gy"), #' bw = 0.1, #' ylim = c(-25, 18), #' summary.pos = "topleft", #' mtext = bquote("Parameters: " ~ #' sigma[b] == .(get_RLum(mam, "args")$sigmab) ~ ", " ~ #' gamma == .(round(log(res$de), 1)) ~ ", " ~ #' sigma == .(round(res$sig, 1)) ~ ", " ~ #' rho == .(round(res$p0, 2)))) #' #' #' #' # (3) Run the minimum age model with bootstrap #' # NOTE: Bootstrapping is computationally intensive #' # (3.1) run the minimum age model with default values for bootstrapping #' calc_MinDose(data = ExampleData.DeValues$CA1, #' sigmab = 0.15, #' bootstrap = TRUE) #' #' # (3.2) Bootstrap control parameters #' mam <- calc_MinDose(data = ExampleData.DeValues$CA1, #' sigmab = 0.15, #' bootstrap = TRUE, #' bs.M = 300, #' bs.N = 500, #' bs.h = 4, #' sigmab.sd = 0.06, #' plot = FALSE) #' #' # Plot the results #' plot_RLum(mam) #' #' # save bootstrap results in a separate variable #' bs <- get_RLum(mam, "bootstrap") #' #' # show structure of the bootstrap results #' str(bs, max.level = 2, give.attr = FALSE) #' #' # print summary of minimum dose and likelihood pairs #' summary(bs$pairs$gamma) #' #' # Show polynomial fits of the bootstrap pairs #' bs$poly.fits$poly.three #' #' # Plot various statistics of the fit using the generic plot() function #' par(mfcol=c(2,2)) #' plot(bs$poly.fits$poly.three, ask = FALSE) #' #' # Show the fitted values of the polynomials #' summary(bs$poly.fits$poly.three$fitted.values) #' } #' #' @export calc_MinDose <- function( data, sigmab, log = TRUE, par = 3, bootstrap = FALSE, init.values, level = 0.95, plot = TRUE, multicore = FALSE, ... ){ ## ============================================================================## ## CONSISTENCY CHECK OF INPUT DATA ## ============================================================================## if (!missing(data)) { if (!is(data, "data.frame") & !is(data, "RLum.Results")) { stop("[calc_MinDose] Error: 'data' object has to be of type\n 'data.frame' or 'RLum.Results'!") } else { if (is(data, "RLum.Results")) { data <- get_RLum(data, "data") } } } if (any(!complete.cases(data))) { message(paste("\n[calc_MinDose] Warning:\nInput data contained NA/NaN values,", "which were removed prior to calculations!")) data <- data[complete.cases(data), ] } ##============================================================================## ## ... ARGUMENTS ##============================================================================## extraArgs <- list(...) ## check if this function is called by calc_MaxDose() if ("invert" %in% names(extraArgs)) { invert <- extraArgs$invert if (!log) { log <- TRUE # overwrite user choice as max dose model currently only supports the logged version cat(paste("\n[WARNING] The maximum dose model only supports the logged version.", "'log' was automatically changed to TRUE.\n\n")) } } else { invert <- FALSE } ## console output if ("verbose" %in% names(extraArgs)) { verbose <- extraArgs$verbose } else { verbose <- TRUE } ## bootstrap replications # first level bootstrap if ("bs.M" %in% names(extraArgs)) { M <- as.integer(extraArgs$bs.M) } else { M <- 1000 } # second level bootstrap if ("bs.N" %in% names(extraArgs)) { N <- as.integer(extraArgs$bs.N) } else { N <- 3*M } # KDE bandwith if ("bs.h" %in% names(extraArgs)) { h <- extraArgs$bs.h } else { h <- (sd(data[ ,1])/sqrt(length(data[ ,1])))*2 } # standard deviation of sigmab if ("sigmab.sd" %in% names(extraArgs)) { sigmab.sd <- extraArgs$sigmab.sd } else { sigmab.sd <- 0.04 } if ("debug" %in% names(extraArgs)) { debug <- extraArgs$debug } else { debug <- FALSE } if ("cores" %in% names(extraArgs)) { cores <- extraArgs$cores } else { cores <- parallel::detectCores() if (multicore) message(paste("Logical CPU cores detected:", cores)) } ## WARNINGS ---- if (!debug) options(warn = -1) ##============================================================================## ## START VALUES ##============================================================================## if (missing(init.values)) { start <- list(gamma = ifelse(log, log(quantile(data[ ,1], probs = 0.25, na.rm = TRUE)), quantile(data[ ,1], probs = 0.25, na.rm = TRUE)), sigma = 1.2, p0 = 0.01, mu = ifelse(log, log(quantile(data[ ,1], probs = 0.25, na.rm = TRUE)), mean(data[ ,1]))) } else { start <- list(gamma = init.values$gamma, sigma = init.values$sigma, p0 = init.values$p0, mu = init.values$mu) } ##============================================================================## ## ESTIMATE BOUNDARY PARAMETERS ##============================================================================## boundaries <- list( # gamma.lower = min(data[ ,1]/10), # gamma.upper = max(data[ ,1]*1.1), # sigma.lower = 0, # sigma.upper = 5, # mu.lower = min(data[ ,1])/10, # mu.upper = max(data[ ,1]*1.1) gamma.lower = -Inf, gamma.upper = Inf, sigma.lower = 0, sigma.upper = Inf, p0.lower = 0, p0.upper = 1, mu.lower = -Inf, mu.upper = Inf ) boundaries <- modifyList(boundaries, list(...)) # combine lower and upper boundary values to vectors if (log) { xlb <- c(log(boundaries$gamma.lower), boundaries$sigma.lower, boundaries$p0.lower) xub <- c(log(boundaries$gamma.upper), boundaries$sigma.upper, boundaries$p0.lower) } else { xlb <- c(boundaries$gamma.lower, boundaries$sigma.lower, boundaries$p0.lower) xub <- c(boundaries$gamma.upper, exp(boundaries$sigma.upper), boundaries$p0.lower) } if (par==4) { xlb <- c(xlb, ifelse(log, log(boundaries$mu.lower), boundaries$mu.lower)) xub <- c(xub, ifelse(log, log(boundaries$mu.upper), boundaries$mu.upper)) } ##============================================================================## ## AUXILLARY FUNCTIONS ##============================================================================## # THIS FUNCTION CALCULATES THE NEGATIVE LOG LIKELIHOOD OF THE DATA Neglik_f <- function(gamma, sigma, p0, mu, data) { # this calculates the negative of the log likelihood of the # data (data) for a given set of parameters (gamma, sigma, p0) # data is a 2x2 matrix of data: De, rel_error (including sigma_b) # recover the data zi <- data[ ,1] si <- data[ ,2] n <- length(zi) # in the MAM-3 gamma and mu are assumed to be equal if (par == 3) mu <- gamma # calculate sigma^2 + seld^2, mu0 and sigma0 s2 <- sigma^2 + si^2 sigma0 <- 1/sqrt(1/sigma^2 + 1/si^2) mu0 <- (mu/sigma^2 + zi/si^2)/(1/sigma^2 + 1/si^2) # calculate the log-likelihood logsqrt2pi <- 0.5*log(2*pi) res0 <- (gamma - mu0)/sigma0 res1 <- (gamma - mu)/sigma lf1i <- log(p0) - log(si) - 0.5*((zi-gamma)/si)^2 - logsqrt2pi lf2i <- log(1-p0) - 0.5*log(s2) - 0.5*(zi-mu)^2/s2 - logsqrt2pi lf2i <- lf2i + log(1-pnorm(res0)) - log(1-pnorm(res1)) llik <- log( exp(lf1i) + exp(lf2i) ) negll <- -sum(llik) return(negll) } # THIS MAXIMIZES THE Neglik_f LIKELIHOOD FUNCTION AND RETURNS AN MLE OBJECT Get_mle <- function(data) { # TODO: PROPER ERROR HANDLING tryCatch({ mle <- bbmle::mle2(data = list(data = data), optimizer = "nlminb", lower=c(gamma = boundaries$gamma.lower, sigma = boundaries$sigma.lower, p0 = boundaries$p0.lower, mu = boundaries$mu.lower), upper=c(gamma = boundaries$gamma.upper, sigma = boundaries$sigma.upper, p0 = boundaries$p0.upper, mu = boundaries$mu.upper), minuslogl = Neglik_f, control = list(iter.max = 1000L), start = start) }, error = function(e) { stop(paste("Sorry, seems like I encountered an error...:", e), call. = FALSE) }) return(mle) } ##============================================================================## ## MAIN PROGRAM ##============================================================================## # combine errors if (log) { if (invert) { lcd <- log(data[ ,1])*-1 x.offset <- abs(min(lcd)) lcd <- lcd+x.offset } else { lcd <- log(data[ ,1]) } lse <- sqrt((data[ ,2]/data[ ,1])^2 + sigmab^2) } else { lcd <- data[ ,1] lse <- sqrt(data[ ,2]^2 + sigmab^2) } # create new data frame with DE and combined relative error dat <- cbind(lcd, lse) # get the maximum likelihood estimate ests <- Get_mle(dat) # check if any standard errors are NA or NaN coef_err <- t(as.data.frame(bbmle::summary(ests)@coef[ ,2])) if (debug) print(bbmle::summary(ests)) if (any(is.nan(coef_err))) coef_err[which(is.nan(coef_err))] <- t(as.data.frame(ests@coef))/100 if (any(is.na(coef_err))) coef_err[which(is.na(coef_err))] <- t(as.data.frame(ests@coef))/100 if (par == 3) which <- c("gamma", "sigma", "p0") if (par == 4) which <- c("gamma", "sigma", "p0", "mu") # calculate profile log likelihoods prof <- bbmle::profile(ests, which = which, std.err = as.vector(coef_err), #try_harder = TRUE, quietly = TRUE, tol.newmin = Inf, skiperrs = TRUE, prof.lower=c(gamma = -Inf, sigma = 0, p0 = 0, mu = -Inf), prof.upper=c(gamma = Inf, sigma = Inf, p0 = 1, mu = Inf) ) # Fallback when profile() returns a 'better' fit maxsteps <- 100 cnt <- 1 while (!inherits(prof, "profile.mle2")) { message(paste0("## Trying to find a better fit (", cnt, "/10) ##")) if (maxsteps == 0L) stop(paste("Sorry, but I can't find a converging fit for the profile log-likelihood."), call. = FALSE) prof <- bbmle::profile(ests, which = which, std.err = as.vector(coef_err), try_harder = TRUE, quietly = TRUE, maxsteps = maxsteps, tol.newmin = Inf, skiperrs = TRUE, prof.lower=c(gamma = -Inf, sigma = 0, p0 = 0, mu = -Inf), prof.upper=c(gamma = Inf, sigma = Inf, p0 = 1, mu = Inf) ) maxsteps <- maxsteps - 10 cnt <- cnt + 1 } ## TODO: reduce the redundant code ## DELETE rows where z = -Inf/Inf prof@profile$gamma <- prof@profile$gamma[which(prof@profile$gamma["z"] != Inf), ] prof@profile$gamma <- prof@profile$gamma[which(prof@profile$gamma["z"] != -Inf), ] prof@profile$sigma <- prof@profile$sigma[which(prof@profile$sigma["z"] != Inf), ] prof@profile$sigma <- prof@profile$sigma[which(prof@profile$sigma["z"] != -Inf), ] prof@profile$p0 <- prof@profile$p0[which(prof@profile$p0["z"] != Inf), ] prof@profile$p0 <- prof@profile$p0[which(prof@profile$p0["z"] != -Inf), ] if (par == 4) { prof@profile$mu <- prof@profile$mu[which(prof@profile$mu["z"] != Inf), ] prof@profile$mu <- prof@profile$mu[which(prof@profile$mu["z"] != -Inf), ] } # calculate Bayesian Information Criterion (BIC) BIC <- BIC(ests) # retrieve results from mle2-object pal <- if (log) { if (invert) { exp((bbmle::coef(ests)[["gamma"]]-x.offset)*-1) } else { exp(bbmle::coef(ests)[["gamma"]]) } } else { bbmle::coef(ests)[["gamma"]] } sig <- bbmle::coef(ests)[["sigma"]] p0end <- bbmle::coef(ests)[["p0"]] if (par == 4) { muend <- ifelse(log, exp(bbmle::coef(ests)[["mu"]]), bbmle::coef(ests)[["mu"]]) } else { muend <- NA } ##============================================================================## ## ERROR CALCULATION #### METHOD 1: follow the instructions of Galbraith & Roberts (2012) #### # "If the likelihood profile is symmetrical about the parameter, an approximate standard error # can be calculated by dividing the length of this interval by 3.92" conf <- as.data.frame(bbmle::confint(prof, tol.newmin = Inf, quietly = TRUE, level = level)) class(conf[,1]) <- class(conf[,2]) <- "numeric" if (invert) { conf[1, ] <- (conf[1, ]-x.offset)*-1 t <- conf[1,1] conf[1,1] <- conf[1,2] conf[1,2] <- t } gamma_err <- if (log) { (exp(conf["gamma",2])-exp(conf["gamma",1]))/3.92 } else { (conf["gamma",2]-conf["gamma",1])/3.92 } ##============================================================================## ## AGGREGATE RESULTS summary <- data.frame(de=pal, de_err=gamma_err, ci_level = level, "ci_lower"=ifelse(log, exp(conf["gamma",1]), conf["gamma",1]), "ci_upper"=ifelse(log, exp(conf["gamma",2]), conf["gamma",2]), par=par, sig=sig, p0=p0end, mu=muend, Lmax=-ests@min, BIC=BIC) call <- sys.call() args <- list(log=log, sigmab=sigmab, bootstrap=bootstrap, init.values=start, bs.M=M, bs.N=N, bs.h=h, sigmab.sd=sigmab.sd) ##============================================================================## ## BOOTSTRAP ##============================================================================## if (bootstrap) { ## BOOTSTRAP FUNCTIONS ---- # Function that draws N+M sets of integer values from 1:n and returns # both the indices and frequencies draw_Freq <- function() { f <- R <- matrix(0L, N+M, n) for (i in seq_len(N+M)) { R[i, ] <- sample(x = n, size = n, replace = TRUE) f[i, ] <- tabulate(R, n) } return(list(R = R, freq = f)) } # Function that adds the additional error sigmab to each individual DE error combine_Errors <- function(d, e) { if (log) { d[ ,2] <- sqrt((d[ ,2]/d[ ,1])^2 + e^2) d[ ,1] <- log(d[ ,1]) } else { d[ ,2] <- sqrt(d[ ,2]^2 + e^2) } return(d) } # Function that produces N+M replicates from the original data set using # randomly sampled indices with replacement and adding a randomly drawn # sigmab error create_Replicates <- function(f, s) { d <- apply(f$R, 1, function(x) data[x, ]) r <- mapply(function(x, y) combine_Errors(x, y), d, s, SIMPLIFY = FALSE) return(r) } # Function to extract the estimate of gamma from mle2 objects and converting # it back to the 'normal' scale save_Gamma <- function(d) { if (log) { if (invert) { m <- exp((bbmle::coef(d)[["gamma"]]-x.offset)*-1) } else { m <- exp(bbmle::coef(d)[["gamma"]]) } } else { m <- bbmle::coef(d)[["gamma"]] } return(m) } # Function that takes each of the N replicates and produces a kernel density # estimate of length n. The normalised values are then returned as a matrix # with dimensions [N, n] get_KDE <- function(d) { f <- approx(density(x=d[ ,1], kernel="gaussian", bw = h), xout = d[ ,1]) pStarTheta <- as.vector(f$y / sum(f$y)) x <- matrix(t(pStarTheta/(1/n)), N, n, byrow = TRUE) return(x) } # Function that calculates the product term of the recycled bootstrap get_ProductTerm <- function(Pmat, b2Pmatrix) { prodterm <- apply(Pmat^b2Pmatrix$freq[1:N, ], 1, prod) return(prodterm) } # Function that calculates the pseudo likelihoods for M replicates and # returns the dose-likelihood pairs make_Pairs <- function(theta, b2mamvec, prodterm) { pairs <- matrix(0, M, 2) for (i in seq_len(M)) { thetavec <- matrix(theta[i], N, 1) kdthis <- (thetavec-b2mamvec)/h kd1 <- dnorm(kdthis) kd2 <- kd1*prodterm[[i]] kd <- sum(kd2, na.rm = TRUE) likelihood <- (1/(N*h))*kd pairs[i, ] <- c(theta[i], likelihood) } return(pairs) } ## START BOOTSTRAP ---- msg <- sprintf(paste("\n [calc_MinDose] \n\nRecycled Bootstrap", "\n\nParameters:", "\n M = %d", "\n N = %d", "\n sigmab = %.2f \U00B1 %.2f", "\n h = %.2f", "\n\n Creating %d bootstrap replicates..."), M, N, sigmab, sigmab.sd, h, N+M) message(msg) n <- length(data[ ,1]) # Draw N+M samples of a normale distributed sigmab sigmab <- rnorm(N + M, sigmab, sigmab.sd) # Draw N+M random indices and their frequencies b2Pmatrix <- draw_Freq() # Finally draw N+M bootstrap replicates replicates <- create_Replicates(b2Pmatrix, sigmab) # MULTICORE: The call to 'Get_mle' is the bottleneck of the function. # Using multiple CPU cores can reduce the computation cost, but may # not work for all machines. if (multicore) { message(paste("\n Spawning", cores, "instances of R for parallel computation. This may take a few seconds...")) cl <- parallel::makeCluster(cores) message("\n Done! Applying the model to all replicates. This may take a while...") mle <- parallel::parLapply(cl, replicates, Get_mle) parallel::stopCluster(cl) } else { message("\n Applying the model to all replicates. This may take a while...") mle <- lapply(replicates, Get_mle) } # Final bootstrap calculations message("\n Calculating the likelihoods...") # Save 2nd- and 1st-level bootstrap results (i.e. estimates of gamma) b2mamvec <- as.matrix(sapply(mle[1:N], save_Gamma, simplify = TRUE)) theta <- sapply(mle[c(N+1):c(N+M)], save_Gamma) # Calculate the probality/pseudo-likelihood Pmat <- lapply(replicates[c(N+1):c(N+M)], get_KDE) prodterm <- lapply(Pmat, get_ProductTerm, b2Pmatrix) # Save the bootstrap results as dose-likelihood pairs pairs <- make_Pairs(theta, b2mamvec, prodterm) ## --------- FIT POLYNOMIALS -------------- ## message("\n Fit curves to dose-likelihood pairs...") # polynomial fits of increasing degrees poly.three <- lm(pairs[ ,2] ~ poly(pairs[ ,1], degree = 3, raw = TRUE)) poly.four <- lm(pairs[ ,2] ~ poly(pairs[ ,1], degree = 4, raw = TRUE)) poly.five <- lm(pairs[ ,2] ~ poly(pairs[ ,1], degree = 5, raw = TRUE)) poly.six <- lm(pairs[ ,2] ~ poly(pairs[ ,1], degree = 6, raw = TRUE)) ## --------- FIT LOESS -------------- ## # Polynomials are probably not reasonable and often suffer badly from # overfitting, especially towards the margins of the fitted data. In this # particular use case polynomials may suggest a multimodal likelihood # distribution where actually none is given. The non-parametric # LOESS (LOcal polynomial regrESSion) often yields better results than # standard polynomials. loess <- loess(pairs[ ,2] ~ pairs[ ,1]) }#EndOf::Bootstrap ##============================================================================## ## CONSOLE PRINT ##============================================================================## if (verbose) { if (!bootstrap) { cat("\n----------- meta data -----------\n") print(data.frame(n=length(data[ ,1]), par=par, sigmab=sigmab, logged=log, Lmax=-ests@min, BIC=BIC, row.names = "")) cat("\n--- final parameter estimates ---\n") print(round(data.frame(gamma=ifelse(!invert, bbmle::coef(ests)[["gamma"]], (bbmle::coef(ests)[["gamma"]]-x.offset)*-1), sigma=bbmle::coef(ests)[["sigma"]], p0=bbmle::coef(ests)[["p0"]], mu=ifelse(par==4, ifelse(log,log(muend),muend),0), row.names=""), 2)) cat("\n------ confidence intervals -----\n") print(round(conf, 2)) cat("\n------ De (asymmetric error) -----\n") print(round(data.frame(De=pal, "lower"=ifelse(log, exp(conf["gamma",1]), conf["gamma",1]), "upper"=ifelse(log, exp(conf["gamma",2]), conf["gamma",2]), row.names=""), 2)) cat("\n------ De (symmetric error) -----\n") print(round(data.frame(De=pal, error=gamma_err, row.names=""), 2)) } else if (bootstrap) { message("\n Finished!") } } ##============================================================================## ## RETURN VALUES ##============================================================================## if (invert) prof@profile$gamma$par.vals[ ,"gamma"] <- rev((prof@profile$gamma$par.vals[ ,"gamma"] - x.offset)*-1) if (!bootstrap) pairs <- poly.three <- poly.four <- poly.five <- poly.six <- loess <- NULL newRLumResults.calc_MinDose <- set_RLum( class = "RLum.Results", originator = "calc_MinDose", data = list(summary = summary, data = data, args = args, call = call, mle = ests, BIC = BIC, confint = conf, profile = prof, bootstrap = list( pairs = list(gamma=pairs), poly.fits = list(poly.three = poly.three, poly.four = poly.four, poly.five = poly.five, poly.six = poly.six), loess.fit = loess))) ##=========## ## PLOTTING if (plot) try(plot_RLum.Results(newRLumResults.calc_MinDose, ...)) if (!debug) options(warn = 0) if (!is.na(summary$mu) && !is.na(summary$de)) { if (log(summary$de) > summary$mu) warning("Gamma is larger than mu. Consider re-running the model", " with new boundary values (see details '?calc_MinDose').", call. = FALSE) } invisible(newRLumResults.calc_MinDose) } Luminescence/R/analyse_SAR.CWOSL.R0000644000176200001440000015573413125226556016265 0ustar liggesusers#' Analyse SAR CW-OSL measurements #' #' The function performs a SAR CW-OSL analysis on an #' \code{\linkS4class{RLum.Analysis}} object including growth curve fitting. #' #' 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 \link{calc_OSLLxTxRatio} is #' used. For \bold{changing the way the Lx/Tx error is calculated} use the argument #' \code{background.count.distribution} and \code{sigmab}, which will be passed to the function #' \link{calc_OSLLxTxRatio}.\cr\cr #' #' \bold{Argument \code{object} is of type \code{list}}\cr\cr #' #' If the argument \code{object} is of type \code{\link{list}} containing \bold{only} #' \code{\linkS4class{RLum.Analysis}} objects, the function re-calls itself as often as elements #' are in the list. This is usefull if an entire measurement wanted to be analysed without #' writing separate for-loops. To gain in full control of the parameters (e.g., \code{dose.points}) for #' every aliquot (corresponding to one \code{\linkS4class{RLum.Analysis}} object in the list), in #' this case the arguments can be provided as \code{\link{list}}. This \code{list} should #' be of similar length as the \code{list} provided with the argument \code{object}, otherwise the function #' will create an own list of the requested lenght. Function output will be just one single \code{\linkS4class{RLum.Results}} 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.\cr\cr #' #' \bold{Working with IRSL data}\cr\cr #' #' 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. \cr #' #' 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.\cr\cr #' #' \bold{Supported rejection criteria}\cr\cr \sQuote{recycling.ratio}: #' calculated for every repeated regeneration dose point.\cr #' #' \sQuote{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).\cr #' #' \sQuote{testdose.error}: set the allowed error for the testdose, which per #' default should not exceed 10\%. The testdose error is calculated as Tx_net.error/Tx_net. #' #' \sQuote{palaeodose.error}: set the allowed error for the De value, which per #' default should not exceed 10\%. #' #' @param object \code{\linkS4class{RLum.Analysis}} (\bold{required}): input #' object containing data for analysis, alternatively a \code{\link{list}} of #' \code{\linkS4class{RLum.Analysis}} objects can be provided. #' #' @param signal.integral.min \code{\link{integer}} (\bold{required}): lower #' bound of the signal integral. Can be a \code{\link{list}} of \code{\link{integer}s}, if \code{object} is #' of type \code{\link{list}}. If the input is vector (e.g., \code{c(1,2)}) the 2nd value will be interpreted #' as the minimum signal integral for the Tx curve. #' #' @param signal.integral.max \code{\link{integer}} (\bold{required}): upper #' bound of the signal integral. Can be a \code{\link{list}} of \code{\link{integer}s}, if \code{object} is #' of type \code{\link{list}}. If the input is vector (e.g., \code{c(1,2)}) the 2nd value will be interpreted #' as the maximum signal integral for the Tx curve. #' #' @param background.integral.min \code{\link{integer}} (\bold{required}): #' lower bound of the background integral. Can be a \code{\link{list}} of \code{\link{integer}s}, if \code{object} is #' of type \code{\link{list}}. If the input is vector (e.g., \code{c(1,2)}) the 2nd value will be interpreted #' as the minimum background integral for the Tx curve. #' #' @param background.integral.max \code{\link{integer}} (\bold{required}): #' upper bound of the background integral. Can be a \code{\link{list}} of \code{\link{integer}s}, if \code{object} is #' of type \code{\link{list}}. If the input is vector (e.g., \code{c(1,2)}) the 2nd value will be interpreted #' as the maximum background integral for the Tx curve. #' #' @param rejection.criteria \code{\link{list}} (with default): provide a named list #' and set rejection criteria in \bold{percentage} for further calculation. Can be a \code{\link{list}} in #' a \code{\link{list}}, if \code{object} is of type \code{\link{list}} #' #' Allowed arguments are \code{recycling.ratio}, \code{recuperation.rate}, #' \code{palaeodose.error}, \code{testdose.error} and \code{exceed.max.regpoint = TRUE/FALSE}. #' Example: \code{rejection.criteria = list(recycling.ratio = 10)}. #' Per default all numerical values are set to 10, \code{exceed.max.regpoint = TRUE}. #' Every criterium can be set to \code{NA}. In this value are calculated, but not considered, i.e. #' the RC.Status becomes always \code{'OK'} #' #' @param dose.points \code{\link{numeric}} (optional): a numeric vector #' containg the dose points values Using this argument overwrites dose point #' values in the signal curves. Can be a \code{\link{list}} of \code{\link{numeric}} vectors, #' if \code{object} is of type \code{\link{list}} #' #' @param mtext.outer \code{\link{character}} (optional): option to provide an #' outer margin mtext. Can be a \code{\link{list}} of \code{\link{character}s}, #' if \code{object} is of type \code{\link{list}} #' #' @param plot \code{\link{logical}} (with default): enables or disables plot #' output. #' #' @param plot.single \code{\link{logical}} (with default) or #' \code{\link{numeric}} (optional): single plot output (\code{TRUE/FALSE}) to #' allow for plotting the results in single plot windows. If a numerice vector #' is provided the plots can be selected individually, i.e. \code{plot.single = #' 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 #' \code{plot = TRUE}. #' #' @param \dots further arguments that will be passed to the function #' \code{\link{plot_GrowthCurve}} or \code{\link{calc_OSLLxTxRatio}} #' (supported: \code{background.count.distribution}, \code{sigmab}, \code{sig0}). \bold{Please note} that #' if you consider to use the early light subtraction method you should provide your own \code{sigmab} #' value! #' #' #' @return A plot (optional) and an \code{\linkS4class{RLum.Results}} object is #' returned containing the following elements: #' #' \item{data}{\link{data.frame} containing De-values, De-error and #' further parameters} \item{LnLxTnTx.values}{\link{data.frame} of all #' calculated Lx/Tx values including signal, background counts and the dose #' points} \item{rejection.criteria}{\link{data.frame} with values that might #' by used as rejection criteria. NA is produced if no R0 dose point exists.} #' \item{Formula}{\link{formula} formula that have been used for the growth #' curve fitting }\cr The output should be accessed using the function #' \code{\link{get_RLum}}. #' #' #' @note This function must not be mixed up with the function #' \code{\link{Analyse_SAR.OSLdata}}, which works with #' \link{Risoe.BINfileData-class} objects.\cr #' #' \bold{The function currently does only support 'OSL' or 'IRSL' data!} #' #' @section Function version: 0.7.10 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' #' @seealso \code{\link{calc_OSLLxTxRatio}}, \code{\link{plot_GrowthCurve}}, #' \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}} #' \code{\link{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, #' exceed.max.regpoint = TRUE) #') #' #' ##show De results #' get_RLum(results) #' #' ##show LnTnLxTx table #' get_RLum(results, data.object = "LnLxTnTx.table") #' #' @export analyse_SAR.CWOSL<- function( object, signal.integral.min, signal.integral.max, background.integral.min, background.integral.max, rejection.criteria = NULL, dose.points = NULL, mtext.outer, plot = TRUE, plot.single = FALSE, ... ) { # SELF CALL ----------------------------------------------------------------------------------- if(is.list(object)){ ##make live easy if(missing("signal.integral.min")){ signal.integral.min <- 1 warning("[analyse_SAR.CWOSL()] 'signal.integral.min' missing, set to 1", call. = FALSE) } if(missing("signal.integral.max")){ signal.integral.max <- 2 warning("[analyse_SAR.CWOSL()] 'signal.integral.max' missing, set to 2", call. = FALSE) } ##now we have to extend everything to allow list of arguments ... this is just consequent signal.integral.min <- rep(list(signal.integral.min), length = length(object)) signal.integral.max <- rep(list(signal.integral.max), length = length(object)) background.integral.min <- rep(list(background.integral.min), length = length(object)) background.integral.max <- rep(list(background.integral.max), length = length(object)) ##it is a little bit more complex, as we have a list in a list if(is(rejection.criteria[[1]], "list")){ rejection.criteria <- rep(rejection.criteria, length = length(object)) }else{ rejection.criteria <- rep(list(rejection.criteria), length = length(object)) } if(!is.null(dose.points)){ if(is(dose.points, "list")){ dose.points <- rep(dose.points, length = length(object)) }else{ dose.points <- rep(list(dose.points), length = length(object)) } }else{ dose.points <- rep(list(NULL), length(object)) } if(!missing(mtext.outer)){ mtext.outer <- rep(as.list(mtext.outer), length = length(object)) }else{ mtext.outer <- rep(list(""), length = length(object)) } ##run analysis temp <- lapply(1:length(object), function(x){ analyse_SAR.CWOSL(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]], mtext.outer = mtext.outer[[x]], plot = plot, rejection.criteria = rejection.criteria[[x]], plot.single = plot.single, main = ifelse("main"%in% names(list(...)), list(...)$main, 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 prevent the function from stopping if(length(results) == 0){ return(NULL) }else{ return(results) } } # CONFIG ----------------------------------------------------------------- ##set error list, this allows to set error messages without breaking the function error.list <- list() # General Integrity Checks --------------------------------------------------- ##GENERAL ##MISSING INPUT if(missing("object")){ stop("[analyse_SAR.CWOSL()] No value set for 'object'!") } ##INPUT OBJECTS if(!is(object, "RLum.Analysis")){ stop("[analyse_SAR.CWOSL()] Input object is not of type 'RLum.Analyis'!") } if(missing("signal.integral.min") & !is.list(object)){ signal.integral.min <- 1 warning("[analyse_SAR.CWOSL()] 'signal.integral.min' missing, set to 1", call. = FALSE) } if(missing("signal.integral.max") & !is.list(object)){ signal.integral.max <- 2 warning("[analyse_SAR.CWOSL()] 'signal.integral.max' missing, set to 2", call. = FALSE) } if(missing("background.integral.min")){ stop("[analyse_SAR.CWOSL()] No value set for 'background.integral.min'!") } if(missing("background.integral.max")){ stop("[analyse_SAR.CWOSL()] No value set for 'background.integral.max'!") } ##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 warning("[analyse_SAR.CWOSL()] 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 warning("[analyse_SAR.CWOSL()] 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")){ stop("[analyse_SAR.CWOSL()] 'signal.integral' or 'background.integral' is not of type integer!") } ##CHECK IF DATA SET CONTAINS ANY OSL curve if (!any(grepl("OSL", structure_RLum(object)$recordType)) && !any(grepl("IRSL", structure_RLum(object)$recordType))) { warning( "[analyse_SAR.CWOSL()] No record of type 'OSL' or 'IRSL' are detected in the sequence object! NULL returned.", call. = FALSE ) return(NULL) } ##Check if any OSL curve is measured, if not set curve type on IRSL ##to allow further proceedings CWcurve.type <- ifelse(!TRUE%in%grepl("OSL", structure_RLum(object)$recordType), "IRSL","OSL") # Rejection criteria ------------------------------------------------------ ##set list rejection.criteria.default <- list( recycling.ratio = 10, recuperation.rate = 10, palaeodose.error = 10, testdose.error = 10, exceed.max.regpoint = TRUE ) ##modify list on the request if(!is.null(rejection.criteria)){ ##check if the provided values are valid at all if(!all(names(rejection.criteria)%in%names(rejection.criteria.default))){ try(stop( paste0("[analyse_SAR.CWOSL()] Rejection criteria '", paste( names( rejection.criteria)[ !names(rejection.criteria)%in%names(rejection.criteria.default)], collapse = ", ") ,"' unknown! Input ignored!"), call. = FALSE)) } ##modify list rejection.criteria <- modifyList(rejection.criteria.default, rejection.criteria) }else{ rejection.criteria <- rejection.criteria.default } # 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} # Protocol Integrity Checks -------------------------------------------------- ##check overall structur 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 }) ##problem: FI lexsyg devices provide irradiation information in a separate curve if("irradiation"%in%temp.ltype){ ##grep irraditation times temp.irradiation <- structure_RLum(object) temp.irradiation <- temp.irradiation[temp.irradiation$recordType == "irradiation", "x.max"] ##remove every 2nd entry (test dose) and add "0" dose for natural signal temp.Dose <- c(0,temp.irradiation) ##remove irradiation entries from file object <- set_RLum( class = "RLum.Analysis", records = get_RLum(object, recordType = c(CWcurve.type, "TL")), protocol = "SAR") } ##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]] <- "[analyse_SAR.CWOSL()] 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]] <- "[analyse_SAR.CWOSL()] Input curves lengths differ." } ##just proceed if error list is empty if (length(error.list) == 0) { ##check background integral if (max(signal.integral) == min(signal.integral)) { signal.integral <- c(min(signal.integral) : (max(signal.integral) + 1)) warning("[analyse_SAR.CWOSL()] integral signal limits cannot be equal, reset automatically!") } ##background integral should not longer than curve channel length if (max(background.integral) == min(background.integral)) { background.integral <- c((min(background.integral) - 1) : max(background.integral)) } if (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)) } warning( "[analyse_SAR.CWOSL()] 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)) } 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 TL.Curves.ID.Lx <- lapply(1:length(OSL.Curves.ID.Lx), function(x) { TL.Curves.ID[which(TL.Curves.ID == (OSL.Curves.ID.Lx[x] - 1))] }) TL.Curves.ID.Tx <- lapply(1:length(OSL.Curves.ID.Tx), function(x) { TL.Curves.ID[which(TL.Curves.ID == (OSL.Curves.ID.Tx[x] - 1))] }) # COMPONENT FITTING ------------------------------------------------------- # for(x in seq(1,length(OSL.Curves.ID),by=2)){ # # # temp.fit.output <- fit_CWCurve(object@records[[OSL.Curves.ID[x]]], # n.components.max=3, # output.terminal = FALSE, # output.terminalAdvanced = FALSE, # plot = FALSE # # ) # if(exists("fit.output") == FALSE){ # # fit.output <- get_RLum(temp.fit.output) # # }else{ # # fit.output <- rbind(fit.output, get_RLum(temp.fit.output)) # # } # # } ##TODO # Calculate LnLxTnTx values -------------------------------------------------- ##calculate LxTx values using external function LnLxTnTx <- lapply(seq(1,length(OSL.Curves.ID),by = 2), function(x){ 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 if (exists("temp.irradiation") == FALSE) { 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) }else{ temp.LnLxTnTx <- cbind(Dose = temp.Dose[x], temp.LnLxTnTx) } }) ##combine LnLxTnTx <- data.table::rbindlist(LnLxTnTx) # Set regeneration points ------------------------------------------------- ##overwrite dose point manually if (!is.null(dose.points)) { if (length(dose.points) != length(LnLxTnTx$Dose)) { stop("[analyse_SAR.CWOSL()] length '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)) { stop("[analyse_SAR.CWOSL()] '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) { warning("[analyse_SAR.CWOSL()] 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.", call. = FALSE) 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 <- paste("R",temp.DoseID,sep = "") 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,]) temp.DoseName[temp.DoseName[,"Name"] != "Natural" & temp.DoseName[,"Name"] != "R0","Name"] <- paste("R",c(1:non.temp.zero.dose.number),sep = "") ##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 = 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 if (length(LnLxTnTx[LnLxTnTx[,"Repeated"] == TRUE,"Repeated"]) > 0) { ##identify repeated doses temp.Repeated <- LnLxTnTx[LnLxTnTx[,"Repeated"] == TRUE,c("Name","Dose","LxTx")] ##find concering 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 }else{ RecyclingRatio <- NA } # Calculate Recuperation Rate --------------------------------------------- ##Recuperation Rate (capable to handle multiple type of recuperation values) if (length(LnLxTnTx[LnLxTnTx[,"Name"] == "R0","Name"]) > 0) { Recuperation <- sapply(1:length(LnLxTnTx[LnLxTnTx[,"Name"] == "R0","Name"]), function(x) { round(LnLxTnTx[LnLxTnTx[,"Name"] == "R0","LxTx"][x] / LnLxTnTx[LnLxTnTx[,"Name"] == "Natural","LxTx"], digits = 4) }) ##Just transform the matrix and add column names Recuperation <- t(Recuperation) colnames(Recuperation) <- unlist(strsplit(paste( "Recuperation rate", 1:length(LnLxTnTx[LnLxTnTx[,"Name"] == "R0","Name"]), collapse = ";" ), ";")) }else{ Recuperation <- NA } # 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 if (!is.na(RecyclingRatio)[1] & !is.na(rejection.criteria$recycling.ratio)) { temp.status.RecyclingRatio <- sapply(1:length(RecyclingRatio), function(x) { if (abs(1 - RecyclingRatio[x]) > (rejection.criteria$recycling.ratio / 100)) { "FAILED" }else{ "OK" } }) }else{ temp.status.RecyclingRatio <- rep("OK", length(RecyclingRatio)) } ##Recuperation 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" } }) } else{ temp.status.Recuperation <- "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{ if(!is.na(testdose.error.threshold)){ testdose.error.status <- ifelse( testdose.error.calculated <= testdose.error.threshold, "OK", "FAILED" ) }else{ testdose.error.status <- "OK" } } 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 == TRUE) { # Plotting - Config ------------------------------------------------------- ##colours and double for plotting col <- get("col", pos = .LuminescenceEnv) if (plot.single[1] == FALSE) { ## read par settings par.default <- par(no.readonly = 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(plot.single, "logical")) { if (!is(plot.single, "numeric")) { stop("[analyse_SAR.CWOSL()] Invalid data type for 'plot.single'.") } plot.single.sel <- plot.single }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) { temp.message <- paste( "\n[analyse_SAR.CWOSL()] To many curves! Only the first", length(col),"curves are plotted!" ) warning(temp.message) } ##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[[1]] > 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 <- sapply(seq(1,length(TL.Curves.ID.Lx),by = 1) ,function(x) { range(object@records[[TL.Curves.ID.Lx[[x]]]]@data[,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 ---------------------------------------------------- ##overall plot option selection for plot.single.sel if (2 %in% plot.single.sel) { ylim.range <- sapply(1:length(OSL.Curves.ID.Lx) ,function(x) { range(object@records[[OSL.Curves.ID.Lx[x]]]@data[,2]) }) if((log == "x" | log == "xy") & object@records[[OSL.Curves.ID.Lx[[1]]]]@data[1,1] == 0){ xlim <- c(object@records[[OSL.Curves.ID.Lx[1]]]@data[2,1], max(object@records[[OSL.Curves.ID.Lx[1]]]@data[,1]) + object@records[[OSL.Curves.ID.Lx[1]]]@data[2,1]) }else{ 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) { if((log == "x" | log == "xy") & object@records[[OSL.Curves.ID.Lx[[x]]]]@data[1,1] == 0){ object@records[[OSL.Curves.ID.Lx[[x]]]]@data[1,] <- object@records[[OSL.Curves.ID.Lx[[x]]]]@data[1,] + diff(c(object@records[[OSL.Curves.ID.Lx[[x]]]]@data[1,1], object@records[[OSL.Curves.ID.Lx[[x]]]]@data[2,1])) warnings("[analyse_SAR.CWOSL()] curves shifted by one chanel for log-plot.") } lines(object@records[[OSL.Curves.ID.Lx[[x]]]]@data,col = col[x]) }) ##mark integration limit Lx curves abline( v = (object@records[[OSL.Curves.ID.Lx[1]]]@data[min(signal.integral),1]), lty = 2, col = "gray" ) abline( v = (object@records[[OSL.Curves.ID.Lx[1]]]@data[max(signal.integral),1]), lty = 2, col = "gray" ) abline( v = (object@records[[OSL.Curves.ID.Lx[1]]]@data[min(background.integral),1]), lty = 2, col = "gray" ) abline( v = (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 if (missing(mtext.outer)) { mtext.outer <- "" } 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[[1]] > 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 <- sapply(1:length(TL.Curves.ID.Tx) ,function(x) { range(object@records[[TL.Curves.ID.Tx[[x]]]]@data[,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 <- sapply(1:length(OSL.Curves.ID.Tx) ,function(x) { range(object@records[[OSL.Curves.ID.Tx[x]]]@data[,2]) }) if((log == "x" | log == "xy") & object@records[[OSL.Curves.ID.Tx[[1]]]]@data[1,1] == 0){ xlim <- c(object@records[[OSL.Curves.ID.Tx[1]]]@data[2,1], max(object@records[[OSL.Curves.ID.Tx[1]]]@data[,1]) + object@records[[OSL.Curves.ID.Tx[1]]]@data[2,1]) }else{ 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 = 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(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) { ##account for log-scale and 0 values if((log == "x" | log == "xy") & object@records[[OSL.Curves.ID.Tx[[x]]]]@data[1,1] == 0){ object@records[[OSL.Curves.ID.Tx[[x]]]]@data[1,] <- object@records[[OSL.Curves.ID.Tx[[x]]]]@data[1,] + diff(c(object@records[[OSL.Curves.ID.Tx[[x]]]]@data[1,1], object@records[[OSL.Curves.ID.Tx[[x]]]]@data[2,1])) warnings("[analyse_SAR.CWOSL()] curves shifted by one chanel for log-plot.") } lines(object@records[[OSL.Curves.ID.Tx[[x]]]]@data,col = col[x]) }) ##mark integration limit Tx curves abline( v = (object@records[[OSL.Curves.ID.Tx[1]]]@data[min(signal.integral),1]), lty = 2, col = "gray" ) abline( v = (object@records[[OSL.Curves.ID.Tx[1]]]@data[max(signal.integral),1]), lty = 2, col = "gray" ) abline( v = (object@records[[OSL.Curves.ID.Tx[1]]]@data[min(background.integral),1]), lty = 2, col = "gray" ) abline( v = (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 if (exists("par.default")) { par(par.default) } }##end plot == TRUE # Plotting GC ---------------------------------------- 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 } ##Fit and plot growth curve temp.GC <- plot_GrowthCurve(temp.sample, output.plot = plot, ...) ##grep informaton 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 Palaedose error -------------------------- palaeodose.error.calculated <- ifelse(is.na(temp.GC[,1]) == FALSE, round(temp.GC[,2] / temp.GC[,1], digits = 5), NA) palaeodose.error.threshold <- rejection.criteria$palaeodose.error / 100 if (is.na(palaeodose.error.calculated)) { palaeodose.error.status <- "FAILED" }else{ if(!is.na(palaeodose.error.threshold)){ palaeodose.error.status <- ifelse( palaeodose.error.calculated <= palaeodose.error.threshold, "OK", "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 recjection status if (length(grep("FAILED",RejectionCriteria$Status)) > 0) { temp.GC <- data.frame(temp.GC, RC.Status = "FAILED") }else{ temp.GC <- data.frame(temp.GC, RC.Status = "OK") } ##add information on the integration limits temp.GC.extened <- 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() temp.results.final <- set_RLum( class = "RLum.Results", data = list( data = as.data.frame(c(temp.GC, temp.GC.extened, 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 == TRUE && 7 %in% plot.single.sel) { ##set graphical parameter if (!plot.single) { par(mfrow = c(1,2)) }else{ par(mfrow = c(1,1)) } ##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 ) for (i in 1:nrow(temp.rc.palaedose.error)) { 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 represenation of IR-curve temp.IRSL <- suppressWarnings(get_RLum(object, recordType = "IRSL")) if(length(temp.IRSL) != 0){ plot_RLum.Data.Curve(temp.IRSL, par.local = FALSE) }else{ plot(1, type="n", axes=F, xlab="", ylab="") text(x = c(1,1), y = c(1, 1), labels = "No IRSL curve detected!") } } ##It is doubled in this function, but the par settings need some more careful considerations ... if (exists("par.default")) { par(par.default) rm(par.default) } # Return -------------------------------------------------------------------------------------- invisible(temp.results.final) }else{ warning(paste0( "\n", paste(unlist(error.list), collapse = "\n"),"\n... >> nothing was done here!" ), call. = FALSE) invisible(NULL) } } Luminescence/R/use_DRAC.R0000644000176200001440000003705213125226556014613 0ustar liggesusers#' Use DRAC to calculate dose rate data #' #' The function provides an interface from R to DRAC. An R-object or a #' pre-formatted XLS/XLSX file is passed to the DRAC website and the #' results are re-imported into R. #' #' #' @param file \code{\link{character}}: spreadsheet to be passed #' to the DRAC website for calculation. Can also be a DRAC template object #' obtained from \code{template_DRAC()}. #' #' @param name \code{\link{character}}: Optional user name submitted to DRAC. If #' omitted, a random name will be generated #' #' @param ... Further arguments. #' #' @return Returns an \code{\linkS4class{RLum.Results}} object containing the following elements: #' #' \item{DRAC}{\link{list}: a named list containing the following elements in slot \code{@@data}: #' #' \tabular{lll}{ #' \code{$highlights} \tab \code{\link{data.frame}} \tab summary of 25 most important input/output fields \cr #' \code{$header} \tab \code{\link{character}} \tab HTTP header from the DRAC server response \cr #' \code{$labels} \tab \code{\link{data.frame}} \tab descriptive headers of all input/output fields \cr #' \code{$content} \tab \code{\link{data.frame}} \tab complete DRAC input/output table \cr #' \code{$input} \tab \code{\link{data.frame}} \tab DRAC input table \cr #' \code{$output} \tab \code{\link{data.frame}} \tab DRAC output table \cr #' } #' #' } #' \item{data}{\link{character} or \link{list} path to the input spreadsheet or a DRAC template} #' \item{call}{\link{call} the function call} #' \item{args}{\link{list} used arguments} #' #' The output should be accessed using the function \code{\link{get_RLum}}. #' #' @section Function version: 0.1.1 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France), Michael Dietze, #' GFZ Potsdam (Germany), Christoph Burow, University of Cologne (Germany)\cr #' #' @references #' #' Durcan, J.A., King, G.E., Duller, G.A.T., 2015. DRAC: Dose Rate and Age Calculator for trapped charge dating. #' Quaternary Geochronology 28, 54-61. doi:10.1016/j.quageo.2015.03.012 #' #' @examples #' #' ## (1) Method using the DRAC spreadsheet #' #' file <- "/PATH/TO/DRAC_Input_Template.csv" #' #' # send the actual IO template spreadsheet to DRAC #' \dontrun{ #' use_DRAC(file = file) #' } #' #' #' #' ## (2) Method using an R template object #' #' # Create a template #' input <- template_DRAC() #' #' # Fill the template with values #' input$`Project ID` <- "DRAC-Example" #' input$`Sample ID` <- "Quartz" #' input$`Conversion factors` <- "AdamiecAitken1998" #' input$`External U (ppm)` <- 3.4 #' input$`errExternal U (ppm)` <- 0.51 #' input$`External Th (ppm)` <- 14.47 #' input$`errExternal Th (ppm)` <- 1.69 #' input$`External K (%)` <- 1.2 #' input$`errExternal K (%)` <- 0.14 #' input$`Calculate external Rb from K conc?` <- "N" #' input$`Calculate internal Rb from K conc?` <- "N" #' input$`Scale gammadoserate at shallow depths?` <- "N" #' input$`Grain size min (microns)` <- 90 #' input$`Grain size max (microns)` <- 125 #' input$`Water content ((wet weight - dry weight)/dry weight) %` <- 5 #' input$`errWater content %` <- 2 #' input$`Depth (m)` <- 2.2 #' input$`errDepth (m)` <- 0.22 #' input$`Overburden density (g cm-3)` <- 1.8 #' input$`errOverburden density (g cm-3)` <- 0.1 #' input$`Latitude (decimal degrees)` <- 30.0000 #' input$`Longitude (decimal degrees)` <- 70.0000 #' input$`Altitude (m)` <- 150 #' input$`De (Gy)` <- 20 #' input$`errDe (Gy)` <- 0.2 #' #' # use DRAC #' \dontrun{ #' output <- use_DRAC(input) #' } #' #' @export use_DRAC <- function( file, name, ... ){ ## TODO: ## (1) Keep the data set as unmodified as possible. Check structure and order of parameters ## for meaningful cominbination. ## ## (2) ## Leave it to the user where the calculations made in our package should be used # Integrity tests ----------------------------------------------------------------------------- if (inherits(file, "character")) { if(!file.exists(file)){ stop("[use_DRAC()] It seems that the file doesn't exist!") } # Import data --------------------------------------------------------------------------------- ## Import and skip the first rows and remove NA lines and the 2 row, as this row contains ## only meta data ## DRAC v1.1 - XLS sheet ##check if is the original DRAC table if (tools::file_ext(file) == "xls" || tools::file_ext(file) == "xlsx") { if (readxl::excel_sheets(file)[1] != "DRAC_1.1_input") stop("[use_DRAC()] It looks like that you are not using the original DRAC v1.1 XLSX template. This is currently not supported!") warning("\n[use_DRAC()] The current DRAC version is 1.2, but you provided the v1.1 excel input template.", "\nPlease transfer your data to the new CSV template introduced with DRAC v1.2.", call. = FALSE) input.raw <- na.omit(as.data.frame(readxl::read_excel(path = file, sheet = 1, skip = 5)))[-1, ] } ## DRAC v1.2 - CSV sheet if (tools::file_ext(file) == "csv") { if (read.csv(file, nrows = 1, header = FALSE)[1] != "DRAC v.1.2 Inputs") stop("[use_DRAC()] It looks like that you are not using the original DRAC v1.2 CSV template. This is currently not supported!") input.raw <- read.csv(file, skip = 8, check.names = FALSE, header = TRUE, stringsAsFactors = FALSE)[-1, ] } } else if (inherits(file, "DRAC.list")) { input.raw <- as.data.frame(file) } else if (inherits(file, "DRAC.data.frame")) { input.raw <- file } else { stop("The provided data object is not a valid DRAC template.", call. = FALSE) } if (nrow(input.raw) > 50) stop("DRAC can only handle 50 data sets at once. Please reduce the number of rows and re-run this function again.", call. = FALSE) # Settings ------------------------------------------------------------------------------------ settings <- list(name = ifelse(missing(name), paste(sample(if(runif(1,-10,10)>0){LETTERS}else{letters}, runif(1, 2, 4)), collapse = ""), name), verbose = TRUE, url = "https://www.aber.ac.uk/en/dges/research/quaternary/luminescence-research-laboratory/dose-rate-calculator/?show=calculator") # override defaults with args in ... settings <- modifyList(settings, list(...)) # Set helper function ------------------------------------------------------------------------- ## The real data are transferred without any encryption, so we have to mask the original ##(0) set masking function .masking <- function(mean, sd, n) { temp <- rnorm(n = 30 * n, mean = mean,sd = sd) temp.result <- sapply(seq(1, length(temp), by = 30), function(x) { c(format(mean(temp[x:(x + 29)]), digits = 2), format(sd(temp[x:(x + 29)]), digits = 2)) }) return(t(temp.result)) } # Process data -------------------------------------------------------------------------------- if (settings$verbose) message("\n\t Preparing data...") ##(1) expand the rows in the data.frame a little bit mask.df <- input.raw[rep(1:nrow(input.raw), each = 3), ] ##(2) generate some meaningful randome variables mask.df <- lapply(seq(1, nrow(input.raw), by = 3), function(x) { if (mask.df[x,"TI:52"] != "X") { ##replace some values - the De value mask.df[x:(x + 2), c("TI:52","TI:53")] <- .masking( mean = as.numeric(mask.df[x,"TI:52"]), sd = as.numeric(mask.df[x,"TI:53"]), n = 3) return(mask.df) } }) ##(3) bin values DRAC_submission.df <- rbind(input.raw,mask.df[[1]]) ##(4) replace ID values DRAC_submission.df$`TI:1` <- paste0(paste0(paste0(sample(if(runif(1,-10,10)>0){LETTERS}else{letters}, runif(1, 2, 4)), collapse = ""), ifelse(runif(1,-10,10)>0, "-", "")), gsub(" ", "0", prettyNum(seq(sample(1:50, 1, prob = 50:1/50, replace = FALSE), by = 1, length.out = nrow(DRAC_submission.df)), width = 2))) ##(5) store the real IDs in a sperate object DRAC_results.id <- DRAC_submission.df[1:nrow(input.raw), "TI:1"] ##(6) create DRAC submission string DRAC_submission.df <- DRAC_submission.df[sample(x = 1:nrow(DRAC_submission.df), nrow(DRAC_submission.df), replace = FALSE), ] ##convert all columns of the data.frame to class 'character' for (i in 1:ncol(DRAC_submission.df)) DRAC_submission.df[ ,i] <- as.character(DRAC_submission.df[, i]) if (settings$verbose) message("\t Creating submission string...") ##get line by line and remove unwanted characters DRAC_submission.string <- sapply(1:nrow(DRAC_submission.df), function(x) { paste0(gsub(",", "", toString(DRAC_submission.df[x, ])), "\n") }) ##paste everything together to get the format we want DRAC_input <- paste(DRAC_submission.string, collapse = "") # Send data to DRAC --------------------------------------------------------------------------- if (settings$verbose) message(paste("\t Establishing connection to", settings$url)) ## send data set to DRAC website and receive repsonse DRAC.response <- httr::POST(settings$url, body = list("drac_data[name]" = settings$name, "drac_data[table]" = DRAC_input)) ## check for correct response if (DRAC.response$status_code != 200) { stop(paste0("[use_DRAC()] transmission failed with HTTP status code: ", DRAC.response$status_code)) } else { if (settings$verbose) message("\t The request was successful, processing the reply...") } ## assign DRAC response data to variables http.header <- DRAC.response$header DRAC.content <- httr::content(x = DRAC.response, as = "text") ## if the input was valid from a technical standpoint, but not with regard ## contents, we indeed get a valid response, but no DRAC output if (!grepl("DRAC Outputs", DRAC.content)) { error_start <- max(gregexpr("drac_field_error", DRAC.content)[[1]]) error_end <- regexec('textarea name=', DRAC.content)[[1]] error_msg <- substr(DRAC.content, error_start, error_end) on.exit({ reply <- readline("Do you want to see the DRAC error message (Y/N)?") if (reply == "Y" || reply == "y" || reply == 1) cat(error_msg) }) stop(paste("\n\t We got a response from the server, but it\n", "\t did not contain DRAC output. Please check\n", "\t your data and verify its validity.\n"), call. = FALSE) } else { if (settings$verbose) message("\t Finalising the results...") } ## split header and content DRAC.content.split <- strsplit(x = DRAC.content, split = "DRAC Outputs\n\n") ## assign DRAC header part DRAC.header <- as.character(DRAC.content.split[[1]][1]) ## assign DRAC content part DRAC.raw <- read.table(text = as.character(DRAC.content.split[[1]][2]), sep = ",", stringsAsFactors = FALSE) ## remove first two lines DRAC.content <- read.table(text = as.character(DRAC.content.split[[1]][2]), sep = ",", skip = 2, stringsAsFactors = FALSE) ##Get rid of all the value we do not need anymore DRAC.content <- subset(DRAC.content, DRAC.content$V1 %in% DRAC_results.id) DRAC.content <- DRAC.content[with(DRAC.content, order(V1)), ] ##replace by original names DRAC.content[ ,1] <- input.raw[ ,1] ## assign column names colnames(DRAC.content) <- DRAC.raw[1, ] ## save column labels and use them as attributes for the I/O table columns DRAC.labels <- DRAC.raw[2, ] for (i in 1:length(DRAC.content)) { attr(DRAC.content[ ,i], "description") <- DRAC.labels[1,i] } ## DRAC also returns the input, so we need to split input and output DRAC.content.input <- DRAC.content[ ,grep("TI:", names(DRAC.content))] DRAC.content.output <- DRAC.content[ ,grep("TO:", names(DRAC.content))] ## The DRAC ouput also contains a hightlight table, which results in ## duplicate columns. When creating the data.frame duplicate columns ## are automatically appended '.1' in their names, so we can identify ## and remove them easily DRAC.content.input <- DRAC.content.input[ ,-grep("\\.1", names(DRAC.content.input))] DRAC.content.output <- DRAC.content.output[ ,-grep("\\.1", names(DRAC.content.output))] ## for some reason the returned input table is unsorted, so we resort it in increasing order DRAC.content.input <- DRAC.content.input[ , paste0("TI:", 1:ncol(DRAC.content.input))] ## The output table (v1.2) has 198 columns, making it unreasonable complex ## for standard data evaluation. We reproduce the DRAC highlight table ## and use the descriptions (saved as attributes) as column names. highlight.keys <- c("TI:1","TI:2","TI:3","TO:FQ","TO:FR", "TO:FS", "TO:FT", "TO:FU", "TO:FV", "TO:FW", "TO:FX", "TO:FY", "TO:FZ", "TO:GG", "TO:GH", "TO:GI", "TO:GJ", "TO:GK", "TO:GL", "TO:GM", "TO:GN", "TI:52", "TI:53", "TO:GO", "TO:GP") DRAC.highlights <- subset(DRAC.content, select = highlight.keys) DRAC.highlights.labels <- as.character(DRAC.labels[1, which(unique(names(DRAC.content)) %in% highlight.keys)]) colnames(DRAC.highlights) <- DRAC.highlights.labels for (i in 1:length(DRAC.highlights)) { attr(DRAC.highlights[ ,i], "key") <- highlight.keys[i] } ## finally, we add the 'DRAC.highlights' class so that we can use a custom print method class(DRAC.highlights) <- c("DRAC.highlights", "data.frame") ## Final Disclaimer messages <- list("\t Done! \n", "\t We, the authors of the R package 'Luminescence', do not take any responsibility and we are not liable for any ", "\t mistakes or unforeseen misbehaviour. All calculations are done by DRAC and it is outside our reference to", "\t verify the input and output. \n", "\t Note that this function is only compatible with DRAC version 1.2. Before using this function make sure that", "\t this is the correct version, otherwise expect unspecified errors.\n", "\t Please ensure you cite the use of DRAC in your work, published or otherwise. Please cite the website name and", "\t version (e.g. DRAC v1.2) and the accompanying journal article:", "\t Durcan, J.A., King, G.E., Duller, G.A.T., 2015. DRAC: Dose rate and age calculation for trapped charge", "\t dating. Quaternary Geochronology 28, 54-61. \n", "\t Use 'verbose = FALSE' to hide this message. \n") if (settings$verbose) lapply(messages, message) ## return output DRAC.return <- set_RLum("RLum.Results", data = list( DRAC = list(highlights = DRAC.highlights, header = DRAC.header, labels = DRAC.labels, content = DRAC.content, input = DRAC.content.input, output = DRAC.content.output), data = file, call = sys.call(), args = as.list(sys.call()[-1]))) invisible(DRAC.return) } Luminescence/R/read_SPE2R.R0000644000176200001440000003167313125226556015057 0ustar liggesusers#' Import Princeton Intruments (TM) SPE-file into R #' #' Function imports Princeton Instruments (TM) SPE-files into R environment and #' provides \code{RLum} objects as output. #' #' Function provides an import routine for the Princton Instruments SPE format. #' Import functionality is based on the file format description provided by #' Princton Instruments and a MatLab script written by Carl Hall (s. #' references). #' #' @param file \link{character} (\bold{required}): spe-file name (including #' path), e.g. \cr [WIN]: \code{read_SPE2R("C:/Desktop/test.spe")}, \cr #' [MAC/LINUX]: \code{readSPER("/User/test/Desktop/test.spe")} #' #' @param output.object \code{\link{character}} (with default): set \code{RLum} #' output object. Allowed types are \code{"RLum.Data.Spectrum"}, #' \code{"RLum.Data.Image"} or \code{"matrix"} #' #' @param frame.range \code{\link{vector}} (optional): limit frame range, e.g. #' select first 100 frames by \code{frame.range = c(1,100)} #' #' @param txtProgressBar \link{logical} (with default): enables or disables #' \code{\link{txtProgressBar}}. #' #' @return Depending on the chosen option the functions returns three different #' type of objects:\cr #' #' \code{output.object}. \cr #' #' \code{RLum.Data.Spectrum}\cr #' #' An object of type \code{\linkS4class{RLum.Data.Spectrum}} is returned. Row #' sums are used to integrate all counts over one channel. #' #' \code{RLum.Data.Image}\cr #' #' An object of type \code{\linkS4class{RLum.Data.Image}} is returned. Due to #' performace reasons the import is aborted for files containing more than 100 #' frames. This limitation can be overwritten manually by using the argument #' \code{frame.frange}. #' #' \code{matrix}\cr #' #' Returns a matrix of the form: Rows = Channels, columns = Frames. For the #' transformation the function \code{\link{get_RLum}} is used, #' meaning that the same results can be obtained by using the function #' \code{\link{get_RLum}} on an \code{RLum.Data.Spectrum} or \code{RLum.Data.Image} object. #' @note \bold{The function does not test whether the input data are spectra or #' pictures for spatial resolved analysis!}\cr #' #' The function has been successfully tested for SPE format versions 2.x. #' #' \emph{Currently not all information provided by the SPE format are #' supported.} #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\link{readBin}}, \code{\linkS4class{RLum.Data.Spectrum}}, #' \code{\link[raster]{raster}} #' #' @references Princeton Instruments, 2014. Princeton Instruments SPE 3.0 File #' Format Specification, Version 1.A (for document URL please use an internet search machine) #' #' Hall, C., 2012: readSPE.m. #' \url{http://www.mathworks.com/matlabcentral/fileexchange/35940-readspe/content/readSPE.m} #' #' @keywords IO #' #' @examples #' #' #' ## to run examples uncomment lines and run the code #' #' ##(1) Import data as RLum.Data.Spectrum object #' #file <- file.choose() #' #temp <- read_SPE2R(file) #' #temp #' #' ##(2) Import data as RLum.Data.Image object #' #file <- file.choose() #' #temp <- read_SPE2R(file, output.object = "RLum.Data.Image") #' #temp #' #' ##(3) Import data as matrix object #' #file <- file.choose() #' #temp <- read_SPE2R(file, output.object = "matrix") #' #temp #' #' ##(4) Export raw data to csv, if temp is a RLum.Data.Spectrum object #' # write.table(x = get_RLum(temp), #' # file = "[your path and filename]", #' # sep = ";", row.names = FALSE) #' #' #' @export read_SPE2R <- function( file, output.object = "RLum.Data.Image", frame.range, txtProgressBar = TRUE ){ # Consistency check ------------------------------------------------------- ##check if file exists if(file.exists(file) == FALSE){ stop("[read_SPE2R()] File not found!") } ##check file extension if(strsplit(file, split = "\\.")[[1]][2] != "SPE"){ temp.text <- paste("[read_SPE2R()] Unsupported file format: *.", strsplit(file, split = "\\.")[[1]][2], sep = "") stop(temp.text) } # Open Connection --------------------------------------------------------- #open connection con<-file(file, "rb") # read header ------------------------------------------------------------- temp <- readBin(con, what="int", 2, size=2, endian="little", signed = TRUE) ControllerVersion <- temp[1] #Hardware version LogicOutput <- temp[2] #Definition of Output BNC temp <- readBin(con, what="int", 2, size=2, endian="little", signed = FALSE) AmpHiCapLowNoise <- temp[1] #Amp Switching Mode xDimDet <- temp[2] #Detector x dimension of chip. #timing mode mode <- readBin(con, what="int", 1, size=2, endian="little", signed = TRUE) #alternative exposure, in sec. exp_sec <- readBin(con, what="double", 1, size=4, endian="little") temp <- readBin(con, what="int", 2, size=2, endian="little", signed = TRUE) VChipXdim <- temp[1] # Virtual Chip X dim VChipYdim <- temp[2] # Virtual Chip Y dim #y dimension of CCD or detector. yDimDet <- readBin(con, what="int", 1, size=2, endian="little", signed = TRUE) #Date Date <- readChar(con, 10, useBytes=TRUE) ##jump stepping <- readBin(con, what="raw", 4, size=1, endian="little", signed = TRUE) #Old number of scans - should always be -1 noscan <- readBin(con, what="int", 1, size=2, endian="little", signed = TRUE) #Detector Temperature Set DetTemperature <- readBin(con, what="double", 1, size=4, endian="little") # CCD/DiodeArray type DetType <- readBin(con, what="int", 1, size=2, endian="little", signed = TRUE) #actual # of pixels on x axis xdim <- readBin(con, what="int", 1, size=2, endian="little", signed = FALSE) ##jump stepping <- readBin(con, what="raw", 64, size=1, endian="little", signed = TRUE) ##experiment data type ##0 = 32f (4 bytes) ##1 = 32s (4 bytes) ##3 = 16u (2 bytes) ##8 = 32u (4 bytes) datatype <- readBin(con, what="int", 1, size=2, endian="little", signed = TRUE) ##jump stepping <- readBin(con, what="raw", 546, size=1, endian="little") #y dimension of raw data. ydim <- readBin(con, what="int", 1, size=2, endian="little", signed = FALSE) ##0=scrambled,1=unscrambled scramble <- readBin(con, what="int", 1, size=2, endian="little", signed = FALSE) ##jump stepping <- readBin(con, what="raw", 4, size=1, endian="little") #Number of scans (Early WinX) lnoscan <- readBin(con, what="int", 1, size=4, endian="little", signed = TRUE) #Number of Accumulations lavgexp <- readBin(con, what="int", 1, size=4, endian="little", signed = TRUE) ##Experiment readout time ReadoutTime <- readBin(con, what="double", 1, size=4, endian="little") #T/F Triggered Timing Option TriggeredModeFlag <- readBin(con, what="int", 1, size=2, endian="little", signed = TRUE) ##jump stepping <- readBin(con, what="raw", 768, size=1, endian="little") ##number of frames in file. NumFrames <- readBin(con, what="int", 1, size=4, endian="little", signed = TRUE) if(NumFrames > 100 & missing(frame.range) & output.object == "RLum.Data.Image"){ error.message <- paste0("[read_SPE2R()] Import aborted. This file containes > 100 (", NumFrames, "). Use argument 'frame.range' to force import.") stop(error.message) } ##set frame.range if(missing(frame.range) == TRUE){frame.range <- c(1,NumFrames)} ##jump stepping <- readBin(con, what="raw", 542, size=1, endian="little") #file_header_ver file_header_ver <- readBin(con, what="double", 1, size=4, endian="little") ##jump stepping <- readBin(con, what="raw", 1000, size=1, endian="little") ##WinView_id - set to 19,088,743 (or 1234567 hex) (required for legacy reasons) WinView_id <- readBin(con, what="integer", 1, size=4, endian="little", signed = TRUE) ##jump stepping <- readBin(con, what="raw", 1098, size=1, endian="little") ##lastvalue - set to 21,845 (or 5555 hex) (required for legacy reasons) lastvalue <- readBin(con, what="integer", 1, size=2, endian="little", signed = TRUE) ##end header ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##create info element list from data temp.info <- list(ControllerVersion, LogicOutput, AmpHiCapLowNoise, xDimDet, yDimDet, xdim, ydim, VChipXdim, VChipYdim, Date, noscan, mode, exp_sec, DetTemperature, DetType, datatype, scramble, lnoscan, lavgexp, ReadoutTime, TriggeredModeFlag, NumFrames, file_header_ver) ##set name for list elements names(temp.info) <- c("ControllerVersion", "LogicOutput", "AmpHiCapLowNoise", "xDimDet", "yDimDet", "xdim", "ydim", "VChipXdim", "VChipYdim", "Date", "noscan", "mode", "exp_sec", "DetTemperature", "DetType", "datatype", "scramble", "lnoscan", "lavgexp", "ReadoutTime", "TriggeredModeFlag", "NumFrames", "file_header_ver") # read count value data --------------------------------------------------- ##set functions if(datatype == 0){ read.data <- function(n.counts){ readBin(con, what="double", n.counts, size=4, endian="little") } }else if(datatype == 1){ read.data <- function(n.counts){ readBin(con, what="integer", n.counts, size=4, endian="little", signed = TRUE) } }else if(datatype == 2){ read.data <- function(n.counts){ readBin(con, what="integer", n.counts, size=2, endian="little", signed = TRUE) } }else if(datatype == 3){ read.data <- function(n.counts){ readBin(con, what="int", n.counts, size=2, endian="little", signed = FALSE) } }else if(datatype == 8){ read.data <- function(n.counts){ readBin(con, what="integer", n.counts, size=4, endian="little", signed = FALSE) } }else{ stop("[read_SPE2R()] Unknown 'datatype'.") } ##loop over all frames ##output cat(paste("\n[read_SPE2R.R]\n\t >> ",file,sep=""), fill=TRUE) ##set progressbar if(txtProgressBar==TRUE){ pb<-txtProgressBar(min=0,max=diff(frame.range)+1, char="=", style=3) } ##stepping for frame range temp <- readBin(con, what = "raw", (min(frame.range)-1)*2, size = 1, endian = "little") for(i in 1:(diff(frame.range)+1)){#NumFrames temp.data <- matrix(read.data(n.counts = (xdim * ydim)), ncol = ydim, nrow = xdim) if(exists("data.list") == FALSE){ data.list <- list(temp.data) }else{ data.list <- c(data.list, list(temp.data)) } ##update progress bar if(txtProgressBar==TRUE){ setTxtProgressBar(pb, i) } } ##close if(txtProgressBar==TRUE){close(pb) ##output cat(paste("\t >> ",i," records have been read successfully!\n\n", sep="")) } # Output ------------------------------------------------------------------ if(output.object == "RLum.Data.Spectrum" | output.object == "matrix"){ ##to create a spectrum object the matrix has to transposed and ##the row sums are needed data.spectrum.vector <- sapply(1:length(data.list), function(x){ rowSums(data.list[[x]]) }) ##split vector to matrix data.spectrum.matrix <- matrix(data.spectrum.vector, nrow = xdim, ncol = length(data.list)) ##set column and row names colnames(data.spectrum.matrix) <- as.character(1:ncol(data.spectrum.matrix)) rownames(data.spectrum.matrix) <- as.character(1:nrow(data.spectrum.matrix)) ##set output object object <- set_RLum( class = "RLum.Data.Spectrum", originator = "read_SPE2R", recordType = "Spectrum", curveType = "measured", data = data.spectrum.matrix, info = temp.info) ##optional matrix object if(output.object == "matrix"){ object <- get_RLum(object)} }else if(output.object == "RLum.Data.Image"){ ##combine to raster data.raster.list <- lapply(1:length(data.list), function(x){ if(txtProgressBar==TRUE){ cat(paste("\r Converting to RasterLayer: ", x, "/",length(data.list), sep = "")) } raster::raster(t(data.list[[x]]), xmn = 0, xmx = max(xdim), ymn = 0, ymx = max(ydim)) }) ##Convert to raster brick data.raster <- raster::brick(x = data.raster.list) ##Create RLum.object object <- set_RLum( class = "RLum.Data.Image", originator = "read_SPE2R", recordType = "Image", curveType = "measured", data = data.raster, info = temp.info) }else{ stop("[read_SPE2R()] Chosen 'output.object' not supported. Please check manual!") } ##close con close(con) ##return values return(object) } Luminescence/R/convert_XSYG2CSV.R0000644000176200001440000000565113125226556016216 0ustar liggesusers#' Export XSYG-file(s) to CSV-files #' #' This function is a wrapper function around the functions \code{\link{read_XSYG2R}} and #' \code{\link{write_RLum2CSV}} and it imports an XSYG-file and directly exports its content to CSV-files. #' If nothing is set for the argument \code{path} (\code{\link{write_RLum2CSV}}) the input folder will #' become the output folder. #' #' @param file \code{\link{character}} (\bold{required}): name of the XSYG-file to be converted to CSV-files #' #' @param \dots further arguments that will be passed to the function \code{\link{read_XSYG2R}} and \code{\link{write_RLum2CSV}} #' #' @return The function returns either a CSV-file (or many of them) or for the option \code{export = FALSE} #' a list comprising objects of type \code{link{data.frame}} and \code{\link{matrix}} #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data}}, \code{\linkS4class{RLum.Results}}, #' \code{\link[utils]{write.table}}, \code{\link{write_RLum2CSV}}, \code{\link{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) #' #' } #' #' @export convert_XSYG2CSV <- function( file, ... ){ # General tests ------------------------------------------------------------------------------- ##file is missing? if(missing(file)){ stop("[convert_XSYG2R()] file is missing!", call. = FALSE) } ##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/plot_AbanicoPlot.R0000644000176200001440000040507613125226556016464 0ustar liggesusers#' Function to create an Abanico Plot. #' #' 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. #' #' The Abanico Plot is a combination of the classic Radial Plot #' (\code{plot_RadialPlot}) and a kernel density estimate plot (e.g #' \code{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 #' thoughtprovocing figure in this article. \cr 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 dispaying 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 themselfes. \cr #' 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 #' \code{?polygon()} for further help. \cr 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. \code{centrality = "median.weighted"}). Also #' user-defined numeric values (e.g. from the central age model) can be used if #' this appears appropriate. \cr The proportion of the polar part and the #' cartesian part of the Abanico Plot can be modfied for display reasons #' (\code{plot.ratio = 0.75}). By default, the polar part spreads over 75 \% #' and leaves 25 \% for the part that shows the KDE graph.\cr\cr #' 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: #' #' \itemize{ #' \item \code{"n"} (number of samples) #' \item \code{"mean"} (mean De value) #' \item \code{"median"} (median of the De values) #' \item \code{"sd.rel"} (relative standard deviation in percent) #' \item \code{"sd.abs"} (absolute standard deviation) #' \item \code{"se.rel"} (relative standard error) #' \item \code{"se.abs"} (absolute standard error) #' \item \code{"in.2s"} (percent of samples in 2-sigma range) #' \item \code{"kurtosis"} (kurtosis) #' \item \code{"skewness"} (skewness) #' } #' #' Note that the input data for the statistic summary is sent to the function #' \code{calc_Statistics()} depending on the log-option for the z-scale. If #' \code{"log.z = TRUE"}, the summary is based on the logarithms of the input #' data. If \code{"log.z = FALSE"} the linearly scaled data is used. \cr #' Note as well, that \code{"calc_Statistics()"} calculates these statistic #' measures in three different ways: \code{unweighted}, \code{weighted} and #' \code{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 \code{summary.method}.\cr\cr #' #' The optional parameter \code{layout} allows to modify the entire plot more #' sophisticated. 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. \code{get_Layout()} or type eg. for the layout type \code{"journal"} #' \code{get_Layout("journal")}. A layout type can be modified by the user by #' assigning new values to the list object.\cr\cr It is possible for the #' z-scale to specify where ticks are to be drawn by using the parameter #' \code{at}, e.g. \code{at = seq(80, 200, 20)}, cf. function documentation of #' \code{axis}. Specifying tick positions manually overrides a #' \code{zlim}-definition. #' #' @param data \code{\link{data.frame}} or \code{\linkS4class{RLum.Results}} #' object (required): for \code{data.frame} two columns: De (\code{data[,1]}) #' and De error (\code{data[,2]}). To plot several data sets in one plot the #' data sets must be provided as \code{list}, e.g. \code{list(data.1, data.2)}. #' #' @param na.rm \code{\link{logical}} (with default): exclude NA values #' from the data set prior to any further operations. #' #' @param log.z \code{\link{logical}} (with default): Option to display the #' z-axis in logarithmic scale. Default is \code{TRUE}. #' #' @param z.0 \code{\link{character}} or \code{\link{numeric}}: User-defined #' central value, used for centering of data. One out of \code{"mean"}, #' \code{"mean.weighted"} and \code{"median"} or a numeric value (not its #' logarithm). Default is \code{"mean.weighted"}. #' #' @param dispersion \code{\link{character}} (with default): measure of #' dispersion, used for drawing the scatter polygon. One out of \code{"qr"} #' (quartile range), \code{"pnn"} (symmetric percentile range with nn the lower #' percentile, e.g. \code{"p05"} depicting the range between 5 and 95 %), #' \code{"sd"} (standard deviation) and \code{"2sd"} (2 standard deviations), #' default is \code{"qr"}. Note that \code{"sd"} and \code{"2sd"} are only #' meaningful in combination with \code{"z.0 = 'mean'"} because the unweighted #' mean is used to center the polygon. #' #' @param plot.ratio \code{\link{numeric}}: Relative space, given to the radial #' versus the cartesian plot part, deault is \code{0.75}. #' #' @param rotate \code{\link{logical}}: Option to turn the plot by 90 degrees. #' #' @param mtext \code{\link{character}}: additional text below the plot title. #' #' @param summary \code{\link{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 \code{\link{numeric}} or \code{\link{character}} (with #' default): optional position coordinates or keyword (e.g. \code{"topright"}) #' for the statistical summary. Alternatively, the keyword \code{"sub"} may be #' specified to place the summary below the plot header. However, this latter #' option in only possible if \code{mtext} is not used. #' #' @param summary.method \code{\link{character}} (with default): keyword #' indicating the method used to calculate the statistic summary. One out of #' \code{"unweighted"}, \code{"weighted"} and \code{"MCM"}. See #' \code{\link{calc_Statistics}} for details. #' #' @param legend \code{\link{character}} vector (optional): legend content to #' be added to the plot. #' #' @param legend.pos \code{\link{numeric}} or \code{\link{character}} (with #' default): optional position coordinates or keyword (e.g. \code{"topright"}) #' for the legend to be plotted. #' #' @param stats \code{\link{character}}: additional labels of statistically #' important values in the plot. One or more out of the following: #' \code{"min"}, \code{"max"}, \code{"median"}. #' #' @param rug \code{\link{logical}}: Option to add a rug to the KDE part, to #' indicate the location of individual values. #' #' @param kde \code{\link{logical}}: Option to add a KDE plot to the dispersion #' part, default is \code{TRUE}. #' #' @param hist \code{\link{logical}}: Option to add a histogram to the #' dispersion part. Only meaningful when not more than one data set is plotted. #' #' @param dots \code{\link{logical}}: 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 \code{\link{logical}}: Option to add a boxplot to the #' dispersion part, default is \code{FALSE}. #' #' @param y.axis \code{\link{logical}}: Option to hide y-axis labels. Useful #' for data with small scatter. #' #' @param error.bars \code{\link{logical}}: Option to show De-errors as error #' bars on De-points. Useful in combination with \code{y.axis = FALSE, bar.col #' = "none"}. #' #' @param bar \code{\link{numeric}} (with default): option to add one or more #' dispersion bars (i.e., bar showing the 2-sigma range) centered at the #' defined values. By default a bar is drawn according to \code{"z.0"}. To omit #' the bar set \code{"bar = FALSE"}. #' #' @param bar.col \code{\link{character}} or \code{\link{numeric}} (with #' default): colour of the dispersion bar. Default is \code{"grey60"}. #' #' @param polygon.col \code{\link{character}} or \code{\link{numeric}} (with #' default): colour of the polygon showing the data scatter. Sometimes this #' polygon may be omitted for clarity. To disable it use \code{FALSE} or #' \code{polygon = FALSE}. Default is \code{"grey80"}. #' #' @param line \code{\link{numeric}}: numeric values of the additional lines to #' be added. #' #' @param line.col \code{\link{character}} or \code{\link{numeric}}: colour of #' the additional lines. #' #' @param line.lty \code{\link{integer}}: line type of additional lines #' #' @param line.label \code{\link{character}}: labels for the additional lines. #' #' @param grid.col \code{\link{character}} or \code{\link{numeric}} (with #' default): colour of the grid lines (originating at [0,0] and strechting to #' the z-scale). To disable grid lines use \code{FALSE}. Default is #' \code{"grey"}. #' #' @param frame \code{\link{numeric}} (with default): option to modify the #' plot frame type. Can be one out of \code{0} (no frame), \code{1} (frame #' originates at 0,0 and runs along min/max isochrons), \code{2} (frame #' embraces the 2-sigma bar), \code{3} (frame embraces the entire plot as a #' rectangle).Default is \code{1}. #' #' @param bw \code{\link{character}} (with default): bin-width for KDE, choose #' a numeric value for manual setting. #' #' @param output \code{\link{logical}}: Optional output of numerical plot #' parameters. These can be useful to reproduce similar plots. Default is #' \code{TRUE}. #' #' @param interactive \code{\link{logical}} (with default): create an interactive #' abanico plot (requires the 'plotly' package) #' #' @param \dots Further plot arguments to pass. \code{xlab} must be a vector of #' length 2, specifying the upper and lower x-axes labels. #' #' @return returns a plot object and, optionally, a list with plot calculus #' data. #' #' @section Function version: 0.1.10 #' #' @author Michael Dietze, GFZ Potsdam (Germany),\cr Sebastian Kreutzer, #' IRAMAT-CRP2A, Universite Bordeaux Montaigne (France)\cr Inspired by a plot #' introduced by Galbraith & Green (1990) #' #' @seealso \code{\link{plot_RadialPlot}}, \code{\link{plot_KDE}}, #' \code{\link{plot_Histogram}} #' #' @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) #' #' @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", output = TRUE, interactive = FALSE, ... ) { ## check data and parameter consistency-------------------------------------- ## Homogenise input data format if(is(data, "list") == FALSE) { data <- list(data) } ## Check input data for(i in 1:length(data)) { if(is(data[[i]], "RLum.Results") == FALSE & is(data[[i]], "data.frame") == FALSE) { stop(paste("[plot_AbanicoPlot()] Input data format is neither", "'data.frame' nor 'RLum.Results'")) } else { if(is(data[[i]], "RLum.Results") == TRUE) { data[[i]] <- get_RLum(data[[i]], "data")[,c(1:2)] } } } ## Check input data for(i in 1:length(data)) { if(is(data[[i]], "RLum.Results") == FALSE & is(data[[i]], "data.frame") == FALSE) { stop(paste("[plot_AbanicoPlot()] Input data format is neither", "'data.frame' nor 'RLum.Results'")) } else { if(is(data[[i]], "RLum.Results") == TRUE) { data[[i]] <- get_RLum(data[[i]])[,c(1:2)] } } } ## optionally, remove NA-values if(na.rm == TRUE) { for(i in 1:length(data)) { n.NA <- sum(!complete.cases(data[[i]])) if(n.NA == 1) {message(paste0("[plot_AbanicoPlot()] data set (", i, "): 1 NA value excluded.")) } else if(n.NA > 1) { message(paste0("[plot_AbanicoPlot()] data set (", i,"): ", n.NA, " NA values 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)){ try(stop("[plot_AbanicoPlot()] Nothing plotted, your data set is empty!", call. = FALSE)) 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 warning(paste0("[plot_AbanicoPlot()] 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){ try(stop("[plot_AbanicoPlot()] After removing invalid entries, nothing is plotted!", call. = FALSE)) return(NULL) } } ## check for zero-error values for(i in 1:length(data)) { if(length(data[[i]]) < 2) { stop("Data without errors cannot be displayed!") } if(sum(data[[i]][,2] == 0) > 0) { data[[i]] <- data[[i]][data[[i]][,2] > 0,] if(nrow(data[[i]]) < 1) { stop("[plot_AbanicoPlot()] Data set contains only values with zero errors.", call. = FALSE) } warning("[plot_AbanicoPlot()] values with zero errors cannot be displayed and were removed!",call. = FALSE) } } ## 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)) } ## check/set layout definitions if("layout" %in% names(list(...))) { layout = get_Layout(layout = list(...)$layout) } else { layout <- get_Layout(layout = "default") } if(missing(stats) == TRUE) { stats <- numeric(0) } if(missing(bar) == TRUE) { bar <- rep(TRUE, length(data)) } if(missing(bar.col) == TRUE) { 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) == TRUE) { 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) == TRUE) { 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) == TRUE) { summary <- c("n", "in.2s") } if(missing(summary.pos) == TRUE) { summary.pos <- "sub" } if(missing(mtext) == TRUE) { 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)) { limits.z <- extraArgs$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(grepl(pattern = "Error", x = bw.test[1]) == TRUE) { bw <- "nrd0" warning("[plot_AbanicoPlot()] Option for bw not possible. Set to nrd0!", call. = FALSE) } } if ("fun" %in% names(extraArgs)) { fun <- list(...)$fun } else { fun <- FALSE } ## check for negative values, stoppp function, but do not stop if(min(De.global) < 0) { message("\n [plot_AbanicoPlot()] data contains negative values. Nothing plotted!") return(NULL) } ##check for 0 dose values and adjust for plotting ... if((min(De.global) == 0) && log.z == TRUE){ warning("\n [plot_AbanicoPlot()] data contains 0 values, values positively shifted by 0.01", call. = FALSE) data <- lapply(1:length(data), function(x){ df <- data.frame( data[[x]][,1] + 0.01, data[[x]][,2]) colnames(df) <- colnames(data) return(df) }) } ## calculate and append statistical measures -------------------------------- ## z-values based on log-option z <- lapply(1:length(data), function(x){ if(log.z == TRUE) { log(data[[x]][,1]) } else { data[[x]][,1] } }) if(is(z, "list") == FALSE) { z <- list(z) } 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){ if(log.z == TRUE) { data[[x]][,2] / data[[x]][,1] } else { data[[x]][,2] } }) if(is(se, "list") == FALSE) { se <- list(se) } 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 if(is.numeric(z.0) == TRUE) { z.central <- lapply(1:length(data), function(x){ rep(ifelse(log.z == TRUE, log(z.0), z.0), length(data[[x]][,3]))}) } else { stop("Value for z.0 not supported!") } 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]}) if(is(precision, "list") == FALSE) {precision <- list(precision)} 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]}) if(is(std.estimate, "list") == FALSE) {std.estimate <- list(std.estimate)} 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)) { if(extraArgs$weights == TRUE) { wgt <- lapply(1:length(data), function(x){ (1 / data[[x]][,2]) / sum(1 / data[[x]][,2]^2) }) if(is(wgt, "list") == FALSE) { wgt <- list(wgt) } data <- lapply(1:length(data), function(x) { cbind(data[[x]], wgt[[x]])}) rm(wgt) } else { wgt <- lapply(1:length(data), function(x){ rep(x = 1, times = nrow(data[[x]])) / sum(rep(x = 1, times = nrow(data[[x]]))) }) if(is(wgt, "list") == FALSE) { wgt <- list(wgt) } data <- lapply(1:length(data), function(x) { cbind(data[[x]], wgt[[x]])}) rm(wgt) } } else { wgt <- lapply(1:length(data), function(x){ rep(x = 1, times = nrow(data[[x]])) / sum(rep(x = 1, times = nrow(data[[x]]))) }) if(is(wgt, "list") == FALSE) { wgt <- list(wgt) } 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) } else { stop("Value for z.0 not supported!") } ## 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 { stop("Argmuent xlab is not of 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)) { 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)) { limits.x <- extraArgs$xlim } else { limits.x <- c(0, max(data.global[,6]) * 1.05) } if(limits.x[1] != 0) { limits.x[1] <- 0 warning("Lower x-axis limit not set to zero, issue corrected!") } if("ylim" %in% names(extraArgs)) { limits.y <- extraArgs$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 { if(length(layout$abanico$colour$bar) == 1) { bar.col <- 1:length(data) } else { bar.col <- layout$abanico$colour$bar.col } if(length(layout$abanico$colour$kde.line) == 1) { kde.line <- 1:length(data) } else { kde.line <- layout$abanico$colour$kde.line } if(length(layout$abanico$colour$kde.fill) == 1) { kde.fill <- rep(layout$abanico$colour$kde.fill, length(data)) } else { kde.fill <- layout$abanico$colour$kde.fill } if(length(layout$abanico$colour$value.dot) == 1) { value.dot <- 1:length(data) } else { value.dot <- layout$abanico$colour$value.dot } if(length(layout$abanico$colour$value.bar) == 1) { value.bar <- 1:length(data) } else { value.bar <- layout$abanico$colour$value.bar } if(length(layout$abanico$colour$value.rug) == 1) { value.rug <- 1:length(data) } else { value.rug <- layout$abanico$colour$value.rug } if(length(layout$abanico$colour$summary) == 1) { summary.col <- 1:length(data) } else { summary.col <- layout$abanico$colour$summary } 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)) tck <- if("tck" %in% names(extraArgs)) { extraArgs$tck } else { NA } tcl <- if("tcl" %in% names(extraArgs)) { extraArgs$tcl } else { -0.5 } ## define auxiliary plot parameters ----------------------------------------- ## set space between z-axis and baseline of cartesian part if(boxplot == TRUE) { lostintranslation <- 1.03 } else { lostintranslation <- 1.03 plot.ratio <- plot.ratio * 1.05 } ## create empty plot to update plot parameters if(rotate == FALSE) { 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 == TRUE) { 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 == TRUE) { label.z.text <- signif(exp(tick.values.major), 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 == TRUE) { De.stats[i,2:4] <- exp(De.stats[i,2:4]) } ##kdemax - here a little doubled as it appears below again De.density <-density(x = data[[i]][,1], kernel = "gaussian", bw = bw, from = limits.z[1], to = limits.z[2]) 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.rel" %in% summary[j] == TRUE, paste("rel. se = ", round(De.stats[i,7], 2), " %", " | ", sep = ""), ""), ifelse("se.abs" %in% summary[j] == TRUE, paste("abs. 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 == FALSE) { ## convert keywords into summary placement coordinates if(missing(summary.pos) == TRUE) { summary.pos <- c(limits.x[1], limits.y[2]) summary.adj <- c(0, 1) } else if(length(summary.pos) == 2) { summary.pos <- summary.pos summary.adj <- c(0, 1) } else if(summary.pos[1] == "topleft") { summary.pos <- c(limits.x[1], limits.y[2] - par()$cxy[2] * 1) summary.adj <- c(0, 1) } else if(summary.pos[1] == "top") { summary.pos <- c(mean(limits.x), limits.y[2] - par()$cxy[2] * 1) summary.adj <- c(0.5, 1) } else if(summary.pos[1] == "topright") { summary.pos <- c(limits.x[2], limits.y[2] - par()$cxy[2] * 1) summary.adj <- c(1, 1) } else if(summary.pos[1] == "left") { summary.pos <- c(limits.x[1], mean(limits.y)) summary.adj <- c(0, 0.5) } else if(summary.pos[1] == "center") { summary.pos <- c(mean(limits.x), mean(limits.y)) summary.adj <- c(0.5, 0.5) } else if(summary.pos[1] == "right") { summary.pos <- c(limits.x[2], mean(limits.y)) summary.adj <- c(1, 0.5) }else if(summary.pos[1] == "bottomleft") { summary.pos <- c(limits.x[1], limits.y[1] + par()$cxy[2] * 3.5) summary.adj <- c(0, 0) } else if(summary.pos[1] == "bottom") { summary.pos <- c(mean(limits.x), limits.y[1] + par()$cxy[2] * 3.5) summary.adj <- c(0.5, 0) } else if(summary.pos[1] == "bottomright") { summary.pos <- c(limits.x[2], limits.y[1] + par()$cxy[2] * 3.5) summary.adj <- c(1, 0) } ## convert keywords into legend placement coordinates if(missing(legend.pos) == TRUE) { legend.pos <- c(limits.x[1], limits.y[2]) legend.adj <- c(0, 1) } else if(length(legend.pos) == 2) { legend.pos <- legend.pos legend.adj <- c(0, 1) } else if(legend.pos[1] == "topleft") { legend.pos <- c(limits.x[1], limits.y[2]) legend.adj <- c(0, 1) } else if(legend.pos[1] == "top") { legend.pos <- c(mean(limits.x), limits.y[2]) legend.adj <- c(0.5, 1) } else if(legend.pos[1] == "topright") { legend.pos <- c(limits.x[2], limits.y[2]) legend.adj <- c(1, 1) } else if(legend.pos[1] == "left") { legend.pos <- c(limits.x[1], mean(limits.y)) legend.adj <- c(0, 0.5) } else if(legend.pos[1] == "center") { legend.pos <- c(mean(limits.x), mean(limits.y)) legend.adj <- c(0.5, 0.5) } else if(legend.pos[1] == "right") { legend.pos <- c(limits.x[2], mean(limits.y)) legend.adj <- c(1, 0.5) } else if(legend.pos[1] == "bottomleft") { legend.pos <- c(limits.x[1], limits.y[1]) legend.adj <- c(0, 0) } else if(legend.pos[1] == "bottom") { legend.pos <- c(mean(limits.x), limits.y[1]) legend.adj <- c(0.5, 0) } else if(legend.pos[1] == "bottomright") { legend.pos <- c(limits.x[2], limits.y[1]) legend.adj <- c(1, 0) } } else { ## convert keywords into summary placement coordinates if(missing(summary.pos) == TRUE) { summary.pos <- c(limits.y[1] + par()$cxy[1] * 7.5, limits.x[1]) summary.adj <- c(0, 0) } else if(length(summary.pos) == 2) { summary.pos <- summary.pos summary.adj <- c(0, 1) } else if(summary.pos[1] == "topleft") { summary.pos <- c(limits.y[1] + par()$cxy[1] * 7.5, limits.x[2]) summary.adj <- c(0, 1) } else if(summary.pos[1] == "top") { summary.pos <- c(mean(limits.y), limits.x[2]) summary.adj <- c(0.5, 1) } else if(summary.pos[1] == "topright") { summary.pos <- c(limits.y[2], limits.x[2]) summary.adj <- c(1, 1) } else if(summary.pos[1] == "left") { summary.pos <- c(limits.y[1] + par()$cxy[1] * 7.5, mean(limits.x)) summary.adj <- c(0, 0.5) } else if(summary.pos[1] == "center") { summary.pos <- c(mean(limits.y), mean(limits.x)) summary.adj <- c(0.5, 0.5) } else if(summary.pos[1] == "right") { summary.pos <- c(limits.y[2], mean(limits.x)) summary.adj <- c(1, 0.5) }else if(summary.pos[1] == "bottomleft") { summary.pos <- c(limits.y[1] + par()$cxy[1] * 7.5, limits.x[1]) summary.adj <- c(0, 0) } else if(summary.pos[1] == "bottom") { summary.pos <- c(mean(limits.y), limits.x[1]) summary.adj <- c(0.5, 0) } else if(summary.pos[1] == "bottomright") { summary.pos <- c(limits.y[2], limits.x[1]) summary.adj <- c(1, 0) } ## convert keywords into legend placement coordinates if(missing(legend.pos) == TRUE) { legend.pos <- c(limits.y[1] + par()$cxy[1] * 7.5, limits.x[1]) legend.adj <- c(0, 0) } else if(length(legend.pos) == 2) { legend.pos <- legend.pos legend.adj <- c(1, 0) } else if(legend.pos[1] == "topleft") { legend.pos <- c(limits.y[1] + par()$cxy[1] * 11, limits.x[2]) legend.adj <- c(1, 0) } else if(legend.pos[1] == "top") { legend.pos <- c(mean(limits.y), limits.x[2]) legend.adj <- c(1, 0.5) } else if(legend.pos[1] == "topright") { legend.pos <- c(limits.y[2], limits.x[2]) legend.adj <- c(1, 1) } else if(legend.pos[1] == "left") { legend.pos <- c(limits.y[1] + par()$cxy[1] * 7.5, mean(limits.x)) legend.adj <- c(0.5, 0) } else if(legend.pos[1] == "center") { legend.pos <- c(mean(limits.y), mean(limits.x)) legend.adj <- c(0.5, 0.5) } else if(legend.pos[1] == "right") { legend.pos <- c(limits.y[2], mean(limits.x)) legend.adj <- c(0.5, 1) } else if(legend.pos[1] == "bottomleft") { legend.pos <- c(limits.y[1] + par()$cxy[1] * 7.5, limits.x[1]) legend.adj <- c(0, 0) } else if(legend.pos[1] == "bottom") { legend.pos <- c(mean(limits.y), limits.x[1]) legend.adj <- c(0, 0.5) } else if(legend.pos[1] == "bottomright") { legend.pos <- c(limits.y[2], limits.x[1]) legend.adj <- c(0, 1) } } ## 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]) } } else { stop("Measure of dispersion not supported.") } 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 <- 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 par(bg = layout$abanico$colour$background) bg.original <- par()$bg if(rotate == FALSE) { ## setup plot area par(mar = c(4.5, 4.5, shift.lines + 1.5, 7), xpd = TRUE, cex = cex) if(layout$abanico$dimension$figure.width != "auto" | layout$abanico$dimension$figure.height != "auto") { par(mai = layout$abanico$dimension$margin / 25.4, pin = c(layout$abanico$dimension$figure.width / 25.4 - layout$abanico$dimension$margin[2] / 25.4 - layout$abanico$dimension$margin[4] / 25.4, layout$abanico$dimension$figure.height / 25.4 - layout$abanico$dimension$margin[1] / 25.4 - layout$abanico$dimension$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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$ylab], 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) == FALSE) { 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$main], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xtck1], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xlab1], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xlab2], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xtck2], col.axis = layout$abanico$colour$xtck2, cex.axis = layout$abanico$font.size$xlab2/12) ## plot y-axis if(y.axis == TRUE) { char.height <- par()$cxy[2] tick.space <- 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 = 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, line = 2 * layout$abanico$dimension$ytck.line / 100 - 2, labels = paste("\u00B1", "2"), las = 1, family = layout$abanico$font.type$ytck, font = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$ytck], col.axis = layout$abanico$colour$ytck, cex.axis = layout$abanico$font.size$ylab/12) } 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), 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$ytck], col.axis = layout$abanico$colour$ytck, cex.axis = layout$abanico$font.size$ylab/12) } } 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, 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$ytck], 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(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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$ztck], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$zlab], cex = cex * layout$abanico$font.size$zlab/12) ## plot values and optionally error bars if(error.bars == TRUE) { for(i in 1:length(data)) { 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xtck3], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xlab3], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xtck3], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xlab2], 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, length(dots.x.i) - 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$stats], 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) == FALSE) { ## store and change font familiy 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$legend], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$mtext], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$summary], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$summary], 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) if(layout$abanico$dimension$figure.width != "auto" | layout$abanico$dimension$figure.height != "auto") { par(mai = layout$abanico$dimension$margin / 25.4, pin = c(layout$abanico$dimension$figure.width / 25.4 - layout$abanico$dimension$margin[2] / 25.4 - layout$abanico$dimension$margin[4] / 25.4, layout$abanico$dimension$figure.height / 25.4 - layout$abanico$dimension$margin[1] / 25.4 - layout$abanico$dimension$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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$ylab], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$main], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xtck1], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xlab1], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xlab2], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xtck2], col.axis = layout$abanico$colour$xtck2, cex.axis = layout$abanico$font.size$xlab2/12) ## plot y-axis if(y.axis == TRUE) { char.height <- par()$cxy[2] tick.space <- 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$ytck], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$ytck], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$ytck], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$ztck], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$zlab], cex = cex * layout$abanico$font.size$zlab/12) ## plot values and optionally error bars if(error.bars == TRUE) { for(i in 1:length(data)) { 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xtck3], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xlab3], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xtck3], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$xlab2], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$stats], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$legend], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$mtext], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$summary], 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 = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$abanico$font.deco$summary], cex = cex * layout$abanico$font.size$summary / 12) } } } } ##sTeve if(fun & !interactive){sTeve()} ## 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) { if (!requireNamespace("plotly", quietly = TRUE)) stop("The interactive abanico plot requires the 'plotly' package. To install", " this package run 'install.packages('plotly')' in your R console.", call. = FALSE) ##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 = precision, y = 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, hoverinfo = "none", name = "z-axis (left)", type = "scatter", mode = "lines", 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, hoverinfo = "none", name = "z-axis (right)", type = "scatter", mode = "lines", 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, hoverinfo = "none", type = "scatter", mode = "lines", 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, hoverinfo = "none", x = x, y = y, showlegend = FALSE, type = "scatter", mode = "lines", 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, text = tick.text, textposition = "right", hoverinfo = "none", 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[[1]][ ,1]), digits = 2, nsmall = 1), "
", "Density:", format(KDE[[1]][ ,2], digits = 2, nsmall = 1)) IAP <- plotly::add_trace(IAP, data = KDE.curve, hoverinfo = "text", text = KDE.text, x = x, y = y, name = "KDE", type = "scatter", mode = "lines", 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 if(output == TRUE) { return(invisible(plot.output)) } } Luminescence/R/plot_RLum.Analysis.R0000644000176200001440000005547513125226556016736 0ustar liggesusers#' Plot function for an RLum.Analysis S4 class object #' #' The function provides a standardised plot output for curve data of an #' RLum.Analysis S4 class object #' #' The function produces a multiple plot output. A file output is recommended #' (e.g., \code{\link{pdf}}). #' #' \bold{curve.transformation}\cr #' #' 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 \code{ltype} #' \code{OSL} and \code{IRSL}.\cr #' #' Please note: The curve transformation within this functions works roughly, #' i.e. every IRSL or OSL curve is transformed, without considerung whether it #' is measured with the PMT or not! However, for a fast look it might be #' helpful.\cr #' #' #' @param object \code{\linkS4class{RLum.Analysis}} (\bold{required}): S4 #' object of class \code{RLum.Analysis} #' #' @param subset named \code{\link{list}} (optional): subsets elements for plotting. The #' arguments in the named \code{\link{list}} will be directly passed to the function \code{\link{get_RLum}} #' (e.g., \code{subset = list(curveType = "measured")}) #' #' @param nrows \code{\link{integer}} (optional): sets number of rows for #' plot output, if nothing is set the function tries to find a value. #' #' @param ncols \code{\link{integer}} (optional): sets number of columns #' for plot output, if nothing is set the function tries to find a value. #' #' @param abline \code{\link{list}} (optional): allows to add ablines to the plot. Argument are provided #' in a list and will be forwared to the function \code{\link{abline}}, e.g., \code{list(v = c(10, 100))} #' adds two vertical lines add 10 and 100 to all plots. In contrast \code{list(v = c(10), v = c(100)} #' adds a vertical at 10 to the first and a vertical line at 100 to the 2nd plot. #' #' @param combine \code{\link{logical}} (with default): allows to combine all #' \code{\linkS4class{RLum.Data.Curve}} objects in one single plot. #' #' @param curve.transformation \code{\link{character}} (optional): allows #' transforming CW-OSL and CW-IRSL curves to pseudo-LM curves via #' transformation functions. Allowed values are: \code{CW2pLM}, \code{CW2pLMi}, #' \code{CW2pHMi} and \code{CW2pPMi}. See details. #' #' @param plot.single \code{\link{logical}} (with default): global par settings are #' considered, normally this should end in one plot per page #' #' @param \dots further arguments and graphical parameters will be passed to #' the \code{plot} function. Supported arguments: \code{main}, \code{mtext}, #' \code{log}, \code{lwd}, \code{lty} \code{type}, \code{pch}, \code{col}, #' \code{norm}, \code{xlim},\code{ylim}, \code{xlab}, \code{ylab}... and for \code{combine = TRUE} #' also: \code{sub}, \code{legend}, \code{legend.text}, \code{legend.pos} (typical plus 'outside'), \code{legend.col}, \code{smooth}. #' All arguments can be provided as \code{vector} or \code{list} to gain in full control #' of all plot settings. #' #' @return Returns multiple plots. #' #' @note Not all arguments available for \code{\link{plot}} will be passed! #' Only plotting of \code{RLum.Data.Curve} and \code{RLum.Data.Spectrum} #' objects are currently supported.\cr #' #' @section Function version: 0.3.8 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\link{plot}}, \code{\link{plot_RLum}}, #' \code{\link{plot_RLum.Data.Curve}} #' #' @references # #' #' @keywords aplot #' #' @examples #' #'##load data #'data(ExampleData.BINfileData, envir = environment()) #' #'##convert values for position 1 #'temp <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos=1) #' #'##(1) plot (combine) TL curves in one plot #'plot_RLum.Analysis( #' temp, #' subset = list(recordType = "TL"), #' combine = TRUE, #' norm = TRUE, #' abline = list(v = c(110)) #' ) #' #'##(2) same as example (1) but using #'## the argument smooth = TRUE #'plot_RLum.Analysis( #' temp, #' subset = list(recordType = "TL"), #' combine = TRUE, #' norm = TRUE, #' smooth = TRUE, #' abline = list(v = c(110)) #' ) #' #' @export plot_RLum.Analysis <- function( object, subset = NULL, nrows, ncols, abline = NULL, combine = FALSE, curve.transformation, plot.single = FALSE, ... ){ # Integrity check ---------------------------------------------------------------------------- ##check if object is of class RLum.Analysis (lists are handled via plot_RLum()) if (!is(object, "RLum.Analysis")) { stop("[plot_RLum.Analysis()] Input object is not of type 'RLum.Analysis'") } # Make selection if wanted ------------------------------------------------------------------- if(!is.null(subset)){ ##check whether the user set the drop option and remove it, as we cannot work with it subset <- subset[!sapply(names(subset), function(x){"drop" %in% x})] object <- do.call(get_RLum, c(object = object, subset, drop = FALSE)) } # Deal with additional arguments. ------------------------------------------------------------ ##create plot settings list plot.settings <- list( main = NULL, mtext = NULL, log = "", lwd = 1, lty = 1, type = "l", xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL, pch = 1, col = "black", norm = FALSE, sub = NULL, cex = 1, legend = TRUE, legend.text = NULL, legend.pos = NULL, legend.col = NULL, smooth = FALSE ) plot.settings <- modifyList(x = plot.settings, val = list(...), keep.null = TRUE) ##try to find optimal parameters, this is however, a little bit stupid, but ##better than without any presetting if(combine){ n.plots <- length(unique(as.character(structure_RLum(object)$recordType))) }else{ n.plots <- length_RLum(object) } if (missing(ncols) | missing(nrows)) { if (missing(ncols) & !missing(nrows)) { if (n.plots == 1) { ncols <- 1 } else{ ncols <- 2 } } else if (!missing(ncols) & missing(nrows)) { if (n.plots == 1) { nrows <- 1 } else if (n.plots > 1 & n.plots <= 4) { nrows <- 2 } else{ nrows <- 3 } } else{ if (n.plots == 1) { nrows <- 1 ncols <- 1 } else if (n.plots > 1 & n.plots <= 2) { nrows <- 1 ncols <- 2 } else if (n.plots > 2 & n.plots <= 4) { nrows <- 2 ncols <- 2 } else{ nrows <- 3 ncols <- 2 } } } # Plotting ------------------------------------------------------------------ ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##(1) NORMAL (combine == FALSE) ##+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ if(!combine || length(object@records) == 1){ ##show warning message if(combine & length(object@records) == 1){ warning("Nothing to combine, object contains a single curve.") } ##grep RLum.Data.Curve or RLum.Data.Spectrum objects temp <- lapply(1:length(object@records), function(x){ if(is(object@records[[x]], "RLum.Data.Curve") || is(object@records[[x]], "RLum.Data.Spectrum")){ object@records[[x]] }}) ##calculate number of pages for mtext if (length(temp) %% (nrows * ncols) > 0) { n.pages <- round(length(temp) / (nrows * ncols), digits = 0) + 1 } else{ n.pages <- length(temp) / (nrows * ncols) } ##set par par.default <- par("mfrow") if(!plot.single){on.exit(par(mfrow = par.default))} if(!plot.single) { par(mfrow = c(nrows, ncols)) } ##expand plot settings list plot.settings <- lapply(setNames(1:length(plot.settings), names(plot.settings)), function(x) { if (!is.null(plot.settings[[x]])) { if(length(plot.settings[[x]]) > 1){ if(is(plot.settings[[x]], "list")){ rep_len(plot.settings[[x]], length.out = length(temp)) }else{ rep_len(list(plot.settings[[x]]), length.out = length(temp)) } }else{ rep_len(plot.settings[[x]], length.out = length(temp)) } } else{ plot.settings[[x]] } }) ##expand abline if(!is.null(abline)){ abline.names <- rep_len(names(abline), length.out = length(temp)) abline <- rep_len(abline, length.out = length(temp)) names(abline) <- abline.names } ##apply curve transformation for(i in 1:length(temp)){ if(is(temp[[i]], "RLum.Data.Curve") == TRUE){ ##set curve transformation if wanted if((grepl("IRSL", temp[[i]]@recordType) | grepl("OSL", temp[[i]]@recordType)) & !missing(curve.transformation)){ if(curve.transformation=="CW2pLM"){ temp[[i]] <- CW2pLM(temp[[i]]) }else if(curve.transformation=="CW2pLMi"){ temp[[i]] <- CW2pLMi(temp[[i]]) }else if(curve.transformation=="CW2pHMi"){ temp[[i]]<- CW2pHMi(temp[[i]]) }else if(curve.transformation=="CW2pPMi"){ temp[[i]] <- CW2pPMi(temp[[i]]) }else{ warning("Function for 'curve.transformation' is unknown. No transformation is performed.") } } ##check plot settings and adjust ##xlim if (!is.null(plot.settings$xlim)) { xlim.set <- plot.settings$xlim[[i]] if (plot.settings$xlim[[i]][1] < min(temp[[i]]@data[,1])) { xlim.set[1] <- min(temp[[i]]@data[,1]) } if (plot.settings$xlim[[i]][2] > max(temp[[i]]@data[,1])) { xlim.set[2] <- max(temp[[i]]@data[,1]) } }else{ xlim.set <- plot.settings$xlim[[i]] } ##ylim if (!is.null(plot.settings$ylim)) { ylim.set <- plot.settings$ylim if (plot.settings$ylim[[i]][1] < min(temp[[i]]@data[,2])) { ylim.set[1] <- min(temp[[i]]@data[,2]) } if (plot.settings$ylim[[i]][2] > max(temp[[i]]@data[,2])) { ylim.set[2] <- max(temp[[i]]@data[,2]) } }else{ ylim.set <- plot.settings$ylim[[i]] } ##col if (unique(plot.settings$col) != "black") { col <- plot.settings$col[i] } else{ if (grepl("IRSL", temp[[i]]@recordType)) { col <- "red" } else if (grepl("OSL", temp[[i]]@recordType)) { col <- "blue" } else { col <- plot.settings$col[[i]] } } ##main main <- if (is.null(plot.settings$main[[i]])) { temp[[i]]@recordType } else{ plot.settings$main[[i]] } ##++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##PLOT ##++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##plot RLum.Data.Curve curve ##we have to do this via this way, otherwise we run into a duplicated arguments ##problem ##check and remove duplicated arguments arguments <- c( list( object = temp[[i]], col = col, mtext = if (!is.null(plot.settings$mtext[[i]])) { plot.settings$mtext[[i]] } else{ paste("#", i, sep = "") }, par.local = FALSE, main = main, log = plot.settings$log[[i]], lwd = plot.settings$lwd[[i]], type = plot.settings$type[[i]], lty = plot.settings$lty[[i]], xlim = xlim.set, ylim = ylim.set, pch = plot.settings$pch[[i]], cex = plot.settings$cex[[i]], smooth = plot.settings$smooth[[i]] ), list(...) ) arguments[duplicated(names(arguments))] <- NULL ##call the fucntion plot_RLum.Data.Curve do.call(what = "plot_RLum.Data.Curve", args = arguments) rm(arguments) ##add abline if(!is.null(abline[[i]])){ do.call(what = "abline", args = abline[i]) } } else if(is(temp[[i]], "RLum.Data.Spectrum")) { plot_RLum.Data.Spectrum(temp[[i]], mtext = if(!is.null(plot.settings$mtext[[i]])){ plot.settings$mtext[[i]] }else{ paste("#", i, sep = "") }, par.local = FALSE, main = if(!is.null(plot.settings$main)){ plot.settings$main }else{ temp[[i]]@recordType }) } }#end for loop }else{ ##++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##(2) NORMAL (combine == TRUE) ##++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ##(1) check RLum objects in the set object.list <- get_RLum(object) sapply(1:length(object.list), function(x){ if(is(object.list[[x]])[1] != "RLum.Data.Curve"){ stop("[plot_RLum.Analysis()] Using 'combine' is limited to 'RLum.Data.Curve' objects.") } }) ##account for different curve types, combine similar temp.object.structure <- structure_RLum(object) temp.recordType <- as.character(unique(temp.object.structure$recordType)) ##change graphic settings if(!plot.single){ par.default <- par()[c("cex", "mfrow")] if(!missing(ncols) & !missing(nrows)){ par(mfrow = c(nrows, ncols)) } ##this 2nd par request is needed as seeting mfrow resets the par settings ... this might ##not be wanted par(cex = plot.settings$cex[1]) }else{ par.default <- par()[c("cex")] par(cex = plot.settings$cex) } ##expand plot settings list ##expand list plot.settings <- lapply(setNames(1:length(plot.settings), names(plot.settings)), function(x) { if (!is.null(plot.settings[[x]])) { if(is.list(plot.settings[[x]])){ rep_len(plot.settings[[x]], length.out = length(temp.recordType)) }else{ rep_len(list(plot.settings[[x]]), length.out = length(temp.recordType)) } } else{ plot.settings[[x]] } }) ##expand abline if(!is.null(abline)){ abline.names <- rep_len(names(abline), length.out = length(temp.recordType)) abline <- rep_len(abline, length.out = length(temp.recordType)) names(abline) <- abline.names } ##(2) PLOT values for(k in 1:length(temp.recordType)) { ###get type of curves temp.object <- get_RLum(object, recordType = temp.recordType[k], drop = FALSE) ##get structure object.structure <- structure_RLum(temp.object) ##now get the real list object (note the argument recursive = FALSE) object.list <- get_RLum(object, recordType = temp.recordType[k], recursive = FALSE) ##prevent problems for non set argument if (missing(curve.transformation)) { curve.transformation <- "None" } ##transform values to data.frame and norm values temp.data.list <- lapply(1:length(object.list), function(x) { ##set curve transformation if wanted if (grepl("IRSL", object.list[[x]]@recordType) | grepl("OSL", object.list[[x]]@recordType)) { if (curve.transformation == "CW2pLM") { object.list[[x]] <- CW2pLM(object.list[[x]]) }else if (curve.transformation == "CW2pLMi") { object.list[[x]] <- CW2pLMi(object.list[[x]]) }else if (curve.transformation == "CW2pHMi") { object.list[[x]] <- CW2pHMi(object.list[[x]]) }else if (curve.transformation == "CW2pPMi") { object.list[[x]] <- CW2pPMi(object.list[[x]]) } } temp.data <- as(object.list[[x]], "data.frame") ##normalise curves if argument has been set if (plot.settings$norm[[k]]) { temp.data[,2] <- temp.data[,2] / max(temp.data[,2]) } return(temp.data) }) ##set plot parameters ##main main <- if (!is.null(plot.settings$main[[k]])) { plot.settings$main[[k]] } else{ paste0(temp.recordType[[k]], " combined") } ##xlab xlab <- if(!is.null(plot.settings$xlab[[k]])){ plot.settings$xlab[[k]] }else{ switch(temp.recordType[[k]], "TL" = "Temperature [\u00B0C]", "IRSL" = "Time [s]", "OSL" = "Time [s]", "RF" = "Time [s]", "RBR" = "Time [s]", "LM-OSL" = "Time [s]" ) } ##ylab ylab <- if(!is.null(plot.settings$ylab[[k]])){ plot.settings$ylab[[k]] }else{ paste0(temp.recordType[[k]], " [a.u.]") } ##xlim xlim <- if (!is.null(plot.settings$xlim[[k]]) & length(plot.settings$xlim[[k]]) >1) { plot.settings$xlim[[k]] } else { c(min(object.structure$x.min), max(object.structure$x.max)) } if (grepl("x", plot.settings$log[[k]], ignore.case = TRUE)) xlim[which(xlim == 0)] <- 1 ##ylim ylim <- if (!is.null(plot.settings$ylim[[k]]) & length(plot.settings$ylim[[k]]) > 1) { plot.settings$ylim[[k]] } else { range(unlist(lapply(X = temp.data.list, FUN = function(x){ range(x[,2]) }))) } if (grepl("y", plot.settings$log[[k]], ignore.case = TRUE)) ylim[which(ylim == 0)] <- 1 ##col (again) col <- if(length(plot.settings$col[[k]]) > 1 || plot.settings$col[[k]][1] != "black"){ plot.settings$col[[k]] }else{ col <- get("col", pos = .LuminescenceEnv) } ##if length of provided colours is < the number of objects, just one colour is supported if (length(col) < length(object.list)) { col <- rep_len(col, length(object.list)) } ##lty if (length(plot.settings$lty[[k]]) < length(object.list)) { lty <- rep(plot.settings$lty[[k]], times = length(object.list)) }else{ lty <- plot.settings$lty[[k]] } ##pch if (length(plot.settings$pch[[k]]) < length(object.list)) { pch <- rep(plot.settings$pch[[k]], times = length(object.list)) }else{ pch <- plot.settings$pch[[k]] } ##legend.text legend.text <- if(!is.null(plot.settings$legend.text[[k]])){ plot.settings$legend.text[[k]] }else{ paste("Curve", 1:length(object.list)) } ##legend.col legend.col <- if(!is.null(plot.settings$legend.col[[k]])){ plot.settings$legend.col[[k]] }else{ NULL } ##legend.pos legend.pos <- if(!is.null(plot.settings$legend.pos[[k]])){ plot.settings$legend.pos[[k]] }else{ "topright" } if (legend.pos == "outside") { par.default.outside <- par()[c("mar", "xpd")] par(mar = c(5.1, 4.1, 4.1, 8.1)) } ##open plot area plot( NA,NA, xlim = xlim, ylim = ylim, main = main, xlab = xlab, ylab = ylab, log = plot.settings$log[[k]], sub = plot.settings$sub[[k]] ) ##plot single curve values ## ...?Why using matplot is a bad idea: The channel resolution might be different for (n in 1:length(temp.data.list)) { ##smooth ##Why here again ... because the call differs from the one before, where the argument ##is passed to plot_RLum.Data.Curve() if(plot.settings$smooth[[k]]){ k_factor <- ceiling(length(temp.data.list[[n]][, 2])/100) temp.data.list[[n]][, 2] <- zoo::rollmean(temp.data.list[[n]][, 2], k = k_factor, fill = NA) } ##remove 0 values if plotted on a log-scale # y-Axis if (grepl("y", plot.settings$log[[k]], ignore.case = TRUE)) temp.data.list[[n]] <- temp.data.list[[n]][which(temp.data.list[[n]]$y > 0), ] # x-Axis if (grepl("x", plot.settings$log[[k]], ignore.case = TRUE)) temp.data.list[[n]] <- temp.data.list[[n]][which(temp.data.list[[n]]$x > 0), ] ##print lines if (plot.settings$type[[k]] == "l" | plot.settings$type[[k]] == "b" ) { lines( temp.data.list[[n]], col = col[n], lty = lty[n], lwd = plot.settings$lwd[[k]] ) } ##add points if requested if (plot.settings$type[[k]] == "p" | plot.settings$type[[k]] == "b" ) { points( temp.data.list[[n]], col = col[n], pch = pch[n], ) } } ##add abline if(!is.null(abline[[k]])){ do.call(what = "abline", args = abline[k]) } ##mtext mtext(plot.settings$mtext[[k]], side = 3, cex = .8 * plot.settings$cex[[k]]) ##if legend is outside of the plotting area we need to allow overplotting ##AFTER all lines have been drawn if (legend.pos == "outside") { par(xpd = TRUE) # determine legend position on log(y) scale if (grepl("y", plot.settings$log[[k]], ignore.case = TRUE)) ypos <- 10^par()$usr[4] else ypos <- par()$usr[4] # determine position on log(x) scale if (grepl("x", plot.settings$log[[k]], ignore.case = TRUE)) xpos <- 10^par()$usr[2] else xpos <- par()$usr[2] } ##legend if (plot.settings$legend[[k]]) { legend( x = ifelse(legend.pos == "outside", xpos, legend.pos), y = ifelse(legend.pos == "outside", ypos, NULL), legend = legend.text, lwd = plot.settings$lwd[[k]], lty = plot.settings$lty[[k]], col = if (is.null(legend.col)) { col[1:length(object.list)] } else{ legend.col }, bty = "n", cex = 0.8 * plot.settings$cex[[k]] ) # revert the overplotting if (legend.pos == "outside") par(xpd = FALSE) } } ##reset graphic settings if (exists("par.default.outside")) { par(par.default.outside) rm(par.default.outside) } par(par.default) rm(par.default) } } Luminescence/R/calc_TLLxTxRatio.R0000644000176200001440000001753013125226556016345 0ustar liggesusers#' Calculate the Lx/Tx ratio for a given set of TL curves [beta version] #' #' Calculate Lx/Tx ratio for a given set of TL curves. #' #' \bold{Uncertainty estimation}\cr #' #' The standard errors are calculated using the following generalised equation: #' #' \deqn{SE_{signal} <- abs(Signal_{net} * BG_f /BG_{signal}} #' #' where \eqn{BG_f} is a term estimated by calculating the standard deviation of the sum of #' the \eqn{L_x} background counts and the sum of the \eqn{T_x} background counts. However, #' if both signals are similar the error becomes zero. #' #' @param Lx.data.signal \code{\linkS4class{RLum.Data.Curve}} or #' \code{\link{data.frame}} (\bold{required}): TL data (x = #' temperature, y = counts) (TL signal) #' #' @param Lx.data.background \code{\linkS4class{RLum.Data.Curve}} or #' \code{\link{data.frame}} (optional): TL data (x = #' temperature, y = counts). If no data are provided no background subtraction #' is performed. #' #' @param Tx.data.signal \code{\linkS4class{RLum.Data.Curve}} or #' \code{\link{data.frame}} (\bold{required}): TL data (x = #' temperature, y = counts) (TL test signal) #' #' @param Tx.data.background \code{\linkS4class{RLum.Data.Curve}} or #' \code{\link{data.frame}} (optional): TL data (x = #' temperature, y = counts). If no data are provided no background subtraction #' is performed. #' #' @param signal.integral.min \code{\link{integer}} (\bold{required}): channel number #' for the lower signal integral bound (e.g. \code{signal.integral.min = 100}) #' #' @param signal.integral.max \code{\link{integer}} (\bold{required}): channel number #' for the upper signal integral bound (e.g. \code{signal.integral.max = 200}) #' #' @return Returns an S4 object of type \code{\linkS4class{RLum.Results}}. #' Slot \code{data} contains a \link{list} with the following structure:\cr\cr #' $ LxTx.table \cr .. $ LnLx \cr .. $ LnLx.BG \cr .. $ TnTx \cr .. $ TnTx.BG #' \cr .. $ Net_LnLx \cr .. $ Net_LnLx.Error\cr #' #' @note \bold{This function has still BETA status!} Please further note that a similar #' background for both curves results in a zero error and is therefore set to \code{NA}. #' #' @section Function version: 0.3.2 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France), Christoph Schmidt, University of Bayreuth (Germany) #' #' @seealso \code{\linkS4class{RLum.Results}}, \code{\link{analyse_SAR.TL}} #' #' @references - #' #' @keywords datagen #' #' @examples #' #' #' ##load package example data #' data(ExampleData.BINfileData, envir = environment()) #' #' ##convert Risoe.BINfileData into a curve object #' temp <- Risoe.BINfileData2RLum.Analysis(TL.SAR.Data, pos = 3) #' #' #' Lx.data.signal <- get_RLum(temp, record.id=1) #' Lx.data.background <- get_RLum(temp, record.id=2) #' Tx.data.signal <- get_RLum(temp, record.id=3) #' Tx.data.background <- get_RLum(temp, record.id=4) #' signal.integral.min <- 210 #' signal.integral.max <- 230 #' #' output <- calc_TLLxTxRatio(Lx.data.signal, #' Lx.data.background, #' Tx.data.signal, Tx.data.background, #' signal.integral.min, signal.integral.max) #' get_RLum(output) #' #' @export calc_TLLxTxRatio <- function( Lx.data.signal, Lx.data.background = NULL, Tx.data.signal, Tx.data.background = NULL, signal.integral.min, signal.integral.max ){ ##--------------------------------------------------------------------------## ##(1) - a few integrity check ##check for MISSING objects if(missing(Lx.data.signal) | missing(Tx.data.signal) | missing(signal.integral.min) | missing(signal.integral.max)){ temp.missing <- paste( c(if(missing(Lx.data.signal)){"Lx.data.signal"}, if(missing(Tx.data.signal)){"Tx.data.signal"}, if(missing(signal.integral.min)){"signal.integral.min"}, if(missing(signal.integral.max)){"signal.integral.max"}), collapse = ", ") stop(paste("[calc_TLLxTxRatio()] Arguments are missing: ",temp.missing, ".", sep=""), call. = FALSE) } ##check DATA TYPE differences if(is(Lx.data.signal)[1]!=is(Tx.data.signal)[1]){ stop("[calc_TLLxTxRatio()] Data type of Lx and Tx data differs!")} ##check for allowed data.types if(!is(Lx.data.signal, "data.frame") & !is(Lx.data.signal, "RLum.Data.Curve")){ stop("[calc_TLLxTxRatio()] Input data type for not allowed. Allowed are 'RLum.Data.Curve' and 'data.frame'") } ##--------------------------------------------------------------------------## ## Type conversion (assuming that all input variables are of the same type) if(is(Lx.data.signal, "RLum.Data.Curve")){ Lx.data.signal <- as(Lx.data.signal, "matrix") Tx.data.signal <- as(Tx.data.signal, "matrix") if(missing(Lx.data.background) == FALSE && is.null(Lx.data.background) == FALSE){ Lx.data.background <- as(Lx.data.background, "matrix") } if(missing(Tx.data.background) == FALSE && is.null(Tx.data.background) == FALSE){ Tx.data.background <- as(Tx.data.background, "matrix") } } ##(d) - check if Lx and Tx curves have the same channel length if(length(Lx.data.signal[,2])!=length(Tx.data.signal[,2])){ stop("[calc_TLLxTxRatio()] Channel number of Lx and Tx data differs!")} ##(e) - check if signal integral is valid if(signal.integral.min < 1 | signal.integral.max > length(Lx.data.signal[,2])){ stop("[calc_TLLxTxRatio()] Signal.integral is not valid!")} # Background Consideration -------------------------------------------------- ##Lx.data if(!is.null(Lx.data.background)){ LnLx.BG <- sum(Lx.data.background[signal.integral.min:signal.integral.max,2]) }else{ LnLx.BG <- NA } ##Tx.data if(!is.null(Tx.data.background)){ TnTx.BG <- sum(Tx.data.background[signal.integral.min:signal.integral.max,2]) }else{ TnTx.BG <- NA } # Calculate Lx/Tx values -------------------------------------------------- LnLx <- sum(Lx.data.signal[signal.integral.min:signal.integral.max,2]) TnTx <- sum(Tx.data.signal[signal.integral.min:signal.integral.max,2]) ##calculate variance of background if(is.na(LnLx.BG) == FALSE & is.na(TnTx.BG) == FALSE){ BG.Error <- sd(c(LnLx.BG, TnTx.BG)) if(BG.Error == 0) { warning( "[calc_TLLxTxRatio()] The background signals for Lx and Tx appear to be similar, no background error was calculated.", call. = FALSE ) BG.Error <- NA } } if(is.na(LnLx.BG) == FALSE){ net_LnLx <- LnLx - LnLx.BG net_LnLx.Error <- abs(net_LnLx * BG.Error/LnLx.BG) }else{ net_LnLx <- NA net_LnLx.Error <- NA } if(is.na(TnTx.BG) == FALSE){ net_TnTx <- TnTx - TnTx.BG net_TnTx.Error <- abs(net_TnTx * BG.Error/TnTx.BG) }else{ net_TnTx <- NA net_TnTx.Error <- NA } if(is.na(net_TnTx)){ LxTx <- LnLx/TnTx LxTx.Error <- NA }else{ LxTx <- net_LnLx/net_TnTx LxTx.Error <- LxTx*((net_LnLx.Error/net_LnLx) + (net_TnTx.Error/net_TnTx)) } ##COMBINE to a data.frame temp.results <- data.frame(LnLx, LnLx.BG, TnTx, TnTx.BG, net_LnLx, net_LnLx.Error, net_TnTx, net_TnTx.Error, LxTx, LxTx.Error) # Return values ----------------------------------------------------------- newRLumResults.calc_TLLxTxRatio <- set_RLum( class = "RLum.Results", data = list(LxTx.table = temp.results), info = list(call = sys.call()) ) return(newRLumResults.calc_TLLxTxRatio) } Luminescence/R/Luminescence-package.R0000644000176200001440000006237213125226556017234 0ustar liggesusers#' Comprehensive Luminescence Dating Data Analysis #' #' A collection of various R functions for the purpose of Luminescence dating #' data analysis. This includes, amongst others, data import, export, #' application of age models, curve deconvolution, sequence analysis and #' plotting of equivalent dose distributions. #' #' \tabular{ll}{ Package: \tab Luminescence\cr Type: \tab Package\cr Version: #' \tab 0.7.5 \cr Date: \tab 2017-06-30 \cr License: \tab GPL-3\cr } #' #' @name Luminescence-package #' @aliases Luminescence-package Luminescence #' @docType package #' @author \bold{Full list of authors and contributors} (alphabetic order) #' #' \tabular{ll}{ #' Christoph Burow \tab University of Cologne, Germany \cr #' Claire Christophe \tab IRAMAT-CRP2A, Universite Bordeaux Montaigne, France \cr #' Michael Dietze \tab GFZ Helmholtz Centre Potsdam, Germany \cr #' Julie Durcan \tab University of Oxford, United Kingdom \cr #' Manfred Fischer\tab University of Bayreuth, Germany \cr #' Margret C. Fuchs \tab Helmholtz-Zentrum Dresden-Rossendorf, Helmholtz-Institute Freiberg for Resource Technology, #' Freiberg, Germany \cr #' Johannes Friedrich \tab University of Bayreuth, Germany \cr #' Guillaume Guerin \tab IRAMAT-CRP2A, Universite Bordeaux Montaigne, France \cr #' Georgina King \tab Institute of Geological Sciences, University of Bern, Switzerland \cr #' Sebastian Kreutzer \tab IRAMAT-CRP2A, Universite Bordeaux Montaigne, France \cr #' Norbert Mercier \tab IRAMAT-CRP2A, Universite Bordeaux Montaigne, France \cr #' Anne Philippe \tab Universite de Nantes and ANJA INRIA, Rennes, France \cr #' Christoph Schmidt \tab University of Bayreuth, Germany \cr #' Rachel K. Smedley \tab Aberystwyth University, United Kingdom \cr #' Antoine Zink \tab C2RMF, Palais du Louvre, Paris, France #' } #' #' \bold{Supervisor of the initial version in 2012} #' #' Markus Fuchs, Justus-Liebig-University Giessen, Germany\cr #' #' \bold{Support contact} #' #' \email{developers@@r-luminescence.org}\cr #' #' We may further encourage the usage of our support forum. For this please #' visit our project website (link below). #' #' \bold{Bug reporting} #' #' \email{developers@@r-luminescence.org} or \cr #' \url{https://github.com/R-Lum/Luminescence/issues} \cr #' #' \bold{Project website} #' #' \url{http://www.r-luminescence.org}\cr #' #' \bold{Project source code repository}\cr #' \url{https://github.com/R-Lum/Luminescence}\cr #' #' \bold{Related package projects}\cr #' \url{https://cran.r-project.org/package=RLumShiny}\cr #' \url{http://shiny.r-luminescence.org}\cr #' \url{https://cran.r-project.org/package=RLumModel}\cr #' \url{http://model.r-luminescence.org}\cr #' #' \bold{Package maintainer} #' #' Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne, Pessac, #' France, \cr \email{sebastian.kreutzer@@u-bordeaux-montaigne.fr} #' #' \bold{Acknowledgement} #' #' Cooperation and personal exchange between the developers is gratefully #' funded by the DFG (SCHM 3051/3-1) in the framework of the program #' "Scientific Networks". Project title: "RLum.Network: Ein #' Wissenschaftsnetzwerk zur Analyse von Lumineszenzdaten mit R" (2014-2017) #' #' @references Dietze, M., Kreutzer, S., Fuchs, M.C., Burow, C., Fischer, M., #' Schmidt, C., 2013. A practical guide to the R package Luminescence. #' Ancient TL, 31, 11-18. #' #' Dietze, M., Kreutzer, S., Burow, C., Fuchs, M.C., Fischer, M., Schmidt, C., 2016. The abanico plot: #' visualising chronometric data with individual standard errors. Quaternary Geochronology 31, 1-7. #' http://dx.doi.org/10.1016/j.quageo.2015.09.003 #' #' Fuchs, M.C., Kreutzer, S., Burow, C., Dietze, M., Fischer, M., Schmidt, C., #' Fuchs, M., 2015. Data processing in luminescence dating analysis: An #' exemplary workflow using the R package 'Luminescence'. Quaternary #' International, 362,8-13. http://dx.doi.org/10.1016/j.quaint.2014.06.034 #' #' Kreutzer, S., Schmidt, C., Fuchs, M.C., Dietze, M., Fischer, M., Fuchs, M., #' 2012. Introducing an R package for luminescence dating analysis. Ancient TL, #' 30, 1-8. #' #' Smedley, R.K., 2015. A new R function for the Internal External Uncertainty (IEU) model. #' Ancient TL 33, 16-21. #' #' @keywords package #' @import utils methods data.table magrittr #' @importFrom raster nlayers raster contour plot plotRGB brick #' @importFrom graphics plot plot.default frame abline mtext text lines par layout lines arrows axTicks axis barplot box boxplot contour curve grconvertX grconvertY hist legend persp points polygon rug segments title grid #' @importFrom grDevices adjustcolor axisTicks colorRampPalette gray.colors rgb topo.colors xy.coords dev.off #' @importFrom stats approx as.formula complete.cases density dnorm glm lm median na.exclude na.omit nls nls.control pchisq pnorm quantile rnorm runif sd smooth smooth.spline spline t.test uniroot var weighted.mean setNames coef confint predict update residuals #' @importFrom parallel parLapply makeCluster stopCluster #' @importFrom httr GET accept_json status_code content #' @useDynLib Luminescence, .registration = TRUE NULL #' Base data set for cosmic dose rate calculation #' #' Collection of data from various sources needed for cosmic dose rate #' calculation #' #' #' @format #' #' \tabular{ll}{ #' #' \code{values.cosmic.Softcomp}: \tab data frame containing cosmic dose rates #' for shallow depths (< 167 g cm^-2) obtained using the "AGE" program by #' Rainer Gruen (cf. Gruen 2009). These data essentially reproduce the graph #' shown in Fig. 1 of Prescott & Hutton (1988). \cr #' #' \code{values.factor.Altitude}: \tab data frame containing altitude factors #' for adjusting geomagnetic field-change factors. Values were read from Fig. 1 #' in Prescott & Hutton (1994). \cr #' #' \code{values.par.FJH}: \tab data frame containing values for parameters F, J #' and H (read from Fig. 2 in Prescott & Hutton 1994) used in the expression } #' #' \deqn{Dc = D0*(F+J*exp((altitude/1000)/H))} #' @section Version: 0.1 #' @references #' Gruen, R., 2009. The "AGE" program for the calculation of luminescence age estimates. #' Ancient TL, 27, pp. 45-46. #' #' Prescott, J.R., Hutton, J.T., 1988. Cosmic ray and gamma ray dosimetry for #' TL and ESR. Nuclear Tracks and Radiation Measurements, 14, pp. 223-227. #' #' Prescott, J.R., Hutton, J.T., 1994. Cosmic ray contributions to dose rates #' for luminescence and ESR dating: large depths and long-term time variations. #' Radiation Measurements, 23, pp. 497-500. #' @source The following data were carefully read from figures in mentioned #' sources and used for fitting procedures. The derived expressions are used in #' the function \code{calc_CosmicDoseRate}. #' #' \bold{values.cosmic.Softcomp} #' #' \tabular{ll}{ #' #' Program: \tab "AGE"\cr Reference: \tab Gruen (2009) \cr Fit: \tab #' Polynomials in the form of #' #' } #' #' For depths between 40-167 g cm^-2: #' #' \deqn{y = 2*10^-6*x^2-0.0008*x+0.2535} #' #' (For depths <40 g cm^-2) #' #' \deqn{y = -6*10^-8*x^3+2*10^-5*x^2-0.0025*x+0.2969} #' #' \bold{values.factor.Altitude} #' #' \tabular{ll}{ #' #' Reference: \tab Prescott & Hutton (1994) \cr Page: \tab 499 \cr Figure: \tab #' 1 \cr Fit: \tab 2-degree polynomial in the form of #' #' } #' #' \deqn{y = -0.026*x^2 + 0.6628*x + 1.0435} #' #' \bold{values.par.FJH} #' #' \tabular{ll}{ #' #' Reference: \tab Prescott & Hutton (1994) \cr Page: \tab 500 \cr Figure: \tab #' 2 \cr Fits: \tab 3-degree polynomials and linear fits #' #' } #' #' F (non-linear part, \eqn{\lambda} < 36.5 deg.): #' #' \deqn{y = -7*10^-7*x^3-8*10^-5*x^2-0.0009*x+0.3988} #' #' F (linear part, \eqn{\lambda} > 36.5 deg.): #' #' \deqn{y = -0.0001*x + 0.2347} #' #' J (non-linear part, \eqn{\lambda} < 34 deg.): #' #' \deqn{y = 5*10^-6*x^3-5*10^-5*x^2+0.0026*x+0.5177} #' #' J (linear part, \eqn{\lambda} > 34 deg.): #' #' \deqn{y = 0.0005*x + 0.7388} #' #' H (non-linear part, \eqn{\lambda} < 36 deg.): #' #' \deqn{y = -3*10^-6*x^3-5*10^-5*x^2-0.0031*x+4.398} #' #' H (linear part, \eqn{\lambda} > 36 deg.): #' #' \deqn{y = 0.0002*x + 4.0914} #' @keywords datasets #' @examples #' #' ##load data #' data(BaseDataSet.CosmicDoseRate) #' @name BaseDataSet.CosmicDoseRate NULL #' Example data from a SAR OSL and SAR TL measurement for the package #' Luminescence #' #' Example data from a SAR OSL and TL measurement for package Luminescence #' directly extracted from a Risoe BIN-file and provided in an object of type #' \link{Risoe.BINfileData-class} #' #' #' @format #' #' \code{CWOSL.SAR.Data}: SAR OSL measurement data #' #' \code{TL.SAR.Data}: SAR TL measurement data #' #' Each class object contains two slots: (a) \code{METADATA} is a #' \link{data.frame} with all metadata stored in the BIN file of the #' measurements and (b) \code{DATA} contains a list of vectors of the measured #' data (usually count values). #' @section Version: 0.1 #' @references #' \bold{CWOSL.SAR.Data}: unpublished data \cr #' #' \bold{TL.SAR.Data}: unpublished data #' @source \bold{CWOSL.SAR.Data} #' #' \tabular{ll}{ #' #' Lab: \tab Luminescence Laboratory Bayreuth\cr Lab-Code: \tab BT607\cr #' Location: \tab Saxony/Germany\cr Material: \tab Middle grain quartz measured #' \cr \tab on aluminum cups on a Risoe TL/OSL DA-15 reader\cr Reference: \tab #' unpublished } #' #' \bold{TL.SAR.Data} #' #' \tabular{ll}{ #' #' Lab: \tab Luminescence Laboratory of Cologne\cr Lab-Code: \tab LP1_5\cr #' Location: \tab Spain\cr Material: \tab Flint \cr Setup: \tab Risoe TL/OSL #' DA-20 reader \cr \tab (Filter: Semrock Brightline, \cr \tab HC475/50, N2, #' unpolished steel discs) \cr Reference: \tab unpublished \cr Remarks: \tab #' dataset limited to one position\cr } #' #' @note Please note that this example data cannot be exported to a BIN-file using the function #' \code{writeR2BIN} as it was generated and implemented in the package long time ago. In the meantime #' the BIN-file format changed. #' #' @keywords datasets #' @examples #' #' ##show first 5 elements of the METADATA and DATA elements in the terminal #' data(ExampleData.BINfileData, envir = environment()) #' CWOSL.SAR.Data@@METADATA[1:5,] #' CWOSL.SAR.Data@@DATA[1:5] #' #' @name ExampleData.BINfileData NULL #' Example CW-OSL curve data for the package Luminescence #' #' \code{data.frame} containing CW-OSL curve data (time, counts) #' #' @name ExampleData.CW_OSL_Curve #' @docType data #' @format Data frame with 1000 observations on the following 2 variables: #' \describe{ \item{list("x")}{a numeric vector, time} \item{list("y")}{a #' numeric vector, counts} } #' @references Baartman, J.E.M., Veldkamp, A., Schoorl, J.M., Wallinga, J., #' Cammeraat, L.H., 2011. Unravelling Late Pleistocene and Holocene landscape #' dynamics: The Upper Guadalentin Basin, SE Spain. Geomorphology, 125, #' 172-185. #' #' Bos, A.J.J. & Wallinga, J., 2012. How to visualize quartz OSL signal #' components. Radiation Measurements, 47, 752-758. #' #' @source \bold{ExampleData.CW_OSL_Curve} #' #' \tabular{ll}{ Lab: \tab Luminescence Laboratory Bayreuth\cr Lab-Code: \tab #' BT607\cr Location: \tab Saxony/Germany\cr Material: \tab Middle grain quartz #' measured on aluminum cups on a Risoe TL/OSL DA-15 reader.\cr Reference: \tab #' unpublished data } #' #' \bold{CW_Curve.BosWallinga2012} #' #' \tabular{ll}{ Lab: \tab Netherlands Centre for Luminescence Dating (NCL)\cr #' Lab-Code: \tab NCL-2108077\cr Location: \tab Guadalentin Basin, Spain\cr #' Material: \tab Coarse grain quartz\cr Reference: \tab Bos & Wallinga (2012) #' and Baartman et al. (2011) } #' #' @keywords datasets #' @examples #' #' data(ExampleData.CW_OSL_Curve, envir = environment()) #' plot(ExampleData.CW_OSL_Curve) #' NULL #' Example portable OSL curve data for the package Luminescence #' #' A \code{list} of \code{\linkS4class{RLum.Analysis}} objects, each containing #' the same number of \code{\linkS4class{RLum.Data.Curve}} objects representing #' individual OSL, IRSL and dark count measurements of a sample. #' #' @name ExampleData.portableOSL #' @docType data #' #' @source \bold{ExampleData.portableOSL} #' #' \tabular{ll}{ Lab: \tab Cologne Luminescence Laboratory\cr Lab-Code: \tab #' - \cr Location: \tab Nievenheim/Germany\cr Material: \tab Fine grain quartz #' \cr Reference: \tab unpublished data } #' #' @keywords datasets #' @examples #' #' data(ExampleData.portableOSL, envir = environment()) #' plot_RLum(ExampleData.portableOSL) #' NULL #' Example data for fit_LMCurve() in the package Luminescence #' #' Lineraly modulated (LM) measurement data from a quartz sample from Norway #' including background measurement. Measurements carried out in the #' luminescence laboratory at the University of Bayreuth. #' #' #' @format Two objects (data.frames) with two columns (time and counts). #' @references #' Fuchs, M., Kreutzer, S., Fischer, M., Sauer, D., Soerensen, R., 2012. OSL and IRSL #' dating of raised beach sand deposits along the southeastern coast of Norway. #' Quaternary Geochronology, 10, 195-200. #' @source #' \tabular{ll}{ Lab: \tab Luminescence Laboratory Bayreuth\cr Lab-Code: \tab #' BT900\cr Location: \tab Norway\cr Material: \tab Beach deposit, coarse grain #' quartz measured on aluminum discs on a Risoe TL/OSL DA-15 reader\cr } #' @examples #' #' ##show LM data #' data(ExampleData.FittingLM, envir = environment()) #' plot(values.curve,log="x") #' #' @name ExampleData.FittingLM NULL #' Example Lx/Tx data from CW-OSL SAR measurement #' #' LxTx data from a SAR measurement for the package Luminescence. #' #' #' @format A \code{data.frame} with 4 columns (Dose, LxTx, LxTx.Error, TnTx). #' @references unpublished data #' @source #' \tabular{ll}{ Lab: \tab Luminescence Laboratory Bayreuth\cr Lab-Code: \tab #' BT607\cr Location: \tab Ostrau (Saxony-Anhalt/Germany)\cr Material: \tab #' Middle grain (38-63 \eqn{\mu}m) quartz measured on a Risoe TL/OSL DA-15 #' reader.\cr } #' @examples #' #' ##plot Lx/Tx data vs dose [s] #' data(ExampleData.LxTxData, envir = environment()) #' plot(LxTxData$Dose,LxTxData$LxTx) #' #' @name ExampleData.LxTxData NULL #' Example Lx and Tx curve data from an artificial OSL measurement #' #' Lx and Tx data of continous wave (CW-) OSL signal curves. #' #' #' @format Two \code{data.frames} containing time and count values. #' @references unpublished data #' @source #' Arbitrary OSL measurement. #' @examples #' #' ##load data #' data(ExampleData.LxTxOSLData, envir = environment()) #' #' ##plot data #' plot(Lx.data) #' plot(Tx.data) #' #' @name ExampleData.LxTxOSLData NULL #' Example data as \code{\linkS4class{RLum.Analysis}} objects #' #' Collection of different \code{\linkS4class{RLum.Analysis}} objects for #' protocol analysis. #' #' #' @format #' #' \code{IRSAR.RF.Data}: IRSAR.RF.Data on coarse grain feldspar #' #' Each object contains data needed for the given protocol analysis. #' @section Version: 0.1 #' @references #' \bold{IRSAR.RF.Data} #' #' Kreutzer, S., Lauer, T., Meszner, S., Krbetschek, M.R., Faust, D., Fuchs, #' M., 2014. Chronology of the Quaternary profile Zeuchfeld in Saxony-Anhalt / #' Germany - a preliminary luminescence dating study. Zeitschrift fuer #' Geomorphologie 58, 5-26. doi: 10.1127/0372-8854/2012/S-00112 #' @source \bold{IRSAR.RF.Data} #' #' These data were kindly provided by Tobias Lauer and Matthias Krbetschek. #' #' \tabular{ll}{ #' #' Lab: \tab Luminescence Laboratory TU Bergakademie Freiberg\cr Lab-Code: \tab #' ZEU/SA1\cr Location: \tab Zeuchfeld (Zeuchfeld Sandur; #' Saxony-Anhalt/Germany)\cr Material: \tab K-feldspar (130-200 \eqn{\mu}m)\cr #' Reference: \tab Kreutzer et al. (2014)\cr #' #' } #' @keywords datasets #' @examples #' #' ##load data #' data(ExampleData.RLum.Analysis, envir = environment()) #' #' ##plot data #' plot_RLum(IRSAR.RF.Data) #' #' @name ExampleData.RLum.Analysis NULL #' Example data as \code{\linkS4class{RLum.Data.Image}} objects #' #' Measurement of Princton Instruments camera imported with the function #' \code{\link{read_SPE2R}} to R to produce an #' \code{\linkS4class{RLum.Data.Image}} object. #' #' #' @format Object of class \code{\linkS4class{RLum.Data.Image}} #' @section Version: 0.1 #' @source \bold{ExampleData.RLum.Data.Image} #' #' These data were kindly provided by Regina DeWitt. #' #' \tabular{ll}{ #' #' Lab.: \tab Department of Physics, East-Carolina University, NC, USA\cr #' Lab-Code: \tab -\cr Location: \tab - \cr Material: \tab - \cr Reference: #' \tab - \cr #' #' } #' #' Image data is a measurement of fluorescent ceiling lights with a cooled #' Princeton Instruments (TM) camera fitted on Risoe DA-20 TL/OSL reader. #' @keywords datasets #' @examples #' #' ##load data #' data(ExampleData.RLum.Data.Image, envir = environment()) #' #' ##plot data #' plot_RLum(ExampleData.RLum.Data.Image) #' #' @name ExampleData.RLum.Data.Image NULL #' Example data for a SAR OSL measurement and a TL spectrum using a lexsyg #' reader #' #' Example data from a SAR OSL measurement and a TL spectrum for package #' Luminescence imported from a Freiberg Instruments XSYG file using the #' function \code{\link{read_XSYG2R}}. #' #' #' @format #' #' \code{OSL.SARMeasurement}: SAR OSL measurement data #' #' The data contain two elements: (a) \code{$Sequence.Header} is a #' \link{data.frame} with metadata from the measurement,(b) #' \code{Sequence.Object} contains an \code{\linkS4class{RLum.Analysis}} object #' for further analysis.\cr #' #' \code{TL.Spectrum}: TL spectrum data #' #' \code{\linkS4class{RLum.Data.Spectrum}} object for further analysis. The #' spectrum was cleaned from cosmic-rays using the function #' \code{apply_CosmicRayRemoval}. Note that no quantum efficiency calibration #' was performed. #' @section Version: 0.1 #' @seealso \code{\link{read_XSYG2R}}, \code{\linkS4class{RLum.Analysis}},\cr #' \code{\linkS4class{RLum.Data.Spectrum}}, \code{\link{plot_RLum}},\cr #' \code{\link{plot_RLum.Analysis}}, \code{\link{plot_RLum.Data.Spectrum}} #' @references Unpublished data measured to serve as example data for that #' package. Location origin of sample BT753 is given here: #' #' Fuchs, M., Kreutzer, S., Rousseau, D.D., Antoine, P., Hatte, C., Lagroix, #' F., Moine, O., Gauthier, C., Svoboda, J., Lisa, L., 2013. The loess sequence #' of Dolni Vestonice, Czech Republic: A new OSL-based chronology of the Last #' Climatic Cycle. Boreas, 42, 664--677. #' @source \bold{OSL.SARMeasurement} #' #' \tabular{ll}{ #' #' Lab: \tab Luminescence Laboratory Giessen\cr Lab-Code: \tab no code\cr #' Location: \tab not specified\cr Material: \tab Coarse grain quartz \cr \tab #' on steel cups on lexsyg research reader\cr Reference: \tab unpublished } #' #' \bold{TL.Spectrum} #' #' \tabular{ll}{ #' #' Lab: \tab Luminescence Laboratory Giessen\cr Lab-Code: \tab BT753\cr #' Location: \tab Dolni Vestonice/Czech Republic\cr Material: \tab Fine grain #' polymineral \cr \tab on steel cups on lexsyg rearch reader\cr Reference: #' \tab Fuchs et al., 2013 \cr Spectrum: \tab Integration time 19 s, channel #' time 20 s\cr Heating: \tab 1 K/s, up to 500 deg. C } #' @keywords datasets #' @examples #' #' ##show data #' data(ExampleData.XSYG, envir = environment()) #' #' ## ========================================= #' ##(1) OSL.SARMeasurement #' OSL.SARMeasurement #' #' ##show $Sequence.Object #' OSL.SARMeasurement$Sequence.Object #' #' ##grep OSL curves and plot the first curve #' OSLcurve <- get_RLum(OSL.SARMeasurement$Sequence.Object, #' recordType="OSL")[[1]] #' plot_RLum(OSLcurve) #' #' ## ========================================= #' ##(2) TL.Spectrum #' TL.Spectrum #' #' ##plot simple spectrum (2D) #' plot_RLum.Data.Spectrum(TL.Spectrum, #' plot.type="contour", #' xlim = c(310,750), #' ylim = c(0,300), #' bin.rows=10, #' bin.cols = 1) #' #' ##plot 3d spectrum (uncomment for usage) #' # plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="persp", #' # xlim = c(310,750), ylim = c(0,300), bin.rows=10, #' # bin.cols = 1) #' #' @name ExampleData.XSYG NULL #' Example De data sets for the package Luminescence #' #' Equivalent dose (De) values measured for a fine grain quartz sample from a #' loess section in Rottewitz (Saxony/Germany) and for a coarse grain quartz #' sample from a fluvial deposit in the rock shelter of Cueva Anton #' (Murcia/Spain). #' #' #' @format A \code{\link{list}} with two elements, each containing a two column #' \code{\link{data.frame}}: #' #' \describe{ \code{$BT998}: De and De error values for a fine grain quartz #' sample from a loess section in Rottewitz.\cr\cr \code{$CA1}: Single grain De #' and De error values for a coarse grain quartz sample from a fluvial deposit #' in the rock shelter of Cueva Anton } #' @references \bold{BT998} \cr\cr Unpublished data \cr\cr #' \bold{CA1} \cr\cr #' Burow, C., Kehl, M., Hilgers, A., Weniger, G.-C., Angelucci, D., Villaverde, #' V., Zapata, J. and Zilhao, J. (2015). Luminescence dating of fluvial #' deposits in the rock shelter of Cueva Anton, Spain. Geochronometria 52, 107-125. #' #' \bold{BT998} \cr #' \tabular{ll}{ Lab: \tab Luminescence Laboratory Bayreuth\cr #' Lab-Code: \tab BT998\cr Location: \tab Rottewitz (Saxony/Germany)\cr #' Material: \tab Fine grain quartz measured on aluminum discs on a Risoe #' TL/OSL DA-15 reader\cr Units: \tab Values are given in seconds \cr Dose #' Rate: \tab Dose rate of the beta-source at measurement ca. 0.0438 Gy/s +/- #' 0.0019 Gy/s\cr Measurement Date: \tab 2012-01-27 } #' \bold{CA1} \cr #' \tabular{ll}{ Lab: \tab Cologne Luminescence Laboratory (CLL)\cr Lab-Code: #' \tab C-L2941\cr Location: \tab Cueva Anton (Murcia/Spain)\cr Material: \tab #' Coarse grain quartz (200-250 microns) measured on single grain discs on a #' Risoe TL/OSL DA-20 reader\cr Units: \tab Values are given in Gray \cr #' Measurement Date: \tab 2012 } #' @keywords datasets #' @examples #' #' ##(1) plot values as histogram #' data(ExampleData.DeValues, envir = environment()) #' plot_Histogram(ExampleData.DeValues$BT998, xlab = "De [s]") #' #' ##(2) plot values as histogram (with second to gray conversion) #' data(ExampleData.DeValues, envir = environment()) #' #' De.values <- Second2Gray(ExampleData.DeValues$BT998, #' dose.rate = c(0.0438, 0.0019)) #' #' #' plot_Histogram(De.values, xlab = "De [Gy]") #' #' @name ExampleData.DeValues NULL #' Example data for feldspar fading measurements #' #' Example data set for fading measurements of the IR50, IR100, IR150 and #' IR225 feldspar signals of sample UNIL/NB123. It further contains regular equivalent dose #' measurement data of the same sample, which can be used to apply a #' fading correction to. #' #' #' @format A \code{\link{list}} with two elements, each containing a further #' \code{\link{list}} of \code{\link{data.frame}}s containing the data #' on the fading and equivalent dose measurements: #' #' \describe{ #' #' \code{$fading.data}: A named \code{\link{list}} of \code{\link{data.frame}}s, #' each having three named columns (\code{LxTx, LxTx.error, timeSinceIrradiation}).\cr #' \code{..$IR50}: Fading data of the IR50 signal.\cr #' \code{..$IR100}: Fading data of the IR100 signal.\cr #' \code{..$IR150}: Fading data of the IR150 signal.\cr #' \code{..$IR225}: Fading data of the IR225 signal.\cr #' \cr\cr #' #' \code{$equivalentDose.data}: A named of \code{\link{data.frame}}s, #' each having three named columns (\code{dose, LxTx, LxTx.error}).\cr #' \code{..$IR50}: Equivalent dose measurement data of the IR50 signal.\cr #' \code{..$IR100}: Equivalent dose measurement data of the IR100 signal.\cr #' \code{..$IR150}: Equivalent dose measurement data of the IR150 signal.\cr #' \code{..$IR225}: Equivalent dose measurement data of the IR225 signal.\cr #' \cr\cr #' #' } #' #' @source #' #' These data were kindly provided by Georgina King. Detailed information #' on the sample UNIL/NB123 can be found in the reference given below. The raw #' data can be found in the accompanying supplementary information. #' #' @references #' #' King, G.E., Herman, F., Lambert, R., Valla, P.G., Guralnik, B., 2016. #' Multi-OSL-thermochronometry of feldspar. Quaternary Geochronology 33, 76-87. doi:10.1016/j.quageo.2016.01.004 #' #' \bold{Details} \cr #' \tabular{ll}{ #' Lab: \tab University of Lausanne \cr #' Lab-Code: \tab UNIL/NB123 \cr #' Location: \tab Namche Barwa (eastern Himalaya)\cr #' Material: \tab Coarse grained (180-212 microns) potassium feldspar \cr #' Units: \tab Values are given in seconds \cr #' Lab Dose Rate: \tab Dose rate of the beta-source at measurement ca. 0.1335 +/- #' 0.004 Gy/s \cr #' Environmental Dose Rate: \tab 7.00 +/- 0.92 Gy/ka (includes internal dose rate) #' } #' #' #' @keywords datasets #' #' @examples #' #' ## Load example data #' data("ExampleData.Fading", envir = environment()) #' #' ## Get fading measurement data of the IR50 signal #' IR50_fading <- ExampleData.Fading$fading.data$IR50 #' head(IR50_fading) #' #' ## Determine g-value and rho' for the IR50 signal #' IR50_fading.res <- analyse_FadingMeasurement(IR50_fading) #' #' ## Show g-value and rho' results #' gval <- get_RLum(IR50_fading.res) #' rhop <- get_RLum(IR50_fading.res, "rho_prime") #' #' gval #' rhop #' #' ## Get LxTx values of the IR50 DE measurement #' IR50_De.LxTx <- ExampleData.Fading$equivalentDose.data$IR50 #' #' ## Calculate the De of the IR50 signal #' IR50_De <- plot_GrowthCurve(IR50_De.LxTx, #' mode = "interpolation", #' fit.method = "EXP") #' #' ## Extract the calculated De and its error #' IR50_De.res <- get_RLum(IR50_De) #' De <- c(IR50_De.res$De, IR50_De.res$De.Error) #' #' ## Apply fading correction (age conversion greatly simplified) #' IR50_Age <- De / 7.00 #' IR50_Age.corr <- calc_FadingCorr(IR50_Age, g_value = IR50_fading.res) #' #' #' @name ExampleData.Fading NULL Luminescence/R/calc_FadingCorr.R0000644000176200001440000003457113125226556016231 0ustar liggesusers#' Apply a fading correction according to Huntley & Lamothe (2001) for a given #' g-value and a given tc #' #' This function solves the equation used for correcting the fading affected age #' including the error for a given g-value according to Huntley & Lamothe (2001). #' #' As the g-value sligthly depends on the time between irradiation and the prompt measurement, #' this is tc, always a tc value needs to be provided. If the g-value was normalised to a distinct #' time or evaluated with a different tc value (e.g., external irradiation), also the tc value #' for the g-value needs to be provided (argument \code{tc.g_value} and then the g-value is recalcualted #' to tc of the measurement used for estimating the age applying the following equation: #' #' \deqn{\kappa_{tc} = \kappa_{tc.g} / (1 - \kappa_{tc.g} * log(tc/tc.g))} #' #' where #' #' \deqn{\kappa_{tc.g} = g / 100 / log(10)} #' #' with \eqn{log} the natural logarithm. #' #' #' The error of the fading-corrected age is determined using a Monte Carlo #' simulation approach. Solving of the equation is realised using #' \code{\link{uniroot}}. Large values for \code{n.MC} will significantly #' increase the computation time.\cr #' #' \bold{\code{n.MC = 'auto'}} #' #' The error estimation based on a stochastic process, i.e. for a small number of MC runs the calculated #' error varies considerably every time the function is called, even with the same input values. #' The argument option \code{n.MC = 'auto'} tries to find a stable value for the standard error, i.e. #' the standard deviation of values calculated during the MC runs (\code{age.corr.MC}), #' within a given precision (2 digits) by increasing the number of MC runs stepwise and #' calculating the corresponding error. #' #' If the determined error does not differ from the 9 values calculated previously #' within a precision of (here) 3 digits the calculation is stopped as it is assumed that the error #' is stable. Please note that (a) the duration depends on the input values as well as on #' the provided computation ressources and it may take a while, (b) the length (size) of the output #' vector \code{age.corr.MC}, where all the single values produced during the MC runs are stored, #' equals the number of MC runs (here termed observations). #' #' To avoid an endless loop the calculation is stopped if the number of observations exceeds 10^7. #' This limitation can be overwritten by setting the number of MC runs manually, #' e.g. \code{n.MC = 10000001}. Note: For this case the function is not checking whether the calculated #' error is stable.\cr #' #' #' \bold{\code{seed}} #' #' This option allows to recreate previously calculated results by setting the seed #' for the R random number generator (see \code{\link{set.seed}} for details). This option #' should not be mixed up with the option \bold{\code{n.MC = 'auto'}}. The results may #' appear similar, but they are not comparable!\cr #' #' \bold{FAQ}\cr #' Q: Which tc value is expected?\cr #' A: tc is the time in seconds between irradiation and the prompt measurement applied during your #' De measurement. However, this tc might differ from the tc used for estimating the g-value. In the #' case of an SAR measurement tc should be similar, however, if it differs, you have to provide this #' tc value (the one used for estimating the g-value) using the argument \code{tc.g_value}.\cr #' #' @param age.faded \code{\link{numeric}} \code{\link{vector}} (\bold{required}): uncorrected #' age with error in ka (see example) #' #' @param g_value \code{\link{vector}} (\bold{required}): g-value and error obtained #' from separate fading measurements (see example). Alternatively an \code{\linkS4class{RLum.Results}} object #' can be provided produced by the function \code{analyse_FadingMeasurement}, in this case tc is set #' automatically #' #' @param tc \code{\link{numeric}} (\bold{required}): time in seconds between #' irradiation and the prompt measurement (cf. Huntley & Lamothe 2001). Argument will be ignored #' if \code{g_value} was an \code{RLum.Results} object #' #' @param tc.g_value \code{\link{numeric}} (with default): the time in seconds between irradiation #' and the prompt measurement used for estimating the g-value. If the g-value was normalised #' to, e.g., 2 days, this time in seconds (i.e., 172800) should be given here. If nothing is provided #' the time is set to tc, which is usual case for g-values obtained using the SAR method and g-values #' that had been not normalised to 2 days. #' #' @param n.MC \code{\link{integer}} (with default): number of Monte Carlo #' simulation runs for error estimation. If \code{n.MC = 'auto'} is used the function #' tries to find a 'stable' error for the age. Note: This may take a while! #' #' @param seed \code{\link{integer}} (optional): sets the seed for the random number generator #' in R using \code{\link{set.seed}} #' #' @param interval \code{\link{numeric}} (with default): a vector containing the end-points (age interval) of the #' interval to be searched for the root in 'ka'. This argument is passed to the function \code{\link[stats]{uniroot}} #' used for solving the equation. #' #' @param txtProgressBar \link{logical} (with default): enables or disables #' \code{\link{txtProgressBar}} #' #' @param verbose \code{\link{logical}} (with default): enables or disables terminal output #' #' #' @return Returns an S4 object of type \code{\linkS4class{RLum.Results}}.\cr #' #' Slot: \bold{@data}\cr #' \tabular{lll}{ #' \bold{Object} \tab \bold{Type} \tab \bold{Comment}\cr #' \code{age.corr} \tab \code{data.frame} \tab Corrected age \cr #' \code{age.corr.MC} \tab \code{numeric} \tab MC simulation results with all possible ages from #' that simulation\cr #' } #' #' Slot: \bold{@info}\cr #' #' \tabular{lll}{ #' \bold{Object} \tab \bold{Type} \tab \bold{Comment}\cr #' \code{info} \tab \code{character} \tab the original function call #' #' } #' #' #' @note Special thanks to Sebastien Huot for his support and clarification via e-mail. #' #' #' @section Function version: 0.4.2 #' #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' #' @seealso \code{\linkS4class{RLum.Results}}, \code{\link{get_RLum}}, #' \code{\link{uniroot}} #' #' #' @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. #' #' #' @keywords datagen #' #' #' @examples #' #' ##run the examples given in the appendix of Huntley and Lamothe, 2001 #' #' ##(1) faded age: 100 a #' results <- calc_FadingCorr( #' age.faded = c(0.1,0), #' g_value = c(5.0, 1.0), #' tc = 2592000, #' tc.g_value = 172800, #' n.MC = 100) #' #' ##(2) faded age: 1 ka #' results <- calc_FadingCorr( #' age.faded = c(1,0), #' g_value = c(5.0, 1.0), #' tc = 2592000, #' tc.g_value = 172800, #' n.MC = 100) #' #' ##(3) faded age: 10.0 ka #' results <- calc_FadingCorr( #' age.faded = c(10,0), #' g_value = c(5.0, 1.0), #' tc = 2592000, #' tc.g_value = 172800, #' n.MC = 100) #' #' ##access the last output #' get_RLum(results) #' #' @export calc_FadingCorr <- function( age.faded, g_value, tc = NULL, tc.g_value = tc, n.MC = 10000, seed = NULL, interval = c(0.01,500), txtProgressBar = TRUE, verbose = TRUE ){ ##TODO set link after the function analyse_FadingMeasurement was released ## ... this option should be tested as well # Integrity checks --------------------------------------------------------------------------- stopifnot(!missing(age.faded), !missing(g_value)) ##check input if(class(g_value)[1] == "RLum.Results"){ if(g_value@originator == "analyse_FadingMeasurement"){ tc <- get_RLum(g_value)[["TC"]] g_value <- as.numeric(get_RLum(g_value)[,c("FIT", "SD")]) }else{ try(stop("[calc_FadingCorr()] Unknown originator for the provided RLum.Results object via 'g_value'!", call. = FALSE)) return(NULL) } } ##check if tc is still NULL if(is.null(tc)){ try(stop("[calc_FadingCorr()] 'tc' needs to be set!", call. = FALSE)) return(NULL) } ##============================================================================## ##DEFINE FUNCTION ##============================================================================## f <- function(x, af,kappa,tc){1-kappa*(log(x/tc)-1) - (af/x)} ##============================================================================## ##CALCULATION ##============================================================================## ##recalculate the g-value to the given tc ... should be similar ##of tc = tc.g_value ##re-calulation thanks to the help by Sebastien Huot, e-mail: 2016-07-19 ##Please note that we take the vector for the g_value here k0 <- g_value / 100 / log(10) k1 <- k0 / (1 - k0 * log(tc[1]/tc.g_value[1])) g_value <- 100 * k1 * log(10) ##calculate kappa (equation [5] in Huntley and Lamothe, 2001) kappa <- g_value / log(10) / 100 ##transform tc in ka years ##duration of the year over a long term taken from http://wikipedia.org tc <- tc[1] / 60 / 60 / 24 / 365.2425 / 1000 tc.g_value <- tc.g_value[1] / 60 / 60 / 24 / 365.2425 / 1000 ##calculate mean value temp <- uniroot( f, interval = interval, tol = 0.001, tc = tc, af = age.faded[1], kappa = kappa[1], check.conv = FALSE ) ##--------------------------------------------------------------------------## ##Monte Carlo simulation for error estimation tempMC.sd.recent <- NA tempMC.sd.count <- 1:10 counter <- 1 ##show some progression bar of the process if (n.MC == 'auto') { n.MC.i <- 10000 cat("\n[calc_FadingCorr()] ... trying to find stable error value ...") if (txtProgressBar) { cat("\n -------------------------------------------------------------\n") cat(paste0(" ",paste0("(",0:9,")", collapse = " "), "\n")) } }else{ n.MC.i <- n.MC } # Start loop --------------------------------------------------------------------------------- ##set object and preallocate memory tempMC <- vector("numeric", length = 1e+07) tempMC[] <- NA i <- 1 j <- n.MC.i while(length(unique(tempMC.sd.count))>1 | j > 1e+07){ ##set previous if(!is.na(tempMC.sd.recent)){ tempMC.sd.count[counter] <- tempMC.sd.recent } ##set seed if (!is.null(seed)) set.seed(seed) ##pre-allocate memory g_valueMC <- vector("numeric", length = n.MC.i) age.fadeMC <- vector("numeric", length = n.MC.i) kappaMC <- vector("numeric", length = n.MC.i) ##set-values g_valueMC <- rnorm(n.MC.i,mean = g_value[1],sd = g_value[2]) age.fadedMC <- rnorm(n.MC.i,mean = age.faded[1],sd = age.faded[2]) kappaMC <- g_valueMC / log(10) / 100 ##calculate for all values tempMC[i:j] <- suppressWarnings(vapply(X = 1:length(age.fadedMC), FUN = function(x) { temp <- try(uniroot( f, interval = interval, tol = 0.001, tc = tc, af = age.fadedMC[[x]], kappa = kappaMC[[x]], check.conv = TRUE, maxiter = 1000, extendInt = "yes" ), silent = TRUE) ##otherwise the automatic error value finding ##will never work if(!is(temp,"try-error") && temp$root<1e8) { return(temp$root) } else{ return(NA) } }, FUN.VALUE = 1)) i <- j + 1 j <- j + n.MC.i ##stop here if a fixed value is set if(n.MC != 'auto'){ break } ##set recent tempMC.sd.recent <- round(sd(tempMC, na.rm = TRUE), digits = 3) if (counter %% 10 == 0) { counter <- 1 }else{ counter <- counter + 1 } ##show progress in terminal if (txtProgressBar) { text <- rep("CHECK",10) if (counter %% 2 == 0) { text[1:length(unique(tempMC.sd.count))] <- "-----" }else{ text[1:length(unique(tempMC.sd.count))] <- " CAL " } cat(paste("\r ",paste(rev(text), collapse = " "))) } } ##--------------------------------------------------------------------------## ##remove all NA values from tempMC tempMC <- tempMC[!is.na(tempMC)] ##obtain corrected age age.corr <- data.frame( AGE = round(temp$root, digits = 4), AGE.ERROR = round(sd(tempMC), digits = 4), AGE_FADED = age.faded[1], AGE_FADED.ERROR = age.faded[2], G_VALUE = g_value[1], G_VALUE.ERROR = g_value[2], KAPPA = kappa[1], KAPPA.ERROR = kappa[2], TC = tc, TC.G_VALUE = tc.g_value, n.MC = n.MC, OBSERVATIONS = length(tempMC), SEED = ifelse(is.null(seed), NA, seed) ) ##============================================================================## ##OUTPUT VISUAL ##============================================================================## if(verbose) { cat("\n\n[calc_FadingCorr()]\n") cat("\n >> Fading correction according to Huntley & Lamothe (2001)") if (tc != tc.g_value) { cat("\n >> g-value re-calculated for the given tc") } cat(paste( "\n\n .. used g-value:\t", round(g_value[1], digits = 3), " \u00b1 ", round(g_value[2], digits = 3), " %/decade", sep = "" )) cat(paste( "\n .. used tc:\t\t", format(tc, digits = 4, scientific = TRUE), " ka", sep = "" )) cat(paste0( "\n .. used kappa:\t\t", round(kappa[1], digits = 4), " \u00b1 ", round(kappa[2], digits = 4) )) cat("\n ----------------------------------------------") cat(paste0("\n seed: \t\t\t", ifelse(is.null(seed), NA, seed))) cat(paste0("\n n.MC: \t\t\t", n.MC)) cat(paste0( "\n observations: \t\t", format(length(tempMC), digits = 2, scientific = TRUE), sep = "" )) cat("\n ----------------------------------------------") cat(paste0( "\n Age (faded):\t\t", round(age.faded[1], digits = 4), " ka \u00b1 ", round(age.faded[2], digits = 4), " ka" )) cat(paste0( "\n Age (corr.):\t\t", round(age.corr[1], digits = 4), " ka \u00b1 ", round(age.corr[2], digits = 4), " ka" )) cat("\n ---------------------------------------------- \n") } ##============================================================================## ##OUTPUT RLUM ##============================================================================## return(set_RLum( class = "RLum.Results", data = list(age.corr = age.corr, age.corr.MC = tempMC), info = list(call = sys.call()) )) } Luminescence/R/calc_MaxDose.R0000644000176200001440000001343513125226556015547 0ustar liggesusers#' Apply the maximum age model to a given De distribution #' #' Function to fit the maximum age model to De data. This is a wrapper function #' that calls calc_MinDose() and applies a similiar approach as described in #' Olley et al. (2006). #' #' \bold{Data transformation} \cr\cr #' To estimate the maximum dose population #' and its standard error, the three parameter minimum age model of Galbraith #' et al. (1999) is adapted. The measured De values are transformed as follows: #' \cr\cr #' 1. convert De values to natural logs \cr #' 2. multiply the logged data to creat a mirror image of the De distribution \cr #' 3. shift De values along x-axis by the smallest x-value found to obtain only positive values \cr #' 4. combine in quadrature the measurement error associated with each De value #' with a relative error specified by sigmab \cr #' 5. apply the MAM to these data \cr\cr #' #' When all calculations are done the results are then converted as #' follows\cr\cr #' 1. subtract the x-offset \cr #' 2. multiply the natural logs by -1 \cr #' 3. take the exponent to obtain the maximum dose estimate in Gy \cr\cr #' #' \bold{Further documentation} \cr\cr #' Please see \code{\link{calc_MinDose}}. #' #' @param data \code{\linkS4class{RLum.Results}} or \link{data.frame} #' (\bold{required}): for \code{data.frame}: two columns with De \code{(data[ #' ,1])} and De error \code{(data[ ,2])}. #' #' @param sigmab \code{\link{numeric}} (\bold{required}): 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). #' \bold{NOTE}: For the logged model (\code{log = TRUE}) this value must be #' a fraction, e.g. 0.2 (= 20 \%). If the un-logged model is used (\code{log = FALSE}), #' sigmab must be provided in the same absolute units of the De values (seconds or Gray). #' See details (\code{\link{calc_MinDose}}. #' #' @param log \code{\link{logical}} (with default): fit the (un-)logged three #' parameter minimum dose model to De data #' #' @param par \code{\link{numeric}} (with default): apply the 3- or #' 4-parametric minimum age model (\code{par=3} or \code{par=4}). #' #' @param bootstrap \code{\link{logical}} (with default): apply the recycled #' bootstrap approach of Cunningham & Wallinga (2012). #' #' @param init.values \code{\link{numeric}} (with default): starting values for #' gamma, sigma, p0 and mu. Custom values need to be provided in a vector of #' length three in the form of \code{c(gamma, sigma, p0)}. #' #' @param plot \code{\link{logical}} (with default): plot output #' (\code{TRUE}/\code{FALSE}) #' #' @param \dots further arguments for bootstrapping (\code{bs.M, bs.N, bs.h, #' sigmab.sd}). See details for their usage. #' #' @return Please see \code{\link{calc_MinDose}}. #' #' @section Function version: 0.3.1 #' #' @author Christoph Burow, University of Cologne (Germany) \cr Based on a #' rewritten S script of Rex Galbraith, 2010 \cr #' #' @seealso \code{\link{calc_CentralDose}}, \code{\link{calc_CommonDose}}, #' \code{\link{calc_FiniteMixture}}, \code{\link{calc_FuchsLang2001}}, #' \code{\link{calc_MinDose}} #' #' @references Arnold, L.J., Roberts, R.G., Galbraith, R.F. & DeLong, S.B., #' 2009. A revised burial dose estimation procedure for optical dating of young #' and modern-age sediments. Quaternary Geochronology 4, 306-325. \cr\cr #' #' Galbraith, R.F. & Laslett, G.M., 1993. Statistical models for mixed fission #' track ages. Nuclear Tracks Radiation Measurements 4, 459-470. \cr\cr #' #' 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. \cr\cr #' #' Galbraith, R.F., 2005. Statistics for #' Fission Track Analysis, Chapman & Hall/CRC, Boca Raton. \cr\cr #' #' Galbraith, R.F. & Roberts, R.G., 2012. Statistical aspects of equivalent dose and error #' calculation and display in OSL dating: An overview and some recommendations. #' Quaternary Geochronology 11, 1-27. \cr\cr #' #' Olley, J.M., Roberts, R.G., Yoshida, H., Bowler, J.M., 2006. Single-grain optical dating of grave-infill #' associated with human burials at Lake Mungo, Australia. Quaternary Science #' Reviews 25, 2469-2474.\cr\cr #' #' \bold{Further reading} \cr\cr #' #' 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. \cr\cr #' #' 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. \cr\cr #' #' Cunningham, A.C. & Wallinga, J., 2012. Realizing the potential of fluvial archives using robust OSL chronologies. #' Quaternary Geochronology 12, 98-106. \cr\cr #' #' 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. #' \cr\cr Rodnight, H., 2008. How many equivalent dose values are needed to #' obtain a reproducible distribution?. Ancient TL 26, 3-10. \cr\cr #' #' @examples #' #' ## load example data #' data(ExampleData.DeValues, envir = environment()) #' #' # apply the maximum dose model #' calc_MaxDose(ExampleData.DeValues$CA1, sigmab = 0.2, par = 3) #' #' @export calc_MaxDose<- function( data, sigmab, log=TRUE, par=3, bootstrap=FALSE, init.values, plot=TRUE, ... ){ res<- calc_MinDose(data, sigmab, log, par, bootstrap, init.values, plot=FALSE, invert=TRUE, ...) res@originator<- "calc_MaxDose" if (plot) try(plot_RLum.Results(res, ...)) invisible(res) } Luminescence/R/Risoe.BINfileData2RLum.Data.Curve.R0000644000176200001440000000766113125226556021170 0ustar liggesusers#' Convert an element from a Risoe.BINfileData object to an RLum.Data.Curve #' object #' #' The function converts one specified single record from a Risoe.BINfileData #' object to an RLum.Data.Curve object. #' #' The function extracts all \code{METADATA} from the \code{Risoe.BINfileData} #' object and stores them in the \code{RLum.Data.Curve} object. This function #' can be used stand-alone, but is the base function for \code{\link{Risoe.BINfileData2RLum.Analysis}}. #' #' @param object \code{\linkS4class{Risoe.BINfileData}} (\bold{required}): #' \code{Risoe.BINfileData} object #' #' @param id \code{\link{integer}} (\bold{required}): record id in the #' \code{Risoe.BINfileData} object of the curve that is to be stored in the #' \code{RLum.Data.Curve} object. If no value for id is provided, the record #' has to be specified by \code{pos}, \code{set} and \code{run}. #' #' @param pos \code{\link{integer}} (optional): record position number in the #' \code{Risoe.BINfileData} object of the curve that is to be stored in the #' \code{RLum.Data.Curve} object. If a value for \code{id} is provided, this #' argument is ignored. #' #' @param run \code{\link{integer}} (optional): record run number in the #' \code{Risoe.BINfileData} object of the curve that is to be stored in the #' \code{RLum.Data.Curve} object. If a value for \code{id} is provided, this #' argument is ignored. #' #' @param set \code{\link{integer}} (optional): record set number in the #' \code{Risoe.BINfileData} object of the curve that is to be stored in the #' \code{RLum.Data.Curve} object. If a value for \code{id} is provided, this #' argument is ignored. #' #' @return Returns an \code{\linkS4class{RLum.Data.Curve}} object. #' #' @note Due to changes in the BIN-file (version 3 to version 4) format the recalculation of TL-curves might be not #' overall correct for cases where the TL measurement is combined with a preheat. #' #' @section Function version: 0.5.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France), #' Christoph Burow, Universtiy of Cologne (Germany) #' #' @seealso \code{\link{Risoe.BINfileData2RLum.Analysis}}, #' \code{\link{set_RLum}}, \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{Risoe.BINfileData}}, #' \code{\link{plot_RLum}} #' #' @references # #' #' @keywords manip #' #' @examples #' #' ##get package example data #' data(ExampleData.BINfileData, envir = environment()) #' #' ##convert one record #' Risoe.BINfileData2RLum.Data.Curve(CWOSL.SAR.Data, id = 1) #' #' @noRd .Risoe.BINfileData2RLum.Data.Curve <- function( object, id, pos, run, set ){ ##disaggregate object ... this makes it much faster below ##we could also access via index, not number, but this is far to risky, as ##every update in the BIN-file version will break the code here METADATA <- as.list(object@METADATA) DATA <- object@DATA # grep id of record ------------------------------------------------------- ##if id is set, no input for pos and rund is nescessary if (missing(id)) { id <- METADATA[METADATA[["POSITION"]] == pos & METADATA[["SET"]] == set & METADATA[["RUN"]] == run, "ID"] } ##grep info elements info <- lapply(1:length(names(METADATA)), function(x){METADATA[[x]][id]}) names(info) <- names(METADATA) # Build object ------------------------------------------------------------ set_RLum( class = "RLum.Data.Curve", recordType = METADATA[["LTYPE"]][id], data = .create_RLumDataCurve_matrix( DATA = DATA[[id]], NPOINTS = METADATA[["NPOINTS"]][id], VERSION = METADATA[["VERSION"]][id], LTYPE = METADATA[["LTYPE"]][id], LOW = METADATA[["LOW"]][id], HIGH = METADATA[["HIGH"]][id], AN_TEMP = METADATA[["AN_TEMP"]][id], TOLDELAY =METADATA[["TOLDELAY"]][id], TOLON = METADATA[["TOLON"]][id], TOLOFF = METADATA[["TOLOFF"]][id] ), info = info ) } Luminescence/R/calc_gSGC.R0000644000176200001440000003072013125226556014766 0ustar liggesusers#' Calculate De value based on the gSGC by Li et al., 2015 #' #' 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 #' #' The error of the De value is determined using a Monte Carlo simulation approach. #' Solving of the equation is realised using \code{\link{uniroot}}. #' Large values for \code{n.MC} will significantly increase the computation time. #' #' #' @param data \code{\link{data.frame}} (\bold{required}): input data of providing the following #' columns: 'LnTn', 'LnTn.error', Lr1Tr1', 'Lr1Tr1.error', 'Dr1' #' Note: column names are not required. The function expect the input data in the given order #' #' @param gSGC.type \code{\link{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: \code{"0-450"} and \code{"0-250"} #' #' @param gSGC.parameters \code{\link{list}} (optional): option to provide own function #' parameters used for #' fitting as named list. #' Nomenclature follows Li et al., 2015, i.e. #' \code{list(A,A.error,D0,D0.error,c,c.error,Y0,Y0.error,range)}, range requires a vector for #' the range the function is considered as valid, e.g. \code{range = c(0,250)}\cr #' Using this option overwrites the default parameter list of the gSGC, meaning the argument #' \code{gSGC.type} will be without effect #' #' @param n.MC \code{\link{integer}} (with default): number of Monte Carlo simulation runs for #' error estimation, s. details. #' #' @param verbose \code{\link{logical}}: enable or disable terminal output #' #' @param plot \code{\link{logical}}: enable or disable graphical feedback as plot #' #' @param ... parameters will be passed to the plot output #' #' @return Returns an S4 object of type \code{\linkS4class{RLum.Results}}.\cr #' #' \bold{@data}\cr #' $ De.value (data.frame) \cr #' .. $ De \cr #' .. $ De.error \cr #' .. $ Eta \cr #' $ De.MC (list) contains the matricies from the error estimation.\cr #' $ uniroot (list) contains the uniroot outputs of the De estimations\cr #' #' \bold{@info}\cr #' $ call (call) the original function call #' #' #' @section Function version: 0.1.1 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montagine (France)\cr #' #' @seealso \code{\linkS4class{RLum.Results}}, \code{\link{get_RLum}}, \code{\link{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") #' #' @export calc_gSGC<- function( data, gSGC.type = "0-250", gSGC.parameters, n.MC = 100, verbose = TRUE, plot = TRUE, ... ){ ##============================================================================## ##CHECK INPUT DATA ##============================================================================## if(!is(data, "data.frame")){stop("'data' needs to be of type data.frame.")} if(!is(gSGC.type, "character")){stop("'gSGC.type' needs to be of type character.")} ##check length of input data if(ncol(data) != 5){stop("Structure of 'data' does not fit the expectations.")} ##rename columns for consistency reasons colnames(data) <- c('LnTn', 'LnTn.error', 'Lr1Tr1', 'Lr1Tr1.error', 'Dr1') ##============================================================================## ##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) }else{ stop("Unknown input for 'gSGC.type'") } } ##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{ 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") } } ##============================================================================## ##OUTPUT VISUALISATION ##============================================================================## if (verbose) { cat("\n[calc_gSGC()]") cat("\n\t Corresponding De based on the gSGC\n") cat(paste0("\n\t"," Ln/Tn:\t\t ",LnTn," \u00B1 ", LnTn.error,"\n")) cat(paste0("\t"," Lr1/Tr1:\t ",Lr1Tr1," \u00B1 ", Lr1Tr1.error,"\n")) cat(paste0("\t"," Dr1:\t\t ",Dr1,"\n")) cat(paste0("\t"," f(D):\t\t ",A," * (1 - exp(-D /",D0,")) + c * D + ",Y0,"\n")) cat(paste0("\t"," n.MC:\t\t ",n.MC,"\n")) cat(paste0("\t ------------------------------ \n")) cat(paste0("\t De:\t\t",round(De,digits = 2)," \u00B1 ",round(De.error,digits = 2),"\n")) cat(paste0("\t ------------------------------ \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){ if(i == 1){ output.De.MC[[i]] <- temp.MC.matrix }else{ output.De.MC[[i]] <- NA } warning("Only the first MC matrix is returned to prevent memory overload!") }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/calc_CosmicDoseRate.R0000644000176200001440000005176413125226556017062 0ustar liggesusers#' Calculate the cosmic dose rate #' #' This function calculates the cosmic dose rate taking into account the soft- #' and hard-component of the cosmic ray flux and allows corrections for #' geomagnetic latitude, altitude above sea-level and geomagnetic field #' changes. #' #' This function calculates the total cosmic dose rate considering both the #' soft- and hard-component of the cosmic ray flux.\cr #' #' \bold{Internal calculation steps} #' #' (1) Calculate total depth of all absorber in hg/cm^2 (1 hg/cm^2 = 100 #' g/cm^2) #' #' \deqn{absorber = depth_1*density_1 + depth_2*density_2 + ... + depth_n* #' density_n} #' #' (2) If \code{half.depth = TRUE} #' #' \deqn{absorber = absorber/2} #' #' (3) Calculate cosmic dose rate at sea-level and 55 deg. latitude #' #' a) If absorber is > 167 g/cm^2 (only hard-component; Allkofer et al. 1975): #' apply equation given by Prescott & Hutton (1994) (c.f. Barbouti & Rastin #' 1983) #' #' \deqn{D0 = C/(((absorber+d)^\alpha+a)*(absober+H))*exp(-B*absorber)} #' #' b) If absorber is < 167 g/cm^2 (soft- and hard-component): derive D0 from #' Fig. 1 in Prescott & Hutton (1988). #' #' (4) Calculate geomagnetic latitude (Prescott & Stephan 1982, Prescott & #' Hutton 1994) #' #' \deqn{\lambda = arcsin(0.203*cos(latitude)*cos(longitude-291)+0.979* #' sin(latitude))} #' #' (5) Apply correction for geomagnetic latitude and altitude above sea-level. #' Values for F, J and H were read from Fig. 3 shown in Prescott & Stephan #' (1982) and fitted with 3-degree polynomials for lambda < 35 degree and a #' linear fit for lambda > 35 degree. #' #' \deqn{Dc = D0*(F+J*exp((altitude/1000)/H))} #' #' (6) Optional: Apply correction for geomagnetic field changes in the last #' 0-80 ka (Prescott & Hutton 1994). Correction and altitude factors are given #' in Table 1 and Fig. 1 in Prescott & Hutton (1994). Values for altitude #' factor were fitted with a 2-degree polynomial. The altitude factor is #' operated on the decimal part of the correction factor. #' #' \deqn{Dc' = Dc*correctionFactor} #' #' \bold{Usage of \code{depth} and \code{density}} #' #' (1) If only one value for depth and density is provided, the cosmic dose #' rate is calculated for exactly one sample and one absorber as overburden #' (i.e. \code{depth*density}). #' #' (2) In some cases it might be useful to calculate the cosmic dose rate for a #' sample that is overlain by more than one absorber, e.g. in a profile with #' soil layers of different thickness and a distinct difference in density. #' This can be calculated by providing a matching number of values for #' \code{depth} and \code{density} (e.g. \code{depth = c(1, 2), density = #' c(1.7, 2.4)}) #' #' (3) Another possibility is to calculate the cosmic dose rate for more than #' one sample of the same profile. This is done by providing more than one #' values for \code{depth} and only one for \code{density}. For example, #' \code{depth = c(1, 2, 3), density = 1.7} will calculate the cosmic dose rate #' for three samples in 1, 2 and 3 m depth in a sediment of density 1.7 g/cm^3. #' #' @param depth \code{\link{numeric}} (\bold{required}): depth of overburden #' (m). For more than one absorber use \cr \code{c(depth_1, depth_2, ..., #' depth_n)} #' #' @param density \code{\link{numeric}} (\bold{required}): average overburden #' density (g/cm^3). For more than one absorber use \cr \code{c(density_1, #' density_2, ..., density_n)} #' #' @param latitude \code{\link{numeric}} (\bold{required}): latitude (decimal #' degree), N positive #' #' @param longitude \code{\link{numeric}} (\bold{required}): longitude (decimal #' degree), E positive #' #' @param altitude \code{\link{numeric}} (\bold{required}): altitude (m above #' sea-level) #' #' @param corr.fieldChanges \code{\link{logical}} (with default): correct for #' geomagnetic field changes after Prescott & Hutton (1994). Apply only when #' justified by the data. #' #' @param est.age \code{\link{numeric}} (with default): estimated age range #' (ka) for geomagnetic field change correction (0-80 ka allowed) #' #' @param half.depth \code{\link{logical}} (with default): How to overcome with #' varying overburden thickness. If \code{TRUE} only half the depth is used for #' calculation. Apply only when justified, i.e. when a constant sedimentation #' rate can safely be assumed. #' #' @param error \code{\link{numeric}} (with default): general error #' (percentage) to be implemented on corrected cosmic dose rate estimate #' #' @param ... further arguments (\code{verbose} to disable/enable console output). #' #' @return Returns a terminal output. In addition an #' \code{\linkS4class{RLum.Results}} object is returned containing the #' following element: #' #' \item{summary}{\link{data.frame} summary of all relevant calculation #' results.} \item{args}{\link{list} used arguments} \item{call}{\link{call} #' the function call} #' #' The output should be accessed using the function #' \code{\link{get_RLum}} #' @note Despite its universal use the equation to calculate the cosmic dose #' rate provided by Prescott & Hutton (1994) is falsely stated to be valid from #' the surface to 10^4 hg/cm^2 of standard rock. The original expression by #' Barbouti & Rastin (1983) only considers the muon flux (i.e. hard-component) #' and is by their own definition only valid for depths between 10-10^4 #' hg/cm^2. #' #' Thus, for near-surface samples (i.e. for depths < 167 g/cm^2) the equation #' of Prescott & Hutton (1994) underestimates the total cosmic dose rate, as it #' neglects the influence of the soft-component of the cosmic ray flux. For #' samples at zero depth and at sea-level the underestimation can be as large #' as ~0.1 Gy/ka. In a previous article, Prescott & Hutton (1988) give another #' approximation of Barbouti & Rastins equation in the form of #' #' \deqn{D = 0.21*exp(-0.070*absorber+0.0005*absorber^2)} #' #' which is valid for depths between 150-5000 g/cm^2. For shallower depths (< #' 150 g/cm^2) they provided a graph (Fig. 1) from which the dose rate can be #' read. #' #' As a result, this function employs the equation of Prescott & Hutton (1994) #' only for depths > 167 g/cm^2, i.e. only for the hard-component of the cosmic #' ray flux. Cosmic dose rate values for depths < 167 g/cm^2 were obtained from #' the "AGE" programm (Gruen 2009) and fitted with a 6-degree polynomial curve #' (and hence reproduces the graph shown in Prescott & Hutton 1988). However, #' these values assume an average overburden density of 2 g/cm^3. #' #' It is currently not possible to obtain more precise cosmic dose rate values #' for near-surface samples as there is no equation known to the author of this #' function at the time of writing. #' @section Function version: 0.5.2 #' @author Christoph Burow, University of Cologne (Germany) #' @seealso \code{\link{BaseDataSet.CosmicDoseRate}} #' @references Allkofer, O.C., Carstensen, K., Dau, W.D., Jokisch, H., 1975. #' Letter to the editor. The absolute cosmic ray flux at sea level. Journal of #' Physics G: Nuclear and Particle Physics 1, L51-L52. \cr\cr Barbouti, A.I., #' Rastin, B.C., 1983. A study of the absolute intensity of muons at sea level #' and under various thicknesses of absorber. Journal of Physics G: Nuclear and #' Particle Physics 9, 1577-1595. \cr\cr Crookes, J.N., Rastin, B.C., 1972. An #' investigation of the absolute intensity of muons at sea-level. Nuclear #' Physics B 39, 493-508. \cr\cr Gruen, R., 2009. The "AGE" program for the #' calculation of luminescence age estimates. Ancient TL 27, 45-46. \cr\cr #' Prescott, J.R., Hutton, J.T., 1988. Cosmic ray and gamma ray dosimetry for #' TL and ESR. Nuclear Tracks and Radiation Measurements 14, \cr\cr 223-227. #' Prescott, J.R., Hutton, J.T., 1994. Cosmic ray contributions to dose rates #' for luminescence and ESR dating: large depths and long-term time variations. #' Radiation Measurements 23, 497-500. \cr\cr Prescott, J.R., Stephan, L.G., #' 1982. The contribution of cosmic radiation to the environmental dose for #' thermoluminescence dating. Latitude, altitude and depth dependences. PACT 6, #' 17-25. #' @examples #' #' ##(1) calculate cosmic dose rate (one absorber) #' calc_CosmicDoseRate(depth = 2.78, density = 1.7, #' latitude = 38.06451, longitude = 1.49646, #' altitude = 364, error = 10) #' #' ##(2a) calculate cosmic dose rate (two absorber) #' calc_CosmicDoseRate(depth = c(5.0, 2.78), density = c(2.65, 1.7), #' latitude = 38.06451, longitude = 1.49646, #' altitude = 364, error = 10) #' #' ##(2b) calculate cosmic dose rate (two absorber) and #' ##correct for geomagnetic field changes #' calc_CosmicDoseRate(depth = c(5.0, 2.78), density = c(2.65, 1.7), #' latitude = 12.04332, longitude = 4.43243, #' altitude = 364, corr.fieldChanges = TRUE, #' est.age = 67, error = 15) #' #' #' ##(3) calculate cosmic dose rate and export results to .csv file #' #calculate cosmic dose rate and save to variable #' results<- calc_CosmicDoseRate(depth = 2.78, density = 1.7, #' latitude = 38.06451, longitude = 1.49646, #' altitude = 364, error = 10) #' #' # the results can be accessed by #' get_RLum(results, "summary") #' #' #export results to .csv file - uncomment for usage #' #write.csv(results, file = "c:/users/public/results.csv") #' #' ##(4) calculate cosmic dose rate for 6 samples from the same profile #' ## and save to .csv file #' #calculate cosmic dose rate and save to variable #' results<- calc_CosmicDoseRate(depth = c(0.1, 0.5 , 2.1, 2.7, 4.2, 6.3), #' density = 1.7, latitude = 38.06451, #' longitude = 1.49646, altitude = 364, #' error = 10) #' #' #export results to .csv file - uncomment for usage #' #write.csv(results, file = "c:/users/public/results_profile.csv") #' #' @export calc_CosmicDoseRate<- function( depth, density, latitude, longitude, altitude, corr.fieldChanges = FALSE, est.age = NA, half.depth = FALSE, error = 10, ... ) { ##============================================================================## ## ... ARGUMENTS ##============================================================================## settings <- list(verbose = TRUE) settings <- modifyList(settings, list(...)) ##============================================================================## ## CONSISTENCY CHECK OF INPUT DATA ##============================================================================## if(depth < 0 || density < 0) { cat(paste("\nNo negative values allowed for depth and density")) stop(domain=NA) } if(corr.fieldChanges == TRUE) { if(is.na(est.age) == TRUE) { cat(paste("\nCorrection for geomagnetic field changes requires", "an age estimate."), fill = FALSE) stop(domain=NA) } if(est.age > 80) { cat(paste("\nCAUTION: No geomagnetic field change correction for samples", "older >80 ka possible!"), fill = FALSE) corr.fieldChanges<- FALSE } } if(length(density) > length(depth)) { stop("\nIf you provide more than one value for density please", " provide an equal number of values for depth.", call. = FALSE) } ##============================================================================## ## CALCULATIONS ##============================================================================## # initialize parameter for Prescott & Hutton (1994) equation C<- 6072 B<- 0.00055 d<- 11.6 alpha<- 1.68 a<- 75 H<- 212 #variable needed to check if cosmic dose rate is calculated for more #than one sample profile.mode<- FALSE #calculate absorber (hgcm) of one depth and one absorber [single sample] if(length(depth)==1) { hgcm<- depth*density if(half.depth == TRUE) { hgcm<- hgcm/2 } } #calculate total absorber of n depths and n densities [single sample] if(length(depth)==length(density)){ hgcm<- 0 for(i in 1:length(depth)) { hgcm<- hgcm + depth[i]*density[i] } if(half.depth == TRUE) { hgcm<- hgcm/2 } } #if there are >1 depths and only one density, calculate #absorber for each sample [multi sample] if(length(depth) > length(density) & length(density) == 1) { profile.mode<- TRUE hgcm<- 1:length(depth) for(i in 1:length(depth)) { hgcm[i]<- depth[i]*density } if(half.depth == TRUE) { hgcm<- hgcm/2 } profile.results<- data.frame(rbind(c(1:3)),cbind(1:length(depth))) colnames(profile.results)<- c("depth (m)", "d0 (Gy/ka)", "dc (Gy/ka)","dc_error (Gy/ka)") } for(i in 1:length(hgcm)) { # calculate cosmic dose rate at sea-level for geomagnetic latitude 55 degrees if(hgcm[i]*100 >= 167) { d0<- (C/((((hgcm[i]+d)^alpha)+a)*(hgcm[i]+H)))*exp(-B*hgcm[i]) } if(hgcm[i]*100 < 167) { temp.hgcm<- hgcm[i]*100 d0.ph<- (C/((((hgcm[i]+d)^alpha)+a)*(hgcm[i]+H)))*exp(-B*hgcm[i]) if(hgcm[i]*100 < 40) { d0<- -6*10^-8*temp.hgcm^3+2*10^-5*temp.hgcm^2-0.0025*temp.hgcm+0.2969 } else { d0<- 2*10^-6*temp.hgcm^2-0.0008*temp.hgcm+0.2535 } if(d0.ph > d0) { d0<- d0.ph } } # Calculate geomagnetic latitude gml.temp<- 0.203*cos((pi/180)*latitude)* cos(((pi/180)*longitude)-(291*pi/180))+0.979* sin((pi/180)*latitude) true.gml<- asin(gml.temp)/(pi/180) gml<- abs(asin(gml.temp)/(pi/180)) # Find values for F, J and H from graph shown in Prescott & Hutton (1994) # values were read from the graph and fitted with 3 degree polynomials and a # linear part if(gml < 36.5) { # Polynomial fit F_ph<- -7*10^-7*gml^3-8*10^-5*gml^2-0.0009*gml+0.3988 } else { # Linear fit F_ph<- -0.0001*gml + 0.2347 } if(gml < 34) { # Polynomial fit J_ph<- 5*10^-6*gml^3-5*10^-5*gml^2+0.0026*gml+0.5177 } else { # Linear fit J_ph<- 0.0005*gml + 0.7388 } if(gml < 36) { # Polynomial fit H_ph<- -3*10^-6*gml^3-5*10^-5*gml^2-0.0031*gml+4.398 } else { # Linear fit H_ph<- 0.0002*gml + 4.0914 } # Apply correction for geomagnetic latitude and altitude according to # Prescott & Hutton (1994) dc<- d0*(F_ph + J_ph*exp((altitude/1000)/H_ph)) ## Additional correction for geomagnetic field change if(corr.fieldChanges==TRUE) { if(gml <= 35) { # Correction matrix for geomagnetic field changes at # sea-level (Prescott & Hutton (1994), Table 1) corr.matrix<- data.frame(rbind(1:5),1:7) colnames(corr.matrix)<- c(0, 10, 20, 30, 35, ">35") rownames(corr.matrix)<- c("0-5","5-10","10-15","15-20","20-35","35-50", "50-80") corr.matrix[1,]<- c(0.97, 0.97, 0.98, 0.98, 0.98, 1.00) corr.matrix[2,]<- c(0.99, 0.99, 0.99, 0.99, 0.99, 1.00) corr.matrix[3,]<- c(1.00, 1.00, 1.00, 1.00, 1.00, 1.00) corr.matrix[4,]<- c(1.01, 1.01, 1.01, 1.00, 1.00, 1.00) corr.matrix[5,]<- c(1.02, 1.02, 1.02, 1.01, 1.00, 1.00) corr.matrix[6,]<- c(1.03, 1.03, 1.02, 1.01, 1.00, 1.00) corr.matrix[7,]<- c(1.02, 1.02, 1.02, 1.01, 1.00, 1.00) # Find corresponding correction factor for given geomagnetic latitude # determine column if(gml <= 5) { corr.c<- 1 } if(5 < gml) { if(gml <= 15) { corr.c<- 2 } } if(15 < gml){ if(gml <= 25) { corr.c<- 3 } } if(25 < gml){ if(gml <= 32.5) { corr.c<- 4 } } if(32.5 < gml){ if(gml <= 35) { corr.c<- 5 } } # find row if(est.age <= 5) { corr.fac<- corr.matrix[1,corr.c] } if(5 < est.age) { if(est.age <= 10) { corr.fac<- corr.matrix[2,corr.c] } } if(10 < est.age){ if(est.age <= 15) { corr.fac<- corr.matrix[3,corr.c] } } if(15 < est.age){ if(est.age <= 20) { corr.fac<- corr.matrix[4,corr.c] } } if(20 < est.age){ if(est.age <= 35) { corr.fac<- corr.matrix[5,corr.c] } } if(35 < est.age){ if(est.age <= 50) { corr.fac<- corr.matrix[6,corr.c] } } if(50 < est.age){ if(est.age <= 80) { corr.fac<- corr.matrix[7,corr.c] } } # Find altitude factor via fitted function 2-degree polynomial # This factor is only available for positive altitudes if(altitude > 0) { alt.fac<- -0.026*(altitude/1000)^2 + 0.6628*altitude/1000 + 1.0435 # Combine geomagnetic latitude correction with altitude # correction (figure caption of Fig. 1 in Precott and Hutton (1994)) diff.one<- corr.fac - 1 corr.fac<- corr.fac + diff.one * alt.fac } # Final correction of cosmic dose rate dc<- dc * corr.fac if (settings$verbose) print(paste("corr.fac",corr.fac,"diff.one",diff.one,"alt.fac",alt.fac)) } else { if (settings$verbose) cat(paste("\n No geomagnetic field change correction necessary for geomagnetic latitude >35 degrees!")) } } # calculate error dc.err<- dc*error/100 # save intermediate results before next sample is calculated if(profile.mode==TRUE) { profile.results[i,1]<- round(depth[i],2) profile.results[i,2]<- round(d0,4) profile.results[i,3]<- round(dc,4) profile.results[i,4]<- round(dc.err,4) } }#END.OF.LOOP call<- sys.call() args<- list(depth = depth, density = density, latitude = latitude, longitude = longitude, altitude = altitude, corr.fieldChanges = corr.fieldChanges, est.age = est.age, half.depth = half.depth, error = error) if(length(hgcm)==1) { ##============================================================================## ##TERMINAL OUTPUT ##============================================================================## if (settings$verbose) { cat("\n\n [calc_CosmicDoseRate]") cat(paste("\n\n ---------------------------------------------------------")) cat(paste("\n depth (m) :", depth)) cat(paste("\n density (g cm^-3) :", density)) cat(paste("\n latitude (N deg.) :", latitude)) cat(paste("\n longitude (E deg.) :", longitude)) cat(paste("\n altitude (m) :", altitude)) cat(paste("\n ---------------------------------------------------------")) cat(paste("\n total absorber (g cm^-2) :", round(hgcm[i]*100,3))) cat(paste("\n")) cat(paste("\n cosmic dose rate (Gy ka^-1) :", round(d0,4))) cat(paste("\n [@sea-level & 55 deg. N G.lat]")) cat(paste("\n")) cat(paste("\n geomagnetic latitude (deg.) :", round(true.gml,1))) cat(paste("\n")) cat(paste("\n cosmic dose rate (Gy ka^-1) :", round(dc,4),"+-", round(dc.err,4))) cat(paste("\n [corrected] ")) cat(paste("\n ---------------------------------------------------------\n\n")) } ##============================================================================## ##RETURN VALUES ##============================================================================## if(length(depth)==1) { temp1<- data.frame(depth=depth,density=density) } else { temp1a<- data.frame(rbind(c(1:length(depth)))) tmpcoln1<- 1:length(depth) for(i in 1:length(depth)) { temp1a[i]<- depth[i] tmpcoln1[i]<- paste("depth",i) } temp1b<- data.frame(rbind(c(1:length(density)))) tmpcoln2<- 1:length(density) for(i in 1:length(density)) { temp1b[i]<- density[i] tmpcoln2[i]<- paste("density",i) } colnames(temp1a)<- tmpcoln1 colnames(temp1b)<- tmpcoln2 temp1<- cbind(temp1a,temp1b) } temp2<- data.frame(latitude=latitude,longitude=longitude, altitude=altitude,total_absorber.gcm2=hgcm*100, d0=d0,geom_lat=true.gml,dc=dc) summary<- data.frame(cbind(temp1,temp2)) newRLumResults.calc_CosmicDoseRate <- set_RLum( class = "RLum.Results", data = list(summary=summary, args=args, call=call)) # Return values invisible(newRLumResults.calc_CosmicDoseRate) } else { #terminal output if (settings$verbose) { cat("\n\n [calc_CosmicDoseRate]") cat(paste("\n\n Calculating cosmic dose rate for",length(depth), "samples. \n\n")) print(profile.results) } #return value add.info<- data.frame(latitude=latitude,longitude=longitude, altitude=altitude,total_absorber.gcm2=hgcm*100, geom_lat=true.gml) add.info<- rbind(add.info*length(i)) colnames(profile.results)<- c("depth","d0","dc","dc_err") summary<- data.frame(cbind(profile.results,add.info)) newRLumResults.calc_CosmicDoseRate <- set_RLum( class = "RLum.Results", data = list(summary=summary, args=args, call=call)) # Return values invisible(newRLumResults.calc_CosmicDoseRate) } } Luminescence/R/merge_RLum.R0000644000176200001440000001026413125226556015260 0ustar liggesusers#' General merge function for RLum S4 class objects #' #' Function calls object-specific merge functions for RLum S4 class objects. #' #' The function provides a generalised access point for merge specific #' \code{\linkS4class{RLum}} objects.\cr Depending on the input object, the #' corresponding merge function will be selected. Allowed arguments can be #' found in the documentations of each merge function. Empty list elements (\code{NULL}) are #' automatically removed from the input \code{list}. #' #' \tabular{lll}{ #' \bold{object} \tab \tab \bold{corresponding merge function} \cr #' #' \code{\linkS4class{RLum.Data.Curve}} \tab : \tab \code{merge_RLum.Data.Curve} \cr #' \code{\linkS4class{RLum.Analysis}} \tab : \tab \code{merge_RLum.Analysis} \cr #' \code{\linkS4class{RLum.Results}} \tab : \tab \code{merge_RLum.Results} # #' } #' #' @param objects \code{\link{list}} of \code{\linkS4class{RLum}} #' (\bold{required}): list of S4 object of class \code{RLum} #' #' @param \dots further arguments that one might want to pass to the specific #' merge function #' #' @return Return is the same as input objects as provided in the list. #' #' @note So far not for every \code{RLum} object a merging function exists. #' #' @section Function version: 0.1.2 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Image}}, #' \code{\linkS4class{RLum.Data.Spectrum}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}} #' #' @references # #' #' @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) #' #' ##apply the central dose model 2nd time #' temp2 <- calc_CentralDose(ExampleData.DeValues$CA1) #' #' ##merge the results and store them in a new object #' temp.merged <- get_RLum(merge_RLum(objects = list(temp1, temp2))) #' #' #' @export merge_RLum<- function( objects, ... ){ # Integrity check ---------------------------------------------------------- if(!is.list(objects)){ stop("[merge_RLum()] argument 'objects' needs to be of type list!") } ##we are friendly and remove all empty list elements, this helps a lot if we place things ##we DO NOT provide a warning as this lower the computation speed in particular cases. objects <- objects[!sapply(objects, is.null)] ##if list is empty afterwards we do nothing if(length(objects) != 0) { ##check if objects are of class RLum temp.class.test <- unique(sapply(1:length(objects), function(x) { if (!is(objects[[x]], "RLum")) { temp.text <- paste( "[merge_RLum()]: At least element", x, "is not of class 'RLum' or a derivative class!" ) stop(temp.text, call. = FALSE) } ##provide class of objects ... so far they should be similar is(objects[[x]])[1] })) ##check if objects are consitent if (length(temp.class.test) > 1) { ##This is not valid for RLum.Analysis objects if (!"RLum.Analysis" %in% temp.class.test) { stop("[merge_RLum()] So far only similar input objects in the list are supported!") } } ##grep object class objects.class <- ifelse("RLum.Analysis" %in% temp.class.test, "RLum.Analysis", temp.class.test) ##select which merge function should be used switch ( objects.class, RLum.Data.Image = stop( "[merge_RLum()] Sorry, merging of 'RLum.Data.Image' objects is currently not supported!" ), RLum.Data.Spectrum = stop( "[merge_RLum()] Sorry, merging of 'RLum.Data.Spectrum' objects is currently not supported!" ), RLum.Data.Curve = merge_RLum.Data.Curve(objects, ...), RLum.Analysis = merge_RLum.Analysis(objects, ...), RLum.Results = merge_RLum.Results(objects, ...) ) }else{ warning("[merge_RLum()] Nothing was merged as the object list was found to be empty!") return(NULL) } } Luminescence/R/analyse_portableOSL.R0000644000176200001440000001701613125226556017126 0ustar liggesusers#' Analyse portable CW-OSL measurements #' #' The function analyses CW-OSL curve data produced by a SUERC portable OSL reader and #' produces a combined plot of OSL/IRSL signal intensities, OSL/IRSL depletion ratios #' and the IRSL/OSL ratio. #' #' This function only works with \code{RLum.Analysis} objects produced by \code{\link{read_PSL2R}}. #' It further assumes (or rather requires) an equal amount of OSL and IRSL curves that #' are pairwise combined for calculating the IRSL/OSL ratio. For calculating the depletion ratios #' the cumulative signal of the last n channels (same number of channels as specified by \code{signal.integral}) #' is divided by cumulative signal of the first n channels (\code{signal.integral}). #' #' @param object \code{\linkS4class{RLum.Analysis}} (\bold{required}): #' \code{RLum.Analysis} object produced by \code{\link{read_PSL2R}}. #' #' @param signal.integral \code{\link{vector}} (\bold{required}): A vector of two values #' specifying the lower and upper channel used to calculate the OSL/IRSL signal. Can #' be provided in form of \code{c(1, 5)} or \code{1:5}. #' #' #' @param invert \code{\link{logical}} (with default): \code{TRUE} to calculate #' and plot the data in reverse order. #' #' @param normalise \code{\link{logical}} (with default): #' \code{TRUE} to normalise the OSL/IRSL signals by the mean of all corresponding #' data curves. #' #' @param plot \code{\link{logical}} (with default): enable/disable plot output #' #' @param ... currently not used. #' #' @return Returns an S4 \code{\linkS4class{RLum.Results}} object containing #' the following elements: #' #' @seealso \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data.Curve}} #' #' @author Christoph Burow, University of Cologne (Germany) #' #' @section Function version: 0.0.3 #' #' @keywords datagen plot #' #' @examples #' #' # (1) load example data set #' data("ExampleData.portableOSL", envir = environment()) #' #' # (2) merge and plot all RLum.Analysis objects #' merged <- merge_RLum(ExampleData.portableOSL) #' plot_RLum(merged, combine = TRUE) #' merged #' #' # (3) analyse and plot #' results <- analyse_portableOSL(merged, signal.integral = 1:5, invert = FALSE, normalise = TRUE) #' get_RLum(results) #' #' #' #' @export analyse_portableOSL <- function(object, signal.integral, invert = FALSE, normalise = FALSE, plot = TRUE, ...) { ## INPUT VERIFICATION ---- if (!inherits(object, "RLum.Analysis")) stop("Only objects of class 'RLum.Analysis' are allowed.", call. = FALSE) if (!all(sapply(object, class) == "RLum.Data.Curve")) stop("The 'RLum.Analysis' object must only contain objects of class 'RLum.Data.Curve'.", call. = FALSE) if (!all(sapply(object, function(x) x@originator) == "read_PSL2R")) stop("Only objects originating from 'read_PSL2R()' are allowed.", call. = FALSE) if (missing(signal.integral)) { signal.integral <- c(1, 1) warning("No value for 'signal.integral' provided. Only the first data point of each curve was used!", call. = FALSE) } ## CALCULATIONS ---- # OSL OSL <- get_RLum(object, recordType = "OSL") OSL <- do.call(rbind, lapply(OSL, function(x) { posl_get_signal(x, signal.integral) })) # IRSL IRSL <- get_RLum(object, recordType = "IRSL") IRSL <- do.call(rbind, lapply(IRSL, function(x) { posl_get_signal(x, signal.integral) })) ## NORMALISE ---- if (normalise) { OSL <- posl_normalise(OSL) IRSL <- posl_normalise(IRSL) } ## INVERT ---- if (invert) { OSL <- posl_invert(OSL) IRSL <- posl_invert(IRSL) } # OSL/IRSL Ratio RATIO <- IRSL$sum_signal / OSL$sum_signal ## PLOTTING ---- if (plot) { par.old.full <- par(no.readonly = TRUE) on.exit(par(par.old.full)) # default: par(mar = c(5, 4, 4, 2) + 0.1) // bottom, left, top, right par(mfrow = c(1, 6)) par(mar = c(5, 4, 4, 1) + 0.1) frame() par(mar = c(5, 0, 4, 1) + 0.1) plot( OSL$sum_signal, 1:nrow(OSL), type = "b", pch = 16, col = "blue", xlim = range(pretty(OSL$sum_signal)), xlab = "BSL", ylab = "Index", bty = "n", yaxt = "n" ) axis(2, line = 3, at = 1:nrow(OSL)) axis(3) mtext("Index", side = 2, line = 6) plot( IRSL$sum_signal, 1:nrow(IRSL), type = "b", pch = 16, col = "red", xlim = range(pretty(IRSL$sum_signal)), xlab = "IRSL", ylab = "", bty = "n", yaxt = "n" ) axis(3) plot( OSL$sum_signal_depletion, 1:nrow(OSL), type = "b", pch = 1, col = "blue", xlim = range(pretty(OSL$sum_signal_depletion)), xlab = "BSL depl.", ylab = "", bty = "n", yaxt = "n", lty = 2 ) axis(3) plot( IRSL$sum_signal_depletion, 1:nrow(IRSL), type = "b", pch = 1, col = "red", xlim = range(pretty(IRSL$sum_signal_depletion)), xlab = "IRSL depl.", ylab = "", bty = "n", yaxt = "n", lty = 2 ) axis(3) plot( RATIO, 1:length(RATIO), type = "b", pch = 16, col = "black", xlim = range(pretty(RATIO)), xlab = "IRSL/BSL", ylab = "", bty = "n", yaxt = "n" ) axis(3) } ## RETURN VALUE ---- call<- sys.call() args <- as.list(call)[2:length(call)] summary <- data.frame(BSL = OSL$sum_signal, BSL_error = OSL$sum_signal_err, IRSL = IRSL$sum_signal, IRSL_error = IRSL$sum_signal_err, BSL_depletion = OSL$sum_signal_depletion, IRSL_depletion = IRSL$sum_signal_depletion, IRSL_BSL_RATIO = RATIO) newRLumResults <- set_RLum( class = "RLum.Results", data = list( summary=summary, data = object, args=args ), info = list(call = call)) return(newRLumResults) } ################################################################################ ## HELPER FUNCTIONS ## ################################################################################ ## This extracts the relevant curve data information of the RLum.Data.Curve ## objects posl_get_signal <- function(x, signal.integral) { raw_signal <- get_RLum(x)[,2] sigint <- range(signal.integral) if (sigint[2] > length(raw_signal)) { sigint[2] <- length(raw_signal) warning("'signal.integral' (", paste(range(signal.integral), collapse = ", "),") ", "exceeded the number of available data points (n = ", length(raw_signal),") and ", "has been automatically reduced to the maximum number.", call. = FALSE) } sum_signal <- sum(raw_signal[sigint[1]:sigint[2]]) sum_signal_err <- sqrt(sum(x@info$raw_data$counts_per_cycle_error[sigint[1]:sigint[2]]^2)) sum_signal_depletion <- sum(raw_signal[(length(raw_signal)-length(sigint[1]:sigint[2])):length(raw_signal)]) / sum_signal return(data.frame(sum_signal, sum_signal_err, sum_signal_depletion)) } ## This function normalises the data curve by the mean signal posl_normalise <- function(x) { rel.error <- x$sum_signal_err / x$sum_signal x$sum_signal <- x$sum_signal / mean(x$sum_signal) x$sum_signal_err <- x$sum_signal * rel.error x$sum_signal_depletion <- x$sum_signal_depletion / mean(x$sum_signal_depletion) return(x) } ## This function invertes the data.frame (useful when the sample are in inverse ## stratigraphic order) posl_invert <- function(x) { x <- x[nrow(x):1, ] } Luminescence/R/Analyse_SAR.OSLdata.R0000644000176200001440000006450713125226556016622 0ustar liggesusers#' Analyse SAR CW-OSL measurements. #' #' 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 \link{calc_OSLLxTxRatio} is used. \cr\cr #' #' \bold{Provided rejection criteria}\cr\cr \sQuote{recyling ratio}: calculated #' for every repeated regeneration dose point.\cr \sQuote{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)\cr #' #' \sQuote{IRSL/BOSL}: the integrated counts (\code{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. \strong{Note:} This is not the IR depletation ratio #' described by Duller (2003). #' #' @param input.data \link{Risoe.BINfileData-class} (\bold{required}): input #' data from a Risoe BIN file, produced by the function \link{read_BIN2R}. #' #' @param signal.integral \link{vector} (\bold{required}): channels used for #' the signal integral, e.g. \code{signal.integral=c(1:2)} #' #' @param background.integral \link{vector} (\bold{required}): channels used #' for the background integral, e.g. \code{background.integral=c(85:100)} #' #' @param position \link{vector} (optional): reader positions that want to be #' analysed (e.g. \code{position=c(1:48)}. Empty positions are automatically #' omitted. If no value is given all positions are analysed by default. #' #' @param run \link{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 \link{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 #' \code{Risoe.BINfileData} object. #' #' @param dtype \code{\link{character}} (optional): allows to further limit the #' curves by their data type (\code{DTYPE}), e.g., \code{dtype = c("Natural", #' "Dose")} limits the curves to this two data types. By default all values are #' allowed. See \link{Risoe.BINfileData-class} for allowed data types. #' #' @param keep.SEL \code{\link{logical}} (default): option allowing to use the #' \code{SEL} element of the \link{Risoe.BINfileData-class} manually. NOTE: In #' this case any limitation provided by \code{run}, \code{set} and \code{dtype} #' are ignored! #' #' @param info.measurement \link{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 \link{logical} (with default): plot output #' (\code{TRUE/FALSE}) #' #' @param output.plot.single \link{logical} (with default): single plot output #' (\code{TRUE/FALSE}) to allow for plotting the results in single plot #' windows. Requires \code{output.plot = TRUE}. #' #' @param cex.global \link{numeric} (with default): global scaling factor. #' #' @param \dots further arguments that will be passed to the function #' \code{\link{calc_OSLLxTxRatio}} (supported: \code{background.count.distribution}, \code{sigmab}, #' \code{sig0}; e.g., for instrumental error) #' and can be used to adjust the plot. Supported" \code{mtext}, \code{log} #' #' @return A plot (optional) and \link{list} is returned containing the #' following elements: \item{LnLxTnTx}{\link{data.frame} of all calculated #' Lx/Tx values including signal, background counts and the dose points.} #' \item{RejectionCriteria}{\link{data.frame} with values that might by used as #' rejection criteria. NA is produced if no R0 dose point exists.} #' \item{SARParameters}{\link{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.\cr\cr #' #' \bold{The analysis of IRSL data is not directly supported}. You may want to #' consider using the functions \code{\link{analyse_SAR.CWOSL}} or #' \code{\link{analyse_pIRIRSequence}} instead.\cr #' #' \bold{The development of this function will not be continued. We recommend #' to use the function \link{analyse_SAR.CWOSL} or instead.} #' #' #' @section Function version: 0.2.17 #' #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France), Margret C. Fuchs, HZDR, Freiberg (Germany) #' @seealso \link{calc_OSLLxTxRatio}, \link{Risoe.BINfileData-class}, #' \link{read_BIN2R} #' #' and for further analysis \link{plot_GrowthCurve} #' #' @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 #' 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 #' #' @export Analyse_SAR.OSLdata <- function( input.data, signal.integral, background.integral, position, run, set, dtype, keep.SEL = FALSE, info.measurement = "unkown measurement", output.plot = FALSE, output.plot.single = FALSE, cex.global = 1, ... ){ ##============================================================================## ##CONFIG ##============================================================================## ##set colors gallery to provide more colors col <- get("col", pos = .LuminescenceEnv) ##============================================================================## ##ERROR HANDLING ##============================================================================## if(missing(input.data)==TRUE){stop("[Analyse_SAR.OSLdata] No input data given!") }else{sample.data<-input.data} if(missing(signal.integral)==TRUE){stop("[Analyse_SAR.OSLdata] No signal integral is given!")} if(missing(background.integral)==TRUE){stop("[Analyse_SAR.OSLdata] 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){ stop("[Analyse_SAR.OSLdata()] 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 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) }else{IRSL_BOSL<-NA} }else{IRSL_BOSL<-NA} ##Combine the two values if(exists("RejectionCriteria")==FALSE){ RejectionCriteria<-cbind(RecyclingRatio,Recuperation,IRSL_BOSL) }else{ RejectionCriteria.temp<-cbind(RecyclingRatio,Recuperation,IRSL_BOSL) RejectionCriteria<-rbind(RejectionCriteria,RejectionCriteria.temp) } ##============================================================================## ##PLOTTING ##============================================================================## if(output.plot){ ##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(output.plot.single==FALSE){ 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(output.plot.single==TRUE){ 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/plot_ViolinPlot.R0000644000176200001440000002035213125226556016356 0ustar liggesusers#' Create a violin plot #' #' Draws a kernal densiy 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 to small to be visualised. The idea for this plot is #' based on the the 'volcano plot' in the ggplot2 package by Hadely Wickham and Winston Chang. #' The general idea for the Violin Plot seems to be introduced by Hintze and Nelson (1998). #' #' The function is passing several arguments to the function \code{\link{plot}}, #' \code{\link[stats]{density}}, \code{\link[graphics]{boxplot}}: #' Supported arguments are: \code{xlim}, \code{main}, \code{xlab}, #' \code{ylab}, \code{col.violin}, \code{col.boxplot}, \code{mtext}, \code{cex}, \code{mtext} #' #' \bold{\code{Valid summary keywords}}\cr #' #' 'n', 'mean', 'median', 'sd.abs', 'sd.rel', 'se.abs', 'se.rel', 'skewness', 'kurtosis' #' #' @param data \code{\link{numeric}} or \code{\linkS4class{RLum.Results}} #' object (required): input data for plotting. Alternatively a \code{\link{data.frame}} or #' a \code{\link{matrix}} can be provided, but only the first column will be considered by the #' function #' #' @param boxplot \code{\link{logical}} (with default): enable or disable boxplot #' #' @param rug \code{\link{logical}} (with default): enable or disable rug #' #' @param summary \code{\link{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 \code{\link{numeric}} or \code{\link{character}} (with #' default): optional position keywords (cf., \code{\link{legend}}) #' for the statistical summary. Alternatively, the keyword \code{"sub"} may be #' specified to place the summary below the plot header. However, this latter #' option in only possible if \code{mtext} is not used. #' #' @param na.rm \code{\link{logical}} (with default): exclude NA values #' from the data set prior to any further operations. #' #' @param \dots further arguments and graphical parameters passed to #' \code{\link{plot.default}}, \code{\link[stats]{density}} and \code{\link{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.3 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @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 \code{\link[stats]{density}}, \code{\link{plot}}, \code{\link{boxplot}}, \code{\link{rug}}, #' \code{\link{calc_Statistics}} #' #' @examples #' ## read example data set #' data(ExampleData.DeValues, envir = environment()) #' ExampleData.DeValues <- Second2Gray(ExampleData.DeValues$BT998, c(0.0438,0.0019)) #' #' ## create plot straightforward #' plot_ViolinPlot(data = ExampleData.DeValues) #' #' @export plot_ViolinPlot <- function( data, boxplot = TRUE, rug = TRUE, summary = NULL, summary.pos = "sub", na.rm = TRUE, ... ) { # Integrity tests and conversion -------------------------------------------------------------- ##Prechecks if(missing(data)){ stop("[plot_ViolinPlot()] I don't know what to do, data input needed." ) }else{ ##check for RLum.Results object if(is(data, "RLum.Results")){ data <- get_RLum(data, "data") } ##if data.frame or matrix if(is(data, "data.frame") | is(data, "matrix")){ data <- data[,1] } } ##Remove NA values if(na.rm){ data <- na.exclude(data) if(length(attr(data, "na.action")) > 0){ warning(paste("[plot_ViolinPlot()]", length(attr(data, "na.action")), "NA values removed!"), call. = FALSE) } } #Further checks if(!is(summary.pos, "character")){ stop("[plot_ViolinPlot()] argument 'summary.pos' needs to be of type character!") } ##stop if only one or 0 values are left in data if(length(data) == 0){ warning("[plot_ViolinePlot()] Actually it is rather hard to plot 0 values. NULL returned", call. = FALSE) 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 warning("[plot_ViolinePlot()] single data point found, no density calculated.", call. = FALSE) } ##some statistical parameter, get rid of the weighted statistics stat.summary <- suppressWarnings(calc_Statistics(as.data.frame(data), digits = 2)[["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))){ warning(paste0("[plot_ViolinePlot()] At least one 'summary' keyword is invalid. Valid keywords are: ", paste(names(stat.summary), collapse = ", ")), call. = FALSE) } ##make sure that only valid keywords make it summary <- summary[(summary %in% names(stat.summary))] stat.text <- paste(names(stat.summary[summary]), " = ", stat.summary[summary], collapse = " \n") stat.mtext <- paste(names(stat.summary[summary]), " = ", stat.summary[summary], collapse = " | ") # 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){ boxplot( data, outline = TRUE, boxwex = 0.4, horizontal = TRUE, axes = FALSE, add = TRUE, col = plot.settings$col.boxplot ) } ##add rug if(rug){ 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{ warning_text <- paste0("Value provided for 'summary.pos' is not a valid keyword, valid keywords are:", paste(valid_keywords, collapse = ", ")) warning(warning_text) } } } Luminescence/R/structure_RLum.R0000644000176200001440000000252013125226556016215 0ustar liggesusers#' General structure function for RLum S4 class objects #' #' Function calls object-specific get functions for RLum S4 class objects. #' #' The function provides a generalised access point for specific #' \code{\linkS4class{RLum}} objects.\cr Depending on the input object, the #' corresponding structure function will be selected. Allowed arguments can be found #' in the documentations of the corresponding \code{\linkS4class{RLum}} class. #' #' @param object \code{\linkS4class{RLum}} (\bold{required}): S4 object of #' class \code{RLum} #' #' @param \dots further arguments that one might want to pass to the specific #' structure method #' #' @return Returns a \code{data.frame} with structure of the object. #' #' @section Function version: 0.2.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso #' \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Data.Image}}, #' \code{\linkS4class{RLum.Data.Spectrum}}, #' \code{\linkS4class{RLum.Analysis}}, #' \code{\linkS4class{RLum.Results}} #' #' @keywords utilities #' #' @examples #' #' ##load example data #' data(ExampleData.XSYG, envir = environment()) #' #' ##show structure #' structure_RLum(OSL.SARMeasurement$Sequence.Object) #' #' @export setGeneric("structure_RLum", function(object, ...) { standardGeneric("structure_RLum") }) Luminescence/R/merge_RLum.Analysis.R0000644000176200001440000001060413125226556017040 0ustar liggesusers#' Merge function for RLum.Analysis S4 class objects #' #' Function allows merging of RLum.Analysis objects and adding of allowed #' objects to an RLum.Analysis. #' #' This function simply allowing to merge \code{\linkS4class{RLum.Analysis}} #' objects. Additionally other \code{\linkS4class{RLum}} objects can be added #' to an existing \code{\linkS4class{RLum.Analysis}} object. Supported objects #' to be added are: \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Data.Spectrum}} and #' \code{\linkS4class{RLum.Data.Image}}.\cr #' #' The order in the new \code{\linkS4class{RLum.Analysis}} object is the object #' order provided with the input list. #' #' @param objects \code{\link{list}} of \code{\linkS4class{RLum.Analysis}} #' (\bold{required}): list of S4 objects of class \code{RLum.Analysis}. #' Furthermore other objects of class \code{\linkS4class{RLum}} can be added, #' see details. #' #' @return Return an \code{\linkS4class{RLum.Analysis}} object. #' #' @note The information for the slot 'protocol' is taken from the first #' \code{\linkS4class{RLum.Analysis}} object in the input list. Therefore at #' least one object of type \code{\linkS4class{RLum.Analysis}} has to be #' provided. #' #' @section Function version: 0.2.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\link{merge_RLum}}, \code{\linkS4class{RLum.Analysis}}, #' \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Data.Spectrum}}, #' \code{\linkS4class{RLum.Data.Image}}, \code{\linkS4class{RLum}} #' #' @references - #' #' @keywords utilities #' #' @examples #' #' #' ##merge different RLum objects from the example data #' data(ExampleData.RLum.Analysis, envir = environment()) #' data(ExampleData.BINfileData, envir = environment()) #' #' object <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos=1) #' curve <- get_RLum(object)[[2]] #' #' temp.merged <- merge_RLum.Analysis(list(curve, IRSAR.RF.Data, IRSAR.RF.Data)) #' #' @export merge_RLum.Analysis<- function( objects ){ # Ingegrity checks ---------------------------------------------------------------------------- ##check if object is of class RLum temp.class.test <- sapply(1:length(objects), function(x){ if(is(objects[[x]], "RLum") == FALSE){ temp.text <- paste("[merge_RLum.Analysis()]: At least element", x, "is not of class 'RLum' or a derivative class!") stop(temp.text) } ##provide class of objects is(objects[[x]])[1] }) ##check if at least one object of RLum.Analysis is provided if(!"RLum.Analysis"%in%temp.class.test){ stop("[merge_RLum.Analysis()] At least one input object in the list has to be of class 'RLum.Analysis'!") } # Merge objects ------------------------------------------------------------------------------- ##(0) get recent environment to later set variable temp.meta.data.first temp.environment <- environment() temp.meta.data.first <- NA; rm(temp.meta.data.first) #to avoid problems with the R check routine ##(1) collect all elements in a list temp.element.list <- unlist(lapply(1:length(objects), function(x){ ##Depending on the element the right functions is used if(is(objects[[x]])[1] == "RLum.Analysis"){ ##grep export meta data from the first RLum.Analysis objects an write if(!exists("temp.meta.data.first")){ assign("temp.meta.data.first", objects[[x]]@protocol, envir = temp.environment) } ##return to list get_RLum(objects[[x]]) }else if((is(objects[[x]])[1] == "RLum.Data.Curve") | (is(objects[[x]])[1] == "RLum.Data.Image") | (is(objects[[x]])[1] == "RLum.Data.Spectrum")){ ##return to list objects[[x]] }else{ stop("[merge_RLum.Anlysis()] What ever was provided, this 'RLum' object is not supported!") } })) # Build new RLum.Analysis object -------------------------------------------------------------- temp.new.RLum.Analysis <- set_RLum( class = "RLum.Analysis", originator = "merge_RLum.Analysis", records = temp.element.list, protocol = temp.meta.data.first, info = unlist(lapply(objects, function(x) { x@info }), recursive = FALSE), .pid = unlist(lapply(objects, function(x) { x@.uid })) ) # Return object ------------------------------------------------------------------------------- return( temp.new.RLum.Analysis) } Luminescence/R/plot_FilterCombinations.R0000644000176200001440000003104313125226556020051 0ustar liggesusers#' Plot filter combinations along with the (optional) net transmission window #' #' The function allows to plot transmission windows for different filters. Missing data for specific #' wavelenghts are automatically interpolated for the given filter data using the function \code{\link{approx}}. #' With that a standardised output is reached and a net transmission window can be shown.\cr #' #' \bold{Calculations}\cr #' #' \bold{Net transmission window}\cr #' The net transmission window of two filters is approximated by #' #' \deqn{T_{final} = T_{1} * T_{2}} #' #' #' \bold{Optical density}\cr #' #' \deqn{OD = -log(T)} #' #' \bold{Total optical density}\cr #' #' \deqn{OD_{total} = OD_{1} + OD_{2}} #' #' Please consider using own calculations for more precise values. #' #' \bold{How to provide input data?}\cr #' #' CASE 1\cr #' #' The function expects that all filter values are either of type \code{matrix} or \code{data.frame} #' with two columns. The first columens contains the wavelength, the second the relative transmission #' (but not in percentage, i.e. the maximum transmission can be only become 1). #' #' In this case only the transmission window is show as provided. Changes in filter thickness and #' relection factor are not considered. \cr #' #' CASE 2\cr #' #' The filter data itself are provided as list element containing a \code{matrix} or \code{data.frame} #' and additional information on the thickness of the filter, e.g., \code{list(filter1 = list(filter_matrix, d = 2))}. #' The given filter data are always considered as standard input and the filter thickness value #' is taken into account by #' #' \deqn{Transmission = Transmission^(d)} #' #' with d given in the same dimension as the original filter data.\cr #' #' CASE 3\cr #' #' Same as CASE 2 but additionally a reflection factor P is provided, e.g., #' \code{list(filter1 = list(filter_matrix, d = 2, P = 0.9))}. The final transmission #' becomes: #' #' \deqn{Transmission = Transmission^(d) * P}\cr #' #' \bold{Advanced plotting parameters}\cr #' #' The following further non-common plotting parameters can be passed to the function:\cr #' #' \tabular{lll}{ #' \bold{Argument} \tab \bold{Datatype} \tab \bold{Description}\cr #' \code{legend} \tab \code{logical} \tab enable/disable legend \cr #' \code{legend.pos} \tab \code{character} \tab change legend position (\code{\link[graphics]{legend}}) \cr #' \code{legend.text} \tab \code{character} \tab same as the argument \code{legend} in (\code{\link[graphics]{legend}}) \cr #' \code{net_transmission.col} \tab \code{col} \tab colour of net transmission window polygon \cr #' \code{net_transmission.col_lines} \tab \code{col} \tab colour of net transmission window polygon lines \cr #' \code{ net_transmission.density} \tab \code{numeric} \tab specify line density in the transmission polygon \cr #' \code{grid} \tab \code{list} \tab full list of arguments that can be passd to the function \code{\link[graphics]{grid}} #' } #' #' For further modifications standard additional R plot functions are recommend, e.g., the legend #' can be fully customised by disabling the standard legend and use the function \code{\link[graphics]{legend}} #' instead. #' #' #' @param filters \code{\link{list}} (\bold{required}): a named list of filter data for each filter to be shown. #' The filter data itself should be either provided as \code{\link{data.frame}} or \code{\link{matrix}}. #' (for more options s. Details) #' #' @param wavelength_range \code{\link{numeric}} (with default): wavelength range used for the interpolation #' #' @param show_net_transmission \code{\link{logical}} (with default): show net transmission window #' as polygon. #' #' @param interactive \code{\link{logical}} (with default): enable/disable interactive plot #' #' @param plot \code{\link{logical}} (with default): enables or disables the plot output #' #' @param \dots further arguments that can be passed to control the plot output. Suppored are \code{main}, #' \code{xlab}, \code{ylab}, \code{xlim}, \code{ylim}, \code{type}, \code{lty}, \code{lwd}. #' For non common plotting parameters see the details section. #' #' @return Returns an S4 object of type \code{\linkS4class{RLum.Results}}. #' #' \bold{@data} #' \tabular{lll}{ #' \bold{Object} \tab \bold{Type} \bold{Description} \cr #' net_transmission_window \tab \code{matrix} \tab the resulting net transmission window \cr #' OD_total \tab \code{matrix} \tab the total optical density\cr #' filter_matrix \tab \code{matrix} \tab the filter matrix used for plotting #' #' } #' #' \bold{@info} #' \tabular{lll}{ #' \bold{Object} \tab \bold{Type} \bold{Description} \cr #' call \tab \code{call} \tab the original function call #' #' } #' #' @section Function version: 0.3.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montagine (France)\cr #' #' @seealso \code{\linkS4class{RLum.Results}}, \code{\link{approx}} #' #' @keywords datagen aplot #' #' @examples #' #' ## (For legal reasons no real filter data are provided) #' #' ## Create filter sets #' filter1 <- density(rnorm(100, mean = 450, sd = 20)) #' filter1 <- matrix(c(filter1$x, filter1$y/max(filter1$y)), ncol = 2) #' filter2 <- matrix(c(200:799,rep(c(0,0.8,0),each = 200)), ncol = 2) #' #' ## Example 1 (standard) #' plot_FilterCombinations(filters = list(filter1, filter2)) #' #' ## Example 2 (with d and P value and name for filter 2) #' results <- plot_FilterCombinations( #' filters = list(filter_1 = filter1, Rectangle = list(filter2, d = 2, P = 0.6))) #' results #' #' ## Example 3 show optical density #' plot(results$OD_total) #' #' \dontrun{ #' ##Example 4 #' ##show the filters using the interative mode #' plot_FilterCombinations(filters = list(filter1, filter2), interative = TRUE) #' #' } #' #' #' @export plot_FilterCombinations <- function( filters, wavelength_range = 200:1000, show_net_transmission = TRUE, interactive = FALSE, plot = TRUE, ...) { # Integrity tests ----------------------------------------------------------------------------- #check filters if (!is(filters, "list")) { stop("[plot_FilterCombinations()] 'filters' should be of type 'list'") } #input should either data.frame or matrix lapply(filters, function(x) { if (!is(x, "data.frame") & !is(x, "matrix") & !is(x, "list")) { stop( paste( "[plot_FilterCombinations()] input for filter", x, "is not of type 'matrix', 'data.frame' or 'list'!" ) ) } }) #check for named list, if not set names if (is.null(names(filters))) { names(filters) <- paste("Filter ", 1:length(filters)) } # Data Preparation ---------------------------------------------------------------------------- ##check if filters are provided with their tickness, if so correct ##transmission for this ... relevant for glass filters filters <- lapply(filters, function(x) { if (is(x, "list")) { ##correction for the transmission accounting for filter tickness, the ##provided thickness is always assumed to be 1 if(length(x) > 1){ x[[1]][, 2] <- x[[1]][, 2] ^ (x[[2]]) }else{ return(x[[1]]) } ##account for potentially provided transmission relexion factor if(length(x) > 2){ x[[1]][,2] <- x[[1]][,2] * x[[3]] return(x[[1]]) }else{ return(x[[1]]) } } else{ return(x) } }) #check if there are transmission values greater than one, this is not possible lapply(filters, function(x) { if (max(x[, 2], na.rm = TRUE) > 1.01) { stop("[plot_FilterCombinations()] transmission values > 1 found. Check your data.") } }) ##combine everything in a matrix using approx for interpolation filter_matrix <- vapply(filters, function(x) { approx(x = x[, 1], y = x[, 2], xout = wavelength_range)$y }, FUN.VALUE = vector(mode = "numeric", length = length(wavelength_range))) ##calculate transmission window filter_matrix <- cbind(filter_matrix) net_transmission_window <- matrix( c(wavelength_range, matrixStats::rowProds(filter_matrix)), ncol = 2) ##add optical density to filter matrix ##calculate OD OD <- -log(filter_matrix) ##calculate total OD OD_total <- cbind(wavelength_range, matrixStats::rowSums2(OD)) ##add to matrix filter_matrix <- cbind(filter_matrix, OD) ##set rownames of filter matrix rownames(filter_matrix) <- wavelength_range ##set column names for filter matrix colnames(filter_matrix) <- c(names(filters), paste0(names(filters), "_OD")) # Plotting ------------------------------------------------------------------------------------ if (plot) { ##(1) ... select transmission values filter_matrix_transmisison <- filter_matrix[,!grepl(pattern = "OD", x = colnames(filter_matrix))] ##set plot settings plot_settings <- list( main = "Filter Combination", xlab = "Wavelength [nm]", ylab = "Transmission [a.u.]", xlim = range(wavelength_range), ylim = c(0, 1), legend.pos = "topleft", lty = 1, lwd = 1, col = 1:length(filters), grid = expression(nx = 10, ny = 10), legend = TRUE, legend.text = colnames(filter_matrix_transmisison), net_transmission.col = rgb(0,0.7,0,.2), net_transmission.col_lines = "grey", net_transmission.density = 20 ) ##modify settings on request plot_settings <- modifyList(plot_settings, list(...)) if(interactive){ ##check for plotly if (!requireNamespace("plotly", quietly = TRUE)) { stop("[plot_FilterCombinations()] Package 'plotly' needed interactive plot functionality. Please install it.", call. = FALSE) } ##create basic plot p <- plotly::plot_ly(x = wavelength_range, y = filter_matrix[,1], type = "scatter", name = colnames(filter_matrix_transmisison)[1], mode = "lines") ##add further filters if (ncol(filter_matrix_transmisison) > 1) { for (i in 2:ncol(filter_matrix_transmisison)) { p <- plotly::add_trace(p, y = filter_matrix[, i], name = colnames(filter_matrix_transmisison)[i], mode = 'lines') } } ##add polygon p <- plotly::add_polygons(p, x = c(wavelength_range, rev(wavelength_range)), y = c(net_transmission_window[, 2], rep(0, length(wavelength_range))), name = "net transmission" ) ##change graphical parameters p <- plotly::layout( p = p, xaxis = list( title = plot_settings$xlab ), yaxis = list( title = plot_settings$ylab ), title = plot_settings$main ) print(p) on.exit(return(p)) }else{ ##plot induvidal filters graphics::matplot( x = wavelength_range, y = filter_matrix_transmisison, type = "l", main = plot_settings$main, xlab = plot_settings$xlab, ylab = plot_settings$ylab, xlim = plot_settings$xlim, ylim = plot_settings$ylim, lty = plot_settings$lty, lwd = plot_settings$lwd, col = plot_settings$col ) if (!is.null(plot_settings$grid)) { graphics::grid(eval(plot_settings$grid)) } ##show effective transmission, which is the minimum for each row if (show_net_transmission) { polygon( x = c(wavelength_range, rev(wavelength_range)), y = c(net_transmission_window[, 2], rep(0, length(wavelength_range))), col = plot_settings$net_transmission.col, border = NA, ) polygon( x = c(wavelength_range, rev(wavelength_range)), y = c(net_transmission_window[, 2], rep(0, length(wavelength_range))), col = plot_settings$net_transmission.col_lines, border = NA, density = plot_settings$net_transmission.density ) } #legend if (plot_settings$legend) { legend( plot_settings$legend.pos, legend = plot_settings$legend.text, col = plot_settings$col, lty = plot_settings$lty, bty = "n" ) } } } # Produce output object ----------------------------------------------------------------------- return(set_RLum( class = "RLum.Results", data = list( net_transmission_window = net_transmission_window, OD_total = OD_total, filter_matrix = filter_matrix ), info = list(call = sys.call()) )) } Luminescence/R/calc_ThermalLifetime.R0000644000176200001440000002671013125226556017262 0ustar liggesusers#' Calculates the Thermal Lifetime using the Arrhenius equation #' #' The function calculates the thermal lifetime of charges for given E (in eV), s (in 1/s) and #' T (in deg. C.) parameters. The function can be used in two operational modes:\cr #' #' \bold{Mode 1 \code{(profiling = FALSE)}} #' #' An arbitrary set of input parameters (E, s, T) can be provided and the #' function calculates the thermal lifetimes using the Arrhenius equation for #' all possible combinations of these input parameters. An array with 3-dimensions #' is returned that can be used for further analyses or graphical output (see example 1) #' #' \bold{Mode 2 \code{(profiling = TRUE)}} #' #' This mode tries to profile the variation of the thermal lifetime for a chosen #' temperature by accounting for the provided E and s parameters and their corresponding #' standard errors, e.g., \code{E = c(1.600, 0.001)} #' The calculation based on a Monte Carlo simulation, where values are sampled from a normal #' distribution (for E and s).\cr #' #' \bold{Used equation (Arrhenius equation)}\cr #' #' \deqn{\tau = 1/s exp(E/kT)} #' where: \eqn{\tau} in s as the mean time an electron spends in the trap for a given \eqn{T}, #' \eqn{E} trap depth in eV, \eqn{s} the frequency factor in 1/s, \eqn{T} the temperature in K and \eqn{k} the Boltzmann constant in eV/K (cf. Furetta, 2010). #' #' @param E \code{\link{numeric}} (\bold{required}): vector of trap depths in eV, #' if \code{profiling = TRUE} #' only the first two elements are considered #' #' @param s \code{\link{numeric}} (\bold{required}): vector of frequency factor in 1/s, #' if \code{profiling = TRUE} only the first two elements are considered #' #' @param T \code{\link{numeric}} (with default): temperature in deg. C for which the lifetime(s) #' will be calculted. A vector can be provided. #' #' @param output_unit \code{\link{character}} (with default): #' output unit of the calculated lifetimes, accepted #' entries are: \code{"Ma"}, \code{"ka"}, \code{"a"}, \code{"d"}, \code{"h"}, \code{"min"}, \code{"s"} #' #' @param profiling \code{\link{logical}} (with default): #' this option allows to estimate uncertainties based on #' given E and s parameters and their corresponding standard error (cf. details and examples section) #' #' @param profiling_config \code{\link{list}} (optional): allows to set configurate parameters #' used for the profiling (and only have an effect here). Supported parameters are: #' \code{n} (number of MC runs), \code{E.distribution} (distribution used for the resampling for E) and #' \code{s.distribution} (distribution used for the resampling for s). Currently only the normal #' distribution is supported (e.g., \code{profiling_config = list(E.distribution = "norm")} #' #' @param verbose \code{\link{logical}}: enables/disables verbose mode #' #' @param plot \code{\link{logical}}: enables/disables output plot, currenlty only in combination #' with \code{profiling = TRUE}. #' #' @param \dots further arguments that can be passed in combination with the plot output. Standard #' plot parameters are supported (\code{\link{plot.default}}) #' #' @return A \code{\linkS4class{RLum.Results}} object is returned a along with a plot (for #' \code{profiling = TRUE}). The output object contain the following slots: #' #' \bold{\code{@data}}\cr #' \tabular{lll}{ #' \bold{Object} \tab \bold{Type} \tab \bold{Description} \cr #' \code{lifetimes} \tab \code{\link{array}} or \code{\link{numeric}} \tab calculated lifetimes \cr #' \code{profiling_matrix} \tab \code{\link{matrix}} \tab profiling matrix used for the MC runs #' #' } #' #' \bold{\code{@info}}\cr #' \tabular{lll}{ #' \bold{Object} \tab \bold{Type} \tab \bold{Description} \cr #' \code{call} \tab \code{call} \tab the original function call #' } #' #' @note The profiling is currently based on resampling from a normal distribution, this #' distribution assumption might be, however, not valid for given E and s paramters. #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\link[graphics]{matplot}}, \code{\link[stats]{rnorm}}, \code{\link{get_RLum}}, #' #' @references Furetta, C., 2010. Handbook of Thermoluminescence, Second Edition. ed. #' World Scientific. #' #' @keywords datagen #' #' @examples #' #' ##EXAMPLE 1 #' ##calculation for two trap-depths with similar frequency factor for different temperatures #' E <- c(1.66, 1.70) #' s <- 1e+13 #' T <- 10:20 #' temp <- calc_ThermalLifetime( #' E = E, #' s = s, #' T = T, #' output_unit = "Ma" #' ) #' contour(x = E, y = T, z = temp$lifetimes[1,,], #' ylab = "Temperature [\u00B0C]", #' xlab = "Trap depth [eV]", #' main = "Thermal Lifetime Contour Plot" #' ) #' mtext(side = 3, "(values quoted in Ma)") #' #' ##EXAMPLE 2 #' ##profiling of thermal life time for E and s and their standard error #' E <- c(1.600, 0.003) #' s <- c(1e+13,1e+011) #' T <- 20 #' calc_ThermalLifetime( #' E = E, #' s = s, #' T = T, #' profiling = TRUE, #' output_unit = "Ma" #') #' #' @export calc_ThermalLifetime <- function( E, s, T = 20, output_unit = "Ma", profiling = FALSE, profiling_config = NULL, verbose = TRUE, plot = TRUE, ... ){ # Integrity ----------------------------------------------------------------------------------- if(missing(E) | missing(s)){ stop("[calc_ThermalLifetime()] 'E' or 's' or both are missing, but required.") } # Set variables ------------------------------------------------------------------------------- ##Boltzmann constant k <- 8.6173324e-05 #eV/K ##recalculate temparature T.K <- T + 273.15 #K ##SETTINGS FOR PROFILING ##profiling settings profiling_settings <- list( n = 1000, E.distribution = "norm", s.distribution = "norm" ) ##replace if set if(!is.null(profiling_config)){ profiling_settings <- modifyList(profiling_settings, profiling_config) } ##check for odd input values if (profiling_settings$n < 1000){ profiling_settings$n <- 1000 warning("[calc_ThermalLifetime()] minimum MC runs are 1000, parameter 'n' in profiling_config reset to 1000.") } # Calculation --------------------------------------------------------------------------------- ##set function for the calculation f <- function(E, s, T.K) { 1 / s * exp(E / (k * T.K)) } ##PROFILING if(profiling) { ##set profiling matrix profiling_matrix <- matrix(NA, ncol = 4, nrow = profiling_settings$n) ##fill matrix ##E profiling_matrix[, 1] <- if( profiling_settings$E.distribution == "norm"){ rnorm(profiling_settings$n, mean = E[1], sd = E[2]) }else{ stop("[calc_ThermalLifetime()] unknown distribution setting for E profiling") } ##s profiling_matrix[, 2] <- if (profiling_settings$s.distribution == "norm") { rnorm(profiling_settings$n, mean = s[1], sd = s[2]) } else{ stop("[calc_ThermalLifetime()] unknown distribution setting for s profiling") } ##T profiling_matrix[, 3] <- rep(T.K[1], each = profiling_settings$n) ##calulate lifetimes profiling_matrix[, 4] <- f(profiling_matrix[, 1], profiling_matrix[, 2], profiling_matrix[, 3]) ##reduce E and s vector on the first entry T <- T[1] ##set lifetimes lifetimes <- profiling_matrix[, 4] } else{ ##set empty profiling matrix profiling_matrix <- matrix() ##calculate lifetimes lifetimes <- vapply( X = T.K, FUN = function(i) { vapply( X = E, FUN = function(j) { f(E = j, s = s, T.K = i) }, FUN.VALUE = vector(mode = "numeric", length = length(s)) ) }, FUN.VALUE = matrix(numeric(), ncol = length(E), nrow = length(s)) ) ##transform to an arry in either case to have the same output if (!is(lifetimes, "array")) { lifetimes <- array(lifetimes, dim = c(length(s), length(E), length(T))) } ##set dimnames to make reading more clear dimnames(lifetimes) <- list(s, E, paste0("T = ", T, " \u00B0C")) } ##re-calculate lifetimes accourding to the chosen output unit temp.lifetimes <- switch ( output_unit, "s" = lifetimes, "min" = lifetimes / 60, "h" = lifetimes / 60 / 60, "d" = lifetimes / 60 / 60 / 24, "a" = lifetimes / 60 / 60 / 24 / 365, "ka" = lifetimes / 60 / 60 / 24 / 365 / 1000, "Ma" = lifetimes / 60 / 60 / 24 / 365 / 1000 / 1000 ) ##check for invalid values if(is.null(temp.lifetimes)){ output_unit <- "s" warning("[calc_ThermalLifetime()] 'output_unit' unknown, reset to 's'") }else{ lifetimes <- temp.lifetimes rm(temp.lifetimes) } # Terminal output ----------------------------------------------------------------------------- if(verbose){ cat("\n[calc_ThermalLifetime()]\n\n") if(profiling){ cat("\tprofiling = TRUE") cat("\n\t--------------------------\n") } cat(paste("\tmean:\t", format(mean(lifetimes), scientific = TRUE), output_unit)) cat(paste("\n\tsd:\t", format(sd(lifetimes), scientific = TRUE), output_unit)) cat(paste("\n\tmin:\t", format(min(lifetimes), scientific = TRUE), output_unit)) if(!profiling){ cat(paste0(" (@",T[which(lifetimes == min(lifetimes), arr.ind = TRUE)[3]], " \u00B0C)")) } cat(paste("\n\tmax:\t", format(max(lifetimes), scientific = TRUE), output_unit)) if(!profiling){ cat(paste0(" (@",T[which(lifetimes == max(lifetimes), arr.ind = TRUE)[3]], " \u00B0C)")) } cat("\n\t--------------------------") cat(paste0("\n\t(", length(lifetimes), " lifetimes calculated in total)")) } # Plotting ------------------------------------------------------------------------------------ if(plot & profiling){ ##plot settings plot.settings <- list( main = "Thermal Lifetime Density Plot", xlab = paste0("Thermal lifetime [",output_unit,"]"), ylab = "Density", xlim = NULL, ylim = NULL, log = "", lwd = 1, lty = 1, col = rgb(0, 0, 0, 0.25) ) ##modify on request plot.settings <- modifyList(plot.settings, list(...)) ##split data and calculate density ##set seq id_seq <- seq( from = 1, to = length(lifetimes), length.out = 200) ##calculate lifetime of the density lifetimes_density <- lapply(1:(length(id_seq) - 1), function(x) { density(lifetimes[id_seq[x]:id_seq[x+1]]) }) ##get x values lifetimes_density.x <- matrix(unlist(lapply(1:length(lifetimes_density), function(i){ lifetimes_density[[i]]$x })), nrow = length(lifetimes_density[[1]]$x)) ##get y values lifetimes_density.y <- matrix(unlist(lapply(1:length(lifetimes_density), function(i){ lifetimes_density[[i]]$y })), nrow = length(lifetimes_density[[1]]$y)) ##plot density curves graphics::matplot( lifetimes_density.x, lifetimes_density.y, type = "l", lwd = plot.settings$lwd, lty = plot.settings$lty, col = plot.settings$col, main = plot.settings$main, xlab = plot.settings$xlab, ylab = plot.settings$ylab, xlim = plot.settings$xlim, ylim = plot.settings$ylim, log = plot.settings$log, ) } # Return values ------------------------------------------------------------------------------- return(set_RLum( class = "RLum.Results", data = list(lifetimes = lifetimes, profiling_matrix = profiling_matrix), info = list(call = sys.call()) )) } Luminescence/R/calc_FiniteMixture.R0000644000176200001440000005377213125226556017013 0ustar liggesusers#' Apply the finite mixture model (FMM) after Galbraith (2005) to a given De #' distribution #' #' This function fits a k-component mixture to a De distribution with differing #' known standard errors. Parameters (doses and mixing proportions) are #' estimated by maximum likelihood assuming that the log dose estimates are #' from a mixture of normal distributions. #' #' This model uses the maximum likelihood and Bayesian Information Criterion #' (BIC) approaches. \cr\cr Indications of overfitting are: \cr\cr - increasing #' BIC \cr - repeated dose estimates \cr - covariance matrix not positive #' definite \cr - covariance matrix produces NaNs\cr - convergence problems #' \cr\cr \bold{Plot} \cr\cr If a vector (\code{c(k.min:k.max)}) is provided #' for \code{n.components} a plot is generated showing the the k components #' equivalent doses as normal distributions. By default \code{pdf.weight} is #' set to \code{FALSE}, so that the area under each normal distribution is #' always 1. If \code{TRUE}, the probability density functions are weighted by #' the components proportion for each iteration of k components, so the sum of #' areas of each component equals 1. While the density values are on the same #' scale when no weights are used, the y-axis are individually scaled if the #' probability density are weighted by the components proportion. \cr The #' standard deviation (sigma) of the normal distributions is by default #' determined by a common \code{sigmab} (see \code{pdf.sigma}). For #' \code{pdf.sigma = "se"} the standard error of each component is taken #' instead.\cr The stacked barplot shows the proportion of each component (in #' per cent) calculated by the FFM. The last plot shows the achieved BIC scores #' and maximum log-likelihood estimates for each iteration of k. #' #' @param data \code{\linkS4class{RLum.Results}} or \link{data.frame} #' (\bold{required}): for \code{data.frame}: two columns with De #' \code{(data[,1])} and De error \code{(values[,2])} #' @param sigmab \code{\link{numeric}} (\bold{required}): spread in De values #' given as a fraction (e.g. 0.2). This value represents the expected #' overdispersion in the data should the sample be well-bleached (Cunningham & #' Wallinga 2012, p. 100). #' @param n.components \code{\link{numeric}} (\bold{required}): number of #' components to be fitted. If a vector is provided (e.g. \code{c(2:8)}) the #' finite mixtures for 2, 3 ... 8 components are calculated and a plot and a #' statistical evaluation of the model performance (BIC score and maximum #' log-likelihood) is provided. #' @param grain.probability \code{\link{logical}} (with default): prints the #' estimated probabilities of which component each grain is in #' @param dose.scale \code{\link{numeric}}: manually set the scaling of the #' y-axis of the first plot with a vector in the form of \code{c(min,max)} #' @param pdf.weight \code{\link{logical}} (with default): weight the #' probability density functions by the components proportion (applies only #' when a vector is provided for \code{n.components}) #' @param pdf.sigma \code{\link{character}} (with default): if \code{"sigmab"} #' the components normal distributions are plotted with a common standard #' deviation (i.e. \code{sigmab}) as assumed by the FFM. Alternatively, #' \code{"se"} takes the standard error of each component for the sigma #' parameter of the normal distribution #' @param pdf.colors \code{\link{character}} (with default): color coding of #' the components in the the plot. Possible options are "gray", "colors" and #' "none" #' @param pdf.scale \code{\link{numeric}}: manually set the max density value #' for proper scaling of the x-axis of the first plot #' @param plot.proportions \code{\link{logical}} (with default): plot barplot #' showing the proportions of components #' @param plot \code{\link{logical}} (with default): plot output #' @param \dots further arguments to pass. See details for their usage. #' @return Returns a plot (optional) and terminal output. In addition an #' \code{\linkS4class{RLum.Results}} object is returned containing the #' following elements: #' #' \item{summary}{\link{data.frame} summary of all relevant model results.} #' \item{data}{\link{data.frame} original input data} \item{args}{\link{list} #' used arguments} \item{call}{\link{call} the function call} \item{mle}{ #' covariance matrices of the log likelhoods} \item{BIC}{ BIC score} #' \item{llik}{ maximum log likelihood} \item{grain.probability}{ probabilities #' of a grain belonging to a component} \item{components}{\link{matrix} #' estimates of the de, de error and proportion for each component} #' \item{single.comp}{\link{data.frame} single componente FFM estimate} #' #' If a vector for \code{n.components} is provided (e.g. \code{c(2:8)}), #' \code{mle} and \code{grain.probability} are lists containing matrices of the #' results for each iteration of the model. #' #' The output should be accessed using the function #' \code{\link{get_RLum}} #' @section Function version: 0.4 #' @author Christoph Burow, University of Cologne (Germany) \cr Based on a #' rewritten S script of Rex Galbraith, 2006. \cr #' @seealso \code{\link{calc_CentralDose}}, \code{\link{calc_CommonDose}}, #' \code{\link{calc_FuchsLang2001}}, \code{\link{calc_MinDose}} #' @references Galbraith, R.F. & Green, P.F., 1990. Estimating the component #' ages in a finite mixture. Nuclear Tracks and Radiation Measurements 17, #' 197-206. \cr\cr Galbraith, R.F. & Laslett, G.M., 1993. Statistical models #' for mixed fission track ages. Nuclear Tracks Radiation Measurements 4, #' 459-470.\cr\cr Galbraith, R.F. & Roberts, R.G., 2012. Statistical aspects of #' equivalent dose and error calculation and display in OSL dating: An overview #' and some recommendations. Quaternary Geochronology 11, 1-27.\cr\cr Roberts, #' R.G., Galbraith, R.F., Yoshida, H., Laslett, G.M. & Olley, J.M., 2000. #' Distinguishing dose populations in sediment mixtures: a test of single-grain #' optical dating procedures using mixtures of laboratory-dosed quartz. #' Radiation Measurements 32, 459-465.\cr\cr Galbraith, R.F., 2005. Statistics #' for Fission Track Analysis, Chapman & Hall/CRC, Boca Raton.\cr\cr #' \bold{Further reading}\cr\cr 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.\cr\cr Cunningham, A.C. & Wallinga, J., 2012. Realizing the #' potential of fluvial archives using robust OSL chronologies. Quaternary #' Geochronology 12, 98-106.\cr\cr 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.\cr\cr #' 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()) #' #' ## (1) apply the finite mixture model #' ## NOTE: the data set is not suitable for the finite mixture model, #' ## which is why a very small sigmab is necessary #' calc_FiniteMixture(ExampleData.DeValues$CA1, #' sigmab = 0.2, n.components = 2, #' grain.probability = TRUE) #' #' ## (2) repeat the finite mixture model for 2, 3 and 4 maximum number of fitted #' ## components and save results #' ## NOTE: The following example is computationally intensive. Please un-comment #' ## the following lines to make the example work. #' FMM<- calc_FiniteMixture(ExampleData.DeValues$CA1, #' sigmab = 0.2, n.components = c(2:4), #' pdf.weight = TRUE, dose.scale = c(0, 100)) #' #' ## show structure of the results #' FMM #' #' ## show the results on equivalent dose, standard error and proportion of #' ## fitted components #' get_RLum(object = FMM, data.object = "components") #' #' @export calc_FiniteMixture <- function( data, sigmab, n.components, grain.probability = FALSE, dose.scale, pdf.weight = TRUE, pdf.sigma = "sigmab", pdf.colors = "gray", pdf.scale, plot.proportions = TRUE, plot=TRUE, ... ){ ##============================================================================## ## CONSISTENCY CHECK OF INPUT DATA ##============================================================================## if(missing(data)==FALSE){ if(is(data, "data.frame") == FALSE & is(data,"RLum.Results") == FALSE){ stop("[calc_FiniteMixture] Error: 'data' object has to be of type 'data.frame' or 'RLum.Results'!") } else { if(is(data, "RLum.Results") == TRUE){ data <- get_RLum(data, "data") } } } try(colnames(data)<- c("ED","ED_Error"),silent=TRUE) if(colnames(data[1])!="ED"||colnames(data[2])!="ED_Error") { cat(paste("Columns must be named 'ED' and 'ED_Error'"), fill = FALSE) stop(domain=NA) } if(sigmab <0 | sigmab >1) { cat(paste("sigmab needs to be given as a fraction between", "0 and 1 (e.g. 0.2)"), fill = FALSE) stop(domain=NA) } if(any(n.components<2) == TRUE) { cat(paste("Atleast two components need to be fitted"), fill = FALSE) stop(domain=NA) } if(pdf.sigma!="se" ) { if(pdf.sigma!="sigmab") { cat(paste("Only 'se' or 'sigmab' allowed for the pdf.sigma argument"), fill = FALSE) stop(domain=NA) } } ##============================================================================## ## ... ARGUMENTS ##============================================================================## extraArgs <- list(...) ## console output if("verbose" %in% names(extraArgs)) { verbose<- extraArgs$verbose } else { verbose<- TRUE } # trace calculations if("trace" %in% names(extraArgs)) { trace<- extraArgs$trace } else { trace<- FALSE } # plot title if("main" %in% names(extraArgs)) { main<- extraArgs$main } else { main<- "Finite Mixture Model" } ##============================================================================## ## CALCULATIONS ##============================================================================## ## create storage variables if more than one k is provided if(length(n.components)>1) { # counter needed for various purposes cnt<- 1 # create summary matrix containing DE, standard error (se) and proportion # for each component comp.n<- matrix(data = NA, ncol = length(n.components), nrow = n.components[length(n.components)] * 3, byrow = TRUE) # create empty vector as storage for BIC and LLIK scores BIC.n<- vector(mode = "double") LLIK.n<- vector(mode = "double") # create empty vectors of type "lists" as storage for mle matrices and # grain probabilities vmat.n<- vector(mode = "list", length = length(n.components)) grain.probability.n<- vector(mode = "list", length = length(n.components)) } ## start actual calculation (loop) for each provided maximum components to ## be fitted. for(i in 1:length(n.components)) { k<- n.components[i] # calculate yu = log(ED), su = se(logED), n = number of grains yu<- log(data$ED) su<- data$ED_Error/data$ED n<- length(yu) # compute starting values fui<- matrix(0,n,k) pui<- matrix(0,n,k) nui<- matrix(0,n,k) pii<- rep(1/k,k) mu<- min(yu) + (max(yu)-min(yu))*(1:k)/(k+1) # remove the # in the line below to get alternative starting values # (useful to check that the algorithm converges to the same values) # mu<- quantile(yu,(1:k)/(k+1)) # compute maximum log likelihood estimates nit<- 499L wu<- 1/(sigmab^2 + su^2) rwu<- sqrt(wu) for(j in 1:nit){ for(i in 1:k) { fui[,i]<- rwu*exp(-0.5*wu*(yu-mu[i])^2) nui[,i]<- pii[i]*fui[,i] } pui<- nui/apply(nui,1,sum) mu<- apply(wu*yu*pui,2,sum)/apply(wu*pui,2,sum) pii<- apply(pui,2,mean) } # calculate the log likelihood and BIC llik<- sum( log( (1/sqrt(2*pi))*apply(nui,1,sum) )) bic<- -2*llik + (2*k - 1)*log(n) # calculate the covariance matrix and standard errors of the estimates # i.e., the dose estimtes in Gy and relative standard errors, and # the mixing proportions and standard errors. aui<- matrix(0,n,k) bui<- matrix(0,n,k) for(i in 1:k) { aui[,i]<- wu*(yu-mu[i]) bui[,i]<- -wu + (wu*(yu-mu[i]))^2 } delta<- diag(rep(1,k)) Au<- matrix(0,k-1,k-1) Bu<- matrix(0,k-1,k) Cu<- matrix(0,k,k) for(i in 1:(k-1)){ for(j in 1:(k-1)){ Au[i,j]<- sum( (pui[,i]/pii[i] - pui[,k]/pii[k])*(pui[,j]/pii[j] - pui[,k]/pii[k]) )}} for(i in 1:(k-1)){ for(j in 1:k){ Bu[i,j]<- sum( pui[,j]*aui[,j]*(pui[,i]/pii[i] - pui[,k]/pii[k] - delta[i,j]/pii[i] + delta[k,j]/pii[k] ) )}} for(i in 1:k){ for(j in 1:k){ Cu[i,j]<- sum( pui[,i]*pui[,j]*aui[,i]*aui[,j] - delta[i,j]*bui[,i]* pui[,i] ) }} invvmat<- rbind(cbind(Au,Bu),cbind(t(Bu),Cu)) vmat<- solve(invvmat, tol=.Machine$double.xmin) rek<- sqrt(sum(vmat[1:(k-1),1:(k-1)])) # calculate DE, relative standard error, standard error dose<- exp(mu) re<- sqrt(diag(vmat))[-c(1:(k-1))] sed<- dose*re estd<- rbind(dose,re,sed) # rename proportion prop<- pii # this calculates the proportional standard error of the proportion of grains # in the fitted components. However, the calculation is most likely erroneous. # sep<- c(sqrt(diag(vmat))[c(1:(k-1))],rek) # rename proportion estp<- prop # merge results to a data frame blk<- rep(" ",k) comp<- rbind(blk,round(estd,4),blk,round(estp,4)) comp<- data.frame(comp,row.names=c("","dose (Gy) ","rse(dose) ", "se(dose)(Gy)"," ","proportion ")) # label results data frame cp<- rep("comp",k) cn<- c(1:k) names(comp)<- paste(cp,cn,sep="") # calculate the log likelihood and BIC for a single component -- can # be useful to see if there is evidence of more than one component mu0<- sum(wu*yu)/sum(wu) fu0<- rwu*exp(-0.5*wu*(yu-mu0)^2) L0<- sum( log((1/sqrt(2*pi))*fu0 ) ) bic0<- -2*L0 + log(n) comp0<- round(c(exp(mu0),sigmab,L0,bic0),4) ## save results for k components in storage variables if(length(n.components)>1) { # vector of indices needed for finding the dose rows of the summary # matrix - position 1,4,7...n pos.n<- seq(from = 1, to = n.components[cnt]*3, by = 3) # save results of each iteration to summary matrix for(i in 1:n.components[cnt]) { comp.n[pos.n[i], cnt]<- round(dose[i], 2) #De comp.n[pos.n[i]+1, cnt]<- round(sed[i], 2) #SE comp.n[pos.n[i]+2, cnt]<- round(estp[i], 2) #Proportion } # save BIC and llik of each iteration to corresponding vector BIC.n[cnt]<- bic LLIK.n[cnt]<- llik # merge BIC and llik scores to a single data frame results.n<- rbind(BIC = round(BIC.n, 3), llik = round(LLIK.n, 3)) # save mle matrix and grain probabilities to corresponding vector vmat.n[[cnt]]<- vmat grain.probability.n[[cnt]]<- as.data.frame(pui) # increase counter by one for next iteration cnt<- cnt+1 }#EndOf::save intermediate results }##EndOf::calculation loop ##============================================================================## ## STATISTICAL CHECK ##============================================================================## if(length(n.components)>1) { ## Evaluate maximum log likelihood estimates LLIK.significant<- vector(mode = "logical") # check if llik is at least three times greater when adding a further # component for(i in 1:c(length(LLIK.n)-1)) { LLIK.significant[i]<- (LLIK.n[i+1]/LLIK.n[i])>3 } ## Find lowest BIC score BIC.lowest<- n.components[which.min(BIC.n)] } ##============================================================================## ## OUTPUT ##============================================================================## if(verbose==TRUE) { ## HEADER (always printed) cat("\n [calc_FiniteMixture]") ##---------------------------------------------------------------------------- ## OUTPUT WHEN ONLY ONE VALUE FOR n.components IS PROVIDED if(length(n.components) == 1) { # covariance matrix cat(paste("\n\n--- covariance matrix of mle's ---\n\n")) print(round(vmat,6)) # general information on sample and model performance cat(paste("\n----------- meta data ------------")) cat(paste("\n n: ",n)) cat(paste("\n sigmab: ",sigmab)) cat(paste("\n number of components: ",k)) cat(paste("\n llik: ",round(llik,4))) cat(paste("\n BIC: ",round(bic,3))) # fitted components cat(paste("\n\n----------- components -----------\n\n")) print(comp) # print (to 2 decimal places) the estimated probabilities of which component # each grain is in -- sometimes useful for diagnostic purposes if(grain.probability==TRUE) { cat(paste("\n-------- grain probability -------\n\n")) print(round(pui,2)) } # output for single component cat(paste("\n-------- single component --------")) cat(paste("\n mu: ", comp0[1])) cat(paste("\n sigmab: ", comp0[2])) cat(paste("\n llik: ", comp0[3])) cat(paste("\n BIC: ", comp0[4])) cat(paste("\n----------------------------------\n\n")) }#EndOf::Output for length(n.components) == 1 ##---------------------------------------------------------------------------- ## OUTPUT WHEN ONLY >1 VALUE FOR n.components IS PROVIDED if(length(n.components) > 1) { ## final labeling of component and BIC/llik matrices # create labels dose.lab<- paste("c", 1:n.components[length(n.components)],"_dose", sep="") se.lab<- paste("c", 1:n.components[length(n.components)],"_se", sep="") prop.lab<- paste("c", 1:n.components[length(n.components)],"_prop", sep="") # empty vector which stores the labeles in correct order (dose, se, prop) n.lab<- vector(mode = "expression", n.components[length(n.components)]*3) # loop to store the labels in correct order (dose, se, prop) cnt<- 1 for(i in pos.n) { n.lab[i]<- dose.lab[cnt] n.lab[i+1]<- se.lab[cnt] n.lab[i+2]<- prop.lab[cnt] cnt<- cnt+1 } # label columns and rows of summary matrix and BIC/LLIK data frame colnames(comp.n)<- n.components[1]:n.components[length(n.components)] rownames(comp.n)<- n.lab colnames(results.n)<- n.components[1]:n.components[length(n.components)] ## CONSOLE OUTPUT # general information on sample and model performance cat(paste("\n\n----------- meta data ------------")) cat(paste("\n n: ",n)) cat(paste("\n sigmab: ",sigmab)) cat(paste("\n number of components: ",n.components[1],"-", n.components[length(n.components)], sep="")) # output for single component cat(paste("\n\n-------- single component --------")) cat(paste("\n mu: ", comp0[1])) cat(paste("\n sigmab: ", comp0[2])) cat(paste("\n llik: ", comp0[3])) cat(paste("\n BIC: ", comp0[4])) # print component matrix cat(paste("\n\n----------- k components -----------\n")) print(comp.n, na.print="") # print BIC scores and LLIK estimates cat(paste("\n----------- statistical criteria -----------\n")) print(results.n) ## print evaluation of statistical criteria # lowest BIC score cat(paste("\n Lowest BIC score for k =", BIC.lowest)) # first significant increase in LLIK estimates if(any(LLIK.significant)!=TRUE) { cat(paste("\n No significant increase in maximum log", "likelihood estimates. \n")) } else { cat(paste("\n First significant increase in maximum log likelihood for", "k =", which(LLIK.significant==TRUE)[1], "\n\n")) } cat(paste("\n")) }#EndOf::Output for length(n.components) > 1 } ##============================================================================## ## RETURN VALUES ##============================================================================## # .@data$meta BIC<- data.frame(n.components=k, BIC=bic) llik<- data.frame(n.components=k, llik=llik) if(length(n.components)>1) { BIC.n<- data.frame(n.components=n.components, BIC=BIC.n) llik.n<- data.frame(n.components=n.components, llik=LLIK.n) } # .@data$single.comp single.comp<- data.frame(mu=comp0[1],sigmab=comp0[2], llik=comp0[3],BIC=comp0[4]) # .@data$components comp.re<- t(rbind(round(estd,4),round(estp,4))) colnames(comp.re)<- c("de","rel_de_err","de_err","proportion") comp.re<- comp.re[,-2] # remove the relative error column # .@data$grain.probability grain.probability<- round(pui, 2) summary<- data.frame(comp.re) call<- sys.call() args<- list(sigmab = sigmab, n.components = n.components) # create S4 object newRLumResults.calc_FiniteMixture <- set_RLum( class = "RLum.Results", data = list( summary=summary, data=data, args=args, call=call, mle=if(length(n.components)==1){vmat}else{vmat.n}, BIC=if(length(n.components)==1){BIC}else{BIC.n}, llik=if(length(n.components)==1){llik}else{llik.n}, grain.probability=if(length(n.components)==1){grain.probability}else{grain.probability.n}, components=if(length(n.components)==1){comp.re}else{comp.n}, single.comp=single.comp)) ##=========## ## PLOTTING if(plot==TRUE) { try(do.call(plot_RLum.Results, c(list(newRLumResults.calc_FiniteMixture), as.list(sys.call())[-c(1,2)]))) }#endif::plot # Return values invisible(newRLumResults.calc_FiniteMixture) } Luminescence/R/CW2pPMi.R0000644000176200001440000002171513125226556014406 0ustar liggesusers#' 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 \code{data.frame} consists of two columns: time (t) and #' count values (CW(t))\cr\cr #' #' \bold{Nomenclature}\cr\cr P = stimulation time (s)\cr 1/P = stimulation rate #' (1/s)\cr\cr #' #' \bold{Internal transformation steps}\cr\cr (1) log(CW-OSL) values\cr\cr (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 \code{min(t)} and \code{max(t)} #' produce \code{NA} values.\cr\cr (4) Select all values for t' < #' \code{min(t)}, i.e. values beyond the time resolution of t. Select the first #' two values of the transformed data set which contain no \code{NA} values and #' use these values for a linear fit using \code{\link{lm}}.\cr\cr (5) #' Extrapolate values for t' < \code{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.\cr\cr (6) Transform #' values using \deqn{pLM(t) = t^2/P^2*CW(t')} (7) Combine all values and #' truncate all values for t' > \code{max(t)}\cr\cr #' #' \emph{The number of values for t' < \code{min(t)} depends on the stimulation #' period \code{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 \code{P}, i.e. provide no value for #' \code{P}.} #' #' @param values \code{\linkS4class{RLum.Data.Curve}} or #' \code{\link{data.frame}} (\bold{required}): #' \code{\linkS4class{RLum.Data.Curve}} or \code{data.frame} with measured #' curve data of type stimulation time (t) (\code{values[,1]}) and measured #' counts (cts) (\code{values[,2]}) #' @param P \code{\link{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. \item{list(list("RLum.Data.Curve"))}{package #' \code{\linkS4class{RLum} object} with two additional info elements: #' \tabular{rl}{ $CW2pPMi.x.t \tab: transformed time values \cr $CW2pPMi.method #' \tab: used method for the production of the new data points }} #' #' \item{list(list("data.frame"))}{with four columns: \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 \code{P} is #' provided manually, not more than two points are extrapolated. #' @section Function version: 0.2.1 #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France)\cr\cr Based on comments and suggestions from:\cr Adrie J.J. Bos, #' Delft University of Technology, The Netherlands\cr #' @seealso \code{\link{CW2pLM}}, \code{\link{CW2pLMi}}, \code{\link{CW2pHMi}}, #' \code{\link{fit_LMCurve}}, \code{\linkS4class{RLum.Data.Curve}} #' @references Bos, A.J.J. & Wallinga, J., 2012. How to visualize quartz OSL #' signal components. Radiation Measurements, 47, 752-758.\cr #' #' \bold{Further Reading}\cr\cr 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 <- 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 <- CW2pLMi(values, P = 1/20) #' lines(values[1:length(values.t[,1]),1],CW2pLMi(values, P = 1/20)[,2], #' col = "red",lwd = 1.3) #' text(0.03,4500,"LM", col = "red", cex = .8) #' #' values.t <- CW2pHMi(values, delta = 40) #' lines(values[1:length(values.t[,1]),1], CW2pHMi(values, delta = 40)[,2], #' col = "black", lwd = 1.3) #' text(0.005,3000,"HM", cex = .8) #' #' values.t <- CW2pPMi(values, P = 1/10) #' lines(values[1:length(values.t[,1]),1], CW2pPMi(values, P = 1/10)[,2], #' col = "blue", lwd = 1.3) #' text(0.5,6500,"PM", col = "blue", cex = .8) #' #' #' @export CW2pPMi<- function( values, P ){ # (0) Integrity checks ------------------------------------------------------ ##(1) data.frame or RLum.Data.Curve object? if(is(values, "data.frame") == FALSE & is(values, "RLum.Data.Curve") == FALSE){ stop("[CW2pPMi()] 'values' object has to be of type 'data.frame' or 'RLum.Data.Curve'!", call. = FALSE) } ##(2) if the input object is an 'RLum.Data.Curve' object check for allowed curves if(is(values, "RLum.Data.Curve") == TRUE){ if(!grepl("OSL", values@recordType) & !grepl("IRSL", values@recordType)){ stop(paste("[CW2pPMi()] recordType ",values@recordType, " is not allowed for the transformation!", sep=""), call. = FALSE) }else{ 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<-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){warning("t' is beyond the time resolution. Only two data points have been extrapolated, the first ",temp.sel.id-3, " points have been 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) } } Luminescence/R/length_RLum.R0000644000176200001440000000206213125226556015437 0ustar liggesusers#' General accessor function for RLum S4 class objects #' #' Function calls object-specific get functions for RLum S4 class objects. #' #' The function provides a generalised access point for specific #' \code{\linkS4class{RLum}} objects.\cr Depending on the input object, the #' corresponding get function will be selected. Allowed arguments can be found #' in the documentations of the corresponding \code{\linkS4class{RLum}} class. #' #' @param object \code{\linkS4class{RLum}} (\bold{required}): S4 object of #' class \code{RLum} #' #' @return Return is the same as input objects as provided in the list. #' #' @section Function version: 0.1.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' @seealso #' \code{\linkS4class{RLum.Data.Curve}}, #' \code{\linkS4class{RLum.Data.Image}}, #' \code{\linkS4class{RLum.Data.Spectrum}}, #' \code{\linkS4class{RLum.Analysis}}, #' \code{\linkS4class{RLum.Results}} #' @keywords utilities #' #' #' @export setGeneric("length_RLum", function(object) { standardGeneric("length_RLum") }) Luminescence/R/plot_Histogram.R0000644000176200001440000007100513125226556016215 0ustar liggesusers#' 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.\cr\cr #' 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: \code{"n"} (number of samples), #' \code{"mean"} (mean De value), \code{"mean.weighted"} (error-weighted mean), #' \code{"median"} (median of the De values), \code{"sdrel"} (relative standard #' deviation in percent), \code{"sdrel.weighted"} (error-weighted relative #' standard deviation in percent), \code{"sdabs"} (absolute standard deviation), #' \code{"sdabs.weighted"} (error-weighted absolute standard deviation), #' \code{"serel"} (relative standard error), \code{"serel.weighted"} ( #' error-weighted relative standard error), \code{"seabs"} (absolute standard #' error), \code{"seabs.weighted"} (error-weighted absolute standard error), #' \code{"kurtosis"} (kurtosis) and \code{"skewness"} (skewness). #' #' @param data \code{\link{data.frame}} or \code{\linkS4class{RLum.Results}} #' object (required): for \code{data.frame}: two columns: De (\code{data[,1]}) #' and De error (\code{data[,2]}) #' #' @param na.rm \code{\link{logical}} (with default): excludes \code{NA} #' values from the data set prior to any further operations. #' #' @param mtext \code{\link{character}} (optional): further sample information #' (\link{mtext}). #' #' @param cex.global \code{\link{numeric}} (with default): global scaling #' factor. #' #' @param se \code{\link{logical}} (optional): plots standard error points over #' the histogram, default is \code{FALSE}. #' #' @param rug \code{\link{logical}} (optional): adds rugs to the histogram, #' default is \code{TRUE}. #' #' @param normal_curve \code{\link{logical}} (with default): adds a normal #' curve to the histogram. Mean and sd are calculated from the input data. More #' see details section. #' #' @param summary \code{\link{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 \code{\link{numeric}} or \code{\link{character}} (with #' default): optional position coordinates or keyword (e.g. \code{"topright"}) #' for the statistical summary. Alternatively, the keyword \code{"sub"} may be #' specified to place the summary below the plot header. However, this latter #' option in only possible if \code{mtext} is not used. In case of coordinate #' specification, y-coordinate refers to the right y-axis. #' #' @param colour \code{\link{numeric}} or \link{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\cr (e.g., \code{c("grey", #' "black", "red", "grey")}). #' #' @param interactive \code{\link{logical}} (with default): create an interactive #' histogram plot (requires the 'plotly' package) #' #' @param \dots further arguments and graphical parameters passed to #' \code{\link{plot}} or \code{\link{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. \code{ylab = c("axis label 1", "axis label 2")}). Y-axes limits #' (\code{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.4 #' @author Michael Dietze, GFZ Potsdam (Germany), \cr Sebastian Kreutzer, #' IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' @seealso \code{\link{hist}}, \code{\link{plot}} #' @examples #' #' ## load data #' data(ExampleData.DeValues, envir = environment()) #' ExampleData.DeValues <- #' 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)) #' #' #' @export plot_Histogram <- function( data, na.rm = TRUE, mtext, cex.global, se, rug, normal_curve, summary, summary.pos, colour, interactive = FALSE, ... ) { # Integrity tests --------------------------------------------------------- ## check/adjust input data structure if(is(data, "RLum.Results") == FALSE & is(data, "data.frame") == FALSE) { stop(paste("[plot_Histogram()] Input data format is neither", "'data.frame' nor 'RLum.Results'")) } else { if(is(data, "RLum.Results") == TRUE) { data <- get_RLum(data, "data")[,1:2] } } ## 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 } 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 } else { breaks.plot <- hist(x = data[,1], plot = FALSE)$breaks } if("xlim" %in% names(extraArgs)) { xlim.plot <- extraArgs$xlim } else { xlim.plot <- range(breaks.plot) } if("ylim" %in% names(extraArgs)) { ylim.plot <- extraArgs$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 == TRUE) {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 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)] }else{ De.denisty <- NA De.stats[i,6] <- NA } } 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 if(missing(summary.pos) == TRUE) { summary.pos <- c(xlim.plot[1], ylim.plot[2]) summary.adj <- c(0, 1) } else if(length(summary.pos) == 2) { summary.pos <- summary.pos summary.adj <- c(0, 1) } else if(summary.pos[1] == "topleft") { summary.pos <- c(xlim.plot[1], ylim.plot[2]) summary.adj <- c(0, 1) } else if(summary.pos[1] == "top") { summary.pos <- c(mean(xlim.plot), ylim.plot[2]) summary.adj <- c(0.5, 1) } else if(summary.pos[1] == "topright") { summary.pos <- c(xlim.plot[2], ylim.plot[2]) summary.adj <- c(1, 1) } else if(summary.pos[1] == "left") { summary.pos <- c(xlim.plot[1], mean(ylim.plot[1:2])) summary.adj <- c(0, 0.5) } else if(summary.pos[1] == "center") { summary.pos <- c(mean(xlim.plot), mean(ylim.plot[1:2])) summary.adj <- c(0.5, 0.5) } else if(summary.pos[1] == "right") { summary.pos <- c(xlim.plot[2], mean(ylim.plot[1:2])) summary.adj <- c(1, 0.5) }else if(summary.pos[1] == "bottomleft") { summary.pos <- c(xlim.plot[1], ylim.plot[1]) summary.adj <- c(0, 0) } else if(summary.pos[1] == "bottom") { summary.pos <- c(mean(xlim.plot), ylim.plot[1]) summary.adj <- c(0.5, 0) } else if(summary.pos[1] == "bottomright") { summary.pos <- c(xlim.plot[2], ylim.plot[1]) summary.adj <- c(1, 0) } ## 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() ## Optionally: Interactive Plot ---------------------------------------------- if (interactive) { if (!requireNamespace("plotly", quietly = TRUE)) stop("The interactive histogram requires the 'plotly' package. To install", " this package run 'install.packages('plotly')' in your R console.", call. = FALSE) ## 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, type = "scatter", mode = "lines", marker = 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, type = "scatter", mode = "markers", name = "Error", hoverinfo = "text", text = se.text, marker = list(color = "black"), yaxis = "y2") hist <- plotly::layout(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/plot_KDE.R0000644000176200001440000012044613125226556014667 0ustar liggesusers#' Plot kernel density estimate with statistics #' #' Plot a kernel density estimate of measurement values in combination with the #' actual values and associated error bars in ascending order. If enabled, the #' boxplot will show the usual distribution parameters (median as #' bold line, box delimited by the first and third quartile, whiskers defined #' by the extremes and outliers shown as points) and also the mean and #' standard deviation as pale bold line and pale polygon, respectively. #' #' The function allows passing several plot arguments, such as \code{main}, #' \code{xlab}, \code{cex}. However, as the figure is an overlay of two #' separate plots, \code{ylim} must be specified in the order: c(ymin_axis1, #' ymax_axis1, ymin_axis2, ymax_axis2) when using the cumulative values plot #' option. See examples for some further explanations. For details on the #' calculation of the bin-width (parameter \code{bw}) see #' \code{\link{density}}.\cr\cr #' 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: #' \itemize{ #' \item \code{"n"} (number of samples) #' \item \code{"mean"} (mean De value) #' \item \code{"median"} (median of the De values) #' \item \code{"sd.rel"} (relative standard deviation in percent) #' \item \code{"sd.abs"} (absolute standard deviation) #' \item \code{"se.rel"} (relative standard error) #' \item \code{"se.abs"} (absolute standard error) #' \item \code{"in.2s"} (percent of samples in 2-sigma range) #' \item \code{"kurtosis"} (kurtosis) #' \item \code{"skewness"} (skewness) #' } #' Note that the input data for the statistic summary is sent to the function #' \code{calc_Statistics()} depending on the log-option for the z-scale. If #' \code{"log.z = TRUE"}, the summary is based on the logarithms of the input #' data. If \code{"log.z = FALSE"} the linearly scaled data is used. \cr #' Note as well, that \code{"calc_Statistics()"} calculates these statistic #' measures in three different ways: \code{unweighted}, \code{weighted} and #' \code{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 \code{summary.method}.\cr\cr #' @param data \code{\link{data.frame}} or \code{\linkS4class{RLum.Results}} #' object (required): for \code{data.frame}: two columns: De #' (\code{values[,1]}) and De error (\code{values[,2]}). For plotting multiple #' data sets, these must be provided as \code{list} (e.g. \code{list(dataset1, #' dataset2)}). #' #' @param na.rm \code{\link{logical}} (with default): exclude NA values #' from the data set prior to any further operation. #' #' @param values.cumulative \code{\link{logical}} (with default): show #' cumulative individual data. #' #' @param order \code{\link{logical}}: Order data in ascending order. #' #' @param boxplot \code{\link{logical}} (with default): optionally show a #' boxplot (depicting median as thick central line, first and third quartile #' as box limits, whiskers denoting +/- 1.5 interquartile ranges and dots #' further outliers). #' #' @param rug \code{\link{logical}} (with default): optionally add rug. #' #' @param summary \code{\link{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 \code{\link{numeric}} or \code{\link{character}} (with #' default): optional position coordinates or keyword (e.g. \code{"topright"}) #' for the statistical summary. Alternatively, the keyword \code{"sub"} may be #' specified to place the summary below the plot header. However, this latter #' option in only possible if \code{mtext} is not used. In case of coordinate #' specification, y-coordinate refers to the right y-axis. #' #' @param summary.method \code{\link{character}} (with default): keyword #' indicating the method used to calculate the statistic summary. One out of #' \code{"unweighted"}, \code{"weighted"} and \code{"MCM"}. See #' \code{\link{calc_Statistics}} for details. #' #' @param bw \code{\link{character}} (with default): bin-width, chose a numeric #' value for manual setting. #' #' @param output \code{\link{logical}}: Optional output of numerical plot #' parameters. These can be useful to reproduce similar plots. Default is #' \code{TRUE}. #' #' @param \dots further arguments and graphical parameters passed to #' \code{\link{plot}}. #' #' @note The plot output is no 'probability density' plot (cf. the discussion #' of Berger and Galbraith in Ancient TL; see references)! #' #' @section Function version: 3.5.5 #' #' @author Michael Dietze, GFZ Potsdam (Germany),\cr Sebastian Kreutzer, #' IRAMAT-CRP2A, Universite Bordeaux Montaigne #' #' @seealso \code{\link{density}}, \code{\link{plot}} #' #' @examples #' #' ## read example data set #' data(ExampleData.DeValues, envir = environment()) #' ExampleData.DeValues <- #' Second2Gray(ExampleData.DeValues$BT998, c(0.0438,0.0019)) #' #' ## create plot straightforward #' plot_KDE(data = ExampleData.DeValues) #' #' ## create plot with logarithmic x-axis #' plot_KDE(data = ExampleData.DeValues, #' log = "x") #' #' ## create plot with user-defined labels and axes limits #' plot_KDE(data = ExampleData.DeValues, #' main = "Dose distribution", #' xlab = "Dose (s)", #' ylab = c("KDE estimate", "Cumulative dose value"), #' xlim = c(100, 250), #' ylim = c(0, 0.08, 0, 30)) #' #' ## create plot with boxplot option #' plot_KDE(data = ExampleData.DeValues, #' boxplot = TRUE) #' #' ## create plot with statistical summary below header #' plot_KDE(data = ExampleData.DeValues, #' summary = c("n", "median", "skewness", "in.2s")) #' #' ## create plot with statistical summary as legend #' plot_KDE(data = ExampleData.DeValues, #' summary = c("n", "mean", "sd.rel", "se.abs"), #' summary.pos = "topleft") #' #' ## split data set into sub-groups, one is manipulated, and merge again #' data.1 <- ExampleData.DeValues[1:15,] #' data.2 <- ExampleData.DeValues[16:25,] * 1.3 #' data.3 <- list(data.1, data.2) #' #' ## create plot with two subsets straightforward #' plot_KDE(data = data.3) #' #' ## create plot with two subsets and summary legend at user coordinates #' plot_KDE(data = data.3, #' summary = c("n", "median", "skewness"), #' summary.pos = c(110, 0.07), #' col = c("blue", "orange")) #' #' ## example of how to use the numerical output of the function #' ## return plot output to draw a thicker KDE line #' KDE_out <- plot_KDE(data = ExampleData.DeValues, #' output = TRUE) #' #' @export plot_KDE <- function( data, na.rm = TRUE, values.cumulative = TRUE, order = TRUE, boxplot = TRUE, rug = TRUE, summary, summary.pos, summary.method = "MCM", bw = "nrd0", output = TRUE, ... ) { ## check data and parameter consistency ------------------------------------- ## account for depreciated arguments if("centrality" %in% names(list(...))) { boxplot <- TRUE warning(paste("[plot_KDE()] Argument 'centrality' no longer supported. ", "Replaced by 'boxplot = TRUE'.")) } if("dispersion" %in% names(list(...))) { boxplot <- TRUE warning(paste("[plot_KDE()] Argument 'dispersion' no longer supported. ", "Replaced by 'boxplot = TRUE'.")) } if("polygon.col" %in% names(list(...))) { boxplot <- TRUE warning(paste("[plot_KDE()] Argument 'polygon.col' no longer supported. ", "Replaced by 'boxplot = TRUE'.")) } if("weights" %in% names(list(...))) { warning(paste("[plot_KDE()] Argument 'weights' no longer supported. ", "Weights are omitted.")) } ## Homogenise input data format if(is(data, "list") == FALSE) { data <- list(data) } ## check/adjust input data structure for(i in 1:length(data)) { if(is(data[[i]], "RLum.Results") == FALSE & is(data[[i]], "data.frame") == FALSE & is.numeric(data[[i]]) == FALSE) { stop(paste("[plot_KDE()] Input data format is neither", "'data.frame', 'RLum.Results' nor 'numeric'")) } else { if(is(data[[i]], "RLum.Results") == TRUE) { data[[i]] <- get_RLum(data[[i]], "data")[,1:2] } if(length(data[[i]]) < 2) { data[[i]] <- cbind(data[[i]], rep(NA, length(data[[i]]))) } } } ## check/set function parameters if(missing(summary) == TRUE) { summary <- "" } if(missing(summary.pos) == TRUE) { summary.pos <- "sub" } ## set mtext output if("mtext" %in% names(list(...))) { mtext <- list(...)$mtext } else { mtext <- "" } ## check/set layout definitions if("layout" %in% names(list(...))) { layout <- get_Layout(layout = list(...)$layout) } else { layout <- get_Layout(layout = "default") } ## data preparation steps --------------------------------------------------- ## optionally, count and exclude NA values and print result if(na.rm == TRUE) { for(i in 1:length(data)) { n.NA <- sum(is.na(data[[i]][,1])) if(n.NA == 1) { message(paste("1 NA value excluded from data set", i, ".")) } else if(n.NA > 1) { message(paste(n.NA, "NA values excluded from data set", i, ".")) } data[[i]] <- na.exclude(data[[i]]) } } ## optionally, order data set if(order == TRUE) { for(i in 1:length(data)) { data[[i]] <- data[[i]][order(data[[i]][,1]),] } } ## 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") De.density <- list(NA) ## loop through all data sets for(i in 1:length(data)) { statistics <- calc_Statistics(data[[i]])[[summary.method]] De.stats[i,1] <- statistics$n De.stats[i,2] <- statistics$mean De.stats[i,3] <- statistics$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 if(nrow(data[[i]]) >= 2){ De.density[[length(De.density) + 1]] <- density(data[[i]][,1], kernel = "gaussian", bw = bw) }else{ De.density[[length(De.density) + 1]] <- NA warning("[plot_KDE()] Less than 2 points provided, no density plotted.", call. = FALSE) } } ## remove dummy list element De.density[[1]] <- NULL ## create global data set De.global <- data[[1]][,1] De.error.global <- data[[1]][,2] De.density.range <- matrix(nrow = length(data), ncol = 4) for(i in 1:length(data)) { ##global De and De.error vector De.global <- c(De.global, data[[i]][,1]) De.error.global <- c(De.error.global, data[[i]][,2]) ## density range if(!all(is.na(De.density[[i]]))){ De.density.range[i,1] <- min(De.density[[i]]$x) De.density.range[i,2] <- max(De.density[[i]]$x) De.density.range[i,3] <- min(De.density[[i]]$y) De.density.range[i,4] <- max(De.density[[i]]$y) ## position of maximum KDE value De.stats[i,4] <- De.density[[i]]$x[which.max(De.density[[i]]$y)] }else{ De.density.range[i,1:4] <- NA De.stats[i,4] <- NA } } ## Get global range of densities De.density.range <- c(min(De.density.range[,1]), max(De.density.range[,2]), min(De.density.range[,3]), max(De.density.range[,4])) 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("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]][,1] > (De.stats[i,2] - 2 * De.stats[i,5]) & data[[i]][,1] < (De.stats[i,2] + 2 * De.stats[i,5])) / 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.rel" %in% summary[j] == TRUE, paste("rel. sd = ", round(De.stats[i,6], 2), " %", " | ", sep = ""), ""), ifelse("sd.abs" %in% summary[j] == TRUE, paste("abs. sd = ", round(De.stats[i,5], 2), " | ", sep = ""), ""), ifelse("se.rel" %in% summary[j] == TRUE, paste("rel. se = ", round(De.stats[i,8], 2), " %", " | ", sep = ""), ""), ifelse("se.abs" %in% summary[j] == TRUE, paste("abs. se = ", round(De.stats[i,7], 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]][,1] > (De.stats[i,2] - 2 * De.stats[i,5]) & data[[i]][,1] < (De.stats[i,2] + 2 * De.stats[i,5])) / 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 ## read out additional parameters ------------------------------------------- if("main" %in% names(list(...))) { main <- list(...)$main } else { main <- expression(bold(paste(D[e], " distribution"))) } if("sub" %in% names(list(...))) { sub <- list(...)$sub } else { sub <- NULL } if("xlab" %in% names(list(...))) { xlab <- list(...)$xlab } else { xlab <- expression(paste(D[e], " [Gy]")) } if("ylab" %in% names(list(...))) { ylab <- list(...)$ylab } else { ylab <- c("Density", "Cumulative frequency") } if("xlim" %in% names(list(...))) { xlim.plot <- list(...)$xlim } else { xlim.plot <- c(min(c(De.global - De.error.global), De.density.range[1], na.rm = TRUE), max(c(De.global + De.error.global), De.density.range[2], na.rm = TRUE)) } if("ylim" %in% names(list(...))) { ylim.plot <- list(...)$ylim } else { if(!is.na(De.density.range[1])){ ylim.plot <- c(De.density.range[3], De.density.range[4], 0, max(De.stats[,1])) }else{ ylim.plot <- c(0, max(De.stats[,1]), 0, max(De.stats[,1])) } } if("log" %in% names(list(...))) { log.option <- list(...)$log } else { log.option <- "" } if("col" %in% names(list(...))) { col.main <- list(...)$col col.xlab <- 1 col.ylab1 <- 1 col.ylab2 <- 1 col.xtck <- 1 col.ytck1 <- 1 col.ytck2 <- 1 col.box <- 1 col.mtext <- 1 col.stats <- list(...)$col col.kde.line <- list(...)$col col.kde.fill <- NA col.value.dot <- list(...)$col col.value.bar <- list(...)$col col.value.rug <- list(...)$col col.boxplot <- list(...)$col col.boxplot.line <- list(...)$col col.boxplot.fill <- NA col.mean.line <- adjustcolor(col = list(...)$col, alpha.f = 0.4) col.sd.bar <- adjustcolor(col = list(...)$col, alpha.f = 0.4) col.background <- NA } else { if(length(layout$kde$colour$main) == 1) { col.main <- c(layout$kde$colour$main, 2:length(data)) } else { col.main <- layout$kde$colour$main } if(length(layout$kde$colour$xlab) == 1) { col.xlab <- c(layout$kde$colour$xlab, 2:length(data)) } else { col.xlab <- layout$kde$colour$xlab } if(length(layout$kde$colour$ylab1) == 1) { col.ylab1 <- c(layout$kde$colour$ylab1, 2:length(data)) } else { col.ylab1 <- layout$kde$colour$ylab1 } if(length(layout$kde$colour$ylab2) == 1) { col.ylab2 <- c(layout$kde$colour$ylab2, 2:length(data)) } else { col.ylab2 <- layout$kde$colour$ylab2 } if(length(layout$kde$colour$xtck) == 1) { col.xtck <- c(layout$kde$colour$xtck, 2:length(data)) } else { col.xtck <- layout$kde$colour$xtck } if(length(layout$kde$colour$ytck1) == 1) { col.ytck1 <- c(layout$kde$colour$ytck1, 2:length(data)) } else { col.ytck1 <- layout$kde$colour$ytck1 } if(length(layout$kde$colour$ytck2) == 1) { col.ytck2 <- c(layout$kde$colour$ytck2, 2:length(data)) } else { col.ytck2 <- layout$kde$colour$ytck2 } if(length(layout$kde$colour$box) == 1) { col.box <- c(layout$kde$colour$box, 2:length(data)) } else { col.box <- layout$kde$colour$box } if(length(layout$kde$colour$mtext) == 1) { col.mtext <- c(layout$kde$colour$mtext, 2:length(data)) } else { col.mtext <- layout$kde$colour$mtext } if(length(layout$kde$colour$stats) == 1) { col.stats <- c(layout$kde$colour$stats, 2:length(data)) } else { col.stats <- layout$kde$colour$stats } if(length(layout$kde$colour$kde.line) == 1) { col.kde.line <- c(layout$kde$colour$kde.line, 2:length(data)) } else { col.kde.line <- layout$kde$colour$kde.line } if(length(layout$kde$colour$kde.fill) == 1) { col.kde.fill <- c(layout$kde$colour$kde.fill, 2:length(data)) } else { col.kde.fill <- layout$kde$colour$kde.fill } if(length(layout$kde$colour$value.dot) == 1) { col.value.dot <- c(layout$kde$colour$value.dot, 2:length(data)) } else { col.value.dot <- layout$kde$colour$value.dot } if(length(layout$kde$colour$value.bar) == 1) { col.value.bar <- c(layout$kde$colour$value.bar, 2:length(data)) } else { col.value.bar <- layout$kde$colour$value.bar } if(length(layout$kde$colour$value.rug) == 1) { col.value.rug <- c(layout$kde$colour$value.rug, 2:length(data)) } else { col.value.rug <- layout$kde$colour$value.rug } if(length(layout$kde$colour$boxplot.line) == 1) { col.boxplot.line <- c(layout$kde$colour$boxplot.line, 2:length(data)) } else { col.boxplot.line <- layout$kde$colour$boxplot.line } if(length(layout$kde$colour$boxplot.fill) == 1) { col.boxplot.fill <- c(layout$kde$colour$boxplot.fill, 2:length(data)) } else { col.boxplot.fill <- layout$kde$colour$boxplot.fill } if(length(layout$kde$colour$mean.line) == 1) { col.mean.line <- adjustcolor(col = 1:length(data), alpha.f = 0.4) } else { col.mean.line <- layout$kde$colour$mean.point } if(length(layout$kde$colour$sd.bar) == 1) { col.sd.bar <- c(layout$kde$colour$sd.bar, 2:length(data)) } else { col.sd.bar <- layout$kde$colour$sd.line } if(length(layout$kde$colour$background) == 1) { col.background <- c(layout$kde$colour$background, 2:length(data)) } else { col.background <- layout$kde$colour$background } } if("lty" %in% names(list(...))) { lty <- list(...)$lty } else { lty <- rep(1, length(data)) } if("lwd" %in% names(list(...))) { lwd <- list(...)$lwd } else { lwd <- rep(1, length(data)) } if("cex" %in% names(list(...))) { cex <- list(...)$cex } else { cex <- 1 } if("fun" %in% names(list(...))) { fun <- list(...)$fun } else { fun <- FALSE } ## convert keywords into summary placement coordinates if(missing(summary.pos) == TRUE) { summary.pos <- c(xlim.plot[1], ylim.plot[2]) summary.adj <- c(0, 1) } else if(length(summary.pos) == 2) { summary.pos <- summary.pos summary.adj <- c(0, 1) } else if(summary.pos[1] == "topleft") { summary.pos <- c(xlim.plot[1], ylim.plot[2]) summary.adj <- c(0, 1) } else if(summary.pos[1] == "top") { summary.pos <- c(mean(xlim.plot), ylim.plot[2]) summary.adj <- c(0.5, 1) } else if(summary.pos[1] == "topright") { summary.pos <- c(xlim.plot[2], ylim.plot[2]) summary.adj <- c(1, 1) } else if(summary.pos[1] == "left") { summary.pos <- c(xlim.plot[1], mean(ylim.plot[1:2])) summary.adj <- c(0, 0.5) } else if(summary.pos[1] == "center") { summary.pos <- c(mean(xlim.plot), mean(ylim.plot[1:2])) summary.adj <- c(0.5, 0.5) } else if(summary.pos[1] == "right") { summary.pos <- c(xlim.plot[2], mean(ylim.plot[1:2])) summary.adj <- c(1, 0.5) }else if(summary.pos[1] == "bottomleft") { summary.pos <- c(xlim.plot[1], ylim.plot[1]) summary.adj <- c(0, 0) } else if(summary.pos[1] == "bottom") { summary.pos <- c(mean(xlim.plot), ylim.plot[1]) summary.adj <- c(0.5, 0) } else if(summary.pos[1] == "bottomright") { summary.pos <- c(xlim.plot[2], ylim.plot[1]) summary.adj <- c(1, 0) } ## plot data sets ----------------------------------------------------------- ## setup plot area if(length(summary) >= 1 & summary.pos[1] == "sub") { toplines <- length(data) } else { toplines <- 1 } ## extract original plot parameters par(bg = layout$kde$colour$background) bg.original <- par()$bg par(mar = c(5, 5.5, 2.5 + toplines, 4.5), xpd = FALSE, cex = cex) if(layout$kde$dimension$figure.width != "auto" | layout$kde$dimension$figure.height != "auto") { par(mai = layout$kde$dimension$margin / 25.4, pin = c(layout$kde$dimension$figure.width / 25.4 - layout$kde$dimension$margin[2] / 25.4 - layout$kde$dimension$margin[4] / 25.4, layout$kde$dimension$figure.height / 25.4 - layout$kde$dimension$margin[1] / 25.4 - layout$kde$dimension$margin[3]/25.4)) } ## create empty plot to get plot dimensions plot(NA, xlim = xlim.plot, ylim = ylim.plot[1:2], sub = sub, log = log.option, axes = FALSE, ann = FALSE) ## get line height in xy coordinates l_height <- par()$cxy[2] ## optionally update ylim if(boxplot == TRUE) { ylim.plot[1] <- ylim.plot[1] - 1.4 * l_height } ## create empty plot to set adjusted plot dimensions par(new = TRUE) plot(NA, xlim = xlim.plot, ylim = ylim.plot[1:2], log = log.option, cex = cex, axes = FALSE, ann = FALSE) ## add box box(which = "plot", col = layout$kde$colour$box) ## add x-axis axis(side = 1, col = layout$kde$colour$xtck, col.axis = layout$kde$colour$xtck, labels = NA, tcl = -layout$kde$dimension$xtcl / 200, cex = cex) axis(side = 1, line = 2 * layout$kde$dimension$xtck.line / 100 - 2, lwd = 0, col = layout$kde$colour$xtck, family = layout$kde$font.type$xtck, font = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$kde$font.deco$xtck], col.axis = layout$kde$colour$xtck, cex.axis = layout$kde$font.size$xlab/12) mtext(text = xlab, side = 1, line = 3 * layout$kde$dimension$xlab.line / 100, col = layout$kde$colour$xlab, family = layout$kde$font.type$xlab, font = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$kde$font.deco$xlab], cex = cex * layout$kde$font.size$xlab/12) ## add left y-axis axis(side = 2, at = pretty(x = range(De.density.range[3:4])), col = layout$kde$colour$ytck1, col.axis = layout$kde$colour$ytck1, labels = NA, tcl = -layout$kde$dimension$ytck1 / 200, cex = cex) axis(side = 2, at = pretty(x = range(De.density.range[3:4])), line = 2 * layout$kde$dimension$ytck1.line / 100 - 2, lwd = 0, col = layout$kde$colour$ytck1, family = layout$kde$font.type$ytck1, font = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$kde$font.deco$ytck1], col.axis = layout$kde$colour$ytck1, cex.axis = layout$kde$font.size$ylab1/12) mtext(text = ylab[1], side = 2, line = 3 * layout$kde$dimension$ylab1.line / 100, col = layout$kde$colour$ylab1, family = layout$kde$font.type$ylab1, font = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$kde$font.deco$ylab1], cex = cex * layout$kde$font.size$ylab1/12) for(i in 1:length(data)) { if(!all(is.na(De.density[[i]]))){ polygon(x = c(par()$usr[1], De.density[[i]]$x, par()$usr[2]), y = c(min(De.density[[i]]$y),De.density[[i]]$y, min(De.density[[i]]$y)), border = col.kde.line[i], col = col.kde.fill[i], lty = lty[i], lwd = lwd[i]) } } ## add plot title cex.old <- par()$cex par(cex = layout$kde$font.size$main / 12) title(main = main, family = layout$kde$font.type$main, font = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$kde$font.deco$main], col.main = layout$kde$colour$main, line = (toplines + 1.2) * layout$kde$dimension$main / 100) par(cex = cex.old) ## optionally add mtext line if(mtext != "") { mtext(text = mtext, side = 3, line = 0.5, family = layout$kde$font.type$mtext, font = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$kde$font.deco$mtext], col.main = layout$kde$colour$mtext, cex = layout$kde$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 = col.stats[i], cex = layout$kde$font.size$stats / 12) } else { if(mtext == "") { mtext(side = 3, line = (toplines + 0.3 - i) * layout$kde$dimension$stats.line / 100, text = label.text[[i]], col = col.stats[i], cex = layout$kde$font.size$stats / 12) } } } if(values.cumulative == TRUE) { ## create empty overlay plot par(new = TRUE) # adjust plot options ## add empty plot, scaled to preliminary secondary plot content plot(x = NA, xlim = xlim.plot, ylim = ylim.plot[3:4], log = log.option, ann = FALSE, axes = FALSE ) ## get line height in xy coordinates l_height <- par()$cxy[2] ## optionally update ylim if(boxplot == TRUE) { ylim.plot[3] <- ylim.plot[3] - 1.4 * l_height } ## create correctly scaled empty overlay plot par(new = TRUE) # adjust plot options ## add empty plot, scaled to secondary plot content plot(NA, xlim = xlim.plot, ylim = ylim.plot[3:4], log = log.option, ann = FALSE, axes = FALSE) ## optionally add boxplot if(boxplot == TRUE) { ## add zero line abline(h = 0) ## get extended boxplot data boxplot.data <- list(NA) for(i in 1:length(data)) { boxplot.i <- boxplot(x = data[[i]][,1], plot = FALSE) boxplot.i$group <- mean(x = data[[i]][,1], na.rm = TRUE) boxplot.i$names <- sd(x = data[[i]][,1], na.rm = TRUE) boxplot.data[[length(boxplot.data) + 1]] <- boxplot.i } ## remove dummy list object boxplot.data[[1]] <- NULL ## get new line hights l_height <- par()$cxy[2] for(i in 1:length(data)) { # ## draw sd line # lines(x = c(boxplot.data[[i]]$group[1] - boxplot.data[[i]]$names[1], # boxplot.data[[i]]$group[1] + boxplot.data[[i]]$names[1]), # y = c(-5/8 * l_height, # -5/8 * l_height), # col = col.mean.line[i]) # # ## draw mean line # points(x = boxplot.data[[i]]$group[1], # y = -5/8 * l_height, # pch = 18, # col = col.mean.line[i]) ## draw median line lines(x = c(boxplot.data[[i]]$stats[3,1], boxplot.data[[i]]$stats[3,1]), y = c(-11/8 * l_height, -7/8 * l_height), lwd = 2, col = col.boxplot.line[i]) ## draw q25-q75-polygon polygon(x = c(boxplot.data[[i]]$stats[2,1], boxplot.data[[i]]$stats[2,1], boxplot.data[[i]]$stats[4,1], boxplot.data[[i]]$stats[4,1]), y = c(-11/8 * l_height, -7/8 * l_height, -7/8 * l_height, -11/8 * l_height), col = col.boxplot.fill[i], border = col.boxplot.line[i]) ## draw whiskers lines(x = c(boxplot.data[[i]]$stats[2,1], boxplot.data[[i]]$stats[1,1]), y = c(-9/8 * l_height, -9/8 * l_height), col = col.boxplot.line[i]) lines(x = c(boxplot.data[[i]]$stats[1,1], boxplot.data[[i]]$stats[1,1]), y = c(-10/8 * l_height, -8/8 * l_height), col = col.boxplot.line[i]) lines(x = c(boxplot.data[[i]]$stats[4,1], boxplot.data[[i]]$stats[5,1]), y = c(-9/8 * l_height, -9/8 * l_height), col = col.boxplot.line[i]) lines(x = c(boxplot.data[[i]]$stats[5,1], boxplot.data[[i]]$stats[5,1]), y = c(-10/8 * l_height, -8/8 * l_height), col = col.boxplot.line[i]) ## draw outliers points(x = boxplot.data[[i]]$out, y = rep(-9/8 * l_height, length(boxplot.data[[i]]$out)), col = col.boxplot.line[i], cex = cex * 0.8) } } ## optionally add rug if(rug == TRUE) { for(i in 1:length(data)) { for(j in 1:nrow(data[[i]])) { lines(x = c(data[[i]][j,1], data[[i]][j,1]), y = c(0, -2/8 * l_height), col = col.value.rug[i]) } } } ## add secondary y-axis ticks_axis <- pretty(x = c(1, ylim.plot[4])) ticks_axis <- ifelse(test = ticks_axis == 0, yes = NA, no = ticks_axis) ## add right y-axis axis(side = 4, at = ticks_axis, col = layout$kde$colour$ytck2, col.axis = layout$kde$colour$ytck2, labels = NA, tcl = -layout$kde$dimension$ytck2 / 200, cex = cex) axis(side = 4, at = ticks_axis, line = 2 * layout$kde$dimension$ytck2.line / 100 - 2, lwd = 0, col = layout$kde$colour$ytck2, family = layout$kde$font.type$ytck2, font = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$kde$font.deco$ytck2], col.axis = layout$kde$colour$ytck2, cex.axis = layout$kde$font.size$ylab2/12) mtext(text = ylab[2], side = 4, line = 3 * layout$kde$dimension$ylab2.line / 100, col = layout$kde$colour$ylab2, family = layout$kde$font.type$ylab2, font = (1:4)[c("plain", "bold", "italic", "bold italic") == layout$kde$font.deco$ylab2], cex = cex * layout$kde$font.size$ylab2/12) ## add De error bars for(i in 1:length(data)) { arrows(data[[i]][,1] - data[[i]][,2]/2, 1:length(data[[i]][,1]), data[[i]][,1] + data[[i]][,2]/2, 1:length(data[[i]][,1]), code = 3, angle = 90, length = 0.05, col = col.value.bar[i]) ## add De measurements points(data[[i]][,1], 1:De.stats[i,1], col = col.value.dot[i], pch = 20) } } ## add empty plot par(new = TRUE) plot(NA, ann = FALSE, axes = FALSE, xlim = xlim.plot, ylim = ylim.plot[1:2], log = log.option, cex = cex, cex.lab = cex, cex.main = cex, cex.axis = cex) ## FUN by R Luminescence Team if(fun==TRUE){sTeve()} if(output == TRUE) { return(invisible(list(De.stats = De.stats, summary.pos = summary.pos, De.density = De.density))) } } Luminescence/R/calc_SourceDoseRate.R0000644000176200001440000001762613125226556017104 0ustar liggesusers#' Calculation of the source dose rate via the date of measurement #' #' Calculating the dose rate of the irradiation source via the date of #' measurement based on: source calibration date, source dose rate, dose rate #' error. The function returns a data.frame that provides the input argument #' dose_rate for the function \code{\link{Second2Gray}}. #' #' Calculation of the source dose rate based on the time elapsed since the last #' calibration of the irradiation source. Decay parameters assume a Sr-90 beta #' source. \deqn{dose.rate = D0 * exp(-log(2) / T.1/2 * t)} \cr with: D0 <- #' calibration dose rate T.1/2 <- half-life of the source nuclide (here in #' days) t <- time since source calibration (in days) log(2) / T.1/2 equals the #' decay constant lambda #' #' Information on the date of measurements may be taken from the data's #' original .BIN file (using e.g., BINfile <- readBIN2R() and the slot #' BINfile@@METADATA$DATE) #' #' \bold{Allowed source types and related values} #' #' \tabular{rllll}{ \bold{#} \tab \bold{Source type} \tab \bold{T.1/2} \tab #' \bold{Reference} \cr [1] \tab Sr-90 \tab 28.90 y \tab NNDC, Brookhaven #' National Laboratory \cr [2] \tab Am-214 \tab 432.6 y \tab NNDC, Brookhaven #' National Laboratory \cr [3] \tab Co-60 \tab 5.274 y \tab NNDC, Brookhaven #' National Laboratory } #' #' @param measurement.date \code{\link{character}} or \code{\link{Date}} (\bold{required}): date of #' measurement in "YYYY-MM-DD". Exceptionally, if no value is provided, the date will be set to today. #' The argument can be provided as vector. #' #' @param calib.date \code{\link{character}} or \code{\link{Date}} (\bold{required}): date of source #' calibration in "YYYY-MM-DD" #' #' @param calib.dose.rate \code{\link{numeric}} (\bold{required}): dose rate at #' date of calibration in Gy/s or Gy/min #' #' @param calib.error \code{\link{numeric}} (\bold{required}): error of dose #' rate at date of calibration Gy/s or Gy/min #' #' @param source.type \code{\link{character}} (with default): specify #' irrdiation source (\code{Sr-90} or \code{Co-60} or \code{Am-214}), see #' details for further information #' #' @param dose.rate.unit \code{\link{character}} (with default): specify dose #' rate unit for input (\code{Gy/min} or \code{Gy/s}), the output is given in #' Gy/s as valid for the function \code{\link{Second2Gray}} #' #' @param predict \code{\link{integer}} (with default): option allowing to predicit the dose #' rate of the source over time in days set by the provided value. Starting date is the value set #' with \code{measurement.date}, e.g., \code{calc_SourceDoseRate(...,predict = 100)} calculates #' the source dose rate for the next 100 days. #' #' @return Returns an S4 object of type \code{\linkS4class{RLum.Results}}. #' Slot \code{data} contains a \code{\link{list}} with the following #' structure:\cr #' $ dose.rate (data.frame)\cr #' .. $ dose.rate \cr #' .. $ dose.rate.error \cr #' .. $ date (corresponding measurement date)\cr #' $ parameters (list) \cr #' .. $ source.type\cr #' .. $ halflife\cr #' .. $ dose.rate.unit\cr #' $ call (the original function call)\cr #' #' The output should be accessed using the function \code{\link{get_RLum}}.\cr #' A plot method of the output is provided via \code{\link{plot_RLum}} #' #' @note Please be careful when using the option \code{predict}, especially when a multiple set #' for \code{measurement.date} and \code{calib.date} is provided. For the source dose rate prediction #' the function takes the last value \code{measurement.date} and predicts from that the the source #' source dose rate for the number of days requested, #' means: the (multiple) orignal input will be replaced. However, the function #' do not change entries for the calibration dates, but mix them up. Therefore, #' it is not recommended to use this option when multiple calibration dates (\code{calib.date}) #' are provided. #' #' @section Function version: 0.3.0 #' #' @author Margret C. Fuchs, HZDR, Helmholtz-Institute Freiberg for Resource Technology (Germany), #' \cr Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' #' @seealso \code{\link{Second2Gray}}, \code{\link{get_RLum}}, \code{\link{plot_RLum}} #' #' @references NNDC, Brookhaven National Laboratory #' (\code{http://www.nndc.bnl.gov/}) #' #' @keywords manip #' #' @examples #' #' #' ##(1) Simple function usage #' ##Basic calculation of the dose rate for a specific date #' dose.rate <- calc_SourceDoseRate(measurement.date = "2012-01-27", #' calib.date = "2014-12-19", #' calib.dose.rate = 0.0438, #' calib.error = 0.0019) #' #' ##show results #' get_RLum(dose.rate) #' #' ##(2) Usage in combination with another function (e.g., Second2Gray() ) #' ## load example data #' data(ExampleData.DeValues, envir = environment()) #' #' ## use the calculated variable dose.rate as input argument #' ## to convert De(s) to De(Gy) #' Second2Gray(ExampleData.DeValues$BT998, dose.rate) #' #' ##(3) source rate prediction and plotting #' dose.rate <- calc_SourceDoseRate(measurement.date = "2012-01-27", #' calib.date = "2014-12-19", #' calib.dose.rate = 0.0438, #' calib.error = 0.0019, #' predict = 1000) #' plot_RLum(dose.rate) #' #' #'##(4) export output to a LaTeX table (example using the package 'xtable') #'\dontrun{ #' xtable::xtable(get_RLum(dose.rate)) #' #'} #' #' #' @export calc_SourceDoseRate <- function( measurement.date, calib.date, calib.dose.rate, calib.error, source.type = "Sr-90", dose.rate.unit = "Gy/s", predict = NULL ){ # -- transform input so far necessary ## measurement.data if (missing(measurement.date)) { measurement.date <- Sys.Date() warning("Argument 'measurement.date', automatically set to today.") }else{ if (is(measurement.date, "character")) { measurement.date <- as.Date(measurement.date) } } ##calibration date if(is(calib.date, "character")) { calib.date <- as.Date(calib.date) } # --- if predict is set if(!is.null(predict) && predict > 1){ measurement.date <- seq(tail(measurement.date), by = 1, length = predict) } # -- calc days since source calibration decay.days <- measurement.date - calib.date # -- calc dose rate of source at date of measurement, considering the chosen source-type ##set halflife halflife.years <- switch( source.type, "Sr-90" = 28.90, "Am-241" = 432.6, "Co-60" = 5.274) if(is.null(halflife.years)){ stop("[calc_SourceDoseRate()] Source type unknown or currently not supported!") } halflife.days <- halflife.years * 365 # N(t) = N(0)*e^((lambda * t) with lambda = log(2)/T1.2) measurement.dose.rate <- (calib.dose.rate) * exp((-log(2) / halflife.days) * as.numeric(decay.days)) measurement.dose.rate.error <- (calib.error) * exp((-log(2) / halflife.days) * as.numeric(decay.days)) # -- convert to input unit to [Gy/s] if(dose.rate.unit == "Gy/min"){ source.dose.rate <- measurement.dose.rate / 60 source.dose.rate.error <- source.dose.rate * (measurement.dose.rate.error / measurement.dose.rate) }else if(dose.rate.unit == "Gy/s"){ source.dose.rate <- measurement.dose.rate source.dose.rate.error <- measurement.dose.rate.error } # Output -------------------------------------------------------------------------------------- dose_rate <- data.frame( dose.rate = source.dose.rate, dose.rate.error = source.dose.rate.error, date = measurement.date, stringsAsFactors = TRUE ) temp.return <- set_RLum( class = "RLum.Results", data = list( dose.rate = dose_rate, parameters = list(source.type = source.type, halflife = halflife.years, dose.rate.unit = dose.rate.unit), call = sys.call() )) return(temp.return) } Luminescence/R/CW2pLMi.R0000644000176200001440000002267613125226556014411 0ustar liggesusers#' Transform a CW-OSL curve into a pLM-OSL curve via interpolation under linear #' modulation conditions #' #' Transforms a conventionally measured continuous-wave (CW) OSL-curve into a #' pseudo linearly modulated (pLM) curve under linear 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 \code{data.frame} consists of two columns: time (t) and #' count values (CW(t))\cr\cr #' #' \bold{Nomenclature}\cr\cr P = stimulation time (s)\cr 1/P = stimulation rate #' (1/s)\cr\cr #' #' \bold{Internal transformation steps}\cr\cr (1) log(CW-OSL) values\cr (2) #' Calculate t' which is the transformed time: \deqn{t' = 1/2*1/P*t^2} #' #' (3) Interpolate CW(t'), i.e. use the log(CW(t)) to obtain the count values #' for the transformed time (t'). Values beyond \code{min(t)} and \code{max(t)} #' produce \code{NA} values.\cr\cr (4) Select all values for t' < #' \code{min(t)}, i.e. values beyond the time resolution of t. Select the first #' two values of the transformed data set which contain no \code{NA} values and #' use these values for a linear fit using \code{\link{lm}}.\cr\cr (5) #' Extrapolate values for t' < \code{min(t)} based on the previously obtained #' fit parameters.\cr\cr (6) Transform values using \deqn{pLM(t) = t/P*CW(t')} #' (7) Combine values and truncate all values for t' > \code{max(t)}\cr\cr #' \emph{The number of values for t' < \code{min(t)} depends on the stimulation #' period (P) and therefore on the stimulation rate 1/P. To avoid the #' production of too many artificial data at the raising tail of the determined #' pLM curves it is recommended to use the automatic estimation routine for #' \code{P}, i.e. provide no own value for \code{P}.} #' #' @param values \code{\linkS4class{RLum.Data.Curve}} or #' \code{\link{data.frame}} (\bold{required}): #' \code{\linkS4class{RLum.Data.Curve}} or \code{data.frame} with measured #' curve data of type stimulation time (t) (\code{values[,1]}) and measured #' counts (cts) (\code{values[,2]}) #' @param P \code{\link{vector}} (optional): stimulation time 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. \item{list(list("RLum.Data.Curve"))}{package #' \code{\linkS4class{RLum}} object with two additional info elements:} #' \tabular{rl}{ $CW2pLMi.x.t \tab: transformed time values \cr $CW2pLMi.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 \code{P} is #' provided manually and more than two points are extrapolated, a warning #' message is returned. #' @section Function version: 0.3.1 #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux #' Montaigne\cr\cr Based on comments and suggestions from:\cr Adrie J.J. Bos, #' Delft University of Technology, The Netherlands\cr #' @seealso \code{\link{CW2pLM}}, \code{\link{CW2pHMi}}, \code{\link{CW2pPMi}}, #' \code{\link{fit_LMCurve}}, \code{\linkS4class{RLum.Data.Curve}} #' @references Bos, A.J.J. & Wallinga, J., 2012. How to visualize quartz OSL #' signal components. Radiation Measurements, 47, 752-758.\cr #' #' \bold{Further Reading}\cr\cr 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 <- CW2pLMi(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 <- CW2pLMi(values, P = 1/20) #' lines(values[1:length(values.t[,1]),1],CW2pLMi(values, P = 1/20)[,2], #' col = "red", lwd = 1.3) #' text(0.03,4500,"LM", col = "red", cex = .8) #' #' values.t <- CW2pHMi(values, delta = 40) #' lines(values[1:length(values.t[,1]),1],CW2pHMi(values, delta = 40)[,2], #' col = "black", lwd = 1.3) #' text(0.005,3000,"HM", cex =.8) #' #' values.t <- CW2pPMi(values, P = 1/10) #' lines(values[1:length(values.t[,1]),1], CW2pPMi(values, P = 1/10)[,2], #' col = "blue", lwd = 1.3) #' text(0.5,6500,"PM", col = "blue", cex = .8) #' #' #' @export CW2pLMi<- function( values, P ){ # (0) Integrity checks ------------------------------------------------------- ##(1) data.frame or RLum.Data.Curve object? if(is(values, "data.frame") == FALSE & is(values, "RLum.Data.Curve") == FALSE){ stop("[CW2pLMi()] 'values' object has to be of type 'data.frame' or 'RLum.Data.Curve'!", call. = FALSE) } ##(2) if the input object is an 'RLum.Data.Curve' object check for allowed curves if(is(values, "RLum.Data.Curve") == TRUE){ if(!grepl("OSL", values@recordType) & !grepl("IRSL", values@recordType)){ stop(paste("[CW2pLMi()] recordType ",values@recordType, " is not allowed for the transformation!", sep=""), call. = FALSE) }else{ temp.values <- as(values, "data.frame") } }else{ temp.values <- values } # (1) Transform values ------------------------------------------------------------------------ ##(a) log transformation of the CW-OSL count values CW_OSL.log<-log(temp.values[,2]) ##(b) 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<-10 P<-1/i t.transformed<-0.5*1/P*t^2 while(length(t.transformed[t.transformed2){ P<-1/i t.transformed<-0.5*1/P*t^2 i<-i+10 }#end::while }else{ if(P==0){stop("[CW2pLMi] P has to be > 0!", call. = FALSE)} t.transformed<-0.5*1/P*t^2 } #endif # (2) 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)) ##Problem: I rare cases the interpolation is not working properely and Inf or NaN values are returned ##Fetch row number of the invalid values invalid_values.id<-c(which(is.infinite(temp[,2]) | is.nan(temp[,2]))) ##interpolate between the lower and the upper value invalid_values.interpolated<-sapply(1:length(invalid_values.id), function(x) { mean(c(temp[invalid_values.id[x]-1,2],temp[invalid_values.id[x]+1,2])) } ) ##replace invalid values in data.frame with newly interpolated values if(length(invalid_values.id)>0){ temp[invalid_values.id,2]<-invalid_values.interpolated } # (3) 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<-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(length(y.i)>2){warning("t' is beyond the time resolution and more than two data points have been extrapolated!")} # (4) 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 pLM-OSL values pLM<-1/P*t*CW_OSL ##combine all values and exclude NA values temp.values <- data.frame(x=t,y.t=pLM,x.t=t.transformed, method=temp.method) temp.values <- na.exclude(temp.values) # (5) 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, CW2pLMi.x.t = list(temp.values$x.t), CW2pLMi.method = list(temp.values$method)) newRLumDataCurves.CW2pLMi <- set_RLum( class = "RLum.Data.Curve", recordType = values@recordType, data = as.matrix(temp.values[,1:2]), info = temp.info) return(newRLumDataCurves.CW2pLMi) } } Luminescence/R/calc_Kars2008.R0000644000176200001440000006607713125226556015433 0ustar liggesusers#' Apply the Kars et al. (2008) model #' #' A function to calculate the expected sample specific fraction of saturation #' following Kars et al. (2008) and Huntley (2006). #' #' This function applies the approach described in Kars et al. (2008), #' developed from the model of Huntley (2006) to calculate the expected sample #' specific fraction of saturation of a feldspar and also to calculate fading #' corrected age using this model. \eqn{\rho}' (\code{rhop}), the density of recombination #' centres, is a crucial parameter of this model and must be determined #' separately from a fading measurement. The function #' \code{\link[Luminescence]{analyse_FadingMeasurement}} #' can be used to calculate the sample specific \eqn{\rho}' value. #' #' Firstly the unfaded D0 value is determined through applying equation 5 of #' Kars et al. (2008) to the measured LxTx data as a function of irradiation #' time, and fitting the data with a single saturating exponential of the form: #' #' \deqn{LxTx(t*) = A x \phi(t*) x (1 - exp(-(t* / D0)))} #' #' where #' #' \deqn{\phi(t*) = exp(-\rho' x ln(1.8 x s_tilde x t*)^3)} #' #' after King et al. (2016) where \code{A} is a pre-exponential factor, #' \code{t*} (s) is the irradiation time, starting at the mid-point of #' irradiation (Auclair et al. 2003) and \code{s_tilde} (3x10^15 s^-1) is the athermal #' frequency factor after Huntley (2006). \cr #' #' Using fit parameters \code{A} and \code{D0}, the function then computes a natural dose #' response curve using the environmental dose rate, \code{D_dot} (Gy/s) and equations #' [1] and [2]. Computed LxTx values are then fitted using the #' \code{\link[Luminescence]{plot_GrowthCurve}} function and the laboratory measured LnTn can then #' be interpolated onto this curve to determine the fading corrected #' De value, from which the fading corrected age is calculated. \cr #' #' The \code{calc_Kars2008} function also calculates the level of saturation (n/N) #' and the field saturation (i.e. athermal steady state, (n/N)_SS) value for #' the sample under investigation using the sample specific \eqn{\rho}', #' unfaded \code{D0} and \code{D_dot} values, following the approach of Kars et al. (2008). \cr #' #' Uncertainties are reported at 1 sigma and are assumed to be normally #' distributed and are estimated using monte-carlo resamples (\code{n.MC = 1000}) #' of \eqn{\rho}' and LxTx during dose response curve fitting, and of \eqn{\rho}' #' in the derivation of (n/N) and (n/N)_SS. #' #' #' #' @param data \code{\link{data.frame}} (\bold{required}): #' A three column data frame with numeric values on a) dose (s), b) LxTx and and #' c) LxTx error. If a two column data frame is provided it is automatically #' assumed that errors on LxTx are missing. A third column will be attached #' with an arbitrary 5 \% error on the provided LxTx values.\cr #' Can also be a wide table, i.e. a \code{\link{data.frame}} with a number of colums divisible by 3 #' and where each triplet has the aforementioned column structure. #' #' @param rhop \code{\link{numeric}} (\bold{required}): #' The density of recombination centres (\eqn{\rho}') and its error (see Huntley 2006), #' given as numeric vector of length two. Note that \eqn{\rho}' must \bold{not} be #' provided as the common logarithm. Example: \code{rhop = c(2.92e-06, 4.93e-07)}. #' #' @param ddot \code{\link{numeric}} (\bold{required}): #' Environmental dose rate and its error, given as a numeric vector of length two. #' Expected unit: Gy/ka. Example: \code{ddot = c(3.7, 0.4)}. #' #' @param readerDdot \code{\linkS4class{RLum.Analysis}} (\bold{required}): #' Dose rate of the irradiation source of the OSL reader and its error, #' given as a numeric vector of length two. #' Expected unit: Gy/s. Example: \code{readerDdot = c(0.08, 0.01)}. #' #' @param normalise \code{\link{logical}} (with default): #' If \code{TRUE} (the default) all measured and computed LxTx values are #' normalised by the pre-exponential factor A (see details). #' #' @param summary \code{\link{logical}} (with default): #' If \code{TRUE} (the default) various parameters provided by the user #' and calculated by the model are added as text on the right-hand side of the #' plot. #' #' @param plot \code{\link{logical}} (with default): enables/disables plot output. #' #' @param ... further arguments passed to \code{\link{plot}} and #' \code{\link[Luminescence]{plot_GrowthCurve}}. #' #' @return An \code{\linkS4class{RLum.Results}} object is returned: #' #' Slot: \bold{@data}\cr #' #' \tabular{lll}{ #' \bold{OBJECT} \tab \bold{TYPE} \tab \bold{COMMENT}\cr #' \code{results} \tab \code{data.frame} \tab results of the of Kars et al. 2008 model \cr #' \code{data} \tab \code{data.frame} \tab original input data \cr #' \code{Ln} \tab \code{numeric} \tab Ln and its error \cr #' \code{LxTx_tables} \tab \code{list} \tab A \code{list} of \code{data.frames} #' containing data on dose, LxTx and LxTx error for each of the dose response curves. #' Note that these \bold{do not} contain the natural Ln signal, which is provided separately. \cr #' \code{fits} \tab \code{list} \tab A \code{list} of \code{nls} #' objects produced by \code{\link[minpack.lm]{nlsLM}} when fitting the dose response curves \cr #' } #' #' Slot: \bold{@info}\cr #' #' \tabular{lll}{ #' \bold{OBJECT} \tab \bold{TYPE} \tab \bold{COMMENT} \cr #' \code{call} \tab \code{call} \tab the original function call \cr #' \code{args} \tab \code{list} \tab arguments of the original function call \cr #' #' } #' #' @section Function version: 0.1.0 #' #' @author Georgina King, University of Cologne (Germany), \cr #' Christoph Burow, University of Cologne (Germany) #' #' @note \bold{This function has BETA status and should not be used for publication work!} #' #' @keywords datagen #' #' @references #' #' Kars, R.H., Wallinga, J., Cohen, K.M., 2008. A new approach towards anomalous fading correction for feldspar #' IRSL dating-tests on samples in field saturation. Radiation Measurements 43, 786-790. doi:10.1016/j.radmeas.2008.01.021 #' #' Huntley, D.J., 2006. An explanation of the power-law decay of luminescence. #' Journal of Physics: Condensed Matter 18, 1359-1365. doi:10.1088/0953-8984/18/4/020 #' #' King, G.E., Herman, F., Lambert, R., Valla, P.G., Guralnik, B., 2016. #' Multi-OSL-thermochronometry of feldspar. Quaternary Geochronology 33, 76-87. doi:10.1016/j.quageo.2016.01.004 #' #' #' \bold{Further reading} #' #' Morthekai, P., Jain, M., Cunha, P.P., Azevedo, J.M., Singhvi, A.K., 2011. An attempt to correct #' for the fading in million year old basaltic rocks. Geochronometria 38(3), 223-230. #' #' @examples #' #' ## Load example data (sample UNIL/NB123, see ?ExampleData.Fading) #' data("ExampleData.Fading", envir = environment()) #' #' ## (1) Set all relevant parameters #' # a. fading measurement data (IR50) #' fading_data <- ExampleData.Fading$fading.data$IR50 #' #' # b. Dose response curve data #' data <- ExampleData.Fading$equivalentDose.data$IR50 #' #' ## (2) Define required function parameters #' ddot <- c(7.00, 0.004) #' readerDdot <- c(0.134, 0.0067) #' #' # Analyse fading measurement and get an estimate of rho'. #' # Note that the RLum.Results object can be directly used for further processing. #' # The number of MC runs is reduced for this example #' rhop <- analyse_FadingMeasurement(fading_data, plot = TRUE, verbose = FALSE, n.MC = 10) #' #' ## (3) Apply the Kars et al. (2008) model to the data #' kars <- calc_Kars2008(data = data, #' rhop = rhop, #' ddot = ddot, #' readerDdot = readerDdot, #' n.MC = 50 #' ) #' @export calc_Kars2008 <- function(data, rhop, ddot, readerDdot, normalise = TRUE, summary = TRUE, plot = TRUE, ...) { ## Validate Input ------------------------------------------------------------ ## Check 'data' # must be a data frame if (is.data.frame(data)) { if (ncol(data) == 2) { warning("[calc_Kars2008] 'data' only had two columns. We assumed that", " the errors on LxTx were missing and automatically added a", " 5 % error.\n Please provide a data frame with three columns", " if you wish to use actually measured LxTx errors.", call. = FALSE) data[ ,3] <- data[ ,2] * 0.05 } # check number of columns if (ncol(data) %% 3 != 0) { stop("[calc_Kars2008] the number of columns in 'data' must be a multiple of 3.", call. = FALSE) } else { # extract all LxTx values data_tmp <- do.call(rbind, lapply(seq(1, ncol(data), 3), function(col) { setNames(data[2:nrow(data), col:c(col+2)], c("dose", "LxTx", "LxTxError")) }) ) # extract the LnTn values (assumed to be the first row) and calculate the column mean LnTn_tmp <- do.call(rbind, lapply(seq(1, ncol(data), 3), function(col) { setNames(data[1, col:c(col+2)], c("dose", "LxTx", "LxTxError")) }) ) # check whether the standard deviation of LnTn estimates or the largest # individual error is highest, and take the larger one LnTn_error_tmp <- max(c(sd(LnTn_tmp[ ,2]), mean(LnTn_tmp[ ,3])), na.rm = TRUE) LnTn_tmp <- colMeans(LnTn_tmp) # re-bind the data frame data <- rbind(LnTn_tmp, data_tmp) data[1, 3] <- LnTn_error_tmp data <- data[complete.cases(data), ] } } else { stop("\n[calc_Kars2008] 'data' must be a data frame.", call. = FALSE) } ## Check 'rhop' # check if numeric if (is.numeric(rhop)) { ### TODO: can be of length 2 if error if (length(rhop) != 2) stop("\n[calc_Kars2008] 'rhop' must be a vector of length two.", call. = FALSE) # alternatively, and RLum.Results object produced by analyse_FadingMeasurement() # can be provided } else if (inherits(rhop, "RLum.Results")) { if (rhop@originator == "analyse_FadingMeasurement") rhop <- c(rhop@data$rho_prime$MEAN, rhop@data$rho_prime$SD) else stop("\n[calc_Kars2008] Only an 'RLum.Results' object produced by", " 'analyse_FadingMeasurement()' is allowed as input for 'rhop'.", call. = FALSE) } ## Check ddot & readerDdot # check if numeric if (any(sapply(list(ddot, readerDdot), is.numeric) == FALSE)) stop("\n[calc_Kars2008] 'ddot' and 'readerDdot' must be numeric values.", call. = FALSE) # check if length == 2 if (any(sapply(list(ddot, readerDdot), function(x) length(x) == 2) == FALSE)) stop("\n[calc_Kars2008] 'ddot' and 'readerDdot' must be of length 2.", call. = FALSE) ## Settings ------------------------------------------------------------------ settings <- list(verbose = TRUE, n.MC = 1000) settings <- modifyList(settings, list(...)) ## Define Constants ---------------------------------------------------------- kb <- 8.617343 * 1e-5 alpha <- 1 Hs <- 3e15 # s value after Huntley (2006) Ma <- 1e6 * 365.25 * 24 * 3600 #in seconds ka <- Ma / 1000 #in seconds ## Define Functions ---------------------------------------------------------- # fit data using using Eq 5. from Kars et al (2008) employing # theta after King et al. (2016) theta <- function(t, r) { res <- exp(-r * log(1.8 * Hs * (0.5 * t))^3) res[!is.finite(res)] <- 0 return(res) } ## Preprocessing ------------------------------------------------------------- readerDdot.error <- readerDdot[2] readerDdot <- readerDdot[1] ddot.error <- ddot[2] ddot <- ddot[1] colnames(data) <- c("dose", "LxTx", "LxTx.Error") dosetime <- data[["dose"]][2:nrow(data)] LxTx.measured <- data[["LxTx"]][2:nrow(data)] LxTx.measured.error <- data[["LxTx.Error"]][2:nrow(data)] #Keep LnTn separate for derivation of measured fraction of saturation Ln <- data[["LxTx"]][1] Ln.error <- data[["LxTx.Error"]][1] ## (1) MEASURED ---------------------------------------------------- if (settings$verbose) cat("\n") data.tmp <- data data.tmp[ ,1] <- data.tmp[ ,1] * readerDdot GC.settings <- list(sample = data.tmp, mode = "interpolation", fit.method = "EXP", output.plot = plot, main = "Measured dose response curve", xlab = "Dose (Gy)", verbose = FALSE) GC.settings <- modifyList(GC.settings, list(...)) GC.settings$verbose <- FALSE GC.measured <- try(do.call(plot_GrowthCurve, GC.settings)) if (inherits(GC.measured, "try-error")) stop("\n[calc_Kars2008()] Unable to fit growth curve to data", call. = FALSE) # extract results and calculate age GC.results <- get_RLum(GC.measured) fit_measured <- GC.measured@data$Fit De.measured <- GC.results$De De.measured.error <- GC.results$De.Error D0.measured <- GC.results$D01 D0.measured.error <- GC.results$D01.ERROR Age.measured <- De.measured/ ddot Age.measured.error <- Age.measured * sqrt( (De.measured.error / De.measured)^2 + (readerDdot.error / readerDdot)^2 + (ddot.error / ddot)^2) ## (2) SIMULATED ----------------------------------------------------- # create MC samples rhop_MC <- rnorm(n = settings$n.MC, mean = rhop[1], sd = rhop[2]) # fitcoef <- do.call(rbind, sapply(rhop_MC, function(rhop_i) { fit_sim <- try(minpack.lm::nlsLM(LxTx.measured ~ a * theta(dosetime, rhop_i) * (1 - exp(-dosetime / D0)), start = list(a = max(LxTx.measured), D0 = D0.measured / readerDdot))) if (!inherits(fit_sim, "try-error")) coefs <- coef(fit_sim) else coefs <- c(NA, NA) return(coefs) }, simplify = FALSE)) # final fit for export fit_simulated <- minpack.lm::nlsLM(LxTx.measured ~ a * theta(dosetime, rhop[1]) * (1 - exp(-dosetime / D0)), start = list(a = max(LxTx.measured), D0 = D0.measured / readerDdot)) # scaling factor A <- mean(fitcoef[, 1], na.rm = TRUE) A.error <- sd(fitcoef[ ,1], na.rm = TRUE) # derive unfaded D0 D0.sim <- mean(fitcoef[ ,2], na.rm = TRUE) D0.sim.error <- sd(fitcoef[ ,2], na.rm = TRUE) D0.sim.Gy <- D0.sim * readerDdot D0.sim.Gy.error <- D0.sim.Gy * sqrt( (D0.sim.error / D0.sim)^2 + (readerDdot.error / readerDdot)^2) # calculate measured fraction of saturation nN <- Ln / A nN.error <- sqrt( (Ln.error / Ln)^2 + (A.error / A)^2) # compute a natural dose response curve following the assumptions of # Morthekai et al. 2011, Geochronometria natdosetime <- seq(0, 1e14, length.out = settings$n.MC) natdosetimeGray <- natdosetime * ddot / ka # calculate D0 dose in seconds computedD0 <- (fitcoef[ ,2] * readerDdot) / (ddot / ka) # compute natural dose response curve LxTx.sim <- A * theta(natdosetime, rhop[1]) * (1 - exp(-natdosetime / mean(computedD0, na.rm = TRUE))) # calculate Age if (Ln < max(LxTx.sim)) { positive <- which(diff(LxTx.sim) > 0) data.unfaded <- data.frame(dose = c(0, natdosetime[positive] * ddot / ka), LxTx = c(Ln, LxTx.sim[positive]), LxTx.error = c(Ln.error, LxTx.sim[positive] * A.error/A)) data.unfaded$LxTx.error[2] <- 0.0001 GC.settings <- list(sample = data.unfaded, mode = "interpolation", fit.method = "EXP", output.plot = TRUE, verbose = FALSE, main = "Simulated dose response curve", xlab = "Dose (Gy)") GC.settings <- modifyList(GC.settings, list(...)) GC.settings$verbose <- FALSE suppressWarnings( GC.unfaded <- try(do.call(plot_GrowthCurve, GC.settings)) ) if (!inherits(GC.unfaded, "try-error")) { GC.unfaded.results <- get_RLum(GC.unfaded) De.sim <- GC.unfaded.results$De De.error.sim <- GC.unfaded.results$De.Error Age.sim <- De.sim / ddot Age.sim.error <- Age.sim * sqrt( ( De.error.sim/ De.sim)^2 + (readerDdot.error / readerDdot)^2 + (ddot.error / ddot)^2) } else { De.sim <- De.error.sim <- Age.sim <- Age.sim.error <- NA } } else { De.sim <- De.error.sim <- Age.sim <- Age.sim.error <- NA } if (Ln > max(LxTx.sim) * 1.1) warning("[calc_Kars2008] Ln is >10 % larger than the maximum computed LxTx value.", " The De and age should be regarded as infinite estimates.", call. = FALSE) # Estimate nN_(steady state) by Monte Carlo Simulation ddot_MC <- rnorm(n = settings$n.MC, mean = ddot, sd = ddot.error) UFD0_MC <- rnorm(n = settings$n.MC, mean = D0.sim.Gy, sd = D0.sim.Gy.error) nN_SS_MC <- mapply(function(rhop_i, ddot_i, UFD0_i) { rprime <- seq(0.01, 5, length.out = settings$n.MC) rho <- 3 * alpha^3 * rhop_i / (4 * pi) r <- rprime / (4 * pi * rho / 3)^(1 / 3) pr <- 3 * rprime^2 * exp(-rprime^3) tau <- ((1 / Hs) * exp(1)^(alpha * r)) / ka Ls <- 1 / (1 + UFD0_i / (ddot_i * tau)) Lstrap <- (pr * Ls) / sum(pr) # field saturation nN_SS_i <- sum(Lstrap) return(nN_SS_i) }, rhop_MC, ddot_MC, UFD0_MC, SIMPLIFY = TRUE) nN_SS <- mean(nN_SS_MC, na.rm = TRUE) nN_SS.error <- sd(nN_SS_MC, na.rm = TRUE) ## (3) UNFADED --------------------------------------------------------------- LxTx.unfaded <- LxTx.measured / theta(dosetime, rhop[1]) LxTx.unfaded[is.nan((LxTx.unfaded))] <- 0 LxTx.unfaded[is.infinite(LxTx.unfaded)] <- 0 dosetimeGray <- dosetime * readerDdot fit_unfaded <- minpack.lm::nlsLM(LxTx.unfaded ~ a * (1 - exp(-dosetimeGray / D0)), start = list(a = max(LxTx.unfaded), D0 = D0.measured / readerDdot)) D0.unfaded <- coef(fit_unfaded)[["D0"]] D0.error.unfaded <- summary(fit_unfaded)$coefficients["D0", "Std. Error"] ## Create LxTx tables -------------------------------------------------------- # normalise by A (saturation point of the un-faded curve) if (normalise) { LxTx.measured.relErr <- (LxTx.measured.error / LxTx.measured) LxTx.measured <- LxTx.measured / A LxTx.measured.error <- LxTx.measured * LxTx.measured.relErr LxTx.sim <- LxTx.sim / A LxTx.unfaded <- LxTx.unfaded / A Ln.relErr <- Ln.error / Ln Ln <- Ln / A Ln.error <- Ln * Ln.relErr } # combine all computed LxTx values LxTx_measured <- data.frame( dose = dosetimeGray, LxTx = LxTx.measured, LxTx.Error = LxTx.measured.error) LxTx_simulated <- data.frame( dose = natdosetimeGray, LxTx = LxTx.sim, LxTx.Error = LxTx.sim * A.error / A) LxTx_unfaded <- data.frame( dose = dosetimeGray, LxTx = LxTx.unfaded, LxTx.Error = LxTx.unfaded * A.error / A) ## Plot settings ------------------------------------------------------------- plot.settings <- list(main = "Dose response curves", xlab = "Dose (Gy)", ylab = ifelse(normalise, "normalised LxTx (a.u.)", "LxTx (a.u.)") ) plot.settings <- modifyList(plot.settings, list(...)) ## Plotting ------------------------------------------------------------------ if (plot) { # set plot parameters par.old.full <- par(no.readonly = TRUE) # set graphical parameters par(mar = c(5, 4, 4, 4), cex = 0.8) if (summary) par(oma = c(0, 3, 0, 9)) else par(oma = c(0, 9, 0, 9)) # Find a good estimate of the x-axis limits xlim <- range(pretty(dosetimeGray)) if (De.sim > xlim[2]) xlim <- range(pretty(c(min(dosetimeGray), De.sim))) # Create figure after Kars et al. (2008) contrasting the dose response curves plot(dosetimeGray, LxTx_measured$LxTx, main = plot.settings$main, xlab = plot.settings$xlab, ylab = plot.settings$ylab, pch = 16, ylim = c(0, max(do.call(rbind, list(LxTx_measured, LxTx_unfaded))[["LxTx"]])), xlim = xlim ) # LxTx error bars segments(x0 = dosetimeGray, y0 = LxTx_measured$LxTx + LxTx_measured$LxTx.Error, x1 = dosetimeGray, y1 = LxTx_measured$LxTx - LxTx_measured$LxTx.Error, col = "black") # re-calculate the measured dose response curve in Gray xRange <- range(pretty(dosetimeGray)) xNew <- seq(xRange[1], xRange[2], length.out = 200) yNew <- predict(GC.measured@data$Fit, list(x = xNew)) if (normalise) yNew <- yNew / A # add line lines(xNew, yNew, col = "black") # add error polygon polygon(x = c(natdosetimeGray, rev(natdosetimeGray)), y = c(LxTx_simulated$LxTx + LxTx_simulated$LxTx.Error, rev(LxTx_simulated$LxTx - LxTx_simulated$LxTx.Error)), col = adjustcolor("grey", alpha.f = 0.5), border = NA) # computed LxTx values points(natdosetimeGray, LxTx_simulated$LxTx, type = "l", lty = 2) # Ln and DE as points points(x = c(0, De.measured), y = c(Ln, Ln), col = "red", pch = c(1, 16)) # Ln error bar segments(x0 = 0, y0 = Ln - Ln.error, x1 = 0, y1 = Ln + Ln.error, col = "red") # Ln as a horizontal line lines(x = c(0, max(c(De.measured, De.sim), na.rm = TRUE)), y = c(Ln, Ln), col = "black", lty = 3) # vertical line of measured DE lines(x = c(De.measured, De.measured), y = c(0, Ln), col = "black", lty = 3) # add legends legend("bottomright", legend = c("Unfaded DRC", "Measured DRC", "Simulated natural DRC"), lty = c(5, 1, 2), bty = "n") # add vertical line of simulated De if (!is.na(De.sim)) { lines(x = c(De.sim, De.sim), y = c(0, Ln), col = "black", lty = 3) points(x = De.sim, y = Ln, col = "red" , pch = 16) } # add unfaded DRC xRange <- range(pretty(dosetimeGray)) xNew <- seq(xRange[1], xRange[2], length.out = 200) yNew <- predict(fit_unfaded, list(dosetimeGray = xNew)) if (normalise) yNew <- yNew / A lines(xNew, yNew, col = "black", lty = 5) points(x = dosetimeGray, y = LxTx_unfaded$LxTx, col = "black") # LxTx error bars segments(x0 = dosetimeGray, y0 = LxTx_unfaded$LxTx + LxTx_unfaded$LxTx.Error, x1 = dosetimeGray, y1 = LxTx_unfaded$LxTx - LxTx_unfaded$LxTx.Error, col = "black") # add text if (summary) { # define labels as expressions labels.text <- list( bquote(dot(D) == .(round(ddot, 2)) %+-% .(round(ddot.error, 2)) ~ frac(Gy, ka)), bquote(dot(D)["Reader"] == .(round(readerDdot, 3)) %+-% .(round(readerDdot.error, 3)) ~ frac(Gy, s)), bquote(log[10]~(rho~"'") == .(round(log10(rhop[1]), 2)) %+-% .(round(rhop[2] / (rhop[1] * log(10, base = exp(1))), 2)) ), bquote(bgroup("(", frac(n, N), ")") == .(round(nN, 2)) %+-% .(round(nN.error, 2)) ), bquote(bgroup("(", frac(n, N), ")")[SS] == .(round(nN_SS, 2)) %+-% .(round(nN_SS.error, 2)) ), bquote(D["E,sim"] == .(round(De.sim, 2)) %+-% .(round(De.error.sim, 2)) ~ Gy), bquote(D["0,sim"] == .(round(D0.sim.Gy, 2)) %+-% .(round(D0.sim.Gy.error, 2)) ~ Gy), bquote(Age["sim"] == .(round(Age.sim, 2)) %+-% .(round(Age.sim.error, 2)) ~ ka) ) # each of the labels is positioned at 1/10 of the availalbe y-axis space ypos <- seq(range(axTicks(2))[2], range(axTicks(2))[1], length.out = 10)[1:length(labels.text)] # allow overprinting par(xpd = NA) # add labels iteratively mapply(function(label, pos) { text(x = max(axTicks(1)) * 1.15, y = pos, labels = label, pos = 4) }, labels.text, ypos) } # recover plot parameters on.exit(par(par.old.full)) } ## Results ------------------------------------------------------------------- results <- set_RLum( class = "RLum.Results", data = list( results = data.frame("nN" = nN, "nN.error" = nN.error, "nN_SS" = nN_SS, "nN_SS.error" = nN_SS.error, "Meas_De" = De.measured, "Meas_De.error" = De.measured.error, "Meas_D0" = D0.measured, "Meas_D0.error" = D0.measured.error, "Meas_Age" = Age.measured, "Meas_Age.error" = Age.measured.error, "Sim_De" = De.sim, "Sim_De.error" = De.error.sim, "Sim_D0" = D0.sim.Gy, "Sim_D0.error" = D0.sim.Gy.error, "Sim_Age" = Age.sim, "Sim_Age.error" = Age.sim.error, "Unfaded_D0" = D0.unfaded, "Unfaded_D0.error" = D0.error.unfaded, row.names = NULL), data = data, Ln = c(Ln, Ln.error), LxTx_tables = list( simulated = LxTx_simulated, measured = LxTx_measured, unfaded = LxTx_unfaded), fits = list( simulated = fit_simulated, measured = fit_measured, unfaded = fit_unfaded ) ), info = list(call = sys.call(), args = as.list(sys.call())[-1]) ) ## Console output ------------------------------------------------------------ if (settings$verbose) { cat("\n[calc_Kars2008()]\n") cat("\n -------------------------------") cat("\n (n/N) [-]:\t", round(results@data$results$nN, 2), "\u00b1", round(results@data$results$nN.error, 2)) cat("\n (n/N)_SS [-]:\t", round(results@data$results$nN_SS, 2),"\u00b1", round(results@data$results$nN_SS.error, 2)) cat("\n\n ---------- Measured -----------") cat("\n DE [Gy]:\t", round(results@data$results$Meas_De, 2), "\u00b1", round(results@data$results$Meas_De.error, 2)) cat("\n D0 [Gy]:\t", round(results@data$results$Meas_D0, 2), "\u00b1", round(results@data$results$Meas_D0.error, 2)) cat("\n Age [ka]:\t", round(results@data$results$Meas_Age, 2), "\u00b1", round(results@data$results$Meas_Age.error, 2)) cat("\n\n ---------- Simulated ----------") cat("\n DE [Gy]:\t", round(results@data$results$Sim_De, 2), "\u00b1", round(results@data$results$Sim_De.error, 2)) cat("\n D0 [Gy]:\t", round(results@data$results$Sim_D0, 2), "\u00b1", round(results@data$results$Sim_D0.error, 2)) cat("\n Age [ka]:\t", round(results@data$results$Sim_Age, 2), "\u00b1", round(results@data$results$Sim_Age.error, 2)) cat("\n\n ---------- Un-faded -----------") cat("\n D0 [Gy]:\t", round(results@data$results$Unfaded_D0, 2), "\u00b1", round(results@data$results$Unfaded_D0.error, 2)) cat("\n -------------------------------\n\n") } ## Return value -------------------------------------------------------------- return(results) } Luminescence/R/get_rightAnswer.R0000644000176200001440000000060413125226556016353 0ustar liggesusers#' Function to get the right answer #' #' This function returns just the right answer #' #' @param ... you can pass an infinite number of further arguments #' @return Returns the right answer #' @section Function version: 0.1.0 #' @author inspired by R.G. #' @examples #' #' ## you really want to know? #' get_rightAnswer() #' #' @export get_rightAnswer <- function(...) { return(46) } Luminescence/R/RLum.Data.Spectrum-class.R0000644000176200001440000002466413125226556017666 0ustar liggesusers#' @include get_RLum.R set_RLum.R names_RLum.R NULL #' Class \code{"RLum.Data.Spectrum"} #' #' Class for representing luminescence spectra data (TL/OSL/RF). #' #' @name RLum.Data.Spectrum-class #' #' @docType class #' #' @slot recordType Object of class \code{\link{character}} containing the type of the curve (e.g. "TL" or "OSL") #' #' @slot curveType Object of class \code{\link{character}} containing curve type, allowed values #' are measured or predefined #' #' @slot data Object of class \code{\link{matrix}} containing spectrum (count) values. #' Row labels indicate wavelength/pixel values, column labels are temperature or time values. #' #' @slot info Object of class \code{\link{list}} containing further meta information objects #' #' @note The class should only contain data for a single spectra data set. For #' additional elements the slot \code{info} can be used. Objects from this class are automatically #' created by, e.g., \code{\link{read_XSYG2R}} #' #' @section Objects from the Class: Objects can be created by calls of the form #' \code{set_RLum("RLum.Data.Spectrum", ...)}. #' #' @section Class version: 0.4.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\linkS4class{RLum}}, \code{\linkS4class{RLum.Data}}, #' \code{\link{plot_RLum}} #' #' @keywords classes #' #' @examples #' #' showClass("RLum.Data.Spectrum") #' #' ##show example data #' data(ExampleData.XSYG, envir = environment()) #' TL.Spectrum #' #' ##show data matrix #' get_RLum(TL.Spectrum) #' #' ##plot spectrum #' \dontrun{ #' plot_RLum(TL.Spectrum) #' } #' @export setClass( "RLum.Data.Spectrum", slots = list( recordType = "character", curveType = "character", data = "matrix", info = "list" ), contains = "RLum.Data", prototype = list ( recordType = NA_character_, curveType = NA_character_, data = matrix(), info = list() ) ) #################################################################################################### ###as() #################################################################################################### ##data.frame ##COERCE RLum.Data.Spectrum >> data.frame AND data.frame >> RLum.Data.Spectrum #' as() #' #' for \code{[RLum.Data.Spectrum]} #' #' #' \bold{[RLum.Data.Spectrum]}\cr #' #' \tabular{ll}{ #' \bold{from} \tab \bold{to}\cr #' \code{data.frame} \tab \code{data.frame}\cr #' \code{matrix} \tab \code{matrix} #' #' } #' #' #' @name as #' #' setAs("data.frame", "RLum.Data.Spectrum", function(from,to){ new(to, recordType = NA_character_, curveType = NA_character_, data = as.matrix(from), info = list()) }) setAs("RLum.Data.Spectrum", "data.frame", function(from){ as.data.frame(from@data) }) ##MATRIX ##COERCE RLum.Data.Spectrum >> matrix AND matrix >> RLum.Data.Spectrum setAs("matrix", "RLum.Data.Spectrum", function(from,to){ new(to, recordType = NA_character_, curveType = NA_character_, data = from, info = list()) }) setAs("RLum.Data.Spectrum", "matrix", function(from){ from@data }) #################################################################################################### ###show() #################################################################################################### #' @describeIn RLum.Data.Spectrum #' Show structure of \code{RLum.Data.Spectrum} object #' @export setMethod("show", signature(object = "RLum.Data.Spectrum"), function(object){ x.range <- suppressWarnings(range(as.numeric(rownames(object@data)))) y.range <- suppressWarnings(range(as.numeric(colnames(object@data)))) z.range <- range(object@data) ##print information cat("\n [RLum.Data.Spectrum]") cat("\n\t recordType:", object@recordType) cat("\n\t curveType:", object@curveType) cat("\n\t .. recorded frames:", length(object@data[1,])) cat("\n\t .. .. measured values per frame:", length(object@data[,1])) cat("\n\t .. .. range wavelength/pixel:", x.range) cat("\n\t .. .. range time/temp.:", y.range) cat("\n\t .. .. range count values:", z.range) cat("\n\t additional info elements:", length(object@info)) #cat("\n\t\t >> names:", names(object@info)) } ) #################################################################################################### ###set_RLum() #################################################################################################### #' @describeIn RLum.Data.Spectrum #' Construction method for RLum.Data.Spectrum object. The slot info is optional #' and predefined as empty list by default #' #' @param class [\code{set_RLum}] \code{\link{character}} (automatic): name of the \code{RLum} class to create. #' @param originator \code{\link{character}} (automatic): contains the name of the calling function #' (the function that produces this object); can be set manually. #' @param .uid [\code{set_RLum}] \code{\link{character}} (automatic): sets an unique ID for this object #' using the internal C++ function \code{.create_UID}. #' @param .pid [\code{set_RLum}] \code{\link{character}} (with default): option to provide a parent id for nesting #' at will. #' @param recordType [\code{set_RLum}] \code{\link{character}}: record type (e.g. "OSL") #' @param curveType [\code{set_RLum}] \code{\link{character}}: curve type (e.g. "predefined" or "measured") #' @param data [\code{set_RLum}] \code{\link{matrix}}: raw curve data. If data is of #' type \code{RLum.Data.Spectrum}, this can be used to re-construct the object. #' @param info [\code{set_RLum}] \code{\link{list}}: info elements #' #' @return #' #' \bold{\code{[set_RLum]}}\cr #' #' An object from the class \code{RLum.Data.Spectrum} #' #' @export setMethod( "set_RLum", signature = signature("RLum.Data.Spectrum"), definition = function(class, originator, .uid, .pid, recordType = "Spectrum", curveType = NA_character_, data = matrix(), info = list()) { ##The case where an RLum.Data.Spectrum object can be provided ##with this RLum.Data.Spectrum objects can be provided to be reconstructed if (is(data, "RLum.Data.Spectrum")) { ##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 missing .uid if (missing(.uid)) { info <- data@.uid } ##check for missing .pid if (missing(.pid)) { info <- data@.pid } ##set empty clas form object newRLumDataSpectrum <- new("RLum.Data.Spectrum") ##fill - this is the faster way, filling in new() costs ... newRLumDataSpectrum@recordType = recordType newRLumDataSpectrum@curveType = curveType newRLumDataSpectrum@data = data@data newRLumDataSpectrum@info = info newRLumDataSpectrum@.uid = data@.uid newRLumDataSpectrum@.pid = data@.pid return(newRLumDataSpectrum) } else{ ##set empty clas form object newRLumDataSpectrum <- new("RLum.Data.Spectrum") ##fill - this is the faster way, filling in new() costs ... newRLumDataSpectrum@originator = originator newRLumDataSpectrum@recordType = recordType newRLumDataSpectrum@curveType = curveType newRLumDataSpectrum@data = data newRLumDataSpectrum@info = info newRLumDataSpectrum@.uid = .uid newRLumDataSpectrum@.pid = .pid return(newRLumDataSpectrum) } } ) #################################################################################################### ###get_RLum() #################################################################################################### #' @describeIn RLum.Data.Spectrum #' Accessor method for RLum.Data.Spectrum object. The argument info.object #' is optional to directly access the info elements. If no info element name #' is provided, the raw curve data (matrix) will be returned #' #' @param object [\code{show_RLum}][\code{get_RLum}][\code{names_RLum}] an object of #' class \code{\linkS4class{RLum.Data.Spectrum}} #' @param info.object [\code{get_RLum}] \code{\link{character}} (optional): the name of the info #' object to be called #' #' @return #' #' \bold{\code{get_RLum}}\cr #' #' (1) A \code{\link{matrix}} with the spectrum values or \cr #' (2) only the info object if \code{info.object} was set.\cr #' #' @export setMethod("get_RLum", signature("RLum.Data.Spectrum"), definition = function(object, info.object) { ##Check if function is of type RLum.Data.Spectrum if(is(object, "RLum.Data.Spectrum") == FALSE){ stop("[get_RLum] Function valid for 'RLum.Data.Spectrum' objects only!") } ##if missing info.object just show the curve values if(missing(info.object) == FALSE){ if(is(info.object, "character") == FALSE){ stop("[get_RLum] 'info.object' has to be a character!") } if(info.object %in% names(object@info) == TRUE){ unlist(object@info[info.object]) }else{ ##grep names temp.element.names <- paste(names(object@info), collapse = ", ") stop.text <- paste("[get_RLum] Invalid element name. Valid names are:", temp.element.names) stop(stop.text) } }else{ object@data } }) #################################################################################################### ###names_RLum() #################################################################################################### #' @describeIn RLum.Data.Spectrum #' Returns the names info elements coming along with this curve object #' #' @return #' #' \bold{\code{names_RLum}}\cr #' #' The names of the info objects #' #' @export setMethod("names_RLum", "RLum.Data.Spectrum", function(object){ names(object@info) }) Luminescence/R/analyse_SAR.TL.R0000644000176200001440000004751413125226556015711 0ustar liggesusers#' Analyse SAR TL measurements #' #' The function performs a SAR TL analysis on a #' \code{\linkS4class{RLum.Analysis}} object including growth curve fitting. #' #' This function performs a SAR TL analysis on a set of curves. The SAR #' procedure in general is given by Murray and Wintle (2000). For the #' calculation of the Lx/Tx value the function \link{calc_TLLxTxRatio} is #' used.\cr\cr \bold{Provided rejection criteria}\cr\cr #' \sQuote{recyling.ratio}: calculated for every repeated regeneration dose #' point.\cr \sQuote{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)\cr #' #' @param object \code{\linkS4class{RLum.Analysis}}(\bold{required}): input #' object containing data for analysis #' #' @param object.background currently not used #' #' @param signal.integral.min \link{integer} (\bold{required}): requires the #' channel number for the lower signal integral bound (e.g. #' \code{signal.integral.min = 100}) #' #' @param signal.integral.max \link{integer} (\bold{required}): requires the #' channel number for the upper signal integral bound (e.g. #' \code{signal.integral.max = 200}) #' #' @param integral_input \code{\link{character}} (with default): defines the input for the #' the arguments \code{signal.integral.min} and \code{signal.integral.max}. These limits can be #' either provided \code{'channel'} number (the default) or \code{'temperature'}. If \code{'temperature'} #' is chosen the best matching channel is selected. #' #' @param sequence.structure \link{vector} \link{character} (with default): #' specifies the general sequence structure. Three steps are allowed ( #' \code{"PREHEAT"}, \code{"SIGNAL"}, \code{"BACKGROUND"}), in addition a #' parameter \code{"EXCLUDE"}. This allows excluding TL curves which are not #' relevant for the protocol analysis. (Note: None TL are removed by default) #' #' @param rejection.criteria \link{list} (with default): list containing #' rejection criteria in percentage for the calculation. #' #' @param dose.points \code{\link{numeric}} (optional): option set dose points manually #' #' @param log \link{character} (with default): a character string which #' contains "x" if the x axis is to be logarithmic, "y" if the y axis is to be #' logarithmic and "xy" or "yx" if both axes are to be logarithmic. See #' \link{plot.default}). #' #' @param \dots further arguments that will be passed to the function #' \code{\link{plot_GrowthCurve}} #' #' @return A plot (optional) and an \code{\linkS4class{RLum.Results}} object is #' returned containing the following elements: #' \item{De.values}{\link{data.frame} containing De-values and further #' parameters} \item{LnLxTnTx.values}{\link{data.frame} of all calculated Lx/Tx #' values including signal, background counts and the dose points.} #' \item{rejection.criteria}{\link{data.frame} with values that might by used #' as rejection criteria. NA is produced if no R0 dose point exists.}\cr\cr #' \bold{note:} the output should be accessed using the function #' \code{\link{get_RLum}} #' #' @note \bold{THIS IS A BETA VERSION}\cr\cr None TL curves will be removed #' from the input object without further warning. #' #' @section Function version: 0.2.0 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\link{calc_TLLxTxRatio}}, \code{\link{plot_GrowthCurve}}, #' \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}} #' \code{\link{get_RLum}} #' #' @references Aitken, M.J. and Smith, B.W., 1988. Optical dating: recuperation #' after bleaching. Quaternary Science Reviews 7, 387-393. #' #' 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 plot #' #' @examples #' #' #' ##load data #' data(ExampleData.BINfileData, envir = environment()) #' #' ##transform the values from the first position in a RLum.Analysis object #' object <- Risoe.BINfileData2RLum.Analysis(TL.SAR.Data, pos=3) #' #' ##perform analysis #' analyse_SAR.TL(object, #' signal.integral.min = 210, #' signal.integral.max = 220, #' log = "y", #' fit.method = "EXP OR LIN", #' sequence.structure = c("SIGNAL", "BACKGROUND")) #' #' @export analyse_SAR.TL <- function( object, object.background, signal.integral.min, signal.integral.max, integral_input = "channel", sequence.structure = c("PREHEAT", "SIGNAL", "BACKGROUND"), rejection.criteria = list(recycling.ratio = 10, recuperation.rate = 10), dose.points, log = "", ... ){ # CONFIG ----------------------------------------------------------------- ##set allowed curve types type.curves <- c("TL") ##=============================================================================# # General Integrity Checks --------------------------------------------------- ##GENERAL ##MISSING INPUT if(missing("object")==TRUE){ stop("[analyse_SAR.TL] No value set for 'object'!") } if(missing("signal.integral.min") == TRUE){ stop("[analyse_SAR.TL] No value set for 'signal.integral.min'!") } if(missing("signal.integral.max") == TRUE){ stop("[analyse_SAR.TL] No value set for 'signal.integral.max'!") } ##INPUT OBJECTS if(is(object, "RLum.Analysis") == FALSE){ stop("[analyse_SAR.TL] Input object is not of type 'RLum.Analyis'!") } # Protocol Integrity Checks -------------------------------------------------- ##Remove non TL-curves from object by selecting TL curves object@records <- get_RLum(object, recordType = type.curves) ##ANALYSE SEQUENCE OBJECT STRUCTURE ##set vector for sequence structure temp.protocol.step <- rep(sequence.structure,length(object@records))[1:length(object@records)] ##grep object strucute temp.sequence.structure <- structure_RLum(object) ##set values for step temp.sequence.structure[,"protocol.step"] <- temp.protocol.step ##remove TL curves which are excluded temp.sequence.structure <- temp.sequence.structure[which( temp.sequence.structure[,"protocol.step"]!="EXCLUDE"),] ##check integrity; signal and bg range should be equal if(length( unique( temp.sequence.structure[temp.sequence.structure[,"protocol.step"]=="SIGNAL","n.channels"]))>1){ stop(paste( "[analyse_SAR.TL()] Signal range differs. Check sequence structure.\n", temp.sequence.structure )) } ##check if the wanted curves are a multiple of the structure if(length(temp.sequence.structure[,"id"])%%length(sequence.structure)!=0){ stop("[analyse_SAR.TL()] Input TL curves are not a multiple of the sequence structure.") } # # Calculate LnLxTnTx values -------------------------------------------------- ##grep IDs for signal and background curves TL.preheat.ID <- temp.sequence.structure[ temp.sequence.structure[,"protocol.step"] == "PREHEAT","id"] TL.signal.ID <- temp.sequence.structure[ temp.sequence.structure[,"protocol.step"] == "SIGNAL","id"] TL.background.ID <- temp.sequence.structure[ temp.sequence.structure[,"protocol.step"] == "BACKGROUND","id"] ##comfort ... translate integral limits from temperature to channel if(integral_input == "temperature"){ signal.integral.min <- which.min(abs( signal.integral.min - get_RLum(object, record.id = TL.signal.ID[1])[, 1] )) signal.integral.max <- which.min(abs( signal.integral.max - get_RLum(object, record.id = TL.signal.ID[1])[, 1] )) } ##calculate LxTx values using external function for(i in seq(1,length(TL.signal.ID),by=2)){ temp.LnLxTnTx <- get_RLum( calc_TLLxTxRatio( Lx.data.signal = get_RLum(object, record.id = TL.signal.ID[i]), Lx.data.background = if (length(TL.background.ID) == 0) { NULL } else{ get_RLum(object, record.id = TL.background.ID[i]) }, Tx.data.signal = get_RLum(object, record.id = TL.signal.ID[i + 1]), Tx.data.background = if (length(TL.background.ID) == 0){ NULL }else{ get_RLum(object, record.id = TL.background.ID[i + 1]) }, signal.integral.min, signal.integral.max ) ) ##grep dose temp.Dose <- object@records[[TL.signal.ID[i]]]@info$IRR_TIME ##take about NULL values if(is.null(temp.Dose)){ temp.Dose <- NA } ##bind data.frame temp.LnLxTnTx <- cbind(Dose=temp.Dose, temp.LnLxTnTx) if(exists("LnLxTnTx")==FALSE){ LnLxTnTx <- data.frame(temp.LnLxTnTx) }else{ LnLxTnTx <- rbind(LnLxTnTx,temp.LnLxTnTx) } } ##set dose.points manual if argument was set if(!missing(dose.points)){ temp.Dose <- dose.points LnLxTnTx$Dose <- dose.points } # Set regeneration points ------------------------------------------------- #generate unique dose id - this are also the # for the generated points temp.DoseID <- c(0:(length(temp.Dose)-1)) temp.DoseName <- paste("R",temp.DoseID,sep="") temp.DoseName <- cbind(Name=temp.DoseName,Dose=temp.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 ##combine in the data frame temp.LnLxTnTx<-data.frame(Name=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 if(length(LnLxTnTx[LnLxTnTx[,"Repeated"]==TRUE,"Repeated"])>0){ ##identify repeated doses temp.Repeated<-LnLxTnTx[LnLxTnTx[,"Repeated"]==TRUE,c("Name","Dose","LxTx")] ##find concering 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)<-temp.ColNames }else{RecyclingRatio<-NA} # Calculate Recuperation Rate --------------------------------------------- ##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} # Combine and Evaluate Rejection Criteria --------------------------------- RejectionCriteria <- data.frame( citeria = c(colnames(RecyclingRatio), "recuperation rate"), value = c(RecyclingRatio,Recuperation), threshold = c( rep(paste("+/-", rejection.criteria$recycling.ratio/100) ,length(RecyclingRatio)), paste("", rejection.criteria$recuperation.rate/100) ), status = c( if(is.na(RecyclingRatio)==FALSE){ sapply(1:length(RecyclingRatio), function(x){ if(abs(1-RecyclingRatio[x])>(rejection.criteria$recycling.ratio/100)){ "FAILED" }else{"OK"}})}else{NA}, if(is.na(Recuperation)==FALSE & Recuperation>rejection.criteria$recuperation.rate){"FAILED"}else{"OK"} )) ##============================================================================## ##PLOTTING ##============================================================================## # Plotting - Config ------------------------------------------------------- ##grep plot parameter par.default <- par(no.readonly = TRUE) on.exit(par(par.default)) ##colours and double for plotting col <- get("col", pos = .LuminescenceEnv) col.doubled <- rep(col, each=2) layout(matrix(c(1,1,2,2, 1,1,2,2, 3,3,4,4, 3,3,4,4, 5,5,5,5),5,4,byrow=TRUE)) par(oma=c(0,0,0,0), mar=c(4,4,3,3)) ## 1 -> TL Lx ## 2 -> TL Tx ## 3 -> TL Lx Plateau ## 4 -> TL Tx Plateau ## 5 -> Legend ##recalculate signal.integral from channels to temperature signal.integral.temperature <- c(object@records[[TL.signal.ID[1]]]@data[signal.integral.min,1] : object@records[[TL.signal.ID[1]]]@data[signal.integral.max,1]) ##warning if number of curves exceed colour values if(length(col) 0) { mtext("[FAILED]", col = "red") } } # Plotting GC ---------------------------------------- temp.sample <- data.frame(Dose=LnLxTnTx$Dose, LxTx=LnLxTnTx$LxTx, LxTx.Error=LnLxTnTx$LxTx.Error, TnTx=LnLxTnTx$TnTx ) ##run curve fitting temp.GC <- try(plot_GrowthCurve( sample = temp.sample, ... )) ##check for error if(inherits(temp.GC, "try-error")){ return(NULL) }else{ temp.GC <- get_RLum(temp.GC)[, c("De", "De.Error")] } ##add recjection status if(length(grep("FAILED",RejectionCriteria$status))>0){ temp.GC <- data.frame(temp.GC, RC.Status="FAILED") }else{ temp.GC <- data.frame(temp.GC, RC.Status="OK") } # Return Values ----------------------------------------------------------- newRLumResults.analyse_SAR.TL <- set_RLum( class = "RLum.Results", data = list( data = temp.GC, LnLxTnTx.table = LnLxTnTx, rejection.criteria = RejectionCriteria ), info = list(info = sys.call()) ) return(newRLumResults.analyse_SAR.TL) } Luminescence/R/zzz.R0000644000176200001440000002200213125226556014050 0ustar liggesusers##////////////////////////////////////////////////////////////////////////////// ##//zzz.R ##////////////////////////////////////////////////////////////////////////////// ## ##============================================================================== ##author: R Luminescence Package Team ##organisation: ##version.: 0.2.1 ##date: 2013-11-10 ##============================================================================== # Set namespace .LuminescenceEnv ------------------------------------------ .LuminescenceEnv <- new.env(parent = emptyenv()) # Assign variables to Namespace ------------------------------------------- ##variable col to define colours in the functions for output assign("col", unlist(colors())[c(261,552,51,62,76,151,451,474,654,657,100,513,23,612,129,27,551,393,80,652,555)], pos = ".LuminescenceEnv", envir = .LuminescenceEnv) ##============================================================================== ##on Attach .onAttach <- function(libname,pkgname){ ##set startup message try(packageStartupMessage(paste("Welcome to the R package Luminescence version ", packageDescription(pkg="Luminescence")$Version, " [Built: ", trimws(strsplit(packageDescription(pkg="Luminescence")$Built, ";")[[1]][3]), "]", sep=""), "\n", get_Quote()), silent=TRUE) } ##============================================================================== # DO NOT TOUCH! ----------------------------------------------------------- #' sTeve - sophisticated tool for efficient data validation and evaluation #' #' This function provides a sophisticated routine for comprehensive #' luminescence dating data analysis. #' #' This amazing sophisticated function validates your data seriously. #' #' @param n_frames \code{\link{integer}} (with default): n frames #' @param t_animation \code{\link{integer}} (with default): t animation #' @param n.tree \code{\link{integer}} (with default): How many trees do you #' want to cut? #' @param type \code{\link{integer}} (optional): Make a decision: 1, 2 or 3 #' @return Validates your data. #' @note This function should not be taken too seriously. #' @author R Luminescence Team, 2012-2013 #' @seealso \link{plot_KDE} #' @references # #' @keywords manip #' @examples #' #' ##no example available #' #' @export sTeve<- function(n_frames = 10, t_animation = 2, n.tree = 7, type) { ## allow new overlay plot par(new = TRUE) ## infer month of year month <- as.numeric(strsplit(x = as.character(Sys.Date()), split = "-")[[1]][2]) ## select showtime item based on month or user-defined type if(missing(type) == TRUE) { if(month >= 1 & month <= 3) { type <- 1 } else if(month >3 & month <= 11) { type <- 2 } else if(month > 11 & month <= 12) { type <- 3 } } if(type == 1) { ## SHOWTIME OPTION 1 Sys.sleep(5) shape::emptyplot() shape::filledrectangle(wx = 0.9, wy = 0.4, mid = c(0.5, 0.5), lcol ="red", lwd=1, col=0, angle = 45) text(x=0.5, y=0.5, labels="NOT FUNNY", cex=2, col="red", font=2, srt=45) } else if(type == 2) { ## SHOWTIME OPTION 2 plot(NA, xlim = c(0, 10), ylim = c(0, 10), main = "", xlab = "", ylab = "", axes = FALSE, frame.plot = FALSE) n_frames <- n_frames t_animation <- t_animation dt <- t_animation / n_frames x1 <- seq(0, 10, length.out = n_frames) y1 <- rep(1.5, n_frames) r1 <- 0.5 x2 <- seq(0, 16, length.out = n_frames) y2 <- rep(8.5, n_frames) r2 <- 0.5 x4 <- seq(11, 0, length.out = n_frames) y4 <- rep(5, n_frames) r4 <- 0.5 # set angles for each step of mouth opening angles_mouth <- rep(c(0.01, 0.25, 0.5, 0.25), length.out = n_frames) for(i in 1:n_frames){ # define pacman circles shape::filledcircle(r1 = r1, r2 = 0.00001, mid = c(x1[i], y1[i]), from = angles_mouth[i], to = 2 * pi - angles_mouth[i], col = "yellow") shape::filledcircle(r1 = r2, r2 = 0.00001, mid = c(x2[i], y2[i]), from = angles_mouth[i], to = 2 * pi - angles_mouth[i], col = "yellow") shape::filledcircle(r1 = r4, r2 = 0.00001, mid = c(x4[i], y4[i]), from = angles_mouth[i] + 3, to = 2 * pi - angles_mouth[i] + 3, col = "yellow") # dinfine eyes for pacman points(x1[i] + 0.2, y1[i] + 0.75, pch = 21, bg = 1, cex = 0.7) points(x2[i] + 0.2, y2[i] + 0.75, pch = 21, bg = 1, cex = 0.7) points(x4[i] - 0.05, y4[i] + 0.75, pch = 21, bg = 1, cex = 0.7) Sys.sleep(dt) shape::plotcircle(r = 1.1 * r1, mid = c(x1[i], y1[i]), col = "white", lcol = "white") shape::plotcircle(r = 1.1 * r2, mid = c(x2[i], y2[i]), col = "white", lcol = "white") shape::plotcircle(r = 1.1 * r4, mid = c(x4[i], y4[i]), col = "white", lcol = "white") } } else if(type == 3) { ## calculate display ratio f <- par()$pin[2] / par()$pin[1] ## create new overlay plot plot(NA, xlim = c(0, 100), ylim = c(0, 100), axes = F, frame.plot = FALSE, xlab = "", ylab = "") ## create semi-transparent layer polygon(x = c(-100, -100, 200, 200), y = c(-100, 200, 200, -100), col = rgb(1,1,1, 0.8), lty = 0) ## draw christmas trees n = n.tree tree.x <- runif(n, 10, 90) tree.y <- runif(n, 10, 90) tree.size <- runif(n, 0.3, 1.5) for(i in 1:n) { ## stem polygon(x = c(tree.x[i] - 1.5 * tree.size[i], tree.x[i] - 1.5 * tree.size[i], tree.x[i] + 1.5 * tree.size[i], tree.x[i] + 1.5 * tree.size[i]) , y = c(tree.y[i] - 12 * tree.size[i], tree.y[i] - 1 * tree.size[i], tree.y[i] - 1 * tree.size[i], tree.y[i] - 12* tree.size[i]), col = "rosybrown4", lty = 0) ## branch one shape::filledellipse(rx1 = 10 * tree.size[i], rx2 = 0.00001, mid = c(tree.x[i], tree.y[i] + 3 * tree.size[i]), col = "darkgreen", from = 4.0143, to = 5.41052) ## branch two shape::filledellipse(rx1 = 8 * tree.size[i], rx2 = 0.00001, mid = c(tree.x[i], tree.y[i] + 7 * tree.size[i]), col = "darkgreen", from = 4.0143, to = 5.41052) ## branch three shape::filledellipse(rx1 = 6 * tree.size[i], rx2 = 0.00001, mid = c(tree.x[i], tree.y[i] + 9 * tree.size[i]), col = "darkgreen", from = 4.0143, to = 5.41052) ## branch four shape::filledellipse(rx1 = 4 * tree.size[i], rx2 = 0.00001, mid = c(tree.x[i], tree.y[i] + 11 * tree.size[i]), col = "darkgreen", from = 4.0143, to = 5.41052) ## sphere one shape::filledellipse(rx1 = 1 * f * tree.size[i], ry1 = 1 * tree.size[i], mid = c(tree.x[i] + 2 * tree.size[i], tree.y[i] + 5 * tree.size[i]), col = shape::shadepalette(n = 20, endcol = "darkred")) ## sphere two shape::filledellipse(rx1 = 0.8 * f * tree.size[i], ry1 = 0.8 * tree.size[i], mid = c(tree.x[i] - 1 * tree.size[i], tree.y[i] + -3 * tree.size[i]), col = shape::shadepalette(n = 20, endcol = "orange")) ## sphere three shape::filledellipse(rx1 = 1.2 * f * tree.size[i], ry1 = 1.2 * tree.size[i], mid = c(tree.x[i] - 1.7 * tree.size[i], tree.y[i] + 2 * tree.size[i]), col = shape::shadepalette(n = 20, endcol = "yellow3")) ## sphere four shape::filledellipse(rx1 = 1 * f * tree.size[i], ry1 = 1 * tree.size[i], mid = c(tree.x[i] + 3 * tree.size[i], tree.y[i] - 4 * tree.size[i]), col = shape::shadepalette(n = 20, endcol = "darkblue")) Sys.sleep(0.1) } ## add snow points(runif(300, 0, 100), runif(300, 0, 100), pch = 8, col = "lightgrey") } }#end function Luminescence/R/fit_CWCurve.R0000644000176200001440000007422513125226556015411 0ustar liggesusers#' Nonlinear Least Squares Fit for CW-OSL curves [beta version] #' #' The function determines the weighted least-squares estimates of the #' component parameters of a CW-OSL signal for a given maximum number of #' components and returns various component parameters. The fitting procedure #' uses the \code{\link{nls}} function with the \code{port} algorithm. #' #' \bold{Fitting function}\cr\cr The function for the CW-OSL fitting has the #' general form: \deqn{y = I0_{1}*\lambda_{1}*exp(-\lambda_1*x) + ,\ldots, + #' I0_{i}*\lambda_{i}*exp(-\lambda_i*x) } where \eqn{0 < i < 8}\cr\cr and #' \eqn{\lambda} is the decay constant and \eqn{I0} the intial number of #' trapped electrons.\cr (for the used equation cf. Boetter-Jensen et al., #' 2003, Eq. 2.31)\cr\cr \bold{Start values}\cr #' #' Start values are estimated automatically by fitting a linear function to the #' logarithmized input data set. Currently, there is no option to manually #' provide start parameters. \cr\cr \bold{Goodness of fit}\cr\cr The goodness #' of the fit is given as pseudoR^2 value (pseudo coefficient of #' determination). According to Lave (1970), the value is calculated as: #' \deqn{pseudoR^2 = 1 - RSS/TSS} where \eqn{RSS = Residual~Sum~of~Squares} \cr #' and \eqn{TSS = Total~Sum~of~Squares}\cr\cr #' #' \bold{Error of fitted component parameters}\cr\cr The 1-sigma error for the #' components is calculated using the function \code{\link{confint}}. Due to #' considerable calculation time, this option is deactived by default. In #' addition, the error for the components can be estimated by using internal R #' functions like \code{\link{summary}}. See the \code{\link{nls}} help page #' for more information.\cr\cr \emph{For details on the nonlinear regression in #' R, see Ritz & Streibig (2008).} #' #' @param values \code{\linkS4class{RLum.Data.Curve}} or \link{data.frame} #' (\bold{required}): x, y data of measured values (time and counts). See #' examples. #' @param n.components.max \link{vector} (optional): maximum number of #' components that are to be used for fitting. The upper limit is 7. #' @param fit.failure_threshold \link{vector} (with default): limits the failed #' fitting attempts. #' @param fit.method \link{character} (with default): select fit method, #' allowed values: \code{'port'} and \code{'LM'}. \code{'port'} uses the 'port' #' routine usint the funtion \code{\link{nls}} \code{'LM'} utilises the #' function \code{nlsLM} from the package \code{minpack.lm} and with that the #' Levenberg-Marquardt algorithm. #' @param fit.trace \link{logical} (with default): traces the fitting process #' on the terminal. #' @param fit.calcError \link{logical} (with default): calculate 1-sigma error #' range of components using \code{\link{confint}} #' @param LED.power \link{numeric} (with default): LED power (max.) used for #' intensity ramping in mW/cm^2. \bold{Note:} The value is used for the #' calculation of the absolute photoionisation cross section. #' @param LED.wavelength \link{numeric} (with default): LED wavelength used for #' stimulation in nm. \bold{Note:} The value is used for the calculation of the #' absolute photoionisation cross section. #' @param cex.global \link{numeric} (with default): global scaling factor. #' @param sample_code \link{character} (optional): sample code used for the #' plot and the optional output table (mtext). #' @param output.path \link{character} (optional): output path for table output #' containing the results of the fit. The file name is set automatically. If #' the file already exists in the directory, the values are appended. #' @param output.terminal \link{logical} (with default): terminal ouput with #' fitting results. #' @param output.terminalAdvanced \link{logical} (with default): enhanced #' terminal output. Requires \code{output.terminal = TRUE}. If #' \code{output.terminal = FALSE} no advanced output is possible. #' @param plot \link{logical} (with default): returns a plot of the fitted #' curves. #' @param \dots further arguments and graphical parameters passed to #' \code{\link{plot}}. #' @return \item{plot}{(optional) the fitted CW-OSL curves are returned as #' plot.} \item{table}{(optional) an output table (*.csv) with parameters of #' the fitted components is provided if the \code{output.path} is set.} #' \item{list(list("RLum.Results"))}{beside the plot and table output options, #' an \code{\linkS4class{RLum.Results}} object is returned.\cr\cr \code{fit}: #' an \code{nls} object (\code{$fit}) for which generic R functions are #' provided, e.g. \link{summary}, \link{confint}, \link{profile}. For more #' details, see \link{nls}.\cr\cr \code{output.table}: a \link{data.frame} #' containing the summarised parameters including the error\cr #' \code{component.contribution.matrix}: \link{matrix} containing the values #' for the component to sum contribution plot #' (\code{$component.contribution.matrix}).\cr #' #' Matrix structure:\cr Column 1 and 2: time and \code{rev(time)} values\cr #' Additional columns are used for the components, two for each component, #' containing I0 and n0. The last columns \code{cont.} provide information on #' the relative component contribution for each time interval including the row #' sum for this values. }\item{ object}{beside the plot and table output #' options, an \code{\linkS4class{RLum.Results}} object is returned.\cr\cr #' \code{fit}: an \code{nls} object (\code{$fit}) for which generic R functions #' are provided, e.g. \link{summary}, \link{confint}, \link{profile}. For more #' details, see \link{nls}.\cr\cr \code{output.table}: a \link{data.frame} #' containing the summarised parameters including the error\cr #' \code{component.contribution.matrix}: \link{matrix} containing the values #' for the component to sum contribution plot #' (\code{$component.contribution.matrix}).\cr #' #' Matrix structure:\cr Column 1 and 2: time and \code{rev(time)} values\cr #' Additional columns are used for the components, two for each component, #' containing I0 and n0. The last columns \code{cont.} provide information on #' the relative component contribution for each time interval including the row #' sum for this values. } #' @note \bold{Beta version - This function has not been properly tested yet #' and should therefore not be used for publication purposes!}\cr\cr The #' pseudo-R^2 may not be the best parameter to describe the goodness of the #' fit. The trade off between the \code{n.components} and the pseudo-R^2 value #' is currently not considered.\cr\cr The function \bold{does not} ensure that #' the fitting procedure has reached a global minimum rather than a local #' minimum! #' #' @section Function version: 0.5.2 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne #' (France) #' #' @seealso \code{\link{fit_LMCurve}}, \code{\link{plot}},\code{\link{nls}}, #' \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Results}}, #' \code{\link{get_RLum}}, \code{\link[minpack.lm]{nlsLM}} #' @references Boetter-Jensen, L., McKeever, S.W.S., Wintle, A.G., 2003. #' Optically Stimulated Luminescence Dosimetry. Elsevier Science B.V. #' #' Lave, C.A.T., 1970. The Demand for Urban Mass Transportation. The Review of #' Economics and Statistics, 52 (3), 320-323. #' #' Ritz, C. & Streibig, J.C., 2008. Nonlinear Regression with R. In: R. #' Gentleman, K. Hornik, G. Parmigiani, eds., Springer, p. 150. #' @keywords dplot models #' @examples #' #' #' ##load data #' data(ExampleData.CW_OSL_Curve, envir = environment()) #' #' ##fit data #' fit <- fit_CWCurve(values = ExampleData.CW_OSL_Curve, #' main = "CW Curve Fit", #' n.components.max = 4, #' log = "x") #' #' @export fit_CWCurve<- function( values, n.components.max, fit.failure_threshold = 5, fit.method = "port", fit.trace = FALSE, fit.calcError = FALSE, LED.power = 36, LED.wavelength = 470, cex.global = 0.6, sample_code = "Default", output.path, output.terminal = TRUE, output.terminalAdvanced = TRUE, plot = TRUE, ... ){ ##TODO ##remove output.path # INTEGRITY CHECKS -------------------------------------------------------- ##INPUT OBJECTS if(is(values, "RLum.Data.Curve") == FALSE & is(values, "data.frame") == FALSE){ stop("[fit_CWCurve()] Input object is not of type 'RLum.Data.Curve' or 'data.frame'!", call. = FALSE) } if(is(values, "RLum.Data.Curve") == TRUE){ x <- values@data[,1] y <- values@data[,2] ##needed due to inconsistencies in the R code below values <- data.frame(x,y) }else{ ##set x and y values x<-values[,1] y<-values[,2] } # Deal with extra arguments ----------------------------------------------- ##deal with addition arguments extraArgs <- list(...) main <- if("main" %in% names(extraArgs)) {extraArgs$main} else {"CW-OSL Curve Fit"} log <- if("log" %in% names(extraArgs)) {extraArgs$log} else {""} xlab <- if("xlab" %in% names(extraArgs)) {extraArgs$xlab} else {"Time [s]"} ylab <- if("ylab" %in% names(extraArgs)) {extraArgs$ylab} else {paste("OSL [cts/",round(max(x)/length(x), digits = 2)," s]",sep="")} ##============================================================================## ## FITTING ##============================================================================## ## ##////equation used for fitting////(start) fit.equation <- function(I0.i,lambda.i){ equation<-parse( text=paste("I0[",I0.i,"]*lambda[",lambda.i,"]*exp(-lambda[",lambda.i,"]*x)", collapse="+",sep="")) return(equation) } ##////equation used for fitting///(end) ##////equation used for fitting////(start) fit.equation.simple <- function(I0.i,lambda.i){ equation<-parse( text=paste("I0[",I0.i,"]*exp(-lambda[",lambda.i,"]*x)", collapse="+",sep="")) return(equation) } ##////equation used for fitting///(end) ##set formula elements for fitting functions ## the upper two funtions should be removed ... but chances are needed ... TODO ##////equation used for fitting////(start) fit.formula <- function(n.components){ I0 <- paste0("I0.",1:n.components) lambda <- paste0("lambda.",1:n.components) as.formula(paste0("y ~ ", paste(I0," * ", lambda, "* exp(-",lambda," * x)", collapse=" + "))) } ##////equation used for fitting///(end) ##////equation used for fitting////(start) fit.formula.simple <- function(n.components){ I0 <- paste0("I0.",1:n.components) lambda <- paste0("lambda.",1:n.components) as.formula(paste0("y ~ ", paste(I0," * exp(-",lambda," * x)", collapse=" + "))) } ##////equation used for fitting///(end) ##set variables fit.trigger <- TRUE #triggers if the fitting should stopped n.components <- 1 #number of components used for fitting - start with 1 fit.failure_counter <- 0 #counts the failed fitting attempts ##if n.components_max is missing, then it is Inf if(missing(n.components.max)==TRUE){n.components.max<-Inf} ## ##++++Fitting loop++++(start) while(fit.trigger==TRUE & n.components <= n.components.max){ ##(0) START PARAMETER ESTIMATION ##rough automatic start parameter estimation ##I0 I0<-rep(values[1,2]/3,n.components) names(I0) <- paste0("I0.",1:n.components) ##lambda ##ensure that no values <=0 are included remove them for start parameter ##estimation and fit an linear function a first guess if(min(y)<=0){ temp.values<-data.frame(x[-which(y<=0)], log(y[-which(y<=0)])) }else{ temp.values<-data.frame(x, log(y)) } temp<-lm(temp.values) lambda<-abs(temp$coefficient[2])/nrow(values) k<-2 while(k<=n.components){ lambda[k]<-lambda[k-1]/100 k<-k+1 } names(lambda) <- paste0("lambda.",1:n.components) ##(1) FIRST FIT WITH A SIMPLE FUNCTION if(fit.method == "LM"){ ##try fit simple fit.try<-suppressWarnings(try(minpack.lm::nlsLM(fit.formula.simple(n.components), data=values, start=c(I0,lambda), na.action = "na.exclude", trace = fit.trace, control = minpack.lm::nls.lm.control( maxiter = 500 )), silent = TRUE ))#end try }else if(fit.method == "port"){ ##try fit simple fit.try<-suppressWarnings(try(nls(fit.formula.simple(n.components), data=values, trace = fit.trace, algorithm="port", na.action = "na.exclude", start=c(I0,lambda), nls.control( tol = 1, maxiter=100, warnOnly=FALSE, minFactor=1/1024 ), lower=rep(0,n.components * 2)# set lower boundaries for components ), silent=TRUE# nls ))#end try }else{ stop("[fit_CWCurve()] fit.method unknown.", call. = FALSE) } ##(3) FIT WITH THE FULL FUNCTION if(inherits(fit.try,"try-error") == FALSE){ ##grep parameters from simple fit to further work with them parameters <- coef(fit.try) ##grep parameters an set new starting parameters, here just lambda is choosen as ##it seems to be the most valuable parameter lambda <- parameters[(n.components+1):length(parameters)] if(fit.method == "LM"){ ##try fit simple fit.try<-suppressWarnings(try(minpack.lm::nlsLM(fit.formula(n.components), data=values, start=c(I0,lambda), trace = fit.trace, na.action = "na.exclude", lower = rep(0,n.components * 2), control = minpack.lm::nls.lm.control( maxiter = 500 )), silent = TRUE)) ## HACK: # minpack.lm::nlsLM() stores the 'lower' argument as class "call" rather # than "numeric" as nls() does. Before running confint() on this object # we overwrite the "lower" slot with the numeric values again. if (!inherits(fit.try, "try-error")) { fit.try$call$lower <- rep(0,n.components * 2) } }else{ ##try fit fit.try<-suppressWarnings(try(nls(fit.formula(n.components), trace=fit.trace, data=values, algorithm="port", na.action = "na.exclude", start=c(I0,lambda), nls.control( maxiter = 500, warnOnly = FALSE, minFactor = 1/4096 ), lower=rep(0,n.components * 2)# set lower boundaries for components ), silent=TRUE# nls ))#end try }#fit.method } ##count failed attempts for fitting if(inherits(fit.try,"try-error")==FALSE){ fit <- fit.try n.components <- n.components + 1 }else{ n.components<-n.components+1 fit.failure_counter <- fit.failure_counter+1 if(n.components==fit.failure_counter & exists("fit")==FALSE){fit<-fit.try}} ##stop fitting after a given number of wrong attempts if(fit.failure_counter>=fit.failure_threshold){ fit.trigger <- FALSE if(!exists("fit")){fit <- fit.try} }else if(n.components == n.components.max & exists("fit") == FALSE){ fit <- fit.try } }##end while ##++++Fitting loop++++(end) ##============================================================================## ## FITTING OUTPUT ##============================================================================## ##grep parameters if(inherits(fit,"try-error")==FALSE){ parameters <- coef(fit) ##correct fit equation for the de facto used number of components I0.i<-1:(length(parameters)/2) lambda.i<-1:(length(parameters)/2) fit.function<-fit.equation(I0.i=I0.i,lambda.i=lambda.i) n.components<-length(I0.i) ##write parameters in vectors and order by decreasing lambda value I0<-parameters[1:(length(parameters)/2)] lambda<-parameters[(1+(length(parameters)/2)):length(parameters)] o<-order(lambda,decreasing=TRUE) I0<-I0[o] lambda<-lambda[o] ##============================================================================## ## Additional Calculation ##============================================================================## ## --------------------------------------------- ##calculate stimulation intensity Schmidt (2008) ##Energy - E = h*v h<-6.62606957e-34 #in W*s^2 - Planck constant ny<-299792458/(LED.wavelength/10^9) #frequency of light E<-h*ny ##transform LED.power in W/cm^2 LED.power<-LED.power/1000 ##gets stimulation intensity stimulation_intensity<-LED.power/E ## --------------------------------------------- ##calculate photoionisation cross section and print on terminal ##using EQ (5) in Kitis cs<-as.vector(lambda/stimulation_intensity) cs.rel<-round(cs/cs[1],digits=4) ## --------------------------------------------- ##coefficient of determination after law RSS <- sum(residuals(fit)^2) #residual sum of squares TSS <- sum((y - mean(y))^2) #total sum of squares pR<-round(1-RSS/TSS,digits=4) if(pR<0){ warning("pseudo-R^2 < 0!") } ## --------------------------------------------- ##calculate 1- sigma CONFIDENCE INTERVALL lambda.error<-rep(NA, n.components) I0.error<-rep(NA, n.components) if(fit.calcError==TRUE){ ##option for confidence interval values.confint<-confint(fit, level=0.68) I0.confint<-values.confint[1:(length(values.confint[,1])/2),] lambda.confint<-values.confint[((length(values.confint[,1])/2)+1):length(values.confint[,1]),] ##error calculation I0.error<-as.vector(abs(I0.confint[,1]-I0.confint[,2])) lambda.error<-as.vector(abs(lambda.confint[,1]-lambda.confint[,2])) }#endif::fit.calcError ##============================================================================## ## Terminal Output ##============================================================================## if (output.terminal==TRUE){ ##print rough fitting information - use the nls() control for more information writeLines("\n[fit_CWCurve()]") writeLines(paste("\nFitting was finally done using a ",n.components, "-component function (max=",n.components.max,"):",sep="")) writeLines("------------------------------------------------------------------------------") writeLines(paste0("y ~ ", as.character(fit.formula(n.components))[3], "\n")) ##combine values and change rows names fit.results<-cbind(I0,I0.error,lambda,lambda.error,cs, cs.rel) row.names(fit.results)<-paste("c", 1:(length(parameters)/2), sep="") ##print parameters print(fit.results) #print some additional information if(fit.calcError==TRUE){writeLines("(errors quoted as 1-sigma values)")} writeLines("------------------------------------------------------------------------------") }#end if ##============================================================================## ## Terminal Output (advanced) ##============================================================================## if (output.terminalAdvanced==TRUE && output.terminal==TRUE){ ##sum of squares writeLines(paste("pseudo-R^2 = ",pR,sep="")) }#end if ##============================================================================## ## Table Output ##============================================================================## ##write output table if values exists if (exists("fit")){ ##set data.frame for a max value of 7 components output.table<-data.frame(NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA, NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA, NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA,NA) output.tableColNames<-c("I01","I01.error","lambda1", "lambda1.error", "cs1","cs1.rel", "I02","I02.error","lambda2", "lambda2.error", "cs2","cs2.rel", "I03","I03.error","lambda3", "lambda3.error", "cs3","cs3.rel", "I04","I04.error","lambda4", "lambda4.error", "cs4","cs4.rel", "I05","I05.error","lambda5", "lambda5.error", "cs5","cs5.rel", "I06","I06.error","lambda6", "lambda6.error", "cs6","cs6.rel", "I07","I07.error","lambda7", "lambda7.error", "cs7","cs7.rel" ) ##write components in output table i<-0 k<-1 while(i<=n.components*6){ output.table[1,i+1]<-I0[k] output.table[1,i+2]<-I0.error[k] output.table[1,i+3]<-lambda[k] output.table[1,i+4]<-lambda.error[k] output.table[1,i+5]<-cs[k] output.table[1,i+6]<-cs.rel[k] i<-i+6 k<-k+1 } ##add pR and n.components output.table<-cbind(sample_code,n.components,output.table,pR) ##alter column names colnames(output.table)<-c("sample_code","n.components", output.tableColNames,"pseudo-R^2") if(missing(output.path)==FALSE){ ##write file with just the header if the file not exists if(file.exists(paste(output.path,"fit_CWCurve_Output_",sample_code,".csv",sep=""))==FALSE){ write.table(output.table,file=paste(output.path,"fit_CWCurve_Output_", sample_code,".csv",sep=""), sep=";" ,row.names=FALSE) }else{ write.table(output.table,file=paste(output.path,"fit_CWCurve_Output_", sample_code,".csv",sep=""), sep=";" ,row.names=FALSE, append=TRUE, col.names=FALSE) }#endif::for write option }#endif::table output ##============================================================================## ## COMPONENT TO SUM CONTRIBUTION PLOT ##============================================================================## ##+++++++++++++++++++++++++++++++ ##set matrix ##set polygon matrix for optional plot output component.contribution.matrix <- matrix(NA, nrow = length(values[,1]), ncol = (2*length(I0)) + 2) ##set x-values component.contribution.matrix[,1] <- values[,1] component.contribution.matrix[,2] <- rev(values[,1]) ##+++++++++++++++++++++++++++++++ ##set 1st polygon ##1st polygon (calculation) y.contribution_first<-(I0[1]*lambda[1]*exp(-lambda[1]*x))/(eval(fit.function))*100 ##avoid NaN values (might happen with synthetic curves) y.contribution_first[is.nan(y.contribution_first)==TRUE] <- 0 ##set values in matrix component.contribution.matrix[,3] <- 100 component.contribution.matrix[,4] <- 100 - rev(y.contribution_first) ##+++++++++++++++++++++++++++++++ ##set polygons in between ##polygons in between (calculate and plot) if (length(I0)>2){ y.contribution_prev <- y.contribution_first i<-2 ##matrix stepping k <- seq(3, ncol(component.contribution.matrix), by=2) while (i<=length(I0)-1) { y.contribution_next<-I0[i]*lambda[i]*exp(-lambda[i]*x)/(eval(fit.function))*100 ##avoid NaN values y.contribution_next[is.nan(y.contribution_next)==TRUE] <- 0 ##set values in matrix component.contribution.matrix[,k[i]] <- 100 - y.contribution_prev component.contribution.matrix[, k[i]+1] <- rev(100-y.contribution_prev- y.contribution_next) y.contribution_prev <- y.contribution_prev + y.contribution_next i <- i+1 }#end while loop }#end if ##+++++++++++++++++++++++++++++++ ##set last polygon ##last polygon (calculation) y.contribution_last <- I0[length(I0)]*lambda[length(lambda)]*exp(-lambda[length(lambda)]*x)/ (eval(fit.function))*100 ##avoid NaN values y.contribution_last[is.nan(y.contribution_last)==TRUE]<-0 component.contribution.matrix[,((2*length(I0))+1)] <- y.contribution_last component.contribution.matrix[,((2*length(I0))+2)] <- 0 ##change names of matrix to make more easy to understand component.contribution.matrix.names <- c( "x", "rev.x", paste(c("y.c","rev.y.c"),rep(1:n.components,each=2), sep="")) ##calculate area for each component, for each time interval component.contribution.matrix.area <- sapply( seq(3,ncol(component.contribution.matrix),by=2), function(x){ matrixStats::rowDiffs(cbind(rev(component.contribution.matrix[,(x+1)]), component.contribution.matrix[,x])) }) ##append to existing matrix component.contribution.matrix <- cbind( component.contribution.matrix, component.contribution.matrix.area, rowSums(component.contribution.matrix.area) ) ##set final column names colnames(component.contribution.matrix) <- c( component.contribution.matrix.names, paste(c("cont.c"),rep(1:n.components,each=1), sep=""), "cont.sum") }#endif :: (exists("fit")) }else{writeLines("[fit_CWCurve()] Fitting Error >> Plot without fit produced!") output.table<-NA component.contribution.matrix <- NA } ##============================================================================## ## PLOTTING ##============================================================================## if(plot==TRUE){ ##grep par parameters par.default <- par(no.readonly = TRUE) ##set colors gallery to provide more colors col <- get("col", pos = .LuminescenceEnv) ##set plot frame if(!inherits(fit, "try-error")){ layout(matrix(c(1,2,3),3,1,byrow=TRUE),c(1.6,1,1), c(1,0.3,0.4),TRUE) par(oma=c(1,1,1,1),mar=c(0,4,3,0),cex=cex.global) }else{ par(cex=cex.global) } ##==uppper plot==## ##open plot area plot(NA,NA, xlim=c(min(x),max(x)), ylim=if(log=="xy"){c(1,max(y))}else{c(0,max(y))}, xlab=if(!inherits(fit, "try-error")){""}else{xlab}, xaxt=if(!inherits(fit, "try-error")){"n"}else{"s"}, ylab=ylab, main=main, log=log) ##plotting measured signal points(x,y,pch=20, col="grey") ##add additional labeling (fitted function) mtext(side=3, sample_code, cex=0.7*cex.global) ##plot sum function if(inherits(fit,"try-error")==FALSE){ lines(x,eval(fit.function), lwd=2, col="black") legend.caption<-"sum curve" curve.col <- 1 ##plot signal curves ##plot curve for additional parameters if(length(I0)>1){ for (i in 1:length(I0)) { curve(I0[i]*lambda[i]*exp(-lambda[i]*x),col=col[i+1], lwd = 2, add = TRUE) legend.caption<-c(legend.caption,paste("component ",i,sep="")) curve.col<-c(curve.col,i+1) } }#end if ##plot legend #legend(y=max(y)*1,"measured values",pch=20, col="gray", bty="n") legend("topright",legend.caption,lty=rep(1,n.components+1,NA),lwd=2,col=col[curve.col], bty="n") ##==lower plot==## ##plot residuals par(mar=c(4.2,4,0,0)) plot(x,residuals(fit), xlim=c(min(x),max(x)), xlab=xlab, type="l", col="grey", ylab="Residual [a.u.]", lwd=2, log=if(log=="x" | log=="xy"){log="x"}else{""} ) ##add 0 line abline(h=0) ##------------------------------------------------------------------------## ##++component to sum contribution plot ++## ##------------------------------------------------------------------------## ##plot component contribution to the whole signal #open plot area par(mar=c(4,4,3.2,0)) plot(NA,NA, xlim=c(min(x),max(x)), ylim=c(0,100), ylab="Contribution [%]", xlab=xlab, main="Component contribution to sum curve", log=if(log=="x" | log=="xy"){log="x"}else{""}) stepping <- seq(3,length(component.contribution.matrix[1,]),2) for(i in 1:length(I0)){ polygon(c(component.contribution.matrix[,1], component.contribution.matrix[,2]), c(component.contribution.matrix[,stepping[i]], component.contribution.matrix[,stepping[i]+1]), col = col[i+1]) } rm(stepping) }#end if try-error for fit par(par.default) rm(par.default) } ##============================================================================## ## Return Values ##============================================================================## newRLumResults.fit_CWCurve <- set_RLum( class = "RLum.Results", data = list( data = output.table, fit = fit, component.contribution.matrix = list(component.contribution.matrix) ), info = list(call = sys.call()) ) rm(fit) rm(output.table) rm(component.contribution.matrix) invisible(newRLumResults.fit_CWCurve) } Luminescence/R/internal_as.latex.table.R0000644000176200001440000001753013125226556017726 0ustar liggesusers#' Create LaTex tables from data.frames and RLum objects #' #' This function takes a data.frame and returns a table in LaTex code that #' can be copied in any tex document. #' #' @param x a \code{\link{data.frame}} or \code{RLum} object #' @param row.names currently unused #' @param col.names currently unused #' @param comments \code{\link{logical}} insert LaTex comments #' @param pos \code{\link{character}} of length one specifying the alignment #' of each column, e.g., pos'clr' for a three column data frame and center, left #' and right alignment #' @param digits \code{\link{numeric}} number of digits (numeric fields) #' @param select a \code{\link{character}} vector passed to \code{\link{subset}} #' @param split an \code{\link{integer}} specifying the number of individual tables #' the data frame is split into. Useful for wide tables. Currently unnused. #' @param ... options: \code{verbose} #' #' @section TODO: #' - Improve by using RegEx to dynamically find error fields, eg. ( "([ ]err)|(^err)" ) #' - #' #' @return #' Returns LaTex code #' #' @examples #' df <- data.frame(x = 1:10, y = letters[1:10]) #' .as.latex.table(df) #' .as.latex.table(df, pos = "lr") #' .as.latex.table(df, select = "y", pos = "r") #' #' @noRd .as.latex.table <- function(x, row.names = NULL, col.names = NULL, comments = TRUE, pos = "c", digits = 3, select, split = NULL, ...) { args <- list(x = x, row.names = row.names, col.names = col.names, comments = comments, pos = pos, digits = digits, split = split, ... = ...) if (!missing(select)) args$select <- select switch(class(x)[1], data.frame = do.call(".as.latex.table.data.frame", args), DRAC.highlights = do.call(".as.latex.table.data.frame", args), RLum.Results = do.call(".as.latex.table.RLum.Results", args)) } ################################################################################ ## "Method" RLum.Results ## ##----------------------------------------------------------------------------## .as.latex.table.RLum.Results <- function(x, row.names = NULL, col.names = NULL, comments = TRUE, pos = "c", digits = 3, select, split = NULL, ...) { ## Object: DRAC.highlights if (x@originator == "use_DRAC") { x <- get_RLum(x)$highlights x <- .digits(x, digits) fields.w.error <- seq(4, 25, 2) for(i in fields.w.error) x[ ,i] <- paste0(x[ ,i], "$\\pm{}$", x[ ,i+1]) x <- x[-c(fields.w.error + 1)] .as.latex.table(x, comments = comments, pos = pos, split = split, ...) }# EndOf::use_DRAC } ################################################################################ ## "Method" data.frame ## ##----------------------------------------------------------------------------## .as.latex.table.data.frame <- function(x, row.names = NULL, col.names = NULL, comments = TRUE, pos = "c", digits = 3, select, split = NULL, ...) { ## Integrity checks ---- if (!is.data.frame(x)) stop("x must be a data frame", call. = FALSE) if (!is.null(col.names) && length(col.names) != ncol(x)) stop("length of col.names does not match the number of columns", call. = FALSE) if (!is.null(row.names) && length(row.names) != nrow(x)) stop("length of row.names does not match the number of rows", call. = FALSE) if (length(pos) != 1) stop("length of pos does not match the number of columns", call. = FALSE) ## Default settings ---- options <- list(verbose = TRUE) ## Override settings ---- options <- modifyList(options, list(...)) ## Subset data frame ---- if (!missing(select)) { is.name <- select %in% names(x) if (any(!is.name)) stop("Undefined columns selected. Please check provided column names in 'select'.", call. = FALSE) x <- subset(x, select = select) } ## Format numeric fields ---- x <- .digits(x, digits) ## Split the table if (is.null(split)) split <- 1 chunks <- ceiling(ncol(x) / split) chunks.start <- seq(1, ncol(x), chunks) chunks.end <- chunks.start + chunks - 1 chunks.end[length(chunks.end)] <- ncol(x) tex.table.list <- vector("list", split) for (i in 1:length(tex.table.list)) { x.chunk <- x[ ,chunks.start[i]:chunks.end[i]] if (ncol(x) == 1) { x.chunk <- as.data.frame(x.chunk) colnames(x.chunk) <- names(x[i]) } ## Comments ---- tex.comment.usePackage <- ifelse(comments, "% add usepackage{adjustbox} to latex preamble \n", "") ## Header ---- col.names <- tex.table.header <- gsub(pattern = " ", x = names(x.chunk), replacement = " \\\\\\\\ ") tex.table.header <- paste0("\t", paste("\\multicolumn{1}{p{2cm}}{\\centering", col.names, "}", collapse = " & \n\t"), "\\\\ \n") ## Rows ---- tex.table.rows <- "" for (j in 1:nrow(x.chunk)) { tex.table.rows <- paste0(tex.table.rows, paste(paste(x.chunk[j, ], collapse = " & "), "\\\\ \n")) } ## Tex table ---- if (nchar(pos) != 1 && nchar(pos) != ncol(x)) pos <- "c" if (!any(strsplit(pos, split = "")[[1]] %in% c("l", "c", "r"))) pos <- "c" if (nchar(pos) == 1) pos <- paste0(rep(pos, ncol(x)), collapse = "") tex.table.begin <- paste0("\\begin{table}[ht] \n", " \\centering \n", " \\begin{adjustbox}{max width=\\textwidth} \n", paste(" \\begin{tabular}{", pos, "}\n"), " \\hline \n") tex.table.end <- paste0(" \\hline \n", " \\end{tabular} \n", " \\end{adjustbox} \n", "\\end{table}") tex.table <- paste0(tex.comment.usePackage, tex.table.begin, tex.table.header, "\\hline \n", tex.table.rows, tex.table.end) if (options$verbose) cat(tex.table) tex.table.list[[i]] <- tex.table } invisible(tex.table.list) } # This function takes a data.frame, checks each column and tries to # force the specified amount of digits if numeric or coercable to numeric .digits <- function(x, digits) { for (i in 1:ncol(x)) { if (is.factor(x[ ,i])) x[ ,i] <- as.character(x[ ,i]) test.numeric <- suppressWarnings(as.numeric(x[ ,i])) if (!is.na(test.numeric[1])) x[ ,i] <- format(test.numeric, nsmall = digits, digits = digits) } return(x) }Luminescence/R/analyse_baSAR.R0000644000176200001440000025366313125226556015702 0ustar liggesusers #' Bayesian models (baSAR) applied on luminescence data #' #' This function allows the application of Bayesian models on luminescence data, measured #' with the single-aliquot regenerative-dose (SAR, Murray and Wintle, 2000) protocol. In particular, #' it follows the idea proposed by Combes et al., 2015 of using an hierarchical model for estimating #' a central equivalent dose from a set of luminescence measurements. This function is (I) the adaption #' of this approach for the R environment and (II) an extension and a technical refinement of the #' published code.\cr #' #' Internally the function consists of two parts: (I) The Bayesian core for the Bayesian calculations #' and applying the hierchical model and (II) a data pre-processing part. The Bayesian core can be run #' independently, if the input data are sufficient (see below). The data pre-processing part was #' implemented to simplify the analysis for the user as all needed data pre-processing is done #' by the function, i.e. in theory it is enough to provide a BIN/BINX-file with the SAR measurement #' data. For the Bayesian analysis for each aliquot the following information are needed from the SAR analysis. #' LxTx, the LxTx error and the dose values for all regeneration points. #' #' \bold{How the systematic error contribution is calculated?}\cr #' #' Standard errors (so far) provided with the source dose rate are considered as systematic uncertainties #' and added to final central dose by: #' #' \deqn{systematic.error = 1/n \sum SE(source.doserate)} #' #' \deqn{SE(central.dose.final) = \sqrt{SE(central.dose)^2 + systematic.error^2}} #' #' Please note that this approach is rather rough and can only be valid if the source dose rate #' errors, in case different readers had been used, are similar. In cases where more than #' one source dose rate is provided a warning is given.\cr #' #' \bold{Input / output scenarios}\cr #' #' Various inputs are allowed for this function. Unfortunately this makes the function handling rather #' complex, but at the same time very powerful. Available scenarios:\cr #' #' \bold{(1) - \code{object} is BIN-file or link to a BIN-file} #' #' Finally it does not matter how the information of the BIN/BINX file are provided. The function #' supports (a) either a path to a file or directory or a \code{list} of file names or paths or (b) #' a \code{\linkS4class{Risoe.BINfileData}} object or a list of these objects. The latter one can #' be produced by using the function \code{\link{read_BIN2R}}, but this function is called automatically #' if only a filename and/or a path is provided. In both cases it will become the data that can be #' used for the analysis. #' #' \code{[XLS_file = NULL]}\cr #' #' If no XLS file (or data frame with the same format) is provided the functions runs an automatic process that #' consists of the following steps: #' #' \itemize{ #' \item Select all valid aliquots using the function \code{\link{verify_SingleGrainData}} #' \item Calculate Lx/Tx values using the function \code{\link{calc_OSLLxTxRatio}} #' \item Calculate De values using the function \code{\link{plot_GrowthCurve}} #' } #' #' These proceeded data are subsequently used in for the Bayesian analysis #' #' \code{[XLS_file != NULL]}\cr #' #' If an XLS-file is provided or a \code{data.frame} providing similar information the pre-processing #' steps consists of the following steps: #' #' \itemize{ #' \item Calculate Lx/Tx values using the function \code{\link{calc_OSLLxTxRatio}} #' \item Calculate De values using the function \code{\link{plot_GrowthCurve}} #' } #' #' Means, the XLS file should contain a selection of the BIN-file names and the aliquots selected #' for the further analysis. This allows a manual selection of input data, as the automatic selection #' by \code{\link{verify_SingleGrainData}} might be not totally sufficient.\cr #' #' #' \bold{(2) - \code{object} \code{RLum.Results object}} #' #' If an \code{\linkS4class{RLum.Results}} object is provided as input and(!) this object was #' previously created by the function \code{analyse_baSAR()} itself, the pre-processing part #' is skipped and the function starts directly the Bayesian analysis. This option is very powerful #' as it allows to change parameters for the Bayesian analysis without the need to repeat #' the data pre-processing. If furthermore the argument \code{aliquot_range} is set, aliquots #' can be manually excluded based on previous runs. \cr #' #' \bold{\code{method_control}}\cr #' #' These are arguments that can be passed directly to the Bayesian calculation core, supported arguments #' are: #' #' \tabular{lll}{ #' \bold{Parameter} \tab \bold{Type} \tab \bold{Descritpion}\cr #' \code{lower_centralD} \tab \code{\link{numeric}} \tab sets the lower bound for the expected De range. Change it only if you know what you are doing!\cr #' \code{upper_centralD} \tab \code{\link{numeric}} \tab sets the upper bound for the expected De range. Change it only if you know what you are doing!\cr #' \code{n.chains} \tab \code{\link{integer}} \tab sets number of parallel chains for the model (default = 3) #' (cf. \code{\link[rjags]{jags.model}})\cr #' \code{inits} \tab \code{\link{list}} \tab option to set initialisation values (cf. \code{\link[rjags]{jags.model}}) \cr #' \code{thin} \tab \code{\link{numeric}} \tab thinning interval for monitoring the Bayesian process (cf. \code{\link[rjags]{jags.model}})\cr #' \code{variable.names} \tab \code{\link{character}} \tab set the variables to be monitored during the MCMC run, default: #' \code{'central_D'}, \code{'sigma_D'}, \code{'D'}, \code{'Q'}, \code{'a'}, \code{'b'}, \code{'c'}, \code{'g'}. #' Note: only variables present in the model can be monitored. #' } #' #' \bold{User defined models}\cr #' #' The function provides the option to modify and to define own models that can be used for #' the Bayesian calculation. In the case the user wants to modify a model, a new model #' can be piped into the funtion via the argument \code{baSAR_model} as \code{character}. #' The model has to be provided in the JAGS dialect of the BUGS language (cf. \code{\link[rjags]{jags.model}}) #' and parameter names given with the pre-defined names have to be respected, otherwise the function #' will break.\cr #' #' \bold{FAQ}\cr #' #' Q: How can I set the seed for the random number generator (RNG)?\cr #' A: Use the argument \code{method_control}, e.g., for three MCMC chains #' (as it is the default):\cr #' \code{method_control = list( #' inits = list( #' list(.RNG.name = "base::Wichmann-Hill", .RNG.seed = 1), #' list(.RNG.name = "base::Wichmann-Hill", .RNG.seed = 2), #' list(.RNG.name = "base::Wichmann-Hill", .RNG.seed = 3) #' ))}\cr #' This sets a reproducible set for every chain separately.\cr #' #' Q: How can I modify the output plots?\cr #' A: You can't, but you can use the function output to create own, modified plots.\cr #' #' Q: Can I change the boundaries for the central_D?\cr #' A: Yes, we made it possible, but we DO NOT recommend it, except you know what you are doing! #' Example: \code{method_control = list(lower_centralD = 10))}\cr #' #' \bold{Additional arguments support via the \code{...} argument }\cr #' #' This list summarizes the additional arguments that can be passed to the internally used #' functions. #' #' \tabular{llll}{ #' \bold{Supported argument} \tab \bold{Corresponding function} \tab \bold{Default} \tab \bold{Short description }\cr #' \code{threshold} \tab \code{\link{verify_SingleGrainData}} \tab \code{30} \tab change rejection threshold for curve selection \cr #' \code{sheet} \tab \code{\link[readxl]{read_excel}} \tab \code{1} \tab select XLS-sheet for import\cr #' \code{col_names} \tab \code{\link[readxl]{read_excel}} \tab \code{TRUE} \tab first row in XLS-file is header\cr #' \code{col_types} \tab \code{\link[readxl]{read_excel}} \tab \code{NULL} \tab limit import to specific columns\cr #' \code{skip} \tab \code{\link[readxl]{read_excel}} \tab \code{0} \tab number of rows to be skipped during import\cr #' \code{n.records} \tab \code{\link{read_BIN2R}} \tab \code{NULL} \tab limit records during BIN-file import\cr #' \code{duplicated.rm} \tab \code{\link{read_BIN2R}} \tab \code{TRUE} \tab remove duplicated records in the BIN-file\cr #' \code{pattern} \tab \code{\link{read_BIN2R}} \tab \code{TRUE} \tab select BIN-file by name pattern\cr #' \code{position} \tab \code{\link{read_BIN2R}} \tab \code{NULL} \tab limit import to a specific position\cr #' \code{background.count.distribution} \tab \code{\link{calc_OSLLxTxRatio}} \tab \code{"non-poisson"} \tab set assumed count distribution\cr #' \code{fit.weights} \tab \code{\link{plot_GrowthCurve}} \tab \code{TRUE} \tab enables / disables fit weights\cr #' \code{fit.bounds} \tab \code{\link{plot_GrowthCurve}} \tab \code{TRUE} \tab enables / disables fit bounds\cr #' \code{NumberIterations.MC} \tab \code{\link{plot_GrowthCurve}} \tab \code{100} \tab number of MC runs for error calculation\cr #' \code{output.plot} \tab \code{\link{plot_GrowthCurve}} \tab \code{TRUE} \tab enables / disables dose response curve plot\cr #' \code{output.plotExtended} \tab \code{\link{plot_GrowthCurve}} \tab \code{TRUE} \tab enables / disables extended dose response curve plot\cr #' } #' #' #' @param object \code{\linkS4class{Risoe.BINfileData}} or \code{\linkS4class{RLum.Results}} or #' \code{\link{character}} or \code{\link{list}} (\bold{required}): #' input object used for the Bayesian analysis. If a \code{character} is provided the function #' assumes a file connection and tries to import a BIN-file using the provided path. If a \code{list} is #' provided the list can only contain either \code{Risoe.BINfileData} objects or \code{character}s #' providing a file connection. Mixing of both types is not allowed. If an \code{\linkS4class{RLum.Results}} #' is provided the function directly starts with the Bayesian Analysis (see details) #' #' @param XLS_file \code{\link{character}} (optional): XLS_file with data for the analysis. This file must contain 3 columns: the name of the file, the disc position and the grain position (the last being 0 for multi-grain measurements). #' Alternatively a \code{data.frame} of similar structure can be provided. #' #' @param aliquot_range \code{\link{numeric}} (optional): allows to limit the range of the aliquots #' used for the analysis. This argument has only an effect if the argument \code{XLS_file} is used or #' the input is the previous output (i.e. is \code{\linkS4class{RLum.Results}}). In this case the #' new selection will add the aliquots to the removed aliquots table. #' #' @param source_doserate \code{\link{numeric}} \bold{(required)}: source dose rate of beta-source used #' for the measuremnt and its uncertainty in Gy/s, e.g., \code{source_doserate = c(0.12, 0.04)}. #' Paramater can be provided as \code{list}, for the case that more than one BIN-file is provided, e.g., #' \code{source_doserate = list(c(0.04, 0.004), c(0.05, 0.004))}. #' #' @param signal.integral \code{\link{vector}} (\bold{required}): vector with the #' limits for the signal integral used for the calculation, e.g., \code{signal.integral = c(1:5)} #' Ignored if \code{object} is an \code{\linkS4class{RLum.Results}} object. #' The parameter can be provided as \code{list}, \code{source_doserate}. #' #' @param signal.integral.Tx \code{\link{vector}} (optional): vector with the #' limits for the signal integral for the Tx curve. If nothing is provided the #' value from \code{signal.integral} is used and it is ignored #' if \code{object} is an \code{\linkS4class{RLum.Results}} object. #' The parameter can be provided as \code{list}, see \code{source_doserate}. #' #' @param background.integral \code{\link{vector}} (\bold{required}): vector with the #' bounds for the background integral. #' Ignored if \code{object} is an \code{\linkS4class{RLum.Results}} object. #' The parameter can be provided as \code{list}, see \code{source_doserate}. #' #' @param background.integral.Tx \code{\link{vector}} (optional): vector with the #' limits for the background integral for the Tx curve. If nothing is provided the #' value from \code{background.integral} is used. #' Ignored if \code{object} is an \code{\linkS4class{RLum.Results}} object. #' The parameter can be provided as \code{list}, see \code{source_doserate}. #' #' @param sigmab \code{\link{numeric}} (with default): option to set a manual value for #' the overdispersion (for LnTx and TnTx), used for the Lx/Tx error #' calculation. The value should be provided as absolute squared count values, cf. \code{\link{calc_OSLLxTxRatio}}. #' The parameter can be provided as \code{list}, see \code{source_doserate}. #' #' @param sig0 \code{\link{numeric}} (with default): allow adding an extra component of error #' to the final Lx/Tx error value (e.g., instrumental errror, see details is \code{\link{calc_OSLLxTxRatio}}). #' The parameter can be provided as \code{list}, see \code{source_doserate}. #' #' @param distribution \code{\link{character}} (with default): type of distribution that is used during #' Bayesian calculations for determining the Central dose and overdispersion values. #' Allowed inputs are \code{"cauchy"}, \code{"normal"} and \code{"log_normal"}. #' #' @param baSAR_model \code{\link{character}} (optional): option to provide an own modified or new model for the #' Bayesian calculation (see details). If an own model is provided the argument \code{distribution} is ignored #' and set to \code{'user_defined'} #' #' @param n.MCMC \code{\link{integer}} (with default): number of iterations for the Markov chain Monte Carlo (MCMC) #' simulations #' #' @param fit.method \code{\link{character}} (with default): fit method used for fitting the growth #' curve using the function \code{\link{plot_GrowthCurve}}. Here supported methods: \code{EXP}, #' \code{EXP+LIN} and \code{LIN} #' #' @param fit.force_through_origin \code{\link{logical}} (with default): force fitting through origin #' #' @param fit.includingRepeatedRegPoints \code{\link{logical}} (with default): #' includes the recycling point (assumed to be measured during the last cycle) #' #' @param method_control \code{\link{list}} (optional): named list of control parameters that can be directly #' passed to the Bayesian analysis, e.g., \code{method_control = list(n.chains = 4)}. #' See details for further information #' #' @param digits \code{\link{integer}} (with default): round output to the number of given digits #' #' @param plot \code{\link{logical}} (with default): enables or disables plot output #' #' @param plot_reduced \code{\link{logical}} (with default): enables or disables the advanced plot output #' #' @param plot.single \code{\link{logical}} (with default): enables or disables single plots or plots #' arranged by analyse_baSAR #' #' @param verbose \code{\link{logical}} (with default): enables or disables verbose mode #' #' @param ... parameters that can be passed to the function \code{\link{calc_OSLLxTxRatio}} (almost full support) #' \code{\link[readxl]{read_excel}} (full support), \code{\link{read_BIN2R}} (\code{n.records}, #' \code{position}, \code{duplicated.rm}), see details. #' #' #' @return Function returns results numerically and graphically:\cr #' #' -----------------------------------\cr #' [ NUMERICAL OUTPUT ]\cr #' -----------------------------------\cr #' \bold{\code{RLum.Reuslts}}-object\cr #' #' \bold{slot:} \bold{\code{@data}}\cr #' \tabular{lll}{ #' \bold{Element} \tab \bold{Type} \tab \bold{Description}\cr #' \code{$summary} \tab \code{data.frame} \tab statistical summary, including the central dose \cr #' \code{$mcmc} \tab \code{mcmc} \tab object including raw output of \code{\link[rjags]{rjags}} \cr #' \code{$models} \tab \code{character} \tab implemented models used in the baSAR-model core \cr #' \code{$input_object} \tab \code{data.frame} \tab summarising table (same format as the XLS-file) including, e.g., Lx/Tx values\cr #' \code{$removed_aliquots} \tab \code{data.frame} \tab table with removed aliquots (e.g., NaN, or Inf Lx/Tx values). If nothing was removed \code{NULL} is returned #' } #' #'\bold{slot:} \bold{\code{@info}}\cr #' #' The original function call\cr #' #' ------------------------\cr #' [ PLOT OUTPUT ]\cr #' ------------------------\cr #' #' \itemize{ #' \item (A) Ln/Tn curves with set integration limits, #' \item (B) trace plots are returned by the baSAR-model, showing the convergence of the parameters (trace) #' and the resulting kernel density plots. If \code{plot_reduced = FALSE} for every(!) dose a trace and #' a density plot is returned (this may take a long time), #' \item (C) dose plots showing the dose for every aliquot as boxplots and the marked #' HPD in within. If boxes are coloured 'orange' or 'red' the aliquot itself should be checked, #' \item (D) the dose response curve resulting from the monitoring of the Bayesian modelling are #' provided along with the Lx/Tx values and the HPD. Note: The amount for curves displayed #' is limited to 1000 (random choice) for performance reasons, #' \item (E) the final plot is the De distribution as calculated using the conventional approach #' and the central dose with the HPDs marked within. #' #' } #' #' \bold{Please note: If distribution was set to \code{log_normal} the central dose is given #' as geometric mean!} #' #' #' @section Function version: 0.1.29 #' #' @author Norbert Mercier, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France), Sebastian Kreutzer, #' IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr #' #' The underlying Bayesian model based on a contribution by Combes et al., 2015. #' #' @seealso \code{\link{read_BIN2R}}, \code{\link{calc_OSLLxTxRatio}}, \code{\link{plot_GrowthCurve}}, #' \code{\link[readxl]{read_excel}}, \code{\link{verify_SingleGrainData}}, #' \code{\link[rjags]{jags.model}}, \code{\link[rjags]{coda.samples}}, \code{\link{boxplot.default}} #' #' #' @references #' #' Combes, B., Philippe, A., Lanos, P., Mercier, N., Tribolo, C., Guerin, G., Guibert, P., Lahaye, C., 2015. #' A Bayesian central equivalent dose model for optically stimulated luminescence dating. #' Quaternary Geochronology 28, 62-70. doi:10.1016/j.quageo.2015.04.001 #' #' Mercier, N., Kreutzer, S., Christophe, C., Guerin, G., Guibert, P., Lahaye, C., Lanos, P., Philippe, A., #' Tribolo, C., 2016. Bayesian statistics in luminescence dating: The 'baSAR'-model and its implementation #' in the R package 'Luminescence'. Ancient TL 34, 14-21. #' #' \bold{Further reading} #' #' Gelman, A., Carlin, J.B., Stern, H.S., Dunson, D.B., Vehtari, A., Rubin, D.B., 2013. #' Bayesian Data Analysis, Third Edition. CRC Press. #' #' 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 #' #' @note \bold{If you provide more than one BIN-file}, it is \bold{strongly} recommanded to provide #' a \code{list} with the same number of elements for the following parameters:\cr #' \code{source_doserate}, \code{signal.integral}, \code{signal.integral.Tx}, \code{background.integral}, #' \code{background.integral.Tx}, \code{sigmab}, \code{sig0}.\cr #' #' Example for two BIN-files: \code{source_doserate = list(c(0.04, 0.006), c(0.05, 0.006))}\cr #' #' \bold{The function is currently limited to work with standard Risoe BIN-files only!} #' #' @keywords datagen #' #' @examples #' #'##(1) load package test data set #'data(ExampleData.BINfileData, envir = environment()) #' #'##(2) selecting relevant curves, and limit dataset #'CWOSL.SAR.Data <- subset( #' CWOSL.SAR.Data, #' subset = POSITION%in%c(1:3) & LTYPE == "OSL") #' #'\dontrun{ #'##(3) run analysis #'##please not that the here selected parameters are #'##choosen for performance, not for reliability #'results <- analyse_baSAR( #' object = CWOSL.SAR.Data, #' source_doserate = c(0.04, 0.001), #' signal.integral = c(1:2), #' background.integral = c(80:100), #' fit.method = "LIN", #' plot = FALSE, #' n.MCMC = 200 #' #') #' #'print(results) #' #' #' ##XLS_file template #' ##copy and paste this the code below in the terminal #' ##you can further use the function write.csv() to export the example #' #' XLS_file <- #' structure( #' list( #' BIN_FILE = NA_character_, #' DISC = NA_real_, #' GRAIN = NA_real_), #' .Names = c("BIN_FILE", "DISC", "GRAIN"), #' class = "data.frame", #' row.names = 1L #' ) #' #' } #' #' @export analyse_baSAR <- function( object, XLS_file = NULL, aliquot_range = NULL, source_doserate = NULL, signal.integral, signal.integral.Tx = NULL, background.integral, background.integral.Tx = NULL, sigmab = 0, sig0 = 0.025, distribution = "cauchy", baSAR_model = NULL, n.MCMC = 100000, fit.method = "EXP", fit.force_through_origin = TRUE, fit.includingRepeatedRegPoints = TRUE, method_control = list(), digits = 3L, plot = TRUE, plot_reduced = TRUE, plot.single = FALSE, verbose = TRUE, ... ){ ##//////////////////////////////////////////////////////////////////////////////////////////////// ##FUNCTION TO BE CALLED to RUN the Bayesian Model ##//////////////////////////////////////////////////////////////////////////////////////////////// ##START .baSAR_function <- function(Nb_aliquots, distribution, data.Dose, data.Lum, data.sLum, fit.method, n.MCMC, fit.force_through_origin, fit.includingRepeatedRegPoints, method_control, baSAR_model, verbose) { ##lower and uppder De, grep from method_control ... for sure we find it here, ##as it was set before the function call lower_centralD <- method_control[["lower_centralD"]] upper_centralD <- method_control[["upper_centralD"]] ##number of MCMC n.chains <- if (is.null(method_control[["n.chains"]])) { 3 } else{ method_control[["n.chains"]] } ##inits inits <- if (is.null(method_control[["inits"]])) { NULL } else{ method_control[["inits"]] } ##thin thin <- if (is.null(method_control[["thin"]])) { if(n.MCMC >= 1e+05){ thin <- n.MCMC/1e+05 * 250 }else{ thin <- 10 } } else{ method_control[["thin"]] } ##variable.names variable.names <- if (is.null(method_control[["variable.names"]])) { c('central_D', 'sigma_D', 'D', 'Q', 'a', 'b', 'c', 'g') } else{ method_control[["variable.names"]] } #check whether this makes sense at all, just a direty and quick test stopifnot(lower_centralD >= 0) Limited_cycles <- vector() if (fit.method == "EXP") {ExpoGC <- 1 ; LinGC <- 0 } if (fit.method == "LIN") {ExpoGC <- 0 ; LinGC <- 1 } if (fit.method == "EXP+LIN") {ExpoGC <- 1 ; LinGC <- 1 } if (fit.force_through_origin == TRUE) {GC_Origin <- 1} else {GC_Origin <- 0} ##Include or exclude repeated dose points if (fit.includingRepeatedRegPoints) { for (i in 1:Nb_aliquots) { Limited_cycles[i] <- length(stats::na.exclude(data.Dose[,i])) } }else{ for (i in 1:Nb_aliquots) { temp.logic <- !duplicated(data.Dose[,i], incomparables=c(0)) # logical excluding 0 m <- length(which(!temp.logic)) data.Dose[,i] <- c(data.Dose[,i][temp.logic], rep(NA, m)) data.Lum[,i] <- c(data.Lum[,i][temp.logic], rep(NA, m)) data.sLum[,i] <- c(data.sLum[,i][temp.logic], rep(NA, m)) rm(m) rm(temp.logic) } for (i in 1:Nb_aliquots) { Limited_cycles[i] <- length(data.Dose[, i]) - length(which(is.na(data.Dose[, i]))) } } ##check and correct for distribution name if(!is.null(baSAR_model)){ if(distribution != "user_defined"){ distribution <- "user_defined" warning("[analyse_baSAR()] 'distribution' set to 'user_defined'.", call. = FALSE) } } # Bayesian Models ---------------------------------------------------------------------------- baSAR_model <- list( cauchy = "model { central_D ~ dunif(lower_centralD,upper_centralD) precision_D ~ dt(0, pow(0.16*central_D, -2), 1)T(0, ) sigma_D <- 1/sqrt(precision_D) for (i in 1:Nb_aliquots) { a[i] ~ dnorm(6.5 , 1/(9.2^2) ) T(0, ) b[i] ~ dnorm(50 , 1/(1000^2) ) T(0, ) c[i] ~ dnorm(1.002 , 1/(0.9^2) ) T(0, ) g[i] ~ dnorm(0.5 , 1/(2.5^2) ) I(-a[i], ) sigma_f[i] ~ dexp (20) D[i] ~ dt ( central_D , precision_D, 1) # Cauchy distribution S_y[1,i] <- 1/(sLum[1,i]^2 + sigma_f[i]^2) Lum[1,i] ~ dnorm ( Q[1,i] , S_y[1,i]) Q[1,i] <- GC_Origin * g[i] + LinGC * (c[i] * D[i] ) + ExpoGC * (a[i] * (1 - exp (-D[i] /b[i])) ) for (m in 2:Limited_cycles[i]) { S_y[m,i] <- 1/(sLum[m,i]^2 + sigma_f[i]^2) Lum[m,i] ~ dnorm( Q[m,i] , S_y[m,i] ) Q[m,i] <- GC_Origin * g[i] + LinGC * (c[i] * Dose[m,i]) + ExpoGC * (a[i] * (1 - exp (-Dose[m,i]/b[i])) ) } } }", normal = "model { central_D ~ dunif(lower_centralD,upper_centralD) sigma_D ~ dunif(0.01, 1 * central_D) for (i in 1:Nb_aliquots) { a[i] ~ dnorm(6.5 , 1/(9.2^2) ) T(0, ) b[i] ~ dnorm(50 , 1/(1000^2) ) T(0, ) c[i] ~ dnorm(1.002 , 1/(0.9^2) ) T(0, ) g[i] ~ dnorm(0.5 , 1/(2.5^2) ) I(-a[i], ) sigma_f[i] ~ dexp (20) D[i] ~ dnorm ( central_D , 1/(sigma_D^2) ) # Normal distribution S_y[1,i] <- 1/(sLum[1,i]^2 + sigma_f[i]^2) Lum[1,i] ~ dnorm ( Q[1,i] , S_y[1,i]) Q[1,i] <- GC_Origin * g[i] + LinGC * (c[i] * D[i] ) + ExpoGC * (a[i] * (1 - exp (-D[i] /b[i])) ) for (m in 2:Limited_cycles[i]) { S_y[m,i] <- 1/(sLum[m,i]^2 + sigma_f[i]^2) Lum[m,i] ~ dnorm( Q[m,i] , S_y[m,i] ) Q[m,i] <- GC_Origin * g[i] + LinGC * (c[i] * Dose[m,i]) + ExpoGC * (a[i] * (1 - exp (-Dose[m,i]/b[i])) ) } } }", log_normal = "model { central_D ~ dunif(lower_centralD,upper_centralD) log_central_D <- log(central_D) - 0.5 * l_sigma_D^2 l_sigma_D ~ dunif(0.01, 1 * log(central_D)) sigma_D <- sqrt((exp(l_sigma_D^2) -1) * exp( 2*log_central_D + l_sigma_D^2) ) for (i in 1:Nb_aliquots) { a[i] ~ dnorm(6.5 , 1/(9.2^2) ) T(0, ) b[i] ~ dnorm(50 , 1/(1000^2) ) T(0, ) c[i] ~ dnorm(1.002 , 1/(0.9^2) ) T(0, ) g[i] ~ dnorm(0.5 , 1/(2.5^2) ) I(-a[i], ) sigma_f[i] ~ dexp (20) log_D[i] ~ dnorm ( log_central_D , 1/(l_sigma_D^2) ) # Log-Normal distribution D[i] <- exp(log_D[i]) S_y[1,i] <- 1/(sLum[1,i]^2 + sigma_f[i]^2) Lum[1,i] ~ dnorm ( Q[1,i] , S_y[1,i]) Q[1,i] <- GC_Origin * g[i] + LinGC * (c[i] * D[i] ) + ExpoGC * (a[i] * (1 - exp (-D[i] /b[i])) ) for (m in 2:Limited_cycles[i]) { S_y[m,i] <- 1/(sLum[m,i]^2 + sigma_f[i]^2) Lum[m,i] ~ dnorm( Q[m,i] , S_y[m,i] ) Q[m,i] <- GC_Origin * g[i] + LinGC * (c[i] * Dose[m,i]) + ExpoGC * (a[i] * (1 - exp (-Dose[m,i]/b[i])) ) } } }", user_defined = baSAR_model ) ##check whether the input for distribution was sufficient if(!any(distribution%in%names(baSAR_model))){ stop(paste0("[analyse_baSAR()] No model is pre-defined for the requested distribution. Please select ", paste(rev(names(baSAR_model))[-1], collapse = ", ")), " or define an own model using the argument 'baSAR_model'!") }else{ if(is.null(baSAR_model)){ stop("[analyse_baSAR()] You have specified a 'user_defined' distribution, but you have not provided a model via 'baSAR_model'!") } } ### Bayesian inputs data_Liste <- list( 'Dose' = data.Dose, 'Lum' = data.Lum, 'sLum' = data.sLum, 'LinGC' = LinGC, 'ExpoGC' = ExpoGC, 'GC_Origin' = GC_Origin, 'Limited_cycles' = Limited_cycles, 'lower_centralD' = lower_centralD, 'upper_centralD' = upper_centralD, 'Nb_aliquots' = Nb_aliquots ) if(verbose){ cat("\n[analyse_baSAR()] ---- baSAR-model ---- \n") cat("\n++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n") cat("[analyse_baSAR()] Bayesian analysis in progress ... ") message(paste(".. >> bounds set to: lower_centralD =", lower_centralD, "| upper_centralD =", upper_centralD)) } Nb_Iterations <- n.MCMC if (verbose) { message(paste0( ".. >> calculation will be done assuming a '", distribution, "' distribution\n" )) } ##set model jagsfit <- rjags::jags.model( file = textConnection(baSAR_model[[distribution]]), data = data_Liste, inits = inits, n.chains = n.chains, n.adapt = Nb_Iterations, quiet = if(verbose){FALSE}else{TRUE} ) ##update jags model (it is a S3-method) update( object = jagsfit, n.iter = Nb_Iterations, progress.bar = if(verbose){"text"}else{NULL} ) ##get data ... full and reduced, the reduced one to limit the plot output sampling <- rjags::coda.samples( model = jagsfit, variable.names = variable.names, n.iter = Nb_Iterations, thin = thin ) ##this we need for the output of the terminal ##Why sampling reduced? Because the summary() method produces a considerable overhead while ##running over all the variables sampling_reduced <- rjags::coda.samples( model = jagsfit, variable.names = c('central_D', 'sigma_D'), n.iter = Nb_Iterations, thin = thin ) pt_zero <- 0 nb_decal <- 2 pt_zero <- Nb_aliquots ##standard error and mean output.mean <- round(summary(sampling_reduced)[[1]][c("central_D", "sigma_D"), 1:2], digits) ##calculate geometric mean for the case that the distribution is log-normal if(distribution == "log_normal"){ temp.vector <- unlist(lapply(sampling_reduced, function(x){as.vector(x[,1])})) gm <- round(exp(sum(log(temp.vector))/length(temp.vector)),digits) rm(temp.vector) }else{ gm <- NULL } ##quantiles ##68% + 95% output.quantiles <- round(summary(sampling_reduced, quantiles = c(0.025, 0.16, 0.84, 0.975))[[2]][c("central_D", "sigma_D"), 1:4], digits) #### output data.frame with results baSAR.output <- data.frame( DISTRIBUTION = distribution, NB_ALIQUOTS = Nb_aliquots, N.CHAINS = n.chains, N.MCMC = n.MCMC, FIT_METHOD = fit.method, CENTRAL = if(is.null(gm)){output.mean[1,1]}else{gm}, CENTRAL.SD = output.mean[1,2], SIGMA = output.mean[2,1], SIGMA.SD = output.mean[2,2], CENTRAL_Q_.16 = output.quantiles[1,2], CENTRAL_Q_.84 = output.quantiles[1,3], SIGMA_Q_.16 = output.quantiles[2,2], SIGMA_Q_.84 = output.quantiles[2,3], CENTRAL_Q_.025 = output.quantiles[1,1], CENTRAL_Q_.975 = output.quantiles[1,4], SIGMA_Q_.025 = output.quantiles[2,1], SIGMA_Q_.975 = output.quantiles[2,4] ) return( baSAR.output = list( baSAR.output_summary = baSAR.output, baSAR.output_mcmc = sampling, models = list( cauchy = baSAR_model[["cauchy"]], normal = baSAR_model[["normal"]], log_normal = baSAR_model[["log_normal"]], user_defined = baSAR_model[["user_defined"]] ) ) ) } ##END ##//////////////////////////////////////////////////////////////////////////////////////////////// # Integrity tests ----------------------------------------------------------------------------- ##check whether rjags is available ##code snippet taken from ##http://r-pkgs.had.co.nz/description.html if (!requireNamespace("rjags", quietly = TRUE)) { stop("[analyse_baSAR()] To use this function you have to first install the package 'rjags'.", call. = FALSE) } if (!requireNamespace("coda", quietly = TRUE)) { stop("[analyse_baSAR()] To use this function you have to first install the package 'coda'.", call. = FALSE) } #capture additional piped arguments additional_arguments <- list( ##verify_SingleGrainData threshold = 30, ##calc_OSLLxTxRatio() background.count.distribution = "non-poisson", ##readxl::read_excel() sheet = 1, col_names = TRUE, col_types = NULL, skip = 0, ##read_BIN2R() n.records = NULL, duplicated.rm = TRUE, position = NULL, pattern = NULL, ##plot_GrowthCurve() fit.weights = TRUE, fit.bounds = TRUE, NumberIterations.MC = 100, output.plot = if(plot){TRUE}else{FALSE}, output.plotExtended = if(plot){TRUE}else{FALSE} ) #modify this list on purpose additional_arguments <- modifyList(x = additional_arguments, val = list(...)) ##set function arguments function_arguments <- NULL ##SET fit.method if (fit.method != "EXP" & fit.method != "EXP+LIN" & fit.method != "LIN"){ stop("[analyse_baSAR()] Unsupported fitting method. Supported: 'EXP', 'EXP+LIN' and 'LIN'") } # Set input ----------------------------------------------------------------------------------- ##if the input is alreayd of type RLum.Results, use the input and do not run ##all pre-calculations again if(is(object, "RLum.Results")){ if(object@originator == "analyse_baSAR"){ ##We want to use previous function arguments and recycle them ##(1) get information you need as input from the RLum.Results object function_arguments <- as.list(object@info$call) ##(2) overwrite by current provided arguments ##by using a new argument we have the choise which argument is allowed for ##changes function_arguments.new <- modifyList(x = function_arguments, val = as.list(match.call())) ##get maximum cycles max_cycles <- max(object$input_object[["CYCLES_NB"]]) ##set Nb_aliquots Nb_aliquots <- nrow(object$input_object) ##return NULL if not a minium of three aliquots are used for the calculation if(Nb_aliquots < 2){ try(stop("[analyse_baSAR()] number of aliquots < 3, this makes no sense, NULL returned!", call. = FALSE)) return(NULL) } ##set variables ##Why is.null() ... it prevents that the function crashed is nothing is provided ... ##set changeable function arguments ##distribution if(!is.null(function_arguments.new$distribution)){ distribution <- function_arguments.new$distribution } ##n.MCMC if(!is.null(function_arguments.new$n.MCMC)){ n.MCMC <- function_arguments.new$n.MCMC } ##fit.method if(!is.null(function_arguments.new$fit.method)){ fit.method <- function_arguments.new$fit.method } ## fit.force_through_origin if(!is.null(function_arguments.new$fit.force_through_origin)){ fit.force_through_origin <- function_arguments.new$fit.force_through_origin } ##fit.includingRepeatedRegPoints if(!is.null(function_arguments.new$fit.includingRepeatedRegPoints)){ fit.includingRepeatedRegPoints <- function_arguments.new$fit.includingRepeatedRegPoints } ##source_doserate if(length(as.list(match.call())$source_doserate) > 0){ warning("[analyse_baSAR()] Argument 'source_doserate' is ignored in this modus, as it was alreay set.", call. = FALSE) } ##aliquot_range if(!is.null(function_arguments.new$aliquot_range)){ aliquot_range <- eval(function_arguments.new$aliquot_range) } ##method_control if(!is.null(function_arguments.new$method_control)){ method_control <- eval(function_arguments.new$method_control) } ##baSAR_model if(!is.null(function_arguments.new$baSAR_model)){ baSAR_model <- eval(function_arguments.new$baSAR_model) } ##plot if(!is.null(function_arguments.new$plot)){ plot <- function_arguments.new$plot } ##verbose if(!is.null(function_arguments.new$verbose)){ verbose <- function_arguments.new$verbose } ##limit according to aliquot_range ##TODO Take car of the case that this was provided, otherwise more and more is removed! if (!is.null(aliquot_range)) { if (max(aliquot_range) <= nrow(object$input_object)) { input_object <- object$input_object[aliquot_range, ] ##update list of removed aliquots removed_aliquots <-rbind(object$removed_aliquots, object$input_object[-aliquot_range,]) ##correct Nb_aliquots Nb_aliquots <- nrow(input_object) } else{ try(stop("[analyse_basAR()] aliquot_range out of bounds! Input ignored!", call. = FALSE)) ##reset aliquot range aliquot_range <- NULL ##take entire object input_object <- object$input_object ##set removed aliquots removed_aliquots <- object$removed_aliquots } } else{ ##set the normal case input_object <- object$input_object ##set removed aliquots removed_aliquots <- object$removed_aliquots } ##set non function arguments Doses <- t(input_object[,9:(8 + max_cycles)]) LxTx <- t(input_object[,(9 + max_cycles):(8 + 2 * max_cycles)]) LxTx.error <- t(input_object[,(9 + 2 * max_cycles):(8 + 3 * max_cycles)]) rm(max_cycles) }else{ stop("[analyse_baSAR()] 'object' is of type 'RLum.Results', but has not been produced by analyse_baSAR()!") } }else{ if(verbose){ cat("\n[analyse_baSAR()] ---- PREPROCESSING ----") } ##Supported input types are: ## (1) BIN-file ## .. list ## .. character ## (2) RisoeBINfileData object ## .. list ## .. S4 if (is(object, "Risoe.BINfileData")) { fileBIN.list <- list(object) } else if (is(object, "list")) { ##check what the list containes ... object_type <- unique(unlist(lapply( 1:length(object), FUN = function(x) { is(object[[x]])[1] } ))) if (length(object_type) == 1) { if (object_type == "Risoe.BINfileData") { fileBIN.list <- object } else if (object_type == "character") { fileBIN.list <- read_BIN2R( file = object, position = additional_arguments$position, duplicated.rm = additional_arguments$duplicated.rm, n.records = additional_arguments$n.records, pattern = additional_arguments$pattern, verbose = verbose ) } else{ stop( "[analyse_baSAR()] data type in the input list provided for 'object' is not supported!" ) } } else{ stop("[analyse_baSAR()] 'object' only accepts a list with objects of similar type!") } } else if (is(object, "character")) { fileBIN.list <- list( read_BIN2R( file = object, position = additional_arguments$position, duplicated.rm = additional_arguments$duplicated.rm, n.records = additional_arguments$n.records, verbose = verbose ) ) } else{ stop( paste0( "[analyse_baSAR()] '", is(object)[1], "' as input is not supported. Check manual for allowed input objects." ) ) } ##Problem ... the user might have made a pre-selection in the Analyst software, if this the ##we respect this selection if(!all(unlist(lapply(fileBIN.list, FUN = function(x){(x@METADATA[["SEL"]])})))){ fileBIN.list <- lapply(fileBIN.list, function(x){ ##reduce data x@DATA <- x@DATA[x@METADATA[["SEL"]]] x@METADATA <- x@METADATA[x@METADATA[["SEL"]], ] ##reset index x@METADATA[["ID"]] <- 1:nrow(x@METADATA) return(x) }) if(verbose){ cat("\n[analyse_baSAR()] Record pre-selection in BIN-file detected >> record reduced to selection") } } # Declare variables --------------------------------------------------------------------------- Dose <- list() LxTx <- list() sLxTx <- list() Disc <- list() Grain <- list() Disc_Grain.list <- list() Nb_aliquots <- 0 previous.Nb_aliquots <- 0 object.file_name <- list() Mono_grain <- TRUE Limited_cycles <- vector() ##set information for (i in 1 : length(fileBIN.list)) { Disc[[i]] <- list() Grain[[i]] <- list() ##get BIN-file name object.file_name[[i]] <- unique(fileBIN.list[[i]]@METADATA[["FNAME"]]) } ##check for duplicated entries; remove them as they would cause a function crash if(any(duplicated(unlist(object.file_name)))){ ##provide messages if(verbose){ message(paste0( "[analyse_baSAR()] '", paste( object.file_name[which(duplicated(unlist(object.file_name)))], collapse = ", ", "' is a duplicate and therefore removed from the input!" ) )) } warning(paste0( "[analyse_baSAR()] '", paste( object.file_name[which(duplicated(unlist(object.file_name)))], collapse = ", ", "' is a duplicate and therefore removed from the input!" ) )) ##remove entry Disc[which(duplicated(unlist(object.file_name)))] <- NULL Grain[which(duplicated(unlist(object.file_name)))] <- NULL fileBIN.list[which(duplicated(unlist(object.file_name)))] <- NULL object.file_name[which(duplicated(unlist(object.file_name)))] <- NULL } # Expand parameter list ----------------------------------------------------------------------- ##test_parameter = source_doserate if(!is.null(source_doserate)){ if(is(source_doserate, "list")){ source_doserate <- rep(source_doserate, length = length(fileBIN.list)) }else{ source_doserate <- rep(list(source_doserate), length = length(fileBIN.list)) } }else{ stop("[analyse_baSAR()] 'source_doserate' is missing, but required as the current implementation expects dose values in Gy!") } ##sigmab if(is(sigmab, "list")){ sigmab <- rep(sigmab, length = length(fileBIN.list)) }else{ sigmab <- rep(list(sigmab), length = length(fileBIN.list)) } ##sig0 if(is(sig0, "list")){ sig0 <- rep(sig0, length = length(fileBIN.list)) }else{ sig0 <- rep(list(sig0), length = length(fileBIN.list)) } ##test_parameter = signal.integral if(is(signal.integral, "list")){ signal.integral <- rep(signal.integral, length = length(fileBIN.list)) }else{ signal.integral <- rep(list(signal.integral), length = length(fileBIN.list)) } ##test_parameter = signal.integral.Tx if (!is.null(signal.integral.Tx)) { if (is(signal.integral.Tx, "list")) { signal.integral.Tx <- rep(signal.integral.Tx, length = length(fileBIN.list)) } else{ signal.integral.Tx <- rep(list(signal.integral.Tx), length = length(fileBIN.list)) } } ##test_parameter = background.integral if(is(background.integral, "list")){ background.integral <- rep(background.integral, length = length(fileBIN.list)) }else{ background.integral <- rep(list(background.integral), length = length(fileBIN.list)) } ##test_parameter = background.integral if(is(background.integral, "list")){ background.integral <- rep(background.integral, length = length(fileBIN.list)) }else{ background.integral <- rep(list(background.integral), length = length(fileBIN.list)) } ##test_parameter = background.integral.Tx if (!is.null(background.integral.Tx)) { if (is(background.integral.Tx, "list")) { background.integral.Tx <- rep(background.integral.Tx, length = length(fileBIN.list)) } else{ background.integral.Tx <- rep(list(background.integral.Tx), length = length(fileBIN.list)) } } # Read EXCEL sheet ---------------------------------------------------------------------------- if(is.null(XLS_file)){ ##select aliquots giving light only, this function accepts also a list as input if(verbose){ cat("\n[analyse_baSAR()] No XLS-file provided, running automatic grain selection ...") } for (k in 1:length(fileBIN.list)) { ##if the uses provides only multiple grain data (GRAIN == 0), the verification ##here makes not really sense and should be skipped if(length(unique(fileBIN.list[[k]]@METADATA[["GRAIN"]])) > 1){ aliquot_selection <- verify_SingleGrainData( object = fileBIN.list[[k]], cleanup_level = "aliquot", threshold = additional_arguments$threshold, cleanup = FALSE ) ##remove grain position 0 (this are usually TL measurements on the cup or we are talking about multipe aliquot) if (sum(aliquot_selection$unique_pairs[["GRAIN"]] == 0, na.rm = TRUE) > 0) { warning( paste( "[analyse_baSAR()] Automatic grain selection:", sum(aliquot_selection$unique_pairs[["GRAIN"]] == 0, na.rm = TRUE), "curve(s) with grain index 0 had been removed from the dataset." ), call. = FALSE ) } datalu <- aliquot_selection$unique_pairs[!aliquot_selection$unique_pairs[["GRAIN"]] == 0,] if(nrow(datalu) == 0){ try(stop("[analyse_baSAR()] Sorry, nothing was left after the automatic grain selection! NULL returned!", call. = FALSE)) return(NULL) } }else{ warning("[analyse_baSAR()] Only multiple grain data provided, automatic selection skipped!", call. = FALSE) datalu <- unique(fileBIN.list[[k]]@METADATA[, c("POSITION", "GRAIN")]) ##set mono grain to FALSE Mono_grain <- FALSE aliquot_selection <- NA } ##get number of aliquots (one aliquot has a position and a grain number) Nb_aliquots <- nrow(datalu) ##write information in variables Disc[[k]] <- datalu[["POSITION"]] Grain[[k]] <- datalu[["GRAIN"]] ##free memory rm(datalu, aliquot_selection) } rm(k) } else if (is(XLS_file, "data.frame") || is(XLS_file, "character")) { ##load file if we have an XLS file if (is(XLS_file, "character")) { ##test for valid file if(!file.exists(XLS_file)){ stop("[analyse_baSAR()] XLS_file does not exist!") } ##import Excel sheet datalu <- as.data.frame(readxl::read_excel( path = XLS_file, sheet = additional_arguments$sheet, col_names = additional_arguments$col_names, col_types = additional_arguments$col_types, skip = additional_arguments$skip ), stringsAsFactors = FALSE) ###check whether data format is somehow odd, check only the first three columns if(!all(grepl(colnames(datalu), pattern = " ")[1:3])){ stop("[analyse_baSAR()] One of the first three columns in your XLS_file has no column header. Your XLS_file requires at least three columns for 'BIN_file', 'DISC' and 'GRAIN'", call. = FALSE) } ##get rid of empty rows if the BIN_FILE name column is empty datalu <- datalu[!is.na(datalu[[1]]), ] } else{ datalu <- XLS_file ##check number of number of columns in data.frame if(ncol(datalu) < 3){ stop("[analyse_baSAR()] The data.frame provided via XLS_file should consist of at least three columns (see manual)!", call. = FALSE) } ##problem: the first column should be of type character, the others are ##of type numeric, unfortunately it is too risky to rely on the user, we do the ##proper conversion by ourself ... datalu[[1]] <- as.character(datalu[[1]]) datalu[[2]] <- as.numeric(datalu[[2]]) datalu[[3]] <- as.numeric(datalu[[3]]) } ##limit aliquot range if (!is.null(aliquot_range)) { datalu <- datalu[aliquot_range,] } Nb_ali <- 0 k <- NULL for (nn in 1:length((datalu[, 1]))) { if (!is.na(datalu[nn, 1])) { ##check wether one file fits if (any(grepl( pattern = strsplit( x = basename(datalu[nn, 1]), split = ".", fixed = TRUE )[[1]][1], x = unlist(object.file_name) ))) { k <- grep(pattern = strsplit( x = basename(datalu[nn, 1]), split = ".", fixed = TRUE )[[1]][1], x = unlist(object.file_name)) nj <- length(Disc[[k]]) + 1 Disc[[k]][nj] <- as.numeric(datalu[nn, 2]) Grain[[k]][nj] <- as.numeric(datalu[nn, 3]) Nb_ali <- Nb_ali + 1 if (is.na(Grain[[k]][nj]) || Grain[[k]][nj] == 0) { Mono_grain <- FALSE } }else{ warning( paste0("[analyse_baSAR] '", (datalu[nn, 1]), "' not recognized or not loaded; skipped!"), call. = FALSE ) } } else{ if (Nb_ali == 0) { stop("[analyse_baSAR()] Nb. discs/grains = 0 !") } break() } } ##if k is NULL it means it was not set so far, so there was ##no corresponding BIN-file found if(is.null(k)){ stop("[analyse_baSAR()] BIN-file names in XLS-file do not fit to the loaded BIN-files!") } } else{ stop("[analyse_baSAR()] input type for 'XLS_file' not supported!") } ###################################### loops on files_number for (k in 1:length(fileBIN.list)) { Disc_Grain.list[[k]] <- list() # data.file number n_aliquots_k <- length((Disc[[k]])) if(n_aliquots_k == 0){ fileBIN.list[[k]] <- NULL if(verbose){ message(paste("[analyse_baSAR()] No data has been seletecd from BIN-file", k, ">> BIN-file removed from input!")) } warning(paste("[analyse_baSAR()] No data has been seletecd from BIN-file", k, ">> BIN-file removed from input!"), call. = FALSE) next() } for (d in 1:n_aliquots_k) { dd <- as.integer(unlist(Disc[[k]][d])) Disc_Grain.list[[k]][[dd]] <- list() # data.file number , disc_number } for (d in 1:n_aliquots_k) { dd <- as.integer(unlist(Disc[[k]][d])) if (Mono_grain == FALSE) { gg <- 1 } if (Mono_grain == TRUE) { gg <- as.integer(unlist(Grain[[k]][d]))} Disc_Grain.list[[k]][[dd]][[gg]] <- list() # data.file number , disc_number, grain_number for (z in 1:6) { Disc_Grain.list[[k]][[dd]][[gg]][[z]] <- list() # 1 = index numbers, 2 = irradiation doses, 3 = LxTx , 4 = sLxTx, 5 = N d'aliquot, 6 = De +- D0 +- (4 values) } } } if(verbose){ cat("\n[analyse_baSAR()] Preliminary analysis in progress ... ") cat("\n[analyse_baSAR()] Hang on, this may take a long time ... \n") } for (k in 1:length(fileBIN.list)) { n_index.vector <- vector("numeric") measured_discs.vector <- vector("numeric") measured_grains.vector <- vector("numeric") measured_grains.vector_list <- vector("numeric") irrad_time.vector <- vector("numeric") disc_pos <- vector("numeric") grain_pos <- vector("numeric") ### METADATA length_BIN <- length(fileBIN.list[[k]]) n_index.vector <- fileBIN.list[[k]]@METADATA[["ID"]][1:length_BIN] # curves indexes vector measured_discs.vector <- fileBIN.list[[k]]@METADATA[["POSITION"]][1:length_BIN] # measured discs vector measured_grains.vector <- fileBIN.list[[k]]@METADATA[["GRAIN"]][1:length_BIN] # measured grains vector irrad_time.vector <- fileBIN.list[[k]]@METADATA[["IRR_TIME"]][1:length_BIN] # irradiation durations vector ##if all irradiation times are 0 we should stop here if (length(unique(irrad_time.vector)) == 1) { try(stop( "[analyse_baSAR()] It appears the the irradiation times are all the same. Analysis stopped an NULL returned!", call. = FALSE )) return(NULL) } disc_pos <- as.integer(unlist(Disc[[k]])) grain_pos <- as.integer(unlist(Grain[[k]])) ### Automatic Filling - Disc_Grain.list for (i in 1: length(Disc[[k]])) { disc_selected <- as.integer(Disc[[k]][i]) if (Mono_grain == TRUE) {grain_selected <- as.integer(Grain[[k]][i])} else { grain_selected <-0} ##hard break if the disc number or grain number does not fit ##disc (position) disc_logic <- (disc_selected == measured_discs.vector) if (!any(disc_logic)) { try(stop( paste0( "[analyse_baSAR()] In BIN-file '", unique(fileBIN.list[[k]]@METADATA[["FNAME"]]), "' position number ", disc_selected, " does not exist! NULL returned!" ), call. = FALSE )) return(NULL) } ##grain grain_logic <- (grain_selected == measured_grains.vector) if (!any(grain_logic)) { try(stop( paste0( "[analyse_baSAR()] In BIN-file '", unique(fileBIN.list[[k]]@METADATA[["FNAME"]]), "' grain number ", grain_selected, " does not exist! NULL returned!" ), call. = FALSE )) return(NULL) } ##if the test passed, compile index list index_liste <- n_index.vector[disc_logic & grain_logic] if (Mono_grain == FALSE) { grain_selected <-1} for (kn in 1: length(index_liste)) { t <- index_liste[kn] ##check if the source_doserate is NULL or not if(!is.null(unlist(source_doserate))){ dose.value <- irrad_time.vector[t] * unlist(source_doserate[[k]][1]) }else{ dose.value <- irrad_time.vector[t] } s <- 1 + length( Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[1]] ) Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[1]][s] <- n_index.vector[t] # indexes if ( s%%2 == 1) { Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[2]][as.integer(1+s/2)] <- dose.value } # irradiation doses } } } ###################### Data associated with a single Disc/Grain max_cycles <- 0 count <- 1 calc_OSLLxTxRatio_warning <- list() for (k in 1:length(fileBIN.list)) { if (Mono_grain == TRUE) (max.grains <- 100) else (max.grains <- 1) ##plot Ln and Tn curves if wanted ##we want to plot the Ln and Tn curves to get a better feeling ##The approach here is rather rough coded, but it works if (plot) { curve_index <- vapply((1:length(Disc[[k]])), function(i) { disc_selected <- as.integer(Disc[[k]][i]) if (Mono_grain == TRUE) { grain_selected <- as.integer(Grain[[k]][i]) } else { grain_selected <- 1 } Ln_index <- as.numeric(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[1]][1]) Tn_index <- as.numeric(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[1]][2]) return(c(Ln_index, Tn_index)) }, FUN.VALUE = vector(mode = "numeric", length = 2)) ##set matrix for Ln values Ln_matrix <- cbind(1:length(fileBIN.list[[k]]@DATA[[curve_index[1, 1]]]), matrix(unlist(fileBIN.list[[k]]@DATA[curve_index[1, ]]), ncol = ncol(curve_index))) Tn_matrix <- cbind(1:length(fileBIN.list[[k]]@DATA[[curve_index[2, 1]]]), matrix(unlist(fileBIN.list[[k]]@DATA[curve_index[2, ]]), ncol = ncol(curve_index))) ##open plot are if(!plot.single){ par.default <- par()$mfrow par(mfrow = c(1, 2)) } ##get natural curve and combine them in matrix graphics::matplot( x = Ln_matrix[, 1], y = Ln_matrix[, -1], col = rgb(0, 0, 0, 0.3), ylab = "Luminescence [a.u.]", xlab = "Channel", main = expression(paste(L[n], " - curves")), type = "l" ) ##add integration limits abline(v = range(signal.integral[[k]]), lty = 2, col = "green") abline(v = range(background.integral[[k]]), lty = 2, col = "red") mtext(paste0("ALQ: ",count, ":", count + ncol(curve_index))) graphics::matplot( x = Tn_matrix[, 1], y = Tn_matrix[, -1], col = rgb(0, 0, 0, 0.3), ylab = "Luminescence [a.u.]", xlab = "Channel", main = expression(paste(T[n], " - curves")), type = "l" ) ##add integration limits depending on the choosen value if(is.null(signal.integral.Tx[[k]])){ abline(v = range(signal.integral[[k]]), lty = 2, col = "green") }else{ abline(v = range(signal.integral.Tx[[k]]), lty = 2, col = "green") } if(is.null(background.integral.Tx[[k]])){ abline(v = range(background.integral[[k]]), lty = 2, col = "red") }else{ abline(v = range(background.integral.Tx[[k]]), lty = 2, col = "red") } mtext(paste0("ALQ: ",count, ":", count + ncol(curve_index))) ##reset par if(!plot.single){ par(mfrow = par.default) } ##remove some variables rm(curve_index, Ln_matrix, Tn_matrix) } for (i in 1:length(Disc[[k]])) { disc_selected <- as.integer(Disc[[k]][i]) if (Mono_grain == TRUE) { grain_selected <- as.integer(Grain[[k]][i]) } else { grain_selected <- 1 } # Data for the selected Disc-Grain for (nb_index in 1:((length(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[1]]))/2 )) { index1 <- as.numeric(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[1]][2*nb_index-1]) index2 <- as.numeric(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[1]][2*nb_index]) Lx.data <- data.frame(seq(1:length( fileBIN.list[[k]]@DATA[[index1]])), fileBIN.list[[k]]@DATA[[index1]]) Tx.data <- data.frame(seq(1:length( fileBIN.list[[k]]@DATA[[index2]])), fileBIN.list[[k]]@DATA[[index2]]) ## call calc_OSLLxTxRatio() ## we run this function with a warnings catcher to reduce the load of warnings for the user temp_LxTx <- withCallingHandlers( calc_OSLLxTxRatio( Lx.data = Lx.data, Tx.data = Tx.data, signal.integral = signal.integral[[k]], signal.integral.Tx = signal.integral.Tx[[k]], background.integral = background.integral[[k]], background.integral.Tx = background.integral.Tx[[k]], background.count.distribution = additional_arguments$background.count.distribution, sigmab = sigmab[[k]], sig0 = sig0[[k]] ), warning = function(c) { calc_OSLLxTxRatio_warning[[i]] <<- c invokeRestart("muffleWarning") } ) ##get LxTx table LxTx.table <- temp_LxTx$LxTx.table Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[3]][nb_index] <- LxTx.table[[9]] Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[4]][nb_index] <- LxTx.table[[10]] Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[5]][nb_index] <- LxTx.table[[7]] ##free memory rm(LxTx.table) rm(temp_LxTx) } # Fitting Growth curve and Plot sample_dose <- unlist(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[2]]) sample_LxTx <- unlist(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[3]]) sample_sLxTx <- unlist(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[4]]) TnTx <- unlist(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[5]]) ##create needed data.frame (this way to make sure that rows are doubled if something is missing) selected_sample <- as.data.frame(cbind(sample_dose, sample_LxTx, sample_sLxTx, TnTx)) ##call plot_GrowthCurve() to get De and De value fitcurve <- suppressWarnings(plot_GrowthCurve( sample = selected_sample, na.rm = TRUE, fit.method = fit.method, fit.force_through_origin = fit.force_through_origin, fit.weights = additional_arguments$fit.weights, fit.includingRepeatedRegPoints = fit.includingRepeatedRegPoints, fit.bounds = additional_arguments$fit.bounds, NumberIterations.MC = additional_arguments$NumberIterations.MC, output.plot = additional_arguments$output.plot, output.plotExtended = additional_arguments$output.plotExtended, txtProgressBar = FALSE, verbose = verbose, main = paste0("ALQ: ", count," | POS: ", Disc[[k]][i], " | GRAIN: ", Grain[[k]][i]) )) ##get data.frame with De values if(!is.null(fitcurve)){ fitcurve_De <- get_RLum(fitcurve, data.object = "De") Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[6]][1] <- fitcurve_De[["De"]] Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[6]][2] <- fitcurve_De[["De.Error"]] Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[6]][3] <- fitcurve_De[["D01"]] Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[6]][4] <- fitcurve_De[["D01.ERROR"]] }else{ ##we have to do this, otherwise the grains will be sorted out Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[6]][1:4] <- NA } Limited_cycles[previous.Nb_aliquots + i] <- length(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[2]]) if (length(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[2]]) > max_cycles) { max_cycles <- length(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[2]]) } previous.Nb_aliquots <- length(Limited_cycles) # Total count of aliquots count <- count + 1 } } ## END of loop on BIN files rm(count) ##evaluate warnings from calc_OSLLxTxRatio() if(length(calc_OSLLxTxRatio_warning)>0){ w_table <- table(unlist(calc_OSLLxTxRatio_warning)) w_table_names <- names(w_table) for(w in 1:length(w_table)){ warning(paste(w_table_names[w], "This warning occurred", w_table[w], "times!"), call. = FALSE) } rm(w_table) rm(w_table_names) } rm(calc_OSLLxTxRatio_warning) Nb_aliquots <- previous.Nb_aliquots ##create results matrix OUTPUT_results <- matrix(nrow = Nb_aliquots, ncol = (8 + 3 * max_cycles), byrow = TRUE) ## set column name (this makes it much easier to debug) colnames(OUTPUT_results) <- c( "INDEX_BINfile", "DISC", "GRAIN", "DE", "DE.SD", "D0", "D0.SD", "CYCLES_NB", paste0("DOSE_", 1:max_cycles), paste0("LxTx_", 1:max_cycles), paste0("LxTx_", 1:max_cycles, ".SD") ) comptage <- 0 for (k in 1:length(fileBIN.list)) { for (i in 1:length(Disc[[k]])) { disc_selected <- as.numeric(Disc[[k]][i]) if (Mono_grain == TRUE) { grain_selected <- as.numeric(Grain[[k]][i]) } else { grain_selected <- 1 } comptage <- comptage + 1 OUTPUT_results[comptage, 1] <- k OUTPUT_results[comptage, 2] <- as.numeric(disc_selected) if (Mono_grain == TRUE) { OUTPUT_results[comptage, 3] <- grain_selected } else { OUTPUT_results[comptage, 3] <- 0 } if (length(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[6]]) != 0) { ##DE OUTPUT_results[comptage, 4] <- as.numeric(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[6]][1]) ##DE.SD OUTPUT_results[comptage, 5] <- as.numeric(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[6]][2]) ##D0 OUTPUT_results[comptage, 6] <- as.numeric(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[6]][3]) ##D0.SD OUTPUT_results[comptage, 7] <- as.numeric(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[6]][4]) ##CYCLES_NB OUTPUT_results[comptage, 8] <- length(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[2]]) ##auxillary variable llong <- length(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[2]]) ##Dose OUTPUT_results[comptage, 9:(8 + llong)] <- as.numeric(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[2]]) ##LxTx values OUTPUT_results[comptage, (9 + max_cycles):(8 + max_cycles + llong)] <- as.numeric(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[3]]) ##LxTx SD values OUTPUT_results[comptage, (9 + 2*max_cycles):(8 + 2*max_cycles + llong)] <- as.numeric(Disc_Grain.list[[k]][[disc_selected]][[grain_selected]][[4]]) } } } ##Clean matrix and remove all unwanted entries ##remove all NA columns, means all NA columns in POSITION and DISC ##this NA values are no calculation artefacts, but coming from the data processing and have ##no further value OUTPUT_results <- OUTPUT_results[!is.na(OUTPUT_results[,2]),] ##clean up NaN values in the LxTx and corresponding error values ##the transposition of the matrix may increase the performance for very large matricies OUTPUT_results_reduced <- t(OUTPUT_results) selection <- vapply(X = 1:ncol(OUTPUT_results_reduced), FUN = function(x){ !any(is.nan(OUTPUT_results_reduced[9:(8+3*max_cycles), x]) | is.infinite(OUTPUT_results_reduced[9:(8+3*max_cycles), x])) }, FUN.VALUE = vector(mode = "logical", length = 1)) removed_aliquots <- t(OUTPUT_results_reduced[,!selection]) OUTPUT_results_reduced <- t(OUTPUT_results_reduced[,selection]) ##finally, check for difference in the number of dose points ... they should be the same if(length(unique(OUTPUT_results_reduced[,"CYCLES_NB"])) > 1){ warning("[analyse_baSAR()] The number of dose points differs across your data set. Check your data!", call. = FALSE) } ##correct number of aliquots if necessary if(Nb_aliquots > nrow(OUTPUT_results_reduced)) { Nb_aliquots <- nrow(OUTPUT_results_reduced) warning( paste0( "[analyse_baSAR()] 'Nb_aliquots' corrected due to NaN or Inf values in Lx and/or Tx to ", Nb_aliquots, ". You might want to check 'removed_aliquots' in the function output."), call. = FALSE) } ##Prepare for Bayesian analysis Doses <- t(OUTPUT_results_reduced[,9:(8 + max_cycles)]) LxTx <- t(OUTPUT_results_reduced[, (9 + max_cycles):(8 + 2 * max_cycles)]) LxTx.error <- t(OUTPUT_results_reduced[, (9 + 2 * max_cycles):(8 + 3 * max_cycles)]) ##prepare data frame for output that can used as input input_object <- data.frame( BIN_FILE = unlist(object.file_name)[OUTPUT_results_reduced[[1]]], OUTPUT_results_reduced[, -1], stringsAsFactors = FALSE ) ##prepare data frame for output that shows rejected aliquots if (length(removed_aliquots) > 0) { removed_aliquots <- as.data.frame(removed_aliquots, stringsAsFactors = FALSE) removed_aliquots <- cbind(BIN_FILE = unlist(object.file_name)[removed_aliquots[[1]]], removed_aliquots[, -1]) }else{ removed_aliquots <- NULL } } # Call baSAR-function ------------------------------------------------------------------------- ##check for the central_D bound settings ##Why do we use 0 and 1000: Combes et al., 2015 wrote ## that "We set the bounds for the prior on the central dose D, Dmin = 0 Gy and ## Dmax = 1000 Gy, to cover the likely range of possible values for D. ##check if something is set in method control, if not, set it if (is.null(method_control[["upper_centralD"]])) { method_control <- c(method_control, upper_centralD = 1000) }else{ if(distribution == "normal" | distribution == "cauchy" | distribution == "log_normal"){ warning("[analyse_baSAR()] You have modified the upper central_D boundary, while applying a predefined model. This is possible but not recommended!", call. = FALSE) } } ##we do the same for the lower_centralD, just to have everthing in one place if (is.null(method_control[["lower_centralD"]])) { method_control <- c(method_control, lower_centralD = 0) }else{ if(distribution == "normal" | distribution == "cauchy" | distribution == "log_normal"){ warning("[analyse_baSAR()] You have modified the lower central_D boundary while applying a predefined model. This is possible but not recommended!", call. = FALSE) } } if(min(input_object[["DE"]][input_object[["DE"]] > 0], na.rm = TRUE) < method_control$lower_centralD | max(input_object[["DE"]], na.rm = TRUE) > method_control$upper_centralD){ warning("[analyse_baSAR()] Your set lower_centralD and/or upper_centralD value seem to do not fit to your input data. This may indicate a wronlgy set 'source_doserate'.", call. = FALSE) } ##>> try here is much better, as the user might run a very long preprocessing and do not ##want to fail here results <- try(.baSAR_function( Nb_aliquots = Nb_aliquots, distribution = distribution, data.Dose = Doses, data.Lum = LxTx, data.sLum = LxTx.error, fit.method = fit.method, n.MCMC = n.MCMC, fit.force_through_origin = fit.force_through_origin, fit.includingRepeatedRegPoints = fit.includingRepeatedRegPoints, method_control = method_control, baSAR_model = baSAR_model, verbose = verbose )) ##check whether this became NULL if(!is(results, "try-error")){ ##how do we add the systematic error? ##(1) source_doserate is a list, not a vector, but the user can ##provide many source dose rates and he can provide only a single vector (no error) if(!is.null(unlist(source_doserate)) || !is.null(function_arguments$source_doserate)){ ##if it comes from the previous call, it is, unfortunately not that simple if(!is.null(function_arguments$source_doserate)){ source_doserate <- eval(function_arguments$source_doserate) if(!is(source_doserate, "list")){ source_doserate <- list(source_doserate) } } systematic_error <- unlist(lapply(source_doserate, function(x){ if(length(x) == 2) { x[2] } else{ NULL } })) }else{ systematic_error <- 0 } ##state are warning for very different errors if(mean(systematic_error) != systematic_error[1]){ warning("[analyse_baSAR()] Provided source dose rate errors differ. The mean was taken, but the calculated systematic error might be not valid!", .call = FALSE) } ##add to the final de DE_FINAL.ERROR <- sqrt(results[[1]][["CENTRAL.SD"]]^2 + mean(systematic_error)^2) ##consider the case that we get NA and this might be confusing if(is.na(DE_FINAL.ERROR)){ DE_FINAL.ERROR <- results[[1]][["CENTRAL.SD"]] } ##combine results[[1]] <- cbind(results[[1]], DE_FINAL = results[[1]][["CENTRAL"]], DE_FINAL.ERROR = DE_FINAL.ERROR) }else{ results <- NULL verbose <- FALSE plot <- FALSE } # Terminal output ----------------------------------------------------------------------------- if(verbose){ cat("++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n\n") cat("\n[analyse_baSAR()] ---- RESULTS ---- \n") cat("------------------------------------------------------------------\n") cat(paste0("Used distribution:\t\t", results[[1]][["DISTRIBUTION"]],"\n")) if(!is.null(removed_aliquots)){ if(!is.null(aliquot_range)){ cat(paste0("Number of aliquots used:\t", results[[1]][["NB_ALIQUOTS"]],"/", results[[1]][["NB_ALIQUOTS"]] + nrow(removed_aliquots), " (manually removed: " ,length(aliquot_range),")\n")) }else{ cat(paste0("Number of aliquots used:\t", results[[1]][["NB_ALIQUOTS"]],"/", results[[1]][["NB_ALIQUOTS"]] + nrow(removed_aliquots),"\n")) } }else{ cat(paste0("Number of aliquots used:\t", results[[1]][["NB_ALIQUOTS"]],"/", results[[1]][["NB_ALIQUOTS"]],"\n")) } if(!is.null(baSAR_model)){ cat(paste0("Considered fitting method:\t", results[[1]][["FIT_METHOD"]]," (user defined)\n")) }else{ cat(paste0("Considered fitting method:\t", results[[1]][["FIT_METHOD"]],"\n")) } cat(paste0("Number of independent chains:\t", results[[1]][["N.CHAINS"]],"\n")) cat(paste0("Number MCMC iterations/chain:\t", results[[1]][["N.MCMC"]],"\n")) cat("------------------------------------------------------------------\n") if(distribution == "log_normal"){ cat("\t\t\t\tmean*\tsd\tHPD\n") }else{ cat("\t\t\t\tmean\tsd\tHPD\n") } cat(paste0(">> Central dose:\t\t", results[[1]][["CENTRAL"]],"\t", results[[1]][["CENTRAL.SD"]],"\t", "[", results[[1]][["CENTRAL_Q_.16"]]," ; ", results[[1]][["CENTRAL_Q_.84"]], "]**\t")) cat(paste0("\n\t\t\t\t\t\t[", results[[1]][["CENTRAL_Q_.025"]]," ; ", results[[1]][["CENTRAL_Q_.975"]],"]***")) cat(paste0("\n>> sigma_D:\t\t\t", results[[1]][["SIGMA"]],"\t", results[[1]][["SIGMA.SD"]], "\t", "[",results[[1]][["SIGMA_Q_.16"]]," ; ", results[[1]][["SIGMA_Q_.84"]], "]**\t")) cat(paste0("\n\t\t\t\t\t\t[",results[[1]][["SIGMA_Q_.025"]]," ; ", results[[1]][["SIGMA_Q_.975"]], "]***")) cat(paste0("\n>> Final central De:\t\t", results[[1]][["DE_FINAL"]],"\t", round(results[[1]][["DE_FINAL.ERROR"]], digits = digits), "\t", " - \t -")) cat("\n------------------------------------------------------------------\n") cat( paste("(systematic error contribution to final De:", format((1-results[[1]][["CENTRAL.SD"]]/results[[1]][["DE_FINAL.ERROR"]])*100, scientific = TRUE), "%)\n") ) if(distribution == "log_normal"){ cat("* mean of the central dose is the geometric mean\n") } cat("** 68 % level | *** 95 % level\n") } # Plotting ------------------------------------------------------------------------------------ if(plot){ ##get colours from the package Luminescence col <- get("col", pos = .LuminescenceEnv) ##get list of variable names (we need them later) varnames <- coda::varnames(results[[2]]) ##//////////////////////////////////////////////////////////////////////////////////////////// ##TRACE AND DENSITY PLOT ####////////////////////////////////////////////////////////////////////////////////////////// if(plot_reduced){ plot_check <- try(plot(results[[2]][,c("central_D","sigma_D"),drop = FALSE]), silent = TRUE) ##show error if(is(plot_check, "try-error")){ stop("[analyse_baSAR()] Plots for 'central_D' and 'sigma_D' could not be produced. You are probably monitoring the wrong variables!", .call = FALSE) } }else{ try(plot(results[[2]])) } ##//////////////////////////////////////////////////////////////////////////////////////////// ##TRUE DOSE PLOT AND DECISION MAKER ####////////////////////////////////////////////////////////////////////////////////////////// if (!plot.single) { par(mfrow = c(2, 2)) } ##get list with D values ##get list out of it plot_matrix <- as.matrix(results[[2]][,grep(x = varnames, pattern = "D[", fixed = TRUE)]) aliquot_quantiles <- t(matrixStats::colQuantiles(x = plot_matrix, probs = c(0.25,0.75))) ##define boxplot colours ... we have red and orange box.col <- vapply(1:ncol(aliquot_quantiles), function(x){ if(aliquot_quantiles[2,x] < results[[1]][,c("CENTRAL_Q_.025")] | aliquot_quantiles[1,x] > results[[1]][,c("CENTRAL_Q_.975")] ){ col[2] }else if(aliquot_quantiles[2,x] < results[[1]][,c("CENTRAL_Q_.16")] | aliquot_quantiles[1,x] > results[[1]][,c("CENTRAL_Q_.84")]){ "orange" }else{ "white" } }, FUN.VALUE = vector(mode = "character", length = 1)) ##to assure a minium of quality not more then 15 boxes a plotted in each plot i <- 1 while(i < ncol(plot_matrix)){ step <- if((i + 14) > ncol(plot_matrix)){ncol(plot_matrix)}else{i + 14} plot_check <- try(boxplot( x = plot_matrix[,i:step], use.cols = TRUE, horizontal = TRUE, outline = TRUE, col = box.col[i:step], xlab = if(is.null(unlist(source_doserate))){"Dose [s]"}else{"Dose [Gy]"}, ylab = "Aliquot index", yaxt = "n", xlim = c(1,19), main = paste0("Individual Doses | ALQ: ", i,":",step) )) if(!is(plot_check, "try-error")){ if(step == ncol(plot_matrix)){ axis(side = 2, at = 1:15, labels = as.character(c(i:step, rep(" ", length = 15 - length(i:step)))), cex.axis = 0.8 ) }else{ axis(side = 2, at = 1:15, labels = as.character(i:step), cex.axis = 0.8) } ##add HPD with text ##HPD - 68% lines( x = c( results[[1]][, c("CENTRAL_Q_.16")], results[[1]][, c("CENTRAL_Q_.16")], results[[1]][, c("CENTRAL_Q_.84")], results[[1]][, c("CENTRAL_Q_.84")]), y = c(par()$usr[3], 16, 16, par()$usr[3]), lty = 3, col = col[3], lwd = 1.5 ) text( x = results[[1]][, c("CENTRAL")], y = 16, labels = "68 %", pos = 3, col = col[3], cex = 0.9 * par()$cex ) ##HPD - 98 %% lines( x = c( results[[1]][, c("CENTRAL_Q_.025")], results[[1]][, c("CENTRAL_Q_.025")], results[[1]][, c("CENTRAL_Q_.975")], results[[1]][, c("CENTRAL_Q_.975")]), y = c(par()$usr[3], 17.5, 17.5, par()$usr[3]), lty = 3, col = col[2], lwd = 1.5 ) text( x = results[[1]][, c("CENTRAL")], y = 17.5, labels = "95 %", pos = 3, col = col[2], cex = 0.9 * par()$cex) } ##update counter i <- i + 15 } rm(plot_matrix) if(!plot.single){ par(mfrow = c(1,2)) on.exit(par(mfrow = c(1,1), bg = "white", xpd = FALSE)) } ##//////////////////////////////////////////////////////////////////////////////////////////// ##DOSE RESPONSE CURVES AND Lx/Tx VALUES ####////////////////////////////////////////////////////////////////////////////////////////// ##define selection vector selection <- c("a[", "b[", "c[", "g[", "Q[1,") ##get list out of it list_selection <- lapply(X = selection, FUN = function(x){ unlist(results[[2]][,grep(x = varnames, pattern = x, fixed = TRUE)]) }) ##create matrix plot_matrix <- t(do.call(what = "cbind", args = list_selection)) ##free memory rm(list_selection) ##make selection according to the model for the curve plotting if (fit.method == "EXP") {ExpoGC <- 1 ; LinGC <- 0 } if (fit.method == "LIN") {ExpoGC <- 0 ; LinGC <- 1 } if (fit.method == "EXP+LIN") {ExpoGC <- 1 ; LinGC <- 1 } if (fit.force_through_origin) {GC_Origin <- 0} else {GC_Origin <- 1} ##add choise for own provided model if(!is.null(baSAR_model)){ fit.method_plot <- paste(fit.method, "(user defined)") }else{ fit.method_plot <- fit.method } ##open plot area ##for the xlim and ylim we have to identify the proper ranges based on the input xlim <- c(0, max(input_object[,grep(x = colnames(input_object), pattern = "DOSE")], na.rm = TRUE)*1.1) ylim <- c( min(input_object[,grep(x = colnames(input_object), pattern = "LxTx")], na.rm = TRUE), max(input_object[,grep(x = colnames(input_object), pattern = "LxTx")], na.rm = TRUE)*1.1) ##check for position of the legend ... we can do better if(results[[1]][["CENTRAL_Q_.975"]] < max(xlim)/2){ legend_pos <- "topright" }else{ legend_pos <- "topleft" } ##set plot area plot_check <- try(plot( NA, NA, ylim = ylim, xlim = xlim, ylab = expression(paste(L[x] / T[x])), xlab = if(is.null(unlist(source_doserate))){"Dose [s]"}else{"Dose [Gy]"}, main = "baSAR Dose Response Curves" )) if (!is(plot_check, "try-error")) { ##add mtext mtext(side = 3, text = paste("Fit:", fit.method_plot)) ##check whether we have all data we need (might be not the case of the user ##selects own variables) if (ncol(plot_matrix) != 0) { ##plot individual dose response curves x <- NA for (i in seq(1, ncol(plot_matrix), length.out = 1000)) { curve( GC_Origin * plot_matrix[4, i] + LinGC * (plot_matrix[3, i] * x) + ExpoGC * (plot_matrix[1, i] * (1 - exp ( -x / plot_matrix[2, i] ))), add = TRUE, col = rgb(0, 0, 0, .1) ) } }else{ try(stop("[analyse_baSAR()] Wrong 'variable.names' monitored, dose responses curves could not be plotted!", call. = FALSE)) } ##add dose points n.col <- length(input_object[, grep(x = colnames(input_object), pattern = "DOSE")]) ##add rug with natural Lx/Tx rug(side = 2, x = input_object[[9 + n.col]]) ##plot Lx/Tx values .. without errors ... this is enough here for (i in 2:length(input_object[, grep(x = colnames(input_object), pattern = "DOSE")])) { ##add error bars segments( x0 = input_object[[8 + i]], x1 = input_object[[8 + i]], y0 = input_object[[8 + n.col + i]] - input_object[[8 + 2 * n.col + i]], y1 = input_object[[8 + n.col + i]] + input_object[[8 + 2 * n.col + i]], col = "grey" ) ##add points in the top of it points( x = input_object[[8 + i]], y = input_object[[8 + n.col + i]], pch = 21, col = col[11], bg = "grey" ) } ##add ablines abline( v = results[[1]][, c("CENTRAL_Q_.16", "CENTRAL_Q_.84")], lty = 3, col = col[3], lwd = 1.2 ) abline(v = results[[1]][, c("CENTRAL_Q_.025", "CENTRAL_Q_.975")], lty = 2, col = col[2]) ##add legend1 legend( legend_pos, bty = "n", horiz = FALSE, lty = c(3, 2), col = c(col[3], col[2]), legend = c("HPD - 68 %", "HPD - 95 %") ) ##add legend2 legend( "bottomright", bty = "n", horiz = FALSE, pch = 21, col = col[11], bg = "grey", legend = "measured dose points" ) } ##remove object, it might be rather big rm(plot_matrix) ##03 Abanico Plot plot_check <- plot_AbanicoPlot( data = input_object[, c("DE", "DE.SD")], zlab = if(is.null(unlist(source_doserate))){expression(paste(D[e], " [s]"))}else{expression(paste(D[e], " [Gy]"))}, log.z = if (distribution != "log_normal") { FALSE } else{ TRUE }, z.0 = results[[1]]$CENTRAL, y.axis = FALSE, polygon.col = FALSE, line = results[[1]][,c( "CENTRAL_Q_.16", "CENTRAL_Q_.84", "CENTRAL_Q_.025", "CENTRAL_Q_.975")], line.col = c(col[3], col[3], col[2], col[2]), line.lty = c(3,3,2,2), output = TRUE, mtext = paste0( nrow(input_object) - length(which(is.na(input_object[, c("DE", "DE.SD")]))), "/", nrow(input_object), " plotted (removed are NA values)" ) ) if (!is.null(plot_check)) { legend( "topleft", legend = c("Central dose", "HPD - 68%", "HPD - 95 %"), lty = c(2, 3, 2), col = c("black", col[3], col[2]), bty = "n", cex = par()$cex * 0.8 ) } ##In case the Abanico plot will not work because of negative values ##provide a KDE if(is.null(plot_check)){ plot_check <- try(suppressWarnings(plot_KDE( data = input_object[, c("DE", "DE.SD")], xlab = if(is.null(unlist(source_doserate))){expression(paste(D[e], " [s]"))}else{expression(paste(D[e], " [Gy]"))}, mtext = paste0( nrow(input_object) - length(which(is.na(input_object[, c("DE", "DE.SD")]))), "/", nrow(input_object), " (removed are NA values)" ) ))) if(!is(plot_check, "try-error")) { abline(v = results[[1]]$CENTRAL, lty = 2) abline( v = results[[1]][, c("CENTRAL_Q_.16", "CENTRAL_Q_.84")], lty = 3, col = col[3], lwd = 1.2 ) abline(v = results[[1]][, c("CENTRAL_Q_.025", "CENTRAL_Q_.975")], lty = 2, col = col[2]) ##check for position of the legend if(results[[1]][["CENTRAL_Q_.975"]] < max(xlim)/2){ legend_pos <- "right" }else{ legend_pos <- "topleft" } legend( legend_pos, legend = c("Central dose", "HPD - 68%", "HPD - 95 %"), lty = c(2, 3, 2), col = c("black", col[3], col[2]), bty = "n", cex = par()$cex * 0.8 ) } } } # Return -------------------------------------------------------------------------------------- return(set_RLum( class = "RLum.Results", data = list( summary = results[[1]], mcmc = results[[2]], models = results[[3]], input_object = input_object, removed_aliquots = removed_aliquots ), info = list(call = sys.call()) )) } Luminescence/R/write_RLum2CSV.R0000644000176200001440000001673113125226556015756 0ustar liggesusers#' Export RLum-objects to CSV #' #' This function exports \code{\linkS4class{RLum}}-objects to CSV-files using the R function #' \code{\link[utils]{write.table}}. All \code{\linkS4class{RLum}}-objects are supported, but the #' export is lossy, i.e. the pure numerical values are exported only. Information that cannot #' be coerced to a \code{\link{data.frame}} or a \code{\link{matrix}} are discarded as well as #' metadata. #' #' However, in combination with the implemented import functions, nearly every supported #' import data format can be exported to CSV-files, this gives a great deal of freedom in terms of #' compatibility with other tools.\cr #' #' \bold{Input is a list of objects}\cr #' #' If the input is a \code{\link{list}} of objects all explicit function arguments can be provided #' as \code{\link{list}}. #' #' @param object \code{\linkS4class{RLum}} or a \code{\link{list}} of \code{RLum} objects (\bold{required}): objects to be written #' #' @param path \code{\link{character}} (optional): character string naming folder for the output to be written. If nothing #' is provided \code{path} will be set to the working directory. Note: this argument is ignored if the #' the argument \code{export} is set to \code{FALSE}. #' #' @param prefix \code{\link{character}} (with default): optional prefix to name the files. This prefix #' is valid for all written files #' #' @param export \code{\link{logical}} (with default): enable or disable the file export. If set to \code{FALSE} #' nothing is written to the file connection, but a list comprising objects of type \code{link{data.frame}} and \code{\link{matrix}} #' is returned instead #' #' @param \dots further arguments that will be passed to the function \code{\link[utils]{write.table}}. All arguments #' except the argument \code{file} are supported #' #' #' @return The function returns either a CSV-file (or many of them) or for the option \code{export == FALSE} #' a list comprising objects of type \code{link{data.frame}} and \code{\link{matrix}} #' #' #' @section Function version: 0.1.1 #' #' @author Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) #' #' @seealso \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data}}, \code{\linkS4class{RLum.Results}}, #' \code{\link[utils]{write.table}} #' #' @keywords IO #' #' @examples #' #' ##transform values to a list #' data(ExampleData.BINfileData, envir = environment()) #' object <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data)[[1]] #' write_RLum2CSV(object, export = FALSE) #' #' \dontrun{ #' #' ##export data to CSV-files in the working directory; #' ##BE CAREFUL, this example creates many files on your file system #' data(ExampleData.BINfileData, envir = environment()) #' object <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data)[[1]] #' write_RLum2CSV(object, export = FALSE) #' #' } #' #' @export write_RLum2CSV <- function( object, path = NULL, prefix = "", export = TRUE, ... ){ # General tests ------------------------------------------------------------------------------- if(missing(object)){ stop("[write_RLum2CSV()] input object is missing!", call. = FALSE) } # Self-call ----------------------------------------------------------------------------------- ##this option allows to work on a list of RLum-objects if(is.list(object)){ ##extent the list of arguments if set ##path path <- rep(list(path), length = length(object)) ##prefix ... create automatic prefix if nothing is provided if(prefix == ""){ prefix <- as.list(paste0("[[",1:length(object),"]]_")) }else{ prefix <- rep(list(prefix), length = length(object)) } ##export export <- rep(list(export), length = length(object)) ##execute the self-call function temp <- lapply(1:length(object), function(x){ write_RLum2CSV( object = object[[x]], path = path[[x]], prefix = prefix[[x]], export = export[[x]], ... ) }) ##this prevents that we get a list of NULL if(is.null(unlist(temp))){ return(NULL) }else{ return(temp) } } # Integrity tests ----------------------------------------------------------------------------- ##check path ##if NULL condition if(export == TRUE && is.null(path)){ path <- getwd() message(paste0("[write_RLum2CSV()] Path automatically set to: ", path)) } ##non NULL conditon if(export == TRUE && !dir.exists(path)){ stop("[write_RLum2CSV()] Diretory provided via the argument 'path' does not exist!", call. = FALSE) } ## What do we need at the end of the day is a named list of data.frames or matrices we can export ## using the function write.table; the name of the list elements will become the file names if(inherits(object, "RLum")){ if(is(object, "RLum.Analysis") || is(object, "RLum.Data.Curve") || is(object, "RLum.Data.Spectrum") || is(object, "RLum.Data.Image")){ ##extract all elements ... depending on the input if(is(object, "RLum.Analysis")){ ##tricky, we cannot use get_RLum() as the function lapply calls as.list() for an object! object_list <- lapply(object, function(x){get_RLum(x)}) ##change names of the list and produce the right format straight away names(object_list) <- paste0(1:length(object_list),"_",names(object)) } else { ##get object and make list object_list <- list(get_RLum(object)) ##set new name names(object_list) <- paste0("1_",object@recordType) } }else if(is(object, "RLum.Results")){ ##we just try the typical R way and hope the best object_list <- unlist(object@data, recursive = FALSE) ##sort out objects we do not like and we cannot procede ... object_list <- object_list[vapply(object_list, function(x) { is.data.frame(x) | is.matrix(x) | is.numeric(x) }, vector(mode = "logical", length = 1))] ##adjust the names names(object_list) <- paste0(1:length(object_list),"_",names(object_list)) }else{ try(stop("[write_RLum2CSV()] One particular RLum-object is not yet supported! NULL returned!", call. = FALSE)) return(NULL) } }else{ stop("[write_RLum2CSV()] Object needs to be a member of the object class RLum!", call. = FALSE) } # Export -------------------------------------------------------------------------------------- if(export){ ##set export settings for write.table export_settings.default <- list( append = FALSE, quote = TRUE, sep = ";", eol = "\n", na = "NA", dec = ".", row.names = FALSE, col.names = FALSE, qmethod = c("escape", "double"), fileEncoding = "" ) ##modify on demand export_settings <- modifyList(x = export_settings.default, val = list(...)) ##write files to file system for(i in 1:length(object_list)){ utils::write.table( x = object_list[[i]], file = paste0(path,"/",prefix, names(object_list)[i],".csv"), append = export_settings$append, quote = export_settings$quote, sep = export_settings$sep, eol = export_settings$eol, na = export_settings$na, dec = export_settings$dec, row.names = export_settings$row.names, col.names = export_settings$col.names, qmethod = export_settings$qmethod, fileEncoding = export_settings$fileEncoding) } }else{ return(object_list) } } Luminescence/MD50000644000176200001440000004323413125301541013175 0ustar liggesusersfee691583fa62e94aedb818ff5f55a82 *DESCRIPTION 9c882be96543c401e87ed863ae9b56e9 *NAMESPACE ace516015bafd2243e6ec0c99c88e6ee *NEWS c1a575eb8fba9c7a3eb7b7b54dfd3581 *R/Analyse_SAR.OSLdata.R fe51ad130bf2bbb04cae492ead8a4f13 *R/CW2pHMi.R b3014d95277600a216af72bddf760c5e *R/CW2pLM.R 832ceb3c08be8001603e68609eee4d34 *R/CW2pLMi.R 3158542c438e20efc95d0d11febf8e61 *R/CW2pPMi.R c95b98d6d530b9a10d47b1061d918e74 *R/Luminescence-package.R 52ac915357d57c719408c1c700d96ca6 *R/PSL2Risoe.BINfileData.R f96b164b48d5343ecaaf4f9b84c74354 *R/RLum-class.R 3243d42067da0defbaafd81af9c85ef1 *R/RLum.Analysis-class.R 738d70f4534e1b5823b0b453e4f2035b *R/RLum.Data-class.R 832f33ab18db374d81166734dc825d62 *R/RLum.Data.Curve-class.R 4d18f10245b689a9bb4c88dbf243fe99 *R/RLum.Data.Image-class.R 79955b868a4822f69b32eb2cb6c30189 *R/RLum.Data.Spectrum-class.R cbe9744df2ae9107ede141a02d84a6d8 *R/RLum.Results-class.R ae8d071b1f3fa935cd2816fb7afedd0d *R/RcppExports.R 9987ef6d6281737152f6d10b1e8cb7a4 *R/Risoe.BINfileData2RLum.Analysis.R 01fc00379960da16b1fbea1e4a8a1327 *R/Risoe.BINfileData2RLum.Data.Curve.R b5f8646dd82d8e1d0af40c3c42b91954 *R/RisoeBINfileData-class.R 02853953b3a9798309fdd0a9901f096a *R/Second2Gray.R db99f3ba3a2bce843b206bd1f0c75334 *R/analyse_FadingMeasurement.R 56213d954ebdb2a56c2e2f63a24a2087 *R/analyse_IRSAR.RF.R a5a443e0b55c20300b29e96d37d60a65 *R/analyse_SAR.CWOSL.R e532e62dcd642980943335e76aaf8590 *R/analyse_SAR.TL.R e256fa858f73e0cb82d2928df08e4f6a *R/analyse_baSAR.R ef51962e710f824771edfb8c1c304761 *R/analyse_pIRIRSequence.R 841395d858eb4aaa9a38ba9dd3de2239 *R/analyse_portableOSL.R ad3202e295e47a6dedd02134058fe392 *R/app_RLum.R e8bf70cc879f026a61634bd74d0fc0c7 *R/apply_CosmicRayRemoval.R bf6ff653d8a02380264316f3d5758031 *R/apply_EfficiencyCorrection.R d27071ceeee72ccb2306634d52367f5f *R/bin_RLum.Data.R b2e169fe1ae7665e5ef8f64a25dbe2e9 *R/calc_AliquotSize.R 682e7fdf2c27dfb54cef0932b5a93c4f *R/calc_AverageDose.R 7b7e4ba411523b50a88914b04a98b4e8 *R/calc_CentralDose.R 71f7a26963d9085cfe1f937555fda654 *R/calc_CommonDose.R 6b6aca5d64243c3d15a5732730fdbcff *R/calc_CosmicDoseRate.R 3d4457ef7606c1d850eb6342fde8544f *R/calc_FadingCorr.R 4026e5b04f6548cf04f330422ed01ce9 *R/calc_FastRatio.R a7f0ca0270d8a2ae14da4220b5c5b363 *R/calc_FiniteMixture.R 46d7564604b36f3b4dacd7b6e041fe95 *R/calc_FuchsLang2001.R 3a73c5b14ee3f97469707d72c43dbd05 *R/calc_HomogeneityTest.R e7887dbe151b36cbd3e11e436e1e3f60 *R/calc_IEU.R 03162d3fcea368634e7cb1ccfe631806 *R/calc_Kars2008.R 6b689e6afa9018dd84d557161e82aa86 *R/calc_MaxDose.R 77c50d59e41c9575533efefc42e9a481 *R/calc_MinDose.R 90eadb8337b7c1ac7131702fc776d520 *R/calc_OSLLxTxRatio.R 2b0adde7f32ed5bfc4c18b1a3f0a9a51 *R/calc_SourceDoseRate.R 0fd66f4ebe46029ea3e347af7c4d49a0 *R/calc_Statistics.R bcf66320202be5d07ea2d5b979b0cd31 *R/calc_TLLxTxRatio.R 16add648f8e85c742ec636dd332898e9 *R/calc_ThermalLifetime.R 992fb95052ecb9461d77e17da325b2bd *R/calc_gSGC.R c6b1c9d5b39c821a221980b6f7e114a9 *R/convert_BIN2CSV.R b6a40759005ad56093a19bf4412efe27 *R/convert_Daybreak2CSV.R d614d4f1425e18bf5a166d03b5cffd0d *R/convert_PSL2CSV.R 99e0aa7f7777734af34cdfbf71e781e3 *R/convert_XSYG2CSV.R 51fea279e9066ae93b56b57baa9a8d56 *R/extract_IrradiationTimes.R de08281401431f33d08dcd1307734fba *R/fit_CWCurve.R 63e1f199ee740d0a8e9c040dc79fcc9f *R/fit_LMCurve.R 7afb7b0fd383ac3655acc2897e785701 *R/get_Layout.R d391bdc903d4d4d15198d8ae6fda8ef5 *R/get_Quote.R d36508b28592e5dc3c16431174c16402 *R/get_RLum.R 90259b563bb83ef834d7ffed77dbd37f *R/get_Risoe.BINfileData.R b45bae48aecccf0556288eff0f8b60ca *R/get_rightAnswer.R d87af547dabdec25ad8b6280175e72c6 *R/github.R c55833b2ed9168bbb8afc4efb8d75ed9 *R/install_DevelopmentVersion.R 173e3a6060036c32353ad079bd8964ba *R/internal_as.latex.table.R 2149235001750f594ff57ded4c542878 *R/internals_RLum.R e2b2ea53ad479b52b03771df74c003c3 *R/length_RLum.R 221e79181b7da8308c0f178c96b1e3d2 *R/merge_RLum.Analysis.R 8c62bc78bcfe58429e966a7fdff7a7be *R/merge_RLum.Data.Curve.R 72b5981712a785746e35a60c6665ce8d *R/merge_RLum.R 13175fd8d36cd775aab857c982a94998 *R/merge_RLum.Results.R 7672d185716790c7e4e823643ccd36d2 *R/merge_Risoe.BINfileData.R 290a2239f4642011957d6e7c80928a1d *R/methods_DRAC.R 4e6315cc2c686be89a6fb559bcb269f8 *R/methods_RLum.R 0ac9615a33fe8b74719e412c6e319acf *R/model_LuminescenceSignals.R 8145486bbfaea0afacf5fa95350b21b4 *R/names_RLum.R 4d6555e9e0166fb2fc93a93d3d0143aa *R/plot_AbanicoPlot.R 129e185ed5534faaa27cae1a936a3465 *R/plot_DRTResults.R b602e69466d97cf3e0df380418a7df3f *R/plot_DetPlot.R 55bec20d68e09461118a1cfebcf099e5 *R/plot_FilterCombinations.R 75aa0aaca06ca659edc789fcce7abfad *R/plot_GrowthCurve.R 019d96fea55d9b18f27c99d92cea10ad *R/plot_Histogram.R d93108d81d4ac01d211362274e987b64 *R/plot_KDE.R b270a4b63b7da7a20afd13a8144e5d1f *R/plot_NRt.R e85af72f04ca4dfef50c5a27668d973c *R/plot_RLum.Analysis.R df6627a2e2b0ed5404600c89fdc24277 *R/plot_RLum.Data.Curve.R d6feaf083c303f395a3fd60a4551a6b9 *R/plot_RLum.Data.Image.R ea2c175663e70925cfbc98c8216254f8 *R/plot_RLum.Data.Spectrum.R 6d183edde109d45577109f78018a3f82 *R/plot_RLum.R 17a082745c028d0ff9d1aa34abb3e7b7 *R/plot_RLum.Results.R f10f11e8a729a4134229a2131f576eea *R/plot_RadialPlot.R 203eff338826b122c5fb22f723351c66 *R/plot_Risoe.BINfileData.R 1b70b73f71a9821a7b012bf78cc1b4e9 *R/plot_ViolinPlot.R 68206777a7cf11c5ad939d55f69bda0d *R/read_BIN2R.R 45d5d4e6f1b1e5fd7ff124775d9dc06b *R/read_Daybreak2R.R 11c089eeab4e0578431d0cb973771751 *R/read_PSL2R.R 89afa696f01d621fa71a9b5f47416ce5 *R/read_SPE2R.R c907f9f6bded2bbeda24c6e2e6f9138b *R/read_XSYG2R.R 123ed927a9bf2662bb6440022eab158c *R/replicate_RLum.R c1dba55660ac08dddc9c2bb26a7ff189 *R/report_RLum.R 2627ec62e84b9e1a7400b12e6d9d6b05 *R/set_RLum.R c6a85601b2522c8947d2d055cc57cf07 *R/set_Risoe.BINfileData.R 6780702bcc2de54e289cc91bb1fccbc0 *R/smooth_RLum.R a8b9523cf0d7070ef8131ff6128fc0f6 *R/structure_RLum.R dbfd45411254c63d115e02a79ff222b9 *R/template_DRAC.R a530148476bff7efc7a117e4c5f02eb0 *R/tune_Data.R 5759ea9cd03f04b70087a4e6c9f169f3 *R/use_DRAC.R 89805a65d83562f1bea44db930e48165 *R/verify_SingleGrainData.R cefefa68bd56c729d49887dd68e1673a *R/write_R2BIN.R 9e18b396152860bd267a665c5de31b95 *R/write_RLum2CSV.R 03e2866d86ec98a42f5f2f675012101f *R/zzz.R 8eb217fc4380f23781dac785d7690941 *data/BaseDataSet.CosmicDoseRate.RData 4f98149ef7a155bd26679d398e5b619b *data/ExampleData.BINfileData.RData 3e72ccbe5fef2feee752206fc52bd358 *data/ExampleData.CW_OSL_Curve.RData d6477245d9abca8d86d0eb6d1d1f319b *data/ExampleData.DeValues.RData e2f24d5d1ad528d9b8852c8c619fb611 *data/ExampleData.Fading.RData 2688778759b5d9ddcd458c98421f5d36 *data/ExampleData.FittingLM.RData 76abec3d75bbea44fac9f599c0de9f0f *data/ExampleData.LxTxData.RData efa094f829c940630aefef99d8eea775 *data/ExampleData.LxTxOSLData.RData dd79ddebf77e9d0f482470546512db58 *data/ExampleData.RLum.Analysis.RData ee4c8be21bfb1f15b4056edb4b160513 *data/ExampleData.RLum.Data.Image.RData c723aab7895f3f8394a10da6d0a6b16d *data/ExampleData.XSYG.RData b2e8b7542753c5968647130e26a83517 *data/ExampleData.portableOSL.RData b072f185fb5d9de2e34883f1f98c027c *data/datalist 6fffef420c1f222939226e9e44ca0583 *inst/CITATION 5e10ccf6f395fe896fd96c527fbc67a3 *inst/NEWS.Rd 12ab72be52e77951d8b5e1ee97f4702e *inst/doc/S4classObjects.pdf a7018449ba9936ff3384170611f7c8e4 *inst/doc/index.html 122b026c56fab28a782c4642e9d8db15 *man/Analyse_SAR.OSLdata.Rd 61a8c6a0f8d2f978c42713a62d17b184 *man/BaseDataSet.CosmicDoseRate.Rd c4ccea82cbbfd7f29ced37061b932f2c *man/CW2pHMi.Rd 40776bc2b68733736bdae5aad1b88d38 *man/CW2pLM.Rd 9694109ce906a82559aecfdbe1ac1df5 *man/CW2pLMi.Rd c2ea84800157c0fd304717bb7e5c4a2a *man/CW2pPMi.Rd a35fea9269153ca92eea85276f59015a *man/ExampleData.BINfileData.Rd 5fb9286fb7d17d5ef45cb5fc07640bd2 *man/ExampleData.CW_OSL_Curve.Rd 7834a3d2fcd83b3ae434bb70d51ba8c0 *man/ExampleData.DeValues.Rd a14dce9efe81a4d4944d280d22435939 *man/ExampleData.Fading.Rd 8e74b8580e300a45b73527c49b673e87 *man/ExampleData.FittingLM.Rd 675f02bcffd91fa4722fb1d2ec5ae75b *man/ExampleData.LxTxData.Rd 863a4552b223c20e693c5df673b9022e *man/ExampleData.LxTxOSLData.Rd 6e5a77bbe10d76fa2454c3ad113ad98e *man/ExampleData.RLum.Analysis.Rd 1780f102250b7b2a656287b1698f008e *man/ExampleData.RLum.Data.Image.Rd 987d0a23a542d69133675d79a0e2dd03 *man/ExampleData.XSYG.Rd 9825014322a727e73bc9f26815cfca1d *man/ExampleData.portableOSL.Rd 2196f1ef636ae248bf199ad1981661d5 *man/GitHub-API.Rd 9e130bb188ee18f9e6ee92309be0081a *man/Luminescence-package.Rd c4779e8abde73aba966b39c057e0063e *man/PSL2Risoe.BINfileData.Rd 1952112acd3f0c69bc20a397e7004ab7 *man/RLum-class.Rd 14a10195c0819478baac4d7848e01778 *man/RLum.Analysis-class.Rd 62278eae044ef3d373fd585bad5a8a45 *man/RLum.Data-class.Rd 7896166ed75ce3c962118936a5bb3021 *man/RLum.Data.Curve-class.Rd e6d36ccde30580931dc24a0ee5bd4208 *man/RLum.Data.Image-class.Rd 881ab2fef13643e3eef347caecea5e12 *man/RLum.Data.Spectrum-class.Rd 1c0a443ad5cda894350d940343686d27 *man/RLum.Results-class.Rd e9398c640d0aca47125479e68af16a3a *man/Risoe.BINfileData-class.Rd 39786244dcd2a6b9fa406015c57ffc57 *man/Risoe.BINfileData2RLum.Analysis.Rd 1b06c60cbe42012c3dea71a954881a0e *man/Second2Gray.Rd c0baf642a5abc68b995d11912e4b377f *man/analyse_FadingMeasurement.Rd 8dfb62b840581b940b42ae85499f0163 *man/analyse_IRSAR.RF.Rd 683f8130e8cafae9096b2a6b284be420 *man/analyse_SAR.CWOSL.Rd d167655f9ddd07772092a9aa569f84c2 *man/analyse_SAR.TL.Rd a26c4b998ff28232ee3e0e2a35394470 *man/analyse_baSAR.Rd 14e106121723223a5829a38b819a26ec *man/analyse_pIRIRSequence.Rd 331ba5f917e28800c0a17b3b76423f85 *man/analyse_portableOSL.Rd 107e00777bc058084c86638b0c73a898 *man/app_RLum.Rd 6e7c349ff045d69ba1f3faadd188f567 *man/apply_CosmicRayRemoval.Rd 0952c006be3a85fa3c9f121ffd257181 *man/apply_EfficiencyCorrection.Rd 9a68bfd566bc2e0a3eb91d31f3400121 *man/as.Rd 278963ab4f30209b16d3f8d6197d705a *man/bin_RLum.Data.Rd df1023c4eec37e530268ee56784a1bd9 *man/calc_AliquotSize.Rd 30227879b57117d465c05da84d7d3423 *man/calc_AverageDose.Rd 24743f69920b71b5fae7daed199417f9 *man/calc_CentralDose.Rd 812e54356c7b4bb35e32ce2289ca72b8 *man/calc_CommonDose.Rd 5339725334b9890e291685d30a591c93 *man/calc_CosmicDoseRate.Rd b1ef02d20c55e4f34e0bae7a54cab230 *man/calc_FadingCorr.Rd 84741e0162f08bf13f06f98c973aa766 *man/calc_FastRatio.Rd 250b5dd03eba9b02519017b57b585cdb *man/calc_FiniteMixture.Rd bc13dff1403e968cb2ed6052e030b2b8 *man/calc_FuchsLang2001.Rd f8faeb25180b2d6a4fc2521d0ba67484 *man/calc_HomogeneityTest.Rd b4b8d926dd7d651dec5c55d2dc97194b *man/calc_IEU.Rd 6637ce006c0353d003315677e65001cb *man/calc_Kars2008.Rd 0db5fa548e44299c6e35956053d71e95 *man/calc_MaxDose.Rd 6f7e70d7fca9568c893cd6152ae1bd0b *man/calc_MinDose.Rd 9752ac7ca01877d3f8f874744a37a9ef *man/calc_OSLLxTxRatio.Rd 4a465d477bcab39f0fe2ca49ec0153b3 *man/calc_SourceDoseRate.Rd 3b04dd5336c6c746aa02dd8301a348e9 *man/calc_Statistics.Rd 786f167dcd04d991442803e0374bd44d *man/calc_TLLxTxRatio.Rd f06b0cdd7e380e1a35afe638a42e9f1a *man/calc_ThermalLifetime.Rd 19b96d0345613a002ca43ad72dab7d29 *man/calc_gSGC.Rd 9fc39985ee79656cbc4fafdbe6cf1a7d *man/convert_BIN2CSV.Rd b2ce6aed145722ec8f932605056a67f1 *man/convert_Daybreak2CSV.Rd 6f6405c0b073a4a79e1bbc8dc976bc4b *man/convert_PSL2CSV.Rd b8e135f884cf3d116e90d790d0a276e0 *man/convert_XSYG2CSV.Rd 2ce9536270596a396c21ce4a07256495 *man/extract_IrradiationTimes.Rd deb6016627acb30e3963c2daf22511a8 *man/fit_CWCurve.Rd 424b1ba34228e6d7c0198343377450d3 *man/fit_LMCurve.Rd 93807aaebeee680f41193be65d4d5604 *man/get_Layout.Rd 48819bdaaaac40e6ab71ee7787f6d7ad *man/get_Quote.Rd db688fe490d74a008647dd8e21acfce9 *man/get_RLum.Rd d508ba4995ab5675836f01bf6eaca613 *man/get_Risoe.BINfileData.Rd 9911f08925189be2133324767056da90 *man/get_rightAnswer.Rd f40f7190eb2e2bfde408bc4b440c7b6c *man/install_DevelopmentVersion.Rd 2c0fe665b4289eb3e1ec5724cb0c687c *man/length_RLum.Rd 2e727bdb8dea1aed273e769e983a95ba *man/merge_RLum.Analysis.Rd f33100f8f4825b03c644aceca0bc2dab *man/merge_RLum.Data.Curve.Rd 8a7e06db1d2dc2612e9f53c86eb8bef6 *man/merge_RLum.Rd 153dedca1a5b115da1ffd7fb79f44a12 *man/merge_RLum.Results.Rd 64a71644bd1bbf84ace9689835d40fbd *man/merge_Risoe.BINfileData.Rd 4b444f591a0dd72797d06f47df9a6e72 *man/methods_RLum.Rd d4aa82f5ddba4de72737a32366ed1aa3 *man/model_LuminescenceSignals.Rd 2468be6ad7752c3f631f0d990a505952 *man/names_RLum.Rd c6335724c69df978371c7bfc7c55aed7 *man/plot_AbanicoPlot.Rd 35c76c017bf79c795f76749cf7735d37 *man/plot_DRTResults.Rd be5e65fcdb3b81121b69ad07b7376740 *man/plot_DetPlot.Rd 6ab6a9247ea22ff60a4bd389577da9d7 *man/plot_FilterCombinations.Rd 72aff33ac4b952e25068050ae644855d *man/plot_GrowthCurve.Rd 06bfa18bd45d39140b2ecc7ec742021e *man/plot_Histogram.Rd d93b4ebed64c3b427a3bd552668cf543 *man/plot_KDE.Rd 740646199ec67b74dbb3d76ceb3e3581 *man/plot_NRt.Rd 2000561a2cc32abe8a02f95f013626e9 *man/plot_RLum.Analysis.Rd ff5af8e16b1dd6d0a55a79b55d118374 *man/plot_RLum.Data.Curve.Rd 4cfd6c93f17026fdb4804f7eef468fb6 *man/plot_RLum.Data.Image.Rd 25f12af2a2506587ccd99c8aa02a5910 *man/plot_RLum.Data.Spectrum.Rd 101dacd7cc66d1daa3ec65654e105bbe *man/plot_RLum.Rd 0fecba4945d4b451a24ef84a3df389f7 *man/plot_RLum.Results.Rd 67d6f3cbe4c7cc553b7befa3ef72f4c4 *man/plot_RadialPlot.Rd 440b26a73eff77ddf0e25d3a318cc2e7 *man/plot_Risoe.BINfileData.Rd 925d8b4701e49b962c54adcedc25f24c *man/plot_ViolinPlot.Rd 38e7576fe5ebb677cc9b14c9521574b5 *man/read_BIN2R.Rd e7ea06f1d32856fae9453aa0f4998709 *man/read_Daybreak2R.Rd 7fb5620e56a4f537b7abe5a25e11ed86 *man/read_PSL2R.Rd 6fc64a9f058fc93ed99216cd7f2fe316 *man/read_SPE2R.Rd c04393a50fde11cfbdba0ea1152fd3ae *man/read_XSYG2R.Rd 42eb67cc28f768e883b8ec635befe4df *man/replicate_RLum.Rd 819e9a4b574bce5c8c079be2105e416f *man/report_RLum.Rd 898b7ef0821a2ba5770cb25641a64bcb *man/sTeve.Rd 37aac8b57f0db14f8084c3e707064711 *man/set_RLum.Rd fafbee0fa7e9bb600141a37c05d907cb *man/set_Risoe.BINfileData.Rd a81fe2d1cb76e47c282516ad60ec6232 *man/smooth_RLum.Rd 88a42283522368818b88086794c390b4 *man/structure_RLum.Rd 3467b50fe7acf1e088f1c5ad186b7e8a *man/template_DRAC.Rd 55f46b155f33e16949df94951eb71c9c *man/tune_Data.Rd c6ca0781fb2c87a1370d5f66e2255d13 *man/use_DRAC.Rd 6bb76a1b0e99a076a90235b12e7413db *man/verify_SingleGrainData.Rd d75fc5e41c8a49061e68cf15ffe17e91 *man/write_R2BIN.Rd d66e25306f6e84738c37b5fd93b2a079 *man/write_RLum2CSV.Rd 87a1a15fb9460dcaf2cd5c6b8934f1d5 *src/Luminescence_init.c d521dbd09a0e8b7ec6b20e53f2994276 *src/RcppExports.cpp a8ca8d72e672faad7595dd329589c810 *src/analyse_IRSARRF_SRS.cpp 4fe2e831c907819c563103feedd70aac *src/create_RLumDataCurve_matrix.cpp 30434cc523b9b2c9704d7331aefd8a5f *src/create_UID.cpp 5c33e2021366df205be163e82ca1a759 *tests/testthat.R b5212accfaed0ef2373b164513f13416 *tests/testthat/test_Analyse_SAROSLdata.R da722a979208f3b55ae9a4c5dc1c02cf *tests/testthat/test_CW2pX.R ae1bd3189f87dcd90077ba3f99e55798 *tests/testthat/test_PSL2RisoeBINfiledata.R c6a8b578b52e7c432c235dc573473f92 *tests/testthat/test_RisoeBINfileData-class.R db9a35c16345701c372e7404378c2c18 *tests/testthat/test_Second2Gray.R a9dcdc8274493d7c92c4310483b73dfa *tests/testthat/test_analyse_IRSARRF.R 50a3ba100df453e3af59550015d9f73f *tests/testthat/test_analyse_SARCWOSL.R aff6bdd623021de1a64a1c620817140b *tests/testthat/test_analyse_SARTL.R b5504451520a8d78b2768ac13c097871 *tests/testthat/test_analyse_baSAR.R 12b034ef782492c2324a170a4e0a6a1f *tests/testthat/test_analyse_pIRIRSequence.R 76adf42e17285a575784c7bfd8e3a18a *tests/testthat/test_analyse_portableOSL.R 1bb9365493a2e71633428776fc34fdd4 *tests/testthat/test_bin_RLumData.R 1bcf9b4357d96c47023cdf26d5f96eb3 *tests/testthat/test_calc_AliquotSize.R 7ab999724414f0364bd4af8809f46cf0 *tests/testthat/test_calc_AverageDose.R e65025d6807077ca0a0cd9f79c9c3f7d *tests/testthat/test_calc_CentralDose.R f3e684f9cfefc721a9bfddfbc9c01950 *tests/testthat/test_calc_CommonDose.R a79160ac6df7646fc3c440b1f346ad29 *tests/testthat/test_calc_CosmicDoseRate.R 724351aaa09692863ea987e71174b3ee *tests/testthat/test_calc_FadingCorr.R ef8a337f704ba7404eb9d52b6ef25f98 *tests/testthat/test_calc_FastRatio.R 6c4411e2879e2ac4f1879d57682e3ff0 *tests/testthat/test_calc_FiniteMixture.R c7bdbb30555290c3c9a14797a8ad7357 *tests/testthat/test_calc_FuchsLang2001.R 9a18e9f0d2673d311789207899e24ad1 *tests/testthat/test_calc_HomogeneityTest.R 246eb64860eed66822ce628b6331490a *tests/testthat/test_calc_IEU.R fc4aac1eef8e42787a605135cb0dee98 *tests/testthat/test_calc_Kars2008.R 44d2344f673e3a7b09549dc3229efb01 *tests/testthat/test_calc_MaxDose.R 94ec5bd92907b97a0523a36a44054b5d *tests/testthat/test_calc_MinDose.R 9cecf6480e009a7a9fc7edfed22aa1b0 *tests/testthat/test_calc_OSLLxTxRatio.R 64597a16c69ff6c50a0be13eda834375 *tests/testthat/test_calc_SourceDoseRate.R c130017fb9e0f31831d95fca9815fe0c *tests/testthat/test_calc_Statistics.R 66dd969ef474afd721b2eb204b39e186 *tests/testthat/test_calc_TLLxTxRatio.R 24caaa2f311cc247869d729abd9c953f *tests/testthat/test_calc_ThermalLifetime.R 3f3573f93891be74b3bb6e428dfb3456 *tests/testthat/test_calc_gSGC.R 18f3912635a3a51be3dda5e79856c88f *tests/testthat/test_convert_X2CSV.R 61d8150cdb8afccb664472edea877368 *tests/testthat/test_fit_CWCurve.R 2bff04b5cd333df3443c86e930769554 *tests/testthat/test_fit_LMCurve.R 7ecde56887533e797e10de0d970220e9 *tests/testthat/test_get_RLum.R d2c03b0a20fdfa55aabf976c061e26cc *tests/testthat/test_merge_RLumDataCurve.R 7784fdf16b40b1d753986fa5915dcc32 *tests/testthat/test_merge_RisoeBINfileData.R 65974af970b9bed8bf057c111f25b0ad *tests/testthat/test_names_RLum.R 3c8f15125781b4142f1256237338658c *tests/testthat/test_plot_AbanicoPlot.R 09bc8c7bd4016222751f9318b45db67a *tests/testthat/test_plot_Functions.R 9949cb9a94a8104c1448e18f059d2a09 *tests/testthat/test_plot_GrowthCurve.R 410d1cf97d0c21772b56ed7dce8b7ceb *tests/testthat/test_read_BIN2R.R bdde07283d4a37484fc09b9f25ea169b *tests/testthat/test_replicate_RLum.R 24266fe2c91ac06752752475030a7913 *tests/testthat/test_smooth_RLum.R 7f25bcca1a2adf5ff8f520fbc2140e72 *tests/testthat/test_template_DRAC.R 71a577eca286a0855544b6646ed03287 *tests/testthat/test_verify_SingleGrainData.R d34f1d0f0cbf9406e85804fcb034bd3f *tests/testthat/test_write_R2BIN.R 241a3594ae2ad3b585b7166dabce51d4 *tests/testthat/test_write_RLum2CSV.R 3795ccc2aa09e748f9aeab17d198f633 *tests/testthat/test_zzz.R Luminescence/DESCRIPTION0000644000176200001440000001245213125301541014371 0ustar liggesusersPackage: Luminescence Type: Package Title: Comprehensive Luminescence Dating Data Analysis Version: 0.7.5 Date: 2017-06-30 Author: Sebastian Kreutzer [aut, trl, cre, dtc], Michael Dietze [aut], Christoph Burow [aut, trl, dtc], Margret C. Fuchs [aut], Christoph Schmidt [aut], Manfred Fischer [aut, trl], Johannes Friedrich [aut], Norbert Mercier [ctb], Rachel K. Smedley [ctb], Claire Christophe [ctb], Antoine Zink [ctb], Julie Durcan [ctb], Georgina King [ctb, dtc], Anne Philippe [ctb], Guillaume Guerin [ctb], Markus Fuchs [ths] Authors@R: c( person("Sebastian", "Kreutzer", role = c("aut", "trl", "cre", "dtc"), email = "sebastian.kreutzer@u-bordeaux-montaigne.fr"), person("Michael", "Dietze", role = c("aut")), person("Christoph", "Burow", role = c("aut", "trl", "dtc")), person("Margret C.", "Fuchs", role = c("aut")), person("Christoph", "Schmidt", role = c("aut")), person("Manfred", "Fischer", role = c("aut", "trl")), person("Johannes", "Friedrich", role = c("aut")), person("Norbert", "Mercier", role = c("ctb")), person("Rachel K.", "Smedley", role = c("ctb")), person("Claire", "Christophe", role = c("ctb")), person("Antoine", "Zink", rol = c("ctb")), person("Julie", "Durcan", role = c("ctb")), person("Georgina", "King", role = c("ctb", "dtc")), person("Anne", "Philippe", role = c("ctb")), person("Guillaume", "Guerin", role = c("ctb")), person("Markus", "Fuchs", role = c("ths"))) Maintainer: Sebastian Kreutzer Description: A collection of various R functions for the purpose of Luminescence dating data analysis. This includes, amongst others, data import, export, application of age models, curve deconvolution, sequence analysis and plotting of equivalent dose distributions. Contact: Package Developers License: GPL-3 BugReports: https://github.com/R-Lum/Luminescence/issues Depends: R (>= 3.3.2), utils, magrittr (>= 1.5) LinkingTo: Rcpp (>= 0.12.9), RcppArmadillo (>= 0.7.600.1.0) Imports: bbmle (>= 1.0.18), data.table (>= 1.10.0), httr (>= 1.2.1), matrixStats (>= 0.51.0), methods, minpack.lm (>= 1.2-1), raster (>= 2.5-8), readxl (>= 0.1.1), shape (>= 1.4.2), parallel, XML (>= 3.98-1.5), zoo (>= 1.7-14) Suggests: RLumShiny (>= 0.1.1), RLumModel (>= 0.1.2), plotly (>= 4.5.6), rmarkdown (>= 1.3), rjags (>= 4-6), coda (>= 0.19-1), pander (>= 0.6.0), rstudioapi (>= 0.6), testthat (>= 1.0.2), devtools (>= 1.12.0) URL: https://CRAN.R-project.org/package=Luminescence Collate: 'Analyse_SAR.OSLdata.R' 'CW2pHMi.R' 'CW2pLM.R' 'CW2pLMi.R' 'CW2pPMi.R' 'Luminescence-package.R' 'PSL2Risoe.BINfileData.R' 'RcppExports.R' 'replicate_RLum.R' 'RLum-class.R' 'smooth_RLum.R' 'names_RLum.R' 'structure_RLum.R' 'length_RLum.R' 'set_RLum.R' 'get_RLum.R' 'RLum.Analysis-class.R' 'RLum.Data-class.R' 'bin_RLum.Data.R' 'RLum.Data.Curve-class.R' 'RLum.Data.Image-class.R' 'RLum.Data.Spectrum-class.R' 'RLum.Results-class.R' 'Risoe.BINfileData2RLum.Analysis.R' 'Risoe.BINfileData2RLum.Data.Curve.R' 'set_Risoe.BINfileData.R' 'get_Risoe.BINfileData.R' 'RisoeBINfileData-class.R' 'Second2Gray.R' 'analyse_FadingMeasurement.R' 'analyse_IRSAR.RF.R' 'analyse_SAR.CWOSL.R' 'analyse_SAR.TL.R' 'analyse_baSAR.R' 'analyse_pIRIRSequence.R' 'analyse_portableOSL.R' 'app_RLum.R' 'apply_CosmicRayRemoval.R' 'apply_EfficiencyCorrection.R' 'calc_AliquotSize.R' 'calc_AverageDose.R' 'calc_CentralDose.R' 'calc_CommonDose.R' 'calc_CosmicDoseRate.R' 'calc_FadingCorr.R' 'calc_FastRatio.R' 'calc_FiniteMixture.R' 'calc_FuchsLang2001.R' 'calc_HomogeneityTest.R' 'calc_IEU.R' 'calc_Kars2008.R' 'calc_MaxDose.R' 'calc_MinDose.R' 'calc_OSLLxTxRatio.R' 'calc_SourceDoseRate.R' 'calc_Statistics.R' 'calc_TLLxTxRatio.R' 'calc_ThermalLifetime.R' 'calc_gSGC.R' 'convert_BIN2CSV.R' 'convert_Daybreak2CSV.R' 'convert_PSL2CSV.R' 'convert_XSYG2CSV.R' 'extract_IrradiationTimes.R' 'fit_CWCurve.R' 'fit_LMCurve.R' 'get_Layout.R' 'get_Quote.R' 'get_rightAnswer.R' 'github.R' 'install_DevelopmentVersion.R' 'internal_as.latex.table.R' 'internals_RLum.R' 'merge_RLum.Analysis.R' 'merge_RLum.Data.Curve.R' 'merge_RLum.R' 'merge_RLum.Results.R' 'merge_Risoe.BINfileData.R' 'methods_DRAC.R' 'methods_RLum.R' 'model_LuminescenceSignals.R' 'plot_AbanicoPlot.R' 'plot_DRTResults.R' 'plot_DetPlot.R' 'plot_FilterCombinations.R' 'plot_GrowthCurve.R' 'plot_Histogram.R' 'plot_KDE.R' 'plot_NRt.R' 'plot_RLum.Analysis.R' 'plot_RLum.Data.Curve.R' 'plot_RLum.Data.Image.R' 'plot_RLum.Data.Spectrum.R' 'plot_RLum.R' 'plot_RLum.Results.R' 'plot_RadialPlot.R' 'plot_Risoe.BINfileData.R' 'plot_ViolinPlot.R' 'read_BIN2R.R' 'read_Daybreak2R.R' 'read_PSL2R.R' 'read_SPE2R.R' 'read_XSYG2R.R' 'report_RLum.R' 'template_DRAC.R' 'tune_Data.R' 'use_DRAC.R' 'verify_SingleGrainData.R' 'write_R2BIN.R' 'write_RLum2CSV.R' 'zzz.R' RoxygenNote: 6.0.1 NeedsCompilation: yes Packaged: 2017-06-29 16:49:05 UTC; kreutzer Repository: CRAN Date/Publication: 2017-06-29 22:46:57 UTC Luminescence/man/0000755000176200001440000000000013125227142013436 5ustar liggesusersLuminescence/man/RLum.Data-class.Rd0000644000176200001440000000124313125226556016567 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RLum.Data-class.R \docType{class} \name{RLum.Data-class} \alias{RLum.Data-class} \title{Class \code{"RLum.Data"}} \description{ Generalized virtual data class for luminescence data. } \note{ Just a virtual class. } \section{Objects from the Class}{ A virtual Class: No objects can be created from it. } \section{Class version}{ 0.2.1 } \examples{ showClass("RLum.Data") } \seealso{ \code{\linkS4class{RLum}}, \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Spectrum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) } \keyword{classes} Luminescence/man/RLum-class.Rd0000644000176200001440000000400213125227576015716 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RLum-class.R \docType{class} \name{RLum-class} \alias{RLum-class} \alias{replicate_RLum,RLum-method} \title{Class \code{"RLum"}} \usage{ \S4method{replicate_RLum}{RLum}(object, times = NULL) } \arguments{ \item{object}{an object of class \code{\linkS4class{RLum}} (\bold{required})} \item{times}{\code{\link{integer}} (optional): number for times each element is repeated element} } \description{ Abstract class for data in the package Luminescence } \section{Methods (by generic)}{ \itemize{ \item \code{replicate_RLum}: Replication method RLum-objects }} \section{Slots}{ \describe{ \item{\code{originator}}{Object of class \code{\link{character}} containing the name of the producing function for the object. Set automatically by using the function \code{\link{set_RLum}}.} \item{\code{info}}{Object of class \code{\link{list}} for additional information on the object itself} \item{\code{.uid}}{Object of class \code{\link{character}} for a unique object identifier. This id is usually calculated using the internal function \code{.create_UID()} if the funtion \code{\link{set_RLum}} is called.} \item{\code{.pid}}{Object of class \code{\link{character}} for a parent id. This allows nesting RLum-objects at will. The parent id can be the uid of another object.} }} \note{ \code{RLum} is a virtual class. } \section{Objects from the Class}{ A virtual Class: No objects can be created from it. } \section{Class version}{ 0.4.0 } \examples{ showClass("RLum") } \seealso{ \code{\linkS4class{RLum.Data}}, \code{\linkS4class{RLum.Analysis}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) } \section{How to cite}{ Kreutzer, S. (2017). RLum-class(): Class 'RLum'. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{classes} Luminescence/man/sTeve.Rd0000644000176200001440000000252213125227576015027 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/zzz.R \name{sTeve} \alias{sTeve} \title{sTeve - sophisticated tool for efficient data validation and evaluation} \usage{ sTeve(n_frames = 10, t_animation = 2, n.tree = 7, type) } \arguments{ \item{n_frames}{\code{\link{integer}} (with default): n frames} \item{t_animation}{\code{\link{integer}} (with default): t animation} \item{n.tree}{\code{\link{integer}} (with default): How many trees do you want to cut?} \item{type}{\code{\link{integer}} (optional): Make a decision: 1, 2 or 3} } \value{ Validates your data. } \description{ This function provides a sophisticated routine for comprehensive luminescence dating data analysis. } \details{ This amazing sophisticated function validates your data seriously. } \note{ This function should not be taken too seriously. } \examples{ ##no example available } \section{How to cite}{ NA, NA, , (2017). sTeve(): sTeve - sophisticated tool for efficient data validation and evaluation. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ # } \seealso{ \link{plot_KDE} } \author{ R Luminescence Team, 2012-2013 } \keyword{manip} Luminescence/man/tune_Data.Rd0000644000176200001440000000352613125227576015652 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tune_Data.R \name{tune_Data} \alias{tune_Data} \title{Tune data for experimental purpose} \usage{ tune_Data(data, decrease.error = 0, increase.data = 0) } \arguments{ \item{data}{\code{\link{data.frame}} (\bold{required}): input values, structure: data (\code{values[,1]}) and data error (\code{values [,2]}) are required} \item{decrease.error}{\code{\link{numeric}}: factor by which the error is decreased, ranges between 0 and 1.} \item{increase.data}{\code{\link{numeric}}: factor by which the error is decreased, ranges between 0 and inf.} } \value{ Returns a \code{\link{data.frame}} with tuned values. } \description{ The error can be reduced and sample size increased for specific purpose. } \note{ You should not use this function to improve your poor data set! } \section{Function version}{ 0.5.0 (2017-06-29 18:40:14) } \examples{ ## load example data set data(ExampleData.DeValues, envir = environment()) x <- ExampleData.DeValues$CA1 ## plot original data plot_AbanicoPlot(data = x, summary = c("n", "mean")) ## decrease error by 10 \% plot_AbanicoPlot(data = tune_Data(x, decrease.error = 0.1), summary = c("n", "mean")) ## increase sample size by 200 \% #plot_AbanicoPlot(data = tune_Data(x, increase.data = 2) , # summary = c("n", "mean")) } \section{How to cite}{ Dietze, M. (2017). tune_Data(): Tune data for experimental purpose. Function version 0.5.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ # } \seealso{ # } \author{ Michael Dietze, GFZ Potsdam (Germany) \cr R Luminescence Package Team} \keyword{manip} Luminescence/man/plot_NRt.Rd0000644000176200001440000001070613125227576015505 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_NRt.R \name{plot_NRt} \alias{plot_NRt} \title{Visualise natural/regenerated signal ratios} \usage{ plot_NRt(data, log = FALSE, smooth = c("none", "spline", "rmean"), k = 3, legend = TRUE, legend.pos = "topright", ...) } \arguments{ \item{data}{a \code{\link{list}}, \code{\link{data.frame}}, \code{\link{matrix}} or \code{\linkS4class{RLum.Analysis}} object (\bold{required}). X,Y data of measured values (time and counts). See details on individual data structure.} \item{log}{\code{\link{character}} (optional): logarithmic axes (\code{c("x", "y", "xy")}).} \item{smooth}{\code{\link{character}} (optional): apply data smoothing. Use \code{"rmean"} to calculate the rolling where \code{k} determines the width of the rolling window (see \code{\link{rollmean}}). \code{"spline"} applies a smoothing spline to each curve (see \code{\link{smooth.spline}})} \item{k}{\code{\link{integer}} (with default): integer width of the rolling window.} \item{legend}{\code{\link{logical}} (with default): show or hide the plot legend.} \item{legend.pos}{\code{\link{character}} (with default): keyword specifying the position of the legend (see \code{\link{legend}}).} \item{...}{further parameters passed to \code{\link{plot}} (also see \code{\link{par}}).} } \value{ Returns a plot and \code{\linkS4class{RLum.Analysis}} object. } \description{ This function creates a Natural/Regenerated signal vs. time (NR(t)) plot as shown in Steffen et al. 2009 } \details{ This function accepts the individual curve data in many different formats. If \code{data} is a \code{list}, each element of the list must contain a two column \code{data.frame} or \code{matrix} containing the XY data of the curves (time and counts). Alternatively, the elements can be objects of class \code{\linkS4class{RLum.Data.Curve}}. Input values can also be provided as a \code{data.frame} or \code{matrix} where the first column contains the time values and each following column contains the counts of each curve. } \examples{ ## load example data data("ExampleData.BINfileData", envir = environment()) ## EXAMPLE 1 ## convert Risoe.BINfileData object to RLum.Analysis object data <- Risoe.BINfileData2RLum.Analysis(object = CWOSL.SAR.Data, pos = 8, ltype = "OSL") ## extract all OSL curves allCurves <- get_RLum(data) ## keep only the natural and regenerated signal curves pos <- seq(1, 9, 2) curves <- allCurves[pos] ## plot a standard NR(t) plot plot_NRt(curves) ## re-plot with rolling mean data smoothing plot_NRt(curves, smooth = "rmean", k = 10) ## re-plot with a logarithmic x-axis plot_NRt(curves, log = "x", smooth = "rmean", k = 5) ## re-plot with custom axes ranges plot_NRt(curves, smooth = "rmean", k = 5, xlim = c(0.1, 5), ylim = c(0.4, 1.6), legend.pos = "bottomleft") ## re-plot with smoothing spline on log scale plot_NRt(curves, smooth = "spline", log = "x", legend.pos = "top") ## EXAMPLE 2 # you may also use this function to check whether all # TD curves follow the same shape (making it a TnTx(t) plot). posTD <- seq(2, 14, 2) curves <- allCurves[posTD] plot_NRt(curves, main = "TnTx(t) Plot", smooth = "rmean", k = 20, ylab = "TD natural / TD regenerated", xlim = c(0, 20), legend = FALSE) ## EXAMPLE 3 # extract data from all positions data <- lapply(1:24, FUN = function(pos) { Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos = pos, ltype = "OSL") }) # get individual curve data from each aliquot aliquot <- lapply(data, get_RLum) # set graphical parameters par(mfrow = c(2, 2)) # create NR(t) plots for all aliquots for (i in 1:length(aliquot)) { plot_NRt(aliquot[[i]][pos], main = paste0("Aliquot #", i), smooth = "rmean", k = 20, xlim = c(0, 10), cex = 0.6, legend.pos = "bottomleft") } # reset graphical parameters par(mfrow = c(1, 1)) } \section{How to cite}{ Burow, C. (2017). plot_NRt(): Visualise natural/regenerated signal ratios. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Steffen, D., Preusser, F., Schlunegger, F., 2009. OSL quartz underestimation due to unstable signal components. Quaternary Geochronology, 4, 353-362. } \seealso{ \code{\link{plot}} } \author{ Christoph Burow, University of Cologne (Germany) } Luminescence/man/Analyse_SAR.OSLdata.Rd0000644000176200001440000001511713125227575017333 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Analyse_SAR.OSLdata.R \name{Analyse_SAR.OSLdata} \alias{Analyse_SAR.OSLdata} \title{Analyse SAR CW-OSL measurements.} \usage{ Analyse_SAR.OSLdata(input.data, signal.integral, background.integral, position, run, set, dtype, keep.SEL = FALSE, info.measurement = "unkown measurement", output.plot = FALSE, output.plot.single = FALSE, cex.global = 1, ...) } \arguments{ \item{input.data}{\link{Risoe.BINfileData-class} (\bold{required}): input data from a Risoe BIN file, produced by the function \link{read_BIN2R}.} \item{signal.integral}{\link{vector} (\bold{required}): channels used for the signal integral, e.g. \code{signal.integral=c(1:2)}} \item{background.integral}{\link{vector} (\bold{required}): channels used for the background integral, e.g. \code{background.integral=c(85:100)}} \item{position}{\link{vector} (optional): reader positions that want to be analysed (e.g. \code{position=c(1:48)}. Empty positions are automatically omitted. If no value is given all positions are analysed by default.} \item{run}{\link{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.} \item{set}{\link{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 \code{Risoe.BINfileData} object.} \item{dtype}{\code{\link{character}} (optional): allows to further limit the curves by their data type (\code{DTYPE}), e.g., \code{dtype = c("Natural", "Dose")} limits the curves to this two data types. By default all values are allowed. See \link{Risoe.BINfileData-class} for allowed data types.} \item{keep.SEL}{\code{\link{logical}} (default): option allowing to use the \code{SEL} element of the \link{Risoe.BINfileData-class} manually. NOTE: In this case any limitation provided by \code{run}, \code{set} and \code{dtype} are ignored!} \item{info.measurement}{\link{character} (with default): option to provide information about the measurement on the plot output (e.g. name of the BIN or BINX file).} \item{output.plot}{\link{logical} (with default): plot output (\code{TRUE/FALSE})} \item{output.plot.single}{\link{logical} (with default): single plot output (\code{TRUE/FALSE}) to allow for plotting the results in single plot windows. Requires \code{output.plot = TRUE}.} \item{cex.global}{\link{numeric} (with default): global scaling factor.} \item{\dots}{further arguments that will be passed to the function \code{\link{calc_OSLLxTxRatio}} (supported: \code{background.count.distribution}, \code{sigmab}, \code{sig0}; e.g., for instrumental error) and can be used to adjust the plot. Supported" \code{mtext}, \code{log}} } \value{ A plot (optional) and \link{list} is returned containing the following elements: \item{LnLxTnTx}{\link{data.frame} of all calculated Lx/Tx values including signal, background counts and the dose points.} \item{RejectionCriteria}{\link{data.frame} with values that might by used as rejection criteria. NA is produced if no R0 dose point exists.} \item{SARParameters}{\link{data.frame} of additional measurement parameters obtained from the BIN file, e.g. preheat or read temperature (not valid for all types of measurements).} } \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. } \details{ 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 \link{calc_OSLLxTxRatio} is used. \cr\cr \bold{Provided rejection criteria}\cr\cr \sQuote{recyling ratio}: calculated for every repeated regeneration dose point.\cr \sQuote{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)\cr \sQuote{IRSL/BOSL}: the integrated counts (\code{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. \strong{Note:} This is not the IR depletation ratio described by Duller (2003). } \note{ Rejection criteria are calculated but not considered during the analysis to discard values.\cr\cr \bold{The analysis of IRSL data is not directly supported}. You may want to consider using the functions \code{\link{analyse_SAR.CWOSL}} or \code{\link{analyse_pIRIRSequence}} instead.\cr \bold{The development of this function will not be continued. We recommend to use the function \link{analyse_SAR.CWOSL} or instead.} } \section{Function version}{ 0.2.17 (2017-06-29 18:40:14) } \examples{ ##load data data(ExampleData.BINfileData, envir = environment()) ##analyse data 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 } \section{How to cite}{ Kreutzer, S., Fuchs, M.C., Fuchs, M. (2017). Analyse_SAR.OSLdata(): Analyse SAR CW-OSL measurements.. Function version 0.2.17. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \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. } \seealso{ \link{calc_OSLLxTxRatio}, \link{Risoe.BINfileData-class}, \link{read_BIN2R} and for further analysis \link{plot_GrowthCurve} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France), Margret C. Fuchs, HZDR, Freiberg (Germany) \cr R Luminescence Package Team} \keyword{datagen} \keyword{dplot} Luminescence/man/set_Risoe.BINfileData.Rd0000644000176200001440000000275013125227576017741 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/set_Risoe.BINfileData.R \name{set_Risoe.BINfileData} \alias{set_Risoe.BINfileData} \title{General accessor function for RLum S4 class objects} \usage{ set_Risoe.BINfileData(METADATA = data.frame(), DATA = list(), .RESERVED = list()) } \arguments{ \item{METADATA}{x} \item{DATA}{x} \item{.RESERVED}{x} } \value{ Return is the same as input objects as provided in the list. } \description{ Function calls object-specific get functions for RisoeBINfileData S4 class objects. } \details{ The function provides a generalised access point for specific \code{\linkS4class{Risoe.BINfileData}} objects.\cr Depending on the input object, the corresponding get function will be selected. Allowed arguments can be found in the documentations of the corresponding \code{\linkS4class{Risoe.BINfileData}} class. } \section{Function version}{ 0.1 (2017-06-29 18:40:14) } \seealso{ \code{\linkS4class{Risoe.BINfileData}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). set_Risoe.BINfileData(): General accessor function for RLum S4 class objects. Function version 0.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{utilities} Luminescence/man/set_RLum.Rd0000644000176200001440000000532113125227576015473 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/set_RLum.R \name{set_RLum} \alias{set_RLum} \title{General set function for RLum S4 class objects} \usage{ set_RLum(class, originator, .uid = .create_UID(), .pid = NA_character_, ...) } \arguments{ \item{class}{\code{\linkS4class{RLum}} (\bold{required}): name of the S4 class to create} \item{originator}{\code{\link{character}} (automatic): contains the name of the calling function (the function that produces this object); can be set manually.} \item{.uid}{\code{\link{character}} (automatic): sets an unique ID for this object using the internal C++ function \code{.create_UID}.} \item{.pid}{\code{\link{character}} (with default): option to provide a parent id for nesting at will.} \item{\dots}{further arguments that one might want to pass to the specific set method} } \value{ Returns an object of the specified class. } \description{ Function calls object-specific set functions for RLum S4 class objects. } \details{ The function provides a generalised access point for specific \code{\linkS4class{RLum}} objects.\cr 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 \code{\linkS4class{RLum}} class: \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Image}}, \code{\linkS4class{RLum.Data.Spectrum}}, \code{\linkS4class{RLum.Analysis}} and \code{\linkS4class{RLum.Results}} } \section{Function version}{ 0.3.0 (2017-06-29 18:40:14) } \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) } \seealso{ \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Image}}, \code{\linkS4class{RLum.Data.Spectrum}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). set_RLum(): General set function for RLum S4 class objects. Function version 0.3.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{utilities} Luminescence/man/use_DRAC.Rd0000644000176200001440000000751213125227576015332 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/use_DRAC.R \name{use_DRAC} \alias{use_DRAC} \title{Use DRAC to calculate dose rate data} \usage{ use_DRAC(file, name, ...) } \arguments{ \item{file}{\code{\link{character}}: spreadsheet to be passed to the DRAC website for calculation. Can also be a DRAC template object obtained from \code{template_DRAC()}.} \item{name}{\code{\link{character}}: Optional user name submitted to DRAC. If omitted, a random name will be generated} \item{...}{Further arguments.} } \value{ Returns an \code{\linkS4class{RLum.Results}} object containing the following elements: \item{DRAC}{\link{list}: a named list containing the following elements in slot \code{@data}: \tabular{lll}{ \code{$highlights} \tab \code{\link{data.frame}} \tab summary of 25 most important input/output fields \cr \code{$header} \tab \code{\link{character}} \tab HTTP header from the DRAC server response \cr \code{$labels} \tab \code{\link{data.frame}} \tab descriptive headers of all input/output fields \cr \code{$content} \tab \code{\link{data.frame}} \tab complete DRAC input/output table \cr \code{$input} \tab \code{\link{data.frame}} \tab DRAC input table \cr \code{$output} \tab \code{\link{data.frame}} \tab DRAC output table \cr } } \item{data}{\link{character} or \link{list} path to the input spreadsheet or a DRAC template} \item{call}{\link{call} the function call} \item{args}{\link{list} used arguments} The output should be accessed using the function \code{\link{get_RLum}}. } \description{ The function provides an interface from R to DRAC. An R-object or a pre-formatted XLS/XLSX file is passed to the DRAC website and the results are re-imported into R. } \section{Function version}{ 0.1.1 (2017-06-29 18:40:14) } \examples{ ## (1) Method using the DRAC spreadsheet file <- "/PATH/TO/DRAC_Input_Template.csv" # send the actual IO template spreadsheet to DRAC \dontrun{ use_DRAC(file = file) } ## (2) Method using an R template object # Create a template input <- template_DRAC() # Fill the template with values input$`Project ID` <- "DRAC-Example" input$`Sample ID` <- "Quartz" input$`Conversion factors` <- "AdamiecAitken1998" input$`External U (ppm)` <- 3.4 input$`errExternal U (ppm)` <- 0.51 input$`External Th (ppm)` <- 14.47 input$`errExternal Th (ppm)` <- 1.69 input$`External K (\%)` <- 1.2 input$`errExternal K (\%)` <- 0.14 input$`Calculate external Rb from K conc?` <- "N" input$`Calculate internal Rb from K conc?` <- "N" input$`Scale gammadoserate at shallow depths?` <- "N" input$`Grain size min (microns)` <- 90 input$`Grain size max (microns)` <- 125 input$`Water content ((wet weight - dry weight)/dry weight) \%` <- 5 input$`errWater content \%` <- 2 input$`Depth (m)` <- 2.2 input$`errDepth (m)` <- 0.22 input$`Overburden density (g cm-3)` <- 1.8 input$`errOverburden density (g cm-3)` <- 0.1 input$`Latitude (decimal degrees)` <- 30.0000 input$`Longitude (decimal degrees)` <- 70.0000 input$`Altitude (m)` <- 150 input$`De (Gy)` <- 20 input$`errDe (Gy)` <- 0.2 # use DRAC \dontrun{ output <- use_DRAC(input) } } \section{How to cite}{ Kreutzer, S., Dietze, M., Burow, C. (2017). use_DRAC(): Use DRAC to calculate dose rate data. Function version 0.1.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Durcan, J.A., King, G.E., Duller, G.A.T., 2015. DRAC: Dose Rate and Age Calculator for trapped charge dating. Quaternary Geochronology 28, 54-61. doi:10.1016/j.quageo.2015.03.012 } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France), Michael Dietze, GFZ Potsdam (Germany), Christoph Burow, University of Cologne (Germany)\cr \cr R Luminescence Package Team} Luminescence/man/calc_AliquotSize.Rd0000644000176200001440000001535213125227575017200 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_AliquotSize.R \name{calc_AliquotSize} \alias{calc_AliquotSize} \title{Estimate the amount of grains on an aliquot} \usage{ calc_AliquotSize(grain.size, sample.diameter, packing.density = 0.65, MC = TRUE, grains.counted, plot = TRUE, ...) } \arguments{ \item{grain.size}{\code{\link{numeric}} (\bold{required}): mean grain size (microns) or a range of grain sizes from which the mean grain size is computed (e.g. \code{c(100,200)}).} \item{sample.diameter}{\code{\link{numeric}} (\bold{required}): diameter (mm) of the targeted area on the sample carrier.} \item{packing.density}{\code{\link{numeric}} (with default) empirical value for mean packing density. \cr If \code{packing.density = "inf"} a hexagonal structure on an infinite plane with a packing density of \eqn{0.906\ldots} is assumed.} \item{MC}{\code{\link{logical}} (optional): if \code{TRUE} the function performs a monte carlo simulation for estimating the amount of grains on the sample carrier and assumes random errors in grain size distribution and packing density. Requires a vector with min and max grain size for \code{grain.size}. For more information see details.} \item{grains.counted}{\code{\link{numeric}} (optional) grains counted on a sample carrier. If a non-zero positive integer is provided this function will calculate the packing density of the aliquot. If more than one value is provided the mean packing density and its standard deviation is calculated. Note that this overrides \code{packing.density}.} \item{plot}{\code{\link{logical}} (with default): plot output (\code{TRUE}/\code{FALSE})} \item{\dots}{further arguments to pass (\code{main, xlab, MC.iter}).} } \value{ Returns a terminal output. In addition an \code{\linkS4class{RLum.Results}} object is returned containing the following element: \item{summary}{\link{data.frame} summary of all relevant calculation results.} \item{args}{\link{list} used arguments} \item{call}{\link{call} the function call} \item{MC}{\link{list} results of the Monte Carlo simulation} The output should be accessed using the function \code{\link{get_RLum}} } \description{ Estimate the number of grains on an aliquot. Alternatively, the packing density of an aliquot is computed. } \details{ This function can be used to either estimate the number of grains on an aliquot or to compute the packing density depending on the the arguments provided. \cr The following function is used to estimate the number of grains \code{n}: \cr \deqn{n = (\pi*x^2)/(\pi*y^2)*d} where \code{x} is the radius of the aliquot size (microns), \code{y} is the mean radius of the mineral grains (mm) and \code{d} is the packing density (value between 0 and 1). \cr \bold{Packing density} \cr\cr The default value for \code{packing.density} is 0.65, which is the mean of empirical values determined by Heer et al. (2012) and unpublished data from the Cologne luminescence laboratory. If \code{packing.density = "inf"} a maximum density of \eqn{\pi/\sqrt12 = 0.9068\ldots} is used. However, note that this value is not appropriate as the standard preparation procedure of aliquots resembles a PECC ("Packing Equal Circles in a Circle") problem where the maximum packing density is asymptotic to about 0.87. \cr \bold{Monte Carlo simulation} \cr\cr The number of grains on an aliquot can be estimated by Monte Carlo simulation when setting \code{MC = TRUE}. Each of the parameters necessary to calculate \code{n} (\code{x}, \code{y}, \code{d}) are assumed to be normally distributed with means \eqn{\mu_x, \mu_y, \mu_d} and standard deviations \eqn{\sigma_x, \sigma_y, \sigma_d}. \cr\cr For the mean grain size random samples are taken first from \eqn{N(\mu_y, \sigma_y)}, where \eqn{\mu_y = mean.grain.size} and \eqn{\sigma_y = (max.grain.size-min.grain.size)/4} so that 95\% of all grains are within the provided the grain size range. This effectively takes into account that after sieving the sample there is still a small chance of having grains smaller or larger than the used mesh sizes. For each random sample the mean grain size is calculated, from which random subsamples are drawn for the Monte Carlo simulation. \cr\cr The packing density is assumed to be normally distributed with an empirically determined \eqn{\mu = 0.65} (or provided value) and \eqn{\sigma = 0.18}. The normal distribution is truncated at \code{d = 0.87} as this is approximately the maximum packing density that can be achieved in PECC problem. \cr\cr The sample diameter has \eqn{\mu = sample.diameter} and \eqn{\sigma = 0.2} to take into account variations in sample disc preparation (i.e. applying silicon spray to the disc). A lower truncation point at \code{x = 0.5} is used, which assumes that aliqouts with smaller sample diameters of 0.5 mm are discarded. Likewise, the normal distribution is truncated at 9.8 mm, which is the diameter of the sample disc. \cr\cr For each random sample drawn from the normal distributions the amount of grains on the aliquot is calculated. By default, \code{10^5} iterations are used, but can be reduced/increased with \code{MC.iter} (see \code{...}). The results are visualised in a bar- and boxplot together with a statistical summary. } \section{Function version}{ 0.31 (2017-06-29 18:40:14) } \examples{ ## Estimate the amount of grains on a small aliquot calc_AliquotSize(grain.size = c(100,150), sample.diameter = 1, MC.iter = 100) ## Calculate the mean packing density of large aliquots calc_AliquotSize(grain.size = c(100,200), sample.diameter = 8, grains.counted = c(2525,2312,2880), MC.iter = 100) } \section{How to cite}{ Burow, C. (2017). calc_AliquotSize(): Estimate the amount of grains on an aliquot. Function version 0.31. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Duller, G.A.T., 2008. Single-grain optical dating of Quaternary sediments: why aliquot size matters in luminescence dating. Boreas 37, 589-612. Heer, A.J., Adamiec, G., Moska, P., 2012. How many grains are there on a single aliquot?. Ancient TL 30, 9-16. \cr\cr \bold{Further reading} \cr\cr Chang, H.-C., Wang, L.-C., 2010. A simple proof of Thue's Theorem on Circle Packing. \url{http://arxiv.org/pdf/1009.4322v1.pdf}, 2013-09-13. Graham, R.L., Lubachevsky, B.D., Nurmela, K.J., Oestergard, P.R.J., 1998. Dense packings of congruent circles in a circle. Discrete Mathematics 181, 139-154. Huang, W., Ye, T., 2011. Global optimization method for finding dense packings of equal circles in a circle. European Journal of Operational Research 210, 474-481. } \author{ Christoph Burow, University of Cologne (Germany) \cr R Luminescence Package Team} Luminescence/man/Luminescence-package.Rd0000644000176200001440000001000313125226556017732 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \docType{package} \name{Luminescence-package} \alias{Luminescence-package} \alias{Luminescence} \title{Comprehensive Luminescence Dating Data Analysis} \description{ A collection of various R functions for the purpose of Luminescence dating data analysis. This includes, amongst others, data import, export, application of age models, curve deconvolution, sequence analysis and plotting of equivalent dose distributions. } \details{ \tabular{ll}{ Package: \tab Luminescence\cr Type: \tab Package\cr Version: \tab 0.7.5 \cr Date: \tab 2017-06-30 \cr License: \tab GPL-3\cr } } \references{ Dietze, M., Kreutzer, S., Fuchs, M.C., Burow, C., Fischer, M., Schmidt, C., 2013. A practical guide to the R package Luminescence. Ancient TL, 31, 11-18. Dietze, M., Kreutzer, S., Burow, C., Fuchs, M.C., Fischer, M., Schmidt, C., 2016. The abanico plot: visualising chronometric data with individual standard errors. Quaternary Geochronology 31, 1-7. http://dx.doi.org/10.1016/j.quageo.2015.09.003 Fuchs, M.C., Kreutzer, S., Burow, C., Dietze, M., Fischer, M., Schmidt, C., Fuchs, M., 2015. Data processing in luminescence dating analysis: An exemplary workflow using the R package 'Luminescence'. Quaternary International, 362,8-13. http://dx.doi.org/10.1016/j.quaint.2014.06.034 Kreutzer, S., Schmidt, C., Fuchs, M.C., Dietze, M., Fischer, M., Fuchs, M., 2012. Introducing an R package for luminescence dating analysis. Ancient TL, 30, 1-8. Smedley, R.K., 2015. A new R function for the Internal External Uncertainty (IEU) model. Ancient TL 33, 16-21. } \author{ \bold{Full list of authors and contributors} (alphabetic order) \tabular{ll}{ Christoph Burow \tab University of Cologne, Germany \cr Claire Christophe \tab IRAMAT-CRP2A, Universite Bordeaux Montaigne, France \cr Michael Dietze \tab GFZ Helmholtz Centre Potsdam, Germany \cr Julie Durcan \tab University of Oxford, United Kingdom \cr Manfred Fischer\tab University of Bayreuth, Germany \cr Margret C. Fuchs \tab Helmholtz-Zentrum Dresden-Rossendorf, Helmholtz-Institute Freiberg for Resource Technology, Freiberg, Germany \cr Johannes Friedrich \tab University of Bayreuth, Germany \cr Guillaume Guerin \tab IRAMAT-CRP2A, Universite Bordeaux Montaigne, France \cr Georgina King \tab Institute of Geological Sciences, University of Bern, Switzerland \cr Sebastian Kreutzer \tab IRAMAT-CRP2A, Universite Bordeaux Montaigne, France \cr Norbert Mercier \tab IRAMAT-CRP2A, Universite Bordeaux Montaigne, France \cr Anne Philippe \tab Universite de Nantes and ANJA INRIA, Rennes, France \cr Christoph Schmidt \tab University of Bayreuth, Germany \cr Rachel K. Smedley \tab Aberystwyth University, United Kingdom \cr Antoine Zink \tab C2RMF, Palais du Louvre, Paris, France } \bold{Supervisor of the initial version in 2012} Markus Fuchs, Justus-Liebig-University Giessen, Germany\cr \bold{Support contact} \email{developers@r-luminescence.org}\cr We may further encourage the usage of our support forum. For this please visit our project website (link below). \bold{Bug reporting} \email{developers@r-luminescence.org} or \cr \url{https://github.com/R-Lum/Luminescence/issues} \cr \bold{Project website} \url{http://www.r-luminescence.org}\cr \bold{Project source code repository}\cr \url{https://github.com/R-Lum/Luminescence}\cr \bold{Related package projects}\cr \url{https://cran.r-project.org/package=RLumShiny}\cr \url{http://shiny.r-luminescence.org}\cr \url{https://cran.r-project.org/package=RLumModel}\cr \url{http://model.r-luminescence.org}\cr \bold{Package maintainer} Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne, Pessac, France, \cr \email{sebastian.kreutzer@u-bordeaux-montaigne.fr} \bold{Acknowledgement} Cooperation and personal exchange between the developers is gratefully funded by the DFG (SCHM 3051/3-1) in the framework of the program "Scientific Networks". Project title: "RLum.Network: Ein Wissenschaftsnetzwerk zur Analyse von Lumineszenzdaten mit R" (2014-2017) } \keyword{package} Luminescence/man/RLum.Analysis-class.Rd0000644000176200001440000001767113125227576017520 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RLum.Analysis-class.R \docType{class} \name{RLum.Analysis-class} \alias{RLum.Analysis-class} \alias{show,RLum.Analysis-method} \alias{set_RLum,RLum.Analysis-method} \alias{get_RLum,RLum.Analysis-method} \alias{structure_RLum,RLum.Analysis-method} \alias{length_RLum,RLum.Analysis-method} \alias{names_RLum,RLum.Analysis-method} \alias{smooth_RLum,RLum.Analysis-method} \title{Class \code{"RLum.Analysis"}} \usage{ \S4method{show}{RLum.Analysis}(object) \S4method{set_RLum}{RLum.Analysis}(class, originator, .uid, .pid, protocol = NA_character_, records = list(), info = list()) \S4method{get_RLum}{RLum.Analysis}(object, record.id = NULL, recordType = NULL, curveType = NULL, RLum.type = NULL, protocol = "UNKNOWN", get.index = NULL, drop = TRUE, recursive = TRUE, info.object = NULL, subset = NULL) \S4method{structure_RLum}{RLum.Analysis}(object, fullExtent = FALSE) \S4method{length_RLum}{RLum.Analysis}(object) \S4method{names_RLum}{RLum.Analysis}(object) \S4method{smooth_RLum}{RLum.Analysis}(object, ...) } \arguments{ \item{object}{\code{[show_RLum]}\code{[get_RLum]}\code{[names_RLum]}\code{[length_RLum]} \code{[structure_RLum]}] an object of class \code{\linkS4class{RLum.Analysis}} (\bold{required})} \item{class}{[\code{set_RLum}] \code{\link{character}} (\bold{required}): name of the \code{RLum} class to be created} \item{originator}{[\code{set_RLum}] \code{\link{character}} (automatic): contains the name of the calling function (the function that produces this object); can be set manually.} \item{.uid}{[\code{set_RLum}] \code{\link{character}} (automatic): sets an unique ID for this object using the internal C++ function \code{.create_UID}.} \item{.pid}{[\code{set_RLum}] \code{\link{character}} (with default): option to provide a parent id for nesting at will.} \item{protocol}{[\code{set_RLum}] \code{\link{character}} (optional): sets protocol type for analysis object. Value may be used by subsequent analysis functions.} \item{records}{[\code{set_RLum}] \code{\link{list}} (\bold{required}): list of \code{\linkS4class{RLum.Analysis}} objects} \item{info}{[\code{set_RLum}] \code{\link{list}} (optional): a list containing additional info data for the object \bold{\code{set_RLum}}:\cr Returns an \code{\linkS4class{RLum.Analysis}} object.} \item{record.id}{[\code{get_RLum}] \code{\link{numeric}} or \code{\link{logical}} (optional): IDs of specific records. If of type \code{logical} the entire id range is assuemd and \code{TRUE} and \code{FALSE} indicates the selection.} \item{recordType}{[\code{get_RLum}] \code{\link{character}} (optional): record type (e.g., "OSL"). Can be also a vector, for multiple matching, e.g., \code{recordType = c("OSL", "IRSL")}} \item{curveType}{[\code{get_RLum}] \code{\link{character}} (optional): curve type (e.g. "predefined" or "measured")} \item{RLum.type}{[\code{get_RLum}] \code{\link{character}} (optional): RLum object type. Defaults to "RLum.Data.Curve" and "RLum.Data.Spectrum".} \item{get.index}{[\code{get_RLum}] \code{\link{logical}} (optional): return a numeric vector with the index of each element in the RLum.Analysis object.} \item{drop}{[\code{get_RLum}] \code{\link{logical}} (with default): coerce to the next possible layer (which are \code{RLum.Data}-objects), \code{drop = FALSE} keeps the original \code{RLum.Analysis}} \item{recursive}{[\code{get_RLum}] \code{\link{logical}} (with default): if \code{TRUE} (the default) and the result of the 'get_RLum' request is a single object this object will be unlisted, means only the object itself and no list containing exactly one object is returned. Mostly this makes things easier, however, if this method is used within a loop this might undesired.} \item{info.object}{[\code{get_RLum}] \code{\link{character}} (optional): name of the wanted info element} \item{subset}{\code{\link{expression}} (optional): logical expression indicating elements or rows to keep: missing values are taken as false. This argument takes precedence over all other arguments, meaning they are not considered when subsetting the object.} \item{fullExtent}{[structure_RLum] \code{\link{logical}} (with default): extents the returned \code{data.frame} to its full extent, i.e. all info elements are part of the return as well. The default valule is \code{FALSE} as the data frame might become rather big.} \item{...}{further arguments passed to underlying methods} } \value{ \bold{\code{get_RLum}}:\cr Returns: \cr (1) \code{\link{list}} of \code{\linkS4class{RLum.Data}} objects or \cr (2) Single \code{\linkS4class{RLum.Data}} object, if only one object is contained and \code{recursive = FALSE} or\cr (3) \code{\linkS4class{RLum.Analysis}} ojects for \code{drop = FALSE} \cr \bold{\code{structure_RLum}}:\cr Returns \code{\linkS4class{data.frame}} showing the structure. \bold{\code{length_RLum}}\cr Returns the number records in this object. \bold{\code{names_RLum}}\cr Returns the names of the record types (recordType) in this object. \bold{\code{smooth_RLum}}\cr Same object as input, after smoothing } \description{ Object class to represent analysis data for protocol analysis, i.e. all curves, spectra etc. from one measurements. Objects from this class are produced, by e.g. \code{\link{read_XSYG2R}}, \code{\link{read_Daybreak2R}} } \section{Methods (by generic)}{ \itemize{ \item \code{show}: Show structure of \code{RLum.Analysis} object \item \code{set_RLum}: Construction method for \code{\linkS4class{RLum.Analysis}} objects. \item \code{get_RLum}: Accessor method for RLum.Analysis object. The slots record.id, recordType, curveType and RLum.type are optional to allow for records limited by their id (list index number), their record type (e.g. recordType = "OSL") or object type. Example: curve type (e.g. curveType = "predefined" or curveType ="measured") The selection of a specific RLum.type object superimposes the default selection. Currently supported objects are: RLum.Data.Curve and RLum.Data.Spectrum \item \code{structure_RLum}: Method to show the structure of an \code{\linkS4class{RLum.Analysis}} object. \item \code{length_RLum}: Returns the length of the object, i.e., number of stored records. \item \code{names_RLum}: Returns the names of the \code{\linkS4class{RLum.Data}} objects objects (same as shown with the show method) \item \code{smooth_RLum}: Smoothing of \code{RLum.Data} objects contained in this \code{RLum.Analysis} object \code{\link[zoo]{rollmean}} or \code{\link[zoo]{rollmedian}}. In particular the internal function \code{.smoothing} is used. }} \section{Slots}{ \describe{ \item{\code{protocol}}{Object of class \code{\link{character}} describing the applied measurement protocol} \item{\code{records}}{Object of class \code{\link{list}} containing objects of class \code{\linkS4class{RLum.Data}}} }} \note{ The method \code{\link{structure_RLum}} is currently just avaiblable for objects containing \code{\linkS4class{RLum.Data.Curve}}. } \section{Objects from the Class}{ Objects can be created by calls of the form \code{set_RLum("RLum.Analysis", ...)}. } \section{Class version}{ 0.4.8 } \examples{ showClass("RLum.Analysis") ##set empty object set_RLum(class = "RLum.Analysis") ###use example data ##load data data(ExampleData.RLum.Analysis, envir = environment()) ##show curves in object get_RLum(IRSAR.RF.Data) ##show only the first object, but by keeping the object get_RLum(IRSAR.RF.Data, record.id = 1, drop = FALSE) } \seealso{ \code{\link{Risoe.BINfileData2RLum.Analysis}}, \code{\linkS4class{Risoe.BINfileData}}, \code{\linkS4class{RLum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) } \section{How to cite}{ Kreutzer, S. (2017). RLum.Analysis-class(): Class 'RLum.Analysis'. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{classes} \keyword{methods} Luminescence/man/calc_FastRatio.Rd0000644000176200001440000001206113125227575016615 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_FastRatio.R \name{calc_FastRatio} \alias{calc_FastRatio} \title{Calculate the Fast Ratio for CW-OSL curves} \usage{ calc_FastRatio(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, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data.Curve}} or \code{\link{data.frame}} (\bold{required}): x, y data of measured values (time and counts).} \item{stimulation.power}{\code{\link{numeric}} (with default): Stimulation power in mW/cm^2} \item{wavelength}{\code{\link{numeric}} (with default): Stimulation wavelength in nm} \item{sigmaF}{\code{\link{numeric}} (with default): Photoionisation cross-section (cm^2) of the fast component. Default value after Durcan & Duller (2011).} \item{sigmaM}{\code{\link{numeric}} (with default): Photoionisation cross-section (cm^2) of the medium component. Default value after Durcan & Duller (2011).} \item{Ch_L1}{\code{\link{numeric}} (with default): An integer specifying the channel for L1.} \item{Ch_L2}{\code{\link{numeric}} (optional): An integer specifying the channel for L2.} \item{Ch_L3}{\code{\link{numeric}} (optional): A vector of length 2 with integer values specifying the start and end channels for L3 (e.g., \code{c(40, 50)}).} \item{x}{\code{\link{numeric}} (with default): \% of signal remaining from the fast component. Used to define the location of L2 and L3 (start).} \item{x2}{\code{\link{numeric}} (with default): \% of signal remaining from the medium component. Used to define the location of L3 (end).} \item{dead.channels}{\code{\link{numeric}} (with default): Vector of length 2 in the form of \code{c(x, y)}. Channels that do not contain OSL data, i.e. at the start or end of measurement.} \item{fitCW.sigma}{\code{\link{logical}} (optional): fit CW-OSL curve using \code{\link{fit_CWCurve}} to calculate \code{sigmaF} and \code{sigmaM} (experimental).} \item{fitCW.curve}{\code{\link{logical}} (optional): fit CW-OSL curve using \code{\link{fit_CWCurve}} and derive the counts of L2 and L3 from the fitted OSL curve (experimental).} \item{plot}{\code{\link{logical}} (with default): plot output (\code{TRUE}/\code{FALSE})} \item{...}{available options: \code{verbose} (\code{\link{logical}}). Further arguments passed to \code{\link{fit_CWCurve}}.} } \value{ Returns a plot (optional) and an S4 object of type \code{\linkS4class{RLum.Results}}. The slot \code{data} contains a \code{\link{list}} with the following elements:\cr \item{summary}{\code{\link{data.frame}} summary of all relevant results} \item{data}{the original input data} \item{fit}{\code{\linkS4class{RLum.Results}} object if either \code{fitCW.sigma} or \code{fitCW.curve} is \code{TRUE}} \item{args}{\code{\link{list}} of used arguments} \item{call}{\code{\link{call}} the function call} } \description{ Function to calculate the fast ratio of quartz CW-OSL single grain or single aliquot curves after Durcan & Duller (2011). } \details{ This function follows the equations of Durcan & Duller (2011). The energy required to reduce the fast and medium quartz OSL components to \code{x} and \code{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)}. } \section{Function version}{ 0.1.1 (2017-06-29 18:40:14) } \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) } \section{How to cite}{ King, G., Durcan, J., Burow, C. (2017). calc_FastRatio(): Calculate the Fast Ratio for CW-OSL curves. Function version 0.1.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \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. \cr\cr 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. \cr\cr \bold{Further reading} \cr\cr Steffen, D., Preusser, F. & Schlunegger, 2009. OSL quartz age underestimation due to unstable signal components. Quaternary Geochronology 4, 353-362. } \seealso{ \code{\link{fit_CWCurve}}, \code{\link{get_RLum}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}}, \code{\linkS4class{RLum.Data.Curve}} } \author{ Georgina King, University of Cologne (Germany) \cr Julie A. Durcan, University of Oxford (United Kingdom) \cr Christoph Burow, University of Cologne (Germany) \cr \cr R Luminescence Package Team} Luminescence/man/plot_AbanicoPlot.Rd0000644000176200001440000004365013125227576017201 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_AbanicoPlot.R \name{plot_AbanicoPlot} \alias{plot_AbanicoPlot} \title{Function to create an Abanico Plot.} \usage{ plot_AbanicoPlot(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", output = TRUE, interactive = FALSE, ...) } \arguments{ \item{data}{\code{\link{data.frame}} or \code{\linkS4class{RLum.Results}} object (required): for \code{data.frame} two columns: De (\code{data[,1]}) and De error (\code{data[,2]}). To plot several data sets in one plot the data sets must be provided as \code{list}, e.g. \code{list(data.1, data.2)}.} \item{na.rm}{\code{\link{logical}} (with default): exclude NA values from the data set prior to any further operations.} \item{log.z}{\code{\link{logical}} (with default): Option to display the z-axis in logarithmic scale. Default is \code{TRUE}.} \item{z.0}{\code{\link{character}} or \code{\link{numeric}}: User-defined central value, used for centering of data. One out of \code{"mean"}, \code{"mean.weighted"} and \code{"median"} or a numeric value (not its logarithm). Default is \code{"mean.weighted"}.} \item{dispersion}{\code{\link{character}} (with default): measure of dispersion, used for drawing the scatter polygon. One out of \code{"qr"} (quartile range), \code{"pnn"} (symmetric percentile range with nn the lower percentile, e.g. \code{"p05"} depicting the range between 5 and 95 %), \code{"sd"} (standard deviation) and \code{"2sd"} (2 standard deviations), default is \code{"qr"}. Note that \code{"sd"} and \code{"2sd"} are only meaningful in combination with \code{"z.0 = 'mean'"} because the unweighted mean is used to center the polygon.} \item{plot.ratio}{\code{\link{numeric}}: Relative space, given to the radial versus the cartesian plot part, deault is \code{0.75}.} \item{rotate}{\code{\link{logical}}: Option to turn the plot by 90 degrees.} \item{mtext}{\code{\link{character}}: additional text below the plot title.} \item{summary}{\code{\link{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).} \item{summary.pos}{\code{\link{numeric}} or \code{\link{character}} (with default): optional position coordinates or keyword (e.g. \code{"topright"}) for the statistical summary. Alternatively, the keyword \code{"sub"} may be specified to place the summary below the plot header. However, this latter option in only possible if \code{mtext} is not used.} \item{summary.method}{\code{\link{character}} (with default): keyword indicating the method used to calculate the statistic summary. One out of \code{"unweighted"}, \code{"weighted"} and \code{"MCM"}. See \code{\link{calc_Statistics}} for details.} \item{legend}{\code{\link{character}} vector (optional): legend content to be added to the plot.} \item{legend.pos}{\code{\link{numeric}} or \code{\link{character}} (with default): optional position coordinates or keyword (e.g. \code{"topright"}) for the legend to be plotted.} \item{stats}{\code{\link{character}}: additional labels of statistically important values in the plot. One or more out of the following: \code{"min"}, \code{"max"}, \code{"median"}.} \item{rug}{\code{\link{logical}}: Option to add a rug to the KDE part, to indicate the location of individual values.} \item{kde}{\code{\link{logical}}: Option to add a KDE plot to the dispersion part, default is \code{TRUE}.} \item{hist}{\code{\link{logical}}: Option to add a histogram to the dispersion part. Only meaningful when not more than one data set is plotted.} \item{dots}{\code{\link{logical}}: Option to add a dot plot to the dispersion part. If number of dots exceeds space in the dispersion part, a square indicates this.} \item{boxplot}{\code{\link{logical}}: Option to add a boxplot to the dispersion part, default is \code{FALSE}.} \item{y.axis}{\code{\link{logical}}: Option to hide y-axis labels. Useful for data with small scatter.} \item{error.bars}{\code{\link{logical}}: Option to show De-errors as error bars on De-points. Useful in combination with \code{y.axis = FALSE, bar.col = "none"}.} \item{bar}{\code{\link{numeric}} (with default): option to add one or more dispersion bars (i.e., bar showing the 2-sigma range) centered at the defined values. By default a bar is drawn according to \code{"z.0"}. To omit the bar set \code{"bar = FALSE"}.} \item{bar.col}{\code{\link{character}} or \code{\link{numeric}} (with default): colour of the dispersion bar. Default is \code{"grey60"}.} \item{polygon.col}{\code{\link{character}} or \code{\link{numeric}} (with default): colour of the polygon showing the data scatter. Sometimes this polygon may be omitted for clarity. To disable it use \code{FALSE} or \code{polygon = FALSE}. Default is \code{"grey80"}.} \item{line}{\code{\link{numeric}}: numeric values of the additional lines to be added.} \item{line.col}{\code{\link{character}} or \code{\link{numeric}}: colour of the additional lines.} \item{line.lty}{\code{\link{integer}}: line type of additional lines} \item{line.label}{\code{\link{character}}: labels for the additional lines.} \item{grid.col}{\code{\link{character}} or \code{\link{numeric}} (with default): colour of the grid lines (originating at [0,0] and strechting to the z-scale). To disable grid lines use \code{FALSE}. Default is \code{"grey"}.} \item{frame}{\code{\link{numeric}} (with default): option to modify the plot frame type. Can be one out of \code{0} (no frame), \code{1} (frame originates at 0,0 and runs along min/max isochrons), \code{2} (frame embraces the 2-sigma bar), \code{3} (frame embraces the entire plot as a rectangle).Default is \code{1}.} \item{bw}{\code{\link{character}} (with default): bin-width for KDE, choose a numeric value for manual setting.} \item{output}{\code{\link{logical}}: Optional output of numerical plot parameters. These can be useful to reproduce similar plots. Default is \code{TRUE}.} \item{interactive}{\code{\link{logical}} (with default): create an interactive abanico plot (requires the 'plotly' package)} \item{\dots}{Further plot arguments to pass. \code{xlab} must be a vector of length 2, specifying the upper and lower x-axes labels.} } \value{ returns a plot object and, optionally, a list with plot calculus data. } \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 (\code{plot_RadialPlot}) and a kernel density estimate plot (e.g \code{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 thoughtprovocing figure in this article. \cr 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 dispaying 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 themselfes. \cr 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 \code{?polygon()} for further help. \cr 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. \code{centrality = "median.weighted"}). Also user-defined numeric values (e.g. from the central age model) can be used if this appears appropriate. \cr The proportion of the polar part and the cartesian part of the Abanico Plot can be modfied for display reasons (\code{plot.ratio = 0.75}). By default, the polar part spreads over 75 \% and leaves 25 \% for the part that shows the KDE graph.\cr\cr 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: \itemize{ \item \code{"n"} (number of samples) \item \code{"mean"} (mean De value) \item \code{"median"} (median of the De values) \item \code{"sd.rel"} (relative standard deviation in percent) \item \code{"sd.abs"} (absolute standard deviation) \item \code{"se.rel"} (relative standard error) \item \code{"se.abs"} (absolute standard error) \item \code{"in.2s"} (percent of samples in 2-sigma range) \item \code{"kurtosis"} (kurtosis) \item \code{"skewness"} (skewness) } Note that the input data for the statistic summary is sent to the function \code{calc_Statistics()} depending on the log-option for the z-scale. If \code{"log.z = TRUE"}, the summary is based on the logarithms of the input data. If \code{"log.z = FALSE"} the linearly scaled data is used. \cr Note as well, that \code{"calc_Statistics()"} calculates these statistic measures in three different ways: \code{unweighted}, \code{weighted} and \code{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 \code{summary.method}.\cr\cr The optional parameter \code{layout} allows to modify the entire plot more sophisticated. 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. \code{get_Layout()} or type eg. for the layout type \code{"journal"} \code{get_Layout("journal")}. A layout type can be modified by the user by assigning new values to the list object.\cr\cr It is possible for the z-scale to specify where ticks are to be drawn by using the parameter \code{at}, e.g. \code{at = seq(80, 200, 20)}, cf. function documentation of \code{axis}. Specifying tick positions manually overrides a \code{zlim}-definition. } \section{Function version}{ 0.1.10 (2017-06-29 18:40:14) } \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) } \section{How to cite}{ Dietze, M., Kreutzer, S. (2017). plot_AbanicoPlot(): Function to create an Abanico Plot.. Function version 0.1.10. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \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 } \seealso{ \code{\link{plot_RadialPlot}}, \code{\link{plot_KDE}}, \code{\link{plot_Histogram}} } \author{ Michael Dietze, GFZ Potsdam (Germany),\cr Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France)\cr Inspired by a plot introduced by Galbraith & Green (1990) \cr R Luminescence Package Team} Luminescence/man/convert_PSL2CSV.Rd0000644000176200001440000000354113125227576016577 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convert_PSL2CSV.R \name{convert_PSL2CSV} \alias{convert_PSL2CSV} \title{Export PSL-file(s) to CSV-files} \usage{ convert_PSL2CSV(file, ...) } \arguments{ \item{file}{\code{\link{character}} (\bold{required}): name of the PSL-file to be converted to CSV-files} \item{\dots}{further arguments that will be passed to the function \code{\link{read_PSL2R}} and \code{\link{write_RLum2CSV}}} } \value{ The function returns either a CSV-file (or many of them) or for the option \code{export = FALSE} a list comprising objects of type \code{link{data.frame}} and \code{\link{matrix}} } \description{ This function is a wrapper function around the functions \code{\link{read_PSL2R}} and \code{\link{write_RLum2CSV}} and it imports an PSL-file (SUERC portable OSL reader file format) and directly exports its content to CSV-files. If nothing is set for the argument \code{path} (\code{\link{write_RLum2CSV}}) the input folder will become the output folder. } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \examples{ \dontrun{ ##select your BIN-file file <- file.choose() ##convert convert_PSL2CSV(file) } } \seealso{ \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data}}, \code{\linkS4class{RLum.Results}}, \code{\link[utils]{write.table}}, \code{\link{write_RLum2CSV}}, \code{\link{read_PSL2R}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). convert_PSL2CSV(): Export PSL-file(s) to CSV-files. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{IO} Luminescence/man/analyse_SAR.CWOSL.Rd0000644000176200001440000002376013125227575016776 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/analyse_SAR.CWOSL.R \name{analyse_SAR.CWOSL} \alias{analyse_SAR.CWOSL} \title{Analyse SAR CW-OSL measurements} \usage{ analyse_SAR.CWOSL(object, signal.integral.min, signal.integral.max, background.integral.min, background.integral.max, rejection.criteria = NULL, dose.points = NULL, mtext.outer, plot = TRUE, plot.single = FALSE, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Analysis}} (\bold{required}): input object containing data for analysis, alternatively a \code{\link{list}} of \code{\linkS4class{RLum.Analysis}} objects can be provided.} \item{signal.integral.min}{\code{\link{integer}} (\bold{required}): lower bound of the signal integral. Can be a \code{\link{list}} of \code{\link{integer}s}, if \code{object} is of type \code{\link{list}}. If the input is vector (e.g., \code{c(1,2)}) the 2nd value will be interpreted as the minimum signal integral for the Tx curve.} \item{signal.integral.max}{\code{\link{integer}} (\bold{required}): upper bound of the signal integral. Can be a \code{\link{list}} of \code{\link{integer}s}, if \code{object} is of type \code{\link{list}}. If the input is vector (e.g., \code{c(1,2)}) the 2nd value will be interpreted as the maximum signal integral for the Tx curve.} \item{background.integral.min}{\code{\link{integer}} (\bold{required}): lower bound of the background integral. Can be a \code{\link{list}} of \code{\link{integer}s}, if \code{object} is of type \code{\link{list}}. If the input is vector (e.g., \code{c(1,2)}) the 2nd value will be interpreted as the minimum background integral for the Tx curve.} \item{background.integral.max}{\code{\link{integer}} (\bold{required}): upper bound of the background integral. Can be a \code{\link{list}} of \code{\link{integer}s}, if \code{object} is of type \code{\link{list}}. If the input is vector (e.g., \code{c(1,2)}) the 2nd value will be interpreted as the maximum background integral for the Tx curve.} \item{rejection.criteria}{\code{\link{list}} (with default): provide a named list and set rejection criteria in \bold{percentage} for further calculation. Can be a \code{\link{list}} in a \code{\link{list}}, if \code{object} is of type \code{\link{list}} Allowed arguments are \code{recycling.ratio}, \code{recuperation.rate}, \code{palaeodose.error}, \code{testdose.error} and \code{exceed.max.regpoint = TRUE/FALSE}. Example: \code{rejection.criteria = list(recycling.ratio = 10)}. Per default all numerical values are set to 10, \code{exceed.max.regpoint = TRUE}. Every criterium can be set to \code{NA}. In this value are calculated, but not considered, i.e. the RC.Status becomes always \code{'OK'}} \item{dose.points}{\code{\link{numeric}} (optional): a numeric vector containg the dose points values Using this argument overwrites dose point values in the signal curves. Can be a \code{\link{list}} of \code{\link{numeric}} vectors, if \code{object} is of type \code{\link{list}}} \item{mtext.outer}{\code{\link{character}} (optional): option to provide an outer margin mtext. Can be a \code{\link{list}} of \code{\link{character}s}, if \code{object} is of type \code{\link{list}}} \item{plot}{\code{\link{logical}} (with default): enables or disables plot output.} \item{plot.single}{\code{\link{logical}} (with default) or \code{\link{numeric}} (optional): single plot output (\code{TRUE/FALSE}) to allow for plotting the results in single plot windows. If a numerice vector is provided the plots can be selected individually, i.e. \code{plot.single = 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 \code{plot = TRUE}.} \item{\dots}{further arguments that will be passed to the function \code{\link{plot_GrowthCurve}} or \code{\link{calc_OSLLxTxRatio}} (supported: \code{background.count.distribution}, \code{sigmab}, \code{sig0}). \bold{Please note} that if you consider to use the early light subtraction method you should provide your own \code{sigmab} value!} } \value{ A plot (optional) and an \code{\linkS4class{RLum.Results}} object is returned containing the following elements: \item{data}{\link{data.frame} containing De-values, De-error and further parameters} \item{LnLxTnTx.values}{\link{data.frame} of all calculated Lx/Tx values including signal, background counts and the dose points} \item{rejection.criteria}{\link{data.frame} with values that might by used as rejection criteria. NA is produced if no R0 dose point exists.} \item{Formula}{\link{formula} formula that have been used for the growth curve fitting }\cr The output should be accessed using the function \code{\link{get_RLum}}. } \description{ The function performs a SAR CW-OSL analysis on an \code{\linkS4class{RLum.Analysis}} 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 \link{calc_OSLLxTxRatio} is used. For \bold{changing the way the Lx/Tx error is calculated} use the argument \code{background.count.distribution} and \code{sigmab}, which will be passed to the function \link{calc_OSLLxTxRatio}.\cr\cr \bold{Argument \code{object} is of type \code{list}}\cr\cr If the argument \code{object} is of type \code{\link{list}} containing \bold{only} \code{\linkS4class{RLum.Analysis}} objects, the function re-calls itself as often as elements are in the list. This is usefull if an entire measurement wanted to be analysed without writing separate for-loops. To gain in full control of the parameters (e.g., \code{dose.points}) for every aliquot (corresponding to one \code{\linkS4class{RLum.Analysis}} object in the list), in this case the arguments can be provided as \code{\link{list}}. This \code{list} should be of similar length as the \code{list} provided with the argument \code{object}, otherwise the function will create an own list of the requested lenght. Function output will be just one single \code{\linkS4class{RLum.Results}} 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.\cr\cr \bold{Working with IRSL data}\cr\cr 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. \cr 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.\cr\cr \bold{Supported rejection criteria}\cr\cr \sQuote{recycling.ratio}: calculated for every repeated regeneration dose point.\cr \sQuote{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).\cr \sQuote{testdose.error}: set the allowed error for the testdose, which per default should not exceed 10\%. The testdose error is calculated as Tx_net.error/Tx_net. \sQuote{palaeodose.error}: set the allowed error for the De value, which per default should not exceed 10\%. } \note{ This function must not be mixed up with the function \code{\link{Analyse_SAR.OSLdata}}, which works with \link{Risoe.BINfileData-class} objects.\cr \bold{The function currently does only support 'OSL' or 'IRSL' data!} } \section{Function version}{ 0.7.10 (2017-06-29 18:40:14) } \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, exceed.max.regpoint = TRUE) ) ##show De results get_RLum(results) ##show LnTnLxTx table get_RLum(results, data.object = "LnLxTnTx.table") } \section{How to cite}{ Kreutzer, S. (2017). analyse_SAR.CWOSL(): Analyse SAR CW-OSL measurements. Function version 0.7.10. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \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 } \seealso{ \code{\link{calc_OSLLxTxRatio}}, \code{\link{plot_GrowthCurve}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}} \code{\link{get_RLum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{datagen} \keyword{plot} Luminescence/man/plot_ViolinPlot.Rd0000644000176200001440000001027713125227576017104 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_ViolinPlot.R \name{plot_ViolinPlot} \alias{plot_ViolinPlot} \title{Create a violin plot} \usage{ plot_ViolinPlot(data, boxplot = TRUE, rug = TRUE, summary = NULL, summary.pos = "sub", na.rm = TRUE, ...) } \arguments{ \item{data}{\code{\link{numeric}} or \code{\linkS4class{RLum.Results}} object (required): input data for plotting. Alternatively a \code{\link{data.frame}} or a \code{\link{matrix}} can be provided, but only the first column will be considered by the function} \item{boxplot}{\code{\link{logical}} (with default): enable or disable boxplot} \item{rug}{\code{\link{logical}} (with default): enable or disable rug} \item{summary}{\code{\link{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.} \item{summary.pos}{\code{\link{numeric}} or \code{\link{character}} (with default): optional position keywords (cf., \code{\link{legend}}) for the statistical summary. Alternatively, the keyword \code{"sub"} may be specified to place the summary below the plot header. However, this latter option in only possible if \code{mtext} is not used.} \item{na.rm}{\code{\link{logical}} (with default): exclude NA values from the data set prior to any further operations.} \item{\dots}{further arguments and graphical parameters passed to \code{\link{plot.default}}, \code{\link[stats]{density}} and \code{\link{boxplot}}. See details for further information} } \description{ Draws a kernal densiy 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 to small to be visualised. The idea for this plot is based on the the 'volcano plot' in the ggplot2 package by Hadely Wickham and Winston Chang. The general idea for the Violin Plot seems to be introduced by Hintze and Nelson (1998). } \details{ The function is passing several arguments to the function \code{\link{plot}}, \code{\link[stats]{density}}, \code{\link[graphics]{boxplot}}: Supported arguments are: \code{xlim}, \code{main}, \code{xlab}, \code{ylab}, \code{col.violin}, \code{col.boxplot}, \code{mtext}, \code{cex}, \code{mtext} \bold{\code{Valid summary keywords}}\cr 'n', 'mean', 'median', 'sd.abs', 'sd.rel', 'se.abs', 'se.rel', 'skewness', 'kurtosis' } \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.3 (2017-06-29 18:40:14) } \examples{ ## read example data set data(ExampleData.DeValues, envir = environment()) ExampleData.DeValues <- Second2Gray(ExampleData.DeValues$BT998, c(0.0438,0.0019)) ## create plot straightforward plot_ViolinPlot(data = ExampleData.DeValues) } \section{How to cite}{ Kreutzer, S. (2017). plot_ViolinPlot(): Create a violin plot. Function version 0.1.3. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \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{ \code{\link[stats]{density}}, \code{\link{plot}}, \code{\link{boxplot}}, \code{\link{rug}}, \code{\link{calc_Statistics}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} Luminescence/man/ExampleData.LxTxOSLData.Rd0000644000176200001440000000106713125226556020174 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \name{ExampleData.LxTxOSLData} \alias{ExampleData.LxTxOSLData} \title{Example Lx and Tx curve data from an artificial OSL measurement} \format{Two \code{data.frames} containing time and count values.} \source{ Arbitrary OSL measurement. } \description{ Lx and Tx data of continous wave (CW-) OSL signal curves. } \examples{ ##load data data(ExampleData.LxTxOSLData, envir = environment()) ##plot data plot(Lx.data) plot(Tx.data) } \references{ unpublished data } Luminescence/man/RLum.Data.Curve-class.Rd0000644000176200001440000001543313125227576017663 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RLum.Data.Curve-class.R \docType{class} \name{RLum.Data.Curve-class} \alias{RLum.Data.Curve-class} \alias{show,RLum.Data.Curve-method} \alias{set_RLum,RLum.Data.Curve-method} \alias{get_RLum,RLum.Data.Curve-method} \alias{length_RLum,RLum.Data.Curve-method} \alias{names_RLum,RLum.Data.Curve-method} \alias{bin_RLum.Data,RLum.Data.Curve-method} \alias{smooth_RLum,RLum.Data.Curve-method} \title{Class \code{"RLum.Data.Curve"}} \usage{ \S4method{show}{RLum.Data.Curve}(object) \S4method{set_RLum}{RLum.Data.Curve}(class, originator, .uid, .pid, recordType = NA_character_, curveType = NA_character_, data = matrix(0, ncol = 2), info = list()) \S4method{get_RLum}{RLum.Data.Curve}(object, info.object = NULL) \S4method{length_RLum}{RLum.Data.Curve}(object) \S4method{names_RLum}{RLum.Data.Curve}(object) \S4method{bin_RLum.Data}{RLum.Data.Curve}(object, bin_size = 2) \S4method{smooth_RLum}{RLum.Data.Curve}(object, k = NULL, fill = NA, align = "right", method = "mean") } \arguments{ \item{object}{[\code{show_RLum}][\code{get_RLum}][\code{length_RLum}][\code{names_RLum}] an object of class \code{\linkS4class{RLum.Data.Curve}} (\bold{required})} \item{class}{[\code{set_RLum}] \code{\link{character}} (\bold{required}): name of the \code{RLum} class to create} \item{originator}{[\code{set_RLum}] \code{\link{character}} (automatic): contains the name of the calling function (the function that produces this object); can be set manually.} \item{.uid}{[\code{set_RLum}] \code{\link{character}} (automatic): sets an unique ID for this object using the internal C++ function \code{.create_UID}.} \item{.pid}{[\code{set_RLum}] \code{\link{character}} (with default): option to provide a parent id for nesting at will.} \item{recordType}{[\code{set_RLum}] \code{\link{character}} (optional): record type (e.g., "OSL")} \item{curveType}{[\code{set_RLum}] \code{\link{character}} (optional): curve type (e.g., "predefined" or "measured")} \item{data}{[\code{set_RLum}] \code{\link{matrix}} (\bold{required}): raw curve data. If \code{data} itself is a \code{RLum.Data.Curve}-object this can be used to re-construct the object (s. Details)} \item{info}{[\code{set_RLum}] \code{\link{list}} (optional): info elements} \item{info.object}{[\code{get_RLum}] \code{\link{character}} (optional): name of the wanted info element} \item{bin_size}{[\code{bin_RLum}] \code{\link{integer}} (with default): set number of channels used for each bin, e.g. \code{bin_size = 2} means that two channels are binned.} \item{k}{[\code{smooth_RLum}] \code{\link{integer}} (with default): window for the rolling mean; must be odd for rollmedian. If nothing is set k is set automatically} \item{fill}{[\code{smooth_RLum}] \code{\link{numeric}} (with default): a vector defining the left and the right hand data} \item{align}{[\code{smooth_RLum}] \code{\link{character}} (with default): specifying whether the index of the result should be left- or right-aligned or centered (default) compared to the rolling window of observations, allowed \code{"right"}, \code{"center"} and \code{left}} \item{method}{[\code{smooth_RLum}] \code{\link{character}} (with default): defines which method should be applied for the smoothing: \code{"mean"} or \code{"median"}} } \value{ \bold{\code{set_RLum}}\cr Returns an \code{\linkS4class{RLum.Data.Curve}} object. \bold{\code{get_RLum}}\cr (1) A \code{\link{matrix}} with the curve values or \cr (2) only the info object if \code{info.object} was set.\cr \bold{\code{length_RLum}}\cr Number of channels in the curve (row number of the matrix) \bold{\code{names_RLum}}\cr Names of the info elements (slot \code{info}) \bold{\code{bin_RLum.Data}}\cr Same object as input, after applying the binning. \bold{\code{smooth_RLum}}\cr Same object as input, after smoothing } \description{ Class for representing luminescence curve data. } \section{Methods (by generic)}{ \itemize{ \item \code{show}: Show structure of \code{RLum.Data.Curve} object \item \code{set_RLum}: Construction method for RLum.Data.Curve object. The slot info is optional and predefined as empty list by default. \item \code{get_RLum}: Accessor method for RLum.Data.Curve object. The argument info.object is optional to directly access the info elements. If no info element name is provided, the raw curve data (matrix) will be returned. \item \code{length_RLum}: Returns the length of the curve object, which is the maximum of the value time/temperature of the curve (corresponding to the stimulation length) \item \code{names_RLum}: Returns the names info elements coming along with this curve object \item \code{bin_RLum.Data}: Allows binning of specific objects \item \code{smooth_RLum}: Smoothing of RLum.Data.Curve objects using the function \code{\link[zoo]{rollmean}} or \code{\link[zoo]{rollmedian}}. In particular the internal function \code{.smoothing} is used. }} \section{Slots}{ \describe{ \item{\code{recordType}}{Object of class "character" containing the type of the curve (e.g. "TL" or "OSL")} \item{\code{curveType}}{Object of class "character" containing curve type, allowed values are measured or predefined} \item{\code{data}}{Object of class \code{\link{matrix}} containing curve x and y data. 'data' can also be of type \code{RLum.Data.Curve} to change object values without deconstructing the object. For example: \code{set_RLum(class = 'RLum.Data.Curve', data = Your.RLum.Data.Curve, recordType = 'never seen before')} would just change the recordType. Missing arguements the value is taken from the input object in 'data' (which is already an RLum.Data.Curve object in this example)} }} \note{ The class should only contain data for a single curve. For additional elements the slot \code{info} can be used (e.g. providing additional heating ramp curve). Objects from the class \code{RLum.Data.Curve} are produced by other functions (partyl within \code{\linkS4class{RLum.Analysis}} objects), namely: \code{\link{Risoe.BINfileData2RLum.Analysis}}, \code{\link{read_XSYG2R}} } \section{Create objects from this Class}{ Objects can be created by calls of the form \code{set_RLum(class = "RLum.Data.Curve", ...)}. } \section{Class version}{ 0.5.0 } \examples{ showClass("RLum.Data.Curve") ##set empty curve object set_RLum(class = "RLum.Data.Curve") } \seealso{ \code{\linkS4class{RLum}}, \code{\linkS4class{RLum.Data}}, \code{\link{plot_RLum}}, \code{\link{merge_RLum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) } \section{How to cite}{ Kreutzer, S. (2017). RLum.Data.Curve-class(): Class 'RLum.Data.Curve'. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{classes} Luminescence/man/analyse_FadingMeasurement.Rd0000644000176200001440000001507513125227575021061 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/analyse_FadingMeasurement.R \name{analyse_FadingMeasurement} \alias{analyse_FadingMeasurement} \title{Analyse fading measurements and returns the fading rate per decade (g-value)} \usage{ analyse_FadingMeasurement(object, structure = c("Lx", "Tx"), signal.integral, background.integral, t_star = "half", n.MC = 100, verbose = TRUE, plot = TRUE, plot.single = FALSE, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Analysis}} (\bold{required}): input object with the measurement data. Alternatively, a \code{\link{list}} containing \code{\linkS4class{RLum.Analysis}} objects or a \code{\link{data.frame}} with three columns (x = LxTx, y = LxTx error, z = time since irradiation) can be provided. Can also be a wide table, i.e. a \code{\link{data.frame}} with a number of colums divisible by 3 and where each triplet has the before mentioned column structure.} \item{structure}{\code{\link{character}} (with default): sets the structure of the measurement data. Allowed are \code{'Lx'} or \code{c('Lx','Tx')}. Other input is ignored} \item{signal.integral}{\code{\link{vector}} (\bold{required}): vector with the limits for the signal integral. Not required if a \code{data.frame} with LxTx values are provided.} \item{background.integral}{\code{\link{vector}} (\bold{required}): vector with the bounds for the background integral. Not required if a \code{data.frame} with LxTx values are provided.} \item{t_star}{\code{\link{character}} (with default): method for calculating the time elasped since irradiaton. Options are: \code{'half'}, which is \eqn{t_star := t_1 + (t_2 - t_1)/2} (Auclair et al., 2003) and \code{'end'}, which takes the time between irradiation and the measurement step. Default is \code{'half'}} \item{n.MC}{\code{\link{integer}} (with default): number for Monte Carlo runs for the error estimation} \item{verbose}{\code{\link{logical}} (with default): enables/disables verbose mode} \item{plot}{\code{\link{logical}} (with default): enables/disables plot output} \item{plot.single}{\code{\link{logical}} (with default): enables/disables single plot mode, i.e. one plot window per plot. Alternatively a vector specifying the plot to be drawn, e.g., \code{plot.single = c(3,4)} draws only the last two plots} \item{\dots}{(optional) further arguments that can be passed to internally used functions (see details)} } \value{ An \code{\linkS4class{RLum.Results}} object is returned: Slot: \bold{@data}\cr \tabular{lll}{ \bold{OBJECT} \tab \code{TYPE} \tab \code{COMMENT}\cr \code{fading_results} \tab \code{data.frame} \tab results of the fading measurement in a table \cr \code{fit} \tab \code{lm} \tab object returned by the used linear fitting function \code{\link[stats]{lm}}\cr \code{rho_prime} \tab \code{data.frame} \tab results of rho' estimation after Kars et al. 2008 \cr \code{LxTx_table} \tab \code{data.frame} \tab Lx/Tx table, if curve data had been provided \cr \code{irr.times} \tab \code{integer} \tab vector with the irradiation times in seconds \cr } Slot: \bold{@info}\cr \tabular{lll}{ \bold{OBJECT} \tab \code{TYPE} \tab \code{COMMENT}\cr \code{call} \tab \code{call} \tab the original function call\cr } } \description{ The function analysis fading measurements and returns a fading rate including an error estimation. The function is not limited to standard fading measurements, as can be seen, e.g., Huntley and Lamothe 2001. Additionally, the density of recombination centres (rho') is estimated after Kars et al. 2008. } \details{ All provided output corresponds to the \eqn{tc} value obtained by this analysis. Additionally in the output object the g-value normalised to 2-days is provided. The output of this function can be passed to the function \code{\link{calc_FadingCorr}}.\cr \bold{Fitting and error estimation}\cr For the fitting the function \code{\link[stats]{lm}} is used without applying weights. For the error estimation all input values, except tc, as the precision can be consdiered as sufficiently high enough with regard to the underlying problem, are sampled assuming a normal distribution for each value with the value as the mean and the provided uncertainty as standard deviation. \cr \bold{Density of recombination centres} The density of recombination centres, expressed by the dimensionless variable rho', is estimated by fitting equation 5 in Kars et al. 2008 to the data. For the fitting the function \code{\link[stats]{nls}} is used without applying weights. For the error estimation the same procedure as for the g-value is applied (see above). } \note{ \bold{This function has BETA status and should not be used for publication work!} } \section{Function version}{ 0.1.5 (2017-06-29 18:40:14) } \examples{ ## load example data (sample UNIL/NB123, see ?ExampleData.Fading) data("ExampleData.Fading", envir = environment()) ##(1) get fading measurement data (here a three column data.frame) fading_data <- ExampleData.Fading$fading.data$IR50 ##(2) run analysis g_value <- analyse_FadingMeasurement( fading_data, plot = TRUE, verbose = TRUE, n.MC = 10) ##(3) this can be further used in the function ## to correct the age according to Huntley & Lamothe, 2001 results <- calc_FadingCorr( age.faded = c(100,2), g_value = g_value, n.MC = 10) } \section{How to cite}{ Kreutzer, S., Burow, C. (2017). analyse_FadingMeasurement(): Analyse fading measurements and returns the fading rate per decade (g-value). Function version 0.1.5. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Auclair, M., Lamothe, M., Huot, S., 2003. Measurement of anomalous fading for feldpsar IRSL using SAR. Radiation Measurements 37, 487-492. doi:10.1016/S1350-4487(03)00018-0 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. doi:10.1139/cjes-38-7-1093 Kars, R.H., Wallinga, J., Cohen, K.M., 2008. A new approach towards anomalous fading correction for feldspar IRSL dating-tests on samples in field saturation. Radiation Measurements 43, 786-790. doi:10.1016/j.radmeas.2008.01.021 } \seealso{ \code{\link{calc_OSLLxTxRatio}}, \code{\link{read_BIN2R}}, \code{\link{read_XSYG2R}}, \code{\link{extract_IrradiationTimes}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr Christoph Burow, University of Cologne (Germany) \cr R Luminescence Package Team} \keyword{datagen} Luminescence/man/merge_RLum.Analysis.Rd0000644000176200001440000000500113125227576017554 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/merge_RLum.Analysis.R \name{merge_RLum.Analysis} \alias{merge_RLum.Analysis} \title{Merge function for RLum.Analysis S4 class objects} \usage{ merge_RLum.Analysis(objects) } \arguments{ \item{objects}{\code{\link{list}} of \code{\linkS4class{RLum.Analysis}} (\bold{required}): list of S4 objects of class \code{RLum.Analysis}. Furthermore other objects of class \code{\linkS4class{RLum}} can be added, see details.} } \value{ Return an \code{\linkS4class{RLum.Analysis}} object. } \description{ Function allows merging of RLum.Analysis objects and adding of allowed objects to an RLum.Analysis. } \details{ This function simply allowing to merge \code{\linkS4class{RLum.Analysis}} objects. Additionally other \code{\linkS4class{RLum}} objects can be added to an existing \code{\linkS4class{RLum.Analysis}} object. Supported objects to be added are: \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Spectrum}} and \code{\linkS4class{RLum.Data.Image}}.\cr The order in the new \code{\linkS4class{RLum.Analysis}} object is the object order provided with the input list. } \note{ The information for the slot 'protocol' is taken from the first \code{\linkS4class{RLum.Analysis}} object in the input list. Therefore at least one object of type \code{\linkS4class{RLum.Analysis}} has to be provided. } \section{Function version}{ 0.2.0 (2017-06-29 18:40:14) } \examples{ ##merge different RLum objects from the example data data(ExampleData.RLum.Analysis, envir = environment()) data(ExampleData.BINfileData, envir = environment()) object <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos=1) curve <- get_RLum(object)[[2]] temp.merged <- merge_RLum.Analysis(list(curve, IRSAR.RF.Data, IRSAR.RF.Data)) } \section{How to cite}{ Kreutzer, S. (2017). merge_RLum.Analysis(): Merge function for RLum.Analysis S4 class objects. Function version 0.2.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ - } \seealso{ \code{\link{merge_RLum}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Spectrum}}, \code{\linkS4class{RLum.Data.Image}}, \code{\linkS4class{RLum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{utilities} Luminescence/man/replicate_RLum.Rd0000644000176200001440000000230613125227576016650 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/replicate_RLum.R \name{replicate_RLum} \alias{replicate_RLum} \title{General replication function for RLum S4 class objects} \usage{ replicate_RLum(object, times = NULL) } \arguments{ \item{object}{an object of class \code{\linkS4class{RLum}} (\bold{required})} \item{times}{\code{\link{integer}} (optional): number for times each element is repeated element} } \value{ Returns a \code{\link{list}} of the object to be repeated } \description{ Function replicates RLum S4 class objects and returns a list for this objects } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \seealso{ \code{\linkS4class{RLum}}, } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). replicate_RLum(): General replication function for RLum S4 class objects. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{utilities} Luminescence/man/calc_FiniteMixture.Rd0000644000176200001440000002054213125227575017520 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_FiniteMixture.R \name{calc_FiniteMixture} \alias{calc_FiniteMixture} \title{Apply the finite mixture model (FMM) after Galbraith (2005) to a given De distribution} \usage{ calc_FiniteMixture(data, sigmab, n.components, grain.probability = FALSE, dose.scale, pdf.weight = TRUE, pdf.sigma = "sigmab", pdf.colors = "gray", pdf.scale, plot.proportions = TRUE, plot = TRUE, ...) } \arguments{ \item{data}{\code{\linkS4class{RLum.Results}} or \link{data.frame} (\bold{required}): for \code{data.frame}: two columns with De \code{(data[,1])} and De error \code{(values[,2])}} \item{sigmab}{\code{\link{numeric}} (\bold{required}): spread in De values given as a fraction (e.g. 0.2). This value represents the expected overdispersion in the data should the sample be well-bleached (Cunningham & Wallinga 2012, p. 100).} \item{n.components}{\code{\link{numeric}} (\bold{required}): number of components to be fitted. If a vector is provided (e.g. \code{c(2:8)}) the finite mixtures for 2, 3 ... 8 components are calculated and a plot and a statistical evaluation of the model performance (BIC score and maximum log-likelihood) is provided.} \item{grain.probability}{\code{\link{logical}} (with default): prints the estimated probabilities of which component each grain is in} \item{dose.scale}{\code{\link{numeric}}: manually set the scaling of the y-axis of the first plot with a vector in the form of \code{c(min,max)}} \item{pdf.weight}{\code{\link{logical}} (with default): weight the probability density functions by the components proportion (applies only when a vector is provided for \code{n.components})} \item{pdf.sigma}{\code{\link{character}} (with default): if \code{"sigmab"} the components normal distributions are plotted with a common standard deviation (i.e. \code{sigmab}) as assumed by the FFM. Alternatively, \code{"se"} takes the standard error of each component for the sigma parameter of the normal distribution} \item{pdf.colors}{\code{\link{character}} (with default): color coding of the components in the the plot. Possible options are "gray", "colors" and "none"} \item{pdf.scale}{\code{\link{numeric}}: manually set the max density value for proper scaling of the x-axis of the first plot} \item{plot.proportions}{\code{\link{logical}} (with default): plot barplot showing the proportions of components} \item{plot}{\code{\link{logical}} (with default): plot output} \item{\dots}{further arguments to pass. See details for their usage.} } \value{ Returns a plot (optional) and terminal output. In addition an \code{\linkS4class{RLum.Results}} object is returned containing the following elements: \item{summary}{\link{data.frame} summary of all relevant model results.} \item{data}{\link{data.frame} original input data} \item{args}{\link{list} used arguments} \item{call}{\link{call} the function call} \item{mle}{ covariance matrices of the log likelhoods} \item{BIC}{ BIC score} \item{llik}{ maximum log likelihood} \item{grain.probability}{ probabilities of a grain belonging to a component} \item{components}{\link{matrix} estimates of the de, de error and proportion for each component} \item{single.comp}{\link{data.frame} single componente FFM estimate} If a vector for \code{n.components} is provided (e.g. \code{c(2:8)}), \code{mle} and \code{grain.probability} are lists containing matrices of the results for each iteration of the model. The output should be accessed using the function \code{\link{get_RLum}} } \description{ This function fits a k-component mixture to a De distribution with differing known standard errors. Parameters (doses and mixing proportions) are estimated by maximum likelihood assuming that the log dose estimates are from a mixture of normal distributions. } \details{ This model uses the maximum likelihood and Bayesian Information Criterion (BIC) approaches. \cr\cr Indications of overfitting are: \cr\cr - increasing BIC \cr - repeated dose estimates \cr - covariance matrix not positive definite \cr - covariance matrix produces NaNs\cr - convergence problems \cr\cr \bold{Plot} \cr\cr If a vector (\code{c(k.min:k.max)}) is provided for \code{n.components} a plot is generated showing the the k components equivalent doses as normal distributions. By default \code{pdf.weight} is set to \code{FALSE}, so that the area under each normal distribution is always 1. If \code{TRUE}, the probability density functions are weighted by the components proportion for each iteration of k components, so the sum of areas of each component equals 1. While the density values are on the same scale when no weights are used, the y-axis are individually scaled if the probability density are weighted by the components proportion. \cr The standard deviation (sigma) of the normal distributions is by default determined by a common \code{sigmab} (see \code{pdf.sigma}). For \code{pdf.sigma = "se"} the standard error of each component is taken instead.\cr The stacked barplot shows the proportion of each component (in per cent) calculated by the FFM. The last plot shows the achieved BIC scores and maximum log-likelihood estimates for each iteration of k. } \section{Function version}{ 0.4 (2017-06-29 18:40:14) } \examples{ ## load example data data(ExampleData.DeValues, envir = environment()) ## (1) apply the finite mixture model ## NOTE: the data set is not suitable for the finite mixture model, ## which is why a very small sigmab is necessary calc_FiniteMixture(ExampleData.DeValues$CA1, sigmab = 0.2, n.components = 2, grain.probability = TRUE) ## (2) repeat the finite mixture model for 2, 3 and 4 maximum number of fitted ## components and save results ## NOTE: The following example is computationally intensive. Please un-comment ## the following lines to make the example work. FMM<- calc_FiniteMixture(ExampleData.DeValues$CA1, sigmab = 0.2, n.components = c(2:4), pdf.weight = TRUE, dose.scale = c(0, 100)) ## show structure of the results FMM ## show the results on equivalent dose, standard error and proportion of ## fitted components get_RLum(object = FMM, data.object = "components") } \section{How to cite}{ Burow, C. (2017). calc_FiniteMixture(): Apply the finite mixture model (FMM) after Galbraith (2005) to a given De distribution. Function version 0.4. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Galbraith, R.F. & Green, P.F., 1990. Estimating the component ages in a finite mixture. Nuclear Tracks and Radiation Measurements 17, 197-206. \cr\cr Galbraith, R.F. & Laslett, G.M., 1993. Statistical models for mixed fission track ages. Nuclear Tracks Radiation Measurements 4, 459-470.\cr\cr Galbraith, R.F. & Roberts, R.G., 2012. Statistical aspects of equivalent dose and error calculation and display in OSL dating: An overview and some recommendations. Quaternary Geochronology 11, 1-27.\cr\cr Roberts, R.G., Galbraith, R.F., Yoshida, H., Laslett, G.M. & Olley, J.M., 2000. Distinguishing dose populations in sediment mixtures: a test of single-grain optical dating procedures using mixtures of laboratory-dosed quartz. Radiation Measurements 32, 459-465.\cr\cr Galbraith, R.F., 2005. Statistics for Fission Track Analysis, Chapman & Hall/CRC, Boca Raton.\cr\cr \bold{Further reading}\cr\cr 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.\cr\cr Cunningham, A.C. & Wallinga, J., 2012. Realizing the potential of fluvial archives using robust OSL chronologies. Quaternary Geochronology 12, 98-106.\cr\cr 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.\cr\cr Rodnight, H. 2008. How many equivalent dose values are needed to obtain a reproducible distribution?. Ancient TL 26, 3-10. } \seealso{ \code{\link{calc_CentralDose}}, \code{\link{calc_CommonDose}}, \code{\link{calc_FuchsLang2001}}, \code{\link{calc_MinDose}} } \author{ Christoph Burow, University of Cologne (Germany) \cr Based on a rewritten S script of Rex Galbraith, 2006. \cr \cr R Luminescence Package Team} Luminescence/man/merge_RLum.Rd0000644000176200001440000000506413125227576016003 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/merge_RLum.R \name{merge_RLum} \alias{merge_RLum} \title{General merge function for RLum S4 class objects} \usage{ merge_RLum(objects, ...) } \arguments{ \item{objects}{\code{\link{list}} of \code{\linkS4class{RLum}} (\bold{required}): list of S4 object of class \code{RLum}} \item{\dots}{further arguments that one might want to pass to the specific merge function} } \value{ Return is the same as input objects as provided in the list. } \description{ Function calls object-specific merge functions for RLum S4 class objects. } \details{ The function provides a generalised access point for merge specific \code{\linkS4class{RLum}} objects.\cr Depending on the input object, the corresponding merge function will be selected. Allowed arguments can be found in the documentations of each merge function. Empty list elements (\code{NULL}) are automatically removed from the input \code{list}. \tabular{lll}{ \bold{object} \tab \tab \bold{corresponding merge function} \cr \code{\linkS4class{RLum.Data.Curve}} \tab : \tab \code{merge_RLum.Data.Curve} \cr \code{\linkS4class{RLum.Analysis}} \tab : \tab \code{merge_RLum.Analysis} \cr \code{\linkS4class{RLum.Results}} \tab : \tab \code{merge_RLum.Results} } } \note{ So far not for every \code{RLum} object a merging function exists. } \section{Function version}{ 0.1.2 (2017-06-29 18:40:14) } \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) ##apply the central dose model 2nd time temp2 <- calc_CentralDose(ExampleData.DeValues$CA1) ##merge the results and store them in a new object temp.merged <- get_RLum(merge_RLum(objects = list(temp1, temp2))) } \section{How to cite}{ Kreutzer, S. (2017). merge_RLum(): General merge function for RLum S4 class objects. Function version 0.1.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ # } \seealso{ \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Image}}, \code{\linkS4class{RLum.Data.Spectrum}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{utilities} Luminescence/man/CW2pLM.Rd0000644000176200001440000000643613125227576014755 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/CW2pLM.R \name{CW2pLM} \alias{CW2pLM} \title{Transform a CW-OSL curve into a pLM-OSL curve} \usage{ CW2pLM(values) } \arguments{ \item{values}{\code{\linkS4class{RLum.Data.Curve}} or \code{\link{data.frame}} (\bold{required}): \code{RLum.Data.Curve} data object. Alternatively, a \code{data.frame} of the measured curve data of type stimulation time (t) (\code{values[,1]}) and measured counts (cts) (\code{values[,2]}) can be provided.} } \value{ The function returns the same data type as the input data type with the transformed curve values. \item{list(list("data.frame"))}{generic R data structure} \item{list(list("RLum.Data.Curve"))}{package \code{\linkS4class{RLum} object}} } \description{ Transforms a conventionally measured continuous-wave (CW) curve into a pseudo linearly modulated (pLM) curve using the equations given in Bulur (2000). } \details{ According to Bulur (2000) the curve data are transformed by introducing two new parameters P (stimulation period) and u (transformed time): \deqn{P=2*max(t)} \deqn{u=\sqrt{(2*t*P)}} The new count values are then calculated by \deqn{ctsNEW = cts(u/P)} and the returned \code{data.frame} is produced by: \code{data.frame(u,ctsNEW)} } \note{ The transformation is recommended for curves recorded with a channel resolution of at least 0.05 s/channel. } \section{Function version}{ 0.4.1 (2017-06-29 18:40:14) } \examples{ ##read curve from CWOSL.SAR.Data transform curve and plot values data(ExampleData.BINfileData, envir = environment()) ##read id for the 1st OSL curve id.OSL <- CWOSL.SAR.Data@METADATA[CWOSL.SAR.Data@METADATA[,"LTYPE"] == "OSL","ID"] ##produce x and y (time and count data for the data set) x<-seq(CWOSL.SAR.Data@METADATA[id.OSL[1],"HIGH"]/CWOSL.SAR.Data@METADATA[id.OSL[1],"NPOINTS"], CWOSL.SAR.Data@METADATA[id.OSL[1],"HIGH"], by = CWOSL.SAR.Data@METADATA[id.OSL[1],"HIGH"]/CWOSL.SAR.Data@METADATA[id.OSL[1],"NPOINTS"]) y <- unlist(CWOSL.SAR.Data@DATA[id.OSL[1]]) values <- data.frame(x,y) ##transform values values.transformed <- CW2pLM(values) ##plot plot(values.transformed) } \section{How to cite}{ Kreutzer, S. (2017). CW2pLM(): Transform a CW-OSL curve into a pLM-OSL curve. Function version 0.4.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Bulur, E., 2000. A simple transformation for converting CW-OSL curves to LM-OSL curves. Radiation Measurements, 32, 141-145. \bold{Further Reading}\cr\cr Bulur, E., 1996. An Alternative Technique For Optically Stimulated Luminescence (OSL) Experiment. Radiation Measurements, 26, 701-709. } \seealso{ \code{\link{CW2pHMi}}, \code{\link{CW2pLMi}}, \code{\link{CW2pPMi}}, \code{\link{fit_LMCurve}}, \code{\link{lm}}, \code{\linkS4class{RLum.Data.Curve}} The output of the function can be further used for LM-OSL fitting: \code{\link{CW2pLMi}}, \code{\link{CW2pHMi}}, \code{\link{CW2pPMi}}, \code{\link{fit_LMCurve}}, \code{\linkS4class{RLum.Data.Curve}}, \code{\link{plot_RLum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{manip} Luminescence/man/analyse_IRSAR.RF.Rd0000644000176200001440000005011513125227575016643 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/analyse_IRSAR.RF.R \name{analyse_IRSAR.RF} \alias{analyse_IRSAR.RF} \title{Analyse IRSAR RF measurements} \usage{ analyse_IRSAR.RF(object, sequence_structure = c("NATURAL", "REGENERATED"), RF_nat.lim = NULL, RF_reg.lim = NULL, method = "FIT", method.control = NULL, test_parameters = NULL, n.MC = 10, txtProgressBar = TRUE, plot = TRUE, plot_reduced = FALSE, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Analysis}} or a \code{\link{list}} of \code{RLum.Analysis} objects (\bold{required}): input object containing data for protocol analysis. The function expects to find at least two curves in the \code{\linkS4class{RLum.Analysis}} object: (1) RF_nat, (2) RF_reg. If a \code{list} is provided as input all other parameters can be provided as \code{list} as well to gain full control.} \item{sequence_structure}{\code{\link{vector}} \link{character} (with default): specifies the general sequence structure. Allowed steps are \code{NATURAL}, \code{REGENERATED}. In addition any other character is allowed in the sequence structure; such curves will be ignored during the analysis.} \item{RF_nat.lim}{\code{\link{vector}} (with default): set minimum and maximum channel range for natural signal fitting and sliding. If only one value is provided this will be treated as minimum value and the maximum limit will be added automatically.} \item{RF_reg.lim}{\code{\link{vector}} (with default): set minimum and maximum channel range for regenerated signal fitting and sliding. If only one value is provided this will be treated as minimum value and the maximum limit will be added automatically.} \item{method}{\code{\link{character}} (with default): setting method applied for the data analysis. Possible options are \code{"FIT"} or \code{"SLIDE"}.} \item{method.control}{\code{\link{list}} (optional): parameters to control the method, that can be passed to the chosen method. These are for (1) \code{method = "FIT"}: 'trace', 'maxiter', 'warnOnly', 'minFactor' and for (2) \code{method = "SLIDE"}: 'correct_onset', 'show_density', 'show_fit', 'trace'. See details.} \item{test_parameters}{\code{\link{list} (with default)}: set test parameters. Supported parameters are: \code{curves_ratio}, \code{residuals_slope} (only for \code{method = "SLIDE"}), \code{curves_bounds}, \code{dynamic_ratio}, \code{lambda}, \code{beta} and \code{delta.phi}. All input: \code{\link{numeric}} values, \code{NA} and \code{NULL} (s. Details) (see Details for further information)} \item{n.MC}{\code{\link{numeric}} (with default): set number of Monte Carlo runs for start parameter estimation (\code{method = "FIT"}) or error estimation (\code{method = "SLIDE"}). This value can be set to \code{NULL} to skip the MC runs. Note: Large values will significantly increase the computation time} \item{txtProgressBar}{\code{\link{logical}} (with default): enables \code{TRUE} or disables \code{FALSE} the progression bar during MC runs} \item{plot}{\code{\link{logical}} (with default): plot output (\code{TRUE} or \code{FALSE})} \item{plot_reduced}{\code{\link{logical}} (optional): provides a reduced plot output if enabled to allow common R plot combinations, e.g., \code{par(mfrow(...))}. If \code{TRUE} no residual plot is returned; it has no effect if \code{plot = FALSE}} \item{\dots}{further arguments that will be passed to the plot output. Currently supported arguments are \code{main}, \code{xlab}, \code{ylab}, \code{xlim}, \code{ylim}, \code{log}, \code{legend} (\code{TRUE/FALSE}), \code{legend.pos}, \code{legend.text} (passes argument to x,y in \code{\link[graphics]{legend}}), \code{xaxt}} } \value{ The function returns numerical output and an (optional) plot. -----------------------------------\cr [ NUMERICAL OUTPUT ]\cr -----------------------------------\cr \bold{\code{RLum.Reuslts}}-object\cr \bold{slot:} \bold{\code{@data}} \cr [.. $data : \code{data.frame}]\cr \tabular{lll}{ \bold{Column} \tab \bold{Type} \tab \bold{Description}\cr DE \tab \code{numeric} \tab the obtained equivalent dose\cr DE.ERROR \tab \code{numeric} \tab (only \code{method = "SLIDE"}) standard deviation obtained from MC runs \cr DE.LOWER \tab \code{numeric}\tab 2.5\% quantile for De values obtained by MC runs \cr DE.UPPER \tab \code{numeric}\tab 97.5\% quantile for De values obtained by MC runs \cr DE.STATUS \tab \code{character}\tab test parameter status\cr RF_NAT.LIM \tab \code{charcter}\tab used RF_nat curve limits \cr RF_REG.LIM \tab \code{character}\tab used RF_reg curve limits\cr POSITION \tab \code{integer}\tab (optional) position of the curves\cr DATE \tab \code{character}\tab (optional) measurement date\cr SEQUENCE_NAME \tab \code{character}\tab (optional) sequence name\cr UID \tab \code{character}\tab unique data set ID } [.. $De.MC : \code{numeric}]\cr A \code{numeric} vector with all the De values obtained by the MC runs.\cr [.. $test_parameters : \code{data.frame}]\cr \tabular{lll}{ \bold{Column} \tab \bold{Type} \tab \bold{Description}\cr POSITION \tab \code{numeric} \tab aliquot position \cr PARAMETER \tab \code{character} \tab test parameter name \cr THRESHOLD \tab \code{numeric} \tab set test parameter threshold value \cr VALUE \tab \code{numeric} \tab the calculated test parameter value (to be compared with the threshold)\cr STATUS \tab \code{character} \tab test parameter status either \code{"OK"} or \code{"FAILED"} \cr SEQUENCE_NAME \tab \code{character} \tab name of the sequence, so far available \cr UID \tab \code{character}\tab unique data set ID } [.. $fit : \code{data.frame}]\cr An \code{\link{nls}} object produced by the fitting.\cr [.. $slide : \code{list}]\cr A \code{\link{list}} with data produced during the sliding. Some elements are previously reported with the summary object data. List elements are: \tabular{lll}{ \bold{Element} \tab \bold{Type} \tab \bold{Description}\cr De \tab \code{numeric} \tab the final De obtained with the sliding approach \cr De.MC \tab \code{numeric} \tab all De values obtained by the MC runs \cr residuals \tab \code{numeric} \tab the obtained residuals for each channel of the curve \cr trend.fit \tab \code{lm} \tab fitting results produced by the fitting of the residuals \cr RF_nat.slided \tab \code{matrix} \tab the slided RF_nat curve \cr t_n.id \tab \code{numeric} \tab the index of the t_n offset \cr I_n \tab \code{numeric} \tab the vertical intensity offset if a vertical slide was applied \cr algorithm_error \tab \code{numeric} \tab the vertical sliding suffers from a systematic effect induced by the used algorithm. The returned value is the standard deviation of all obtained De values while expanding the vertical sliding range. I can be added as systematic error to the final De error; so far wanted.\cr vslide_range \tab \code{numeric} \tab the range used for the vertical sliding \cr squared_residuals \tab \code{numeric} \tab the squared residuals (horizontal sliding) } \bold{slot:} \bold{\code{@info}} \cr The original function call (\code{\link[methods]{language-class}}-object) The output (\code{data}) should be accessed using the function \code{\link{get_RLum}} ------------------------\cr [ PLOT OUTPUT ]\cr ------------------------\cr The slided IR-RF curves with the finally obtained De } \description{ Function to analyse IRSAR RF measurements on K-feldspar samples, performed using the protocol according to Erfurt et al. (2003) and beyond. } \details{ The function performs an IRSAR analysis described for K-feldspar samples by Erfurt et al. (2003) assuming a negligible sensitivity change of the RF signal.\cr \bold{General Sequence Structure} (according to Erfurt et al. (2003)) \enumerate{ \item Measuring IR-RF intensity of the natural dose for a few seconds (\eqn{RF_{nat}}) \item Bleach the samples under solar conditions for at least 30 min without changing the geometry \item Waiting for at least one hour \item Regeneration of the IR-RF signal to at least the natural level (measuring (\eqn{RF_{reg}}) \item Fitting data with a stretched exponential function \item Calculate the the palaeodose \eqn{D_{e}} using the parameters from the fitting} Actually two methods are supported to obtain the \eqn{D_{e}}: \code{method = "FIT"} and \code{method = "SLIDE"}: \bold{\code{method = "FIT"}}\cr The principle is described above and follows the original suggestions by Erfurt et al., 2003. For the fitting the mean count value of the RF_nat curve is used. Function used for the fitting (according to Erfurt et al. (2003)): \cr \deqn{\phi(D) = \phi_{0}-\Delta\phi(1-exp(-\lambda*D))^\beta} with \eqn{\phi(D)} the dose dependent IR-RF flux, \eqn{\phi_{0}} the initial IR-RF flux, \eqn{\Delta\phi} the dose dependent change of the IR-RF flux, \eqn{\lambda} the exponential parameter, \eqn{D} the dose and \eqn{\beta} the dispersive factor.\cr\cr To obtain the palaeodose \eqn{D_{e}} the function is changed to:\cr \deqn{D_{e} = ln(-(\phi(D) - \phi_{0})/(-\lambda*\phi)^{1/\beta}+1)/-\lambda}\cr The fitting is done using the \code{port} algorithm of the \code{\link{nls}} function.\cr \bold{\code{method = "SLIDE"}}\cr For this method the natural curve is slided along the x-axis until congruence with the regenerated curve is reached. Instead of fitting this allows to work with the original data without the need of any physical model. This approach was introduced for RF curves by Buylaert et al., 2012 and Lapp et al., 2012. Here the sliding is done by searching for the minimum of the squared residuals. For the mathematical details of the implementation see Frouin et al., 2017 \cr \bold{\code{method.control}}\cr To keep the generic argument list as clear as possible, arguments to control the methods for De estimation are all preset with meaningful default parameters and can be handled using the argument \code{method.control} only, e.g., \code{method.control = list(trace = TRUE)}. Supported arguments are:\cr \tabular{lll}{ ARGUMENT \tab METHOD \tab DESCRIPTION\cr \code{trace} \tab \code{FIT}, \code{SLIDE} \tab as in \code{\link{nls}}; shows sum of squared residuals\cr \code{trace_vslide} \tab \code{SLIDE} \tab \code{\link{logical}} argument to enable or disable the tracing of the vertical sliding\cr \code{maxiter} \tab \code{FIT} \tab as in \code{\link{nls}}\cr \code{warnOnly} \tab \code{FIT} \tab as in \code{\link{nls}}\cr \code{minFactor} \tab \code{FIT} \tab as in \code{\link{nls}}\cr \code{correct_onset} \tab \code{SLIDE} \tab The logical argument shifts the curves along the x-axis by the first channel, as light is expected in the first channel. The default value is \code{TRUE}.\cr \code{show_density} \tab \code{SLIDE} \tab \code{\link{logical}} (with default) enables or disables KDE plots for MC run results. If the distribution is too narrow nothing is shown.\cr \code{show_fit} \tab \code{SLIDE} \tab \code{\link{logical}} (with default) enables or disables the plot of the fitted curve routinely obtained during the evaluation.\cr \code{n.MC} \tab \code{SLIDE} \tab \code{\link{integer}} (with default): This controls the number of MC runs within the sliding (assessing the possible minimum values). The default \code{n.MC = 1000}. Note: This parameter is not the same as controlled by the function argument \code{n.MC}. \cr \code{vslide_range} \tab \code{SLDE} \tab \code{\link{logical}} or \code{\link{numeric}} or \code{\link{character}} (with default): This argument sets the boundaries for a vertical curve sliding. The argument expects a vector with an absolute minimum and a maximum (e.g., \code{c(-1000,1000)}). Alternatively the values \code{NULL} and \code{'auto'} are allowed. The automatic mode detects the reasonable vertical sliding range (\bold{recommended}). \code{NULL} applies no vertical sliding. The default is \code{NULL}.\cr \code{cores} \tab \code{SLIDE} \tab \code{number} or \code{character} (with default): set number of cores to be allocated for a parallel processing of the Monte-Carlo runs. The default value is \code{NULL} (single thread), the recommended values is \code{'auto'}. An optional number (e.g., \code{cores} = 8) assigns a value manually. } \bold{Error estimation}\cr For \bold{\code{method = "FIT"}} the asymmetric error range is obtained by using the 2.5 \% (lower) and the 97.5 \% (upper) quantiles of the \eqn{RF_{nat}} curve for calculating the \eqn{D_{e}} error range.\cr For \bold{\code{method = "SLIDE"}} the error is obtained by bootstrapping the residuals of the slided curve to construct new natural curves for a Monte Carlo simulation. The error is returned in two ways: (a) the standard deviation of the herewith obtained \eqn{D_{e}} from the MC runs and (b) the confidence interval using the 2.5 \% (lower) and the 97.5 \% (upper) quantiles. The results of the MC runs are returned with the function output. \cr \bold{Test parameters}\cr The argument \code{test_parameters} allows to pass some thresholds for several test parameters, which will be evaluated during the function run. If a threshold is set and it will be exceeded the test parameter status will be set to "FAILED". Intentionally this parameter is not termed 'rejection criteria' as not all test parameters are evaluated for both methods and some parameters are calculated by not evaluated by default. Common for all parameters are the allowed argument options \code{NA} and \code{NULL}. If the parameter is set to \code{NA} the value is calculated but the result will not be evaluated, means it has no effect on the status ("OK" or "FAILED") of the parameter. Setting the parameter to \code{NULL} disables the parameter entirely and the parameter will be also removed from the function output. This might be useful in cases where a particular parameter asks for long computation times. Currently supported parameters are: \code{curves_ratio} \code{\link{numeric}} (default: \code{1.001}):\cr The ratio of \eqn{RF_{nat}} over \eqn{RF_{reg}} in the range of\eqn{RF_{nat}} of is calculated and should not exceed the threshold value. \cr \code{intersection_ratio} \code{\link{numeric}} (default: \code{NA}):\cr Calculated as absolute difference from 1 of the ratio of the integral of the normalised RF-curves, This value indicates intersection of the RF-curves and should be close to 0 if the curves have a similar shape. For this calculation first the corresponding time-count pair value on the RF_reg curve is obtained using the maximum count value of the RF_nat curve and only this segment (fitting to the RF_nat curve) on the RF_reg curve is taken for further calculating this ratio. If nothing is found at all, \code{Inf} is returned. \cr \code{residuals_slope} \code{\link{numeric}} (default: \code{NA}; only for \code{method = "SLIDE"}): \cr A linear function is fitted on the residuals after sliding. The corresponding slope can be used to discard values as a high (positive, negative) slope may indicate that both curves are fundamentally different and the method cannot be applied at all. Per default the value of this parameter is calculated but not evaluated. \cr \code{curves_bounds} \code{\link{numeric}} (default: \eqn{max(RF_{reg_counts})}:\cr This measure uses the maximum time (x) value of the regenerated curve. The maximum time (x) value of the natural curve cannot be larger than this value. However, although this is not recommended the value can be changed or disabled.\cr \code{dynamic_ratio} \code{\link{numeric}} (default: \code{NA}):\cr The dynamic ratio of the regenerated curve is calculated as ratio of the minimum and maximum count values. \code{lambda}, \code{beta} and \code{delta.phi} \code{\link{numeric}} (default: \code{NA}; \code{method = "SLIDE"}): \cr The stretched exponential function suggested by Erfurt et al. (2003) describing the decay of the RF signal, comprises several parameters that might be useful to evaluate the shape of the curves. For \code{method = "FIT"} this parameter is obtained during the fitting, for \code{method = "SLIDE"} a rather rough estimation is made using the function \code{\link[minpack.lm]{nlsLM}} and the equation given above. Note: As this procedure requests more computation time, setting of one of these three parameters to \code{NULL} also prevents a calculation of the remaining two. } \note{ This function assumes that there is no sensitivity change during the measurements (natural vs. regenerated signal), which is in contrast to the findings by Buylaert et al. (2012). Furthermore: In course of ongoing research this function has been almost fully re-written, but further thoughtful tests are still pending! However, as a lot new package functionality was introduced with the changes made for this function and to allow a part of such tests the re-newed code was made part of the current package.\cr } \section{Function version}{ 0.7.2 (2017-06-29 18:40:14) } \examples{ ##load data data(ExampleData.RLum.Analysis, envir = environment()) ##(1) perform analysis using the method 'FIT' results <- analyse_IRSAR.RF(object = IRSAR.RF.Data) ##show De results and test paramter results get_RLum(results, data.object = "data") get_RLum(results, data.object = "test_parameters") ##(2) perform analysis using the method 'SLIDE' results <- analyse_IRSAR.RF(object = IRSAR.RF.Data, method = "SLIDE", n.MC = 1) \dontrun{ ##(3) perform analysis using the method 'SLIDE' and method control option ## 'trace results <- analyse_IRSAR.RF( object = IRSAR.RF.Data, method = "SLIDE", method.control = list(trace = TRUE)) } } \section{How to cite}{ Kreutzer, S. (2017). analyse_IRSAR.RF(): Analyse IRSAR RF measurements. Function version 0.7.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Buylaert, J.P., Jain, M., Murray, A.S., Thomsen, K.J., Lapp, T., 2012. IR-RF dating of sand-sized K-feldspar extracts: A test of accuracy. Radiation Measurements 44 (5-6), 560-565. doi: 10.1016/j.radmeas.2012.06.021 Erfurt, G., Krbetschek, M.R., 2003. IRSAR - A single-aliquot regenerative-dose dating protocol applied to the infrared radiofluorescence (IR-RF) of coarse- grain K-feldspar. Ancient TL 21, 35-42. Erfurt, G., 2003. Infrared luminescence of Pb+ centres in potassium-rich feldspars. physica status solidi (a) 200, 429-438. Erfurt, G., Krbetschek, M.R., 2003. Studies on the physics of the infrared radioluminescence of potassium feldspar and on the methodology of its application to sediment dating. Radiation Measurements 37, 505-510. Erfurt, G., Krbetschek, M.R., Bortolot, V.J., Preusser, F., 2003. A fully automated multi-spectral radioluminescence reading system for geochronometry and dosimetry. Nuclear Instruments and Methods in Physics Research Section B: Beam Interactions with Materials and Atoms 207, 487-499. Frouin, M., Huot, S., Kreutzer, S., Lahaye, C., Lamothe, M., Philippe, A., Mercier, N., 2017. An improved radiofluorescence single-aliquot regenerative dose protocol for K-feldspars. Quaternary Geochronology 38, 13-24. doi:10.1016/j.quageo.2016.11.004 Lapp, T., Jain, M., Thomsen, K.J., Murray, A.S., Buylaert, J.P., 2012. New luminescence measurement facilities in retrospective dosimetry. Radiation Measurements 47, 803-808. doi:10.1016/j.radmeas.2012.02.006 Trautmann, T., 2000. A study of radioluminescence kinetics of natural feldspar dosimeters: experiments and simulations. Journal of Physics D: Applied Physics 33, 2304-2310. Trautmann, T., Krbetschek, M.R., Dietrich, A., Stolz, W., 1998. Investigations of feldspar radioluminescence: potential for a new dating technique. Radiation Measurements 29, 421-425. Trautmann, T., Krbetschek, M.R., Dietrich, A., Stolz, W., 1999. Feldspar radioluminescence: a new dating method and its physical background. Journal of Luminescence 85, 45-58. Trautmann, T., Krbetschek, M.R., Stolz, W., 2000. A systematic study of the radioluminescence properties of single feldspar grains. Radiation Measurements 32, 685-690. } \seealso{ \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}}, \code{\link{get_RLum}}, \code{\link{nls}}, \code{\link[minpack.lm]{nlsLM}}, \code{\link[parallel]{mclapply}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{datagen} Luminescence/man/fit_LMCurve.Rd0000644000176200001440000002443013125227576016122 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fit_LMCurve.R \name{fit_LMCurve} \alias{fit_LMCurve} \title{Nonlinear Least Squares Fit for LM-OSL curves} \usage{ fit_LMCurve(values, values.bg, n.components = 3, start_values, input.dataType = "LM", fit.method = "port", sample_code = "", sample_ID = "", LED.power = 36, LED.wavelength = 470, fit.trace = FALSE, fit.advanced = FALSE, fit.calcError = FALSE, bg.subtraction = "polynomial", verbose = TRUE, plot = TRUE, plot.BG = FALSE, ...) } \arguments{ \item{values}{\code{\linkS4class{RLum.Data.Curve}} or \link{data.frame} (\bold{required}): x,y data of measured values (time and counts). See examples.} \item{values.bg}{\code{\linkS4class{RLum.Data.Curve}} or \link{data.frame} (optional): x,y data of measured values (time and counts) for background subtraction.} \item{n.components}{\link{integer} (with default): fixed number of components that are to be recognised during fitting (min = 1, max = 7).} \item{start_values}{\link{data.frame} (optional): start parameters for lm and xm data for the fit. If no start values are given, an automatic start value estimation is attempted (see details).} \item{input.dataType}{\link{character} (with default): alter the plot output depending on the input data: "LM" or "pLM" (pseudo-LM). See: \link{CW2pLM}} \item{fit.method}{\code{\link{character}} (with default): select fit method, allowed values: \code{'port'} and \code{'LM'}. \code{'port'} uses the 'port' routine usint the funtion \code{\link{nls}} \code{'LM'} utilises the function \code{nlsLM} from the package \code{minpack.lm} and with that the Levenberg-Marquardt algorithm.} \item{sample_code}{\link{character} (optional): sample code used for the plot and the optional output table (mtext).} \item{sample_ID}{\link{character} (optional): additional identifier used as column header for the table output.} \item{LED.power}{\link{numeric} (with default): LED power (max.) used for intensity ramping in mW/cm^2. \bold{Note:} This value is used for the calculation of the absolute photoionisation cross section.} \item{LED.wavelength}{\link{numeric} (with default): LED wavelength in nm used for stimulation. \bold{Note:} This value is used for the calculation of the absolute photoionisation cross section.} \item{fit.trace}{\link{logical} (with default): traces the fitting process on the terminal.} \item{fit.advanced}{\link{logical} (with default): enables advanced fitting attempt for automatic start parameter recognition. Works only if no start parameters are provided. \bold{Note:} It may take a while and it is not compatible with \code{fit.method = "LM"}.} \item{fit.calcError}{\link{logical} (with default): calculate 1-sigma error range of components using \link{confint}.} \item{bg.subtraction}{\link{character} (with default): specifies method for background subtraction (\code{polynomial}, \code{linear}, \code{channel}, see Details). \bold{Note:} requires input for \code{values.bg}.} \item{verbose}{\link{logical} (with default): terminal output with fitting results.} \item{plot}{\link{logical} (with default): returns a plot of the fitted curves.} \item{plot.BG}{\link{logical} (with default): returns a plot of the background values with the fit used for the background subtraction.} \item{\dots}{Further arguments that may be passed to the plot output, e.g. \code{xlab}, \code{xlab}, \code{main}, \code{log}.} } \value{ Various types of plots are returned. For details see above.\cr Furthermore an \code{RLum.Results} object is returned with the following structure:\cr data:\cr .. $data : \code{data.frame} with fitting results\cr .. $fit : \code{nls} (nls object)\cr .. $component.contribution.matrix : \code{list} component distribution matrix\cr info:\cr .. $call : \code{call} the original function call\cr Matrix structure for the distribution matrix:\cr Column 1 and 2: time and \code{rev(time)} values\cr Additional columns are used for the components, two for each component, containing I0 and n0. The last columns \code{cont.} provide information on the relative component contribution for each time interval including the row sum for this values. } \description{ The function determines weighted nonlinear least-squares estimates of the component parameters of an LM-OSL curve (Bulur 1996) for a given number of components and returns various component parameters. The fitting procedure uses the function \code{\link{nls}} with the \code{port} algorithm. } \details{ \bold{Fitting function}\cr\cr The function for the fitting has the general form: \deqn{y = (exp(0.5)*Im_1*x/xm_1)*exp(-x^2/(2*xm_1^2)) + ,\ldots, + exp(0.5)*Im_i*x/xm_i)*exp(-x^2/(2*xm_i^2))} where \eqn{1 < i < 8}\cr This function and the equations for the conversion to b (detrapping probability) and n0 (proportional to initially trapped charge) have been taken from Kitis et al. (2008): \deqn{xm_i=\sqrt{max(t)/b_i}} \deqn{Im_i=exp(-0.5)n0/xm_i}\cr \bold{Background subtraction}\cr\cr Three methods for background subtraction are provided for a given background signal (\code{values.bg}).\cr \code{polynomial}: default method. A polynomial function is fitted using \link{glm} and the resulting function is used for background subtraction: \deqn{y = a*x^4 + b*x^3 + c*x^2 + d*x + e}\cr \code{linear}: a linear function is fitted using \link{glm} and the resulting function is used for background subtraction: \deqn{y = a*x + b}\cr \code{channel}: the measured background signal is subtracted channelwise from the measured signal.\cr\cr \bold{Start values}\cr The choice of the initial parameters for the \code{nls}-fitting is a crucial point and the fitting procedure may mainly fail due to ill chosen start parameters. Here, three options are provided:\cr\cr \bold{(a)} If no start values (\code{start_values}) are provided by the user, a cheap guess is made by using the detrapping values found by Jain et al. (2003) for quartz for a maximum of 7 components. Based on these values, the pseudo start parameters xm and Im are recalculated for the given data set. In all cases, the fitting starts with the ultra-fast component and (depending on \code{n.components}) steps through the following values. If no fit could be achieved, an error plot (for \code{plot = TRUE}) with the pseudo curve (based on the pseudo start parameters) is provided. This may give the opportunity to identify appropriate start parameters visually.\cr\cr \bold{(b)} If start values are provided, the function works like a simple \code{\link{nls}} fitting approach.\cr\cr \bold{(c)} If no start parameters are provided and the option \code{fit.advanced = TRUE} is chosen, an advanced start paramter estimation is applied using a stochastical attempt. Therefore, the recalculated start parameters \bold{(a)} are used to construct a normal distribution. The start parameters are then sampled randomly from this distribution. A maximum of 100 attempts will be made. \bold{Note:} This process may be time consuming. \cr\cr \bold{Goodness of fit}\cr\cr The goodness of the fit is given by a pseudoR^2 value (pseudo coefficient of determination). According to Lave (1970), the value is calculated as: \deqn{pseudoR^2 = 1 - RSS/TSS} where \eqn{RSS = Residual~Sum~of~Squares} \cr and \eqn{TSS = Total~Sum~of~Squares}\cr\cr \bold{Error of fitted component parameters}\cr\cr The 1-sigma error for the components is calculated using the function \link{confint}. Due to considerable calculation time, this option is deactived by default. In addition, the error for the components can be estimated by using internal R functions like \link{summary}. See the \link{nls} help page for more information.\cr \emph{For more details on the nonlinear regression in R, see Ritz & Streibig (2008).} } \note{ The pseudo-R^2 may not be the best parameter to describe the goodness of the fit. The trade off between the \code{n.components} and the pseudo-R^2 value currently remains unconsidered. \cr The function \bold{does not} ensure that the fitting procedure has reached a global minimum rather than a local minimum! In any case of doubt, the use of manual start values is highly recommended. } \section{Function version}{ 0.3.2 (2017-06-29 18:40:14) } \examples{ ##(1) fit LM data without background subtraction data(ExampleData.FittingLM, envir = environment()) fit_LMCurve(values = values.curve, n.components = 3, log = "x") ##(2) fit LM data with background subtraction and export as JPEG ## -alter file path for your preferred system ##jpeg(file = "~/Desktop/Fit_Output\\\%03d.jpg", quality = 100, ## height = 3000, width = 3000, res = 300) data(ExampleData.FittingLM, envir = environment()) fit_LMCurve(values = values.curve, values.bg = values.curveBG, n.components = 2, log = "x", plot.BG = TRUE) ##dev.off() ##(3) fit LM data with manual start parameters data(ExampleData.FittingLM, envir = environment()) fit_LMCurve(values = values.curve, values.bg = values.curveBG, n.components = 3, log = "x", start_values = data.frame(Im = c(170,25,400), xm = c(56,200,1500))) } \section{How to cite}{ Kreutzer, S. (2017). fit_LMCurve(): Nonlinear Least Squares Fit for LM-OSL curves. Function version 0.3.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Bulur, E., 1996. An Alternative Technique For Optically Stimulated Luminescence (OSL) Experiment. Radiation Measurements, 26, 5, 701-709. Jain, M., Murray, A.S., Boetter-Jensen, L., 2003. Characterisation of blue-light stimulated luminescence components in different quartz samples: implications for dose measurement. Radiation Measurements, 37 (4-5), 441-449. Kitis, G. & Pagonis, V., 2008. Computerized curve deconvolution analysis for LM-OSL. Radiation Measurements, 43, 737-741. Lave, C.A.T., 1970. The Demand for Urban Mass Transportation. The Review of Economics and Statistics, 52 (3), 320-323. Ritz, C. & Streibig, J.C., 2008. Nonlinear Regression with R. R. Gentleman, K. Hornik, & G. Parmigiani, eds., Springer, p. 150. } \seealso{ \code{\link{fit_CWCurve}}, \code{\link{plot}}, \code{\link{nls}}, \code{\link[minpack.lm]{nlsLM}}, \code{\link{get_RLum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{dplot} \keyword{models} Luminescence/man/get_Quote.Rd0000644000176200001440000000232113125227576015672 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_Quote.R \name{get_Quote} \alias{get_Quote} \title{Function to return essential quotes} \usage{ get_Quote(ID, author, separated = FALSE) } \arguments{ \item{ID}{\code{\link{character}}, qoute ID to be returned.} \item{author}{\code{\link{character}}, all quotes by specified author.} \item{separated}{\code{\link{logical}}, return result in separated form.} } \value{ Returns a character with quote and respective (false) author. } \description{ This function returns one of the collected essential quotes in the growing library. If called without any parameters, a random quote is returned. } \section{Function version}{ 0.1.1 (2017-06-29 18:40:14) } \examples{ ## ask for an arbitrary qoute get_Quote() } \author{ Michael Dietze, GFZ Potsdam (Germany) \cr R Luminescence Package Team} \section{How to cite}{ Dietze, M. (2017). get_Quote(): Function to return essential quotes. Function version 0.1.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } Luminescence/man/calc_MinDose.Rd0000644000176200001440000003526513125227575016272 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_MinDose.R \name{calc_MinDose} \alias{calc_MinDose} \title{Apply the (un-)logged minimum age model (MAM) after Galbraith et al. (1999) to a given De distribution} \usage{ calc_MinDose(data, sigmab, log = TRUE, par = 3, bootstrap = FALSE, init.values, level = 0.95, plot = TRUE, multicore = FALSE, ...) } \arguments{ \item{data}{\code{\linkS4class{RLum.Results}} or \link{data.frame} (\bold{required}): for \code{data.frame}: two columns with De \code{(data[ ,1])} and De error \code{(data[ ,2])}.} \item{sigmab}{\code{\link{numeric}} (\bold{required}): 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). \bold{NOTE}: For the logged model (\code{log = TRUE}) this value must be a fraction, e.g. 0.2 (= 20 \%). If the un-logged model is used (\code{log = FALSE}), sigmab must be provided in the same absolute units of the De values (seconds or Gray). See details.} \item{log}{\code{\link{logical}} (with default): fit the (un-)logged minimum dose model to De data.} \item{par}{\code{\link{numeric}} (with default): apply the 3- or 4-parametric minimum age model (\code{par=3} or \code{par=4}). The MAM-3 is used by default.} \item{bootstrap}{\code{\link{logical}} (with default): apply the recycled bootstrap approach of Cunningham & Wallinga (2012).} \item{init.values}{\code{\link{numeric}} (optional): a named list with starting values for gamma, sigma, p0 and mu (e.g. \code{list(gamma=100 sigma=1.5, p0=0.1, mu=100)}). If no values are provided reasonable values are tried to be estimated from the data.} \item{level}{\code{\link{logical}} (with default): the confidence level required (defaults to 0.95).} \item{plot}{\code{\link{logical}} (with default): plot output (\code{TRUE}/\code{FALSE})} \item{multicore}{\code{\link{logical}} (with default): enable parallel computation of the bootstrap by creating a multicore SNOW cluster. Depending on the number of available logical CPU cores this may drastically reduce the computation time. Note that this option is highly experimental and may not work on all machines. (\code{TRUE}/\code{FALSE})} \item{\dots}{(optional) further arguments for bootstrapping (\code{bs.M, bs.N, bs.h, sigmab.sd}). See details for their usage. Further arguments are \code{verbose} to de-/activate console output (logical), \code{debug} for extended console output (logical) and \code{cores} (integer) to manually specify the number of cores to be used when \code{multicore=TRUE}.} } \value{ Returns a plot (optional) and terminal output. In addition an \code{\linkS4class{RLum.Results}} object is returned containing the following elements: \item{summary}{\link{data.frame} summary of all relevant model results.} \item{data}{\link{data.frame} original input data} \item{args}{\link{list} used arguments} \item{call}{\link{call} the function call} \item{mle}{\link{mle2} object containing the maximum log likelhood functions for all parameters} \item{BIC}{\link{numeric} BIC score} \item{confint}{\link{data.frame} confidence intervals for all parameters} \item{profile}{\link{profile.mle2} the log likelihood profiles} \item{bootstrap}{\link{list} bootstrap results} The output should be accessed using the function \code{\link{get_RLum}} } \description{ Function to fit the (un-)logged three or four parameter minimum dose model (MAM-3/4) to De data. } \details{ \bold{Parameters} \cr\cr This model has four parameters: \cr\cr \tabular{rl}{ \code{gamma}: \tab minimum dose on the log scale \cr \code{mu}: \tab mean of the non-truncated normal distribution \cr \code{sigma}: \tab spread in ages above the minimum \cr \code{p0}: \tab proportion of grains at gamma \cr } If \code{par=3} (default) the 3-parametric minimum age model is applied, where \code{gamma=mu}. For \code{par=4} the 4-parametric model is applied instead.\cr\cr \bold{(Un-)logged model} \cr\cr In the original version of the minimum dose model, the basic data are the natural logarithms of the De estimates and relative standard errors of the De estimates. The value for \code{sigmab} must be provided as a ratio (e.g, 0.2 for 20 \%). This model will be applied if \code{log=TRUE}. \cr\cr If \code{log=FALSE}, the modified un-logged model will be applied instead. This has essentially the same form as the original version. \code{gamma} and \code{sigma} are in Gy and \code{gamma} becomes the minimum true dose in the population. \bold{Note} that the un-logged model requires \code{sigmab} to be in the same absolute unit as the provided De values (seconds or Gray). \cr\cr While the original (logged) version of the mimimum dose model may be appropriate for most samples (i.e. De distributions), the modified (un-logged) version is specially designed for modern-age and young samples containing negative, zero or near-zero De estimates (Arnold et al. 2009, p. 323). \cr\cr \bold{Initial values & boundaries} \cr\cr The log likelihood calculations use the \link{nlminb} function for box-constrained optimisation using PORT routines. Accordingly, initial values for the four parameters can be specified via \code{init.values}. If no values are provided for \code{init.values} reasonable starting values are estimated from the input data. If the final estimates of \emph{gamma}, \emph{mu}, \emph{sigma} and \emph{p0} are totally off target, consider providing custom starting values via \code{init.values}. \cr In contrast to previous versions of this function the boundaries for the individual model parameters are no longer required to be explicitly specified. If you want to override the default boundary values use the arguments \code{gamma.lower}, \code{gamma.upper}, \code{sigma.lower}, \code{sigma.upper}, \code{p0.lower}, \code{p0.upper}, \code{mu.lower} and \code{mu.upper}. \cr\cr \bold{Bootstrap} \cr\cr When \code{bootstrap=TRUE} the function applies the bootstrapping method as described in Wallinga & Cunningham (2012). By default, the minimum age model produces 1000 first level and 3000 second level bootstrap replicates (actually, the number of second level bootstrap replicates is three times the number of first level replicates unless specified otherwise). The uncertainty on sigmab is 0.04 by default. These values can be changed by using the arguments \code{bs.M} (first level replicates), \code{bs.N} (second level replicates) and \code{sigmab.sd} (error on sigmab). With \code{bs.h} the bandwidth of the kernel density estimate can be specified. By default, \code{h} is calculated as \cr \deqn{h = (2*\sigma_{DE})/\sqrt{n}} \cr \bold{Multicore support} \cr\cr This function supports parallel computing and can be activated by \code{multicore=TRUE}. By default, the number of available logical CPU cores is determined automatically, but can be changed with \code{cores}. The multicore support is only available when \code{bootstrap=TRUE} and spawns \code{n} R instances for each core to get MAM estimates for each of the N and M boostrap replicates. Note that this option is highly experimental and may or may not work for your machine. Also the performance gain increases for larger number of bootstrap replicates. Also note that with each additional core and hence R instance and depending on the number of bootstrap replicates the memory usage can significantly increase. Make sure that memory is always availabe, otherwise there will be a massive perfomance hit. \cr\cr \bold{Likelihood profiles} The likelihood profiles are generated and plotted by the \code{bbmle} package. The profile likelihood plots look different to ordinary profile likelihood as \cr\cr "[...] the plot method for likelihood profiles displays the square root of the the deviance difference (twice the difference in negative log-likelihood from the best fit), so it will be V-shaped for cases where the quadratic approximation works well [...]." (Bolker 2016). \cr\cr For more details on the profile likelihood calculations and plots please see the vignettes of the \code{bbmle} package (also available here: \url{https://CRAN.R-project.org/package=bbmle}). } \note{ The default starting values for \emph{gamma}, \emph{mu}, \emph{sigma} and \emph{p0} may only be appropriate for some De data sets and may need to be changed for other data. This is especially true when the un-logged version is applied. \cr Also note that all R warning messages are suppressed when running this function. If the results seem odd consider re-running the model with \code{debug=TRUE} which provides extended console output and forwards all internal warning messages. } \section{Function version}{ 0.4.4 (2017-06-29 18:40:14) } \examples{ ## Load example data data(ExampleData.DeValues, envir = environment()) # (1) Apply the minimum age model with minimum required parameters. # By default, this will apply the un-logged 3-parametric MAM. calc_MinDose(data = ExampleData.DeValues$CA1, sigmab = 0.1) \dontrun{ # (2) Re-run the model, but save results to a variable and turn # plotting of the log-likelihood profiles off. mam <- calc_MinDose(data = ExampleData.DeValues$CA1, sigmab = 0.1, plot = FALSE) # Show structure of the RLum.Results object mam # Show summary table that contains the most relevant results res <- get_RLum(mam, "summary") res # Plot the log likelihood profiles retroactively, because before # we set plot = FALSE plot_RLum(mam) # Plot the dose distribution in an abanico plot and draw a line # at the minimum dose estimate plot_AbanicoPlot(data = ExampleData.DeValues$CA1, main = "3-parameter Minimum Age Model", line = mam,polygon.col = "none", hist = TRUE, rug = TRUE, summary = c("n", "mean", "mean.weighted", "median", "in.ci"), centrality = res$de, line.col = "red", grid.col = "none", line.label = paste0(round(res$de, 1), "\\U00B1", round(res$de_err, 1), " Gy"), bw = 0.1, ylim = c(-25, 18), summary.pos = "topleft", mtext = bquote("Parameters: " ~ sigma[b] == .(get_RLum(mam, "args")$sigmab) ~ ", " ~ gamma == .(round(log(res$de), 1)) ~ ", " ~ sigma == .(round(res$sig, 1)) ~ ", " ~ rho == .(round(res$p0, 2)))) # (3) Run the minimum age model with bootstrap # NOTE: Bootstrapping is computationally intensive # (3.1) run the minimum age model with default values for bootstrapping calc_MinDose(data = ExampleData.DeValues$CA1, sigmab = 0.15, bootstrap = TRUE) # (3.2) Bootstrap control parameters mam <- calc_MinDose(data = ExampleData.DeValues$CA1, sigmab = 0.15, bootstrap = TRUE, bs.M = 300, bs.N = 500, bs.h = 4, sigmab.sd = 0.06, plot = FALSE) # Plot the results plot_RLum(mam) # save bootstrap results in a separate variable bs <- get_RLum(mam, "bootstrap") # show structure of the bootstrap results str(bs, max.level = 2, give.attr = FALSE) # print summary of minimum dose and likelihood pairs summary(bs$pairs$gamma) # Show polynomial fits of the bootstrap pairs bs$poly.fits$poly.three # Plot various statistics of the fit using the generic plot() function par(mfcol=c(2,2)) plot(bs$poly.fits$poly.three, ask = FALSE) # Show the fitted values of the polynomials summary(bs$poly.fits$poly.three$fitted.values) } } \section{How to cite}{ Burow, C. (2017). calc_MinDose(): Apply the (un-)logged minimum age model (MAM) after Galbraith et al. (1999) to a given De distribution. Function version 0.4.4. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Arnold, L.J., Roberts, R.G., Galbraith, R.F. & DeLong, S.B., 2009. A revised burial dose estimation procedure for optical dating of young and modern-age sediments. Quaternary Geochronology 4, 306-325. \cr\cr Galbraith, R.F. & Laslett, G.M., 1993. Statistical models for mixed fission track ages. Nuclear Tracks Radiation Measurements 4, 459-470. \cr\cr 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. \cr\cr Galbraith, R.F., 2005. Statistics for Fission Track Analysis, Chapman & Hall/CRC, Boca Raton. \cr\cr Galbraith, R.F. & Roberts, R.G., 2012. Statistical aspects of equivalent dose and error calculation and display in OSL dating: An overview and some recommendations. Quaternary Geochronology 11, 1-27. \cr\cr Olley, J.M., Roberts, R.G., Yoshida, H., Bowler, J.M., 2006. Single-grain optical dating of grave-infill associated with human burials at Lake Mungo, Australia. Quaternary Science Reviews 25, 2469-2474.\cr\cr \bold{Further reading} \cr\cr 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. \cr\cr Bolker, B., 2016. Maximum likelihood estimation analysis with the bbmle package. In: Bolker, B., R Development Core Team, 2016. bbmle: Tools for General Maximum Likelihood Estimation. R package version 1.0.18. https://CRAN.R-project.org/package=bbmle \cr\cr 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. \cr\cr Cunningham, A.C. & Wallinga, J., 2012. Realizing the potential of fluvial archives using robust OSL chronologies. Quaternary Geochronology 12, 98-106. \cr\cr 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. \cr\cr Rodnight, H., 2008. How many equivalent dose values are needed to obtain a reproducible distribution?. Ancient TL 26, 3-10. \cr\cr } \seealso{ \code{\link{calc_CentralDose}}, \code{\link{calc_CommonDose}}, \code{\link{calc_FiniteMixture}}, \code{\link{calc_FuchsLang2001}}, \code{\link{calc_MaxDose}} } \author{ Christoph Burow, University of Cologne (Germany) \cr Based on a rewritten S script of Rex Galbraith, 2010 \cr The bootstrap approach is based on a rewritten MATLAB script of Alastair Cunningham. \cr Alastair Cunningham is thanked for his help in implementing and cross-checking the code. \cr R Luminescence Package Team} Luminescence/man/analyse_portableOSL.Rd0000644000176200001440000000545013125227575017645 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/analyse_portableOSL.R \name{analyse_portableOSL} \alias{analyse_portableOSL} \title{Analyse portable CW-OSL measurements} \usage{ analyse_portableOSL(object, signal.integral, invert = FALSE, normalise = FALSE, plot = TRUE, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Analysis}} (\bold{required}): \code{RLum.Analysis} object produced by \code{\link{read_PSL2R}}.} \item{signal.integral}{\code{\link{vector}} (\bold{required}): A vector of two values specifying the lower and upper channel used to calculate the OSL/IRSL signal. Can be provided in form of \code{c(1, 5)} or \code{1:5}.} \item{invert}{\code{\link{logical}} (with default): \code{TRUE} to calculate and plot the data in reverse order.} \item{normalise}{\code{\link{logical}} (with default): \code{TRUE} to normalise the OSL/IRSL signals by the mean of all corresponding data curves.} \item{plot}{\code{\link{logical}} (with default): enable/disable plot output} \item{...}{currently not used.} } \value{ Returns an S4 \code{\linkS4class{RLum.Results}} object containing the following elements: } \description{ The function analyses CW-OSL curve data produced by a SUERC portable OSL reader and produces a combined plot of OSL/IRSL signal intensities, OSL/IRSL depletion ratios and the IRSL/OSL ratio. } \details{ This function only works with \code{RLum.Analysis} objects produced by \code{\link{read_PSL2R}}. It further assumes (or rather requires) an equal amount of OSL and IRSL curves that are pairwise combined for calculating the IRSL/OSL ratio. For calculating the depletion ratios the cumulative signal of the last n channels (same number of channels as specified by \code{signal.integral}) is divided by cumulative signal of the first n channels (\code{signal.integral}). } \section{Function version}{ 0.0.3 (2017-06-29 18:40:14) } \examples{ # (1) load example data set data("ExampleData.portableOSL", envir = environment()) # (2) merge and plot all RLum.Analysis objects merged <- merge_RLum(ExampleData.portableOSL) plot_RLum(merged, combine = TRUE) merged # (3) analyse and plot results <- analyse_portableOSL(merged, signal.integral = 1:5, invert = FALSE, normalise = TRUE) get_RLum(results) } \seealso{ \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data.Curve}} } \author{ Christoph Burow, University of Cologne (Germany) \cr R Luminescence Package Team} \section{How to cite}{ Burow, C. (2017). analyse_portableOSL(): Analyse portable CW-OSL measurements. Function version 0.0.3. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{datagen} \keyword{plot} Luminescence/man/convert_BIN2CSV.Rd0000644000176200001440000000376713125227576016563 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convert_BIN2CSV.R \name{convert_BIN2CSV} \alias{convert_BIN2CSV} \title{Export Risoe BIN-file(s) to CSV-files} \usage{ convert_BIN2CSV(file, ...) } \arguments{ \item{file}{\code{\link{character}} (\bold{required}): name of the BIN-file to be converted to CSV-files} \item{\dots}{further arguments that will be passed to the function \code{\link{read_BIN2R}} and \code{\link{write_RLum2CSV}}} } \value{ The function returns either a CSV-file (or many of them) or for the option \code{export == FALSE} a list comprising objects of type \code{link{data.frame}} and \code{\link{matrix}} } \description{ This function is a wrapper function around the functions \code{\link{read_BIN2R}} and \code{\link{write_RLum2CSV}} and it imports a Risoe BIN-file and directly exports its content to CSV-files. If nothing is set for the argument \code{path} (\code{\link{write_RLum2CSV}}) the input folder will become the output folder. } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \examples{ ##transform Risoe.BINfileData values to a list data(ExampleData.BINfileData, envir = environment()) convert_BIN2CSV(subset(CWOSL.SAR.Data, POSITION == 1), export = FALSE) \dontrun{ ##select your BIN-file file <- file.choose() ##convert convert_BIN2CSV(file) } } \seealso{ \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data}}, \code{\linkS4class{RLum.Results}}, \code{\link[utils]{write.table}}, \code{\link{write_RLum2CSV}}, \code{\link{read_BIN2R}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). convert_BIN2CSV(): Export Risoe BIN-file(s) to CSV-files. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{IO} Luminescence/man/app_RLum.Rd0000644000176200001440000000214313125227575015456 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/app_RLum.R \name{app_RLum} \alias{app_RLum} \title{Run Luminescence shiny apps (wrapper)} \usage{ app_RLum(app = NULL, ...) } \arguments{ \item{app}{\code{\link{character}} (required): name of the application to start. See details for a list of available apps.} \item{...}{further arguments to pass to \code{\link[shiny]{runApp}}} } \description{ Wrapper for the function \code{\link[RLumShiny]{app_RLum}} from the package \link[RLumShiny]{RLumShiny-package}. For further details and examples please see the manual of this package. } \section{Function version}{ 0.1.1 (2017-06-29 18:40:14) } \author{ Christoph Burow, University of Cologne (Germany) \cr R Luminescence Package Team} \section{How to cite}{ Burow, C. (2017). app_RLum(): Run Luminescence shiny apps (wrapper). Function version 0.1.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } Luminescence/man/ExampleData.XSYG.Rd0000644000176200001440000000613713125226556016722 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \name{ExampleData.XSYG} \alias{ExampleData.XSYG} \title{Example data for a SAR OSL measurement and a TL spectrum using a lexsyg reader} \format{\code{OSL.SARMeasurement}: SAR OSL measurement data The data contain two elements: (a) \code{$Sequence.Header} is a \link{data.frame} with metadata from the measurement,(b) \code{Sequence.Object} contains an \code{\linkS4class{RLum.Analysis}} object for further analysis.\cr \code{TL.Spectrum}: TL spectrum data \code{\linkS4class{RLum.Data.Spectrum}} object for further analysis. The spectrum was cleaned from cosmic-rays using the function \code{apply_CosmicRayRemoval}. Note that no quantum efficiency calibration was performed.} \source{ \bold{OSL.SARMeasurement} \tabular{ll}{ Lab: \tab Luminescence Laboratory Giessen\cr Lab-Code: \tab no code\cr Location: \tab not specified\cr Material: \tab Coarse grain quartz \cr \tab on steel cups on lexsyg research reader\cr Reference: \tab unpublished } \bold{TL.Spectrum} \tabular{ll}{ Lab: \tab Luminescence Laboratory Giessen\cr Lab-Code: \tab BT753\cr Location: \tab Dolni Vestonice/Czech Republic\cr Material: \tab Fine grain polymineral \cr \tab on steel cups on lexsyg rearch reader\cr Reference: \tab Fuchs et al., 2013 \cr Spectrum: \tab Integration time 19 s, channel time 20 s\cr Heating: \tab 1 K/s, up to 500 deg. C } } \description{ Example data from a SAR OSL measurement and a TL spectrum for package Luminescence imported from a Freiberg Instruments XSYG file using the function \code{\link{read_XSYG2R}}. } \section{Version}{ 0.1 } \examples{ ##show data data(ExampleData.XSYG, envir = environment()) ## ========================================= ##(1) OSL.SARMeasurement OSL.SARMeasurement ##show $Sequence.Object OSL.SARMeasurement$Sequence.Object ##grep OSL curves and plot the first curve OSLcurve <- get_RLum(OSL.SARMeasurement$Sequence.Object, recordType="OSL")[[1]] plot_RLum(OSLcurve) ## ========================================= ##(2) TL.Spectrum TL.Spectrum ##plot simple spectrum (2D) plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="contour", xlim = c(310,750), ylim = c(0,300), bin.rows=10, bin.cols = 1) ##plot 3d spectrum (uncomment for usage) # plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="persp", # xlim = c(310,750), ylim = c(0,300), bin.rows=10, # bin.cols = 1) } \references{ Unpublished data measured to serve as example data for that package. Location origin of sample BT753 is given here: Fuchs, M., Kreutzer, S., Rousseau, D.D., Antoine, P., Hatte, C., Lagroix, F., Moine, O., Gauthier, C., Svoboda, J., Lisa, L., 2013. The loess sequence of Dolni Vestonice, Czech Republic: A new OSL-based chronology of the Last Climatic Cycle. Boreas, 42, 664--677. } \seealso{ \code{\link{read_XSYG2R}}, \code{\linkS4class{RLum.Analysis}},\cr \code{\linkS4class{RLum.Data.Spectrum}}, \code{\link{plot_RLum}},\cr \code{\link{plot_RLum.Analysis}}, \code{\link{plot_RLum.Data.Spectrum}} } \keyword{datasets} Luminescence/man/calc_CentralDose.Rd0000644000176200001440000001160013125227575017122 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_CentralDose.R \name{calc_CentralDose} \alias{calc_CentralDose} \title{Apply the central age model (CAM) after Galbraith et al. (1999) to a given De distribution} \usage{ calc_CentralDose(data, sigmab, log = TRUE, plot = TRUE, ...) } \arguments{ \item{data}{\code{\linkS4class{RLum.Results}} or \link{data.frame} (\bold{required}): for \code{data.frame}: two columns with De \code{(data[,1])} and De error \code{(data[,2])}} \item{sigmab}{\code{\link{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). \bold{NOTE}: For the logged model (\code{log = TRUE}) this value must be a fraction, e.g. 0.2 (= 20 \%). If the un-logged model is used (\code{log = FALSE}), sigmab must be provided in the same absolute units of the De values (seconds or Gray).} \item{log}{\code{\link{logical}} (with default): fit the (un-)logged central age model to De data} \item{plot}{\code{\link{logical}} (with default): plot output} \item{\dots}{further arguments (\code{trace, verbose}).} } \value{ Returns a plot (optional) and terminal output. In addition an \code{\linkS4class{RLum.Results}} object is returned containing the following element: \item{summary}{\link{data.frame} summary of all relevant model results.} \item{data}{\link{data.frame} original input data} \item{args}{\link{list} used arguments} \item{call}{\link{call} the function call} \item{profile}{\link{data.frame} the log likelihood profile for sigma} The output should be accessed using the function \code{\link{get_RLum}} } \description{ This function calculates the central dose and dispersion of the De distribution, their standard errors and the profile log likelihood function for sigma. } \details{ This function uses the equations of Galbraith & Roberts (2012). The parameters \code{delta} and \code{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 \code{sigma} is calculated using eq. 18 and presented as a plot. Numerical values of the maximum likelihood approach are \bold{only} presented in the plot and \bold{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) } \section{Function version}{ 1.3.2 (2017-06-29 18:40:14) } \examples{ ##load example data data(ExampleData.DeValues, envir = environment()) ##apply the central dose model calc_CentralDose(ExampleData.DeValues$CA1) } \section{How to cite}{ Burow, C. (2017). calc_CentralDose(): Apply the central age model (CAM) after Galbraith et al. (1999) to a given De distribution. Function version 1.3.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Galbraith, R.F. & Laslett, G.M., 1993. Statistical models for mixed fission track ages. Nuclear Tracks Radiation Measurements 4, 459-470. \cr \cr 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. \cr \cr Galbraith, R.F. & Roberts, R.G., 2012. Statistical aspects of equivalent dose and error calculation and display in OSL dating: An overview and some recommendations. Quaternary Geochronology 11, 1-27. \cr \cr \bold{Further reading} \cr \cr 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. \cr \cr 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. \cr \cr Cunningham, A.C. & Wallinga, J., 2012. Realizing the potential of fluvial archives using robust OSL chronologies. Quaternary Geochronology 12, 98-106. \cr \cr 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. \cr \cr Rodnight, H., 2008. How many equivalent dose values are needed to obtain a reproducible distribution?. Ancient TL 26, 3-10. } \seealso{ \code{\link{plot}}, \code{\link{calc_CommonDose}}, \code{\link{calc_FiniteMixture}}, \code{\link{calc_FuchsLang2001}}, \code{\link{calc_MinDose}} } \author{ Christoph Burow, University of Cologne (Germany) \cr Based on a rewritten S script of Rex Galbraith, 2010 \cr \cr R Luminescence Package Team} Luminescence/man/convert_XSYG2CSV.Rd0000644000176200001440000000374713125227576016743 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convert_XSYG2CSV.R \name{convert_XSYG2CSV} \alias{convert_XSYG2CSV} \title{Export XSYG-file(s) to CSV-files} \usage{ convert_XSYG2CSV(file, ...) } \arguments{ \item{file}{\code{\link{character}} (\bold{required}): name of the XSYG-file to be converted to CSV-files} \item{\dots}{further arguments that will be passed to the function \code{\link{read_XSYG2R}} and \code{\link{write_RLum2CSV}}} } \value{ The function returns either a CSV-file (or many of them) or for the option \code{export = FALSE} a list comprising objects of type \code{link{data.frame}} and \code{\link{matrix}} } \description{ This function is a wrapper function around the functions \code{\link{read_XSYG2R}} and \code{\link{write_RLum2CSV}} and it imports an XSYG-file and directly exports its content to CSV-files. If nothing is set for the argument \code{path} (\code{\link{write_RLum2CSV}}) the input folder will become the output folder. } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \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) } } \seealso{ \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data}}, \code{\linkS4class{RLum.Results}}, \code{\link[utils]{write.table}}, \code{\link{write_RLum2CSV}}, \code{\link{read_XSYG2R}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). convert_XSYG2CSV(): Export XSYG-file(s) to CSV-files. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{IO} Luminescence/man/merge_Risoe.BINfileData.Rd0000644000176200001440000000702513125227576020245 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/merge_Risoe.BINfileData.R \name{merge_Risoe.BINfileData} \alias{merge_Risoe.BINfileData} \title{Merge Risoe.BINfileData objects or Risoe BIN-files} \usage{ merge_Risoe.BINfileData(input.objects, output.file, keep.position.number = FALSE, position.number.append.gap = 0) } \arguments{ \item{input.objects}{\code{\link{character}} with \code{\linkS4class{Risoe.BINfileData}} objects (\bold{required}): Character vector with path and files names (e.g. \code{input.objects = c("path/file1.bin", "path/file2.bin")} or \code{\linkS4class{Risoe.BINfileData}} objects (e.g. \code{input.objects = c(object1, object2)}). Alternatively a \code{list} is supported.} \item{output.file}{\code{\link{character}} (optional): File output path and name. \cr If no value is given, a \code{\linkS4class{Risoe.BINfileData}} is returned instead of a file.} \item{keep.position.number}{\code{\link{logical}} (with default): Allows keeping the original position numbers of the input objects. Otherwise the position numbers are recalculated.} \item{position.number.append.gap}{\code{\link{integer}} (with default): Set the position number gap between merged BIN-file sets, if the option \code{keep.position.number = FALSE} is used. See details for further information.} } \value{ Returns a \code{file} or a \code{\linkS4class{Risoe.BINfileData}} object. } \description{ Function allows merging Risoe BIN/BINX files or Risoe.BINfileData objects. } \details{ The function allows merging different measurements to one file or one object.\cr The record IDs are recalculated for the new object. Other values are kept for each object. The number of input objects is not limited. \cr \code{position.number.append.gap} option \cr If the option \code{keep.position.number = FALSE} is used, the position numbers of the new data set are recalculated by adding the highest position number of the previous data set to the each position number of the next data set. For example: The highest position number is 48, then this number will be added to all other position numbers of the next data set (e.g. 1 + 48 = 49)\cr However, there might be cases where an additional addend (summand) is needed before the next position starts. Example: \cr Position number set (A): \code{1,3,5,7}\cr Position number set (B): \code{1,3,5,7} \cr With no additional summand the new position numbers would be: \code{1,3,5,7,8,9,10,11}. That might be unwanted. Using the argument \code{position.number.append.gap = 1} it will become: \code{1,3,5,7,9,11,13,15,17}. } \note{ The validity of the output objects is not further checked. } \section{Function version}{ 0.2.7 (2017-06-29 18:40:14) } \examples{ ##merge two objects data(ExampleData.BINfileData, envir = environment()) object1 <- CWOSL.SAR.Data object2 <- CWOSL.SAR.Data object.new <- merge_Risoe.BINfileData(c(object1, object2)) } \section{How to cite}{ Kreutzer, S. (2017). merge_Risoe.BINfileData(): Merge Risoe.BINfileData objects or Risoe BIN-files. Function version 0.2.7. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Duller, G., 2007. Analyst. } \seealso{ \code{\linkS4class{Risoe.BINfileData}}, \code{\link{read_BIN2R}}, \code{\link{write_R2BIN}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{IO} \keyword{manip} Luminescence/man/read_SPE2R.Rd0000644000176200001440000000767413125227576015604 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/read_SPE2R.R \name{read_SPE2R} \alias{read_SPE2R} \title{Import Princeton Intruments (TM) SPE-file into R} \usage{ read_SPE2R(file, output.object = "RLum.Data.Image", frame.range, txtProgressBar = TRUE) } \arguments{ \item{file}{\link{character} (\bold{required}): spe-file name (including path), e.g. \cr [WIN]: \code{read_SPE2R("C:/Desktop/test.spe")}, \cr [MAC/LINUX]: \code{readSPER("/User/test/Desktop/test.spe")}} \item{output.object}{\code{\link{character}} (with default): set \code{RLum} output object. Allowed types are \code{"RLum.Data.Spectrum"}, \code{"RLum.Data.Image"} or \code{"matrix"}} \item{frame.range}{\code{\link{vector}} (optional): limit frame range, e.g. select first 100 frames by \code{frame.range = c(1,100)}} \item{txtProgressBar}{\link{logical} (with default): enables or disables \code{\link{txtProgressBar}}.} } \value{ Depending on the chosen option the functions returns three different type of objects:\cr \code{output.object}. \cr \code{RLum.Data.Spectrum}\cr An object of type \code{\linkS4class{RLum.Data.Spectrum}} is returned. Row sums are used to integrate all counts over one channel. \code{RLum.Data.Image}\cr An object of type \code{\linkS4class{RLum.Data.Image}} is returned. Due to performace reasons the import is aborted for files containing more than 100 frames. This limitation can be overwritten manually by using the argument \code{frame.frange}. \code{matrix}\cr Returns a matrix of the form: Rows = Channels, columns = Frames. For the transformation the function \code{\link{get_RLum}} is used, meaning that the same results can be obtained by using the function \code{\link{get_RLum}} on an \code{RLum.Data.Spectrum} or \code{RLum.Data.Image} object. } \description{ Function imports Princeton Instruments (TM) SPE-files into R environment and provides \code{RLum} objects as output. } \details{ Function provides an import routine for the Princton Instruments SPE format. Import functionality is based on the file format description provided by Princton Instruments and a MatLab script written by Carl Hall (s. references). } \note{ \bold{The function does not test whether the input data are spectra or pictures for spatial resolved analysis!}\cr The function has been successfully tested for SPE format versions 2.x. \emph{Currently not all information provided by the SPE format are supported.} } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \examples{ ## to run examples uncomment lines and run the code ##(1) Import data as RLum.Data.Spectrum object #file <- file.choose() #temp <- read_SPE2R(file) #temp ##(2) Import data as RLum.Data.Image object #file <- file.choose() #temp <- read_SPE2R(file, output.object = "RLum.Data.Image") #temp ##(3) Import data as matrix object #file <- file.choose() #temp <- read_SPE2R(file, output.object = "matrix") #temp ##(4) Export raw data to csv, if temp is a RLum.Data.Spectrum object # write.table(x = get_RLum(temp), # file = "[your path and filename]", # sep = ";", row.names = FALSE) } \section{How to cite}{ Kreutzer, S. (2017). read_SPE2R(): Import Princeton Intruments (TM) SPE-file into R. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Princeton Instruments, 2014. Princeton Instruments SPE 3.0 File Format Specification, Version 1.A (for document URL please use an internet search machine) Hall, C., 2012: readSPE.m. \url{http://www.mathworks.com/matlabcentral/fileexchange/35940-readspe/content/readSPE.m} } \seealso{ \code{\link{readBin}}, \code{\linkS4class{RLum.Data.Spectrum}}, \code{\link[raster]{raster}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{IO} Luminescence/man/ExampleData.portableOSL.Rd0000644000176200001440000000150213125226556020305 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \docType{data} \name{ExampleData.portableOSL} \alias{ExampleData.portableOSL} \title{Example portable OSL curve data for the package Luminescence} \source{ \bold{ExampleData.portableOSL} \tabular{ll}{ Lab: \tab Cologne Luminescence Laboratory\cr Lab-Code: \tab - \cr Location: \tab Nievenheim/Germany\cr Material: \tab Fine grain quartz \cr Reference: \tab unpublished data } } \description{ A \code{list} of \code{\linkS4class{RLum.Analysis}} objects, each containing the same number of \code{\linkS4class{RLum.Data.Curve}} objects representing individual OSL, IRSL and dark count measurements of a sample. } \examples{ data(ExampleData.portableOSL, envir = environment()) plot_RLum(ExampleData.portableOSL) } \keyword{datasets} Luminescence/man/Risoe.BINfileData2RLum.Analysis.Rd0000644000176200001440000000764613125227576021543 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Risoe.BINfileData2RLum.Analysis.R \name{Risoe.BINfileData2RLum.Analysis} \alias{Risoe.BINfileData2RLum.Analysis} \title{Convert Risoe.BINfileData object to an RLum.Analysis object} \usage{ Risoe.BINfileData2RLum.Analysis(object, pos = NULL, grain = NULL, run = NULL, set = NULL, ltype = NULL, dtype = NULL, protocol = "unknown", keep.empty = TRUE, txtProgressBar = FALSE) } \arguments{ \item{object}{\code{\linkS4class{Risoe.BINfileData}} (\bold{required}): \code{Risoe.BINfileData} object} \item{pos}{\code{\link{numeric}} (optional): position number of the \code{Risoe.BINfileData} object for which the curves are stored in the \code{RLum.Analysis} object. If \code{length(position)>1} a list of \code{RLum.Analysis} objects is returned. If nothing is provided every position will be converted. If the position is not valid \code{NA} is returned.} \item{grain}{\code{\link{vector}, \link{numeric}} (optional): grain number from the measurement to limit the converted data set (e.g., \code{grain = c(1:48)}). Please be aware that this option may lead to unwanted effects, as the output is strictly limited to the choosen grain number for all position numbers} \item{run}{\code{\link{vector}, \link{numeric}} (optional): run number from the measurement to limit the converted data set (e.g., \code{run = c(1:48)}).} \item{set}{\code{\link{vector}, \link{numeric}} (optional): set number from the measurement to limit the converted data set (e.g., \code{set = c(1:48)}).} \item{ltype}{\code{\link{vector}, \link{character}} (optional): curve type to limit the converted data. Commonly allowed values are: \code{IRSL}, \code{OSL}, \code{TL}, \code{RIR}, \code{RBR} and \code{USER} (see also \code{\linkS4class{Risoe.BINfileData}})} \item{dtype}{\code{\link{vector}, \link{character}} (optional): data type to limit the converted data. Commonly allowed values are listed in \code{\linkS4class{Risoe.BINfileData}}} \item{protocol}{\code{\link{character}} (optional): sets protocol type for analysis object. Value may be used by subsequent analysis functions.} \item{keep.empty}{\code{\link{logical}} (with default): If \code{TRUE} (default) an \code{RLum.Analysis} object is returned even if it does not contain any records. Set to \code{FALSE} to discard all empty objects.} \item{txtProgressBar}{\link{logical} (with default): enables or disables \code{\link{txtProgressBar}}.} } \value{ Returns an \code{\linkS4class{RLum.Analysis}} object. } \description{ Converts values from one specific position of a Risoe.BINfileData S4-class object to an RLum.Analysis object. } \details{ The \code{\linkS4class{RLum.Analysis}} object requires a set of curves for specific further protocol analyses. However, the \code{\linkS4class{Risoe.BINfileData}} usually contains a set of curves for different aliquots and different protocol types that may be mixed up. Therefore, a conversion is needed. } \note{ The \code{protocol} argument of the \code{\linkS4class{RLum.Analysis}} object is set to 'unknown' if not stated otherwise. } \section{Function version}{ 0.4.2 (2017-06-29 18:40:14) } \examples{ ##load data data(ExampleData.BINfileData, envir = environment()) ##convert values for position 1 Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos = 1) } \section{How to cite}{ Kreutzer, S. (2017). Risoe.BINfileData2RLum.Analysis(): Convert Risoe.BINfileData object to an RLum.Analysis object. Function version 0.4.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ # } \seealso{ \code{\linkS4class{Risoe.BINfileData}}, \code{\linkS4class{RLum.Analysis}}, \code{\link{read_BIN2R}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{manip} Luminescence/man/merge_RLum.Data.Curve.Rd0000644000176200001440000001025313125227576017732 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/merge_RLum.Data.Curve.R \name{merge_RLum.Data.Curve} \alias{merge_RLum.Data.Curve} \title{Merge function for RLum.Data.Curve S4 class objects} \usage{ merge_RLum.Data.Curve(object, merge.method = "mean", method.info) } \arguments{ \item{object}{\code{\link{list}} of \code{\linkS4class{RLum.Data.Curve}} (\bold{required}): list of S4 objects of class \code{RLum.Curve}.} \item{merge.method}{\code{\link{character}} (\bold{required}): method for combining of the objects, e.g. \code{'mean'}, \code{'sum'}, see details for further information and allowed methods. Note: Elements in slot info will be taken from the first curve in the list.} \item{method.info}{\code{\link{numeric}} (optional): allows to specify how info elements of the input objects are combined, e.g. \code{1} means that just the elements from the first object are kept, \code{2} keeps only the info elements from the 2 object etc. If nothing is provided all elements are combined.} } \value{ Returns an \code{\linkS4class{RLum.Data.Curve}} object. } \description{ Function allows merging of RLum.Data.Curve objects in different ways } \details{ This function simply allowing to merge \code{\linkS4class{RLum.Data.Curve}} objects without touching the objects itself. Merging is always applied on the 2nd colum of the data matrix of the object.\cr \bold{Supported merge operations are \code{\linkS4class{RLum.Data.Curve}}}\cr \code{"sum"}\cr All count values will be summed up using the function \code{\link{rowSums}}. \code{"mean"}\cr The mean over the count values is calculated using the function \code{\link{rowMeans}}. \code{"median"}\cr The median over the count values is calculated using the function \code{\link[matrixStats]{rowMedians}}. \code{"sd"}\cr The standard deviation over the count values is calculated using the function \code{\link[matrixStats]{rowSds}}. \code{"var"}\cr The variance over the count values is calculated using the function \code{\link[matrixStats]{rowVars}}. \code{"min"}\cr The min values from the count values is chosen using the function \code{\link[matrixStats]{rowMins}}. \code{"max"}\cr The max values from the count values is chosen using the function \code{\link[matrixStats]{rowMins}}. \code{"append"}\cr 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. \code{"-"}\cr The row sums of the last objects are subtracted from the first object. \code{"*"}\cr The row sums of the last objects are mutliplied with the first object. \code{"/"}\cr Values of the first object are divided by row sums of the last objects. } \note{ The information from the slot 'recordType' is taken from the first \code{\linkS4class{RLum.Data.Curve}} object in the input list. The slot 'curveType' is filled with the name \code{merged}. } \section{S3-generic support}{ This function is fully operational via S3-generics: \code{`+`}, \code{`-`}, \code{`/`}, \code{`*`}, \code{merge} } \section{Function version}{ 0.2.0 (2017-06-29 18:40:14) } \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) } \section{How to cite}{ Kreutzer, S. (2017). merge_RLum.Data.Curve(): Merge function for RLum.Data.Curve S4 class objects. Function version 0.2.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ - } \seealso{ \code{\link{merge_RLum}}, \code{\linkS4class{RLum.Data.Curve}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{utilities} Luminescence/man/CW2pLMi.Rd0000644000176200001440000001253213125227576015120 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/CW2pLMi.R \name{CW2pLMi} \alias{CW2pLMi} \title{Transform a CW-OSL curve into a pLM-OSL curve via interpolation under linear modulation conditions} \usage{ CW2pLMi(values, P) } \arguments{ \item{values}{\code{\linkS4class{RLum.Data.Curve}} or \code{\link{data.frame}} (\bold{required}): \code{\linkS4class{RLum.Data.Curve}} or \code{data.frame} with measured curve data of type stimulation time (t) (\code{values[,1]}) and measured counts (cts) (\code{values[,2]})} \item{P}{\code{\link{vector}} (optional): stimulation time 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.} } \value{ The function returns the same data type as the input data type with the transformed curve values. \item{list(list("RLum.Data.Curve"))}{package \code{\linkS4class{RLum}} object with two additional info elements:} \tabular{rl}{ $CW2pLMi.x.t \tab: transformed time values \cr $CW2pLMi.method \tab: used method for the production of the new data points} } \description{ Transforms a conventionally measured continuous-wave (CW) OSL-curve into a pseudo linearly modulated (pLM) curve under linear modulation conditions using the interpolation procedure described by Bos & Wallinga (2012). } \details{ The complete procedure of the transformation is given in Bos & Wallinga (2012). The input \code{data.frame} consists of two columns: time (t) and count values (CW(t))\cr\cr \bold{Nomenclature}\cr\cr P = stimulation time (s)\cr 1/P = stimulation rate (1/s)\cr\cr \bold{Internal transformation steps}\cr\cr (1) log(CW-OSL) values\cr (2) Calculate t' which is the transformed time: \deqn{t' = 1/2*1/P*t^2} (3) Interpolate CW(t'), i.e. use the log(CW(t)) to obtain the count values for the transformed time (t'). Values beyond \code{min(t)} and \code{max(t)} produce \code{NA} values.\cr\cr (4) Select all values for t' < \code{min(t)}, i.e. values beyond the time resolution of t. Select the first two values of the transformed data set which contain no \code{NA} values and use these values for a linear fit using \code{\link{lm}}.\cr\cr (5) Extrapolate values for t' < \code{min(t)} based on the previously obtained fit parameters.\cr\cr (6) Transform values using \deqn{pLM(t) = t/P*CW(t')} (7) Combine values and truncate all values for t' > \code{max(t)}\cr\cr \emph{The number of values for t' < \code{min(t)} depends on the stimulation period (P) and therefore on the stimulation rate 1/P. To avoid the production of too many artificial data at the raising tail of the determined pLM curves it is recommended to use the automatic estimation routine for \code{P}, i.e. provide no own value for \code{P}.} } \note{ According to Bos & Wallinga (2012) the number of extrapolated points should be limited to avoid artificial intensity data. If \code{P} is provided manually and more than two points are extrapolated, a warning message is returned. } \section{Function version}{ 0.3.1 (2017-06-29 18:40:14) } \examples{ ##(1) ##load CW-OSL curve data data(ExampleData.CW_OSL_Curve, envir = environment()) ##transform values values.transformed <- CW2pLMi(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 <- CW2pLMi(values, P = 1/20) lines(values[1:length(values.t[,1]),1],CW2pLMi(values, P = 1/20)[,2], col = "red", lwd = 1.3) text(0.03,4500,"LM", col = "red", cex = .8) values.t <- CW2pHMi(values, delta = 40) lines(values[1:length(values.t[,1]),1],CW2pHMi(values, delta = 40)[,2], col = "black", lwd = 1.3) text(0.005,3000,"HM", cex =.8) values.t <- CW2pPMi(values, P = 1/10) lines(values[1:length(values.t[,1]),1], CW2pPMi(values, P = 1/10)[,2], col = "blue", lwd = 1.3) text(0.5,6500,"PM", col = "blue", cex = .8) } \section{How to cite}{ Kreutzer, S. (2017). CW2pLMi(): Transform a CW-OSL curve into a pLM-OSL curve via interpolation under linear modulation conditions. Function version 0.3.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Bos, A.J.J. & Wallinga, J., 2012. How to visualize quartz OSL signal components. Radiation Measurements, 47, 752-758.\cr \bold{Further Reading}\cr\cr 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. } \seealso{ \code{\link{CW2pLM}}, \code{\link{CW2pHMi}}, \code{\link{CW2pPMi}}, \code{\link{fit_LMCurve}}, \code{\linkS4class{RLum.Data.Curve}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne\cr\cr Based on comments and suggestions from:\cr Adrie J.J. Bos, Delft University of Technology, The Netherlands\cr \cr R Luminescence Package Team} \keyword{manip} Luminescence/man/merge_RLum.Results.Rd0000644000176200001440000000233013125227576017434 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/merge_RLum.Results.R \name{merge_RLum.Results} \alias{merge_RLum.Results} \title{Merge function for RLum.Results S4-class objects} \usage{ merge_RLum.Results(objects) } \arguments{ \item{objects}{\code{\link{list}} (required): a list of \code{\linkS4class{RLum.Results}} objects} } \description{ Function merges objects of class \code{\linkS4class{RLum.Results}}. The slots in the objects are combined depending on the object type, e.g., for \code{\link{data.frame}} and \code{\link{matrix}} rows are appended. } \note{ The originator is taken from the first element and not reset to \code{merge_RLum} } \section{Function version}{ 0.2.0 (2017-06-29 18:40:14) } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). merge_RLum.Results(): Merge function for RLum.Results S4-class objects. Function version 0.2.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } Luminescence/man/ExampleData.CW_OSL_Curve.Rd0000644000176200001440000000300313125226556020307 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \docType{data} \name{ExampleData.CW_OSL_Curve} \alias{ExampleData.CW_OSL_Curve} \title{Example CW-OSL curve data for the package Luminescence} \format{Data frame with 1000 observations on the following 2 variables: \describe{ \item{list("x")}{a numeric vector, time} \item{list("y")}{a numeric vector, counts} }} \source{ \bold{ExampleData.CW_OSL_Curve} \tabular{ll}{ Lab: \tab Luminescence Laboratory Bayreuth\cr Lab-Code: \tab BT607\cr Location: \tab Saxony/Germany\cr Material: \tab Middle grain quartz measured on aluminum cups on a Risoe TL/OSL DA-15 reader.\cr Reference: \tab unpublished data } \bold{CW_Curve.BosWallinga2012} \tabular{ll}{ Lab: \tab Netherlands Centre for Luminescence Dating (NCL)\cr Lab-Code: \tab NCL-2108077\cr Location: \tab Guadalentin Basin, Spain\cr Material: \tab Coarse grain quartz\cr Reference: \tab Bos & Wallinga (2012) and Baartman et al. (2011) } } \description{ \code{data.frame} containing CW-OSL curve data (time, counts) } \examples{ data(ExampleData.CW_OSL_Curve, envir = environment()) plot(ExampleData.CW_OSL_Curve) } \references{ Baartman, J.E.M., Veldkamp, A., Schoorl, J.M., Wallinga, J., Cammeraat, L.H., 2011. Unravelling Late Pleistocene and Holocene landscape dynamics: The Upper Guadalentin Basin, SE Spain. Geomorphology, 125, 172-185. Bos, A.J.J. & Wallinga, J., 2012. How to visualize quartz OSL signal components. Radiation Measurements, 47, 752-758. } \keyword{datasets} Luminescence/man/get_rightAnswer.Rd0000644000176200001440000000164313125227576017100 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_rightAnswer.R \name{get_rightAnswer} \alias{get_rightAnswer} \title{Function to get the right answer} \usage{ get_rightAnswer(...) } \arguments{ \item{...}{you can pass an infinite number of further arguments} } \value{ Returns the right answer } \description{ This function returns just the right answer } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \examples{ ## you really want to know? get_rightAnswer() } \author{ inspired by R.G. \cr R Luminescence Package Team} \section{How to cite}{ NA, NA, , (2017). get_rightAnswer(): Function to get the right answer. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } Luminescence/man/analyse_pIRIRSequence.Rd0000644000176200001440000001625213125227575020077 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/analyse_pIRIRSequence.R \name{analyse_pIRIRSequence} \alias{analyse_pIRIRSequence} \title{Analyse post-IR IRSL sequences} \usage{ analyse_pIRIRSequence(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.single = FALSE, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Analysis}} (\bold{required}) or \code{\link{list}} of \code{\linkS4class{RLum.Analysis}} objects: input object containing data for analysis. If a \code{\link{list}} is provided the functions tries to iteratre over the list.} \item{signal.integral.min}{\code{\link{integer}} (\bold{required}): lower bound of the signal integral. Provide this value as vector for different integration limits for the different IRSL curves.} \item{signal.integral.max}{\code{\link{integer}} (\bold{required}): upper bound of the signal integral. Provide this value as vector for different integration limits for the different IRSL curves.} \item{background.integral.min}{\code{\link{integer}} (\bold{required}): lower bound of the background integral. Provide this value as vector for different integration limits for the different IRSL curves.} \item{background.integral.max}{\code{\link{integer}} (\bold{required}): upper bound of the background integral. Provide this value as vector for different integration limits for the different IRSL curves.} \item{dose.points}{\code{\link{numeric}} (optional): a numeric vector containing the dose points values. Using this argument overwrites dose point values in the signal curves.} \item{sequence.structure}{\link{vector} \link{character} (with default): specifies the general sequence structure. Allowed values are \code{"TL"} and any \code{"IR"} combination (e.g., \code{"IR50"},\code{"pIRIR225"}). Additionally a parameter \code{"EXCLUDE"} is allowed to exclude curves from the analysis (Note: If a preheat without PMT measurement is used, i.e. preheat as non TL, remove the TL step.)} \item{plot}{\code{\link{logical}} (with default): enables or disables plot output.} \item{plot.single}{\code{\link{logical}} (with default): single plot output (\code{TRUE/FALSE}) to allow for plotting the results in single plot windows. Requires \code{plot = TRUE}.} \item{\dots}{further arguments that will be passed to the function \code{\link{analyse_SAR.CWOSL}} and \code{\link{plot_GrowthCurve}}} } \value{ Plots (optional) and an \code{\linkS4class{RLum.Results}} object is returned containing the following elements: \tabular{lll}{ \bold{DATA.OBJECT} \tab \bold{TYPE} \tab \bold{DESCRIPTION} \cr \code{..$data} : \tab \code{data.frame} \tab Table with De values \cr \code{..$LnLxTnTx.table} : \tab \code{data.frame} \tab with the LnLxTnTx values \cr \code{..$rejection.criteria} : \tab \code{\link{data.frame}} \tab rejection criteria \cr \code{..$Formula} : \tab \code{\link{list}} \tab Function used for fitting of the dose response curve \cr \code{..$call} : \tab \code{\link{call}} \tab the original function call } The output should be accessed using the function \code{\link{get_RLum}}. } \description{ The function performs an analysis of post-IR IRSL sequences including curve fitting on \code{\linkS4class{RLum.Analysis}} objects. } \details{ To allow post-IR IRSL protocol (Thomsen et al., 2008) measurement analyses this function has been written as extended wrapper function for the function \code{\link{analyse_SAR.CWOSL}}, facilitating an entire sequence analysis in one run. With this, its functionality is strictly limited by the functionality of the function \code{\link{analyse_SAR.CWOSL}}.\cr \bold{If the input is a \code{list}}\cr If the input is a list of RLum.Analysis-objects, every argument can be provided as list to allow for different sets of parameters for every single input element. For further information see \code{\link{analyse_SAR.CWOSL}}. } \note{ Best graphical output can be achieved by using the function \code{pdf} with the following options:\cr \code{pdf(file = "...", height = 15, width = 15)} } \section{Function version}{ 0.2.2 (2017-06-29 18:40:14) } \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.single = TRUE) ##(3) Perform pIRIR analysis (for this example with quartz OSL data!) ## Alternative for PDF output, uncomment and complete for usage \dontrun{ pdf(file = "...", height = 15, width = 15) 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() } } \section{How to cite}{ Kreutzer, S. (2017). analyse_pIRIRSequence(): Analyse post-IR IRSL sequences. Function version 0.2.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \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 } \seealso{ \code{\link{analyse_SAR.CWOSL}}, \code{\link{calc_OSLLxTxRatio}}, \code{\link{plot_GrowthCurve}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}} \code{\link{get_RLum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{datagen} \keyword{plot} Luminescence/man/ExampleData.Fading.Rd0000644000176200001440000000650013125226556017312 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \name{ExampleData.Fading} \alias{ExampleData.Fading} \title{Example data for feldspar fading measurements} \format{A \code{\link{list}} with two elements, each containing a further \code{\link{list}} of \code{\link{data.frame}}s containing the data on the fading and equivalent dose measurements: \describe{ \code{$fading.data}: A named \code{\link{list}} of \code{\link{data.frame}}s, each having three named columns (\code{LxTx, LxTx.error, timeSinceIrradiation}).\cr \code{..$IR50}: Fading data of the IR50 signal.\cr \code{..$IR100}: Fading data of the IR100 signal.\cr \code{..$IR150}: Fading data of the IR150 signal.\cr \code{..$IR225}: Fading data of the IR225 signal.\cr \cr\cr \code{$equivalentDose.data}: A named of \code{\link{data.frame}}s, each having three named columns (\code{dose, LxTx, LxTx.error}).\cr \code{..$IR50}: Equivalent dose measurement data of the IR50 signal.\cr \code{..$IR100}: Equivalent dose measurement data of the IR100 signal.\cr \code{..$IR150}: Equivalent dose measurement data of the IR150 signal.\cr \code{..$IR225}: Equivalent dose measurement data of the IR225 signal.\cr \cr\cr }} \source{ These data were kindly provided by Georgina King. Detailed information on the sample UNIL/NB123 can be found in the reference given below. The raw data can be found in the accompanying supplementary information. } \description{ Example data set for fading measurements of the IR50, IR100, IR150 and IR225 feldspar signals of sample UNIL/NB123. It further contains regular equivalent dose measurement data of the same sample, which can be used to apply a fading correction to. } \examples{ ## Load example data data("ExampleData.Fading", envir = environment()) ## Get fading measurement data of the IR50 signal IR50_fading <- ExampleData.Fading$fading.data$IR50 head(IR50_fading) ## Determine g-value and rho' for the IR50 signal IR50_fading.res <- analyse_FadingMeasurement(IR50_fading) ## Show g-value and rho' results gval <- get_RLum(IR50_fading.res) rhop <- get_RLum(IR50_fading.res, "rho_prime") gval rhop ## Get LxTx values of the IR50 DE measurement IR50_De.LxTx <- ExampleData.Fading$equivalentDose.data$IR50 ## Calculate the De of the IR50 signal IR50_De <- plot_GrowthCurve(IR50_De.LxTx, mode = "interpolation", fit.method = "EXP") ## Extract the calculated De and its error IR50_De.res <- get_RLum(IR50_De) De <- c(IR50_De.res$De, IR50_De.res$De.Error) ## Apply fading correction (age conversion greatly simplified) IR50_Age <- De / 7.00 IR50_Age.corr <- calc_FadingCorr(IR50_Age, g_value = IR50_fading.res) } \references{ King, G.E., Herman, F., Lambert, R., Valla, P.G., Guralnik, B., 2016. Multi-OSL-thermochronometry of feldspar. Quaternary Geochronology 33, 76-87. doi:10.1016/j.quageo.2016.01.004 \bold{Details} \cr \tabular{ll}{ Lab: \tab University of Lausanne \cr Lab-Code: \tab UNIL/NB123 \cr Location: \tab Namche Barwa (eastern Himalaya)\cr Material: \tab Coarse grained (180-212 microns) potassium feldspar \cr Units: \tab Values are given in seconds \cr Lab Dose Rate: \tab Dose rate of the beta-source at measurement ca. 0.1335 +/- 0.004 Gy/s \cr Environmental Dose Rate: \tab 7.00 +/- 0.92 Gy/ka (includes internal dose rate) } } \keyword{datasets} Luminescence/man/ExampleData.RLum.Analysis.Rd0000644000176200001440000000246713125226556020573 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \name{ExampleData.RLum.Analysis} \alias{ExampleData.RLum.Analysis} \title{Example data as \code{\linkS4class{RLum.Analysis}} objects} \format{\code{IRSAR.RF.Data}: IRSAR.RF.Data on coarse grain feldspar Each object contains data needed for the given protocol analysis.} \source{ \bold{IRSAR.RF.Data} These data were kindly provided by Tobias Lauer and Matthias Krbetschek. \tabular{ll}{ Lab: \tab Luminescence Laboratory TU Bergakademie Freiberg\cr Lab-Code: \tab ZEU/SA1\cr Location: \tab Zeuchfeld (Zeuchfeld Sandur; Saxony-Anhalt/Germany)\cr Material: \tab K-feldspar (130-200 \eqn{\mu}m)\cr Reference: \tab Kreutzer et al. (2014)\cr } } \description{ Collection of different \code{\linkS4class{RLum.Analysis}} objects for protocol analysis. } \section{Version}{ 0.1 } \examples{ ##load data data(ExampleData.RLum.Analysis, envir = environment()) ##plot data plot_RLum(IRSAR.RF.Data) } \references{ \bold{IRSAR.RF.Data} Kreutzer, S., Lauer, T., Meszner, S., Krbetschek, M.R., Faust, D., Fuchs, M., 2014. Chronology of the Quaternary profile Zeuchfeld in Saxony-Anhalt / Germany - a preliminary luminescence dating study. Zeitschrift fuer Geomorphologie 58, 5-26. doi: 10.1127/0372-8854/2012/S-00112 } \keyword{datasets} Luminescence/man/plot_Histogram.Rd0000644000176200001440000001254413125227576016741 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_Histogram.R \name{plot_Histogram} \alias{plot_Histogram} \title{Plot a histogram with separate error plot} \usage{ plot_Histogram(data, na.rm = TRUE, mtext, cex.global, se, rug, normal_curve, summary, summary.pos, colour, interactive = FALSE, ...) } \arguments{ \item{data}{\code{\link{data.frame}} or \code{\linkS4class{RLum.Results}} object (required): for \code{data.frame}: two columns: De (\code{data[,1]}) and De error (\code{data[,2]})} \item{na.rm}{\code{\link{logical}} (with default): excludes \code{NA} values from the data set prior to any further operations.} \item{mtext}{\code{\link{character}} (optional): further sample information (\link{mtext}).} \item{cex.global}{\code{\link{numeric}} (with default): global scaling factor.} \item{se}{\code{\link{logical}} (optional): plots standard error points over the histogram, default is \code{FALSE}.} \item{rug}{\code{\link{logical}} (optional): adds rugs to the histogram, default is \code{TRUE}.} \item{normal_curve}{\code{\link{logical}} (with default): adds a normal curve to the histogram. Mean and sd are calculated from the input data. More see details section.} \item{summary}{\code{\link{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.} \item{summary.pos}{\code{\link{numeric}} or \code{\link{character}} (with default): optional position coordinates or keyword (e.g. \code{"topright"}) for the statistical summary. Alternatively, the keyword \code{"sub"} may be specified to place the summary below the plot header. However, this latter option in only possible if \code{mtext} is not used. In case of coordinate specification, y-coordinate refers to the right y-axis.} \item{colour}{\code{\link{numeric}} or \link{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\cr (e.g., \code{c("grey", "black", "red", "grey")}).} \item{interactive}{\code{\link{logical}} (with default): create an interactive histogram plot (requires the 'plotly' package)} \item{\dots}{further arguments and graphical parameters passed to \code{\link{plot}} or \code{\link{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. \code{ylab = c("axis label 1", "axis label 2")}). Y-axes limits (\code{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.} } \description{ Function plots a predefined histogram with an accompanying error plot as suggested by Rex Galbraith at the UK LED in Oxford 2010. } \details{ If the normal curve is added, the y-axis in the histogram will show the probability density.\cr\cr 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: \code{"n"} (number of samples), \code{"mean"} (mean De value), \code{"mean.weighted"} (error-weighted mean), \code{"median"} (median of the De values), \code{"sdrel"} (relative standard deviation in percent), \code{"sdrel.weighted"} (error-weighted relative standard deviation in percent), \code{"sdabs"} (absolute standard deviation), \code{"sdabs.weighted"} (error-weighted absolute standard deviation), \code{"serel"} (relative standard error), \code{"serel.weighted"} ( error-weighted relative standard error), \code{"seabs"} (absolute standard error), \code{"seabs.weighted"} (error-weighted absolute standard error), \code{"kurtosis"} (kurtosis) and \code{"skewness"} (skewness). } \note{ The input data is not restricted to a special type. } \section{Function version}{ 0.4.4 (2017-06-29 18:40:14) } \examples{ ## load data data(ExampleData.DeValues, envir = environment()) ExampleData.DeValues <- 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)) } \seealso{ \code{\link{hist}}, \code{\link{plot}} } \author{ Michael Dietze, GFZ Potsdam (Germany), \cr Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Dietze, M., Kreutzer, S. (2017). plot_Histogram(): Plot a histogram with separate error plot. Function version 0.4.4. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } Luminescence/man/plot_RLum.Analysis.Rd0000644000176200001440000001122213125227576017435 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_RLum.Analysis.R \name{plot_RLum.Analysis} \alias{plot_RLum.Analysis} \title{Plot function for an RLum.Analysis S4 class object} \usage{ plot_RLum.Analysis(object, subset = NULL, nrows, ncols, abline = NULL, combine = FALSE, curve.transformation, plot.single = FALSE, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Analysis}} (\bold{required}): S4 object of class \code{RLum.Analysis}} \item{subset}{named \code{\link{list}} (optional): subsets elements for plotting. The arguments in the named \code{\link{list}} will be directly passed to the function \code{\link{get_RLum}} (e.g., \code{subset = list(curveType = "measured")})} \item{nrows}{\code{\link{integer}} (optional): sets number of rows for plot output, if nothing is set the function tries to find a value.} \item{ncols}{\code{\link{integer}} (optional): sets number of columns for plot output, if nothing is set the function tries to find a value.} \item{abline}{\code{\link{list}} (optional): allows to add ablines to the plot. Argument are provided in a list and will be forwared to the function \code{\link{abline}}, e.g., \code{list(v = c(10, 100))} adds two vertical lines add 10 and 100 to all plots. In contrast \code{list(v = c(10), v = c(100)} adds a vertical at 10 to the first and a vertical line at 100 to the 2nd plot.} \item{combine}{\code{\link{logical}} (with default): allows to combine all \code{\linkS4class{RLum.Data.Curve}} objects in one single plot.} \item{curve.transformation}{\code{\link{character}} (optional): allows transforming CW-OSL and CW-IRSL curves to pseudo-LM curves via transformation functions. Allowed values are: \code{CW2pLM}, \code{CW2pLMi}, \code{CW2pHMi} and \code{CW2pPMi}. See details.} \item{plot.single}{\code{\link{logical}} (with default): global par settings are considered, normally this should end in one plot per page} \item{\dots}{further arguments and graphical parameters will be passed to the \code{plot} function. Supported arguments: \code{main}, \code{mtext}, \code{log}, \code{lwd}, \code{lty} \code{type}, \code{pch}, \code{col}, \code{norm}, \code{xlim},\code{ylim}, \code{xlab}, \code{ylab}... and for \code{combine = TRUE} also: \code{sub}, \code{legend}, \code{legend.text}, \code{legend.pos} (typical plus 'outside'), \code{legend.col}, \code{smooth}. All arguments can be provided as \code{vector} or \code{list} to gain in full control of all plot settings.} } \value{ Returns multiple plots. } \description{ The function provides a standardised plot output for curve data of an RLum.Analysis S4 class object } \details{ The function produces a multiple plot output. A file output is recommended (e.g., \code{\link{pdf}}). \bold{curve.transformation}\cr 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 \code{ltype} \code{OSL} and \code{IRSL}.\cr Please note: The curve transformation within this functions works roughly, i.e. every IRSL or OSL curve is transformed, without considerung whether it is measured with the PMT or not! However, for a fast look it might be helpful.\cr } \note{ Not all arguments available for \code{\link{plot}} will be passed! Only plotting of \code{RLum.Data.Curve} and \code{RLum.Data.Spectrum} objects are currently supported.\cr } \section{Function version}{ 0.3.8 (2017-06-29 18:40:14) } \examples{ ##load data data(ExampleData.BINfileData, envir = environment()) ##convert values for position 1 temp <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data, pos=1) ##(1) plot (combine) TL curves in one plot plot_RLum.Analysis( temp, subset = list(recordType = "TL"), combine = TRUE, norm = TRUE, abline = list(v = c(110)) ) ##(2) same as example (1) but using ## the argument smooth = TRUE plot_RLum.Analysis( temp, subset = list(recordType = "TL"), combine = TRUE, norm = TRUE, smooth = TRUE, abline = list(v = c(110)) ) } \section{How to cite}{ Kreutzer, S. (2017). plot_RLum.Analysis(): Plot function for an RLum.Analysis S4 class object. Function version 0.3.8. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ # } \seealso{ \code{\link{plot}}, \code{\link{plot_RLum}}, \code{\link{plot_RLum.Data.Curve}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{aplot} Luminescence/man/get_Risoe.BINfileData.Rd0000644000176200001440000000310513125227576017720 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_Risoe.BINfileData.R \name{get_Risoe.BINfileData} \alias{get_Risoe.BINfileData} \title{General accessor function for RLum S4 class objects} \usage{ get_Risoe.BINfileData(object, ...) } \arguments{ \item{object}{\code{\linkS4class{Risoe.BINfileData}} (\bold{required}): S4 object of class \code{RLum}} \item{\dots}{further arguments that one might want to pass to the specific get function} } \value{ Return is the same as input objects as provided in the list. } \description{ Function calls object-specific get functions for RisoeBINfileData S4 class objects. } \details{ The function provides a generalised access point for specific \code{\linkS4class{Risoe.BINfileData}} objects.\cr Depending on the input object, the corresponding get function will be selected. Allowed arguments can be found in the documentations of the corresponding \code{\linkS4class{Risoe.BINfileData}} class. } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \seealso{ \code{\linkS4class{Risoe.BINfileData}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). get_Risoe.BINfileData(): General accessor function for RLum S4 class objects. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{utilities} Luminescence/man/plot_RLum.Data.Image.Rd0000644000176200001440000000710513125227576017551 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_RLum.Data.Image.R \name{plot_RLum.Data.Image} \alias{plot_RLum.Data.Image} \title{Plot function for an \code{RLum.Data.Image} S4 class object} \usage{ plot_RLum.Data.Image(object, par.local = TRUE, plot.type = "plot.raster", ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Data.Image}} (\bold{required}): S4 object of class \code{RLum.Data.Image}} \item{par.local}{\code{\link{logical}} (with default): use local graphical parameters for plotting, e.g. the plot is shown in one column and one row. If \code{par.local = FALSE} global parameters are inherited.} \item{plot.type}{\code{\link{character}} (with default): plot types. Supported types are \code{plot.raster}, \code{plotRGB} or \code{contour}} \item{\dots}{further arguments and graphical parameters that will be passed to the specific plot functions.} } \value{ Returns a plot. } \description{ The function provides a standardised plot output for image data of an \code{RLum.Data.Image}S4 class object, mainly using the plot functions provided by the \code{\link{raster}} package. } \details{ \bold{Details on the plot functions} \cr Image is visualised as 2D plot usinng generic plot types provided by other packages. Supported plot types: \cr \bold{\code{plot.type = "plot.raster"}}\cr Uses the standard plot function for raster data from the package \code{\link[raster]{raster}}: \code{\link[raster]{plot}}. For each raster layer in a raster brick one plot is produced. Arguments that are passed through the function call:\cr \code{main},\code{axes}, \code{xlab}, \code{ylab}, \code{xlim}, \code{ylim}, \code{col} \bold{\code{plot.type = "plotRGB"}}\cr Uses the function \code{\link[raster]{plotRGB}} from the \code{\link[raster]{raster}} package. Only one image plot is produced as all layers in a brick a combined. This plot type is useful to see whether any signal is recorded by the camera.\cr Arguments that are passed through the function call:\cr \code{main},\code{axes}, \code{xlab}, \code{ylab}, \code{ext}, \code{interpolate}, \code{maxpixels}, \code{alpha}, \code{colNA}, \code{stretch}\cr \bold{\code{plot.type = "contour"}}\cr Uses the function contour plot function from the \code{\link{raster}} function (\code{\link[raster]{contour}}). For each raster layer one contour plot is produced. Arguments that are passed through the function call:\cr \code{main},\code{axes}, \code{xlab}, \code{ylab}, \code{xlim}, \code{ylim}, \code{col} } \note{ This function has been created to faciliate the plotting of image data imported by the function \code{\link{read_SPE2R}}. However, so far the function is not optimized to handle image data > ca. 200 MByte and thus plotting of such data is extremely slow. } \section{Function version}{ 0.1 (2017-06-29 18:40:14) } \examples{ ##load data data(ExampleData.RLum.Data.Image, envir = environment()) ##plot data plot_RLum.Data.Image(ExampleData.RLum.Data.Image) } \section{How to cite}{ Kreutzer, S. (2017). plot_RLum.Data.Image(): Plot function for an RLum.Data.Image S4 class object. Function version 0.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ - } \seealso{ \code{\linkS4class{RLum.Data.Image}}, \code{\link{plot}}, \code{\link{plot_RLum}}, \code{\link[raster]{raster}}, } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{aplot} Luminescence/man/ExampleData.LxTxData.Rd0000644000176200001440000000140513125226556017612 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \name{ExampleData.LxTxData} \alias{ExampleData.LxTxData} \title{Example Lx/Tx data from CW-OSL SAR measurement} \format{A \code{data.frame} with 4 columns (Dose, LxTx, LxTx.Error, TnTx).} \source{ \tabular{ll}{ Lab: \tab Luminescence Laboratory Bayreuth\cr Lab-Code: \tab BT607\cr Location: \tab Ostrau (Saxony-Anhalt/Germany)\cr Material: \tab Middle grain (38-63 \eqn{\mu}m) quartz measured on a Risoe TL/OSL DA-15 reader.\cr } } \description{ LxTx data from a SAR measurement for the package Luminescence. } \examples{ ##plot Lx/Tx data vs dose [s] data(ExampleData.LxTxData, envir = environment()) plot(LxTxData$Dose,LxTxData$LxTx) } \references{ unpublished data } Luminescence/man/get_Layout.Rd0000644000176200001440000000421113125227576016052 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_Layout.R \name{get_Layout} \alias{get_Layout} \title{Collection of layout definitions} \usage{ get_Layout(layout) } \arguments{ \item{layout}{\code{\link{character}} or \code{\link{list}} object (required): name of the layout definition to be returned. If name is provided the respective definition is returned. One of the following supported layout definitions is possible: \code{"default"}, \code{"journal.1"}, \code{"small"}, \code{"empty"}. User-specific layout definitions must be provided as a list object of predefined structure, see details.} } \value{ A list object with layout definitions for plot functions. } \description{ This helper function returns a list with layout definitions for homogeneous plotting. } \details{ The easiest way to create a user-specific layout definition is perhaps to create either an empty or a default layout object and fill/modify the definitions (\code{user.layout <- get_Layout(data = "empty")}). } \section{Function version}{ 0.1 (2017-06-29 18:40:14) } \examples{ ## read example data set data(ExampleData.DeValues, envir = environment()) ## show structure of the default layout definition layout.default <- get_Layout(layout = "default") str(layout.default) ## show colour definitions for Abanico plot, only layout.default$abanico$colour ## set Abanico plot title colour to orange layout.default$abanico$colour$main <- "orange" ## create Abanico plot with modofied layout definition plot_AbanicoPlot(data = ExampleData.DeValues, layout = layout.default) ## create Abanico plot with predefined layout "journal" plot_AbanicoPlot(data = ExampleData.DeValues, layout = "journal") } \author{ Michael Dietze, GFZ Potsdam (Germany) \cr R Luminescence Package Team} \section{How to cite}{ Dietze, M. (2017). get_Layout(): Collection of layout definitions. Function version 0.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } Luminescence/man/plot_FilterCombinations.Rd0000644000176200001440000001412413125227576020573 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_FilterCombinations.R \name{plot_FilterCombinations} \alias{plot_FilterCombinations} \title{Plot filter combinations along with the (optional) net transmission window} \usage{ plot_FilterCombinations(filters, wavelength_range = 200:1000, show_net_transmission = TRUE, interactive = FALSE, plot = TRUE, ...) } \arguments{ \item{filters}{\code{\link{list}} (\bold{required}): a named list of filter data for each filter to be shown. The filter data itself should be either provided as \code{\link{data.frame}} or \code{\link{matrix}}. (for more options s. Details)} \item{wavelength_range}{\code{\link{numeric}} (with default): wavelength range used for the interpolation} \item{show_net_transmission}{\code{\link{logical}} (with default): show net transmission window as polygon.} \item{interactive}{\code{\link{logical}} (with default): enable/disable interactive plot} \item{plot}{\code{\link{logical}} (with default): enables or disables the plot output} \item{\dots}{further arguments that can be passed to control the plot output. Suppored are \code{main}, \code{xlab}, \code{ylab}, \code{xlim}, \code{ylim}, \code{type}, \code{lty}, \code{lwd}. For non common plotting parameters see the details section.} } \value{ Returns an S4 object of type \code{\linkS4class{RLum.Results}}. \bold{@data} \tabular{lll}{ \bold{Object} \tab \bold{Type} \bold{Description} \cr net_transmission_window \tab \code{matrix} \tab the resulting net transmission window \cr OD_total \tab \code{matrix} \tab the total optical density\cr filter_matrix \tab \code{matrix} \tab the filter matrix used for plotting } \bold{@info} \tabular{lll}{ \bold{Object} \tab \bold{Type} \bold{Description} \cr call \tab \code{call} \tab the original function call } } \description{ The function allows to plot transmission windows for different filters. Missing data for specific wavelenghts are automatically interpolated for the given filter data using the function \code{\link{approx}}. With that a standardised output is reached and a net transmission window can be shown.\cr } \details{ \bold{Calculations}\cr \bold{Net transmission window}\cr The net transmission window of two filters is approximated by \deqn{T_{final} = T_{1} * T_{2}} \bold{Optical density}\cr \deqn{OD = -log(T)} \bold{Total optical density}\cr \deqn{OD_{total} = OD_{1} + OD_{2}} Please consider using own calculations for more precise values. \bold{How to provide input data?}\cr CASE 1\cr The function expects that all filter values are either of type \code{matrix} or \code{data.frame} with two columns. The first columens contains the wavelength, the second the relative transmission (but not in percentage, i.e. the maximum transmission can be only become 1). In this case only the transmission window is show as provided. Changes in filter thickness and relection factor are not considered. \cr CASE 2\cr The filter data itself are provided as list element containing a \code{matrix} or \code{data.frame} and additional information on the thickness of the filter, e.g., \code{list(filter1 = list(filter_matrix, d = 2))}. The given filter data are always considered as standard input and the filter thickness value is taken into account by \deqn{Transmission = Transmission^(d)} with d given in the same dimension as the original filter data.\cr CASE 3\cr Same as CASE 2 but additionally a reflection factor P is provided, e.g., \code{list(filter1 = list(filter_matrix, d = 2, P = 0.9))}. The final transmission becomes: \deqn{Transmission = Transmission^(d) * P}\cr \bold{Advanced plotting parameters}\cr The following further non-common plotting parameters can be passed to the function:\cr \tabular{lll}{ \bold{Argument} \tab \bold{Datatype} \tab \bold{Description}\cr \code{legend} \tab \code{logical} \tab enable/disable legend \cr \code{legend.pos} \tab \code{character} \tab change legend position (\code{\link[graphics]{legend}}) \cr \code{legend.text} \tab \code{character} \tab same as the argument \code{legend} in (\code{\link[graphics]{legend}}) \cr \code{net_transmission.col} \tab \code{col} \tab colour of net transmission window polygon \cr \code{net_transmission.col_lines} \tab \code{col} \tab colour of net transmission window polygon lines \cr \code{ net_transmission.density} \tab \code{numeric} \tab specify line density in the transmission polygon \cr \code{grid} \tab \code{list} \tab full list of arguments that can be passd to the function \code{\link[graphics]{grid}} } For further modifications standard additional R plot functions are recommend, e.g., the legend can be fully customised by disabling the standard legend and use the function \code{\link[graphics]{legend}} instead. } \section{Function version}{ 0.3.0 (2017-06-29 18:40:14) } \examples{ ## (For legal reasons no real filter data are provided) ## Create filter sets filter1 <- density(rnorm(100, mean = 450, sd = 20)) filter1 <- matrix(c(filter1$x, filter1$y/max(filter1$y)), ncol = 2) filter2 <- matrix(c(200:799,rep(c(0,0.8,0),each = 200)), ncol = 2) ## Example 1 (standard) plot_FilterCombinations(filters = list(filter1, filter2)) ## Example 2 (with d and P value and name for filter 2) results <- plot_FilterCombinations( filters = list(filter_1 = filter1, Rectangle = list(filter2, d = 2, P = 0.6))) results ## Example 3 show optical density plot(results$OD_total) \dontrun{ ##Example 4 ##show the filters using the interative mode plot_FilterCombinations(filters = list(filter1, filter2), interative = TRUE) } } \seealso{ \code{\linkS4class{RLum.Results}}, \code{\link{approx}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montagine (France)\cr \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). plot_FilterCombinations(): Plot filter combinations along with the (optional) net transmission window. Function version 0.3.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{aplot} \keyword{datagen} Luminescence/man/read_PSL2R.Rd0000644000176200001440000000563413125227576015605 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/read_PSL2R.R \name{read_PSL2R} \alias{read_PSL2R} \title{Import PSL files to R} \usage{ read_PSL2R(file, drop_bg = FALSE, as_decay_curve = TRUE, smooth = FALSE, merge = FALSE, ...) } \arguments{ \item{file}{\code{\link{character}} (\bold{required}): path and file name of the PSL file. If input is a \code{vector} it should comprise only \code{character}s representing valid paths and PSL file names. Alternatively the input character can be just a directory (path). In this case the the function tries to detect and import all PSL files found in the directory.} \item{drop_bg}{\code{\link{logical}} (with default): \code{TRUE} to automatically remove all non-OSL/IRSL curves.} \item{as_decay_curve}{\code{\link{logical}} (with default): Portable OSL Reader curves are often given as cumulative light sum curves. Use \code{TRUE} (default) to convert the curves to the more usual decay form.} \item{smooth}{\code{\link{logical}} (with default): \code{TRUE} to apply Tukey's Running Median Smoothing for OSL and IRSL decay curves. Smoothing is encouraged if you see random signal drops within the decay curves related to hardware errors.} \item{merge}{\code{\link{logical}} (with default): \code{TRUE} to merge all \code{RLum.Analysis} objects. Only applicable if multiple files are imported.} \item{...}{currently not used.} } \value{ Returns an S4 \code{\linkS4class{RLum.Analysis}} object containing \code{\linkS4class{RLum.Data.Curve}} objects for each curve. } \description{ Imports PSL files produced by a SUERC portable OSL reader into R \bold{(BETA)}. } \details{ This function provides an import routine for the SUERC portable OSL Reader PSL format. PSL files are just plain text and can be viewed with any text editor. Due to the formatting of PSL files this import function relies heavily on regular expression to find and extract all relevant information. See \bold{note}. } \note{ Because this function relies heavily on regular expressions to parse PSL files it is currently only in beta status. If the routine fails to import a specific PSL file please report to so the function can be updated. } \section{Function version}{ 0.0.1 (2017-06-29 18:40:14) } \examples{ # (1) Import PSL file to R \dontrun{ FILE <- file.choose() temp <- read_PSL2R(FILE) temp } } \seealso{ \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Curve}} } \author{ Christoph Burow, University of Cologne (Germany) \cr R Luminescence Package Team} \section{How to cite}{ Burow, C. (2017). read_PSL2R(): Import PSL files to R. Function version 0.0.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{IO} Luminescence/man/plot_Risoe.BINfileData.Rd0000644000176200001440000001051613125227576020123 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_Risoe.BINfileData.R \name{plot_Risoe.BINfileData} \alias{plot_Risoe.BINfileData} \title{Plot single luminescence curves from a BIN file object} \usage{ plot_Risoe.BINfileData(BINfileData, position, run, set, sorter = "POSITION", ltype = c("IRSL", "OSL", "TL", "RIR", "RBR", "RL"), curve.transformation, dose_rate, temp.lab, cex.global = 1, ...) } \arguments{ \item{BINfileData}{\link{Risoe.BINfileData-class} (\bold{required}): requires an S4 object returned by the \link{read_BIN2R} function.} \item{position}{\link{vector} (optional): option to limit the plotted curves by position (e.g. \code{position = 1}, \code{position = c(1,3,5)}).} \item{run}{\link{vector} (optional): option to limit the plotted curves by run (e.g., \code{run = 1}, \code{run = c(1,3,5)}).} \item{set}{\link{vector} (optional): option to limit the plotted curves by set (e.g., \code{set = 1}, \code{set = c(1,3,5)}).} \item{sorter}{\link{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.} \item{ltype}{\link{character} (with default): option to limit the plotted curves by the type of luminescence stimulation. Allowed values: \code{"IRSL"}, \code{"OSL"},\code{"TL"}, \code{"RIR"}, \code{"RBR"} (corresponds to LM-OSL), \code{"RL"}. All type of curves are plotted by default.} \item{curve.transformation}{\link{character} (optional): allows transforming CW-OSL and CW-IRSL curves to pseudo-LM curves via transformation functions. Allowed values are: \code{CW2pLM}, \code{CW2pLMi}, \code{CW2pHMi} and \code{CW2pPMi}. See details.} \item{dose_rate}{\link{numeric} (optional): dose rate of the irradition source at the measurement date. If set, the given irradiation dose will be shown in Gy. See details.} \item{temp.lab}{\link{character} (optional): option to allow for different temperature units. If no value is set deg. C is chosen.} \item{cex.global}{\link{numeric} (with default): global scaling factor.} \item{\dots}{further undocumented plot arguments.} } \value{ Returns a plot. } \description{ Plots single luminescence curves from an object returned by the \link{read_BIN2R} function. } \details{ \bold{Nomenclature}\cr See \code{\link{Risoe.BINfileData-class}} \bold{curve.transformation}\cr 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 \code{ltype} \code{OSL} and \code{IRSL}.\cr \bold{Irradiation time}\cr Plotting the irradiation time (s) or the given dose (Gy) requires that the variable \code{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. } \note{ The function has been successfully tested for the Sequence Editor file output version 3 and 4. } \section{Function version}{ 0.4.1 (2017-06-29 18:40:14) } \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() } \section{How to cite}{ Kreutzer, S., Dietze, M. (2017). plot_Risoe.BINfileData(): Plot single luminescence curves from a BIN file object. Function version 0.4.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Duller, G., 2007. Analyst. pp. 1-45. } \seealso{ \code{\link{Risoe.BINfileData-class}},\code{\link{read_BIN2R}}, \code{\link{CW2pLM}}, \code{\link{CW2pLMi}}, \code{\link{CW2pPMi}}, \code{\link{CW2pHMi}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France),\cr Michael Dietze, GFZ Potsdam (Germany) \cr R Luminescence Package Team} \keyword{dplot} Luminescence/man/ExampleData.BINfileData.Rd0000644000176200001440000000372113125226556020166 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \name{ExampleData.BINfileData} \alias{ExampleData.BINfileData} \title{Example data from a SAR OSL and SAR TL measurement for the package Luminescence} \format{\code{CWOSL.SAR.Data}: SAR OSL measurement data \code{TL.SAR.Data}: SAR TL measurement data Each class object contains two slots: (a) \code{METADATA} is a \link{data.frame} with all metadata stored in the BIN file of the measurements and (b) \code{DATA} contains a list of vectors of the measured data (usually count values).} \source{ \bold{CWOSL.SAR.Data} \tabular{ll}{ Lab: \tab Luminescence Laboratory Bayreuth\cr Lab-Code: \tab BT607\cr Location: \tab Saxony/Germany\cr Material: \tab Middle grain quartz measured \cr \tab on aluminum cups on a Risoe TL/OSL DA-15 reader\cr Reference: \tab unpublished } \bold{TL.SAR.Data} \tabular{ll}{ Lab: \tab Luminescence Laboratory of Cologne\cr Lab-Code: \tab LP1_5\cr Location: \tab Spain\cr Material: \tab Flint \cr Setup: \tab Risoe TL/OSL DA-20 reader \cr \tab (Filter: Semrock Brightline, \cr \tab HC475/50, N2, unpolished steel discs) \cr Reference: \tab unpublished \cr Remarks: \tab dataset limited to one position\cr } } \description{ Example data from a SAR OSL and TL measurement for package Luminescence directly extracted from a Risoe BIN-file and provided in an object of type \link{Risoe.BINfileData-class} } \note{ Please note that this example data cannot be exported to a BIN-file using the function \code{writeR2BIN} as it was generated and implemented in the package long time ago. In the meantime the BIN-file format changed. } \section{Version}{ 0.1 } \examples{ ##show first 5 elements of the METADATA and DATA elements in the terminal data(ExampleData.BINfileData, envir = environment()) CWOSL.SAR.Data@METADATA[1:5,] CWOSL.SAR.Data@DATA[1:5] } \references{ \bold{CWOSL.SAR.Data}: unpublished data \cr \bold{TL.SAR.Data}: unpublished data } \keyword{datasets} Luminescence/man/ExampleData.RLum.Data.Image.Rd0000644000176200001440000000206313125226556020672 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \name{ExampleData.RLum.Data.Image} \alias{ExampleData.RLum.Data.Image} \title{Example data as \code{\linkS4class{RLum.Data.Image}} objects} \format{Object of class \code{\linkS4class{RLum.Data.Image}}} \source{ \bold{ExampleData.RLum.Data.Image} These data were kindly provided by Regina DeWitt. \tabular{ll}{ Lab.: \tab Department of Physics, East-Carolina University, NC, USA\cr Lab-Code: \tab -\cr Location: \tab - \cr Material: \tab - \cr Reference: \tab - \cr } Image data is a measurement of fluorescent ceiling lights with a cooled Princeton Instruments (TM) camera fitted on Risoe DA-20 TL/OSL reader. } \description{ Measurement of Princton Instruments camera imported with the function \code{\link{read_SPE2R}} to R to produce an \code{\linkS4class{RLum.Data.Image}} object. } \section{Version}{ 0.1 } \examples{ ##load data data(ExampleData.RLum.Data.Image, envir = environment()) ##plot data plot_RLum(ExampleData.RLum.Data.Image) } \keyword{datasets} Luminescence/man/read_XSYG2R.Rd0000644000176200001440000001535113125227576015736 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/read_XSYG2R.R \name{read_XSYG2R} \alias{read_XSYG2R} \title{Import XSYG files to R} \usage{ read_XSYG2R(file, recalculate.TL.curves = TRUE, fastForward = FALSE, import = TRUE, pattern = ".xsyg", txtProgressBar = TRUE) } \arguments{ \item{file}{\code{\link{character}} or \code{\link{list}} (\bold{required}): path and file name of the XSYG file. If input is a \code{list} it should comprise only \code{character}s representing each valid path and xsyg-file names. Alternatively the input character can be just a directory (path), in this case the the function tries to detect and import all xsyg files found in the directory.} \item{recalculate.TL.curves}{\link{logical} (with default): if set to \code{TRUE}, TL curves are returned as temperature against count values (see details for more information) Note: The option overwrites the time vs. count TL curve. Select \code{FALSE} to import the raw data delivered by the lexsyg. Works for TL curves and spectra.} \item{fastForward}{\code{\link{logical}} (with default): if \code{TRUE} for a more efficient data processing only a list of \code{RLum.Analysis} objects is returned.} \item{import}{\code{\link{logical}} (with default): if set to \code{FALSE}, only the XSYG file structure is shown.} \item{pattern}{\code{\link{regex}} (with default): optional regular expression if \code{file} is a link to a folder, to select just specific XSYG-files} \item{txtProgressBar}{\link{logical} (with default): enables \code{TRUE} or disables \code{FALSE} the progression bar during import} } \value{ \bold{Using the option \code{import = FALSE}}\cr\cr A list consisting of two elements is shown: \item{Sample}{\link{data.frame} with information on file.} \item{Sequences}{\link{data.frame} with information on the sequences stored in the XSYG file}.\cr\cr \bold{Using the option \code{import = TRUE} (default)} \cr\cr A list is provided, the list elements contain: \item{Sequence.Header}{\link{data.frame} with information on the sequence.} \item{Sequence.Object}{\code{\linkS4class{RLum.Analysis}} containing the curves.} } \description{ Imports XSYG files produced by a Freiberg Instrument lexsyg reader into R. } \details{ \bold{How does the import function work?}\cr\cr The function uses the \code{\link{xml}} package to parse the file structure. Each sequence is subsequently translated into an \code{\linkS4class{RLum.Analysis}} object.\cr\cr \bold{General structure XSYG format}\cr\cr \code{}\cr \code{ }\cr \code{ }\cr \code{ }\cr \code{ }\cr \code{ x0 , y0 ; x1 , y1 ; x2 , y2 ; x3 , y3}\cr \code{ }\cr \code{ }\cr \code{ }\cr \code{ }\cr\cr So far, each XSYG file can only contain one \code{}, but multiple sequences. \cr\cr Each record may comprise several curves.\cr\cr \bold{TL curve recalculation}\cr On the FI lexsyg device TL curves are recorded as time against count values. Temperature values are monitored on the heating plate and stored in a separate curve (time vs. temperature). If the option \code{recalculate.TL.curves = TRUE} is chosen, the time values for each TL curve are replaced by temperature values.\cr Practically, this means combining two matrices (Time vs. Counts and Time vs. Temperature) with different row numbers by their time values. Three cases are considered: HE: Heating element\cr PMT: Photomultiplier tube\cr Interpolation is done using the function \code{\link{approx}}\cr CASE (1): \code{nrow(matrix(PMT))} > \code{nrow(matrix(HE))} \cr Missing temperature values from the heating element are calculated using time values from the PMT measurement.\cr CASE (2): \code{nrow(matrix(PMT))} < \code{nrow(matrix(HE))} \cr Missing count values from the PMT are calculated using time values from the heating element measurement.\cr CASE (3): \code{nrow(matrix(PMT))} == \code{nrow(matrix(HE))} \cr A new matrix is produced using temperature values from the heating element and count values from the PMT. \cr \emph{Note: Please note that due to the recalculation of the temperature values based on values delivered by the heating element, it may happen that mutiple count values exists for each temperature value and temperature values may also decrease during heating, not only increase. }\cr \bold{Advanced file import}\cr To allow for a more efficient usage of the function, instead of single path to a file just a directory can be passed as input. In this particular case the function tries to extract all XSYG-files found in the directory and import them all. Using this option internally the function constructs as list of the XSYG-files found in the directory. Please note no recursive detection is supported as this may lead to endless loops. } \note{ This function is a beta version as the XSYG file format is not yet fully specified. Thus, further file operations (merge, export, write) should be done using the functions provided with the package \code{\link{xml}}.\cr \bold{So far, no image data import is provided!}\cr Corresponding values in the XSXG file are skipped. } \section{Function version}{ 0.5.8 (2017-06-29 18:40:14) } \examples{ ##(1) import XSYG file to R (uncomment for usage) #FILE <- file.choose() #temp <- read_XSYG2R(FILE) ##(2) additional examples for pure XML import using the package XML ## (uncomment for usage) ##import entire XML file #FILE <- file.choose() #temp <- XML::xmlRoot(XML::xmlTreeParse(FILE)) ##search for specific subnodes with curves containing 'OSL' #getNodeSet(temp, "//Sample/Sequence/Record[@recordType = 'OSL']/Curve") ##(2) How to extract single curves ... after import data(ExampleData.XSYG, envir = environment()) ##grep one OSL curves and plot the first curve OSLcurve <- get_RLum(OSL.SARMeasurement$Sequence.Object, recordType="OSL")[[1]] ##(3) How to see the structure of an object? structure_RLum(OSL.SARMeasurement$Sequence.Object) } \section{How to cite}{ Kreutzer, S. (2017). read_XSYG2R(): Import XSYG files to R. Function version 0.5.8. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Grehl, S., Kreutzer, S., Hoehne, M., 2013. Documentation of the XSYG file format. Unpublished Technical Note. Freiberg, Germany \cr\cr \bold{Further reading} \cr\cr XML: \url{http://en.wikipedia.org/wiki/XML} } \seealso{ \code{\link{xml}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data.Curve}}, \code{\link{approx}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{IO} Luminescence/man/apply_CosmicRayRemoval.Rd0000644000176200001440000001077513125227575020375 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/apply_CosmicRayRemoval.R \name{apply_CosmicRayRemoval} \alias{apply_CosmicRayRemoval} \title{Function to remove cosmic rays from an RLum.Data.Spectrum S4 class object} \usage{ apply_CosmicRayRemoval(object, method = "smooth", method.Pych.smoothing = 2, method.Pych.threshold_factor = 3, MARGIN = 2, verbose = FALSE, plot = FALSE, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Data.Spectrum}} (\bold{required}): S4 object of class \code{RLum.Data.Spectrum}} \item{method}{\code{\link{character}} (with default): Defines method that is applied for cosmic ray removal. Allowed methods are \code{smooth}, the default, (\code{\link{smooth}}), \code{smooth.spline} (\code{\link{smooth.spline}}) and \code{Pych}. See details for further information.} \item{method.Pych.smoothing}{\code{\link{integer}} (with default): Smoothing parameter for cosmic ray removal according to Pych (2003). The value defines how many neighboring values in each frame are used for smoothing (e.g., \code{2} means that the two previous and two following values are used).} \item{method.Pych.threshold_factor}{\code{\link{numeric}} (with default): Threshold for zero-bins in the histogram. Small values mean that more peaks are removed, but signal might be also affected by this removal.} \item{MARGIN}{\code{\link{integer}} (with default): on which part the function cosmic ray removal should be applied on: 1 = along the time axis (line by line), 2 = along the wavelength axis (column by column). Note: This argument currently only affects the methods \code{smooth} and \code{smooth.spline}} \item{verbose}{\code{\link{logical}} (with default): Option to suppress terminal output.,} \item{plot}{\code{\link{logical}} (with default): If \code{TRUE} the histograms used for the cosmic-ray removal are returned as plot including the used threshold. Note: A separat plot is returned for each frame! Currently only for \code{method = "Pych"} a graphical output is provided.} \item{\dots}{further arguments and graphical parameters that will be passed to the \code{smooth} function.} } \value{ Returns same object as input (\code{\linkS4class{RLum.Data.Spectrum}}) } \description{ The function provides several methods for cosmic ray removal and spectrum smoothing for an RLum.Data.Spectrum S4 class object } \details{ \bold{\code{method = "Pych"}} \cr This method applies the cosmic-ray removal algorithm described by Pych (2003). Some aspects that are different to the publication: \itemize{ \item For interpolation between neighbouring values the median and not the mean is used. \item The number of breaks to construct the histogram is set to: \code{length(number.of.input.values)/2} } For further details see references below. \bold{\code{method = "smooth"}} \cr Method uses the function \code{\link{smooth}} to remove cosmic rays.\cr Arguments that can be passed are: \code{kind}, \code{twiceit}\cr \bold{\code{method = "smooth.spline"}} \cr Method uses the function \code{\link{smooth.spline}} to remove cosmic rays.\cr Arguments that can be passed are: \code{spar}\cr \bold{How to combine methods?}\cr Different methods can be combined by applying the method repeatedly to the dataset (see example). } \note{ - } \section{Function version}{ 0.2.1 (2017-06-29 18:40:14) } \examples{ ##(1) - use with your own data and combine (uncomment for usage) ## run two times the default method and smooth with another method ## your.spectrum <- apply_CosmicRayRemoval(your.spectrum, method = "Pych") ## your.spectrum <- apply_CosmicRayRemoval(your.spectrum, method = "Pych") ## your.spectrum <- apply_CosmicRayRemoval(your.spectrum, method = "smooth") } \section{How to cite}{ Kreutzer, S. (2017). apply_CosmicRayRemoval(): Function to remove cosmic rays from an RLum.Data.Spectrum S4 class object. Function version 0.2.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Pych, W., 2003. A Fast Algorithm for Cosmic-Ray Removal from Single Images. Astrophysics 116, 148-153. \url{http://arxiv.org/pdf/astro-ph/0311290.pdf?origin=publication_detail} } \seealso{ \code{\linkS4class{RLum.Data.Spectrum}}, \code{\link{smooth}}, \code{\link{smooth.spline}}, \code{\link{apply_CosmicRayRemoval}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{manip} Luminescence/man/CW2pPMi.Rd0000644000176200001440000001322413125227576015123 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/CW2pPMi.R \name{CW2pPMi} \alias{CW2pPMi} \title{Transform a CW-OSL curve into a pPM-OSL curve via interpolation under parabolic modulation conditions} \usage{ CW2pPMi(values, P) } \arguments{ \item{values}{\code{\linkS4class{RLum.Data.Curve}} or \code{\link{data.frame}} (\bold{required}): \code{\linkS4class{RLum.Data.Curve}} or \code{data.frame} with measured curve data of type stimulation time (t) (\code{values[,1]}) and measured counts (cts) (\code{values[,2]})} \item{P}{\code{\link{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.} } \value{ The function returns the same data type as the input data type with the transformed curve values. \item{list(list("RLum.Data.Curve"))}{package \code{\linkS4class{RLum} object} with two additional info elements: \tabular{rl}{ $CW2pPMi.x.t \tab: transformed time values \cr $CW2pPMi.method \tab: used method for the production of the new data points }} \item{list(list("data.frame"))}{with four columns: \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 }} } \description{ 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). } \details{ The complete procedure of the transformation is given in Bos & Wallinga (2012). The input \code{data.frame} consists of two columns: time (t) and count values (CW(t))\cr\cr \bold{Nomenclature}\cr\cr P = stimulation time (s)\cr 1/P = stimulation rate (1/s)\cr\cr \bold{Internal transformation steps}\cr\cr (1) log(CW-OSL) values\cr\cr (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 \code{min(t)} and \code{max(t)} produce \code{NA} values.\cr\cr (4) Select all values for t' < \code{min(t)}, i.e. values beyond the time resolution of t. Select the first two values of the transformed data set which contain no \code{NA} values and use these values for a linear fit using \code{\link{lm}}.\cr\cr (5) Extrapolate values for t' < \code{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.\cr\cr (6) Transform values using \deqn{pLM(t) = t^2/P^2*CW(t')} (7) Combine all values and truncate all values for t' > \code{max(t)}\cr\cr \emph{The number of values for t' < \code{min(t)} depends on the stimulation period \code{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 \code{P}, i.e. provide no value for \code{P}.} } \note{ According to Bos & Wallinga (2012), the number of extrapolated points should be limited to avoid artificial intensity data. If \code{P} is provided manually, not more than two points are extrapolated. } \section{Function version}{ 0.2.1 (2017-06-29 18:40:14) } \examples{ ##(1) ##load CW-OSL curve data data(ExampleData.CW_OSL_Curve, envir = environment()) ##transform values values.transformed <- 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 <- CW2pLMi(values, P = 1/20) lines(values[1:length(values.t[,1]),1],CW2pLMi(values, P = 1/20)[,2], col = "red",lwd = 1.3) text(0.03,4500,"LM", col = "red", cex = .8) values.t <- CW2pHMi(values, delta = 40) lines(values[1:length(values.t[,1]),1], CW2pHMi(values, delta = 40)[,2], col = "black", lwd = 1.3) text(0.005,3000,"HM", cex = .8) values.t <- CW2pPMi(values, P = 1/10) lines(values[1:length(values.t[,1]),1], CW2pPMi(values, P = 1/10)[,2], col = "blue", lwd = 1.3) text(0.5,6500,"PM", col = "blue", cex = .8) } \section{How to cite}{ Kreutzer, S. (2017). CW2pPMi(): Transform a CW-OSL curve into a pPM-OSL curve via interpolation under parabolic modulation conditions. Function version 0.2.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Bos, A.J.J. & Wallinga, J., 2012. How to visualize quartz OSL signal components. Radiation Measurements, 47, 752-758.\cr \bold{Further Reading}\cr\cr 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. } \seealso{ \code{\link{CW2pLM}}, \code{\link{CW2pLMi}}, \code{\link{CW2pHMi}}, \code{\link{fit_LMCurve}}, \code{\linkS4class{RLum.Data.Curve}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France)\cr\cr Based on comments and suggestions from:\cr Adrie J.J. Bos, Delft University of Technology, The Netherlands\cr \cr R Luminescence Package Team} \keyword{manip} Luminescence/man/convert_Daybreak2CSV.Rd0000644000176200001440000000377313125227576017672 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convert_Daybreak2CSV.R \name{convert_Daybreak2CSV} \alias{convert_Daybreak2CSV} \title{Export measurement data produced by a Daybreak luminescence reader to CSV-files} \usage{ convert_Daybreak2CSV(file, ...) } \arguments{ \item{file}{\code{\link{character}} (\bold{required}): name of the Daybreak-file (TXT-file, DAT-file) to be converted to CSV-files} \item{\dots}{further arguments that will be passed to the function \code{\link{read_Daybreak2R}} and \code{\link{write_RLum2CSV}}} } \value{ The function returns either a CSV-file (or many of them) or for the option \code{export = FALSE} a list comprising objects of type \code{link{data.frame}} and \code{\link{matrix}} } \description{ This function is a wrapper function around the functions \code{\link{read_Daybreak2R}} and \code{\link{write_RLum2CSV}} and it imports an Daybreak-file (TXT-file, DAT-file) and directly exports its content to CSV-files. If nothing is set for the argument \code{path} (\code{\link{write_RLum2CSV}}) the input folder will become the output folder. } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \examples{ \dontrun{ ##select your BIN-file file <- file.choose() ##convert convert_Daybreak2CSV(file) } } \seealso{ \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data}}, \code{\linkS4class{RLum.Results}}, \code{\link[utils]{write.table}}, \code{\link{write_RLum2CSV}}, \code{\link{read_Daybreak2R}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). convert_Daybreak2CSV(): Export measurement data produced by a Daybreak luminescence reader to CSV-files. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{IO} Luminescence/man/calc_Kars2008.Rd0000644000176200001440000001743013125227575016140 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_Kars2008.R \name{calc_Kars2008} \alias{calc_Kars2008} \title{Apply the Kars et al. (2008) model} \usage{ calc_Kars2008(data, rhop, ddot, readerDdot, normalise = TRUE, summary = TRUE, plot = TRUE, ...) } \arguments{ \item{data}{\code{\link{data.frame}} (\bold{required}): A three column data frame with numeric values on a) dose (s), b) LxTx and and c) LxTx error. If a two column data frame is provided it is automatically assumed that errors on LxTx are missing. A third column will be attached with an arbitrary 5 \% error on the provided LxTx values.\cr Can also be a wide table, i.e. a \code{\link{data.frame}} with a number of colums divisible by 3 and where each triplet has the aforementioned column structure.} \item{rhop}{\code{\link{numeric}} (\bold{required}): The density of recombination centres (\eqn{\rho}') and its error (see Huntley 2006), given as numeric vector of length two. Note that \eqn{\rho}' must \bold{not} be provided as the common logarithm. Example: \code{rhop = c(2.92e-06, 4.93e-07)}.} \item{ddot}{\code{\link{numeric}} (\bold{required}): Environmental dose rate and its error, given as a numeric vector of length two. Expected unit: Gy/ka. Example: \code{ddot = c(3.7, 0.4)}.} \item{readerDdot}{\code{\linkS4class{RLum.Analysis}} (\bold{required}): Dose rate of the irradiation source of the OSL reader and its error, given as a numeric vector of length two. Expected unit: Gy/s. Example: \code{readerDdot = c(0.08, 0.01)}.} \item{normalise}{\code{\link{logical}} (with default): If \code{TRUE} (the default) all measured and computed LxTx values are normalised by the pre-exponential factor A (see details).} \item{summary}{\code{\link{logical}} (with default): If \code{TRUE} (the default) various parameters provided by the user and calculated by the model are added as text on the right-hand side of the plot.} \item{plot}{\code{\link{logical}} (with default): enables/disables plot output.} \item{...}{further arguments passed to \code{\link{plot}} and \code{\link[Luminescence]{plot_GrowthCurve}}.} } \value{ An \code{\linkS4class{RLum.Results}} object is returned: Slot: \bold{@data}\cr \tabular{lll}{ \bold{OBJECT} \tab \bold{TYPE} \tab \bold{COMMENT}\cr \code{results} \tab \code{data.frame} \tab results of the of Kars et al. 2008 model \cr \code{data} \tab \code{data.frame} \tab original input data \cr \code{Ln} \tab \code{numeric} \tab Ln and its error \cr \code{LxTx_tables} \tab \code{list} \tab A \code{list} of \code{data.frames} containing data on dose, LxTx and LxTx error for each of the dose response curves. Note that these \bold{do not} contain the natural Ln signal, which is provided separately. \cr \code{fits} \tab \code{list} \tab A \code{list} of \code{nls} objects produced by \code{\link[minpack.lm]{nlsLM}} when fitting the dose response curves \cr } Slot: \bold{@info}\cr \tabular{lll}{ \bold{OBJECT} \tab \bold{TYPE} \tab \bold{COMMENT} \cr \code{call} \tab \code{call} \tab the original function call \cr \code{args} \tab \code{list} \tab arguments of the original function call \cr } } \description{ A function to calculate the expected sample specific fraction of saturation following Kars et al. (2008) and Huntley (2006). } \details{ This function applies the approach described in Kars et al. (2008), developed from the model of Huntley (2006) to calculate the expected sample specific fraction of saturation of a feldspar and also to calculate fading corrected age using this model. \eqn{\rho}' (\code{rhop}), the density of recombination centres, is a crucial parameter of this model and must be determined separately from a fading measurement. The function \code{\link[Luminescence]{analyse_FadingMeasurement}} can be used to calculate the sample specific \eqn{\rho}' value. Firstly the unfaded D0 value is determined through applying equation 5 of Kars et al. (2008) to the measured LxTx data as a function of irradiation time, and fitting the data with a single saturating exponential of the form: \deqn{LxTx(t*) = A x \phi(t*) x (1 - exp(-(t* / D0)))} where \deqn{\phi(t*) = exp(-\rho' x ln(1.8 x s_tilde x t*)^3)} after King et al. (2016) where \code{A} is a pre-exponential factor, \code{t*} (s) is the irradiation time, starting at the mid-point of irradiation (Auclair et al. 2003) and \code{s_tilde} (3x10^15 s^-1) is the athermal frequency factor after Huntley (2006). \cr Using fit parameters \code{A} and \code{D0}, the function then computes a natural dose response curve using the environmental dose rate, \code{D_dot} (Gy/s) and equations [1] and [2]. Computed LxTx values are then fitted using the \code{\link[Luminescence]{plot_GrowthCurve}} function and the laboratory measured LnTn can then be interpolated onto this curve to determine the fading corrected De value, from which the fading corrected age is calculated. \cr The \code{calc_Kars2008} function also calculates the level of saturation (n/N) and the field saturation (i.e. athermal steady state, (n/N)_SS) value for the sample under investigation using the sample specific \eqn{\rho}', unfaded \code{D0} and \code{D_dot} values, following the approach of Kars et al. (2008). \cr Uncertainties are reported at 1 sigma and are assumed to be normally distributed and are estimated using monte-carlo resamples (\code{n.MC = 1000}) of \eqn{\rho}' and LxTx during dose response curve fitting, and of \eqn{\rho}' in the derivation of (n/N) and (n/N)_SS. } \note{ \bold{This function has BETA status and should not be used for publication work!} } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \examples{ ## Load example data (sample UNIL/NB123, see ?ExampleData.Fading) data("ExampleData.Fading", envir = environment()) ## (1) Set all relevant parameters # a. fading measurement data (IR50) fading_data <- ExampleData.Fading$fading.data$IR50 # b. Dose response curve data data <- ExampleData.Fading$equivalentDose.data$IR50 ## (2) Define required function parameters ddot <- c(7.00, 0.004) readerDdot <- c(0.134, 0.0067) # Analyse fading measurement and get an estimate of rho'. # Note that the RLum.Results object can be directly used for further processing. # The number of MC runs is reduced for this example rhop <- analyse_FadingMeasurement(fading_data, plot = TRUE, verbose = FALSE, n.MC = 10) ## (3) Apply the Kars et al. (2008) model to the data kars <- calc_Kars2008(data = data, rhop = rhop, ddot = ddot, readerDdot = readerDdot, n.MC = 50 ) } \section{How to cite}{ King, G., Burow, C. (2017). calc_Kars2008(): Apply the Kars et al. (2008) model. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Kars, R.H., Wallinga, J., Cohen, K.M., 2008. A new approach towards anomalous fading correction for feldspar IRSL dating-tests on samples in field saturation. Radiation Measurements 43, 786-790. doi:10.1016/j.radmeas.2008.01.021 Huntley, D.J., 2006. An explanation of the power-law decay of luminescence. Journal of Physics: Condensed Matter 18, 1359-1365. doi:10.1088/0953-8984/18/4/020 King, G.E., Herman, F., Lambert, R., Valla, P.G., Guralnik, B., 2016. Multi-OSL-thermochronometry of feldspar. Quaternary Geochronology 33, 76-87. doi:10.1016/j.quageo.2016.01.004 \bold{Further reading} Morthekai, P., Jain, M., Cunha, P.P., Azevedo, J.M., Singhvi, A.K., 2011. An attempt to correct for the fading in million year old basaltic rocks. Geochronometria 38(3), 223-230. } \author{ Georgina King, University of Cologne (Germany), \cr Christoph Burow, University of Cologne (Germany) \cr R Luminescence Package Team} \keyword{datagen} Luminescence/man/bin_RLum.Data.Rd0000644000176200001440000000373513125227575016326 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bin_RLum.Data.R \name{bin_RLum.Data} \alias{bin_RLum.Data} \title{Channel binning - method dispatchter} \usage{ bin_RLum.Data(object, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Data}} (\bold{required}): S4 object of class \code{RLum.Data}} \item{...}{further arguments passed to the specifc class method} } \value{ An object of the same type as the input object is provided } \description{ Function calls the object-specific bin functions for RLum.Data S4 class objects. } \details{ The function provides a generalised access point for specific \code{\linkS4class{RLum.Data}} objects.\cr Depending on the input object, the corresponding function will be selected. Allowed arguments can be found in the documentations of the corresponding \code{\linkS4class{RLum.Data}} class. } \note{ Currenlty only \code{RLum.Data} objects of class \code{RLum.Data.Curve} are supported! } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \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)) } \seealso{ \code{\linkS4class{RLum.Data.Curve}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). bin_RLum.Data(): Channel binning - method dispatchter. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{utilities} Luminescence/man/RLum.Results-class.Rd0000644000176200001440000001204013125227576017357 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RLum.Results-class.R \docType{class} \name{RLum.Results-class} \alias{RLum.Results-class} \alias{show,RLum.Results-method} \alias{set_RLum,RLum.Results-method} \alias{get_RLum,RLum.Results-method} \alias{length_RLum,RLum.Results-method} \alias{names_RLum,RLum.Results-method} \title{Class \code{"RLum.Results"}} \usage{ \S4method{show}{RLum.Results}(object) \S4method{set_RLum}{RLum.Results}(class, originator, .uid, .pid, data = list(), info = list()) \S4method{get_RLum}{RLum.Results}(object, data.object, info.object = NULL, drop = TRUE) \S4method{length_RLum}{RLum.Results}(object) \S4method{names_RLum}{RLum.Results}(object) } \arguments{ \item{object}{[\code{get_RLum}] \code{\linkS4class{RLum.Results}} (required): an object of class \code{\linkS4class{RLum.Results}} to be evaluated} \item{class}{[\code{set_RLum}] \code{\link{character}} \bold{(required)}: name of the \code{RLum} class to create} \item{originator}{[\code{set_RLum}] \code{\link{character}} (automatic): contains the name of the calling function (the function that produces this object); can be set manually.} \item{.uid}{[\code{set_RLum}] \code{\link{character}} (automatic): sets an unique ID for this object using the internal C++ function \code{.create_UID}.} \item{.pid}{[\code{set_RLum}] \code{\link{character}} (with default): option to provide a parent id for nesting at will.} \item{data}{[\code{set_RLum}] \code{\link{list}} (optional): a list containing the data to be stored in the object} \item{info}{[\code{set_RLum}] \code{\link{list}} (optional): a list containing additional info data for the object} \item{data.object}{[\code{get_RLum}] \code{\link{character}} or \code{\link{numeric}}: name or index of the data slot to be returned} \item{info.object}{[\code{get_RLum}] \code{\link{character}} (optional): name of the wanted info element} \item{drop}{[\code{get_RLum}] \code{\link{logical}} (with default): coerce to the next possible layer (which are data objects, \code{drop = FALSE} keeps the original \code{RLum.Results}} } \value{ \bold{\code{set_RLum}}:\cr Returns an object from the class \code{\linkS4class{RLum.Results}}\cr \bold{\code{get_RLum}}:\cr Returns: \cr (1) Data object from the specified slot \cr (2) \code{\link{list}} of data objects from the slots if 'data.object' is vector or \cr (3) an \code{\linkS4class{RLum.Results}} for \code{drop = FALSE}.\cr \bold{\code{length_RLum}}\cr Returns the number of data elements in the \code{RLum.Results} object. \bold{\code{names_RLum}}\cr Returns the names of the data elements in the object. } \description{ Object class contains results data from functions (e.g., \code{\link{analyse_SAR.CWOSL}}). } \section{Methods (by generic)}{ \itemize{ \item \code{show}: Show structure of \code{RLum.Results} object \item \code{set_RLum}: Construction method for an RLum.Results object. \item \code{get_RLum}: Accessor method for RLum.Results object. The argument data.object allows directly accessing objects delivered within the slot data. The default return object depends on the object originator (e.g., \code{fit_LMCurve}). If nothing is specified always the first \code{data.object} will be returned. Note: Detailed specification should be made in combination with the originator slot in the receiving function if results are pipped. \item \code{length_RLum}: Returns the length of the object, i.e., number of stored data.objects \item \code{names_RLum}: Returns the names data.objects }} \section{Slots}{ \describe{ \item{\code{data}}{Object of class "list" containing output data} }} \note{ The class is intended to store results from functions to be used by other functions. The data in the object should always be accessed by the method \code{get_RLum}. } \section{Objects from the Class}{ Objects can be created by calls of the form \code{new("RLum.Results", ...)}. } \section{Class version}{ 0.5.1 } \examples{ showClass("RLum.Results") ##create an empty object from this class set_RLum(class = "RLum.Results") ##use another function to show how it works ##Basic calculation of the dose rate for a specific date dose.rate <- calc_SourceDoseRate( measurement.date = "2012-01-27", calib.date = "2014-12-19", calib.dose.rate = 0.0438, calib.error = 0.0019) ##show object dose.rate ##get results get_RLum(dose.rate) ##get parameters used for the calcualtion from the same object get_RLum(dose.rate, data.object = "parameters") ##alternatively objects can be accessed using S3 generics, such as dose.rate$parameters } \seealso{ \code{\linkS4class{RLum}}, \code{\link{plot_RLum}}, \code{\link{merge_RLum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) } \section{How to cite}{ Kreutzer, S. (2017). RLum.Results-class(): Class 'RLum.Results'. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{classes} \keyword{methods} Luminescence/man/calc_OSLLxTxRatio.Rd0000644000176200001440000001613413125227575017202 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_OSLLxTxRatio.R \name{calc_OSLLxTxRatio} \alias{calc_OSLLxTxRatio} \title{Calculate Lx/Tx ratio for CW-OSL curves} \usage{ calc_OSLLxTxRatio(Lx.data, Tx.data = NULL, signal.integral, signal.integral.Tx = NULL, background.integral, background.integral.Tx = NULL, background.count.distribution = "non-poisson", use_previousBG = FALSE, sigmab = NULL, sig0 = 0, digits = NULL) } \arguments{ \item{Lx.data}{\code{\linkS4class{RLum.Data.Curve}} or \link{data.frame} (\bold{required}): requires a CW-OSL shine down curve (x = time, y = counts)} \item{Tx.data}{\code{\linkS4class{RLum.Data.Curve}} or \link{data.frame} (optional): requires a CW-OSL shine down curve (x = time, y = counts). If no input is given the Tx.data will be treated as \code{NA} and no Lx/Tx ratio is calculated.} \item{signal.integral}{\code{\link{vector}} (\bold{required}): vector with the limits for the signal integral.} \item{signal.integral.Tx}{\code{\link{vector}} (optional): vector with the limits for the signal integral for the Tx curve. If nothing is provided the value from \code{signal.integral} is used.} \item{background.integral}{\code{\link{vector}} (\bold{required}): vector with the bounds for the background integral.} \item{background.integral.Tx}{\code{\link{vector}} (optional): vector with the limits for the background integral for the Tx curve. If nothing is provided the value from \code{background.integral} is used.} \item{background.count.distribution}{\code{\link{character}} (with default): sets the count distribution assumed for the error calculation. Possible arguments \code{poisson} or \code{non-poisson}. See details for further information} \item{use_previousBG}{\code{\link{logical}} (with default): If set to \code{TRUE} the background of the Lx-signal is substracted also from the Tx-signal. Please note that in this case separat signal integral limits for the Tx signal are not allowed and will be reset.} \item{sigmab}{\code{\link{numeric}} (optional): option to set a manual value for the overdispersion (for LnTx and TnTx), used for the Lx/Tx error calculation. The value should be provided as absolute squared count values, e.g. \code{sigmab = c(300,300)}. Note: If only one value is provided this value is taken for both (LnTx and TnTx) signals.} \item{sig0}{\code{\link{numeric}} (with default): allow adding an extra component of error to the final Lx/Tx error value (e.g., instrumental errror, see details).} \item{digits}{\code{\link{integer}} (with default): round numbers to the specified digits. If digits is set to \code{NULL} nothing is rounded.} } \value{ Returns an S4 object of type \code{\linkS4class{RLum.Results}}. Slot \code{data} contains a \code{\link{list}} with the following structure:\cr \bold{@data}\cr $LxTx.table (data.frame) \cr .. $ LnLx \cr .. $ LnLx.BG \cr .. $ TnTx \cr .. $ TnTx.BG \cr .. $ Net_LnLx \cr .. $ Net_LnLx.Error\cr .. $ Net_TnTx.Error\cr .. $ LxTx\cr .. $ LxTx.Error \cr $ calc.parameters (list) \cr .. $ sigmab.LnTx\cr .. $ sigmab.TnTx\cr .. $ k \cr \bold{@info}\cr $ call (original function call)\cr } \description{ Calculate Lx/Tx ratios from a given set of CW-OSL curves assuming late light background subtraction. } \details{ The integrity of the chosen values for the signal and background integral is checked by the function; the signal integral limits have to be lower than the background integral limits. If a \link{vector} is given as input instead of a \link{data.frame}, an artificial \code{data.frame} is produced. The error calculation is done according to Galbraith (2002).\cr \bold{Please note:} In cases where the calculation results in \code{NaN} values (for example due to zero-signal, and therefore a division of 0 by 0), these \code{NaN} values are replaced by 0. \bold{sigmab}\cr The default value of \code{sigmab} is calculated assuming the background is constant and \bold{would not} applicable when the background varies as, e.g., as observed for the early light substraction method.\cr \bold{sig0}\cr This argument allows to add an extra component of error to the final Lx/Tx error value. The input will be treated as factor that is multiplied with the already calculated LxTx and the result is add up by: \deqn{se(LxTx) = \sqrt(se(LxTx)^2 + (LxTx * sig0)^2)} \bold{background.count.distribution}\cr This argument allows selecting the distribution assumption that is used for the error calculation. According to Galbraith (2002, 2014) the background counts may be overdispersed (i.e. do not follow a poisson distribution, which is assumed for the photomultiplier counts). In that case (might be the normal case) it has to be accounted for the overdispersion by estimating \eqn{\sigma^2} (i.e. the overdispersion value). Therefore the relative standard error is calculated as:\cr\cr (a) \code{poisson}\cr \deqn{rse(\mu_{S}) \approx \sqrt(Y_{0} + Y_{1}/k^2)/Y_{0} - Y_{1}/k} (b) \code{non-poisson}\cr \deqn{rse(\mu_{S}) \approx \sqrt(Y_{0} + Y_{1}/k^2 + \sigma^2(1+1/k))/Y_{0} - Y_{1}/k} \bold{Please note} that when using the early background subtraction method in combination with the 'non-poisson' distribution argument, the corresponding Lx/Tx error may considerably increase due to a high sigmab value. Please check whether this is valid for your data set and if necessary consider to provide an own sigmab value using the corresponding argument \code{sigmab}. } \note{ The results of this function have been cross-checked with the Analyst (vers. 3.24b). Access to the results object via \code{\link{get_RLum}}.\cr \bold{Caution:} If you are using early light subtraction (EBG), please either provide your own \code{sigmab} value or use \code{background.count.distribution = "poisson"}. } \section{Function version}{ 0.7.0 (2017-06-29 18:40:14) } \examples{ ##load data data(ExampleData.LxTxOSLData, envir = environment()) ##calculate Lx/Tx ratio results <- calc_OSLLxTxRatio(Lx.data, Tx.data, signal.integral = c(1:2), background.integral = c(85:100)) ##get results object get_RLum(results) } \section{How to cite}{ Kreutzer, S. (2017). calc_OSLLxTxRatio(): Calculate Lx/Tx ratio for CW-OSL curves. Function version 0.7.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Duller, G., 2007. Analyst. \url{http://www.nutech.dtu.dk/english/~/media/Andre_Universitetsenheder/Nutech/Produkter\%20og\%20services/Dosimetri/radiation_measurement_instruments/tl_osl_reader/Manuals/analyst_manual_v3_22b.ashx}\cr Galbraith, R.F., 2002. A note on the variance of a background-corrected OSL count. Ancient TL, 20 (2), 49-51. Galbraith, R.F., 2014. A further note on the variance of a background-corrected OSL count. Ancient TL, 31 (2), 1-3. } \seealso{ \code{\linkS4class{RLum.Data.Curve}}, \code{\link{Analyse_SAR.OSLdata}}, \code{\link{plot_GrowthCurve}}, \code{\link{analyse_SAR.CWOSL}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{datagen} Luminescence/man/methods_RLum.Rd0000644000176200001440000001670513125226556016350 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/methods_RLum.R \name{methods_RLum} \alias{methods_RLum} \alias{plot.list} \alias{plot.RLum.Results} \alias{plot.RLum.Analysis} \alias{plot.RLum.Data.Curve} \alias{plot.RLum.Data.Spectrum} \alias{plot.RLum.Data.Image} \alias{plot.Risoe.BINfileData} \alias{hist.RLum.Results} \alias{hist.RLum.Data.Image} \alias{hist.RLum.Data.Curve} \alias{hist.RLum.Analysis} \alias{summary.RLum.Results} \alias{summary.RLum.Analysis} \alias{summary.RLum.Data.Image} \alias{summary.RLum.Data.Curve} \alias{subset.Risoe.BINfileData} \alias{subset.RLum.Analysis} \alias{bin.RLum.Data.Curve} \alias{length.RLum.Results} \alias{length.RLum.Analysis} \alias{length.RLum.Data.Curve} \alias{length.Risoe.BINfileData} \alias{dim.RLum.Data.Curve} \alias{dim.RLum.Data.Spectrum} \alias{rep.RLum} \alias{names.RLum.Data.Curve} \alias{names.RLum.Data.Spectrum} \alias{names.RLum.Data.Image} \alias{names.RLum.Analysis} \alias{names.RLum.Results} \alias{names.Risoe.BINfileData} \alias{row.names.RLum.Data.Spectrum} \alias{as.data.frame.RLum.Data.Curve} \alias{as.data.frame.RLum.Data.Spectrum} \alias{as.list.RLum.Results} \alias{as.list.RLum.Data.Curve} \alias{as.list.RLum.Analysis} \alias{as.matrix.RLum.Data.Curve} \alias{as.matrix.RLum.Data.Spectrum} \alias{is.RLum} \alias{is.RLum.Data} \alias{is.RLum.Data.Curve} \alias{is.RLum.Data.Spectrum} \alias{is.RLum.Data.Image} \alias{is.RLum.Analysis} \alias{is.RLum.Results} \alias{merge.RLum} \alias{unlist.RLum.Analysis} \alias{+.RLum.Data.Curve} \alias{-.RLum.Data.Curve} \alias{*.RLum.Data.Curve} \alias{/.RLum.Data.Curve} \alias{[.RLum.Data.Curve} \alias{[.RLum.Data.Spectrum} \alias{[.RLum.Data.Image} \alias{[.RLum.Analysis} \alias{[.RLum.Results} \alias{[<-.RLum.Data.Curve} \alias{[[.RLum.Analysis} \alias{[[.RLum.Results} \alias{$.RLum.Data.Curve} \alias{$.RLum.Analysis} \alias{$.RLum.Results} \title{methods_RLum} \usage{ \method{plot}{list}(x, y, ...) \method{plot}{RLum.Results}(x, y, ...) \method{plot}{RLum.Analysis}(x, y, ...) \method{plot}{RLum.Data.Curve}(x, y, ...) \method{plot}{RLum.Data.Spectrum}(x, y, ...) \method{plot}{RLum.Data.Image}(x, y, ...) \method{plot}{Risoe.BINfileData}(x, y, ...) \method{hist}{RLum.Results}(x, ...) \method{hist}{RLum.Data.Image}(x, ...) \method{hist}{RLum.Data.Curve}(x, ...) \method{hist}{RLum.Analysis}(x, ...) \method{summary}{RLum.Results}(object, ...) \method{summary}{RLum.Analysis}(object, ...) \method{summary}{RLum.Data.Image}(object, ...) \method{summary}{RLum.Data.Curve}(object, ...) \method{subset}{Risoe.BINfileData}(x, subset, records.rm = TRUE, ...) \method{subset}{RLum.Analysis}(x, subset, ...) bin.RLum.Data.Curve(x, ...) \method{length}{RLum.Results}(x, ...) \method{length}{RLum.Analysis}(x, ...) \method{length}{RLum.Data.Curve}(x, ...) \method{length}{Risoe.BINfileData}(x, ...) \method{dim}{RLum.Data.Curve}(x) \method{dim}{RLum.Data.Spectrum}(x) \method{rep}{RLum}(x, ...) \method{names}{RLum.Data.Curve}(x, ...) \method{names}{RLum.Data.Spectrum}(x, ...) \method{names}{RLum.Data.Image}(x, ...) \method{names}{RLum.Analysis}(x, ...) \method{names}{RLum.Results}(x, ...) \method{names}{Risoe.BINfileData}(x) \method{row.names}{RLum.Data.Spectrum}(x, ...) \method{as.data.frame}{RLum.Data.Curve}(x, row.names = NULL, optional = FALSE, ...) \method{as.data.frame}{RLum.Data.Spectrum}(x, row.names = NULL, optional = FALSE, ...) \method{as.list}{RLum.Results}(x, ...) \method{as.list}{RLum.Data.Curve}(x, ...) \method{as.list}{RLum.Analysis}(x, ...) \method{as.matrix}{RLum.Data.Curve}(x, ...) \method{as.matrix}{RLum.Data.Spectrum}(x, ...) is.RLum(x, ...) is.RLum.Data(x, ...) is.RLum.Data.Curve(x, ...) is.RLum.Data.Spectrum(x, ...) is.RLum.Data.Image(x, ...) is.RLum.Analysis(x, ...) is.RLum.Results(x, ...) \method{merge}{RLum}(x, y, ...) \method{unlist}{RLum.Analysis}(x, recursive = TRUE, ...) \method{+}{RLum.Data.Curve}(x, y) \method{-}{RLum.Data.Curve}(x, y) \method{*}{RLum.Data.Curve}(x, y) \method{/}{RLum.Data.Curve}(x, y) \method{[}{RLum.Data.Curve}(x, y, z, drop = TRUE) \method{[}{RLum.Data.Spectrum}(x, y, z, drop = TRUE) \method{[}{RLum.Data.Image}(x, y, z, drop = TRUE) \method{[}{RLum.Analysis}(x, i, drop = FALSE) \method{[}{RLum.Results}(x, i, drop = TRUE) \method{[}{RLum.Data.Curve}(x, i, j) <- value \method{[[}{RLum.Analysis}(x, i) \method{[[}{RLum.Results}(x, i) \method{$}{RLum.Data.Curve}(x, i) \method{$}{RLum.Analysis}(x, i) \method{$}{RLum.Results}(x, i) } \arguments{ \item{x}{\code{\linkS4class{RLum}} or \code{\linkS4class{Risoe.BINfileData}} (\bold{required}): input opject} \item{y}{\code{\link{integer}} (optional): the row index of the matrix, data.frame} \item{...}{further arguments that can be passed to the method} \item{object}{\code{\linkS4class{RLum}} (\bold{required}): input opject} \item{subset}{\code{[subset]} \code{\link{expression}} (\bold{required}): logical expression indicating elements or rows to keep, this function works in \code{\linkS4class{Risoe.BINfileData}} objects like \code{\link{subset.data.frame}}, but takes care of the object structure} \item{records.rm}{[subset] \code{\link{logical}} (with default): remove records from data set, can be disabled, to just set the column \code{SET} to \code{TRUE} or \code{FALSE}} \item{row.names}{\code{\link{logical}} (with default): enables or disables row names (\code{as.data.frame})} \item{optional}{\code{\link{logical}} (with default): logical. If TRUE, setting row names and converting column names (to syntactic names: see make.names) is optional (see \code{\link[base]{as.data.frame}})} \item{recursive}{\code{\link{logical}} (with default): enables or disables further subsetting (\code{unlist})} \item{z}{\code{\link{integer}} (optional): the column index of the matrix, data.frame} \item{drop}{\code{\link{logical}} (with default): keep object structure or drop it} \item{i}{\code{\link{character}} (optional): name of the wanted record type or data object or row in the \code{RLum.Data.Curve} object} \item{j}{\code{\link{integer}} (optional): column of the data matrix in the \code{RLum.Data.Curve} object} \item{value}{\code{\link{numeric}} \bold{(required)}: numeric value which replace the value in the \code{RLum.Data.Curve} object} } \description{ Methods for S3-generics implemented for the package 'Luminescence'. This document summarises all implemented S3-generics. The name of the function is given before the first dot, after the dot the name of the object that is supported by this method is given, e.g. \code{plot.RLum.Data.Curve} can be called by \code{plot(object, ...)}, where \code{object} is the \code{RLum.Data.Curve} object. } \details{ The term S3-generics sounds complicated, however, it just means that something has been implemented in the package to increase the usability for users new in R and who are not familiar with the underlying \code{RLum}-object structure of the package. The practical outcome is that operations and functions presented in standard books on R can be used without knowing the specifica of the R package 'Luminescence'. For examples see the example section. } \note{ \code{methods_RLum} are not really new functions, everything given here are mostly just surrogates for existing functions in the package. } \examples{ ##load example data data(ExampleData.RLum.Analysis, envir = environment()) ##combine curve is various ways curve1 <- IRSAR.RF.Data[[1]] curve2 <- IRSAR.RF.Data[[1]] curve1 + curve2 curve1 - curve2 curve1 / curve2 curve1 * curve2 ##`$` access curves IRSAR.RF.Data$RF } Luminescence/man/plot_RLum.Data.Curve.Rd0000644000176200001440000000430213125227576017607 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_RLum.Data.Curve.R \name{plot_RLum.Data.Curve} \alias{plot_RLum.Data.Curve} \title{Plot function for an RLum.Data.Curve S4 class object} \usage{ plot_RLum.Data.Curve(object, par.local = TRUE, norm = FALSE, smooth = FALSE, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Data.Curve}} (\bold{required}): S4 object of class \code{RLum.Data.Curve}} \item{par.local}{\code{\link{logical}} (with default): use local graphical parameters for plotting, e.g. the plot is shown in one column and one row. If \code{par.local = FALSE}, global parameters are inherited.} \item{norm}{\code{\link{logical}} (with default): allows curve normalisation to the highest count value} \item{smooth}{\code{\link{logical}} (with default): provides an automatic curve smoothing based on \code{\link[zoo]{rollmean}}} \item{\dots}{further arguments and graphical parameters that will be passed to the \code{plot} function} } \value{ Returns a plot. } \description{ The function provides a standardised plot output for curve data of an RLum.Data.Curve S4 class object } \details{ Only single curve data can be plotted with this function. Arguments according to \code{\link{plot}}. } \note{ Not all arguments of \code{\link{plot}} will be passed! } \section{Function version}{ 0.2.3 (2017-06-29 18:40:14) } \examples{ ##plot curve data #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.Data.Curve object plot_RLum.Data.Curve(temp) } \section{How to cite}{ Kreutzer, S. (2017). plot_RLum.Data.Curve(): Plot function for an RLum.Data.Curve S4 class object. Function version 0.2.3. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ # } \seealso{ \code{\link{plot}}, \code{\link{plot_RLum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{aplot} Luminescence/man/write_RLum2CSV.Rd0000644000176200001440000000646613125227576016503 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/write_RLum2CSV.R \name{write_RLum2CSV} \alias{write_RLum2CSV} \title{Export RLum-objects to CSV} \usage{ write_RLum2CSV(object, path = NULL, prefix = "", export = TRUE, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum}} or a \code{\link{list}} of \code{RLum} objects (\bold{required}): objects to be written} \item{path}{\code{\link{character}} (optional): character string naming folder for the output to be written. If nothing is provided \code{path} will be set to the working directory. Note: this argument is ignored if the the argument \code{export} is set to \code{FALSE}.} \item{prefix}{\code{\link{character}} (with default): optional prefix to name the files. This prefix is valid for all written files} \item{export}{\code{\link{logical}} (with default): enable or disable the file export. If set to \code{FALSE} nothing is written to the file connection, but a list comprising objects of type \code{link{data.frame}} and \code{\link{matrix}} is returned instead} \item{\dots}{further arguments that will be passed to the function \code{\link[utils]{write.table}}. All arguments except the argument \code{file} are supported} } \value{ The function returns either a CSV-file (or many of them) or for the option \code{export == FALSE} a list comprising objects of type \code{link{data.frame}} and \code{\link{matrix}} } \description{ This function exports \code{\linkS4class{RLum}}-objects to CSV-files using the R function \code{\link[utils]{write.table}}. All \code{\linkS4class{RLum}}-objects are supported, but the export is lossy, i.e. the pure numerical values are exported only. Information that cannot be coerced to a \code{\link{data.frame}} or a \code{\link{matrix}} are discarded as well as metadata. } \details{ However, in combination with the implemented import functions, nearly every supported import data format can be exported to CSV-files, this gives a great deal of freedom in terms of compatibility with other tools.\cr \bold{Input is a list of objects}\cr If the input is a \code{\link{list}} of objects all explicit function arguments can be provided as \code{\link{list}}. } \section{Function version}{ 0.1.1 (2017-06-29 18:40:14) } \examples{ ##transform values to a list data(ExampleData.BINfileData, envir = environment()) object <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data)[[1]] write_RLum2CSV(object, export = FALSE) \dontrun{ ##export data to CSV-files in the working directory; ##BE CAREFUL, this example creates many files on your file system data(ExampleData.BINfileData, envir = environment()) object <- Risoe.BINfileData2RLum.Analysis(CWOSL.SAR.Data)[[1]] write_RLum2CSV(object, export = FALSE) } } \seealso{ \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data}}, \code{\linkS4class{RLum.Results}}, \code{\link[utils]{write.table}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). write_RLum2CSV(): Export RLum-objects to CSV. Function version 0.1.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{IO} Luminescence/man/plot_DRTResults.Rd0000644000176200001440000001607613125227576017023 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_DRTResults.R \name{plot_DRTResults} \alias{plot_DRTResults} \title{Visualise dose recovery test results} \usage{ plot_DRTResults(values, given.dose = NULL, error.range = 10, preheat, boxplot = FALSE, mtext, summary, summary.pos, legend, legend.pos, par.local = TRUE, na.rm = FALSE, ...) } \arguments{ \item{values}{\code{\linkS4class{RLum.Results}} or \code{\link{data.frame}}, (\bold{required}): input values containing at least De and De error. To plot more than one data set in one figure, a \code{list} of the individual data sets must be provided (e.g. \code{list(dataset.1, dataset.2)}).} \item{given.dose}{\code{\link{numeric}} (optional): given dose used for the dose recovery test to normalise data. If only one given dose is provided this given dose is valid for all input data sets (i.e., \code{values} is a list). Otherwise a given dose for each input data set has to be provided (e.g., \code{given.dose = c(100,200)}). If no \code{given.dose} values are plotted without normalisation (might be useful for preheat plateau tests). Note: Unit has to be the same as from the input values (e.g., Seconds or Gray).} \item{error.range}{\code{\link{numeric}}: symmetric error range in percent will be shown as dashed lines in the plot. Set \code{error.range} to 0 to void plotting of error ranges.} \item{preheat}{\code{\link{numeric}}: optional vector of preheat temperatures to be used for grouping the De values. If specified, the temperatures are assigned to the x-axis.} \item{boxplot}{\code{\link{logical}}: optionally plot values, that are grouped by preheat temperature as boxplots. Only possible when \code{preheat} vector is specified.} \item{mtext}{\code{\link{character}}: additional text below the plot title.} \item{summary}{\code{\link{character}} (optional): adds numerical output to the plot. Can be one or more out of: \code{"n"} (number of samples), \code{"mean"} (mean De value), \code{"mean.weighted"} (error-weighted mean), \code{"median"} (median of the De values), \code{"sdrel"} (relative standard deviation in percent), \code{"sdabs"} (absolute standard deviation), \code{"serel"} (relative standard error) and \code{"seabs"} (absolute standard error).} \item{summary.pos}{\code{\link{numeric}} or \code{\link{character}} (with default): optional position coordinates or keyword (e.g. \code{"topright"}) for the statistical summary. Alternatively, the keyword \code{"sub"} may be specified to place the summary below the plot header. However, this latter option in only possible if \code{mtext} is not used.} \item{legend}{\code{\link{character}} vector (optional): legend content to be added to the plot.} \item{legend.pos}{\code{\link{numeric}} or \code{\link{character}} (with default): optional position coordinates or keyword (e.g. \code{"topright"}) for the legend to be plotted.} \item{par.local}{\code{\link{logical}} (with default): use local graphical parameters for plotting, e.g. the plot is shown in one column and one row. If \code{par.local = FALSE}, global parameters are inherited, i.e. parameters provided via \code{par()} work} \item{na.rm}{\code{\link{logical}}: indicating wether \code{NA} values are removed before plotting from the input data set} \item{\dots}{further arguments and graphical parameters passed to \code{\link{plot}}.} } \value{ A plot is returned. } \description{ The function provides a standardised plot output for dose recovery test measurements. } \details{ Procedure to test the accuracy of a measurement protocol to reliably determine the dose of a specific sample. Here, the natural signal is erased and a known laboratory dose administered which is treated as unknown. Then the De measurement is carried out and the degree of congruence between administered and recovered dose is a measure of the protocol's accuracy for this sample.\cr In the plot the normalised De is shown on the y-axis, i.e. obtained De/Given Dose. } \note{ Further data and plot arguments can be added by using the appropiate R commands. } \section{Function version}{ 0.1.10 (2017-06-29 18:40:14) } \examples{ ## read example data set and misapply them for this plot type data(ExampleData.DeValues, envir = environment()) ## plot values plot_DRTResults(values = ExampleData.DeValues$BT998[7:11,], given.dose = 2800, mtext = "Example data") ## plot values with legend plot_DRTResults(values = ExampleData.DeValues$BT998[7:11,], given.dose = 2800, legend = "Test data set") ## create and plot two subsets with randomised values x.1 <- ExampleData.DeValues$BT998[7:11,] x.2 <- ExampleData.DeValues$BT998[7:11,] * c(runif(5, 0.9, 1.1), 1) plot_DRTResults(values = list(x.1, x.2), given.dose = 2800) ## some more user-defined plot parameters plot_DRTResults(values = list(x.1, x.2), given.dose = 2800, pch = c(2, 5), col = c("orange", "blue"), xlim = c(0, 8), ylim = c(0.85, 1.15), xlab = "Sample aliquot") ## plot the data with user-defined statistical measures as legend plot_DRTResults(values = list(x.1, x.2), given.dose = 2800, summary = c("n", "mean.weighted", "sd")) ## plot the data with user-defined statistical measures as sub-header plot_DRTResults(values = list(x.1, x.2), given.dose = 2800, summary = c("n", "mean.weighted", "sd"), summary.pos = "sub") ## plot the data grouped by preheat temperatures plot_DRTResults(values = ExampleData.DeValues$BT998[7:11,], given.dose = 2800, preheat = c(200, 200, 200, 240, 240)) ## read example data set and misapply them for this plot type data(ExampleData.DeValues, envir = environment()) ## plot values plot_DRTResults(values = ExampleData.DeValues$BT998[7:11,], given.dose = 2800, mtext = "Example data") ## plot two data sets grouped by preheat temperatures plot_DRTResults(values = list(x.1, x.2), given.dose = 2800, preheat = c(200, 200, 200, 240, 240)) ## plot the data grouped by preheat temperatures as boxplots plot_DRTResults(values = ExampleData.DeValues$BT998[7:11,], given.dose = 2800, preheat = c(200, 200, 200, 240, 240), boxplot = TRUE) } \section{How to cite}{ Kreutzer, S., Dietze, M. (2017). plot_DRTResults(): Visualise dose recovery test results. Function version 0.1.10. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Wintle, A.G., Murray, A.S., 2006. A review of quartz optically stimulated luminescence characteristics and their relevance in single-aliquot regeneration dating protocols. Radiation Measurements, 41, 369-391. } \seealso{ \code{\link{plot}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France), Michael Dietze, GFZ Potsdam (Germany) \cr R Luminescence Package Team} \keyword{dplot} Luminescence/man/ExampleData.DeValues.Rd0000644000176200001440000000444113125226556017634 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \name{ExampleData.DeValues} \alias{ExampleData.DeValues} \title{Example De data sets for the package Luminescence} \format{A \code{\link{list}} with two elements, each containing a two column \code{\link{data.frame}}: \describe{ \code{$BT998}: De and De error values for a fine grain quartz sample from a loess section in Rottewitz.\cr\cr \code{$CA1}: Single grain De and De error values for a coarse grain quartz sample from a fluvial deposit in the rock shelter of Cueva Anton }} \description{ Equivalent dose (De) values measured for a fine grain quartz sample from a loess section in Rottewitz (Saxony/Germany) and for a coarse grain quartz sample from a fluvial deposit in the rock shelter of Cueva Anton (Murcia/Spain). } \examples{ ##(1) plot values as histogram data(ExampleData.DeValues, envir = environment()) plot_Histogram(ExampleData.DeValues$BT998, xlab = "De [s]") ##(2) plot values as histogram (with second to gray conversion) data(ExampleData.DeValues, envir = environment()) De.values <- Second2Gray(ExampleData.DeValues$BT998, dose.rate = c(0.0438, 0.0019)) plot_Histogram(De.values, xlab = "De [Gy]") } \references{ \bold{BT998} \cr\cr Unpublished data \cr\cr \bold{CA1} \cr\cr Burow, C., Kehl, M., Hilgers, A., Weniger, G.-C., Angelucci, D., Villaverde, V., Zapata, J. and Zilhao, J. (2015). Luminescence dating of fluvial deposits in the rock shelter of Cueva Anton, Spain. Geochronometria 52, 107-125. \bold{BT998} \cr \tabular{ll}{ Lab: \tab Luminescence Laboratory Bayreuth\cr Lab-Code: \tab BT998\cr Location: \tab Rottewitz (Saxony/Germany)\cr Material: \tab Fine grain quartz measured on aluminum discs on a Risoe TL/OSL DA-15 reader\cr Units: \tab Values are given in seconds \cr Dose Rate: \tab Dose rate of the beta-source at measurement ca. 0.0438 Gy/s +/- 0.0019 Gy/s\cr Measurement Date: \tab 2012-01-27 } \bold{CA1} \cr \tabular{ll}{ Lab: \tab Cologne Luminescence Laboratory (CLL)\cr Lab-Code: \tab C-L2941\cr Location: \tab Cueva Anton (Murcia/Spain)\cr Material: \tab Coarse grain quartz (200-250 microns) measured on single grain discs on a Risoe TL/OSL DA-20 reader\cr Units: \tab Values are given in Gray \cr Measurement Date: \tab 2012 } } \keyword{datasets} Luminescence/man/install_DevelopmentVersion.Rd0000644000176200001440000000332413125226556021315 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/install_DevelopmentVersion.R \name{install_DevelopmentVersion} \alias{install_DevelopmentVersion} \title{Attempts to install the development version of the 'Luminescence' package} \usage{ install_DevelopmentVersion(force_install = FALSE) } \arguments{ \item{force_install}{\code{\link{logical}} (optional): If \code{FALSE} (the default) the function produces and prints the required code to the console for the user to run manually afterwards. When \code{TRUE} and all requirements are fulfilled (see details) this function attempts to install the package itself.} } \value{ This function requires user input at the command prompt to choose the desired development branch to be installed. The required R code to install the package is then printed to the console. } \description{ This function is a convenient method for installing the development version of the R package 'Luminescence' directly from GitHub. } \details{ This function uses \code{\link[Luminescence]{github_branches}} to check which development branches of the R package 'Luminescence' are currently available on GitHub. The user is then prompted to choose one of the branches to be installed. It further checks whether the R package 'devtools' is currently installed and available on the system. Finally, it prints R code to the console that the user can copy and paste to the R console in order to install the desired development version of the package.\cr\cr If \code{force_install=TRUE} the functions checks if 'devtools' is available and then attempts to install the chosen development branch via \code{\link[devtools]{install_github}}. } \examples{ \dontrun{ install_DevelopmentVersion() } } Luminescence/man/calc_FadingCorr.Rd0000644000176200001440000001666113125227575016751 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_FadingCorr.R \name{calc_FadingCorr} \alias{calc_FadingCorr} \title{Apply a fading correction according to Huntley & Lamothe (2001) for a given g-value and a given tc} \usage{ calc_FadingCorr(age.faded, g_value, tc = NULL, tc.g_value = tc, n.MC = 10000, seed = NULL, interval = c(0.01, 500), txtProgressBar = TRUE, verbose = TRUE) } \arguments{ \item{age.faded}{\code{\link{numeric}} \code{\link{vector}} (\bold{required}): uncorrected age with error in ka (see example)} \item{g_value}{\code{\link{vector}} (\bold{required}): g-value and error obtained from separate fading measurements (see example). Alternatively an \code{\linkS4class{RLum.Results}} object can be provided produced by the function \code{analyse_FadingMeasurement}, in this case tc is set automatically} \item{tc}{\code{\link{numeric}} (\bold{required}): time in seconds between irradiation and the prompt measurement (cf. Huntley & Lamothe 2001). Argument will be ignored if \code{g_value} was an \code{RLum.Results} object} \item{tc.g_value}{\code{\link{numeric}} (with default): the time in seconds between irradiation and the prompt measurement used for estimating the g-value. If the g-value was normalised to, e.g., 2 days, this time in seconds (i.e., 172800) should be given here. If nothing is provided the time is set to tc, which is usual case for g-values obtained using the SAR method and g-values that had been not normalised to 2 days.} \item{n.MC}{\code{\link{integer}} (with default): number of Monte Carlo simulation runs for error estimation. If \code{n.MC = 'auto'} is used the function tries to find a 'stable' error for the age. Note: This may take a while!} \item{seed}{\code{\link{integer}} (optional): sets the seed for the random number generator in R using \code{\link{set.seed}}} \item{interval}{\code{\link{numeric}} (with default): a vector containing the end-points (age interval) of the interval to be searched for the root in 'ka'. This argument is passed to the function \code{\link[stats]{uniroot}} used for solving the equation.} \item{txtProgressBar}{\link{logical} (with default): enables or disables \code{\link{txtProgressBar}}} \item{verbose}{\code{\link{logical}} (with default): enables or disables terminal output} } \value{ Returns an S4 object of type \code{\linkS4class{RLum.Results}}.\cr Slot: \bold{@data}\cr \tabular{lll}{ \bold{Object} \tab \bold{Type} \tab \bold{Comment}\cr \code{age.corr} \tab \code{data.frame} \tab Corrected age \cr \code{age.corr.MC} \tab \code{numeric} \tab MC simulation results with all possible ages from that simulation\cr } Slot: \bold{@info}\cr \tabular{lll}{ \bold{Object} \tab \bold{Type} \tab \bold{Comment}\cr \code{info} \tab \code{character} \tab the original function call } } \description{ This function solves the equation used for correcting the fading affected age including the error for a given g-value according to Huntley & Lamothe (2001). } \details{ As the g-value sligthly depends on the time between irradiation and the prompt measurement, this is tc, always a tc value needs to be provided. If the g-value was normalised to a distinct time or evaluated with a different tc value (e.g., external irradiation), also the tc value for the g-value needs to be provided (argument \code{tc.g_value} and then the g-value is recalcualted to tc of the measurement used for estimating the age applying the following equation: \deqn{\kappa_{tc} = \kappa_{tc.g} / (1 - \kappa_{tc.g} * log(tc/tc.g))} where \deqn{\kappa_{tc.g} = g / 100 / log(10)} with \eqn{log} the natural logarithm. The error of the fading-corrected age is determined using a Monte Carlo simulation approach. Solving of the equation is realised using \code{\link{uniroot}}. Large values for \code{n.MC} will significantly increase the computation time.\cr \bold{\code{n.MC = 'auto'}} The error estimation based on a stochastic process, i.e. for a small number of MC runs the calculated error varies considerably every time the function is called, even with the same input values. The argument option \code{n.MC = 'auto'} tries to find a stable value for the standard error, i.e. the standard deviation of values calculated during the MC runs (\code{age.corr.MC}), within a given precision (2 digits) by increasing the number of MC runs stepwise and calculating the corresponding error. If the determined error does not differ from the 9 values calculated previously within a precision of (here) 3 digits the calculation is stopped as it is assumed that the error is stable. Please note that (a) the duration depends on the input values as well as on the provided computation ressources and it may take a while, (b) the length (size) of the output vector \code{age.corr.MC}, where all the single values produced during the MC runs are stored, equals the number of MC runs (here termed observations). To avoid an endless loop the calculation is stopped if the number of observations exceeds 10^7. This limitation can be overwritten by setting the number of MC runs manually, e.g. \code{n.MC = 10000001}. Note: For this case the function is not checking whether the calculated error is stable.\cr \bold{\code{seed}} This option allows to recreate previously calculated results by setting the seed for the R random number generator (see \code{\link{set.seed}} for details). This option should not be mixed up with the option \bold{\code{n.MC = 'auto'}}. The results may appear similar, but they are not comparable!\cr \bold{FAQ}\cr Q: Which tc value is expected?\cr A: tc is the time in seconds between irradiation and the prompt measurement applied during your De measurement. However, this tc might differ from the tc used for estimating the g-value. In the case of an SAR measurement tc should be similar, however, if it differs, you have to provide this tc value (the one used for estimating the g-value) using the argument \code{tc.g_value}.\cr } \note{ Special thanks to Sebastien Huot for his support and clarification via e-mail. } \section{Function version}{ 0.4.2 (2017-06-29 18:40:14) } \examples{ ##run the examples given in the appendix of Huntley and Lamothe, 2001 ##(1) faded age: 100 a results <- calc_FadingCorr( age.faded = c(0.1,0), g_value = c(5.0, 1.0), tc = 2592000, tc.g_value = 172800, n.MC = 100) ##(2) faded age: 1 ka results <- calc_FadingCorr( age.faded = c(1,0), g_value = c(5.0, 1.0), tc = 2592000, tc.g_value = 172800, n.MC = 100) ##(3) faded age: 10.0 ka results <- calc_FadingCorr( age.faded = c(10,0), g_value = c(5.0, 1.0), tc = 2592000, tc.g_value = 172800, n.MC = 100) ##access the last output get_RLum(results) } \section{How to cite}{ Kreutzer, S. (2017). calc_FadingCorr(): Apply a fading correction according to Huntley & Lamothe (2001) for a given g-value and a given tc. Function version 0.4.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \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. } \seealso{ \code{\linkS4class{RLum.Results}}, \code{\link{get_RLum}}, \code{\link{uniroot}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{datagen} Luminescence/man/GitHub-API.Rd0000644000176200001440000000544113125227576015535 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/github.R \name{GitHub-API} \alias{GitHub-API} \alias{github_commits} \alias{github_branches} \alias{github_issues} \title{GitHub API} \usage{ github_commits(user = "r-lum", repo = "luminescence", branch = "master", n = 5) github_branches(user = "r-lum", repo = "luminescence") github_issues(user = "r-lum", repo = "luminescence", verbose = TRUE) } \arguments{ \item{user}{\code{\link{character}}: GitHub user name (defaults to 'r-lum').} \item{repo}{\code{\link{character}}: name of a GitHub repository (defaults to 'luminescence').} \item{branch}{\code{\link{character}}: branch of a GitHub repository (defaults to 'master').} \item{n}{\code{\link{integer}}: number of commits returned (defaults to 5).} \item{verbose}{\code{\link{logical}}: print the output to the console (defaults to \code{TRUE}).} } \value{ \code{github_commits}: \code{\link{data.frame}} with columns: \tabular{ll}{ [ ,1] \tab SHA \cr [ ,2] \tab AUTHOR \cr [ ,3] \tab DATE \cr [ ,4] \tab MESSAGE \cr } \code{github_branches}: \code{\link{data.frame}} with columns: \tabular{ll}{ [ ,1] \tab BRANCH \cr [ ,2] \tab SHA \cr [ ,3] \tab INSTALL \cr } \code{github_commits}: Nested \code{\link{list}} with \code{n} elements. Each commit element is a list with elements: \tabular{ll}{ [[1]] \tab NUMBER \cr [[2]] \tab TITLE \cr [[3]] \tab BODY \cr [[4]] \tab CREATED \cr [[5]] \tab UPDATED \cr [[6]] \tab CREATOR \cr [[7]] \tab URL \cr [[8]] \tab STATUS \cr } } \description{ R Interface to the GitHub API v3. } \details{ These functions can be used to query a specific repository hosted on GitHub. \cr \code{github_commits} lists the most recent \code{n} commits of a specific branch of a repository. \code{github_branches} can be used to list all current branches of a repository and returns the corresponding SHA hash as well as an installation command to install the branch in R via the 'devtools' package. \code{github_issues} lists all open issues for a repository in valid YAML. } \section{Function version}{ 0.1.0 } \examples{ \dontrun{ github_branches(user = "r-lum", repo = "luminescence") github_issues(user = "r-lum", repo = "luminescence") github_commits(user = "r-lum", repo = "luminescence", branch = "master", n = 10) } } \section{How to cite}{ Burow, C. (2017). GitHub-API(): GitHub API. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ GitHub Developer API v3. \url{https://developer.github.com/v3/}, last accessed: 10/01/2017. } \author{ Christoph Burow, University of Cologne (Germany) \cr R Luminescence Package Team} Luminescence/man/apply_EfficiencyCorrection.Rd0000644000176200001440000000451713125227575021247 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/apply_EfficiencyCorrection.R \name{apply_EfficiencyCorrection} \alias{apply_EfficiencyCorrection} \title{Function to apply spectral efficiency correction to RLum.Data.Spectrum S4 class objects} \usage{ apply_EfficiencyCorrection(object, spectral.efficiency) } \arguments{ \item{object}{\code{\linkS4class{RLum.Data.Spectrum}} (\bold{required}): S4 object of class \code{RLum.Data.Spectrum}} \item{spectral.efficiency}{\code{\link{data.frame}} (\bold{required}): Data set containing wavelengths (x-column) and relative spectral response values (y-column) in percentage} } \value{ Returns same object as input (\code{\linkS4class{RLum.Data.Spectrum}}) } \description{ The function allows spectral efficiency corrections for RLum.Data.Spectrum S4 class objects } \details{ The efficiency correction is based on a spectral response dataset provided by the user. Usually the data set for the quantum efficiency is of lower resolution and values are interpolated for the required spectral resolution using the function \code{\link[stats]{approx}} If the energy calibration differes for both data set \code{NA} values are produces that will be removed from the matrix. } \note{ Please note that the spectral efficiency data from the camera alone may not sufficiently correct for spectral efficiency of the entire optical system (e.g., spectrometer, camera ...). } \section{Function version}{ 0.1.1 (2017-06-29 18:40:14) } \examples{ ##(1) - use with your own data (uncomment for usage) ## spectral.efficiency <- read.csv("your data") ## ## your.spectrum <- apply_EfficiencyCorrection(your.spectrum, ) } \section{How to cite}{ Kreutzer, S., Friedrich, J. (2017). apply_EfficiencyCorrection(): Function to apply spectral efficiency correction to RLum.Data.Spectrum S4 class objects. Function version 0.1.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ - } \seealso{ \code{\linkS4class{RLum.Data.Spectrum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France),\cr Johannes Friedrich, University of Bayreuth (Germany) \cr R Luminescence Package Team} \keyword{manip} Luminescence/man/PSL2Risoe.BINfileData.Rd0000644000176200001440000000407613125227576017532 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/PSL2Risoe.BINfileData.R \name{PSL2Risoe.BINfileData} \alias{PSL2Risoe.BINfileData} \title{Convert portable OSL data to an Risoe.BINfileData object} \usage{ PSL2Risoe.BINfileData(object, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Analysis}} (\bold{required}): \code{RLum.Analysis} object produced by \code{\link{read_PSL2R}}} \item{...}{currently not used.} } \value{ Returns an S4 \code{\linkS4class{Risoe.BINfileData}} object that can be used to write a BIN file using \code{\link{write_R2BIN}}. } \description{ Converts an \code{RLum.Analysis} object produced by the function \code{read_PSL2R()} to an \code{Risoe.BINfileData} object \bold{(BETA)}. } \details{ This function converts an \code{\linkS4class{RLum.Analysis}} object that was produced by the \code{\link{read_PSL2R}} function to an \code{\linkS4class{Risoe.BINfileData}}. The \code{Risoe.BINfileData} can be used to write a Risoe BIN file via \code{\link{write_R2BIN}}. } \section{Function version}{ 0.0.1 (2017-06-29 18:40:14) } \examples{ # (1) load and plot example data set data("ExampleData.portableOSL", envir = environment()) plot_RLum(ExampleData.portableOSL) # (2) merge all RLum.Analysis objects into one merged <- merge_RLum(ExampleData.portableOSL) merged # (3) convert to RisoeBINfile object bin <- PSL2Risoe.BINfileData(merged) bin # (4) write Risoe BIN file \dontrun{ write_R2BIN(bin, "~/portableOSL.binx") } } \seealso{ \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{Risoe.BINfileData}} } \author{ Christoph Burow, University of Cologne (Germany) \cr R Luminescence Package Team} \section{How to cite}{ Burow, C. (2017). PSL2Risoe.BINfileData(): Convert portable OSL data to an Risoe.BINfileData object. Function version 0.0.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{IO} Luminescence/man/analyse_SAR.TL.Rd0000644000176200001440000001203713125227575016421 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/analyse_SAR.TL.R \name{analyse_SAR.TL} \alias{analyse_SAR.TL} \title{Analyse SAR TL measurements} \usage{ analyse_SAR.TL(object, object.background, signal.integral.min, signal.integral.max, integral_input = "channel", sequence.structure = c("PREHEAT", "SIGNAL", "BACKGROUND"), rejection.criteria = list(recycling.ratio = 10, recuperation.rate = 10), dose.points, log = "", ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Analysis}}(\bold{required}): input object containing data for analysis} \item{object.background}{currently not used} \item{signal.integral.min}{\link{integer} (\bold{required}): requires the channel number for the lower signal integral bound (e.g. \code{signal.integral.min = 100})} \item{signal.integral.max}{\link{integer} (\bold{required}): requires the channel number for the upper signal integral bound (e.g. \code{signal.integral.max = 200})} \item{integral_input}{\code{\link{character}} (with default): defines the input for the the arguments \code{signal.integral.min} and \code{signal.integral.max}. These limits can be either provided \code{'channel'} number (the default) or \code{'temperature'}. If \code{'temperature'} is chosen the best matching channel is selected.} \item{sequence.structure}{\link{vector} \link{character} (with default): specifies the general sequence structure. Three steps are allowed ( \code{"PREHEAT"}, \code{"SIGNAL"}, \code{"BACKGROUND"}), in addition a parameter \code{"EXCLUDE"}. This allows excluding TL curves which are not relevant for the protocol analysis. (Note: None TL are removed by default)} \item{rejection.criteria}{\link{list} (with default): list containing rejection criteria in percentage for the calculation.} \item{dose.points}{\code{\link{numeric}} (optional): option set dose points manually} \item{log}{\link{character} (with default): a character string which contains "x" if the x axis is to be logarithmic, "y" if the y axis is to be logarithmic and "xy" or "yx" if both axes are to be logarithmic. See \link{plot.default}).} \item{\dots}{further arguments that will be passed to the function \code{\link{plot_GrowthCurve}}} } \value{ A plot (optional) and an \code{\linkS4class{RLum.Results}} object is returned containing the following elements: \item{De.values}{\link{data.frame} containing De-values and further parameters} \item{LnLxTnTx.values}{\link{data.frame} of all calculated Lx/Tx values including signal, background counts and the dose points.} \item{rejection.criteria}{\link{data.frame} with values that might by used as rejection criteria. NA is produced if no R0 dose point exists.}\cr\cr \bold{note:} the output should be accessed using the function \code{\link{get_RLum}} } \description{ The function performs a SAR TL analysis on a \code{\linkS4class{RLum.Analysis}} object including growth curve fitting. } \details{ This function performs a SAR TL analysis on a set of curves. The SAR procedure in general is given by Murray and Wintle (2000). For the calculation of the Lx/Tx value the function \link{calc_TLLxTxRatio} is used.\cr\cr \bold{Provided rejection criteria}\cr\cr \sQuote{recyling.ratio}: calculated for every repeated regeneration dose point.\cr \sQuote{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)\cr } \note{ \bold{THIS IS A BETA VERSION}\cr\cr None TL curves will be removed from the input object without further warning. } \section{Function version}{ 0.2.0 (2017-06-29 18:40:14) } \examples{ ##load data data(ExampleData.BINfileData, envir = environment()) ##transform the values from the first position in a RLum.Analysis object object <- Risoe.BINfileData2RLum.Analysis(TL.SAR.Data, pos=3) ##perform analysis analyse_SAR.TL(object, signal.integral.min = 210, signal.integral.max = 220, log = "y", fit.method = "EXP OR LIN", sequence.structure = c("SIGNAL", "BACKGROUND")) } \section{How to cite}{ Kreutzer, S. (2017). analyse_SAR.TL(): Analyse SAR TL measurements. Function version 0.2.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Aitken, M.J. and Smith, B.W., 1988. Optical dating: recuperation after bleaching. Quaternary Science Reviews 7, 387-393. 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. } \seealso{ \code{\link{calc_TLLxTxRatio}}, \code{\link{plot_GrowthCurve}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}} \code{\link{get_RLum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{datagen} \keyword{plot} Luminescence/man/analyse_baSAR.Rd0000644000176200001440000005022113125227575016403 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/analyse_baSAR.R \name{analyse_baSAR} \alias{analyse_baSAR} \title{Bayesian models (baSAR) applied on luminescence data} \usage{ analyse_baSAR(object, XLS_file = NULL, aliquot_range = NULL, source_doserate = NULL, signal.integral, signal.integral.Tx = NULL, background.integral, background.integral.Tx = NULL, sigmab = 0, sig0 = 0.025, distribution = "cauchy", baSAR_model = NULL, n.MCMC = 1e+05, fit.method = "EXP", fit.force_through_origin = TRUE, fit.includingRepeatedRegPoints = TRUE, method_control = list(), digits = 3L, plot = TRUE, plot_reduced = TRUE, plot.single = FALSE, verbose = TRUE, ...) } \arguments{ \item{object}{\code{\linkS4class{Risoe.BINfileData}} or \code{\linkS4class{RLum.Results}} or \code{\link{character}} or \code{\link{list}} (\bold{required}): input object used for the Bayesian analysis. If a \code{character} is provided the function assumes a file connection and tries to import a BIN-file using the provided path. If a \code{list} is provided the list can only contain either \code{Risoe.BINfileData} objects or \code{character}s providing a file connection. Mixing of both types is not allowed. If an \code{\linkS4class{RLum.Results}} is provided the function directly starts with the Bayesian Analysis (see details)} \item{XLS_file}{\code{\link{character}} (optional): XLS_file with data for the analysis. This file must contain 3 columns: the name of the file, the disc position and the grain position (the last being 0 for multi-grain measurements). Alternatively a \code{data.frame} of similar structure can be provided.} \item{aliquot_range}{\code{\link{numeric}} (optional): allows to limit the range of the aliquots used for the analysis. This argument has only an effect if the argument \code{XLS_file} is used or the input is the previous output (i.e. is \code{\linkS4class{RLum.Results}}). In this case the new selection will add the aliquots to the removed aliquots table.} \item{source_doserate}{\code{\link{numeric}} \bold{(required)}: source dose rate of beta-source used for the measuremnt and its uncertainty in Gy/s, e.g., \code{source_doserate = c(0.12, 0.04)}. Paramater can be provided as \code{list}, for the case that more than one BIN-file is provided, e.g., \code{source_doserate = list(c(0.04, 0.004), c(0.05, 0.004))}.} \item{signal.integral}{\code{\link{vector}} (\bold{required}): vector with the limits for the signal integral used for the calculation, e.g., \code{signal.integral = c(1:5)} Ignored if \code{object} is an \code{\linkS4class{RLum.Results}} object. The parameter can be provided as \code{list}, \code{source_doserate}.} \item{signal.integral.Tx}{\code{\link{vector}} (optional): vector with the limits for the signal integral for the Tx curve. If nothing is provided the value from \code{signal.integral} is used and it is ignored if \code{object} is an \code{\linkS4class{RLum.Results}} object. The parameter can be provided as \code{list}, see \code{source_doserate}.} \item{background.integral}{\code{\link{vector}} (\bold{required}): vector with the bounds for the background integral. Ignored if \code{object} is an \code{\linkS4class{RLum.Results}} object. The parameter can be provided as \code{list}, see \code{source_doserate}.} \item{background.integral.Tx}{\code{\link{vector}} (optional): vector with the limits for the background integral for the Tx curve. If nothing is provided the value from \code{background.integral} is used. Ignored if \code{object} is an \code{\linkS4class{RLum.Results}} object. The parameter can be provided as \code{list}, see \code{source_doserate}.} \item{sigmab}{\code{\link{numeric}} (with default): option to set a manual value for the overdispersion (for LnTx and TnTx), used for the Lx/Tx error calculation. The value should be provided as absolute squared count values, cf. \code{\link{calc_OSLLxTxRatio}}. The parameter can be provided as \code{list}, see \code{source_doserate}.} \item{sig0}{\code{\link{numeric}} (with default): allow adding an extra component of error to the final Lx/Tx error value (e.g., instrumental errror, see details is \code{\link{calc_OSLLxTxRatio}}). The parameter can be provided as \code{list}, see \code{source_doserate}.} \item{distribution}{\code{\link{character}} (with default): type of distribution that is used during Bayesian calculations for determining the Central dose and overdispersion values. Allowed inputs are \code{"cauchy"}, \code{"normal"} and \code{"log_normal"}.} \item{baSAR_model}{\code{\link{character}} (optional): option to provide an own modified or new model for the Bayesian calculation (see details). If an own model is provided the argument \code{distribution} is ignored and set to \code{'user_defined'}} \item{n.MCMC}{\code{\link{integer}} (with default): number of iterations for the Markov chain Monte Carlo (MCMC) simulations} \item{fit.method}{\code{\link{character}} (with default): fit method used for fitting the growth curve using the function \code{\link{plot_GrowthCurve}}. Here supported methods: \code{EXP}, \code{EXP+LIN} and \code{LIN}} \item{fit.force_through_origin}{\code{\link{logical}} (with default): force fitting through origin} \item{fit.includingRepeatedRegPoints}{\code{\link{logical}} (with default): includes the recycling point (assumed to be measured during the last cycle)} \item{method_control}{\code{\link{list}} (optional): named list of control parameters that can be directly passed to the Bayesian analysis, e.g., \code{method_control = list(n.chains = 4)}. See details for further information} \item{digits}{\code{\link{integer}} (with default): round output to the number of given digits} \item{plot}{\code{\link{logical}} (with default): enables or disables plot output} \item{plot_reduced}{\code{\link{logical}} (with default): enables or disables the advanced plot output} \item{plot.single}{\code{\link{logical}} (with default): enables or disables single plots or plots arranged by analyse_baSAR} \item{verbose}{\code{\link{logical}} (with default): enables or disables verbose mode} \item{...}{parameters that can be passed to the function \code{\link{calc_OSLLxTxRatio}} (almost full support) \code{\link[readxl]{read_excel}} (full support), \code{\link{read_BIN2R}} (\code{n.records}, \code{position}, \code{duplicated.rm}), see details.} } \value{ Function returns results numerically and graphically:\cr -----------------------------------\cr [ NUMERICAL OUTPUT ]\cr -----------------------------------\cr \bold{\code{RLum.Reuslts}}-object\cr \bold{slot:} \bold{\code{@data}}\cr \tabular{lll}{ \bold{Element} \tab \bold{Type} \tab \bold{Description}\cr \code{$summary} \tab \code{data.frame} \tab statistical summary, including the central dose \cr \code{$mcmc} \tab \code{mcmc} \tab object including raw output of \code{\link[rjags]{rjags}} \cr \code{$models} \tab \code{character} \tab implemented models used in the baSAR-model core \cr \code{$input_object} \tab \code{data.frame} \tab summarising table (same format as the XLS-file) including, e.g., Lx/Tx values\cr \code{$removed_aliquots} \tab \code{data.frame} \tab table with removed aliquots (e.g., NaN, or Inf Lx/Tx values). If nothing was removed \code{NULL} is returned } \bold{slot:} \bold{\code{@info}}\cr The original function call\cr ------------------------\cr [ PLOT OUTPUT ]\cr ------------------------\cr \itemize{ \item (A) Ln/Tn curves with set integration limits, \item (B) trace plots are returned by the baSAR-model, showing the convergence of the parameters (trace) and the resulting kernel density plots. If \code{plot_reduced = FALSE} for every(!) dose a trace and a density plot is returned (this may take a long time), \item (C) dose plots showing the dose for every aliquot as boxplots and the marked HPD in within. If boxes are coloured 'orange' or 'red' the aliquot itself should be checked, \item (D) the dose response curve resulting from the monitoring of the Bayesian modelling are provided along with the Lx/Tx values and the HPD. Note: The amount for curves displayed is limited to 1000 (random choice) for performance reasons, \item (E) the final plot is the De distribution as calculated using the conventional approach and the central dose with the HPDs marked within. } \bold{Please note: If distribution was set to \code{log_normal} the central dose is given as geometric mean!} } \description{ This function allows the application of Bayesian models on luminescence data, measured with the single-aliquot regenerative-dose (SAR, Murray and Wintle, 2000) protocol. In particular, it follows the idea proposed by Combes et al., 2015 of using an hierarchical model for estimating a central equivalent dose from a set of luminescence measurements. This function is (I) the adaption of this approach for the R environment and (II) an extension and a technical refinement of the published code.\cr } \details{ Internally the function consists of two parts: (I) The Bayesian core for the Bayesian calculations and applying the hierchical model and (II) a data pre-processing part. The Bayesian core can be run independently, if the input data are sufficient (see below). The data pre-processing part was implemented to simplify the analysis for the user as all needed data pre-processing is done by the function, i.e. in theory it is enough to provide a BIN/BINX-file with the SAR measurement data. For the Bayesian analysis for each aliquot the following information are needed from the SAR analysis. LxTx, the LxTx error and the dose values for all regeneration points. \bold{How the systematic error contribution is calculated?}\cr Standard errors (so far) provided with the source dose rate are considered as systematic uncertainties and added to final central dose by: \deqn{systematic.error = 1/n \sum SE(source.doserate)} \deqn{SE(central.dose.final) = \sqrt{SE(central.dose)^2 + systematic.error^2}} Please note that this approach is rather rough and can only be valid if the source dose rate errors, in case different readers had been used, are similar. In cases where more than one source dose rate is provided a warning is given.\cr \bold{Input / output scenarios}\cr Various inputs are allowed for this function. Unfortunately this makes the function handling rather complex, but at the same time very powerful. Available scenarios:\cr \bold{(1) - \code{object} is BIN-file or link to a BIN-file} Finally it does not matter how the information of the BIN/BINX file are provided. The function supports (a) either a path to a file or directory or a \code{list} of file names or paths or (b) a \code{\linkS4class{Risoe.BINfileData}} object or a list of these objects. The latter one can be produced by using the function \code{\link{read_BIN2R}}, but this function is called automatically if only a filename and/or a path is provided. In both cases it will become the data that can be used for the analysis. \code{[XLS_file = NULL]}\cr If no XLS file (or data frame with the same format) is provided the functions runs an automatic process that consists of the following steps: \itemize{ \item Select all valid aliquots using the function \code{\link{verify_SingleGrainData}} \item Calculate Lx/Tx values using the function \code{\link{calc_OSLLxTxRatio}} \item Calculate De values using the function \code{\link{plot_GrowthCurve}} } These proceeded data are subsequently used in for the Bayesian analysis \code{[XLS_file != NULL]}\cr If an XLS-file is provided or a \code{data.frame} providing similar information the pre-processing steps consists of the following steps: \itemize{ \item Calculate Lx/Tx values using the function \code{\link{calc_OSLLxTxRatio}} \item Calculate De values using the function \code{\link{plot_GrowthCurve}} } Means, the XLS file should contain a selection of the BIN-file names and the aliquots selected for the further analysis. This allows a manual selection of input data, as the automatic selection by \code{\link{verify_SingleGrainData}} might be not totally sufficient.\cr \bold{(2) - \code{object} \code{RLum.Results object}} If an \code{\linkS4class{RLum.Results}} object is provided as input and(!) this object was previously created by the function \code{analyse_baSAR()} itself, the pre-processing part is skipped and the function starts directly the Bayesian analysis. This option is very powerful as it allows to change parameters for the Bayesian analysis without the need to repeat the data pre-processing. If furthermore the argument \code{aliquot_range} is set, aliquots can be manually excluded based on previous runs. \cr \bold{\code{method_control}}\cr These are arguments that can be passed directly to the Bayesian calculation core, supported arguments are: \tabular{lll}{ \bold{Parameter} \tab \bold{Type} \tab \bold{Descritpion}\cr \code{lower_centralD} \tab \code{\link{numeric}} \tab sets the lower bound for the expected De range. Change it only if you know what you are doing!\cr \code{upper_centralD} \tab \code{\link{numeric}} \tab sets the upper bound for the expected De range. Change it only if you know what you are doing!\cr \code{n.chains} \tab \code{\link{integer}} \tab sets number of parallel chains for the model (default = 3) (cf. \code{\link[rjags]{jags.model}})\cr \code{inits} \tab \code{\link{list}} \tab option to set initialisation values (cf. \code{\link[rjags]{jags.model}}) \cr \code{thin} \tab \code{\link{numeric}} \tab thinning interval for monitoring the Bayesian process (cf. \code{\link[rjags]{jags.model}})\cr \code{variable.names} \tab \code{\link{character}} \tab set the variables to be monitored during the MCMC run, default: \code{'central_D'}, \code{'sigma_D'}, \code{'D'}, \code{'Q'}, \code{'a'}, \code{'b'}, \code{'c'}, \code{'g'}. Note: only variables present in the model can be monitored. } \bold{User defined models}\cr The function provides the option to modify and to define own models that can be used for the Bayesian calculation. In the case the user wants to modify a model, a new model can be piped into the funtion via the argument \code{baSAR_model} as \code{character}. The model has to be provided in the JAGS dialect of the BUGS language (cf. \code{\link[rjags]{jags.model}}) and parameter names given with the pre-defined names have to be respected, otherwise the function will break.\cr \bold{FAQ}\cr Q: How can I set the seed for the random number generator (RNG)?\cr A: Use the argument \code{method_control}, e.g., for three MCMC chains (as it is the default):\cr \code{method_control = list( inits = list( list(.RNG.name = "base::Wichmann-Hill", .RNG.seed = 1), list(.RNG.name = "base::Wichmann-Hill", .RNG.seed = 2), list(.RNG.name = "base::Wichmann-Hill", .RNG.seed = 3) ))}\cr This sets a reproducible set for every chain separately.\cr Q: How can I modify the output plots?\cr A: You can't, but you can use the function output to create own, modified plots.\cr Q: Can I change the boundaries for the central_D?\cr A: Yes, we made it possible, but we DO NOT recommend it, except you know what you are doing! Example: \code{method_control = list(lower_centralD = 10))}\cr \bold{Additional arguments support via the \code{...} argument }\cr This list summarizes the additional arguments that can be passed to the internally used functions. \tabular{llll}{ \bold{Supported argument} \tab \bold{Corresponding function} \tab \bold{Default} \tab \bold{Short description }\cr \code{threshold} \tab \code{\link{verify_SingleGrainData}} \tab \code{30} \tab change rejection threshold for curve selection \cr \code{sheet} \tab \code{\link[readxl]{read_excel}} \tab \code{1} \tab select XLS-sheet for import\cr \code{col_names} \tab \code{\link[readxl]{read_excel}} \tab \code{TRUE} \tab first row in XLS-file is header\cr \code{col_types} \tab \code{\link[readxl]{read_excel}} \tab \code{NULL} \tab limit import to specific columns\cr \code{skip} \tab \code{\link[readxl]{read_excel}} \tab \code{0} \tab number of rows to be skipped during import\cr \code{n.records} \tab \code{\link{read_BIN2R}} \tab \code{NULL} \tab limit records during BIN-file import\cr \code{duplicated.rm} \tab \code{\link{read_BIN2R}} \tab \code{TRUE} \tab remove duplicated records in the BIN-file\cr \code{pattern} \tab \code{\link{read_BIN2R}} \tab \code{TRUE} \tab select BIN-file by name pattern\cr \code{position} \tab \code{\link{read_BIN2R}} \tab \code{NULL} \tab limit import to a specific position\cr \code{background.count.distribution} \tab \code{\link{calc_OSLLxTxRatio}} \tab \code{"non-poisson"} \tab set assumed count distribution\cr \code{fit.weights} \tab \code{\link{plot_GrowthCurve}} \tab \code{TRUE} \tab enables / disables fit weights\cr \code{fit.bounds} \tab \code{\link{plot_GrowthCurve}} \tab \code{TRUE} \tab enables / disables fit bounds\cr \code{NumberIterations.MC} \tab \code{\link{plot_GrowthCurve}} \tab \code{100} \tab number of MC runs for error calculation\cr \code{output.plot} \tab \code{\link{plot_GrowthCurve}} \tab \code{TRUE} \tab enables / disables dose response curve plot\cr \code{output.plotExtended} \tab \code{\link{plot_GrowthCurve}} \tab \code{TRUE} \tab enables / disables extended dose response curve plot\cr } } \note{ \bold{If you provide more than one BIN-file}, it is \bold{strongly} recommanded to provide a \code{list} with the same number of elements for the following parameters:\cr \code{source_doserate}, \code{signal.integral}, \code{signal.integral.Tx}, \code{background.integral}, \code{background.integral.Tx}, \code{sigmab}, \code{sig0}.\cr Example for two BIN-files: \code{source_doserate = list(c(0.04, 0.006), c(0.05, 0.006))}\cr \bold{The function is currently limited to work with standard Risoe BIN-files only!} } \section{Function version}{ 0.1.29 (2017-06-29 18:40:14) } \examples{ ##(1) load package test data set data(ExampleData.BINfileData, envir = environment()) ##(2) selecting relevant curves, and limit dataset CWOSL.SAR.Data <- subset( CWOSL.SAR.Data, subset = POSITION\%in\%c(1:3) & LTYPE == "OSL") \dontrun{ ##(3) run analysis ##please not that the here selected parameters are ##choosen for performance, not for reliability results <- analyse_baSAR( object = CWOSL.SAR.Data, source_doserate = c(0.04, 0.001), signal.integral = c(1:2), background.integral = c(80:100), fit.method = "LIN", plot = FALSE, n.MCMC = 200 ) print(results) ##XLS_file template ##copy and paste this the code below in the terminal ##you can further use the function write.csv() to export the example XLS_file <- structure( list( BIN_FILE = NA_character_, DISC = NA_real_, GRAIN = NA_real_), .Names = c("BIN_FILE", "DISC", "GRAIN"), class = "data.frame", row.names = 1L ) } } \section{How to cite}{ Mercier, N., Kreutzer, S. (2017). analyse_baSAR(): Bayesian models (baSAR) applied on luminescence data. Function version 0.1.29. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Combes, B., Philippe, A., Lanos, P., Mercier, N., Tribolo, C., Guerin, G., Guibert, P., Lahaye, C., 2015. A Bayesian central equivalent dose model for optically stimulated luminescence dating. Quaternary Geochronology 28, 62-70. doi:10.1016/j.quageo.2015.04.001 Mercier, N., Kreutzer, S., Christophe, C., Guerin, G., Guibert, P., Lahaye, C., Lanos, P., Philippe, A., Tribolo, C., 2016. Bayesian statistics in luminescence dating: The 'baSAR'-model and its implementation in the R package 'Luminescence'. Ancient TL 34, 14-21. \bold{Further reading} Gelman, A., Carlin, J.B., Stern, H.S., Dunson, D.B., Vehtari, A., Rubin, D.B., 2013. Bayesian Data Analysis, Third Edition. CRC Press. 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 } \seealso{ \code{\link{read_BIN2R}}, \code{\link{calc_OSLLxTxRatio}}, \code{\link{plot_GrowthCurve}}, \code{\link[readxl]{read_excel}}, \code{\link{verify_SingleGrainData}}, \code{\link[rjags]{jags.model}}, \code{\link[rjags]{coda.samples}}, \code{\link{boxplot.default}} } \author{ Norbert Mercier, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France), Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr The underlying Bayesian model based on a contribution by Combes et al., 2015. \cr R Luminescence Package Team} \keyword{datagen} Luminescence/man/calc_gSGC.Rd0000644000176200001440000000667713125227575015524 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_gSGC.R \name{calc_gSGC} \alias{calc_gSGC} \title{Calculate De value based on the gSGC by Li et al., 2015} \usage{ calc_gSGC(data, gSGC.type = "0-250", gSGC.parameters, n.MC = 100, verbose = TRUE, plot = TRUE, ...) } \arguments{ \item{data}{\code{\link{data.frame}} (\bold{required}): input data of providing the following columns: 'LnTn', 'LnTn.error', Lr1Tr1', 'Lr1Tr1.error', 'Dr1' Note: column names are not required. The function expect the input data in the given order} \item{gSGC.type}{\code{\link{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: \code{"0-450"} and \code{"0-250"}} \item{gSGC.parameters}{\code{\link{list}} (optional): option to provide own function parameters used for #' fitting as named list. Nomenclature follows Li et al., 2015, i.e. \code{list(A,A.error,D0,D0.error,c,c.error,Y0,Y0.error,range)}, range requires a vector for the range the function is considered as valid, e.g. \code{range = c(0,250)}\cr Using this option overwrites the default parameter list of the gSGC, meaning the argument \code{gSGC.type} will be without effect} \item{n.MC}{\code{\link{integer}} (with default): number of Monte Carlo simulation runs for error estimation, s. details.} \item{verbose}{\code{\link{logical}}: enable or disable terminal output} \item{plot}{\code{\link{logical}}: enable or disable graphical feedback as plot} \item{...}{parameters will be passed to the plot output} } \value{ Returns an S4 object of type \code{\linkS4class{RLum.Results}}.\cr \bold{@data}\cr $ De.value (data.frame) \cr .. $ De \cr .. $ De.error \cr .. $ Eta \cr $ De.MC (list) contains the matricies from the error estimation.\cr $ uniroot (list) contains the uniroot outputs of the De estimations\cr \bold{@info}\cr $ call (call) the original function call } \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 \code{\link{uniroot}}. Large values for \code{n.MC} will significantly increase the computation time. } \section{Function version}{ 0.1.1 (2017-06-29 18:40:14) } \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") } \section{How to cite}{ Kreutzer, S. (2017). calc_gSGC(): Calculate De value based on the gSGC by Li et al., 2015. Function version 0.1.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \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 } \seealso{ \code{\linkS4class{RLum.Results}}, \code{\link{get_RLum}}, \code{\link{uniroot}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montagine (France)\cr \cr R Luminescence Package Team} \keyword{datagen} Luminescence/man/calc_ThermalLifetime.Rd0000644000176200001440000001271413125227576020002 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_ThermalLifetime.R \name{calc_ThermalLifetime} \alias{calc_ThermalLifetime} \title{Calculates the Thermal Lifetime using the Arrhenius equation} \usage{ calc_ThermalLifetime(E, s, T = 20, output_unit = "Ma", profiling = FALSE, profiling_config = NULL, verbose = TRUE, plot = TRUE, ...) } \arguments{ \item{E}{\code{\link{numeric}} (\bold{required}): vector of trap depths in eV, if \code{profiling = TRUE} only the first two elements are considered} \item{s}{\code{\link{numeric}} (\bold{required}): vector of frequency factor in 1/s, if \code{profiling = TRUE} only the first two elements are considered} \item{T}{\code{\link{numeric}} (with default): temperature in deg. C for which the lifetime(s) will be calculted. A vector can be provided.} \item{output_unit}{\code{\link{character}} (with default): output unit of the calculated lifetimes, accepted entries are: \code{"Ma"}, \code{"ka"}, \code{"a"}, \code{"d"}, \code{"h"}, \code{"min"}, \code{"s"}} \item{profiling}{\code{\link{logical}} (with default): this option allows to estimate uncertainties based on given E and s parameters and their corresponding standard error (cf. details and examples section)} \item{profiling_config}{\code{\link{list}} (optional): allows to set configurate parameters used for the profiling (and only have an effect here). Supported parameters are: \code{n} (number of MC runs), \code{E.distribution} (distribution used for the resampling for E) and \code{s.distribution} (distribution used for the resampling for s). Currently only the normal distribution is supported (e.g., \code{profiling_config = list(E.distribution = "norm")}} \item{verbose}{\code{\link{logical}}: enables/disables verbose mode} \item{plot}{\code{\link{logical}}: enables/disables output plot, currenlty only in combination with \code{profiling = TRUE}.} \item{\dots}{further arguments that can be passed in combination with the plot output. Standard plot parameters are supported (\code{\link{plot.default}})} } \value{ A \code{\linkS4class{RLum.Results}} object is returned a along with a plot (for \code{profiling = TRUE}). The output object contain the following slots: \bold{\code{@data}}\cr \tabular{lll}{ \bold{Object} \tab \bold{Type} \tab \bold{Description} \cr \code{lifetimes} \tab \code{\link{array}} or \code{\link{numeric}} \tab calculated lifetimes \cr \code{profiling_matrix} \tab \code{\link{matrix}} \tab profiling matrix used for the MC runs } \bold{\code{@info}}\cr \tabular{lll}{ \bold{Object} \tab \bold{Type} \tab \bold{Description} \cr \code{call} \tab \code{call} \tab the original function call } } \description{ The function calculates the thermal lifetime of charges for given E (in eV), s (in 1/s) and T (in deg. C.) parameters. The function can be used in two operational modes:\cr } \details{ \bold{Mode 1 \code{(profiling = FALSE)}} An arbitrary set of input parameters (E, s, T) can be provided and the function calculates the thermal lifetimes using the Arrhenius equation for all possible combinations of these input parameters. An array with 3-dimensions is returned that can be used for further analyses or graphical output (see example 1) \bold{Mode 2 \code{(profiling = TRUE)}} This mode tries to profile the variation of the thermal lifetime for a chosen temperature by accounting for the provided E and s parameters and their corresponding standard errors, e.g., \code{E = c(1.600, 0.001)} The calculation based on a Monte Carlo simulation, where values are sampled from a normal distribution (for E and s).\cr \bold{Used equation (Arrhenius equation)}\cr \deqn{\tau = 1/s exp(E/kT)} where: \eqn{\tau} in s as the mean time an electron spends in the trap for a given \eqn{T}, \eqn{E} trap depth in eV, \eqn{s} the frequency factor in 1/s, \eqn{T} the temperature in K and \eqn{k} the Boltzmann constant in eV/K (cf. Furetta, 2010). } \note{ The profiling is currently based on resampling from a normal distribution, this distribution assumption might be, however, not valid for given E and s paramters. } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \examples{ ##EXAMPLE 1 ##calculation for two trap-depths with similar frequency factor for different temperatures E <- c(1.66, 1.70) s <- 1e+13 T <- 10:20 temp <- calc_ThermalLifetime( E = E, s = s, T = T, output_unit = "Ma" ) contour(x = E, y = T, z = temp$lifetimes[1,,], ylab = "Temperature [\\u00B0C]", xlab = "Trap depth [eV]", main = "Thermal Lifetime Contour Plot" ) mtext(side = 3, "(values quoted in Ma)") ##EXAMPLE 2 ##profiling of thermal life time for E and s and their standard error E <- c(1.600, 0.003) s <- c(1e+13,1e+011) T <- 20 calc_ThermalLifetime( E = E, s = s, T = T, profiling = TRUE, output_unit = "Ma" ) } \section{How to cite}{ Kreutzer, S. (2017). calc_ThermalLifetime(): Calculates the Thermal Lifetime using the Arrhenius equation. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Furetta, C., 2010. Handbook of Thermoluminescence, Second Edition. ed. World Scientific. } \seealso{ \code{\link[graphics]{matplot}}, \code{\link[stats]{rnorm}}, \code{\link{get_RLum}}, } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{datagen} Luminescence/man/plot_KDE.Rd0000644000176200001440000001604013125227576015402 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_KDE.R \name{plot_KDE} \alias{plot_KDE} \title{Plot kernel density estimate with statistics} \usage{ plot_KDE(data, na.rm = TRUE, values.cumulative = TRUE, order = TRUE, boxplot = TRUE, rug = TRUE, summary, summary.pos, summary.method = "MCM", bw = "nrd0", output = TRUE, ...) } \arguments{ \item{data}{\code{\link{data.frame}} or \code{\linkS4class{RLum.Results}} object (required): for \code{data.frame}: two columns: De (\code{values[,1]}) and De error (\code{values[,2]}). For plotting multiple data sets, these must be provided as \code{list} (e.g. \code{list(dataset1, dataset2)}).} \item{na.rm}{\code{\link{logical}} (with default): exclude NA values from the data set prior to any further operation.} \item{values.cumulative}{\code{\link{logical}} (with default): show cumulative individual data.} \item{order}{\code{\link{logical}}: Order data in ascending order.} \item{boxplot}{\code{\link{logical}} (with default): optionally show a boxplot (depicting median as thick central line, first and third quartile as box limits, whiskers denoting +/- 1.5 interquartile ranges and dots further outliers).} \item{rug}{\code{\link{logical}} (with default): optionally add rug.} \item{summary}{\code{\link{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.} \item{summary.pos}{\code{\link{numeric}} or \code{\link{character}} (with default): optional position coordinates or keyword (e.g. \code{"topright"}) for the statistical summary. Alternatively, the keyword \code{"sub"} may be specified to place the summary below the plot header. However, this latter option in only possible if \code{mtext} is not used. In case of coordinate specification, y-coordinate refers to the right y-axis.} \item{summary.method}{\code{\link{character}} (with default): keyword indicating the method used to calculate the statistic summary. One out of \code{"unweighted"}, \code{"weighted"} and \code{"MCM"}. See \code{\link{calc_Statistics}} for details.} \item{bw}{\code{\link{character}} (with default): bin-width, chose a numeric value for manual setting.} \item{output}{\code{\link{logical}}: Optional output of numerical plot parameters. These can be useful to reproduce similar plots. Default is \code{TRUE}.} \item{\dots}{further arguments and graphical parameters passed to \code{\link{plot}}.} } \description{ Plot a kernel density estimate of measurement values in combination with the actual values and associated error bars in ascending order. If enabled, the boxplot will show the usual distribution parameters (median as bold line, box delimited by the first and third quartile, whiskers defined by the extremes and outliers shown as points) and also the mean and standard deviation as pale bold line and pale polygon, respectively. } \details{ The function allows passing several plot arguments, such as \code{main}, \code{xlab}, \code{cex}. However, as the figure is an overlay of two separate plots, \code{ylim} must be specified in the order: c(ymin_axis1, ymax_axis1, ymin_axis2, ymax_axis2) when using the cumulative values plot option. See examples for some further explanations. For details on the calculation of the bin-width (parameter \code{bw}) see \code{\link{density}}.\cr\cr 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: \itemize{ \item \code{"n"} (number of samples) \item \code{"mean"} (mean De value) \item \code{"median"} (median of the De values) \item \code{"sd.rel"} (relative standard deviation in percent) \item \code{"sd.abs"} (absolute standard deviation) \item \code{"se.rel"} (relative standard error) \item \code{"se.abs"} (absolute standard error) \item \code{"in.2s"} (percent of samples in 2-sigma range) \item \code{"kurtosis"} (kurtosis) \item \code{"skewness"} (skewness) } Note that the input data for the statistic summary is sent to the function \code{calc_Statistics()} depending on the log-option for the z-scale. If \code{"log.z = TRUE"}, the summary is based on the logarithms of the input data. If \code{"log.z = FALSE"} the linearly scaled data is used. \cr Note as well, that \code{"calc_Statistics()"} calculates these statistic measures in three different ways: \code{unweighted}, \code{weighted} and \code{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 \code{summary.method}.\cr\cr } \note{ The plot output is no 'probability density' plot (cf. the discussion of Berger and Galbraith in Ancient TL; see references)! } \section{Function version}{ 3.5.5 (2017-06-29 18:40:14) } \examples{ ## read example data set data(ExampleData.DeValues, envir = environment()) ExampleData.DeValues <- Second2Gray(ExampleData.DeValues$BT998, c(0.0438,0.0019)) ## create plot straightforward plot_KDE(data = ExampleData.DeValues) ## create plot with logarithmic x-axis plot_KDE(data = ExampleData.DeValues, log = "x") ## create plot with user-defined labels and axes limits plot_KDE(data = ExampleData.DeValues, main = "Dose distribution", xlab = "Dose (s)", ylab = c("KDE estimate", "Cumulative dose value"), xlim = c(100, 250), ylim = c(0, 0.08, 0, 30)) ## create plot with boxplot option plot_KDE(data = ExampleData.DeValues, boxplot = TRUE) ## create plot with statistical summary below header plot_KDE(data = ExampleData.DeValues, summary = c("n", "median", "skewness", "in.2s")) ## create plot with statistical summary as legend plot_KDE(data = ExampleData.DeValues, summary = c("n", "mean", "sd.rel", "se.abs"), summary.pos = "topleft") ## split data set into sub-groups, one is manipulated, and merge again data.1 <- ExampleData.DeValues[1:15,] data.2 <- ExampleData.DeValues[16:25,] * 1.3 data.3 <- list(data.1, data.2) ## create plot with two subsets straightforward plot_KDE(data = data.3) ## create plot with two subsets and summary legend at user coordinates plot_KDE(data = data.3, summary = c("n", "median", "skewness"), summary.pos = c(110, 0.07), col = c("blue", "orange")) ## example of how to use the numerical output of the function ## return plot output to draw a thicker KDE line KDE_out <- plot_KDE(data = ExampleData.DeValues, output = TRUE) } \seealso{ \code{\link{density}}, \code{\link{plot}} } \author{ Michael Dietze, GFZ Potsdam (Germany),\cr Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne \cr R Luminescence Package Team} \section{How to cite}{ Dietze, M., Kreutzer, S. (2017). plot_KDE(): Plot kernel density estimate with statistics. Function version 3.5.5. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } Luminescence/man/extract_IrradiationTimes.Rd0000644000176200001440000001440313125227576020743 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/extract_IrradiationTimes.R \name{extract_IrradiationTimes} \alias{extract_IrradiationTimes} \title{Extract Irradiation Times from an XSYG-file} \usage{ extract_IrradiationTimes(object, file.BINX, recordType = c("irradiation (NA)", "IRSL (UVVIS)", "OSL (UVVIS)", "TL (UVVIS)"), compatibility.mode = TRUE, txtProgressBar = TRUE) } \arguments{ \item{object}{\code{\link{character}} (\bold{required}) or \code{\linkS4class{RLum.Analysis}} object or \code{\link{list}}: path and file name of the XSYG file or an \code{\linkS4class{RLum.Analysis}} produced by the function \code{\link{read_XSYG2R}}; alternatively a \code{list} of \code{\linkS4class{RLum.Analysis}} can be provided. \cr \bold{Note}: If an \code{\linkS4class{RLum.Analysis}} is used, any input for the arguments \code{file.BINX} and \code{recordType} will be ignored!} \item{file.BINX}{\code{\link{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.\cr Note: The XSYG and the BINX-file have to be originate from the same measurement!} \item{recordType}{\code{\link{character}} (with default): select relevant curves types from the XSYG file or \code{\linkS4class{RLum.Analysis}} 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 \code{\link{get_RLum}}. The argument \code{recordType} works as described for this function. \cr Note: A wrong selection will causes a function error. Please change this argument only if you have reasons to do so.} \item{compatibility.mode}{\code{\link{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.\code{\link{write_R2BIN}}} \item{txtProgressBar}{\code{\link{logical}} (with default): enables \code{TRUE} or disables \code{FALSE} the progression bars during import and export} } \value{ An \code{\linkS4class{RLum.Results}} object is returned with the following structure:\cr .. $irr.times (data.frame)\cr 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 \code{file.BINX} is ignored.\cr In the self call mode (input is a \code{list} of \code{\linkS4class{RLum.Analysis}} objects a list of \code{\linkS4class{RLum.Results}} is returned. } \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). \cr Typical application example: g-value estimation from fading measurements using the Analyst or any other self written script.\cr Beside the some simple data transformation steps the function applies the functions \code{\link{read_XSYG2R}}, \code{\link{read_BIN2R}}, \code{\link{write_R2BIN}} for data import and export. } \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 separat sequences steps.\cr BINX-file 'Time Since Irradiation' value differs from the table output?\cr 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 \code{TIMESINCELAS.STEP}? \cr 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 (\code{\link{read_XSYG2R}}) do not change the order of entries for one step towards a correct time order. } \section{Function version}{ 0.3.1 (2017-06-29 18:40:14) } \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) } \section{How to cite}{ Kreutzer, S. (2017). extract_IrradiationTimes(): Extract Irradiation Times from an XSYG-file. Function version 0.3.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Duller, G.A.T., 2015. The Analyst software package for luminescence data: overview and recent improvements. Ancient TL 33, 35-42. } \seealso{ \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}}, \code{\linkS4class{Risoe.BINfileData}}, \code{\link{read_XSYG2R}}, \code{\link{read_BIN2R}}, \code{\link{write_R2BIN}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{IO} \keyword{manip} Luminescence/man/report_RLum.Rd0000644000176200001440000001606313125227576016220 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/report_RLum.R \name{report_RLum} \alias{report_RLum} \title{Create a HTML report for (RLum) objects} \usage{ report_RLum(object, file = tempfile(), title = "RLum.Report", compact = TRUE, timestamp = TRUE, launch.browser = FALSE, css.file = NULL, quiet = TRUE, clean = TRUE, ...) } \arguments{ \item{object}{(\bold{required}): The object to be reported on, preferably of any \code{RLum}-class.} \item{file}{\code{\link{character}} (with default): A character string naming the output file. If no filename is provided a temporary file is created.} \item{title}{\code{\link{character}} (with default): A character string specifying the title of the document.} \item{compact}{\code{\link{logical}} (with default): When \code{TRUE} the following report components are hidden: \code{@.pid}, \code{@.uid}, \code{'Object structure'}, \code{'Session Info'} and only the first and last 5 rows of long matrices and data frames are shown. See details.} \item{timestamp}{\code{\link{logical}} (with default): \code{TRUE} to add a timestamp to the filename (suffix).} \item{launch.browser}{\code{\link{logical}} (with default): \code{TRUE} to open the HTML file in the system's default web browser after it has been rendered.} \item{css.file}{\code{\link{character}} (optional): Path to a CSS file to change the default styling of the HTML document.} \item{quiet}{\code{\link{logical}} (with default): \code{TRUE} to supress printing of the pandoc command line.} \item{clean}{\code{\link{logical}} (with default): \code{TRUE} to clean intermediate files created during rendering.} \item{...}{further arguments passed to or from other methods and to control the document's structure (see details).} } \value{ Writes a HTML and .Rds file. } \description{ This function creates a HTML report for a given object, listing its complete structure and content. The object itself is saved as a serialised .Rds file. The report file serves both as a convenient way of browsing through objects with complex data structures as well as a mean of properly documenting and saving objects. } \details{ The HTML report is created with \code{\link[rmarkdown]{render}} and has the following structure: \tabular{ll}{ \bold{Section} \tab \bold{Description} \cr \code{Header} \tab A summary of general characteristics of the object \cr \code{Object content} \tab A comprehensive list of the complete structure and content of the provided object. \cr \code{Object structure} \tab Summary of the objects structure given as a table \cr \code{File} \tab Information on the saved RDS file \cr \code{Session Info} \tab Captured output from sessionInfo() \cr \code{Plots} \tab (optional) For \code{RLum-class} objects a variable number of plots \cr } The structure of the report can be controlled individually by providing one or more of the following arguments (all \code{logical}): \tabular{ll}{ \bold{Argument} \tab \bold{Description} \cr \code{header} \tab Hide or show general information on the object \cr \code{main} \tab Hide or show the object's content \cr \code{structure} \tab Hide or show object's structure \cr \code{rds} \tab Hide or show information on the saved RDS file \cr \code{session} \tab Hide or show the session info \cr \code{plot} \tab Hide or show the plots (depending on object) \cr } Note that these arguments have higher precedence than \code{compact}. Further options that can be provided via the \code{...} argument: \tabular{ll}{ \bold{Argument} \tab \bold{Description} \cr \code{short_table} \tab If \code{TRUE} only show the first and last 5 rows of lang tables. \cr \code{theme} \tab Specifies the Bootstrap theme to use for the report. Valid themes include "default", "cerulean", "journal", "flatly", "readable", "spacelab", "united", "cosmo", "lumen", "paper", "sandstone", "simplex", and "yeti". \cr \code{highlight} \tab Specifies the syntax highlighting style. Supported styles include "default", "tango", "pygments", "kate", "monochrome", "espresso", "zenburn", "haddock", and "textmate". \cr \code{css} \tab \code{TRUE} or \code{FALSE} to enable/disable custom CSS styling \cr } The following arguments can be used to customise the report via CSS (Cascading Style Sheets): \tabular{ll}{ \bold{Argument} \tab \bold{Description} \cr \code{font_family} \tab Define the font family of the HTML document (default: arial) \cr \code{headings_size} \tab Size of the

to

tags used to define HTML headings (default: 166\%). \cr \code{content_color} \tab Color of the object's content (default: #a72925). \cr } Note that these arguments must all be of class \code{\link{character}} and follow standard CSS syntax. For exhaustive CSS styling you can provide a custom CSS file for argument \code{css.file}. CSS styling can be turned of using \code{css = FALSE}. } \note{ This function requires the R packages 'rmarkdown', 'pander' and 'rstudioapi'. } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \examples{ \dontrun{ ## Example: RLum.Results ---- # load example data data("ExampleData.DeValues") # apply the MAM-3 age model and save results mam <- calc_MinDose(ExampleData.DeValues$CA1, sigmab = 0.2) # create the HTML report report_RLum(object = mam, file = "~/CA1_MAM.Rmd", timestamp = FALSE, title = "MAM-3 for sample CA1") # when creating a report the input file is automatically saved to a # .Rds file (see saveRDS()). mam_report <- readRDS("~/CA1_MAM.Rds") all.equal(mam, mam_report) ## Example: Temporary file & Viewer/Browser ---- # (a) # Specifying a filename is not necessarily required. If no filename is provided, # the report is rendered in a temporary file. If you use the RStudio IDE, the # temporary report is shown in the interactive Viewer pane. report_RLum(object = mam) # (b) # Additionally, you can view the HTML report in your system's default web browser. report_RLum(object = mam, launch.browser = TRUE) ## Example: RLum.Analysis ---- data("ExampleData.RLum.Analysis") # create the HTML report (note that specifying a file # extension is not necessary) report_RLum(object = IRSAR.RF.Data, file = "~/IRSAR_RF") ## Example: RLum.Data.Curve ---- data.curve <- get_RLum(IRSAR.RF.Data)[[1]] # create the HTML report report_RLum(object = data.curve, file = "~/Data_Curve") ## Example: Any other object ---- x <- list(x = 1:10, y = runif(10, -5, 5), z = data.frame(a = LETTERS[1:20], b = dnorm(0:9)), NA) report_RLum(object = x, file = "~/arbitray_list") } } \seealso{ \code{\link[rmarkdown]{render}}, \code{\link[pander]{pander_return}}, \code{\link[pander]{openFileInOS}}, \code{\link[rstudioapi]{viewer}}, \code{\link{browseURL}} } \author{ Christoph Burow, University of Cologne (Germany) \cr \cr R Luminescence Package Team} \section{How to cite}{ Burow, C. (2017). report_RLum(): Create a HTML report for (RLum) objects. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } Luminescence/man/get_RLum.Rd0000644000176200001440000000521313125227576015457 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/get_RLum.R \docType{methods} \name{get_RLum} \alias{get_RLum} \alias{get_RLum,list-method} \title{General accessor function for RLum S4 class objects} \usage{ get_RLum(object, ...) \S4method{get_RLum}{list}(object, null.rm = FALSE, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum}} (\bold{required}): S4 object of class \code{RLum} or an object of type \code{\link{list}} containing only objects of type \code{\linkS4class{RLum}}} \item{\dots}{further arguments that will be passed to the object specific methods. For furter details on the supported arguments please see the class documentation: \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Spectrum}}, \code{\linkS4class{RLum.Data.Image}}, \code{\linkS4class{RLum.Analysis}} and \code{\linkS4class{RLum.Results}}} \item{null.rm}{\code{\link{logical}} (with default): option to get rid of empty and NULL objects} } \value{ Return is the same as input objects as provided in the list. } \description{ Function calls object-specific get functions for RLum S4 class objects. } \details{ The function provides a generalised access point for specific \code{\linkS4class{RLum}} objects.\cr Depending on the input object, the corresponding get function will be selected. Allowed arguments can be found in the documentations of the corresponding \code{\linkS4class{RLum}} class. } \section{Methods (by class)}{ \itemize{ \item \code{list}: Returns a list of \code{\linkS4class{RLum}} objects that had been passed to \code{\link{get_RLum}} }} \section{Function version}{ 0.3.0 (2017-06-29 18:40:14) } \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) } \seealso{ \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Image}}, \code{\linkS4class{RLum.Data.Spectrum}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). get_RLum(): General accessor function for RLum S4 class objects. Function version 0.3.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{utilities} Luminescence/man/calc_CommonDose.Rd0000644000176200001440000001103413125227575016763 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_CommonDose.R \name{calc_CommonDose} \alias{calc_CommonDose} \title{Apply the (un-)logged common age model after Galbraith et al. (1999) to a given De distribution} \usage{ calc_CommonDose(data, sigmab, log = TRUE, ...) } \arguments{ \item{data}{\code{\linkS4class{RLum.Results}} or \link{data.frame} (\bold{required}): for \code{data.frame}: two columns with De \code{(data[,1])} and De error \code{(values[,2])}} \item{sigmab}{\code{\link{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). \bold{NOTE}: For the logged model (\code{log = TRUE}) this value must be a fraction, e.g. 0.2 (= 20 \%). If the un-logged model is used (\code{log = FALSE}), sigmab must be provided in the same absolute units of the De values (seconds or Gray).} \item{log}{\code{\link{logical}} (with default): fit the (un-)logged common age model to De data} \item{\dots}{currently not used.} } \value{ Returns a terminal output. In addition an \code{\linkS4class{RLum.Results}} object is returned containing the following element: \item{summary}{\link{data.frame} summary of all relevant model results.} \item{data}{\link{data.frame} original input data} \item{args}{\link{list} used arguments} \item{call}{\link{call} the function call} The output should be accessed using the function \code{\link{get_RLum}} } \description{ Function to calculate the common dose of a De distribution. } \details{ \bold{(Un-)logged model} \cr\cr When \code{log = TRUE} this function calculates the weighted mean of logarithmic De values. Each of the estimates is weighted by the inverse square of its relative standard error. The weighted mean is then transformed back to the dose scale (Galbraith & Roberts 2012, p. 14).\cr\cr The log transformation is not applicable if the De estimates are close to zero or negative. In this case the un-logged model can be applied instead (\code{log = FALSE}). The weighted mean is then calculated using the un-logged estimates of De and their absolute standard error (Galbraith & Roberts 2012, p. 14). } \section{Function version}{ 0.1.1 (2017-06-29 18:40:14) } \examples{ ## load example data data(ExampleData.DeValues, envir = environment()) ## apply the common dose model calc_CommonDose(ExampleData.DeValues$CA1) } \section{How to cite}{ Burow, C. (2017). calc_CommonDose(): Apply the (un-)logged common age model after Galbraith et al. (1999) to a given De distribution. Function version 0.1.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Galbraith, R.F. & Laslett, G.M., 1993. Statistical models for mixed fission track ages. Nuclear Tracks Radiation Measurements 4, 459-470. \cr\cr 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. \cr\cr Galbraith, R.F. & Roberts, R.G., 2012. Statistical aspects of equivalent dose and error calculation and display in OSL dating: An overview and some recommendations. Quaternary Geochronology 11, 1-27. \cr\cr \bold{Further reading} \cr\cr 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. \cr\cr 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. \cr\cr Cunningham, A.C. & Wallinga, J., 2012. Realizing the potential of fluvial archives using robust OSL chronologies. Quaternary Geochronology 12, 98-106. \cr\cr 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.\cr\cr Rodnight, H., 2008. How many equivalent dose values are needed to obtain a reproducible distribution?. Ancient TL 26, 3-10. } \seealso{ \code{\link{calc_CentralDose}}, \code{\link{calc_FiniteMixture}}, \code{\link{calc_FuchsLang2001}}, \code{\link{calc_MinDose}} } \author{ Christoph Burow, University of Cologne (Germany) \cr R Luminescence Package Team} Luminescence/man/ExampleData.FittingLM.Rd0000644000176200001440000000205013125226556017753 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \name{ExampleData.FittingLM} \alias{ExampleData.FittingLM} \title{Example data for fit_LMCurve() in the package Luminescence} \format{Two objects (data.frames) with two columns (time and counts).} \source{ \tabular{ll}{ Lab: \tab Luminescence Laboratory Bayreuth\cr Lab-Code: \tab BT900\cr Location: \tab Norway\cr Material: \tab Beach deposit, coarse grain quartz measured on aluminum discs on a Risoe TL/OSL DA-15 reader\cr } } \description{ Lineraly modulated (LM) measurement data from a quartz sample from Norway including background measurement. Measurements carried out in the luminescence laboratory at the University of Bayreuth. } \examples{ ##show LM data data(ExampleData.FittingLM, envir = environment()) plot(values.curve,log="x") } \references{ Fuchs, M., Kreutzer, S., Fischer, M., Sauer, D., Soerensen, R., 2012. OSL and IRSL dating of raised beach sand deposits along the southeastern coast of Norway. Quaternary Geochronology, 10, 195-200. } Luminescence/man/RLum.Data.Image-class.Rd0000644000176200001440000001050113125227576017610 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RLum.Data.Image-class.R \docType{class} \name{RLum.Data.Image-class} \alias{RLum.Data.Image-class} \alias{show,RLum.Data.Image-method} \alias{set_RLum,RLum.Data.Image-method} \alias{get_RLum,RLum.Data.Image-method} \alias{names_RLum,RLum.Data.Image-method} \title{Class \code{"RLum.Data.Image"}} \usage{ \S4method{show}{RLum.Data.Image}(object) \S4method{set_RLum}{RLum.Data.Image}(class, originator, .uid, .pid, recordType = "Image", curveType = NA_character_, data = raster::brick(raster::raster(matrix())), info = list()) \S4method{get_RLum}{RLum.Data.Image}(object, info.object) \S4method{names_RLum}{RLum.Data.Image}(object) } \arguments{ \item{object}{\code{[show_RLum]}\code{[get_RLum]}\code{[names_RLum]} an object of class \code{\linkS4class{RLum.Data.Image}}} \item{class}{\code{[set_RLum]}\code{\link{character}}: name of the \code{RLum} class to create} \item{originator}{\code{[set_RLum]} \code{\link{character}} (automatic): contains the name of the calling function (the function that produces this object); can be set manually.} \item{.uid}{[\code{set_RLum}] \code{\link{character}} (automatic): sets an unique ID for this object using the internal C++ function \code{.create_UID}.} \item{.pid}{[\code{set_RLum}] \code{\link{character}} (with default): option to provide a parent id for nesting at will.} \item{recordType}{\code{[set_RLum]} \code{\link{character}}: record type (e.g. "OSL")} \item{curveType}{\code{[set_RLum]} \code{\link{character}}: curve type (e.g. "predefined" or "measured")} \item{data}{\code{[set_RLum]} \code{\link{matrix}}: raw curve data. If data is of type \code{RLum.Data.Image} this can be used to re-construct the object.} \item{info}{\code{[set_RLum]} \code{\link{list}}: info elements} \item{info.object}{\code{[get_RLum]} \code{\link{character}} name of the info object to returned} } \value{ \bold{\code{set_RLum}}\cr Returns an object from class \code{RLum.Data.Image} \bold{\code{get_RLum}}\cr (1) Returns the data object (\code{\link[raster]{brick}})\cr (2) only the info object if \code{info.object} was set.\cr \bold{\code{names_RLum}}\cr Returns the names of the info elements } \description{ Class for representing luminescence image data (TL/OSL/RF). Such data are for example produced by the function \code{\link{read_SPE2R}} } \section{Methods (by generic)}{ \itemize{ \item \code{show}: Show structure of \code{RLum.Data.Image} object \item \code{set_RLum}: Construction method for RLum.Data.Image object. The slot info is optional and predefined as empty list by default.. \item \code{get_RLum}: 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 (RasterBrick) will be returned. \item \code{names_RLum}: Returns the names info elements coming along with this curve object }} \section{Slots}{ \describe{ \item{\code{recordType}}{Object of class \code{\link{character}} containing the type of the curve (e.g. "OSL image", "TL image")} \item{\code{curveType}}{Object of class \code{\link{character}} containing curve type, allowed values are measured or predefined} \item{\code{data}}{Object of class \code{\link[raster]{brick}} containing images (raster data).} \item{\code{info}}{Object of class \code{\link{list}} containing further meta information objects} }} \note{ The class should only contain data for a set of images. For additional elements the slot \code{info} can be used. } \section{Objects from the Class}{ Objects can be created by calls of the form \code{set_RLum("RLum.Data.Image", ...)}. } \section{Class version}{ 0.4.0 } \examples{ showClass("RLum.Data.Image") ##create empty RLum.Data.Image object set_RLum(class = "RLum.Data.Image") } \seealso{ \code{\linkS4class{RLum}}, \code{\linkS4class{RLum.Data}}, \code{\link{plot_RLum}}, \code{\link{read_SPE2R}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) } \section{How to cite}{ Kreutzer, S. (2017). RLum.Data.Image-class(): Class 'RLum.Data.Image'. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{classes} Luminescence/man/calc_TLLxTxRatio.Rd0000644000176200001440000000736513125227576017073 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_TLLxTxRatio.R \name{calc_TLLxTxRatio} \alias{calc_TLLxTxRatio} \title{Calculate the Lx/Tx ratio for a given set of TL curves [beta version]} \usage{ calc_TLLxTxRatio(Lx.data.signal, Lx.data.background = NULL, Tx.data.signal, Tx.data.background = NULL, signal.integral.min, signal.integral.max) } \arguments{ \item{Lx.data.signal}{\code{\linkS4class{RLum.Data.Curve}} or \code{\link{data.frame}} (\bold{required}): TL data (x = temperature, y = counts) (TL signal)} \item{Lx.data.background}{\code{\linkS4class{RLum.Data.Curve}} or \code{\link{data.frame}} (optional): TL data (x = temperature, y = counts). If no data are provided no background subtraction is performed.} \item{Tx.data.signal}{\code{\linkS4class{RLum.Data.Curve}} or \code{\link{data.frame}} (\bold{required}): TL data (x = temperature, y = counts) (TL test signal)} \item{Tx.data.background}{\code{\linkS4class{RLum.Data.Curve}} or \code{\link{data.frame}} (optional): TL data (x = temperature, y = counts). If no data are provided no background subtraction is performed.} \item{signal.integral.min}{\code{\link{integer}} (\bold{required}): channel number for the lower signal integral bound (e.g. \code{signal.integral.min = 100})} \item{signal.integral.max}{\code{\link{integer}} (\bold{required}): channel number for the upper signal integral bound (e.g. \code{signal.integral.max = 200})} } \value{ Returns an S4 object of type \code{\linkS4class{RLum.Results}}. Slot \code{data} contains a \link{list} with the following structure:\cr\cr $ LxTx.table \cr .. $ LnLx \cr .. $ LnLx.BG \cr .. $ TnTx \cr .. $ TnTx.BG \cr .. $ Net_LnLx \cr .. $ Net_LnLx.Error\cr } \description{ Calculate Lx/Tx ratio for a given set of TL curves. } \details{ \bold{Uncertainty estimation}\cr The standard errors are calculated using the following generalised equation: \deqn{SE_{signal} <- abs(Signal_{net} * BG_f /BG_{signal}} where \eqn{BG_f} is a term estimated by calculating the standard deviation of the sum of the \eqn{L_x} background counts and the sum of the \eqn{T_x} background counts. However, if both signals are similar the error becomes zero. } \note{ \bold{This function has still BETA status!} Please further note that a similar background for both curves results in a zero error and is therefore set to \code{NA}. } \section{Function version}{ 0.3.2 (2017-06-29 18:40:14) } \examples{ ##load package example data data(ExampleData.BINfileData, envir = environment()) ##convert Risoe.BINfileData into a curve object temp <- Risoe.BINfileData2RLum.Analysis(TL.SAR.Data, pos = 3) Lx.data.signal <- get_RLum(temp, record.id=1) Lx.data.background <- get_RLum(temp, record.id=2) Tx.data.signal <- get_RLum(temp, record.id=3) Tx.data.background <- get_RLum(temp, record.id=4) signal.integral.min <- 210 signal.integral.max <- 230 output <- calc_TLLxTxRatio(Lx.data.signal, Lx.data.background, Tx.data.signal, Tx.data.background, signal.integral.min, signal.integral.max) get_RLum(output) } \section{How to cite}{ Kreutzer, S., Schmidt, C. (2017). calc_TLLxTxRatio(): Calculate the Lx/Tx ratio for a given set of TL curves [beta version]. Function version 0.3.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ - } \seealso{ \code{\linkS4class{RLum.Results}}, \code{\link{analyse_SAR.TL}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France), Christoph Schmidt, University of Bayreuth (Germany) \cr R Luminescence Package Team} \keyword{datagen} Luminescence/man/plot_RLum.Rd0000644000176200001440000000600613125227576015657 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_RLum.R \name{plot_RLum} \alias{plot_RLum} \title{General plot function for RLum S4 class objects} \usage{ plot_RLum(object, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum}} (\bold{required}): S4 object of class \code{RLum}. Optional a \code{\link{list}} containing objects of class \code{\linkS4class{RLum}} can be provided. In this case the function tries to plot every object in this list according to its \code{RLum} class.} \item{\dots}{further arguments and graphical parameters that will be passed to the specific plot functions. The only argument that is supported directly is \code{main} (setting the plot title). In contrast to the normal behaviour \code{main} can be here provided as \code{\link{list}} and the arguments in the list will dispatched to the plots if the \code{object} is of type \code{list} as well.} } \value{ Returns a plot. } \description{ Function calls object specific plot functions for RLum S4 class objects. } \details{ The function provides a generalised access point for plotting specific \code{\linkS4class{RLum}} 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}{ \bold{object} \tab \tab \bold{corresponding plot function} \cr \code{\linkS4class{RLum.Data.Curve}} \tab : \tab \code{\link{plot_RLum.Data.Curve}} \cr \code{\linkS4class{RLum.Data.Spectrum}} \tab : \tab \code{\link{plot_RLum.Data.Spectrum}}\cr \code{\linkS4class{RLum.Data.Image}} \tab : \tab \code{\link{plot_RLum.Data.Image}}\cr \code{\linkS4class{RLum.Analysis}} \tab : \tab \code{\link{plot_RLum.Analysis}}\cr \code{\linkS4class{RLum.Results}} \tab : \tab \code{\link{plot_RLum.Results}} } } \note{ The provided plot output depends on the input object. } \section{Function version}{ 0.4.3 (2017-06-29 18:40:14) } \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) } \section{How to cite}{ Kreutzer, S. (2017). plot_RLum(): General plot function for RLum S4 class objects. Function version 0.4.3. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ # } \seealso{ \code{\link{plot_RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Curve}}, \code{\link{plot_RLum.Data.Spectrum}}, \code{\linkS4class{RLum.Data.Spectrum}}, \code{\link{plot_RLum.Data.Image}}, \code{\linkS4class{RLum.Data.Image}}, \code{\link{plot_RLum.Analysis}}, \code{\linkS4class{RLum.Analysis}}, \code{\link{plot_RLum.Results}}, \code{\linkS4class{RLum.Results}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{dplot} Luminescence/man/calc_FuchsLang2001.Rd0000644000176200001440000000723413125227575017104 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_FuchsLang2001.R \name{calc_FuchsLang2001} \alias{calc_FuchsLang2001} \title{Apply the model after Fuchs & Lang (2001) to a given De distribution.} \usage{ calc_FuchsLang2001(data, cvThreshold = 5, startDeValue = 1, plot = TRUE, ...) } \arguments{ \item{data}{\code{\linkS4class{RLum.Results}} or \link{data.frame} (\bold{required}): for \code{data.frame}: two columns with De \code{(data[,1])} and De error \code{(values[,2])}} \item{cvThreshold}{\link{numeric} (with default): coefficient of variation in percent, as threshold for the method, e.g. \code{cvThreshold = 3}. See details.} \item{startDeValue}{\link{numeric} (with default): number of the first aliquot that is used for the calculations} \item{plot}{\link{logical} (with default): plot output \code{TRUE}/\code{FALSE}} \item{\dots}{further arguments and graphical parameters passed to \code{\link{plot}}} } \value{ Returns a plot (optional) and terminal output. In addition an \code{\linkS4class{RLum.Results}} object is returned containing the following elements: \item{summary}{\link{data.frame} summary of all relevant model results.} \item{data}{\link{data.frame} original input data} \item{args}{\link{list} used arguments} \item{call}{\link{call} the function call} \item{usedDeValues}{\link{data.frame} containing the used values for the calculation} } \description{ This function applies the method according to Fuchs & Lang (2001) for heterogeneously bleached samples with a given coefficient of variation threshold. } \details{ \bold{Used values} \cr If the coefficient of variation (c[v]) of the first two values is larger than the threshold c[v_threshold], the first value is skipped. Use the \code{startDeValue} argument to define a start value for calculation (e.g. 2nd or 3rd value).\cr \bold{Basic steps of the approach} \cr (1) Estimate natural relative variation of the sample using a dose recovery test\cr (2) Sort the input values ascendingly\cr (3) Calculate a running mean, starting with the lowermost two values and add values iteratively.\cr (4) Stop if the calculated c[v] exceeds the specified \code{cvThreshold}\cr } \note{ Please consider the requirements and the constraints of this method (see Fuchs & Lang, 2001) } \section{Function version}{ 0.4.1 (2017-06-29 18:40:14) } \examples{ ##load example data data(ExampleData.DeValues, envir = environment()) ##calculate De according to Fuchs & Lang (2001) temp<- calc_FuchsLang2001(ExampleData.DeValues$BT998, cvThreshold = 5) } \section{How to cite}{ Kreutzer, S., Burow, C. (2017). calc_FuchsLang2001(): Apply the model after Fuchs & Lang (2001) to a given De distribution.. Function version 0.4.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Fuchs, M. & Lang, A., 2001. OSL dating of coarse-grain fluvial quartz using single-aliqout protocols on sediments from NE Peloponnese, Greece. In: Quaternary Science Reviews 20, 783-787. Fuchs, M. & Wagner, G.A., 2003. Recognition of insufficient bleaching by small aliquots of quartz for reconstructing soil erosion in Greece. Quaternary Science Reviews 22, 1161-1167. } \seealso{ \code{\link{plot}}, \code{\link{calc_MinDose}}, \code{\link{calc_FiniteMixture}}, \code{\link{calc_CentralDose}}, \code{\link{calc_CommonDose}}, \code{\linkS4class{RLum.Results}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) Christoph Burow, University of Cologne (Germany) \cr R Luminescence Package Team} \keyword{dplot} Luminescence/man/structure_RLum.Rd0000644000176200001440000000344213125227576016742 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/structure_RLum.R \name{structure_RLum} \alias{structure_RLum} \title{General structure function for RLum S4 class objects} \usage{ structure_RLum(object, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum}} (\bold{required}): S4 object of class \code{RLum}} \item{\dots}{further arguments that one might want to pass to the specific structure method} } \value{ Returns a \code{data.frame} with structure of the object. } \description{ Function calls object-specific get functions for RLum S4 class objects. } \details{ The function provides a generalised access point for specific \code{\linkS4class{RLum}} objects.\cr Depending on the input object, the corresponding structure function will be selected. Allowed arguments can be found in the documentations of the corresponding \code{\linkS4class{RLum}} class. } \section{Function version}{ 0.2.0 (2017-06-29 18:40:14) } \examples{ ##load example data data(ExampleData.XSYG, envir = environment()) ##show structure structure_RLum(OSL.SARMeasurement$Sequence.Object) } \seealso{ \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Image}}, \code{\linkS4class{RLum.Data.Spectrum}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). structure_RLum(): General structure function for RLum S4 class objects. Function version 0.2.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{utilities} Luminescence/man/read_BIN2R.Rd0000644000176200001440000001401613125227576015551 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/read_BIN2R.R \name{read_BIN2R} \alias{read_BIN2R} \title{Import Risoe BIN-file into R} \usage{ read_BIN2R(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, ...) } \arguments{ \item{file}{\code{\link{character}} or \code{\link{list}} (\bold{required}): path and file name of the BIN/BINX file (URLs are supported). If input is a \code{list} it should comprise only \code{character}s representing each valid path and BIN/BINX-file names. Alternatively the input character can be just a directory (path), in this case the the function tries to detect and import all BIN/BINX files found in the directory.} \item{show.raw.values}{\link{logical} (with default): shows raw values from BIN file for \code{LTYPE}, \code{DTYPE} and \code{LIGHTSOURCE} without translation in characters. Can be provided as \code{list} if \code{file} is a \code{list}.} \item{position}{\code{\link{numeric}} (optional): imports only the selected position. Note: the import performance will not benefit by any selection made here. Can be provided as \code{list} if \code{file} is a \code{list}.} \item{n.records}{\link{raw} (optional): limits the number of imported records. Can be used in combination with \code{show.record.number} for debugging purposes, e.g. corrupt BIN-files. Can be provided as \code{list} if \code{file} is a \code{list}.} \item{zero_data.rm}{\code{\link{logical}} (with default): remove erroneous data with no count values. As such data are usally not needed for the subsequent data analysis they will be removed by default. Can be provided as \code{list} if \code{file} is a \code{list}.} \item{duplicated.rm}{\code{\link{logical}} (with default): remove duplicated entries if \code{TRUE}. This may happen due to an erroneous produced BIN/BINX-file. This option compares only predeccessor and successor. Can be provided as \code{list} if \code{file} is a \code{list}.} \item{fastForward}{\code{\link{logical}} (with default): if \code{TRUE} for a more efficient data processing only a list of \code{RLum.Analysis} objects is returned instead of a \link{Risoe.BINfileData-class} object. Can be provided as \code{list} if \code{file} is a \code{list}.} \item{show.record.number}{\link{logical} (with default): shows record number of the imported record, for debugging usage only. Can be provided as \code{list} if \code{file} is a \code{list}.} \item{txtProgressBar}{\link{logical} (with default): enables or disables \code{\link{txtProgressBar}}.} \item{forced.VersionNumber}{\code{\link{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 \code{list} if \code{file} is a \code{list}.\cr Note: The usage is at own risk, only supported BIN-file versions have been tested.} \item{ignore.RECTYPE}{\code{\link{logical}} (with default): this argument allows to ignore values in the byte 'REGTYPE' (BIN-file version 08), in case there are not documented or faulty set. If set all records are treated like records of 'REGYPE' 0 or 1.} \item{pattern}{\code{\link{character}} (optional): argument that is used if only a path is provided. The argument will than be passed to the function \code{\link{list.files}} used internally to construct a \code{list} of wanted files} \item{verbose}{\code{\link{logical}} (with default): enables or disables verbose mode} \item{\dots}{further arguments that will be passed to the function \code{\link{Risoe.BINfileData2RLum.Analysis}}. Please note that any matching argument automatically sets \code{fastForward = TRUE}} } \value{ Returns an S4 \link{Risoe.BINfileData-class} object containing two slots:\cr \item{METADATA}{A \link{data.frame} containing all variables stored in the bin-file.} \item{DATA}{A \link{list} containing a numeric \link{vector} of the measured data. The ID corresponds to the record ID in METADATA.}\cr If \code{fastForward = TRUE} a list of \code{\linkS4class{RLum.Analysis}} object is returned. The internal coercing is done using the function \code{\link{Risoe.BINfileData2RLum.Analysis}} } \description{ Import a *.bin or a *.binx file produced by a Risoe 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.\cr\cr For the general BIN-file structure, the reader is referred to the Risoe website: \code{http://www.nutech.dtu.dk/} } \note{ The function works for BIN/BINX-format versions 03, 04, 06, 07 and 08. The version number depends on the used Sequence Editor.\cr\cr \bold{ROI data sets introduced with BIN-file version 8 are not supported and skipped durint import.} } \section{Function version}{ 0.15.6 (2017-06-29 18:40:14) } \examples{ ##(1) import Risoe BIN-file to R (uncomment for usage) #FILE <- file.choose() #temp <- read_BIN2R(FILE) #temp } \section{How to cite}{ Kreutzer, S., Fuchs, M.C., Fuchs, M. (2017). read_BIN2R(): Import Risoe BIN-file into R. Function version 0.15.6. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ DTU Nutech, 2016. The Squence Editor, Users Manual, February, 2016. \url{http://www.nutech.dtu.dk/english/products-and-services/radiation-instruments/tl_osl_reader/manuals} } \seealso{ \code{\link{write_R2BIN}}, \code{\linkS4class{Risoe.BINfileData}}, \code{\link[base]{readBin}}, \code{\link{merge_Risoe.BINfileData}}, \code{\linkS4class{RLum.Analysis}} \code{\link[utils]{txtProgressBar}}, \code{\link{list.files}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France), Margret C. Fuchs, HZDR Freiberg, (Germany) \cr R Luminescence Package Team} \keyword{IO} Luminescence/man/plot_RadialPlot.Rd0000644000176200001440000002551413125227576017040 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_RadialPlot.R \name{plot_RadialPlot} \alias{plot_RadialPlot} \title{Function to create a Radial Plot} \usage{ plot_RadialPlot(data, na.rm = TRUE, log.z = TRUE, central.value, centrality = "mean.weighted", mtext, summary, summary.pos, legend, legend.pos, stats, rug = FALSE, plot.ratio, bar.col, y.ticks = TRUE, grid.col, line, line.col, line.label, output = FALSE, ...) } \arguments{ \item{data}{\code{\link{data.frame}} or \code{\linkS4class{RLum.Results}} object (required): for \code{data.frame} two columns: De (\code{data[,1]}) and De error (\code{data[,2]}). To plot several data sets in one plot, the data sets must be provided as \code{list}, e.g. \code{list(data.1, data.2)}.} \item{na.rm}{\code{\link{logical}} (with default): excludes \code{NA} values from the data set prior to any further operations.} \item{log.z}{\code{\link{logical}} (with default): Option to display the z-axis in logarithmic scale. Default is \code{TRUE}.} \item{central.value}{\code{\link{numeric}}: User-defined central value, primarily used for horizontal centering of the z-axis.} \item{centrality}{\code{\link{character}} or \code{\link{numeric}} (with default): measure of centrality, used for automatically centering the plot and drawing the central line. Can either be one out of \code{"mean"}, \code{"median"}, \code{"mean.weighted"} and \code{"median.weighted"} or a numeric value used for the standardisation.} \item{mtext}{\code{\link{character}}: additional text below the plot title.} \item{summary}{\code{\link{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.} \item{summary.pos}{\code{\link{numeric}} or \code{\link{character}} (with default): optional position coordinates or keyword (e.g. \code{"topright"}) for the statistical summary. Alternatively, the keyword \code{"sub"} may be specified to place the summary below the plot header. However, this latter option is only possible if \code{mtext} is not used.} \item{legend}{\code{\link{character}} vector (optional): legend content to be added to the plot.} \item{legend.pos}{\code{\link{numeric}} or \code{\link{character}} (with default): optional position coordinates or keyword (e.g. \code{"topright"}) for the legend to be plotted.} \item{stats}{\code{\link{character}}: additional labels of statistically important values in the plot. One or more out of the following: \code{"min"}, \code{"max"}, \code{"median"}.} \item{rug}{\code{\link{logical}}: Option to add a rug to the z-scale, to indicate the location of individual values} \item{plot.ratio}{\code{\link{numeric}}: User-defined plot area ratio (i.e. curvature of the z-axis). If omitted, the default value (\code{4.5/5.5}) is used and modified automatically to optimise the z-axis curvature. The parameter should be decreased when data points are plotted outside the z-axis or when the z-axis gets too elliptic.} \item{bar.col}{\code{\link{character}} or \code{\link{numeric}} (with default): colour of the bar showing the 2-sigma range around the central value. To disable the bar, use \code{"none"}. Default is \code{"grey"}.} \item{y.ticks}{\code{\link{logical}}: Option to hide y-axis labels. Useful for data with small scatter.} \item{grid.col}{\code{\link{character}} or \code{\link{numeric}} (with default): colour of the grid lines (originating at [0,0] and stretching to the z-scale). To disable grid lines, use \code{"none"}. Default is \code{"grey"}.} \item{line}{\code{\link{numeric}}: numeric values of the additional lines to be added.} \item{line.col}{\code{\link{character}} or \code{\link{numeric}}: colour of the additional lines.} \item{line.label}{\code{\link{character}}: labels for the additional lines.} \item{output}{\code{\link{logical}}: Optional output of numerical plot parameters. These can be useful to reproduce similar plots. Default is \code{FALSE}.} \item{\dots}{Further plot arguments to pass. \code{xlab} must be a vector of length 2, specifying the upper and lower x-axes labels.} } \value{ Returns a plot object. } \description{ A Galbraith's radial plot is produced on a logarithmic or a linear scale. } \details{ Details and the theoretical background of the radial plot are given in the cited literature. This function is based on an S script of Rex Galbraith. To reduce the manual adjustments, the function has been rewritten. Thanks to Rex Galbraith for useful comments on this function. \cr Plotting can be disabled by adding the argument \code{plot = "FALSE"}, e.g. to return only numeric plot output.\cr Earlier versions of the Radial Plot in this package had the 2-sigma-bar drawn onto the z-axis. However, this might have caused misunderstanding in that the 2-sigma range may also refer to the z-scale, which it does not! Rather it applies only to the x-y-coordinate system (standardised error vs. precision). A spread in doses or ages must be drawn as lines originating at zero precision (x0) and zero standardised estimate (y0). Such a range may be drawn by adding lines to the radial plot ( \code{line}, \code{line.col}, \code{line.label}, cf. examples).\cr\cr 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: \code{"n"} (number of samples), \code{"mean"} (mean De value), \code{"mean.weighted"} (error-weighted mean), \code{"median"} (median of the De values), \code{"sdrel"} (relative standard deviation in percent), \code{"sdrel.weighted"} (error-weighted relative standard deviation in percent), \code{"sdabs"} (absolute standard deviation), \code{"sdabs.weighted"} (error-weighted absolute standard deviation), \code{"serel"} (relative standard error), \code{"serel.weighted"} ( error-weighted relative standard error), \code{"seabs"} (absolute standard error), \code{"seabs.weighted"} (error-weighted absolute standard error), \code{"in.2s"} (percent of samples in 2-sigma range), \code{"kurtosis"} (kurtosis) and \code{"skewness"} (skewness). } \section{Function version}{ 0.5.4 (2017-06-29 18:40:14) } \examples{ ## load example data data(ExampleData.DeValues, envir = environment()) ExampleData.DeValues <- Second2Gray(ExampleData.DeValues$BT998, c(0.0438,0.0019)) ## plot the example data straightforward plot_RadialPlot(data = ExampleData.DeValues) ## now with linear z-scale plot_RadialPlot(data = ExampleData.DeValues, log.z = FALSE) ## now with output of the plot parameters plot1 <- plot_RadialPlot(data = ExampleData.DeValues, log.z = FALSE, output = TRUE) plot1 plot1$zlim ## now with adjusted z-scale limits plot_RadialPlot(data = ExampleData.DeValues, log.z = FALSE, zlim = c(100, 200)) ## now the two plots with serious but seasonally changing fun #plot_RadialPlot(data = data.3, fun = TRUE) ## now with user-defined central value, in log-scale again plot_RadialPlot(data = ExampleData.DeValues, central.value = 150) ## now with a rug, indicating individual De values at the z-scale plot_RadialPlot(data = ExampleData.DeValues, rug = TRUE) ## now with legend, colour, different points and smaller scale plot_RadialPlot(data = ExampleData.DeValues, legend.text = "Sample 1", col = "tomato4", bar.col = "peachpuff", pch = "R", cex = 0.8) ## now without 2-sigma bar, y-axis, grid lines and central value line plot_RadialPlot(data = ExampleData.DeValues, bar.col = "none", grid.col = "none", y.ticks = FALSE, lwd = 0) ## now with user-defined axes labels plot_RadialPlot(data = ExampleData.DeValues, xlab = c("Data error (\%)", "Data precision"), ylab = "Scatter", zlab = "Equivalent dose [Gy]") ## now with minimum, maximum and median value indicated plot_RadialPlot(data = ExampleData.DeValues, central.value = 150, stats = c("min", "max", "median")) ## now with a brief statistical summary plot_RadialPlot(data = ExampleData.DeValues, summary = c("n", "in.2s")) ## now with another statistical summary as subheader plot_RadialPlot(data = ExampleData.DeValues, summary = c("mean.weighted", "median"), summary.pos = "sub") ## now the data set is split into sub-groups, one is manipulated data.1 <- ExampleData.DeValues[1:15,] data.2 <- ExampleData.DeValues[16:25,] * 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_RadialPlot(data = data.3) ## now with some graphical modification plot_RadialPlot(data = data.3, col = c("darkblue", "darkgreen"), bar.col = c("lightblue", "lightgreen"), pch = c(2, 6), summary = c("n", "in.2s"), summary.pos = "sub", legend = c("Sample 1", "Sample 2")) } \section{How to cite}{ Dietze, M., Kreutzer, S. (2017). plot_RadialPlot(): Function to create a Radial Plot. Function version 0.5.4. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Galbraith, R.F., 1988. Graphical Display of Estimates Having Differing Standard Errors. Technometrics, 30 (3), 271-281. Galbraith, R.F., 1990. The radial plot: Graphical assessment of spread in ages. International Journal of Radiation Applications and Instrumentation. Part D. Nuclear Tracks and Radiation Measurements, 17 (3), 207-214. 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. Galbraith, R.F. & Laslett, G.M., 1993. Statistical models for mixed fission track ages. Nuclear Tracks And Radiation Measurements, 21 (4), 459-470. Galbraith, R.F., 1994. Some Applications of Radial Plots. Journal of the American Statistical Association, 89 (428), 1232-1242. Galbraith, R.F., 2010. On plotting OSL equivalent doses. Ancient TL, 28 (1), 1-10. 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. } \seealso{ \code{\link{plot}}, \code{\link{plot_KDE}}, \code{\link{plot_Histogram}} } \author{ Michael Dietze, GFZ Potsdam (Germany),\cr Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France)\cr Based on a rewritten S script of Rex Galbraith, 2010 \cr R Luminescence Package Team} Luminescence/man/read_Daybreak2R.Rd0000644000176200001440000000504213125227576016662 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/read_Daybreak2R.R \name{read_Daybreak2R} \alias{read_Daybreak2R} \title{Import measurement data produced by a Daybreak TL/OSL reader into R} \usage{ read_Daybreak2R(file, raw = FALSE, verbose = TRUE, txtProgressBar = TRUE) } \arguments{ \item{file}{\code{\link{character}} or \code{\link{list}} (\bold{required}): path and file name of the file to be imported. Alternatively a list of file names can be provided or just the path a folder containing measurement data. Please note that the specific, common, file extension (txt) is likely leading to function failures during import when just a path is provided.} \item{raw}{\code{\link{logical}} (with default): if the input is a DAT-file (binary) a \code{\link[data.table]{data.table}} instead of the \code{\linkS4class{RLum.Analysis}} object can be returned for debugging purposes.} \item{verbose}{\code{\link{logical}} (with default): enables or disables terminal feedback} \item{txtProgressBar}{\code{\link{logical}} (with default): enables or disables \code{\link{txtProgressBar}}.} } \value{ A list of \code{\linkS4class{RLum.Analysis}} objects (each per position) is provided. } \description{ Import a TXT-file (ASCII file) or a DAT-file (binary file) produced by a Daybreak reader into R. The import of the DAT-files is limited to the file format described for the software TLAPLLIC v.3.2 used for a Daybreak, model 1100. } \note{ \bold{[BETA VERSION]} This function still needs to be tested properly. In particular the function has underwent only very rough rests using a few files. } \section{Function version}{ 0.3.0 (2017-06-29 18:40:14) } \examples{ \dontrun{ file <- file.choose() temp <- read_Daybreak2R(file) } } \section{How to cite}{ Kreutzer, S., Zink, A. (2017). read_Daybreak2R(): Import measurement data produced by a Daybreak TL/OSL reader into R. Function version 0.3.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ - } \seealso{ \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Data.Curve}}, \code{\link[data.table]{data.table}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France), \cr Anotine Zink, C2RMF, Palais du Louvre, Paris (France)\cr \cr The ASCII-file import is based on a suggestion by Willian Amidon and Andrew Louis Gorin \cr R Luminescence Package Team} \keyword{IO} Luminescence/man/model_LuminescenceSignals.Rd0000644000176200001440000001042313125227576021053 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/model_LuminescenceSignals.R \name{model_LuminescenceSignals} \alias{model_LuminescenceSignals} \title{Model Luminescence Signals (wrapper)} \usage{ model_LuminescenceSignals(model, sequence, lab.dose_rate = 1, simulate_sample_history = FALSE, plot = TRUE, verbose = TRUE, show_structure = FALSE, own_parameters = NULL, own_state_parameters = NULL, own_start_temperature = NULL, ...) } \arguments{ \item{model}{\code{\link{character}} (\bold{required}): set model to be used. Available models are: "Bailey2001", "Bailey2002", "Bailey2004", "Pagonis2007", "Pagonis2008" and "Friedrich2017".} \item{sequence}{\code{\link{list}} (\bold{required}): set sequence to model as \code{\link{list}} or as *.seq file from the Riso sequence editor. To simulate SAR measurements there is an extra option to set the sequence list (cf. details).} \item{lab.dose_rate}{\code{\link{numeric}} (with default): laboratory dose rate in XXX Gy/s for calculating seconds into Gray in the *.seq file.} \item{simulate_sample_history}{\code{\link{logical}} (with default): FALSE (with default): simulation begins at laboratory conditions, TRUE: simulations begins at crystallization (all levels 0) process} \item{plot}{\code{\link{logical}} (with default): Enables or disables plot output} \item{verbose}{\code{\link{logical}} (with default): Verbose mode on/off} \item{show_structure}{\code{\link{logical}} (with default): Shows the structure of the result. Recommended to show record.id to analyse concentrations.} \item{own_parameters}{\code{\link{list}} (with default): This argument allows the user to submit own parameter sets. The \code{\link{list}} has to contain the following items: \itemize{ \item{N: Concentration of electron- and hole traps [cm^(-3)]} \item{E: Electron/Hole trap depth [eV} \item{s: Frequency factor [s^(-1)]} \item{A: Conduction band to electron trap and valence band to hole trap transition probability [s^(-1) * cm^(3)]. \bold{CAUTION: Not every publication uses the same definition of parameter A and B! See vignette "RLumModel - Usage with own parameter sets" for further details}} \item{B: Conduction band to hole centre transition probability [s^(-1) * cm^(3)].} \item{Th: Photo-eviction constant or photoionisation cross section, respectively} \item{E_th: Thermal assistence energy [eV]} \item{k_B: Boltzman constant 8.617e-05 [eV/K]} \item{W: activation energy 0.64 [eV] (for UV)} \item{K: 2.8e7 (dimensionless constant)} \item{model: "customized"} \item{R (optional): Ionisation rate (pair production rate) equivalent to 1 Gy/s [s^(-1) * cm^(-3)]} } For further details see Bailey 2001, Wintle 1975, vignette "RLumModel - Using own parameter sets" and example 3.} \item{own_state_parameters}{\code{\link{numeric}} (with default): Some publications (e.g. Pagonis 2009) offer state parameters. With this argument the user can submit this state parameters. \bold{Note:} You have to submit the state parameters for the conduction band and the valence band, too. For further details see vignette ""RLumModel - Using own parameter sets" and example 3.} \item{own_start_temperature}{\code{\link{numeric}} (with default): Parameter to control the start temperature (in deg. C) of a simulation. This parameter takes effect only when 'model = "customized"' is choosen.} \item{...}{further arguments and graphical parameters passed to \code{\link{plot.default}}. See details for further information.} } \description{ Wrapper for the function \code{\link[RLumModel]{model_LuminescenceSignals}} from the package \link[RLumModel]{RLumModel-package}. For the further details and examples please see the manual of this package. } \section{Function version}{ 0.1.3 (2017-06-29 18:40:14) } \author{ Johannes Friedrich, University of Bayreuth (Germany),\cr Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaige (France), \cr \cr R Luminescence Package Team} \section{How to cite}{ Friedrich, J., Kreutzer, S. (2017). model_LuminescenceSignals(): Model Luminescence Signals (wrapper). Function version 0.1.3. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } Luminescence/man/calc_HomogeneityTest.Rd0000644000176200001440000000375213125227575020057 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_HomogeneityTest.R \name{calc_HomogeneityTest} \alias{calc_HomogeneityTest} \title{Apply a simple homogeneity test after Galbraith (2003)} \usage{ calc_HomogeneityTest(data, log = TRUE, ...) } \arguments{ \item{data}{\code{\linkS4class{RLum.Results}} or \link{data.frame} (\bold{required}): for \code{data.frame}: two columns with De \code{(data[,1])} and De error \code{(values[,2])}} \item{log}{\code{\link{logical}} (with default): peform the homogeniety test with (un-)logged data} \item{\dots}{further arguments (for internal compatibility only).} } \value{ Returns a terminal output. In addition an \code{\linkS4class{RLum.Results}} object is returned containing the following element: \item{summary}{\link{data.frame} summary of all relevant model results.} \item{data}{\link{data.frame} original input data} \item{args}{\link{list} used arguments} \item{call}{\link{call} the function call} The output should be accessed using the function \code{\link{get_RLum}} } \description{ A simple homogeneity test for De estimates } \details{ For details see Galbraith (2003). } \section{Function version}{ 0.2 (2017-06-29 18:40:14) } \examples{ ## load example data data(ExampleData.DeValues, envir = environment()) ## apply the homogeneity test calc_HomogeneityTest(ExampleData.DeValues$BT998) } \section{How to cite}{ Burow, C. (2017). calc_HomogeneityTest(): Apply a simple homogeneity test after Galbraith (2003). Function version 0.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Galbraith, R.F., 2003. A simple homogeneity test for estimates of dose obtained using OSL. Ancient TL 21, 75-77. } \seealso{ \code{\link{pchisq}} } \author{ Christoph Burow, University of Cologne (Germany) \cr R Luminescence Package Team} Luminescence/man/Second2Gray.Rd0000644000176200001440000001030213125227576016054 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Second2Gray.R \name{Second2Gray} \alias{Second2Gray} \title{Converting equivalent dose values from seconds (s) to gray (Gy)} \usage{ Second2Gray(data, dose.rate, error.propagation = "omit") } \arguments{ \item{data}{\code{\link{data.frame}} (\bold{required}): input values, structure: data (\code{values[,1]}) and data error (\code{values [,2]}) are required} \item{dose.rate}{\code{\linkS4class{RLum.Results}} or \code{\link{data.frame}} or \code{\link{numeric}} (\bold{required}): \code{RLum.Results} needs to be orginated from the function \code{\link{calc_SourceDoseRate}}, for \code{vector} dose rate in Gy/s and dose rate error in Gy/s} \item{error.propagation}{\code{\link{character}} (with default): error propagation method used for error calculation (\code{omit}, \code{gaussian} or \code{absolute}), see details for further information} } \value{ Returns a \link{data.frame} with converted values. } \description{ Conversion of absorbed radiation dose in seconds (s) to the SI unit gray (Gy) including error propagation. Normally used for equivalent dose data. } \details{ Calculation of De values from seconds (s) to gray (Gy) \deqn{De [Gy] = De [s] * Dose Rate [Gy/s])} \cr Provided calculation error propagation methods for error calculation (with 'se' as the standard error and 'DR' of the dose rate of the beta-source):\cr \bold{(1) \code{omit}} (default)\cr \deqn{se(De) [Gy] = se(De) [s] * DR [Gy/s]} In this case the standard error of the dose rate of the beta-source is treated as systematic (i.e. non-random), it error propagation is omitted. However, the error must be considered during calculation of the final age. (cf. Aitken, 1985, pp. 242). This approach can be seen as method (2) (gaussian) for the case the (random) standard error of the beta-source calibration is 0. Which particular method is requested depends on the situation and cannot be prescriptive. \bold{(2) \code{gaussian}} error propagation \cr \deqn{se(De) [Gy] = \sqrt((DR [Gy/s] * se(De) [s])^2 + (De [s] * se(DR) [Gy/s])^2)} Applicable under the assumption that errors of De and se are uncorrelated. \bold{(3) \code{absolute}} error propagation \cr \deqn{se(De) [Gy]= abs(DR [Gy/s] * se(De) [s]) + abs(De [s] * se(DR) [Gy/s])} Applicable under the assumption that errors of De and se are not uncorrelated. } \note{ If no or a wrong error propagation method is given, the execution of the function is stopped. Furthermore, if a \code{data.frame} is provided for the dose rate values is has to be of the same length as the data frame provided with the argument \code{data} } \section{Function version}{ 0.6.0 (2017-06-29 18:40:14) } \examples{ ##(A) for known source dose rate at date of measurement ## - load De data from the example data help file data(ExampleData.DeValues, envir = environment()) ## - convert De(s) to De(Gy) Second2Gray(ExampleData.DeValues$BT998, c(0.0438,0.0019)) ##(B) for source dose rate calibration data ## - calculate source dose rate first dose.rate <- calc_SourceDoseRate(measurement.date = "2012-01-27", calib.date = "2014-12-19", calib.dose.rate = 0.0438, calib.error = 0.0019) # read example data data(ExampleData.DeValues, envir = environment()) # apply dose.rate to convert De(s) to De(Gy) Second2Gray(ExampleData.DeValues$BT998, dose.rate) } \section{How to cite}{ Kreutzer, S., Dietze, M., Fuchs, M.C., Fuchs, M. (2017). Second2Gray(): Converting equivalent dose values from seconds (s) to gray (Gy). Function version 0.6.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Aitken, M.J., 1985. Thermoluminescence dating. Academic Press. } \seealso{ \code{\link{calc_SourceDoseRate}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France),\cr Michael Dietze, GFZ Potsdam (Germany),\cr Margret C. Fuchs, HZDR, Helmholtz-Institute Freiberg for Resource Technology (Germany) \cr R Luminescence Package Team} \keyword{manip} Luminescence/man/calc_Statistics.Rd0000644000176200001440000000625313125227576017062 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_Statistics.R \name{calc_Statistics} \alias{calc_Statistics} \title{Function to calculate statistic measures} \usage{ calc_Statistics(data, weight.calc = "square", digits = NULL, n.MCM = NULL, na.rm = TRUE) } \arguments{ \item{data}{\code{\link{data.frame}} or \code{\linkS4class{RLum.Results}} object (required): for \code{data.frame} two columns: De (\code{data[,1]}) and De error (\code{data[,2]}). To plot several data sets in one plot the data sets must be provided as \code{list}, e.g. \code{list(data.1, data.2)}.} \item{weight.calc}{\code{\link{character}}: type of weight calculation. One out of \code{"reciprocal"} (weight is 1/error), \code{"square"} (weight is 1/error^2). Default is \code{"square"}.} \item{digits}{\code{\link{integer}} (with default): round numbers to the specified digits. If digits is set to \code{NULL} nothing is rounded.} \item{n.MCM}{\code{\link{numeric}} (with default): number of samples drawn for Monte Carlo-based statistics. \code{NULL} (the default) disables MC runs.} \item{na.rm}{\code{\link{logical}} (with default): indicating whether NA values should be stripped before the computation proceeds.} } \value{ Returns a list with weighted and unweighted statistic measures. } \description{ This function calculates a number of descriptive statistics for estimates with a given standard error (SE), most fundamentally using error-weighted approaches. } \details{ The option to use Monte Carlo Methods (\code{n.MCM}) allows calculating all descriptive statistics based on random values. The distribution of these random values is based on the Normal distribution with \code{De} values as means and \code{De_error} values as one standard deviation. Increasing the number of MCM-samples linearly increases computation time. On a Lenovo X230 machine evaluation of 25 Aliquots with n.MCM = 1000 takes 0.01 s, with n = 100000, ca. 1.65 s. It might be useful to work with logarithms of these values. See Dietze et al. (2016, Quaternary Geochronology) and the function \code{\link{plot_AbanicoPlot}} for details. } \section{Function version}{ 0.1.7 (2017-06-29 18:40:14) } \examples{ ## load example data data(ExampleData.DeValues, envir = environment()) ## show a rough plot of the data to illustrate the non-normal distribution plot_KDE(ExampleData.DeValues$BT998) ## calculate statistics and show output str(calc_Statistics(ExampleData.DeValues$BT998)) \dontrun{ ## now the same for 10000 normal distributed random numbers with equal errors x <- as.data.frame(cbind(rnorm(n = 10^5, mean = 0, sd = 1), rep(0.001, 10^5))) ## note the congruent results for weighted and unweighted measures str(calc_Statistics(x)) } } \author{ Michael Dietze, GFZ Potsdam (Germany) \cr R Luminescence Package Team} \section{How to cite}{ Dietze, M. (2017). calc_Statistics(): Function to calculate statistic measures. Function version 0.1.7. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{datagen} Luminescence/man/calc_SourceDoseRate.Rd0000644000176200001440000001372013125227575017613 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_SourceDoseRate.R \name{calc_SourceDoseRate} \alias{calc_SourceDoseRate} \title{Calculation of the source dose rate via the date of measurement} \usage{ calc_SourceDoseRate(measurement.date, calib.date, calib.dose.rate, calib.error, source.type = "Sr-90", dose.rate.unit = "Gy/s", predict = NULL) } \arguments{ \item{measurement.date}{\code{\link{character}} or \code{\link{Date}} (\bold{required}): date of measurement in "YYYY-MM-DD". Exceptionally, if no value is provided, the date will be set to today. The argument can be provided as vector.} \item{calib.date}{\code{\link{character}} or \code{\link{Date}} (\bold{required}): date of source calibration in "YYYY-MM-DD"} \item{calib.dose.rate}{\code{\link{numeric}} (\bold{required}): dose rate at date of calibration in Gy/s or Gy/min} \item{calib.error}{\code{\link{numeric}} (\bold{required}): error of dose rate at date of calibration Gy/s or Gy/min} \item{source.type}{\code{\link{character}} (with default): specify irrdiation source (\code{Sr-90} or \code{Co-60} or \code{Am-214}), see details for further information} \item{dose.rate.unit}{\code{\link{character}} (with default): specify dose rate unit for input (\code{Gy/min} or \code{Gy/s}), the output is given in Gy/s as valid for the function \code{\link{Second2Gray}}} \item{predict}{\code{\link{integer}} (with default): option allowing to predicit the dose rate of the source over time in days set by the provided value. Starting date is the value set with \code{measurement.date}, e.g., \code{calc_SourceDoseRate(...,predict = 100)} calculates the source dose rate for the next 100 days.} } \value{ Returns an S4 object of type \code{\linkS4class{RLum.Results}}. Slot \code{data} contains a \code{\link{list}} with the following structure:\cr $ dose.rate (data.frame)\cr .. $ dose.rate \cr .. $ dose.rate.error \cr .. $ date (corresponding measurement date)\cr $ parameters (list) \cr .. $ source.type\cr .. $ halflife\cr .. $ dose.rate.unit\cr $ call (the original function call)\cr The output should be accessed using the function \code{\link{get_RLum}}.\cr A plot method of the output is provided via \code{\link{plot_RLum}} } \description{ Calculating the dose rate of the irradiation source via the date of measurement based on: source calibration date, source dose rate, dose rate error. The function returns a data.frame that provides the input argument dose_rate for the function \code{\link{Second2Gray}}. } \details{ Calculation of the source dose rate based on the time elapsed since the last calibration of the irradiation source. Decay parameters assume a Sr-90 beta source. \deqn{dose.rate = D0 * exp(-log(2) / T.1/2 * t)} \cr with: D0 <- calibration dose rate T.1/2 <- half-life of the source nuclide (here in days) t <- time since source calibration (in days) log(2) / T.1/2 equals the decay constant lambda Information on the date of measurements may be taken from the data's original .BIN file (using e.g., BINfile <- readBIN2R() and the slot BINfile@METADATA$DATE) \bold{Allowed source types and related values} \tabular{rllll}{ \bold{#} \tab \bold{Source type} \tab \bold{T.1/2} \tab \bold{Reference} \cr [1] \tab Sr-90 \tab 28.90 y \tab NNDC, Brookhaven National Laboratory \cr [2] \tab Am-214 \tab 432.6 y \tab NNDC, Brookhaven National Laboratory \cr [3] \tab Co-60 \tab 5.274 y \tab NNDC, Brookhaven National Laboratory } } \note{ Please be careful when using the option \code{predict}, especially when a multiple set for \code{measurement.date} and \code{calib.date} is provided. For the source dose rate prediction the function takes the last value \code{measurement.date} and predicts from that the the source source dose rate for the number of days requested, means: the (multiple) orignal input will be replaced. However, the function do not change entries for the calibration dates, but mix them up. Therefore, it is not recommended to use this option when multiple calibration dates (\code{calib.date}) are provided. } \section{Function version}{ 0.3.0 (2017-06-29 18:40:14) } \examples{ ##(1) Simple function usage ##Basic calculation of the dose rate for a specific date dose.rate <- calc_SourceDoseRate(measurement.date = "2012-01-27", calib.date = "2014-12-19", calib.dose.rate = 0.0438, calib.error = 0.0019) ##show results get_RLum(dose.rate) ##(2) Usage in combination with another function (e.g., Second2Gray() ) ## load example data data(ExampleData.DeValues, envir = environment()) ## use the calculated variable dose.rate as input argument ## to convert De(s) to De(Gy) Second2Gray(ExampleData.DeValues$BT998, dose.rate) ##(3) source rate prediction and plotting dose.rate <- calc_SourceDoseRate(measurement.date = "2012-01-27", calib.date = "2014-12-19", calib.dose.rate = 0.0438, calib.error = 0.0019, predict = 1000) plot_RLum(dose.rate) ##(4) export output to a LaTeX table (example using the package 'xtable') \dontrun{ xtable::xtable(get_RLum(dose.rate)) } } \section{How to cite}{ Fuchs, M.C., Fuchs, M., Kreutzer, S. (2017). calc_SourceDoseRate(): Calculation of the source dose rate via the date of measurement. Function version 0.3.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ NNDC, Brookhaven National Laboratory (\code{http://www.nndc.bnl.gov/}) } \seealso{ \code{\link{Second2Gray}}, \code{\link{get_RLum}}, \code{\link{plot_RLum}} } \author{ Margret C. Fuchs, HZDR, Helmholtz-Institute Freiberg for Resource Technology (Germany), \cr Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{manip} Luminescence/man/template_DRAC.Rd0000644000176200001440000000504513125227576016350 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/template_DRAC.R \name{template_DRAC} \alias{template_DRAC} \title{Create a DRAC input data template (v1.1)} \usage{ template_DRAC(nrow = 1, notification = TRUE) } \arguments{ \item{nrow}{\code{\link{integer}} (with default): specifies the number of rows of the template (i.e., the number of data sets you want to submit)} \item{notification}{\code{\link{logical}} (with default): show or hide the notification} } \value{ A list. } \description{ This function returns a DRAC input template (v1.1) to be used in conjunction with the use_DRAC() function } \examples{ # create a new DRAC input input input <- template_DRAC() # show content of the input print(input) print(input$`Project ID`) print(input[[4]]) ## Example: DRAC Quartz example # note that you only have to assign new values where they # are different to the default values input$`Project ID` <- "DRAC-Example" input$`Sample ID` <- "Quartz" input$`Conversion factors` <- "AdamiecAitken1998" input$`External U (ppm)` <- 3.4 input$`errExternal U (ppm)` <- 0.51 input$`External Th (ppm)` <- 14.47 input$`errExternal Th (ppm)` <- 1.69 input$`External K (\%)` <- 1.2 input$`errExternal K (\%)` <- 0.14 input$`Calculate external Rb from K conc?` <- "N" input$`Calculate internal Rb from K conc?` <- "N" input$`Scale gammadoserate at shallow depths?` <- "N" input$`Grain size min (microns)` <- 90 input$`Grain size max (microns)` <- 125 input$`Water content ((wet weight - dry weight)/dry weight) \%` <- 5 input$`errWater content \%` <- 2 input$`Depth (m)` <- 2.2 input$`errDepth (m)` <- 0.22 input$`Overburden density (g cm-3)` <- 1.8 input$`errOverburden density (g cm-3)` <- 0.1 input$`Latitude (decimal degrees)` <- 30.0000 input$`Longitude (decimal degrees)` <- 70.0000 input$`Altitude (m)` <- 150 input$`De (Gy)` <- 20 input$`errDe (Gy)` <- 0.2 # use DRAC \dontrun{ output <- use_DRAC(input) } } \section{How to cite}{ Burow, C. (2017). template_DRAC(): Create a DRAC input data template (v1.1). In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Durcan, J.A., King, G.E., Duller, G.A.T., 2015. DRAC: Dose Rate and Age Calculator for trapped charge dating. Quaternary Geochronology 28, 54-61. doi:10.1016/j.quageo.2015.03.012 } \seealso{ \code{\link{as.data.frame}} \code{\link{list}} } \author{ Christoph Burow, University of Cologne (Germany) } Luminescence/man/RLum.Data.Spectrum-class.Rd0000644000176200001440000001101213125227576020366 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RLum.Data.Spectrum-class.R \docType{class} \name{RLum.Data.Spectrum-class} \alias{RLum.Data.Spectrum-class} \alias{show,RLum.Data.Spectrum-method} \alias{set_RLum,RLum.Data.Spectrum-method} \alias{get_RLum,RLum.Data.Spectrum-method} \alias{names_RLum,RLum.Data.Spectrum-method} \title{Class \code{"RLum.Data.Spectrum"}} \usage{ \S4method{show}{RLum.Data.Spectrum}(object) \S4method{set_RLum}{RLum.Data.Spectrum}(class, originator, .uid, .pid, recordType = "Spectrum", curveType = NA_character_, data = matrix(), info = list()) \S4method{get_RLum}{RLum.Data.Spectrum}(object, info.object) \S4method{names_RLum}{RLum.Data.Spectrum}(object) } \arguments{ \item{object}{[\code{show_RLum}][\code{get_RLum}][\code{names_RLum}] an object of class \code{\linkS4class{RLum.Data.Spectrum}}} \item{class}{[\code{set_RLum}] \code{\link{character}} (automatic): name of the \code{RLum} class to create.} \item{originator}{\code{\link{character}} (automatic): contains the name of the calling function (the function that produces this object); can be set manually.} \item{.uid}{[\code{set_RLum}] \code{\link{character}} (automatic): sets an unique ID for this object using the internal C++ function \code{.create_UID}.} \item{.pid}{[\code{set_RLum}] \code{\link{character}} (with default): option to provide a parent id for nesting at will.} \item{recordType}{[\code{set_RLum}] \code{\link{character}}: record type (e.g. "OSL")} \item{curveType}{[\code{set_RLum}] \code{\link{character}}: curve type (e.g. "predefined" or "measured")} \item{data}{[\code{set_RLum}] \code{\link{matrix}}: raw curve data. If data is of type \code{RLum.Data.Spectrum}, this can be used to re-construct the object.} \item{info}{[\code{set_RLum}] \code{\link{list}}: info elements} \item{info.object}{[\code{get_RLum}] \code{\link{character}} (optional): the name of the info object to be called} } \value{ \bold{\code{[set_RLum]}}\cr An object from the class \code{RLum.Data.Spectrum} \bold{\code{get_RLum}}\cr (1) A \code{\link{matrix}} with the spectrum values or \cr (2) only the info object if \code{info.object} was set.\cr \bold{\code{names_RLum}}\cr The names of the info objects } \description{ Class for representing luminescence spectra data (TL/OSL/RF). } \section{Methods (by generic)}{ \itemize{ \item \code{show}: Show structure of \code{RLum.Data.Spectrum} object \item \code{set_RLum}: Construction method for RLum.Data.Spectrum object. The slot info is optional and predefined as empty list by default \item \code{get_RLum}: Accessor method for RLum.Data.Spectrum object. The argument info.object is optional to directly access the info elements. If no info element name is provided, the raw curve data (matrix) will be returned \item \code{names_RLum}: Returns the names info elements coming along with this curve object }} \section{Slots}{ \describe{ \item{\code{recordType}}{Object of class \code{\link{character}} containing the type of the curve (e.g. "TL" or "OSL")} \item{\code{curveType}}{Object of class \code{\link{character}} containing curve type, allowed values are measured or predefined} \item{\code{data}}{Object of class \code{\link{matrix}} containing spectrum (count) values. Row labels indicate wavelength/pixel values, column labels are temperature or time values.} \item{\code{info}}{Object of class \code{\link{list}} containing further meta information objects} }} \note{ The class should only contain data for a single spectra data set. For additional elements the slot \code{info} can be used. Objects from this class are automatically created by, e.g., \code{\link{read_XSYG2R}} } \section{Objects from the Class}{ Objects can be created by calls of the form \code{set_RLum("RLum.Data.Spectrum", ...)}. } \section{Class version}{ 0.4.0 } \examples{ showClass("RLum.Data.Spectrum") ##show example data data(ExampleData.XSYG, envir = environment()) TL.Spectrum ##show data matrix get_RLum(TL.Spectrum) ##plot spectrum \dontrun{ plot_RLum(TL.Spectrum) } } \seealso{ \code{\linkS4class{RLum}}, \code{\linkS4class{RLum.Data}}, \code{\link{plot_RLum}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) } \section{How to cite}{ Kreutzer, S. (2017). RLum.Data.Spectrum-class(): Class 'RLum.Data.Spectrum'. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{classes} Luminescence/man/plot_RLum.Results.Rd0000644000176200001440000000420313125227576017314 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_RLum.Results.R \name{plot_RLum.Results} \alias{plot_RLum.Results} \title{Plot function for an RLum.Results S4 class object} \usage{ plot_RLum.Results(object, single = TRUE, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Results}} (\bold{required}): S4 object of class \code{RLum.Results}} \item{single}{\code{\link{logical}} (with default): single plot output (\code{TRUE/FALSE}) to allow for plotting the results in as few plot windows as possible.} \item{\dots}{further arguments and graphical parameters will be passed to the \code{plot} function.} } \value{ Returns multiple plots. } \description{ The function provides a standardised plot output for data of an RLum.Results S4 class object } \details{ The function produces a multiple plot output. A file output is recommended (e.g., \code{\link{pdf}}). } \note{ Not all arguments available for \code{\link{plot}} will be passed! Only plotting of \code{RLum.Results} objects are supported. } \section{Function version}{ 0.2.1 (2017-06-29 18:40:14) } \examples{ ###load data data(ExampleData.DeValues, envir = environment()) # apply the un-logged minimum age model mam <- calc_MinDose(data = ExampleData.DeValues$CA1, sigmab = 0.2, log = TRUE, plot = FALSE) ##plot plot_RLum.Results(mam) # estimate the number of grains on an aliquot grains<- calc_AliquotSize(grain.size = c(100,150), sample.diameter = 1, plot = FALSE, MC.iter = 100) ##plot plot_RLum.Results(grains) } \section{How to cite}{ Burow, C., Kreutzer, S. (2017). plot_RLum.Results(): Plot function for an RLum.Results S4 class object. Function version 0.2.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ # } \seealso{ \code{\link{plot}}, \code{\link{plot_RLum}}, } \author{ Christoph Burow, University of Cologne (Germany), Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{aplot} Luminescence/man/calc_CosmicDoseRate.Rd0000644000176200001440000002376013125227575017575 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_CosmicDoseRate.R \name{calc_CosmicDoseRate} \alias{calc_CosmicDoseRate} \title{Calculate the cosmic dose rate} \usage{ calc_CosmicDoseRate(depth, density, latitude, longitude, altitude, corr.fieldChanges = FALSE, est.age = NA, half.depth = FALSE, error = 10, ...) } \arguments{ \item{depth}{\code{\link{numeric}} (\bold{required}): depth of overburden (m). For more than one absorber use \cr \code{c(depth_1, depth_2, ..., depth_n)}} \item{density}{\code{\link{numeric}} (\bold{required}): average overburden density (g/cm^3). For more than one absorber use \cr \code{c(density_1, density_2, ..., density_n)}} \item{latitude}{\code{\link{numeric}} (\bold{required}): latitude (decimal degree), N positive} \item{longitude}{\code{\link{numeric}} (\bold{required}): longitude (decimal degree), E positive} \item{altitude}{\code{\link{numeric}} (\bold{required}): altitude (m above sea-level)} \item{corr.fieldChanges}{\code{\link{logical}} (with default): correct for geomagnetic field changes after Prescott & Hutton (1994). Apply only when justified by the data.} \item{est.age}{\code{\link{numeric}} (with default): estimated age range (ka) for geomagnetic field change correction (0-80 ka allowed)} \item{half.depth}{\code{\link{logical}} (with default): How to overcome with varying overburden thickness. If \code{TRUE} only half the depth is used for calculation. Apply only when justified, i.e. when a constant sedimentation rate can safely be assumed.} \item{error}{\code{\link{numeric}} (with default): general error (percentage) to be implemented on corrected cosmic dose rate estimate} \item{...}{further arguments (\code{verbose} to disable/enable console output).} } \value{ Returns a terminal output. In addition an \code{\linkS4class{RLum.Results}} object is returned containing the following element: \item{summary}{\link{data.frame} summary of all relevant calculation results.} \item{args}{\link{list} used arguments} \item{call}{\link{call} the function call} The output should be accessed using the function \code{\link{get_RLum}} } \description{ This function calculates the cosmic dose rate taking into account the soft- and hard-component of the cosmic ray flux and allows corrections for geomagnetic latitude, altitude above sea-level and geomagnetic field changes. } \details{ This function calculates the total cosmic dose rate considering both the soft- and hard-component of the cosmic ray flux.\cr \bold{Internal calculation steps} (1) Calculate total depth of all absorber in hg/cm^2 (1 hg/cm^2 = 100 g/cm^2) \deqn{absorber = depth_1*density_1 + depth_2*density_2 + ... + depth_n* density_n} (2) If \code{half.depth = TRUE} \deqn{absorber = absorber/2} (3) Calculate cosmic dose rate at sea-level and 55 deg. latitude a) If absorber is > 167 g/cm^2 (only hard-component; Allkofer et al. 1975): apply equation given by Prescott & Hutton (1994) (c.f. Barbouti & Rastin 1983) \deqn{D0 = C/(((absorber+d)^\alpha+a)*(absober+H))*exp(-B*absorber)} b) If absorber is < 167 g/cm^2 (soft- and hard-component): derive D0 from Fig. 1 in Prescott & Hutton (1988). (4) Calculate geomagnetic latitude (Prescott & Stephan 1982, Prescott & Hutton 1994) \deqn{\lambda = arcsin(0.203*cos(latitude)*cos(longitude-291)+0.979* sin(latitude))} (5) Apply correction for geomagnetic latitude and altitude above sea-level. Values for F, J and H were read from Fig. 3 shown in Prescott & Stephan (1982) and fitted with 3-degree polynomials for lambda < 35 degree and a linear fit for lambda > 35 degree. \deqn{Dc = D0*(F+J*exp((altitude/1000)/H))} (6) Optional: Apply correction for geomagnetic field changes in the last 0-80 ka (Prescott & Hutton 1994). Correction and altitude factors are given in Table 1 and Fig. 1 in Prescott & Hutton (1994). Values for altitude factor were fitted with a 2-degree polynomial. The altitude factor is operated on the decimal part of the correction factor. \deqn{Dc' = Dc*correctionFactor} \bold{Usage of \code{depth} and \code{density}} (1) If only one value for depth and density is provided, the cosmic dose rate is calculated for exactly one sample and one absorber as overburden (i.e. \code{depth*density}). (2) In some cases it might be useful to calculate the cosmic dose rate for a sample that is overlain by more than one absorber, e.g. in a profile with soil layers of different thickness and a distinct difference in density. This can be calculated by providing a matching number of values for \code{depth} and \code{density} (e.g. \code{depth = c(1, 2), density = c(1.7, 2.4)}) (3) Another possibility is to calculate the cosmic dose rate for more than one sample of the same profile. This is done by providing more than one values for \code{depth} and only one for \code{density}. For example, \code{depth = c(1, 2, 3), density = 1.7} will calculate the cosmic dose rate for three samples in 1, 2 and 3 m depth in a sediment of density 1.7 g/cm^3. } \note{ Despite its universal use the equation to calculate the cosmic dose rate provided by Prescott & Hutton (1994) is falsely stated to be valid from the surface to 10^4 hg/cm^2 of standard rock. The original expression by Barbouti & Rastin (1983) only considers the muon flux (i.e. hard-component) and is by their own definition only valid for depths between 10-10^4 hg/cm^2. Thus, for near-surface samples (i.e. for depths < 167 g/cm^2) the equation of Prescott & Hutton (1994) underestimates the total cosmic dose rate, as it neglects the influence of the soft-component of the cosmic ray flux. For samples at zero depth and at sea-level the underestimation can be as large as ~0.1 Gy/ka. In a previous article, Prescott & Hutton (1988) give another approximation of Barbouti & Rastins equation in the form of \deqn{D = 0.21*exp(-0.070*absorber+0.0005*absorber^2)} which is valid for depths between 150-5000 g/cm^2. For shallower depths (< 150 g/cm^2) they provided a graph (Fig. 1) from which the dose rate can be read. As a result, this function employs the equation of Prescott & Hutton (1994) only for depths > 167 g/cm^2, i.e. only for the hard-component of the cosmic ray flux. Cosmic dose rate values for depths < 167 g/cm^2 were obtained from the "AGE" programm (Gruen 2009) and fitted with a 6-degree polynomial curve (and hence reproduces the graph shown in Prescott & Hutton 1988). However, these values assume an average overburden density of 2 g/cm^3. It is currently not possible to obtain more precise cosmic dose rate values for near-surface samples as there is no equation known to the author of this function at the time of writing. } \section{Function version}{ 0.5.2 (2017-06-29 18:40:14) } \examples{ ##(1) calculate cosmic dose rate (one absorber) calc_CosmicDoseRate(depth = 2.78, density = 1.7, latitude = 38.06451, longitude = 1.49646, altitude = 364, error = 10) ##(2a) calculate cosmic dose rate (two absorber) calc_CosmicDoseRate(depth = c(5.0, 2.78), density = c(2.65, 1.7), latitude = 38.06451, longitude = 1.49646, altitude = 364, error = 10) ##(2b) calculate cosmic dose rate (two absorber) and ##correct for geomagnetic field changes calc_CosmicDoseRate(depth = c(5.0, 2.78), density = c(2.65, 1.7), latitude = 12.04332, longitude = 4.43243, altitude = 364, corr.fieldChanges = TRUE, est.age = 67, error = 15) ##(3) calculate cosmic dose rate and export results to .csv file #calculate cosmic dose rate and save to variable results<- calc_CosmicDoseRate(depth = 2.78, density = 1.7, latitude = 38.06451, longitude = 1.49646, altitude = 364, error = 10) # the results can be accessed by get_RLum(results, "summary") #export results to .csv file - uncomment for usage #write.csv(results, file = "c:/users/public/results.csv") ##(4) calculate cosmic dose rate for 6 samples from the same profile ## and save to .csv file #calculate cosmic dose rate and save to variable results<- calc_CosmicDoseRate(depth = c(0.1, 0.5 , 2.1, 2.7, 4.2, 6.3), density = 1.7, latitude = 38.06451, longitude = 1.49646, altitude = 364, error = 10) #export results to .csv file - uncomment for usage #write.csv(results, file = "c:/users/public/results_profile.csv") } \section{How to cite}{ Burow, C. (2017). calc_CosmicDoseRate(): Calculate the cosmic dose rate. Function version 0.5.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Allkofer, O.C., Carstensen, K., Dau, W.D., Jokisch, H., 1975. Letter to the editor. The absolute cosmic ray flux at sea level. Journal of Physics G: Nuclear and Particle Physics 1, L51-L52. \cr\cr Barbouti, A.I., Rastin, B.C., 1983. A study of the absolute intensity of muons at sea level and under various thicknesses of absorber. Journal of Physics G: Nuclear and Particle Physics 9, 1577-1595. \cr\cr Crookes, J.N., Rastin, B.C., 1972. An investigation of the absolute intensity of muons at sea-level. Nuclear Physics B 39, 493-508. \cr\cr Gruen, R., 2009. The "AGE" program for the calculation of luminescence age estimates. Ancient TL 27, 45-46. \cr\cr Prescott, J.R., Hutton, J.T., 1988. Cosmic ray and gamma ray dosimetry for TL and ESR. Nuclear Tracks and Radiation Measurements 14, \cr\cr 223-227. Prescott, J.R., Hutton, J.T., 1994. Cosmic ray contributions to dose rates for luminescence and ESR dating: large depths and long-term time variations. Radiation Measurements 23, 497-500. \cr\cr Prescott, J.R., Stephan, L.G., 1982. The contribution of cosmic radiation to the environmental dose for thermoluminescence dating. Latitude, altitude and depth dependences. PACT 6, 17-25. } \seealso{ \code{\link{BaseDataSet.CosmicDoseRate}} } \author{ Christoph Burow, University of Cologne (Germany) \cr R Luminescence Package Team} Luminescence/man/names_RLum.Rd0000644000176200001440000000275313125227576016011 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/names_RLum.R \name{names_RLum} \alias{names_RLum} \title{S4-names function for RLum S4 class objects} \usage{ names_RLum(object) } \arguments{ \item{object}{\code{\linkS4class{RLum}} (\bold{required}): S4 object of class \code{RLum}} } \value{ Returns a \code{\link{character}} } \description{ Function calls object-specific names functions for RLum S4 class objects. } \details{ The function provides a generalised access point for specific \code{\linkS4class{RLum}} objects.\cr Depending on the input object, the corresponding 'names' function will be selected. Allowed arguments can be found in the documentations of the corresponding \code{\linkS4class{RLum}} class. } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \seealso{ \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Image}}, \code{\linkS4class{RLum.Data.Spectrum}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). names_RLum(): S4-names function for RLum S4 class objects. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{utilities} Luminescence/man/calc_IEU.Rd0000644000176200001440000000610313125227575015343 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_IEU.R \name{calc_IEU} \alias{calc_IEU} \title{Apply the internal-external-uncertainty (IEU) model after Thomsen et al. (2007) to a given De distribution} \usage{ calc_IEU(data, a, b, interval, decimal.point = 2, plot = TRUE, ...) } \arguments{ \item{data}{\code{\linkS4class{RLum.Results}} or \link{data.frame} (\bold{required}): for \code{data.frame}: two columns with De \code{(data[,1])} and De error \code{(values[,2])}} \item{a}{\code{\link{numeric}}: slope} \item{b}{\code{\link{numeric}}: intercept} \item{interval}{\code{\link{numeric}}: fixed interval (e.g. 5 Gy) used for iteration of Dbar, from the mean to Lowest.De used to create Graph.IEU [Dbar.Fixed vs Z]} \item{decimal.point}{\code{\link{numeric}} (with default): number of decimal points for rounding calculations (e.g. 2)} \item{plot}{\code{\link{logical}} (with default): plot output} \item{\dots}{further arguments (\code{trace, verbose}).} } \value{ Returns a plot (optional) and terminal output. In addition an \code{\linkS4class{RLum.Results}} object is returned containing the following element: \item{summary}{\link{data.frame} summary of all relevant model results.} \item{data}{\link{data.frame} original input data} \item{args}{\link{list} used arguments} \item{call}{\link{call} the function call} \item{tables}{\link{list} a list of data frames containing all calculation tables} The output should be accessed using the function \code{\link{get_RLum}}. } \description{ Function to calculate the IEU De for a De data set. } \details{ This function uses the equations of Thomsen et al. (2007). The parameters a and b are estimated from dose-recovery experiments. } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \examples{ ## load data data(ExampleData.DeValues, envir = environment()) ## apply the IEU model ieu <- calc_IEU(ExampleData.DeValues$CA1, a = 0.2, b = 1.9, interval = 1) } \section{How to cite}{ Smedley, R.K. (2017). calc_IEU(): Apply the internal-external-uncertainty (IEU) model after Thomsen et al. (2007) to a given De distribution. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Smedley, R.K., 2015. A new R function for the Internal External Uncertainty (IEU) model. Ancient TL 33, 16-21. Thomsen, K.J., Murray, A.S., Boetter-Jensen, L. & Kinahan, J., 2007. Determination of burial dose in incompletely bleached fluvial samples using single grains of quartz. Radiation Measurements 42, 370-379. } \seealso{ \code{\link{plot}}, \code{\link{calc_CommonDose}}, \code{\link{calc_CentralDose}}, \code{\link{calc_FiniteMixture}}, \code{\link{calc_FuchsLang2001}}, \code{\link{calc_MinDose}} } \author{ Rachel Smedley, Geography & Earth Sciences, Aberystwyth University (United Kingdom) \cr Based on an excel spreadsheet and accompanying macro written by Kristina Thomsen. \cr R Luminescence Package Team} Luminescence/man/smooth_RLum.Rd0000644000176200001440000000435113125227576016213 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/smooth_RLum.R \docType{methods} \name{smooth_RLum} \alias{smooth_RLum} \alias{smooth_RLum,list-method} \title{Smoothing of data} \usage{ smooth_RLum(object, ...) \S4method{smooth_RLum}{list}(object, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum}} (\bold{required}): S4 object of class \code{RLum}} \item{...}{further arguments passed to the specifc class method} } \value{ An object of the same type as the input object is provided } \description{ Function calls the object-specific smooth functions for provided RLum S4-class objects. } \details{ The function provides a generalised access point for specific \code{\linkS4class{RLum}} objects.\cr Depending on the input object, the corresponding function will be selected. Allowed arguments can be found in the documentations of the corresponding \code{\linkS4class{RLum}} class. The smoothing is based on an internal function called \code{.smoothing}. } \section{Methods (by class)}{ \itemize{ \item \code{list}: Returns a list of \code{\linkS4class{RLum}} objects that had been passed to \code{\link{smooth_RLum}} }} \note{ Currenlty only \code{RLum} objects of class \code{RLum.Data.Curve} and \code{RLum.Analysis} (with curve data) are supported! } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \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)) } \seealso{ \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Analysis}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). smooth_RLum(): Smoothing of data. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{utilities} Luminescence/man/plot_GrowthCurve.Rd0000644000176200001440000002277313125227576017270 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_GrowthCurve.R \name{plot_GrowthCurve} \alias{plot_GrowthCurve} \title{Fit and plot a growth curve for luminescence data (Lx/Tx against dose)} \usage{ plot_GrowthCurve(sample, na.rm = TRUE, mode = "interpolation", fit.method = "EXP", fit.force_through_origin = FALSE, fit.weights = TRUE, fit.includingRepeatedRegPoints = TRUE, fit.NumberRegPoints = NULL, fit.NumberRegPointsReal = NULL, fit.bounds = TRUE, NumberIterations.MC = 100, output.plot = TRUE, output.plotExtended = TRUE, output.plotExtended.single = FALSE, cex.global = 1, txtProgressBar = TRUE, verbose = TRUE, ...) } \arguments{ \item{sample}{\code{\link{data.frame}} (\bold{required}): data frame with three columns for x=Dose,y=LxTx,z=LxTx.Error, y1=TnTx. The column for the test dose response is optional, but requires 'TnTx' as column name if used. For exponential fits at least three dose points (including the natural) should be provided.} \item{na.rm}{\code{\link{logical}} (with default): excludes \code{NA} values from the data set prior to any further operations.} \item{mode}{\code{\link{character}} (with default): selects calculation mode of the function. (A) \code{"interpolation"} (default) calculates the De by interpolation, (B) \code{"extrapolation"} calculates the De by extrapolation and (C) \code{"alternate"} calculates no De and just fits the data points. Please note that for option \code{"regenrative"} the first point is considered as natural dose} \item{fit.method}{\code{\link{character}} (with default): function used for fitting. Possible options are: \code{LIN}, \code{QDR}, \code{EXP}, \code{EXP OR LIN}, \code{EXP+LIN} or \code{EXP+EXP}. See details.} \item{fit.force_through_origin}{\code{\link{logical}} (with default) allow to force the fitted function through the origin. For \code{method = "EXP+EXP"} the function will go to the origin in either case, so this option will have no effect.} \item{fit.weights}{\code{\link{logical}} (with default): option whether the fitting is done with or without weights. See details.} \item{fit.includingRepeatedRegPoints}{\code{\link{logical}} (with default): includes repeated points for fitting (\code{TRUE}/\code{FALSE}).} \item{fit.NumberRegPoints}{\code{\link{integer}} (optional): set number of regeneration points manually. By default the number of all (!) regeneration points is used automatically.} \item{fit.NumberRegPointsReal}{\code{\link{integer}} (optional): if the number of regeneration points is provided manually, the value of the real, regeneration points = all points (repeated points) including reg 0, has to be inserted.} \item{fit.bounds}{\code{\link{logical}} (with default): set lower fit bounds for all fitting parameters to 0. Limited for the use with the fit methods \code{EXP}, \code{EXP+LIN} and \code{EXP OR LIN}. Argument to be inserted for experimental application only!} \item{NumberIterations.MC}{\code{\link{integer}} (with default): number of Monte Carlo simulations for error estimation. See details.} \item{output.plot}{\code{\link{logical}} (with default): plot output (\code{TRUE/FALSE}).} \item{output.plotExtended}{\code{\link{logical}} (with default): If \code{TRUE}, 3 plots on one plot area are provided: (1) growth curve, (2) histogram from Monte Carlo error simulation and (3) a test dose response plot. If \code{FALSE}, just the growth curve will be plotted. \bold{Requires:} \code{output.plot = TRUE}.} \item{output.plotExtended.single}{\code{\link{logical}} (with default): single plot output (\code{TRUE/FALSE}) to allow for plotting the results in single plot windows. Requires \code{output.plot = TRUE} and \code{output.plotExtended = TRUE}.} \item{cex.global}{\code{\link{numeric}} (with default): global scaling factor.} \item{txtProgressBar}{\code{\link{logical}} (with default): enables or disables txtProgressBar. If \code{verbose = FALSE} also no txtProgressBar is shown.} \item{verbose}{\code{\link{logical}} (with default): enables or disables terminal feedback.} \item{\dots}{Further arguments and graphical parameters to be passed. Note: Standard arguments will only be passed to the growth curve plot. Supported: \code{xlim}, \code{ylim}, \code{main}, \code{xlab}, \code{ylab}} } \value{ Along with a plot (so far wanted) an \code{RLum.Results} object is returned containing, the slot \code{data} contains the following elements:\cr \tabular{lll}{ \bold{DATA.OBJECT} \tab \bold{TYPE} \tab \bold{DESCRIPTION} \cr \code{..$De} : \tab \code{data.frame} \tab Table with De values \cr \code{..$De.MC} : \tab \code{numeric} \tab Table with De values from MC runs \cr \code{..$Fit} : \tab \code{\link{nls}} or \code{\link{lm}} \tab object from the fitting for \code{EXP}, \code{EXP+LIN} and \code{EXP+EXP}. In case of a resulting linear fit when using \code{LIN}, \code{QDR} or \code{EXP OR LIN} \cr \code{..$Formula} : \tab \code{\link{expression}} \tab Fitting formula as R expression \cr \code{..$call} : \tab \code{call} \tab The original function call\cr } } \description{ A dose response curve is produced for luminescence measurements using a regenerative or additive protocol. The function supports interpolation and extraxpolation to calculate the equivalent dose. } \details{ \bold{Fitting methods} \cr\cr For all options (except for the \code{LIN}, \code{QDR} and the \code{EXP OR LIN}), the \code{\link[minpack.lm]{nlsLM}} function with the \code{LM} (Levenberg-Marquardt algorithm) algorithm is used. Note: For historical reasons for the Monte Carlo simulations partly the function \code{\link{nls}} using the \code{port} algorithm. The solution is found by transforming the function or using \code{\link{uniroot}}. \cr \code{LIN}: fits a linear function to the data using \link{lm}: \deqn{y = m*x+n} \code{QDR}: fits a linear function to the data using \link{lm}: \deqn{y = a + b * x + c * x^2} \code{EXP}: try to fit a function of the form \deqn{y = a*(1-exp(-(x+c)/b))} Parameters b and c are approximated by a linear fit using \link{lm}. Note: b = D0\cr \code{EXP OR LIN}: works for some cases where an \code{EXP} fit fails. If the \code{EXP} fit fails, a \code{LIN} fit is done instead. \cr \code{EXP+LIN}: tries to fit an exponential plus linear function of the form: \deqn{y = a*(1-exp(-(x+c)/b)+(g*x))} The De is calculated by iteration.\cr \bold{Note:} In the context of luminescence dating, this function has no physical meaning. Therefore, no D0 value is returned.\cr \code{EXP+EXP}: tries to fit a double exponential function of the form \deqn{y = (a1*(1-exp(-(x)/b1)))+(a2*(1-exp(-(x)/b2)))} This fitting procedure is not robust against wrong start parameters and should be further improved.\cr\cr \bold{Fit weighting}\cr If the option \code{fit.weights = TRUE} is chosen, weights are calculated using provided signal errors (Lx/Tx error): \deqn{fit.weights = 1/error/(sum(1/error))}\cr \bold{Error estimation using Monte Carlo simulation}\cr Error estimation is done using a Monte Carlo (MC) simulation approach. A set of Lx/Tx values is constructed by randomly drawing curve data from samled from normal distributions. The normal distribution is defined by the input values (mean = value, sd = value.error). Then, a growth curve fit is attempted for each dataset resulting in a new distribution of single De values. The \link{sd} of this distribution is becomes then the error of the De. With increasing iterations, the error value becomes more stable. \bold{Note:} It may take some calculation time with increasing MC runs, especially for the composed functions (\code{EXP+LIN} and \code{EXP+EXP}).\cr Each error estimation is done with the function of the chosen fitting method. \cr \bold{Subtitle information}\cr To avoid plotting the subtitle information, provide an empty user mtext \code{mtext = ""}. To plot any other subtitle text, use \code{mtext}. } \section{Function version}{ 1.9.5 (2017-06-29 18:40:14) } \examples{ ##(1) plot growth curve for a dummy data.set and show De value data(ExampleData.LxTxData, envir = environment()) temp <- plot_GrowthCurve(LxTxData) get_RLum(temp) ##(1a) to access the fitting value try get_RLum(temp, data.object = "Fit") ##(2) plot the growth curve only - uncomment to use ##pdf(file = "~/Desktop/Growth_Curve_Dummy.pdf", paper = "special") plot_GrowthCurve(LxTxData) ##dev.off() ##(3) plot growth curve with pdf output - uncomment to use, single output ##pdf(file = "~/Desktop/Growth_Curve_Dummy.pdf", paper = "special") plot_GrowthCurve(LxTxData, output.plotExtended.single = TRUE) ##dev.off() ##(4) plot resulting function for given intervall x x <- seq(1,10000, by = 100) plot( x = x, y = eval(temp$Formula), type = "l" ) ##(5) plot using the 'extrapolation' mode LxTxData[1,2:3] <- c(0.5, 0.001) print(plot_GrowthCurve(LxTxData,mode = "extrapolation")) ##(6) plot using the 'alternate' mode LxTxData[1,2:3] <- c(0.5, 0.001) print(plot_GrowthCurve(LxTxData,mode = "alternate")) } \seealso{ \code{\link{nls}}, \code{\linkS4class{RLum.Results}}, \code{\link{get_RLum}}, \code{\link[minpack.lm]{nlsLM}}, \code{\link{lm}}, \code{uniroot} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France), \cr Michael Dietze, GFZ Potsdam (Germany) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S., Dietze, M. (2017). plot_GrowthCurve(): Fit and plot a growth curve for luminescence data (Lx/Tx against dose). Function version 1.9.5. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } Luminescence/man/Risoe.BINfileData-class.Rd0000644000176200001440000002736213125227576020177 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RisoeBINfileData-class.R \docType{class} \name{Risoe.BINfileData-class} \alias{Risoe.BINfileData-class} \alias{show,Risoe.BINfileData-method} \alias{set_Risoe.BINfileData,ANY-method} \alias{get_Risoe.BINfileData,Risoe.BINfileData-method} \title{Class \code{"Risoe.BINfileData"}} \usage{ \S4method{show}{Risoe.BINfileData}(object) \S4method{set_Risoe.BINfileData}{ANY}(METADATA = data.frame(), DATA = list(), .RESERVED = list()) \S4method{get_Risoe.BINfileData}{Risoe.BINfileData}(object, ...) } \arguments{ \item{object}{an object of class \code{\linkS4class{Risoe.BINfileData}}} \item{METADATA}{Object of class "data.frame" containing the meta information for each curve.} \item{DATA}{Object of class "list" containing numeric vector with count data.} \item{.RESERVED}{Object of class "list" containing list of undocumented raw values for internal use only.} \item{...}{other arguments that might be passed} } \description{ S4 class object for luminescence data in R. The object is produced as output of the function \code{\link{read_BIN2R}}. } \section{Methods (by generic)}{ \itemize{ \item \code{show}: Show structure of RLum and Risoe.BINfile class objects \item \code{set_Risoe.BINfileData}: The Risoe.BINfileData is normally produced as output of the function read_BIN2R. This construction method is intended for internal usage only. \item \code{get_Risoe.BINfileData}: Formal get-method for Risoe.BINfileData object. It does not allow accessing the object directly, it is just showing a terminal message. }} \section{Slots}{ \describe{ \item{\code{METADATA}}{Object of class "data.frame" containing the meta information for each curve.} \item{\code{DATA}}{Object of class "list" containing numeric vector with count data.} \item{\code{.RESERVED}}{Object of class "list" containing list of undocumented raw values for internal use only.} }} \note{ \bold{Internal METADATA - object structure} This structure is compatible with BIN-files version 03-08, however, it does not follow (in its sequential arrangment) the manual provided by the manufacturer, but an own structure accounting for the different versions. \tabular{rllll}{ \bold{#} \tab \bold{Name} \tab \bold{Data Type} \tab \bold{V} \tab \bold{Description} \cr [,1] \tab ID \tab \code{numeric} \tab RLum \tab Unique record ID (same ID as in slot \code{DATA})\cr [,2] \tab SEL \tab \code{logic} \tab RLum \tab Record selection, not part official BIN-format, triggered by TAG\cr [,3] \tab VERSION \tab \code{raw} \tab 03-08 \tab BIN-file version number \cr [,4] \tab LENGTH \tab \code{integer} \tab 03-08 \tab Length of this record\cr [,5] \tab PREVIOUS \tab \code{integer} \tab 03-08 \tab Length of previous record\cr [,6] \tab NPOINTS \tab \code{integer} \tab 03-08 \tab Number of data points in the record\cr [,7] \tab RECTYPE \tab \code{integer} \tab 08 \tab Record type \cr [,8] \tab RUN \tab \code{integer} \tab 03-08 \tab Run number\cr [,9] \tab SET \tab \code{integer} \tab 03-08 \tab Set number\cr [,10] \tab POSITION \tab \code{integer} \tab 03-08 \tab Position number\cr [,11] \tab GRAIN \tab \code{integer} \tab 03-04 \tab Grain number\cr [,12] \tab GRAINNUMBER \tab \code{integer} \tab 06-08 \tab Grain number\cr [,13] \tab CURVENO \tab \code{integer} \tab 06-08 \tab Curve number\cr [,14] \tab XCOORD \tab \code{integer} \tab 03-08 \tab X position of a single grain\cr [,15] \tab YCOORD \tab \code{integer} \tab 03-08 \tab Y position of a single grain\cr [,16] \tab SAMPLE \tab \code{factor} \tab 03-08 \tab Sample name\cr [,17] \tab COMMENT \tab \code{factor} \tab 03-08 \tab Comment name\cr [,18] \tab SYSTEMID \tab \code{integer} \tab 03-08 \tab Risoe system id\cr [,19] \tab FNAME \tab \code{factor} \tab 06-08 \tab File name (*.bin/*.binx)\cr [,20] \tab USER \tab \code{facotr} \tab 03-08 \tab User name\cr [,21] \tab TIME \tab \code{character} \tab 03-08 \tab Data collection time (hh-mm-ss)\cr [,22] \tab DATE \tab \code{factor} \tab 03-08 \tab Data collection date (ddmmyy)\cr [,23] \tab DTYPE \tab \code{character} \tab 03-08 \tab Data type\cr [,24] \tab BL_TIME \tab \code{numeric} \tab 03-08 \tab Bleaching time\cr [,25] \tab BL_UNIT \tab \code{integer} \tab 03-08 \tab Bleaching unit (mJ, J, secs, mins, hrs)\cr [,26] \tab NORM1 \tab \code{numeric} \tab 03-08 \tab Normalisation factor (1)\cr [,27] \tab NORM2 \tab \code{numeric} \tab 03-08 \tab Normalisation factor (2)\cr [,28] \tab NORM3 \tab \code{numeric} \tab 03-08 \tab Normalisation factor (3)\cr [,29] \tab BG \tab \code{numeric} \tab 03-08 \tab Background level\cr [,30] \tab SHIFT \tab \code{integer} \tab 03-08 \tab Number of channels to shift data\cr [,31] \tab TAG \tab \code{integer} \tab 03-08 \tab Tag, triggers SEL\cr [,32] \tab LTYPE \tab \code{character} \tab 03-08 \tab Luminescence type\cr [,33] \tab LIGHTSOURCE \tab \code{character} \tab 03-08 \tab Light source\cr [,34] \tab LPOWER \tab \code{numeric} \tab 03-08 \tab Optical stimulation power\cr [,35] \tab LIGHTPOWER \tab \code{numeric} \tab 06-08 \tab Optical stimulation power\cr [,36] \tab LOW \tab \code{numeric} \tab 03-08 \tab Low (temperature, time, wavelength)\cr [,37] \tab HIGH \tab \code{numeric} \tab 03-08 \tab High (temperature, time, wavelength)\cr [,38] \tab RATE \tab \code{numeric} \tab 03-08 \tab Rate (heating rate, scan rate)\cr [,39] \tab TEMPERATURE \tab \code{integer} \tab 03-08 \tab Sample temperature\cr [,40] \tab MEASTEMP \tab \code{integer} \tab 06-08 \tab Measured temperature\cr [,41] \tab AN_TEMP \tab \code{numeric} \tab 03-08 \tab Annealing temperature\cr [,42] \tab AN_TIME \tab \code{numeric} \tab 03-08 \tab Annealing time\cr [,43] \tab TOLDELAY \tab \code{integer} \tab 03-08 \tab TOL 'delay' channels\cr [,44] \tab TOLON \tab \code{integer} \tab 03-08 \tab TOL 'on' channels\cr [,45] \tab TOLOFF \tab \code{integer} \tab 03-08 \tab TOL 'off' channels\cr [,46] \tab IRR_TIME \tab \code{numeric} \tab 03-08 \tab Irradiation time\cr [,47] \tab IRR_TYPE \tab \code{integer} \tab 03-08 \tab Irradiation type (alpha, beta or gamma)\cr [,48] \tab IRR_UNIT \tab \code{integer} \tab 03-04 \tab Irradiation unit (Gy, Rads, secs, mins, hrs)\cr [,49] \tab IRR_DOSERATE \tab \code{numeric} \tab 06-08 \tab Irradiation dose rate (Gy/s)\cr [,50] \tab IRR_DOSERATEERR \tab \code{numeric} \tab 06-08 \tab Irradiation dose rate error (Gy/s)\cr [,51] \tab TIMESINCEIRR \tab \code{integer} \tab 06-08 \tab Time since irradiation (s)\cr [,52] \tab TIMETICK \tab \code{numeric} \tab 06-08 \tab Time tick for pulsing (s)\cr [,53] \tab ONTIME \tab \code{integer} \tab 06-08 \tab On-time for pulsing (in time ticks)\cr [,54] \tab OFFTIME \tab \code{integer} \tab 03 \tab Off-time for pulsed stimulation (in s) \cr [,55] \tab STIMPERIOD \tab \code{integer} \tab 06-08 \tab Stimulation period (on+off in time ticks)\cr [,56] \tab GATE_ENABLED \tab \code{raw} \tab 06-08 \tab PMT signal gating enabled\cr [,57] \tab ENABLE_FLAGS \tab \code{raw} \tab 06-08 \tab PMT signal gating enabled\cr [,58] \tab GATE_START \tab \code{integer} \tab 06-08 \tab Start gating (in time ticks)\cr [,59] \tab GATE_STOP \tab \code{ingeter} \tab 06-08 \tab Stop gating (in time ticks), 'Gateend' for version 04, here only GATE_STOP is used\cr [,60] \tab PTENABLED \tab \code{raw} \tab 06-08 \tab Photon time enabled\cr [,61] \tab DTENABLED \tab \code{raw} \tab 06-08 \tab PMT dead time correction enabled\cr [,62] \tab DEADTIME \tab \code{numeric} \tab 06-08 \tab PMT dead time (s)\cr [,63] \tab MAXLPOWER \tab \code{numeric} \tab 06-08 \tab Stimulation power to 100 percent (mW/cm^2)\cr [,64] \tab XRF_ACQTIME \tab \code{numeric} \tab 06-08 \tab XRF acquisition time (s)\cr [,65] \tab XRF_HV \tab \code{numeric} \tab 06-08 \tab XRF X-ray high voltage (V)\cr [,66] \tab XRF_CURR \tab \code{integer} \tab 06-08 \tab XRF X-ray current (uA)\cr [,67] \tab XRF_DEADTIMEF \tab \code{numeric} \tab 06-08 \tab XRF dead time fraction\cr [,68] \tab DETECTOR_ID \tab \code{raw} \tab 07-08 \tab Detector ID\cr [,69] \tab LOWERFILTER_ID \tab \code{integer} \tab 07-08 \tab Lower filter ID in reader\cr [,70] \tab UPPERFILTER_ID \tab \code{integer} \tab 07-08 \tab Uper filter ID in reader\cr [,71] \tab ENOISEFACTOR \tab \code{numeric} \tab 07-08 \tab Excess noise filter, usage unknown \cr [,72] \tab MARKPOS_X1 \tab \code{numeric} \tab 08 \tab Coordinates marker position 1 \cr [,73] \tab MARKPOS_Y1 \tab \code{numeric} \tab 08 \tab Coordinates marker position 1 \cr [,74] \tab MARKPOS_X2 \tab \code{numeric} \tab 08 \tab Coordinates marker position 2 \cr [,75] \tab MARKPOS_Y2 \tab \code{numeric} \tab 08 \tab Coordinates marker position 2 \cr [,76] \tab MARKPOS_X3 \tab \code{numeric} \tab 08 \tab Coordinates marker position 3 \cr [,77] \tab MARKPOS_Y3 \tab \code{numeric} \tab 08 \tab Coordinates marker position 3 \cr [,78] \tab EXTR_START \tab \code{numeric} \tab 08 \tab usage unknown \cr [,79] \tab EXTR_END \tab \code{numeric} \tab 08 \tab usage unknown\cr [,80] \tab SEQUENCE \tab \code{character} \tab 03-04 \tab Sequence name } V = BIN-file version (RLum means that it does not depend on a specific BIN version)\cr Note that the \code{Risoe.BINfileData} object combines all values from different versions from the BIN-file, reserved bits are skipped, however, the function \code{\link{write_R2BIN}} reset arbitrary reserved bits. Invalid values for a specific version are set to \code{NA}. Furthermore, the internal R data types do not necessarily match the required data types for the BIN-file data import! Data types are converted during data import.\cr \bold{LTYPE} values \tabular{rll}{ [,0] \tab TL \tab: Thermoluminescence \cr [,1] \tab OSL \tab: Optically stimulated luminescence \cr [,2] \tab IRSL \tab: Infrared stimulated luminescence \cr [,3] \tab M-IR \tab: Infrared monochromator scan\cr [,4] \tab M-VIS \tab: Visible monochromator scan\cr [,5] \tab TOL \tab: Thermo-optical luminescence \cr [,6] \tab TRPOSL \tab: Time Resolved Pulsed OSL\cr [,7] \tab RIR \tab: Ramped IRSL\cr [,8] \tab RBR \tab: Ramped (Blue) LEDs\cr [,9] \tab USER \tab: User defined\cr [,10] \tab POSL \tab: Pulsed OSL \cr [,11] \tab SGOSL \tab: Single Grain OSL\cr [,12] \tab RL \tab: Radio Luminescence \cr [,13] \tab XRF \tab: X-ray Fluorescence } \bold{DTYPE} values \tabular{rll}{ [,0] \tab 0 \tab Natural \cr [,1] \tab 1 \tab N+dose \cr [,2] \tab 2 \tab Bleach \cr [,3] \tab 3 \tab Bleach+dose \cr [,4] \tab 4 \tab Natural (Bleach) \cr [,5] \tab 5 \tab N+dose (Bleach) \cr [,6] \tab 6 \tab Dose \cr [,7] \tab 7 \tab Background } \bold{LIGHTSOURCE} values \tabular{rll}{ [,0] \tab 0 \tab Non \cr [,1] \tab 1 \tab Lamp \cr [,2] \tab 2 \tab IR diodes/IR Laser \cr [,3] \tab 3 \tab Calibration LED \cr [,4] \tab 4 \tab Blue Diodes \cr [,5] \tab 5 \tab White lite \cr [,6] \tab 6 \tab Green laser (single grain) \cr [,7] \tab 7 \tab IR laser (single grain) } (information on the BIN/BINX file format are kindly provided by Risoe, DTU Nutech) } \section{Objects from the Class}{ Objects can be created by calls of the form \code{new("Risoe.BINfileData", ...)}. } \section{Function version}{ 0.3.3 } \examples{ showClass("Risoe.BINfileData") } \section{How to cite}{ Kreutzer, S. (2017). Risoe.BINfileData-class(): Class 'Risoe.BINfileData'. Function version 0.3.3. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Risoe DTU, 2013. The Sequence Editor User Manual - Feb 2013 and Risoe DTU, 2016. The Sequence Editor User Manual - Feburar 2016 \code{http://www.nutech.dtu.dk/} } \seealso{ \code{\link{plot_Risoe.BINfileData}}, \code{\link{read_BIN2R}}, \code{\link{write_R2BIN}},\code{\link{merge_Risoe.BINfileData}}, \code{\link{Risoe.BINfileData2RLum.Analysis}}, } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{classes} Luminescence/man/plot_RLum.Data.Spectrum.Rd0000644000176200001440000002127113125227576020331 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_RLum.Data.Spectrum.R \name{plot_RLum.Data.Spectrum} \alias{plot_RLum.Data.Spectrum} \title{Plot function for an RLum.Data.Spectrum S4 class object} \usage{ plot_RLum.Data.Spectrum(object, par.local = TRUE, plot.type = "contour", optical.wavelength.colours = TRUE, bg.channels, bin.rows = 1, bin.cols = 1, rug = TRUE, limit_counts = NULL, xaxis.energy = FALSE, legend.text, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Data.Spectrum}} or \code{\link{matrix}} (\bold{required}): S4 object of class \code{RLum.Data.Spectrum} or a \code{matrix} containing count values of the spectrum.\cr Please note that in case of a matrix rownames and colnames are set automatically if not provided.} \item{par.local}{\code{\link{logical}} (with default): use local graphical parameters for plotting, e.g. the plot is shown in one column and one row. If \code{par.local = FALSE} global parameters are inherited.} \item{plot.type}{\code{\link{character}} (with default): plot type, for 3D-plot use \code{persp}, or \code{interactive}, for a 2D-plot \code{contour}, \code{single} or \code{multiple.lines} (along the time or temperature axis) or \code{transect} (along the wavelength axis) \cr} \item{optical.wavelength.colours}{\code{\link{logical}} (with default): use optical wavelength colour palette. Note: For this, the spectrum range is limited: \code{c(350,750)}. Own colours can be set with the argument \code{col}.} \item{bg.channels}{\code{\link{vector}} (optional): defines channel for background subtraction If a vector is provided the mean of the channels is used for subtraction. Note: Background subtraction is applied prior to channel binning} \item{bin.rows}{\code{\link{integer}} (with defaul): allow summing-up wavelength channels (horizontal binning), e.g. \code{bin.rows = 2} two channels are summed up} \item{bin.cols}{\code{\link{integer}} (with default): allow summing-up channel counts (vertical binning) for plotting, e.g. \code{bin.cols = 2} two channels are summed up} \item{rug}{\code{\link{logical}} (with default): enables or disables colour rug. Currently only implemented for plot type \code{multiple.lines} and \code{single}} \item{limit_counts}{\code{\link{numeric}} (optional): value to limit all count values to this value, i.e. all count values above this threshold will be replaced by this threshold. This is helpfull especially in case of TL-spectra.} \item{xaxis.energy}{\code{\link{logical}} (with default): enables or disables energy instead of wavelength axis. Note: This option means not only simnply redrawing the axis, insteadly the spectrum in terms of intensity is recalculated, s. details.} \item{legend.text}{\code{\link{character}} (with default): possiblity to provide own legend text. This argument is only considered for plot types providing a legend, e.g. \code{plot.type="transect"}} \item{\dots}{further arguments and graphical parameters that will be passed to the \code{plot} function.} } \value{ Returns a plot. } \description{ The function provides a standardised plot output for spectrum data of an RLum.Data.Spectrum S4 class object } \details{ \bold{Matrix structure} \cr (cf. \code{\linkS4class{RLum.Data.Spectrum}}) \itemize{ \item \code{rows} (x-values): wavelengths/channels (xlim, xlab) \item \code{columns} (y-values): time/temperature (ylim, ylab) \item \code{cells} (z-values): count values (zlim, zlab) } \emph{Note: This nomenclature is valid for all plot types of this function!}\cr \bold{Nomenclature for value limiting} \code{xlim}: Limits values along the wavelength axis\cr \code{ylim}: Limits values along the time/temperature axis\cr \code{zlim}: Limits values along the count value axis\cr \bold{Energy axis re-calculation} If the argument \code{xaxis.energy = TRUE} is chosen, instead intensity vs. wavelength the spectrum is plotted as intensiyt vs. energy. Therefore the entire spectrum is re-recaluated (e.g., Appendix 4 in Blasse and Grabmeier, 1994): The intensity of the spectrum (z-values) is re-calcualted using the following equation: \deqn{\phi_{E} = \phi_{\lambda} * \lambda^2 / (hc)} with \eqn{\phi_{E}} the intensity per interval of energy \eqn{E} (eV), \eqn{\phi_{\lambda}} the intensity per interval of wavelength \eqn{\lambda} (nm) and \eqn{h} (eV/s) the Planck constant and \eqn{c} (m/s) the velocity of light. For transforming the wavelength axis (x-values) the equation \deqn{E = hc/\lambda} is used. For further details please see the cited the literature.\cr \bold{Details on the plot functions} Spectrum is visualised as 3D or 2D plot. Both plot types are based on internal R plot functions. \cr \bold{\code{plot.type = "persp"}} Arguments that will be passed to \code{\link{persp}}: \itemize{ \item \code{shade}: default is \code{0.4} \item \code{phi}: default is \code{15} \item \code{theta}: default is \code{-30} \item \code{expand}: default is \code{1} \item \code{ticktype}: default is \code{detailed}, \code{r}: default is \code{10}} \emph{Note: Further parameters can be adjusted via \code{par}. For example to set the background transparent and reduce the thickness of the lines use: \code{par(bg = NA, lwd = 0.7)} previous the function call.} \bold{\code{plot.type = "single"}}\cr Per frame a single curve is returned. Frames are time or temperature steps.\cr \bold{\code{plot.type = "multiple.lines"}}\cr All frames plotted in one frame.\cr \bold{\code{plot.type = "transect"}}\cr Depending on the selected wavelength/channel range a transect over the time/temperature (y-axis) will be plotted along the wavelength/channels (x-axis). If the range contains more than one channel, values (z-values) are summed up. To select a transect use the \code{xlim} argument, e.g. \code{xlim = c(300,310)} plot along the summed up count values of channel 300 to 310.\cr \bold{Further arguments that will be passed (depending on the plot type)} \code{xlab}, \code{ylab}, \code{zlab}, \code{xlim}, \code{ylim}, \code{zlim}, \code{main}, \code{mtext}, \code{pch}, \code{type} ("single", "multiple.lines", "interactive"), \code{col}, \code{border}, \code{box} \code{lwd}, \code{bty}, \code{showscale} ("interactive") \cr } \note{ Not all additional arguments (\code{...}) will be passed similarly! } \section{Function version}{ 0.5.3 (2017-06-29 18:40:14) } \examples{ ##load example data data(ExampleData.XSYG, envir = environment()) ##(1)plot simple spectrum (2D) - contour plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="contour", xlim = c(310,750), ylim = c(0,300), bin.rows=10, bin.cols = 1) ##(2) plot spectrum (3D) plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="persp", xlim = c(310,750), ylim = c(0,100), bin.rows=10, bin.cols = 1) ##(3) plot multiple lines (2D) - multiple.lines (with ylim) plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="multiple.lines", xlim = c(310,750), ylim = c(0,100), bin.rows=10, bin.cols = 1) \dontrun{ ##(4) interactive plot using the package plotly ("surface") plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="interactive", xlim = c(310,750), ylim = c(0,300), bin.rows=10, bin.cols = 1) ##(5) interactive plot using the package plotly ("contour") plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="interactive", xlim = c(310,750), ylim = c(0,300), bin.rows=10, bin.cols = 1, type = "contour", showscale = TRUE) ##(6) interactive plot using the package plotly ("heatmap") plot_RLum.Data.Spectrum(TL.Spectrum, plot.type="interactive", xlim = c(310,750), ylim = c(0,300), bin.rows=10, bin.cols = 1, type = "heatmap", showscale = TRUE) ##(7) alternative using the package fields fields::image.plot(get_RLum(TL.Spectrum)) contour(get_RLum(TL.Spectrum), add = TRUE) } } \section{How to cite}{ Kreutzer, S. (2017). plot_RLum.Data.Spectrum(): Plot function for an RLum.Data.Spectrum S4 class object. Function version 0.5.3. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Blasse, G., Grabmaier, B.C., 1994. Luminescent Materials. Springer. } \seealso{ \code{\linkS4class{RLum.Data.Spectrum}}, \code{\link{plot}}, \code{\link{plot_RLum}}, \code{\link{persp}}, \code{\link[plotly]{plot_ly}}, \code{\link{contour}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{aplot} Luminescence/man/plot_DetPlot.Rd0000644000176200001440000001326013125227576016353 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/plot_DetPlot.R \name{plot_DetPlot} \alias{plot_DetPlot} \title{Create De(t) plot} \usage{ plot_DetPlot(object, signal.integral.min, signal.integral.max, background.integral.min, background.integral.max, method = "shift", signal_integral.seq = NULL, analyse_function = "analyse_SAR.CWOSL", analyse_function.control = list(), n.channels = NULL, show_ShineDownCurve = TRUE, respect_RC.Status = FALSE, verbose = TRUE, ...) } \arguments{ \item{object}{\code{\linkS4class{RLum.Analysis}} (\bold{required}): input object containing data for analysis} \item{signal.integral.min}{\code{\link{integer}} (\bold{required}): lower bound of the signal integral.} \item{signal.integral.max}{\code{\link{integer}} (\bold{required}): upper bound of the signal integral.} \item{background.integral.min}{\code{\link{integer}} (\bold{required}): lower bound of the background integral.} \item{background.integral.max}{\code{\link{integer}} (\bold{required}): upper bound of the background integral.} \item{method}{\code{\link{character}} (with default): method applied for constructing the De(t) plot. \code{shift} (the default): the chosen signal integral is shifted the shine down curve, \code{expansion}: the chosen signal integral is expanded each time by its length} \item{signal_integral.seq}{\code{\link{numeric}} (optional): argument to provide an own signal integral sequence for constructing the De(t) plot} \item{analyse_function}{\code{\link{character}} (with default): name of the analyse function to be called. Supported functions are: \code{'analyse_SAR.CWOSL'}, \code{'analyse_pIRIRSequence'}} \item{analyse_function.control}{\code{\link{list}} (optional): arguments to be passed to the supported analyse functions (\code{'analyse_SAR.CWOSL'}, \code{'analyse_pIRIRSequence'})} \item{n.channels}{\code{\link{integer}} (optional): number of channels used for the De(t) plot. If nothing is provided all De-values are calculated and plotted until the start of the background integral.} \item{show_ShineDownCurve}{\code{\link{logical}} (with default): enables or disables shine down curve in the plot output} \item{respect_RC.Status}{\code{\link{logical} (with default)}: remove De-values with 'FAILED' RC.Status from the plot (cf. \code{\link{analyse_SAR.CWOSL}} and \code{\link{analyse_pIRIRSequence}})} \item{verbose}{\code{\link{logical} (with default)}: enables or disables terminal feedback} \item{\dots}{further arguments and graphical parameters passed to \code{\link{plot.default}}, \code{\link{analyse_SAR.CWOSL}} and \code{\link{analyse_pIRIRSequence}}. See details for further information.} } \value{ A plot and an \code{\linkS4class{RLum.Results}} object with the produced De values \code{@data}: \tabular{lll}{ \bold{Object} \tab \bold{Type} \tab \bold{Description}\cr De.values \tab \code{data.frame} \tab table with De values \cr signal_integral.seq \tab \code{numeric} \tab integral sequence used for the calculation } \code{@info}: \tabular{lll}{ \bold{Object} \tab \bold{Type} \tab \bold{Description}\cr call \tab \code{call} \tab the original function call } } \description{ Plots the equivalent dose (De) in dependency of the chosen signal integral (cf. Bailey et al., 2003). The function is simply passing several arguments to the function \code{\link{plot}} and the used analysis functions and runs it in a loop. Example: \code{legend.pos} for legend position, \code{legend} for legend text.\cr } \details{ \bold{method}\cr The original method presented by Baiely et al., 2003 shifted the signal integrals and slightly extended them accounting for changes in the counting statistics. Example: \code{c(1:3, 3:5, 5:7)}. However, here also another method is provided allowing to expand the signal integral by consectutively expaning the integral by its chosen length. Example: \code{c(1:3, 1:5, 1:7)} Note that in both cases the integral limits are overlap. The finally applied limits are part of the function output.\cr } \note{ The entire analysis is based on the used analysis functions, namely \code{\link{analyse_SAR.CWOSL}} and \code{\link{analyse_pIRIRSequence}}. However, the integrity checks of this function are not that thoughtful as in these functions itself. It means, that every sequence should be checked carefully before running long calculations using serveral hundreds of channels. } \section{Function version}{ 0.1.1 (2017-06-29 18:40:14) } \examples{ \dontrun{ ##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) plot_DetPlot(object, signal.integral.min = 1, signal.integral.max = 3, background.integral.min = 900, background.integral.max = 1000, n.channels = 5, ) } } \section{How to cite}{ Kreutzer, S. (2017). plot_DetPlot(): Create De(t) plot. Function version 0.1.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Bailey, R.M., Singarayer, J.S., Ward, S., Stokes, S., 2003. Identification of partial resetting using De as a function of illumination time. Radiation Measurements 37, 511-518. doi:10.1016/S1350-4487(03)00063-5 } \seealso{ \code{\link{plot}}, \code{\link{analyse_SAR.CWOSL}}, \code{\link{analyse_pIRIRSequence}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} Luminescence/man/length_RLum.Rd0000644000176200001440000000302513125227576016160 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/length_RLum.R \name{length_RLum} \alias{length_RLum} \title{General accessor function for RLum S4 class objects} \usage{ length_RLum(object) } \arguments{ \item{object}{\code{\linkS4class{RLum}} (\bold{required}): S4 object of class \code{RLum}} } \value{ Return is the same as input objects as provided in the list. } \description{ Function calls object-specific get functions for RLum S4 class objects. } \details{ The function provides a generalised access point for specific \code{\linkS4class{RLum}} objects.\cr Depending on the input object, the corresponding get function will be selected. Allowed arguments can be found in the documentations of the corresponding \code{\linkS4class{RLum}} class. } \section{Function version}{ 0.1.0 (2017-06-29 18:40:14) } \seealso{ \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Data.Image}}, \code{\linkS4class{RLum.Data.Spectrum}}, \code{\linkS4class{RLum.Analysis}}, \code{\linkS4class{RLum.Results}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \section{How to cite}{ Kreutzer, S. (2017). length_RLum(): General accessor function for RLum S4 class objects. Function version 0.1.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \keyword{utilities} Luminescence/man/BaseDataSet.CosmicDoseRate.Rd0000644000176200001440000000564713125226556020734 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Luminescence-package.R \name{BaseDataSet.CosmicDoseRate} \alias{BaseDataSet.CosmicDoseRate} \title{Base data set for cosmic dose rate calculation} \format{\tabular{ll}{ \code{values.cosmic.Softcomp}: \tab data frame containing cosmic dose rates for shallow depths (< 167 g cm^-2) obtained using the "AGE" program by Rainer Gruen (cf. Gruen 2009). These data essentially reproduce the graph shown in Fig. 1 of Prescott & Hutton (1988). \cr \code{values.factor.Altitude}: \tab data frame containing altitude factors for adjusting geomagnetic field-change factors. Values were read from Fig. 1 in Prescott & Hutton (1994). \cr \code{values.par.FJH}: \tab data frame containing values for parameters F, J and H (read from Fig. 2 in Prescott & Hutton 1994) used in the expression } \deqn{Dc = D0*(F+J*exp((altitude/1000)/H))}} \source{ The following data were carefully read from figures in mentioned sources and used for fitting procedures. The derived expressions are used in the function \code{calc_CosmicDoseRate}. \bold{values.cosmic.Softcomp} \tabular{ll}{ Program: \tab "AGE"\cr Reference: \tab Gruen (2009) \cr Fit: \tab Polynomials in the form of } For depths between 40-167 g cm^-2: \deqn{y = 2*10^-6*x^2-0.0008*x+0.2535} (For depths <40 g cm^-2) \deqn{y = -6*10^-8*x^3+2*10^-5*x^2-0.0025*x+0.2969} \bold{values.factor.Altitude} \tabular{ll}{ Reference: \tab Prescott & Hutton (1994) \cr Page: \tab 499 \cr Figure: \tab 1 \cr Fit: \tab 2-degree polynomial in the form of } \deqn{y = -0.026*x^2 + 0.6628*x + 1.0435} \bold{values.par.FJH} \tabular{ll}{ Reference: \tab Prescott & Hutton (1994) \cr Page: \tab 500 \cr Figure: \tab 2 \cr Fits: \tab 3-degree polynomials and linear fits } F (non-linear part, \eqn{\lambda} < 36.5 deg.): \deqn{y = -7*10^-7*x^3-8*10^-5*x^2-0.0009*x+0.3988} F (linear part, \eqn{\lambda} > 36.5 deg.): \deqn{y = -0.0001*x + 0.2347} J (non-linear part, \eqn{\lambda} < 34 deg.): \deqn{y = 5*10^-6*x^3-5*10^-5*x^2+0.0026*x+0.5177} J (linear part, \eqn{\lambda} > 34 deg.): \deqn{y = 0.0005*x + 0.7388} H (non-linear part, \eqn{\lambda} < 36 deg.): \deqn{y = -3*10^-6*x^3-5*10^-5*x^2-0.0031*x+4.398} H (linear part, \eqn{\lambda} > 36 deg.): \deqn{y = 0.0002*x + 4.0914} } \description{ Collection of data from various sources needed for cosmic dose rate calculation } \section{Version}{ 0.1 } \examples{ ##load data data(BaseDataSet.CosmicDoseRate) } \references{ Gruen, R., 2009. The "AGE" program for the calculation of luminescence age estimates. Ancient TL, 27, pp. 45-46. Prescott, J.R., Hutton, J.T., 1988. Cosmic ray and gamma ray dosimetry for TL and ESR. Nuclear Tracks and Radiation Measurements, 14, pp. 223-227. Prescott, J.R., Hutton, J.T., 1994. Cosmic ray contributions to dose rates for luminescence and ESR dating: large depths and long-term time variations. Radiation Measurements, 23, pp. 497-500. } \keyword{datasets} Luminescence/man/calc_MaxDose.Rd0000644000176200001440000001354013125227575016264 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_MaxDose.R \name{calc_MaxDose} \alias{calc_MaxDose} \title{Apply the maximum age model to a given De distribution} \usage{ calc_MaxDose(data, sigmab, log = TRUE, par = 3, bootstrap = FALSE, init.values, plot = TRUE, ...) } \arguments{ \item{data}{\code{\linkS4class{RLum.Results}} or \link{data.frame} (\bold{required}): for \code{data.frame}: two columns with De \code{(data[ ,1])} and De error \code{(data[ ,2])}.} \item{sigmab}{\code{\link{numeric}} (\bold{required}): 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). \bold{NOTE}: For the logged model (\code{log = TRUE}) this value must be a fraction, e.g. 0.2 (= 20 \%). If the un-logged model is used (\code{log = FALSE}), sigmab must be provided in the same absolute units of the De values (seconds or Gray). See details (\code{\link{calc_MinDose}}.} \item{log}{\code{\link{logical}} (with default): fit the (un-)logged three parameter minimum dose model to De data} \item{par}{\code{\link{numeric}} (with default): apply the 3- or 4-parametric minimum age model (\code{par=3} or \code{par=4}).} \item{bootstrap}{\code{\link{logical}} (with default): apply the recycled bootstrap approach of Cunningham & Wallinga (2012).} \item{init.values}{\code{\link{numeric}} (with default): starting values for gamma, sigma, p0 and mu. Custom values need to be provided in a vector of length three in the form of \code{c(gamma, sigma, p0)}.} \item{plot}{\code{\link{logical}} (with default): plot output (\code{TRUE}/\code{FALSE})} \item{\dots}{further arguments for bootstrapping (\code{bs.M, bs.N, bs.h, sigmab.sd}). See details for their usage.} } \value{ Please see \code{\link{calc_MinDose}}. } \description{ Function to fit the maximum age model to De data. This is a wrapper function that calls calc_MinDose() and applies a similiar approach as described in Olley et al. (2006). } \details{ \bold{Data transformation} \cr\cr To estimate the maximum dose population and its standard error, the three parameter minimum age model of Galbraith et al. (1999) is adapted. The measured De values are transformed as follows: \cr\cr 1. convert De values to natural logs \cr 2. multiply the logged data to creat a mirror image of the De distribution \cr 3. shift De values along x-axis by the smallest x-value found to obtain only positive values \cr 4. combine in quadrature the measurement error associated with each De value with a relative error specified by sigmab \cr 5. apply the MAM to these data \cr\cr When all calculations are done the results are then converted as follows\cr\cr 1. subtract the x-offset \cr 2. multiply the natural logs by -1 \cr 3. take the exponent to obtain the maximum dose estimate in Gy \cr\cr \bold{Further documentation} \cr\cr Please see \code{\link{calc_MinDose}}. } \section{Function version}{ 0.3.1 (2017-06-29 18:40:14) } \examples{ ## load example data data(ExampleData.DeValues, envir = environment()) # apply the maximum dose model calc_MaxDose(ExampleData.DeValues$CA1, sigmab = 0.2, par = 3) } \section{How to cite}{ Burow, C. (2017). calc_MaxDose(): Apply the maximum age model to a given De distribution. Function version 0.3.1. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Arnold, L.J., Roberts, R.G., Galbraith, R.F. & DeLong, S.B., 2009. A revised burial dose estimation procedure for optical dating of young and modern-age sediments. Quaternary Geochronology 4, 306-325. \cr\cr Galbraith, R.F. & Laslett, G.M., 1993. Statistical models for mixed fission track ages. Nuclear Tracks Radiation Measurements 4, 459-470. \cr\cr 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. \cr\cr Galbraith, R.F., 2005. Statistics for Fission Track Analysis, Chapman & Hall/CRC, Boca Raton. \cr\cr Galbraith, R.F. & Roberts, R.G., 2012. Statistical aspects of equivalent dose and error calculation and display in OSL dating: An overview and some recommendations. Quaternary Geochronology 11, 1-27. \cr\cr Olley, J.M., Roberts, R.G., Yoshida, H., Bowler, J.M., 2006. Single-grain optical dating of grave-infill associated with human burials at Lake Mungo, Australia. Quaternary Science Reviews 25, 2469-2474.\cr\cr \bold{Further reading} \cr\cr 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. \cr\cr 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. \cr\cr Cunningham, A.C. & Wallinga, J., 2012. Realizing the potential of fluvial archives using robust OSL chronologies. Quaternary Geochronology 12, 98-106. \cr\cr 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. \cr\cr Rodnight, H., 2008. How many equivalent dose values are needed to obtain a reproducible distribution?. Ancient TL 26, 3-10. \cr\cr } \seealso{ \code{\link{calc_CentralDose}}, \code{\link{calc_CommonDose}}, \code{\link{calc_FiniteMixture}}, \code{\link{calc_FuchsLang2001}}, \code{\link{calc_MinDose}} } \author{ Christoph Burow, University of Cologne (Germany) \cr Based on a rewritten S script of Rex Galbraith, 2010 \cr \cr R Luminescence Package Team} Luminescence/man/fit_CWCurve.Rd0000644000176200001440000002017713125227576016127 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fit_CWCurve.R \name{fit_CWCurve} \alias{fit_CWCurve} \title{Nonlinear Least Squares Fit for CW-OSL curves [beta version]} \usage{ fit_CWCurve(values, n.components.max, fit.failure_threshold = 5, fit.method = "port", fit.trace = FALSE, fit.calcError = FALSE, LED.power = 36, LED.wavelength = 470, cex.global = 0.6, sample_code = "Default", output.path, output.terminal = TRUE, output.terminalAdvanced = TRUE, plot = TRUE, ...) } \arguments{ \item{values}{\code{\linkS4class{RLum.Data.Curve}} or \link{data.frame} (\bold{required}): x, y data of measured values (time and counts). See examples.} \item{n.components.max}{\link{vector} (optional): maximum number of components that are to be used for fitting. The upper limit is 7.} \item{fit.failure_threshold}{\link{vector} (with default): limits the failed fitting attempts.} \item{fit.method}{\link{character} (with default): select fit method, allowed values: \code{'port'} and \code{'LM'}. \code{'port'} uses the 'port' routine usint the funtion \code{\link{nls}} \code{'LM'} utilises the function \code{nlsLM} from the package \code{minpack.lm} and with that the Levenberg-Marquardt algorithm.} \item{fit.trace}{\link{logical} (with default): traces the fitting process on the terminal.} \item{fit.calcError}{\link{logical} (with default): calculate 1-sigma error range of components using \code{\link{confint}}} \item{LED.power}{\link{numeric} (with default): LED power (max.) used for intensity ramping in mW/cm^2. \bold{Note:} The value is used for the calculation of the absolute photoionisation cross section.} \item{LED.wavelength}{\link{numeric} (with default): LED wavelength used for stimulation in nm. \bold{Note:} The value is used for the calculation of the absolute photoionisation cross section.} \item{cex.global}{\link{numeric} (with default): global scaling factor.} \item{sample_code}{\link{character} (optional): sample code used for the plot and the optional output table (mtext).} \item{output.path}{\link{character} (optional): output path for table output containing the results of the fit. The file name is set automatically. If the file already exists in the directory, the values are appended.} \item{output.terminal}{\link{logical} (with default): terminal ouput with fitting results.} \item{output.terminalAdvanced}{\link{logical} (with default): enhanced terminal output. Requires \code{output.terminal = TRUE}. If \code{output.terminal = FALSE} no advanced output is possible.} \item{plot}{\link{logical} (with default): returns a plot of the fitted curves.} \item{\dots}{further arguments and graphical parameters passed to \code{\link{plot}}.} } \value{ \item{plot}{(optional) the fitted CW-OSL curves are returned as plot.} \item{table}{(optional) an output table (*.csv) with parameters of the fitted components is provided if the \code{output.path} is set.} \item{list(list("RLum.Results"))}{beside the plot and table output options, an \code{\linkS4class{RLum.Results}} object is returned.\cr\cr \code{fit}: an \code{nls} object (\code{$fit}) for which generic R functions are provided, e.g. \link{summary}, \link{confint}, \link{profile}. For more details, see \link{nls}.\cr\cr \code{output.table}: a \link{data.frame} containing the summarised parameters including the error\cr \code{component.contribution.matrix}: \link{matrix} containing the values for the component to sum contribution plot (\code{$component.contribution.matrix}).\cr Matrix structure:\cr Column 1 and 2: time and \code{rev(time)} values\cr Additional columns are used for the components, two for each component, containing I0 and n0. The last columns \code{cont.} provide information on the relative component contribution for each time interval including the row sum for this values. }\item{ object}{beside the plot and table output options, an \code{\linkS4class{RLum.Results}} object is returned.\cr\cr \code{fit}: an \code{nls} object (\code{$fit}) for which generic R functions are provided, e.g. \link{summary}, \link{confint}, \link{profile}. For more details, see \link{nls}.\cr\cr \code{output.table}: a \link{data.frame} containing the summarised parameters including the error\cr \code{component.contribution.matrix}: \link{matrix} containing the values for the component to sum contribution plot (\code{$component.contribution.matrix}).\cr Matrix structure:\cr Column 1 and 2: time and \code{rev(time)} values\cr Additional columns are used for the components, two for each component, containing I0 and n0. The last columns \code{cont.} provide information on the relative component contribution for each time interval including the row sum for this values. } } \description{ The function determines the weighted least-squares estimates of the component parameters of a CW-OSL signal for a given maximum number of components and returns various component parameters. The fitting procedure uses the \code{\link{nls}} function with the \code{port} algorithm. } \details{ \bold{Fitting function}\cr\cr The function for the CW-OSL fitting has the general form: \deqn{y = I0_{1}*\lambda_{1}*exp(-\lambda_1*x) + ,\ldots, + I0_{i}*\lambda_{i}*exp(-\lambda_i*x) } where \eqn{0 < i < 8}\cr\cr and \eqn{\lambda} is the decay constant and \eqn{I0} the intial number of trapped electrons.\cr (for the used equation cf. Boetter-Jensen et al., 2003, Eq. 2.31)\cr\cr \bold{Start values}\cr Start values are estimated automatically by fitting a linear function to the logarithmized input data set. Currently, there is no option to manually provide start parameters. \cr\cr \bold{Goodness of fit}\cr\cr The goodness of the fit is given as pseudoR^2 value (pseudo coefficient of determination). According to Lave (1970), the value is calculated as: \deqn{pseudoR^2 = 1 - RSS/TSS} where \eqn{RSS = Residual~Sum~of~Squares} \cr and \eqn{TSS = Total~Sum~of~Squares}\cr\cr \bold{Error of fitted component parameters}\cr\cr The 1-sigma error for the components is calculated using the function \code{\link{confint}}. Due to considerable calculation time, this option is deactived by default. In addition, the error for the components can be estimated by using internal R functions like \code{\link{summary}}. See the \code{\link{nls}} help page for more information.\cr\cr \emph{For details on the nonlinear regression in R, see Ritz & Streibig (2008).} } \note{ \bold{Beta version - This function has not been properly tested yet and should therefore not be used for publication purposes!}\cr\cr The pseudo-R^2 may not be the best parameter to describe the goodness of the fit. The trade off between the \code{n.components} and the pseudo-R^2 value is currently not considered.\cr\cr The function \bold{does not} ensure that the fitting procedure has reached a global minimum rather than a local minimum! } \section{Function version}{ 0.5.2 (2017-06-29 18:40:14) } \examples{ ##load data data(ExampleData.CW_OSL_Curve, envir = environment()) ##fit data fit <- fit_CWCurve(values = ExampleData.CW_OSL_Curve, main = "CW Curve Fit", n.components.max = 4, log = "x") } \section{How to cite}{ Kreutzer, S. (2017). fit_CWCurve(): Nonlinear Least Squares Fit for CW-OSL curves [beta version]. Function version 0.5.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Boetter-Jensen, L., McKeever, S.W.S., Wintle, A.G., 2003. Optically Stimulated Luminescence Dosimetry. Elsevier Science B.V. Lave, C.A.T., 1970. The Demand for Urban Mass Transportation. The Review of Economics and Statistics, 52 (3), 320-323. Ritz, C. & Streibig, J.C., 2008. Nonlinear Regression with R. In: R. Gentleman, K. Hornik, G. Parmigiani, eds., Springer, p. 150. } \seealso{ \code{\link{fit_LMCurve}}, \code{\link{plot}},\code{\link{nls}}, \code{\linkS4class{RLum.Data.Curve}}, \code{\linkS4class{RLum.Results}}, \code{\link{get_RLum}}, \code{\link[minpack.lm]{nlsLM}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{dplot} \keyword{models} Luminescence/man/write_R2BIN.Rd0000644000176200001440000000710213125227576015766 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/write_R2BIN.R \name{write_R2BIN} \alias{write_R2BIN} \title{Export Risoe.BINfileData into Risoe BIN-file} \usage{ write_R2BIN(object, file, version, compatibility.mode = FALSE, txtProgressBar = TRUE) } \arguments{ \item{object}{\code{\linkS4class{Risoe.BINfileData}} (\bold{required}): input object to be stored in a bin file.} \item{file}{\code{\link{character}} (\bold{required}): file name and path of the output file\cr [WIN]: \code{write_R2BIN(object, "C:/Desktop/test.bin")}, \cr [MAC/LINUX]: \code{write_R2BIN("/User/test/Desktop/test.bin")}} \item{version}{\code{\link{character}} (optional): version number for the output file. If no value is provided the highest version number from the \code{\linkS4class{Risoe.BINfileData}} is taken automatically.\cr\cr Note: This argument can be used to convert BIN-file versions.} \item{compatibility.mode}{\code{\link{logical}} (with default): this option recalculates the position values if necessary and set the max. value to 48. The old position number is appended as comment (e.g., 'OP: 70). This option accounts for potential compatibility problems with the Analyst software.} \item{txtProgressBar}{\link{logical} (with default): enables or disables \code{\link{txtProgressBar}}.} } \value{ Write a binary file. } \description{ Exports a Risoe.BINfileData object in a *.bin or *.binx file that can be opened by the Analyst software or other Risoe software. } \details{ The structure of the exported binary data follows the data structure published in the Appendices of the Analyst manual p. 42.\cr\cr If \code{LTYPE}, \code{DTYPE} and \code{LIGHTSOURCE} are not of type \code{\link{character}}, no transformation into numeric values is done. } \note{ The function just roughly checks the data structures. The validity of the output data depends on the user.\cr\cr The validity of the file path is not further checked. \cr BIN-file conversions using the argument \code{version} may be a lossy conversion, depending on the chosen input and output data (e.g., conversion from version 08 to 07 to 06 to 04 or 03).\cr \bold{Warning}\cr Although the coding was done carefully it seems that the BIN/BINX-files produced by Risoe DA 15/20 TL/OSL readers slightly differ on the byte level. No obvious differences are observed in the METADATA, however, the BIN/BINX-file may not fully compatible, at least not similar to the once directly produced by the Risoe readers!\cr ROI definitions (introduced in BIN-file version 8) are not supported! There are furthermore ignored by the function \code{\link{read_BIN2R}}. } \section{Function version}{ 0.4.2 (2017-06-29 18:40:14) } \examples{ ##uncomment for usage ##data(ExampleData.BINfileData, envir = environment()) ##write_R2BIN(CWOSL.SAR.Data, file="[your path]/output.bin") } \section{How to cite}{ Kreutzer, S. (2017). write_R2BIN(): Export Risoe.BINfileData into Risoe BIN-file. Function version 0.4.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ DTU Nutech, 2016. The Squence Editor, Users Manual, February, 2016. \url{http://www.nutech.dtu.dk/english/products-and-services/radiation-instruments/tl_osl_reader/manuals} } \seealso{ \code{\link{read_BIN2R}}, \code{\linkS4class{Risoe.BINfileData}}, \code{\link{writeBin}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{IO} Luminescence/man/calc_AverageDose.Rd0000644000176200001440000001277013125227575017115 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/calc_AverageDose.R \name{calc_AverageDose} \alias{calc_AverageDose} \title{Calculate the Average Dose and the dose rate dispersion} \usage{ calc_AverageDose(data, sigma_m = NULL, Nb_BE = 500, na.rm = TRUE, plot = TRUE, verbose = TRUE, ...) } \arguments{ \item{data}{\code{\linkS4class{RLum.Results}} or \link{data.frame} (\bold{required}): for \code{data.frame}: two columns with De \code{(data[,1])} and De error \code{(values[,2])}} \item{sigma_m}{\code{\link{numeric}} (\bold{required}): the overdispersion resulting from a dose recovery experiment, i.e. when all grains have received the same dose. Indeed in such a case, any overdispersion (i.e. dispersion on top of analytical uncertainties) is, by definition, an unrecognised measurement uncertainty.} \item{Nb_BE}{\code{\link{integer}} (with default): sample size used for the bootstrapping} \item{na.rm}{\code{\link{logical}} (with default): exclude NA values from the data set prior to any further operation.} \item{plot}{\code{\link{logical}} (with default): enables/disables plot output} \item{verbose}{\code{\link{logical}} (with default): enables/disables terminal output} \item{...}{further arguments that can be passed to \code{\link[graphics]{hist}}. As three plots are returned all arguments need to be provided as \code{\link{list}}, e.g., \code{main = list("Plot 1", "Plot 2", "Plot 3")}. Note: not all arguments of \code{hist} are supported, but the output of \code{hist} is returned and can be used of own plots. \cr Further supported arguments: \code{mtext} (\code{character}), \code{rug} (\code{TRUE/FALSE}).} } \value{ The function returns numerical output and an (optional) plot. -----------------------------------\cr [ NUMERICAL OUTPUT ]\cr -----------------------------------\cr \bold{\code{RLum.Reuslts}}-object\cr \bold{slot:} \bold{\code{@data}} \cr [.. $summary : \code{data.frame}]\cr \tabular{lll}{ \bold{Column} \tab \bold{Type} \tab \bold{Description}\cr AVERAGE_DOSE \tab \code{numeric} \tab the obtained averge dose\cr AVERAGE_DOSE.SE \tab \code{numeric} \tab the average dose error \cr SIGMA_D \tab \code{numeric}\tab sigma \cr SIGMA_D.SE \tab \code{numeric}\tab standard error of the sigma \cr IC_AVERAGE_DOSE.LEVEL \tab \code{character}\tab confidence level average dose\cr IC_AVERAGE_DOSE.LOWER \tab \code{charcter}\tab lower quantile of average dose \cr IC_AVERAGE_DOSE.UPPER \tab \code{character}\tab upper quantile of average dose\cr IC_SIGMA_D.LEVEL \tab \code{integer}\tab confidence level sigma\cr IC_SIGMA_D.LOWER \tab \code{character}\tab lower sigma quantile\cr IC_SIGMA_D.UPPER \tab \code{character}\tab upper sigma quantile\cr L_MAX \tab \code{character}\tab maximum likelihood value } [.. $dstar : \code{matrix}]\cr Matrix with bootstrap values\cr [.. $hist : \code{list}]\cr Object as produced by the function histogram ------------------------\cr [ PLOT OUTPUT ]\cr ------------------------\cr The function returns two different plot panels. (1) An abanico plot with the dose values (2) A histogram panel comprising 3 histograms with the equivalent dose and the bootstrapped average dose and the sigma values. } \description{ This functions calculates the Average Dose and their extrinsic dispersion and estimates the standard errors by bootstrapping based on the Average Dose Model by Guerin et al., 2017 } \details{ \bold{\code{sigma_m}}\cr The program requires the input of a known value of sigma_m, which corresponds to the intrinsic overdispersion, as determined by a dose recovery experiment. Then the dispersion in doses (sigma_d) will be that over and above sigma_m (and individual uncertainties sigma_wi). } \note{ This function has beta status! } \section{Function version}{ 0.1.4 (2017-06-29 18:40:14) } \examples{ ##Example 01 using package example data ##load example data data(ExampleData.DeValues, envir = environment()) ##calculate Average dose ##(use only the first 56 values here) AD <- calc_AverageDose(ExampleData.DeValues$CA1[1:56,], sigma_m = 0.1) ##plot De and set Average dose as central value plot_AbanicoPlot( data = ExampleData.DeValues$CA1[1:56,], z.0 = AD$summary$AVERAGE_DOSE) } \section{How to cite}{ Christophe, C., Philippe, A., Guerin, G., Kreutzer, S. (2017). calc_AverageDose(): Calculate the Average Dose and the dose rate dispersion. Function version 0.1.4. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Guerin, G., Christophe, C., Philippe, A., Murray, A.S., Thomsen, K.J., Tribolo, C., Urbanova, P., Jain, M., Guibert, P., Mercier, N., Kreutzer, S., Lahaye, C., 2017. Absorbed dose, equivalent dose, measured dose rates, and implications for OSL age estimates: Introducing the Average Dose Model. Quaternary Geochronology 1-32. doi:10.1016/j.quageo.2017.04.002 \bold{Further reading}\cr Efron, B., Tibshirani, R., 1986. Bootstrap Methods for Standard Errors, Confidence Intervals, and Other Measures of Statistical Accuracy. Statistical Science 1, 54-75. } \seealso{ \code{\link{read.table}}, \code{\link[graphics]{hist}} } \author{ Claire Christophe, IRAMAT-CRP2A, Universite de Nantes (France), Anne Philippe, Universite de Nantes, (France), Guillaume Guerin, IRAMAT-CRP2A, Universite Bordeaux Montaigne, (France), Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne, (France) \cr R Luminescence Package Team} \keyword{datagen} Luminescence/man/CW2pHMi.Rd0000644000176200001440000001574613125227576015126 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/CW2pHMi.R \name{CW2pHMi} \alias{CW2pHMi} \title{Transform a CW-OSL curve into a pHM-OSL curve via interpolation under hyperbolic modulation conditions} \usage{ CW2pHMi(values, delta) } \arguments{ \item{values}{\code{\linkS4class{RLum.Data.Curve}} or \code{\link{data.frame}} (\bold{required}): \code{\linkS4class{RLum.Data.Curve}} or \code{\link{data.frame}} with measured curve data of type stimulation time (t) (\code{values[,1]}) and measured counts (cts) (\code{values[,2]}).} \item{delta}{\code{\link{vector}} (optional): stimulation rate parameter, if no value is given, the optimal value is estimated automatically (see details). Smaller values of delta produce more points in the rising tail of the curve.} } \value{ The function returns the same data type as the input data type with the transformed curve values. \item{list(list("RLum.Data.Curve"))}{package \code{\linkS4class{RLum} object} with two additional info elements: \tabular{rl}{ $CW2pHMi.x.t \tab: transformed time values \cr $CW2pHMi.method \tab: used method for the production of the new data points }} \item{list(list("data.frame"))}{with four columns: \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 }} } \description{ This function transforms a conventionally measured continuous-wave (CW) OSL-curve to a pseudo hyperbolic modulated (pHM) curve under hyperbolic modulation conditions using the interpolation procedure described by Bos & Wallinga (2012). } \details{ The complete procedure of the transformation is described in Bos & Wallinga (2012). The input \code{data.frame} consists of two columns: time (t) and count values (CW(t))\cr\cr \bold{Internal transformation steps}\cr\cr (1) log(CW-OSL) values\cr\cr (2) Calculate t' which is the transformed time:\cr \deqn{t' = t-(1/\delta)*log(1+\delta*t)} (3) Interpolate CW(t'), i.e. use the log(CW(t)) to obtain the count values for the transformed time (t'). Values beyond \code{min(t)} and \code{max(t)} produce \code{NA} values.\cr\cr (4) Select all values for t' < \code{min(t)}, i.e. values beyond the time resolution of t. Select the first two values of the transformed data set which contain no \code{NA} values and use these values for a linear fit using \code{\link{lm}}.\cr\cr (5) Extrapolate values for t' < \code{min(t)} based on the previously obtained fit parameters.\cr\cr (6) Transform values using\cr \deqn{pHM(t) = (\delta*t/(1+\delta*t))*c*CW(t')} \deqn{c = (1+\delta*P)/\delta*P} \deqn{P = length(stimulation~period)} (7) Combine all values and truncate all values for t' > \code{max(t)} \cr\cr \emph{The number of values for t' < \code{min(t)} depends on the stimulation rate parameter \code{delta}. To avoid the production of too many artificial data at the raising tail of the determined pHM curve, it is recommended to use the automatic estimation routine for \code{delta}, i.e. provide no value for \code{delta}.} } \note{ According to Bos & Wallinga (2012), the number of extrapolated points should be limited to avoid artificial intensity data. If \code{delta} is provided manually and more than two points are extrapolated, a warning message is returned. \cr\cr The function \code{\link{approx}} may produce some \code{Inf} and \code{NaN} data. The function tries to manually interpolate these values by calculating the \code{mean} using the adjacent channels. If two invalid values are succeeding, the values are removed and no further interpolation is attempted.\cr In every case a warning message is shown. } \section{Function version}{ 0.2.2 (2017-06-29 18:40:14) } \examples{ ##(1) - simple transformation ##load CW-OSL curve data data(ExampleData.CW_OSL_Curve, envir = environment()) ##transform values values.transformed<-CW2pHMi(ExampleData.CW_OSL_Curve) ##plot plot(values.transformed$x, values.transformed$y.t, log = "x") ##(2) - load CW-OSL curve from BIN-file and plot transformed values ##load BINfile #BINfileData<-readBIN2R("[path to BIN-file]") data(ExampleData.BINfileData, envir = environment()) ##grep first CW-OSL curve from ALQ 1 curve.ID<-CWOSL.SAR.Data@METADATA[CWOSL.SAR.Data@METADATA[,"LTYPE"]=="OSL" & CWOSL.SAR.Data@METADATA[,"POSITION"]==1 ,"ID"] curve.HIGH<-CWOSL.SAR.Data@METADATA[CWOSL.SAR.Data@METADATA[,"ID"]==curve.ID[1] ,"HIGH"] curve.NPOINTS<-CWOSL.SAR.Data@METADATA[CWOSL.SAR.Data@METADATA[,"ID"]==curve.ID[1] ,"NPOINTS"] ##combine curve to data set curve<-data.frame(x = seq(curve.HIGH/curve.NPOINTS,curve.HIGH, by = curve.HIGH/curve.NPOINTS), y=unlist(CWOSL.SAR.Data@DATA[curve.ID[1]])) ##transform values curve.transformed <- CW2pHMi(curve) ##plot curve plot(curve.transformed$x, curve.transformed$y.t, log = "x") ##(3) - 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<-CW2pLMi(values, P=1/20) lines(values[1:length(values.t[,1]),1],CW2pLMi(values, P=1/20)[,2], col="red" ,lwd=1.3) text(0.03,4500,"LM", col="red" ,cex=.8) values.t<-CW2pHMi(values, delta=40) lines(values[1:length(values.t[,1]),1],CW2pHMi(values, delta=40)[,2], col="black", lwd=1.3) text(0.005,3000,"HM", cex=.8) values.t<-CW2pPMi(values, P=1/10) lines(values[1:length(values.t[,1]),1],CW2pPMi(values, P=1/10)[,2], col="blue", lwd=1.3) text(0.5,6500,"PM", col="blue" ,cex=.8) } \section{How to cite}{ Kreutzer, S. (2017). CW2pHMi(): Transform a CW-OSL curve into a pHM-OSL curve via interpolation under hyperbolic modulation conditions. Function version 0.2.2. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ Bos, A.J.J. & Wallinga, J., 2012. How to visualize quartz OSL signal components. Radiation Measurements, 47, 752-758.\cr \bold{Further Reading}\cr\cr 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. } \seealso{ \code{\link{CW2pLM}}, \code{\link{CW2pLMi}}, \code{\link{CW2pPMi}}, \code{\link{fit_LMCurve}}, \code{\link{lm}}, \code{\linkS4class{RLum.Data.Curve}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr\cr Based on comments and suggestions from:\cr Adrie J.J. Bos, Delft University of Technology, The Netherlands\cr \cr R Luminescence Package Team} \keyword{manip} Luminescence/man/verify_SingleGrainData.Rd0000644000176200001440000001321413125227576020321 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/verify_SingleGrainData.R \name{verify_SingleGrainData} \alias{verify_SingleGrainData} \title{Verify single grain data sets and check for invalid grains, i.e. zero-light level grains} \usage{ verify_SingleGrainData(object, threshold = 10, cleanup = FALSE, cleanup_level = "aliquot", verbose = TRUE, plot = FALSE) } \arguments{ \item{object}{\code{\linkS4class{Risoe.BINfileData}} or \code{\linkS4class{RLum.Analysis}} (\bold{required}): input object. The function also accepts a list with objects of allowed type.} \item{threshold}{\code{\link{numeric}} (with default): numeric threshold value for the allowed difference between the \code{mean} and the \code{var} of the count values (see details)} \item{cleanup}{\code{\link{logical}} (with default): if set to \code{TRUE} curves indentified as zero light level curves are automatically removed. Ouput is an object as same type as the input, i.e. either \code{\linkS4class{Risoe.BINfileData}} or \code{\linkS4class{RLum.Analysis}}} \item{cleanup_level}{\code{\link{character}} (with default): selects the level for the cleanup of the input data sets. Two options are allowed: \code{"curve"} or \code{"aliquot"}. If \code{"curve"} is selected every single curve marked as \code{invalid} is removed. If \code{"aliquot"} is selected, curves of one aliquot (grain or disc) can be marked as invalid, but will not be removed. An aliquot will be only removed if all curves of this aliquot are marked as invalid.} \item{verbose}{\code{\link{logical}} (with default): enables or disables the terminal feedback} \item{plot}{\code{\link{logical}} (with default): enables or disables the graphical feedback} } \value{ The function returns -----------------------------------\cr [ NUMERICAL OUTPUT ]\cr -----------------------------------\cr \bold{\code{RLum.Reuslts}}-object\cr \bold{slot:} \bold{\code{@data}}\cr \tabular{lll}{ \bold{Element} \tab \bold{Type} \tab \bold{Description}\cr \code{$unique_pairs} \tab \code{data.frame} \tab the unique position and grain pairs \cr \code{$selection_id} \tab \code{numeric} \tab the selection as record ID \cr \code{$selection_full} \tab \code{data.frame} \tab implemented models used in the baSAR-model core \cr } \bold{slot:} \bold{\code{@info}}\cr The original function call\cr \bold{Output variation}\cr For \code{cleanup = TRUE} the same object as the input is returned, but cleaned up (invalid curves were removed). This means: Either an \code{\linkS4class{Risoe.BINfileData}} or an \code{\linkS4class{RLum.Analysis}} object is returned in such cases. An \code{\linkS4class{Risoe.BINfileData}} object can be exported to a BIN-file by using the function \code{\link{write_R2BIN}}. } \description{ This function tries to identify automatically zero-light level curves (grains) from single grain data measurements. \cr } \details{ \bold{How does the method work?}\cr The function compares the expected values (\eqn{E(X)}) and the variance (\eqn{Var(X)}) of the count values for each curve. Assuming that the background roughly follows a poisson distribution the absolute difference of both values should be zero or at least around zero as \deqn{E(x) = Var(x) = \lambda} Thus the function checks for: \deqn{abs(E(x) - Var(x)) >= \Theta} With \eqn{\Theta} an arbitray, user defined, threshold. Values above the threshold indicating curves comprising a signal.\cr Note: the absolute difference of \eqn{E(X)} and \eqn{Var(x)} instead of the ratio was chosen as both terms can become 0 which would result in 0 or \code{Inf}, if the ratio is calculated. } \note{ This function can work with \code{\linkS4class{Risoe.BINfileData}} objects or \code{\linkS4class{RLum.Analysis}} objects (or a list of it). However, the function is highly optimised for \code{\linkS4class{Risoe.BINfileData}} objects as it make sense to remove identify invalid grains before the conversion to an \code{\linkS4class{RLum.Analysis}} object.\cr The function checking for invalid curves works rather robust and it is likely that Reg0 curves within a SAR cycle are removed as well. Therefore it is strongly recommended to use the argument \code{cleanup = TRUE} carefully. } \section{Function version}{ 0.2.0 (2017-06-29 18:40:14) } \examples{ ##01 - basic example I ##just show how to apply the function data(ExampleData.XSYG, envir = environment()) ##verify and get data.frame out of it verify_SingleGrainData(OSL.SARMeasurement$Sequence.Object)$selection_full ##02 - basic example II data(ExampleData.BINfileData, envir = environment()) id <- verify_SingleGrainData(object = CWOSL.SAR.Data, cleanup_level = "aliquot")$selection_id \dontrun{ ##03 - advanced example I ##importing and exporting a BIN-file ##select and import file file <- file.choose() object <- read_BIN2R(file) ##remove invalid aliquots(!) object <- verify_SingleGrainData(object, cleanup = TRUE) ##export to new BIN-file write_R2BIN(object, paste0(dirname(file),"/", basename(file), "_CLEANED.BIN")) } } \section{How to cite}{ Kreutzer, S. (2017). verify_SingleGrainData(): Verify single grain data sets and check for invalid grains, i.e. zero-light level grains. Function version 0.2.0. In: Kreutzer, S., Dietze, M., Burow, C., Fuchs, M.C., Schmidt, C., Fischer, M., Friedrich, J. (2017). Luminescence: Comprehensive Luminescence Dating Data Analysis. R package version 0.7.5. https://CRAN.R-project.org/package=Luminescence } \references{ - } \seealso{ \code{\linkS4class{Risoe.BINfileData}}, \code{\linkS4class{RLum.Analysis}}, \code{\link{write_R2BIN}}, \code{\link{read_BIN2R}} } \author{ Sebastian Kreutzer, IRAMAT-CRP2A, Universite Bordeaux Montaigne (France) \cr R Luminescence Package Team} \keyword{datagen} \keyword{manip} Luminescence/man/as.Rd0000644000176200001440000000344413125226556014345 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RLum.Analysis-class.R, % R/RLum.Data.Curve-class.R, R/RLum.Data.Image-class.R, % R/RLum.Data.Spectrum-class.R, R/RLum.Results-class.R \name{as} \alias{as} \alias{as} \alias{as} \alias{as} \alias{as} \title{as() - RLum-object coercion} \arguments{ \item{from}{\code{\linkS4class{RLum}} or \code{\link{list}}, \code{\link{data.frame}}, \code{\link{matrix}} (\bold{required}): object to be coerced from} \item{to}{\code{\link{character}} (\bold{required}): class name to be coerced to} } \description{ for \code{[RLum.Analysis]} for \code{[RLum.Data.Curve]} for \code{[RLum.Data.Image]} for \code{[RLum.Data.Spectrum]} for \code{[RLum.Results]} } \details{ \bold{[RLum.Analysis]}\cr \tabular{ll}{ \bold{from} \tab \bold{to}\cr \code{list} \tab \code{list}\cr } Given that the \code{\link{list}} consits of \code{\linkS4class{RLum.Analysis}} objects. \bold{[RLum.Data.Curve]}\cr \tabular{ll}{ \bold{from} \tab \bold{to}\cr \code{list} \tab \code{list} \cr \code{data.frame} \tab \code{data.frame}\cr \code{matrix} \tab \code{matrix} } \bold{[RLum.Data.Image]}\cr \tabular{ll}{ \bold{from} \tab \bold{to}\cr \code{data.frame} \tab \code{data.frame}\cr \code{matrix} \tab \code{matrix} } \bold{[RLum.Data.Spectrum]}\cr \tabular{ll}{ \bold{from} \tab \bold{to}\cr \code{data.frame} \tab \code{data.frame}\cr \code{matrix} \tab \code{matrix} } \bold{[RLum.Results]}\cr \tabular{ll}{ \bold{from} \tab \bold{to}\cr \code{list} \tab \code{list}\cr } Given that the \code{\link{list}} consits of \code{\linkS4class{RLum.Results}} objects. } \note{ Due to the complex structure of the \code{RLum} objects itself a coercing to standard R data structures will be always loosely! } \seealso{ \code{\link[methods]{as}} }