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
.lintr
+11
View File
@@ -0,0 +1,11 @@
linters: linters_with_defaults(
line_length_linter(150),
commented_code_linter = NULL,
object_name_linter = NULL,
brace_linter = NULL
)
exclusions: list(
"inst/doc/creating_linters.R" = 1,
"inst/example/bad.R",
"tests/testthat/exclusions-test"
)
R/Global.R
+40 -40
View File
@@ -45,7 +45,7 @@ library(scales)
#' Dat <- list() #' Dat <- list()
#' te <- Fitting_FUNC(dat, TransF) #' te <- Fitting_FUNC(dat, TransF)
#' print(te) #' print(te)
Fitting_FUNC <- function(ro_new, TransFlag = F) { Fitting_FUNC <- function(ro_new, TransFlag = FALSE) {
CORro <- cor(ro_new[, 1], ro_new[, ncol(ro_new)]) CORro <- cor(ro_new[, 1], ro_new[, ncol(ro_new)])
# browser() # browser()
all_l <- melt(data.frame(ro_new), id.vars = "log_dose", variable.name = "replname", value.name = "readout") all_l <- melt(data.frame(ro_new), id.vars = "log_dose", variable.name = "replname", value.name = "readout")
@@ -268,7 +268,7 @@ plotSingularity <- function(dat) { # sigmoid,det_sig,
#' Dat <- list() #' Dat <- list()
#' p <- plot_f(dat, sigmoid, det_sig, TransF) #' p <- plot_f(dat, sigmoid, det_sig, TransF)
#' print(p) #' print(p)
plot_f <- function(dat, TransFlag = F) { # sigmoid,det_sig, plot_f <- function(dat, TransFlag = FALSE) { # sigmoid,det_sig,
CORdat <- cor(dat[, 1], dat[, ncol(dat)]) CORdat <- cor(dat[, 1], dat[, ncol(dat)])
# browser() # browser()
all_l <- melt(data.frame(dat), id.vars = "log_dose", variable.name = "replname", value.name = "readout") all_l <- melt(data.frame(dat), id.vars = "log_dose", variable.name = "replname", value.name = "readout")
@@ -276,7 +276,7 @@ plot_f <- function(dat, TransFlag = F) { # sigmoid,det_sig,
isSample <- rep(c(0, 1), 1, each = nrow(all_l) / 2) isSample <- rep(c(0, 1), 1, each = nrow(all_l) / 2)
all_l2 <- cbind(all_l, isRef, isSample) all_l2 <- cbind(all_l, isRef, isSample)
# browser() # browser()
MODLS <- Fitting_FUNC(dat, TransFlag = F) MODLS <- Fitting_FUNC(dat, TransFlag = FALSE)
s_mr <- MODLS[[1]] s_mr <- MODLS[[1]]
a <- s_mr$coefficients["a", 1] a <- s_mr$coefficients["a", 1]
b <- s_mr$coefficients["b", 1] b <- s_mr$coefficients["b", 1]
@@ -340,23 +340,23 @@ plot_f <- function(dat, TransFlag = F) { # sigmoid,det_sig,
scale_x_continuous(breaks = scales::pretty_breaks(n = 10)) + scale_x_continuous(breaks = scales::pretty_breaks(n = 10)) +
scale_y_continuous(breaks = scales::pretty_breaks(n = 10)) + scale_y_continuous(breaks = scales::pretty_breaks(n = 10)) +
# theme_bw() + # theme_bw() +
theme(axis.text.x = element_text(size = 12, angle=90), axis.text.y = element_text(size = 12)) theme(axis.text.x = element_text(size = 12, angle = 90), axis.text.y = element_text(size = 12))
p2 <- p + geom_line( p2 <- p + geom_line(
data = as.data.frame(pl_df), aes(x = seq_x, y = SAMPLE), color = "#C2173F", data = as.data.frame(pl_df), aes(x = seq_x, y = SAMPLE), color = "#C2173F",
inherit.aes = F inherit.aes = FALSE
) + ) +
geom_line( geom_line(
data = as.data.frame(pl_df), aes(x = seq_x, y = REF), color = "#4545BA", data = as.data.frame(pl_df), aes(x = seq_x, y = REF), color = "#4545BA",
inherit.aes = F inherit.aes = FALSE
) + ) +
geom_line( geom_line(
data = as.data.frame(pl_df), aes(x = seq_x, y = SAMPLEtrue), color = "#C2173F", linetype = 2, alpha = 0.4, data = as.data.frame(pl_df), aes(x = seq_x, y = SAMPLEtrue), color = "#C2173F", linetype = 2, alpha = 0.4,
inherit.aes = F inherit.aes = FALSE
) + ) +
geom_line( geom_line(
data = as.data.frame(pl_df), aes(x = seq_x, y = REFtrue), color = "#4545BA", linetype = 2, alpha = 0.4, data = as.data.frame(pl_df), aes(x = seq_x, y = REFtrue), color = "#4545BA", linetype = 2, alpha = 0.4,
inherit.aes = F inherit.aes = FALSE
) + ) +
geom_vline(xintercept = c(Xbendl3, Xbendu3), col = "#4545BA", linetype = 2) + geom_vline(xintercept = c(Xbendl3, Xbendu3), col = "#4545BA", linetype = 2) +
geom_vline(xintercept = c(XbendlT, XbenduT), col = "#C2173F", linetype = 2) + geom_vline(xintercept = c(XbendlT, XbenduT), col = "#C2173F", linetype = 2) +
@@ -397,11 +397,11 @@ plot_f <- function(dat, TransFlag = F) { # sigmoid,det_sig,
pl_df_trans <- cbind(seq_x, SAMPLEtrans, REFtrans) pl_df_trans <- cbind(seq_x, SAMPLEtrans, REFtrans)
p_rt2 <- p_rt + geom_line( p_rt2 <- p_rt + geom_line(
data = as.data.frame(pl_df_trans), aes(x = seq_x, y = SAMPLEtrans), color = "#C2173F", data = as.data.frame(pl_df_trans), aes(x = seq_x, y = SAMPLEtrans), color = "#C2173F",
inherit.aes = F inherit.aes = FALSE
) + ) +
geom_line( geom_line(
data = as.data.frame(pl_df_trans), aes(x = seq_x, y = REFtrans), color = "#4545BA", data = as.data.frame(pl_df_trans), aes(x = seq_x, y = REFtrans), color = "#4545BA",
inherit.aes = F inherit.aes = FALSE
) + ) +
geom_vline(xintercept = c(XbendlTrans, XbenduTrans), col = "#4545BA", linetype = 2) + geom_vline(xintercept = c(XbendlTrans, XbenduTrans), col = "#4545BA", linetype = 2) +
geom_vline(xintercept = c(XbendlTransT, XbenduTransT), col = "#C2173F", linetype = 2) + geom_vline(xintercept = c(XbendlTransT, XbenduTransT), col = "#C2173F", linetype = 2) +
@@ -432,12 +432,12 @@ plot_f <- function(dat, TransFlag = F) { # sigmoid,det_sig,
theme_bw() theme_bw()
pu2 <- pu + geom_line( pu2 <- pu + geom_line(
data = as.data.frame(pl_df2), aes(x = seq_x, y = SAMPLEu), data = as.data.frame(pl_df2), aes(x = seq_x, y = SAMPLEu),
color = "#C2173F", inherit.aes = F color = "#C2173F", inherit.aes = FALSE
) + ) +
geom_line( geom_line(
data = as.data.frame(pl_df2), aes(x = seq_x, y = REFu), data = as.data.frame(pl_df2), aes(x = seq_x, y = REFu),
color = "#4545BA", inherit.aes = F, color = "#4545BA", inherit.aes = FALSE,
show.legend = F show.legend = FALSE
) )
pu2_ <- pu2 + pu2_ <- pu2 +
theme(legend.position = "none", axis.text = element_text(size = 14)) theme(legend.position = "none", axis.text = element_text(size = 14))
@@ -465,12 +465,12 @@ plot_f <- function(dat, TransFlag = F) { # sigmoid,det_sig,
pu2_t <- putrans + geom_line( pu2_t <- putrans + geom_line(
data = as.data.frame(pl_df2u_t), aes(x = seq_x, y = SAMPLEu_trans), data = as.data.frame(pl_df2u_t), aes(x = seq_x, y = SAMPLEu_trans),
color = "#C2173F", inherit.aes = F color = "#C2173F", inherit.aes = FALSE
) + ) +
geom_line( geom_line(
data = as.data.frame(pl_df2u_t), aes(x = seq_x, y = REFu_trans), data = as.data.frame(pl_df2u_t), aes(x = seq_x, y = REFu_trans),
color = "#4545BA", inherit.aes = F, color = "#4545BA", inherit.aes = FALSE,
show.legend = F show.legend = FALSE
) )
pu3_t <- pu2_t pu3_t <- pu2_t
if (TransFlag) grid.arrange(p_rt2, pu3_t, nrow = 1) else grid.arrange(p2, pu2_, nrow = 1) if (TransFlag) grid.arrange(p_rt2, pu3_t, nrow = 1) else grid.arrange(p2, pu2_, nrow = 1)
@@ -782,19 +782,19 @@ ANOVAlintests <- function(ro_new, circles, Lim, PureErrFlag) {
# F-test on regression: MSSreg/MSSE # F-test on regression: MSSreg/MSSE
if (is.na(F_nonlin)) F_nonlin <- 0 if (is.na(F_nonlin)) F_nonlin <- 0
if (F_nonlin > 0) { if (F_nonlin > 0) {
p_F_nonlin <- round(pf(F_nonlin, 2, dfPureE, lower.tail = F), 5) p_F_nonlin <- round(pf(F_nonlin, 2, dfPureE, lower.tail = FALSE), 5)
} else { } else {
p_F_nonlin <- "SSnonlin neg or 0" p_F_nonlin <- "SSnonlin neg or 0"
} }
# significances # significances
F_regr <- (SSreg / 1) / (SSRes / dfRes) F_regr <- (SSreg / 1) / (SSRes / dfRes)
p_F_regr <- round(pf(F_regr, 1, dfRes, lower.tail = F), 3) p_F_regr <- round(pf(F_regr, 1, dfRes, lower.tail = FALSE), 3)
p_F_treat <- round(pf(F_treat, 3, dfRes, lower.tail = F), 3) p_F_treat <- round(pf(F_treat, 3, dfRes, lower.tail = FALSE), 3)
p_F_prep <- round(pf(F_prep, 1, dfRes, lower.tail = F), 3) p_F_prep <- round(pf(F_prep, 1, dfRes, lower.tail = FALSE), 3)
p_F_slope_A <- round(pf(F_slope_A, 1, (nrow(circ_Al) - 2), lower.tail = F), 3) p_F_slope_A <- round(pf(F_slope_A, 1, (nrow(circ_Al) - 2), lower.tail = FALSE), 3)
p_F_slope_B <- round(pf(F_slope_B, 1, (nrow(circ_Bl) - 2), lower.tail = F), 3) p_F_slope_B <- round(pf(F_slope_B, 1, (nrow(circ_Bl) - 2), lower.tail = FALSE), 3)
p_F_nonp <- round(pf(F_nonpar, 1, dfRes, lower.tail = F), 3) p_F_nonp <- round(pf(F_nonpar, 1, dfRes, lower.tail = FALSE), 3)
p_F_LoF <- p_F_nonlin p_F_LoF <- p_F_nonlin
res_tab_lin <- data.frame( res_tab_lin <- data.frame(
@@ -869,7 +869,7 @@ ANOVAlintests <- function(ro_new, circles, Lim, PureErrFlag) {
#' #'
#' PlotLinPLA_FUNC(circle, sigmoid, all_l2, pl_df, indS, indT) #' PlotLinPLA_FUNC(circle, sigmoid, all_l2, pl_df, indS, indT)
PlotLinPLA_FUNC <- function(circle, sigmoid, all_l2, pl_df, indS, indT) { PlotLinPLA_FUNC <- function(circle, sigmoid, all_l2, pl_df, indS, indT) {
#browser() # browser()
mLin <- gsl_nls(readout ~ (intS + r) * isSample + intS * isRef + k * log_dose, mLin <- gsl_nls(readout ~ (intS + r) * isSample + intS * isRef + k * log_dose,
data = circle, data = circle,
start = list(intS = 0, k = 1, r = 0), start = list(intS = 0, k = 1, r = 0),
@@ -901,17 +901,17 @@ PlotLinPLA_FUNC <- function(circle, sigmoid, all_l2, pl_df, indS, indT) {
theme_bw() theme_bw()
p2 <- p + geom_line( p2 <- p + geom_line(
data = pl_df, aes(x = lnC, y = plotS), color = "#4545BA", data = pl_df, aes(x = lnC, y = plotS), color = "#4545BA",
inherit.aes = F inherit.aes = FALSE
) + ) +
geom_line( geom_line(
data = pl_df, aes(x = lnC, y = plotT), color = "#C2173F", data = pl_df, aes(x = lnC, y = plotT), color = "#C2173F",
inherit.aes = F inherit.aes = FALSE
) + ) +
{ {
if (!is.null(truePL_df)) { if (!is.null(truePL_df)) {
geom_line( geom_line(
data = data.frame(truePL_df), aes(x = seq_x, y = SAMPLEtrue), color = "#C2173F", linetype = 2, alpha = 0.4, data = data.frame(truePL_df), aes(x = seq_x, y = SAMPLEtrue), color = "#C2173F", linetype = 2, alpha = 0.4,
inherit.aes = F inherit.aes = FALSE
) )
} }
} + } +
@@ -919,7 +919,7 @@ PlotLinPLA_FUNC <- function(circle, sigmoid, all_l2, pl_df, indS, indT) {
if (!is.null(truePL_df)) { if (!is.null(truePL_df)) {
geom_line( geom_line(
data = data.frame(truePL_df), aes(x = seq_x, y = REFtrue), color = "#4545BA", linetype = 2, alpha = 0.4, data = data.frame(truePL_df), aes(x = seq_x, y = REFtrue), color = "#4545BA", linetype = 2, alpha = 0.4,
inherit.aes = F inherit.aes = FALSE
) )
} }
} + } +
@@ -939,17 +939,17 @@ PlotLinPLA_FUNC <- function(circle, sigmoid, all_l2, pl_df, indS, indT) {
pr2 <- p + geom_line( pr2 <- p + geom_line(
data = pl_rest, aes(x = lnC, y = plotS), color = "#4545BA", data = pl_rest, aes(x = lnC, y = plotS), color = "#4545BA",
inherit.aes = F inherit.aes = FALSE
) + ) +
geom_line( geom_line(
data = pl_rest, aes(x = lnC, y = plotT), color = "#C2173F", data = pl_rest, aes(x = lnC, y = plotT), color = "#C2173F",
inherit.aes = F inherit.aes = FALSE
) + ) +
{ {
if (!is.null(truePL_df)) { if (!is.null(truePL_df)) {
geom_line( geom_line(
data = data.frame(truePL_df), aes(x = seq_x, y = SAMPLEtrue), color = "#C2173F", linetype = 2, alpha = 0.4, data = data.frame(truePL_df), aes(x = seq_x, y = SAMPLEtrue), color = "#C2173F", linetype = 2, alpha = 0.4,
inherit.aes = F inherit.aes = FALSE
) )
} }
} + } +
@@ -957,7 +957,7 @@ PlotLinPLA_FUNC <- function(circle, sigmoid, all_l2, pl_df, indS, indT) {
if (!is.null(truePL_df)) { if (!is.null(truePL_df)) {
geom_line( geom_line(
data = data.frame(truePL_df), aes(x = seq_x, y = REFtrue), color = "#4545BA", linetype = 2, alpha = 0.4, data = data.frame(truePL_df), aes(x = seq_x, y = REFtrue), color = "#4545BA", linetype = 2, alpha = 0.4,
inherit.aes = F inherit.aes = FALSE
) )
} }
} + } +
@@ -1012,7 +1012,7 @@ pot4plFUNC <- function(ro_new, PureErrFlag) {
CORdat <- cor(ro_new[, 1], ro_new[, ncol(ro_new)]) CORdat <- cor(ro_new[, 1], ro_new[, ncol(ro_new)])
if (CORdat < 0) SLOPE <- -1 else SLOPE <- 1 if (CORdat < 0) SLOPE <- -1 else SLOPE <- 1
# #
FITs <- Fitting_FUNC(ro_new, TransFlag = F) FITs <- Fitting_FUNC(ro_new, TransFlag = FALSE)
if (!PureErrFlag) { if (!PureErrFlag) {
pot_est <- FITs[[3]] pot_est <- FITs[[3]]
potU_est <- FITs[[4]] potU_est <- FITs[[4]]
@@ -1205,10 +1205,10 @@ tests_FUNC <- function(ro_new, Lim, PureErrFlag) {
SSnonlin <- sum((predict(lm(readout ~ factor(Conc) * isSample, all_l)) - predPotU)^2) SSnonlin <- sum((predict(lm(readout ~ factor(Conc) * isSample, all_l)) - predPotU)^2)
LoF_df <- FitAnova[1, 1] + FitAnova[2, 1] LoF_df <- FitAnova[1, 1] + FitAnova[2, 1]
F_regr <- (SSregr / AnovaDFs[3]) / ERR F_regr <- (SSregr / AnovaDFs[3]) / ERR
p_F_regr <- round(pf(F_regr, AnovaDFs[3], ERR_df, lower.tail = F), 5) p_F_regr <- round(pf(F_regr, AnovaDFs[3], ERR_df, lower.tail = FALSE), 5)
if (ncol(ro_new) < 4) F_nonlin <- 0 else F_nonlin <- (SSnonlin / AnovaDFs[6]) / ERR if (ncol(ro_new) < 4) F_nonlin <- 0 else F_nonlin <- (SSnonlin / AnovaDFs[6]) / ERR
if (F_nonlin > 0) { if (F_nonlin > 0) {
p_F_nonlin <- round(pf(F_nonlin, AnovaDFs[6], ERR_df, lower.tail = F), 5) p_F_nonlin <- round(pf(F_nonlin, AnovaDFs[6], ERR_df, lower.tail = FALSE), 5)
} else { } else {
p_F_nonlin <- "SSnonlin neg or single dilutions" p_F_nonlin <- "SSnonlin neg or single dilutions"
} }
@@ -1404,11 +1404,11 @@ ANOVA4plUnresfunc <- function(ro_new) {
MSE <- RSS / RSS_df MSE <- RSS / RSS_df
noConc <- length(unique(all_l$Conc)) noConc <- length(unique(all_l$Conc))
AnovaDFs <- c(noConc - 1, 1, 3, noConc - 4 - 1, nrow(all_l) - noConc, noConc, nrow(all_l) - noConc - noConc, nrow(all_l) - 1) AnovaDFs <- c(noConc - 1, 1, 3, noConc - 4 - 1, nrow(all_l) - noConc, noConc, nrow(all_l) - noConc - noConc, nrow(all_l) - 1)
p_SStreat <- round(pf((SStreat / AnovaDFs[1]) / MSE, AnovaDFs[1], RSS_df, lower.tail = F), 3) p_SStreat <- round(pf((SStreat / AnovaDFs[1]) / MSE, AnovaDFs[1], RSS_df, lower.tail = FALSE), 3)
p_SSprep <- round(pf((SSprep / AnovaDFs[2]) / MSE, AnovaDFs[2], RSS_df, lower.tail = F), 3) p_SSprep <- round(pf((SSprep / AnovaDFs[2]) / MSE, AnovaDFs[2], RSS_df, lower.tail = FALSE), 3)
p_SSregr <- round(pf((SSregr / AnovaDFs[3]) / MSE, AnovaDFs[3], RSS_df, lower.tail = F), 3) p_SSregr <- round(pf((SSregr / AnovaDFs[3]) / MSE, AnovaDFs[3], RSS_df, lower.tail = FALSE), 3)
p_SSnonp <- round(pf((SSnonparallel / AnovaDFs[4]) / MSE, AnovaDFs[3], RSS_df, lower.tail = F), 3) p_SSnonp <- round(pf((SSnonparallel / AnovaDFs[4]) / MSE, AnovaDFs[3], RSS_df, lower.tail = FALSE), 3)
p_SSLoF <- round(pf((SSnonlin / LoF_df) / (SSE / SSE_df), LoF_df, SSE_df, lower.tail = F), 5) p_SSLoF <- round(pf((SSnonlin / LoF_df) / (SSE / SSE_df), LoF_df, SSE_df, lower.tail = FALSE), 5)
ANOVAtab <- data.frame( ANOVAtab <- data.frame(
Source = c( Source = c(
dev/app.R
+162 -125
View File
@@ -104,20 +104,18 @@ server <- function(input, output, session) {
font-family: 'Helvetica Neue', Helvetica, Arial, sans-serif;font-size: 12px;} ")), font-family: 'Helvetica Neue', Helvetica, Arial, sans-serif;font-size: 12px;} ")),
h4("Introduction to the plateflow software"), h4("Introduction to the plateflow software"),
# tags$mark("linear regression"), br(), # tags$mark("linear regression"), br(),
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. ", "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(), "Bring your data in a readable format and start inspecting.", br(),
"Example of EXCEL/csv/numbers file:",br(), "Example of EXCEL/csv/numbers file:", br(),
tags$img(src = "ExampleXL.png", class = "adv_logo", width = "100%"), 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.", "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 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)", "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.", "It is assumed, that the concentrations are in anti-log or in natural log mode.",
), ),
column(6, column(6, )
)
), ),
tabPanel( tabPanel(
"Documentation", "Documentation",
@@ -146,7 +144,7 @@ server <- function(input, output, session) {
3, 3,
# img(src="Screenshot.png", width=200), # img(src="Screenshot.png", width=200),
box( 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") fileInput("iFile", "", accept = ".xlsx")
), ),
uiOutput(outputId = "sheetName"), uiOutput(outputId = "sheetName"),
@@ -186,7 +184,6 @@ server <- function(input, output, session) {
selected = c("1", "2", "3", "4", "5", "6", "7", "8") selected = c("1", "2", "3", "4", "5", "6", "7", "8")
) )
), ),
column(2, column(2,
style = "background: #7FAEFF88", style = "background: #7FAEFF88",
numericInput("lEACratiola", "lower EAC ratio of LAs", 0.005, step = 0.001), numericInput("lEACratiola", "lower EAC ratio of LAs", 0.005, step = 0.001),
@@ -194,16 +191,16 @@ server <- function(input, output, session) {
numericInput("lEACratioSlope", "lower EAC for ratio of slopes", 0.55, step = 0.01), 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("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("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)), numericInput("uEACratioua", "upper EAC for ratio of UAs", 1.33, step = 0.1)
column(2, style = "background: #7FAEFF88", ),
column(2,
style = "background: #7FAEFF88",
numericInput("lowerPot", "lower EAC for potency", 75, step = 1), numericInput("lowerPot", "lower EAC for potency", 75, step = 1),
numericInput("upperPot", "upper EAC for potency", 133, 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("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("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("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) numericInput("uEACdiffla", "upper EAC for diff. of LA", 0.189, step = 0.001)
) )
), ),
tabPanel( tabPanel(
@@ -226,22 +223,29 @@ server <- function(input, output, session) {
tableOutput("AIC"), tableOutput("AIC"),
h5("First row: restricted model; 2nd row: unrestricted model"), h5("First row: restricted model; 2nd row: unrestricted model"),
h5("Smaller values of AIC indicate better fit to the data"), h5("Smaller values of AIC indicate better fit to the data"),
box(title = "Useful information", status = "info", solidHeader = T, width = 12, "", collapsible = T, box(
tableOutput("VarDiagn")) title = "Useful information", status = "info", solidHeader = TRUE, width = 12, "", collapsible = TRUE,
tableOutput("VarDiagn")
)
), ),
column( column(
8, 8,
plotOutput("XLplot"), plotOutput("XLplot"),
htmlOutput("No4PLFitText"), htmlOutput("No4PLFitText"),
DTOutput("pottab4plXL"), DTOutput("pottab4plXL"),
box(title = "Residuals and QQ-plot", status = "info", solidHeader = T, width = 12, "", collapsible = T, box(
plotOutput("diagnplot")), title = "Residuals and QQ-plot", status = "info", solidHeader = TRUE, width = 12, "", collapsible = TRUE,
box(title = "Assay Suitability Tests", status = "info", solidHeader = T, width = 12, "", collapsible = T, plotOutput("diagnplot")
DTOutput("EQtests")), ),
box(
title = "Assay Suitability Tests", status = "info", solidHeader = TRUE, width = 12, "", collapsible = TRUE,
DTOutput("EQtests")
),
DTOutput("pottab4plTransXL"), DTOutput("pottab4plTransXL"),
box(title = "ANOVA", status = "info", solidHeader = T, width = 12, "", collapsible = T, box(
tableOutput("ANOVAXLS")) title = "ANOVA", status = "info", solidHeader = TRUE, width = 12, "", collapsible = TRUE,
tableOutput("ANOVAXLS")
)
) )
) )
) )
@@ -285,14 +289,14 @@ server <- function(input, output, session) {
12, 12,
h3("Tests for linear PLA:"), h3("Tests for linear PLA:"),
box( box(
title = "Suitability tests", status = "primary", solidHeader = T, width = 12, title = "Suitability tests", status = "primary", solidHeader = TRUE, width = 12,
DTOutput("TESTSlin") DTOutput("TESTSlin")
), ),
h5("The estimate is the p-value of the test"), 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("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"), h5("All other tests pass if p-value > 0.05"),
"SST CI for difference of slopes:", "SST CI for difference of slopes:",
#tableOutput("SlopeDiffCI"), # tableOutput("SlopeDiffCI"),
h3("ANOVA for parallel line assay"), h3("ANOVA for parallel line assay"),
DTOutput("ANOVAlin") DTOutput("ANOVAlin")
) )
@@ -437,7 +441,7 @@ server <- function(input, output, session) {
column( column(
8, 8,
box( 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") DT::dataTableOutput("ConctabMeta")
), ),
verbatimTextOutput("logdil") verbatimTextOutput("logdil")
@@ -472,7 +476,7 @@ server <- function(input, output, session) {
8, 8,
"4 PL ANOVA unrestricted", "4 PL ANOVA unrestricted",
box( box(
title = "ANOVA unrestricted", status = "warning", solidHeader = T, width = 12, "", title = "ANOVA unrestricted", status = "warning", solidHeader = TRUE, width = 12, "",
DT::dataTableOutput("ANOVA") DT::dataTableOutput("ANOVA")
), ),
h5("Please note that for the CIs of rel. potency the RSS of the restricted model is used"), 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, 5,
h3("Tests for linear PLA:"), h3("Tests for linear PLA:"),
box( 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") DTOutput("TESTSlinMeta")
), ),
h5("The estimate is the p-value of the test"), 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("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"), h5("All other tests pass if p-value > 0.05"),
box( 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") tableOutput("SummaryModABuMeta")
), ),
h4("Restricted linear model (CSSI):"), h4("Restricted linear model (CSSI):"),
box( 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") tableOutput("SummaryModABMeta")
) )
), ),
@@ -532,7 +536,7 @@ server <- function(input, output, session) {
6, 6,
h3("ANOVA for parallel line assay"), h3("ANOVA for parallel line assay"),
box( 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") DTOutput("ANOVAlinMeta")
), ),
" CI for difference of slopes:", " CI for difference of slopes:",
@@ -572,12 +576,14 @@ server <- function(input, output, session) {
sidebarPanel( sidebarPanel(
width = 3, width = 3,
fluidRow( fluidRow(
column(6, column(
box(title = "Upload multiple worksheets", status = "warning", solidHeader = T, width = 12, "Please upload your EXCEL file here", 6,
fileInput("MiFile", "", accept = ".xlsx")) box(
title = "Upload multiple worksheets", status = "warning", solidHeader = TRUE, width = 12, "Please upload your EXCEL file here",
fileInput("MiFile", "", accept = ".xlsx")
)
) )
) )
), ),
mainPanel( mainPanel(
tabsetPanel( tabsetPanel(
@@ -585,10 +591,11 @@ server <- function(input, output, session) {
tabPanel( tabPanel(
"4pl", "4pl",
box( box(
title = "ANOVA table", status = "primary", solidHeader = T, width = 12, title = "ANOVA table", status = "primary", solidHeader = TRUE, width = 12,
tableOutput("Anovatab") tableOutput("Anovatab")
), ),
column(4, column(
4,
h3("Confidence intervals"), h3("Confidence intervals"),
tableOutput("CIs"), tableOutput("CIs"),
"The confidence interval 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,
@@ -596,7 +603,8 @@ server <- function(input, output, session) {
tableOutput("optimalDils"), tableOutput("optimalDils"),
selectInput(inputId = "scenario", label = "Select an 'optimal' scenario:", choices = c("scenario 2", "scenario 3", "scenario 6", "steep slope")) selectInput(inputId = "scenario", label = "Select an 'optimal' scenario:", choices = c("scenario 2", "scenario 3", "scenario 6", "steep slope"))
), ),
column(5, column(
5,
plotOutput("plotfordilutions"), plotOutput("plotfordilutions"),
h4("in grey: most extreme bend point lines of theoretical samples with 50% and 200% potency"), 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), 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(), "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", "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"), h3("Bend points"),
tableOutput("bps"), tableOutput("bps"),
tableOutput("extremebps"), tableOutput("extremebps"),
@@ -625,7 +634,6 @@ server <- function(input, output, session) {
}) })
v <- reactiveValues(num_dose = 0, next.dose.t = 0) v <- reactiveValues(num_dose = 0, next.dose.t = 0)
sigmoid <- reactive({ sigmoid <- reactive({
@@ -701,13 +709,12 @@ server <- function(input, output, session) {
if (!is.null(input$iFile)) { if (!is.null(input$iFile)) {
if (!is.null(input$sheet)) { if (!is.null(input$sheet)) {
if (input$sheet != "please choose") { if (input$sheet != "please choose") {
Dat$RepIdentifier <- input$RepIdentifier Dat$RepIdentifier <- input$RepIdentifier
Dat$Author <- input$Author Dat$Author <- input$Author
Dat$NoP <- input$NoP Dat$NoP <- input$NoP
Dat$Assay <- input$Assay Dat$Assay <- input$Assay
Dat$FITsFlag <- FALSE Dat$FITsFlag <- FALSE
#browser() # browser()
XLdat <- Dat$wb[input$sheet][[1]] XLdat <- Dat$wb[input$sheet][[1]]
if (is.null(XLdat)) XLdat <- Dat$wb[Dat$sheets[1]][[1]] if (is.null(XLdat)) XLdat <- Dat$wb[Dat$sheets[1]][[1]]
cn <- colnames(XLdat) cn <- colnames(XLdat)
@@ -778,30 +785,61 @@ server <- function(input, output, session) {
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 havea several reasons: \nA control sample was tested/\n
the EC50 is not catched with the dilutions/\n the assay/reader had a problem", 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. "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.") Black line is the true slope at EC50 of REF."
)
}) })
output$No4PLFitText <- renderText(warning_textNo4PLFit()) output$No4PLFitText <- renderText(warning_textNo4PLFit())
output$relpotTestTab <- renderTable({ NULL }) output$relpotTestTab <- renderTable({
output$relpotTestPlot <- renderPlot({ NULL }) NULL
})
output$relpotTestPlot <- renderPlot({
NULL
})
output$AIC <- renderTable({ NULL }) output$AIC <- renderTable({
output$VarDiagn <- renderTable({ NULL }) NULL
})
output$VarDiagn <- renderTable({
NULL
})
output$pottab4plXL <- renderDT({ NULL }) output$pottab4plXL <- renderDT({
output$diagnplot <- renderPlot({ NULL }) NULL
output$EQtests <- renderDT({ NULL }) })
output$diagnplot <- renderPlot({
NULL
})
output$EQtests <- renderDT({
NULL
})
# #
output$pottab4plTransXL <- renderDT({ NULL }) output$pottab4plTransXL <- renderDT({
output$ANOVAXLS <- renderTable({ NULL }) NULL
})
output$ANOVAXLS <- renderTable({
NULL
})
output$coeffs_r <- renderTable({ NULL}) output$coeffs_r <- renderTable({
NULL
})
output$bends_r2 <- renderTable({ NULL }) output$bends_r2 <- renderTable({
output$coeffs_unr <- renderTable({ NULL }) NULL
output$logcoeffs_r <- renderTable({ NULL }) })
output$bends_unr2 <- renderTable({ NULL }) output$coeffs_unr <- renderTable({
output$logcoeffs_unr <- renderTable({ NULL }) NULL
})
output$logcoeffs_r <- renderTable({
NULL
})
output$bends_unr2 <- renderTable({
NULL
})
output$logcoeffs_unr <- renderTable({
NULL
})
return(NULL) return(NULL)
@@ -963,7 +1001,7 @@ server <- function(input, output, session) {
{ {
Filesample Filesample
}, },
rownames = F rownames = FALSE
) )
UnRPLAausw <- data.frame( UnRPLAausw <- data.frame(
@@ -976,7 +1014,7 @@ server <- function(input, output, session) {
Results = unlist(c("UNRESTRICTED", round(coeffsMU, 3), round(potU_est * 100, 3))) Results = unlist(c("UNRESTRICTED", round(coeffsMU, 3), round(potU_est * 100, 3)))
) # von psl_nls ) # 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({ output$coeffs_unr <- renderTable({
UnRPLAausw UnRPLAausw
@@ -1026,7 +1064,7 @@ server <- function(input, output, session) {
bendsAll bendsAll
}, },
digits = 3, digits = 3,
rownames = T rownames = TRUE
) )
REP$PLAausw <- PLAAusw REP$PLAausw <- PLAAusw
@@ -1089,7 +1127,7 @@ server <- function(input, output, session) {
##### Plot XL 4PL ---- ##### Plot XL 4PL ----
output$XLplot <- renderPlot({ output$XLplot <- renderPlot({
XLplot4pl <- plot_f(XLdat2, TransFlag = F) XLplot4pl <- plot_f(XLdat2, TransFlag = FALSE)
REP$XLplot4pl <- XLplot4pl REP$XLplot4pl <- XLplot4pl
XLplot4pl XLplot4pl
@@ -1278,7 +1316,7 @@ server <- function(input, output, session) {
sigmoid <- sigmoid() sigmoid <- sigmoid()
det_sig <- NULL det_sig <- NULL
plot_f(sim2(), TransFlag = F) plot_f(sim2(), TransFlag = FALSE)
}) })
#### Plot 4pl Meta Transformed ---- #### Plot 4pl Meta Transformed ----
@@ -1291,7 +1329,7 @@ server <- function(input, output, session) {
output$PureErrWLogMeta <- renderText(warning_text3()) output$PureErrWLogMeta <- renderText(warning_text3())
sigmoid <- sigmoid() sigmoid <- sigmoid()
det_sig <- NULL 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 REP$testsTab <- tab
tab2 <- tab[1:7, ] tab2 <- tab[1:7, ]
dat <- datatable(tab2, rownames = F, options = list( dat <- datatable(tab2, rownames = FALSE, options = list(
paging = TRUE, paging = TRUE,
dom = "t", dom = "t",
rownames = FALSE rownames = FALSE
)) %>% formatStyle("test_results", )) |> formatStyle("test_results",
target = "row", target = "row",
backgroundColor = styleEqual( backgroundColor = styleEqual(
c(-1, 0, 1), c(-1, 0, 1),
@@ -1391,7 +1429,7 @@ server <- function(input, output, session) {
paging = TRUE, paging = TRUE,
dom = "t" dom = "t"
) )
) %>% formatStyle("test_results", ) |> formatStyle("test_results",
target = "row", target = "row",
backgroundColor = styleEqual( backgroundColor = styleEqual(
c(-1, 0, 1), c(-1, 0, 1),
@@ -1437,7 +1475,7 @@ server <- function(input, output, session) {
paste("R", seq(1, (ncol(tab2) - 1) / 2)), "log_conc" paste("R", seq(1, (ncol(tab2) - 1) / 2)), "log_conc"
) )
dat <- datatable(tab2, options = list( dat <- datatable(tab2, options = list(
paging = T, paging = TRUE,
pageLength = 20, pageLength = 20,
dom = "t" dom = "t"
)) ))
@@ -1462,17 +1500,17 @@ server <- function(input, output, session) {
Dat$Conctab <- Conctab Dat$Conctab <- Conctab
dat <- datatable(Conctab, options = list( dat <- datatable(Conctab, options = list(
paging = T, paging = TRUE,
pageLength = 12, pageLength = 12,
dom = "t" dom = "t"
)) %>% )) |>
formatStyle(0, formatStyle(0,
target = "row", target = "row",
backgroundColor = styleEqual( backgroundColor = styleEqual(
c("avs", "sds", "cv", "avs_test", "sds_test", "cv_test"), c("avs", "sds", "cv", "avs_test", "sds_test", "cv_test"),
c("lightgrey", "lightgreen", "pink", "lightgrey", "lightgreen", "pink") c("lightgrey", "lightgreen", "pink", "lightgrey", "lightgreen", "pink")
) )
) %>% ) |>
formatRound(columns = colnames(Conctab), digits = 3) formatRound(columns = colnames(Conctab), digits = 3)
}) })
@@ -1495,17 +1533,17 @@ server <- function(input, output, session) {
Dat$Conctab <- Conctab Dat$Conctab <- Conctab
dat <- datatable(Conctab, options = list( dat <- datatable(Conctab, options = list(
paging = T, paging = TRUE,
pageLength = 12, pageLength = 12,
dom = "t" dom = "t"
)) %>% )) |>
formatStyle(0, formatStyle(0,
target = "row", target = "row",
backgroundColor = styleEqual( backgroundColor = styleEqual(
c("avs", "sds", "cv", "avs_test", "sds_test", "cv_test"), c("avs", "sds", "cv", "avs_test", "sds_test", "cv_test"),
c("lightgrey", "lightgreen", "pink", "lightgrey", "lightgreen", "pink") c("lightgrey", "lightgreen", "pink", "lightgrey", "lightgreen", "pink")
) )
) %>% ) |>
formatRound(columns = colnames(Conctab), digits = 3) formatRound(columns = colnames(Conctab), digits = 3)
}) })
@@ -1666,9 +1704,9 @@ server <- function(input, output, session) {
Dat$ANOVAMeta <- df[, 4:length(df)] Dat$ANOVAMeta <- df[, 4:length(df)]
dat <- datatable(df2[, 1:3], dat <- datatable(df2[, 1:3],
options = list( 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(-1, 0, 1),
c("pink", "lightgreen", "lightgrey") c("pink", "lightgreen", "lightgrey")
)) ))
@@ -1771,9 +1809,9 @@ server <- function(input, output, session) {
Dat$ANOVA <- df[, 4:length(df)] Dat$ANOVA <- df[, 4:length(df)]
dat <- datatable(df2[, 1:3], dat <- datatable(df2[, 1:3],
options = list( 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(-1, 0, 1),
c("pink", "lightgreen", "lightgrey") c("pink", "lightgreen", "lightgrey")
)) ))
@@ -1788,9 +1826,9 @@ server <- function(input, output, session) {
tab <- ANOVA4plUnresfunc(sim2()) # ,sigmoid tab <- ANOVA4plUnresfunc(sim2()) # ,sigmoid
dat <- datatable(tab, dat <- datatable(tab,
options = list( options = list(
dom = "t", rownames = F dom = "t", rownames = FALSE
) )
) %>% formatStyle("p_value", ) |> formatStyle("p_value",
target = "row", target = "row",
backgroundColor = styleEqual( backgroundColor = styleEqual(
c("p_value"), c("p_value"),
@@ -1807,7 +1845,7 @@ server <- function(input, output, session) {
# dat <- datatable(tab, # dat <- datatable(tab,
# options=list( # options=list(
# dom="t",rownames=F # dom="t",rownames=F
# )) %>% formatStyle("p_value", target="row", # )) |> formatStyle("p_value", target="row",
# backgroundColor = styleEqual(c("p_value"), # backgroundColor = styleEqual(c("p_value"),
# c("lightgrey"))) # c("lightgrey")))
# }) # })
@@ -1833,9 +1871,9 @@ server <- function(input, output, session) {
ANOVAlin <- Dat$ANOVA ANOVAlin <- Dat$ANOVA
dat <- datatable(ANOVAlin, dat <- datatable(ANOVAlin,
options = list( options = list(
dom = "t", rownames = F dom = "t", rownames = FALSE
) )
) %>% formatStyle("p.value", ) |> formatStyle("p.value",
target = "cell", target = "cell",
backgroundColor = styleEqual( backgroundColor = styleEqual(
c("p.value"), c("p.value"),
@@ -1848,9 +1886,9 @@ server <- function(input, output, session) {
ANOVAlin <- Dat$ANOVAMeta ANOVAlin <- Dat$ANOVAMeta
dat <- datatable(ANOVAlin, dat <- datatable(ANOVAlin,
options = list( options = list(
dom = "t", rownames = F dom = "t", rownames = FALSE
) )
) %>% formatStyle("p.value", ) |> formatStyle("p.value",
target = "cell", target = "cell",
backgroundColor = styleEqual( backgroundColor = styleEqual(
c("p.value"), c("p.value"),
@@ -1884,9 +1922,9 @@ server <- function(input, output, session) {
dat <- datatable(LinPotTab, dat <- datatable(LinPotTab,
options = list( options = list(
dom = "t", rownames = F dom = "t", rownames = FALSE
) )
) %>% formatStyle("test_result", ) |> formatStyle("test_result",
target = "row", target = "row",
backgroundColor = styleEqual(c(0, 1), c("#B5C74055", "#F9545488")) backgroundColor = styleEqual(c(0, 1), c("#B5C74055", "#F9545488"))
) )
@@ -1907,9 +1945,9 @@ server <- function(input, output, session) {
pottab <- LinPotTab(circles, Lim, PureErrFlag = PureErrFlag) pottab <- LinPotTab(circles, Lim, PureErrFlag = PureErrFlag)
dat <- datatable(pottab, dat <- datatable(pottab,
options = list( options = list(
dom = "t", rownames = F dom = "t", rownames = FALSE
) )
) %>% formatStyle("test_result", ) |> formatStyle("test_result",
target = "row", target = "row",
backgroundColor = styleEqual(c(0, 1), c("#B5C74055", "#F9545488")) backgroundColor = styleEqual(c(0, 1), c("#B5C74055", "#F9545488"))
) )
@@ -1968,9 +2006,9 @@ server <- function(input, output, session) {
dat <- datatable(pottab4_[1:2, ], dat <- datatable(pottab4_[1:2, ],
options = list( options = list(
digits = 3, 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(0, 1),
c("lightgreen", "pink") c("lightgreen", "pink")
)) ))
@@ -1979,9 +2017,9 @@ server <- function(input, output, session) {
dat <- datatable(pottab4_[3:4, ], dat <- datatable(pottab4_[3:4, ],
options = list( options = list(
digits = 3, 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(0, 1),
c("lightgreen", "pink") c("lightgreen", "pink")
)) ))
@@ -1990,8 +2028,6 @@ server <- function(input, output, session) {
#### 4pl potency table XL ---- #### 4pl potency table XL ----
observe({ observe({
if (is.null(Dat$EXCEL)) { if (is.null(Dat$EXCEL)) {
return(NULL) return(NULL)
} }
@@ -2043,25 +2079,25 @@ server <- function(input, output, session) {
colnames(pottab4_) <- c("model", "potency", "lower95%CI", "upper95%CI", "relative_lower95%CI", "relative_upper95%CI", "test_result") colnames(pottab4_) <- c("model", "potency", "lower95%CI", "upper95%CI", "relative_lower95%CI", "relative_upper95%CI", "test_result")
row.names(pottab4_) <- NULL row.names(pottab4_) <- NULL
REP$pottab4plXL <- pottab4_[1:2, ] REP$pottab4plXL <- pottab4_[1:2, ]
#browser() # browser()
output$pottab4plXL <- DT::renderDataTable({ output$pottab4plXL <- DT::renderDataTable({
dat <- datatable(pottab4_[1:2, ], dat <- datatable(pottab4_[1:2, ],
rownames = F, rownames = FALSE,
options = list( options = list(
digits = 3, 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("passed", "failed"),
c("#B5C74055", "#F9545455") c("#B5C74055", "#F9545455")
)) ))
}) })
output$pottab4plTransXL <- DT::renderDataTable({ output$pottab4plTransXL <- DT::renderDataTable({
dat <- datatable(pottab4_[3:4, -ncol(pottab4_)], dat <- datatable(pottab4_[3:4, -ncol(pottab4_)],
rownames = F, rownames = FALSE,
options = list( options = list(
digits = 3, digits = 3,
paging = T, dom = "t" paging = TRUE, dom = "t"
) )
) )
}) })
@@ -2070,13 +2106,13 @@ server <- function(input, output, session) {
#### Dilutions Simulator ---- #### Dilutions Simulator ----
output$plotfordilutions <- renderPlot({ output$plotfordilutions <- renderPlot({
if (!is.null(Dat$Mws)) if (!is.null(Dat$Mws)) {
AllXL <- Dat$Mws AllXL <- Dat$Mws
}
AllSheets <- Dat$Msheets AllSheets <- Dat$Msheets
for (N_WS in 1:length(AllXL)) { for (N_WS in 1:length(AllXL)) {
datWS <- as.data.frame(AllXL[[N_WS]]) datWS <- as.data.frame(AllXL[[N_WS]])
cn <- colnames(datWS) cn <- colnames(datWS)
@@ -2097,7 +2133,7 @@ server <- function(input, output, session) {
} }
Dat$datWS2 <- datWS2 Dat$datWS2 <- datWS2
FITs <- Fitting_FUNC(datWS2, TransFlag = F) FITs <- Fitting_FUNC(datWS2, TransFlag = FALSE)
pot_est <- FITs[[3]] pot_est <- FITs[[3]]
potU_est <- FITs[[4]] potU_est <- FITs[[4]]
@@ -2106,22 +2142,22 @@ server <- function(input, output, session) {
URMcoeffs <- SU_mu$coefficients URMcoeffs <- SU_mu$coefficients
X <- seq(min(log(datWS23$log_dose)), max(log(datWS2$log_dose)), 0.1) 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))) 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))) 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) dfPlotsigRef <- data.frame(X = X, sigRef = sigRef, Prod = pdfInd)
dfPlotsigTest <- data.frame(X=X, sigTest = sigTest1, Prod = AllSheets[[N_WS]]) dfPlotsigTest <- data.frame(X = X, sigTest = sigTest1, Prod = AllSheets[[N_WS]])
if (!exists("SIGrefDF")) SIGrefDF <- dfPlotsigRef else SIGrefDF <- rbind(SIGrefDF, dfPlotsigRef) if (!exists("SIGrefDF")) SIGrefDF <- dfPlotsigRef else SIGrefDF <- rbind(SIGrefDF, dfPlotsigRef)
if (!exists("SIGtestDF")) SIGtestDF <- dfPlotsigTest else SIGtestDF <- rbind(SIGtestDF,dfPlotsigTest) if (!exists("SIGtestDF")) SIGtestDF <- dfPlotsigTest else SIGtestDF <- rbind(SIGtestDF, dfPlotsigTest)
EC50TEST <- as.numeric(c(URMcoefsDF[,8])) EC50TEST <- as.numeric(c(URMcoefsDF[, 8]))
# EC50TEST <- EC50TEST[!EC50TEST %in% boxplot.stats(EC50TEST)$out] # EC50TEST <- EC50TEST[!EC50TEST %in% boxplot.stats(EC50TEST)$out]
EC50REF <- as.numeric(URMcoefsDF[,4]) EC50REF <- as.numeric(URMcoefsDF[, 4])
# EC50REF <- EC50REF[!EC50REF %in% boxplot.stats(EC50REF)$out] # EC50REF <- EC50REF[!EC50REF %in% boxplot.stats(EC50REF)$out]
UasREF <- as.numeric(URMcoefsDF[,5]) UasREF <- as.numeric(URMcoefsDF[, 5])
# UasREF <- UasREF[!UasREF %in% boxplot.stats(UasREF)$out] # UasREF <- UasREF[!UasREF %in% boxplot.stats(UasREF)$out]
LasREF <- as.numeric(URMcoefsDF[,2]) LasREF <- as.numeric(URMcoefsDF[, 2])
# LasREF <- LasREF[!LasREF %in% boxplot.stats(LasREF)$out] # LasREF <- LasREF[!LasREF %in% boxplot.stats(LasREF)$out]
# #
# Dat$URMcoefsDF <- URMcoefsDF # Dat$URMcoefsDF <- URMcoefsDF
@@ -2129,7 +2165,7 @@ server <- function(input, output, session) {
# Dat$CalcPot <- CalcPot # Dat$CalcPot <- CalcPot
# #
#### sigmoid plots ---- #### sigmoid plots ----
Slope <- as.numeric(URMcoefsDF[1,3]) Slope <- as.numeric(URMcoefsDF[1, 3])
# if (Slope > 0) { # if (Slope > 0) {
# x_UA <- max(X); x_LA <- min(X) # x_UA <- max(X); x_LA <- min(X)
# } else { x_UA <- min(X); x_LA <- max(X) } # } else { x_UA <- min(X); x_LA <- max(X) }
@@ -2185,8 +2221,7 @@ server <- function(input, output, session) {
dils2 <- dils_avsc + av dils2 <- dils_avsc + av
dilfactors <- 1 / exp(dils2 - lag(dils2)) dilfactors <- 1 / exp(dils2 - lag(dils2))
} }
} #for N_WS } # for N_WS
Dat$newDils <- dils2 Dat$newDils <- dils2
@@ -2277,11 +2312,11 @@ server <- function(input, output, session) {
) + ) +
geom_line( geom_line(
data = as.data.frame(pl_df), aes(x = dils2, y = SAMPLE50), color = "grey15", linetype = 2, data = as.data.frame(pl_df), aes(x = dils2, y = SAMPLE50), color = "grey15", linetype = 2,
inherit.aes = F inherit.aes = FALSE
) + ) +
geom_line( geom_line(
data = as.data.frame(pl_df), aes(x = dils2, y = SAMPLE200), color = "grey15", linetype = 2, 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) + 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 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] uCIuAs <- uAsratio[1] + qt(0.975, DF_U) * uAsratio[2]
lCIuAs <- 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] uCIlAs <- lAsratio[1] + qt(0.975, DF_U) * lAsratio[2]
lCIlAs <- 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] uCISlo <- Sloperatio[1] + qt(0.975, DF_U) * Sloperatio[2]
lCISlo <- Sloperatio[1] - qt(0.975, DF_U) * Sloperatio[2] lCISlo <- Sloperatio[1] - qt(0.975, DF_U) * Sloperatio[2]
su <- summary(potU) su <- summary(potU)
@@ -2608,7 +2643,9 @@ server <- function(input, output, session) {
#### download XL 4PL report---- #### download XL 4PL report----
observe({ observe({
if (is.null(Dat$FITsFlag)) return(NULL) if (is.null(Dat$FITsFlag)) {
return(NULL)
}
if (!Dat$FITsFlag) { if (!Dat$FITsFlag) {
browser() browser()
output$downloadXLReport <- downloadHandler( output$downloadXLReport <- downloadHandler(
@@ -2616,10 +2653,10 @@ server <- function(input, output, session) {
content = function(file) { content = function(file) {
tpdr <- tempdir() tpdr <- tempdir()
tempReport <- file.path(tpdr, "Doc_BioassayReport.Rmd") tempReport <- file.path(tpdr, "Doc_BioassayReport.Rmd")
file.copy("Doc_BioassayReport.Rmd", tempReport, overwrite = T) file.copy("Doc_BioassayReport.Rmd", tempReport, overwrite = TRUE)
tempReportc <- file.path(tpdr, "logov2.png") tempReportc <- file.path(tpdr, "logov2.png")
file.copy("logov2.png", tempReportc, overwrite = T) file.copy("logov2.png", tempReportc, overwrite = TRUE)
rmarkdown::render(tempReport, rmarkdown::render(tempReport,
output_file = file, output_file = file,
@@ -2645,10 +2682,10 @@ server <- function(input, output, session) {
content = function(file) { content = function(file) {
tpdr <- tempdir() tpdr <- tempdir()
tempReport <- file.path(tpdr, "Doc_BioassayLinReport.Rmd") 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") tempReportc <- file.path(tpdr, "logov2.png")
file.copy("logov2.png", tempReportc, overwrite = T) file.copy("logov2.png", tempReportc, overwrite = TRUE)
rmarkdown::render(tempReport, rmarkdown::render(tempReport,
output_file = file, output_file = file,