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

Catch singularities when fitting 4pl, SCRUM jobs listed

Browse Source
This commit is contained in:
Franz Innerbichler
2026-05-17 11:13:02 +02:00
parent ec13d95387
commit 9ff1a360d4
5 changed files with 136 additions and 103 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Global.R
+64 -13
View File
@@ -37,10 +37,17 @@ Fitting_FUNC <- function(ro_new, TransFlag=F) {
if (!TransFlag) {
startlist <- list(a=min(ro_new[,2]), b=SLOPE, d=max(ro_new[,2]), cs=mean(all_l$log_dose),r=0)
mr <- gsl_nls(fn = readout ~ a+(d-a)/(1+exp(b*((cs-r*isSample)-log_dose))),
mr <- tryCatch({gsl_nls(fn = readout ~ a+(d-a)/(1+exp(b*((cs-r*isSample)-log_dose))),
data=all_l2,
start=startlist,#trace=T,
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"
})
# Stop if singular gradient matrix
if (is.character(mr)) return(mr)
s_mr <- tryCatch({
s_mr <- summary(mr)
},
@@ -103,6 +110,40 @@ Fitting_FUNC <- function(ro_new, TransFlag=F) {
return(list(s_mr, Sum_u, pot_est, potU_est, PRED, PREDu))
}
plotSingularity <- function(dat) { #sigmoid,det_sig,
CORdat <- cor(dat[,1],dat[,ncol(dat)])
#browser()
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)
#browser()
log_dose <- unique(all_l$log_dose)
seq_x <- seq(min(log_dose),max(log_dose),0.1)
#browser()
#all_l2$readout[all_l2$readout < 0] <- 0.01
all_l2$readouttrans <- log(all_l2$readout)
#browser()
pSing <- ggplot(all_l2, aes(x=log_dose, y=readout, color=factor(isRef))) +
geom_point(shape=factor(isRef), size=3,alpha=0.8) +
labs(title = paste("No 4pl fit possible"),
color="product") +
scale_color_manual(labels=c("test","reference"), values=c("#C2173F","#4545BA")) +
scale_shape_manual(labels=c("test","reference")) +
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))
return(pSing)
}
#' Plot sigmoidal curve
#'
@@ -680,10 +721,18 @@ PlotLinPLA_FUNC <-function(circle, sigmoid, all_l2, pl_df, indS, indT) {
log_dose <- unique(all_l2$log_dose)
seq_x <- seq(min(log_dose), max(log_dose),0.1)
SAMPLEtrue <- sigmoid[5] + (sigmoid[7]-sigmoid[5])/(1+exp(sigmoid[6]*((sigmoid[4]-sigmoid[8]-seq_x))))
REFtrue <- sigmoid[1] + (sigmoid[3]-sigmoid[1])/(1+exp(sigmoid[2]*((sigmoid[4]-seq_x))))
if (!is.null(sigmoid)) {
SAMPLEtrue <- sigmoid[5] + (sigmoid[7]-sigmoid[5])/(1+exp(sigmoid[6]*((sigmoid[4]-sigmoid[8]-seq_x))))
REFtrue <- sigmoid[1] + (sigmoid[3]-sigmoid[1])/(1+exp(sigmoid[2]*((sigmoid[4]-seq_x))))
truePL_df <- cbind(seq_x,SAMPLEtrue, REFtrue)
} else {
SAMPLEtrue <- NULL
REFtrue <- NULL
truePL_df <- NULL
}
truePL_df <- cbind(seq_x,SAMPLEtrue, REFtrue)
p <- ggplot(all_l2,aes(x=log_dose,y=readout, color=factor(isRef))) +
geom_point(size=2) +
@@ -697,10 +746,10 @@ PlotLinPLA_FUNC <-function(circle, sigmoid, all_l2, pl_df, indS, indT) {
inherit.aes = F) +
geom_line(data=pl_df,aes(x=lnC,y=plotT),color="#C2173F",
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="#C2173F", linetype=2,alpha=0.4,
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="#4545BA", linetype=2,alpha=0.4,
inherit.aes = F) +
{if (!is.null(truePL_df)) geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="#C2173F", linetype=2,alpha=0.4,
inherit.aes = F) } +
{if (!is.null(truePL_df)) geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="#4545BA", linetype=2,alpha=0.4,
inherit.aes = F)} +
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))
p3 <- p2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
@@ -717,10 +766,10 @@ PlotLinPLA_FUNC <-function(circle, sigmoid, all_l2, pl_df, indS, indT) {
inherit.aes = F) +
geom_line(data=pl_rest,aes(x=lnC,y=plotT),color="#C2173F",
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="#C2173F", linetype=2,alpha=0.4,
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="#4545BA", linetype=2,alpha=0.4,
inherit.aes = F) +
{if (!is.null(truePL_df)) geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="#C2173F", linetype=2,alpha=0.4,
inherit.aes = F) } +
{if (!is.null(truePL_df)) geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="#4545BA", linetype=2,alpha=0.4,
inherit.aes = F) } +
labs(title = paste("restricted linear regression model"),
subtitle = paste("Regression on highlighted points")) +
theme(legend.position="none", axis.text = element_text(size=14))
@@ -895,6 +944,8 @@ tests_FUNC <- function(ro_new, Lim, PureErrFlag) {
all_l$readout[all_l$readout < 0] <- 0.01
#browser()
FITs <- Fitting_FUNC(ro_new = ro_new, TransFlag = FALSE)
if (is.character(FITs)) return(FITs) # if singularity
POTr_CI <- FITs[[3]][2:3]
potAll2 <- FITs[[3]]
SCRUm jobs.rtf
+17
View File
@@ -0,0 +1,17 @@
{\rtf1\ansi\ansicpg1252\cocoartf2867
\cocoatextscaling0\cocoaplatform0{\fonttbl\f0\fswiss\fcharset0 Helvetica;}
{\colortbl;\red255\green255\blue255;}
{\*\expandedcolortbl;;}
\paperw11900\paperh16840\margl1440\margr1440\vieww11520\viewh8400\viewkind0
\pard\tx720\tx1440\tx2160\tx2880\tx3600\tx4320\tx5040\tx5760\tx6480\tx7200\tx7920\tx8640\pardirnatural\partightenfactor0
\f0\fs24 \cf0 SCRUM jobs\
\
*) Sessioninfo geht noch ins Leere: \
tabPanel("Configuration",\
verbatimTextOutput("sessioninfo"))\
*) Checks ob EXCEL file den Vorgaben entspricht: \
**) Mindestens 2 Referenz- und gleich viele Testsample Spalten. \
**) Check ob Spalte mit den Verd\'fcnnungen den regex Vorgaben entspricht (Ind <- grep("dilu | dose | Dose | Conc | conc",cn)\
\
}
app.R
+53 -88
View File
@@ -44,11 +44,11 @@ ui <- dashboardPage(
# menuSubItem(icon = NULL, tags$li(a("Document", target="self",href="UserManual.pdf")))
# ),
menuItem("EXCEL upload", tabName="Dataupload", icon=icon("magnet", lib="glyphicon")),
menuItem("4PL metadata + report", tabName="fourPL", icon=icon("chart-line", lib="font-awesome")),
menuItem("4PL simulation", tabName="fourPL", icon=icon("chart-line", lib="font-awesome")),
#menuItem("XLSX diagnostics", tabName="XLdiagn", icon=icon("chart-bar", lib="font-awesome")),
# menuItem("Linear regression + report", tabName="pla", icon=icon("pencil", lib="glyphicon")),
menuItem("Wizard", tabName="wizard", icon=icon("chart-column", lib="font-awesome")),
menuItem("Documentation", tabName="documentation", icon=icon("chart-area", lib="font-awesome"))
menuItem("Wizard", tabName="wizard", icon=icon("chart-column", lib="font-awesome"))#,
#menuItem("Documentation", tabName="documentation", icon=icon("chart-area", lib="font-awesome"))
),
tags$footer(HTML(paste(tags$strong(tags$u("InnerAnalytics")), paste(rep("&nbsp",9), collapse=""),
"Developer:", paste(rep("&nbsp",9), collapse=""),
@@ -64,9 +64,9 @@ ui <- dashboardPage(
tabItem(tabName = "Dataupload", uiOutput("Dataupload")),
tabItem(tabName = "fourPL", uiOutput("fourPL")),
#tabItem(tabName = "XLdiagn", uiOutput("XLdiagn")),
tabItem(tabName = "pla", uiOutput("pla")),
tabItem(tabName = "wizard", uiOutput("wizard")),
tabItem(tabName = "documentation", uiOutput("docu"))
#tabItem(tabName = "pla", uiOutput("pla")),
tabItem(tabName = "wizard", uiOutput("wizard"))#,
#tabItem(tabName = "documentation", uiOutput("docu"))
)
)
@@ -82,11 +82,11 @@ server <- function(input, output, session) {
#### renderUIs ----
output$homePage <- renderUI({
navbarPage("Home",
tabPanel("Introduction",
tabPanel("Limit setting",
tags$img(src="logo.png", class="adv_logo"),
h4("Introduction to the bioassay software"),
tags$mark("linear regression"), br(),
column(4,
column(3,
tags$table(id="dose-table",
numericInput("lEACdiffla","lower EAC for diff. of LA", -0.175, step=0.001),
numericInput("uEACdiffla","upper EAC for diff. of LA", 0.189, step=0.001),
@@ -153,7 +153,9 @@ server <- function(input, output, session) {
"F-test on slope A"= "5", "F-test on slope B"="6",
"F-test on non-parallelism"= "7", "F-test on preparation"="8"),
selected= c("1","2","3","4","5","6","7","8"))
)
),
column(4,
plotOutput("plotSing", width="400px", height="300px"))
),
tabPanel("4pl-Analysis",
@@ -514,7 +516,7 @@ server <- function(input, output, session) {
)))
})
#output$sessioninfo <- renderPrint(sessioninfo())
v <- reactiveValues(num_dose=0, next.dose.t=0)
@@ -630,6 +632,42 @@ server <- function(input, output, session) {
if (CORro<0) SLOPE <- -1 else SLOPE <- 1
FITs <- Fitting_FUNC(XLdat2, TransFlag = FALSE)
#### if no 4pl fit is possible ----
if (!is.null(FITs)) {
if (is.character(FITs)) {
Dat$FITsFlag <- TRUE
pSing <- plotSingularity(XLdat2)
output$plotSing <- renderPlot({
pSing
})
output$XLplot <- renderPlot({
REP$XLplotSing <- pSing
pSing
})
output$relpotTestTab <- renderTable({ NULL })
output$relpotTestPlot<- renderPlot({ NULL })
output$AIC <- renderTable({ NULL })
output$VarDiagn <- renderTable({ NULL })
output$pottab4plXL <- renderDT({ NULL })
output$diagnplot <- renderPlot({ NULL })
output$EQtests <- renderDT({ NULL })
#
output$pottab4plTransXL <- renderDT({ NULL })
output$ANOVAXLS <- renderTable({ NULL })
#)
return(NULL)
}
}
Smr <- FITs[[1]] # summary(mr)
Smu <- FITs[[2]] # summary(mu)
@@ -767,7 +805,7 @@ server <- function(input, output, session) {
colnames(logpotUest) <- c("estimate", "lowerCI", "upperCI")
#browser()
cnXL <- colnames(XLdat2)
Filesample <- data.frame(Test = c("FFILE NAME:", "SAMPLES"), Test2=c(Dat$FileName, paste(cnXL[1], " vs ", cnXL[4])))
Filesample <- data.frame(Test = c("FILE NAME:", "SAMPLES"), Test2=c(Dat$FileName, paste(cnXL[1], " vs ", cnXL[4])))
colnames(Filesample) <- c("", "")
output$Filesampl <- renderTable({ Filesample }, rownames = F)
@@ -932,83 +970,7 @@ server <- function(input, output, session) {
}
})
#### updateSlider on XLSX ----
# observe({
# if (!is.null(Dat$potDiffXL)) {
# updateSliderInput(session, "potencydiff",
# value=round(as.numeric(Dat$potDiffXL[[1]]),5))
# }
# })
# observeEvent(input$potencydiff, {
# if (!is.null(Dat$potDiffXL)) {
# updateSliderInput(session, "potencydiff",
# value=round(as.numeric(input$potencydiff),5))
# }
# })
# observe({
# if (!is.null(Dat$ProzSD_XL)) {
# updateSliderInput(session, "sdfac",
# value=round(as.numeric(Dat$ProzSD_XL[[1]]),5))
# }
# })
# observeEvent(input$sdfac, {
# if (!is.null(Dat$ProzSD_XL)) {
# updateSliderInput(session, "sdfac",
# value=round(as.numeric(Dat$ProzSD_XL[[1]]),5))
# }
# })
#### updaterNumeric Input ----
# observe({
# if(!is.null(Dat$coeffs_UN)) {
# updateNumericInput(session, "lowAsymptREF",
# value=round(as.numeric(Dat$coeffs_UN[3]),5), min=0)
# updateNumericInput(session, "lowAsymptTEST",
# value=round(as.numeric(Dat$coeffs_UN[4]),5), min=0)
# updateNumericInput(session, "uppAsymptREF",
# value=round(as.numeric(Dat$coeffs_UN[5]),5), min=0)
# updateNumericInput(session, "uppAsymptTEST",
# value=round(as.numeric(Dat$coeffs_UN[6]),5), min=0)
# updateNumericInput(session, "slopeREF",
# value=round(as.numeric(Dat$coeffs_UN[1]),5))
# updateNumericInput(session, "slopeTEST",
# value=round(as.numeric(Dat$coeffs_UN[2]),5))
# updateNumericInput(session, "EC50",
# value=round(as.numeric(Dat$coeffs_UN[7]),5))
# updateNumericInput(session, "potDiff",
# value=round(as.numeric(Dat$coeffs_UN[7])- as.numeric(Dat$coeffs_UN[8]),5))
# }
# })
#
# observe({
# if(!is.null(Dat$dilution)) {
# updateNumericInput(session, "CONC1",
# value=as.numeric(Dat$dilution[1]))
# updateNumericInput(session, "CONC2",
# value=as.numeric(Dat$dilution[2]))
# updateNumericInput(session, "CONC3",
# value=as.numeric(Dat$dilution[3]))
# updateNumericInput(session, "CONC4",
# value=as.numeric(Dat$dilution[4]))
# updateNumericInput(session, "CONC5",
# value=as.numeric(Dat$dilution[5]))
# updateNumericInput(session, "CONC6",
# value=as.numeric(Dat$dilution[6]))
# updateNumericInput(session, "CONC7",
# value=as.numeric(Dat$dilution[7]))
# updateNumericInput(session, "CONC8",
# value=as.numeric(Dat$dilution[8]))
# updateNumericInput(session, "CONC9",
# value=as.numeric(Dat$dilution[9]))
# updateNumericInput(session, "CONC10",
# value=as.numeric(Dat$dilution[10]))
# updateNumericInput(session, "CONC11",
# value=as.numeric(Dat$dilution[11]))
# updateNumericInput(session, "CONC12",
# value=as.numeric(Dat$dilution[12]))
#
# }
# })
observe({
if(!is.null(Dat$MetaConc)) {
@@ -1161,10 +1123,12 @@ server <- function(input, output, session) {
}) # observe
#### Testergebnisse für XLSX ----
#### Testergebnisse 4PL für XLSX ----
observe({
if (is.null(Dat$EXCEL)) return(NULL)
if (is.null(input$PureErr)) return(NULL)
if (!is.null(Dat$FITsFlag)) return(NULL)
#observeEvent(input$StartCalc,{
PureErrFlag <- input$PureErr
warning_text3 <- reactive({
@@ -1691,6 +1655,7 @@ server <- function(input, output, session) {
observe({
#browser()
if (is.null(Dat$EXCEL)) return(NULL)
if (!is.null(Dat$FITsFlag)) return(NULL)
ro_new <- Dat$EXCEL
noDilSer <- Dat$noDilSeriesXL
www/TestFile.xlsx
BIN
View File
Binary file not shown.
www/Testsdfac0.2b_3Dil12.numbers
BIN
View File
Binary file not shown.