ROUT outlier report updated and finalized
This commit is contained in:
Guxa committed
1 parent
15a048b127
commit
2beaf0a9c8
8 files changed
+171
-111
No files matched your search
@@ -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
|
||||
|
||||
|
||||
Reference in new issue
Block a user