Skip to content

Commit

Permalink
Rework the creation of RejectionCriteria in analyse_SAR.TL().
Browse files Browse the repository at this point in the history 
The code that creates the RejectionCriteria data frame has been entirely
rewritten using data.table, resulting in cleaner and also more performant
code.

Moreover, this change allows to solve an additional testcase:

  analyse_SAR.TL(object, dose.points = 2,
                 signal.integral.min = 210, signal.integral.max = 220,
                 sequence.structure = c("SIGNAL", "BACKGROUND"))

which previously failed with:

  Error in dimnames(x) <- dn :
    length of 'dimnames' [2] not equal to array extent

due to the use of sapply(), which in this case ended up producing a matrix
instead of a vector.
  • Loading branch information
@mcol
mcol committed Sep 16, 2024
1 parent a530df8 commit 00723c3
Show file tree
Hide file tree
Showing 3 changed files with 288 additions and 55 deletions.
95 changes: 40 additions & 55 deletions R/analyse_SAR.TL.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -300,67 +300,52 @@ analyse_SAR.TL <- function(
LnLxTnTx <- cbind(temp.DoseName[, c("Name", "Repeated")],
LnLxTnTx)

# 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="")
})
## convert to data.table for more convenient column manipulation
temp <- data.table(LnLxTnTx[, c("Name", "Dose", "Repeated", "LxTx")])

##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
# Calculate Recycling Ratio -----------------------------------------------
## 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
Expand Down
240 changes: 240 additions & 0 deletions tests/testthat/_snaps/analyse_SAR.TL.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1006,3 +1006,243 @@
}
}

---

{
"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"
}
}

8 changes: 8 additions & 0 deletions tests/testthat/test_analyse_SAR.TL.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -98,4 +98,12 @@ test_that("regression tests", {
"[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")
})

0 comments on commit 00723c3

Please sign in to comment.