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

ROUT outlier report updated and finalized
Build and deploy Roxygen2|pkgdown documentation site / build-and-deploy-documentation (push) Successful in 1m58s
Details
run tests / build-and-deploy-documentation (push) Successful in 18s
Details

Browse Source
This commit is contained in:
Guxa committed 2026-08-31 21:30:58 +02:00
1 parent 15a048b127
commit 2beaf0a9c8
8 files changed
+164 -104
Download Patch File Download Diff File Expand all files Collapse all files

No files matched your search

R/Global.R
+48
View File
@@ -1578,3 +1578,51 @@ divFUN <- function(x, Div, N, res, noDil) {
}
divFUN(y, Div, N, res, noDil)
}
#' Calculates bend points.
#'
#' Function to calcuate bend points and asymptote points.
#'
#' @param coeffsMR Coefficients of the restricted 4PL function fitting.
#' @param coeffsMU Coefficients of the unrestricted 4PL function fitting.
#' @returns A data-frame with the bend and asymptote points.
#' @export
#' @examples
#' suppressMessages(source("../../dev/setup.R"))
#'
#' Y = c(as = 0.120445892203919, bs = 1.28418582519022, ds = 1.8338879701327,
#' cs = 1.39147328614669, at = 0.138485413007939, bt = 1.21165361681225,
#' dt = 1.87305623127598, r = -0.124939016993196)
#' X=c(a = 0.128595630629391, b = 1.24241130117909, d = 1.85344873664946,
#' cs = 1.42641893429388, r = -0.048418036970926)
#'
#' bendFUN(X,Y)
bendFUN <- function(coeffsMR, coeffsMU) {
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])
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 REF", "lower asymp. point TEST", "upper asymp. point TEST",
"bendREF_lower_unrestr", "bendREF_upper_unrestr", "bendTEST_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)
)
)
return(BPsMR_MU)
}
dev/BioassayReportROUT.Rmd
+26 -19
View File
@@ -53,10 +53,10 @@ all_l <- REP$all_l
#ANOVAXLS <- REP$ANOVAXLS
#XLplot4pl <- REP$XLplot4pl
DiagnTable <- REP$DiagnTable
UnRPLAausw <- REP$UnRPLAausw
UnRPLBend <- REP$UnRPLBend
PLAausw <- REP$PLAausw
PLbend <- REP$PLBend
BendsROUT <- REP$BendsROUT
pottab4plXL <- REP$pottab4plXL
Lim <- REP$Lim
XLdat2 <- REP$XLdat2
@@ -64,7 +64,8 @@ PureErr <- REP$PureErr
ro_newROUT <- REP$ro_newROUT
ROUTplot <- REP$ROUTplot
ANOVA_ROUT <- REP$ANOVA_ROUT
coeffsMR_ROUT <- REP$RPLAauswROUT
coeffsMU_ROUT <- REP$UnRPLAauswROUT
CIplot <- REP$CIplot
testsTabROUT <- REP$testsTabROUT
relpotTestPlot <- REP$relpotTestPlot
@@ -100,7 +101,7 @@ if (!is.null(ro_newROUT)) {
```{r Over_all, echo=FALSE, comment=NA, warning=NA, message=NA}
browser()
#browser()
potFlag <- 0
if (pottab4plXL["test_result"][[1]][1]=="failed") potFlag <- 1
AnalysisFlag <- FALSE
@@ -125,7 +126,7 @@ colFmt <- function() {
## 4pl-regression
Relative potency (absolute and relative confidence limits) are shown in Table 3. `r if(PureErr) {"Pure Error is used for calculations."}`
Relative potency (absolute and relative confidence limits) BEFORE EXCLUSION of potential outliers are shown in Table 3 for information. `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}
@@ -154,6 +155,8 @@ plot(ROUTplot)
```
# Results after exclusion of potential outliers
## ANOVA table
The ANOVA of the unconstrained model is listed in table 4. Bates and Watts [4] 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 4). This test is for information only as it may be overly sensitive in case of small overall variability of the data.
@@ -200,7 +203,7 @@ cat(" 1 ... test failed (for EQ tests: CL not within limits);")
```{r AST_Ergebn, echo=FALSE, cache=FALSE, warning=FALSE, message=FALSE, tidy=TRUE}
TestsTabFlag <- FALSE
if (sum(testsTabROUT$test_results)>0) TestsTabFlag <- TRUE
if (sum(testsTabROUT[-nrow(testsTabROUT),]$test_results)>0) TestsTabFlag <- TRUE
colFmt2 <- function() {
outputFormat <- knitr::opts_knit$get("rmarkdown.pandoc.to")
@@ -223,35 +226,39 @@ colFmt2 <- function() {
## Fitting results with curve points
The results of the non-linear fitting procedure for the restricted model (5 parameters) is listed in table 5:
The results of the non-linear fitting procedure for the restricted model (5 parameters) is listed in Table 6:
```{r PLAausw, echo=FALSE, warning=FALSE, results='asis'}
kable(PLAausw, format = "markdown", caption= "Restricted 4PL model", digits=3, row.names = F)
kable(coeffsMR_ROUT , format = "markdown", caption= "Restricted 4PL model", digits=3, row.names = F)
```
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'}
kable(PLbend, format = "markdown", caption= "Bendpoints and asymptote points of restricted 4PL model", digits=3)
```
The results of the non-linear fitting procedure for the unrestricted model (8 parameters) is listed in table 7:
```{r UnRPLAausw, echo=FALSE, warning=FALSE, results='asis'}
kable(UnRPLAausw, format = "markdown", caption= "Unrestricted 4PL model", digits=3, row.names = F)
kable(coeffsMU_ROUT , format = "markdown", caption= "Unrestricted 4PL model", digits=3, row.names = F)
```
## Bend points and asymptote points
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'}
BendsROUT2 <- BendsROUT[1:8,]
kable(BendsROUT2, format = "markdown", caption= "Bendpoints and asymptote points of restricted 4PL model", digits=3)
```
# Signature
dev/ROUT.R
+3 -3
View File
@@ -11,9 +11,9 @@ library(minpack.lm)
library(ggplot2)
library(rstudioapi)
# Getting path for current open file
current_path = rstudioapi::getActiveDocumentContext()$path
setwd(dirname(current_path))
# # Getting path for current open file
# current_path = rstudioapi::getActiveDocumentContext()$path
# setwd(dirname(current_path))
outsPlot_FUN <- function(all_l,OUTs_, TS, PROC = "not specified", PROBE="", Q=0.01, par) {
#browser()
dev/app.R
+87 -82
View File
@@ -822,73 +822,99 @@ server <- function(input, output, session) {
##### ROUT outlier testing ----
#browser()
if(!is.null(input$Qslider)) {
all_lROUT <- all_l[complete.cases(all_l),]
colnames(all_lROUT) <- c("log_dose","sample","y","isRef","isSample","conc")
res <- rout_4pl_potency(all_lROUT, Q=input$Qslider/100)
OUTs_ <- all_lROUT[res$outliers,]
all_lROUT <- all_l[complete.cases(all_l),]
colnames(all_lROUT) <- c("log_dose","sample","y","isRef","isSample","conc")
res <- rout_4pl_potency(all_lROUT, Q=input$Qslider/100)
OUTs_ <- all_lROUT[res$outliers,]
all_l_rout <- all_lROUT[res$kept,]
# all_l_rout$log_dose <- log(all_l_rout$Conc)
# colnames(all_l_rout) <- c("log_dose","sample","y","isRef","isSample","conc")
if (all_l_rout$conc[1]>all_l_rout$conc[6]) {
if (all_l_rout$y[1]>all_l_rout$y[6]) SLOPE <- 1 else SLOPE<- -1
} else {
if (all_l_rout$y[1]>all_l_rout$y[6]) SLOPE <- -1 else SLOPE<- 1
}
all_l_rout <- all_lROUT[res$kept,]
# all_l_rout$log_dose <- log(all_l_rout$Conc)
# colnames(all_l_rout) <- c("log_dose","sample","y","isRef","isSample","conc")
if (all_l_rout$conc[1]>all_l_rout$conc[6]) {
if (all_l_rout$y[1]>all_l_rout$y[6]) SLOPE <- 1 else SLOPE<- -1
} else {
if (all_l_rout$y[1]>all_l_rout$y[6]) SLOPE <- -1 else SLOPE<- 1
}
startlist <- list(a = min(all_l_rout$y), b = SLOPE, d = max(all_l_rout$y), cs = mean(log(all_l_rout$conc)), r = 0)
startlist <- list(a = min(all_l_rout$y), b = SLOPE, d = max(all_l_rout$y), cs = mean(log(all_l_rout$conc)), r = 0)
mr <- tryCatch(
{
gsl_nls(
fn = y ~ a + (d - a) / (1 + exp(b * ((cs - r * isSample) - log_dose))),
data = all_l_rout,
start = startlist, # race=T,
control = gsl_nls_control(xtol = 1e-6, ftol = 1e-6, gtol = 1e-6)
)
},
warning = function(e) {
mr <<- "In nlsModel singular gradient matrix"
mr <- tryCatch(
{
gsl_nls(
fn = y ~ a + (d - a) / (1 + exp(b * ((cs - r * isSample) - log_dose))),
data = all_l_rout,
start = startlist, # race=T,
control = gsl_nls_control(xtol = 1e-6, ftol = 1e-6, gtol = 1e-6)
)
},
warning = function(e) {
mr <<- "In nlsModel singular gradient matrix"
})
PAR <- summary(mr)$coefficients[,1]
ROUTplot <- outsPlot_FUN(all_l_rout, OUTs_, TS=all_l_rout$sample[13], PROC="ROUT",PROBE=input$sheet,Q=input$Qslider/100,par=PAR)
output$OutlierDF <- renderTable({
OUTs_
})
output$OutlierPlot <- renderPlot({
print(ROUTplot)
})
PAR <- summary(mr)$coefficients[,1]
ROUTplot <- outsPlot_FUN(all_l_rout, OUTs_, TS=all_l_rout$sample[13], PROC="ROUT",PROBE=input$sheet,Q=input$Qslider/100,par=PAR)
output$OutlierDF <- renderTable({
OUTs_
})
output$OutlierPlot <- renderPlot({
print(ROUTplot)
})
all_l_rout2 <- all_l_rout[,-c(4:6)]
ro_newROUT <- reshape(all_l_rout2, direction="wide", idvar = "log_dose", timevar="sample", varying = as.vector(unique(all_l_rout2$sample)))
REP$ro_newROUT <- ro_newROUT
REP$ROUTplot <- ROUTplot
ANOVA_ROUT <- ANOVA4plUnresfunc(ro_new = ro_newROUT)
REP$ANOVA_ROUT <- ANOVA_ROUT
Limite <- list(
as.numeric(input$lEACdiffla), as.numeric(input$uEACdiffla),
as.numeric(input$lEACratiola), as.numeric(input$uEACratiola),
as.numeric(input$lEACratioSlope), as.numeric(input$uEACratioSlope),
as.numeric(input$lEACratioua), as.numeric(input$uEACratioua),
as.numeric(input$lowerPot), as.numeric(input$upperPot),
as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff)
)
tabROUT <- tests_FUNC(ro_newROUT, Limite, PureErrFlag = PureErrFlag)
#browser()
tabROUT[1, 6:7] <- c("-", "-")
#tabROUT2 <- tabROUT[SelTests, ]
#Dat$tests_FUNC <- tabROUT
REP$testsTabROUT <- tabROUT
FITsROUT <- Fitting_FUNC(ro_newROUT, TransFlag = FALSE, nameWS="")
SmrROUT <- FITsROUT[[1]] # summary(mr)
SmuROUT <- FITsROUT[[2]] # summary(mu)
coeffsMR_ROUT <- SmrROUT$coefficients[, 1]
coeffsMU_ROUT <- SmuROUT$coefficients[, 1]
BendsROUT <- bendFUN(coeffsMR_ROUT,coeffsMU_ROUT)
coeffsMR_ROUT_ <- data.frame(
Information = c(
"model", "lower asymptote", "Hill's slope", "upper asymptote", "EC50 Ref",
"EC50 difference"),
Results = unlist(c(
"RESTRICTED", round(coeffsMR_ROUT, 3)
)))
coeffsMU_ROUT_ <- data.frame(
Information = c(
"model", "lower asymptote Ref", "Hill's slope Ref", "upper asymptote Ref", "EC50 Ref",
"lower asymptote Test", "Hill's slope Test",
"upper asymptote Test", "EC50 difference"),
Results = unlist(c("UNRESTRICTED", round(coeffsMU_ROUT, 3)))
) # von psl_nls
REP$RPLAauswROUT <- coeffsMR_ROUT_
REP$UnRPLAauswROUT <- coeffsMU_ROUT_
all_l_rout2 <- all_l_rout[,-c(4:6)]
ro_newROUT <- reshape(all_l_rout2, direction="wide", idvar = "log_dose", timevar="sample", varying = as.vector(unique(all_l_rout2$sample)))
REP$ro_newROUT <- ro_newROUT
REP$ROUTplot <- ROUTplot
ANOVA_ROUT <- ANOVA4plUnresfunc(ro_new = ro_newROUT)
REP$ANOVA_ROUT <- ANOVA_ROUT
Limite <- list(
as.numeric(input$lEACdiffla), as.numeric(input$uEACdiffla),
as.numeric(input$lEACratiola), as.numeric(input$uEACratiola),
as.numeric(input$lEACratioSlope), as.numeric(input$uEACratioSlope),
as.numeric(input$lEACratioua), as.numeric(input$uEACratioua),
as.numeric(input$lowerPot), as.numeric(input$upperPot),
as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff)
)
tabROUT <- tests_FUNC(ro_newROUT, Limite, PureErrFlag = PureErrFlag)
#browser()
tabROUT[1, 6:7] <- c("-", "-")
#tabROUT2 <- tabROUT[SelTests, ]
#Dat$tests_FUNC <- tabROUT
REP$testsTabROUT <- tabROUT
REP$BendsROUT <- BendsROUT
}
@@ -986,30 +1012,9 @@ server <- function(input, output, session) {
Dat$coeffsMUnr <- coeffsMU
Dat$coeffs_UN <- coeffsMU
names(coeffsMU) <- c("lowAsym REF", "slope REF", "upperAsym REF", "EC50 REF", "lowAsym TEST", "slope TEST", "upperAsym TEST", "r")
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])
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 REF", "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)
)
)
##### bend function ----
BPsMR_MU <- bendFUN(coeffsMR, coeffsMU)
Dat$bendsAll <- BPsMR_MU
REP$bendsAll <- BPsMR_MU
dev/logo.png
BIN
View File
Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 23 KiB

dev/logov2_.png
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 35 KiB

dev/www/logo.png
BIN
View File
Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 23 KiB

www/logo.png
BIN
View File
Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 23 KiB