From 1555fe3b6c6b64a9c7bdbd4c2f55576119cd0222 Mon Sep 17 00:00:00 2001 From: Franz Innerbichler Date: Wed, 13 May 2026 15:08:12 +0200 Subject: [PATCH] app made independent XL and metadata, functions roxygenized --- TestFileRoxygen.R | 25 +- app.R | 675 ++++++++++++++++++++++++++++++---------------- 2 files changed, 443 insertions(+), 257 deletions(-) diff --git a/TestFileRoxygen.R b/TestFileRoxygen.R index e2537cd..48d6737 100644 --- a/TestFileRoxygen.R +++ b/TestFileRoxygen.R @@ -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)) - -all_l <- melt(data.frame(dat), id.vars="log_dose", variable.name="replname", value.name = "readout") -isRef <- rep(c(1,0),1,each=nrow(all_l)/2) -isSample <- rep(c(0,1),1,each=nrow(all_l)/2) -all_l2 <- cbind(all_l, isRef, isSample) - -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 +################################################################################ +# Test file for functions of plateflow +# F. Innerbichler +# 13.5.2026 +################################################################################ CIRC <- data.frame(log_dose = c(-2.5,-2.5,-2.5, -3.2,-3.2,-3.2,-3.9,-3.9,-3.9, diff --git a/app.R b/app.R index 1f72925..723cd91 100644 --- a/app.R +++ b/app.R @@ -669,6 +669,66 @@ ANOVAlintests <- function(ro_new, circles, Lim, PureErrFlag) { 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 #' #' 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")) ) }) - + ##### UI XL ---- output$Dataupload <- renderUI({ navbarPage(title="Information", tabPanel(title = "Real data", @@ -1312,11 +1372,11 @@ server <- function(input, output, session) { ), column(8, plotOutput("XLplot"), - + DTOutput("pottab4plXL"), plotOutput("diagnplot"), DTOutput("EQtests"), - DTOutput("pottab4pl"), - DTOutput("pottab4plTrans"), + + DTOutput("pottab4plTransXL"), tableOutput("ANOVAXLS") ) @@ -1335,7 +1395,6 @@ server <- function(input, output, session) { mainPanel( tabsetPanel(id="tabs", tabPanel("linear PLA", - column(12, htmlOutput("PureErrW3"), tags$head(tags$style("#PureErrW3{color: red; @@ -1348,7 +1407,7 @@ server <- function(input, output, session) { tableOutput("SummaryModABu"), h4("Restricted linear model (CSSI):"), tableOutput("SummaryModAB"), - + h3("Tests for linear PLA):"), box(title="Suitability tests", status="primary",solidHeader = T, width=12, DTOutput("TESTSlin")), @@ -1357,9 +1416,10 @@ server <- function(input, output, session) { h5("All other tests pass if p-value > 0.05"), "SST CI for difference of slopes:", tableOutput("SlopeDiffCI"), - + h3("ANOVA for parallel line assay"), - DTOutput("ANOVAlin"))), + DTOutput("ANOVAlin")) + ), tabPanel("Report", h4("Settings for report") )) @@ -1396,9 +1456,9 @@ server <- function(input, output, session) { - + ##### UI Meta ---- output$fourPL <- renderUI({ - navbarPage(title="4PL", + navbarPage(title="4PL+linear reg", tabPanel("Analysis and Plots", #sidebarLayout( # sidebarPanel( @@ -1410,7 +1470,7 @@ server <- function(input, output, session) { tabsetPanel(id="tabs", tabPanel("Settings", 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"), 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) ), 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")), htmlOutput("PureErrW3"), - plotOutput("plot", width = "80%"), + plotOutput("plot4plMeta", width = "80%"), DTOutput("pottab4pl"), "Footnote: test performed on relative CIs.", @@ -1510,18 +1573,51 @@ server <- function(input, output, session) { h5("SSE ... 'Pure error' in the SumSquares column"), h5("RMSE ... Square root of the 'Residual Error' in the MeanSquares column"), 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", h4("ln-transformed y-axis plots"), - plotOutput("plot4plTrans", width = "80%"), + plotOutput("plot4plTransMeta", width = "80%"), 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", h4("Settings for report"), downloadButton("downloadXLReport", label="Download PDF report", class="butt"), @@ -1795,13 +1891,13 @@ server <- function(input, output, session) { REP$DiagnTable <- DiagnTable 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) # 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(logpotuest) <- c("estimate", "lowerCI", "upperCI") + colnames(logpotUest) <- c("estimate", "lowerCI", "upperCI") #browser() cnXL <- colnames(XLdat2) Filesample <- data.frame(Test = c("File name", "samples"), Test2=c(Dat$FileName, paste(cnXL[1], " vs ", cnXL[4]))) @@ -1839,8 +1935,7 @@ server <- function(input, output, session) { coeffs_R <- coeffsMR # pot$coefficients coeffs_R[5] <- coeffs_R[4] - coeffs_R[5] 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 --- PLAAusw <- data.frame( 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$PLBend <- PLAAusw2 - # --- Koeffizienten-Extraktion --- + #### Koeffizienten-Extraktion ---- logcoeffs_R <- SRlog$coefficients[, 1] # logpot$coefficients 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", "log lower CI", "log upper CI"), 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 }) REP$LogPLAausw <- LogPLAAusw @@ -1885,7 +1980,7 @@ server <- function(input, output, session) { "relative potency", "lower CI", "upper CI"), 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({ LogUnrPLAAusw @@ -1900,7 +1995,7 @@ server <- function(input, output, session) { } else Dat$dilution <- exp(XLdat[,logI]) # --- Plot-Ausgabe --- output$XLplot <- renderPlot({ - plot_f(XLdat2, sigmoid = NULL, det_sig = coeffsMU, TransFlag=F) + plot_f(XLdat2, TransFlag=F) }) REP$XLdat2 <- XLdat2 @@ -1967,82 +2062,82 @@ server <- function(input, output, session) { }) #### updateSlider on XLSX ---- - observe({ - if (!is.null(Dat$potDiffXL)) { - updateSliderInput(session, "potencydiff", - value=round(as.numeric(Dat$potDiffXL[[1]]),5)) - } - }) - observeEvent(input$potencydiff, { - if (!is.null(Dat$potDiffXL)) { - updateSliderInput(session, "potencydiff", - value=round(as.numeric(input$potencydiff),5)) - } - }) - observe({ - if (!is.null(Dat$ProzSD_XL)) { - updateSliderInput(session, "sdfacf", - value=round(as.numeric(Dat$ProzSD_XL[[1]]),5)) - } - }) - observeEvent(input$sdfac, { - if (!is.null(Dat$ProzSD_XL)) { - updateSliderInput(session, "sdfac", - value=round(as.numeric(Dat$ProzSD_XL[[1]]),5)) - } - }) + # observe({ + # if (!is.null(Dat$potDiffXL)) { + # updateSliderInput(session, "potencydiff", + # value=round(as.numeric(Dat$potDiffXL[[1]]),5)) + # } + # }) + # observeEvent(input$potencydiff, { + # if (!is.null(Dat$potDiffXL)) { + # updateSliderInput(session, "potencydiff", + # value=round(as.numeric(input$potencydiff),5)) + # } + # }) + # observe({ + # if (!is.null(Dat$ProzSD_XL)) { + # updateSliderInput(session, "sdfac", + # value=round(as.numeric(Dat$ProzSD_XL[[1]]),5)) + # } + # }) + # observeEvent(input$sdfac, { + # if (!is.null(Dat$ProzSD_XL)) { + # updateSliderInput(session, "sdfac", + # value=round(as.numeric(Dat$ProzSD_XL[[1]]),5)) + # } + # }) #### updaterNumeric Input ---- - observe({ - if(!is.null(Dat$coeffs_UN)) { - updateNumericInput(session, "lowAsymptREF", - value=round(as.numeric(Dat$coeffs_UN[3]),5), min=0) - updateNumericInput(session, "lowAsymptTEST", - value=round(as.numeric(Dat$coeffs_UN[4]),5), min=0) - updateNumericInput(session, "uppAsymptREF", - value=round(as.numeric(Dat$coeffs_UN[5]),5), min=0) - updateNumericInput(session, "uppAsymptTEST", - value=round(as.numeric(Dat$coeffs_UN[6]),5), min=0) - updateNumericInput(session, "slopeREF", - value=round(as.numeric(Dat$coeffs_UN[1]),5)) - updateNumericInput(session, "slopeTEST", - value=round(as.numeric(Dat$coeffs_UN[2]),5)) - updateNumericInput(session, "EC50", - value=round(as.numeric(Dat$coeffs_UN[7]),5)) - updateNumericInput(session, "potDiff", - value=round(as.numeric(Dat$coeffs_UN[7])- as.numeric(Dat$coeffs_UN[8]),5)) - } - }) - - observe({ - if(!is.null(Dat$dilution)) { - updateNumericInput(session, "CONC1", - value=as.numeric(Dat$dilution[1])) - updateNumericInput(session, "CONC2", - value=as.numeric(Dat$dilution[2])) - updateNumericInput(session, "CONC3", - value=as.numeric(Dat$dilution[3])) - updateNumericInput(session, "CONC4", - value=as.numeric(Dat$dilution[4])) - updateNumericInput(session, "CONC5", - value=as.numeric(Dat$dilution[5])) - updateNumericInput(session, "CONC6", - value=as.numeric(Dat$dilution[6])) - updateNumericInput(session, "CONC7", - value=as.numeric(Dat$dilution[7])) - updateNumericInput(session, "CONC8", - value=as.numeric(Dat$dilution[8])) - updateNumericInput(session, "CONC9", - value=as.numeric(Dat$dilution[9])) - updateNumericInput(session, "CONC10", - value=as.numeric(Dat$dilution[10])) - updateNumericInput(session, "CONC11", - value=as.numeric(Dat$dilution[11])) - updateNumericInput(session, "CONC12", - value=as.numeric(Dat$dilution[12])) - - } - }) + # observe({ + # if(!is.null(Dat$coeffs_UN)) { + # updateNumericInput(session, "lowAsymptREF", + # value=round(as.numeric(Dat$coeffs_UN[3]),5), min=0) + # updateNumericInput(session, "lowAsymptTEST", + # value=round(as.numeric(Dat$coeffs_UN[4]),5), min=0) + # updateNumericInput(session, "uppAsymptREF", + # value=round(as.numeric(Dat$coeffs_UN[5]),5), min=0) + # updateNumericInput(session, "uppAsymptTEST", + # value=round(as.numeric(Dat$coeffs_UN[6]),5), min=0) + # updateNumericInput(session, "slopeREF", + # value=round(as.numeric(Dat$coeffs_UN[1]),5)) + # updateNumericInput(session, "slopeTEST", + # value=round(as.numeric(Dat$coeffs_UN[2]),5)) + # updateNumericInput(session, "EC50", + # value=round(as.numeric(Dat$coeffs_UN[7]),5)) + # updateNumericInput(session, "potDiff", + # value=round(as.numeric(Dat$coeffs_UN[7])- as.numeric(Dat$coeffs_UN[8]),5)) + # } + # }) + # + # observe({ + # if(!is.null(Dat$dilution)) { + # updateNumericInput(session, "CONC1", + # value=as.numeric(Dat$dilution[1])) + # updateNumericInput(session, "CONC2", + # value=as.numeric(Dat$dilution[2])) + # updateNumericInput(session, "CONC3", + # value=as.numeric(Dat$dilution[3])) + # updateNumericInput(session, "CONC4", + # value=as.numeric(Dat$dilution[4])) + # updateNumericInput(session, "CONC5", + # value=as.numeric(Dat$dilution[5])) + # updateNumericInput(session, "CONC6", + # value=as.numeric(Dat$dilution[6])) + # updateNumericInput(session, "CONC7", + # value=as.numeric(Dat$dilution[7])) + # updateNumericInput(session, "CONC8", + # value=as.numeric(Dat$dilution[8])) + # updateNumericInput(session, "CONC9", + # value=as.numeric(Dat$dilution[9])) + # updateNumericInput(session, "CONC10", + # value=as.numeric(Dat$dilution[10])) + # updateNumericInput(session, "CONC11", + # value=as.numeric(Dat$dilution[11])) + # updateNumericInput(session, "CONC12", + # value=as.numeric(Dat$dilution[12])) + # + # } + # }) observe({ if(!is.null(Dat$MetaConc)) { @@ -2119,33 +2214,33 @@ server <- function(input, output, session) { ####sim2 ---- sim2 <- reactive({ 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 ---- - output$plot <- renderPlot({ + output$plot4plMeta <- renderPlot({ #browser() sigmoid <- sigmoid() det_sig=NULL - plot_f(sim2(),sigmoid, det_sig, TransFlag = F) + plot_f(sim2(), TransFlag = F) }) #### Plot 4pl Transformed ---- - output$plot4plTrans <- renderPlot({ + output$plot4plTransMeta <- renderPlot({ #browser() sigmoid <- sigmoid() det_sig=NULL - plot_f(sim2(),sigmoid, det_sig, TransFlag = T) + plot_f(sim2(), TransFlag = T) }) #### Testergebnisse für 4PL ---- observe({ if (is.null(sim2())) return(NULL) - if (is.null(input$PureErr4pl)) return(NULL) + if (is.null(input$PureErrMeta)) return(NULL) #observeEvent(input$StartCalc,{ - PureErrFlag <- input$PureErr4pl + PureErrFlag <- input$PureErrMeta warning_text3 <- reactive({ ifelse(PureErrFlag, 'Pure error selected','') }) @@ -2261,6 +2356,31 @@ server <- function(input, output, session) { 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({ 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) }) - #### linear Plot output ---- - + #### process XL linearly, Plot output ---- output$plotLin <- renderPlot({ - + + if (is.null(Dat$EXCEL)) return(NULL) tab <- Dat$EXCEL # tab <- sim2() @@ -2336,70 +2456,25 @@ server <- function(input, output, session) { Dat$circles <- circle #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 - 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 - - 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="#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) + pLin <- PlotLinPLA_FUNC(circle, sigmoid = sigmoid, all_l2, pl_df, indS, indT) + + + pLin }) - - output$plotLin2 <- renderPlot({ + #### process metadata, Plot output ---- + output$plotLinMeta <- renderPlot({ tab <- sim2() + + if(is.null(tab)) return(NULL) if (is.character(tab)) stop(tab) #browser() if (!is.na(Dils()[4])) noDilSer <- Dils()[4] else noDilSer = (ncol(tab)-1)/2 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) 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),] circle <- rbind(circleS,circleT) - Dat$circles <- circle + Dat$circlesMeta <- circle sigmoid <- sigmoid() - log_dose <- unique(all_l$log_dose) - seq_x <- seq(min(log_dose), max(log_dose),0.1) - SAMPLEtrue <- sigmoid[2] + (sigmoid[4]-sigmoid[2])/(1+exp(sigmoid[6]*((sigmoid[7]-log(input$potencydiff/100)-seq_x)))) - 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) + #browser() + pLin2 <- PlotLinPLA_FUNC(circle, sigmoid = sigmoid, all_l2, pl_df,indS, indT) + pLin2 }) - #### linear PLA tests ---- - output$TESTSlin <- DT::renderDataTable({ + #### linear PLA tests Metadata ---- + output$TESTSlinMeta <- DT::renderDataTable({ tab <- sim2() - if (is.character(tab)) stop(tab) + if (is.null(tab)) return(NULL) 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), as.numeric(input$lEACratiola), as.numeric(input$uEACratiola), 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$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 warning_text <- reactive({ ifelse(PureErrFlag, 'Pure error is selected','') }) - output$PureErrW <- renderText(warning_text()) - - LIN <- ANOVAlintests(tab,circles,Limite,PureErrFlag=PureErrFlag) + output$PureErrW3 <- renderText(warning_text()) + #browser() + LIN <- ANOVAlintests(tab,circle,Limite,PureErrFlag=PureErrFlag) df <- LIN[[1]] su_modU <- LIN[[2]] 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({ sigmoid <- sigmoid() tab <- ANOVA4plUnresfunc(sim2()) # ,sigmoid @@ -2545,18 +2644,33 @@ server <- function(input, output, session) { 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$RMSE <- renderText({ - paste("RMSE (unrestricted model):", Dat$RMSE_unr, "(~ entered % upper-lower asymptote)\n", - "RMSE restricted model:", Dat$RMSE_r, "\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", + 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", + "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", "RMSE (log restr. model): ", Dat$RMSE_Rlog, "\n", "RMSE (log unrestr. model): ", Dat$RMSE_Ulog, "\n", "%SDlog (unr model): ", Dat$RMSE_Ulog*100/Dat$up_lowAslog ) }) output$ANOVAlin <- DT::renderDataTable({ + if (is.null(Dat$ANOVA)) return(NULL) ANOVAlin <- Dat$ANOVA dat <- datatable(ANOVAlin, options=list( @@ -2565,9 +2679,19 @@ server <- function(input, output, session) { backgroundColor = styleEqual(c("p.value"), 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({ - + if (is.null(Dat$circles)) return(NULL) 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), @@ -2582,17 +2706,38 @@ server <- function(input, output, session) { options=list( dom="t",rownames=F )) %>% 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({ #browser() if (is.null(sim2()) | is.null(Dils())) return(NULL) ro_new <- sim2() Dils_ <- Dils() 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) #browser() 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 ---- output$plotfordilutions <- renderPlot({ tab <- sim2() @@ -2686,7 +2887,7 @@ server <- function(input, output, session) { Xbend200u <- sigmoid[7] - 0.693147+1.5434/sigmoid[5] Xbend50 <- max(Xbend50l, Xbend50u) Xbend200 <- min(Xbend200l, Xbend200u) - dummy <- plot_f(tab,sigmoid,det_sig=NULL) + dummy <- plot_f(tab) } else { #browser() @@ -2698,7 +2899,7 @@ server <- function(input, output, session) { Xbend200u <- det_sig[7] - 0.693147+1.5434/det_sig[1] Xbend50 <- max(Xbend50l, Xbend50u) Xbend200 <- min(Xbend200l, Xbend200u) - dummy <- plot_f(tab,sigmoid=NULL,det_sig=det_sig) + dummy <- plot_f(tab) }