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

bugfix: 4PL fit made robust
Build and deploy Roxygen2|pkgdown documentation site / build-and-deploy-documentation (push) Successful in 1m0s
Details
run tests / build-and-deploy-documentation (push) Successful in 9s
Details

Browse Source
This commit is contained in:
Franz Innerbichler
2026-07-30 12:29:43 +02:00
parent d450000178
commit 0b56824e3d
11 changed files with 160 additions and 145 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dev/app.R
+77 -111
View File
@@ -28,6 +28,7 @@ library(twopartm)
library(car)
library(dplyr)
library(scales)
library(tolerance)
source("../R/Global.R")
@@ -116,7 +117,7 @@ server <- function(input, output, session) {
"It needs to contain 1 column with the dilution concentrations (first or last column) and at least 2 columns of reference and test sample readouts, respectively.",
"The reference readout columns have to be before the test sample readout columns. The column names for reference and test are free to set, but different for all columns.",
"The column name of the dilution concentrations can be as follows: concentration, dose, log_concentration, log_dose (first letter can be capital)",
"It is assumed, that the concentrations are in anti-log or in natural log mode.",
"If the concentrations are in logarithmized, any log base can be used.",
),
column(6, )
),
@@ -159,10 +160,11 @@ server <- function(input, output, session) {
),
# actionLink("selectall","SelectAll"),
h5("\n\n\n Author: Franz Innerbichler, InnerAnalytics")
#h5("\n\n\n Author: Franz Innerbichler, InnerAnalytics")
),
column(
4,
h4("Suitability tests for 4-parametric logistic regression"),
"(potency CI test is set per default)",
checkboxGroupInput("selectedSSTs", "Which suitability tests to be used?",
@@ -206,6 +208,11 @@ server <- function(input, output, session) {
numericInput("uEACdiffla", "upper EAC for diff. of LA", 0.189, step = 0.001)
)
),
tabPanel(
"Uploaded data",
tableOutput("XLdata")
),
tabPanel(
"4pl-Analysis",
tags$style(HTML("pre { color: black; background-color: #FFE1FF;
@@ -376,7 +383,7 @@ server <- function(input, output, session) {
mainPanel(
width = 12,
tabsetPanel(
id = "tabs",
id = "tabs2",
tabPanel(
"Settings",
h4("Settings of 4PL regression"),
@@ -588,12 +595,15 @@ server <- function(input, output, session) {
fileInput("MiFile", "", accept = ".xlsx")
),
sliderInput("dilslider", "Adjust the dilutions(+-change in %)", min = -100,max=100, value=0, step=1, round=0),
checkboxInput("fixupper","Fix highest concentration (if unticked, the center is fixed)",FALSE)
#checkboxInput("fixupper","Fix highest concentration (if unticked, the center is fixed)",FALSE),
sliderInput("dilmover", "Move the dilutions(+-move in log-units)", min = -3,max=3, value=0, step=0.1, round=1),
numericInput("TolConf","confidence", value=0.95, step=0.01),
numericInput("TolPop","population", value=0.9, step=0.01)
)
),
mainPanel(
tabsetPanel(
id = "tabs",
id = "tabs3",
tabPanel("4pl",
@@ -736,17 +746,19 @@ server <- function(input, output, session) {
if (length(logI) > 0 & length(logDoseI) == 0) {
XLdat$log_dose <- XLdat[, logI]
XLdat2 <- XLdat[, -logI]
CORro <- cor(XLdat$log_dose, XLdat[, 3])
CORro <- COR_FUNC(XLdat$log_dose, XLdat[, 3])
} else if (length(logI) == 0 & length(logDoseI) == 0) {
Ind <- grep(".ilution|.ose|.onc", cn)
XLdat$log_dose <- log(XLdat[, Ind])
CORro <- cor(XLdat[, Ind], XLdat[, 3])
CORro <- COR_FUNC(XLdat[, Ind], XLdat[, 3])
XLdat2 <- XLdat[, -Ind]
} else if (length(logI) > 0 & length(logDoseI) > 0) {
XLdat2 <- XLdat
CORro <- cor(XLdat[, logI], XLdat[, 3])
CORro <- COR_FUNC(XLdat[, logI], XLdat[, 3])
}
Dat$EXCEL <- XLdat2
output$XLdata <- renderTable({ XLdat2 })
PureErrFlag <- input$PureErr
warning_text2 <- reactive({
ifelse(PureErrFlag, "Pure Error is selected", "")
@@ -775,7 +787,7 @@ server <- function(input, output, session) {
#### XLSX eval ----
#if (CORro < 0) SLOPE <- -1 else SLOPE <- 1
FITs <- Fitting_FUNC(XLdat2, TransFlag = FALSE)
FITs <- Fitting_FUNC(XLdat2, TransFlag = FALSE, nameWS="")
#### if no 4pl fit is possible ----
if (!is.null(FITs)) {
@@ -795,7 +807,7 @@ server <- function(input, output, session) {
})
warning_textNo4PLFit <- reactive({
ifelse(Dat$FITsFlag, "No meaningful 4PL fit was possible. This may havea several reasons: \nA control sample was tested/\n
ifelse(Dat$FITsFlag, "No meaningful 4PL fit was possible. This may have a several reasons: \nA control sample was tested/\n
the EC50 is not catched with the dilutions/\n the assay/reader had a problem",
"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."
@@ -2130,55 +2142,56 @@ server <- function(input, output, session) {
for (N_WS in 1:length(AllXL)) {
datWS <- as.data.frame(AllXL[[N_WS]])
nameWS <- names(AllXL)[N_WS]
cn <- colnames(datWS)
logI <- grep("log|ln", cn)
logDoseI <- grep("log_dose", cn)
if (length(logI) > 0 & length(logDoseI) == 0) {
datWS$log_dose <- datWS[, logI]
datWS2 <- datWS[, -logI]
CORro <- cor(datWS$log_dose, datWS[, 3])
CORro <- COR_FUNC(datWS$log_dose, datWS[, 3])
} else if (length(logI) == 0 & length(logDoseI) == 0) {
Ind <- grep(".ilution|.ose|.onc", cn)
datWS$log_dose <- log(datWS[, Ind])
CORro <- cor(datWS[, Ind], datWS[, 3])
CORro <- COR_FUNC(datWS[, Ind], datWS[, 3])
datWS2 <- datWS[, -Ind]
} else if (length(logI) > 0 & length(logDoseI) > 0) {
datWS2 <- datWS
CORro <- cor(datWS[, logI], datWS[, 3])
CORro <- COR_FUNC(datWS[, logI], datWS[, 3])
}
Dat$datWS2 <- datWS2
FITs <- Fitting_FUNC(datWS2, TransFlag = F)
pot_est <- FITs[[3]]
potEstL[[N_WS]] <- pot_est
potU_est <- FITs[[4]]
# unrestricted
SU_mu <- FITs[[2]]
URMcoefs1 <- SU_mu$coefficients
URMcoefs <- t(matrix(unlist(URMcoefs1[,1])))
URMcoefs_ <- cbind(AllSheets[[N_WS]], URMcoefs)
URMcoefsL[[N_WS]] <- URMcoefs_
SU_mr <- FITs[[1]]
RMcoefs1 <- SU_mr$coefficients
RMcoefs <- t(matrix(unlist(RMcoefs1[,1])))
RMcoefs_ <- cbind(AllSheets[[N_WS]], RMcoefs)
RMcoefsL[[N_WS]] <- RMcoefs_
X <- seq(min(datWS2$log_dose), max(datWS2$log_dose), 0.1)
sigRef <- URMcoefs[1,1] + (URMcoefs[1,3]-URMcoefs[1,1])/(1+exp(URMcoefs[1,2]*(URMcoefs[1,4]-X)))
sigTest1 <- URMcoefs[1,5] + (URMcoefs[1,7]-URMcoefs[1,5])/(1+exp(URMcoefs[1,6]*(URMcoefs[1,4] - URMcoefs[1,8]-X)))
#browser()
dfPlotsigRef <- data.frame(X=X, sigRef = sigRef, Sheet = AllSheets[[N_WS]])
dfPlotsigTest <- data.frame(X=X, sigTest = sigTest1, Sheet = AllSheets[[N_WS]])
if (!exists("SIGrefDF")) SIGrefDF <- dfPlotsigRef else SIGrefDF <- rbind(SIGrefDF, dfPlotsigRef)
if (!exists("SIGtestDF")) SIGtestDF <- dfPlotsigTest else SIGtestDF <- rbind(SIGtestDF,dfPlotsigTest)
FITs <- Fitting_FUNC(datWS2, TransFlag = F, nameWS = nameWS)
if (!is.character(FITs)) {
pot_est <- FITs[[3]]
potEstL[[N_WS]] <- pot_est
potU_est <- FITs[[4]]
# unrestricted
SU_mu <- FITs[[2]]
URMcoefs1 <- SU_mu$coefficients
URMcoefs <- t(matrix(unlist(URMcoefs1[,1])))
URMcoefs_ <- cbind(AllSheets[[N_WS]], URMcoefs)
URMcoefsL[[N_WS]] <- URMcoefs_
SU_mr <- FITs[[1]]
RMcoefs1 <- SU_mr$coefficients
RMcoefs <- t(matrix(unlist(RMcoefs1[,1])))
RMcoefs_ <- cbind(AllSheets[[N_WS]], RMcoefs)
RMcoefsL[[N_WS]] <- RMcoefs_
X <- seq(min(datWS2$log_dose), max(datWS2$log_dose), 0.1)
sigRef <- URMcoefs[1,1] + (URMcoefs[1,3]-URMcoefs[1,1])/(1+exp(URMcoefs[1,2]*(URMcoefs[1,4]-X)))
sigTest1 <- URMcoefs[1,5] + (URMcoefs[1,7]-URMcoefs[1,5])/(1+exp(URMcoefs[1,6]*(URMcoefs[1,4] - URMcoefs[1,8]-X)))
#browser()
dfPlotsigRef <- data.frame(X=X, sigRef = sigRef, Sheet = AllSheets[[N_WS]])
dfPlotsigTest <- data.frame(X=X, sigTest = sigTest1, Sheet = AllSheets[[N_WS]])
if (!exists("SIGrefDF")) SIGrefDF <- dfPlotsigRef else SIGrefDF <- rbind(SIGrefDF, dfPlotsigRef)
if (!exists("SIGtestDF")) SIGtestDF <- dfPlotsigTest else SIGtestDF <- rbind(SIGtestDF,dfPlotsigTest)
}
} #for N_WS
#browser()
@@ -2211,11 +2224,15 @@ server <- function(input, output, session) {
#browser()
BoxDF <- data.frame(EC50REF = EC50REF, EC50TEST = EC50TEST, LasREF = LasREF, UasREF = UasREF)
UasParTolREF <- normtol.int(x = UasREF, alpha = 1-input$TolConf, P = input$TolPop, side = 2)
LasParTolREF <- normtol.int(x = LasREF, alpha = 1-input$TolConf, P = input$TolPop, side = 2)
p1 <- ggplot(SIGrefDF, aes(x=X, y=sigRef, col=as.factor(Sheet))) +
geom_line() +
annotate("text", label="x", x=x_UA, y=UasREF, alpha=0.2) +
annotate("text", label="o", x=x_LA, y=LasREF, alpha=0.2) +
geom_hline(yintercept = c(UasParTolREF[[4]], UasParTolREF[[5]]), linetype=2, col="grey") +
geom_hline(yintercept = c(LasParTolREF[[4]], LasParTolREF[[5]]), linetype=2, col="grey") +
geom_vline(xintercept = EC50REF, alpha = 0.2) +
scale_x_continuous(expand = c(0, 0)) +
scale_y_continuous(expand = c(0, 0)) +
@@ -2229,70 +2246,19 @@ server <- function(input, output, session) {
theme(axis.text = element_text(face = "bold", size = 15),
plot.title = element_text(size = 15, face = "bold"),
plot.margin = unit(c(0.2, 0.2, 0.5, 0.5), "lines"))
# Horizontal marginal boxplot - to appear at the top of the chart
pBox_hor <- ggplot( BoxDF, aes(x = factor(1), y = EC50REF)) +
geom_boxplot(outlier.colour = NA) +
geom_jitter(position = position_jitter(width = 0.05)) +
scale_y_continuous(expand = c(0, 0)) +
expand_limits(y = c(min(SIGrefDF$X) - 0.1 * diff(range(SIGrefDF$X)),
max(SIGrefDF$X) + 0.1 * diff(range(SIGrefDF$X)))) +
coord_flip() +
theme_bw() +
theme(axis.text = element_blank(),
axis.title = element_blank(),
axis.ticks = element_blank(),
plot.margin = unit(c(1, 0.2, -0.5, 0.5), "lines"))
# Vertical marginal boxplot - to appear at the right of the chart
pBox_ver <- ggplot(BoxDF, aes(x = factor(1), y = UasREF)) +
geom_boxplot(outlier.colour = NA) +
geom_jitter(position = position_jitter(width = 0.05)) +
scale_y_continuous(expand = c(0, 0)) +
expand_limits(y = c(min(SIGrefDF$sigRef) - 0.1 * diff(range(SIGrefDF$sigRef)),
max(SIGrefDF$sigRef) + 0.1 * diff(range(SIGrefDF$sigRef)))) +
theme_bw() +
theme(axis.text = element_blank(),
axis.title = element_blank(),
axis.ticks = element_blank(),
plot.margin = unit(c(0.2, 1, 0.5, -0.5), "lines"))
#browser()
gt1 <- ggplot_gtable(ggplot_build(p1))
gt2 <- ggplot_gtable(ggplot_build(pBox_hor))
gt3 <- ggplot_gtable(ggplot_build(pBox_ver))
# Get maximum widths and heights
maxWidth <- unit.pmax(gt1$widths[2:3], gt2$widths[2:3])
maxHeight <- unit.pmax(gt1$heights[4:5], gt3$heights[4:5])
# Set the maximums in the gtables for gt1, gt2 and gt3
gt1$widths[2:3] <- as.list(maxWidth)
gt2$widths[2:3] <- as.list(maxWidth)
gt1$heights[4:5] <- as.list(maxHeight)
gt3$heights[4:5] <- as.list(maxHeight)
# Create a new gtable
gt <- gtable(widths = unit(c(7, 1), "null"), height = unit(c(1, 7), "null"))
# Instert gt1, gt2 and gt3 into the new gtable
gt <- gtable_add_grob(gt, gt1, 2, 1)
gt <- gtable_add_grob(gt, gt2, 1, 1)
gt <- gtable_add_grob(gt, gt3, 2, 2)
# grid.rect(x = 0.5, y = 0.5, height = 0.995, width = 0.995, default.units = "npc",
# gp = gpar(col = "black", fill = NA, lwd = 1))
# And render the plot
grid.newpage()
#browser()
output$sigPlotREF <- renderPlot({ grid.draw(gt) })
output$sigPlotREF <- renderPlot({ p1 })
Dat$sigPlotREF <- p1
#
UasParTolTEST <- normtol.int(x = UasTEST, alpha = 1-input$TolConf, P = input$TolPop, side = 2)
LasParTolTEST <- normtol.int(x = LasTEST, alpha = 1-input$TolConf, P = input$TolPop, side = 2)
p2 <- ggplot(SIGtestDF, aes(x=X, y=sigTest, col=as.factor(Sheet))) +
geom_line() +
annotate("text", label="x", x=x_UA, y=UasTEST, alpha=0.2) +
geom_hline(yintercept = c(UasParTolTEST[[4]], UasParTolTEST[[5]]), linetype=2, col="grey") +
annotate("text", label="o", x=x_LA, y=LasTEST, alpha=0.2) +
geom_hline(yintercept = c(LasParTolTEST[[4]], LasParTolTEST[[5]]), linetype=2, col="grey") +
geom_vline(xintercept = EC50TEST, alpha = 0.2) +
xlab("dilutions") +
ggtitle("Calculated test sample fits (unrestricted model, in gray vertical lines: EC50)") +
@@ -2354,23 +2320,23 @@ server <- function(input, output, session) {
dils <- tab$log_dose
min_y <- min(tab[, 1:2])
max_y <- max(tab[, 1:2])
if (input$fixupper) {
dils_av <- dils - max(dils)
dils_av_ <- dils_av * (input$dilslider / 100 + 1)
dils2 <- round(dils_av_ + max(dils), 4)
dilfactors <- 1 / exp(dils2 - lag(dils2))
} else {
#browser()
# if (input$fixupper) {
# dils_av <- dils - max(dils)
# dils_av_ <- dils_av * (input$dilslider / 100 + 1) + input$dilmover
# dils2 <- round(dils_av_ + max(dils), 4)
# dilfactors <- 1 / exp(dils2 - lag(dils2))
# } else {
if (!is.null(EC50TEST)) {
av <- mean(EC50TEST, na.rm = TRUE)
} else {
av <- (min(dils) + max(dils)) / 2
}
dils_av <- dils - av
dils_avsc <- dils_av * (input$dilslider / 100 + 1)
dils_avsc <- dils_av * (input$dilslider / 100 + 1) + input$dilmover
dils2 <- dils_avsc + av
dilfactors <- 1 / exp(dils2 - lag(dils2))
}
#}
Dat$newDils <- dils2