[Zooimage-commits] r249 - in pkg: . zooimage zooimage/R zooimage/inst/gui zooimage/inst/gui/errorcorrection zooimage/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Dec 7 08:40:32 CET 2014
Author: phgrosjean
Date: 2014-12-07 08:40:31 +0100 (Sun, 07 Dec 2014)
New Revision: 249
Added:
pkg/zooimage/inst/gui/errorcorrection/
pkg/zooimage/inst/gui/errorcorrection/global.R
pkg/zooimage/inst/gui/errorcorrection/server.R
pkg/zooimage/inst/gui/errorcorrection/ui.R
Removed:
pkg/zooimage.Rcheck/
Modified:
pkg/zooimage/DESCRIPTION
pkg/zooimage/NAMESPACE
pkg/zooimage/NEWS
pkg/zooimage/R/ZIRes.R
pkg/zooimage/R/ZITrain.R
pkg/zooimage/R/gui.R
pkg/zooimage/R/import.R
pkg/zooimage/R/utilities.R
pkg/zooimage/R/zid.R
pkg/zooimage/R/zidb.R
pkg/zooimage/man/gui.Rd
Log:
Changes in the GUI
Modified: pkg/zooimage/DESCRIPTION
===================================================================
--- pkg/zooimage/DESCRIPTION 2014-12-02 08:13:10 UTC (rev 248)
+++ pkg/zooimage/DESCRIPTION 2014-12-07 07:40:31 UTC (rev 249)
@@ -11,7 +11,7 @@
email = "kevin.denis at umons.ac.be"))
Maintainer: Philippe Grosjean <phgrosjean at sciviews.org>
Depends: R (>= 2.14.0), svMisc (>= 0.9-67), svDialogs (>= 0.9-53), mlearning
-Imports: filehash, jpeg, png, tiff, utils, digest, tools
+Imports: filehash, jpeg, png, tiff, utils, digest, tools, shiny
Suggests: rJava, mlbench
Description: ZooImage is a free (open source) solution for analyzing digital
images of zooplankton. In combination with ImageJ, a free image analysis
Modified: pkg/zooimage/NAMESPACE
===================================================================
--- pkg/zooimage/NAMESPACE 2014-12-02 08:13:10 UTC (rev 248)
+++ pkg/zooimage/NAMESPACE 2014-12-07 07:40:31 UTC (rev 249)
@@ -21,6 +21,7 @@
#import(RWeka)
import(mlearning)
#import(party)
+import(shiny)
# planktonSorter
export(correctError)
@@ -164,6 +165,7 @@
export(ZIDlg)
# Not in menus yet!
#export(subpartZIDat)
+export(ZIUI)
# GUI-Utilities
export(selectGroups)
Modified: pkg/zooimage/NEWS
===================================================================
--- pkg/zooimage/NEWS 2014-12-02 08:13:10 UTC (rev 248)
+++ pkg/zooimage/NEWS 2014-12-07 07:40:31 UTC (rev 249)
@@ -7,6 +7,8 @@
from there). This way, there is no need any more of a second image analysis
in ImageJ.
+* A new UI for error correction using shiny.
+
== Changes in zooimage 5.0-0
Modified: pkg/zooimage/R/ZIRes.R
===================================================================
--- pkg/zooimage/R/ZIRes.R 2014-12-02 08:13:10 UTC (rev 248)
+++ pkg/zooimage/R/ZIRes.R 2014-12-07 07:40:31 UTC (rev 249)
@@ -106,6 +106,9 @@
processSample <- function (x, sample, keep = NULL, detail = NULL, classes = "both",
header = c("Abd", "Bio"), biomass = NULL, breaks = NULL)
{
+ ## Fix ECD in case of FIT_VIS data
+ if ("FIT_Area_ABD" %in% names(x)) x$ECD <- ecd(x$FIT_Area_ABD)
+
## Check arguments
if (missing(sample)) {
sample <- unique(sampleInfo(x$Label, type = "sample", ext = ""))
@@ -208,7 +211,7 @@
x$P2 <- biomass[2]
x$P3 <- biomass[3]
} else stop("wrong 'biomass', must be NULL, a vector of 3 values or a data frame with Class, P1, P2 and P3")
- if(!is.numeric(x$ECD)) stop("'ECD' required for biomasses")
+ if (!is.numeric(x$ECD)) stop("'ECD' required for biomasses")
x$BioWeight <- (x$P1 * x$ECD^x$P3 + x$P2) * x$Dil
}
Modified: pkg/zooimage/R/ZITrain.R
===================================================================
--- pkg/zooimage/R/ZITrain.R 2014-12-02 08:13:10 UTC (rev 248)
+++ pkg/zooimage/R/ZITrain.R 2014-12-07 07:40:31 UTC (rev 249)
@@ -380,6 +380,8 @@
## Rename Dat in df
df <- Dat
+ ## Fix ECD in case of FIT_VIS data
+ if ("FIT_Area_ABD" %in% names(df)) df$ECD <- ecd(df$FIT_Area_ABD)
## Problem if there is no remaining row in the data frame
if (nrow(df) == 0) {
warning("No valid item found (no vignettes with valid measurement data)")
Modified: pkg/zooimage/R/gui.R
===================================================================
--- pkg/zooimage/R/gui.R 2014-12-02 08:13:10 UTC (rev 248)
+++ pkg/zooimage/R/gui.R 2014-12-07 07:40:31 UTC (rev 249)
@@ -27,6 +27,8 @@
menuAddItem(ZIname, "List objects", "listObjects()")
menuAddItem(ZIname, "Remove objects", "removeObjects()")
menuAddItem(ZIname, "-", "")
+ menuAddItem(ZIname, "Interactive UI", "ZIUI()")
+ menuAddItem(ZIname, "--", "")
menuAddItem(ZIname, "Online help", 'help("zooimage")')
menuAddItem(ZIname, "Manual", "viewManual()")
menuAddItem(ZIname,
@@ -1345,3 +1347,16 @@
# res <- subpartThreshold(ZIDat = zid, Filter = threshold)
# return(res)
#}
+
+
+################################################################################
+## New User Interface using Shiny for error correction
+ZIUI <- function () {
+ #appdir <- system.file("gui", "errorcorrection", package = "zooimage")
+ #runApp(appdir)
+ res <- dlgOpen(title = "Select one R method file",
+ filters = dlgFilters[c("R", "All"), ])$res
+ if (length(res)) {
+ source(res, chdir = TRUE)
+ }
+}
\ No newline at end of file
Modified: pkg/zooimage/R/import.R
===================================================================
--- pkg/zooimage/R/import.R 2014-12-02 08:13:10 UTC (rev 248)
+++ pkg/zooimage/R/import.R 2014-12-07 07:40:31 UTC (rev 249)
@@ -302,7 +302,7 @@
tab$Id <- NULL
dil <- 1/(Sub$SubPart * Sub$CellPart * Sub$Replicates * Sub$VolIni)
tab <- cbind(data.frame(Label = rep(label, n), Item = items,
- ECD = ecd(tab$FIT_Raw_Area)), tab, data.frame(Dil = rep(dil, n)))
+ ECD = ecd(tab$FIT_Area_ABD)), tab, data.frame(Dil = rep(dil, n)))
## Add metadata and change class of the object
attr(tab, "metadata") <- ctxData
Modified: pkg/zooimage/R/utilities.R
===================================================================
--- pkg/zooimage/R/utilities.R 2014-12-02 08:13:10 UTC (rev 248)
+++ pkg/zooimage/R/utilities.R 2014-12-07 07:40:31 UTC (rev 249)
@@ -112,7 +112,7 @@
"FIT_Low_U32", "FIT_Total", "FIT_Red_Green_Ratio",
"FIT_Blue_Green_Ratio", "FIT_Red_Blue_Ratio",
"FIT_Ch2_Ch1_Ratio", "FIT_Ch4_Peak", "FIT_Ch4_TOF", "FIT_Timestamp1",
- "FIT_Timestamp2", "FIT_Camera", "FIT_FringSize", "FIT_CircleFit",
+ "FIT_Timestamp2", "FIT_Camera", "FIT_FringSize",
"FIT_Ch1_Area", "FIT_Ch2_Area", "FIT_Ch3_Area",
"FIT_TimeStamp1", "FIT_Source_Image.1",
"X.Item.1", "FeretAngle", "Count",
@@ -129,7 +129,8 @@
## Found in format 17 of a color FlowCAM (from KAUST)
## and not used yet
"FIT_Symmetry", "FIT_Circularity_Hu", "FIT_Intensity_Calimage",
- "FIT_Raw_Convex_Hull_Area", "FIT_Raw_Filled_Area"
+ "FIT_Raw_Convex_Hull_Area", "FIT_Raw_Filled_Area",
+ "FIT_CircleFit", "FIT_Edge_Gradient"
))
as.character(res)
}
@@ -150,9 +151,8 @@
## ECD, FIT_Area_ABD, FIT_Length, FIT_Width, FIT_Diameter_ESD,
## FIT_Perimeter, FIT_Convex_Perimeter, FIT_Intensity, FIT_Sigma_Intensity,
## FIT_Compactness, FIT_Elongation, FIT_Sum_Intensity, FIT_Roughness,
- ## FIT_Edge_Gradient, FIT_Volume_ABD, FIT_Volume_ESD, FIT_Aspect_Ratio,
- ## FIT_Transparency, EdgeRange, CV, MeanFDia, Transp2, FeretRoundness,
- ## EdgeCV, EdgeSDNorm & Perim_Ratio
+ ## FIT_Volume_ABD, FIT_Volume_ESD, FIT_Aspect_Ratio, FIT_Transparency,
+ ## CV, MeanFDia, Transp2, FeretRoundness & Perim_Ratio
## A small hack to correct some 0 (which can be problematic in further calcs)
noZero <- function(x) {
@@ -174,7 +174,7 @@
## (=> all FIT_Raw_xxx should be eliminated in dropVars()!)
## (re)calculate ECD from FIT_DIameter_ABD (was once calc from FIT_Raw_Area)
- x$ECD <- noZero(x$FIT_Diameter_ABD)
+ x$ECD <- noZero(ecd(x$FIT_Area_ABD))
x$FIT_Area_ABD <- noZero(x$FIT_Area_ABD)
x$FIT_Length <- noZero(x$FIT_Length)
x$FIT_Width <- noZero(x$FIT_Width)
@@ -191,20 +191,20 @@
x$FIT_Volume_ABD <- noZero(x$FIT_Volume_ABD)
x$FIT_Volume_ESD <- noZero(x$FIT_Volume_ESD)
x$FIT_Transparency <- noZero(x$FIT_Transparency)
- x$FIT_Edge_Gradient <- noZero(x$FIT_Edge_Gradient)
-
## Additional calculated variables
# This is FIT_Aspect_Ratio! x$ARFeret <- x$FIT_Width/x$FIT_Length
- x$EdgeRange <- abs(x$FIT_Intensity - x$FIT_Edge_Gradient)
+ ## For later on:
+ #x$EdgeRange <- abs(x$FIT_Intensity - x$FIT_Edge_Gradient)
x$CV <- x$FIT_Sigma_Intensity/x$FIT_Intensity * 100
x$MeanFDia <- (x$FIT_Length + x$FIT_Width) / 2
x$Transp2 <- 1 - (x$FIT_Diameter_ABD/x$MeanFDia)
x$Transp2[x$Transp2 < 0] <- 0
x$FeretRoundness <- 4 * x$FIT_Area_ABD/(pi * sqrt(x$FIT_Length))
x$Circ. <- 4 * pi * x$FIT_Area_ABD / sqrt(x$FIT_Perimeter) # ImageJ calculation
- x$EdgeCV <- x$FIT_Sigma_Intensity/x$FIT_Edge_Gradient * 100
- x$EdgeSDNorm <- x$FIT_Intensity/x$EdgeRange
+ ## For later on:
+ #x$EdgeCV <- x$FIT_Sigma_Intensity/x$FIT_Edge_Gradient * 100
+ #x$EdgeSDNorm <- x$FIT_Intensity/x$EdgeRange
x$Perim_Ratio <- x$FIT_Convex_Perimeter / x$FIT_Perimeter
## Eliminate variables that are not predictors... and use Id as rownames
Modified: pkg/zooimage/R/zid.R
===================================================================
--- pkg/zooimage/R/zid.R 2014-12-02 08:13:10 UTC (rev 248)
+++ pkg/zooimage/R/zid.R 2014-12-07 07:40:31 UTC (rev 249)
@@ -521,11 +521,18 @@
rownames(allmes) <- 1:nrow(allmes)
Names <- names(allmes)
- ## Calculate an ECD from Area if there is not one yet
- if (!"ECD" %in% Names && "Area" %in% Names) {
- ECD <- ecd(allmes$Area)
- allmes <- data.frame(allmes[, 1:2], ECD = ECD, allmes[, 3:ncol(allmes)])
- }
+ ## Calculate an ECD from Area (or FIT_Area_ABD) if there is not one yet
+ if (!"ECD" %in% Names) {
+ if ("FIT_Area_ABD" %in% Names) { # This is FlowCAM data!
+ ECD <- ecd(allmes$FIT_Area_ABD)
+ allmes <- data.frame(allmes[, 1:2], ECD = ECD,
+ allmes[, 3:ncol(allmes)])
+ } else if ("Area" %in% Names) { # All other cases
+ ECD <- ecd(allmes$Area)
+ allmes <- data.frame(allmes[, 1:2], ECD = ECD,
+ allmes[, 3:ncol(allmes)])
+ }
+ }
attr(allmes, "metadata") <- allmeta
class(allmes) <- c("ZI3Dat", "ZIDat", "data.frame")
ZI.sample <- allmes
@@ -585,6 +592,10 @@
ZI.sample <- NULL
load(rdata)
+ ## Fix ECD in case of FIT_VIS data
+ if ("FIT_Area_ABD" %in% names(ZI.sample))
+ ZI.sample$ECD <- ecd(ZI.sample$FIT_Area_ABD)
+
## Delete the file
if (deletefile) {
unlink(rdata)
Modified: pkg/zooimage/R/zidb.R
===================================================================
--- pkg/zooimage/R/zidb.R 2014-12-02 08:13:10 UTC (rev 248)
+++ pkg/zooimage/R/zidb.R 2014-12-07 07:40:31 UTC (rev 249)
@@ -125,7 +125,10 @@
warning("Error loading ", zidat)
return(invisible(FALSE))
}
- dbInsert(db, ".Data", get(obj))
+ dat <- get(obj)
+ ## Fix ECD in case of FIT_VIS data
+ if ("FIT_Area_ABD" %in% names(dat)) dat$ECD <- ecd(dat$FIT_Area_ABD)
+ dbInsert(db, ".Data", dat)
## Do we delete sources?
if (isTRUE(as.logical(delete.source)))
@@ -429,8 +432,12 @@
db2env(dbInit(zidbfile))
## Read only Rdata file from a .zidb database
-zidbDatRead <- function (zidbfile)
- zidbLink(zidbfile)$.Data
+zidbDatRead <- function (zidbfile) {
+ res <- zidbLink(zidbfile)$.Data
+ ## Fix ECD in case of FIT_VIS data
+ if ("FIT_Area_ABD" %in% names(res)) res$ECD <- ecd(res$FIT_Area_ABD)
+ res
+}
## Read only the sample data
zidbSampleRead <- function (zidbfile)
Added: pkg/zooimage/inst/gui/errorcorrection/global.R
===================================================================
--- pkg/zooimage/inst/gui/errorcorrection/global.R (rev 0)
+++ pkg/zooimage/inst/gui/errorcorrection/global.R 2014-12-07 07:40:31 UTC (rev 249)
@@ -0,0 +1,128 @@
+## Zoo/PhytoImage simplified analysis UI (run the application)
+## Copyright (c) 2014, Philippe Grosjean (Philippe.Grosjean at umons.ac.be)
+## TODO: allow for placing samples in subdirs + use tree view
+
+## Get the working directory
+if (!exists(".ZI"))
+ stop("You must run this app from within a method script!")
+inidir <- dirname(.ZI$wdir)
+cat("Directory:", inidir, "\n")
+
+## Used to print a report after exiting the shiny app
+print.reportObj <- function (x, ...) {
+ line <- paste0(c("\n", rep('-', getOption("width")), "\n"))
+ cat(line, paste0(x, collapse = "\n"), line, sep = "")
+ invisible(x)
+}
+
+## Additional functions required by the UI
+## Same a headerPanel, but taking less space, using h5 instead of h1
+smallHeaderPanel <- function (title, windowTitle = title) {
+ tagList(tags$head(tags$title(windowTitle)), div(class = "span12",
+ style = "padding: 2px 0px;", strong(title)))
+}
+
+#smallTitlePanel <- function (title, windowTitle = title) {
+# tagList(tags$head(tags$title(windowTitle)), h5(style = "padding: 2px 0px;",
+# title))
+#}
+
+## Define UI for default process using a config .R script in zooimage
+## TODO: change the title according to actual name and version of the software
+## TODO: translate UI strings (English and French interfaces)
+uiTitle <- paste0("Zoo/PhytoImage version 5.1-0 (UMONS/IFREMER rephy release) - ",
+ .ZI$method, " - ", .ZI$user)
+
+
+### List all available methods
+#Methods <- dir(file.path(inidir, "_analyses"), pattern = "\\.R$")
+#if (!length(Methods)) stop("No methods defined in that directory")
+### Eliminate .R
+#Methods <- sub("\\.R$", "", Methods)
+#Methods <- .ZI$method
+
+### Prepare for first method
+#source(paste(file.path(inidir, "_analyses", .ZI$method), "R", sep = "."), chdir = TRUE)
+
+## List all samples currently available
+listSamples <- function (path, method, unanalyzed.only = FALSE) {
+ res <- dir(path)
+ if (!length(res)) return(character(0))
+ ## Eliminate hidden dirs and files (starting with "_")
+ res <- res[substr(res, 1, 1) != "_"]
+ if (!length(res)) return(character(0))
+ ## Keep only dirs or .zidb files
+ res <- res[grepl("\\.zidb$", res) | file.info(file.path(inidir, res))$isdir]
+ if (!length(res)) return(character(0))
+ ## Copy res to files, and eliminate .zidb extensions from res
+ files <- rev(res)
+ res <- rev(sub("\\.zidb$", "", res))
+ ## Where there is a dir and a .zidb file for the same sample, eliminate dir
+ keep <- !duplicated(res)
+ ## Select files and dir, rereverting rev and files
+ res <- rev(res[keep])
+ if (!length(res)) return(character(0))
+ files <- rev(files[keep])
+ ## Determine which sample is imported (has a .zidb file)
+ imp <- grepl("\\.zidb$", files)
+ ## Determine if some of these files are already processed
+ proc <- dir(file.path(path, "_analyses", method),
+ pattern = "\\_valid.RData$")
+ if (length(proc)) {
+ ## Keep only those items that are in res
+ procsmp <- sub("_valid\\.RData$", "", proc)
+ proc <- (res %in% procsmp)
+ } else proc <- rep(FALSE, length(res))
+ ## Create names with smp [ ]/[I]/[A]
+ status <- rep("[ ]", length(res))
+ status[imp] <- "[I]"
+ status[proc] <- "[A]"
+ nms <- paste(status, res)
+
+ ## If keep unanalyzed only, select corresponding items
+ # if (isTRUE(as.logical(unanalyzed.only))) {
+ # res <- res[!proc]
+ # nms <- nms[!proc]
+ # files <- files[!proc]
+ # imp <- imp[!proc]
+ # }
+
+ ## Create a list with samples, files and processed
+ list(samples = res, names = nms, files = files, imported = imp,
+ analyzed = proc)
+}
+AllSamples <- listSamples(inidir, method = .ZI$method)
+
+
+
+calcSample <- function (Sample, input, output, session)
+{
+ ## Is this sample already imported?
+ ## Try to import it anyway with replace = FALSE
+ if (file.exists(file.path(inidir, Sample))) {
+ ## Get .lst file first
+ Lst <- dir(file.path(inidir, Sample), pattern = "\\.lst$",
+ full.names = TRUE)[1]
+ if (length(Lst)) {
+ res <- try(importFlowCAM(Lst, rgb.vigs = FALSE, replace = FALSE),
+ silent = TRUE)
+ if (inherits(res, "try-error")) {
+ stop("Error importing sample", Sample)
+ } else { # Update list
+ Method <- .ZI$method #input$method
+ AllSamples <- listSamples(inidir, method = Method)
+ #, input$newonlyCheck)
+ ## Is this sample validated?
+ ## TODO: if reimported => backup validation data and clear it now!
+ if (file.exists(file.path(inidir, "_analyses", Method,
+ paste(Sample, "valid.RData", sep = "_")))) {
+ tag <- "[A]"
+ } else tag <- "[I]"
+
+ updateSelectInput(session, "sample", choices = AllSamples$names,
+ selected = paste(tag, Sample))
+ }
+ }
+ }
+}
+
Added: pkg/zooimage/inst/gui/errorcorrection/server.R
===================================================================
--- pkg/zooimage/inst/gui/errorcorrection/server.R (rev 0)
+++ pkg/zooimage/inst/gui/errorcorrection/server.R 2014-12-07 07:40:31 UTC (rev 249)
@@ -0,0 +1,397 @@
+## Zoo/PhytoImage simplified analysis UI (server code)
+## Copyright (c) 2014, Philippe Grosjean (Philippe.Grosjean at umons.ac.be)
+## TODO: allow for placing samples in subdirs + use tree view
+## TODO: add "Stat" button for fully validated samples
+## TODO: translate server messages (English and French interfaces)
+## TODO: allow downloading the data with something like:
+## In server.R:
+#output$downloadData <- downloadHandler(
+# filename = function() {
+# paste('data-', Sys.Date(), '.csv', sep='')
+# },
+# content = function(file) {
+# write.csv(data, file)
+# }
+#)
+#
+## In ui.R:
+#downloadLink('downloadData', 'Download')
+##
+## - Use includeMarkdown()
+##
+## - Use renderDataTable(), e.g.,
+## Pass a callback function to DataTables using I()
+#renderDataTable(iris, options = list(
+# iDisplayLength = 5,
+# fnInitComplete = I("function(oSettings, json) {alert('Done.');}")
+#))
+
+shinyServer(function (input, output, session) {
+
+ doAnalysis <- reactive({
+ generalMessage <- function(message) {
+ paste0("______________________________________________________________________",
+ #"\nÉchantillons totaux: ", length(AllSamples$names),
+ "\nÉchantillons à traiter: ", sum(!AllSamples$analyzed),
+ "\nÉchantillons analysés: ", sum(AllSamples$analyzed),
+ "\n\n", message, "\n",
+ "______________________________________________________________________\n")
+ }
+
+ if (input$goButton == 0)
+ return(generalMessage("(Auncun échantillon n'a encore été analysé au cours de cette session)."))
+ isolate({
+ Sample <- substring(input$sample, 5)
+ ZIDB <- file.path(inidir, paste(Sample, "zidb", sep = "."))
+ ## Determine if we already got some data...
+ ## First look at "demo" data _valid0.RData
+ DemoFile <- file.path(inidir, "_analyses", .ZI$method, #input$method,
+ paste(Sample, "valid0.RData", sep = "_"))
+ SampleFile <- file.path(inidir, "_analyses", .ZI$method, #input$method,
+ paste(Sample, "valid.RData", sep = "_"))
+ MetaFile <- file.path(inidir, "_analyses", .ZI$method, #input$method,
+ paste(Sample, "valid.txt", sep = "_"))
+ ResFile <- file.path(inidir, "_analyses", .ZI$method, #input$method,
+ paste(Sample, "res.RData", sep = "_"))
+
+ ValidData <- paste(Sample, "valid", sep = "_")
+ ResData <- paste(Sample, "res", sep = "_")
+ if (exists(ValidData, inherits = FALSE)) rm(list = ValidData)
+ if (file.exists(DemoFile)) { # Run in demo mode
+ res <- load(DemoFile)
+ DemoData <- get(res)
+ rm(list = res)
+ ce <- correctError(zidb = ZIDB, classifier = .ZIClass,
+ data = DemoData, mode = "demo")
+ ## Note: we save just nothing, because we are in demo mode?
+ ## or do we save data?
+ } else {
+ ## Are there some data already available?
+ if (file.exists(SampleFile)) { # Reanalyze the sample
+ res <- load(SampleFile)
+ SampleData <- get(res)
+ rm(list = res)
+ ce <- correctError(zidb = ZIDB, classifier = .ZIClass,
+ data = SampleData)
+ } else { # Nothing available: start from scratch
+ ce <- correctError(zidb = ZIDB, classifier = .ZIClass)
+ }
+
+ } #x <- "Demo found" else x <- "Demo not found"
+
+
+ ## Backup sample and metadata files if they exist
+ if (file.exists(SampleFile))
+ file.copy(SampleFile, paste(SampleFile, "bak", sep = "."))
+ unlink(SampleFile)
+ if (file.exists(MetaFile))
+ file.copy(MetaFile, paste(MetaFile, "bak", sep = "."))
+ unlink(MetaFile)
+ if (file.exists(ResFile))
+ file.copy(ResFile, paste(ResFile, "bak", sep = "."))
+ unlink(ResFile)
+
+ ## The following code fails while we are still validating items...
+ ## TODO: associate name of validator + date
+ res <- try(save(list = ValidData, file = SampleFile), silent = TRUE)
+ while (inherits(res, "try-error")) {
+ Sys.sleep(0.5) # Wait 1/2 sec
+ res <- try(save(list = ValidData, file = SampleFile),
+ silent = TRUE)
+ }
+ ## Save associated metadata
+ cat("zooimage version: 5.1.0\n", file = MetaFile)
+ cat("method: ", .ZI$method, "\n", sep = "",
+ file = MetaFile, append = TRUE)
+ cat("user: ", .ZI$user, "\n", sep = "",
+ file = MetaFile, append = TRUE)
+ cat("date: ", as.character(Sys.time()), "\n", sep = "",
+ file = MetaFile, append = TRUE)
+ cat("training set: ", .ZI$train, "\n", sep = "",
+ file = MetaFile, append = TRUE)
+ ## should be../ more
+ #cat("training file: ", .ZI$trainfile, "\n", sep = "",
+ # file = MetaFile, append = TRUE)
+ cat("classifier: ", .ZI$classif, "\n", sep = "",
+ file = MetaFile, append = TRUE)
+ ## should be../ more
+ #cat("classifier file: ", .ZI$classifile, "\n", sep = "",
+ # file = MetaFile, append = TRUE)
+ cat("classifier cmd: ", .ZI$classifcmd, "\n", sep = "",
+ file = MetaFile, append = TRUE)
+ cat("size breaks: ", paste(.ZI$breaks, collapse = "-"), "\n", sep = "",
+ file = MetaFile, append = TRUE)
+ cat("biovolume conversion: \n", sep = "",
+ file = MetaFile, append = TRUE)
+ write.table(.ZI$biovolume, sep = "\t", dec = ".", row.names = FALSE,
+ col.names = TRUE, file = MetaFile, append = TRUE)
+
+ ## Calculate results for this sample
+ dat2 <- get(ValidData)
+ cl <- levels(dat2$Class) # All classes
+ ## We used first uppercase for classes of interest, thus:
+ cl <- cl[grepl("^[A-Z]", cl)]
+ ## Now, we also want to calculate separate abundances for most abundant classes
+ ## i.e., those with at least 50 individuals measured
+ detail <- cl[cl %in% levels(dat2$Class)[table(dat2$Class) >= 50]]
+ ## Calculate results for this sample
+ ## TODO: correct the bug with keep = cl => replacement has different number of rows
+ #assign(ResData, processSample(dat2, keep = cl, detail = detail,
+ # biomass = .ZI$biovolume, breaks = .ZI$breaks, classes = "Class"))
+ assign(ResData, processSample(dat2, keep = NULL, detail = detail,
+ biomass = .ZI$biovolume, breaks = .ZI$breaks, classes = "Class"))
+ ## Save it
+ save(list = ResData, file = ResFile)
+
+ ## Report success
+ x <- paste("(L'échantillon", Sample, "vient d'être analysé).")
+
+ Method <- .ZI$method #input$method
+ AllSamples <- listSamples(inidir, method = Method)
+
+ if (file.exists(file.path(inidir, "_analyses", Method,
+ paste(Sample, "valid.RData", sep = "_")))) {
+ tag <- "[A]"
+ } else tag <- "[I]"
+
+ updateSelectInput(session, "sample", choices = AllSamples$names,
+ selected = paste(tag, Sample))
+
+ return(generalMessage(x))
+ })
+ })
+
+ #output$generalSummary <- renderText({
+ # if (input$stopButton) { # Manage clean closing of the page
+ # ## Réactiver R
+ # ## TODO: change this code to get the name of R application under Mac OS X
+ # GUI <- .Platform$GUI
+ # if (GUI == "Rgui") { # Code for RGui under Windows
+ # try(bringToTop(-1), silent = TRUE)
+ # } else if (GUI == "AQUA") { # Code for R/R64/SciViews R64.app
+ # ## This works from Mac OS X 10.5 Leopard:
+ # try(system("osascript -e 'tell application id \"Rgui\" to activate'",
+ # ignore.stdout = TRUE, ignore.stderr = TRUE), silent = TRUE)
+ # #try(system("osascript -e 'tell application \"R\" to activate'",
+ # # ignore.stdout = TRUE, ignore.stderr = TRUE), silent = TRUE)
+ # #try(system("osascript -e 'tell application \"R64\" to activate'",
+ # # ignore.stdout = TRUE, ignore.stderr = TRUE), silent = TRUE)
+ # #try(system("osascript -e 'tell application \"SciViews R64\" to activate'",
+ # # ignore.stdout = TRUE, ignore.stderr = TRUE), silent = TRUE)
+ # } else if (grepl("^mac", .Platform$pkgType)) { # Try code for Terminal.app
+ # try(system("osascript -e 'tell application \"Terminal\" to activate'",
+ # ignore.stdout = TRUE, ignore.stderr = TRUE), silent = TRUE)
+ # }
+ #
+ # ## Stop the application, returning a short report of what was done
+ # report <- structure("Content of my report here...", class = "reportObj")
+ # stopApp(report)
+ #
+ # ## Indicate the app is disconnected
+ # paste(strong(em("Application déconnectée!")))
+ #
+ # } else { # Indicate number of samples to process and number analyzed
+ # ## TODO: make this reactive to the change to the list of samples
+ # paste(em("A traiter:"), strong(em(sum(!AllSamples$analyzed))),
+ # em(" - analysés:"), strong(em(sum(AllSamples$analyzed))))
+ # }
+ #})
+
+ output$sampleSummary <- renderPrint(width = 80, {
+ if (input$stopButton) {
+ #updateTabsetPanel(session, "mainTabset", selected = "Résumé")
+ } else {
+ ## Also update the list of samples, depending on both method and newonlyCheck
+ # AllSamples <- listSamples(inidir, method = .ZI$method, input$newonlyCheck)
+ # updateSelectInput(session, "sample", choices = AllSamples$names)
+ Sample <- substring(input$sample, 5)
+ calcSample(Sample, input, output, session)
+ ## Link to the .zidb file and provide a summary of this sample
+ cat("===", Sample, "===\n")
+ ZIDB <- file.path(inidir, paste(Sample, "zidb", sep = "."))
+ Dat <- zidbDatRead(ZIDB)
+ cat("Échantillon contenant", nrow(Dat), "particules numérisées.\n")
+ if (substr(input$sample, 1, 3) == "[A]") {
+ ## Get analysis statistics about this sample
+ #if (!exists("SampleData")) {
+ ## Download the data!
+ SampleFile <- file.path(inidir, "_analyses", .ZI$method, #input$method,
+ paste(Sample, "valid.RData", sep = "_"))
+ if (file.exists(SampleFile)) {
+ res <- load(SampleFile)
+ SampleData <- get(res)
+ rm(list = res)
+ }
+ #}
+ res <- try(print(table(SampleData$Class)), silent = TRUE)
+ if (inherits(res, "try-error"))
+ cat("\nStatistiques d'analyse pour l'échantillon non disponibles\n")
+ } else cat("\nCet échantillon n'est pas encore analysé avec la méthode '", .ZI$method, "'.", sep = "")
+ #head(Dat)
+ #print(summary(Dat[, c("ECD")]))
+ #print(attr(Dat, "metadata"))
+ #plot(Dat$Area, Dat$Perim.)
+ #cat("Ici, le résumé de", Sample)
+ cat("\n", doAnalysis())
+ }
+ })
+
+ output$sampleTable <- renderDataTable(options = list(pageLength = 50), { #renderTable({
+ if (input$stopButton) {
+ updateTabsetPanel(session, "mainTabset", selected = "Résumé")
+ } else {
+ doAnalysis()
+ Sample <- substring(input$sample, 5)
+ calcSample(Sample, input, output, session)
+ ## Link to the .zidb file and provide a summary of this sample
+ #cat("===", Sample, "===\n")
+ ZIDB <- file.path(inidir, paste(Sample, "zidb", sep = "."))
+
+ ## Depending if the file is analyzed or not, we look at the
+ ## ZITest or ZIDat object
+ if (substr(input$sample, 1, 3) == "[A]") {
+ ## Get analysis statistics about this sample
+ #if (!exists("SampleData")) {
+ ## Download the data!
+ SampleFile <- file.path(inidir, "_analyses", .ZI$method, #input$method,
+ paste(Sample, "valid.RData", sep = "_"))
+ if (file.exists(SampleFile)) {
+ res <- load(SampleFile)
+ SampleData <- get(res)
+ rm(list = res)
+ }
+ #}
+ res <- try(Dat50 <- head(SampleData, n = 50), silent = TRUE)
+ if (inherits(res, "try-error")) {
+ Dat <- zidbDatRead(ZIDB)
+ Dat50 <- head(Dat, n = 50)
+ Dat50b <- Dat50
+ Dat50b$Label <- NULL
+ Dat50b$Item <- NULL
+ Dat50b$ECD <- NULL
+ data.frame(Label = Dat50$Label, Item = Dat50$Item,
+ ECD = Dat50$ECD, Dat50b)
+ } else {
+ Dat50b <- Dat50
+ Dat50b$Label <- NULL
+ Dat50b$Item <- NULL
+ Dat50b$ECD <- NULL
+ Dat50b$Class <- NULL
+ Dat50b$Predicted <- NULL
+ Dat50b$Id <- NULL
+ Dat50b$Id.1 <- NULL
+ data.frame(Label = Dat50$Label, Item = Dat50$Item,
+ ECD = Dat50$ECD, Class = Dat50$Class, Dat50b)
+ #Dat50$Predicted,Dat50$ECD, Dat50b)
+ }
+ } else {
+ Dat <- zidbDatRead(ZIDB)
+ Dat50 <- head(Dat, n = 50)
+ Dat50b <- Dat50
+ Dat50b$Label <- NULL
+ Dat50b$Item <- NULL
+ Dat50b$ECD <- NULL
+ data.frame(Label = Dat50$Label, Item = Dat50$Item,
+ ECD = Dat50$ECD, Dat50b)
+ }
+ }
+ })
+
+ output$samplePlot <- renderPlot({
+ if (input$stopButton) {
+ updateTabsetPanel(session, "mainTabset", selected = "Résumé")
+ } else {
+
+ ## This is only in shiny 0.10.2!!
+ #withProgress(message = 'Calculation in progress',
+ # detail = '...', value = 0, {
+ # for (i in 1:15) {
+ # incProgress(1/15, detail = paste0("...", i, "/15"))
+ # Sys.sleep(0.25)
+ # }
+ #})
+
+ Sample <- substring(input$sample, 5)
+ calcSample(Sample, input, output, session)
+ ## Link to the .zidb file and provide a summary of this sample
+ #cat("===", Sample, "===\n")
+ ZIDB <- file.path(inidir, paste(Sample, "zidb", sep = "."))
+ Dat <- zidbDatRead(ZIDB)
+ hist(Dat$ECD, col = "cornsilk", breaks = "FD",
+ main = "Distribution de la taille des particules",
+ xlab = "ECD", ylab = "Fréquences")
+ }
+ })
+
+ output$vignettesPlot <- renderPlot({
+ if (input$stopButton) {
+ updateTabsetPanel(session, "mainTabset", selected = "Résumé")
+ } else {
+ Sample <- substring(input$sample, 5)
+ calcSample(Sample, input, output, session)
+ ## Link to the .zidb file and provide a summary of this sample
+ #cat("===", Sample, "===\n")
+ ZIDB <- file.path(inidir, paste(Sample, "zidb", sep = "."))
+ DB <- zidbLink(ZIDB)
+ Items <- ls(DB) # Contains data in *_dat1 and vignettes in *_nn
+ ## Eliminate items that are not vignettes
+ noVig <- grep("_dat1", Items)
+ if (length(noVig)) Vigs <- Items[-noVig] else Vigs <- Items
+ ## Display a 5*5 thumbnail of the first 25 vignettes
+ zidbPlotNew(Sample)
+ ImgType <- DB$.ImageType
+ for (i in 1:30)
+ zidbDrawVignette(DB[[Vigs[i]]], type = ImgType, item = i,
+ nx = 6, ny = 5)
+ }
+ })
+
+ output$sampleResults <- renderPrint({
+ if (input$stopButton) {
+ updateTabsetPanel(session, "mainTabset", selected = "Résumé")
+ } else {
+ ## Also update the list of samples, depending on both method and newonlyCheck
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/zooimage -r 249
More information about the Zooimage-commits
mailing list