R/gui_lb_met_cla.R

Defines functions gui_lb_met_cla

Documented in gui_lb_met_cla

#' LogBook Metier Classification GUI
#'
#' The \code{gui_lb_met_cla} function implements the graphical user interface
#'  for the LogBook metier classification
#'
#' This function, with a LogBook DB and a Metier Discovery object
#'  (see \code{\link{gui_lb_met_dis}}), computes a fuzzy classification of the logbooks
#'   in the seleted db according to the data provided from the Metier Discovery object.
#'
#' @param lb_db_name The path of a LogBook DataBase
#'
#' @return This function does not return a value.
#'  After the execution the computed result will be added to the logbook database
#'   in the 'lb_cla' table.
#'
#' @usage gui_lb_met_cla(lb_db_name = "")
#'
#'
#' @seealso \code{\link{gui_lb_met_dis}}


gui_lb_met_cla <- function(lb_db_name = "") {
  lb_DB <- log_DB$new()
  lb_DB$db <- lb_db_name
  lb_CLU <- log_Cla$new()
  cla_file <- ""

  lb_met_cla_win <- gwindow(
    title = "LogBook Metier Classification Tool",
    visible = FALSE
  )

  big_g <- ggroup(horizontal = FALSE, container = lb_met_cla_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) <- strsplit(lb_DB$db, "/")[[1]][length(strsplit(lb_DB$db, "/")[[1]])]
      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(g_input) <- TRUE
      enabled(in_sel_g) <- TRUE
      enabled(b_met_cla) <- TRUE
    }
  )
  gimage(system.file("ico/application-exit-5.png", package = "vmsbase"),
    container = lb_db_f,
    handler = function(h, ...) {
      lb_DB$db <<- ""
      enabled(b_met_cla) <- FALSE
      enabled(g_input) <- FALSE
      enabled(in_sel_g) <- FALSE
      svalue(sel_lb_f) <- "Select LB DB file"
    }
  )
  addSpring(new_g)




  in_sel_g <- ggroup(horizontal = TRUE, container = big_g)
  addSpring(in_sel_g)
  in_sel_f <- gframe(text = "Classify Logbook by", horizontal = TRUE, container = in_sel_g)
  addSpring(in_sel_f)
  #   sel_lb_f <- glabel("Select LB DB file", container = in_sel_f)
  addSpring(in_sel_f)

  in_by_sel <- gradio(c(
    "Stored 'Metier' field in DB",
    "Stored 'Gear' field in DB",
    "Fuzzy Membership of Catch Profile"
  ),
  container = in_sel_f, horizontal = FALSE,
  handler = function(h, ...) {
    if (svalue(in_by_sel) == "Fuzzy Membership of Catch Profile") {
      enabled(g_input) <- TRUE
    } else {
      enabled(g_input) <- FALSE
    }
  }
  )

  img_g <- ggroup(horizontal = FALSE, container = in_sel_f)

  gimage(system.file("ico/document-properties.png", package = "vmsbase"),
    container = img_g,
    handler = function(h, ...) {
      if (lb_DB$db != "") {
        met_lst <- sqldf("select metier from elobo", dbname = lb_DB$db)
        ok_met <- which(met_lst != 0)
        if (length(ok_met) != 0) {
          met_tbl <- sort(table(met_lst), decreasing = TRUE)
          met_dia <- gbasicdialog(title = "Logbook DB Metier Data")
          met_lab <- glabel(paste("\n\tN. of records:\t\t\tMetier Name:\n\n\t\t", paste(as.numeric(met_tbl)[which(as.numeric(met_tbl) >= (nrow(met_lst) / 100))], names(met_tbl)[which(as.numeric(met_tbl) >= (nrow(met_lst) / 100))]
            ,
            sep = "  \t\t\t", collapse = "\t\n\t\t"
          ), "\n\n", paste("\t\t\t...and other ", length(which(!as.numeric(met_tbl) >= (nrow(met_lst) / 100))), " metier with a frequency < 1%\n\n", sep = ""), sep = ""),
          container = met_dia
          )
          visible(met_dia, set = TRUE)
        } else {
          gmessage("\n\n      ERROR! Metier Data not available!     ", icon = "error")
        }
      }
    }
  )
  gimage(system.file("ico/document-properties.png", package = "vmsbase"),
    container = img_g,
    handler = function(h, ...) {
      if (lb_DB$db != "") {
        gea_lst <- sqldf("select gear from elobo", dbname = lb_DB$db)
        ok_gea <- which(gea_lst != 0)
        if (length(ok_gea) != 0) {
          gea_tbl <- sort(table(gea_lst), decreasing = TRUE)
          gea_dia <- gbasicdialog(title = "Logbook DB Gear Data")
          gea_lab <- glabel(paste("\n\tN. of records:\t\t\tGear Name:\n\n\t\t", paste(as.numeric(gea_tbl)[which(as.numeric(gea_tbl) >= (nrow(gea_lst) / 100))], names(gea_tbl)[which(as.numeric(gea_tbl) >= (nrow(gea_lst) / 100))]
            ,
            sep = "  \t\t\t", collapse = "\t\n\t\t"
          ), "\n\n", paste("\t\t\t...and other ", length(which(!as.numeric(gea_tbl) >= (nrow(gea_lst) / 100))), " gears with a frequency < 1%\n\n", sep = ""), sep = ""),
          container = gea_dia
          )
          visible(gea_dia, set = TRUE)
        } else {
          gmessage("\n\n      ERROR! Gear Data not available!     ", icon = "error")
        }
      }
    }
  )

  addSpring(in_sel_g)




  g_input <- ggroup(horizontal = TRUE, container = big_g)
  addSpring(g_input)
  met_c_f <- gframe(text = "Metier file", horizontal = FALSE, container = g_input)
  me_cl_st_g <- ggroup(horizontal = TRUE, container = met_c_f)
  glabel("Use Standard\nClassification?", container = me_cl_st_g)
  sta_cla_sel <- gradio(c("Yes", "No"),
    container = me_cl_st_g, horizontal = FALSE,
    handler = function(h, ...) {
      enabled(cus_cla_g) <- !enabled(cus_cla_g)
      enabled(b_met_cla) <- !enabled(b_met_cla)
      if (lb_DB$db == "") {
        enabled(b_met_cla) <- FALSE
      }
    }
  )

  cus_cla_g <- ggroup(horizontal = TRUE, container = met_c_f)
  sta_cla_lab <- glabel("Select Edited\nMetier File", container = cus_cla_g)
  gimage(system.file("ico/address-book-new-4.png", package = "vmsbase"),
    container = cus_cla_g,
    handler = function(h, ...) {
      enabled(b_met_cla) <- FALSE
      cla_file <- gfile(
        text = "Select Metier file",
        type = "open",
        filter = list("Metier data" = list(patterns = c("*.rData")))
      )
      #            svalue(sta_cla_lab) <- paste(strsplit(cla_file, "/")[[1]][length(strsplit(cla_file, "/")[[1]])])
      svalue(sta_cla_lab) <- ifelse(.Platform$OS.type == "windows", strsplit(cla_file, "\\\\")[[1]][length(strsplit(cla_file, "\\\\")[[1]])], strsplit(cla_file, "/")[[1]][length(strsplit(cla_file, "/")[[1]])])
      if (lb_DB$db != "") {
        enabled(b_met_cla) <- TRUE
      }
    }
  )
  enabled(cus_cla_g) <- FALSE

  addSpring(g_input)
  met_c_f <- gframe(text = "Metric", horizontal = FALSE, container = g_input)
  met_cla_sel <- gradio(c("euclidean", "manhattan", "bray-curtis"), container = met_c_f, horizontal = FALSE)
  addSpring(g_input)
  addSpring(big_g)

  info_lab <- glabel("", container = big_g)

  addSpring(big_g)
  b_met_cla <- gbutton(text = "Start\nClassification", container = big_g, handler = function(h, ...) {
    enabled(g_input) <- FALSE
    enabled(in_sel_g) <- FALSE
    enabled(b_met_cla) <- FALSE

    sqldf("drop table if exists lb_cla", dbname = lb_DB$db)
    query <- "CREATE TABLE lb_cla(vessel INT, log_num INT, met_fo INT, met_des CHAR)"
    sqldf(query, dbname = lb_DB$db)

    if (svalue(in_by_sel) == "Fuzzy Membership of Catch Profile") {
      vess <- sqldf("select distinct vessUE from elobo", dbname = lb_DB$db)

      svalue(info_lab) <- paste("LogBook Metier Classification Started!", sep = "")
      cat("\n\n   ---   LogBook Metier Classification Started!   ---\n\n", sep = "")

      risultato <- data.frame()
      num_vess <- nrow(vess)

      if (svalue(sta_cla_sel) == "No") {
        lb_CLU <- readRDS(cla_file)
        medoids <- lb_CLU$data$medoids
        options <- lb_CLU$options
      } else {
        sta_cla_fl <- read.csv2(system.file("extdata/Sta_met", package = "vmsbase"))
        medoids <- sta_cla_fl[, 2:ncol(sta_cla_fl)]
        colnames(medoids) <- paste("FAO_", colnames(medoids), sep = "")
        options <- as.character(sta_cla_fl[, 1])
      }

      for (i in 1:num_vess)
      {
        cat("\nClassifying vessel: ", vess[i, 1], " - N.", i, " of ", num_vess, sep = "")
        svalue(info_lab) <- paste("Classifying vessel: ", vess[i, 1], " - N.", i, " of ", num_vess, sep = "")
        lb_data <- fn$sqldf("select ROWID, * from elobo where vessUE = `vess[i,1]`", dbname = lb_DB$db)

        if (nrow(lb_data) > 0) {
          same_col <- which(colnames(lb_data) %in% colnames(medoids))
          same_col2 <- which(colnames(medoids) %in% colnames(lb_data))


          same_dat <- lb_data[, same_col]

          num_lb <- nrow(same_dat)

          res_diss <- data.frame(
            vessel = vess[i, 1],
            log_num = numeric(num_lb),
            met_fo = numeric(num_lb),
            met_des = character(num_lb)
          )

          res_diss[, 4] <- NA
          #                            res_diss[1:num_lb,2] <- 1:num_lb

          fuzz <- 2

          cat("\n", num_lb, " logbooks - Calculating... ", sep = "")
          for (k in 1:num_lb)
          {
            if (sum(same_dat[k, ]) == 0) {
              next
            }

            diss_dat <- rbind(same_dat[k, ], medoids[, same_col2])

            diss_res <- distance(diss_dat, method = svalue(met_cla_sel))

            mat_res <- as.matrix(diss_res)[, 1]

            vec_res <- as.numeric(mat_res[-1])

            memb <- numeric(length(vec_res))

            for (h in 1:length(vec_res))
            {
              memb[h] <- 1 / sum((vec_res[h] / vec_res)^(2 / (fuzz - 1)))
            }
            res_diss[k, 2] <- lb_data[k, "rowid"]
            res_diss[k, 3] <- which.max(memb)
            if (length(options) != 0 & res_diss[k, 3] != 0) {
              res_diss[k, 4] <- options[res_diss[k, 3]]
            }
          }

          cat("Complete!\n\n", sep = "")

          sqldf("INSERT INTO lb_cla SELECT * FROM `res_diss`", dbname = lb_DB$db)
        } else {
          cat(" - Skipped \n", sep = "")
        }
      }
      svalue(info_lab) <- paste("End LogBook Metier Classification", sep = "")
      cat("\n   ---   End LogBook Metier Classification   ---\n\n", sep = "")
    }

    if (svalue(in_by_sel) == "Stored 'Metier' field in DB") {
      lb_data <- sqldf("select vessUE, ROWID, metier from elobo", dbname = lb_DB$db)

      if (nrow(lb_data) > 0 & length(which((lb_data[, "metier"]) == 0)) == 0) {
        lb_data <- cbind(lb_data[, 1:2], as.numeric(as.factor(lb_data[, "metier"])), lb_data[, 3])
        colnames(lb_data) <- c("vessel", "log_num", "met_fo", "met_des")

        sqldf("INSERT INTO lb_cla SELECT * FROM `lb_data`", dbname = lb_DB$db)

        svalue(info_lab) <- paste("End LogBook Metier Classification", sep = "")
        cat("\n   ---   End LogBook Metier Classification   ---\n\n", sep = "")
      } else {
        cat("\n   ---   ERROR! Metier data not available!   ---\n\n", sep = "")
      }
    }


    if (svalue(in_by_sel) == "Stored 'Gear' field in DB") {
      lb_data <- sqldf("select vessUE, ROWID, gear from elobo", dbname = lb_DB$db)

      if (nrow(lb_data) > 0 & length(which((lb_data[, "gear"]) == 0)) == 0) {
        lb_data <- cbind(lb_data[, 1:2], as.numeric(as.factor(lb_data[, "gear"])), lb_data[, 3])
        colnames(lb_data) <- c("vessel", "log_num", "met_fo", "met_des")
        sqldf("INSERT INTO lb_cla SELECT * FROM `lb_data`", dbname = lb_DB$db)

        svalue(info_lab) <- paste("End LogBook Metier Classification", sep = "")
        cat("\n   ---   End LogBook Metier Classification   ---\n\n", sep = "")
      } else {
        cat("\n   ---   ERROR! Gear data not available!   ---\n\n", sep = "")
      }
    }

    gconfirm("LogBook Classification Complete!",
      title = "Confirm", icon = "info",
      handler = dispose(lb_met_cla_win)
    )
  })
  # addSpring(g_go)
  enabled(g_input) <- FALSE
  enabled(b_met_cla) <- FALSE
  enabled(in_sel_g) <- FALSE


  if (lb_DB$db != "") {
    #     svalue(sel_lb_f) <- strsplit(lb_DB$db, "/")[[1]][length(strsplit(lb_DB$db, "/")[[1]])]
    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(b_met_cla) <- TRUE
    enabled(in_sel_g) <- TRUE
    enabled(g_input) <- TRUE
  }
  visible(lb_met_cla_win) <- TRUE
}

Try the vmsbase package in your browser

Any scripts or data that you put into this service are public.

vmsbase documentation built on Dec. 3, 2018, 5:03 p.m.