4PL report update

This commit is contained in:
2026-05-14 18:38:27 +02:00
parent 9861af5fba
commit 9422490f25
4 changed files with 338 additions and 455 deletions
+192 -191
View File
@@ -90,198 +90,199 @@ You can also embed plots, for example:
```{r XLplot, echo=FALSE, warning=FALSE, fig.height=4, fig.width=6, fig.cap="Plot of models", fig.align='left'}
plot_f <- function(dat, sigmoid,det_sig) {
CORdat <- cor(dat[,1],dat[,ncol(dat)])
# plot_f <- function(dat, sigmoid,det_sig) {
# CORdat <- cor(dat[,1],dat[,ncol(dat)])
#
# all_l <- melt(data.frame(dat), id.vars="log_dose", variable.name="replname", value.name = "readout")
# isRef <- rep(c(1,0),1,each=nrow(all_l)/2)
# isSample <- rep(c(0,1),1,each=nrow(all_l)/2)
# all_l2 <- cbind(all_l, isRef, isSample)
#
# if(is.null(det_sig)) {
# if (CORdat<0) {
# startlist <- list(a=sigmoid[3], b=-sigmoid[5],cs=sigmoid[7],
# d=sigmoid[1],r=sigmoid[8])
# } else {
# startlist <- list(a=sigmoid[3],b=sigmoid[5],cs=sigmoid[7],
# d=sigmoid[1],r=sigmoid[8])
# }
# } else {
# startlist <- list(a=det_sig[5], b=det_sig[1],cs=det_sig[7],
# d=det_sig[3],r=det_sig[7] - det_sig[8])
# }
# #browser()
# tryCatch({
# mr <- gsl_nls(fn = readout ~ a+(d-a)/(1+exp(b*(log_dose-(cs-r*isSample)))),
# data=all_l2,
# start=startlist,
# control=gsl_nls_control(xtol=1e-6,ftol=1e-6, gtol=1e-6))
# },
# error = function(err) {
# err$message
# })
# s_mr <- summary(mr)
# a <- s_mr$coefficients[1,1]
# b <- s_mr$coefficients[2,1]
# cs <- s_mr$coefficients[3,1]
# d <- s_mr$coefficients[4,1]
# r <- s_mr$coefficients[5,1]
#
# log_dose <- unique(all_l$log_dose)
# seq_x <- seq(min(log_dose),max(log_dose),0.1)
# SAMPLE <- a+(d-a)/(1+exp(b*(seq_x-(cs-r))))
# REF <- a+(d-a)/(1+exp(b*(seq_x-(cs))))
#
# if (is.null(det_sig)) {
# SAMPLEtrue <- sigmoid[4] + (sigmoid[2] -sigmoid[4])/(1+exp(sigmoid[6]*(seq_x-(sigmoid[7]-sigmoid[8]))))
# REFtrue <- sigmoid[3] + (sigmoid[1] -sigmoid[3])/(1+exp(sigmoid[5]*(seq_x-(sigmoid[7]))))
# } else {
# SAMPLEtrue <- det_sig[4] + (det_sig[6] -det_sig[4])/(1+exp(-det_sig[2]*(seq_x-(det_sig[8]))))
# REFtrue <- det_sig[3] + (det_sig[5] -det_sig[3])/(1+exp(-det_sig[1]*(seq_x-(det_sig[7]))))
# }
#
# pl_df <- cbind(seq_x, SAMPLE, REF, SAMPLEtrue, REFtrue)
# all_l2$readout[all_l2$readout < 0] <- 0.01
# all_l2$readouttrans <- log(all_l2$readout)
# slopeEC50 <- b*(a-d)/4
#
# Xbendl3 <- cs-(1.31696/b)
# Xbendu3 <- cs+(1.31696/b)
# XbendlT <- cs-r-(1.31696/b)
# XbenduT <- cs-r+(1.31696/b)
# bendpoints <- c(bendREF_lower = round(Xbendl3,3), bendREF_upper=round(Xbendu3,3),
# bendSAMPLE_lower = round(XbendlT,3), bendSAMPLE_upper=round(XbenduT,3))
#
# p <- ggplot(all_l2, aes(x=log_dose, y=readout, color=factor(isRef))) +
# geom_point(shape=factor(isRef), alpha=0.8) +
# labs(title = paste("restricted 4pl; bendp:", round(Xbendl3,3),round(Xbendu3,3),round(XbendlT,3),round(XbenduT,3)),
# color="product") +
# scale_color_manual(labels=c("test","reference"), values=c("red","blue")) +
# scale_shape_manual(labels=c("test","reference")) +
# theme_bw() +
# theme(axis.text = element_text(size=14))
#
# p2 <- p + geom_line(data=as.data.frame(pl_df), aes(x=seq_x, y=SAMPLE), color="red",
# inherit.aes = F) +
# geom_line(data=as.data.frame(pl_df), aes(x=seq_x, y=REF), color="blue",
# inherit.aes = F) +
# geom_line(data=as.data.frame(pl_df), aes(x=seq_x, y=SAMPLEtrue), color="red", linetype=2, alpha=0.4,
# inherit.aes = F) +
# geom_line(data=as.data.frame(pl_df), aes(x=seq_x, y=REFtrue), color="blue", linetype=2, alpha=0.4,
# inherit.aes = F) +
# geom_vline(xintercept=c(Xbendl3, Xbendu3), col="blue",linetype=2) +
# geom_vline(xintercept=c(XbendlT, XbenduT), col="red",linetype=2) +
# annotate("text", x=cs, y=a+(d-a)/2, label="0", size=5) +
# theme(legend.position="none")
#
#
# # transformed plots
# p_rt <- ggplot(all_l2, aes(x=log_dose, y=readouttrans, color=factor(isRef))) +
# geom_point(shape=factor(isRef), alpha=0.8) +
# labs(title = paste("restricted transformed 4pl"), color="product") +
# scale_color_manual(labels=c("test","reference"), values=c("red","blue")) +
# theme_bw()
#
# mrt <- gsl_nls(fn = readouttrans ~ a+(d-a)/(1+exp(b*(log_dose-(cs-r*isSample)))),
# data=all_l2,
# start=startlist,
# control=gsl_nls_control(xtol=1e-6,ftol=1e-6, gtol=1e-6))
# s_mrt <- summary(mrt)
# a_trans <- s_mrt$coefficients[1,1]
# b_trans <- s_mrt$coefficients[2,1]
# cs_trans <- s_mrt$coefficients[3,1]
# d_trans <- s_mrt$coefficients[4,1]
# r_trans <- s_mrt$coefficients[5,1]
#
# XbendlTrans <- cs_trans-(1.31696/b_trans)
# XbenduTrans <- cs_trans+(1.31696/b_trans)
# XbendlTransT <- cs_trans-r_trans-(1.31696/b_trans)
# XbenduTransT <- cs_trans-r_trans+(1.31696/b_trans)
# bendpointsTRANS <- c(bendREF_lower = round(XbendlTrans,3), bendREF_upper=round(XbenduTrans,3),
# bendSAMPLE_lower = round(XbendlTransT,3), bendSAMPLE_upper=round(XbenduTransT,3))
#
# SAMPLEtrans <- a_trans+(d_trans-a_trans)/(1+exp(b_trans*(seq_x-(cs_trans-r_trans))))
# REFtrans <- a_trans+(d_trans-a_trans)/(1+exp(b_trans*(seq_x-(cs_trans))))
#
# pl_df_trans <- cbind(seq_x, SAMPLEtrans, REFtrans)
# p_rt2 <- p_rt + geom_line(data=as.data.frame(pl_df_trans), aes(x=seq_x, y=SAMPLEtrans), color="red",
# inherit.aes = F) +
# geom_line(data=as.data.frame(pl_df_trans), aes(x=seq_x, y=REFtrans), color="blue",
# inherit.aes = F) +
# geom_vline(xintercept=c(XbendlTrans, XbenduTrans), col="blue",linetype=2) +
# geom_vline(xintercept=c(XbendlTransT, XbenduTransT), col="red",linetype=2) +
# theme(legend.position = "none", axis.text=element_text(size=14))
#
# if (is.null(det_sig)) {
# unrestr <- drm(readout ~ exp(log_dose), isSample, data=all_l2, fct=LL.4(),
# pmodels=data.frame(isSample, isSample,isSample,isSample))
# Sum_u <- summary(unrestr)
# ast <- Sum_u$coefficients[3,1]
# ate <- Sum_u$coefficients[4,1]
# bst <- Sum_u$coefficients[1,1]
# bte <- Sum_u$coefficients[2,1]
# cst <- log(Sum_u$coefficients[7,1])
# cte <- log(Sum_u$coefficients[8,1])
# dst <- Sum_u$coefficients[5,1]
# dte <- Sum_u$coefficients[6,1]
# } else {
# ast <- det_sig[5]
# ate <- det_sig[6]
# bst <- det_sig[1]
# bte <- det_sig[2]
# cst <- det_sig[7]
# cte <- det_sig[8]
# dst <- det_sig[3]
# dte <- det_sig[4]
# }
# REFu <- ast + (dst-ast)/(1+exp(bst*(seq_x-cst)))
# SAMPLEu <- ate + (dte-ate)/(1+exp(bte*(seq_x-cte)))
# pl_df2 <- cbind(seq_x, SAMPLEu, REFu)
# #browser()
# pu <- ggplot(all_l2, aes(x=log_dose, y=readout, color=factor(isRef))) +
# geom_point() +
# labs(title="unrestricted 4_pl-Model", color="product") +
# scale_color_manual(labels = c("test","reference"), values=c("red","blue")) +
# theme_bw()
# pu2 <- pu + geom_line(data=as.data.frame(pl_df2), aes(x=seq_x, y=SAMPLEu),
# color="red", inherit.aes = F) +
# geom_line(data=as.data.frame(pl_df2), aes(x=seq_x, y=REFu),
# color="blue", inherit.aes = F,
# show.legend = F)
# pu2_ <- pu2 +
# theme(legend.position = "none", axis.text = element_text(size=14))
# putrans <- ggplot(all_l2, aes(x=log_dose, y=readouttrans, color=factor(isRef))) +
# geom_point() +
# labs(title="unrestricted transformed 4_pl-Model", color="product") +
# scale_color_manual(labels = c("test","reference"), values=c("red","blue")) +
# theme_bw()
#
# unrestr_trans <- drm(readouttrans ~ exp(log_dose), isSample, data=all_l2, fct=LL.4(),
# pmodels=data.frame(isSample, isSample,isSample,isSample))
# Sum_ut <- summary(unrestr_trans)
# ast_t <- Sum_ut$coefficients[3,1]
# ate_t <- Sum_ut$coefficients[4,1]
# bst_t <- Sum_ut$coefficients[1,1]
# bte_t <- Sum_ut$coefficients[2,1]
# cst_t <- log(Sum_ut$coefficients[7,1])
# cte_t <- log(Sum_ut$coefficients[8,1])
# dst_t <- Sum_ut$coefficients[5,1]
# dte_t <- Sum_ut$coefficients[6,1]
#
# REFu_trans <- ast_t + (dst_t-ast_t)/(1+exp(bst_t*(seq_x-cst_t)))
# SAMPLEu_trans <- ate_t + (dte_t-ate_t)/(1+exp(bte_t*(seq_x-cte_t)))
# pl_df2u_t <- cbind(seq_x, SAMPLEu_trans, REFu_trans)
#
# pu2_t <- putrans + geom_line(data=as.data.frame(pl_df2u_t), aes(x=seq_x, y=SAMPLEu_trans),
# color="red", inherit.aes = F) +
# geom_line(data=as.data.frame(pl_df2u_t), aes(x=seq_x, y=REFu_trans),
# color="blue", inherit.aes = F,
# show.legend = F)
# pu3_t <- pu2_t
# grid.arrange(p2,p_rt2,pu2_,pu3_t, nrow=2)
# }
#
# plot_f(XLdat2, sigmoid=NULL, det_sig=coeffs)
all_l <- melt(data.frame(dat), id.vars="log_dose", variable.name="replname", value.name = "readout")
isRef <- rep(c(1,0),1,each=nrow(all_l)/2)
isSample <- rep(c(0,1),1,each=nrow(all_l)/2)
all_l2 <- cbind(all_l, isRef, isSample)
if(is.null(det_sig)) {
if (CORdat<0) {
startlist <- list(a=sigmoid[3], b=-sigmoid[5],cs=sigmoid[7],
d=sigmoid[1],r=sigmoid[8])
} else {
startlist <- list(a=sigmoid[3],b=sigmoid[5],cs=sigmoid[7],
d=sigmoid[1],r=sigmoid[8])
}
} else {
startlist <- list(a=det_sig[5], b=det_sig[1],cs=det_sig[7],
d=det_sig[3],r=det_sig[7] - det_sig[8])
}
#browser()
tryCatch({
mr <- gsl_nls(fn = readout ~ a+(d-a)/(1+exp(b*(log_dose-(cs-r*isSample)))),
data=all_l2,
start=startlist,
control=gsl_nls_control(xtol=1e-6,ftol=1e-6, gtol=1e-6))
},
error = function(err) {
err$message
})
s_mr <- summary(mr)
a <- s_mr$coefficients[1,1]
b <- s_mr$coefficients[2,1]
cs <- s_mr$coefficients[3,1]
d <- s_mr$coefficients[4,1]
r <- s_mr$coefficients[5,1]
log_dose <- unique(all_l$log_dose)
seq_x <- seq(min(log_dose),max(log_dose),0.1)
SAMPLE <- a+(d-a)/(1+exp(b*(seq_x-(cs-r))))
REF <- a+(d-a)/(1+exp(b*(seq_x-(cs))))
if (is.null(det_sig)) {
SAMPLEtrue <- sigmoid[4] + (sigmoid[2] -sigmoid[4])/(1+exp(sigmoid[6]*(seq_x-(sigmoid[7]-sigmoid[8]))))
REFtrue <- sigmoid[3] + (sigmoid[1] -sigmoid[3])/(1+exp(sigmoid[5]*(seq_x-(sigmoid[7]))))
} else {
SAMPLEtrue <- det_sig[4] + (det_sig[6] -det_sig[4])/(1+exp(-det_sig[2]*(seq_x-(det_sig[8]))))
REFtrue <- det_sig[3] + (det_sig[5] -det_sig[3])/(1+exp(-det_sig[1]*(seq_x-(det_sig[7]))))
}
pl_df <- cbind(seq_x, SAMPLE, REF, SAMPLEtrue, REFtrue)
all_l2$readout[all_l2$readout < 0] <- 0.01
all_l2$readouttrans <- log(all_l2$readout)
slopeEC50 <- b*(a-d)/4
Xbendl3 <- cs-(1.31696/b)
Xbendu3 <- cs+(1.31696/b)
XbendlT <- cs-r-(1.31696/b)
XbenduT <- cs-r+(1.31696/b)
bendpoints <- c(bendREF_lower = round(Xbendl3,3), bendREF_upper=round(Xbendu3,3),
bendSAMPLE_lower = round(XbendlT,3), bendSAMPLE_upper=round(XbenduT,3))
p <- ggplot(all_l2, aes(x=log_dose, y=readout, color=factor(isRef))) +
geom_point(shape=factor(isRef), alpha=0.8) +
labs(title = paste("restricted 4pl; bendp:", round(Xbendl3,3),round(Xbendu3,3),round(XbendlT,3),round(XbenduT,3)),
color="product") +
scale_color_manual(labels=c("test","reference"), values=c("red","blue")) +
scale_shape_manual(labels=c("test","reference")) +
theme_bw() +
theme(axis.text = element_text(size=14))
p2 <- p + geom_line(data=as.data.frame(pl_df), aes(x=seq_x, y=SAMPLE), color="red",
inherit.aes = F) +
geom_line(data=as.data.frame(pl_df), aes(x=seq_x, y=REF), color="blue",
inherit.aes = F) +
geom_line(data=as.data.frame(pl_df), aes(x=seq_x, y=SAMPLEtrue), color="red", linetype=2, alpha=0.4,
inherit.aes = F) +
geom_line(data=as.data.frame(pl_df), aes(x=seq_x, y=REFtrue), color="blue", linetype=2, alpha=0.4,
inherit.aes = F) +
geom_vline(xintercept=c(Xbendl3, Xbendu3), col="blue",linetype=2) +
geom_vline(xintercept=c(XbendlT, XbenduT), col="red",linetype=2) +
annotate("text", x=cs, y=a+(d-a)/2, label="0", size=5) +
theme(legend.position="none")
# transformed plots
p_rt <- ggplot(all_l2, aes(x=log_dose, y=readouttrans, color=factor(isRef))) +
geom_point(shape=factor(isRef), alpha=0.8) +
labs(title = paste("restricted transformed 4pl"), color="product") +
scale_color_manual(labels=c("test","reference"), values=c("red","blue")) +
theme_bw()
mrt <- gsl_nls(fn = readouttrans ~ a+(d-a)/(1+exp(b*(log_dose-(cs-r*isSample)))),
data=all_l2,
start=startlist,
control=gsl_nls_control(xtol=1e-6,ftol=1e-6, gtol=1e-6))
s_mrt <- summary(mrt)
a_trans <- s_mrt$coefficients[1,1]
b_trans <- s_mrt$coefficients[2,1]
cs_trans <- s_mrt$coefficients[3,1]
d_trans <- s_mrt$coefficients[4,1]
r_trans <- s_mrt$coefficients[5,1]
XbendlTrans <- cs_trans-(1.31696/b_trans)
XbenduTrans <- cs_trans+(1.31696/b_trans)
XbendlTransT <- cs_trans-r_trans-(1.31696/b_trans)
XbenduTransT <- cs_trans-r_trans+(1.31696/b_trans)
bendpointsTRANS <- c(bendREF_lower = round(XbendlTrans,3), bendREF_upper=round(XbenduTrans,3),
bendSAMPLE_lower = round(XbendlTransT,3), bendSAMPLE_upper=round(XbenduTransT,3))
SAMPLEtrans <- a_trans+(d_trans-a_trans)/(1+exp(b_trans*(seq_x-(cs_trans-r_trans))))
REFtrans <- a_trans+(d_trans-a_trans)/(1+exp(b_trans*(seq_x-(cs_trans))))
pl_df_trans <- cbind(seq_x, SAMPLEtrans, REFtrans)
p_rt2 <- p_rt + geom_line(data=as.data.frame(pl_df_trans), aes(x=seq_x, y=SAMPLEtrans), color="red",
inherit.aes = F) +
geom_line(data=as.data.frame(pl_df_trans), aes(x=seq_x, y=REFtrans), color="blue",
inherit.aes = F) +
geom_vline(xintercept=c(XbendlTrans, XbenduTrans), col="blue",linetype=2) +
geom_vline(xintercept=c(XbendlTransT, XbenduTransT), col="red",linetype=2) +
theme(legend.position = "none", axis.text=element_text(size=14))
if (is.null(det_sig)) {
unrestr <- drm(readout ~ exp(log_dose), isSample, data=all_l2, fct=LL.4(),
pmodels=data.frame(isSample, isSample,isSample,isSample))
Sum_u <- summary(unrestr)
ast <- Sum_u$coefficients[3,1]
ate <- Sum_u$coefficients[4,1]
bst <- Sum_u$coefficients[1,1]
bte <- Sum_u$coefficients[2,1]
cst <- log(Sum_u$coefficients[7,1])
cte <- log(Sum_u$coefficients[8,1])
dst <- Sum_u$coefficients[5,1]
dte <- Sum_u$coefficients[6,1]
} else {
ast <- det_sig[5]
ate <- det_sig[6]
bst <- det_sig[1]
bte <- det_sig[2]
cst <- det_sig[7]
cte <- det_sig[8]
dst <- det_sig[3]
dte <- det_sig[4]
}
REFu <- ast + (dst-ast)/(1+exp(bst*(seq_x-cst)))
SAMPLEu <- ate + (dte-ate)/(1+exp(bte*(seq_x-cte)))
pl_df2 <- cbind(seq_x, SAMPLEu, REFu)
#browser()
pu <- ggplot(all_l2, aes(x=log_dose, y=readout, color=factor(isRef))) +
geom_point() +
labs(title="unrestricted 4_pl-Model", color="product") +
scale_color_manual(labels = c("test","reference"), values=c("red","blue")) +
theme_bw()
pu2 <- pu + geom_line(data=as.data.frame(pl_df2), aes(x=seq_x, y=SAMPLEu),
color="red", inherit.aes = F) +
geom_line(data=as.data.frame(pl_df2), aes(x=seq_x, y=REFu),
color="blue", inherit.aes = F,
show.legend = F)
pu2_ <- pu2 +
theme(legend.position = "none", axis.text = element_text(size=14))
putrans <- ggplot(all_l2, aes(x=log_dose, y=readouttrans, color=factor(isRef))) +
geom_point() +
labs(title="unrestricted transformed 4_pl-Model", color="product") +
scale_color_manual(labels = c("test","reference"), values=c("red","blue")) +
theme_bw()
unrestr_trans <- drm(readouttrans ~ exp(log_dose), isSample, data=all_l2, fct=LL.4(),
pmodels=data.frame(isSample, isSample,isSample,isSample))
Sum_ut <- summary(unrestr_trans)
ast_t <- Sum_ut$coefficients[3,1]
ate_t <- Sum_ut$coefficients[4,1]
bst_t <- Sum_ut$coefficients[1,1]
bte_t <- Sum_ut$coefficients[2,1]
cst_t <- log(Sum_ut$coefficients[7,1])
cte_t <- log(Sum_ut$coefficients[8,1])
dst_t <- Sum_ut$coefficients[5,1]
dte_t <- Sum_ut$coefficients[6,1]
REFu_trans <- ast_t + (dst_t-ast_t)/(1+exp(bst_t*(seq_x-cst_t)))
SAMPLEu_trans <- ate_t + (dte_t-ate_t)/(1+exp(bte_t*(seq_x-cte_t)))
pl_df2u_t <- cbind(seq_x, SAMPLEu_trans, REFu_trans)
pu2_t <- putrans + geom_line(data=as.data.frame(pl_df2u_t), aes(x=seq_x, y=SAMPLEu_trans),
color="red", inherit.aes = F) +
geom_line(data=as.data.frame(pl_df2u_t), aes(x=seq_x, y=REFu_trans),
color="blue", inherit.aes = F,
show.legend = F)
pu3_t <- pu2_t
grid.arrange(p2,p_rt2,pu2_,pu3_t, nrow=2)
}
plot_f(XLdat2, sigmoid=NULL, det_sig=coeffs)
```