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
app.R
+96 -36
View File
@@ -18,11 +18,13 @@ library(drc)
library(twopartm)
library(car)
library(dplyr)
library(scales)
#### reactive values ----
Dat <- reactiveValues()
REP <- reactiveValues()
REPlin <- reactiveValues()
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 upper asymptote"= "5", "F-test on non-linearity"="6",
"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"),
checkboxGroupInput("selectedSSTsLinear", "Which suitability tests to be used?",
choices= c("F-test on Regr."="1",
@@ -177,6 +179,8 @@ server <- function(input, output, session) {
),
column(8,
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"),
plotOutput("diagnplot"),
DTOutput("EQtests"),
@@ -192,14 +196,14 @@ server <- function(input, output, session) {
width=2,
fluidRow(
column(12,
numericInput("Limits",p("limit to be >", bsButton("q4",label="", icon=icon("info"), style="primary", size="extra-small")),
bsPopover(id="q4", title="", content="The calculated limits ...")),
numericInput("EACLinlow","Potency CL to be > than",value=80),
numericInput("EACLinupp","Potency CL to be < than", value=125)
)
)),
mainPanel(
tabsetPanel(id="tabs",
tabPanel("linear PLA",
tabPanel("Plot and models",
column(12,
htmlOutput("PureErrWLinXL"),
tags$head(tags$style("#PureErrWLinXL{color: red;
@@ -212,8 +216,11 @@ server <- function(input, output, session) {
tableOutput("SummaryModABu"),
h4("Restricted linear model (CSSI):"),
tableOutput("SummaryModAB"),
h3("Tests for linear PLA):"),
)),
tabPanel("Tests and ANOVAA",
column(12,
h3("Tests for linear PLA:"),
box(title="Suitability tests", status="primary",solidHeader = T, width=12,
DTOutput("TESTSlin")),
h5("The estimate is the p-value of the test"),
@@ -224,11 +231,12 @@ server <- function(input, output, session) {
h3("ANOVA for parallel line assay"),
DTOutput("ANOVAlin"))
),
tabPanel("Report",
h4("Settings for report"),
))
),
# tabPanel("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}"),
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}"),
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,
h3("Confidence intervals"),
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",
tableOutput("optimalDils"),
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") {
#browser()
Dat$RepIdentifier <- input$RepIdentifier
Dat$Author <- input$Author
Dat$NoP <- input$NoP
Dat$Assay <- input$Assay
XLdat <- Dat$wb[input$sheet][[1]]
if (is.null(XLdat)) XLdat <- Dat$wb[Dat$sheets[1]][[1]]
cn <- colnames(XLdat)
@@ -593,6 +611,8 @@ server <- function(input, output, session) {
})
output$PureErrWParEst <- renderText(warning_textParEst())
REP$PureErr <- PureErrFlag
noDilSeries <-(ncol(XLdat2)-1)/2
noDils <- nrow(XLdat2)
Dat$noDilSeriesXL <- noDilSeries
@@ -619,6 +639,28 @@ 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")
# 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) {
pot_est <- FITs[[3]]
@@ -725,7 +767,7 @@ server <- function(input, output, session) {
colnames(logpotUest) <- c("estimate", "lowerCI", "upperCI")
#browser()
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("", "")
output$Filesampl <- renderTable({ Filesample }, rownames = F)
@@ -770,11 +812,11 @@ server <- function(input, output, session) {
round(pot_est[1, ] * 100, 3)))) # von gs1_nls
output$coeffs_r <- renderTable({ PLAAusw })
PLAAusw2 <- data.frame(Dat$bendpoints)
output$bends_r2 <- renderTable({ PLAAusw2 }, digits = 3, rownames = T)
bendsAll <- data.frame(Dat$bendsAll[1:8,])
output$bends_r2 <- renderTable({ bendsAll }, digits = 3, rownames = T)
REP$PLAausw <- PLAAusw
REP$PLBend <- PLAAusw2
REP$PLBend <- bendsAll
#### Parameter extraktion ----
logcoeffs_R <- SRlog$coefficients[, 1] # logpot$coefficients
@@ -1105,7 +1147,7 @@ server <- function(input, output, session) {
REP$testsTab <- tab
tab2 <- tab[1:7,]
dat <- datatable(tab2,options = list(
dat <- datatable(tab2, rownames=F, options = list(
paging=TRUE,
dom="t",
rownames=FALSE
@@ -1149,10 +1191,10 @@ server <- function(input, output, session) {
Dat$tests_FUNC <- tab2
REP$testsTab <- tab2
dat <- datatable(tab2,options = list(
dat <- datatable(tab2,
rownames=FALSE, options = list(
paging=TRUE,
dom="t",
rownames=FALSE
dom="t"
)) %>% formatStyle("test_results",
target='row',
backgroundColor = styleEqual(c(-1,0,1),
@@ -1297,11 +1339,12 @@ server <- function(input, output, session) {
circle <- rbind(circleS,circleT)
Dat$circles <- circle
REPlin$circles <- circle
#browser()
sigmoid <- Dat$coeffsMUnr
pLin <- PlotLinPLA_FUNC(circle, sigmoid = sigmoid, all_l2, pl_df, indS, indT)
REPlin$pLin <- pLin
pLin
})
@@ -1397,7 +1440,10 @@ server <- function(input, output, session) {
})
#### linear PLA tests XLinput ----
output$TESTSlin <- DT::renderDataTable({
#output$TESTSlin <- DT::renderDataTable({
observe({
if (is.null(Dat$EXCEL)) return(NULL)
tab <- Dat$EXCEL
if (is.character(tab)) stop(tab)
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$lEACratioSlope), as.numeric(input$uEACratioSlope),
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))
noDil <- nrow(tab)
@@ -1458,6 +1504,9 @@ server <- function(input, output, session) {
output$SummaryModABu <- renderTable({ su_modU }, digits=5)
output$SummaryModAB <- renderTable({ su_mod2 }, digits=5)
REPlin$SuModABu <- su_modU
REPlin$SuModAB <- su_mod2
slopeDiffCI <- t(data.frame(LIN[[3]]))
colnames(slopeDiffCI) <- c("slope difference","lower CI","upper CI")
output$SlopeDiffCI <- renderTable({ slopeDiffCI },digits=5)
@@ -1465,13 +1514,17 @@ server <- function(input, output, session) {
SelTestsL <- as.numeric(input$selectedSSTsLinear)
df2 <- df[SelTestsL,]
REPlin$LinTests <- df2
Dat$ANOVA <- df[,4:length(df)]
dat <- datatable(df2[,1:3],
options=list(
paging=T, dom="t",rownames=F
)) %>% formatStyle("test_results", target="row",backgroundColor = styleEqual(c(-1,0,1),
c("pink","lightgreen","lightgrey")))
output$TESTSlin <- DT::renderDataTable({
dat
})
})
#### output 4PL ANOVA tests Meta ----
@@ -1548,9 +1601,10 @@ server <- function(input, output, session) {
})
output$PureErrWLinXL <- renderText(warning_text2())
pottab <- LinPotTab(circles,Lim,PureErrFlag = PureErrFlag)
#browser()
dat <- datatable(pottab,
LinPotTab <- LinPotTab(circles,Lim,PureErrFlag = PureErrFlag)
REPlin$LinPotTab <- LinPotTab
dat <- datatable(LinPotTab,
options=list(
dom="t",rownames=F
)) %>% formatStyle("test_result", target='row',
@@ -1671,20 +1725,20 @@ server <- function(input, output, session) {
} else {test_potUCI_t <- 1 }
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")
row.names(pottab4_) <- NULL
REP$pottab4plXL <- pottab4_[1:2,]
output$pottab4plXL <- DT::renderDataTable({
dat <- datatable(pottab4_[1:2,],
dat <- datatable(pottab4_[1:2,],rownames=F,
options=list(digits=3,
paging=T, dom="t",rownames=F
paging=T, dom="t"
)) %>% formatStyle("test_result", target="row",backgroundColor = styleEqual(c(0,1),
c("#B5C74055","#F9545455")))
})
output$pottab4plTransXL <- DT::renderDataTable({
dat <- datatable(pottab4_[3:4,],
dat <- datatable(pottab4_[3:4,],rownames=F,
options=list(digits=3,
paging=T, dom="t",rownames=F
paging=T, dom="t"
)) %>% formatStyle("test_result", target="row",backgroundColor = styleEqual(c(0,1),
c("#B5C74055","#F9545455")))
})
@@ -2064,7 +2118,10 @@ server <- function(input, output, session) {
#### download XL 4PL report----
output$downloadXLReport <- downloadHandler(
filename= paste0("Report_4PLEvaluation", Dat$FileName,".pdf"),
filename= paste0("Report_4PLEvaluation", Dat$RepIdentifier,".pdf"),
content = function(file) {
tpdr <- tempdir()
@@ -2076,7 +2133,9 @@ server <- function(input, output, session) {
rmarkdown::render(tempReport, output_file = file,
params = list(FileName = Dat$FileName,
author = Dat$author,
author = Dat$Author,
NoP = Dat$NoP,
Assay = Dat$Assay,
REP = REP,
coeffs = Dat$coeffs_UN),
envir = new.env(parent = globalenv()))
@@ -2099,9 +2158,10 @@ server <- function(input, output, session) {
rmarkdown::render(tempReport, output_file = file,
params = list(FileName = Dat$FileName,
author = Dat$author,
author = Dat$Author,
REP = REP,
coeffs = Dat$coeffs_UN),
REPlin = REPlin,
coeffsLin = Dat$coeffs_UN),
envir = new.env(parent = globalenv()))
}