diff --git a/Global.R b/Global.R index 1344d95..9f175a2 100644 --- a/Global.R +++ b/Global.R @@ -37,10 +37,17 @@ Fitting_FUNC <- function(ro_new, TransFlag=F) { if (!TransFlag) { startlist <- list(a=min(ro_new[,2]), b=SLOPE, d=max(ro_new[,2]), cs=mean(all_l$log_dose),r=0) - mr <- gsl_nls(fn = readout ~ a+(d-a)/(1+exp(b*((cs-r*isSample)-log_dose))), + mr <- tryCatch({gsl_nls(fn = readout ~ a+(d-a)/(1+exp(b*((cs-r*isSample)-log_dose))), data=all_l2, - start=startlist,#trace=T, + 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" + }) + # Stop if singular gradient matrix + if (is.character(mr)) return(mr) + s_mr <- tryCatch({ s_mr <- summary(mr) }, @@ -103,6 +110,40 @@ Fitting_FUNC <- function(ro_new, TransFlag=F) { return(list(s_mr, Sum_u, pot_est, potU_est, PRED, PREDu)) } +plotSingularity <- function(dat) { #sigmoid,det_sig, + CORdat <- cor(dat[,1],dat[,ncol(dat)]) + #browser() + all_l <- melt(data.frame(dat), id.vars="log_dose", variable.name="replname", value.name = "readout") + isRef <- rep(c(1,0),1,each=nrow(all_l)/2) + isSample <- rep(c(0,1),1,each=nrow(all_l)/2) + all_l2 <- cbind(all_l, isRef, isSample) + #browser() + + log_dose <- unique(all_l$log_dose) + seq_x <- seq(min(log_dose),max(log_dose),0.1) + + + #browser() + #all_l2$readout[all_l2$readout < 0] <- 0.01 + all_l2$readouttrans <- log(all_l2$readout) + + #browser() + pSing <- ggplot(all_l2, aes(x=log_dose, y=readout, color=factor(isRef))) + + geom_point(shape=factor(isRef), size=3,alpha=0.8) + + labs(title = paste("No 4pl fit possible"), + color="product") + + scale_color_manual(labels=c("test","reference"), values=c("#C2173F","#4545BA")) + + scale_shape_manual(labels=c("test","reference")) + + scale_x_continuous(breaks = scales::pretty_breaks(n = 10)) + + scale_y_continuous(breaks = scales::pretty_breaks(n = 10)) + + #theme_bw() + + theme(axis.text = element_text(size=14)) + + return(pSing) +} + + + #' Plot sigmoidal curve #' @@ -680,10 +721,18 @@ PlotLinPLA_FUNC <-function(circle, sigmoid, all_l2, pl_df, indS, indT) { log_dose <- unique(all_l2$log_dose) seq_x <- seq(min(log_dose), max(log_dose),0.1) - SAMPLEtrue <- sigmoid[5] + (sigmoid[7]-sigmoid[5])/(1+exp(sigmoid[6]*((sigmoid[4]-sigmoid[8]-seq_x)))) - REFtrue <- sigmoid[1] + (sigmoid[3]-sigmoid[1])/(1+exp(sigmoid[2]*((sigmoid[4]-seq_x)))) + if (!is.null(sigmoid)) { + 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) + } else { + SAMPLEtrue <- NULL + REFtrue <- NULL + truePL_df <- NULL + } - truePL_df <- cbind(seq_x,SAMPLEtrue, REFtrue) + + p <- ggplot(all_l2,aes(x=log_dose,y=readout, color=factor(isRef))) + geom_point(size=2) + @@ -697,10 +746,10 @@ PlotLinPLA_FUNC <-function(circle, sigmoid, all_l2, pl_df, indS, indT) { 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) + + {if (!is.null(truePL_df)) geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="#C2173F", linetype=2,alpha=0.4, + inherit.aes = F) } + + {if (!is.null(truePL_df)) 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 PLA model"), subtitle = paste("Regression starts for reference sample:",indS, "for test sample:",indT)) + 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), @@ -717,10 +766,10 @@ PlotLinPLA_FUNC <-function(circle, sigmoid, all_l2, pl_df, indS, indT) { 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) + + {if (!is.null(truePL_df)) geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=SAMPLEtrue),color="#C2173F", linetype=2,alpha=0.4, + inherit.aes = F) } + + {if (!is.null(truePL_df)) 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"), subtitle = paste("Regression on highlighted points")) + theme(legend.position="none", axis.text = element_text(size=14)) @@ -895,6 +944,8 @@ tests_FUNC <- function(ro_new, Lim, PureErrFlag) { all_l$readout[all_l$readout < 0] <- 0.01 #browser() FITs <- Fitting_FUNC(ro_new = ro_new, TransFlag = FALSE) + if (is.character(FITs)) return(FITs) # if singularity + POTr_CI <- FITs[[3]][2:3] potAll2 <- FITs[[3]] diff --git a/SCRUm jobs.rtf b/SCRUm jobs.rtf new file mode 100644 index 0000000..86137c2 --- /dev/null +++ b/SCRUm jobs.rtf @@ -0,0 +1,17 @@ +{\rtf1\ansi\ansicpg1252\cocoartf2867 +\cocoatextscaling0\cocoaplatform0{\fonttbl\f0\fswiss\fcharset0 Helvetica;} +{\colortbl;\red255\green255\blue255;} +{\*\expandedcolortbl;;} +\paperw11900\paperh16840\margl1440\margr1440\vieww11520\viewh8400\viewkind0 +\pard\tx720\tx1440\tx2160\tx2880\tx3600\tx4320\tx5040\tx5760\tx6480\tx7200\tx7920\tx8640\pardirnatural\partightenfactor0 + +\f0\fs24 \cf0 SCRUM jobs\ +\ +*) Sessioninfo geht noch ins Leere: \ +tabPanel("Configuration",\ + verbatimTextOutput("sessioninfo"))\ +*) Checks ob EXCEL file den Vorgaben entspricht: \ +**) Mindestens 2 Referenz- und gleich viele Testsample Spalten. \ +**) Check ob Spalte mit den Verd\'fcnnungen den regex Vorgaben entspricht (Ind <- grep("dilu | dose | Dose | Conc | conc",cn)\ +\ +} \ No newline at end of file diff --git a/app.R b/app.R index ad6a971..282e6c5 100644 --- a/app.R +++ b/app.R @@ -44,11 +44,11 @@ ui <- dashboardPage( # menuSubItem(icon = NULL, tags$li(a("Document", target="self",href="UserManual.pdf"))) # ), menuItem("EXCEL upload", tabName="Dataupload", icon=icon("magnet", lib="glyphicon")), - menuItem("4PL metadata + report", tabName="fourPL", icon=icon("chart-line", lib="font-awesome")), + 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("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=""), @@ -64,9 +64,9 @@ ui <- dashboardPage( 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 = "pla", uiOutput("pla")), + tabItem(tabName = "wizard", uiOutput("wizard"))#, + #tabItem(tabName = "documentation", uiOutput("docu")) ) ) @@ -82,11 +82,11 @@ server <- function(input, output, session) { #### renderUIs ---- output$homePage <- renderUI({ navbarPage("Home", - tabPanel("Introduction", + tabPanel("Limit setting", tags$img(src="logo.png", class="adv_logo"), h4("Introduction to the bioassay software"), tags$mark("linear regression"), br(), - column(4, + 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), @@ -153,7 +153,9 @@ server <- function(input, output, session) { "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, + plotOutput("plotSing", width="400px", height="300px")) ), tabPanel("4pl-Analysis", @@ -514,7 +516,7 @@ server <- function(input, output, session) { ))) }) - +#output$sessioninfo <- renderPrint(sessioninfo()) v <- reactiveValues(num_dose=0, next.dose.t=0) @@ -629,7 +631,43 @@ server <- function(input, output, session) { #### XLSX eval ---- 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 }) + + 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) @@ -767,7 +805,7 @@ server <- function(input, output, session) { colnames(logpotUest) <- c("estimate", "lowerCI", "upperCI") #browser() cnXL <- colnames(XLdat2) - Filesample <- data.frame(Test = c("FFILE 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) @@ -932,83 +970,7 @@ server <- function(input, output, session) { } }) - #### updateSlider on XLSX ---- - # observe({ - # if (!is.null(Dat$potDiffXL)) { - # updateSliderInput(session, "potencydiff", - # value=round(as.numeric(Dat$potDiffXL[[1]]),5)) - # } - # }) - # observeEvent(input$potencydiff, { - # if (!is.null(Dat$potDiffXL)) { - # updateSliderInput(session, "potencydiff", - # value=round(as.numeric(input$potencydiff),5)) - # } - # }) - # observe({ - # if (!is.null(Dat$ProzSD_XL)) { - # updateSliderInput(session, "sdfac", - # value=round(as.numeric(Dat$ProzSD_XL[[1]]),5)) - # } - # }) - # observeEvent(input$sdfac, { - # if (!is.null(Dat$ProzSD_XL)) { - # updateSliderInput(session, "sdfac", - # value=round(as.numeric(Dat$ProzSD_XL[[1]]),5)) - # } - # }) - - #### updaterNumeric Input ---- - # observe({ - # if(!is.null(Dat$coeffs_UN)) { - # updateNumericInput(session, "lowAsymptREF", - # value=round(as.numeric(Dat$coeffs_UN[3]),5), min=0) - # updateNumericInput(session, "lowAsymptTEST", - # value=round(as.numeric(Dat$coeffs_UN[4]),5), min=0) - # updateNumericInput(session, "uppAsymptREF", - # value=round(as.numeric(Dat$coeffs_UN[5]),5), min=0) - # updateNumericInput(session, "uppAsymptTEST", - # value=round(as.numeric(Dat$coeffs_UN[6]),5), min=0) - # updateNumericInput(session, "slopeREF", - # value=round(as.numeric(Dat$coeffs_UN[1]),5)) - # updateNumericInput(session, "slopeTEST", - # value=round(as.numeric(Dat$coeffs_UN[2]),5)) - # updateNumericInput(session, "EC50", - # value=round(as.numeric(Dat$coeffs_UN[7]),5)) - # updateNumericInput(session, "potDiff", - # value=round(as.numeric(Dat$coeffs_UN[7])- as.numeric(Dat$coeffs_UN[8]),5)) - # } - # }) - # - # observe({ - # if(!is.null(Dat$dilution)) { - # updateNumericInput(session, "CONC1", - # value=as.numeric(Dat$dilution[1])) - # updateNumericInput(session, "CONC2", - # value=as.numeric(Dat$dilution[2])) - # updateNumericInput(session, "CONC3", - # value=as.numeric(Dat$dilution[3])) - # updateNumericInput(session, "CONC4", - # value=as.numeric(Dat$dilution[4])) - # updateNumericInput(session, "CONC5", - # value=as.numeric(Dat$dilution[5])) - # updateNumericInput(session, "CONC6", - # value=as.numeric(Dat$dilution[6])) - # updateNumericInput(session, "CONC7", - # value=as.numeric(Dat$dilution[7])) - # updateNumericInput(session, "CONC8", - # value=as.numeric(Dat$dilution[8])) - # updateNumericInput(session, "CONC9", - # value=as.numeric(Dat$dilution[9])) - # updateNumericInput(session, "CONC10", - # value=as.numeric(Dat$dilution[10])) - # updateNumericInput(session, "CONC11", - # value=as.numeric(Dat$dilution[11])) - # updateNumericInput(session, "CONC12", - # value=as.numeric(Dat$dilution[12])) - # - # } - # }) + observe({ if(!is.null(Dat$MetaConc)) { @@ -1161,10 +1123,12 @@ server <- function(input, output, session) { }) # observe - #### Testergebnisse für XLSX ---- + #### 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,{ PureErrFlag <- input$PureErr warning_text3 <- reactive({ @@ -1691,6 +1655,7 @@ server <- function(input, output, session) { observe({ #browser() if (is.null(Dat$EXCEL)) return(NULL) + if (!is.null(Dat$FITsFlag)) return(NULL) ro_new <- Dat$EXCEL noDilSer <- Dat$noDilSeriesXL diff --git a/www/TestFile.xlsx b/www/TestFile.xlsx new file mode 100644 index 0000000..075eb1e Binary files /dev/null and b/www/TestFile.xlsx differ diff --git a/www/Testsdfac0.2b_3Dil12.numbers b/www/Testsdfac0.2b_3Dil12.numbers new file mode 100644 index 0000000..0a28439 Binary files /dev/null and b/www/Testsdfac0.2b_3Dil12.numbers differ