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

app made independent XL and metadata, functions roxygenized

Browse Source
This commit is contained in:
Franz Innerbichler
2026-05-13 15:08:12 +02:00
parent a4bdbe8f8c
commit 1555fe3b6c
2 changed files with 443 additions and 257 deletions
Download Patch File Download Diff File Expand all files Collapse all files
TestFileRoxygen.R
+5 -20
View File
@@ -1,23 +1,8 @@
dat <- data.frame(REF1=c(1.1,1.2,2.1,3,5,6,8.1,9), REF1=c(1.2,1.5,2.1,3.1,4.9,6.1,8.3,9.1), ################################################################################
TEST1=c(1,1.3,2.5,3.5,5.9,6.9,8.1,9.1), TEST2=c(1.4,1.2,2.6,3.4,5.8,6.7,8.6,9.3), log_dose=c(1,0,-1,-2,-3,-4,-5,-6)) # Test file for functions of plateflow
# F. Innerbichler
all_l <- melt(data.frame(dat), id.vars="log_dose", variable.name="replname", value.name = "readout") # 13.5.2026
isRef <- rep(c(1,0),1,each=nrow(all_l)/2) ################################################################################
isSample <- rep(c(0,1),1,each=nrow(all_l)/2)
all_l2 <- cbind(all_l, isRef, isSample)
startlistmu <- list(as=1, bs=-1,cs=-3,
ds=10,at=1, bt=-1,
dt=10,r=0)
mu <- gsl_nls(fn = readout ~ as*isRef + at*isSample + (ds*isRef + dt*isSample - as*isRef - at*isSample)/
(1+isRef*exp(bs*(cs - log_dose)) + isSample*exp(bt*(cs-r*isSample-log_dose))),
data=all_l,
start=startlistmu,
control=gsl_nls_control(xtol=1e-6,ftol=1e-6, gtol=1e-6))
s_mu <- summary(mu)$coefficients[,1]
s_mu
CIRC <- data.frame(log_dose = c(-2.5,-2.5,-2.5, -3.2,-3.2,-3.2,-3.9,-3.9,-3.9, CIRC <- data.frame(log_dose = c(-2.5,-2.5,-2.5, -3.2,-3.2,-3.2,-3.9,-3.9,-3.9,
app.R
+438 -237
View File
@@ -669,6 +669,66 @@ ANOVAlintests <- function(ro_new, circles, Lim, PureErrFlag) {
return(RET) return(RET)
} }
PlotLinPLA_FUNC <-function(circle, sigmoid, all_l2, pl_df, indS, indT) {
mLin <- gsl_nls(readout ~ (intS+r)*isSample + intS*isRef + k*log_dose,
data=circle,
start=list(intS = 0, k=1,r=0),
control = gsl_nls_control(xtol=1e-10,ftol=1e-10,gtol=1e-10))
# alternativ: modAB <- lm(readout ~ log_dose+isSample, circle)
sum_mLin <- summary(mLin)
log_dose <- unique(all_l2$log_dose)
seq_x <- seq(min(log_dose), max(log_dose),0.1)
SAMPLEtrue <- sigmoid[5] + (sigmoid[7]-sigmoid[5])/(1+exp(sigmoid[6]*((sigmoid[4]-sigmoid[8]-seq_x))))
REFtrue <- sigmoid[1] + (sigmoid[3]-sigmoid[1])/(1+exp(sigmoid[2]*((sigmoid[4]-seq_x))))
truePL_df <- cbind(seq_x,SAMPLEtrue, REFtrue)
p <- ggplot(all_l2,aes(x=log_dose,y=readout, color=factor(isRef))) +
geom_point() +
labs(title=paste("linear regression model", indS,indT), color="product") +
scale_colour_manual(labels = c("test","reference"), values=c("#C2173F","#4545BA")) +
ylim(min(all_l2$readout),max(all_l2$readout)) +
theme_bw()
p2 <- p + geom_line(data=pl_df,aes(x=lnC,y=plotS),color="#4545BA",
inherit.aes = F) +
geom_line(data=pl_df,aes(x=lnC,y=plotT),color="#C2173F",
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="#C2173F", linetype=2,alpha=0.4,
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="#4545BA", linetype=2,alpha=0.4,
inherit.aes = F) +
labs(title = paste("unrestricted linear regression model",indS,indT), color="product") +
theme(legend.position="none", axis.text = element_text(size=14))
p3 <- p2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
size=5,alpha=0.2), inherit.aes = FALSE) +
scale_shape_manual(labels=c("test","reference"), values=c(21,21))
# fit intercept for test and ref and common slope
pl_restS <- sum_mLin$coefficients[1,1] + sum_mLin$coefficients[2,1]*log_dose
pl_restT <- sum_mLin$coefficients[1,1] + sum_mLin$coefficients[3,1] + sum_mLin$coefficients[2,1]*log_dose
pl_rest <- data.frame(lnC=log_dose, plotS=pl_restS, plotT=pl_restT)
pr2 <- p + geom_line(data=pl_rest,aes(x=lnC,y=plotS),color="#4545BA",
inherit.aes = F) +
geom_line(data=pl_rest,aes(x=lnC,y=plotT),color="#C2173F",
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="#C2173F", linetype=2,alpha=0.4,
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="#4545BA", linetype=2,alpha=0.4,
inherit.aes = F) +
labs(title = paste("restricted linear regression model",indS,indT), color="product") +
theme(legend.position="none", axis.text = element_text(size=14))
pr3 <- pr2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
size=5,alpha=0.2), inherit.aes = FALSE) +
scale_shape_manual(labels=c("test","reference"), values=c(21,21))
return(grid.arrange(p3,pr3,nrow=1))
}
#' Calculates the potency of 4PL PLA of all models model #' Calculates the potency of 4PL PLA of all models model
#' #'
#' The gradient method is used for calculating the potency for a restricted model, an unrestricteed model, #' The gradient method is used for calculating the potency for a restricted model, an unrestricteed model,
@@ -1247,7 +1307,7 @@ server <- function(input, output, session) {
verbatimTextOutput("sessioninfo")) verbatimTextOutput("sessioninfo"))
) )
}) })
##### UI XL ----
output$Dataupload <- renderUI({ output$Dataupload <- renderUI({
navbarPage(title="Information", navbarPage(title="Information",
tabPanel(title = "Real data", tabPanel(title = "Real data",
@@ -1312,11 +1372,11 @@ server <- function(input, output, session) {
), ),
column(8, column(8,
plotOutput("XLplot"), plotOutput("XLplot"),
DTOutput("pottab4plXL"),
plotOutput("diagnplot"), plotOutput("diagnplot"),
DTOutput("EQtests"), DTOutput("EQtests"),
DTOutput("pottab4pl"),
DTOutput("pottab4plTrans"), DTOutput("pottab4plTransXL"),
tableOutput("ANOVAXLS") tableOutput("ANOVAXLS")
) )
@@ -1335,7 +1395,6 @@ server <- function(input, output, session) {
mainPanel( mainPanel(
tabsetPanel(id="tabs", tabsetPanel(id="tabs",
tabPanel("linear PLA", tabPanel("linear PLA",
column(12, column(12,
htmlOutput("PureErrW3"), htmlOutput("PureErrW3"),
tags$head(tags$style("#PureErrW3{color: red; tags$head(tags$style("#PureErrW3{color: red;
@@ -1348,7 +1407,7 @@ server <- function(input, output, session) {
tableOutput("SummaryModABu"), tableOutput("SummaryModABu"),
h4("Restricted linear model (CSSI):"), h4("Restricted linear model (CSSI):"),
tableOutput("SummaryModAB"), tableOutput("SummaryModAB"),
h3("Tests for linear PLA):"), h3("Tests for linear PLA):"),
box(title="Suitability tests", status="primary",solidHeader = T, width=12, box(title="Suitability tests", status="primary",solidHeader = T, width=12,
DTOutput("TESTSlin")), DTOutput("TESTSlin")),
@@ -1357,9 +1416,10 @@ server <- function(input, output, session) {
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"))
),
tabPanel("Report", tabPanel("Report",
h4("Settings for report") h4("Settings for report")
)) ))
@@ -1396,9 +1456,9 @@ server <- function(input, output, session) {
##### UI Meta ----
output$fourPL <- renderUI({ output$fourPL <- renderUI({
navbarPage(title="4PL", navbarPage(title="4PL+linear reg",
tabPanel("Analysis and Plots", tabPanel("Analysis and Plots",
#sidebarLayout( #sidebarLayout(
# sidebarPanel( # sidebarPanel(
@@ -1410,7 +1470,7 @@ server <- function(input, output, session) {
tabsetPanel(id="tabs", tabsetPanel(id="tabs",
tabPanel("Settings", tabPanel("Settings",
h4("Settings of 4PL regression"), h4("Settings of 4PL regression"),
div(checkboxInput("PureErr4pl", "Should pure error be used for calculation of CIs?", FALSE), div(checkboxInput("PureErrMeta", "Should pure error be used for calculation of CIs?", FALSE),
style = "font-size: 24px !important;color: #C2173F"), style = "font-size: 24px !important;color: #C2173F"),
h4("User help"), h4("User help"),
@@ -1472,7 +1532,10 @@ server <- function(input, output, session) {
sliderInput("outlU","outlier in upper asymptote", min=0, max=1.5,value=0, step=0.1) sliderInput("outlU","outlier in upper asymptote", min=0, max=1.5,value=0, step=0.1)
), ),
h4("log-dilutions from settings above"), h4("log-dilutions from settings above"),
verbatimTextOutput("logdil") verbatimTextOutput("logdil"),
column(8,
box(title = "Simulated data per log-concentration", status="warning",solidHeader = T, width=12, "incl. mean, sd and CV%",
DT::dataTableOutput("ConctabMeta")))
#) #)
), ),
@@ -1487,7 +1550,7 @@ server <- function(input, output, session) {
tags$style(span(htmlOutput("PureErrW3"), style="color: red")), tags$style(span(htmlOutput("PureErrW3"), style="color: red")),
htmlOutput("PureErrW3"), htmlOutput("PureErrW3"),
plotOutput("plot", width = "80%"), plotOutput("plot4plMeta", width = "80%"),
DTOutput("pottab4pl"), DTOutput("pottab4pl"),
"Footnote: test performed on relative CIs.", "Footnote: test performed on relative CIs.",
@@ -1510,18 +1573,51 @@ server <- function(input, output, session) {
h5("SSE ... 'Pure error' in the SumSquares column"), h5("SSE ... 'Pure error' in the SumSquares column"),
h5("RMSE ... Square root of the 'Residual Error' in the MeanSquares column"), h5("RMSE ... Square root of the 'Residual Error' in the MeanSquares column"),
verbatimTextOutput("RMSE") verbatimTextOutput("RMSE")
), )
column(8,
box(title = "Simulated data per log-concentration", status="warning",solidHeader = T, width=12, "incl. mean, sd and CV%",
DT::dataTableOutput("Conctab")))
)) ))
), ),
tabPanel("ln-transformed y", tabPanel("ln-transformed y",
h4("ln-transformed y-axis plots"), h4("ln-transformed y-axis plots"),
plotOutput("plot4plTrans", width = "80%"), plotOutput("plot4plTransMeta", width = "80%"),
DT::dataTableOutput("pottab4plTrans"), DT::dataTableOutput("pottab4plTrans"),
), ),
tabPanel("linear regression",
h4("Evaluations from meta-data"),
htmlOutput("PureErrW3"),
tags$head(tags$style("#PureErrW3{color: red;
font-size: 16px;
font_style: italic;}")),
column(12,
plotOutput("plotLinMeta"),
"Delta method is used for potency CIs",
DTOutput("pottabMeta")
),
column(5,
h3("Tests for linear PLA:"),
box(title="Suitability tests", status="primary",solidHeader = T,collapsible=T, 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,
tableOutput("SummaryModABuMeta")),
h4("Restricted linear model (CSSI):"),
box(title="Restricted linear model (CSSI):", status="primary",solidHeader = T,collapsible=T, width=12,
tableOutput("SummaryModABMeta"))
),
column(6,
h3("ANOVA for parallel line assay"),
box(title="ANOVA for simultated data", status="primary",solidHeader = T, collapsible=T, width=12,
DTOutput("ANOVAlinMeta")),
" CI for difference of slopes:",
tableOutput("SlopeDiffCIMeta"),
)
),
tabPanel("Report", tabPanel("Report",
h4("Settings for report"), h4("Settings for report"),
downloadButton("downloadXLReport", label="Download PDF report", class="butt"), downloadButton("downloadXLReport", label="Download PDF report", class="butt"),
@@ -1795,13 +1891,13 @@ server <- function(input, output, session) {
REP$DiagnTable <- DiagnTable REP$DiagnTable <- DiagnTable
logpotest <- FITsTrans[[3]] #exp(confintd(mrlog, "r", method = "asymptotic")) # compParm(logpot, "c") logpotest <- FITsTrans[[3]] #exp(confintd(mrlog, "r", method = "asymptotic")) # compParm(logpot, "c")
logpotuest <- FITsTrans[[4]] # exp(confintd(mulog, "r", method = "asymptotic")) # compParm(logpotu, "c") logpotUest <- FITsTrans[[4]] # exp(confintd(mulog, "r", method = "asymptotic")) # compParm(logpotu, "c")
# Berechnung der Konfidenzintervalle (CI) # Berechnung der Konfidenzintervalle (CI)
# logpotCI <- c(exp(Smrlog[5,1] - qt(0.975, nrow(all_1)-5) * Smrlog[5,2]), exp(Smrlog[5,1]), exp(Smrlog[5,1] + qt(0.975, nrow(all_1)-5) * Smrlog[5,2])) # logpotCI <- c(exp(Smrlog[5,1] - qt(0.975, nrow(all_1)-5) * Smrlog[5,2]), exp(Smrlog[5,1]), exp(Smrlog[5,1] + qt(0.975, nrow(all_1)-5) * Smrlog[5,2]))
colnames(logpotest) <- c("estimate", "lowerCI", "upperCI") colnames(logpotest) <- c("estimate", "lowerCI", "upperCI")
colnames(logpotuest) <- c("estimate", "lowerCI", "upperCI") colnames(logpotUest) <- c("estimate", "lowerCI", "upperCI")
#browser() #browser()
cnXL <- colnames(XLdat2) 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("File name", "samples"), Test2=c(Dat$FileName, paste(cnXL[1], " vs ", cnXL[4])))
@@ -1839,8 +1935,7 @@ server <- function(input, output, session) {
coeffs_R <- coeffsMR # pot$coefficients coeffs_R <- coeffsMR # pot$coefficients
coeffs_R[5] <- coeffs_R[4] - coeffs_R[5] coeffs_R[5] <- coeffs_R[4] - coeffs_R[5]
names(coeffs_R) <- c("lower A", "slope", "upper A", "EC50 REF", "EC50 TEST") names(coeffs_R) <- c("lower A", "slope", "upper A", "EC50 REF", "EC50 TEST")
# coeffs_R[4] <- log(coeffs_R[4])
# coeffs_R[5] <- log(coeffs_R[5])
# --- Ergebnistabelle: RESTRICTED --- # --- Ergebnistabelle: RESTRICTED ---
PLAAusw <- data.frame( PLAAusw <- data.frame(
Information = c("model", "lower asymptote", "Hill's slope", "upper asymptote","EC50 Ref", Information = c("model", "lower asymptote", "Hill's slope", "upper asymptote","EC50 Ref",
@@ -1856,7 +1951,7 @@ server <- function(input, output, session) {
REP$PLAausw <- PLAAusw REP$PLAausw <- PLAAusw
REP$PLBend <- PLAAusw2 REP$PLBend <- PLAAusw2
# --- Koeffizienten-Extraktion --- #### Koeffizienten-Extraktion ----
logcoeffs_R <- SRlog$coefficients[, 1] # logpot$coefficients logcoeffs_R <- SRlog$coefficients[, 1] # logpot$coefficients
names(logcoeffs_R) <- c("lower A", "Hill's slope", "upper A", "EC50 REF","EC50 DIFF") names(logcoeffs_R) <- c("lower A", "Hill's slope", "upper A", "EC50 REF","EC50 DIFF")
@@ -1867,7 +1962,7 @@ server <- function(input, output, session) {
"EC50 difference", "log relative potency", "EC50 difference", "log relative potency",
"log lower CI", "log upper CI"), "log lower CI", "log upper CI"),
Results = unlist(c("LOG RESTRICTED", round(logcoeffs_R, 3), Results = unlist(c("LOG RESTRICTED", round(logcoeffs_R, 3),
round(logpotest * 100, 3)))) # von gs1_nls round(logpotest * 100, 3)))) # von gsl_nls
output$logcoeffs_r <- renderTable({ LogPLAAusw }) output$logcoeffs_r <- renderTable({ LogPLAAusw })
REP$LogPLAausw <- LogPLAAusw REP$LogPLAausw <- LogPLAAusw
@@ -1885,7 +1980,7 @@ server <- function(input, output, session) {
"relative potency", "lower CI", "upper CI"), "relative potency", "lower CI", "upper CI"),
Results = unlist(c("LOG UNRESTRICTED", round(logcoeffs_UNR, 3), Results = unlist(c("LOG UNRESTRICTED", round(logcoeffs_UNR, 3),
round(logpotest * 100, 3)))) # von gs1_nls round(logpotUest * 100, 3)))) # von gsl_nls
output$logcoeffs_unr <- renderTable({ output$logcoeffs_unr <- renderTable({
LogUnrPLAAusw LogUnrPLAAusw
@@ -1900,7 +1995,7 @@ server <- function(input, output, session) {
} else Dat$dilution <- exp(XLdat[,logI]) } else Dat$dilution <- exp(XLdat[,logI])
# --- Plot-Ausgabe --- # --- Plot-Ausgabe ---
output$XLplot <- renderPlot({ output$XLplot <- renderPlot({
plot_f(XLdat2, sigmoid = NULL, det_sig = coeffsMU, TransFlag=F) plot_f(XLdat2, TransFlag=F)
}) })
REP$XLdat2 <- XLdat2 REP$XLdat2 <- XLdat2
@@ -1967,82 +2062,82 @@ server <- function(input, output, session) {
}) })
#### updateSlider on XLSX ---- #### updateSlider on XLSX ----
observe({ # observe({
if (!is.null(Dat$potDiffXL)) { # if (!is.null(Dat$potDiffXL)) {
updateSliderInput(session, "potencydiff", # updateSliderInput(session, "potencydiff",
value=round(as.numeric(Dat$potDiffXL[[1]]),5)) # value=round(as.numeric(Dat$potDiffXL[[1]]),5))
} # }
}) # })
observeEvent(input$potencydiff, { # observeEvent(input$potencydiff, {
if (!is.null(Dat$potDiffXL)) { # if (!is.null(Dat$potDiffXL)) {
updateSliderInput(session, "potencydiff", # updateSliderInput(session, "potencydiff",
value=round(as.numeric(input$potencydiff),5)) # value=round(as.numeric(input$potencydiff),5))
} # }
}) # })
observe({ # observe({
if (!is.null(Dat$ProzSD_XL)) { # if (!is.null(Dat$ProzSD_XL)) {
updateSliderInput(session, "sdfacf", # updateSliderInput(session, "sdfac",
value=round(as.numeric(Dat$ProzSD_XL[[1]]),5)) # value=round(as.numeric(Dat$ProzSD_XL[[1]]),5))
} # }
}) # })
observeEvent(input$sdfac, { # observeEvent(input$sdfac, {
if (!is.null(Dat$ProzSD_XL)) { # if (!is.null(Dat$ProzSD_XL)) {
updateSliderInput(session, "sdfac", # updateSliderInput(session, "sdfac",
value=round(as.numeric(Dat$ProzSD_XL[[1]]),5)) # value=round(as.numeric(Dat$ProzSD_XL[[1]]),5))
} # }
}) # })
#### updaterNumeric Input ---- #### updaterNumeric Input ----
observe({ # observe({
if(!is.null(Dat$coeffs_UN)) { # if(!is.null(Dat$coeffs_UN)) {
updateNumericInput(session, "lowAsymptREF", # updateNumericInput(session, "lowAsymptREF",
value=round(as.numeric(Dat$coeffs_UN[3]),5), min=0) # value=round(as.numeric(Dat$coeffs_UN[3]),5), min=0)
updateNumericInput(session, "lowAsymptTEST", # updateNumericInput(session, "lowAsymptTEST",
value=round(as.numeric(Dat$coeffs_UN[4]),5), min=0) # value=round(as.numeric(Dat$coeffs_UN[4]),5), min=0)
updateNumericInput(session, "uppAsymptREF", # updateNumericInput(session, "uppAsymptREF",
value=round(as.numeric(Dat$coeffs_UN[5]),5), min=0) # value=round(as.numeric(Dat$coeffs_UN[5]),5), min=0)
updateNumericInput(session, "uppAsymptTEST", # updateNumericInput(session, "uppAsymptTEST",
value=round(as.numeric(Dat$coeffs_UN[6]),5), min=0) # value=round(as.numeric(Dat$coeffs_UN[6]),5), min=0)
updateNumericInput(session, "slopeREF", # updateNumericInput(session, "slopeREF",
value=round(as.numeric(Dat$coeffs_UN[1]),5)) # value=round(as.numeric(Dat$coeffs_UN[1]),5))
updateNumericInput(session, "slopeTEST", # updateNumericInput(session, "slopeTEST",
value=round(as.numeric(Dat$coeffs_UN[2]),5)) # value=round(as.numeric(Dat$coeffs_UN[2]),5))
updateNumericInput(session, "EC50", # updateNumericInput(session, "EC50",
value=round(as.numeric(Dat$coeffs_UN[7]),5)) # value=round(as.numeric(Dat$coeffs_UN[7]),5))
updateNumericInput(session, "potDiff", # updateNumericInput(session, "potDiff",
value=round(as.numeric(Dat$coeffs_UN[7])- as.numeric(Dat$coeffs_UN[8]),5)) # value=round(as.numeric(Dat$coeffs_UN[7])- as.numeric(Dat$coeffs_UN[8]),5))
} # }
}) # })
#
observe({ # observe({
if(!is.null(Dat$dilution)) { # if(!is.null(Dat$dilution)) {
updateNumericInput(session, "CONC1", # updateNumericInput(session, "CONC1",
value=as.numeric(Dat$dilution[1])) # value=as.numeric(Dat$dilution[1]))
updateNumericInput(session, "CONC2", # updateNumericInput(session, "CONC2",
value=as.numeric(Dat$dilution[2])) # value=as.numeric(Dat$dilution[2]))
updateNumericInput(session, "CONC3", # updateNumericInput(session, "CONC3",
value=as.numeric(Dat$dilution[3])) # value=as.numeric(Dat$dilution[3]))
updateNumericInput(session, "CONC4", # updateNumericInput(session, "CONC4",
value=as.numeric(Dat$dilution[4])) # value=as.numeric(Dat$dilution[4]))
updateNumericInput(session, "CONC5", # updateNumericInput(session, "CONC5",
value=as.numeric(Dat$dilution[5])) # value=as.numeric(Dat$dilution[5]))
updateNumericInput(session, "CONC6", # updateNumericInput(session, "CONC6",
value=as.numeric(Dat$dilution[6])) # value=as.numeric(Dat$dilution[6]))
updateNumericInput(session, "CONC7", # updateNumericInput(session, "CONC7",
value=as.numeric(Dat$dilution[7])) # value=as.numeric(Dat$dilution[7]))
updateNumericInput(session, "CONC8", # updateNumericInput(session, "CONC8",
value=as.numeric(Dat$dilution[8])) # value=as.numeric(Dat$dilution[8]))
updateNumericInput(session, "CONC9", # updateNumericInput(session, "CONC9",
value=as.numeric(Dat$dilution[9])) # value=as.numeric(Dat$dilution[9]))
updateNumericInput(session, "CONC10", # updateNumericInput(session, "CONC10",
value=as.numeric(Dat$dilution[10])) # value=as.numeric(Dat$dilution[10]))
updateNumericInput(session, "CONC11", # updateNumericInput(session, "CONC11",
value=as.numeric(Dat$dilution[11])) # value=as.numeric(Dat$dilution[11]))
updateNumericInput(session, "CONC12", # updateNumericInput(session, "CONC12",
value=as.numeric(Dat$dilution[12])) # value=as.numeric(Dat$dilution[12]))
#
} # }
}) # })
observe({ observe({
if(!is.null(Dat$MetaConc)) { if(!is.null(Dat$MetaConc)) {
@@ -2119,33 +2214,33 @@ server <- function(input, output, session) {
####sim2 ---- ####sim2 ----
sim2 <- reactive({ sim2 <- reactive({
tab <- sim() tab <- sim()
if (is.null(Dat$EXCEL)) return(tab) else return(Dat$EXCEL) #if (is.null(Dat$EXCEL)) return(tab) else return(Dat$EXCEL)
}) })
#### Plot 4pl ---- #### Plot 4pl ----
output$plot <- renderPlot({ output$plot4plMeta <- renderPlot({
#browser() #browser()
sigmoid <- sigmoid() sigmoid <- sigmoid()
det_sig=NULL det_sig=NULL
plot_f(sim2(),sigmoid, det_sig, TransFlag = F) plot_f(sim2(), TransFlag = F)
}) })
#### Plot 4pl Transformed ---- #### Plot 4pl Transformed ----
output$plot4plTrans <- renderPlot({ output$plot4plTransMeta <- renderPlot({
#browser() #browser()
sigmoid <- sigmoid() sigmoid <- sigmoid()
det_sig=NULL det_sig=NULL
plot_f(sim2(),sigmoid, det_sig, TransFlag = T) plot_f(sim2(), TransFlag = T)
}) })
#### Testergebnisse für 4PL ---- #### Testergebnisse für 4PL ----
observe({ observe({
if (is.null(sim2())) return(NULL) if (is.null(sim2())) return(NULL)
if (is.null(input$PureErr4pl)) return(NULL) if (is.null(input$PureErrMeta)) return(NULL)
#observeEvent(input$StartCalc,{ #observeEvent(input$StartCalc,{
PureErrFlag <- input$PureErr4pl PureErrFlag <- input$PureErrMeta
warning_text3 <- reactive({ warning_text3 <- reactive({
ifelse(PureErrFlag, 'Pure error selected','') ifelse(PureErrFlag, 'Pure error selected','')
}) })
@@ -2261,6 +2356,31 @@ server <- function(input, output, session) {
dom="t" dom="t"
)) ))
}) })
##### Concentrationtab Meta ----
output$ConctabMeta <- DT::renderDataTable({
if (!is.na(Dils()[1]) & is.na(Dils()[4])) return(NULL)
tab <- sim2()
if (is.character(tab)) stop(tab)
if (!is.na(Dils()[4])) {
noDilSer <- Dils()[4]
} else if (!is.null(Dat$noDilSeriesXL)) {
noDilSer <- Dat$noDilSeriesXL
} else { noDilSer <- 3 }
Conc <- CONC()
Conctab <- perConcTab(tab, noDilSeries = noDilSer)
Dat$Conctab <- Conctab
dat <- datatable(Conctab, options=list(
paging=T,
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)
})
output$Conctab <- DT::renderDataTable({ output$Conctab <- DT::renderDataTable({
if (!is.na(Dils()[1]) & is.na(Dils()[4])) return(NULL) if (!is.na(Dils()[1]) & is.na(Dils()[4])) return(NULL)
@@ -2287,10 +2407,10 @@ server <- function(input, output, session) {
) %>% formatRound(columns=colnames(Conctab), digits=3) ) %>% formatRound(columns=colnames(Conctab), digits=3)
}) })
#### linear Plot output ---- #### process XL linearly, Plot output ----
output$plotLin <- renderPlot({ output$plotLin <- renderPlot({
if (is.null(Dat$EXCEL)) return(NULL)
tab <- Dat$EXCEL tab <- Dat$EXCEL
# tab <- sim2() # tab <- sim2()
@@ -2336,70 +2456,25 @@ server <- function(input, output, session) {
Dat$circles <- circle Dat$circles <- circle
#browser() #browser()
mLin <- gsl_nls(readout ~ (intS+r)*isSample + intS*isRef + k*log_dose,
data=circle,
start=list(intS = 0, k=1,r=0),
control = gsl_nls_control(xtol=1e-10,ftol=1e-10,gtol=1e-10))
# alternativ: modAB <- lm(readout ~ log_dose+isSample, circle)
sum_mLin <- summary(mLin)
sigmoid <- Dat$coeffsMUnr sigmoid <- Dat$coeffsMUnr
log_dose <- unique(all_l$log_dose)
seq_x <- seq(min(log_dose), max(log_dose),0.1)
SAMPLEtrue <- sigmoid[5] + (sigmoid[7]-sigmoid[5])/(1+exp(sigmoid[6]*((sigmoid[4]-sigmoid[8]-seq_x))))
REFtrue <- sigmoid[1] + (sigmoid[3]-sigmoid[1])/(1+exp(sigmoid[2]*((sigmoid[4]-seq_x))))
truePL_df <- cbind(seq_x,SAMPLEtrue, REFtrue)
p <- ggplot(all_l2,aes(x=log_dose,y=readout, color=factor(isRef))) +
geom_point() +
labs(title=paste("linear regression model", indS,indT), color="product") +
scale_colour_manual(labels = c("test","reference"), values=c("#C2173F","#4545BA")) +
ylim(min(all_l2$readout),max(all_l2$readout)) +
theme_bw()
p2 <- p + geom_line(data=pl_df,aes(x=lnC,y=plotS),color="#4545BA",
inherit.aes = F) +
geom_line(data=pl_df,aes(x=lnC,y=plotT),color="#C2173F",
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="#C2173F", linetype=2,alpha=0.4,
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="#4545BA", linetype=2,alpha=0.4,
inherit.aes = F) +
labs(title = paste("unrestricted linear regression model",indS,indT), color="product") +
theme(legend.position="none", axis.text = element_text(size=14))
p3 <- p2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
size=5,alpha=0.2), inherit.aes = FALSE) +
scale_shape_manual(labels=c("test","reference"), values=c(21,21))
# fit intercept for test and ref and common slope
pLin <- PlotLinPLA_FUNC(circle, sigmoid = sigmoid, all_l2, pl_df, indS, indT)
pl_restS <- sum_mLin$coefficients[1,1] + sum_mLin$coefficients[2,1]*log_conc
pl_restT <- sum_mLin$coefficients[1,1] + sum_mLin$coefficients[3,1] + sum_mLin$coefficients[2,1]*log_conc
pl_rest <- data.frame(lnC=log_conc, plotS=pl_restS, plotT=pl_restT) pLin
pr2 <- p + geom_line(data=pl_rest,aes(x=lnC,y=plotS),color="#4545BA",
inherit.aes = F) +
geom_line(data=pl_rest,aes(x=lnC,y=plotT),color="#C2173F",
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="#C2173F", linetype=2,alpha=0.4,
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="#4545BA", linetype=2,alpha=0.4,
inherit.aes = F) +
labs(title = paste("restricted linear regression model",indS,indT), color="product") +
theme(legend.position="none", axis.text = element_text(size=14))
pr3 <- pr2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
size=5,alpha=0.2), inherit.aes = FALSE) +
scale_shape_manual(labels=c("test","reference"), values=c(21,21))
grid.arrange(p3,pr3,nrow=1)
}) })
#### process metadata, Plot output ----
output$plotLin2 <- renderPlot({ output$plotLinMeta <- renderPlot({
tab <- sim2() tab <- sim2()
if(is.null(tab)) return(NULL)
if (is.character(tab)) stop(tab) if (is.character(tab)) stop(tab)
#browser() #browser()
if (!is.na(Dils()[4])) noDilSer <- Dils()[4] else noDilSer = (ncol(tab)-1)/2 if (!is.na(Dils()[4])) noDilSer <- Dils()[4] else noDilSer = (ncol(tab)-1)/2
Conc <- CONC() Conc <- CONC()
Conctab <- Dat$Conctab log_conc <- log(Conc)
Conctab <- perConcTab(tab, noDilSer)
if (!is.na(Dils()[3])) noDil <- Dils()[3] else noDil = length(Conc) if (!is.na(Dils()[3])) noDil <- Dils()[3] else noDil = length(Conc)
slopeSt <- slopeTe <- matrix(NA, nrow=noDil-2,ncol=2) slopeSt <- slopeTe <- matrix(NA, nrow=noDil-2,ncol=2)
@@ -2434,67 +2509,56 @@ server <- function(input, output, session) {
circleT <- all_mT[(indT*noDilSer-(noDilSer-1)):((indT+2)*noDilSer),] circleT <- all_mT[(indT*noDilSer-(noDilSer-1)):((indT+2)*noDilSer),]
circle <- rbind(circleS,circleT) circle <- rbind(circleS,circleT)
Dat$circles <- circle Dat$circlesMeta <- circle
sigmoid <- sigmoid() sigmoid <- sigmoid()
log_dose <- unique(all_l$log_dose) #browser()
seq_x <- seq(min(log_dose), max(log_dose),0.1) pLin2 <- PlotLinPLA_FUNC(circle, sigmoid = sigmoid, all_l2, pl_df,indS, indT)
SAMPLEtrue <- sigmoid[2] + (sigmoid[4]-sigmoid[2])/(1+exp(sigmoid[6]*((sigmoid[7]-log(input$potencydiff/100)-seq_x)))) pLin2
REFtrue <- sigmoid[1] + (sigmoid[3]-sigmoid[1])/(1+exp(sigmoid[5]*((sigmoid[7]-seq_x))))
truePL_df <- cbind(seq_x,SAMPLEtrue, REFtrue)
p <- ggplot(all_l2,aes(x=log_dose,y=readout, color=factor(isRef))) +
geom_point() +
labs(title=paste("linear regression model", indS,indT), color="product") +
scale_colour_manual(labels = c("test","reference"), values=c("red","blue")) +
ylim(min(all_l2$readout),max(all_l2$readout)) +
theme_bw()
p2 <- p + geom_line(data=pl_df,aes(x=lnC,y=plotS),color="blue",
inherit.aes = F) +
geom_line(data=pl_df,aes(x=lnC,y=plotT),color="red",
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="red", linetype=2,alpha=0.4,
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="blue", linetype=2,alpha=0.4,
inherit.aes = F) +
labs(title = paste("unrestricted linear regression model",indS,indT), color="product") +
theme(legend.position="none", axis.text = element_text(size=14))
p3 <- p2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
size=5,alpha=0.2), inherit.aes = FALSE) +
scale_shape_manual(labels=c("test","reference"), values=c(21,21))
mLin <- gsl_nls(readout ~ (intS+r)*isSample + intS*isRef + k*log_dose,
data=circle,
start=list(intS = 0, k=1,r=0),
control = gsl_nls_control(xtol=1e-10,ftol=1e-10,gtol=1e-10))
# alternativ: modAB <- lm(readout ~ log_dose+isSample, circle)
sum_mLin <- summary(mLin)
pl_restS <- sum_mLin$coefficients[1,1] + sum_mLin$coefficients[2,1]*log_conc
pl_restT <- sum_mLin$coefficients[1,1] + sum_mLin$coefficients[3,1] + sum_mLin$coefficients[2,1]*log_conc
pl_rest <- data.frame(lnC=log_conc, plotS=pl_restS, plotT=pl_restT)
pr2 <- p + geom_line(data=pl_rest,aes(x=lnC,y=plotS),color="blue",
inherit.aes = F) +
geom_line(data=pl_rest,aes(x=lnC,y=plotT),color="red",
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="red", linetype=2,alpha=0.4,
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="blue", linetype=2,alpha=0.4,
inherit.aes = F) +
labs(title = paste("restricted linear regression model",indS,indT), color="product") +
theme(legend.position="none", axis.text = element_text(size=14))
pr3 <- pr2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
size=5,alpha=0.2), inherit.aes = FALSE) +
scale_shape_manual(labels=c("test","reference"), values=c(21,21))
grid.arrange(p3,pr3,nrow=1)
}) })
#### linear PLA tests ---- #### linear PLA tests Metadata ----
output$TESTSlin <- DT::renderDataTable({ output$TESTSlinMeta <- DT::renderDataTable({
tab <- sim2() tab <- sim2()
if (is.character(tab)) stop(tab) if (is.null(tab)) return(NULL)
Conc <- CONC() Conc <- CONC()
Limite <- Dat$limite
circlesMeta <- Dat$circlesMeta
PureErrFlag <- input$PureErrMeta
warning_text <- reactive({
ifelse(PureErrFlag, 'Pure error is selected','')
})
output$PureErrW <- renderText(warning_text())
browser()
LIN <- ANOVAlintests(tab,circlesMeta,Limite,PureErrFlag=PureErrFlag)
df <- LIN[[1]]
su_modU <- LIN[[2]]
su_mod2 <- LIN[[4]]
output$SummaryModABuMeta <- renderTable({ su_modU }, digits=5)
output$SummaryModABMeta <- renderTable({ su_mod2 }, digits=5)
slopeDiffCI <- t(data.frame(LIN[[3]]))
colnames(slopeDiffCI) <- c("slope difference","lower CI","upper CI")
output$SlopeDiffCIMeta <- renderTable({ slopeDiffCI },digits=5)
SelTestsL <- as.numeric(input$selectedSSTsLinear)
df2 <- df
Dat$ANOVAMeta <- 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")))
})
#### linear PLA tests XLinput ----
output$TESTSlin <- DT::renderDataTable({
tab <- Dat$EXCEL
if (is.character(tab)) stop(tab)
Conc <- exp(tab$log_dose)
Limite <- list(as.numeric(input$lEACdiffla), as.numeric(input$uEACdiffla), Limite <- list(as.numeric(input$lEACdiffla), as.numeric(input$uEACdiffla),
as.numeric(input$lEACratiola), as.numeric(input$uEACratiola), as.numeric(input$lEACratiola), as.numeric(input$uEACratiola),
as.numeric(input$lEACratioSlope), as.numeric(input$uEACratioSlope), as.numeric(input$lEACratioSlope), as.numeric(input$uEACratioSlope),
@@ -2502,14 +2566,49 @@ server <- function(input, output, session) {
as.numeric(input$lowerPot), as.numeric(input$upperPot), as.numeric(input$lowerPot), as.numeric(input$upperPot),
as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff)) as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff))
circles <- Dat$circles noDil <- nrow(tab)
noDilSer <- Dat$noDilSeriesXL
Conctab <- perConcTab(tab, noDilSeries = noDilSer)
#browser()
slopeSt <- slopeTe <- matrix(NA, nrow=noDil-2,ncol=2)
for (i in 1:(noDil-2)) {
avs <- Conctab[noDilSer+1,]
threes <- data.frame(lnC=log(Conc[i:(i+2)]), resp=avs[i:(i+2)])
lm3St <- lm(resp ~ lnC, data=threes)
slopeSt[i,] <- lm3St$coefficients
avt <- Conctab[noDilSer*2+4,]
threet <- data.frame(lnC=log(Conc[i:(i+2)]), resp=avt[i:(i+2)])
lm3Te <- lm(resp ~ lnC, data=threet)
slopeTe[i,] <- lm3Te$coefficients
}
indS <- which(abs(slopeSt[,2]) == max(abs(slopeSt[,2])))
indT <- which(abs(slopeTe[,2]) == max(abs(slopeTe[,2])))
# pl_ <- slopeSt[indS,1]+slopeSt[indS,2]*log_conc
# pl_T <- slopeTe[indT,1]+slopeTe[indT,2]*log_conc
# pl_df <- data.frame(lnC=log_conc, plotS=pl_, plotT=pl_T)
all_l <- melt(data.frame(tab), id.vars="log_dose",variable.name="replname",value.name="readout")
isRef <- rep(c(1,0), 1,each=nrow(all_l)/2)
isSample <- rep(c(0,1), 1,each=nrow(all_l)/2)
all_l2 <- cbind(all_l,isRef, isSample)
all_l2S <- all_l2[all_l2$isRef == 1,]
all_l2T <- all_l2[all_l2$isRef == 0,]
all_mS <- all_l2S[order(all_l2S$log_dose, decreasing=TRUE),]
all_mT <- all_l2T[order(all_l2T$log_dose, decreasing=TRUE),]
circleS <- all_mS[(indS*noDilSer-(noDilSer-1)):((indS+2)*noDilSer),]
circleT <- all_mT[(indT*noDilSer-(noDilSer-1)):((indT+2)*noDilSer),]
circle <- rbind(circleS,circleT)
PureErrFlag <- input$PureErr PureErrFlag <- input$PureErr
warning_text <- reactive({ warning_text <- reactive({
ifelse(PureErrFlag, 'Pure error is selected','') ifelse(PureErrFlag, 'Pure error is selected','')
}) })
output$PureErrW <- renderText(warning_text()) output$PureErrW3 <- renderText(warning_text())
#browser()
LIN <- ANOVAlintests(tab,circles,Limite,PureErrFlag=PureErrFlag) LIN <- ANOVAlintests(tab,circle,Limite,PureErrFlag=PureErrFlag)
df <- LIN[[1]] df <- LIN[[1]]
su_modU <- LIN[[2]] su_modU <- LIN[[2]]
su_mod2 <- LIN[[4]] su_mod2 <- LIN[[4]]
@@ -2533,7 +2632,7 @@ server <- function(input, output, session) {
}) })
#### output 4PL ANOVA tests --- #### output 4PL ANOVA tests Meta ----
output$ANOVA <- DT::renderDataTable({ output$ANOVA <- DT::renderDataTable({
sigmoid <- sigmoid() sigmoid <- sigmoid()
tab <- ANOVA4plUnresfunc(sim2()) # ,sigmoid tab <- ANOVA4plUnresfunc(sim2()) # ,sigmoid
@@ -2545,18 +2644,33 @@ server <- function(input, output, session) {
c("lightgrey"))) c("lightgrey")))
}) })
#### output 4PL ANOVA tests XL ----
# not needed
# output$ANOVA_XL <- DT::renderDataTable({
# tab <- Dat$EXCEL
# tab <- ANOVA4plUnresfunc(sim2()) # ,sigmoid
# dat <- datatable(tab,
# options=list(
# dom="t",rownames=F
# )) %>% formatStyle("p_value", target="row",
# backgroundColor = styleEqual(c("p_value"),
# c("lightgrey")))
# })
#### output RMSEs ---- #### output RMSEs ----
output$RMSE <- renderText({ output$RMSE <- renderText({
paste("RMSE (unrestricted model):", Dat$RMSE_unr, "(~ entered % upper-lower asymptote)\n", paste("RMSE (unrestricted model):", Dat$RMSE_unr, "(Use it to compare against RMSE restr. model for non-parallelism)\n",
"RMSE restricted model:", Dat$RMSE_r, "\n", "RMSE (restricted model):", Dat$RMSE_r, "\n",
"Pure RMSE unrestricted model:", Dat$RMSE_pure, "\n", "Pure RMSE (unrestricted model):", Dat$RMSE_pure, "\n",
"%SD (unr model): ", Dat$RMSE_unr*100/Dat$up_lowAs, "(calculated as: RMSE/(upper-lower Asymptote)*100\n", "%SD (unr. model): ", Dat$RMSE_unr*100/Dat$up_lowAs, "(calculated as: RMSE/(upper-lower Asymptote)*100\n",
"RMSE (log restr. model): ", Dat$RMSE_Rlog, "\n", "RMSE (log restr. model): ", Dat$RMSE_Rlog, "\n",
"RMSE (log unrestr. model): ", Dat$RMSE_Ulog, "\n", "RMSE (log unrestr. model): ", Dat$RMSE_Ulog, "\n",
"%SDlog (unr model): ", Dat$RMSE_Ulog*100/Dat$up_lowAslog ) "%SDlog (unr model): ", Dat$RMSE_Ulog*100/Dat$up_lowAslog )
}) })
output$ANOVAlin <- DT::renderDataTable({ output$ANOVAlin <- DT::renderDataTable({
if (is.null(Dat$ANOVA)) return(NULL)
ANOVAlin <- Dat$ANOVA ANOVAlin <- Dat$ANOVA
dat <- datatable(ANOVAlin, dat <- datatable(ANOVAlin,
options=list( options=list(
@@ -2565,9 +2679,19 @@ server <- function(input, output, session) {
backgroundColor = styleEqual(c("p.value"), backgroundColor = styleEqual(c("p.value"),
c("lightgrey"))) c("lightgrey")))
}) })
### output pot tab ----
output$ANOVAlinMeta <- DT::renderDataTable({
ANOVAlin <- Dat$ANOVAMeta
dat <- datatable(ANOVAlin,
options=list(
dom="t",rownames=F
)) %>% formatStyle("p.value", target='cell',
backgroundColor = styleEqual(c("p.value"),
c("lightgrey")))
})
#### output Lin pot tab XL ----
output$pottab <- DT::renderDataTable({ output$pottab <- DT::renderDataTable({
if (is.null(Dat$circles)) return(NULL)
Lim <- list(as.numeric(input$lEACdiffla), as.numeric(input$uEACdiffla), Lim <- list(as.numeric(input$lEACdiffla), as.numeric(input$uEACdiffla),
as.numeric(input$lEACratiola), as.numeric(input$uEACratiola), as.numeric(input$lEACratiola), as.numeric(input$uEACratiola),
as.numeric(input$lEACratioSlope), as.numeric(input$uEACratioSlope), as.numeric(input$lEACratioSlope), as.numeric(input$uEACratioSlope),
@@ -2582,17 +2706,38 @@ server <- function(input, output, session) {
options=list( options=list(
dom="t",rownames=F dom="t",rownames=F
)) %>% formatStyle("test_result", target='row', )) %>% formatStyle("test_result", target='row',
backgroundColor = styleEqual(c(0,1), c("lightgrey"))) backgroundColor = styleEqual(c(0,1), c("lightgrey","#F9545488")))
}) })
#### 4pl potency table ----
### output pot tab Meta ----
output$pottabMeta <- DT::renderDataTable({
Lim <- list(as.numeric(input$lEACdiffla), as.numeric(input$uEACdiffla),
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))
circles <- Dat$circlesMeta
PureErrFlag <- input$PureErrMeta
pottab <- LinPotTab(circles,Lim,PureErrFlag = PureErrFlag)
#browser()
dat <- datatable(pottab,
options=list(
dom="t",rownames=F
)) %>% formatStyle("test_result", target='row',
backgroundColor = styleEqual(c(0,1), c("lightgrey","#F9545488")))
})
#### 4pl potency table Meta ----
observe({ observe({
#browser() #browser()
if (is.null(sim2()) | is.null(Dils())) return(NULL) if (is.null(sim2()) | is.null(Dils())) return(NULL)
ro_new <- sim2() ro_new <- sim2()
Dils_ <- Dils() Dils_ <- Dils()
if (!is.na(Dils()[4])) noDilSer <- Dils()[4] else noDilSer <- 3 if (!is.na(Dils()[4])) noDilSer <- Dils()[4] else noDilSer <- 3
PureErrFl <- input$PureErr4pl PureErrFl <- input$PureErrMeta
pottab4 <- pot4plFUNC(ro_new = ro_new, PureErrFlag = PureErrFl) pottab4 <- pot4plFUNC(ro_new = ro_new, PureErrFlag = PureErrFl)
#browser() #browser()
Lim <- list(as.numeric(input$lEACdiffla), as.numeric(input$uEACdiffla), Lim <- list(as.numeric(input$lEACdiffla), as.numeric(input$uEACdiffla),
@@ -2640,6 +2785,62 @@ server <- function(input, output, session) {
}) })
}) })
#### 4pl potency table XL ----
observe({
#browser()
if (is.null(Dat$EXCEL)) return(NULL)
ro_new <- Dat$EXCEL
noDilSer <- Dat$noDilSeriesXL
PureErrFl <- input$PureErr
pottab4 <- pot4plFUNC(ro_new = ro_new, PureErrFlag = PureErrFl)
#browser()
Lim <- list(as.numeric(input$lEACdiffla), as.numeric(input$uEACdiffla),
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))
pottab4_ <- data.frame(pottab4)
pottab4_$potency <- round(as.numeric(pottab4[,2])*100,1)
pottab4_$`lower95%CI` <- round(as.numeric(pottab4[,3])*100,2)
pottab4_$`upper95%CI` <- round(as.numeric(pottab4[,4])*100,2)
pottab4_$relative_lowerCL <- round(pottab4_[,6]/pottab4_[,5]*100,2)
pottab4_$relative_upperCL <- round(pottab4_[,7]/pottab4_[,5]*100,2)
if (as.numeric(pottab4_$relative_lowerCL[1]) > Lim[[9]] & as.numeric(pottab4_$relative_upperCL[1]) < Lim[[10]] ) {
test_potCI <- 0
} else {test_potCI <- 1 }
if (as.numeric(pottab4_$relative_lowerCL[2]) > Lim[[9]] & as.numeric(pottab4_$relative_upperCL[2]) < Lim[[10]] ) {
test_potUCI <- 0
} else {test_potUCI <- 1 }
if (as.numeric(pottab4_$relative_lowerCL[3]) > Lim[[9]] & as.numeric(pottab4_$relative_upperCL[3]) < Lim[[10]] ) {
test_potCI_t <- 0
} else {test_potCI_t <- 1 }
if (as.numeric(pottab4_$relative_lowerCL[4]) > Lim[[9]] & as.numeric(pottab4_$relative_upperCL[4]) < Lim[[10]] ) {
test_potUCI_t <- 0
} 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")
output$pottab4plXL <- DT::renderDataTable({
dat <- datatable(pottab4_[1:2,],
options=list(digits=3,
paging=T, dom="t",rownames=F
)) %>% formatStyle("test_result", target="row",backgroundColor = styleEqual(c(0,1),
c("#B5C74055","#F9545455")))
})
output$pottab4plTransXL <- DT::renderDataTable({
dat <- datatable(pottab4_[3:4,],
options=list(digits=3,
paging=T, dom="t",rownames=F
)) %>% formatStyle("test_result", target="row",backgroundColor = styleEqual(c(0,1),
c("#B5C74055","#F9545455")))
})
})
#### Dilutions Simulator ---- #### Dilutions Simulator ----
output$plotfordilutions <- renderPlot({ output$plotfordilutions <- renderPlot({
tab <- sim2() tab <- sim2()
@@ -2686,7 +2887,7 @@ server <- function(input, output, session) {
Xbend200u <- sigmoid[7] - 0.693147+1.5434/sigmoid[5] Xbend200u <- sigmoid[7] - 0.693147+1.5434/sigmoid[5]
Xbend50 <- max(Xbend50l, Xbend50u) Xbend50 <- max(Xbend50l, Xbend50u)
Xbend200 <- min(Xbend200l, Xbend200u) Xbend200 <- min(Xbend200l, Xbend200u)
dummy <- plot_f(tab,sigmoid,det_sig=NULL) dummy <- plot_f(tab)
} else { } else {
#browser() #browser()
@@ -2698,7 +2899,7 @@ server <- function(input, output, session) {
Xbend200u <- det_sig[7] - 0.693147+1.5434/det_sig[1] Xbend200u <- det_sig[7] - 0.693147+1.5434/det_sig[1]
Xbend50 <- max(Xbend50l, Xbend50u) Xbend50 <- max(Xbend50l, Xbend50u)
Xbend200 <- min(Xbend200l, Xbend200u) Xbend200 <- min(Xbend200l, Xbend200u)
dummy <- plot_f(tab,sigmoid=NULL,det_sig=det_sig) dummy <- plot_f(tab)
} }