From 335dfc653d42047b674a97d7a35e3cfec74c8c02 Mon Sep 17 00:00:00 2001 From: Simon Innerbichler Date: Tue, 19 May 2026 11:23:27 +0200 Subject: [PATCH] formatted app.R --- dev/app.R | 3427 +++++++++++++++++++++++++++++------------------------ 1 file changed, 1910 insertions(+), 1517 deletions(-) diff --git a/dev/app.R b/dev/app.R index d6d0682..e74e8bf 100644 --- a/dev/app.R +++ b/dev/app.R @@ -27,10 +27,6 @@ library(car) library(dplyr) library(scales) -Dat <- reactiveValues() -REP <- reactiveValues() -REPlin <- reactiveValues() - source("../R/Global.R") @@ -40,525 +36,617 @@ ui <- dashboardPage( dashboardHeader(title = "Plateflow"), dashboardSidebar( sidebarMenu( - img(src="logo.png", width=230), - menuItem("Home", tabName="home", icon=icon("home")), - menuItem("Data template", tabName = "template", icon=icon("table"), - menuSubItem( tags$li(a("EXCEL File", target="self",href="TestFile.xlsx"))) + img(src = "logo.png", width = 230), + menuItem("Home", tabName = "home", icon = icon("home")), + menuItem("Data template", + tabName = "template", icon = icon("table"), + menuSubItem(tags$li(a("EXCEL File", target = "self", href = "TestFile.xlsx"))) + ), + # menuItem("User Manual /Validation", tabName = "manual", icon=icon("book"), # tabName here and in dashboard body need to be identical + # menuSubItem(icon = NULL, tags$li(a("Document", target="self",href="UserManual.pdf"))) + # ), + menuItem("EXCEL upload", tabName = "Dataupload", icon = icon("magnet", lib = "glyphicon")), + menuItem("4PL simulation", tabName = "fourPL", icon = icon("chart-line", lib = "font-awesome")), + # menuItem("XLSX diagnostics", tabName="XLdiagn", icon=icon("chart-bar", lib="font-awesome")), + # menuItem("Linear regression + report", tabName="pla", icon=icon("pencil", lib="glyphicon")), + menuItem("Wizard", tabName = "wizard", icon = icon("chart-column", lib = "font-awesome")) # , + # menuItem("Documentation", tabName="documentation", icon=icon("chart-area", lib="font-awesome")) ), - # menuItem("User Manual /Validation", tabName = "manual", icon=icon("book"), # tabName here and in dashboard body need to be identical - # menuSubItem(icon = NULL, tags$li(a("Document", target="self",href="UserManual.pdf"))) - # ), - menuItem("EXCEL upload", tabName="Dataupload", icon=icon("magnet", lib="glyphicon")), - menuItem("4PL simulation", tabName="fourPL", icon=icon("chart-line", lib="font-awesome")), - #menuItem("XLSX diagnostics", tabName="XLdiagn", icon=icon("chart-bar", lib="font-awesome")), - # menuItem("Linear regression + report", tabName="pla", icon=icon("pencil", lib="glyphicon")), - menuItem("Wizard", tabName="wizard", icon=icon("chart-column", lib="font-awesome"))#, - #menuItem("Documentation", tabName="documentation", icon=icon("chart-area", lib="font-awesome")) + tags$footer( + HTML(paste( + tags$strong(tags$u("InnerAnalytics")), paste(rep(" ", 9), collapse = ""), + "Developer:", paste(rep(" ", 9), collapse = ""), + "Host on:", paste(rep(" ", 9), collapse = ""), + "Version:" + )), + align = "left", style = + "position:fixed; bottom:0;width=100%; background: #FFC337BB; font-family: Times New Roman; font-size:100%; + padding: 5px; color:#4545BA; box-sizing: border-box; z-index: 1000;" + ) ), - tags$footer(HTML(paste(tags$strong(tags$u("InnerAnalytics")), paste(rep(" ",9), collapse=""), - "Developer:", paste(rep(" ",9), collapse=""), - "Host on:", paste(rep(" ",9), collapse=""), - "Version:")), - align="left", style= - "position:fixed; bottom:0;width=100%; background: #FFC337BB; font-family: Times New Roman; font-size:100%; - padding: 5px; color:#4545BA; box-sizing: border-box; z-index: 1000;")), dashboardBody( fluidPage( tabItems( tabItem(tabName = "home", htmlOutput("homePage")), tabItem(tabName = "Dataupload", uiOutput("Dataupload")), tabItem(tabName = "fourPL", uiOutput("fourPL")), - #tabItem(tabName = "XLdiagn", uiOutput("XLdiagn")), - #tabItem(tabName = "pla", uiOutput("pla")), - tabItem(tabName = "wizard", uiOutput("wizard"))#, - #tabItem(tabName = "documentation", uiOutput("docu")) + # tabItem(tabName = "XLdiagn", uiOutput("XLdiagn")), + # tabItem(tabName = "pla", uiOutput("pla")), + tabItem(tabName = "wizard", uiOutput("wizard")) # , + # tabItem(tabName = "documentation", uiOutput("docu")) ) - ) - ), skin="blue" + ), + skin = "blue" ) #### server ---- server <- function(input, output, session) { - #### reactive values ---- Dat <- reactiveValues() REP <- reactiveValues() REPlin <- reactiveValues() - - - #### renderUIs ---- + + # this sets the environment of all functions that need to have access to the + # reactiveValues objects to the environment of the server function. + # this way, the reactiveValues are specific to the server namespace + environment(plot_f) <- environment() + environment(pot4plFUNC) <- environment() + environment(tests_FUNC) <- environment() + + #### renderUIs ---- output$homePage <- renderUI({ - navbarPage("Home", - tabPanel("Limit setting", - tags$img(src="logo.png", class="adv_logo"), - h4("Introduction to the bioassay software"), - #tags$mark("linear regression"), br(), - column(3, - tags$table(id="dose-table", - 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("lEACratiola","lower EAC ratio of LAs", 0.005, step=0.001), - numericInput("uEACratiola","upper EAC for ratio of LAs", 100, step=1), - - numericInput("lEACratioSlope","lower EAC for ratio of slopes", 0.55, step=0.01), - numericInput("uEACratioSlope","upper EAC for ratio of slopes", 1.84, step=0.1), - numericInput("lEACratioua","lower EAC for ratio of UAs", 0.75, step=0.1), - numericInput("uEACratioua","upper EAC for ratio of UAs", 1.33, step=0.1), - numericInput("lowerPot","lower EAC for potency", 75, step=1), - numericInput("upperPot","upper EAC for potency", 133, step=1), - numericInput("lEACratioAdiff","lower EAC of ratio of asymptote differences", 0.75, step=0.01), - numericInput("uEACratioAdiff","upper EAC of ratio of asymptote differences", 1.33, step=0.01) - )) - - ), - tabPanel("Documentation", - h4("Introduction "), - h4("Information on dilution setting"), - "(for details see:", a(href="ADONIS.pdf","Whitepaper", download=NA, target="_blank"),")",tags$br(), - "Bend points are calculated according to following formula:", - withMathJax(" $$bp_{1/2} = \\pm\\frac{1.31696}{Hill's slope}$$")), - tabPanel("Configuration", - verbatimTextOutput("sessioninfo")) + navbarPage( + "Home", + tabPanel( + "Limit setting", + tags$img(src = "logo.png", class = "adv_logo"), + h4("Introduction to the bioassay software"), + # tags$mark("linear regression"), br(), + column( + 3, + tags$table( + id = "dose-table", + 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("lEACratiola", "lower EAC ratio of LAs", 0.005, step = 0.001), + numericInput("uEACratiola", "upper EAC for ratio of LAs", 100, step = 1), + numericInput("lEACratioSlope", "lower EAC for ratio of slopes", 0.55, step = 0.01), + numericInput("uEACratioSlope", "upper EAC for ratio of slopes", 1.84, step = 0.1), + numericInput("lEACratioua", "lower EAC for ratio of UAs", 0.75, step = 0.1), + numericInput("uEACratioua", "upper EAC for ratio of UAs", 1.33, step = 0.1), + numericInput("lowerPot", "lower EAC for potency", 75, step = 1), + numericInput("upperPot", "upper EAC for potency", 133, step = 1), + numericInput("lEACratioAdiff", "lower EAC of ratio of asymptote differences", 0.75, step = 0.01), + numericInput("uEACratioAdiff", "upper EAC of ratio of asymptote differences", 1.33, step = 0.01) + ) + ) + ), + tabPanel( + "Documentation", + h4("Introduction "), + h4("Information on dilution setting"), + "(for details see:", a(href = "ADONIS.pdf", "Whitepaper", download = NA, target = "_blank"), ")", tags$br(), + "Bend points are calculated according to following formula:", + withMathJax(" $$bp_{1/2} = \\pm\\frac{1.31696}{Hill's slope}$$") + ), + tabPanel( + "Configuration", + verbatimTextOutput("sessioninfo") + ) ) }) ##### UI XL ---- output$Dataupload <- renderUI({ - navbarPage(title="Information", - tabPanel(title = "Real data", - tabsetPanel( - tabPanel("Data input", - - - column(3, - #img(src="Screenshot.png", width=200), - box(title = "Upload", status="warning",solidHeader = T, width=12, "Please upload your EXCEL file here", - fileInput("iFile",'',accept=".xlsx")), - uiOutput(outputId = "sheetName"), - "For data format in the EXCEL file see Data template", - "If no data are uploaded, the settings to the right are used for calculations.", - - tags$head(tags$style(HTML("label {font-size:80%;margin-bottom: 3px;margin-top: 3px;}"))), - - div(checkboxInput("PureErr", "Should pure error be used for calculation of CIs?", FALSE), - style = "font-size: 24px !important;color: #C2173F"), - - #actionLink("selectall","SelectAll"), - h5("\n\n\n Author: Franz Innerbichler, InnerAnalytics")), - column(4, - h4("Suitability tests for 4-parametric logistic regression"), - checkboxGroupInput("selectedSSTs", "Which suitability tests to be used?", choices= c("F-test on Regr."="1", - "EQ-test on lower asymptote difference"= "2", - "EQ-test on ratio of lower asymptote"= "3","EQ-test on ratio of Hill slopes"= "4", - "EQ-test on ratio of upper asymptote"= "5", "F-test on non-linearity"="6", - "EQ-test on ratio of asymptote differences"= "7"), - selected= c("1","4","5","6","7")), - h4("Suitability tests for Parallel Line Assay"), - checkboxGroupInput("selectedSSTsLinear", "Which suitability tests to be used?", - choices= c("F-test on Regr."="1", - "F-test on non-linearity"= "2", - "F-test on R^2 A"= "3","F-test on R^2 B"= "4", - "F-test on slope A"= "5", "F-test on slope B"="6", - "F-test on non-parallelism"= "7", "F-test on preparation"="8"), - selected= c("1","2","3","4","5","6","7","8")) - ), - column(4, - h4("Example of EXCEL file "), - h4("with column of dilutions and at least 2 columns of reference and the same amount of columns with test sample readouts."), - tags$img(src="ExampleXL.png", class="adv_logo", width="100%"), - - plotOutput("plotSing", width="400px", height="300px")) - - ), - tabPanel("4pl-Analysis", - tags$style(HTML("pre { color: black; background-color: #FFE1FF; - font-family: 'Helvetica Neue', Helvetica, Arial, sans-serif;font-size: 12px;} ")), - - wellPanel( - fluidRow( - column(4, - #h5("Diagnostics only shown if EXCEL is uploaded"), - htmlOutput("PureErrW2"), - tags$head(tags$style("#PureErrW2{color: red; - font-size: 16px; - font_style: italic;}")), - tableOutput("Filesampl"), - tableOutput("relpotTestTab"), - plotOutput("relpotTestPlot", width="300px", height="150px"), # Pot CI plot - h4("Akaike Information Criterion"), - tableOutput("AIC"), - h5("First row: restricted model; 2nd row: unrestricted model"), - h5("Smaller values of AIC indicate better fit to the data"), - tableOutput("VarDiagn") - ), - column(8, - plotOutput("XLplot"), - "Footnote: bendpoints (linear part) and asymptote points (point where asymptote is reached) are plotted in dashed and dotted lines. They indicate whether the linear part and asymptotes are catched with the current dilutions.", - "Black line is the true slope at EC50 of REF.", - DTOutput("pottab4plXL"), - plotOutput("diagnplot"), - DTOutput("EQtests"), - - DTOutput("pottab4plTransXL"), - tableOutput("ANOVAXLS") - ) - - ))), - tabPanel("linear Analysis", - sidebarLayout( - sidebarPanel( - width=2, - fluidRow( - column(12, - numericInput("EACLinlow","Potency CL to be > than",value=80), - numericInput("EACLinupp","Potency CL to be < than", value=125) - - ) - )), - mainPanel( - tabsetPanel(id="tabs", - tabPanel("Plot and models", - column(12, - htmlOutput("PureErrWLinXL"), - tags$head(tags$style("#PureErrWLinXL{color: red; - font-size: 16px; - font_style: italic;}")), - plotOutput("plotLin"), - "Delta method is used for potency CIs", - DT::dataTableOutput("pottab"), - h4("Unrestricted linear model (SSSI):"), - tableOutput("SummaryModABu"), - h4("Restricted linear model (CSSI):"), - tableOutput("SummaryModAB"), - )), - tabPanel("Tests and ANOVAA", - column(12, - - h3("Tests for linear PLA:"), - box(title="Suitability tests", status="primary",solidHeader = T, width=12, - DTOutput("TESTSlin")), - h5("The estimate is the p-value of the test"), - h5("F-tests on regression, significance of slopes, and preparation need to have a p-value <0.05 to pass"), - h5("All other tests pass if p-value > 0.05"), - "SST CI for difference of slopes:", - tableOutput("SlopeDiffCI"), - - h3("ANOVA for parallel line assay"), - DTOutput("ANOVAlin")) - ), - # tabPanel("Report", - # h4("Settings for report"), - # - # ) - ) - ) - ) - ), - tabPanel("parameter estimates", - htmlOutput("PureErrWParEst"), - tags$head(tags$style("#PureErrWParEst{color: red; - font-size: 16px; - font_style: italic;}")), - column(3,style = "background: #4FCBD922", - br(), - h4("Regression results restricted"), - tableOutput("coeffs_r"), - "Bend points restricted", - tableOutput("bends_r2")), - column(3,style = "background: #B5C74022", - br(), - h4("Regression results unrestricted"), - tableOutput("coeffs_unr")), - column(3,style = "background: #F9545422", - h4("Regression results (ln-transformed)"), - tableOutput("logcoeffs_r"), - tableOutput("bends_unr2"), - - tableOutput("logcoeffs_unr")) - ), - tabPanel("Report", - h4("Settings for report"), - downloadButton("downloadXLReport", label="Download 4PL PDF report", class="butt"), - tags$style(type="text/css","#downloadXLReport {background-color: orange; color: black;font-family: Courier New}"), - downloadButton("downloadXLReportLin", label="Download linear PLA PDF report", class="butt"), - tags$style(type="text/css","#downloadXLReportLin {background-color: #4FCBD9; color: black;font-family: Courier New}"), - textInput("Author", "Author", value=""), - textInput("RepIdentifier", "Report name", value=""), - textInput("NoP","Product name", value=""), - textInput("Assay", "Assay name",value="") - ) - ) - ) - ) - }) - - - - ##### UI Meta ---- - output$fourPL <- renderUI({ - navbarPage(title="4PL+linear reg", - tabPanel("Analysis and Plots", - #sidebarLayout( - # sidebarPanel( - # width=4, - # fluidRow( - # ) - # ), - mainPanel(width=12, - tabsetPanel(id="tabs", - tabPanel("Settings", - h4("Settings of 4PL regression"), - div(checkboxInput("PureErrMeta", "Should pure error be used for calculation of CIs?", FALSE), - style = "font-size: 24px !important;color: #C2173F"), - - h4("User help"), - h5("If new dilutions are entered, please adjust EC50 to avoid calculation errors"), - # numericInput("Limits",p("limit to be >", bsButton("q4",label="", icon=icon("info"), style="primary", size="extra-small")), - # bsPopover(id="q4", title="", content="The calculated limits ...")), - #h5("Diagnostics only shown if EXCEL is uploaded"), - column(2, - h3("Settings"), - helpText("Vary the slider to see the effect of special cause"), - sliderInput("sdfac","Variability as % of lower to upper asymptote", max=10, value=3, min=0.1, step=0.1), - checkboxInput("heterosked","heteroskedastic noise", FALSE), - sliderInput("potencydiff","potency of test (%)", max=200, min=50, value=100, step=1), - # sliderInput("outlL","outlier in lower asymptote", min=0, max=1.5, value=0, step=0.1), - # sliderInput("outlM","outlier in mid part", 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) - ), - column(2,style = "background: #7FAEFF", - #actionButton("StartCalc", "Click, when calculations to be started"), - h4("curve settings"), - numericInput("lowAsymptREF", "lower asymptote REF",10,step=1,min=0), - numericInput("lowAsymptTEST", "lower asymptote TEST",10,step=1,min=0), - numericInput("uppAsymptREF", "upper asymptote REF",110,step=1,min=0), - numericInput("uppAsymptTEST", "upper asymptote TEST",110,step=1,min=0) - ), - column(2,style = "background: #7FAEFF", - numericInput("slopeREF", "slope REF",1,step=0.1,min=-10), - numericInput("slopeTEST", "slope TEST",1,step=0.1,min=-10), - numericInput("EC50", "EC50 REF",-3.5), - numericInput("potDiff", "potency difference",0) - ), - column(2,style = "background: #627ADD", - h4("dilutions"), - numericInput("CONC1", "highest concentration",0.3, min=-3.5), - numericInput("CONC2", "2nd concentration",0.15), - numericInput("CONC3", "3rd concentration",0.075), - numericInput("CONC4", "4th concentration",0.0375), - numericInput("CONC5", "5th concentration",0.01875), - - numericInput("CONC6", "6th concentration",0.00938) - ), - column(2,style = "background: #627ADD", - - numericInput("CONC7", "7th concentration",0.00469), - numericInput("CONC8", "8thd concentration",0.00235), - numericInput("CONC9", "9thd concentration",value=NA), - numericInput("CONC10", "10th concentration",value=NA), - numericInput("CONC11", "11th concentration",value=NA), - - numericInput("CONC12", "lowest concentration",NA) - ), - column(2,style = "background: #4FCBD9", - h4("geometric dilution scheme"), - numericInput("ConcStart", "starting concentration",value=NA, min=0), - numericInput("dilutionFac", "dilution factor",value=NA, min=0, max=10), - numericInput("NoDil", "no. of dilutions",value=NA, min=8), - numericInput("NoDilSer", "no. of dil. series",value=NA), - verbatimTextOutput("dilutions") - ), + navbarPage( + title = "Information", + tabPanel( + title = "Real data", + tabsetPanel( + tabPanel( + "Data input", + column( + 3, + # img(src="Screenshot.png", width=200), + box( + title = "Upload", status = "warning", solidHeader = T, width = 12, "Please upload your EXCEL file here", + fileInput("iFile", "", accept = ".xlsx") + ), + uiOutput(outputId = "sheetName"), + "For data format in the EXCEL file see Data template", + "If no data are uploaded, the settings to the right are used for calculations.", + tags$head(tags$style(HTML("label {font-size:80%;margin-bottom: 3px;margin-top: 3px;}"))), + div(checkboxInput("PureErr", "Should pure error be used for calculation of CIs?", FALSE), + style = "font-size: 24px !important;color: #C2173F" + ), - - h4("log-dilutions from settings above"), - - column(8, - box(title = "Simulated data per log-concentration", status="warning",solidHeader = T, width=12, "incl. mean, sd and CV%", - DT::dataTableOutput("ConctabMeta")), - verbatimTextOutput("logdil")) - - #) - ), - #### 4pl fits ---- - tabPanel("4pl-fit", - - wellPanel( - fluidRow( - column(10, - htmlOutput("PureErrW4plMeta"), - tags$head(tags$style("#PureErrW4plMeta{color: red; + # actionLink("selectall","SelectAll"), + h5("\n\n\n Author: Franz Innerbichler, InnerAnalytics") + ), + column( + 4, + h4("Suitability tests for 4-parametric logistic regression"), + checkboxGroupInput("selectedSSTs", "Which suitability tests to be used?", + choices = c( + "F-test on Regr." = "1", + "EQ-test on lower asymptote difference" = "2", + "EQ-test on ratio of lower asymptote" = "3", "EQ-test on ratio of Hill slopes" = "4", + "EQ-test on ratio of upper asymptote" = "5", "F-test on non-linearity" = "6", + "EQ-test on ratio of asymptote differences" = "7" + ), + selected = c("1", "4", "5", "6", "7") + ), + h4("Suitability tests for Parallel Line Assay"), + checkboxGroupInput("selectedSSTsLinear", "Which suitability tests to be used?", + choices = c( + "F-test on Regr." = "1", + "F-test on non-linearity" = "2", + "F-test on R^2 A" = "3", "F-test on R^2 B" = "4", + "F-test on slope A" = "5", "F-test on slope B" = "6", + "F-test on non-parallelism" = "7", "F-test on preparation" = "8" + ), + selected = c("1", "2", "3", "4", "5", "6", "7", "8") + ) + ), + column( + 4, + h4("Example of EXCEL file "), + h4("with column of dilutions and at least 2 columns of reference and the same amount of columns with test sample readouts."), + tags$img(src = "ExampleXL.png", class = "adv_logo", width = "100%"), + plotOutput("plotSing", width = "400px", height = "300px") + ) + ), + tabPanel( + "4pl-Analysis", + tags$style(HTML("pre { color: black; background-color: #FFE1FF; + font-family: 'Helvetica Neue', Helvetica, Arial, sans-serif;font-size: 12px;} ")), + wellPanel( + fluidRow( + column( + 4, + # h5("Diagnostics only shown if EXCEL is uploaded"), + htmlOutput("PureErrW2"), + tags$head(tags$style("#PureErrW2{color: red; font-size: 16px; font_style: italic;}")), - plotOutput("plot4plMeta", width = "80%"), - DTOutput("pottab4pl"), - "Footnote: test performed on relative CIs.", - - DTOutput("EQtests4pl"), # SSTs - h5("*...The estimate for F-test on regression and on non-linearity is the p-value"), - h5("F-test on regression passes if F-value > F-crit and thus p < 0.05"), - h5("F-test on non-linearity passes if F-value < F-crit and thus p > 0.05"), - h5("Test results outcome: 0 ... test passed (for EQ tests: CI within limits); - 1 ... test failed (for EQ tests CI not within limits); - -1 ... calculations unbound/denominator too close to 0"), - #plotOutput("CIplot, height=50%") - ), - column(8, - "4 PL ANOVA unrestricted", - box(title = "ANOVA unrestricted", status="warning",solidHeader = T, width=12, "", - DT::dataTableOutput("ANOVA")), - h5("Please note that for the CIs of rel. potency the RSS of the restricted model is used"), - h5("RSS ... 'Residual error' in the SumSquares column"), - h5("MSE ... 'Residual error' in the MeanSquaress column"), - h5("SSE ... 'Pure error' in the SumSquares column"), - h5("RMSE ... Square root of the 'Residual Error' in the MeanSquares column"), - verbatimTextOutput("RMSE") - ) - )) - ), - - tabPanel("ln-transformed y", - htmlOutput("PureErrWLogMeta"), - tags$head(tags$style("#PureErrWLogMeta{color: red; + tableOutput("Filesampl"), + tableOutput("relpotTestTab"), + plotOutput("relpotTestPlot", width = "300px", height = "150px"), # Pot CI plot + h4("Akaike Information Criterion"), + tableOutput("AIC"), + h5("First row: restricted model; 2nd row: unrestricted model"), + h5("Smaller values of AIC indicate better fit to the data"), + tableOutput("VarDiagn") + ), + column( + 8, + plotOutput("XLplot"), + "Footnote: bendpoints (linear part) and asymptote points (point where asymptote is reached) are plotted in dashed and dotted lines. They indicate whether the linear part and asymptotes are catched with the current dilutions.", + "Black line is the true slope at EC50 of REF.", + DTOutput("pottab4plXL"), + plotOutput("diagnplot"), + DTOutput("EQtests"), + DTOutput("pottab4plTransXL"), + tableOutput("ANOVAXLS") + ) + ) + ) + ), + tabPanel( + "linear Analysis", + sidebarLayout( + sidebarPanel( + width = 2, + fluidRow( + column( + 12, + numericInput("EACLinlow", "Potency CL to be > than", value = 80), + numericInput("EACLinupp", "Potency CL to be < than", value = 125) + ) + ) + ), + mainPanel( + tabsetPanel( + id = "tabs", + tabPanel( + "Plot and models", + column( + 12, + htmlOutput("PureErrWLinXL"), + tags$head(tags$style("#PureErrWLinXL{color: red; font-size: 16px; font_style: italic;}")), - h4("ln-transformed y-axis plots"), - plotOutput("plot4plTransMeta", width = "80%"), - DT::dataTableOutput("pottab4plTrans"), - ), - tabPanel("linear regression", - - htmlOutput("PureErrW3"), - h4("Evaluations from meta-data"), - tags$head(tags$style("#PureErrW3{color: red; + plotOutput("plotLin"), + "Delta method is used for potency CIs", + DT::dataTableOutput("pottab"), + h4("Unrestricted linear model (SSSI):"), + tableOutput("SummaryModABu"), + h4("Restricted linear model (CSSI):"), + tableOutput("SummaryModAB"), + ) + ), + tabPanel( + "Tests and ANOVAA", + column( + 12, + h3("Tests for linear PLA:"), + box( + title = "Suitability tests", status = "primary", solidHeader = T, width = 12, + DTOutput("TESTSlin") + ), + h5("The estimate is the p-value of the test"), + h5("F-tests on regression, significance of slopes, and preparation need to have a p-value <0.05 to pass"), + h5("All other tests pass if p-value > 0.05"), + "SST CI for difference of slopes:", + tableOutput("SlopeDiffCI"), + h3("ANOVA for parallel line assay"), + DTOutput("ANOVAlin") + ) + ), + # tabPanel("Report", + # h4("Settings for report"), + # + # ) + ) + ) + ) + ), + tabPanel( + "parameter estimates", + htmlOutput("PureErrWParEst"), + tags$head(tags$style("#PureErrWParEst{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"), - tags$style(type="text/css","#downloadXLReport {background-color: orange; color: black;font-family: COurier New}"), - ) - ) - ) - #) - ) + column(3, + style = "background: #4FCBD922", + br(), + h4("Regression results restricted"), + tableOutput("coeffs_r"), + "Bend points restricted", + tableOutput("bends_r2") + ), + column(3, + style = "background: #B5C74022", + br(), + h4("Regression results unrestricted"), + tableOutput("coeffs_unr") + ), + column(3, + style = "background: #F9545422", + h4("Regression results (ln-transformed)"), + tableOutput("logcoeffs_r"), + tableOutput("bends_unr2"), + tableOutput("logcoeffs_unr") + ) + ), + tabPanel( + "Report", + h4("Settings for report"), + downloadButton("downloadXLReport", label = "Download 4PL PDF report", class = "butt"), + tags$style(type = "text/css", "#downloadXLReport {background-color: orange; color: black;font-family: Courier New}"), + downloadButton("downloadXLReportLin", label = "Download linear PLA PDF report", class = "butt"), + tags$style(type = "text/css", "#downloadXLReportLin {background-color: #4FCBD9; color: black;font-family: Courier New}"), + textInput("Author", "Author", value = ""), + textInput("RepIdentifier", "Report name", value = ""), + textInput("NoP", "Product name", value = ""), + textInput("Assay", "Assay name", value = "") + ) + ) + ) ) }) - - + + + ##### UI Meta ---- + output$fourPL <- renderUI({ + navbarPage( + title = "4PL+linear reg", + tabPanel( + "Analysis and Plots", + # sidebarLayout( + # sidebarPanel( + # width=4, + # fluidRow( + # ) + # ), + mainPanel( + width = 12, + tabsetPanel( + id = "tabs", + tabPanel( + "Settings", + h4("Settings of 4PL regression"), + div(checkboxInput("PureErrMeta", "Should pure error be used for calculation of CIs?", FALSE), + style = "font-size: 24px !important;color: #C2173F" + ), + h4("User help"), + h5("If new dilutions are entered, please adjust EC50 to avoid calculation errors"), + # numericInput("Limits",p("limit to be >", bsButton("q4",label="", icon=icon("info"), style="primary", size="extra-small")), + # bsPopover(id="q4", title="", content="The calculated limits ...")), + # h5("Diagnostics only shown if EXCEL is uploaded"), + column( + 2, + h3("Settings"), + helpText("Vary the slider to see the effect of special cause"), + sliderInput("sdfac", "Variability as % of lower to upper asymptote", max = 10, value = 3, min = 0.1, step = 0.1), + checkboxInput("heterosked", "heteroskedastic noise", FALSE), + sliderInput("potencydiff", "potency of test (%)", max = 200, min = 50, value = 100, step = 1), + # sliderInput("outlL","outlier in lower asymptote", min=0, max=1.5, value=0, step=0.1), + # sliderInput("outlM","outlier in mid part", 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) + ), + column(2, + style = "background: #7FAEFF", + # actionButton("StartCalc", "Click, when calculations to be started"), + h4("curve settings"), + numericInput("lowAsymptREF", "lower asymptote REF", 10, step = 1, min = 0), + numericInput("lowAsymptTEST", "lower asymptote TEST", 10, step = 1, min = 0), + numericInput("uppAsymptREF", "upper asymptote REF", 110, step = 1, min = 0), + numericInput("uppAsymptTEST", "upper asymptote TEST", 110, step = 1, min = 0) + ), + column(2, + style = "background: #7FAEFF", + numericInput("slopeREF", "slope REF", 1, step = 0.1, min = -10), + numericInput("slopeTEST", "slope TEST", 1, step = 0.1, min = -10), + numericInput("EC50", "EC50 REF", -3.5), + numericInput("potDiff", "potency difference", 0) + ), + column(2, + style = "background: #627ADD", + h4("dilutions"), + numericInput("CONC1", "highest concentration", 0.3, min = -3.5), + numericInput("CONC2", "2nd concentration", 0.15), + numericInput("CONC3", "3rd concentration", 0.075), + numericInput("CONC4", "4th concentration", 0.0375), + numericInput("CONC5", "5th concentration", 0.01875), + numericInput("CONC6", "6th concentration", 0.00938) + ), + column(2, + style = "background: #627ADD", + numericInput("CONC7", "7th concentration", 0.00469), + numericInput("CONC8", "8thd concentration", 0.00235), + numericInput("CONC9", "9thd concentration", value = NA), + numericInput("CONC10", "10th concentration", value = NA), + numericInput("CONC11", "11th concentration", value = NA), + numericInput("CONC12", "lowest concentration", NA) + ), + column(2, + style = "background: #4FCBD9", + h4("geometric dilution scheme"), + numericInput("ConcStart", "starting concentration", value = NA, min = 0), + numericInput("dilutionFac", "dilution factor", value = NA, min = 0, max = 10), + numericInput("NoDil", "no. of dilutions", value = NA, min = 8), + numericInput("NoDilSer", "no. of dil. series", value = NA), + verbatimTextOutput("dilutions") + ), + h4("log-dilutions from settings above"), + column( + 8, + box( + title = "Simulated data per log-concentration", status = "warning", solidHeader = T, width = 12, "incl. mean, sd and CV%", + DT::dataTableOutput("ConctabMeta") + ), + verbatimTextOutput("logdil") + ) + + # ) + ), + #### 4pl fits ---- + tabPanel( + "4pl-fit", + wellPanel( + fluidRow( + column( + 10, + htmlOutput("PureErrW4plMeta"), + tags$head(tags$style("#PureErrW4plMeta{color: red; + font-size: 16px; + font_style: italic;}")), + plotOutput("plot4plMeta", width = "80%"), + DTOutput("pottab4pl"), + "Footnote: test performed on relative CIs.", + DTOutput("EQtests4pl"), # SSTs + h5("*...The estimate for F-test on regression and on non-linearity is the p-value"), + h5("F-test on regression passes if F-value > F-crit and thus p < 0.05"), + h5("F-test on non-linearity passes if F-value < F-crit and thus p > 0.05"), + h5("Test results outcome: 0 ... test passed (for EQ tests: CI within limits); + 1 ... test failed (for EQ tests CI not within limits); + -1 ... calculations unbound/denominator too close to 0"), + # plotOutput("CIplot, height=50%") + ), + column( + 8, + "4 PL ANOVA unrestricted", + box( + title = "ANOVA unrestricted", status = "warning", solidHeader = T, width = 12, "", + DT::dataTableOutput("ANOVA") + ), + h5("Please note that for the CIs of rel. potency the RSS of the restricted model is used"), + h5("RSS ... 'Residual error' in the SumSquares column"), + h5("MSE ... 'Residual error' in the MeanSquaress column"), + h5("SSE ... 'Pure error' in the SumSquares column"), + h5("RMSE ... Square root of the 'Residual Error' in the MeanSquares column"), + verbatimTextOutput("RMSE") + ) + ) + ) + ), + tabPanel( + "ln-transformed y", + htmlOutput("PureErrWLogMeta"), + tags$head(tags$style("#PureErrWLogMeta{color: red; + font-size: 16px; + font_style: italic;}")), + h4("ln-transformed y-axis plots"), + plotOutput("plot4plTransMeta", width = "80%"), + DT::dataTableOutput("pottab4plTrans"), + ), + tabPanel( + "linear regression", + htmlOutput("PureErrW3"), + h4("Evaluations from meta-data"), + 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"), + tags$style(type = "text/css", "#downloadXLReport {background-color: orange; color: black;font-family: COurier New}"), + ) + ) + ) + # ) + ) + ) + }) + + output$pla <- renderUI({ - navbarPage(title="pla", - tabPanel("Analysis and Plots", - - ) - ) + navbarPage( + title = "pla", + tabPanel("Analysis and Plots", ) + ) }) - + output$wizard <- renderUI({ - navbarPage(title="Dilution setting", - tabPanel("Plots", - sidebarLayout( - sidebarPanel( - width=3, - fluidRow( - column(6, - numericInput("Limits",p("limit to be >", bsButton("q4",label="", icon=icon("info"), style="primary", size="extra-small")), - bsPopover(id="q4", title="", content="The calculated limits ..."))) - )), - mainPanel( - tabsetPanel(id="tabs", - tabPanel("4pl", - box(title="ANOVA table", status="primary",solidHeader = T, width=12, - tableOutput("Anovatab")), - column(4, - h3("Confidence intervals"), - tableOutput("CIs"), - "The confidence interval table is interaactive for changes in: variability slider (%SD), potency of test-slider, + navbarPage( + title = "Dilution setting", + tabPanel( + "Plots", + sidebarLayout( + sidebarPanel( + width = 3, + fluidRow( + column( + 6, + numericInput( + "Limits", p("limit to be >", bsButton("q4", label = "", icon = icon("info"), style = "primary", size = "extra-small")), + bsPopover(id = "q4", title = "", content = "The calculated limits ...") + ) + ) + ) + ), + mainPanel( + tabsetPanel( + id = "tabs", + tabPanel( + "4pl", + box( + title = "ANOVA table", status = "primary", solidHeader = T, width = 12, + tableOutput("Anovatab") + ), + column( + 4, + h3("Confidence intervals"), + tableOutput("CIs"), + "The confidence interval table is interaactive for changes in: variability slider (%SD), potency of test-slider, and 'Adjust the dilutions'-slider", - tableOutput("optimalDils"), - selectInput(inputId="scenario", label= "Select an 'optimal' scenario:", choices = c("scenario 2","scenario 3","scenario 6","steep slope"))), - column(5, - plotOutput("plotfordilutions"), - h4("in grey: most extreme bend point lines of theoretical samples with 50% and 200% potency"), - sliderInput("dilslider", "Adjust the dilutions(+-change in %)", min = -100,max=100, value=0, step=1, round=0), - checkboxInput("fixupper","Fix highest concentration (if unticked, the center is fixed)",FALSE), - h5("Dilution factors"), - tableOutput("adjlogdil"), - "Short guidance: wider dilution ranges increase the CIs of rel. potency, and decrease the CIs of upper and lower asymptote ratios, as well as Hill's slope ratios", br(), - "Narrower dilution ranges decrease the CIs of rel. potency, and increase the CIs of upper and lower asymptote ratios, ands Hill's slope ratios",), - column(3, - h3("Bend points"), - tableOutput("bps"), - tableOutput("extremebps"), - h4("Explanation of the plots") - )), - tabPanel("Report", - h4("Settings for report") - )) - ) - ))) + tableOutput("optimalDils"), + selectInput(inputId = "scenario", label = "Select an 'optimal' scenario:", choices = c("scenario 2", "scenario 3", "scenario 6", "steep slope")) + ), + column( + 5, + plotOutput("plotfordilutions"), + h4("in grey: most extreme bend point lines of theoretical samples with 50% and 200% potency"), + sliderInput("dilslider", "Adjust the dilutions(+-change in %)", min = -100, max = 100, value = 0, step = 1, round = 0), + checkboxInput("fixupper", "Fix highest concentration (if unticked, the center is fixed)", FALSE), + h5("Dilution factors"), + tableOutput("adjlogdil"), + "Short guidance: wider dilution ranges increase the CIs of rel. potency, and decrease the CIs of upper and lower asymptote ratios, as well as Hill's slope ratios", br(), + "Narrower dilution ranges decrease the CIs of rel. potency, and increase the CIs of upper and lower asymptote ratios, ands Hill's slope ratios", + ), + column( + 3, + h3("Bend points"), + tableOutput("bps"), + tableOutput("extremebps"), + h4("Explanation of the plots") + ) + ), + tabPanel( + "Report", + h4("Settings for report") + ) + ) + ) + ) + ) + ) }) - -#output$sessioninfo <- renderPrint(sessioninfo()) - - v <- reactiveValues(num_dose=0, next.dose.t=0) - + + # output$sessioninfo <- renderPrint(sessioninfo()) + + v <- reactiveValues(num_dose = 0, next.dose.t = 0) + sigmoid <- reactive({ - sig <- c(input$lowAsymptREF, input$lowAsymptTEST,input$uppAsymptREF,input$uppAsymptTEST, - input$slopeREF,input$slopeTEST,input$EC50,input$potDiff) + sig <- c( + input$lowAsymptREF, input$lowAsymptTEST, input$uppAsymptREF, input$uppAsymptTEST, + input$slopeREF, input$slopeTEST, input$EC50, input$potDiff + ) sig }) - + CONC <- reactive({ - Konz_ <- c(input$CONC1,input$CONC2,input$CONC3,input$CONC4, - input$CONC5,input$CONC6,input$CONC7,input$CONC8, - input$CONC9,input$CONC10,input$CONC11,input$CONC12) - if (any(na.omit(Konz_)==0)) Konz_[Konz_ ==0] <- 0.0000001 + Konz_ <- c( + input$CONC1, input$CONC2, input$CONC3, input$CONC4, + input$CONC5, input$CONC6, input$CONC7, input$CONC8, + input$CONC9, input$CONC10, input$CONC11, input$CONC12 + ) + if (any(na.omit(Konz_) == 0)) Konz_[Konz_ == 0] <- 0.0000001 Konz <- na.omit(Konz_) }) - + Dils <- reactive({ - Dilutions <- c(input$ConcStart,input$dilutionFac,input$NoDil,input$NoDilSer) + Dilutions <- c(input$ConcStart, input$dilutionFac, input$NoDil, input$NoDilSer) }) - + #### input EXCEL file ---- - + observe({ if (!is.null(input$iFile)) { inFile <- input$iFile ext <- tools::file_ext(inFile$name) - file.rename(inFile$datapath, paste(inFile$datapath, ".xlsx",sep="")) - t.filelocation <- gsub('\\\\','/',paste(inFile$datapath, ext,sep=".")) + file.rename(inFile$datapath, paste(inFile$datapath, ".xlsx", sep = "")) + t.filelocation <- gsub("\\\\", "/", paste(inFile$datapath, ext, sep = ".")) sheets <- openxlsx::getSheetNames(t.filelocation) dat <- lapply(sheets, openxlsx::read.xlsx, xlsxFile = t.filelocation) names(dat) <- sheets @@ -566,365 +654,427 @@ server <- function(input, output, session) { names(Dat$wb) <- sheets Dat$sheets <- sheets Dat$FileName <- input$iFile[["name"]] - } }) output$sheetName <- renderUI({ if (!is.null(Dat$wb)) { - #browser() cnSheets <- Dat$sheets cnSheets2 <- c("please choose", cnSheets) - selectInput(inputId = "sheet", label="Select a sheet:",choices = cnSheets) + selectInput(inputId = "sheet", label = "Select a sheet:", choices = cnSheets) } }) observeEvent(input$sign_out, { unlink(input$iFile$datapath) reset(id = "") # from shinyjs package }) - - + + #### process XLSX file ---- observe({ if (!is.null(input$iFile)) { if (!is.null(input$sheet)) { if (input$sheet != "please choose") { - #browser() - + Dat$RepIdentifier <- input$RepIdentifier Dat$Author <- input$Author Dat$NoP <- input$NoP Dat$Assay <- input$Assay - - + + XLdat <- Dat$wb[input$sheet][[1]] if (is.null(XLdat)) XLdat <- Dat$wb[Dat$sheets[1]][[1]] cn <- colnames(XLdat) logI <- grep("log", cn) logDoseI <- grep("log_dose", cn) - if (length(logI)>0 & length(logDoseI)==0) { - XLdat$log_dose <- XLdat[,logI] - XLdat2 <- XLdat[,-logI] - CORro <- cor(XLdat$log_dose, XLdat[,3]) - } else if (length(logI)==0 & length(logDoseI)==0) { - Ind <- grep("dilu|dose|Dose|Conc|conc",cn) - XLdat$log_dose <- log(XLdat[,Ind]) - CORro <- cor(XLdat[,Ind], XLdat[,3]) - XLdat2 <- XLdat[,-Ind] - } else if (length(logI)>0 & length(logDoseI)>0) { + if (length(logI) > 0 & length(logDoseI) == 0) { + XLdat$log_dose <- XLdat[, logI] + XLdat2 <- XLdat[, -logI] + CORro <- cor(XLdat$log_dose, XLdat[, 3]) + } else if (length(logI) == 0 & length(logDoseI) == 0) { + Ind <- grep("dilu|dose|Dose|Conc|conc", cn) + XLdat$log_dose <- log(XLdat[, Ind]) + CORro <- cor(XLdat[, Ind], XLdat[, 3]) + XLdat2 <- XLdat[, -Ind] + } else if (length(logI) > 0 & length(logDoseI) > 0) { XLdat2 <- XLdat - CORro <- cor(XLdat[,logI], XLdat[,3]) + CORro <- cor(XLdat[, logI], XLdat[, 3]) } Dat$EXCEL <- XLdat2 PureErrFlag <- input$PureErr warning_text2 <- reactive({ - ifelse(PureErrFlag, 'Pure Error is selected', '') + ifelse(PureErrFlag, "Pure Error is selected", "") }) output$PureErrW2 <- renderText(warning_text2()) warning_textParEst <- reactive({ - ifelse(PureErrFlag, 'Pure Error is selected', '') + ifelse(PureErrFlag, "Pure Error is selected", "") }) output$PureErrWParEst <- renderText(warning_textParEst()) - + REP$PureErr <- PureErrFlag - - noDilSeries <-(ncol(XLdat2)-1)/2 + + noDilSeries <- (ncol(XLdat2) - 1) / 2 noDils <- nrow(XLdat2) Dat$noDilSeriesXL <- noDilSeries - - all_l <- melt(data.frame(XLdat2), id.vars="log_dose",variable.name = "replname", value.name = "readout") - isRef <- rep(c(1,0),1,each=nrow(XLdat2)*noDilSeries) - isSample <- rep(c(0,1),1,each=nrow(XLdat2)*noDilSeries) + + all_l <- melt(data.frame(XLdat2), id.vars = "log_dose", variable.name = "replname", value.name = "readout") + isRef <- rep(c(1, 0), 1, each = nrow(XLdat2) * noDilSeries) + isSample <- rep(c(0, 1), 1, each = nrow(XLdat2) * noDilSeries) all_l$isRef <- isRef all_l$isSample <- isSample all_l$Conc <- exp(all_l$log_dose) # all_l$readout[all_l$readout < 0] <- 0.01 REP$all_l <- all_l - + #### XLSX eval ---- - if (CORro<0) SLOPE <- -1 else SLOPE <- 1 + if (CORro < 0) SLOPE <- -1 else SLOPE <- 1 FITs <- Fitting_FUNC(XLdat2, TransFlag = FALSE) - - #### if no 4pl fit is possible ---- - if (!is.null(FITs)) { - if (is.character(FITs)) { - - Dat$FITsFlag <- TRUE - - pSing <- plotSingularity(XLdat2) - - output$plotSing <- renderPlot({ - pSing - }) - - output$XLplot <- renderPlot({ - - REP$XLplotSing <- pSing - - pSing - }) - - output$relpotTestTab <- renderTable({ NULL }) - output$relpotTestPlot<- renderPlot({ NULL }) - output$AIC <- renderTable({ NULL }) - output$VarDiagn <- renderTable({ NULL }) + #### if no 4pl fit is possible ---- + if (!is.null(FITs)) { + if (is.character(FITs)) { + Dat$FITsFlag <- TRUE + + pSing <- plotSingularity(XLdat2) + + output$plotSing <- renderPlot({ + pSing + }) + + output$XLplot <- renderPlot({ + REP$XLplotSing <- pSing + + pSing + }) + + output$relpotTestTab <- renderTable({ + NULL + }) + output$relpotTestPlot <- renderPlot({ + NULL + }) + + output$AIC <- renderTable({ + NULL + }) + output$VarDiagn <- renderTable({ + NULL + }) + + output$pottab4plXL <- renderDT({ + NULL + }) + output$diagnplot <- renderPlot({ + NULL + }) + output$EQtests <- renderDT({ + NULL + }) + # + output$pottab4plTransXL <- renderDT({ + NULL + }) + output$ANOVAXLS <- renderTable({ + NULL + }) + # ) + + return(NULL) + } + } - output$pottab4plXL <- renderDT({ NULL }) - output$diagnplot <- renderPlot({ NULL }) - output$EQtests <- renderDT({ NULL }) - # - output$pottab4plTransXL <- renderDT({ NULL }) - output$ANOVAXLS <- renderTable({ NULL }) - #) - - return(NULL) - } - } - Smr <- FITs[[1]] # summary(mr) Smu <- FITs[[2]] # summary(mu) - coeffsMR <- Smr$coefficients[,1] - coeffsMU <- Smu$coefficients[,1] + coeffsMR <- Smr$coefficients[, 1] + coeffsMU <- Smu$coefficients[, 1] Dat$coeffsMRes <- coeffsMR Dat$coeffsMUnr <- coeffsMU - Dat$coeffs_UN <- coeffsMU - names(coeffsMU) <- c("lowAsym REF", "slope REF","upperAsym REF","EC50 REF","lowAsym TEST","slope TEST","upperAsym TEST","r") - # browser() - XbendMUlREF <- coeffsMU[4] - 1.5434/abs(coeffsMU[2]) - XbendMUuREF <- coeffsMU[4] + 1.5434/abs(coeffsMU[2]) - XbendMUlTEST <- coeffsMU[4]-coeffsMU[8] - 1.5434/abs(coeffsMU[6]) - XbendMUuTEST <- coeffsMU[4]+coeffsMU[8] + 1.5434/abs(coeffsMU[6]) - XbendMRlREF <- coeffsMR[4] - 1.5434/abs(coeffsMR[2]) - XbendMRuREF <- coeffsMR[4] + 1.5434/abs(coeffsMR[2]) - XbendMRlTEST <- coeffsMR[4]-coeffsMR[5] - 1.5434/abs(coeffsMR[2]) - XbendMRuTEST <- coeffsMR[4]-coeffsMR[5] + 1.5434/abs(coeffsMR[2]) - XasymlREF <- coeffsMR[4] - 3/abs(coeffsMR[2]) - XasymuREF <- coeffsMR[4] + 3/abs(coeffsMR[2]) - XasymlTEST <- coeffsMR[4]-coeffsMR[5] - 3/abs(coeffsMR[2]) - XasymuTEST <- coeffsMR[4]-coeffsMR[5] + 3/abs(coeffsMR[2]) - #browser() - BPsMR_MU <- data.frame(points = c("lower bendpoint REF", "upper bendpoint REF","lower bendpoint TEST" ,"upper bendpoint TEST", - "lower asymp. point REF", "upper asymp. point REFr", "lower asymp. point TEST", "upper asymp. point TEST", - "bendREF_lower_unrestr", "bendREF_upper_unrestr", "bendTESTE_lower_unrestr", "bendTEST_upper_unrestr"), - estimates = c(round(XbendMRlREF,3), round(XbendMRuREF,3),round(XbendMRlTEST,3),round(XbendMRuTEST,3), - round(XasymlREF,3),round(XasymuREF,3),round(XasymlTEST,3),round(XasymuTEST,3), - round(XbendMRlREF,3),round(XbendMRuREF,3),round(XbendMRlTEST,3),round(XbendMRuTEST,3))) - Dat$bendsAll <- BPsMR_MU + Dat$coeffs_UN <- coeffsMU + names(coeffsMU) <- c("lowAsym REF", "slope REF", "upperAsym REF", "EC50 REF", "lowAsym TEST", "slope TEST", "upperAsym TEST", "r") + XbendMUlREF <- coeffsMU[4] - 1.5434 / abs(coeffsMU[2]) + XbendMUuREF <- coeffsMU[4] + 1.5434 / abs(coeffsMU[2]) + XbendMUlTEST <- coeffsMU[4] - coeffsMU[8] - 1.5434 / abs(coeffsMU[6]) + XbendMUuTEST <- coeffsMU[4] + coeffsMU[8] + 1.5434 / abs(coeffsMU[6]) + XbendMRlREF <- coeffsMR[4] - 1.5434 / abs(coeffsMR[2]) + XbendMRuREF <- coeffsMR[4] + 1.5434 / abs(coeffsMR[2]) + XbendMRlTEST <- coeffsMR[4] - coeffsMR[5] - 1.5434 / abs(coeffsMR[2]) + XbendMRuTEST <- coeffsMR[4] - coeffsMR[5] + 1.5434 / abs(coeffsMR[2]) + XasymlREF <- coeffsMR[4] - 3 / abs(coeffsMR[2]) + XasymuREF <- coeffsMR[4] + 3 / abs(coeffsMR[2]) + XasymlTEST <- coeffsMR[4] - coeffsMR[5] - 3 / abs(coeffsMR[2]) + XasymuTEST <- coeffsMR[4] - coeffsMR[5] + 3 / abs(coeffsMR[2]) + BPsMR_MU <- data.frame( + points = c( + "lower bendpoint REF", "upper bendpoint REF", "lower bendpoint TEST", "upper bendpoint TEST", + "lower asymp. point REF", "upper asymp. point REFr", "lower asymp. point TEST", "upper asymp. point TEST", + "bendREF_lower_unrestr", "bendREF_upper_unrestr", "bendTESTE_lower_unrestr", "bendTEST_upper_unrestr" + ), + estimates = c( + round(XbendMRlREF, 3), round(XbendMRuREF, 3), round(XbendMRlTEST, 3), round(XbendMRuTEST, 3), + round(XasymlREF, 3), round(XasymuREF, 3), round(XasymlTEST, 3), round(XasymuTEST, 3), + round(XbendMRlREF, 3), round(XbendMRuREF, 3), round(XbendMRlTEST, 3), round(XbendMRuTEST, 3) + ) + ) + Dat$bendsAll <- BPsMR_MU REP$bendsAll <- BPsMR_MU - + if (!PureErrFlag) { pot_est <- FITs[[3]] potU_est <- FITs[[4]] - colnames(pot_est) <- c("estimate","lowerCI","upperCI") - colnames(potU_est) <- c("estimate","lowerCI","upperCI") + colnames(pot_est) <- c("estimate", "lowerCI", "upperCI") + colnames(potU_est) <- c("estimate", "lowerCI", "upperCI") } else { - FitAnova <- anova(lm(readout ~ factor(log_dose)*isSample, all_l)) - meanPureErr <- FitAnova[4,3] - DFsPure <- FitAnova[4,1] - #VCOV <- vcov(mr) - V_V <- Smr$cov.unscaled #VCOV/Smr$sigma^2 - #VCOVpure <- V_V*meanPureErr - SEsPure <- sqrt(diag(V_V)*meanPureErr) - pot_est <- data.frame(estimate=exp(coeffsMR[5]), lowerCI = exp(coeffsMR[5]-qt(0.975,DFsPure)*SEsPure[5]), - upperCI = exp(coeffsMR[5]+qt(0.975,DFsPure)*SEsPure[5])) - #browser() - #VCOVu <- vcov(mu) + FitAnova <- anova(lm(readout ~ factor(log_dose) * isSample, all_l)) + meanPureErr <- FitAnova[4, 3] + DFsPure <- FitAnova[4, 1] + # VCOV <- vcov(mr) + V_V <- Smr$cov.unscaled # VCOV/Smr$sigma^2 + # VCOVpure <- V_V*meanPureErr + SEsPure <- sqrt(diag(V_V) * meanPureErr) + pot_est <- data.frame( + estimate = exp(coeffsMR[5]), lowerCI = exp(coeffsMR[5] - qt(0.975, DFsPure) * SEsPure[5]), + upperCI = exp(coeffsMR[5] + qt(0.975, DFsPure) * SEsPure[5]) + ) + # VCOVu <- vcov(mu) V_Vu <- Smu$cov.unscaled - #VCOVpure <- V_Vu*meanPureErr - SEsPureU <- sqrt(diag(V_Vu)*meanPureErr) - potU_est <- data.frame(estimate=exp(coeffsMU[8]), lowerCI = exp(coeffsMU[8]-qt(0.975,DFsPure)*SEsPureU[8]), - upperCI = exp(coeffsMU[8]+qt(0.975,DFsPure)*SEsPureU[8])) - + # VCOVpure <- V_Vu*meanPureErr + SEsPureU <- sqrt(diag(V_Vu) * meanPureErr) + potU_est <- data.frame( + estimate = exp(coeffsMU[8]), lowerCI = exp(coeffsMU[8] - qt(0.975, DFsPure) * SEsPureU[8]), + upperCI = exp(coeffsMU[8] + qt(0.975, DFsPure) * SEsPureU[8]) + ) } - - - #browser() - Dat$potDiffXL <- potU_est[1]*100 + + + Dat$potDiffXL <- potU_est[1] * 100 RMSE_unr_diagn <- Smu$sigma # sqrt(SU$resVar) - RMSE_res_diagn <- Smr$sigma #sqrt(SR$resVar) - up_lowDiffDiagn <- Smu$coefficients["ds",1]-Smu$coefficients["as",1] - ProzSD_diagn <- RMSE_unr_diagn*100/up_lowDiffDiagn + RMSE_res_diagn <- Smr$sigma # sqrt(SR$resVar) + up_lowDiffDiagn <- Smu$coefficients["ds", 1] - Smu$coefficients["as", 1] + ProzSD_diagn <- RMSE_unr_diagn * 100 / up_lowDiffDiagn Dat$ProzSD_XL <- ProzSD_diagn - + observe({ - pot_est3 <- data.frame(pot_est*100) + pot_est3 <- data.frame(pot_est * 100) MaxPl <- max(input$upperPot, pot_est3$upperCI) MinPl <- min(input$lowerPot, pot_est3$lowerCI) - MaxPl_ <- MaxPl*1.2 - MinPl_ <- MinPl*0.8 - #browser() - p_relCI <- ggplot(data=pot_est3, aes(xmin=lowerCI, xmax=upperCI, y=1)) + - geom_linerange(size=4, col="darkseagreen",alpha=0.5) + - geom_point(aes(x=estimate, y=1), col="grey15", shape=13, size=10) + - geom_vline(xintercept = c(input$lowerPot, input$upperPot), col="indianred") + - annotate("text", x=input$lowerPot-13, y=1.040, label=paste("lower EAC:", input$lowerPot), col="indianred") + - annotate("text", x=input$upperPot+13, y=1.040, label=paste("upper EAC:", input$upperPot), col="indianred") + - annotate("text", x=pot_est3$lowerCI-10, y=1.020, label=paste("lower CL:", round(pot_est3$lowerCI,1)), col="darkgreen") + - annotate("text", x=pot_est3$upperCI+10, y=1.020, label=paste("upper CL:", round(pot_est3$upperCI,1)), col="darkgreen") + - annotate("text", x=pot_est3$estimate, y=0.98, label=paste("rel. potency:", round(pot_est3$estimate,1)), col="black") + + MaxPl_ <- MaxPl * 1.2 + MinPl_ <- MinPl * 0.8 + p_relCI <- ggplot(data = pot_est3, aes(xmin = lowerCI, xmax = upperCI, y = 1)) + + geom_linerange(size = 4, col = "darkseagreen", alpha = 0.5) + + geom_point(aes(x = estimate, y = 1), col = "grey15", shape = 13, size = 10) + + geom_vline(xintercept = c(input$lowerPot, input$upperPot), col = "indianred") + + annotate("text", x = input$lowerPot - 13, y = 1.040, label = paste("lower EAC:", input$lowerPot), col = "indianred") + + annotate("text", x = input$upperPot + 13, y = 1.040, label = paste("upper EAC:", input$upperPot), col = "indianred") + + annotate("text", x = pot_est3$lowerCI - 10, y = 1.020, label = paste("lower CL:", round(pot_est3$lowerCI, 1)), col = "darkgreen") + + annotate("text", x = pot_est3$upperCI + 10, y = 1.020, label = paste("upper CL:", round(pot_est3$upperCI, 1)), col = "darkgreen") + + annotate("text", x = pot_est3$estimate, y = 0.98, label = paste("rel. potency:", round(pot_est3$estimate, 1)), col = "black") + ylim(c(0.95, 1.05)) + - xlim(c(MinPl_,MaxPl_)) + + xlim(c(MinPl_, MaxPl_)) + xlab("relative potency + confidence interval") + theme_bw() + - theme(axis.title.y=element_blank(), - axis.text.y=element_blank(), - axis.ticks.y=element_blank()) + theme( + axis.title.y = element_blank(), + axis.text.y = element_blank(), + axis.ticks.y = element_blank() + ) output$relpotTestPlot <- renderPlot({ p_relCI }) REP$relpotTestPlot <- p_relCI - - output$relpotTestTab <- renderTable({ pot_est3 }) + + output$relpotTestTab <- renderTable({ + pot_est3 + }) }) - - - + + ANOVAtab2 <- ANOVA4plUnresfunc(ro_new = XLdat2) - output$ANOVAXLS <- renderTable({ ANOVAtab2 }) - + output$ANOVAXLS <- renderTable({ + ANOVAtab2 + }) + REP$ANOVAXLS <- ANOVAtab2 - - #browser() + FITsTrans <- Fitting_FUNC(XLdat2, TransFlag = TRUE) - # - + # + SUlog <- FITsTrans[[2]] SRlog <- FITsTrans[[1]] RMSE_unrlog_diagn <- SUlog$sigma RMSE_reslog_diagn <- SRlog$sigma - - up_lowDifflogDiagn <- SUlog$coefficients["ds",1]-SUlog$coefficients["as",1] - ProzSDlog_diagn <- RMSE_unrlog_diagn * 100 / up_lowDifflogDiagn - + + up_lowDifflogDiagn <- SUlog$coefficients["ds", 1] - SUlog$coefficients["as", 1] + ProzSDlog_diagn <- RMSE_unrlog_diagn * 100 / up_lowDifflogDiagn + #### Diagnostic RMSE table #### - DiagnTable <- data.frame(parameter = c("RMSE unrestricted", "RMSE_restr.", "Diff_upper-lowerAsymp", "%SD (unrestricted)", - "RMSE log_unrestricted", "RMSE log_restr", "diff_up-lowAsymp_log", "%SD (log unrestricted)"), - result = c(round(RMSE_unr_diagn, 4), round(RMSE_res_diagn, 4), - round(up_lowDiffDiagn, 4), round(ProzSD_diagn, 4), - round(RMSE_unrlog_diagn, 4), round(RMSE_reslog_diagn, 4), - round(up_lowDifflogDiagn, 4), round(ProzSDlog_diagn, 4))) - + DiagnTable <- data.frame( + parameter = c( + "RMSE unrestricted", "RMSE_restr.", "Diff_upper-lowerAsymp", "%SD (unrestricted)", + "RMSE log_unrestricted", "RMSE log_restr", "diff_up-lowAsymp_log", "%SD (log unrestricted)" + ), + result = c( + round(RMSE_unr_diagn, 4), round(RMSE_res_diagn, 4), + round(up_lowDiffDiagn, 4), round(ProzSD_diagn, 4), + round(RMSE_unrlog_diagn, 4), round(RMSE_reslog_diagn, 4), + round(up_lowDifflogDiagn, 4), round(ProzSDlog_diagn, 4) + ) + ) + Dat$DiagnTable <- DiagnTable 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") - + + logpotest <- FITsTrans[[3]] # exp(confintd(mrlog, "r", method = "asymptotic")) # compParm(logpot, "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(logpotest) <- 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]))) + Filesample <- data.frame(Test = c("FILE NAME:", "SAMPLES"), Test2 = c(Dat$FileName, paste(cnXL[1], " vs ", cnXL[4]))) colnames(Filesample) <- c("", "") - output$Filesampl <- renderTable({ Filesample }, rownames = F) - - UnRPLAausw <- data.frame(Information = c("model", "lower asymptote Ref", "Hill's slope Ref", "upper asymptote Ref","EC50 Ref", - "lower asymptote Test", "Hill's slope Test", - "upper asymptote Test","EC50 Difference", - "relative potency", "lower CI", "upper CI"), - Results = unlist(c("UNRESTRICTED", round(coeffsMU, 3), round(potU_est*100, 3)))) # von psl_nls - + output$Filesampl <- renderTable( + { + Filesample + }, + rownames = F + ) + + UnRPLAausw <- data.frame( + Information = c( + "model", "lower asymptote Ref", "Hill's slope Ref", "upper asymptote Ref", "EC50 Ref", + "lower asymptote Test", "Hill's slope Test", + "upper asymptote Test", "EC50 Difference", + "relative potency", "lower CI", "upper CI" + ), + Results = unlist(c("UNRESTRICTED", round(coeffsMU, 3), round(potU_est * 100, 3))) + ) # von psl_nls + # "log relative potency", "log lower CI", "log upper CI", round(logpotest, 3), round(compParm(potu, "c", display = F), 3) - + output$coeffs_unr <- renderTable({ UnRPLAausw }) - - #browser() + UnRPLAausw2 <- data.frame(Dat$bendpointsTRANS) if (length(UnRPLAausw2) > 0) { colnames(UnRPLAausw2) <- c("bendpoints log") - UnrBendLog <- data.frame(Bendpoint = c("REF_lower","REF_upper", - "TEST_lower","REF_lower"), - bendpoints_logscale = UnRPLAausw2) - + UnrBendLog <- data.frame( + Bendpoint = c( + "REF_lower", "REF_upper", + "TEST_lower", "REF_lower" + ), + bendpoints_logscale = UnRPLAausw2 + ) + output$bends_unr2 <- renderTable({ UnrBendLog }) } - REP$UnRPLAausw <- UnRPLAausw + REP$UnRPLAausw <- UnRPLAausw REP$UnRPLAausw2 <- UnRPLAausw2 - - # browser() - coeffs_R <- coeffsMR # pot$coefficients + + 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") + names(coeffs_R) <- c("lower A", "slope", "upper A", "EC50 REF", "EC50 TEST") # --- Ergebnistabelle: RESTRICTED --- PLAAusw <- data.frame( - Information = c("model", "lower asymptote", "Hill's slope", "upper asymptote","EC50 Ref", - "EC50 Test", "relative potency", - "lower CI", "upper CI"), - Results = unlist(c("RESTRICTED", round(coeffs_R, 3), - round(pot_est[1, ] * 100, 3)))) # von gs1_nls - output$coeffs_r <- renderTable({ PLAAusw }) - - bendsAll <- data.frame(Dat$bendsAll[1:8,]) - output$bends_r2 <- renderTable({ bendsAll }, digits = 3, rownames = T) - + Information = c( + "model", "lower asymptote", "Hill's slope", "upper asymptote", "EC50 Ref", + "EC50 Test", "relative potency", + "lower CI", "upper CI" + ), + Results = unlist(c( + "RESTRICTED", round(coeffs_R, 3), + round(pot_est[1, ] * 100, 3) + )) + ) # von gs1_nls + output$coeffs_r <- renderTable({ + PLAAusw + }) + + bendsAll <- data.frame(Dat$bendsAll[1:8, ]) + output$bends_r2 <- renderTable( + { + bendsAll + }, + digits = 3, + rownames = T + ) + REP$PLAausw <- PLAAusw REP$PLBend <- bendsAll - + #### Parameter extraktion ---- 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") + # --- Ergebnistabelle: LOG RESTRICTED --- - + LogPLAAusw <- data.frame( - Information = c("model", "lower asymptote", "Hill's slope", "upper asymptote","EC50 Ref", - "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 gsl_nls - - output$logcoeffs_r <- renderTable({ LogPLAAusw }) + Information = c( + "model", "lower asymptote", "Hill's slope", "upper asymptote", "EC50 Ref", + "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 gsl_nls + + output$logcoeffs_r <- renderTable({ + LogPLAAusw + }) REP$LogPLAausw <- LogPLAAusw - - logcoeffs_UNR <- SUlog$coefficients[,1] - names(logcoeffs_UNR) <- c("lower asymptote Ref", "Hill's slope Ref", "upper asymptote Ref","EC50 Ref", - "lower asymptote Test", "Hill's slope Test", "upper asymptote Test","EC50 Diff" + + logcoeffs_UNR <- SUlog$coefficients[, 1] + names(logcoeffs_UNR) <- c( + "lower asymptote Ref", "Hill's slope Ref", "upper asymptote Ref", "EC50 Ref", + "lower asymptote Test", "Hill's slope Test", "upper asymptote Test", "EC50 Diff" ) - + # --- Ergebnistabelle: LOG UNRESTRICTED --- - + LogUnrPLAAusw <- data.frame( - Information = c("model", "lower asymptote Ref", "Hill's slope Ref", "upper asymptote Ref","EC50 Ref", - "lower asymptote Test", "Hill's slope Test", "upper asymptote Test","EC50 Diff" , - "relative potency", "lower CI", "upper CI"), - - Results = unlist(c("LOG UNRESTRICTED", round(logcoeffs_UNR, 3), - round(logpotUest * 100, 3)))) # von gsl_nls - + Information = c( + "model", "lower asymptote Ref", "Hill's slope Ref", "upper asymptote Ref", "EC50 Ref", + "lower asymptote Test", "Hill's slope Test", "upper asymptote Test", "EC50 Diff", + "relative potency", "lower CI", "upper CI" + ), + Results = unlist(c( + "LOG UNRESTRICTED", round(logcoeffs_UNR, 3), + round(logpotUest * 100, 3) + )) + ) # von gsl_nls + output$logcoeffs_unr <- renderTable({ LogUnrPLAAusw }) REP$LogUnrPLAausw <- LogUnrPLAAusw - #browser() - - - + + if (exists("Ind")) { - Dat$dilution <- XLdat[,Ind] - } else Dat$dilution <- exp(XLdat[,logI]) - - ##### Plot XL 4PL ---- + Dat$dilution <- XLdat[, Ind] + } else { + Dat$dilution <- exp(XLdat[, logI]) + } + + ##### Plot XL 4PL ---- output$XLplot <- renderPlot({ - XLplot4pl <- plot_f(XLdat2, TransFlag=F) + XLplot4pl <- plot_f(XLdat2, TransFlag = F) REP$XLplot4pl <- XLplot4pl - + XLplot4pl }) - + REP$XLdat2 <- XLdat2 - + # --- Diagnose-Plots (Residualanalyse) --- output$diagnplot <- renderPlot({ - op <- par(mfrow = c(2, 2), mar = c(3.2, 3.2, 2, .5), mgp = c(2, .7, 0)) + op <- par(mfrow = c(2, 2), mar = c(3.2, 3.2, 2, .5), mgp = c(2, .7, 0)) PREDs <- FITs[[5]] PREDsU <- FITs[[6]] # 1. Residuals vs Fitted @@ -934,588 +1084,696 @@ server <- function(input, output, session) { qqline(Smr$residuals) plot(Smu$residuals ~ PREDsU, main = "Residuals unrestricted") abline(h = 0) - + qqnorm(Smu$residuals) qqline(Smu$residuals) - + par(op) # Parameter zurücksetzen }) - - - pot <- drm(readout ~ Conc, isSample, data=all_l, fct=LL.4(names=c("b","d","a","c")), - pmodels=data.frame(1,1,1,isSample)) - potU <- drm(readout ~ Conc, isSample, data=all_l, fct=LL.4(names=c("b","d","a","c")), - pmodels=data.frame(isSample, isSample,isSample,isSample)) + + + pot <- drm(readout ~ Conc, isSample, + data = all_l, fct = LL.4(names = c("b", "d", "a", "c")), + pmodels = data.frame(1, 1, 1, isSample) + ) + potU <- drm(readout ~ Conc, isSample, + data = all_l, fct = LL.4(names = c("b", "d", "a", "c")), + pmodels = data.frame(isSample, isSample, isSample, isSample) + ) output$AIC <- renderTable({ AIC <- AIC(pot, potU) }) - - output$VarDiagn <- renderTable({ - DiagnTable - }, digits=4) - + + output$VarDiagn <- renderTable( + { + DiagnTable + }, + digits = 4 + ) + output$relpotplot <- renderPlot({ - relpot(potU, intervall="fieller", bty="l", - main="Quality of rel. potency over response") + relpot(potU, + intervall = "fieller", bty = "l", + main = "Quality of rel. potency over response" + ) }) - - - } # !please choose } # input$sheet } # input$iFile }) - + #### make geomDils reactive ---- observe({ - #browser() - if (is.null(input$ConcStart)) return(NULL) - if (!is.na(input$ConcStart) & !is.na(input$dilutionFac) &!is.na(input$NoDil) &!is.na(input$NoDilSer)) { + if (is.null(input$ConcStart)) { + return(NULL) + } + if (!is.na(input$ConcStart) & !is.na(input$dilutionFac) & !is.na(input$NoDil) & !is.na(input$NoDilSer)) { upR <- input$ConcStart noDil <- input$NoDil noDilSer <- input$NoDilSer Div <- input$dilutionFac res <- c() N_ <- 1 - Conc <- c(upR, divFUN(upR,Div,N=N_,res,noDil)) - + Conc <- c(upR, divFUN(upR, Div, N = N_, res, noDil)) + Dat$MetaConc <- Conc - } - }) - - - - observe({ - if(!is.null(Dat$MetaConc)) { - updateNumericInput(session, "CONC1", - value=as.numeric(Dat$MetaConc[1])) - updateNumericInput(session, "CONC2", - value=as.numeric(Dat$MetaConc[2])) - updateNumericInput(session, "CONC3", - value=as.numeric(Dat$MetaConc[3])) - updateNumericInput(session, "CONC4", - value=as.numeric(Dat$MetaConc[4])) - updateNumericInput(session, "CONC5", - value=as.numeric(Dat$MetaConc[5])) - updateNumericInput(session, "CONC6", - value=as.numeric(Dat$MetaConc[6])) - updateNumericInput(session, "CONC7", - value=as.numeric(Dat$MetaConc[7])) - updateNumericInput(session, "CONC8", - value=as.numeric(Dat$MetaConc[8])) - updateNumericInput(session, "CONC9", - value=as.numeric(Dat$MetaConc[9])) - updateNumericInput(session, "CONC10", - value=as.numeric(Dat$MetaConc[10])) - updateNumericInput(session, "CONC11", - value=as.numeric(Dat$MetaConc[11])) - updateNumericInput(session, "CONC12", - value=as.numeric(Dat$MetaConc[12])) - } }) - + + + observe({ + if (!is.null(Dat$MetaConc)) { + updateNumericInput(session, "CONC1", + value = as.numeric(Dat$MetaConc[1]) + ) + updateNumericInput(session, "CONC2", + value = as.numeric(Dat$MetaConc[2]) + ) + updateNumericInput(session, "CONC3", + value = as.numeric(Dat$MetaConc[3]) + ) + updateNumericInput(session, "CONC4", + value = as.numeric(Dat$MetaConc[4]) + ) + updateNumericInput(session, "CONC5", + value = as.numeric(Dat$MetaConc[5]) + ) + updateNumericInput(session, "CONC6", + value = as.numeric(Dat$MetaConc[6]) + ) + updateNumericInput(session, "CONC7", + value = as.numeric(Dat$MetaConc[7]) + ) + updateNumericInput(session, "CONC8", + value = as.numeric(Dat$MetaConc[8]) + ) + updateNumericInput(session, "CONC9", + value = as.numeric(Dat$MetaConc[9]) + ) + updateNumericInput(session, "CONC10", + value = as.numeric(Dat$MetaConc[10]) + ) + updateNumericInput(session, "CONC11", + value = as.numeric(Dat$MetaConc[11]) + ) + updateNumericInput(session, "CONC12", + value = as.numeric(Dat$MetaConc[12]) + ) + } + }) + #### render logDilsText ---- output$logdil <- renderText({ if (!is.null(Dat$MetaConc)) { Conc <- Dat$MetaConc - } else Conc <- CONC() - logdilu <-log(Conc) + } else { + Conc <- CONC() + } + logdilu <- log(Conc) logdilu }) - - + + #### reactive dataset sim ---- - + sim <- reactive({ - #browser() - if(is.null(sigmoid())) return(NULL) + if (is.null(sigmoid())) { + return(NULL) + } sd_fac_ <- as.numeric(input$sdfac) - r_ <- log(as.numeric(input$potencydiff)/100) - as = sigmoid()[1]; bs = sigmoid()[5];cs = sigmoid()[7];ds = sigmoid()[3];at = sigmoid()[2]; - bt = sigmoid()[6];r = sigmoid()[8]; ct = cs-r_; dt = sigmoid()[4]; + r_ <- log(as.numeric(input$potencydiff) / 100) + as <- sigmoid()[1] + bs <- sigmoid()[5] + cs <- sigmoid()[7] + ds <- sigmoid()[3] + at <- sigmoid()[2] + bt <- sigmoid()[6] + r <- sigmoid()[8] + ct <- cs - r_ + dt <- sigmoid()[4] if (!is.null(Dat$MetaConc)) Conc <- Dat$MetaConc else Conc <- CONC() log_conc <- log(Conc) - av_test <- as + (ds-as)/(1+exp(bs*(cs - log_conc))) - av_ref <- at + (dt-at)/(1+exp(bt*(ct - log_conc))) - #browser() + av_test <- as + (ds - as) / (1 + exp(bs * (cs - log_conc))) + av_ref <- at + (dt - at) / (1 + exp(bt * (ct - log_conc))) if (!is.na(input$NoDilSer)) { noDilSer <- input$NoDilSer } else if (!is.null(Dat$noDilSeriesXL)) noDilSer <- Dat$noDilSeriesXL else noDilSer <- 3 if (!is.na(input$NoDil)) noDil <- input$NoDil else noDil <- length(log_conc) - isRef <- rep(c(1,0), 1,each=noDilSer*noDil) - isSample <- rep(c(0,1), 1,each=noDilSer*noDil) - - #if (is.null(Dat$EXCEL)) { - ro_new <- Calc_DilRes(as=as,at=at,ds=ds,dt=dt,cs=cs,ct=ct,r=r_,bt=bt,bs=bs, log_conc = log_conc, - sd_fac=sd_fac_, - # auslenkU=outlierU, - # auslenkM=outlierM, - # auslenkL=outlierL, - heteroNoise = input$heterosked, noDilSeries = noDilSer, noDils = noDil) - #} else ro_new <- Dat$EXCEL + isRef <- rep(c(1, 0), 1, each = noDilSer * noDil) + isSample <- rep(c(0, 1), 1, each = noDilSer * noDil) + + # if (is.null(Dat$EXCEL)) { + ro_new <- Calc_DilRes( + as = as, at = at, ds = ds, dt = dt, cs = cs, ct = ct, r = r_, bt = bt, bs = bs, log_conc = log_conc, + sd_fac = sd_fac_, + # auslenkU=outlierU, + # auslenkM=outlierM, + # auslenkL=outlierL, + heteroNoise = input$heterosked, noDilSeries = noDilSer, noDils = noDil + ) + # } else ro_new <- Dat$EXCEL }) # }) - - ####sim2 ---- + + #### 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 Meta ---- output$plot4plMeta <- renderPlot({ PureErrFlag <- input$PureErrMeta warning_text3 <- reactive({ - ifelse(PureErrFlag, 'Pure error selected','') + ifelse(PureErrFlag, "Pure error selected", "") }) - + output$PureErrW4plMeta <- renderText(warning_text3()) - + sigmoid <- sigmoid() - det_sig=NULL + det_sig <- NULL plot_f(sim2(), TransFlag = F) }) - + #### Plot 4pl Meta Transformed ---- output$plot4plTransMeta <- renderPlot({ PureErrFlag <- input$PureErrMeta warning_text3 <- reactive({ - ifelse(PureErrFlag, 'Pure error selected','') + ifelse(PureErrFlag, "Pure error selected", "") }) output$PureErrWLogMeta <- renderText(warning_text3()) - #browser() sigmoid <- sigmoid() - det_sig=NULL + det_sig <- NULL plot_f(sim2(), TransFlag = T) }) - - + + #### Testergebnisse für 4PL Meta ---- observe({ - if (is.null(sim2())) return(NULL) - if (is.null(input$PureErrMeta)) return(NULL) - #observeEvent(input$StartCalc,{ + if (is.null(sim2())) { + return(NULL) + } + if (is.null(input$PureErrMeta)) { + return(NULL) + } + # observeEvent(input$StartCalc,{ PureErrFlag <- input$PureErrMeta warning_text3 <- reactive({ - ifelse(PureErrFlag, 'Pure error selected','') + ifelse(PureErrFlag, "Pure error selected", "") }) - - #browser() + output$PureErrW3 <- renderText(warning_text3()) - - 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), - as.numeric(input$lEACratioua), as.numeric(input$uEACratioua), - as.numeric(input$lowerPot), as.numeric(input$upperPot), - as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff)) + + 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), + as.numeric(input$lEACratioua), as.numeric(input$uEACratioua), + as.numeric(input$lowerPot), as.numeric(input$upperPot), + as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff) + ) Dat$limite <- Limite - #browser() - + tab <- tests_FUNC(sim2(), Limite, PureErrFlag = PureErrFlag) - if (length(tab)>1) { - tab[1,6:7] <- c("-","-") + if (length(tab) > 1) { + tab[1, 6:7] <- c("-", "-") Dat$tests_FUNC <- tab REP$testsTab <- tab - tab2 <- tab[1:7,] - - dat <- datatable(tab2, rownames=F, options = list( - paging=TRUE, - dom="t", - rownames=FALSE + tab2 <- tab[1:7, ] + + dat <- datatable(tab2, rownames = F, options = list( + paging = TRUE, + dom = "t", + rownames = FALSE )) %>% formatStyle("test_results", - target='row', - backgroundColor = styleEqual(c(-1,0,1), - c("pink",'lightgreen','lightgrey'))) - } else { dat <- datatable(data.frame(test_results = "Convergeance failed for the uploaded dataset")) } - #browser() - output$EQtests4pl <- renderDT({ dat}) - + target = "row", + backgroundColor = styleEqual( + c(-1, 0, 1), + c("pink", "lightgreen", "lightgrey") + ) + ) + } else { + dat <- datatable(data.frame(test_results = "Convergeance failed for the uploaded dataset")) + } + output$EQtests4pl <- renderDT({ + dat + }) }) # observe - + #### Testergebnisse 4PL für XLSX ---- observe({ - if (is.null(Dat$EXCEL)) return(NULL) - if (is.null(input$PureErr)) return(NULL) - if (!is.null(Dat$FITsFlag)) return(NULL) - - #observeEvent(input$StartCalc,{ + if (is.null(Dat$EXCEL)) { + return(NULL) + } + if (is.null(input$PureErr)) { + return(NULL) + } + if (!is.null(Dat$FITsFlag)) { + return(NULL) + } + + # observeEvent(input$StartCalc,{ PureErrFlag <- input$PureErr warning_text3 <- reactive({ - ifelse(PureErrFlag, 'Pure error selected','') + ifelse(PureErrFlag, "Pure error selected", "") }) - - + + output$PureErrW3 <- renderText(warning_text3()) - - 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), - as.numeric(input$lEACratioua), as.numeric(input$uEACratioua), - as.numeric(input$lowerPot), as.numeric(input$upperPot), - as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff)) + + 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), + as.numeric(input$lEACratioua), as.numeric(input$uEACratioua), + as.numeric(input$lowerPot), as.numeric(input$upperPot), + as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff) + ) Dat$limite <- Limite - #browser() SelTests <- as.numeric(input$selectedSSTs) tab <- tests_FUNC(Dat$EXCEL, Limite, PureErrFlag = PureErrFlag) - - tab[1,6:7] <- c("-","-") - - tab2 <- tab[SelTests,] + + tab[1, 6:7] <- c("-", "-") + + tab2 <- tab[SelTests, ] Dat$tests_FUNC <- tab2 REP$testsTab <- tab2 - + dat <- datatable(tab2, - rownames=FALSE, options = list( - paging=TRUE, - dom="t" - )) %>% formatStyle("test_results", - target='row', - backgroundColor = styleEqual(c(-1,0,1), - c("pink",'lightgreen','lightgrey'))) - - output$EQtests <- renderDT({ dat }) - + rownames = FALSE, options = list( + paging = TRUE, + dom = "t" + ) + ) %>% formatStyle("test_results", + target = "row", + backgroundColor = styleEqual( + c(-1, 0, 1), + c("pink", "lightgreen", "lightgrey") + ) + ) + + output$EQtests <- renderDT({ + dat + }) }) # observe - + #### plot CIs XL---- # observe({ # tab <- Dat$tests_FUNC # if (is.null(tab)) return(NULL) - # + # # tab2 <- tab[-c(1,2,3,6),] # tab2[,3:ncol(tab2)] <- apply(tab2[,3:ncol(tab2)],2,as.numeric) # tab2[4:5,3:7] <- tab2[4:5,3:7]/100 - # + # # p_CIs <- ggplot(tab2,aes(x=test,y=estimate, color=test,group=test)) + # geom_point() + # geom_errorbar(aes(ymin=lower_CI, ymax=upper_CI), width=0.4) + - # geom_crossbar(aes(ymin=lower_limit, ymax=upper_limit), size=0.8) + - # coord_flip() + + # geom_crossbar(aes(ymin=lower_limit, ymax=upper_limit), size=0.8) + + # coord_flip() + # theme_bw() + # theme(legend.position = "none",text = element_text(size=20)) - # + # # output$CIplot <- renderPlot({ p_CIs}, height=200) - # + # # REP$CIplot <- p_CIs # }) - + #### simulated data tab Meta ---- output$simdat <- DT::renderDataTable({ tab <- sim2() if (is.character(tab)) stop(tab) - + tab2 <- round(tab, 5) - colnames(tab2) <- c(paste("T", seq(1,(ncol(tab2)-1)/2)), - paste("R", seq(1,(ncol(tab2)-1)/2)), "log_conc" ) - dat <- datatable(tab2, options=list( - paging=T, - pageLength=20, - dom="t" - )) + colnames(tab2) <- c( + paste("T", seq(1, (ncol(tab2) - 1) / 2)), + paste("R", seq(1, (ncol(tab2) - 1) / 2)), "log_conc" + ) + dat <- datatable(tab2, options = list( + paging = T, + pageLength = 20, + dom = "t" + )) }) ##### Concentrationtab Meta ---- output$ConctabMeta <- DT::renderDataTable({ - if (!is.na(Dils()[1]) & is.na(Dils()[4])) return(NULL) + 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) - 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) - }) - - #### process XL linearly, Plot output ---- - output$plotLin <- renderPlot({ - - if (is.null(Dat$EXCEL)) return(NULL) - tab <- Dat$EXCEL - - # tab <- sim2() - if (is.character(tab)) stop(tab) - #browser() - log_conc <- tab$log_dose - noDilSer = (ncol(tab)-1)/2 - noDil <- nrow(tab) - 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) - 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 + } else { + noDilSer <- 3 } - indS <- which(abs(slopeSt[,2]) == max(abs(slopeSt[,2]))) - indT <- which(abs(slopeTe[,2]) == max(abs(slopeTe[,2]))) + Conc <- CONC() + Conctab <- perConcTab(tab, noDilSeries = noDilSer) + Dat$Conctab <- Conctab - 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) + 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) + }) - 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),] + output$Conctab <- 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 + } - circleS <- all_mS[(indS*noDilSer-(noDilSer-1)):((indS+2)*noDilSer),] - circleT <- all_mT[(indT*noDilSer-(noDilSer-1)):((indT+2)*noDilSer),] - circle <- rbind(circleS,circleT) + 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) + }) + + #### process XL linearly, Plot output ---- + output$plotLin <- renderPlot({ + if (is.null(Dat$EXCEL)) { + return(NULL) + } + tab <- Dat$EXCEL + + # tab <- sim2() + if (is.character(tab)) stop(tab) + log_conc <- tab$log_dose + noDilSer <- (ncol(tab) - 1) / 2 + noDil <- nrow(tab) + 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) + 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) Dat$circles <- circle REPlin$circles <- circle - #browser() sigmoid <- Dat$coeffsMUnr - + pLin <- PlotLinPLA_FUNC(circle, sigmoid = sigmoid, all_l2, pl_df, indS, indT) REPlin$pLin <- pLin - - pLin + + pLin }) - + #### process metadata, Plot output ---- output$plotLinMeta <- renderPlot({ tab <- sim2() - - if(is.null(tab)) return(NULL) + + 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 + if (!is.na(Dils()[4])) noDilSer <- Dils()[4] else noDilSer <- (ncol(tab) - 1) / 2 Conc <- CONC() 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) - 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 + if (!is.na(Dils()[3])) noDil <- Dils()[3] else noDil <- length(Conc) + + 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) - + + 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) + Dat$circlesMeta <- circle sigmoid <- sigmoid() - #browser() - pLin2 <- PlotLinPLA_FUNC(circle, sigmoid = sigmoid, all_l2, pl_df,indS, indT) - pLin2 + pLin2 <- PlotLinPLA_FUNC(circle, sigmoid = sigmoid, all_l2, pl_df, indS, indT) + pLin2 }) - + #### linear PLA tests Metadata ---- output$TESTSlinMeta <- DT::renderDataTable({ tab <- sim2() - if (is.null(tab)) return(NULL) + 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','') + ifelse(PureErrFlag, "Pure error is selected", "") }) output$PureErrW <- renderText(warning_text()) - #browser() - LIN <- ANOVAlintests(tab,circlesMeta,Limite,PureErrFlag=PureErrFlag) + 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) - + + 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) - + 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"))) - + + 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({ + # output$TESTSlin <- DT::renderDataTable({ observe({ - if (is.null(Dat$EXCEL)) return(NULL) - + if (is.null(Dat$EXCEL)) { + return(NULL) + } + 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), - as.numeric(input$lEACratioua), as.numeric(input$uEACratioua), - as.numeric(input$EACLinlow), as.numeric(input$EACLinupp), - as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff)) - + 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), + as.numeric(input$lEACratioua), as.numeric(input$uEACratioua), + as.numeric(input$EACLinlow), as.numeric(input$EACLinupp), + as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff) + ) + 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 + 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]))) - + + 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) - + + 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','') + ifelse(PureErrFlag, "Pure error is selected", "") }) output$PureErrW3 <- renderText(warning_text()) - #browser() - LIN <- ANOVAlintests(tab,circle,Limite,PureErrFlag=PureErrFlag) + LIN <- ANOVAlintests(tab, circle, Limite, PureErrFlag = PureErrFlag) df <- LIN[[1]] su_modU <- LIN[[2]] su_mod2 <- LIN[[4]] - - output$SummaryModABu <- renderTable({ su_modU }, digits=5) - output$SummaryModAB <- renderTable({ su_mod2 }, digits=5) - + + output$SummaryModABu <- renderTable( + { + su_modU + }, + digits = 5 + ) + output$SummaryModAB <- renderTable( + { + su_mod2 + }, + digits = 5 + ) + REPlin$SuModABu <- su_modU REPlin$SuModAB <- su_mod2 - + slopeDiffCI <- t(data.frame(LIN[[3]])) - colnames(slopeDiffCI) <- c("slope difference","lower CI","upper CI") - output$SlopeDiffCI <- renderTable({ slopeDiffCI },digits=5) - + colnames(slopeDiffCI) <- c("slope difference", "lower CI", "upper CI") + output$SlopeDiffCI <- renderTable( + { + slopeDiffCI + }, + digits = 5 + ) + SelTestsL <- as.numeric(input$selectedSSTsLinear) - df2 <- df[SelTestsL,] - + df2 <- df[SelTestsL, ] + REPlin$LinTests <- df2 - - Dat$ANOVA <- df[,4:length(df)] - dat <- datatable(df2[,1:3], - options=list( - paging=T, dom="t",rownames=F - )) %>% formatStyle("test_results", target="row",backgroundColor = styleEqual(c(-1,0,1), - c("pink","lightgreen","lightgrey"))) + + Dat$ANOVA <- df[, 4:length(df)] + dat <- datatable(df2[, 1:3], + options = list( + paging = T, dom = "t", rownames = F + ) + ) %>% formatStyle("test_results", target = "row", backgroundColor = styleEqual( + c(-1, 0, 1), + c("pink", "lightgreen", "lightgrey") + )) output$TESTSlin <- DT::renderDataTable({ dat }) }) - + #### output 4PL ANOVA tests Meta ---- output$ANOVA <- DT::renderDataTable({ sigmoid <- sigmoid() 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"))) + options = list( + dom = "t", rownames = F + ) + ) %>% formatStyle("p_value", + target = "row", + backgroundColor = styleEqual( + c("p_value"), + c("lightgrey") + ) + ) }) - + #### output 4PL ANOVA tests XL ---- # not needed # output$ANOVA_XL <- DT::renderDataTable({ @@ -1528,354 +1786,478 @@ server <- function(input, output, session) { # backgroundColor = styleEqual(c("p_value"), # c("lightgrey"))) # }) - - + + #### output RMSEs ---- output$RMSE <- renderText({ - 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 ) + 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) + if (is.null(Dat$ANOVA)) { + return(NULL) + } ANOVAlin <- Dat$ANOVA dat <- datatable(ANOVAlin, - options=list( - dom="t",rownames=F - )) %>% formatStyle("p.value", target='cell', - backgroundColor = styleEqual(c("p.value"), - c("lightgrey"))) + options = list( + dom = "t", rownames = F + ) + ) %>% formatStyle("p.value", + target = "cell", + backgroundColor = styleEqual( + c("p.value"), + c("lightgrey") + ) + ) }) - + 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"))) + 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), - as.numeric(input$lEACratioua), as.numeric(input$uEACratioua), - as.numeric(input$lowerPot), as.numeric(input$upperPot)) - + 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), + as.numeric(input$lEACratioua), as.numeric(input$uEACratioua), + as.numeric(input$lowerPot), as.numeric(input$upperPot) + ) + circles <- Dat$circles PureErrFlag <- input$PureErr - + warning_text2 <- reactive({ - ifelse(PureErrFlag, 'Pure Error is selected', '') + ifelse(PureErrFlag, "Pure Error is selected", "") }) output$PureErrWLinXL <- renderText(warning_text2()) - - LinPotTab <- LinPotTab(circles,Lim,PureErrFlag = PureErrFlag) + + LinPotTab <- LinPotTab(circles, Lim, PureErrFlag = PureErrFlag) REPlin$LinPotTab <- LinPotTab - + dat <- datatable(LinPotTab, - options=list( - dom="t",rownames=F - )) %>% formatStyle("test_result", target='row', - backgroundColor = styleEqual(c(0,1), c("#B5C74055","#F9545488"))) - }) - - + options = list( + dom = "t", rownames = F + ) + ) %>% formatStyle("test_result", + target = "row", + backgroundColor = styleEqual(c(0, 1), c("#B5C74055", "#F9545488")) + ) + }) + + ### 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)) - #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) + ) circles <- Dat$circlesMeta PureErrFlag <- input$PureErrMeta - pottab <- LinPotTab(circles,Lim,PureErrFlag = PureErrFlag) - #browser() + pottab <- LinPotTab(circles, Lim, PureErrFlag = PureErrFlag) dat <- datatable(pottab, - options=list( - dom="t",rownames=F - )) %>% formatStyle("test_result", target='row', - backgroundColor = styleEqual(c(0,1), c("#B5C74055","#F9545488"))) - }) - + options = list( + dom = "t", rownames = F + ) + ) %>% formatStyle("test_result", + target = "row", + backgroundColor = styleEqual(c(0, 1), c("#B5C74055", "#F9545488")) + ) + }) + #### 4pl potency table Meta ---- - observe({ - #browser() - if (is.null(sim2()) | is.null(Dils())) return(NULL) + observe({ + 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$PureErrMeta 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)) - - + 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]] ) { + 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]] ) { + } 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]] ) { + } 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]] ) { + } 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") - + } 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$pottab4pl <- 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("lightgreen","pink"))) + 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("lightgreen", "pink") + )) }) output$pottab4plTrans <- 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("lightgreen","pink"))) + 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("lightgreen", "pink") + )) }) -}) - + }) + #### 4pl potency table XL ---- observe({ - #browser() - if (is.null(Dat$EXCEL)) return(NULL) - if (!is.null(Dat$FITsFlag)) return(NULL) + if (is.null(Dat$EXCEL)) { + return(NULL) + } + if (!is.null(Dat$FITsFlag)) { + 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)) + 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) + ) REP$Lim <- Lim - + 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]] ) { + 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]] ) { + } 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]] ) { + } 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]] ) { + } 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") + } else { + test_potUCI_t <- 1 + } + pottab4_ <- cbind(pottab4_[, -(2:4)], data.frame(tests = c(test_potCI, test_potUCI, test_potCI_t, test_potUCI_t))) + colnames(pottab4_) <- c("model", "potency", "lower95%CI", "upper95%CI", "relative_lower95%CI", "relative_upper95%CI", "test_result") row.names(pottab4_) <- NULL - REP$pottab4plXL <- pottab4_[1:2,] - + REP$pottab4plXL <- pottab4_[1:2, ] + output$pottab4plXL <- DT::renderDataTable({ - dat <- datatable(pottab4_[1:2,],rownames=F, - options=list(digits=3, - paging=T, dom="t" - )) %>% formatStyle("test_result", target="row",backgroundColor = styleEqual(c(0,1), - c("#B5C74055","#F9545455"))) + dat <- datatable(pottab4_[1:2, ], + rownames = F, + options = list( + digits = 3, + paging = T, dom = "t" + ) + ) %>% formatStyle("test_result", target = "row", backgroundColor = styleEqual( + c(0, 1), + c("#B5C74055", "#F9545455") + )) }) output$pottab4plTransXL <- DT::renderDataTable({ - dat <- datatable(pottab4_[3:4,],rownames=F, - options=list(digits=3, - paging=T, dom="t" - )) %>% formatStyle("test_result", target="row",backgroundColor = styleEqual(c(0,1), - c("#B5C74055","#F9545455"))) + dat <- datatable(pottab4_[3:4, ], + rownames = F, + options = list( + digits = 3, + paging = T, dom = "t" + ) + ) %>% formatStyle("test_result", target = "row", backgroundColor = styleEqual( + c(0, 1), + c("#B5C74055", "#F9545455") + )) }) }) - - + + #### Dilutions Simulator ---- output$plotfordilutions <- renderPlot({ tab <- sim2() - #browser() tab <- as.data.frame(tab) dils <- tab$log_dose - min_y <- min(tab[,1:3]) - max_y <- max(tab[,1:3]) - + min_y <- min(tab[, 1:3]) + max_y <- max(tab[, 1:3]) + if (input$fixupper) { - dils_av <- dils-max(dils) - dils_av_ <- dils_av*(input$dilslider/100+1) - dils2 <- round(dils_av_ + max(dils),4) - dilfactors <- 1/exp(dils2-lag(dils2)) + dils_av <- dils - max(dils) + dils_av_ <- dils_av * (input$dilslider / 100 + 1) + dils2 <- round(dils_av_ + max(dils), 4) + dilfactors <- 1 / exp(dils2 - lag(dils2)) } else { if (!is.null(Dat$cfordils)) { av <- Dat$cfordils - } else { av <- (min(dils) + max(dils))/2 } - dils_av <- dils-av - dils_avsc <- dils_av*(input$dilslider/100+1) - dils2 <- dils_avsc+av - dilfactors <- 1/exp(dils2-lag(dils2)) + } else { + av <- (min(dils) + max(dils)) / 2 + } + dils_av <- dils - av + dils_avsc <- dils_av * (input$dilslider / 100 + 1) + dils2 <- dils_avsc + av + dilfactors <- 1 / exp(dils2 - lag(dils2)) } - + Dat$newDils <- dils2 - + sigmoid <- sigmoid() - - #browser() + BPs <- Dat$bendpoints - EC50REF <- (BPs[2]+BPs[1])/2 - Einh <- abs((BPs[2]-BPs[1])/5) - asyml <- EC50REF-2*(EC50REF-BPs[1]) - asymu <- EC50REF+2*(EC50REF-BPs[1]) - + EC50REF <- (BPs[2] + BPs[1]) / 2 + Einh <- abs((BPs[2] - BPs[1]) / 5) + asyml <- EC50REF - 2 * (EC50REF - BPs[1]) + asymu <- EC50REF + 2 * (EC50REF - BPs[1]) + det_sig <- Dat$coeffs_UN - + if (is.null(Dat$coeffs_UN)) { - SAMPLE50 <- sigmoid[1] + (sigmoid[3] - sigmoid[1])/(1+exp(sigmoid[5]*( (sigmoid[7]+0.693147)- dils2))) - SAMPLE200 <- sigmoid[1] + (sigmoid[3] - sigmoid[1])/(1+exp(sigmoid[5]*( (sigmoid[7]-0.693147)-dils2))) - Xbend50l <- sigmoid[7] + 0.693147-1.5434/sigmoid[5] - Xbend200l <- sigmoid[7] - 0.693147-1.5434/sigmoid[5] - Xbend50u <- sigmoid[7] + 0.693147+1.5434/sigmoid[5] - Xbend200u <- sigmoid[7] - 0.693147+1.5434/sigmoid[5] + SAMPLE50 <- sigmoid[1] + (sigmoid[3] - sigmoid[1]) / (1 + exp(sigmoid[5] * ((sigmoid[7] + 0.693147) - dils2))) + SAMPLE200 <- sigmoid[1] + (sigmoid[3] - sigmoid[1]) / (1 + exp(sigmoid[5] * ((sigmoid[7] - 0.693147) - dils2))) + Xbend50l <- sigmoid[7] + 0.693147 - 1.5434 / sigmoid[5] + Xbend200l <- sigmoid[7] - 0.693147 - 1.5434 / sigmoid[5] + Xbend50u <- sigmoid[7] + 0.693147 + 1.5434 / sigmoid[5] + Xbend200u <- sigmoid[7] - 0.693147 + 1.5434 / sigmoid[5] Xbend50 <- max(Xbend50l, Xbend50u) Xbend200 <- min(Xbend200l, Xbend200u) dummy <- plot_f(tab) } else { - - #browser() - SAMPLE50 <- det_sig[3] + (det_sig[5] - det_sig[3])/(1+exp(det_sig[1]*(det_sig[7]+0.693147-dils2))) - SAMPLE200 <- det_sig[3] + (det_sig[5] - det_sig[3])/(1+exp(det_sig[1]*(det_sig[7]-0.693147-dils2))) - Xbend50l <- det_sig[7] + 0.693147-1.5434/det_sig[1] - Xbend200l <- det_sig[7] - 0.693147-1.5434/det_sig[1] - Xbend50u <- det_sig[7] + 0.693147+1.5434/det_sig[1] - Xbend200u <- det_sig[7] - 0.693147+1.5434/det_sig[1] + SAMPLE50 <- det_sig[3] + (det_sig[5] - det_sig[3]) / (1 + exp(det_sig[1] * (det_sig[7] + 0.693147 - dils2))) + SAMPLE200 <- det_sig[3] + (det_sig[5] - det_sig[3]) / (1 + exp(det_sig[1] * (det_sig[7] - 0.693147 - dils2))) + Xbend50l <- det_sig[7] + 0.693147 - 1.5434 / det_sig[1] + Xbend200l <- det_sig[7] - 0.693147 - 1.5434 / det_sig[1] + Xbend50u <- 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) Xbend200 <- min(Xbend200l, Xbend200u) dummy <- plot_f(tab) } - - - - - + + pl_df <- cbind(dils2, SAMPLE50, SAMPLE200) - - #browser() + # scenario2 - eqSpac <- abs((BPs[1]-BPs[2])/5) - optdils <- c((asyml+BPs[1])/2, BPs[1], BPs[1]+1*eqSpac, BPs[1]+2*eqSpac,BPs[1]+3*eqSpac,BPs[1]+4*eqSpac,BPs[2], (asymu+BPs[2])/2) + eqSpac <- abs((BPs[1] - BPs[2]) / 5) + optdils <- c((asyml + BPs[1]) / 2, BPs[1], BPs[1] + 1 * eqSpac, BPs[1] + 2 * eqSpac, BPs[1] + 3 * eqSpac, BPs[1] + 4 * eqSpac, BPs[2], (asymu + BPs[2]) / 2) # scenario 3 - eqSpac_3 <- abs((BPs[1]-BPs[2])/3) - optdils_3 <- c(BPs[1]-2*eqSpac_3, BPs[1]-eqSpac_3, BPs[1], BPs[1]+1*eqSpac_3, BPs[1]+2*eqSpac_3,BPs[2], BPs[2]+eqSpac_3, BPs[2]+2*eqSpac_3) + eqSpac_3 <- abs((BPs[1] - BPs[2]) / 3) + optdils_3 <- c(BPs[1] - 2 * eqSpac_3, BPs[1] - eqSpac_3, BPs[1], BPs[1] + 1 * eqSpac_3, BPs[1] + 2 * eqSpac_3, BPs[2], BPs[2] + eqSpac_3, BPs[2] + 2 * eqSpac_3) # scenario 6 - Einh2 <- abs(((BPs[2]-BPs[1])*0.7)/5) - eqSpac2 <- (2*0.7/Einh)/3 - optdils2 <- c((asyml+BPs[1])/2, BPs[1], EC50REF-1.5*Einh2, EC50REF-0.5*Einh2,EC50REF+0.5*Einh2,EC50REF+1.5*Einh2, BPs[2], (asymu+BPs[2])/2) + Einh2 <- abs(((BPs[2] - BPs[1]) * 0.7) / 5) + eqSpac2 <- (2 * 0.7 / Einh) / 3 + optdils2 <- c((asyml + BPs[1]) / 2, BPs[1], EC50REF - 1.5 * Einh2, EC50REF - 0.5 * Einh2, EC50REF + 0.5 * Einh2, EC50REF + 1.5 * Einh2, BPs[2], (asymu + BPs[2]) / 2) # steep slope - eqSpac3 <- (abs(Xbend200-Xbend50))/5 - optdils3 <- c(Xbend200-eqSpac3,Xbend200, Xbend200+1*eqSpac3, Xbend200+2*eqSpac3,Xbend200+3*eqSpac3,Xbend200+4*eqSpac3,Xbend50, Xbend50+eqSpac3) - + eqSpac3 <- (abs(Xbend200 - Xbend50)) / 5 + optdils3 <- c(Xbend200 - eqSpac3, Xbend200, Xbend200 + 1 * eqSpac3, Xbend200 + 2 * eqSpac3, Xbend200 + 3 * eqSpac3, Xbend200 + 4 * eqSpac3, Xbend50, Xbend50 + eqSpac3) + output$extremebps <- renderTable({ - ExtremeBPs <- c(Xbend50,Xbend200) - DF2 <- data.frame(sample=c("50% sample (right)", "200% sample (left)"), Extreme_BPs=ExtremeBPs) + ExtremeBPs <- c(Xbend50, Xbend200) + DF2 <- data.frame(sample = c("50% sample (right)", "200% sample (left)"), Extreme_BPs = ExtremeBPs) DF2 }) - - optD <- data.frame(cbind(optdils, optdils_3,optdils2, optdils3)) - colnames(optD) <- c("scenario2","scenario3","scenario6","steep slope") - - output$optimalDils <- renderTable({ optD }) - - output$adjlogdil <- renderTable({ - adjlogdilfactors <- round(dilfactors,3) - adjlogdils <- round(dils2,3) - adjdils <- round(exp(dils2),3) - DilsTable <- data.frame('adjusted ln(dilutions)' = adjlogdils, - 'adjusted ln_dilution_factors' = adjlogdilfactors, - 'adjusted dilutions' = adjdils) + + optD <- data.frame(cbind(optdils, optdils_3, optdils2, optdils3)) + colnames(optD) <- c("scenario2", "scenario3", "scenario6", "steep slope") + + output$optimalDils <- renderTable({ + optD + }) + + output$adjlogdil <- renderTable({ + adjlogdilfactors <- round(dilfactors, 3) + adjlogdils <- round(dils2, 3) + adjdils <- round(exp(dils2), 3) + DilsTable <- data.frame( + "adjusted ln(dilutions)" = adjlogdils, + "adjusted ln_dilution_factors" = adjlogdilfactors, + "adjusted dilutions" = adjdils + ) DilsTable }) - + if (!is.null(Dat$p2)) { p2 <- Dat$p2 p_dil <- p2 + - annotate("pointrange",x=dils2,y=rep(min_y, length(dils2)), xmin=min(dils2), xmax=max(dils2)) + - annotate("text", x=dils2,y=rep(min_y+(max_y-min_y)*0.05, length(dils2)), label=as.character(round(dils2,3))) + - annotate("text", x=dils2[-1]+(max(dils2)-min(dils2))*0.05, - y=rep(min_y+(max_y-min_y)*0.1, length(dils2[-1])), - label=as.character(round(dilfactors[-1],3))) + - geom_line(data=as.data.frame(pl_df),aes(x=dils2,y=SAMPLE50), color="grey15", linetype=2, - inherit.aes = F) + - geom_line(data=as.data.frame(pl_df),aes(x=dils2,y=SAMPLE200), color="grey15", linetype=2, - inherit.aes = F) + - geom_vline(xintercept=c(Xbend50,Xbend200), col="grey15", linetype=2) + - {if (input$scenario =="scenario 6") annotate("pointrange",x=optdils2,y=rep(min_y+(max_y-min_y)*0.2, length(optdils2)), - xmin=min(optdils2), xmax=max(optdils2), color="seagreen")} + - {if (input$scenario =="scenario 6") annotate("text",x=optdils2,y=rep(min_y+(max_y-min_y)*0.25, length(optdils2)), - label=as.character(round(optdils2,3)), color="seagreen")} + - {if (input$scenario =="scenario 2") annotate("pointrange",x=optdils,y=rep(min_y+(max_y-min_y)*0.2, length(optdils)), - xmin=min(optdils), xmax=max(optdils), color="seagreen")} + - {if (input$scenario =="scenario 2") annotate("text",x=optdils,y=rep(min_y+(max_y-min_y)*0.25, length(optdils)), - label=as.character(round(optdils,3)), color="seagreen")} + - {if (input$scenario =="scenario 3") annotate("pointrange",x=optdils_3,y=rep(min_y+(max_y-min_y)*0.2, length(optdils_3)), - xmin=min(optdils_3), xmax=max(optdils_3), color="seagreen")} + - {if (input$scenario =="scenario 3") annotate("text",x=optdils_3,y=rep(min_y+(max_y-min_y)*0.25, length(optdils_3)), - label=as.character(round(optdils_3,3)), color="seagreen")} + - {if (input$scenario =="steep slope") annotate("pointrange",x=optdils3,y=rep(min_y+(max_y-min_y)*0.2, length(optdils3)), - xmin=min(optdils3), xmax=max(optdils3), color="seagreen")} + - {if (input$scenario =="steep slope") annotate("text",x=optdils3,y=rep(min_y+(max_y-min_y)*0.25, length(optdils3)), - label=as.character(round(optdils3,3)), color="seagreen")} + - annotate("text",x=optdils[1],y=(max_y+min_y)*0.5, - label=paste("in green: optimal \n dilutions acc. to Whitepaper\n", input$scenario), color="seagreen", - size=14/.pt,fontface="bold") + annotate("pointrange", x = dils2, y = rep(min_y, length(dils2)), xmin = min(dils2), xmax = max(dils2)) + + annotate("text", x = dils2, y = rep(min_y + (max_y - min_y) * 0.05, length(dils2)), label = as.character(round(dils2, 3))) + + annotate("text", + x = dils2[-1] + (max(dils2) - min(dils2)) * 0.05, + y = rep(min_y + (max_y - min_y) * 0.1, length(dils2[-1])), + label = as.character(round(dilfactors[-1], 3)) + ) + + geom_line( + data = as.data.frame(pl_df), aes(x = dils2, y = SAMPLE50), color = "grey15", linetype = 2, + inherit.aes = F + ) + + geom_line( + data = as.data.frame(pl_df), aes(x = dils2, y = SAMPLE200), color = "grey15", linetype = 2, + inherit.aes = F + ) + + geom_vline(xintercept = c(Xbend50, Xbend200), col = "grey15", linetype = 2) + + { + if (input$scenario == "scenario 6") { + annotate("pointrange", + x = optdils2, y = rep(min_y + (max_y - min_y) * 0.2, length(optdils2)), + xmin = min(optdils2), xmax = max(optdils2), color = "seagreen" + ) + } + } + + { + if (input$scenario == "scenario 6") { + annotate("text", + x = optdils2, y = rep(min_y + (max_y - min_y) * 0.25, length(optdils2)), + label = as.character(round(optdils2, 3)), color = "seagreen" + ) + } + } + + { + if (input$scenario == "scenario 2") { + annotate("pointrange", + x = optdils, y = rep(min_y + (max_y - min_y) * 0.2, length(optdils)), + xmin = min(optdils), xmax = max(optdils), color = "seagreen" + ) + } + } + + { + if (input$scenario == "scenario 2") { + annotate("text", + x = optdils, y = rep(min_y + (max_y - min_y) * 0.25, length(optdils)), + label = as.character(round(optdils, 3)), color = "seagreen" + ) + } + } + + { + if (input$scenario == "scenario 3") { + annotate("pointrange", + x = optdils_3, y = rep(min_y + (max_y - min_y) * 0.2, length(optdils_3)), + xmin = min(optdils_3), xmax = max(optdils_3), color = "seagreen" + ) + } + } + + { + if (input$scenario == "scenario 3") { + annotate("text", + x = optdils_3, y = rep(min_y + (max_y - min_y) * 0.25, length(optdils_3)), + label = as.character(round(optdils_3, 3)), color = "seagreen" + ) + } + } + + { + if (input$scenario == "steep slope") { + annotate("pointrange", + x = optdils3, y = rep(min_y + (max_y - min_y) * 0.2, length(optdils3)), + xmin = min(optdils3), xmax = max(optdils3), color = "seagreen" + ) + } + } + + { + if (input$scenario == "steep slope") { + annotate("text", + x = optdils3, y = rep(min_y + (max_y - min_y) * 0.25, length(optdils3)), + label = as.character(round(optdils3, 3)), color = "seagreen" + ) + } + } + + annotate("text", + x = optdils[1], y = (max_y + min_y) * 0.5, + label = paste("in green: optimal \n dilutions acc. to Whitepaper\n", input$scenario), color = "seagreen", + size = 14 / .pt, fontface = "bold" + ) } print(p_dil) - }) - + #### Dilutions CI table ---- observe({ - if (is.null(input$potencydiff)) return(NULL) + if (is.null(input$potencydiff)) { + return(NULL) + } output$CIs <- renderTable({ PureErrFlag <- input$PureErr if (is.null(Dat$coeffs_UN)) { # checks if an EXCEL was uploaded sigmoid <- sigmoid() - det_sig=NULL - - ast = sigmoid()[1];bst = sigmoid()[5];cst = sigmoid()[7];dst = sigmoid()[3];ate = sigmoid()[2]; - bte = sigmoid()[6];r_ = sigmoid()[8]; - cte = cst-r_;dte = sigmoid()[4]; + det_sig <- NULL + + ast <- sigmoid()[1] + bst <- sigmoid()[5] + cst <- sigmoid()[7] + dst <- sigmoid()[3] + ate <- sigmoid()[2] + bte <- sigmoid()[6] + r_ <- sigmoid()[8] + cte <- cst - r_ + dte <- sigmoid()[4] } else { sigmoid <- NULL det_sig <- Dat$coeffs_UN @@ -1884,264 +2266,275 @@ server <- function(input, output, session) { bst <- det_sig[1] bte <- det_sig[2] cst <- det_sig[7] - cte <- det_sig[7] -log(input$potencydiff/100) + cte <- det_sig[7] - log(input$potencydiff / 100) dst <- det_sig[5] dte <- det_sig[6] - r_ <- log(input$potencydiff/100) - + r_ <- log(input$potencydiff / 100) } if (!is.na(input$NoDilSer)) { noDilSer <- input$NoDilSer } else if (!is.null(Dat$NoDilSeriesXL)) noDilSer <- Dat$noDilSeriesXL else noDilSer <- 3 if (!is.na(input$NoDil)) noDil <- input$NoDil else noDil <- length(Dat$newDils) - #browser() - tab <- Calc_DilRes(as=ast,at=ate,ds=dst,dt=dte,cs=cst,ct=cte,r=r_,bt=bte,bs=bst, - sd_fac=input$sdfac,log_conc=Dat$newDils, - # auslenkU=outlierU, - # auslenkM=outlierM, - # auslenkL=outlierL, - heteroNoise = FALSE, noDilSeries = noDilSer, noDils = noDil) - 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), - as.numeric(input$lEACratioua), as.numeric(input$uEACratioua), - as.numeric(input$lowerPot), as.numeric(input$upperPot), - as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff)) - - CItable <- tests_FUNC(tab,Limite,PureErrFlag=PureErrFlag) - - CItable_ <- CItable[-c(1,2,6,8,9),-c(2,4,5)] + tab <- Calc_DilRes( + as = ast, at = ate, ds = dst, dt = dte, cs = cst, ct = cte, r = r_, bt = bte, bs = bst, + sd_fac = input$sdfac, log_conc = Dat$newDils, + # auslenkU=outlierU, + # auslenkM=outlierM, + # auslenkL=outlierL, + heteroNoise = FALSE, noDilSeries = noDilSer, noDils = noDil + ) + 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), + as.numeric(input$lEACratioua), as.numeric(input$uEACratioua), + as.numeric(input$lowerPot), as.numeric(input$upperPot), + as.numeric(input$lEACratioAdiff), as.numeric(input$uEACratioAdiff) + ) + + CItable <- tests_FUNC(tab, Limite, PureErrFlag = PureErrFlag) + + CItable_ <- CItable[-c(1, 2, 6, 8, 9), -c(2, 4, 5)] potAll <- pot4plFUNC(tab, input$PureErr) - restrPot <- potAll[1,1:4] - restrPot[2:4] <- round(as.numeric(restrPot[2:4]),5) + restrPot <- potAll[1, 1:4] + restrPot[2:4] <- round(as.numeric(restrPot[2:4]), 5) potAll_ <- rbind(CItable_, restrPot) - potAll_$CIwidth <- as.numeric(potAll_[,4])-as.numeric(potAll_[,3]) - potAll_[,1] <- c("ratio of lower asymptotes","ratio of slopes","ratio of upper asymptotes", "ratio of asympt. differences","restricted potency") - + potAll_$CIwidth <- as.numeric(potAll_[, 4]) - as.numeric(potAll_[, 3]) + potAll_[, 1] <- c("ratio of lower asymptotes", "ratio of slopes", "ratio of upper asymptotes", "ratio of asympt. differences", "restricted potency") + output$bps <- renderTable({ - DF <- data.frame(sample=names(Dat$bendpoints),BPs=Dat$bendpoints) + DF <- data.frame(sample = names(Dat$bendpoints), BPs = Dat$bendpoints) DF }) return(potAll_) }) }) - + #### simulations ---- observe({ - observeEvent(input$goSim,{ + observeEvent(input$goSim, { sd_fac_ <- as.numeric(input$sdfac) - - r_ <- log(as.numeric(input$potencydiff)/100) + + r_ <- log(as.numeric(input$potencydiff) / 100) Conc <- Dat$MetaConc - as = sigmoid()[1]; bs = sigmoid()[5];cs = sigmoid()[7];ds = sigmoid()[3];at = sigmoid()[2]; - bt = sigmoid()[6];r = sigmoid()[8]; ct = cs-r_; dt = sigmoid()[4] - + as <- sigmoid()[1] + bs <- sigmoid()[5] + cs <- sigmoid()[7] + ds <- sigmoid()[3] + at <- sigmoid()[2] + bt <- sigmoid()[6] + r <- sigmoid()[8] + ct <- cs - r_ + dt <- sigmoid()[4] + if (!is.null(Dat$MetaConc)) { Conc <- Dat$MetaConc } else { Conc <- CONC() } log_dose <- log(Conc) - yAxfac <- (ds-as) - + yAxfac <- (ds - as) + if (!is.na(input$NoDilSer)) { noDilSer <- input$NoDilSer } else if (!is.null(Dat$NoDilSeriesXL)) noDilSer <- Dat$noDilSeriesXL else noDilSer <- 3 if (!is.na(input$NoDil)) noDil <- input$NoDil else noDil <- length(Conc) - isRef <- rep(c(1,0),1,each=noDilSer*noDil) - isSample <- rep(c(0,1),1,each=noDilSer*noDil) + isRef <- rep(c(1, 0), 1, each = noDilSer * noDil) + isSample <- rep(c(0, 1), 1, each = noDilSer * noDil) N <- as.numeric(input$simN) - - av <- as*isRef + at*isSample + (ds*isRef + dt*isSample - as*isRef - at*isSample)/ - (1+isRef*exp(bs*(cs - log_dose)) + isSample*exp(bt*(ct-log_dose))) - - resHist <- matrix(NA,nrow=N, ncol=13) + + av <- as * isRef + at * isSample + (ds * isRef + dt * isSample - as * isRef - at * isSample) / + (1 + isRef * exp(bs * (cs - log_dose)) + isSample * exp(bt * (ct - log_dose))) + + resHist <- matrix(NA, nrow = N, ncol = 13) residualsList <- list() start.time2 <- Sys.time() - withProgress(message = 'Making plot', value=0, { + withProgress(message = "Making plot", value = 0, { for (i in 1:N) { if (input$heterosked) { # heterosc noise - ro_jit <- matrix(unlist(map(av, function(x) x+rnorm(1,0,x*sd_fac_/100))), nrow=noDil, ncol=noDilSer*2) + ro_jit <- matrix(unlist(map(av, function(x) x + rnorm(1, 0, x * sd_fac_ / 100))), nrow = noDil, ncol = noDilSer * 2) } else { # homosc noise - ro_jit <- matrix(unlist(map(av, function(x) x+rnorm(1,0,sd_fac_*yAxfac/100))), nrow=noDil, ncol=noDilSer*2) + ro_jit <- matrix(unlist(map(av, function(x) x + rnorm(1, 0, sd_fac_ * yAxfac / 100))), nrow = noDil, ncol = noDilSer * 2) } - # browser() ro_jit <- abs(ro_jit) ro_new <- cbind(ro_jit, log_dose) - 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") all_l$isRef <- isRef all_l$isSample <- isSample all_l$Conc <- exp(all_l$log_dose) - pot <- drm(readout ~ Conc, isSample, data=all_l, fct=LL.4(names=c("b","d","a","c")), - pmodels=data.frame(1,1,1,isSample)) - potAll <- EDcomp(pot, percVec=c(50,50), interval="delta", display=FALSE) + pot <- drm(readout ~ Conc, isSample, + data = all_l, fct = LL.4(names = c("b", "d", "a", "c")), + pmodels = data.frame(1, 1, 1, isSample) + ) + potAll <- EDcomp(pot, percVec = c(50, 50), interval = "delta", display = FALSE) potAll2 <- potAll[1:3] - RSS <- sum(pot$predres[,2]^2) - dfreed <- nrow(all_l)-5 - MSE <- RSS/dfreed - - potU <- drm(readout ~ Conc, isSample, data=all_l, fct=LL.4(names=c("b","d","a","c")), - pmodels=data.frame(isSample, isSample,isSample,isSample)) - DF_U <- nrow(all_l)-8 - - uAsratio <- compParm(potU, "a",display=F) - uCIuAs <- uAsratio[1]+qt(0.975,DF_U)*uAsratio[2] - lCIuAs <- uAsratio[1]-qt(0.975,DF_U)*uAsratio[2] - lAsratio <- compParm(potU, "d",display=F) - uCIlAs <- lAsratio[1]+qt(0.975,DF_U)*lAsratio[2] - lCIlAs <- lAsratio[1]-qt(0.975,DF_U)*lAsratio[2] - Sloperatio <- compParm(potU, "b",display=F) - uCISlo <- Sloperatio[1]+qt(0.975,DF_U)*Sloperatio[2] - lCISlo <- Sloperatio[1]-qt(0.975,DF_U)*Sloperatio[2] + RSS <- sum(pot$predres[, 2]^2) + dfreed <- nrow(all_l) - 5 + MSE <- RSS / dfreed + + potU <- drm(readout ~ Conc, isSample, + data = all_l, fct = LL.4(names = c("b", "d", "a", "c")), + pmodels = data.frame(isSample, isSample, isSample, isSample) + ) + DF_U <- nrow(all_l) - 8 + + uAsratio <- compParm(potU, "a", display = F) + uCIuAs <- uAsratio[1] + qt(0.975, DF_U) * uAsratio[2] + lCIuAs <- uAsratio[1] - qt(0.975, DF_U) * uAsratio[2] + lAsratio <- compParm(potU, "d", display = F) + uCIlAs <- lAsratio[1] + qt(0.975, DF_U) * lAsratio[2] + lCIlAs <- lAsratio[1] - qt(0.975, DF_U) * lAsratio[2] + Sloperatio <- compParm(potU, "b", display = F) + uCISlo <- Sloperatio[1] + qt(0.975, DF_U) * Sloperatio[2] + lCISlo <- Sloperatio[1] - qt(0.975, DF_U) * Sloperatio[2] su <- summary(potU) - - v <- vcov(potU)[c(5,6),c(5,6)] - Vd <- vcov(potU)[c(3,4),c(3,4)] - Va_d <- v+Vd - - A_DTEST <- su$coefficients[6,1]-su$coefficients[4,1] - A_DREF <- su$coefficients[5,1]-su$coefficients[3,1] - if (abs(at/(sqrt(Va_d[2,2]/3))) > qt(0.95,2)) { - try(Fie_ad <- round(FiellerRatio(A_DREF,A_DTEST, Va_d),5)) + + v <- vcov(potU)[c(5, 6), c(5, 6)] + Vd <- vcov(potU)[c(3, 4), c(3, 4)] + Va_d <- v + Vd + + A_DTEST <- su$coefficients[6, 1] - su$coefficients[4, 1] + A_DREF <- su$coefficients[5, 1] - su$coefficients[3, 1] + if (abs(at / (sqrt(Va_d[2, 2] / 3))) > qt(0.95, 2)) { + try(Fie_ad <- round(FiellerRatio(A_DREF, A_DTEST, Va_d), 5)) } if (!exists("Fie_ad")) Fie_ad <- NA - - resHist[i,] <- c(potAll2, sqrt(MSE),Sloperatio[1],lCISlo, uCISlo, - uAsratio[1], lCIuAs, uCIuAs, Fie_ad[1],Fie_ad[2],Fie_ad[3]) - colnames(resHist) <- c("pot4pl","lCI4pl","uCI4pl","RMSE","estSlope_ratio", - "lCISlope_ratio","uCISlope_ratio","estuAs_ratio", - "lCIuAs_ratio","uCIuAs_ratio","estAsyDiff_ratio", - "lCIAsyDiff_ratio", "uCIAsyDiff_ratio") - - incProgress(1/N, detail=paste("Doing simulations",i)) - } # withProgress - + + resHist[i, ] <- c( + potAll2, sqrt(MSE), Sloperatio[1], lCISlo, uCISlo, + uAsratio[1], lCIuAs, uCIuAs, Fie_ad[1], Fie_ad[2], Fie_ad[3] + ) + colnames(resHist) <- c( + "pot4pl", "lCI4pl", "uCI4pl", "RMSE", "estSlope_ratio", + "lCISlope_ratio", "uCISlope_ratio", "estuAs_ratio", + "lCIuAs_ratio", "uCIuAs_ratio", "estAsyDiff_ratio", + "lCIAsyDiff_ratio", "uCIAsyDiff_ratio" + ) + + incProgress(1 / N, detail = paste("Doing simulations", i)) + } # withProgress }) end.time2 <- Sys.time() - + Dat$resHist <- resHist }) }) - - + + #### simulation Histograms output ---- - + output$plotHistuAs <- renderPlot({ if (!is.null(Dat$resHist)) { - resHist <- Dat$resHist - #browser() - resHistuAs <- as.data.frame(resHist[,8:10]) - resHistuAs_l <- melt(data.frame(resHistuAs), variable.name="ratio_CIs", value.name = "readout") - #browser() - lowquant_uAs <- quantile(resHistuAs[,2], probs=as.numeric(input$lowQuant)/100) - upquant_uAs <- quantile(resHistuAs[,3], probs=as.numeric(input$uppQuant)/100) - + resHistuAs <- as.data.frame(resHist[, 8:10]) + resHistuAs_l <- melt(data.frame(resHistuAs), variable.name = "ratio_CIs", value.name = "readout") + lowquant_uAs <- quantile(resHistuAs[, 2], probs = as.numeric(input$lowQuant) / 100) + upquant_uAs <- quantile(resHistuAs[, 3], probs = as.numeric(input$uppQuant) / 100) + p_uAs <- ggplot(resHistuAs_l) + - geom_histogram(aes(readout, fill=ratio_CIs),alpha=0.5,position="identity") + - labs(title = paste("upper asymptote ratio EACs:", round(lowquant_uAs,3), " to ", round(upquant_uAs,3))) + - geom_vline(xintercept = c(lowquant_uAs, upquant_uAs), color="black", linetype="dashed", linewidth=1) + - geom_vline(xintercept = c(input$lEACratioua , input$uEACratioua), color="red", linetype="dashed", linewidth=1) + + geom_histogram(aes(readout, fill = ratio_CIs), alpha = 0.5, position = "identity") + + labs(title = paste("upper asymptote ratio EACs:", round(lowquant_uAs, 3), " to ", round(upquant_uAs, 3))) + + geom_vline(xintercept = c(lowquant_uAs, upquant_uAs), color = "black", linetype = "dashed", linewidth = 1) + + geom_vline(xintercept = c(input$lEACratioua, input$uEACratioua), color = "red", linetype = "dashed", linewidth = 1) + theme_bw() - + # asympt diff ratio - resHistAsDiff <- as.data.frame(resHist[,11:13]) - resHistAsDiff_l <- melt(data.frame(resHistAsDiff), variable.name="ratio_CIs", value.name = "readout") - - lowquant_AsDiff <- quantile(resHistAsDiff[,2], probs=as.numeric(input$lowQuant)/100) - upquant_AsDiff <- quantile(resHistAsDiff[,3], probs=as.numeric(input$uppQuant)/100) - - p_AsDiff <- ggplot(resHistAsDiff_l, aes(readout, fill=ratio_CIs)) + - geom_histogram(alpha=0.5,position="identity") + - labs(title = paste("asymptote diff. ratio EACs:", round(lowquant_AsDiff,3), " to ", round(upquant_AsDiff,3))) + - geom_vline(xintercept = c(lowquant_AsDiff, upquant_AsDiff), color="black", linetype="dashed", linewidth=1) + - geom_vline(xintercept = c(input$lEACratioAdiff , input$uEACratioAdiff), color="red", linetype="dashed", linewidth=1) + + resHistAsDiff <- as.data.frame(resHist[, 11:13]) + resHistAsDiff_l <- melt(data.frame(resHistAsDiff), variable.name = "ratio_CIs", value.name = "readout") + + lowquant_AsDiff <- quantile(resHistAsDiff[, 2], probs = as.numeric(input$lowQuant) / 100) + upquant_AsDiff <- quantile(resHistAsDiff[, 3], probs = as.numeric(input$uppQuant) / 100) + + p_AsDiff <- ggplot(resHistAsDiff_l, aes(readout, fill = ratio_CIs)) + + geom_histogram(alpha = 0.5, position = "identity") + + labs(title = paste("asymptote diff. ratio EACs:", round(lowquant_AsDiff, 3), " to ", round(upquant_AsDiff, 3))) + + geom_vline(xintercept = c(lowquant_AsDiff, upquant_AsDiff), color = "black", linetype = "dashed", linewidth = 1) + + geom_vline(xintercept = c(input$lEACratioAdiff, input$uEACratioAdiff), color = "red", linetype = "dashed", linewidth = 1) + theme_bw() - + # Slope ratio - resHistSlo <- as.data.frame(resHist[,5:7]) - resHistSlo_l <- melt(data.frame(resHistSlo), variable.name="ratio_CIs", value.name = "readout") - - lowquant_Slo <- quantile(resHistSlo[,2], probs=as.numeric(input$lowQuant)/100) - upquant_Slo <- quantile(resHistSlo[,3], probs=as.numeric(input$uppQuant)/100) - - p_Slo <- ggplot(resHistSlo_l, aes(readout, fill=ratio_CIs)) + - geom_histogram(alpha=0.5,position="identity") + - labs(title = paste("Slope ratio EACs:", round(lowquant_Slo,3), " to ", round(upquant_Slo,3))) + - geom_vline(xintercept = c(lowquant_Slo, upquant_Slo), color="black", linetype="dashed", linewidth=1) + - geom_vline(xintercept = c(input$lEACratioSlope , input$uEACratioSlope), color="red", linetype="dashed", linewidth=1) + + resHistSlo <- as.data.frame(resHist[, 5:7]) + resHistSlo_l <- melt(data.frame(resHistSlo), variable.name = "ratio_CIs", value.name = "readout") + + lowquant_Slo <- quantile(resHistSlo[, 2], probs = as.numeric(input$lowQuant) / 100) + upquant_Slo <- quantile(resHistSlo[, 3], probs = as.numeric(input$uppQuant) / 100) + + p_Slo <- ggplot(resHistSlo_l, aes(readout, fill = ratio_CIs)) + + geom_histogram(alpha = 0.5, position = "identity") + + labs(title = paste("Slope ratio EACs:", round(lowquant_Slo, 3), " to ", round(upquant_Slo, 3))) + + geom_vline(xintercept = c(lowquant_Slo, upquant_Slo), color = "black", linetype = "dashed", linewidth = 1) + + geom_vline(xintercept = c(input$lEACratioSlope, input$uEACratioSlope), color = "red", linetype = "dashed", linewidth = 1) + theme_bw() - + # poency ratio - resHistPot <- as.data.frame(resHist[,1:3]) - resHistPot_l <- melt(data.frame(resHistPot), variable.name="ratio_CIs", value.name = "readout") - - lowquant_Pot <- quantile(resHistPot[,2], probs=as.numeric(input$lowQuant)/100) - upquant_Pot <- quantile(resHistPot[,3], probs=as.numeric(input$uppQuant)/100) - #browser() - p_Pot <- ggplot(resHistPot_l, aes(readout, fill=ratio_CIs)) + - geom_histogram(alpha=0.5,position="identity") + - labs(title = paste("Poency ratio EACs:", round(lowquant_Pot,3), " to ", round(upquant_Pot,3))) + - geom_vline(xintercept = c(lowquant_Pot, upquant_Pot), color="black", linetype="dashed", linewidth=1) + - geom_vline(xintercept = c(input$lowerPot/100, input$upperPot/100), color="red", linetype="dashed", linewidth=1) + + resHistPot <- as.data.frame(resHist[, 1:3]) + resHistPot_l <- melt(data.frame(resHistPot), variable.name = "ratio_CIs", value.name = "readout") + + lowquant_Pot <- quantile(resHistPot[, 2], probs = as.numeric(input$lowQuant) / 100) + upquant_Pot <- quantile(resHistPot[, 3], probs = as.numeric(input$uppQuant) / 100) + p_Pot <- ggplot(resHistPot_l, aes(readout, fill = ratio_CIs)) + + geom_histogram(alpha = 0.5, position = "identity") + + labs(title = paste("Poency ratio EACs:", round(lowquant_Pot, 3), " to ", round(upquant_Pot, 3))) + + geom_vline(xintercept = c(lowquant_Pot, upquant_Pot), color = "black", linetype = "dashed", linewidth = 1) + + geom_vline(xintercept = c(input$lowerPot / 100, input$upperPot / 100), color = "red", linetype = "dashed", linewidth = 1) + theme_bw() - - grid.arrange(p_Slo, p_AsDiff, p_uAs, p_Pot, nrow=1) - + + grid.arrange(p_Slo, p_AsDiff, p_uAs, p_Pot, nrow = 1) } }) - + #### download XL 4PL report---- - + output$downloadXLReport <- downloadHandler( - - - - filename= paste0("Report_4PLEvaluation", Dat$RepIdentifier,".pdf"), - + filename = paste0("Report_4PLEvaluation", Dat$RepIdentifier, ".pdf"), content = function(file) { tpdr <- tempdir() - tempReport <- file.path(tpdr,"Doc_BioassayReport.Rmd") + tempReport <- file.path(tpdr, "Doc_BioassayReport.Rmd") file.copy("Doc_BioassayReport.Rmd", tempReport, overwrite = T) - - tempReportc <- file.path(tpdr,"logo.png") + + tempReportc <- file.path(tpdr, "logo.png") file.copy("logo.png", tempReportc, overwrite = T) - - rmarkdown::render(tempReport, output_file = file, - params = list(FileName = Dat$FileName, - author = Dat$Author, - NoP = Dat$NoP, - Assay = Dat$Assay, - REP = REP, - coeffs = Dat$coeffs_UN), - envir = new.env(parent = globalenv())) - + + rmarkdown::render(tempReport, + output_file = file, + params = list( + FileName = Dat$FileName, + author = Dat$Author, + NoP = Dat$NoP, + Assay = Dat$Assay, + REP = REP, + coeffs = Dat$coeffs_UN + ), + envir = new.env(parent = globalenv()) + ) } ) - + #### download XL Lin report---- - + output$downloadXLReportLin <- downloadHandler( - filename= paste0("Report_linPLA",Dat$nameRep ,".pdf"), - + filename = paste0("Report_linPLA", Dat$nameRep, ".pdf"), content = function(file) { tpdr <- tempdir() - tempReport <- file.path(tpdr,"Doc_BioassayLinReport.Rmd") + tempReport <- file.path(tpdr, "Doc_BioassayLinReport.Rmd") file.copy("Doc_BioassayLinReport.Rmd", tempReport, overwrite = T) - - tempReportc <- file.path(tpdr,"logo.png") + + tempReportc <- file.path(tpdr, "logo.png") file.copy("logo.png", tempReportc, overwrite = T) - - rmarkdown::render(tempReport, output_file = file, - params = list(FileName = Dat$FileName, - author = Dat$Author, - REP = REP, - REPlin = REPlin, - coeffsLin = Dat$coeffs_UN), - envir = new.env(parent = globalenv())) - + + rmarkdown::render(tempReport, + output_file = file, + params = list( + FileName = Dat$FileName, + author = Dat$Author, + REP = REP, + REPlin = REPlin, + coeffsLin = Dat$coeffs_UN + ), + envir = new.env(parent = globalenv()) + ) } ) }