Catch singularities when fitting 4pl, SCRUM jobs listed

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))))
+  if (!is.null(sigmoid)) {
-  REFtrue <- sigmoid[1] + (sigmoid[3]-sigmoid[1])/(1+exp(sigmoid[2]*((sigmoid[4]-seq_x))))
+    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,
+    {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) +
+              inherit.aes = F) } +
-    geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="#4545BA", linetype=2,alpha=0.4,
+    {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) +
+              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,
+    {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) +
+              inherit.aes = F) } +
-    geom_line(data=data.frame(truePL_df),aes(x=seq_x,y=REFtrue),color="#4545BA", linetype=2,alpha=0.4,
+    {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) +
+              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]]
   

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)\
+\
+}

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("Wizard", tabName="wizard", icon=icon("chart-column", lib="font-awesome"))#,
-    menuItem("Documentation", tabName="documentation", icon=icon("chart-area", 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("&nbsp",9), collapse=""),
                          "Developer:", paste(rep("&nbsp",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 = "pla", uiOutput("pla")),
-        tabItem(tabName = "wizard", uiOutput("wizard")),
+        tabItem(tabName = "wizard", uiOutput("wizard"))#,
-        tabItem(tabName = "documentation", uiOutput("docu"))
+        #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)
   
@@ -630,6 +632,42 @@ server <- function(input, output, session) {
           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