diff --git a/NEWS.Rmd b/NEWS.Rmd index a8b94b6ff..5bba66a8e 100644 --- a/NEWS.Rmd +++ b/NEWS.Rmd @@ -24,6 +24,7 @@ it shows a warning with instructions and set `plot = FALSE`. This should prevent ### `analyse_SAR.TL()` * The function now produces a more correct `rejection.criteria` data frame (#245, fixed in #246). +* Several edge cases that led to crashes have been fixed (#147, fixed in #247). ### `get_RLum()` * When the function was used on a list of `RLum.Analysis-class` objects with the argument `null.rm = TRUE` it would diff --git a/NEWS.md b/NEWS.md index c032f6197..4aa746dd9 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,7 +5,7 @@ -# Changes in version 0.9.25.9000-6 (2024-09-16) +# Changes in version 0.9.25.9000-3 (2024-09-16) ## New functions @@ -28,6 +28,8 @@ - The function now produces a more correct `rejection.criteria` data frame (#245, fixed in \#246). +- Several edge cases that led to crashes have been fixed (#147, fixed in + \#247). ### `get_RLum()` diff --git a/R/analyse_SAR.TL.R b/R/analyse_SAR.TL.R index 4162ccc81..c7b6bad7e 100644 --- a/R/analyse_SAR.TL.R +++ b/R/analyse_SAR.TL.R @@ -10,7 +10,7 @@ #' #' **Provided rejection criteria** #' -#' `[recyling.ratio]`: calculated for every repeated regeneration dose point. +#' `[recycling.ratio]`: calculated for every repeated regeneration dose point. #' #' `[recuperation.rate]`: recuperation rate calculated by #' comparing the `Lx/Tx` values of the zero regeneration point with the `Ln/Tn` @@ -40,7 +40,7 @@ #' specifies the general sequence structure. Three steps are allowed #' (`"PREHEAT"`, `"SIGNAL"`, `"BACKGROUND"`), in addition a #' parameter `"EXCLUDE"`. This allows excluding TL curves which are not -#' relevant for the protocol analysis. (**Note:** None TL are removed by default) +#' relevant for the protocol analysis. (**Note:** No TL are removed by default) #' #' @param rejection.criteria [list] (*with default*): #' list containing rejection criteria in percentage for the calculation. @@ -193,6 +193,7 @@ analyse_SAR.TL <- function( ##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( @@ -217,6 +218,18 @@ analyse_SAR.TL <- function( TL.background.ID <- temp.sequence.structure[ temp.sequence.structure[,"protocol.step"] == "BACKGROUND","id"] + ## check that `dose.points` is compatible with our signals: + ## as we expect each signal to have an Lx and a Tx components (see calls + ## to calc_TLLxTxRatio()), `dose.points` must divide `length(TL.signal.ID)` + ## in order for vector recycling to work when further down we do + ## `LnLxTnTx$Dose <- dose.points` + if (!missing(dose.points)) { + if ((length(TL.signal.ID) / 2) %% length(dose.points) != 0) { + .throw_error("Length of 'dose.points' not compatible with number ", + "of signals") + } + } + ##comfort ... translate integral limits from temperature to channel if(integral_input == "temperature"){ signal.integral.min <- @@ -230,147 +243,109 @@ analyse_SAR.TL <- function( } ##calculate LxTx values using external function + LnLxTnTx <- NULL for(i in seq(1,length(TL.signal.ID),by=2)){ - temp.LnLxTnTx <- get_RLum( - calc_TLLxTxRatio( + Lx.data.background <- Tx.data.background <- NULL + if (length(TL.background.ID) > 0) { + Lx.data.background <- get_RLum(object, record.id = TL.background.ID[i]) + Tx.data.background <- get_RLum(object, record.id = TL.background.ID[i + 1]) + } + LxTxRatio <- 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]) - - }, + Lx.data.background = Lx.data.background, + Tx.data.background = Tx.data.background, signal.integral.min, signal.integral.max - ) ) + temp.LnLxTnTx <- get_RLum(LxTxRatio) + rm(LxTxRatio) ##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) - + if (is.null(temp.Dose)) { + temp.Dose <- NA } + + ## append row to the data.frame + LnLxTnTx <- rbind(LnLxTnTx, cbind(Dose = temp.Dose, temp.LnLxTnTx)) } ##set dose.points manually 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(LnLxTnTx[["Dose"]]) - 1)) - temp.DoseName <- paste0("R", temp.DoseID) - temp.DoseName <- cbind(Name = temp.DoseName, Dose = LnLxTnTx[["Dose"]]) + temp.DoseName <- data.frame(Name = paste0("R", seq(nrow(LnLxTnTx)) - 1), + 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" + 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) + temp.DoseName <- cbind(temp.DoseName, + Repeated = duplicated(temp.DoseName[, "Dose"])) ##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.DoseName[, c("Name", "Repeated")], + LnLxTnTx) - - LnLxTnTx<-cbind(temp.LnLxTnTx,LnLxTnTx) - LnLxTnTx[,"Name"]<-as.character(LnLxTnTx[,"Name"]) + ## convert to data.table for more convenient column manipulation + temp <- data.table(LnLxTnTx[, c("Name", "Dose", "Repeated", "LxTx")]) # Calculate Recycling Ratio ----------------------------------------------- - RecyclingRatio <- NA_real_ - 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 + ## we first create a dummy object to use in case there are no repeated doses, + ## but replace it in the `if` block if there are any + rej.thresh <- rejection.criteria$recycling.ratio / 100 + rej.thresh.text <- paste("\u00b1", rej.thresh) # \u00b1 is ± + RecyclingRatio <- data.table(criterion = "recycling ratio", + value = NA, + threshold = rej.thresh.text, + status = NA_character_) + if (any(temp$Repeated)) { + + ## find the index of the previous dose of each repeated dose + temp[, prev.idx := match(Dose, Dose)] + + ## calculate the recycling ratio + temp[, criterion := paste0(Name, "/", Name[prev.idx])] + temp[, value := LxTx / LxTx[prev.idx]] + + ## set status according to the given rejection threshold + temp[, threshold := rej.thresh.text] + temp[, status := fifelse(abs(1 - value) > rej.thresh, "FAILED", "OK")] + + ## keep only the repeated doses + RecyclingRatio <- temp[Repeated == TRUE, + .(criterion, value, threshold, status)] } # Calculate Recuperation Rate --------------------------------------------- - Recuperation <- NA_real_ - if("R0" %in% LnLxTnTx[,"Name"]==TRUE){ - Recuperation<-round(LnLxTnTx[LnLxTnTx[,"Name"]=="R0","LxTx"]/ - LnLxTnTx[LnLxTnTx[,"Name"]=="Natural","LxTx"],digits=4) + ## we first create a dummy object to use in case there is no R0 dose, + ## but replace it in the `if` block if there is one + Recuperation <- data.table(criterion = "recuperation rate", + value = NA_real_, + threshold = rejection.criteria$recuperation.rate / 100, + status = NA_character_) + if ("R0" %in% temp$Name) { + Recuperation[, value := round(temp[Name == "R0", LxTx] / + temp[Name == "Natural", LxTx], digits = 4)] + Recuperation[, status := fifelse(value > threshold, "FAILED", "OK")] } - # Combine and Evaluate Rejection Criteria --------------------------------- - - RejectionCriteria <- data.frame( - criterion = c(if (is.na(RecyclingRatio)) "recycling ratio" else colnames(RecyclingRatio), - "recuperation rate"), - value = c(RecyclingRatio,Recuperation), - threshold = c( - rep(paste("\u00b1", rejection.criteria$recycling.ratio/100) - ,length(RecyclingRatio)), - 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) { - if (Recuperation > rejection.criteria$recuperation.rate / 100) "FAILED" else "OK" - } else NA_character_ - )) + ## join the two tables and convert back to data.frame + RejectionCriteria <- as.data.frame(rbind(RecyclingRatio, Recuperation)) + rm(temp) ##============================================================================## ##PLOTTING @@ -526,19 +501,17 @@ analyse_SAR.TL <- function( lines(NTL.net.LnLx, col = col[1]) lines(Reg1.net.LnLx, col = col[2]) - ##plot + TL.tmp <- TL.Plateau.LnLx[c(signal.integral.min:signal.integral.max), 2] + ylim.max <- quantile(TL.tmp[!is.infinite(TL.tmp)], + probs = 0.90, na.rm = TRUE) par(new = TRUE) plot( TL.Plateau.LnLx, axes = FALSE, xlab = "", ylab = "", - ylim = c(0, - quantile( - TL.Plateau.LnLx[c(signal.integral.min:signal.integral.max), 2], - probs = c(0.90), na.rm = TRUE - ) + 3), + ylim = c(0, ylim.max + 3), col = "darkgreen" ) axis(4) @@ -651,15 +624,20 @@ analyse_SAR.TL <- function( ... )) - ##check for error + ## plot_GrowthCurve() can fail in two ways: + ## 1. either with a hard error, in which case there's nothing much we + ## can do and stop early by returning NULL if(inherits(temp.GC, "try-error")){ return(NULL) - - }else{ - temp.GC <- get_RLum(temp.GC)[, c("De", "De.Error")] - } + ## 2. or with a soft error by returning NULL, in which case we set + ## temp.GC to NA and continue (this can be done after the call to + ## get_RLum(), as it deals well with NULLs) + temp.GC <- get_RLum(temp.GC)[, c("De", "De.Error")] + if (is.null(temp.GC)) + temp.GC <- NA + ##add rejection status if(length(grep("FAILED",RejectionCriteria$status))>0){ temp.GC <- data.frame(temp.GC, RC.Status="FAILED") diff --git a/man/analyse_SAR.TL.Rd b/man/analyse_SAR.TL.Rd index 13e1db4a3..5ccc85ffb 100644 --- a/man/analyse_SAR.TL.Rd +++ b/man/analyse_SAR.TL.Rd @@ -41,7 +41,7 @@ best matching channel is selected.} 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. (\strong{Note:} None TL are removed by default)} +relevant for the protocol analysis. (\strong{Note:} No TL are removed by default)} \item{rejection.criteria}{\link{list} (\emph{with default}): list containing rejection criteria in percentage for the calculation.} @@ -79,7 +79,7 @@ used. \strong{Provided rejection criteria} -\verb{[recyling.ratio]}: calculated for every repeated regeneration dose point. +\verb{[recycling.ratio]}: calculated for every repeated regeneration dose point. \verb{[recuperation.rate]}: recuperation rate calculated by comparing the \code{Lx/Tx} values of the zero regeneration point with the \code{Ln/Tn} diff --git a/tests/testthat/_snaps/analyse_SAR.TL.md b/tests/testthat/_snaps/analyse_SAR.TL.md index 948b1c7fb..fddfbc85b 100644 --- a/tests/testthat/_snaps/analyse_SAR.TL.md +++ b/tests/testthat/_snaps/analyse_SAR.TL.md @@ -761,3 +761,488 @@ } } +# regression tests + + { + "type": "S4", + "attributes": { + "data": { + "type": "list", + "attributes": { + "names": { + "type": "character", + "attributes": {}, + "value": ["data", "LnLxTnTx.table", "rejection.criteria"] + } + }, + "value": [ + { + "type": "list", + "attributes": { + "names": { + "type": "character", + "attributes": {}, + "value": ["De", "De.Error", "RC.Status"] + }, + "class": { + "type": "character", + "attributes": {}, + "value": ["data.frame"] + }, + "row.names": { + "type": "integer", + "attributes": {}, + "value": [1] + } + }, + "value": [ + { + "type": "integer", + "attributes": {}, + "value": ["NA"] + }, + { + "type": "double", + "attributes": {}, + "value": [29.59178565] + }, + { + "type": "character", + "attributes": {}, + "value": ["OK"] + } + ] + }, + { + "type": "list", + "attributes": { + "names": { + "type": "character", + "attributes": {}, + "value": ["Name", "Repeated", "Dose", "LnLx", "LnLx.BG", "TnTx", "TnTx.BG", "net_LnLx", "net_LnLx.Error", "net_TnTx", "net_TnTx.Error", "LxTx", "LxTx.Error"] + }, + "class": { + "type": "character", + "attributes": {}, + "value": ["data.frame"] + }, + "row.names": { + "type": "integer", + "attributes": {}, + "value": [1, 2, 3, 4, 5, 6, 7] + } + }, + "value": [ + { + "type": "character", + "attributes": {}, + "value": ["Natural", "R1", "R2", "R3", "R4", "R0", "R6"] + }, + { + "type": "logical", + "attributes": {}, + "value": [false, false, false, false, false, false, true] + }, + { + "type": "double", + "attributes": {}, + "value": [0, 136, 317, 544, 815, 0, 317] + }, + { + "type": "double", + "attributes": {}, + "value": [23, 75, 130, 148, 196, 27, 131] + }, + { + "type": "double", + "attributes": {}, + "value": [25, 16, 14, 17, 18, 19, 14] + }, + { + "type": "double", + "attributes": {}, + "value": [99, 98, 97, 85, 80, 76, 90] + }, + { + "type": "double", + "attributes": {}, + "value": [13, 13, 19, 16, 11, 8, 17] + }, + { + "type": "double", + "attributes": {}, + "value": [-2, 59, 116, 131, 178, 8, 117] + }, + { + "type": "double", + "attributes": {}, + "value": [0.67882251, 7.82236877, 29.29442379, 5.44888167, 48.94750274, 3.27502088, 17.72817716] + }, + { + "type": "double", + "attributes": {}, + "value": [86, 85, 78, 69, 69, 68, 73] + }, + { + "type": "double", + "attributes": {}, + "value": [56.13339986, 13.87017148, 14.51429709, 3.04939799, 31.04841594, 66.11448404, 9.10919912] + }, + { + "type": "double", + "attributes": {}, + "value": [-0.02325581, 0.69411765, 1.48717949, 1.89855072, 2.57971014, 0.11764706, 1.60273973] + }, + { + "type": "double", + "attributes": {}, + "value": [0.00728611, 0.20529294, 0.65230498, 0.16287418, 1.87019444, 0.16254699, 0.44284729] + } + ] + }, + { + "type": "list", + "attributes": { + "names": { + "type": "character", + "attributes": {}, + "value": ["criterion", "value", "threshold", "status"] + }, + "class": { + "type": "character", + "attributes": {}, + "value": ["data.frame"] + }, + "row.names": { + "type": "integer", + "attributes": {}, + "value": [1, 2] + } + }, + "value": [ + { + "type": "character", + "attributes": {}, + "value": ["R6/R2", "recuperation rate"] + }, + { + "type": "double", + "attributes": {}, + "value": [1.0777043, -5.0588] + }, + { + "type": "character", + "attributes": {}, + "value": ["± 0.1", "0.1"] + }, + { + "type": "character", + "attributes": {}, + "value": ["OK", "OK"] + } + ] + } + ] + }, + "originator": { + "type": "character", + "attributes": {}, + "value": ["analyse_SAR.TL"] + }, + "info": { + "type": "list", + "attributes": { + "names": { + "type": "character", + "attributes": {}, + "value": ["info"] + } + }, + "value": [ + { + "type": "language", + "attributes": { + "srcref": { + "type": "integer", + "attributes": { + "srcfile": { + "type": "environment", + "attributes": { + "class": { + "type": "character", + "attributes": {}, + "value": ["srcfilecopy", "srcfile"] + } + }, + "value": {} + }, + "class": { + "type": "character", + "attributes": {}, + "value": ["srcref"] + } + }, + "value": [6, 3, 6, 30, 3, 30, 6, 6] + } + }, + "value": ["analyse_SAR.TL(object, sequence.structure = c(\"SIGNAL\", \"BACKGROUND\"), ", " signal.integral.min = 2, signal.integral.max = 3)"] + } + ] + }, + ".uid": { + "type": "character", + "attributes": {}, + "value": [null] + }, + ".pid": { + "type": "character", + "attributes": {}, + "value": [null] + } + }, + "value": { + "class": "RLum.Results", + "package": "Luminescence" + } + } + +--- + + { + "type": "S4", + "attributes": { + "data": { + "type": "list", + "attributes": { + "names": { + "type": "character", + "attributes": {}, + "value": ["data", "LnLxTnTx.table", "rejection.criteria"] + } + }, + "value": [ + { + "type": "list", + "attributes": { + "names": { + "type": "character", + "attributes": {}, + "value": ["temp.GC", "RC.Status"] + }, + "class": { + "type": "character", + "attributes": {}, + "value": ["data.frame"] + }, + "row.names": { + "type": "integer", + "attributes": {}, + "value": [1] + } + }, + "value": [ + { + "type": "logical", + "attributes": {}, + "value": [null] + }, + { + "type": "character", + "attributes": {}, + "value": ["FAILED"] + } + ] + }, + { + "type": "list", + "attributes": { + "names": { + "type": "character", + "attributes": {}, + "value": ["Name", "Repeated", "Dose", "LnLx", "LnLx.BG", "TnTx", "TnTx.BG", "net_LnLx", "net_LnLx.Error", "net_TnTx", "net_TnTx.Error", "LxTx", "LxTx.Error"] + }, + "class": { + "type": "character", + "attributes": {}, + "value": ["data.frame"] + }, + "row.names": { + "type": "integer", + "attributes": {}, + "value": [1, 2, 3, 4, 5, 6, 7] + } + }, + "value": [ + { + "type": "character", + "attributes": {}, + "value": ["Natural", "R1", "R2", "R3", "R4", "R5", "R6"] + }, + { + "type": "logical", + "attributes": {}, + "value": [false, true, true, true, true, true, true] + }, + { + "type": "double", + "attributes": {}, + "value": [2, 2, 2, 2, 2, 2, 2] + }, + { + "type": "double", + "attributes": {}, + "value": [143976, 46982, 116969, 202244, 288938, 1072, 104093] + }, + { + "type": "double", + "attributes": {}, + "value": [1264, 945, 1448, 1930, 2688, 906, 1573] + }, + { + "type": "double", + "attributes": {}, + "value": [46845, 46693, 48323, 48617, 47368, 44496, 44685] + }, + { + "type": "double", + "attributes": {}, + "value": [970, 960, 1145, 1312, 1490, 1040, 1127] + }, + { + "type": "double", + "attributes": {}, + "value": [142712, 46037, 115521, 200314, 286250, 166, 102520] + }, + { + "type": "double", + "attributes": {}, + "value": [23471.76514974, 516.71547437, 17093.06753332, 45355.24022785, 90210.69966717, 17.36079828, 20554.16013632] + }, + { + "type": "double", + "attributes": {}, + "value": [45875, 45733, 47178, 47305, 45878, 43456, 43558] + }, + { + "type": "double", + "attributes": {}, + "value": [9831.88240676, 505.28303788, 8827.98669696, 15756.02600879, 26083.14939525, 3959.18877496, 12188.88207632] + }, + { + "type": "double", + "attributes": {}, + "value": [3.11088828, 1.00664728, 2.44862012, 4.23452066, 6.23937399, 0.00381996, 2.35364342] + }, + { + "type": "double", + "attributes": {}, + "value": [1.17836846, 0.02242051, 0.82049797, 2.36918841, 5.51360616, 0.00074753, 1.13050283] + } + ] + }, + { + "type": "list", + "attributes": { + "names": { + "type": "character", + "attributes": {}, + "value": ["criterion", "value", "threshold", "status"] + }, + "row.names": { + "type": "integer", + "attributes": {}, + "value": [1, 2, 3, 4, 5, 6, 7] + }, + "class": { + "type": "character", + "attributes": {}, + "value": ["data.frame"] + } + }, + "value": [ + { + "type": "character", + "attributes": {}, + "value": ["R1/Natural", "R2/Natural", "R3/Natural", "R4/Natural", "R5/Natural", "R6/Natural", "recuperation rate"] + }, + { + "type": "double", + "attributes": {}, + "value": [0.32358837, 0.78711284, 1.36119342, 2.00565672, 0.00122793, 0.75658243, "NA"] + }, + { + "type": "character", + "attributes": {}, + "value": ["± 0.1", "± 0.1", "± 0.1", "± 0.1", "± 0.1", "± 0.1", "0.1"] + }, + { + "type": "character", + "attributes": {}, + "value": ["FAILED", "FAILED", "FAILED", "FAILED", "FAILED", "FAILED", null] + } + ] + } + ] + }, + "originator": { + "type": "character", + "attributes": {}, + "value": ["analyse_SAR.TL"] + }, + "info": { + "type": "list", + "attributes": { + "names": { + "type": "character", + "attributes": {}, + "value": ["info"] + } + }, + "value": [ + { + "type": "language", + "attributes": { + "srcref": { + "type": "integer", + "attributes": { + "srcfile": { + "type": "environment", + "attributes": { + "class": { + "type": "character", + "attributes": {}, + "value": ["srcfilecopy", "srcfile"] + } + }, + "value": {} + }, + "class": { + "type": "character", + "attributes": {}, + "value": ["srcref"] + } + }, + "value": [6, 3, 6, 30, 3, 30, 6, 6] + } + }, + "value": ["analyse_SAR.TL(object, dose.points = 2, signal.integral.min = 210, ", " signal.integral.max = 220, sequence.structure = c(\"SIGNAL\", ", " \"BACKGROUND\"))"] + } + ] + }, + ".uid": { + "type": "character", + "attributes": {}, + "value": [null] + }, + ".pid": { + "type": "character", + "attributes": {}, + "value": [null] + } + }, + "value": { + "class": "RLum.Results", + "package": "Luminescence" + } + } + diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 103c4eaf7..e30412a86 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -2,8 +2,9 @@ ## helper functions for snapshotting ## -expect_snapshot_RLum <- function(object) { +## the ... can be used to set the tolerance +expect_snapshot_RLum <- function(object, ...) { object@.uid <- NA_character_ object@.pid <- NA_character_ - expect_snapshot_value(object, style = "json2") + expect_snapshot_value(object, style = "json2", ...) } diff --git a/tests/testthat/test_analyse_SAR.TL.R b/tests/testthat/test_analyse_SAR.TL.R index e639825c3..ffac490d4 100644 --- a/tests/testthat/test_analyse_SAR.TL.R +++ b/tests/testthat/test_analyse_SAR.TL.R @@ -1,10 +1,10 @@ ## load data data(ExampleData.BINfileData, envir = environment()) -## transform the values from the first position in a RLum.Analysis object +## transform the values from the third position in an RLum.Analysis object object <- Risoe.BINfileData2RLum.Analysis(TL.SAR.Data, pos = 3) -test_that("Input validation", { +test_that("input validation", { skip_on_cran() expect_error(analyse_SAR.TL(), @@ -20,6 +20,11 @@ test_that("Input validation", { expect_error(analyse_SAR.TL(object, signal.integral.min = 1, signal.integral.max = 2), "Input TL curves are not a multiple of the sequence structure") + expect_error(analyse_SAR.TL(object, dose.points = c(2, 2), + signal.integral.min = 210, + signal.integral.max = 220, + sequence.structure = c("SIGNAL", "BACKGROUND")), + "Length of 'dose.points' not compatible with number of signals") }) test_that("Test examples", { @@ -71,3 +76,35 @@ test_that("Test examples", { "'fit.weights' ignored since the error column is invalid or 0") }) }) + +test_that("regression tests", { + skip_on_cran() + + ## issue 147 -------------------------------------------------------------- + + SW({ + set.seed(1) + expect_snapshot_RLum( + analyse_SAR.TL(object, sequence.structure = c("SIGNAL", "BACKGROUND"), + signal.integral.min = 2, signal.integral.max = 3), + tolerance = 1.5e-4 + ) + + seq.structure <- c("SIGNAL", "EXCLUDE", "BACKGROUND", "EXCLUDE", "PREHEAT", + "EXCLUDE", "BACKGROUND", "SIGNAL", "EXCLUDE", "EXCLUDE", + "EXCLUDE", "EXCLUDE") + expect_error(analyse_SAR.TL(object, signal.integral.min = 2, + signal.integral.max = 2, + sequence.structure = seq.structure), + "[calc_TLLxTxRatio()] Data types of Lx and Tx data differ", + fixed = TRUE) + }) + + expect_message( + expect_snapshot_RLum( + analyse_SAR.TL(object, dose.points = 2, + signal.integral.min = 210, signal.integral.max = 220, + sequence.structure = c("SIGNAL", "BACKGROUND")) + ), + "Error: All points have the same dose, NULL returned") +})