diff --git a/R/Global.R b/R/Global.R index 0cdf094..82fef44 100644 --- a/R/Global.R +++ b/R/Global.R @@ -1578,3 +1578,51 @@ divFUN <- function(x, Div, N, res, noDil) { } divFUN(y, Div, N, res, noDil) } + + +#' Calculates bend points. +#' +#' Function to calcuate bend points and asymptote points. +#' +#' @param coeffsMR Coefficients of the restricted 4PL function fitting. +#' @param coeffsMU Coefficients of the unrestricted 4PL function fitting. +#' @returns A data-frame with the bend and asymptote points. +#' @export +#' @examples +#' suppressMessages(source("../../dev/setup.R")) +#' +#' Y = c(as = 0.120445892203919, bs = 1.28418582519022, ds = 1.8338879701327, +#' cs = 1.39147328614669, at = 0.138485413007939, bt = 1.21165361681225, +#' dt = 1.87305623127598, r = -0.124939016993196) +#' X=c(a = 0.128595630629391, b = 1.24241130117909, d = 1.85344873664946, +#' cs = 1.42641893429388, r = -0.048418036970926) + +#' +#' bendFUN(X,Y) +bendFUN <- function(coeffsMR, coeffsMU) { + 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 REF", "lower asymp. point TEST", "upper asymp. point TEST", + "bendREF_lower_unrestr", "bendREF_upper_unrestr", "bendTEST_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) + ) + ) + return(BPsMR_MU) +} diff --git a/dev/BioassayReportROUT.Rmd b/dev/BioassayReportROUT.Rmd index 49a1a13..b6720ae 100644 --- a/dev/BioassayReportROUT.Rmd +++ b/dev/BioassayReportROUT.Rmd @@ -53,10 +53,10 @@ all_l <- REP$all_l #ANOVAXLS <- REP$ANOVAXLS #XLplot4pl <- REP$XLplot4pl DiagnTable <- REP$DiagnTable -UnRPLAausw <- REP$UnRPLAausw + UnRPLBend <- REP$UnRPLBend -PLAausw <- REP$PLAausw -PLbend <- REP$PLBend + +BendsROUT <- REP$BendsROUT pottab4plXL <- REP$pottab4plXL Lim <- REP$Lim XLdat2 <- REP$XLdat2 @@ -64,7 +64,8 @@ PureErr <- REP$PureErr ro_newROUT <- REP$ro_newROUT ROUTplot <- REP$ROUTplot ANOVA_ROUT <- REP$ANOVA_ROUT - +coeffsMR_ROUT <- REP$RPLAauswROUT +coeffsMU_ROUT <- REP$UnRPLAauswROUT CIplot <- REP$CIplot testsTabROUT <- REP$testsTabROUT relpotTestPlot <- REP$relpotTestPlot @@ -100,7 +101,7 @@ if (!is.null(ro_newROUT)) { ```{r Over_all, echo=FALSE, comment=NA, warning=NA, message=NA} -browser() +#browser() potFlag <- 0 if (pottab4plXL["test_result"][[1]][1]=="failed") potFlag <- 1 AnalysisFlag <- FALSE @@ -125,7 +126,7 @@ colFmt <- function() { ## 4pl-regression -Relative potency (absolute and relative confidence limits) are shown in Table 3. `r if(PureErr) {"Pure Error is used for calculations."}` +Relative potency (absolute and relative confidence limits) BEFORE EXCLUSION of potential outliers are shown in Table 3 for information. `r if(PureErr) {"Pure Error is used for calculations."}` `r if (!PureErr) {"RMSE of restricted model is used for confidence limit calculation."}` ```{r Pot_tab4pl, echo=FALSE, comment=NA, warning=NA, message=NA} @@ -154,6 +155,8 @@ plot(ROUTplot) ``` +# Results after exclusion of potential outliers + ## ANOVA table The ANOVA of the unconstrained model is listed in table 4. Bates and Watts [4] proposed a test on parallelism which compares the residual sum of squares of the restricted model (ResRSSE) with the residual sum of squares of the unrestricted model (UnresRSSE). If the UnresRSSE is significantly smaller than the ResRSSE, the p-value of "Non-parallelism" is smaller than 0.05 (line 4 in table 4). This test is for information only as it may be overly sensitive in case of small overall variability of the data. @@ -200,7 +203,7 @@ cat(" 1 ... test failed (for EQ tests: CL not within limits);") ```{r AST_Ergebn, echo=FALSE, cache=FALSE, warning=FALSE, message=FALSE, tidy=TRUE} TestsTabFlag <- FALSE -if (sum(testsTabROUT$test_results)>0) TestsTabFlag <- TRUE +if (sum(testsTabROUT[-nrow(testsTabROUT),]$test_results)>0) TestsTabFlag <- TRUE colFmt2 <- function() { outputFormat <- knitr::opts_knit$get("rmarkdown.pandoc.to") @@ -223,35 +226,39 @@ colFmt2 <- function() { ## Fitting results with curve points -The results of the non-linear fitting procedure for the restricted model (5 parameters) is listed in table 5: +The results of the non-linear fitting procedure for the restricted model (5 parameters) is listed in Table 6: ```{r PLAausw, echo=FALSE, warning=FALSE, results='asis'} -kable(PLAausw, format = "markdown", caption= "Restricted 4PL model", digits=3, row.names = F) +kable(coeffsMR_ROUT , format = "markdown", caption= "Restricted 4PL model", digits=3, row.names = F) ``` -Sebaugh et al proposed bend points for test and reference samples, that define the points with highest turning behavior. Table 6 lists these bendpoints as well as asymptote points ~ twice as far from the center as the bendpoints. - -```{r PLBend, echo=FALSE, warning=FALSE, results='asis'} - -kable(PLbend, format = "markdown", caption= "Bendpoints and asymptote points of restricted 4PL model", digits=3) - - -``` - The results of the non-linear fitting procedure for the unrestricted model (8 parameters) is listed in table 7: ```{r UnRPLAausw, echo=FALSE, warning=FALSE, results='asis'} -kable(UnRPLAausw, format = "markdown", caption= "Unrestricted 4PL model", digits=3, row.names = F) +kable(coeffsMU_ROUT , format = "markdown", caption= "Unrestricted 4PL model", digits=3, row.names = F) ``` +## Bend points and asymptote points + +Sebaugh et al. proposed bend points for test and reference samples, that define the points with highest turning behavior. Table 6 lists these bendpoints as well as asymptote points ~ twice as far from the center as the bendpoints. + +```{r PLBend, echo=FALSE, warning=FALSE, results='asis'} + + +BendsROUT2 <- BendsROUT[1:8,] +kable(BendsROUT2, format = "markdown", caption= "Bendpoints and asymptote points of restricted 4PL model", digits=3) + + +``` + # Signature diff --git a/dev/ROUT.R b/dev/ROUT.R index a23babb..67345df 100644 --- a/dev/ROUT.R +++ b/dev/ROUT.R @@ -11,9 +11,9 @@ library(minpack.lm) library(ggplot2) library(rstudioapi) -# Getting path for current open file -current_path = rstudioapi::getActiveDocumentContext()$path -setwd(dirname(current_path)) +# # Getting path for current open file +# current_path = rstudioapi::getActiveDocumentContext()$path +# setwd(dirname(current_path)) outsPlot_FUN <- function(all_l,OUTs_, TS, PROC = "not specified", PROBE="", Q=0.01, par) { #browser() diff --git a/dev/app.R b/dev/app.R index 3b369b9..3e71931 100644 --- a/dev/app.R +++ b/dev/app.R @@ -822,73 +822,99 @@ server <- function(input, output, session) { ##### ROUT outlier testing ---- #browser() if(!is.null(input$Qslider)) { - all_lROUT <- all_l[complete.cases(all_l),] - colnames(all_lROUT) <- c("log_dose","sample","y","isRef","isSample","conc") - res <- rout_4pl_potency(all_lROUT, Q=input$Qslider/100) - OUTs_ <- all_lROUT[res$outliers,] - - all_l_rout <- all_lROUT[res$kept,] - # all_l_rout$log_dose <- log(all_l_rout$Conc) - # colnames(all_l_rout) <- c("log_dose","sample","y","isRef","isSample","conc") - if (all_l_rout$conc[1]>all_l_rout$conc[6]) { - if (all_l_rout$y[1]>all_l_rout$y[6]) SLOPE <- 1 else SLOPE<- -1 - } else { - if (all_l_rout$y[1]>all_l_rout$y[6]) SLOPE <- -1 else SLOPE<- 1 - } - - startlist <- list(a = min(all_l_rout$y), b = SLOPE, d = max(all_l_rout$y), cs = mean(log(all_l_rout$conc)), r = 0) - - mr <- tryCatch( - { - gsl_nls( - fn = y ~ a + (d - a) / (1 + exp(b * ((cs - r * isSample) - log_dose))), - data = all_l_rout, - start = startlist, # race=T, - control = gsl_nls_control(xtol = 1e-6, ftol = 1e-6, gtol = 1e-6) - ) - }, - warning = function(e) { - mr <<- "In nlsModel singular gradient matrix" - + all_lROUT <- all_l[complete.cases(all_l),] + colnames(all_lROUT) <- c("log_dose","sample","y","isRef","isSample","conc") + res <- rout_4pl_potency(all_lROUT, Q=input$Qslider/100) + OUTs_ <- all_lROUT[res$outliers,] + + all_l_rout <- all_lROUT[res$kept,] + # all_l_rout$log_dose <- log(all_l_rout$Conc) + # colnames(all_l_rout) <- c("log_dose","sample","y","isRef","isSample","conc") + if (all_l_rout$conc[1]>all_l_rout$conc[6]) { + if (all_l_rout$y[1]>all_l_rout$y[6]) SLOPE <- 1 else SLOPE<- -1 + } else { + if (all_l_rout$y[1]>all_l_rout$y[6]) SLOPE <- -1 else SLOPE<- 1 + } + + startlist <- list(a = min(all_l_rout$y), b = SLOPE, d = max(all_l_rout$y), cs = mean(log(all_l_rout$conc)), r = 0) + + mr <- tryCatch( + { + gsl_nls( + fn = y ~ a + (d - a) / (1 + exp(b * ((cs - r * isSample) - log_dose))), + data = all_l_rout, + start = startlist, # race=T, + control = gsl_nls_control(xtol = 1e-6, ftol = 1e-6, gtol = 1e-6) + ) + }, + warning = function(e) { + mr <<- "In nlsModel singular gradient matrix" + + }) + PAR <- summary(mr)$coefficients[,1] + ROUTplot <- outsPlot_FUN(all_l_rout, OUTs_, TS=all_l_rout$sample[13], PROC="ROUT",PROBE=input$sheet,Q=input$Qslider/100,par=PAR) + + + output$OutlierDF <- renderTable({ + OUTs_ }) - PAR <- summary(mr)$coefficients[,1] - ROUTplot <- outsPlot_FUN(all_l_rout, OUTs_, TS=all_l_rout$sample[13], PROC="ROUT",PROBE=input$sheet,Q=input$Qslider/100,par=PAR) - - - output$OutlierDF <- renderTable({ - OUTs_ - }) - output$OutlierPlot <- renderPlot({ - print(ROUTplot) - }) - - - all_l_rout2 <- all_l_rout[,-c(4:6)] - ro_newROUT <- reshape(all_l_rout2, direction="wide", idvar = "log_dose", timevar="sample", varying = as.vector(unique(all_l_rout2$sample))) - REP$ro_newROUT <- ro_newROUT - - REP$ROUTplot <- ROUTplot - - ANOVA_ROUT <- ANOVA4plUnresfunc(ro_new = ro_newROUT) - REP$ANOVA_ROUT <- ANOVA_ROUT - - 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) - ) - - tabROUT <- tests_FUNC(ro_newROUT, Limite, PureErrFlag = PureErrFlag) - #browser() - tabROUT[1, 6:7] <- c("-", "-") - - #tabROUT2 <- tabROUT[SelTests, ] - #Dat$tests_FUNC <- tabROUT - REP$testsTabROUT <- tabROUT + output$OutlierPlot <- renderPlot({ + print(ROUTplot) + }) + + + all_l_rout2 <- all_l_rout[,-c(4:6)] + ro_newROUT <- reshape(all_l_rout2, direction="wide", idvar = "log_dose", timevar="sample", varying = as.vector(unique(all_l_rout2$sample))) + REP$ro_newROUT <- ro_newROUT + + REP$ROUTplot <- ROUTplot + + ANOVA_ROUT <- ANOVA4plUnresfunc(ro_new = ro_newROUT) + REP$ANOVA_ROUT <- ANOVA_ROUT + + 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) + ) + + tabROUT <- tests_FUNC(ro_newROUT, Limite, PureErrFlag = PureErrFlag) + #browser() + tabROUT[1, 6:7] <- c("-", "-") + + #tabROUT2 <- tabROUT[SelTests, ] + #Dat$tests_FUNC <- tabROUT + REP$testsTabROUT <- tabROUT + FITsROUT <- Fitting_FUNC(ro_newROUT, TransFlag = FALSE, nameWS="") + SmrROUT <- FITsROUT[[1]] # summary(mr) + SmuROUT <- FITsROUT[[2]] # summary(mu) + coeffsMR_ROUT <- SmrROUT$coefficients[, 1] + + coeffsMU_ROUT <- SmuROUT$coefficients[, 1] + BendsROUT <- bendFUN(coeffsMR_ROUT,coeffsMU_ROUT) + coeffsMR_ROUT_ <- data.frame( + Information = c( + "model", "lower asymptote", "Hill's slope", "upper asymptote", "EC50 Ref", + "EC50 difference"), + Results = unlist(c( + "RESTRICTED", round(coeffsMR_ROUT, 3) + ))) + coeffsMU_ROUT_ <- 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"), + Results = unlist(c("UNRESTRICTED", round(coeffsMU_ROUT, 3))) + ) # von psl_nls + REP$RPLAauswROUT <- coeffsMR_ROUT_ + REP$UnRPLAauswROUT <- coeffsMU_ROUT_ + + + REP$BendsROUT <- BendsROUT } @@ -986,30 +1012,9 @@ server <- function(input, output, session) { 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") - 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 REF", "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) - ) - ) + ##### bend function ---- + BPsMR_MU <- bendFUN(coeffsMR, coeffsMU) + Dat$bendsAll <- BPsMR_MU REP$bendsAll <- BPsMR_MU diff --git a/dev/logo.png b/dev/logo.png deleted file mode 100644 index c6a6fc3..0000000 Binary files a/dev/logo.png and /dev/null differ diff --git a/dev/logov2_.png b/dev/logov2_.png new file mode 100644 index 0000000..08990cc Binary files /dev/null and b/dev/logov2_.png differ diff --git a/dev/www/logo.png b/dev/www/logo.png deleted file mode 100644 index c6a6fc3..0000000 Binary files a/dev/www/logo.png and /dev/null differ diff --git a/www/logo.png b/www/logo.png deleted file mode 100644 index c6a6fc3..0000000 Binary files a/www/logo.png and /dev/null differ