Skip to content

Commit 76917f4

Browse files
JensBaalkildeJensBaalkilde
authored
Merge pull request #33 from JensBaalkilde/master
Imported drc helper functions to resolve ::: notes
2 parents cc34683 + 5a1d7b4 commit 76917f4

7 files changed

Lines changed: 110 additions & 13 deletions

File tree

‎.DS_Store‎

0 Bytes
Binary file not shown.

‎R/EDhelper.R‎

Lines changed: 46 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,46 @@
1+
# HELPER FUNCTION BORROWED FROM DRC PACKAGE
2+
3+
"EDhelper" <- function(parmVec, respl, reference, typeCalc, cond = TRUE)
4+
{
5+
## Works for log-logistic type dose-response models
6+
7+
## Converting absolute to relative
8+
if (typeCalc == "absolute")
9+
{
10+
p <- 100 * ((parmVec[3] - respl) / (parmVec[3] - parmVec[2]))
11+
# typeCalc <- "relative"
12+
} else {
13+
p <- respl
14+
}
15+
## Swapping p for an increasing curve
16+
if (cond)
17+
{
18+
if ((typeCalc == "relative") && (parmVec[1] < 0) && (reference == "control"))
19+
{
20+
p <- 100 - p
21+
}
22+
} else {
23+
if ((typeCalc == "relative") && (reference == "control"))
24+
{
25+
p <- 100 - p
26+
}
27+
}
28+
p
29+
}
30+
31+
## Used for FP models
32+
"EDhelper2" <- function(parmVec, respl, reference, typeCalc, increasing)
33+
{
34+
## Converting absolute to relative
35+
if (typeCalc == "absolute")
36+
{
37+
p <- 100 * (1 - (parmVec[3] - respl) / (parmVec[3] - parmVec[2]))
38+
39+
} else {
40+
41+
if (increasing) {p <- respl} else {p <- 100 - respl}
42+
}
43+
44+
p
45+
}
46+

‎R/absToRel.R‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
# HELPER FUNCTION BORROWED FROM DRC PACKAGE
2+
3+
"absToRel" <- function(parmVec, respl, typeCalc)
4+
{
5+
## Converting absolute to relative
6+
if (typeCalc == "absolute")
7+
{
8+
p <- 100 * ((parmVec[3] - respl) / (parmVec[3] - parmVec[2]))
9+
} else {
10+
p <- respl
11+
}
12+
13+
p
14+
}
15+

