R/gui_vms_met_pred.R

Defines functions gui_vms_met_pred

Documented in gui_vms_met_pred

#' Predict Metier GUI
#'
#' The \code{gui_vms_met_pred} function implements the graphical user interface for the
#'  Metier Prediction
#'
#' This function,  with a VMS database and a shape file with harbours points, performs a neural network prediction over the whole
#'  db assigning metier data to vms tracks based on a training with existing vms-lb match data
#'   given by the database.
#'
#' @param vms_db_name The path of a VMS DataBase
#'
#' @return This function does not return a value.
#'
#' @usage gui_vms_met_pred(vms_db_name = "")
#'
#'
#' @references
#' Russo, T., Parisi, A., Prorgi, M., Boccoli, F., Cignini, I., Tordoni, M. and Cataudella, S. (2011) When behaviour reveals activity: Assigning fishing effort to metiers based on VMS data using artificial neural networks. \emph{Fisheries Research}, \bold{111(1)}, 53--64.
#' \url{http://www.sciencedirect.com/science/article/pii/S0165783611002281}

gui_vms_met_pred <- function(vms_db_name = "") {
  vms_DB <- vms_DB$new()
  vms_DB$db <- vms_db_name
  clas_file <- ""

  main_win <- gwindow(
    title = " Metier Prediction - Interactive Interface", visible = FALSE,
    width = 800, height = 500
  )
  main_g <- ggroup(horizontal = TRUE, container = main_win)
  right_g <- gframe(horizontal = FALSE, use.scrollwindow = FALSE, container = main_g)
  addSpring(main_g)
  left_g <- ggroup(horizontal = FALSE, use.scrollwindow = FALSE, container = main_g)

  # addSpring(left_g)
  one_g <- ggroup(horizontal = TRUE, container = right_g)
  addSpring(one_g)
  ## VMS DataBase file
  vms_db_f <- gframe(text = "VMS DB file", horizontal = TRUE, container = one_g)
  addSpring(vms_db_f)
  sel_vms_f <- glabel("Select VMS DB file", container = vms_db_f)
  addSpring(vms_db_f)
  gimage(system.file("ico/folder-blue.png", package = "vmsbase"),
    container = vms_db_f,
    handler = function(h, ...) {
      vms_DB$db <- gfile(
        text = "Select VMS DataBase file",
        type = "open",
        filter = list("VMS DB file" = list(patterns = c("*.vms.sqlite")))
      )
      if (!is.na(vms_DB$db)) {
        svalue(sel_vms_f) <- ifelse(.Platform$OS.type == "windows", strsplit(vms_DB$db, "\\\\")[[1]][length(strsplit(vms_DB$db, "\\\\")[[1]])], strsplit(vms_DB$db, "/")[[1]][length(strsplit(vms_DB$db, "/")[[1]])])
        n_ntr <- as.numeric(sqldf("select count(*) from intrp", dbname = vms_DB$db))
        if (n_ntr > 0) {
          svalue(n_vess) <- paste("   N. of Vessels:  ", as.numeric(sqldf("select count(distinct I_NCEE) from intrp", dbname = vms_DB$db)), sep = "")
          svalue(n_trck) <- paste("    N. of tracks:  ", as.numeric(sqldf("select count(*) from (select distinct I_NCEE, T_NUM from track)", dbname = vms_DB$db)), sep = "")
          svalue(n_matc) <- paste(" N. VMS-LB match:  ", as.numeric(sqldf("select count(*) from vms_lb", dbname = vms_DB$db)), sep = "")
          svalue(n_ping) <- paste("     N. of Pings:  ", n_ntr, sep = "")

          enabled(start_ba) <- TRUE
          enabled(two_b_g) <- TRUE

          nn_tab <- as.numeric(sqldf("SELECT count(*) FROM sqlite_master WHERE type='table' AND name='pre_nn'", dbname = vms_DB$db))
          if (nn_tab == 1) {
            enabled(g_go) <- TRUE
            enabled(two_c_g) <- TRUE
          }
        } else {
          cat("\n\n  VMS DB error - Interpolated Pings not found!\n\n", sep = "")
        }
      }
    }
  )
  gimage(system.file("ico/application-exit-5.png", package = "vmsbase"),
    container = vms_db_f,
    handler = function(h, ...) {
      vms_DB$db <- ""
      svalue(sel_vms_f) <- "Select VMS DB file"
      enabled(g_go) <- FALSE
      enabled(start_ba) <- FALSE
      enabled(two_b_g) <- FALSE
      enabled(two_c_g) <- FALSE
    }
  )
  addSpring(one_g)

  two_g <- gexpandgroup("Data", horizontal = FALSE, container = right_g)
  n_vess <- glabel("N. of Vessels:   ---", container = two_g)
  n_trck <- glabel(" N. of Tracks:   ---", container = two_g)
  n_matc <- glabel(" VMS-LB match:   ---", container = two_g)
  n_ping <- glabel("  N. of Pings:   ---", container = two_g)

  par_bg00 <- ggroup(horizontal = TRUE, container = right_g)
  addSpring(par_bg00)
  glabel("Classify by", container = par_bg00)
  cla_trkvess <- gradio(c("Vessel", "Track"), container = par_bg00, horizontal = TRUE)
  addSpring(par_bg00)

  two_b_g <- gexpandgroup("Classes", horizontal = FALSE, container = right_g)
  addSpring(two_b_g)

  par_bg21 <- ggroup(horizontal = TRUE, container = two_b_g)

  addSpring(par_bg21)
  bg21 <- glayout(container = par_bg21, spacing = 10)
  bg21[1, 1, anchor = 0] <- "Speed\nClasses"
  bg21[1, 2, anchor = 0] <- gspinbutton(from = 2, to = 30, by = 1, value = 9)
  bg21[1, 3, anchor = 0] <- "Max Speed"
  bg21[1, 4, anchor = 0] <- gspinbutton(from = 0, to = 60, by = 1, value = 30)

  bg21[2, 1, anchor = 0] <- "Depth\nClasses"
  bg21[2, 2, anchor = 0] <- gspinbutton(from = 2, to = 30, by = 1, value = 9)
  bg21[2, 3, anchor = 0] <- "Max Depth"
  bg21[2, 4, anchor = 0] <- gspinbutton(from = 0, to = 11000, by = 1, value = 1000)

  bg21[3, 1, anchor = 0] <- "Heading\nClasses"
  bg21[3, 2, anchor = 0] <- gspinbutton(from = 2, to = 30, by = 1, value = 4)
  addSpring(par_bg21)

  addSpring(two_b_g)

  par_bg22 <- ggroup(horizontal = TRUE, container = two_b_g)
  addSpring(par_bg22)

  glabel("Use Custom\nClasses?", container = par_bg22)
  sta_cla_sel <- gradio(c("No", "Yes"),
    container = par_bg22, horizontal = FALSE,
    handler = function(h, ...) {
      enabled(par_bg21) <- !enabled(par_bg21)
      enabled(cust_clas) <- !enabled(cust_clas)
      enabled(start_ba) <- !enabled(start_ba)
      if (vms_DB$db == "") {
        enabled(start_ba) <- FALSE
      }
    }
  )

  cust_clas <- ggroup(horizontal = TRUE, container = par_bg22)
  cus_cla_lab <- glabel("Select Custom\nClass File", container = cust_clas)
  gimage(system.file("ico/address-book-new-4.png", package = "vmsbase"),
    container = cust_clas,
    handler = function(h, ...) {
      enabled(start_ba) <- FALSE
      clas_file <<- gfile(
        text = "Select Custom Class file",
        type = "open"
      )
      svalue(cus_cla_lab) <- ifelse(.Platform$OS.type == "windows", strsplit(clas_file, "\\\\")[[1]][length(strsplit(clas_file, "\\\\")[[1]])], strsplit(clas_file, "/")[[1]][length(strsplit(clas_file, "/")[[1]])])
      if (vms_DB$db != "") {
        enabled(start_ba) <- TRUE
      }
    }
  )
  enabled(cust_clas) <- FALSE

  addSpring(par_bg22)

  start_ba <- gbutton(text = "\nClassify Data\n", container = two_b_g, handler = function(h, ...) {
    enabled(g_go) <- FALSE
    enabled(start_ba) <- FALSE
    enabled(vms_db_f) <- FALSE
    enabled(two_b_g) <- FALSE
    enabled(two_c_g) <- FALSE

    ## Data Classification ----
    cat("\n\n   ---   Start Data Classification   ---\n\n", sep = "")
    cat("\n   -     Configuration...     \n", sep = "")
    svalue(sup_rep) <- "Parameters\nConfiguration..."

    ## Classes Definition ----
    if (svalue(sta_cla_sel) == "No") {
      max_spe <- svalue(bg21[1, 4])
      min_spe <- 0
      max_dep <- 0
      min_dep <- -as.numeric(floor(svalue(bg21[2, 4])))
      cla_spe <- svalue(bg21[1, 2])
      cla_dep <- svalue(bg21[2, 2])
      cla_hea <- svalue(bg21[3, 2])

      vect_spe <- seq(min_spe, max_spe, length = cla_spe + 1)
      cat("\n Speed Classes: ", round(vect_spe, 2), sep = " ")

      vect_dep <- seq(min_dep, max_dep, length = cla_dep + 1)
      cat("\n Depth Classes: ", round(vect_dep, 2), sep = " ")

      vect_hea <- seq(-360, 360, length = cla_hea + 1)
      cat("\n Heading Classes: ", round(vect_hea, 2), "\n\n", sep = " ")
    } else {
      if (clas_file != "") {
        thr_lns <- readLines(clas_file, 3)
        vect_spe <- as.numeric(unlist(strsplit(unlist(strsplit(thr_lns[1], ":"))[2], "; ")))
        vect_dep <- as.numeric(unlist(strsplit(unlist(strsplit(thr_lns[2], ":"))[2], "; ")))
        vect_hea <- as.numeric(unlist(strsplit(unlist(strsplit(thr_lns[3], ":"))[2], "; ")))
        max_spe <- max(vect_spe)
        min_spe <- 0
        max_dep <- 0
        min_dep <- min(vect_dep)
        cla_spe <- length(vect_spe) - 1
        cla_dep <- length(vect_dep) - 1
        cla_hea <- length(vect_hea) - 1
      } else {
        enabled(start_ba) <- TRUE
        enabled(two_b_g) <- TRUE
        nn_tab <- as.numeric(sqldf("SELECT count(*) FROM sqlite_master WHERE type='table' AND name='pre_nn'", dbname = vms_DB$db))
        if (nn_tab == 1) {
          enabled(g_go) <- TRUE
          enabled(two_c_g) <- TRUE
        }
        stop("Missing Custom Class File")
      }
    }

    ## Classification by track ----

    if (svalue(cla_trkvess) == "Track") {
      svalue(sup_rep) <- "Loading\nFleet Data..."
      poi <- sqldf("select distinct I_NCEE, T_NUM from intrp", dbname = vms_DB$db)
      numpoi <- nrow(poi)
      to_out <- data.frame(
        "I_NCEE" = numeric(numpoi),
        "T_NUM" = numeric(numpoi)
      )
      to_out[, 1:2] <- poi
      for (s in 1:cla_spe) {
        to_out <- cbind(to_out, 0)
        colnames(to_out)[ncol(to_out)] <- paste("SPE_", s, sep = "")
      }
      for (d in 1:cla_dep) {
        to_out <- cbind(to_out, 0)
        colnames(to_out)[ncol(to_out)] <- paste("DEP_", d, sep = "")
      }
      for (h in 1:cla_hea) {
        to_out <- cbind(to_out, 0)
        colnames(to_out)[ncol(to_out)] <- paste("HEA_", h, sep = "")
      }
      to_out <- cbind(to_out, 0)
      colnames(to_out)[ncol(to_out)] <- "M_LAT"
      to_out <- cbind(to_out, 0)
      colnames(to_out)[ncol(to_out)] <- "M_LON"
      to_out <- cbind(to_out, 0)
      colnames(to_out)[ncol(to_out)] <- "MET"

      incee <- sqldf("select distinct(I_NCEE) from intrp", dbname = vms_DB$db)
      cat("   -     Analyzing     -\n", sep = "")
      svalue(sup_rep) <- "Analysis\nStarted..."
      for (v in 1:nrow(incee)) {
        cat("\n   -     Vessel: ", incee[v, 1], " - ", v, " of ", nrow(incee), sep = "")
        vessel <- fn$sqldf("select * from intrp, p_depth where intrp.ROWID = i_id and I_NCEE = `incee[v,1]` order by DATE", dbname = vms_DB$db)
        svalue(sup_rep) <- paste("Analyzing...\n   ", round((100 / nrow(incee)) * v, 1), "%", sep = "")
        if (nrow(vessel) > 0) {
          trks <- unique(vessel[, "T_NUM"])
          for (t in trks) {
            spee_t <- vessel[which(vessel[, "T_NUM"] == t), "SPE"]
            spee_t <- spee_t[which((spee_t >= min_spe) & (spee_t < max_spe))]
            if (length(spee_t) == 0) {
              cat(" - Skipped no speed data", sep = "")
              next
            }
            spee_t[which(spee_t >= max_spe)] <- max_spe
            spe_int <- hist(spee_t, breaks = vect_spe, plot = FALSE)$count
            spe_out <- spe_int / length(spee_t)

            deep_t <- vessel[which(vessel[, "T_NUM"] == t), "DEPTH"]
            deep_t <- deep_t[which((deep_t > min_dep) & (deep_t <= max_dep))]
            if (length(deep_t) == 0) {
              cat(" - Skipped no depth data", sep = "")
              next
            }
            dee_int <- hist(deep_t, breaks = vect_dep, plot = FALSE)$count
            dep_out <- dee_int / length(deep_t)

            head_t <- vessel[which(vessel[, "T_NUM"] == t), "HEA"]
            head_t[which(head_t > 360)] <- head_t[which(head_t > 360)] - 360
            head_t <- c(0, diff(head_t))
            hea_int <- hist(head_t, breaks = vect_hea, plot = FALSE)$count
            hea_out <- hea_int / length(head_t)

            to_tr <- which((to_out[, "I_NCEE"] == incee[v, 1]) & (to_out[, "T_NUM"] == t))
            to_out[to_tr, 3:(2 + cla_spe)] <- spe_out
            to_out[to_tr, (3 + cla_spe):(2 + cla_spe + cla_dep)] <- dep_out
            to_out[to_tr, (3 + cla_spe + cla_dep):(2 + cla_spe + cla_dep + cla_hea)] <- hea_out

            cat(".", sep = "")
            to_out[to_tr, "M_LON"] <- median(vessel[which(vessel[, "T_NUM"] == t), "LON"])
            to_out[to_tr, "M_LAT"] <- median(vessel[which(vessel[, "T_NUM"] == t), "LAT"])
          }
          metier <- fn$sqldf("select * from vms_lb where vessel = `incee[v,1]`", dbname = vms_DB$db)
          if (length(metier) > 0) {
            go_in <- which(to_out[, "I_NCEE"] == incee[v, 1])
            whi_1 <- which(to_out[go_in, "T_NUM"] %in% metier[, 2])
            if (length(whi_1) > 0) {
              whi_3 <- which(metier[, "track"] %in% to_out[go_in[whi_1], 2])
              if (length(whi_3) > 0) {
                to_out[go_in[whi_1], "MET"] <- as.character(metier[whi_3, "met_des"])
              }
            }
          }
        } else {
          cat(" - No VMS-Depth Data - Skipping", sep = "")
          next
        }
      }
    } else {
      ## Classification by Vessel ----

      poi <- sqldf("select distinct I_NCEE from intrp", dbname = vms_DB$db)
      numpoi <- nrow(poi)
      to_out <- data.frame("I_NCEE" = numeric(numpoi))
      to_out[, 1] <- poi[, 1]

      for (s in 1:cla_spe) {
        to_out <- cbind(to_out, 0)
        colnames(to_out)[ncol(to_out)] <- paste("SPE_", s, sep = "")
      }
      for (d in 1:cla_dep) {
        to_out <- cbind(to_out, 0)
        colnames(to_out)[ncol(to_out)] <- paste("DEP_", d, sep = "")
      }
      for (h in 1:cla_hea) {
        to_out <- cbind(to_out, 0)
        colnames(to_out)[ncol(to_out)] <- paste("HEA_", h, sep = "")
      }
      to_out <- cbind(to_out, 0)
      colnames(to_out)[ncol(to_out)] <- "M_LAT"
      to_out <- cbind(to_out, 0)
      colnames(to_out)[ncol(to_out)] <- "M_LON"
      to_out <- cbind(to_out, 0)
      colnames(to_out)[ncol(to_out)] <- "MET"

      incee <- sqldf("select distinct(I_NCEE) from intrp", dbname = vms_DB$db)
      cat("   -     Analyzing     -\n", sep = "")
      svalue(sup_rep) <- "Analysis\nStarted..."

      for (v in 1:nrow(incee)) {
        cat("\n   -     Vessel: ", incee[v, 1], " - ", v, " of ", nrow(incee), sep = "")
        vessel <- fn$sqldf("select * from intrp, p_depth where intrp.ROWID = i_id and I_NCEE = `incee[v,1]` order by DATE", dbname = vms_DB$db)
        svalue(sup_rep) <- paste("Analyzing...\n   ", round((100 / nrow(incee)) * v, 1), "%", sep = "")
        if (nrow(vessel) > 0) {
          spee_t <- vessel$SPE
          spee_t <- spee_t[which((spee_t >= min_spe) & (spee_t < max_spe))]
          if (length(spee_t) == 0) {
            cat(" - Skipped no speed data", sep = "")
            next
          }
          spe_int <- hist(spee_t, breaks = vect_spe, plot = FALSE)$count
          spe_out <- spe_int / length(spee_t)

          deep_t <- vessel$DEPTH
          deep_t <- deep_t[which((deep_t > min_dep) & (deep_t <= max_dep))]
          if (length(deep_t) == 0) {
            cat(" - Skipped no depth data", sep = "")
            next
          }
          dee_int <- hist(deep_t, breaks = vect_dep, plot = FALSE)$count
          dep_out <- dee_int / length(deep_t)

          head_t <- vessel$HEA
          head_t[which(head_t > 360)] <- head_t[which(head_t > 360)] - 360
          head_t <- c(0, diff(head_t))
          hea_int <- hist(head_t, breaks = vect_hea, plot = FALSE)$count
          hea_out <- hea_int / length(head_t)

          to_tr <- which(to_out[, "I_NCEE"] == incee[v, 1])
          to_out[to_tr, 3:(2 + cla_spe)] <- spe_out
          to_out[to_tr, (3 + cla_spe):(2 + cla_spe + cla_dep)] <- dep_out
          to_out[to_tr, (3 + cla_spe + cla_dep):(2 + cla_spe + cla_dep + cla_hea)] <- hea_out

          to_out[to_tr, "M_LON"] <- median(vessel$LON)
          to_out[to_tr, "M_LAT"] <- median(vessel$LAT)

          metier <- fn$sqldf("select met_des from vms_lb where vessel = `incee[v,1]`", dbname = vms_DB$db)[, 1]
          if (length(metier) > 0) {
            to_out[to_tr, "MET"] <- names(which.max(table(metier)))
          }
        } else {
          cat(" - No VMS-Depth Data - Skipping", sep = "")
          next
        }
      }
    }
    svalue(sup_rep) <- "Updating\nDataBase..."
    sqldf("drop table if exists pre_nn", dbname = vms_DB$db)
    sqldf("CREATE TABLE pre_nn AS SELECT * FROM `to_out`", dbname = vms_DB$db)
    svalue(sup_rep) <- ""

    cat("\n\n   ---   Vessel Data Classification Complete!   ---\n\n", sep = "")

    enabled(g_go) <- TRUE
    enabled(start_ba) <- TRUE
    enabled(vms_db_f) <- TRUE
    enabled(two_b_g) <- TRUE
    enabled(two_c_g) <- TRUE
  })
  # addSpring(right_g)

  ## NN Metier Predict ----

  two_c_g <- gexpandgroup("NN parameters", horizontal = FALSE, container = right_g)
  bgc1 <- ggroup(horizontal = TRUE, container = two_c_g)
  addSpring(bgc1)
  n_thr_h <- glabel("Metier Abundance\nThreshold", container = bgc1)
  addSpring(bgc1)
  thr_sel <- gspinbutton(from = 0.0001, to = 0.1, by = 0.0001, value = 0.05, container = bgc1)
  bgc2 <- ggroup(horizontal = TRUE, container = two_c_g)
  addSpring(bgc2)
  n_nHf_h <- glabel("nHf", container = bgc2)
  addSpring(bgc2)
  nHf_sel <- gspinbutton(from = 1, to = 3, by = 0.5, value = 1.5, container = bgc2)
  bgc3 <- ggroup(horizontal = TRUE, container = two_c_g)
  addSpring(bgc3)
  n_trs_h <- glabel("TR size", container = bgc3)
  addSpring(bgc3)
  trs_sel <- gspinbutton(from = 50, to = 70, by = 1, value = 60, container = bgc3)
  bgc4 <- ggroup(horizontal = TRUE, container = two_c_g)
  addSpring(bgc4)
  n_va_h <- glabel("VA size", container = bgc4)
  addSpring(bgc4)
  va_sel <- gspinbutton(from = 10, to = 29, by = 1, value = 15, container = bgc4)
  bgc5 <- ggroup(horizontal = TRUE, container = two_c_g)
  addSpring(bgc5)
  n_step_h <- glabel("n. Step", container = bgc5)
  addSpring(bgc5)
  step_sel <- gspinbutton(from = 100, to = 1000, by = 100, value = 100, container = bgc5)
  bgc6 <- ggroup(horizontal = TRUE, container = two_c_g)
  addSpring(bgc6)
  n_show_h <- glabel("n. Show", container = bgc6)
  addSpring(bgc6)
  show_sel <- gspinbutton(from = 100, to = 1000, by = 100, value = 100, container = bgc6)
  bgc7 <- ggroup(horizontal = TRUE, container = two_c_g)
  addSpring(bgc7)
  n_mfac_h <- glabel("Min Fac", container = bgc7)
  addSpring(bgc7)
  mfac_sel <- gspinbutton(from = 1, to = 100, by = 1, value = 50, container = bgc7)

  sup_rep <- glabel("\n", container = right_g)

  g_go <- ggroup(horizontal = TRUE, container = right_g)
  addSpring(g_go)
  pred_f_net <- gbutton(text = "\nPredict from Saved\n", container = g_go, handler = function(h, ...) {
    enabled(g_go) <- FALSE
    enabled(start_ba) <- FALSE
    enabled(vms_db_f) <- FALSE
    enabled(two_b_g) <- FALSE
    enabled(two_c_g) <- FALSE

    net <- readRDS(gfile(
      text = "Select Saved Neural Net file",
      type = "open",
      filter = list("R file" = list(patterns = c("*.rData")))
    ))

    LBdata <- sqldf("select * from pre_nn", dbname = vms_DB$db)

    if (svalue(cla_trkvess) == "Track") {
      hea_lb <- LBdata[, c(1:2)]
      tai_lb <- LBdata[, ncol(LBdata)]
      LBdata <- LBdata[, 3:(ncol(LBdata) - 1)]
    } else {
      hea_lb <- LBdata[, 1]
      tai_lb <- LBdata[, ncol(LBdata)]
      LBdata <- LBdata[, 2:(ncol(LBdata) - 1)]
    }

    cat("\n\n   ---   Metier Prediction Started!   ---", sep = "")
    cat("\n   -     Configuring Neural Network     -", sep = "")

    # Previsione
    Te_PRED <- net$selmet[apply(sim(net$net, LBdata), 1, which.max)]

    nomet <- which(tai_lb == 0)
    Out_BP <- as.data.frame(cbind(hea_lb, tai_lb))

    if (svalue(cla_trkvess) == "Track") {
      Out_BP[nomet, 3] <- Te_PRED[nomet]
    } else {
      Out_BP[nomet, 2] <- Te_PRED[nomet]
    }

    cat("\n   -     DataBase Update     -", sep = "")
    svalue(sup_rep) <- "Updating\nDataBase..."
    sqldf("drop table if exists nn_clas", dbname = vms_DB$db)
    sqldf("CREATE TABLE nn_clas(I_NCEE INT, T_NUM INT, met_des CHAR)", dbname = vms_DB$db)
    if (svalue(cla_trkvess) == "Vessel") {
      poi <- sqldf("select distinct I_NCEE, T_NUM from intrp", dbname = vms_DB$db)
      Out_BP <- merge(poi, Out_BP, by.x = "I_NCEE", by.y = "hea_lb")
    }
    sqldf("INSERT INTO nn_clas SELECT * FROM `Out_BP`", dbname = vms_DB$db)
    svalue(sup_rep) <- ""

    cat("\n\n   ---   Metier Prediction Complete!   ---\n\n", sep = "")

    gconfirm("\nNeural Network Prediction complete!\n",
      title = "Save NN", icon = "info",
      parent = main_win
    )

    enabled(vms_db_f) <- TRUE
    enabled(two_b_g) <- TRUE
    enabled(two_c_g) <- TRUE
    enabled(g_go) <- TRUE
    enabled(start_ba) <- TRUE
  })
  addSpring(g_go)
  start_bb <- gbutton(text = "\nTrain & Predict\n", container = g_go, handler = function(h, ...) {
    enabled(g_go) <- FALSE
    enabled(start_ba) <- FALSE
    enabled(vms_db_f) <- FALSE
    enabled(two_b_g) <- FALSE
    enabled(two_c_g) <- FALSE

    cat("\n\n   ---   Metier Prediction Started!   ---", sep = "")

    cat("\n   -     Configuring Neural Network     -", sep = "")
    svalue(sup_rep) <- "Neural Network\nConfiguration..."

    # Set parametri
    thr <- svalue(thr_sel)
    nHf <- svalue(nHf_sel)
    nTr <- svalue(trs_sel)
    nVa <- svalue(va_sel)
    ##########
    nTe <- 100 - (svalue(trs_sel) + svalue(va_sel))
    nStep <- svalue(step_sel)
    nShow <- svalue(show_sel)
    minfac <- svalue(mfac_sel)

    LBdata <- sqldf("select * from pre_nn", dbname = vms_DB$db)

    if (nrow(LBdata) > 0) {
      # Seleziono dati per training
      if (svalue(cla_trkvess) == "Track") {
        tdata <- LBdata[which(LBdata[, ncol(LBdata)] != 0), 3:ncol(LBdata)]
      } else {
        tdata <- LBdata[which(LBdata[, ncol(LBdata)] != 0), 2:ncol(LBdata)]
      }
      if (nrow(tdata) == 0) {
        cat("\n\n   ---   Error not enough data!   ---", sep = "")
      } else {
        # Quanti met, quali met
        lmet <- unique(tdata[, ncol(tdata)])
        nmet <- length(lmet)
        mets <- tdata[, ncol(tdata)]
        nvms <- nrow(tdata)

        # Bilancia i mestieri
        selmet <- names(table(mets))[which(table(mets) > (thr * length(mets)))]
        minrec <- minfac * min(table(mets[which(mets %in% selmet)]))
        tdatab <- tdata[0, ]
        for (i in 1:length(selmet)) {
          metIdx <- which(mets == selmet[i])
          if (length(metIdx) == 1) {
            tdatab <- rbind(tdatab, tdata[rep(metIdx, minrec), ])
          } else {
            tdatab <- rbind(tdatab, tdata[sample(metIdx, minrec, replace = T), ])
          }
        }

        mets <- tdatab[, ncol(tdatab)]
        nvms <- nrow(tdatab)
        lmet <- unique(mets)
        nmet <- length(lmet)

        # Pulizia
        # Elimina colonne nulle
        c0 <- which(apply(tdatab[, 1:(ncol(tdatab) - 1)], 2, sum) == 0)
        if (length(c0) > 0) tdatab <- tdatab[, -c0]
        # Standardizzo
        tdatab[, 1:(ncol(tdatab) - 1)] <- StandardizeByCol(tdatab[, 1:(ncol(tdatab) - 1)])

        # Genero Training, Validation, Test dataset
        Tr <- Va <- Te <- numeric(0)
        for (ij in 1:nmet) {
          ijr <- which(tdatab[, ncol(tdatab)] == selmet[ij])
          Tr <- c(Tr, sample(ijr, floor(length(ijr) * nTr / 100), replace = F))
          Va <- c(Va, sample(setdiff(ijr, Tr), floor(length(ijr) * nVa / 100), replace = F))
          Te <- c(Te, setdiff(ijr, c(Tr, Va)))
        }

        # Genero matrici x BP
        metmat <- matrix(0, nvms, nmet)
        colnames(metmat) <- selmet
        for (ij in 1:nvms) metmat[ij, which(colnames(metmat) == mets[ij])] <- 1

        nInput <- ncol(tdatab) - 1
        nOUT <- nmet
        nH <- floor(nInput * nHf)

        svalue(sup_rep) <- "TR - VA - TE\nConfiguration..."
        # Individua le matrici di Training
        Tr_DATA <- as.matrix(tdatab[Tr, 1:nInput])
        Tr_OUT <- as.matrix(metmat[Tr, ])
        # Individua le matrici di Validazione
        Va_DATA <- as.matrix(tdatab[Va, 1:nInput])
        Va_OUT <- as.matrix(metmat[Va, ])
        # Individua le matrici di Test
        Te_DATA <- as.matrix(tdatab[Te, 1:nInput])
        Te_OUT <- as.matrix(metmat[Te, ])

        net.start <- newff(
          n.neurons = c(nInput, nH, nOUT), learning.rate.global = 1e-2,
          momentum.global = 0.5, error.criterium = "LMS",
          hidden.layer = "sigmoid", output.layer = "sigmoid",
          method = "ADAPTgd"
        )
        cat("\n   -     Neural Network Calibration     -\n", sep = "")
        svalue(sup_rep) <- "Neural Network\nTraining..."
        net <- train(net.start,
          P = Tr_DATA,
          T = Tr_OUT,
          Pval = Va_DATA,
          Tval = Va_OUT,
          error.criterium = "LMS",
          report = FALSE, show.step = nStep, n.shows = nShow
        )
        cat("\n   -     Neural Network Prediction     -", sep = "")

        svalue(sup_rep) <- "Neural Network\nPredicting..."
        # Previsione
        Te_PRED <- sim(net$net, Te_DATA)
        Te_PRED <- selmet[apply(Te_PRED, 1, which.max)]
        Te_OUT <- mets[Te]
        ConfMat <- xtabs(~., cbind(Te_PRED, Te_OUT))
        rownames(ConfMat) <- colnames(ConfMat) <- selmet
        Dg <- sum(diag(ConfMat)) / sum(ConfMat)

        # Assegnazione finale
        if (svalue(cla_trkvess) == "Track") {
          pdata <- LBdata[which(LBdata[, ncol(LBdata)] == 0), c(3:(ncol(LBdata) - 1))]
        } else {
          pdata <- LBdata[which(LBdata[, ncol(LBdata)] == 0), c(2:(ncol(LBdata) - 1))]
        }
        if (length(c0) > 0) pdata <- pdata[, -c0]
        # Standardizzo
        pdata[, 1:(ncol(pdata) - 1)] <- StandardizeByCol(pdata[, 1:(ncol(pdata) - 1)])

        Met_PRED <- sim(net$net, pdata)
        Met_PRED <- selmet[apply(Met_PRED, 1, which.max)]
        Out_Pred <- numeric(nrow(LBdata))
        Out_Pred[which(LBdata[, ncol(LBdata)] != 0)] <- LBdata[which(LBdata[, ncol(LBdata)] != 0), ncol(LBdata)]
        Out_Pred[which(Out_Pred == 0)] <- Met_PRED

        if (svalue(cla_trkvess) == "Track") {
          Out_BP <- as.data.frame(cbind(LBdata[, c(1:2)], Out_Pred))
        } else {
          Out_BP <- data.frame(I_NCEE = LBdata[, 1], met_des = Out_Pred)
          poi <- sqldf("select distinct I_NCEE, T_NUM from intrp", dbname = vms_DB$db)
          Out_BP <- merge(poi, Out_BP, by = "I_NCEE")
        }

        plotNet(net, Dg, ConfMat)

        cat("\n   -     DataBase Update     -", sep = "")
        svalue(sup_rep) <- "Updating\nDataBase..."
        sqldf("drop table if exists nn_clas", dbname = vms_DB$db)
        sqldf("CREATE TABLE nn_clas(I_NCEE INT, T_NUM INT, met_des CHAR)", dbname = vms_DB$db)
        sqldf("INSERT INTO nn_clas SELECT * FROM `Out_BP`", dbname = vms_DB$db)
        cat("\n   -     Perfect Prediction in ", round(Dg * 100, 2), "% of test set     -", sep = "")
        cat("\n\n   ---   Metier Prediction Complete!   ---\n\n", sep = "")
        svalue(sup_rep) <- paste("Perfect Prediction\nin ", round(Dg * 100, 2), "% of test set\nwith ", minrec, " observation * metier", sep = "")


        gconfirm("\nNeural Network Training and Prediction complete!\n\nSave current network?\n\n",
          title = "Save NN", icon = "info",
          parent = main_win,
          handler = function(...) {
            nn_file <- gfile(
              text = "Save Neural Network", type = "save", initialfilename = "*.rData",
              filter = list(
                "All files" = list(patterns = c("*")), "R files" =
                  list(patterns = "*.rData")
              )
            )
            if (length(unlist(strsplit(nn_file, "[.]"))) == 1) {
              nn_file <- paste(nn_file, ".rData", sep = "")
            }
            net$selmet <- selmet
            saveRDS(net, nn_file)
          }
        )
      }
    } else {
      cat("\n\n   ---   Error no Pre_NN data!   ---", sep = "")
    }

    enabled(vms_db_f) <- TRUE
    enabled(two_b_g) <- TRUE
    enabled(two_c_g) <- TRUE
    enabled(g_go) <- TRUE
    enabled(start_ba) <- TRUE
  })
  addSpring(g_go)

  enabled(g_go) <- FALSE
  enabled(two_b_g) <- FALSE
  enabled(two_c_g) <- FALSE

  addSpring(left_g)
  theplot <- ggraphics(width = 600, height = 400, container = left_g)
  addSpring(left_g)


  if (vms_DB$db != "") {
    svalue(sel_vms_f) <- ifelse(.Platform$OS.type == "windows", strsplit(vms_DB$db, "\\\\")[[1]][length(strsplit(vms_DB$db, "\\\\")[[1]])], strsplit(vms_DB$db, "/")[[1]][length(strsplit(vms_DB$db, "/")[[1]])])

    n_ntr <- as.numeric(sqldf("select count(*) from intrp", dbname = vms_DB$db))
    if (n_ntr > 0) {
      svalue(n_vess) <- paste("   N. of Vessels:  ", as.numeric(sqldf("select count(distinct I_NCEE) from intrp", dbname = vms_DB$db)), sep = "")
      svalue(n_trck) <- paste("    N. of tracks:  ", as.numeric(sqldf("select count(*) from (select distinct I_NCEE, T_NUM from track)", dbname = vms_DB$db)), sep = "")
      svalue(n_matc) <- paste(" N. VMS-LB match:  ", as.numeric(sqldf("select count(*) from vms_lb", dbname = vms_DB$db)), sep = "")
      svalue(n_ping) <- paste("     N. of Pings:  ", n_ntr, sep = "")
      enabled(start_ba) <- TRUE
      enabled(two_b_g) <- TRUE
      nn_tab <- as.numeric(sqldf("SELECT count(*) FROM sqlite_master WHERE type='table' AND name='pre_nn'", dbname = vms_DB$db))
      if (nn_tab == 1) {
        enabled(g_go) <- TRUE
        enabled(two_c_g) <- TRUE
      }
    } else {
      cat("\n\n  VMS DB error - Interpolated Pings not found!\n\n", sep = "")
    }
  }
  visible(main_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.