Guxa/dashboard-app
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cleanup and bugfix; linearity report made work

Browse Source
This commit is contained in:
Franz Innerbichler
2026-05-15 22:11:20 +02:00
parent 9422490f25
commit ec13d95387
4 changed files with 249 additions and 379 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Doc_BioassayLinReport.Rmd
+81 -298
View File
@@ -17,17 +17,18 @@ params:
FileName: NA FileName: NA
newTitle: NA newTitle: NA
author: NA author: NA
REPLin: NA REP: NA
REPlin: NA
coeffsLin: NA coeffsLin: NA
author: "Author: `r params$author`" author: "Author: `r params$author`"
title: | title: |
| ![](logo.png){width=1in} | ![](logo.png){width=1in}
| 4PL bioassay evaluation | Linear bioassay evaluation
subtitle: | subtitle: |
`r params$FileName` `r params$FileName`
<left> Unique time: </left> <right> `r Sys.time()`</right> <left> Unique time: </left> <right> `r Sys.time()`</right>
date: "`r paste(params$Subway, params$Version)`" date: "`r paste(params$NoP, params$Assay)`"
--- ---
@@ -44,25 +45,21 @@ library(knitr)
library(DT) library(DT)
REP <- params$REP REP <- params$REP
REPLin <- params$REPLin REPlin <- params$REPlin
author <- params$author author <- params$author
coeffsLin <- params$coeffsLin coeffsLin <- params$coeffsLin
all_l <- REP$all_l all_l <- REP$all_l
circles <- REPlin$circles
ANOVAXLS <- REP$ANOVAXLS ANOVAXLS <- REP$ANOVAXLS
DiagnTable <- REP$DiagnTable SuModAB <- REPlin$SuModAB
UnRPLAausw <- REP$UnRPLAausw SuModABu <- REPlin$SuModABu
UnRPLBend <- REP$UnRPLBend LinTests <- REPlin$LinTests
PLAausw <- REP$PLAausw XLplotLin <- REPlin$pLin
PLBend <- REP$PLBend LinPotTab <- REPlin$LinPotTab
LogPLAausw <- REP$LogPLAausw
LogUnrPLAausw <- REP$LogUnrPLAausw
XLdat2 <- REP$XLdat2 XLdat2 <- REP$XLdat2
CIplot <- REP$CIplot
testsTab <- REP$testsTab
relpotTestPlot <- REP$relpotTestPlot
@@ -74,220 +71,71 @@ relpotTestPlot <- REP$relpotTestPlot
Bioassay potency estimation uses statistical methods to quantify the strength of a biological product or drug by comparing its response to that of a reference standard. Because biological responses are inherently variable, affected by assay conditions, cell systems or organisms, and measurement noise, the 4-parametric logistic regression is used to obtain reliable potency values. The variance for confidence interval calculation is coming from the regression procedure itself and is an excellent predictor for the variability of any future potency determinations. Bioassay potency estimation uses statistical methods to quantify the strength of a biological product or drug by comparing its response to that of a reference standard. Because biological responses are inherently variable, affected by assay conditions, cell systems or organisms, and measurement noise, the 4-parametric logistic regression is used to obtain reliable potency values. The variance for confidence interval calculation is coming from the regression procedure itself and is an excellent predictor for the variability of any future potency determinations.
USP<1034> recommends calculation of standard errors of ratios of the parameters using Fieller's theorem [Finney D.J. 1978] or using the "delta" method (for a discussion about the "delta" method see [Ver Hoef 2012]). However, the presented gradient approach using the differences on the log-scale is methematically more stable und thus preferable compared to any ratio approach ([Franz, V.H. 2007]). USP<1034> recommends calculation of standard errors of ratios of the parameters using Fieller's theorem [Finney D.J. 1978] or using the "delta" method (for a discussion about the "delta" method see [Ver Hoef 2012]). However, the presented gradient approach using the differences on the log-scale is methematically more stable und thus preferable compared to any ratio approach ([Franz, V.H. 2007]).
# Raw data
All data used for evaluation is shown in table 1.
```{r Alll, echo=FALSE, warning=FALSE, results='asis'}
kable(XLdat2, format = "markdown", caption= "Uploaded data (test and reference) ", digits=3)
```
All data used linerar regression is shown in table 2.
```{r Circles, echo=FALSE, warning=FALSE, results='asis'}
kable(circles, format = "markdown", caption= "Concentrations and readout used for linear regression", digits=3, row.names = F)
```
# Results # Results
All data used for the 4PL evaluation is shown in table 1: ## Overall result
```{r alll, echo=FALSE, warning=FALSE, results='asis'} ```{r Over_all, echo=FALSE, comment=NA, warning=NA, message=NA}
#browser()
potFlag <- 0
if (LinPotTab[1,"test_result"]==1) potFlag <- 1
AnalysisFlag <- FALSE
if (potFlag==1 | sum(LinTests$test_results)>0) AnalysisFlag <- TRUE
colFmt <- function() {
outputFormat <- knitr::opts_knit$get("rmarkdown.pandoc.to")
if(AnalysisFlag) {
text <- paste("\\textcolor{red}{Analysis failed}",sep="")
} else {
text <- paste("\\textcolor{black}{Analysis succeeded}",sep="")
}
return(text)
}
kable(all_l, format = "markdown", caption= "Uploaded data (test and reference) in long format", digits=3)
``` ```
The following 4 plots show all 4 models: restricted and unrestricted, and log transformed, respectively. `r colFmt()`
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'} ## Plots and ANOVA
# plot_f <- function(dat, sigmoid,det_sig) { Plots in Figure 1 show the restricted and unrestricted model, respectively.
# CORdat <- cor(dat[,1],dat[,ncol(dat)])
# ```{r LinPlot, echo=FALSE, warning=FALSE, fig.height=4, fig.width=6, fig.cap="Plot of models", fig.align='left'}
# 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) library(cowplot)
# isSample <- rep(c(0,1),1,each=nrow(all_l)/2)
# all_l2 <- cbind(all_l, isRef, isSample)
# plot_grid(XLplotLin)
# 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)
``` ```
The ANOVA of the unconstrained model is listed in table 2: The ANOVA of the unconstrained model is listed in table 3.
```{r anovaxls, echo=FALSE, warning=FALSE, results='asis'} ```{r anovaxls, echo=FALSE, warning=FALSE, results='asis'}
@@ -296,130 +144,65 @@ kable(ANOVAXLS, format = "markdown", caption= "ANOVA table unrestricted", digits
``` ```
The assay suitability tests are shown in table 4.
```{r SST_ergebn, fig.align='center', fig.pos='htb!', echo=FALSE, cache=FALSE, warning=FALSE, message=FALSE, tidy=TRUE}
kable(testsTab[1:7,], row.names = F, format = "markdown", caption="SST results") ```{r SST_ergebn, echo=FALSE, cache=FALSE, warning=FALSE, message=FALSE, tidy=TRUE}
kable(LinTests, row.names = F, format = "markdown", caption="Assay suitability test results", digits=3)
``` ```
*...The estimate for F-test on regression and on non-linearity is the p-value The estimate is the p-value of the test.
F-test on regression passes if F-value > F-crit and thus p < 0.05 F-tests on regression, significance of slopes, and preparation need to have a p-value <0.05 to pass.
F-test on non-linearity passes if F-value < F-crit and thus p > 0.05 All other tests pass if p-value > 0.05.
Test results outcome:
0 ... test passed (for EQ tests: CI within limits); 0 ... test passed (for EQ tests: CI within limits);
1 ... test failed (for EQ tests CI not within limits); 1 ... test failed (for EQ tests CI not within limits);
-1 ... calculations unbound/denominator too close to 0
<!-- ```{r, label= 'CIplot', echo=FALSE, warning=FALSE, fig.width=100, fig.cap='Selected SSt confidence intervals with entered limits', fig.align='center'} --> ## Fitting results
<!-- png("CIplot.png") --> The results of the linear fitting procedure for the restricted model is listed in table 5:
<!-- print(CIplot) -->
<!-- dev.off() -->
```{r SumCSSI, echo=FALSE, warning=FALSE, results='asis'}
<!-- ``` --> kable(SuModAB, format = "markdown", caption= "Restricted linear regression (CSSI)", digits=3, row.names = F)
<!-- ![](CIplot.png){width=60%} -->
## Fitting results of the 4 models with bend points
The results of the non-linear fitting procedure for the restricted model (5 parameters) is listed in table 4:
```{r PLAausw, echo=FALSE, warning=FALSE, results='asis'}
kable(PLAausw, format = "markdown", caption= "Restricted 4PL evaluation", digits=3, row.names = F)
``` ```
CSSI: common slope, separate intercept
A depiction of the CI and corresponding limits of relative potency is shown here: The results of the linear fitting procedure for the unrestricted model is listed in table 6.
```{r, label='relpotPlot', echo=FALSE, warning=FALSE, fig.height=2, fig.width=3.5, fig.cap="Rel potency with CIs and limits", fig.align='left', results='asis'} ```{r SuSSSI, echo=FALSE, warning=FALSE, results='asis'}
print(relpotTestPlot) kable(SuModABu, format = "markdown", caption= "Restricted linear regression (SSSI)", digits=3, row.names = F)
``` ```
SSSI: separate slope, separate intercept
The bend points for test and reference sample are in table 5:
```{r PLBend, echo=FALSE, warning=FALSE, results='asis'}
kable(PLBend, format = "markdown", caption= "Bendpoints (Sebaugh) of restricted 4PL", digits=3)
```
The results of the non-linear fitting procedure for the unrestricted model (8 parameters) is listed in table 6:
```{r UnRPLAausw, echo=FALSE, warning=FALSE, results='asis'}
kable(UnRPLAausw, format = "markdown", caption= "UNrestricted 4PL evaluation", digits=3, row.names = F)
```
```{r UnRPLBend, echo=FALSE, warning=FALSE, results='asis'}
kable(UnRPLBend, format = "markdown", caption= "Bend points of 4PL unrestricted", digits=3, row.names = F)
```
```{r LogPLAausw, echo=FALSE, warning=FALSE, results='asis'}
kable(LogPLAausw, format = "markdown", caption= "Restricted 4PL evaluation with log-transformed response", digits=3)
```
```{r LogUnRPLAausw, echo=FALSE, warning=FALSE, results='asis'}
kable(LogUnrPLAausw, format = "markdown", caption= "Unrestricted 4PL evaluation with log-transformed response", digits=3)
```
# Appendix: Formulas # Appendix: Formulas
## 4PL regression ## Potency of linear PLA
$$ $$
Y = D + \frac{A-D} {1+(\frac{C} {x})^B } + \epsilon rel Potency = \frac{I_{ref} - I_{test}{k}
$$ $$
where: I... intercept of reference or test
k ... common slope
## log-logistic 4P regression
$$
Y = D + \frac{A-D} {1+e^{(B*(C - log(x))) }} + \epsilon
$$
where: x ... concentration of the analyte
A: upper asymptote
B: slope
D: lower asymptote
C ... EC50
# Literature # Literature
Doc_BioassayReport.Rmd
+59 -37
View File
@@ -15,19 +15,20 @@ header_includes:
-\rhead{\includegraphics[width=.15\textwidth]{`r getwd()`/logo.png}} -\rhead{\includegraphics[width=.15\textwidth]{`r getwd()`/logo.png}}
params: params:
FileName: NA FileName: NA
newTitle: NA
author: NA author: NA
NoP: NA
Assay: NA
REP: NA REP: NA
coeffs: NA coeffs: NA
author: "Author: `r params$author`" author: "Author: `r params$author`"
title: | title: |
| ![](logo.png){width=1in} | ![](logo.png){width=2in}
| 4PL bioassay evaluation | 4PL bioassay evaluation
subtitle: | subtitle: |
`r params$FileName` `r params$FileName`
<left> Unique time: </left> <right> `r Sys.time()`</right> <left> Unique time: </left> <right> `r Sys.time()`</right>
date: "`r paste(params$Subway, params$Version)`" date: "`r paste(params$NoP, params$Assay)`"
--- ---
@@ -55,17 +56,17 @@ DiagnTable <- REP$DiagnTable
UnRPLAausw <- REP$UnRPLAausw UnRPLAausw <- REP$UnRPLAausw
UnRPLBend <- REP$UnRPLBend UnRPLBend <- REP$UnRPLBend
PLAausw <- REP$PLAausw PLAausw <- REP$PLAausw
PLBend <- REP$PLBend PLbend <- REP$PLBend
pottab4plXL <- REP$pottab4plXL pottab4plXL <- REP$pottab4plXL
Lim <- REP$Lim Lim <- REP$Lim
XLdat2 <- REP$XLdat2 XLdat2 <- REP$XLdat2
PureErr <- REP$PureErr
CIplot <- REP$CIplot CIplot <- REP$CIplot
testsTab <- REP$testsTab testsTab <- REP$testsTab
relpotTestPlot <- REP$relpotTestPlot relpotTestPlot <- REP$relpotTestPlot
#browser()
``` ```
@@ -103,7 +104,7 @@ colFmt <- function() {
if(AnalysisFlag) { if(AnalysisFlag) {
text <- paste("\\textcolor{red}{Analysis failed}",sep="") text <- paste("\\textcolor{red}{Analysis failed}",sep="")
} else { } else {
text <- paste("\\textcolor{black}{Analysis succeeded}>",sep="") text <- paste("\\textcolor{black}{Analysis succeeded}",sep="")
} }
return(text) return(text)
} }
@@ -116,12 +117,14 @@ colFmt <- function() {
## 4pl-regression ## 4pl-regression
Relative potency (absolute and relative confidence limits) are shown in Table 2: Relative potency (absolute and relative confidence limits) are shown in Table 2. `r if(PureErr) {"Pure Error is used for calculations."}`
`r if (!PureErr) {"RMSE of restricted model is used for confidence limit calculation."}`
```{r Pot_tab4pl, echo=FALSE, comment=NA, warning=NA, message=NA} ```{r Pot_tab4pl, echo=FALSE, comment=NA, warning=NA, message=NA}
#browser() #browser()
if (pottab4plXL["test_result"][[1]][1]==1) { cat(paste("FAILED: relative potency CL result of restricted model outside limits: ", Lim[[9]], "and" ,Lim[[10]] ))} if (pottab4plXL["test_result"][[1]][1]==1) { cat(paste("FAILED: relative potency CL result of restricted model outside limits: ", Lim[[9]], "to" ,Lim[[10]] ))}
if (pottab4plXL["test_result"][[1]][1]==0) { cat(paste("PASSED: relative potency CL result of restricted model within limits: ", Lim[[9]], "to" ,Lim[[10]] ))}
kable(pottab4plXL, format = "markdown", caption= "Relative potency with absolute and relative CLs ", digits=3, row.names = F) %>% kable(pottab4plXL, format = "markdown", caption= "Relative potency with absolute and relative CLs ", digits=3, row.names = F) %>%
kable_styling(latex_options = "hold_position") kable_styling(latex_options = "hold_position")
@@ -129,9 +132,10 @@ kable(pottab4plXL, format = "markdown", caption= "Relative potency with absolute
``` ```
## Plot of the data and models ## Plot of the data and models
The following plots show the restricted and unrestricted model, respectively. Plots in Figure 1 show the restricted and unrestricted model, respectively.
```{r XLplot, echo=FALSE, warning=FALSE, fig.height=4, fig.width=6, fig.cap="Plot of models", fig.align='left', comment=F, message=F, results='asis', fig.pos='H'} ```{r XLplot, echo=FALSE, warning=FALSE, fig.height=4, fig.width=6, fig.cap="Plot of models", fig.align='left', comment=F, message=F, results='asis', fig.pos='H'}
@@ -147,24 +151,24 @@ plot_grid(XLplot4pl)
## ANOVA table ## ANOVA table
The ANOVA of the unconstrained model is listed in table 2: The ANOVA of the unconstrained model is listed in table 3. Bates and Watts proposed a test on parallelism which compares the residual sum of squares of the restricted model (ResRSSE) with the residual sum of squares of the unrestricted model (UnresRSSE). If the UnresRSSE is significantly smaller than the ResRSSE, the p-value of "Non-parallelism" is smaller than 0.05 (line 4 in table 3). This test is for information only as it may be overly sensitive in case of small overall variability of the data.
```{r anovaxls, echo=FALSE, warning=FALSE, results='asis'} ```{r anovaxls, echo=FALSE, warning=FALSE, results='asis'}
kable(ANOVAXLS, format = "markdown", caption= "ANOVA table unrestricted", digits=3) %>% kable(ANOVAXLS, format = "markdown", caption= "Analysis of variance", digits=3) %>%
kable_styling(latex_options = "hold_position") kable_styling(latex_options = "hold_position")
``` ```
## Analysis suitability tests ## Assay suitability tests
The following table lists the chosen suitabilit test results with confidence limits, where applicable: Table 4 lists the chosen suitability test results with confidence limits, where applicable. F-tests should be read with caution, if the overall variability is small, as the test gets overly sensitive.
```{r SST_ergebn, echo=FALSE, cache=FALSE, warning=FALSE, message=FALSE, tidy=TRUE} ```{r SST_ergebn, echo=FALSE, cache=FALSE, warning=FALSE, message=FALSE, tidy=TRUE}
kable(testsTab, row.names = F, format = "markdown", caption="SST results") kable(testsTab, row.names = F, format = "markdown", caption="Assay suitability results", digits=4)
``` ```
@@ -196,9 +200,9 @@ colFmt2 <- function() {
outputFormat <- knitr::opts_knit$get("rmarkdown.pandoc.to") outputFormat <- knitr::opts_knit$get("rmarkdown.pandoc.to")
if(TestsTabFlag) { if(TestsTabFlag) {
text <- paste("\\textcolor{red}{Analysis suitability tests failed}",sep="") text <- paste("\\textcolor{red}{Assay suitability tests failed}",sep="")
} else { } else {
text <- paste("\\textcolor{black}{Analysis suitability tests succeeded}",sep="") text <- paste("\\textcolor{black}{Assay suitability tests succeeded}",sep="")
} }
return(text) return(text)
} }
@@ -212,33 +216,33 @@ colFmt2 <- function() {
## Fitting results of the 4 models with bend points ## Fitting results with curve points
The results of the non-linear fitting procedure for the restricted model (5 parameters) is listed in table 4: The results of the non-linear fitting procedure for the restricted model (5 parameters) is listed in table 5:
```{r PLAausw, echo=FALSE, warning=FALSE, results='asis'} ```{r PLAausw, echo=FALSE, warning=FALSE, results='asis'}
kable(PLAausw, format = "markdown", caption= "Restricted 4PL evaluation", digits=3, row.names = F) kable(PLAausw, format = "markdown", caption= "Restricted 4PL model", digits=3, row.names = F)
``` ```
A depiction of the CI and corresponding limits of relative potency is shown here: <!-- A depiction of the CI and corresponding limits of relative potency is shown here: -->
```{r, label='relpotPlot', echo=FALSE, warning=FALSE, fig.height=2, fig.width=3.5, fig.cap="Rel potency with CIs and limits", fig.align='left', results='asis'} <!-- ```{r, label='relpotPlot', echo=FALSE, warning=FALSE, fig.height=2, fig.width=3.5, fig.cap="Rel potency with CIs and limits", fig.align='left', results='asis'} -->
print(relpotTestPlot) <!-- print(relpotTestPlot) -->
``` <!-- ``` -->
The bend points for test and reference sample are in table 5: Sebaugh et al proposed bend points for test and reference samples, that define the points with highest turning behavior. Table 6 lists these bendpoints as well as asymptote points ~ twice as far from the center as the bendpoints.
```{r PLBend, echo=FALSE, warning=FALSE, results='asis'} ```{r PLBend, echo=FALSE, warning=FALSE, results='asis'}
kable(PLBend, format = "markdown", caption= "Bendpoints (Sebaugh) of restricted 4PL", digits=3) kable(PLbend, format = "markdown", caption= "Bendpoints and asymptote points of restricted 4PL model", digits=3)
``` ```
@@ -247,17 +251,17 @@ The results of the non-linear fitting procedure for the unrestricted model (8 pa
```{r UnRPLAausw, echo=FALSE, warning=FALSE, results='asis'} ```{r UnRPLAausw, echo=FALSE, warning=FALSE, results='asis'}
kable(UnRPLAausw, format = "markdown", caption= "UNrestricted 4PL evaluation", digits=3, row.names = F) kable(UnRPLAausw, format = "markdown", caption= "Unrestricted 4PL model", digits=3, row.names = F)
``` ```
```{r UnRPLBend, echo=FALSE, warning=FALSE, results='asis'} <!-- ```{r UnRPLBend, echo=FALSE, warning=FALSE, results='asis'} -->
kable(UnRPLBend, format = "markdown", caption= "Bend points of 4PL unrestricted", digits=3, row.names = F) <!-- kable(UnRPLBend, format = "markdown", caption= "Bend points of 4PL unrestricted", digits=3, row.names = F) -->
``` <!-- ``` -->
@@ -269,13 +273,6 @@ $$
Y = D + \frac{A-D} {1+(\frac{C} {x})^B } + \epsilon Y = D + \frac{A-D} {1+(\frac{C} {x})^B } + \epsilon
$$ $$
## log-logistic 4P regression
$$
Y = D + \frac{A-D} {1+e^{(B*(C - log(x))) }} + \epsilon
$$
where: x ... concentration of the analyte where: x ... concentration of the analyte
A: upper asymptote A: upper asymptote
@@ -286,6 +283,29 @@ D: lower asymptote
C ... EC50 C ... EC50
## log-logistic 4P regression
$$
Y = D + \frac{A-D} {1+e^{(B*(C - log(x))) }} + \epsilon
$$
## Intercept for slope at EC50
$$
I = A+\frac{D-A}{2}-B_{true}*EC50
$$
## Slope at EC50
$$
B_{true}=B*\frac{D-A}{4}
$$
# Literature # Literature
Finney, D.J.: (1978) Statistical Method in Biological Assay, London: Charles Griffin House, 3rd edition (pp. 80-82) Finney, D.J.: (1978) Statistical Method in Biological Assay, London: Charles Griffin House, 3rd edition (pp. 80-82)
@@ -294,6 +314,8 @@ Franz, V.H.: Ratios: A short guide to confidence limits and proper use. arXiv:07
VerHoef, J.M.: Who invented the Delta Method? The American Statistician, 2012, 66:2, 124-127 DOI: 10.1080/00031305.2012.687494 VerHoef, J.M.: Who invented the Delta Method? The American Statistician, 2012, 66:2, 124-127 DOI: 10.1080/00031305.2012.687494
Bates, D.M., Watts, D.G. (1988). Comparing models. In: Nonlinear Regression Analysis and Its Applications. New York: Wiley, pp 103-108
Global.R
+12 -7
View File
@@ -2,6 +2,7 @@
Dat <- reactiveValues() Dat <- reactiveValues()
REP <- reactiveValues() REP <- reactiveValues()
REPlin <- reactiveValues()
#' Levenberg Marquard fit of 4 pl #' Levenberg Marquard fit of 4 pl
#' #'
@@ -188,11 +189,13 @@ plot_f <- function(dat, TransFlag=F) { #sigmoid,det_sig,
#browser() #browser()
p <- ggplot(all_l2, aes(x=log_dose, y=readout, color=factor(isRef))) + p <- ggplot(all_l2, aes(x=log_dose, y=readout, color=factor(isRef))) +
geom_point(shape=factor(isRef), size=3,alpha=0.8) + geom_point(shape=factor(isRef), size=3,alpha=0.8) +
labs(title = paste("restricted 4pl"), labs(title = paste("restricted 4pl model"),
color="product") + color="product") +
scale_color_manual(labels=c("test","reference"), values=c("#C2173F","#4545BA")) + scale_color_manual(labels=c("test","reference"), values=c("#C2173F","#4545BA")) +
scale_shape_manual(labels=c("test","reference")) + scale_shape_manual(labels=c("test","reference")) +
theme_bw() + scale_x_continuous(breaks = scales::pretty_breaks(n = 10)) +
scale_y_continuous(breaks = scales::pretty_breaks(n = 10)) +
#theme_bw() +
theme(axis.text = element_text(size=14)) theme(axis.text = element_text(size=14))
p2 <- p + geom_line(data=as.data.frame(pl_df), aes(x=seq_x, y=SAMPLE), color="#C2173F", p2 <- p + geom_line(data=as.data.frame(pl_df), aes(x=seq_x, y=SAMPLE), color="#C2173F",
@@ -205,8 +208,8 @@ plot_f <- function(dat, TransFlag=F) { #sigmoid,det_sig,
inherit.aes = F) + inherit.aes = F) +
geom_vline(xintercept=c(Xbendl3, Xbendu3), col="#4545BA",linetype=2) + geom_vline(xintercept=c(Xbendl3, Xbendu3), col="#4545BA",linetype=2) +
geom_vline(xintercept=c(XbendlT, XbenduT), col="#C2173F",linetype=2) + geom_vline(xintercept=c(XbendlT, XbenduT), col="#C2173F",linetype=2) +
geom_vline(xintercept=c( XasymplS, XasympuS), col="#4545BA55",linetype=2) + geom_vline(xintercept=c( XasymplS, XasympuS), col="#4545BABB",linetype=3) +
geom_vline(xintercept=c(XasymplT, XasympuT), col="#C2173F55",linetype=2) + geom_vline(xintercept=c(XasymplT, XasympuT), col="#C2173FBB",linetype=3) +
annotate("text", x=cs, y=a+(d-a)/2, label="0", size=5) + annotate("text", x=cs, y=a+(d-a)/2, label="0", size=5) +
geom_abline(slope = slopeEC50, intercept = Intercept) + geom_abline(slope = slopeEC50, intercept = Intercept) +
theme(legend.position="none") theme(legend.position="none")
@@ -274,7 +277,7 @@ plot_f <- function(dat, TransFlag=F) { #sigmoid,det_sig,
#browser() #browser()
pu <- ggplot(all_l2, aes(x=log_dose, y=readout, color=factor(isRef))) + pu <- ggplot(all_l2, aes(x=log_dose, y=readout, color=factor(isRef))) +
geom_point(size=3) + geom_point(size=3) +
labs(title="unrestricted 4_pl-Model", color="product") + labs(title="unrestricted 4pl model", color="product") +
scale_color_manual(labels = c("test","reference"), values=c("#C2173F88","#4545BA88")) + scale_color_manual(labels = c("test","reference"), values=c("#C2173F88","#4545BA88")) +
theme_bw() theme_bw()
pu2 <- pu + geom_line(data=as.data.frame(pl_df2), aes(x=seq_x, y=SAMPLEu), pu2 <- pu + geom_line(data=as.data.frame(pl_df2), aes(x=seq_x, y=SAMPLEu),
@@ -687,6 +690,8 @@ PlotLinPLA_FUNC <-function(circle, sigmoid, all_l2, pl_df, indS, indT) {
#labs(title=paste("linear regression model", indS,indT), color="product") + #labs(title=paste("linear regression model", indS,indT), color="product") +
scale_colour_manual(labels = c("test","reference"), values=c("#C2173F","#4545BA")) + scale_colour_manual(labels = c("test","reference"), values=c("#C2173F","#4545BA")) +
ylim(min(all_l2$readout),max(all_l2$readout)) + ylim(min(all_l2$readout),max(all_l2$readout)) +
scale_x_continuous(breaks = scales::pretty_breaks(n = 10)) +
scale_y_continuous(breaks = scales::pretty_breaks(n = 10)) +
theme_bw() theme_bw()
p2 <- p + geom_line(data=pl_df,aes(x=lnC,y=plotS),color="#4545BA", p2 <- p + geom_line(data=pl_df,aes(x=lnC,y=plotS),color="#4545BA",
inherit.aes = F) + inherit.aes = F) +
@@ -699,7 +704,7 @@ PlotLinPLA_FUNC <-function(circle, sigmoid, all_l2, pl_df, indS, indT) {
labs(title = paste("unrestricted PLA model"), subtitle = paste("Regression starts for reference sample:",indS, "for test sample:",indT)) + labs(title = paste("unrestricted PLA model"), subtitle = paste("Regression starts for reference sample:",indS, "for test sample:",indT)) +
theme(legend.position="none", axis.text = element_text(size=14)) theme(legend.position="none", axis.text = element_text(size=14))
p3 <- p2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef), p3 <- p2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
size=5,alpha=0.2), inherit.aes = FALSE) + size=5,alpha=0.2), col=c("black"), inherit.aes = FALSE) +
scale_shape_manual(labels=c("test","reference"), values=c(21,21)) scale_shape_manual(labels=c("test","reference"), values=c(21,21))
# fit intercept for test and ref and common slope # fit intercept for test and ref and common slope
@@ -720,7 +725,7 @@ PlotLinPLA_FUNC <-function(circle, sigmoid, all_l2, pl_df, indS, indT) {
subtitle = paste("Regression on highlighted points")) + subtitle = paste("Regression on highlighted points")) +
theme(legend.position="none", axis.text = element_text(size=14)) theme(legend.position="none", axis.text = element_text(size=14))
pr3 <- pr2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef), pr3 <- pr2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
size=5, alpha=0.2), col=c("#1FE8B2"), stroke=2, inherit.aes = FALSE) + size=5, alpha=0.2), col=c("black"), inherit.aes = FALSE) +
scale_shape_manual(labels=c("test","reference"), values=c(21,21)) scale_shape_manual(labels=c("test","reference"), values=c(21,21))
return(grid.arrange(p3,pr3,nrow=1)) return(grid.arrange(p3,pr3,nrow=1))
} }
app.R
+94 -34
View File
@@ -18,11 +18,13 @@ library(drc)
library(twopartm) library(twopartm)
library(car) library(car)
library(dplyr) library(dplyr)
library(scales)
#### reactive values ---- #### reactive values ----
Dat <- reactiveValues() Dat <- reactiveValues()
REP <- reactiveValues() REP <- reactiveValues()
REPlin <- reactiveValues()
source("Global.R") source("Global.R")
@@ -142,7 +144,7 @@ server <- function(input, output, session) {
"EQ-test on ratio of lower asymptote"= "3","EQ-test on ratio of Hill slopes"= "4", "EQ-test on ratio of lower asymptote"= "3","EQ-test on ratio of Hill slopes"= "4",
"EQ-test on ratio of upper asymptote"= "5", "F-test on non-linearity"="6", "EQ-test on ratio of upper asymptote"= "5", "F-test on non-linearity"="6",
"EQ-test on ratio of asymptote differences"= "7"), "EQ-test on ratio of asymptote differences"= "7"),
selected= c("1","2","3","4","5","6","7")), selected= c("1","4","5","6","7")),
h4("Suitability tests for Parallel Line Assay"), h4("Suitability tests for Parallel Line Assay"),
checkboxGroupInput("selectedSSTsLinear", "Which suitability tests to be used?", checkboxGroupInput("selectedSSTsLinear", "Which suitability tests to be used?",
choices= c("F-test on Regr."="1", choices= c("F-test on Regr."="1",
@@ -177,6 +179,8 @@ server <- function(input, output, session) {
), ),
column(8, column(8,
plotOutput("XLplot"), plotOutput("XLplot"),
"Footnote: bendpoints (linear part) and asymptote points (point where asymptote is reached) are plotted in dashed and dotted lines. They indicate whether the linear part and asymptotes are catched with the current dilutions.",
"Black line is the true slope at EC50 of REF.",
DTOutput("pottab4plXL"), DTOutput("pottab4plXL"),
plotOutput("diagnplot"), plotOutput("diagnplot"),
DTOutput("EQtests"), DTOutput("EQtests"),
@@ -192,14 +196,14 @@ server <- function(input, output, session) {
width=2, width=2,
fluidRow( fluidRow(
column(12, column(12,
numericInput("Limits",p("limit to be >", bsButton("q4",label="", icon=icon("info"), style="primary", size="extra-small")), numericInput("EACLinlow","Potency CL to be > than",value=80),
bsPopover(id="q4", title="", content="The calculated limits ...")), numericInput("EACLinupp","Potency CL to be < than", value=125)
) )
)), )),
mainPanel( mainPanel(
tabsetPanel(id="tabs", tabsetPanel(id="tabs",
tabPanel("linear PLA", tabPanel("Plot and models",
column(12, column(12,
htmlOutput("PureErrWLinXL"), htmlOutput("PureErrWLinXL"),
tags$head(tags$style("#PureErrWLinXL{color: red; tags$head(tags$style("#PureErrWLinXL{color: red;
@@ -212,8 +216,11 @@ server <- function(input, output, session) {
tableOutput("SummaryModABu"), tableOutput("SummaryModABu"),
h4("Restricted linear model (CSSI):"), h4("Restricted linear model (CSSI):"),
tableOutput("SummaryModAB"), tableOutput("SummaryModAB"),
)),
tabPanel("Tests and ANOVAA",
column(12,
h3("Tests for linear PLA):"), h3("Tests for linear PLA:"),
box(title="Suitability tests", status="primary",solidHeader = T, width=12, box(title="Suitability tests", status="primary",solidHeader = T, width=12,
DTOutput("TESTSlin")), DTOutput("TESTSlin")),
h5("The estimate is the p-value of the test"), h5("The estimate is the p-value of the test"),
@@ -225,10 +232,11 @@ server <- function(input, output, session) {
h3("ANOVA for parallel line assay"), h3("ANOVA for parallel line assay"),
DTOutput("ANOVAlin")) DTOutput("ANOVAlin"))
), ),
tabPanel("Report", # tabPanel("Report",
h4("Settings for report"), # h4("Settings for report"),
#
)) # )
)
) )
) )
), ),
@@ -260,6 +268,10 @@ server <- function(input, output, session) {
tags$style(type="text/css","#downloadXLReport {background-color: orange; color: black;font-family: Courier New}"), tags$style(type="text/css","#downloadXLReport {background-color: orange; color: black;font-family: Courier New}"),
downloadButton("downloadXLReportLin", label="Download linear PLA PDF report", class="butt"), downloadButton("downloadXLReportLin", label="Download linear PLA PDF report", class="butt"),
tags$style(type="text/css","#downloadXLReportLin {background-color: #4FCBD9; color: black;font-family: Courier New}"), tags$style(type="text/css","#downloadXLReportLin {background-color: #4FCBD9; color: black;font-family: Courier New}"),
textInput("Author", "Author", value=""),
textInput("RepIdentifier", "Report name", value=""),
textInput("NoP","Product name", value=""),
textInput("Assay", "Assay name",value="")
) )
) )
) )
@@ -476,7 +488,7 @@ server <- function(input, output, session) {
column(4, column(4,
h3("Confidence intervals"), h3("Confidence intervals"),
tableOutput("CIs"), tableOutput("CIs"),
"The confidence intrval table is interaactive for changes in: variability slider (%SD), potency of test-slider, "The confidence interval table is interaactive for changes in: variability slider (%SD), potency of test-slider,
and 'Adjust the dilutions'-slider", and 'Adjust the dilutions'-slider",
tableOutput("optimalDils"), tableOutput("optimalDils"),
selectInput(inputId="scenario", label= "Select an 'optimal' scenario:", choices = c("scenario 2","scenario 3","scenario 6","steep slope"))), selectInput(inputId="scenario", label= "Select an 'optimal' scenario:", choices = c("scenario 2","scenario 3","scenario 6","steep slope"))),
@@ -563,6 +575,12 @@ server <- function(input, output, session) {
if (input$sheet != "please choose") { if (input$sheet != "please choose") {
#browser() #browser()
Dat$RepIdentifier <- input$RepIdentifier
Dat$Author <- input$Author
Dat$NoP <- input$NoP
Dat$Assay <- input$Assay
XLdat <- Dat$wb[input$sheet][[1]] XLdat <- Dat$wb[input$sheet][[1]]
if (is.null(XLdat)) XLdat <- Dat$wb[Dat$sheets[1]][[1]] if (is.null(XLdat)) XLdat <- Dat$wb[Dat$sheets[1]][[1]]
cn <- colnames(XLdat) cn <- colnames(XLdat)
@@ -593,6 +611,8 @@ server <- function(input, output, session) {
}) })
output$PureErrWParEst <- renderText(warning_textParEst()) output$PureErrWParEst <- renderText(warning_textParEst())
REP$PureErr <- PureErrFlag
noDilSeries <-(ncol(XLdat2)-1)/2 noDilSeries <-(ncol(XLdat2)-1)/2
noDils <- nrow(XLdat2) noDils <- nrow(XLdat2)
Dat$noDilSeriesXL <- noDilSeries Dat$noDilSeriesXL <- noDilSeries
@@ -619,6 +639,28 @@ server <- function(input, output, session) {
Dat$coeffsMUnr <- coeffsMU Dat$coeffsMUnr <- coeffsMU
Dat$coeffs_UN <- coeffsMU Dat$coeffs_UN <- coeffsMU
names(coeffsMU) <- c("lowAsym REF", "slope REF","upperAsym REF","EC50 REF","lowAsym TEST","slope TEST","upperAsym TEST","r") names(coeffsMU) <- c("lowAsym REF", "slope REF","upperAsym REF","EC50 REF","lowAsym TEST","slope TEST","upperAsym TEST","r")
# browser()
XbendMUlREF <- coeffsMU[4] - 1.5434/abs(coeffsMU[2])
XbendMUuREF <- coeffsMU[4] + 1.5434/abs(coeffsMU[2])
XbendMUlTEST <- coeffsMU[4]-coeffsMU[8] - 1.5434/abs(coeffsMU[6])
XbendMUuTEST <- coeffsMU[4]+coeffsMU[8] + 1.5434/abs(coeffsMU[6])
XbendMRlREF <- coeffsMR[4] - 1.5434/abs(coeffsMR[2])
XbendMRuREF <- coeffsMR[4] + 1.5434/abs(coeffsMR[2])
XbendMRlTEST <- coeffsMR[4]-coeffsMR[5] - 1.5434/abs(coeffsMR[2])
XbendMRuTEST <- coeffsMR[4]-coeffsMR[5] + 1.5434/abs(coeffsMR[2])
XasymlREF <- coeffsMR[4] - 3/abs(coeffsMR[2])
XasymuREF <- coeffsMR[4] + 3/abs(coeffsMR[2])
XasymlTEST <- coeffsMR[4]-coeffsMR[5] - 3/abs(coeffsMR[2])
XasymuTEST <- coeffsMR[4]-coeffsMR[5] + 3/abs(coeffsMR[2])
#browser()
BPsMR_MU <- data.frame(points = c("lower bendpoint REF", "upper bendpoint REF","lower bendpoint TEST" ,"upper bendpoint TEST",
"lower asymp. point REF", "upper asymp. point REFr", "lower asymp. point TEST", "upper asymp. point TEST",
"bendREF_lower_unrestr", "bendREF_upper_unrestr", "bendTESTE_lower_unrestr", "bendTEST_upper_unrestr"),
estimates = c(round(XbendMRlREF,3), round(XbendMRuREF,3),round(XbendMRlTEST,3),round(XbendMRuTEST,3),
round(XasymlREF,3),round(XasymuREF,3),round(XasymlTEST,3),round(XasymuTEST,3),
round(XbendMRlREF,3),round(XbendMRuREF,3),round(XbendMRlTEST,3),round(XbendMRuTEST,3)))
Dat$bendsAll <- BPsMR_MU
REP$bendsAll <- BPsMR_MU
if (!PureErrFlag) { if (!PureErrFlag) {
pot_est <- FITs[[3]] pot_est <- FITs[[3]]
@@ -725,7 +767,7 @@ server <- function(input, output, session) {
colnames(logpotUest) <- c("estimate", "lowerCI", "upperCI") colnames(logpotUest) <- c("estimate", "lowerCI", "upperCI")
#browser() #browser()
cnXL <- colnames(XLdat2) cnXL <- colnames(XLdat2)
Filesample <- data.frame(Test = c("File name", "samples"), Test2=c(Dat$FileName, paste(cnXL[1], " vs ", cnXL[4]))) Filesample <- data.frame(Test = c("FFILE NAME:", "SAMPLES"), Test2=c(Dat$FileName, paste(cnXL[1], " vs ", cnXL[4])))
colnames(Filesample) <- c("", "") colnames(Filesample) <- c("", "")
output$Filesampl <- renderTable({ Filesample }, rownames = F) output$Filesampl <- renderTable({ Filesample }, rownames = F)
@@ -770,11 +812,11 @@ server <- function(input, output, session) {
round(pot_est[1, ] * 100, 3)))) # von gs1_nls round(pot_est[1, ] * 100, 3)))) # von gs1_nls
output$coeffs_r <- renderTable({ PLAAusw }) output$coeffs_r <- renderTable({ PLAAusw })
PLAAusw2 <- data.frame(Dat$bendpoints) bendsAll <- data.frame(Dat$bendsAll[1:8,])
output$bends_r2 <- renderTable({ PLAAusw2 }, digits = 3, rownames = T) output$bends_r2 <- renderTable({ bendsAll }, digits = 3, rownames = T)
REP$PLAausw <- PLAAusw REP$PLAausw <- PLAAusw
REP$PLBend <- PLAAusw2 REP$PLBend <- bendsAll
#### Parameter extraktion ---- #### Parameter extraktion ----
logcoeffs_R <- SRlog$coefficients[, 1] # logpot$coefficients logcoeffs_R <- SRlog$coefficients[, 1] # logpot$coefficients
@@ -1105,7 +1147,7 @@ server <- function(input, output, session) {
REP$testsTab <- tab REP$testsTab <- tab
tab2 <- tab[1:7,] tab2 <- tab[1:7,]
dat <- datatable(tab2,options = list( dat <- datatable(tab2, rownames=F, options = list(
paging=TRUE, paging=TRUE,
dom="t", dom="t",
rownames=FALSE rownames=FALSE
@@ -1149,10 +1191,10 @@ server <- function(input, output, session) {
Dat$tests_FUNC <- tab2 Dat$tests_FUNC <- tab2
REP$testsTab <- tab2 REP$testsTab <- tab2
dat <- datatable(tab2,options = list( dat <- datatable(tab2,
rownames=FALSE, options = list(
paging=TRUE, paging=TRUE,
dom="t", dom="t"
rownames=FALSE
)) %>% formatStyle("test_results", )) %>% formatStyle("test_results",
target='row', target='row',
backgroundColor = styleEqual(c(-1,0,1), backgroundColor = styleEqual(c(-1,0,1),
@@ -1297,11 +1339,12 @@ server <- function(input, output, session) {
circle <- rbind(circleS,circleT) circle <- rbind(circleS,circleT)
Dat$circles <- circle Dat$circles <- circle
REPlin$circles <- circle
#browser() #browser()
sigmoid <- Dat$coeffsMUnr sigmoid <- Dat$coeffsMUnr
pLin <- PlotLinPLA_FUNC(circle, sigmoid = sigmoid, all_l2, pl_df, indS, indT) pLin <- PlotLinPLA_FUNC(circle, sigmoid = sigmoid, all_l2, pl_df, indS, indT)
REPlin$pLin <- pLin
pLin pLin
}) })
@@ -1397,7 +1440,10 @@ server <- function(input, output, session) {
}) })
#### linear PLA tests XLinput ---- #### linear PLA tests XLinput ----
output$TESTSlin <- DT::renderDataTable({ #output$TESTSlin <- DT::renderDataTable({
observe({
if (is.null(Dat$EXCEL)) return(NULL)
tab <- Dat$EXCEL tab <- Dat$EXCEL
if (is.character(tab)) stop(tab) if (is.character(tab)) stop(tab)
Conc <- exp(tab$log_dose) Conc <- exp(tab$log_dose)
@@ -1405,7 +1451,7 @@ server <- function(input, output, session) {
as.numeric(input$lEACratiola), as.numeric(input$uEACratiola), as.numeric(input$lEACratiola), as.numeric(input$uEACratiola),
as.numeric(input$lEACratioSlope), as.numeric(input$uEACratioSlope), as.numeric(input$lEACratioSlope), as.numeric(input$uEACratioSlope),
as.numeric(input$lEACratioua), as.numeric(input$uEACratioua), as.numeric(input$lEACratioua), as.numeric(input$uEACratioua),
as.numeric(input$lowerPot), as.numeric(input$upperPot), as.numeric(input$EACLinlow), as.numeric(input$EACLinupp),
as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff)) as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff))
noDil <- nrow(tab) noDil <- nrow(tab)
@@ -1458,6 +1504,9 @@ server <- function(input, output, session) {
output$SummaryModABu <- renderTable({ su_modU }, digits=5) output$SummaryModABu <- renderTable({ su_modU }, digits=5)
output$SummaryModAB <- renderTable({ su_mod2 }, digits=5) output$SummaryModAB <- renderTable({ su_mod2 }, digits=5)
REPlin$SuModABu <- su_modU
REPlin$SuModAB <- su_mod2
slopeDiffCI <- t(data.frame(LIN[[3]])) slopeDiffCI <- t(data.frame(LIN[[3]]))
colnames(slopeDiffCI) <- c("slope difference","lower CI","upper CI") colnames(slopeDiffCI) <- c("slope difference","lower CI","upper CI")
output$SlopeDiffCI <- renderTable({ slopeDiffCI },digits=5) output$SlopeDiffCI <- renderTable({ slopeDiffCI },digits=5)
@@ -1465,13 +1514,17 @@ server <- function(input, output, session) {
SelTestsL <- as.numeric(input$selectedSSTsLinear) SelTestsL <- as.numeric(input$selectedSSTsLinear)
df2 <- df[SelTestsL,] df2 <- df[SelTestsL,]
REPlin$LinTests <- df2
Dat$ANOVA <- df[,4:length(df)] Dat$ANOVA <- df[,4:length(df)]
dat <- datatable(df2[,1:3], dat <- datatable(df2[,1:3],
options=list( options=list(
paging=T, dom="t",rownames=F paging=T, dom="t",rownames=F
)) %>% formatStyle("test_results", target="row",backgroundColor = styleEqual(c(-1,0,1), )) %>% formatStyle("test_results", target="row",backgroundColor = styleEqual(c(-1,0,1),
c("pink","lightgreen","lightgrey"))) c("pink","lightgreen","lightgrey")))
output$TESTSlin <- DT::renderDataTable({
dat
})
}) })
#### output 4PL ANOVA tests Meta ---- #### output 4PL ANOVA tests Meta ----
@@ -1548,9 +1601,10 @@ server <- function(input, output, session) {
}) })
output$PureErrWLinXL <- renderText(warning_text2()) output$PureErrWLinXL <- renderText(warning_text2())
pottab <- LinPotTab(circles,Lim,PureErrFlag = PureErrFlag) LinPotTab <- LinPotTab(circles,Lim,PureErrFlag = PureErrFlag)
#browser() REPlin$LinPotTab <- LinPotTab
dat <- datatable(pottab,
dat <- datatable(LinPotTab,
options=list( options=list(
dom="t",rownames=F dom="t",rownames=F
)) %>% formatStyle("test_result", target='row', )) %>% formatStyle("test_result", target='row',
@@ -1671,20 +1725,20 @@ server <- function(input, output, session) {
} else {test_potUCI_t <- 1 } } else {test_potUCI_t <- 1 }
pottab4_ <- cbind(pottab4_[,-(2:4)], data.frame(tests=c(test_potCI, test_potUCI,test_potCI_t,test_potUCI_t))) pottab4_ <- cbind(pottab4_[,-(2:4)], data.frame(tests=c(test_potCI, test_potUCI,test_potCI_t,test_potUCI_t)))
colnames(pottab4_) <- c("model","potency","lower95%CI","upper95%CI","relative_lower95%CI","relative_upper95%CI","test_result") colnames(pottab4_) <- c("model","potency","lower95%CI","upper95%CI","relative_lower95%CI","relative_upper95%CI","test_result")
row.names(pottab4_) <- NULL
REP$pottab4plXL <- pottab4_[1:2,] REP$pottab4plXL <- pottab4_[1:2,]
output$pottab4plXL <- DT::renderDataTable({ output$pottab4plXL <- DT::renderDataTable({
dat <- datatable(pottab4_[1:2,], dat <- datatable(pottab4_[1:2,],rownames=F,
options=list(digits=3, options=list(digits=3,
paging=T, dom="t",rownames=F paging=T, dom="t"
)) %>% formatStyle("test_result", target="row",backgroundColor = styleEqual(c(0,1), )) %>% formatStyle("test_result", target="row",backgroundColor = styleEqual(c(0,1),
c("#B5C74055","#F9545455"))) c("#B5C74055","#F9545455")))
}) })
output$pottab4plTransXL <- DT::renderDataTable({ output$pottab4plTransXL <- DT::renderDataTable({
dat <- datatable(pottab4_[3:4,], dat <- datatable(pottab4_[3:4,],rownames=F,
options=list(digits=3, options=list(digits=3,
paging=T, dom="t",rownames=F paging=T, dom="t"
)) %>% formatStyle("test_result", target="row",backgroundColor = styleEqual(c(0,1), )) %>% formatStyle("test_result", target="row",backgroundColor = styleEqual(c(0,1),
c("#B5C74055","#F9545455"))) c("#B5C74055","#F9545455")))
}) })
@@ -2064,7 +2118,10 @@ server <- function(input, output, session) {
#### download XL 4PL report---- #### download XL 4PL report----
output$downloadXLReport <- downloadHandler( output$downloadXLReport <- downloadHandler(
filename= paste0("Report_4PLEvaluation", Dat$FileName,".pdf"),
filename= paste0("Report_4PLEvaluation", Dat$RepIdentifier,".pdf"),
content = function(file) { content = function(file) {
tpdr <- tempdir() tpdr <- tempdir()
@@ -2076,7 +2133,9 @@ server <- function(input, output, session) {
rmarkdown::render(tempReport, output_file = file, rmarkdown::render(tempReport, output_file = file,
params = list(FileName = Dat$FileName, params = list(FileName = Dat$FileName,
author = Dat$author, author = Dat$Author,
NoP = Dat$NoP,
Assay = Dat$Assay,
REP = REP, REP = REP,
coeffs = Dat$coeffs_UN), coeffs = Dat$coeffs_UN),
envir = new.env(parent = globalenv())) envir = new.env(parent = globalenv()))
@@ -2099,9 +2158,10 @@ server <- function(input, output, session) {
rmarkdown::render(tempReport, output_file = file, rmarkdown::render(tempReport, output_file = file,
params = list(FileName = Dat$FileName, params = list(FileName = Dat$FileName,
author = Dat$author, author = Dat$Author,
REP = REP, REP = REP,
coeffs = Dat$coeffs_UN), REPlin = REPlin,
coeffsLin = Dat$coeffs_UN),
envir = new.env(parent = globalenv())) envir = new.env(parent = globalenv()))
} }