‎R/bmd.R‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -92,7 +92,7 @@ bmd<-function(object, bmr, backgType = c("modelBased", "absolute", "hybridSD", "
9292
if(inherits(object, "drcMMRE")){
9393
intMat <- matrix(qnorm(c((1-level)/2, 1-(1-level)/2), mean = bmdVal, sd = bmdSEVal), ncol = 2)
9494
} else {
95-
intMat <- drc:::confint.basic(matrix(c(bmdVal, bmdSEVal), ncol = 2),
95+
intMat <- confint.basic(matrix(c(bmdVal, bmdSEVal), ncol = 2),
9696
level = level, object$"type", df.residual(object), FALSE)
9797
}
9898
} else if(interval == "inv"){
@@ -178,7 +178,7 @@ bmd<-function(object, bmr, backgType = c("modelBased", "absolute", "hybridSD", "
178178
bmdSEVal <- sqrt(dBmdVal %*% varCov %*% dBmdVal)
179179

180180
if(interval == "delta"){
181-
intMat <- drc:::confint.basic(matrix(c(bmdVal, bmdSEVal), ncol = 2),
181+
intMat <- confint.basic(matrix(c(bmdVal, bmdSEVal), ncol = 2),
182182
level = level, object$"type", df.residual(object), FALSE)
183183
}
184184

‎R/bmd.edfct.R‎

Lines changed: 14 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@ bmd.edfct <- function(object){
1212
edfct <- function(parm, respl, reference, type, ...)
1313
{
1414
parmVec[notFixed] <- parm
15-
p <- drc:::EDhelper(parmVec, respl, reference, type)
15+
p <- EDhelper(parmVec, respl, reference, type)
1616

1717
tempVal <- log((100-p)/100)
1818
EDp <- parmVec[4]*(exp(-tempVal/parmVec[5])-1)^(1/parmVec[1])
@@ -35,7 +35,7 @@ bmd.edfct <- function(object){
3535
{
3636
parmVec[notFixed] <- parm
3737

38-
p <- drc:::EDhelper(parmVec, respl, reference, type)
38+
p <- EDhelper(parmVec, respl, reference, type)
3939

4040
tempVal <- log((100-p)/100)
4141
EDp <- exp(parmVec[4])*(exp(-tempVal/parmVec[5])-1)^(1/parmVec[1])
@@ -61,7 +61,7 @@ bmd.edfct <- function(object){
6161
edfct <- function(parm, respl, reference, type, ...)
6262
{
6363
parmVec[notFixed] <- parm
64-
p <- drc:::absToRel(parmVec, respl, type)
64+
p <- absToRel(parmVec, respl, type)
6565

6666
## Reversing p
6767
if (identical(type, "absolute"))
@@ -105,7 +105,7 @@ bmd.edfct <- function(object){
105105
edfct <- function(parm, respl, reference, type, ...) # function(parm, p, reference, type, ...)
106106
{
107107
parmVec[notFixed] <- parm
108-
p <- drc:::EDhelper(parmVec, respl, reference, type)
108+
p <- EDhelper(parmVec, respl, reference, type)
109109

110110
tempVal <- log(-log((100-p)/100))
111111
EDp <- exp(tempVal/parmVec[1] + log(parmVec[4]))
@@ -128,7 +128,7 @@ bmd.edfct <- function(object){
128128
{
129129
parmVec[notFixed] <- parm
130130

131-
p <- drc:::absToRel(parmVec, respl, type)
131+
p <- absToRel(parmVec, respl, type)
132132

133133
## Reversing p
134134
if ( (parmVec[1] > 0) && (reference == "control") && (type == "relative") )
@@ -154,7 +154,7 @@ bmd.edfct <- function(object){
154154
edfct <- function(parm, respl, reference, type, ...)
155155
{
156156
parmVec[notFixed] <- parm
157-
p <- drc:::EDhelper(parmVec, respl, reference, type)
157+
p <- EDhelper(parmVec, respl, reference, type)
158158

159159
# if (parmVec[1] > 0)
160160
# {
@@ -201,11 +201,11 @@ bmd.edfct <- function(object){
201201
interval <- c(lower, upper)
202202

203203
parmVec[notFixed] <- parm
204-
p <- drc:::EDhelper(parmVec, respl, reference, type)
204+
p <- EDhelper(parmVec, respl, reference, type)
205205
tempVal <- (100-p)/100
206206

207207
edfct0 <- function(parmVec){
208-
p <- drc:::EDhelper(parmVec, respl, reference, type)
208+
p <- EDhelper(parmVec, respl, reference, type)
209209
tempVal <- (100-p)/100
210210

211211
helpEqn <- function(dose)
@@ -240,12 +240,16 @@ bmd.edfct <- function(object){
240240
}
241241

242242
if(identical(class(object$fct), "fp-logistic")){
243+
if(!requireNamespace("numDeriv")){
244+
stop('package "numDeriv" must be installed to use FPL models')
245+
}
246+
243247
p1 <- as.numeric(unlist(strsplit(object$fct$name, split = "[,()]+"))[2])
244248
p2 <- as.numeric(unlist(strsplit(object$fct$name, split = "[,()]+"))[3])
245249
edfct <- function(parm, respl, reference, type, loged = FALSE, ...)
246250
{
247251
parmVec[notFixed] <- parm
248-
p <- drc:::EDhelper2(parmVec, respl, reference, type, parmVec[1] > 0)
252+
p <- EDhelper2(parmVec, respl, reference, type, parmVec[1] > 0)
249253

250254
invfp <- function(resp, b, e)
251255
{
@@ -260,7 +264,7 @@ bmd.edfct <- function(object){
260264

261265
EDfct0 <- function(par)
262266
{
263-
p <- drc:::EDhelper2(par, respl, reference, type, par[1] > 0)
267+
p <- EDhelper2(par, respl, reference, type, par[1] > 0)
264268
invfp(log((100-p)/p), par[1], par[4])
265269
}
266270

‎R/confint.basic.R‎

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,32 @@
1+
# HELPER FUNCTION BORROWED FROM DRC PACKAGE
2+
# Defining basic function for providing confidence intervals
3+
4+
"confint.basic" <- function(estMat, level, intType, dfres, formatting = TRUE)
5+
{
6+
alphah <- (1 - level)/2
7+
# if (type == "u") {two <- qnorm(1 - alphah)}
8+
# if (type == "t") {two <- qt(1 - alphah, df.residual(object))}
9+
tailPercentile <- switch(intType,
10+
binomial = qnorm(1 - alphah),
11+
continuous = qt(1 - alphah, dfres),
12+
event = qnorm(1 - alphah),
13+
Poisson = qnorm(1 - alphah),
14+
negbin1 = qnorm(1 - alphah),
15+
negbin2 = qnorm(1 - alphah))
16+
17+
estVec <- estMat[, 1]
18+
halfLength <- tailPercentile * estMat[, 2]
19+
confMat <- matrix(c(estVec - halfLength, estVec + halfLength), ncol = 2)
20+
21+
## Formatting matrix
22+
if (formatting)
23+
{
24+
colnames(confMat) <- c(paste(format(100 * alphah), "%", sep = " "), paste(format(100*(1 - alphah)), "%", sep = " "))
25+
rownames(confMat) <- rownames(estMat)
26+
}
27+
28+
return(confMat)
29+
}
30+
31+
32+

‎R/invBmd.R‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -559,7 +559,7 @@ invBmd <- function(object, bmr, level=0.9, slope, backgType="modelBased",
559559
# g1<-function(x){as.numeric(g(x, matrix(coef(object), 1, length(coef(object)))))}
560560
if(sandwich.vcov){
561561
j1<-function(x){sqrt(as.vector(h(x, matrix(coef(object), 1, length(coef(object)))))%*%
562-
sandwich(object)%*%
562+
sandwich::sandwich(object)%*%
563563
as.vector(h(x, matrix(coef(object), 1, length(coef(object))))))}
564564
} else{
565565
j1<-function(x){sqrt(as.vector(h(x, matrix(coef(object), 1, length(coef(object)))))%*%

0 commit comments

Comments
 (0)