Nothing
#' LogBook Metier Discovery GUI
#'
#'
#' The \code{gui_lb_met_dis} function implements the graphical user interface for the
#' LogBook Metier Discovery
#'
#' This function, with a logbook database, performs a clustering over the whole
#' db calculating the distance or dissimilarity between every observation
#' in the sample.
#'
#' @param lb_db_name The path of a LogBook DataBase
#'
#' @return This function does not return a value.
#' After the execution the user is asked where to save the result file.
#'
#' @usage gui_lb_met_dis(lb_db_name = "")
#'
#'
gui_lb_met_dis <- function(lb_db_name = "")
{
lb_DB <- log_DB$new()
lb_DB$db <- lb_db_name
lb_CLA <- log_Cla$new()
met_dis_win <- gwindow("Metier Discovery Tool", visible = FALSE)
big_g <- ggroup(horizontal = FALSE, container = met_dis_win)
new_g <- ggroup(horizontal = TRUE, container = big_g)
addSpring(new_g)
lb_db_f <- gframe(text = "LogBook DB file", horizontal = TRUE, container = new_g)
addSpring(lb_db_f)
sel_lb_f <- glabel("Select LB DB file", container = lb_db_f)
addSpring(lb_db_f)
gimage(system.file("ico/folder-orange.png", package="vmsbase"), container = lb_db_f,
handler = function(h,...){
lb_DB$db <<- gfile(text = "Select LB DataBase file",
type = "open",
filter = list("LB DB file" = list(patterns = c("*.lb.sqlite"))))
svalue(sel_lb_f) <- ifelse(.Platform$OS.type == "windows", strsplit(lb_DB$db, "\\\\")[[1]][length(strsplit(lb_DB$db, "\\\\")[[1]])],strsplit(lb_DB$db, "/")[[1]][length(strsplit(lb_DB$db, "/")[[1]])])
enabled(start_b) <- TRUE
enabled(g_sup) <- TRUE
})
gimage(system.file("ico/application-exit-5.png", package="vmsbase"), container = lb_db_f,
handler = function(h,...){
lb_DB$db <<- ""
enabled(start_b) <- FALSE
enabled(g_sup) <- FALSE
svalue(sel_lb_f) <- "Select LB DB file"
})
addSpring(new_g)
g_sup <- ggroup(horizontal = TRUE, container = big_g)
addSpring(g_sup)
g_s_b <- gframe("Dataset Cleaning", horizontal = F, container = g_sup)
cles_ex <- gcheckbox("Remove Exotics", checked = TRUE, container = g_s_b)
cles_ef_g <- ggroup(horizontal = TRUE, container = g_s_b)
cles_ef <- gcheckbox("Species f <", checked = TRUE, handler = function(h,...){enabled(cles_ef_q) <- !enabled(cles_ef_q)}, container = cles_ef_g)
cles_ef_q <- gspinbutton (from = 0, to = 3, by = 0.001, value = 0, container = cles_ef_g)
cles_ou <- gcheckbox("Species Outliers", checked = TRUE, container = g_s_b)
cles_oul <- gcheckbox("Logs Outliers", checked = TRUE, container = g_s_b)
cles_lo <- gcheckbox("logarithm", checked = FALSE, container = g_s_b)
cles_st <- gcheckbox("Stand by time", checked = FALSE, container = g_s_b)
g_s_c <- gframe("Clustering", horizontal = F, container = g_sup)
g_k_ran <- ggroup(horizontal = T, container = g_s_c)
l_k_ran <- glabel("Clusters to test Min", container = g_k_ran)
addSpring(g_k_ran)
min_k_ran <- gspinbutton(from = 2, to = 60, by = 1, value = 1, digits = 0,
horizontal = TRUE, container = g_k_ran)
g_k_ran2 <- ggroup(horizontal = T, container = g_s_c)
l_k_ran2 <- glabel("Clusters to test Max", container = g_k_ran2)
addSpring(g_k_ran2)
max_k_ran <- gspinbutton(from = 2, to = 60, by = 1, value = 60, digits = 0,
horizontal = TRUE, container = g_k_ran2)
g_samp <- ggroup(horizontal = T, container = g_s_c)
l_samp <- glabel("Number of samples", container = g_samp)
addSpring(g_samp)
s_samp <- gspinbutton(from = 10, to = 1000, by = 10, value = 10, digits = 0,
horizontal = TRUE, container = g_samp)
g_size <- ggroup(horizontal = T, container = g_s_c)
l_size <- glabel("Size of samples", container = g_size)
addSpring(g_size)
s_size <- gspinbutton(from = 10, to = 1000, by = 10, value = 10, digits = 0,
horizontal = TRUE, container = g_size)
g_metr <- gframe("Metric:", horizontal = FALSE, container = g_sup)
s_metr <- gradio(c("euclidean", "manhattan"), selected = 2,
container = g_metr)
g_subs <- gframe("Sub-Sampling:", horizontal = FALSE, container = g_sup)
s_subs <- gcheckbox("N. SubSample", checked = TRUE, handler = function(h,...){enabled(subs_q) <- !enabled(subs_q)}, container = g_subs)
subs_q <- gspinbutton (from = 100, to = 10000, by = 100, value = 1000, container = g_subs)
g_go <- ggroup(horizontal = TRUE, container = g_sup)
addSpring(g_go)
start_b <- gbutton(text = "Start\nMetier Discovery", container = g_go, handler = function(h,...){
enabled(g_sup) <- FALSE
enabled(save_bu) <- FALSE
#
# if(exists("x") == TRUE){rm(x)}
#
cat("\n\nGetting the DataSet...")
svalue(sb) <- "Getting the DataSet..."
x <- sqldf("select * from elobo", dbname = lb_DB$db)
if(svalue(cles_st) == TRUE)
{
cat("\nStandardizing by time...")
svalue(sb) <- "Standardizing by time..."
tms=ceiling(x[,3]-x[,2])
tms.0 = which(tms==0)
if(length(tms.0)>0){
x = x[-tms.0,]
tms = tms[-tms.0]
}
tms.outlier <- which(tms > 21)
if(length(tms.outlier)>0){
tms = tms[-tms.outlier]
x=x[-tms.outlier,]
}
divid <- tms
for(l in 1:(ncol(x)-6)){divid <- cbind(divid, tms)}
x[,6:ncol(x)] <- x[,6:ncol(x)]/divid
rm(divid)
}
cat("\nClearing Header...")
svalue(sb) <- "Clearing Header..."
x <- x[,-c(1,2,3,4,5)]
if(svalue(cles_ex) == TRUE)
{
#Elimina le specie esotiche
cat("\nExcluding exotic species")
svalue(sb) <- "Excluding exotic species..."
bad_str <- c("SQI", "CRQ", "GBO", "GGY", "OFJ", "COD", "SQL", "POI", "MAW")
bad_str_FAO <- paste("FAO_", bad_str, sep = "")
tole_ba <- which(colnames(x) %in% bad_str_FAO)
if(length(tole_ba)>0){
cat(" - ", length(tole_ba), " species removed", sep = " ")
bad_str_col <- which(colnames(x) %in% bad_str_FAO)
x <- x[,-bad_str_col]
}
}
#Elimina le specie con f < 1x100
if(svalue(cles_ef) == TRUE)
{
cat("\nExcluding species with f < ", svalue(cles_ef_q), sep = "")
svalue(sb) <- paste("Removing species with f < ", svalue(cles_ef_q), "% ", sep = "")
nposit <- function(vec) return(length(which(vec>0)))
nocc <- 100*apply(x,2,nposit)/nrow(x)
nocc_bru <- which(nocc <= svalue(cles_ef_q))
if(length(nocc_bru)>0)
{
cat(" - ", length(nocc_bru)," species removed", sep = "")
x <- x[,-nocc_bru]
}
}
#Rimuove gli outliers
if(svalue(cles_ou) == TRUE)
{
cat("\nExcluding Species Outliers")
svalue(sb) <- "Excluding Species Outliers..."
#################
# x <- rm.outlier(x, fill = TRUE, median = TRUE, opposite = FALSE)
tot_sp <- apply(x, 2, sum)
sp_out <- boxplot(tot_sp, plot = FALSE)$out
tole_sp <- which(colnames(x) %in% names(sp_out))
if(length(tole_sp) > 0){
cat(" - ", length(tole_sp), " species removed", sep = " ")
x <- x[,-tole_sp]
}
}
if(svalue(cles_oul) == TRUE)
{
cat("\nExcluding Logs Outliers")
svalue(sb) <- "Excluding Logs Outliers..."
tot_ca <- apply(x, 1, sum)
ca_out <- as.numeric(names(boxplot(tot_ca, plot = FALSE)$out))
if(length(ca_out) > 0)
{
cat(" - ", length(ca_out), " logs removed", sep = "")
x <- x[-ca_out,]
}
}
if(svalue(s_subs) == TRUE & svalue(subs_q) < nrow(x))
{
totak <- sample(1:nrow(x), svalue(subs_q), replace = FALSE)
x <- x[totak,]
}
if(svalue(cles_lo) == TRUE)
{
cat("\nCalculating logarithm", sep = "")
svalue(sb) <- paste("Calculating logarithm", sep = "")
x <- log(x+1)
}
#Ultimi controlli x scrupolo
col_sum <- apply(x,2,sum)
col_sum_zero <- which(col_sum == 0)
if(length(col_sum_zero)>0) x <- x[,-col_sum_zero]
row_sum <- apply(x,1,sum)
row_sum_na <- which(is.na(row_sum)==TRUE)
if(length(row_sum_na) > 0) x <- x[-row_sum_na,]
if(nrow(x) > 0 & ncol(x) > 0)
{
#Set k
krange = c(svalue(min_k_ran):min(nrow(x)-1, svalue(max_k_ran)))
silhvec=numeric(length(krange))
#Perform the CLARA
i=thr=0
max_siz <- max(svalue(s_size), max(krange))
cat("\n\n - Beginning Metier Discovery! -\n\n - Testing partioning:\n")
svalue(sb) <- "Metier Discovery..."
tonorm <- ifelse((svalue(s_metr) == "Bray-Curtis"),FALSE,TRUE)
S1=Sys.time()
for(k in krange){
if(max_siz <= k){
cat("\n\n - STOP - Sample Size < number of clusters -")
break}
cat("\n\nTesting ", k," clusters - ", sep = "")
svalue(sb) <- paste("Testing partioning with ",k," clusters", sep = "")
S2=Sys.time()
i=i+1
xclara <- clara(x,
k,
metric = svalue(s_metr),
stand = tonorm,
samples = svalue(s_samp),
sampsize = min(nrow(x), max_siz),
trace = 0,
medoids.x = TRUE, keep.data = TRUE, rngR = TRUE, pamLike = TRUE)
silhvec[i]=xclara$silinfo$avg.width
cat("Average width: ", round(silhvec[i], 3), sep = "")
svalue(sb) <- paste("Average width: ", silhvec[i], sep = "")
if(silhvec[i] > thr){
thr = silhvec[i]
lb_CLA$data <- xclara
cat(" - New Best Result!", sep = "")
svalue(sb) <- paste("Cluster ", i," with average width: ", round(silhvec[i], 2), " - NEW BEST!", sep = "")
}
par(las=1)
plot(silhvec, type="b", lwd=2, axes=F, cex=1.5,
xlab = "N. of Clusters", ylab = "Avg. Width",
mar = c(2,2,0,0),
ylim=c(0.9*min(silhvec),1.1*max(silhvec)))
axis(1, 1:length(krange),krange)
abline(v = krange-1, lty = 2, col = "gray", lwd = 1)
# abline(h = 0.5, lty = 2, col = 2)
points(krange[which.max(silhvec)]-(svalue(min_k_ran)-1), max(silhvec), pch=19, col=2, cex=1.3)
S3=Sys.time()
cat(" - Required time: ",round(S3-S2, 3), " ", attr(S3-S2, "units"), sep ="")
svalue(sb) <- paste("Required time: ", S3-S2, attr(S3-S2, "units"), " with k =", i, sep =" ")
}
S4 = Sys.time()
cat("\n\n --- Metier Discovery Completed! ---\n\nBest Avg Width ", lb_CLA$data$silinfo$avg.width, " - with ", nrow(lb_CLA$data$medoids), " clusters in ", round(S4-S1, 3), " ", attr(S4-S1, "units"), "\n", sep = "")
svalue(sb) <- paste("END\nCompleted in ", round(S4-S1, 3), " ", attr(S4-S1, "units"), sep = "")
gconfirm("Metier discovery completed", title = "Confirm")
enabled(save_bu) <- TRUE
enabled(g_sup) <- TRUE
}else{
cat("\nNot enough data to perform Metier Discovery!", sep = "")
enabled(g_sup) <- TRUE
}
})
addSpring(g_go)
addSpring(g_sup)
enabled(g_sup) <- FALSE
g_med <- gframe(text = "Results", horizontal = FALSE, container = big_g)
theplot <- ggraphics(width = 700, height = 350, container = g_med, expand = TRUE)
g_inf <- ggroup(horizontal = TRUE, container = big_g)
addSpring(g_inf)
save_bu <- gbutton(text = "Save\nMetier Discovery\nResults", container = g_inf, handler = function(h,...)
{
res_file <- gfile(text = "Save Metier Discovery result",
type = "save")
saveRDS(lb_CLA, file = paste(res_file, ".rData", sep = ""))
gconfirm("Metier discovery results saved", title = "Confirm")
})
enabled(save_bu) <- FALSE
addSpring(g_inf)
sb <- gstatusbar("", container = met_dis_win)
enabled(start_b) <- FALSE
if(lb_DB$db != "")
{
svalue(sel_lb_f) <- ifelse(.Platform$OS.type == "windows", strsplit(lb_DB$db, "\\\\")[[1]][length(strsplit(lb_DB$db, "\\\\")[[1]])],strsplit(lb_DB$db, "/")[[1]][length(strsplit(lb_DB$db, "/")[[1]])])
enabled(start_b) <- TRUE
enabled(g_sup) <- TRUE
}
visible(met_dis_win) <- TRUE
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.