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

linear reg evaluation for EXCEL upload

Browse Source
This commit is contained in:
Franz Innerbichler
2026-05-10 11:22:31 +02:00
parent 26aa2b8b2e
commit 7250a00adc
1 changed files with 115 additions and 103 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app.R
+115 -103
View File
@@ -1096,18 +1096,25 @@ server <- function(input, output, session) {
tabPanel("linear Analysis",
sidebarLayout(
sidebarPanel(
width=3,
width=2,
fluidRow(
column(6,
column(12,
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 ...")))
bsPopover(id="q4", title="", content="The calculated limits ...")),
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")),
)
)),
mainPanel(
tabsetPanel(id="tabs",
tabPanel("linear PLA",
box(title="ANOVA table", status="primary",solidHeader = T, width=12,
tableOutput("Anovatab")),
column(6,
column(12,
htmlOutput("PureErrW3"),
tags$head(tags$style("#PureErrW3{color: red;
font-size: 16px;
@@ -1118,18 +1125,19 @@ server <- function(input, output, session) {
h4("Unrestricted linear model (SSSI):"),
tableOutput("SummaryModABu"),
h4("Restricted linear model (CSSI):"),
tableOutput("SummaryModAB")),
column(3,
tableOutput("SummaryModAB"),
h3("Tests for linear PLA):"),
DT::dataTableOutput("TESTSlin"),
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")),
column(3,
tableOutput("SlopeDiffCI"),
h3("ANOVA for parallel line assay"),
DT::dataTableOutput("ANOVAlin"))),
DTOutput("ANOVAlin"))),
tabPanel("Report",
h4("Settings for report")
))
@@ -1489,6 +1497,7 @@ server <- function(input, output, session) {
coeffsMR <- Smr$coefficients[,1]
coeffsMU <- Smu$coefficients[,1]
Dat$coeffsMRes <- coeffsMR
Dat$coeffsMUnr <- coeffsMU
names(coeffsMU) <- c("lowAsym REF", "slope REF","upperAsym REF","EC50 REF","lowAsym TEST","slope TEST","upperAsym TEST","r")
if (!PureErrFlag) {
@@ -2150,102 +2159,105 @@ server <- function(input, output, session) {
#### linear Plot output ----
output$plotLin <- renderPlot({
tab <- Dat$EXCEL
# tab <- sim2()
# if (is.character(tab)) stop(tab)
# #browser()
# if (!is.na(Dils()[4])) noDilSer <- Dils()[4] else noDilSer = (ncol(tab)-1)/2
# Conc <- CONC()
# Conctab <- Dat$Conctab
if (is.character(tab)) stop(tab)
browser()
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
# sigmoid <- sigmoid()
# log_dose <- unique(all_l$log_dose)
# seq_x <- seq(min(log_dose), max(log_dose),0.1)
# SAMPLEtrue <- sigmoid[2] + (sigmoid[4]-sigmoid[2])/(1+exp(sigmoid[6]*((sigmoid[7]-log(input$potencydiff/100)-seq_x))))
# REFtrue <- sigmoid[1] + (sigmoid[3]-sigmoid[1])/(1+exp(sigmoid[5]*((sigmoid[7]-seq_x))))
#
# truePL_df <- cbind(seq_x,SAMPLEtrue, REFtrue)
#
# p <- ggplot(all_l2,aes(x=log_dose,y=readout, color=factor(isRef))) +
# geom_point() +
# labs(title=paste("linear regression model", indS,indT), color="product") +
# scale_colour_manual(labels = c("test","reference"), values=c("red","blue")) +
# ylim(min(all_l2$readout),max(all_l2$readout)) +
# theme_bw()
# p2 <- p + geom_line(data=pl_df,aes(x=lnC,y=plotS),color="blue",
# inherit.aes = F) +
# geom_line(data=pl_df,aes(x=lnC,y=plotT),color="red",
# inherit.aes = F) +
# geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="red", linetype=2,alpha=0.4,
# inherit.aes = F) +
# geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="blue", linetype=2,alpha=0.4,
# inherit.aes = F) +
# labs(title = paste("unrestricted linear regression model",indS,indT), color="product") +
# theme(legend.position="none", axis.text = element_text(size=14))
# p3 <- p2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
# size=5,alpha=0.2), inherit.aes = FALSE) +
# scale_shape_manual(labels=c("test","reference"), values=c(21,21))
#
# mLin <- gsl_nls(readout ~ (intS+r)*isSample + intS*isRef + k*log_dose,
# data=circle,
# start=list(intS = 0, k=1,r=0),
# control = gsl_nls_control(xtol=1e-10,ftol=1e-10,gtol=1e-10))
# # alternativ: modAB <- lm(readout ~ log_dose+isSample, circle)
# sum_mLin <- summary(mLin)
#
# pl_restS <- sum_mLin$coefficients[1,1] + sum_mLin$coefficients[2,1]*log(Conc)
# pl_restT <- sum_mLin$coefficients[1,1] + sum_mLin$coefficients[3,1] + sum_mLin$coefficients[2,1]*log(Conc)
# pl_rest <- data.frame(lnC=log(Conc), plotS=pl_restS, plotT=pl_restT)
#
# pr2 <- p + geom_line(data=pl_rest,aes(x=lnC,y=plotS),color="blue",
# inherit.aes = F) +
# geom_line(data=pl_rest,aes(x=lnC,y=plotT),color="red",
# inherit.aes = F) +
# geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="red", linetype=2,alpha=0.4,
# inherit.aes = F) +
# geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="blue", linetype=2,alpha=0.4,
# inherit.aes = F) +
# labs(title = paste("restricted linear regression model",indS,indT), color="product") +
# theme(legend.position="none", axis.text = element_text(size=14))
# pr3 <- pr2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
# size=5,alpha=0.2), inherit.aes = FALSE) +
# scale_shape_manual(labels=c("test","reference"), values=c(21,21))
# grid.arrange(p3,pr3,nrow=1)
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
#browser()
mLin <- gsl_nls(readout ~ (intS+r)*isSample + intS*isRef + k*log_dose,
data=circle,
start=list(intS = 0, k=1,r=0),
control = gsl_nls_control(xtol=1e-10,ftol=1e-10,gtol=1e-10))
# alternativ: modAB <- lm(readout ~ log_dose+isSample, circle)
sum_mLin <- summary(mLin)
sigmoid <- Dat$coeffsMUnr
log_dose <- unique(all_l$log_dose)
seq_x <- seq(min(log_dose), max(log_dose),0.1)
SAMPLEtrue <- sigmoid[5] + (sigmoid[7]-sigmoid[5])/(1+exp(sigmoid[6]*((sigmoid[4]-sigmoid[8]-seq_x))))
REFtrue <- sigmoid[1] + (sigmoid[3]-sigmoid[1])/(1+exp(sigmoid[2]*((sigmoid[4]-seq_x))))
truePL_df <- cbind(seq_x,SAMPLEtrue, REFtrue)
p <- ggplot(all_l2,aes(x=log_dose,y=readout, color=factor(isRef))) +
geom_point() +
labs(title=paste("linear regression model", indS,indT), color="product") +
scale_colour_manual(labels = c("test","reference"), values=c("#C2173F","#4545BA")) +
ylim(min(all_l2$readout),max(all_l2$readout)) +
theme_bw()
p2 <- p + geom_line(data=pl_df,aes(x=lnC,y=plotS),color="#4545BA",
inherit.aes = F) +
geom_line(data=pl_df,aes(x=lnC,y=plotT),color="#C2173F",
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="#C2173F", linetype=2,alpha=0.4,
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="#4545BA", linetype=2,alpha=0.4,
inherit.aes = F) +
labs(title = paste("unrestricted linear regression model",indS,indT), color="product") +
theme(legend.position="none", axis.text = element_text(size=14))
p3 <- p2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
size=5,alpha=0.2), inherit.aes = FALSE) +
scale_shape_manual(labels=c("test","reference"), values=c(21,21))
# fit intercept for test and ref and common slope
pl_restS <- sum_mLin$coefficients[1,1] + sum_mLin$coefficients[2,1]*log(Conc)
pl_restT <- sum_mLin$coefficients[1,1] + sum_mLin$coefficients[3,1] + sum_mLin$coefficients[2,1]*log(Conc)
pl_rest <- data.frame(lnC=log(Conc), plotS=pl_restS, plotT=pl_restT)
pr2 <- p + geom_line(data=pl_rest,aes(x=lnC,y=plotS),color="#4545BA",
inherit.aes = F) +
geom_line(data=pl_rest,aes(x=lnC,y=plotT),color="#C2173F",
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="#C2173F", linetype=2,alpha=0.4,
inherit.aes = F) +
geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="#4545BA", linetype=2,alpha=0.4,
inherit.aes = F) +
labs(title = paste("restricted linear regression model",indS,indT), color="product") +
theme(legend.position="none", axis.text = element_text(size=14))
pr3 <- pr2 + geom_point(circle, mapping=aes(x=log_dose, y=readout, shape=factor(isRef),
size=5,alpha=0.2), inherit.aes = FALSE) +
scale_shape_manual(labels=c("test","reference"), values=c(21,21))
grid.arrange(p3,pr3,nrow=1)
})