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

IMPORTANT added linting configuration
Build and deploy Roxygen2|pkgdown documentation site / build-and-deploy-documentation (push) Successful in 44s
Details
run tests / build-and-deploy-documentation (push) Successful in 8s
Details

Browse Source 
linting can be started by clicking Addins in RStudio, then
"Lint current file". This commit also contains quick fixes for common
linter messages like changing F to FALSE and T to TRUE.
This commit is contained in:
Simon Innerbichler
2026-06-03 10:33:40 +02:00
parent 4cfda9d162
commit 4cfdc288a8
3 changed files with 370 additions and 322 deletions
Download Patch File Download Diff File Expand all files Collapse all files
dev/app.R
+317 -280
View File
@@ -104,20 +104,18 @@ server <- function(input, output, session) {
font-family: 'Helvetica Neue', Helvetica, Arial, sans-serif;font-size: 12px;} ")),
h4("Introduction to the plateflow software"),
# tags$mark("linear regression"), br(),
column(6,
"INSPECT your plate reader data: This is the right place if you want to visualize your data in the context of a 4 PL fit or a linear regression fit. ",
"Bring your data in a readable format and start inspecting.",br(),
"Example of EXCEL/csv/numbers file:",br(),
tags$img(src = "ExampleXL.png", class = "adv_logo", width = "100%"),
"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.",
),
column(6,
)
column(
6,
"INSPECT your plate reader data: This is the right place if you want to visualize your data in the context of a 4 PL fit or a linear regression fit. ",
"Bring your data in a readable format and start inspecting.", br(),
"Example of EXCEL/csv/numbers file:", br(),
tags$img(src = "ExampleXL.png", class = "adv_logo", width = "100%"),
"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.",
),
column(6, )
),
tabPanel(
"Documentation",
@@ -146,7 +144,7 @@ server <- function(input, output, session) {
3,
# img(src="Screenshot.png", width=200),
box(
title = "Upload", status = "warning", solidHeader = T, width = 12, "Please upload your EXCEL file here",
title = "Upload", status = "warning", solidHeader = TRUE, width = 12, "Please upload your EXCEL file here",
fileInput("iFile", "", accept = ".xlsx")
),
uiOutput(outputId = "sheetName"),
@@ -186,24 +184,23 @@ server <- function(input, output, session) {
selected = c("1", "2", "3", "4", "5", "6", "7", "8")
)
),
column(2,
style = "background: #7FAEFF88",
numericInput("lEACratiola", "lower EAC ratio of LAs", 0.005, step = 0.001),
numericInput("uEACratiola", "upper EAC for ratio of LAs", 100, step = 1),
numericInput("lEACratioSlope", "lower EAC for ratio of slopes", 0.55, step = 0.01),
numericInput("uEACratioSlope", "upper EAC for ratio of slopes", 1.84, step = 0.1),
numericInput("lEACratioua", "lower EAC for ratio of UAs", 0.75, step = 0.1),
numericInput("uEACratioua", "upper EAC for ratio of UAs", 1.33, step = 0.1)),
column(2, style = "background: #7FAEFF88",
numericInput("lowerPot", "lower EAC for potency", 75, step = 1),
numericInput("upperPot", "upper EAC for potency", 133, step = 1),
numericInput("lEACratioAdiff", "lower EAC of ratio of asymptote differences", 0.75, step = 0.01),
numericInput("uEACratioAdiff", "upper EAC of ratio of asymptote differences", 1.33, step = 0.01),
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)
column(2,
style = "background: #7FAEFF88",
numericInput("lEACratiola", "lower EAC ratio of LAs", 0.005, step = 0.001),
numericInput("uEACratiola", "upper EAC for ratio of LAs", 100, step = 1),
numericInput("lEACratioSlope", "lower EAC for ratio of slopes", 0.55, step = 0.01),
numericInput("uEACratioSlope", "upper EAC for ratio of slopes", 1.84, step = 0.1),
numericInput("lEACratioua", "lower EAC for ratio of UAs", 0.75, step = 0.1),
numericInput("uEACratioua", "upper EAC for ratio of UAs", 1.33, step = 0.1)
),
column(2,
style = "background: #7FAEFF88",
numericInput("lowerPot", "lower EAC for potency", 75, step = 1),
numericInput("upperPot", "upper EAC for potency", 133, step = 1),
numericInput("lEACratioAdiff", "lower EAC of ratio of asymptote differences", 0.75, step = 0.01),
numericInput("uEACratioAdiff", "upper EAC of ratio of asymptote differences", 1.33, step = 0.01),
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)
)
),
tabPanel(
@@ -226,22 +223,29 @@ server <- function(input, output, session) {
tableOutput("AIC"),
h5("First row: restricted model; 2nd row: unrestricted model"),
h5("Smaller values of AIC indicate better fit to the data"),
box(title = "Useful information", status = "info", solidHeader = T, width = 12, "", collapsible = T,
tableOutput("VarDiagn"))
box(
title = "Useful information", status = "info", solidHeader = TRUE, width = 12, "", collapsible = TRUE,
tableOutput("VarDiagn")
)
),
column(
8,
plotOutput("XLplot"),
htmlOutput("No4PLFitText"),
DTOutput("pottab4plXL"),
box(title = "Residuals and QQ-plot", status = "info", solidHeader = T, width = 12, "", collapsible = T,
plotOutput("diagnplot")),
box(title = "Assay Suitability Tests", status = "info", solidHeader = T, width = 12, "", collapsible = T,
DTOutput("EQtests")),
box(
title = "Residuals and QQ-plot", status = "info", solidHeader = TRUE, width = 12, "", collapsible = TRUE,
plotOutput("diagnplot")
),
box(
title = "Assay Suitability Tests", status = "info", solidHeader = TRUE, width = 12, "", collapsible = TRUE,
DTOutput("EQtests")
),
DTOutput("pottab4plTransXL"),
box(title = "ANOVA", status = "info", solidHeader = T, width = 12, "", collapsible = T,
tableOutput("ANOVAXLS"))
box(
title = "ANOVA", status = "info", solidHeader = TRUE, width = 12, "", collapsible = TRUE,
tableOutput("ANOVAXLS")
)
)
)
)
@@ -285,14 +289,14 @@ server <- function(input, output, session) {
12,
h3("Tests for linear PLA:"),
box(
title = "Suitability tests", status = "primary", solidHeader = T, width = 12,
title = "Suitability tests", status = "primary", solidHeader = TRUE, width = 12,
DTOutput("TESTSlin")
),
h5("The estimate is the p-value of the test"),
h5("F-tests on regression, significance of slopes, and preparation need to have a p-value <0.05 to pass"),
h5("All other tests pass if p-value > 0.05"),
"SST CI for difference of slopes:",
#tableOutput("SlopeDiffCI"),
# tableOutput("SlopeDiffCI"),
h3("ANOVA for parallel line assay"),
DTOutput("ANOVAlin")
)
@@ -437,7 +441,7 @@ server <- function(input, output, session) {
column(
8,
box(
title = "Simulated data per log-concentration", status = "warning", solidHeader = T, width = 12, "incl. mean, sd and CV%",
title = "Simulated data per log-concentration", status = "warning", solidHeader = TRUE, width = 12, "incl. mean, sd and CV%",
DT::dataTableOutput("ConctabMeta")
),
verbatimTextOutput("logdil")
@@ -472,7 +476,7 @@ server <- function(input, output, session) {
8,
"4 PL ANOVA unrestricted",
box(
title = "ANOVA unrestricted", status = "warning", solidHeader = T, width = 12, "",
title = "ANOVA unrestricted", status = "warning", solidHeader = TRUE, width = 12, "",
DT::dataTableOutput("ANOVA")
),
h5("Please note that for the CIs of rel. potency the RSS of the restricted model is used"),
@@ -512,19 +516,19 @@ server <- function(input, output, session) {
5,
h3("Tests for linear PLA:"),
box(
title = "Suitability tests", status = "primary", solidHeader = T, collapsible = T, width = 12,
title = "Suitability tests", status = "primary", solidHeader = TRUE, collapsible = TRUE, width = 12,
DTOutput("TESTSlinMeta")
),
h5("The estimate is the p-value of the test"),
h5("F-tests on regression, significance of slopes, and preparation need to have a p-value <0.05 to pass"),
h5("All other tests pass if p-value > 0.05"),
box(
title = "Unrestricted linear model (SSSI):", status = "primary", solidHeader = T, collapsible = T, width = 12,
title = "Unrestricted linear model (SSSI):", status = "primary", solidHeader = TRUE, collapsible = TRUE, width = 12,
tableOutput("SummaryModABuMeta")
),
h4("Restricted linear model (CSSI):"),
box(
title = "Restricted linear model (CSSI):", status = "primary", solidHeader = T, collapsible = T, width = 12,
title = "Restricted linear model (CSSI):", status = "primary", solidHeader = TRUE, collapsible = TRUE, width = 12,
tableOutput("SummaryModABMeta")
)
),
@@ -532,7 +536,7 @@ server <- function(input, output, session) {
6,
h3("ANOVA for parallel line assay"),
box(
title = "ANOVA for simultated data", status = "primary", solidHeader = T, collapsible = T, width = 12,
title = "ANOVA for simultated data", status = "primary", solidHeader = TRUE, collapsible = TRUE, width = 12,
DTOutput("ANOVAlinMeta")
),
" CI for difference of slopes:",
@@ -553,7 +557,7 @@ server <- function(input, output, session) {
})
output$sessioninfo <- renderPrint(sessionInfo())
output$pla <- renderUI({
navbarPage(
title = "pla",
@@ -561,7 +565,7 @@ server <- function(input, output, session) {
)
})
#### UI wizard ----
output$wizard <- renderUI({
navbarPage(
@@ -572,12 +576,14 @@ server <- function(input, output, session) {
sidebarPanel(
width = 3,
fluidRow(
column(6,
box(title = "Upload multiple worksheets", status = "warning", solidHeader = T, width = 12, "Please upload your EXCEL file here",
fileInput("MiFile", "", accept = ".xlsx"))
column(
6,
box(
title = "Upload multiple worksheets", status = "warning", solidHeader = TRUE, width = 12, "Please upload your EXCEL file here",
fileInput("MiFile", "", accept = ".xlsx")
)
)
)
),
mainPanel(
tabsetPanel(
@@ -585,10 +591,11 @@ server <- function(input, output, session) {
tabPanel(
"4pl",
box(
title = "ANOVA table", status = "primary", solidHeader = T, width = 12,
title = "ANOVA table", status = "primary", solidHeader = TRUE, width = 12,
tableOutput("Anovatab")
),
column(4,
column(
4,
h3("Confidence intervals"),
tableOutput("CIs"),
"The confidence interval table is interaactive for changes in: variability slider (%SD), potency of test-slider,
@@ -596,7 +603,8 @@ server <- function(input, output, session) {
tableOutput("optimalDils"),
selectInput(inputId = "scenario", label = "Select an 'optimal' scenario:", choices = c("scenario 2", "scenario 3", "scenario 6", "steep slope"))
),
column(5,
column(
5,
plotOutput("plotfordilutions"),
h4("in grey: most extreme bend point lines of theoretical samples with 50% and 200% potency"),
sliderInput("dilslider", "Adjust the dilutions(+-change in %)", min = -100, max = 100, value = 0, step = 1, round = 0),
@@ -606,7 +614,8 @@ server <- function(input, output, session) {
"Short guidance: wider dilution ranges increase the CIs of rel. potency, and decrease the CIs of upper and lower asymptote ratios, as well as Hill's slope ratios", br(),
"Narrower dilution ranges decrease the CIs of rel. potency, and increase the CIs of upper and lower asymptote ratios, ands Hill's slope ratios",
),
column(3,
column(
3,
h3("Bend points"),
tableOutput("bps"),
tableOutput("extremebps"),
@@ -624,7 +633,6 @@ server <- function(input, output, session) {
)
})
v <- reactiveValues(num_dose = 0, next.dose.t = 0)
@@ -695,19 +703,18 @@ server <- function(input, output, session) {
Dat$MFileName <- input$MiFile[["name"]]
}
})
#### process XLSX file ----
observe({
if (!is.null(input$iFile)) {
if (!is.null(input$sheet)) {
if (input$sheet != "please choose") {
Dat$RepIdentifier <- input$RepIdentifier
Dat$Author <- input$Author
Dat$NoP <- input$NoP
Dat$Assay <- input$Assay
Dat$FITsFlag <- FALSE
#browser()
# browser()
XLdat <- Dat$wb[input$sheet][[1]]
if (is.null(XLdat)) XLdat <- Dat$wb[Dat$sheets[1]][[1]]
cn <- colnames(XLdat)
@@ -773,36 +780,67 @@ server <- function(input, output, session) {
pSing
})
warning_textNo4PLFit <- reactive({
ifelse(Dat$FITsFlag, "No meaningful 4PL fit was possible. This may havea 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.")
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."
)
})
output$No4PLFitText <- renderText(warning_textNo4PLFit())
output$relpotTestTab <- renderTable({ NULL })
output$relpotTestPlot <- renderPlot({ NULL })
output$relpotTestTab <- renderTable({
NULL
})
output$relpotTestPlot <- renderPlot({
NULL
})
output$AIC <- renderTable({ NULL })
output$VarDiagn <- renderTable({ NULL })
output$AIC <- renderTable({
NULL
})
output$VarDiagn <- renderTable({
NULL
})
output$pottab4plXL <- renderDT({ NULL })
output$diagnplot <- renderPlot({ NULL })
output$EQtests <- renderDT({ NULL })
output$pottab4plXL <- renderDT({
NULL
})
output$diagnplot <- renderPlot({
NULL
})
output$EQtests <- renderDT({
NULL
})
#
output$pottab4plTransXL <- renderDT({ NULL })
output$ANOVAXLS <- renderTable({ NULL })
output$coeffs_r <- renderTable({ NULL})
output$bends_r2 <- renderTable({ NULL })
output$coeffs_unr <- renderTable({ NULL })
output$logcoeffs_r <- renderTable({ NULL })
output$bends_unr2 <- renderTable({ NULL })
output$logcoeffs_unr <- renderTable({ NULL })
output$pottab4plTransXL <- renderDT({
NULL
})
output$ANOVAXLS <- renderTable({
NULL
})
output$coeffs_r <- renderTable({
NULL
})
output$bends_r2 <- renderTable({
NULL
})
output$coeffs_unr <- renderTable({
NULL
})
output$logcoeffs_r <- renderTable({
NULL
})
output$bends_unr2 <- renderTable({
NULL
})
output$logcoeffs_unr <- renderTable({
NULL
})
return(NULL)
}
@@ -963,7 +1001,7 @@ server <- function(input, output, session) {
{
Filesample
},
rownames = F
rownames = FALSE
)
UnRPLAausw <- data.frame(
@@ -976,7 +1014,7 @@ server <- function(input, output, session) {
Results = unlist(c("UNRESTRICTED", round(coeffsMU, 3), round(potU_est * 100, 3)))
) # von psl_nls
# "log relative potency", "log lower CI", "log upper CI", round(logpotest, 3), round(compParm(potu, "c", display = F), 3)
# "log relative potency", "log lower CI", "log upper CI", round(logpotest, 3), round(compParm(potu, "c", display = FALSE), 3)
output$coeffs_unr <- renderTable({
UnRPLAausw
@@ -1026,7 +1064,7 @@ server <- function(input, output, session) {
bendsAll
},
digits = 3,
rownames = T
rownames = TRUE
)
REP$PLAausw <- PLAAusw
@@ -1089,7 +1127,7 @@ server <- function(input, output, session) {
##### Plot XL 4PL ----
output$XLplot <- renderPlot({
XLplot4pl <- plot_f(XLdat2, TransFlag = F)
XLplot4pl <- plot_f(XLdat2, TransFlag = FALSE)
REP$XLplot4pl <- XLplot4pl
XLplot4pl
@@ -1278,7 +1316,7 @@ server <- function(input, output, session) {
sigmoid <- sigmoid()
det_sig <- NULL
plot_f(sim2(), TransFlag = F)
plot_f(sim2(), TransFlag = FALSE)
})
#### Plot 4pl Meta Transformed ----
@@ -1291,7 +1329,7 @@ server <- function(input, output, session) {
output$PureErrWLogMeta <- renderText(warning_text3())
sigmoid <- sigmoid()
det_sig <- NULL
plot_f(sim2(), TransFlag = T)
plot_f(sim2(), TransFlag = TRUE)
})
@@ -1328,11 +1366,11 @@ server <- function(input, output, session) {
REP$testsTab <- tab
tab2 <- tab[1:7, ]
dat <- datatable(tab2, rownames = F, options = list(
dat <- datatable(tab2, rownames = FALSE, options = list(
paging = TRUE,
dom = "t",
rownames = FALSE
)) %>% formatStyle("test_results",
)) |> formatStyle("test_results",
target = "row",
backgroundColor = styleEqual(
c(-1, 0, 1),
@@ -1391,7 +1429,7 @@ server <- function(input, output, session) {
paging = TRUE,
dom = "t"
)
) %>% formatStyle("test_results",
) |> formatStyle("test_results",
target = "row",
backgroundColor = styleEqual(
c(-1, 0, 1),
@@ -1437,7 +1475,7 @@ server <- function(input, output, session) {
paste("R", seq(1, (ncol(tab2) - 1) / 2)), "log_conc"
)
dat <- datatable(tab2, options = list(
paging = T,
paging = TRUE,
pageLength = 20,
dom = "t"
))
@@ -1462,17 +1500,17 @@ server <- function(input, output, session) {
Dat$Conctab <- Conctab
dat <- datatable(Conctab, options = list(
paging = T,
paging = TRUE,
pageLength = 12,
dom = "t"
)) %>%
)) |>
formatStyle(0,
target = "row",
backgroundColor = styleEqual(
c("avs", "sds", "cv", "avs_test", "sds_test", "cv_test"),
c("lightgrey", "lightgreen", "pink", "lightgrey", "lightgreen", "pink")
)
) %>%
) |>
formatRound(columns = colnames(Conctab), digits = 3)
})
@@ -1495,17 +1533,17 @@ server <- function(input, output, session) {
Dat$Conctab <- Conctab
dat <- datatable(Conctab, options = list(
paging = T,
paging = TRUE,
pageLength = 12,
dom = "t"
)) %>%
)) |>
formatStyle(0,
target = "row",
backgroundColor = styleEqual(
c("avs", "sds", "cv", "avs_test", "sds_test", "cv_test"),
c("lightgrey", "lightgreen", "pink", "lightgrey", "lightgreen", "pink")
)
) %>%
) |>
formatRound(columns = colnames(Conctab), digits = 3)
})
@@ -1666,9 +1704,9 @@ server <- function(input, output, session) {
Dat$ANOVAMeta <- df[, 4:length(df)]
dat <- datatable(df2[, 1:3],
options = list(
paging = T, dom = "t", rownames = F
paging = TRUE, dom = "t", rownames = FALSE
)
) %>% formatStyle("test_results", target = "row", backgroundColor = styleEqual(
) |> formatStyle("test_results", target = "row", backgroundColor = styleEqual(
c(-1, 0, 1),
c("pink", "lightgreen", "lightgrey")
))
@@ -1771,9 +1809,9 @@ server <- function(input, output, session) {
Dat$ANOVA <- df[, 4:length(df)]
dat <- datatable(df2[, 1:3],
options = list(
paging = T, dom = "t", rownames = F
paging = TRUE, dom = "t", rownames = FALSE
)
) %>% formatStyle("test_results", target = "row", backgroundColor = styleEqual(
) |> formatStyle("test_results", target = "row", backgroundColor = styleEqual(
c(-1, 0, 1),
c("pink", "lightgreen", "lightgrey")
))
@@ -1788,9 +1826,9 @@ server <- function(input, output, session) {
tab <- ANOVA4plUnresfunc(sim2()) # ,sigmoid
dat <- datatable(tab,
options = list(
dom = "t", rownames = F
dom = "t", rownames = FALSE
)
) %>% formatStyle("p_value",
) |> formatStyle("p_value",
target = "row",
backgroundColor = styleEqual(
c("p_value"),
@@ -1807,7 +1845,7 @@ server <- function(input, output, session) {
# dat <- datatable(tab,
# options=list(
# dom="t",rownames=F
# )) %>% formatStyle("p_value", target="row",
# )) |> formatStyle("p_value", target="row",
# backgroundColor = styleEqual(c("p_value"),
# c("lightgrey")))
# })
@@ -1833,9 +1871,9 @@ server <- function(input, output, session) {
ANOVAlin <- Dat$ANOVA
dat <- datatable(ANOVAlin,
options = list(
dom = "t", rownames = F
dom = "t", rownames = FALSE
)
) %>% formatStyle("p.value",
) |> formatStyle("p.value",
target = "cell",
backgroundColor = styleEqual(
c("p.value"),
@@ -1848,9 +1886,9 @@ server <- function(input, output, session) {
ANOVAlin <- Dat$ANOVAMeta
dat <- datatable(ANOVAlin,
options = list(
dom = "t", rownames = F
dom = "t", rownames = FALSE
)
) %>% formatStyle("p.value",
) |> formatStyle("p.value",
target = "cell",
backgroundColor = styleEqual(
c("p.value"),
@@ -1884,9 +1922,9 @@ server <- function(input, output, session) {
dat <- datatable(LinPotTab,
options = list(
dom = "t", rownames = F
dom = "t", rownames = FALSE
)
) %>% formatStyle("test_result",
) |> formatStyle("test_result",
target = "row",
backgroundColor = styleEqual(c(0, 1), c("#B5C74055", "#F9545488"))
)
@@ -1907,9 +1945,9 @@ server <- function(input, output, session) {
pottab <- LinPotTab(circles, Lim, PureErrFlag = PureErrFlag)
dat <- datatable(pottab,
options = list(
dom = "t", rownames = F
dom = "t", rownames = FALSE
)
) %>% formatStyle("test_result",
) |> formatStyle("test_result",
target = "row",
backgroundColor = styleEqual(c(0, 1), c("#B5C74055", "#F9545488"))
)
@@ -1968,9 +2006,9 @@ server <- function(input, output, session) {
dat <- datatable(pottab4_[1:2, ],
options = list(
digits = 3,
paging = T, dom = "t", rownames = F
paging = TRUE, dom = "t", rownames = FALSE
)
) %>% formatStyle("test_result", target = "row", backgroundColor = styleEqual(
) |> formatStyle("test_result", target = "row", backgroundColor = styleEqual(
c(0, 1),
c("lightgreen", "pink")
))
@@ -1979,9 +2017,9 @@ server <- function(input, output, session) {
dat <- datatable(pottab4_[3:4, ],
options = list(
digits = 3,
paging = T, dom = "t", rownames = F
paging = TRUE, dom = "t", rownames = FALSE
)
) %>% formatStyle("test_result", target = "row", backgroundColor = styleEqual(
) |> formatStyle("test_result", target = "row", backgroundColor = styleEqual(
c(0, 1),
c("lightgreen", "pink")
))
@@ -1990,8 +2028,6 @@ server <- function(input, output, session) {
#### 4pl potency table XL ----
observe({
if (is.null(Dat$EXCEL)) {
return(NULL)
}
@@ -2043,152 +2079,151 @@ server <- function(input, output, session) {
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, ]
#browser()
# browser()
output$pottab4plXL <- DT::renderDataTable({
dat <- datatable(pottab4_[1:2, ],
rownames = F,
rownames = FALSE,
options = list(
digits = 3,
paging = T, dom = "t"
paging = TRUE, dom = "t"
)
) %>% formatStyle("test_result", target = "row", backgroundColor = styleEqual(
) |> formatStyle("test_result", target = "row", backgroundColor = styleEqual(
c("passed", "failed"),
c("#B5C74055", "#F9545455")
))
})
output$pottab4plTransXL <- DT::renderDataTable({
dat <- datatable(pottab4_[3:4, -ncol(pottab4_)],
rownames = F,
rownames = FALSE,
options = list(
digits = 3,
paging = T, dom = "t"
paging = TRUE, dom = "t"
)
)
)
})
})
#### Dilutions Simulator ----
output$plotfordilutions <- renderPlot({
if (!is.null(Dat$Mws))
AllXL <- Dat$Mws
if (!is.null(Dat$Mws)) {
AllXL <- Dat$Mws
}
AllSheets <- Dat$Msheets
for (N_WS in 1:length(AllXL)) {
datWS <- as.data.frame(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])
} 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])
datWS2 <- datWS[, -Ind]
} else if (length(logI) > 0 & length(logDoseI) > 0) {
datWS2 <- datWS
CORro <- cor(datWS[, logI], datWS[, 3])
}
Dat$datWS2 <- datWS2
FITs <- Fitting_FUNC(datWS2, TransFlag = F)
pot_est <- FITs[[3]]
potU_est <- FITs[[4]]
# unrestricted
SU_mu <- FITs[[2]]
URMcoeffs <- SU_mu$coefficients
X <- seq(min(log(datWS23$log_dose)), max(log(datWS2$log_dose)), 0.1)
sigRef <- URMcoefs[1,1] + (URMcoefs1[4,1]-URMcoefs[1,1])/(1+exp(URMcoefs[2,1]*(URMcoefs[3,1]-X)))
sigTest1 <- URMcoefs[5,1] + (URMcoefs[8,1]-URMcoefs[5,1])/(1+exp(URMcoefs[6,1]*(URMcoefs[7,1]-X)))
dfPlotsigRef <- data.frame(X=X, sigRef = sigRef, Prod = pdfInd)
dfPlotsigTest <- data.frame(X=X, sigTest = sigTest1, Prod = AllSheets[[N_WS]])
if (!exists("SIGrefDF")) SIGrefDF <- dfPlotsigRef else SIGrefDF <- rbind(SIGrefDF, dfPlotsigRef)
if (!exists("SIGtestDF")) SIGtestDF <- dfPlotsigTest else SIGtestDF <- rbind(SIGtestDF,dfPlotsigTest)
EC50TEST <- as.numeric(c(URMcoefsDF[,8]))
# EC50TEST <- EC50TEST[!EC50TEST %in% boxplot.stats(EC50TEST)$out]
EC50REF <- as.numeric(URMcoefsDF[,4])
# EC50REF <- EC50REF[!EC50REF %in% boxplot.stats(EC50REF)$out]
UasREF <- as.numeric(URMcoefsDF[,5])
# UasREF <- UasREF[!UasREF %in% boxplot.stats(UasREF)$out]
LasREF <- as.numeric(URMcoefsDF[,2])
# LasREF <- LasREF[!LasREF %in% boxplot.stats(LasREF)$out]
#
# Dat$URMcoefsDF <- URMcoefsDF
# Dat$RestrM <- RestrM
# Dat$CalcPot <- CalcPot
#
#### sigmoid plots ----
Slope <- as.numeric(URMcoefsDF[1,3])
# if (Slope > 0) {
# x_UA <- max(X); x_LA <- min(X)
# } else { x_UA <- min(X); x_LA <- max(X) }
#
# p1 <- ggplot(SIGrefDF, aes(x_X, y=sigRef, col=as.factor(Prod))) +
# 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_vline(xintercept = EC50REF, alpha = 0.2) +
# xlab("dilutions") +
# ggtitle("Plot of all calculated reference fits (unrestricted model, in gray vertical lines: EC50)") +
# theme_bw() +
# theme(axis.text = element_text(face = "bold", size = 15),
# plot.title = element_text(size = 15, face = "bold"))
#
# output$sigPlotREF <- renderPlot({ p1 })
#
# PLOTS$sigPlotREF <- p1
#
# p2 <- ggplot(SIGtestDF, aes(x_X, y=sigTest, col=as.factor(Prod))) +
# 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_vline(xintercept = EC50TEST, alpha = 0.2) +
# xlab("dilutions") +
# ggtitle("Plot of all calculated reference fits (unrestricted model, in gray vertical lines: EC50)") +
# theme_bw() +
# theme(axis.text = element_text(face = "bold", size = 15),
# plot.title = element_text(size = 15, face = "bold"))
#
# output$sigPlotREF <- renderPlot({ p2 })
#
# PLOTS$sigPlotTEST <- p2
dils <- tab$log_dose
min_y <- min(tab[, 1:3])
max_y <- max(tab[, 1:3])
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 {
if (!is.null(Dat$cfordils)) {
av <- Dat$cfordils
} else {
av <- (min(dils) + max(dils)) / 2
for (N_WS in 1:length(AllXL)) {
datWS <- as.data.frame(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])
} 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])
datWS2 <- datWS[, -Ind]
} else if (length(logI) > 0 & length(logDoseI) > 0) {
datWS2 <- datWS
CORro <- cor(datWS[, logI], datWS[, 3])
}
dils_av <- dils - av
dils_avsc <- dils_av * (input$dilslider / 100 + 1)
dils2 <- dils_avsc + av
dilfactors <- 1 / exp(dils2 - lag(dils2))
}
} #for N_WS
Dat$datWS2 <- datWS2
FITs <- Fitting_FUNC(datWS2, TransFlag = FALSE)
pot_est <- FITs[[3]]
potU_est <- FITs[[4]]
# unrestricted
SU_mu <- FITs[[2]]
URMcoeffs <- SU_mu$coefficients
X <- seq(min(log(datWS23$log_dose)), max(log(datWS2$log_dose)), 0.1)
sigRef <- URMcoefs[1, 1] + (URMcoefs1[4, 1] - URMcoefs[1, 1]) / (1 + exp(URMcoefs[2, 1] * (URMcoefs[3, 1] - X)))
sigTest1 <- URMcoefs[5, 1] + (URMcoefs[8, 1] - URMcoefs[5, 1]) / (1 + exp(URMcoefs[6, 1] * (URMcoefs[7, 1] - X)))
dfPlotsigRef <- data.frame(X = X, sigRef = sigRef, Prod = pdfInd)
dfPlotsigTest <- data.frame(X = X, sigTest = sigTest1, Prod = AllSheets[[N_WS]])
if (!exists("SIGrefDF")) SIGrefDF <- dfPlotsigRef else SIGrefDF <- rbind(SIGrefDF, dfPlotsigRef)
if (!exists("SIGtestDF")) SIGtestDF <- dfPlotsigTest else SIGtestDF <- rbind(SIGtestDF, dfPlotsigTest)
EC50TEST <- as.numeric(c(URMcoefsDF[, 8]))
# EC50TEST <- EC50TEST[!EC50TEST %in% boxplot.stats(EC50TEST)$out]
EC50REF <- as.numeric(URMcoefsDF[, 4])
# EC50REF <- EC50REF[!EC50REF %in% boxplot.stats(EC50REF)$out]
UasREF <- as.numeric(URMcoefsDF[, 5])
# UasREF <- UasREF[!UasREF %in% boxplot.stats(UasREF)$out]
LasREF <- as.numeric(URMcoefsDF[, 2])
# LasREF <- LasREF[!LasREF %in% boxplot.stats(LasREF)$out]
#
# Dat$URMcoefsDF <- URMcoefsDF
# Dat$RestrM <- RestrM
# Dat$CalcPot <- CalcPot
#
#### sigmoid plots ----
Slope <- as.numeric(URMcoefsDF[1, 3])
# if (Slope > 0) {
# x_UA <- max(X); x_LA <- min(X)
# } else { x_UA <- min(X); x_LA <- max(X) }
#
# p1 <- ggplot(SIGrefDF, aes(x_X, y=sigRef, col=as.factor(Prod))) +
# 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_vline(xintercept = EC50REF, alpha = 0.2) +
# xlab("dilutions") +
# ggtitle("Plot of all calculated reference fits (unrestricted model, in gray vertical lines: EC50)") +
# theme_bw() +
# theme(axis.text = element_text(face = "bold", size = 15),
# plot.title = element_text(size = 15, face = "bold"))
#
# output$sigPlotREF <- renderPlot({ p1 })
#
# PLOTS$sigPlotREF <- p1
#
# p2 <- ggplot(SIGtestDF, aes(x_X, y=sigTest, col=as.factor(Prod))) +
# 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_vline(xintercept = EC50TEST, alpha = 0.2) +
# xlab("dilutions") +
# ggtitle("Plot of all calculated reference fits (unrestricted model, in gray vertical lines: EC50)") +
# theme_bw() +
# theme(axis.text = element_text(face = "bold", size = 15),
# plot.title = element_text(size = 15, face = "bold"))
#
# output$sigPlotREF <- renderPlot({ p2 })
#
# PLOTS$sigPlotTEST <- p2
dils <- tab$log_dose
min_y <- min(tab[, 1:3])
max_y <- max(tab[, 1:3])
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 {
if (!is.null(Dat$cfordils)) {
av <- Dat$cfordils
} else {
av <- (min(dils) + max(dils)) / 2
}
dils_av <- dils - av
dils_avsc <- dils_av * (input$dilslider / 100 + 1)
dils2 <- dils_avsc + av
dilfactors <- 1 / exp(dils2 - lag(dils2))
}
} # for N_WS
Dat$newDils <- dils2
sigmoid <- sigmoid()
@@ -2277,11 +2312,11 @@ server <- function(input, output, session) {
) +
geom_line(
data = as.data.frame(pl_df), aes(x = dils2, y = SAMPLE50), color = "grey15", linetype = 2,
inherit.aes = F
inherit.aes = FALSE
) +
geom_line(
data = as.data.frame(pl_df), aes(x = dils2, y = SAMPLE200), color = "grey15", linetype = 2,
inherit.aes = F
inherit.aes = FALSE
) +
geom_vline(xintercept = c(Xbend50, Xbend200), col = "grey15", linetype = 2) +
{
@@ -2500,13 +2535,13 @@ server <- function(input, output, session) {
)
DF_U <- nrow(all_l) - 8
uAsratio <- compParm(potU, "a", display = F)
uAsratio <- compParm(potU, "a", display = FALSE)
uCIuAs <- uAsratio[1] + qt(0.975, DF_U) * uAsratio[2]
lCIuAs <- uAsratio[1] - qt(0.975, DF_U) * uAsratio[2]
lAsratio <- compParm(potU, "d", display = F)
lAsratio <- compParm(potU, "d", display = FALSE)
uCIlAs <- lAsratio[1] + qt(0.975, DF_U) * lAsratio[2]
lCIlAs <- lAsratio[1] - qt(0.975, DF_U) * lAsratio[2]
Sloperatio <- compParm(potU, "b", display = F)
Sloperatio <- compParm(potU, "b", display = FALSE)
uCISlo <- Sloperatio[1] + qt(0.975, DF_U) * Sloperatio[2]
lCISlo <- Sloperatio[1] - qt(0.975, DF_U) * Sloperatio[2]
su <- summary(potU)
@@ -2607,34 +2642,36 @@ server <- function(input, output, session) {
#### download XL 4PL report----
observe({
if (is.null(Dat$FITsFlag)) return(NULL)
observe({
if (is.null(Dat$FITsFlag)) {
return(NULL)
}
if (!Dat$FITsFlag) {
browser()
output$downloadXLReport <- downloadHandler(
filename = paste0("Report_4PLEvaluation", Dat$RepIdentifier, ".pdf"),
content = function(file) {
tpdr <- tempdir()
tempReport <- file.path(tpdr, "Doc_BioassayReport.Rmd")
file.copy("Doc_BioassayReport.Rmd", tempReport, overwrite = T)
tempReportc <- file.path(tpdr, "logov2.png")
file.copy("logov2.png", tempReportc, overwrite = T)
rmarkdown::render(tempReport,
output_file = file,
params = list(
FileName = Dat$FileName,
author = Dat$Author,
NoP = Dat$NoP,
Assay = Dat$Assay,
REP = REP,
coeffs = Dat$coeffs_UN
),
envir = new.env(parent = globalenv())
)
}
)
browser()
output$downloadXLReport <- downloadHandler(
filename = paste0("Report_4PLEvaluation", Dat$RepIdentifier, ".pdf"),
content = function(file) {
tpdr <- tempdir()
tempReport <- file.path(tpdr, "Doc_BioassayReport.Rmd")
file.copy("Doc_BioassayReport.Rmd", tempReport, overwrite = TRUE)
tempReportc <- file.path(tpdr, "logov2.png")
file.copy("logov2.png", tempReportc, overwrite = TRUE)
rmarkdown::render(tempReport,
output_file = file,
params = list(
FileName = Dat$FileName,
author = Dat$Author,
NoP = Dat$NoP,
Assay = Dat$Assay,
REP = REP,
coeffs = Dat$coeffs_UN
),
envir = new.env(parent = globalenv())
)
}
)
}
})
@@ -2645,10 +2682,10 @@ server <- function(input, output, session) {
content = function(file) {
tpdr <- tempdir()
tempReport <- file.path(tpdr, "Doc_BioassayLinReport.Rmd")
file.copy("Doc_BioassayLinReport.Rmd", tempReport, overwrite = T)
file.copy("Doc_BioassayLinReport.Rmd", tempReport, overwrite = TRUE)
tempReportc <- file.path(tpdr, "logov2.png")
file.copy("logov2.png", tempReportc, overwrite = T)
file.copy("logov2.png", tempReportc, overwrite = TRUE)
rmarkdown::render(tempReport,
output_file = file,