4144 lines
152 KiB
R
4144 lines
152 KiB
R
|
|
pkgs <- c("arrow", "class", "DT", "future", "ggplot2", "glmnet", "htmlTable",
|
|
"LiblineaR", "Matrix","Metrics", "promises", "quanteda",
|
|
"quanteda.textmodels", "ranger", "rlang", "Rtsne",
|
|
"RJSONIO", "shiny", "SparseM", "stringi", "uwot")
|
|
pkgs <- pkgs[! pkgs %in% rownames(installed.packages())]
|
|
if (length(pkgs)) {
|
|
warning(paste0("Packages ", paste0(pkgs, collapse = " , "), " not available. ",
|
|
"App might crash."))
|
|
}
|
|
# for (i in seq_along(pkgs)) install.packages(pkgs[i])
|
|
|
|
verbose <- TRUE
|
|
# sink("ActiveTigger.log")
|
|
|
|
options(shiny.maxRequestSize = 30*1024^3) # File upload size
|
|
|
|
modelnames <- read.csv("modelnames.csv")
|
|
modelnames_labels <- modelnames$short
|
|
names(modelnames_labels) <- modelnames$short_lang
|
|
|
|
library(quanteda)
|
|
library(ggplot2)
|
|
library(promises)
|
|
library(future)
|
|
plan(multisession)
|
|
|
|
|
|
################################################################################
|
|
## Global functions
|
|
################################################################################
|
|
|
|
label2hash <- function(label) rlang::hash(label)
|
|
|
|
cleanFileName <- function(name)
|
|
gsub('\\s|[/]|[\\]|[:]|[*]|[?]|["]|[<]|[>]|[+]|[$]|[=]', "_",
|
|
gsub("^\\s+|\\s+$", "", name))
|
|
|
|
wtdF1 <- function(truth, pred) {
|
|
pred <- pred[!is.na(truth)]
|
|
truth <- truth[!is.na(truth)]
|
|
sum(sapply(unique(truth), function(ilab)
|
|
Metrics::fbeta_score(truth == ilab, pred == ilab) *
|
|
sum(truth == ilab) / length(truth)), na.rm = TRUE)
|
|
}
|
|
|
|
metricsTable <- function(truth, pred) {
|
|
do.call(rbind, lapply(sort(unique(truth)), function(ilab) {
|
|
tmptrue <- truth == ilab
|
|
tmppred <- pred == ilab
|
|
tmp <- data.frame(
|
|
"Tag" = ilab,
|
|
"N.cases" = sum(tmptrue),
|
|
"N.predict" = sum(tmppred),
|
|
"Accuracy" = sprintf("%f", round(Metrics::accuracy(tmptrue, tmppred), 6)),
|
|
"Precision" = sprintf("%f", round(Metrics::precision(tmptrue, tmppred), 6)),
|
|
"Recall" = sprintf("%f", round(Metrics::recall(tmptrue, tmppred), 6)),
|
|
"F1" = sprintf("%f", round(Metrics::fbeta_score(tmptrue, tmppred), 6)))
|
|
tmp$F1[tmp$F1 == "NaN"] <- sprintf("%f", 0)
|
|
tmp
|
|
}))
|
|
}
|
|
|
|
bertPlotFromPath <- function(path) {
|
|
if (!file.exists(paste0(path, "/trainer_state.json"))) return(NULL)
|
|
state <- RJSONIO::fromJSON(paste0(path, "/trainer_state.json"))
|
|
logs <- data.table::rbindlist(lapply(state$log_history, as.list), fill = TRUE)
|
|
epochmin <- logs$epoch[which.min(logs$eval_loss)]
|
|
|
|
gdat <- data.table::rbindlist(
|
|
use.names = FALSE,
|
|
list(
|
|
cbind("train", logs[!is.na(logs$loss), c("epoch", "loss")]),
|
|
cbind("valid", logs[!is.na(logs$eval_loss), c("epoch", "eval_loss")])
|
|
))
|
|
colnames(gdat) <- c("data", "epoch", "loss")
|
|
|
|
ggplot(gdat, aes_string("epoch", "loss", color = "data", shape = "data")) +
|
|
geom_point(size = 2) + geom_line() +
|
|
geom_vline(xintercept = epochmin, linetype = 2) +
|
|
theme_bw() + expand_limits(y=0)
|
|
}
|
|
|
|
bertHyperToMsg <- function(pars) {
|
|
if (is.null(pars)) return(NULL)
|
|
paste0("Scheme : ", pars$bertScheme, "; ",
|
|
"Model : ", pars$bertModel, "\n* ",
|
|
"Epochs : ", pars$bertEpochs, " ; ",
|
|
"Lrate : ", pars$bertLrate, " ; ",
|
|
"Wdecay : ", pars$bertWdecay, " ; ",
|
|
"Batch size : ", pars$bertBatchsize, " ; ",
|
|
"Grad. accum. : ", pars$bertGradacc, "\n* ",
|
|
"Keep best : ", pars$bertBest, " ; ",
|
|
"ValidFrac : ", pars$bertValidFrac, " ; ",
|
|
"ValidSeed : ", pars$bertValidSeed, " \n* ",
|
|
pars$bertNtrain, " training samples : ",
|
|
paste0(names(pars$bertTrainTable), " (",
|
|
as.numeric(pars$bertTrainTable), ")",
|
|
collapse = " ; "))
|
|
}
|
|
|
|
get_status <- function(dafile)
|
|
scan(dafile, what = "character", sep="\n", quiet = TRUE)
|
|
set_status <- function(dafile, msg) write(msg, dafile)
|
|
|
|
|
|
|
|
################################################################################
|
|
## Main server function
|
|
################################################################################
|
|
|
|
# options(shiny.maxRequestSize=2^34) # Max filesize
|
|
|
|
shinyServer(function(input, output, session) {
|
|
|
|
values <- reactiveValues()
|
|
values$visuGo <- FALSE
|
|
values$dfmGo <- FALSE
|
|
# queryTrigger <- reactiveVal(0)
|
|
# predlabTrigger <- reactiveVal(0)
|
|
initDataTrigger <- reactiveVal(0)
|
|
queryNext <- reactiveVal(0)
|
|
trainTrigger <- reactiveVal(0)
|
|
predTrigger <- reactiveVal(0)
|
|
diagTrigger <- reactiveVal(0)
|
|
ready2tag <- reactiveVal(0)
|
|
trainCountdown <- reactiveVal(0)
|
|
|
|
ok.data <- reactiveVal()
|
|
ok.data.async <- reactiveVal()
|
|
ok.data.running <- reactiveVal(FALSE)
|
|
|
|
bpall_nclicks <- reactiveVal(0)
|
|
bertpred_nclicks <- reactiveVal(0)
|
|
|
|
## NEW use_regressors list as values$new_use_regressors
|
|
observeEvent(input$use_regressors, {
|
|
values$new_use_regressors <- input$use_regressors
|
|
cat("DEBUG new_use_regressors: ", paste(input$use_regressors, collapse = " "), "\n")
|
|
})
|
|
|
|
## NEW trainCountdown with input$trainCountdown
|
|
## Policy: 0, don't train ; 1, trigger train on tag ; >1, decrement on tag
|
|
observeEvent(input$trainCountdown, trainCountdown(input$trainCountdown))
|
|
|
|
####################
|
|
## Projects and data
|
|
|
|
## Read config files, update UI forms accordingly
|
|
## This should happen only once
|
|
observe({
|
|
if (verbose)
|
|
cat("DEBUG read project configs\n")
|
|
# values$conf <- RJSONIO::fromJSON("conf.json")
|
|
projfiles <- dir(pattern = "^tigger_.*[.]json$")
|
|
isolate({
|
|
if (!length(projfiles)) {
|
|
values$conf <- NULL
|
|
return(NULL)
|
|
}
|
|
values$confnames <- gsub("^tigger_(.*)[.]json$", "\\1", projfiles)
|
|
|
|
values$conf <- RJSONIO::fromJSON(projfiles[1])
|
|
})
|
|
})
|
|
|
|
## When projects added, update selector
|
|
observeEvent(values$confnames, {
|
|
if (verbose)
|
|
cat("DEBUG update selectProject from confnames\n")
|
|
updateSelectInput(session, "selectProject", choices = values$confnames)
|
|
})
|
|
|
|
## Event from project change
|
|
observeEvent(input$selectProject, {
|
|
if (is.null(input$selectProject)) return(NULL)
|
|
if (!nchar(input$selectProject)) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG project change step 1\n")
|
|
# values$project <- input$selectProject
|
|
# values$conf <- values$confs[[values$project]]
|
|
values$conf <- RJSONIO::fromJSON(
|
|
paste0("tigger_", input$selectProject, ".json"))
|
|
ok.data(NULL)
|
|
ok.visu(NULL)
|
|
initDataTrigger(initDataTrigger() + 1)
|
|
|
|
if (verbose)
|
|
cat("DEBUG project change step 2\n")
|
|
if (!is.null(values$conf$dataNrows))
|
|
updateNumericInput(session, "dataNrows", value = as.numeric(values$conf$dataNrows))
|
|
if (!is.null(values$conf$dataSkipRows))
|
|
updateNumericInput(session, "dataSkipRows", value = as.numeric(values$conf$dataSkipRows))
|
|
|
|
#### Python ####
|
|
## Default use_python if not found in conf file: FALSE
|
|
if(is.null(values$conf$use_python))
|
|
values$conf$use_python <- FALSE
|
|
updateCheckboxInput(session, "sys_use_python", value = values$conf$use_python)
|
|
|
|
## Set default python if not found in conf file
|
|
if(is.null(values$conf$python))
|
|
values$conf$python <- "python3"
|
|
updateTextInput(session, "sys_which_python", value = values$conf$python)
|
|
|
|
values$python_ok <- FALSE
|
|
if (values$conf$use_python) {
|
|
## Check whether python is working
|
|
pytest <- try(system(paste(values$conf$python, "--version"),
|
|
intern = TRUE))
|
|
if (inherits(pytest, "try-error")) {
|
|
showNotification(paste(
|
|
"Python path `", values$conf$python,
|
|
"` not valid, try changing it in Project/System tab"),
|
|
duration = 10, type = "error")
|
|
} else
|
|
values$python_ok <- TRUE
|
|
}
|
|
if (verbose)
|
|
cat("Python ok:", values$python_ok, "\n")
|
|
|
|
|
|
#### GPU ####
|
|
if (!is.null(values$conf$use_gpu))
|
|
updateCheckboxInput(session, "sys_use_gpu", value = values$conf$use_gpu)
|
|
|
|
#### Spacy ####
|
|
if (!is.null(values$conf$use_spacy))
|
|
updateCheckboxInput(session, "sys_use_spacy", value = values$conf$use_spacy)
|
|
updateTextInput(session, "sys_use_spacy_model", value = values$conf$use_spacy_model)
|
|
|
|
#### fastText ####
|
|
if (!is.null(values$conf$use_ft))
|
|
updateCheckboxInput(session, "sys_use_ft", value = values$conf$use_ft)
|
|
updateTextInput(session, "sys_use_ft_model", value = values$conf$use_ft_model)
|
|
|
|
#### SBERT ####
|
|
if (!is.null(values$conf$use_sb))
|
|
updateCheckboxInput(session, "sys_use_sb", value = values$conf$use_sb)
|
|
updateTextInput(session, "sys_use_sb_model", value = values$conf$use_sb_model)
|
|
|
|
})
|
|
|
|
|
|
##############################################################################
|
|
## Reactives : project settings UI
|
|
##############################################################################
|
|
|
|
output$sys_datadir <- renderText(values$conf$datadir)
|
|
output$sys_datafile <- renderText(paste0(values$conf$dataname, ".feather"))
|
|
output$sys_var_id <- renderUI(renderText(values$conf$idcol))
|
|
output$sys_var_text <- renderUI(renderText(values$conf$textcols))
|
|
output$sys_var_tag <- renderUI(renderText(values$conf$tagcols))
|
|
output$sys_var_context_ui <- renderUI(selectInput(
|
|
"sys_var_context", NULL, values$data_orig_colnames, values$conf$contextcols,
|
|
multiple = TRUE))
|
|
output$sys_var_comm_ui <- renderUI(selectInput(
|
|
"sys_var_comm", NULL, c("(none)", values$data_orig_colnames),
|
|
values$conf$commcol))
|
|
|
|
output$sys_ex_lang_ui <- renderUI(selectInput(
|
|
"sys_ex_lang", NULL, modelnames_labels, "en"
|
|
))
|
|
output$sys_ex_spacy <- renderText(
|
|
modelnames$spacy_name[modelnames$short == input$sys_ex_lang])
|
|
output$sys_ex_spacy_dl <- renderText(paste0(
|
|
"Download with python module: ", values$conf$python, " -m spacy download ",
|
|
modelnames$spacy_name[modelnames$short == input$sys_ex_lang]))
|
|
output$sys_ex_ft <- renderText(
|
|
modelnames$fasttext_name[modelnames$short == input$sys_ex_lang])
|
|
output$sys_ex_ft_dl <- renderText(paste0(
|
|
"Manual download link : ",
|
|
modelnames$fasttext_url[modelnames$short == input$sys_ex_lang]))
|
|
output$sys_ex_sb <- renderText(
|
|
ifelse(input$sys_ex_lang %in% c("ar", "zh", "nl", "en", "fr", "de",
|
|
"it", "ko", "pl", "pt", "ru", "es", "tr"),
|
|
"distiluse-base-multilingual-cased-v1",
|
|
"distiluse-base-multilingual-cased-v2"))
|
|
|
|
|
|
## Save system changes on button click, with modal
|
|
output$save_config_msg <- renderUI({
|
|
req(values$save_config_msg)
|
|
p(strong(values$save_config_msg))
|
|
})
|
|
output$save_embed_msg <- renderUI({
|
|
tmp <- ""
|
|
if (input$sys_use_spacy) if (!identical(input$sys_use_spacy_model, values$conf$use_spacy_model))
|
|
tmp <- paste0(tmp, "<li> Changing the spacy model will delete the current tokenized text and fasttext word embeddings, to prevent conflicts</li>")
|
|
if (input$sys_use_ft) if (!identical(input$sys_use_ft_model, values$conf$use_ft_model))
|
|
tmp <- paste0(tmp, "<li> Changing the fasttext model will delete the current fasttext word embeddings, to prevent conflicts.</li>")
|
|
if (input$sys_use_sb) if (!identical(input$sys_use_sb_model, values$conf$use_sb_model))
|
|
tmp <- paste0(tmp, "<li> Changing the SBERT model will delete the current SBERT sentence embeddings, to prevent conflicts.</li>")
|
|
|
|
if (nchar(tmp)) {
|
|
return(HTML(paste("<br><p> <strong>Warning:</strong> <ul>", tmp, "</ul></p>")))
|
|
} else
|
|
return(NULL)
|
|
})
|
|
observeEvent(input$saveSystem, {
|
|
values$save_config_msg <- NULL
|
|
showModal(modalDialog(
|
|
title = "Save project configuration",
|
|
paste0("Click 'Save' to check and confirm the new configuration"),
|
|
uiOutput("save_embed_msg"),
|
|
uiOutput("save_config_msg"),
|
|
footer = tagList(actionButton(paste0("save_conf_confirm"), "Save"),
|
|
modalButton("Cancel"))))
|
|
})
|
|
observeEvent(input$save_conf_confirm, {
|
|
newconf <- values$conf
|
|
newconf$contextcols <- input$sys_var_context
|
|
newconf$commcol <- input$sys_var_comm
|
|
|
|
if (input$sys_use_python) {
|
|
pytest <- try(system(paste(input$sys_which_python, "--version"),
|
|
intern = TRUE))
|
|
if (inherits(pytest, "try-error")) {
|
|
values$save_config_msg <- paste0(
|
|
"Error: python path `", input$sys_which_python, "` not valid")
|
|
return(NULL)
|
|
}
|
|
}
|
|
newconf$use_python <- input$sys_use_python
|
|
newconf$python <- input$sys_which_python
|
|
newconf$use_gpu <- input$sys_use_gpu
|
|
|
|
if (input$sys_use_spacy) {
|
|
sptest <- system(paste0(
|
|
newconf$python, " -m spacy info ", input$sys_use_spacy_model), intern = TRUE)
|
|
if (length(sptest) == 0) {
|
|
values$save_config_msg <- paste(
|
|
"Error loading spacy, check that it is installed in the specified python env")
|
|
return(NULL)
|
|
}
|
|
if (length(attr(sptest, "status"))) {
|
|
values$save_config_msg <- paste(
|
|
"Error loading spacy model, check that it has been downloaded")
|
|
return(NULL)
|
|
}
|
|
newconf$use_spacy_model <- input$sys_use_spacy_model
|
|
}
|
|
newconf$use_spacy <- input$sys_use_spacy
|
|
|
|
if (input$sys_use_ft) {
|
|
if (!file.exists(input$sys_use_ft_model)) {
|
|
values$save_config_msg <- paste(
|
|
"Error loading fasttext model, check the specified path")
|
|
return(NULL)
|
|
}
|
|
newconf$use_ft_model <- input$sys_use_ft_model
|
|
}
|
|
newconf$use_ft <- input$sys_use_ft
|
|
|
|
if (input$sys_use_sb)
|
|
newconf$use_sb_model <- input$sys_use_sb_model
|
|
newconf$use_sb <- input$sys_use_sb
|
|
|
|
# if (newconf$use_spacy) if (newconf$use_spacy_model != values$conf$use_spacy_model) {
|
|
if (newconf$use_spacy) if (!identical(newconf$use_spacy_model, values$conf$use_spacy_model)) {
|
|
file.remove(paste0(values$conf$datadir, values$conf$dataname, "_spa.feather"))
|
|
file.remove(paste0(values$conf$datadir, values$conf$dataname, "_ft.feather"))
|
|
}
|
|
# if (newconf$use_ft) if (newconf$use_ft_model != values$conf$use_ft_model)
|
|
if (newconf$use_ft) if (!identical(newconf$use_ft_model, values$conf$use_ft_model))
|
|
file.remove(paste0(values$conf$datadir, values$conf$dataname, "_ft.feather"))
|
|
# if (newconf$use_sb) if (newconf$use_sb_model != values$conf$use_sb_model)
|
|
if (newconf$use_sb) if (!identical(newconf$use_sb_model, values$conf$use_sb_model))
|
|
file.remove(paste0(values$conf$datadir, values$conf$dataname, "_sb.feather"))
|
|
|
|
writeLines(RJSONIO::toJSON(newconf),
|
|
paste0("tigger_", newconf$projectid, ".json"))
|
|
values$conf <- newconf
|
|
initDataTrigger(initDataTrigger() + 1)
|
|
removeModal()
|
|
})
|
|
|
|
##############################################################################
|
|
## Reactives : data
|
|
##############################################################################
|
|
|
|
ok.commentCol <- reactive(values$conf$commcol)
|
|
|
|
## Current imported data (async)
|
|
observeEvent(input$dataImport, {
|
|
if (ok.data.running()) return(NULL)
|
|
## Save nrows to conf file on change
|
|
if (!is.numeric(input$dataNrows) | !is.numeric(input$dataSkipRows)) return(NULL)
|
|
values$conf$dataNrows <- input$dataNrows
|
|
values$conf$dataSkipRows <- input$dataSkipRows
|
|
if (!is.null(values$conf$projectid))
|
|
writeLines(RJSONIO::toJSON(values$conf), paste0(
|
|
"tigger_", values$conf$projectid, ".json"))
|
|
initDataTrigger(initDataTrigger() + 1)
|
|
})
|
|
|
|
|
|
## Read data event
|
|
observeEvent(initDataTrigger(), {
|
|
if (is.null(values$conf)) {
|
|
ok.data(NULL)
|
|
return(NULL)
|
|
}
|
|
if (initDataTrigger() == 0) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG enter ok.data\n")
|
|
if (verbose)
|
|
cat("DEBUG enter ok.data trigger", initDataTrigger(), "\n")
|
|
ok.data.running(TRUE)
|
|
|
|
## Prepare variables for async launch
|
|
coco <- values$conf
|
|
coco$python_ok <- values$python_ok
|
|
|
|
da_token <- session$token
|
|
data_status <- paste0("tigger_", da_token, "_data")
|
|
|
|
file_orig_colnames <- paste0(data_status, "_origcols")
|
|
file_colstok <- paste0(data_status, "_tok")
|
|
file_colsft <- paste0(data_status, "_ft")
|
|
file_colssb <- paste0(data_status, "_sb")
|
|
file_colsbertpred <- paste0(data_status, "_bertpred")
|
|
da_missing <- paste0(data_status, "_bertpred_missing")
|
|
|
|
projpath <- paste0(coco$datadir, coco$projectid)
|
|
if (!file.exists(projpath))
|
|
dir.create(projpath)
|
|
|
|
## Read data: async launch
|
|
data_async <- future({
|
|
#################
|
|
## Main data file
|
|
|
|
set_status(data_status, "Importing main data file...")
|
|
res <- arrow::read_feather(
|
|
paste0(coco$datadir, coco$dataname, ".feather"))
|
|
if (is.null(coco$dataNrows)) return(NULL)
|
|
rowselect <-
|
|
intersect(1:nrow(res), (1:(coco$dataNrows)) + coco$dataSkipRows)
|
|
if (!length(rowselect)) return(NULL)
|
|
res <- res[rowselect, , drop = FALSE]
|
|
|
|
writeLines(colnames(res), file_orig_colnames)
|
|
|
|
|
|
#################
|
|
## Tokenized text
|
|
|
|
## Import data : feather of two cols, one the id, other the tokenized
|
|
set_status(data_status, "Importing tokenized text...")
|
|
file_tok <- paste0(coco$datadir, coco$dataname, "_spa.feather")
|
|
if (file.exists(file_tok)) {
|
|
tokdat <- arrow::read_feather(file_tok)
|
|
} else
|
|
tokdat <- NULL
|
|
tok_remaining <- res[[coco$idcol]]
|
|
tok_remaining <-
|
|
tok_remaining[! tok_remaining %in% tokdat[[coco$idcol]]]
|
|
|
|
## Tokenize remaining texts
|
|
if (length(tok_remaining)) {
|
|
if (!coco$python_ok | !coco$use_spacy) {
|
|
## If remaining texts to tokenize but no python, fall back on
|
|
## untokenized text
|
|
## TODO here use quanteda tokenizer with options?
|
|
tokdat <- data.frame(
|
|
res[[coco$idcol]],
|
|
do.call(paste, c(res[match(tok_remaining, res[[coco$idcol]]),
|
|
coco$textcols, drop = FALSE], sep = "\n\n")))
|
|
colnames(tokdat) <- c(coco$idcol, "text_spa")
|
|
set_status(data_status, "Importing tokenized text: no spacy ok")
|
|
} else {
|
|
## If python present, tokenize with spacy
|
|
set_status(data_status,
|
|
paste("Tokenizing", length(tok_remaining), "new texts"))
|
|
tmpfile <- paste0("tigger_tok_", da_token)
|
|
arrow::write_feather(
|
|
data.frame(
|
|
id = tok_remaining,
|
|
text = do.call(
|
|
paste, c(res[match(tok_remaining, res[[coco$idcol]]),
|
|
coco$textcols, drop = FALSE], sep = "\n\n"))),
|
|
paste0(tmpfile, ".feather")
|
|
)
|
|
system(paste0(
|
|
coco$python, " tokenize_spacy.py -d ", tmpfile, ".feather",
|
|
" -m ", coco$use_spacy_model))
|
|
tok_new <- arrow::read_feather(paste0(tmpfile, "_spa.feather"))
|
|
colnames(tok_new)[colnames(tok_new) == "id"] <- coco$idcol
|
|
tokdat <- rbind(tokdat, tok_new)
|
|
arrow::write_feather(tokdat, file_tok)
|
|
system(paste0("rm ", tmpfile, "*"))
|
|
set_status(data_status, "Importing tokenized text: spacy ok")
|
|
}
|
|
}
|
|
|
|
## Save colname for tokenized text
|
|
tmp_cols_tok <- colnames(tokdat)[colnames(tokdat) != coco$idcol]
|
|
writeLines(tmp_cols_tok, file_colstok)
|
|
|
|
set_status(data_status, "Importing tokenized text: wrote colnames")
|
|
|
|
## Merge with current data
|
|
res <- merge(res, tokdat, by = coco$idcol,
|
|
all.y = FALSE, sort = FALSE)
|
|
rm(tokdat)
|
|
|
|
set_status(data_status, "Importing tokenized text: merged")
|
|
|
|
#################
|
|
## FastText embeddings
|
|
|
|
set_status(data_status, paste("Loading fastText embeddings"))
|
|
|
|
## FastText embeddings : feather file with id and embeddings
|
|
file_ft <- paste0(coco$datadir, coco$dataname, "_ft.feather")
|
|
if (file.exists(file_ft)) {
|
|
ftdat <- arrow::read_feather(file_ft)
|
|
} else
|
|
ftdat <- NULL
|
|
ft_remaining <- res[[coco$idcol]]
|
|
ft_remaining <-
|
|
ft_remaining[! ft_remaining %in% ftdat[[coco$idcol]]]
|
|
|
|
## Embed remaining texts, if FT in use
|
|
if (length(ft_remaining)) {
|
|
if (!coco$python_ok | !coco$use_ft) {
|
|
## If no python or FT, abort if not all rows already embedded
|
|
ftdat <- NULL
|
|
} else {
|
|
set_status(data_status, paste(
|
|
"Embedding", length(ft_remaining), "new texts with fastText"))
|
|
tmpfile <- paste0("tigger_ft_", da_token)
|
|
arrow::write_feather(
|
|
data.frame(
|
|
id = ft_remaining,
|
|
text = do.call(
|
|
paste, res[match(ft_remaining, res[[coco$idcol]]),
|
|
tmp_cols_tok, drop = FALSE])),
|
|
paste0(tmpfile, ".feather")
|
|
)
|
|
system(paste0(
|
|
coco$python, " embed_fasttext.py -d ", tmpfile, ".feather",
|
|
" -m ", coco$use_ft_model))
|
|
ft_new <- arrow::read_feather(paste0(tmpfile, "_ft.feather"))
|
|
colnames(ft_new)[colnames(ft_new) == "id"] <- coco$idcol
|
|
ftdat <- rbind(ftdat, ft_new)
|
|
arrow::write_feather(ftdat, file_ft)
|
|
system(paste0("rm ", tmpfile, "*"))
|
|
}
|
|
}
|
|
|
|
if (!is.null(ftdat)) {
|
|
## Merge with current data
|
|
writeLines(colnames(ftdat)[colnames(ftdat) != coco$idcol], file_colsft)
|
|
res <- merge(res, ftdat, by = coco$idcol, all.y = FALSE, sort = FALSE)
|
|
rm(ftdat)
|
|
}
|
|
|
|
|
|
#################
|
|
## SBERT embeddings
|
|
|
|
set_status(data_status, "Loading SBERT embeddings")
|
|
|
|
## SBERT file : feather of id and embeddings
|
|
file_sb <- paste0(coco$datadir, coco$dataname, "_sb.feather")
|
|
if (file.exists(file_sb)) {
|
|
sbdat <- arrow::read_feather(file_sb)
|
|
}else
|
|
sbdat <- NULL
|
|
sb_remaining <- res[[coco$idcol]]
|
|
sb_remaining <-
|
|
sb_remaining[! sb_remaining %in% sbdat[[coco$idcol]]]
|
|
|
|
## Embed remaining texts
|
|
if (length(sb_remaining)) {
|
|
if (!coco$python_ok | !coco$use_sb) {
|
|
## If no python or SB, abort if not all rows already embedded
|
|
sbdat <- NULL
|
|
} else {
|
|
set_status(data_status, paste(
|
|
"Embedding", length(sb_remaining), "new texts with SBERT"))
|
|
tmpfile <- paste0("tigger_sb_", da_token)
|
|
arrow::write_feather(
|
|
data.frame(
|
|
id = sb_remaining,
|
|
text = do.call(
|
|
paste, res[match(sb_remaining, res[[coco$idcol]]),
|
|
coco$textcols, drop = FALSE])),
|
|
paste0(tmpfile, ".feather")
|
|
)
|
|
system(paste0(
|
|
coco$python, " embed_sbert.py -d ", tmpfile, ".feather",
|
|
" -m ", coco$use_sb_model))
|
|
sb_new <- arrow::read_feather(paste0(tmpfile, "_sb.feather"))
|
|
colnames(sb_new)[colnames(sb_new) == "id"] <- coco$idcol
|
|
sbdat <- rbind(sbdat, sb_new)
|
|
arrow::write_feather(sbdat, file_sb)
|
|
system(paste0("rm ", tmpfile, "*"))
|
|
}
|
|
}
|
|
|
|
if (!is.null(sbdat)) {
|
|
## Merge with current data
|
|
writeLines(colnames(sbdat)[colnames(sbdat) != coco$idcol], file_colssb)
|
|
res <- merge(res, sbdat, by = coco$idcol, all.y = FALSE, sort = FALSE)
|
|
rm(sbdat)
|
|
}
|
|
|
|
#################
|
|
## BERT predictions
|
|
|
|
set_status(data_status, "Loading BERT predictions")
|
|
|
|
## BERT predictions : feathers of id and probs
|
|
## TODO: take full prediction if existing
|
|
|
|
files_pred <- dir(
|
|
coco$datadir, paste0("^", coco$dataname, "_bertpred_.*[.]feather$"))
|
|
# files_predall <- dir(
|
|
# coco$datadir, paste0("^", coco$dataname, "_bertpredall_.*[.]feather$"))
|
|
# files_pred <- files_pred[
|
|
# ! gsub("_bertpred_", "_bertpredall_", files_pred) %in% files_predall]
|
|
# files_pred <- c(files_predall, files_pred)
|
|
|
|
tmp_bertpred_cols <- list()
|
|
if (length(files_pred)) {
|
|
for (ipred in files_pred) {
|
|
preddat <- arrow::read_feather(paste0(coco$datadir, ipred))
|
|
predname <-
|
|
gsub(paste0("^", coco$dataname, "_bertpred_(.*)[.]feather$"),
|
|
"\\1", ipred)
|
|
# predname <-
|
|
# gsub(paste0("^", coco$dataname, "_bertpred(all)?_(.*)[.]feather$"),
|
|
# "\\2", ipred, perl = TRUE)
|
|
n_missing <- sum(! res[[coco$idcol]] %in% preddat[[coco$idcol]])
|
|
if (n_missing) {
|
|
write(
|
|
paste0("BERT prediction ", predname, " : ", n_missing,
|
|
" texts missing in prediction."),
|
|
da_missing, append = TRUE)
|
|
} else {
|
|
colnames(preddat) <- gsub(
|
|
"^bertpred_", paste0("bertpred_", predname), colnames(preddat))
|
|
tmp_bertpred_cols[[predname]] <-
|
|
colnames(preddat)[colnames(preddat) != coco$idcol]
|
|
res <- merge(res, preddat, by = coco$idcol,
|
|
all.y = FALSE, sort = FALSE)
|
|
}
|
|
rm(preddat)
|
|
}
|
|
if (length(tmp_bertpred_cols)) {
|
|
writeLines(names(tmp_bertpred_cols), file_colsbertpred)
|
|
lapply(names(tmp_bertpred_cols), function(x) {
|
|
writeLines(tmp_bertpred_cols[[x]], paste0(file_colsbertpred, "_", x))
|
|
})
|
|
}
|
|
}
|
|
|
|
## Comment col
|
|
set_status(data_status, "Loading comments")
|
|
tmpfile <- paste0(projpath, "/", coco$commcol, ".csv")
|
|
if (file.exists(tmpfile)) {
|
|
tmpcol <- read.csv(tmpfile)
|
|
colnames(tmpcol)[2] <- coco$commcol
|
|
## Remove duplicates, keep newest
|
|
tmpcol <- tmpcol[nrow(tmpcol):1, , drop = FALSE]
|
|
tmpcol <- tmpcol[!duplicated(tmpcol[, 1]), , drop = FALSE]
|
|
tmpcol <- tmpcol[nrow(tmpcol):1, , drop = FALSE]
|
|
res <- merge(res, tmpcol, by = coco$idcol,
|
|
all.x = TRUE, all.y = FALSE, sort = FALSE)
|
|
res[[coco$commcol]][is.na(res[[coco$commcol]])] <- ""
|
|
} else
|
|
res[[coco$commcol]] <- ""
|
|
|
|
# ## Tagging cols
|
|
# set_status(data_status, "Loading tags")
|
|
# for (itag in coco$tagcols) {
|
|
# tmpfile <- paste0(projpath, "/", itag, ".csv")
|
|
# if (file.exists(tmpfile)) {
|
|
# tmpcol <- read.csv(tmpfile)
|
|
# tmpcol[[paste0("hist_", itag)]] <- 1:nrow(tmpcol)
|
|
# ## Remove duplicates, keep newest
|
|
# tmpcol <- tmpcol[nrow(tmpcol):1, ]
|
|
# tmpcol <- tmpcol[!duplicated(tmpcol[, 1]), ]
|
|
# tmpcol <- tmpcol[nrow(tmpcol):1, ]
|
|
# if (verbose)
|
|
# cat("DEBUG imported ", itag, nrow(tmpcol), "\n")
|
|
# res <- merge(res, tmpcol, by = coco$idcol,
|
|
# all.x = TRUE, all.y = FALSE, sort = FALSE)
|
|
# } else {
|
|
# res[[itag]] <- NA
|
|
# res[[paste0("hist_", itag)]] <- NA
|
|
# }
|
|
# }
|
|
## Tagging cols
|
|
set_status(data_status, "Loading tags")
|
|
for (itag in coco$tagcols) {
|
|
itaghist <- paste0("hist_", itag)
|
|
if (is.null(res[[itag]]) | all(is.na(res[[itag]]))) {
|
|
res[[itag]] <- NA
|
|
res[[itaghist]] <- NA
|
|
} else {
|
|
res[[itaghist]][!is.na(res[[itag]])] <- 1:sum(!is.na(res[[itag]]))
|
|
}
|
|
tmpfile <- paste0(projpath, "/", itag, ".csv")
|
|
if (file.exists(tmpfile)) {
|
|
tmpcol <- read.csv(tmpfile)
|
|
tmpcol[[itaghist]] <- 1:nrow(tmpcol) +
|
|
max(0, suppressWarnings(max(na.omit(res[[itaghist]]))))
|
|
## Remove duplicates, keep newest
|
|
tmpcol <- tmpcol[nrow(tmpcol):1, ]
|
|
tmpcol <- tmpcol[!duplicated(tmpcol[, 1]), ]
|
|
tmpcol <- tmpcol[nrow(tmpcol):1, ]
|
|
tmpcol <- tmpcol[tmpcol[[coco$idcol]] %in% res[[coco$idcol]], ]
|
|
if (verbose)
|
|
cat("DEBUG imported", itag, nrow(tmpcol), "\n")
|
|
# res <- merge(res, tmpcol, by = coco$idcol,
|
|
# all.x = TRUE, all.y = FALSE, sort = FALSE)
|
|
if (nrow(tmpcol)) {
|
|
idmatches <- match(tmpcol[[coco$idcol]], res[[coco$idcol]])
|
|
# idmatches <- idmatches[!is.na(idmatches)]
|
|
res[[itag]][idmatches] <- tmpcol[[itag]]
|
|
res[[itaghist]][idmatches] <- tmpcol[[itaghist]]
|
|
}
|
|
}
|
|
}
|
|
|
|
set_status(data_status, "Finalizing data import")
|
|
res
|
|
}) %...>% ok.data.async()
|
|
data_async <- catch(data_async, function(error) {
|
|
values$modelDiagno <- paste0("Error in data import: ", error)
|
|
})
|
|
data_async <- finally(data_async, function() {
|
|
#################
|
|
## Finalize data importation
|
|
res <- ok.data.async()
|
|
if (is.null(res)) return(NULL)
|
|
|
|
set_status(data_status, "Finalizing data import: read columns")
|
|
## Read column (tok, ft, sb, ...) names from dedicated files
|
|
values$tagcols <- coco$tagcols
|
|
values$cols_tok <- readLines(file_colstok)
|
|
values$cols_ft <- NULL
|
|
if (file.exists(file_colsft)) {
|
|
values$cols_ft <- readLines(file_colsft)
|
|
}
|
|
values$cols_sb <- NULL
|
|
if (file.exists(file_colssb)) {
|
|
values$cols_sb <- readLines(file_colssb)
|
|
}
|
|
set_status(data_status, "Finalizing data import: bertpred")
|
|
if (file.exists(file_colsbertpred)) {
|
|
tmp_bertpred <- readLines(file_colsbertpred)
|
|
values$cols_bertpred <- lapply(tmp_bertpred, function(x)
|
|
readLines(paste0(file_colsbertpred, "_", x)))
|
|
names(values$cols_bertpred) <- tmp_bertpred
|
|
} else
|
|
values$cols_bertpred <- NULL
|
|
set_status(data_status, "Finalizing data import: bertpred missing")
|
|
if (file.exists(da_missing)) {
|
|
lapply(readLines(da_missing), function(x)
|
|
showNotification(paste(
|
|
x, "\n",
|
|
"You may predict on current text in BERT panel, ",
|
|
"and then reload the data.")))
|
|
}
|
|
|
|
## Populate regressors list in prediction panel
|
|
set_status(data_status, "Finalizing data import: populating regressors")
|
|
regr_choices <- c(
|
|
"Regex" = "regex",
|
|
"Word counts (DFM)" = "dfm")
|
|
if (!is.null(values$cols_ft))
|
|
regr_choices <- c(regr_choices, "Word embeddings (FastText)" = "ft")
|
|
if (!is.null(values$cols_sb))
|
|
regr_choices <- c(regr_choices, "Sentence embeddings (SBERT)" = "sb")
|
|
regr_choices <- c(regr_choices, "Extra predictors" = "extra")
|
|
|
|
if (length(values$cols_bertpred)) {
|
|
tmp_choices <- paste0("bertpred_", names(values$cols_bertpred))
|
|
names(tmp_choices) <- paste0("BERT_", names(values$cols_bertpred))
|
|
regr_choices <- c(regr_choices, tmp_choices)
|
|
}
|
|
|
|
# if (length(regr_choices) > 3) {
|
|
regr_choices_sel <-
|
|
regr_choices[regr_choices %in% c("regex", "ft", "sb")]
|
|
# } else
|
|
# regr_choices_sel <- c("regex", "dfm")
|
|
|
|
updateSelectizeInput(
|
|
session, "use_regressors", choices = regr_choices,
|
|
selected = regr_choices_sel)
|
|
values$new_use_regressors <- regr_choices_sel
|
|
|
|
othercols <- colnames(res)
|
|
othercols <- othercols[! othercols %in% c(
|
|
values$cols_tok, values$cols_ft, values$cols_sb, values$cols_bertpred,
|
|
values$tagcols, paste0("hist_", values$tagcols),
|
|
coco$commcol, coco$textcols)]
|
|
updateSelectInput(
|
|
session, "dlTagSelect",
|
|
choices = c("tags", "comments", "predictions", othercols),
|
|
selected = c("tags", "comments", "predictions"))
|
|
|
|
## Populate extra regressors lists in prediction panel
|
|
updateSelectizeInput(
|
|
session, "use_ootregnum", choices = othercols, selected = NULL)
|
|
updateSelectizeInput(
|
|
session, "use_ootregcat", choices = othercols, selected = NULL)
|
|
|
|
## Project path
|
|
values$projectdir <- paste0(projpath, "/")
|
|
|
|
## Create tagmat: data.frame of all current taggings
|
|
values$tagmat <- res[, coco$tagcols, drop = FALSE]
|
|
## Create tagmathist: data.frame of historical order of taggings
|
|
values$tagmathist <- res[, paste0("hist_", coco$tagcols), drop = FALSE]
|
|
colnames(values$tagmathist) <- coco$tagcols
|
|
|
|
## Save data original colnames
|
|
values$data_orig_colnames <- readLines(file_orig_colnames)
|
|
|
|
ok.data(ok.data.async())
|
|
ok.data.async(NULL)
|
|
ok.data.running(FALSE)
|
|
set_status(data_status, "Exit data async")
|
|
system(paste0("rm ", data_status, "*"))
|
|
values$modelDiagno <- "No model"
|
|
|
|
|
|
if(trainTrigger() == 0) trainTrigger(1) ## For first run. TODO set trainTrigger to 0 when changing data?
|
|
if (verbose) cat("DEBUG Exit data async finally\n")
|
|
})
|
|
NULL
|
|
})
|
|
|
|
## Read data import status from file
|
|
observe({
|
|
if (ok.data.running()) {
|
|
invalidateLater(100)
|
|
tmpfile <- paste0("tigger_", session$token, "_data")
|
|
if (file.exists(tmpfile)) {
|
|
values$modelDiagno <- paste(collapse = "\n", scan(
|
|
tmpfile, what = "character", sep="\n", quiet = TRUE))
|
|
} else
|
|
values$modelDiagno <- ""
|
|
}
|
|
})
|
|
|
|
|
|
###############
|
|
## ok.text() reactive
|
|
###############
|
|
ok.text <- eventReactive(ok.data(), {
|
|
if (is.null(ok.data())) return(NULL)
|
|
res <- ok.data()[, values$cols_tok[1]]
|
|
if (length(values$cols_tok) > 1) {
|
|
for (icol in values$cols_tok[-1]) {
|
|
res <- paste0(res, "\n\n", ok.data()[, icol])
|
|
}
|
|
}
|
|
# queryTrigger(queryTrigger() + 1)
|
|
if (verbose)
|
|
cat("DEBUG ok.text", length(res), "\n")
|
|
res
|
|
})
|
|
|
|
ok.labelcol <- reactive({
|
|
if (is.null(ok.data())) return(NULL)
|
|
if (verbose)
|
|
# cat("DEBUG enter ok.labelcol\n")
|
|
if (is.null(input$selectScheme)) return(values$conf$tagcols[1])
|
|
input$selectScheme
|
|
})
|
|
|
|
|
|
ok.nicetext <- reactive({
|
|
req(ok.data(), values$conf$textcols)
|
|
# if (is.null(ok.data())) return(NULL)
|
|
do.call(paste, c(ok.data()[, values$conf$textcols, drop = FALSE],
|
|
sep = "\n\n"))
|
|
})
|
|
|
|
ok.regressor.names <- reactive({
|
|
daregs <- values$new_use_regressors
|
|
if (verbose)
|
|
cat("DEBUG enter ok.regressor.names ", paste(daregs, collapse = " "), "\n")
|
|
res <- NULL
|
|
if ("ft" %in% daregs)
|
|
res <- c(res, values$cols_ft)
|
|
if ("sb" %in% daregs)
|
|
res <- c(res, values$cols_sb)
|
|
if (length(values$cols_bertpred)) {
|
|
for (ipred in 1:length(values$cols_bertpred)) {
|
|
if (paste0("bertpred_", names(values$cols_bertpred)[ipred]) %in% daregs)
|
|
res <- c(res, values$cols_bertpred[[ipred]])
|
|
}
|
|
}
|
|
if (verbose)
|
|
cat("DEBUG exit ok.regressor.names:", length(res), "\n")
|
|
res
|
|
})
|
|
|
|
ok.contextCol <- reactive({
|
|
if (verbose)
|
|
cat("DEBUG enter ok.contextCol\n")
|
|
# res <- isolate(values$conf$contextcols)
|
|
res <- values$conf$contextcols
|
|
names(res) <- res
|
|
res
|
|
})
|
|
|
|
## Initiate label and queries history, on ok.text() or labelcol change,
|
|
observeEvent(list(ok.text(), ok.labelcol()), {
|
|
if (verbose)
|
|
cat("DEBUG initiate label\n")
|
|
if (is.null(ok.labelcol())) {
|
|
values$label <- NULL
|
|
values$labelhist <- NULL
|
|
values$queries <- NULL
|
|
values$comment <- NULL
|
|
values$wasTagged <- NULL
|
|
values$wasRetagged <- NULL
|
|
} else {
|
|
values$label <- values$tagmat[, ok.labelcol()]
|
|
values$labelhist <- values$tagmathist[, ok.labelcol()]
|
|
values$queries <- which(!is.na(values$label))
|
|
values$comment <- ok.data()[[values$conf$commcol]]
|
|
values$wasTagged <- !is.na(values$label)
|
|
values$wasRetagged <- rep(FALSE, length(values$label))
|
|
}
|
|
})
|
|
|
|
## On values$label change, values$tagmat is updated for separate history
|
|
observeEvent(values$label, {
|
|
if (is.null(values$label)) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG Update tagmat from label\n")
|
|
values$tagmat[, ok.labelcol()] <- values$label
|
|
values$tagmathist[, ok.labelcol()] <- values$labelhist
|
|
})
|
|
|
|
|
|
##############################################################################
|
|
## Reactives : training
|
|
##############################################################################
|
|
|
|
## Message of how many tagged and untagged, for model diagnostics box
|
|
ok.msgtagged <- reactive({
|
|
if (verbose)
|
|
cat("DEBUG enter ok.msgtagged\n")
|
|
# if (is.null(ok.data()) | ok.data.running()) {
|
|
if (is.null(ok.data())) {
|
|
return("No data yet ")
|
|
}
|
|
|
|
tmp <- ""
|
|
# if (sum(is.na(values$label)) == 0)
|
|
# tmp <- paste0(tmp, "Data correction mode (0 NA labels left).\n")
|
|
paste0(tmp, "Tagged: ", sum(!is.na(values$label)),
|
|
" ; Untagged: ", sum(is.na(values$label)))
|
|
})
|
|
|
|
## Training possible? At least 3 texts for 2 tags
|
|
ok.train.possible <- reactive({
|
|
if (verbose)
|
|
cat("DEBUG enter ok.train.possible\n")
|
|
labtab <- table(values$label)
|
|
if (length(labtab) < 2) return(FALSE)
|
|
if (sum(labtab > 2) < 2) return(FALSE)
|
|
TRUE
|
|
})
|
|
|
|
## Compute DFM (async)
|
|
## TODO make this less reactive
|
|
observe({
|
|
# if ("dfm" %in% input$use_regressors & !values$dfmGo)
|
|
if ("dfm" %in% values$new_use_regressors & !values$dfmGo)
|
|
values$dfmGo <- TRUE
|
|
})
|
|
ok.dfm <- reactiveVal()
|
|
observe({
|
|
if (is.null(ok.text())) return(NULL)
|
|
if (! values$dfmGo) return(NULL)
|
|
if (!is.numeric(input$dfmNgrams)) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG enter dfm observer\n")
|
|
|
|
datext <- ok.text()
|
|
dfmNgrams <- input$dfmNgrams
|
|
dfmTfIdf <- input$dfmTfIdf
|
|
dfmMinDocfreq <- input$dfmMinDocfreq
|
|
dfmMinTermfreq <- input$dfmMinTermfreq
|
|
dfmTfScheme <- input$dfmTfScheme
|
|
dfmDfScheme <- input$dfmDfScheme
|
|
|
|
dfm_async <- future(seed = TRUE, {
|
|
dadfm <- datext %>%
|
|
tolower() %>% tokens(remove_punct = F) %>%
|
|
# tokens_select(pattern = stopwords(language= "fr"), selection = "remove") %>%
|
|
tokens_ngrams(n= 1:dfmNgrams) %>% dfm() %>%
|
|
dfm_trim(min_docfreq = dfmMinDocfreq, min_termfreq = dfmMinTermfreq,
|
|
verbose = TRUE)
|
|
if (dfmTfIdf) {
|
|
dadfm <- dadfm %>%
|
|
dfm_tfidf(scheme_tf = dfmTfScheme, scheme_df = dfmDfScheme)
|
|
}
|
|
suppressWarnings({ # TODO : check
|
|
dadfm <- quanteda::convert(dadfm, to= "tm")
|
|
})
|
|
dadfm <- Matrix::sparseMatrix(i= dadfm$i, j= dadfm$j, x= dadfm$v,
|
|
dimnames = dadfm$dimnames)
|
|
dadfm
|
|
}) %...>% ok.dfm()
|
|
dfm_async <- catch(dfm_async, function(error) {
|
|
values$modelDiagno <- paste0("Error in DFM: ", error)
|
|
})
|
|
})
|
|
|
|
## Predictor : df or matrix of dfm and extra
|
|
ok.regressor.matrix <- reactive({
|
|
if (is.null(ok.text())) return(NULL)
|
|
if (is.null(ok.regressor.names())) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG enter ok.regressor.matrix\n")
|
|
model.matrix(~., data= ok.data()[, ok.regressor.names()])[, -1]
|
|
})
|
|
|
|
ok.extraregressor.matrix <- reactive({
|
|
req(ok.text())
|
|
if (! "extra" %in% values$new_use_regressors) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG enter ok.extraregressor.matrix\n")
|
|
|
|
res <- NULL
|
|
for (inum in input$use_ootregnum) {
|
|
suppressWarnings({tmp <- as.numeric(ok.data()[[inum]])})
|
|
if (all(is.na(tmp))) {
|
|
showNotification(paste0(inum, " is all NAs or non-numeric ; predictor not used"),
|
|
duration = 5, type = "warning")
|
|
next
|
|
}
|
|
tmp[is.na(tmp)] <- median(tmp, na.rm = TRUE)
|
|
res <- cbind(res, tmp)
|
|
}
|
|
for (icat in input$use_ootregcat) {
|
|
tmp <- ok.data()[[icat]]
|
|
if (! length(unique(tmp)) %in% 2:100) {
|
|
showNotification(paste0(icat, " has ", length(unique(tmp)),
|
|
" unique values ; predictor not used"),
|
|
duration = 5, type = "warning")
|
|
next
|
|
}
|
|
tmp <- as.character(tmp)
|
|
tmp[is.na(tmp)] <- "<NA>"
|
|
tmp <- as.factor(tmp)
|
|
tmpmat <- model.matrix(~., data.frame(cat = tmp))[, -1, drop = FALSE]
|
|
res <- cbind(res, tmpmat)
|
|
}
|
|
if (verbose)
|
|
cat("DEBUG exit ok.extraregressor.matrix", ncol(res), "\n")
|
|
res
|
|
})
|
|
|
|
ok.extraRegex.matrix <- reactive({
|
|
if (is.null(ok.nicetext())) return(NULL)
|
|
if (is.null(values$extraRegex)) return(NULL)
|
|
if (is.null(values$regex_inuse)) return(NULL)
|
|
if (!any(values$regex_inuse)) return(NULL)
|
|
if (is.null(values$regex_case)) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG enter ok.extraRegex.matrix\n")
|
|
tmp <- as.matrix(sapply(which(values$regex_inuse), function(iregex) {
|
|
1 * stringi::stri_detect_regex(
|
|
ok.nicetext(), values$extraRegex[iregex],
|
|
opts_regex = list(case_insensitive = !values$regex_case[iregex]))
|
|
}))
|
|
colnames(tmp) <- values$extraRegex[values$regex_inuse]
|
|
tmp
|
|
})
|
|
|
|
ok.predictor <- reactive({
|
|
req(values$new_use_regressors)
|
|
if (ok.data.running()) return(NULL)
|
|
if (is.null(ok.text())) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG enter ok.predictor\n")
|
|
dadfm <- NULL
|
|
if ("dfm" %in% values$new_use_regressors) {
|
|
dadfm <- ok.dfm()
|
|
} else {
|
|
if (input$predModel == "naive bayes") {
|
|
values$modelDiagno <-
|
|
"Error in training: Naive Bayes requires DFM word counts as predictors."
|
|
return(NULL)
|
|
}
|
|
}
|
|
if (length(ok.regressor.names()) > 0) {
|
|
if (input$predModel == "random forest") {
|
|
if (is.null(dadfm)) {
|
|
dadfm <- ok.data()[, ok.regressor.names()]
|
|
} else
|
|
dadfm <- cbind(ok.data()[, ok.regressor.names()], as.matrix(dadfm))
|
|
}
|
|
if (input$predModel %in% c("lasso", "linear", "knn")) {
|
|
dadfm <- cbind(ok.regressor.matrix(), dadfm)
|
|
}
|
|
}
|
|
# if ("regex" %in% input$use_regressors && length(values$regex_inuse) > 0) {
|
|
if ("regex" %in% values$new_use_regressors & !is.null(ok.extraRegex.matrix())) {
|
|
dadfm <- cbind(dadfm, ok.extraRegex.matrix())
|
|
}
|
|
if ("extra" %in% values$new_use_regressors) {
|
|
dadfm <- cbind(dadfm, ok.extraregressor.matrix())
|
|
}
|
|
|
|
if (is.null(dadfm)) {
|
|
values$modelDiagno <- "Error in training: no predictors selected"
|
|
if (verbose)
|
|
cat("DEBUG ok.predictor exit: no predictors\n")
|
|
return(NULL)
|
|
}
|
|
|
|
if (input$predModel == "linear")
|
|
dadfm <- SparseM::as.matrix.csr(dadfm, nrow(dadfm), ncol(dadfm))
|
|
if (input$predModel == "naive bayes")
|
|
dadfm <- as.dfm(dadfm)
|
|
if (verbose)
|
|
cat("DEBUG exit ok.predictor: ", ncol(dadfm), "\n")
|
|
dadfm
|
|
})
|
|
|
|
|
|
## Train model async
|
|
ok.train <- reactiveVal()
|
|
ok.train.async <- reactiveVal()
|
|
observeEvent(
|
|
list(trainTrigger(), input$modelTrain),
|
|
{
|
|
if (is.null(ok.predictor())) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG enter ok.train observer\n")
|
|
if (!ok.train.possible()) {
|
|
values$modelDiagno <-
|
|
"Tag at least 3 texts for 2 tags to train prediction model."
|
|
ok.train(NULL)
|
|
# queryTrigger(queryTrigger() + 1)
|
|
return(NULL)
|
|
}
|
|
ready2tag(0)
|
|
values$modelDiagno <- paste0("Training ", input$predModel)
|
|
|
|
tmp_model <- input$predModel
|
|
if (tmp_model == "random forest") {
|
|
if (!is.numeric(input$rfNumTrees) | !is.numeric(input$rfMtry) |
|
|
!is.numeric(input$rfSampleFrac)) {
|
|
ok.train(NULL)
|
|
return(NULL)
|
|
}
|
|
train_fun <- ranger::ranger
|
|
train_args <- list(
|
|
x= ok.predictor()[!is.na(values$label), ],
|
|
y= as.factor(values$label[!is.na(values$label)]),
|
|
num.trees = input$rfNumTrees,
|
|
mtry = if (input$rfMtry > 0) input$rfMtry,
|
|
sample.fraction = input$rfSampleFrac, probability = TRUE)
|
|
} else {
|
|
if (tmp_model == "linear") {
|
|
tmpvalues <- values$label
|
|
if (!is.numeric(input$liblinCost)) {
|
|
ok.train(NULL)
|
|
return(NULL)
|
|
}
|
|
for (ival in na.omit(unique(tmpvalues)))
|
|
if (sum(tmpvalues == ival, na.rm = T) == 1)
|
|
tmpvalues[which(tmpvalues == ival)] <- NA
|
|
train_fun <- LiblineaR::LiblineaR
|
|
train_args <- list(
|
|
data= ok.predictor()[!is.na(tmpvalues), ],
|
|
target= as.factor(tmpvalues[!is.na(tmpvalues)]),
|
|
type= 0, cost = input$liblinCost)
|
|
} else if (tmp_model == "lasso") {
|
|
tmpvalues <- values$label
|
|
for (ival in na.omit(unique(tmpvalues)))
|
|
if (sum(tmpvalues == ival, na.rm = T) == 1)
|
|
tmpvalues[which(tmpvalues == ival)] <- NA
|
|
train_fun <- glmnet::glmnet
|
|
train_args <- list(
|
|
x= ok.predictor()[!is.na(tmpvalues), ],
|
|
y= as.factor(tmpvalues[!is.na(tmpvalues)]),
|
|
family= "multinomial")
|
|
} else if (tmp_model == "naive bayes") {
|
|
if (!is.numeric(input$naiveSmooth)) {
|
|
ok.train(NULL)
|
|
return(NULL)
|
|
}
|
|
tmpvalues <- values$label
|
|
for (ival in na.omit(unique(tmpvalues)))
|
|
if (sum(tmpvalues == ival, na.rm = T) == 1)
|
|
tmpvalues[which(tmpvalues == ival)] <- NA
|
|
train_fun <- quanteda.textmodels::textmodel_nb
|
|
train_args <- list(
|
|
x= ok.predictor()[!is.na(tmpvalues), ],
|
|
y= as.factor(tmpvalues[!is.na(tmpvalues)]),
|
|
smooth = input$naiveSmooth, prior = input$naivePrior,
|
|
distribution = input$naiveDistri)
|
|
} else if (tmp_model == "knn") {
|
|
train_fun <- function(x) return(TRUE)
|
|
train_args <- list(x = "knn")
|
|
}
|
|
}
|
|
|
|
train_async <- future(seed = TRUE, {
|
|
suppressWarnings(do.call(train_fun, train_args))
|
|
}) %...>% ok.train.async()
|
|
train_async <- catch(train_async, function(error) {
|
|
values$modelDiagno <- paste0("Model training error: ", error)
|
|
ok.train(NULL)
|
|
ok.train.async(NULL)
|
|
})
|
|
train_async <- finally(train_async, function() {
|
|
values$modelDiagno <- "Training done, predicting..."
|
|
ok.train(ok.train.async())
|
|
ok.train.async(NULL)
|
|
predTrigger(predTrigger() + 1)
|
|
})
|
|
NULL
|
|
}
|
|
)
|
|
|
|
## Model prediction on full dataset (async)
|
|
ok.pred <- reactiveVal()
|
|
ok.pred.async <- reactiveVal()
|
|
# observeEvent(list(ok.train(), input$glmLambda, input$knnK, values$retagged), {
|
|
observeEvent(predTrigger(), {
|
|
if (is.null(ok.train())) {
|
|
ok.pred(NULL)
|
|
return(NULL)
|
|
}
|
|
if (verbose)
|
|
cat("DEBUG ok.pred()\n")
|
|
|
|
damodel <- input$predModel
|
|
if (input$predModel == "random forest") {
|
|
pred_args <- list(ok.train(), data = ok.predictor())
|
|
dacolnames <- colnames(ok.train()$predictions)
|
|
} else if (input$predModel == "lasso") {
|
|
if (!is.numeric(input$glmLambda)) {
|
|
ok.pred(NULL)
|
|
return(NULL)
|
|
}
|
|
pred_args <- list(ok.train(), newx = ok.predictor(), s = input$glmLambda,
|
|
type = "response")
|
|
} else if (input$predModel == "linear") {
|
|
pred_args <- list(ok.train(), newx = ok.predictor(), proba = TRUE)
|
|
} else if (input$predModel == "naive bayes") {
|
|
pred_args <- list(ok.train(), newdata = ok.predictor(),
|
|
type = "probability")
|
|
} else if (input$predModel == "knn") {
|
|
if (!is.numeric(input$knnK)) {
|
|
ok.pred(NULL)
|
|
return(NULL)
|
|
}
|
|
pred_args <- list(train = ok.predictor()[!is.na(values$label), ],
|
|
test = ok.predictor(),
|
|
cl = values$label[!is.na(values$label)],
|
|
k = input$knnK, prob = TRUE)
|
|
}
|
|
|
|
pred_async <- future(seed = TRUE, {
|
|
if (damodel == "random forest") {
|
|
res <- do.call(predict, pred_args)$predictions
|
|
colnames(res) <- dacolnames
|
|
res
|
|
} else if (damodel == "lasso") {
|
|
do.call(predict, pred_args)[, , 1]
|
|
} else if (damodel == "linear") {
|
|
do.call(predict, pred_args)$probabilities
|
|
} else if (damodel == "naive bayes") {
|
|
do.call(predict, pred_args)
|
|
} else if (damodel == "knn") {
|
|
tmp <- do.call(class::knn, pred_args)
|
|
## A bit flaky here: probs of non-best classes uniformly share the rest,
|
|
## and distance is euc
|
|
tmpvalues <- sort(unique(pred_args$cl))
|
|
res <- matrix(0, nrow(pred_args$test), length(tmpvalues),
|
|
dimnames = list(NULL, tmpvalues))
|
|
res[cbind(1:nrow(res), tmp)] <- attr(tmp, "prob") -
|
|
((1 - attr(tmp, "prob")) / (ncol(res) - 1))
|
|
res <- res + (1 - attr(tmp, "prob")) / (ncol(res) - 1)
|
|
res
|
|
}
|
|
}) %...>% ok.pred.async()
|
|
pred_async <- catch(pred_async, function(error) {
|
|
values$modelDiagno <- paste0("Error in prediction: ", error)
|
|
})
|
|
pred_async <- finally(pred_async, function() {
|
|
if (verbose)
|
|
cat("DEBUG ok.pred() out of async\n")
|
|
ok.pred(ok.pred.async())
|
|
ok.pred.async(NULL)
|
|
# predlabTrigger(predlabTrigger() + 1)
|
|
diagTrigger(diagTrigger() + 1)
|
|
queryNext(queryNext() + 1)
|
|
})
|
|
})
|
|
|
|
## Best predicted label for full dataset
|
|
# ok.predlab1 <- eventReactive(predlabTrigger(), {
|
|
# if (is.null(ok.pred())) return(NULL)
|
|
# if (verbose)
|
|
# cat("DEBUG ok.predlab1\n")
|
|
# # queryTrigger(queryTrigger() + 1)
|
|
# colnames(ok.pred())[max.col(ok.pred())]
|
|
# })
|
|
ok.predlab1 <- reactive({
|
|
if (is.null(ok.pred())) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG ok.predlab1\n")
|
|
colnames(ok.pred())[max.col(ok.pred())]
|
|
})
|
|
|
|
## On scheme change, forget existing model, queue, query and hist
|
|
## load scheme description and predictor-regex
|
|
observeEvent(ok.labelcol(), {
|
|
if (verbose)
|
|
cat("DEBUG event selectScheme", ok.labelcol(), "\n")
|
|
ok.pred(NULL)
|
|
ok.train(NULL)
|
|
values$queryqueue <- NULL
|
|
values$modelDiagno <- "No model"
|
|
values$histSaveStack <- NULL
|
|
|
|
## Load description file
|
|
descr <- ""
|
|
if (file.exists(paste0(values$conf$datadir, values$conf$projectid,
|
|
"/", input$selectScheme, ".txt"))) {
|
|
descr <- paste(collapse = "\n", readLines(paste0(
|
|
values$conf$datadir, values$conf$projectid,
|
|
"/", input$selectScheme, ".txt")))
|
|
}
|
|
updateTextAreaInput(session, "schemeDescr", value = descr)
|
|
|
|
## Load regex from json
|
|
regexfile <- paste0(values$projectdir, input$selectScheme, "_regex.json")
|
|
if (file.exists(regexfile)) {
|
|
if (verbose)
|
|
cat("DEBUG enter regex.json\n")
|
|
tmp <- RJSONIO::fromJSON(paste(collapse = "\n", readLines(regexfile)))
|
|
if (is.null(tmp$regex)) return(NULL)
|
|
values$extraRegex <- tmp$regex
|
|
names(values$extraRegex) <- sapply(tmp$regex, label2hash)
|
|
for (iregex in 1:length(tmp$regex)) {
|
|
values[[paste0("useregex_", names(values$extraRegex)[iregex])]] <-
|
|
tmp$use[iregex]
|
|
values[[paste0("caseregex_", names(values$extraRegex)[iregex])]] <-
|
|
tmp$case[iregex]
|
|
}
|
|
} else
|
|
values$extraRegex <- NULL
|
|
|
|
})
|
|
|
|
|
|
|
|
## queryNext event: update values$newQuery ; called by queryNext(), or by
|
|
## queryQueue or regex change
|
|
## Requires :
|
|
## - queryQueue (reactive: indices of current queue), and
|
|
## - wasTagged (boolean vector indicating whether each element has been tagged this session, used in "on untagged")
|
|
## - wasRetagged (boolean vector indicating whether each element has been tagged this session, used in "on tagged")
|
|
## TODO: make a scheme-list of wasTagged, now it will be wiped at each scheme change?
|
|
observeEvent(
|
|
list(queryNext(), values$queryQueue,
|
|
input$sampleChoice, input$taggedWhich, input$maxprobWhich,
|
|
input$regexFilter, input$regexCaseSens,
|
|
input$visuLock, values$visuZoom$xlim, values$visuZoom$ylim),
|
|
{
|
|
if (is.null(values$queryQueue)) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG queryNext\n")
|
|
|
|
queue <- values$queryQueue
|
|
|
|
if (input$sampleChoice == "untagged") {
|
|
queue <- queue[!values$wasTagged[queue]]
|
|
} else if (input$sampleChoice == "tagged") {
|
|
queue <- queue[!is.na(values$label)[queue] & !values$wasRetagged[queue]]
|
|
if (input$taggedWhich != "all") {
|
|
queue <- queue[values$label[queue] == input$taggedWhich]
|
|
}
|
|
} else if (input$sampleChoice == "all") {
|
|
queue <- queue[!values$wasRetagged[queue]]
|
|
}
|
|
|
|
if (input$visuLock) if (!is.null(values$visuZoom$xlim)) {
|
|
if (!is.null(ok.visu()))
|
|
queue <- queue[ok.visu()[queue, 1] >= values$visuZoom$xlim[1] &
|
|
ok.visu()[queue, 1] <= values$visuZoom$xlim[2] &
|
|
ok.visu()[queue, 2] >= values$visuZoom$ylim[1] &
|
|
ok.visu()[queue, 2] <= values$visuZoom$ylim[2]]
|
|
}
|
|
|
|
if (length(queue)) if (nchar(input$regexFilter)) {
|
|
try_regex <- try(silent = TRUE, {
|
|
queue <- queue[
|
|
stringi::stri_detect_regex(
|
|
ok.nicetext()[queue], input$regexFilter,
|
|
opts_regex = list(case_insensitive = !input$regexCaseSens))]
|
|
})
|
|
if (inherits(try_regex, "try-error")) {
|
|
showNotification("Invalid regex", duration = 2, type = "error")
|
|
values$newQuery <- NULL
|
|
return(NULL)
|
|
}
|
|
}
|
|
|
|
if (!length(queue)) {
|
|
if (nchar(input$regexFilter)) {
|
|
showNotification("No texts matching the regex",
|
|
duration = 2, type = "warning")
|
|
} else
|
|
showNotification("No more texts to be tagged in this set",
|
|
duration = 2, type = "warning")
|
|
values$newQuery <- NULL
|
|
return(NULL)
|
|
}
|
|
|
|
values$lastQuery <- queue[1] # ??
|
|
values$newQuery <- queue[1]
|
|
ready2tag(1)
|
|
}
|
|
)
|
|
|
|
## queryQueue event: fix values$queryQueue, (indices of current queue)
|
|
observeEvent(
|
|
list(ok.data(), ok.pred(), input$strategy, input$maxprobWhich,
|
|
input$selectProject, input$selectScheme), {
|
|
if (input$strategy %in% c("entropy", "maxprob") & is.null(ok.pred())) {
|
|
values$queryQueue <- NULL
|
|
values$lastQuery <- NULL
|
|
values$newQuery <- NULL
|
|
return(NULL)
|
|
}
|
|
if (is.null(ok.text())) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG queryQueue change\n")
|
|
|
|
if (input$strategy == "sequential") {
|
|
values$queryQueue <- 1:length(ok.text())
|
|
} else if (input$strategy == "random") {
|
|
values$queryQueue <- sample(length(ok.text()))
|
|
} else {
|
|
dapred <- ok.pred()
|
|
if (input$strategy == "entropy") {
|
|
tominimize <- rowSums(dapred * log(dapred))
|
|
if (any(dapred == 0)) {
|
|
tominimize[dapred == 0] <- 0
|
|
}
|
|
}
|
|
if (input$strategy == "maxprob") {
|
|
if (! input$maxprobWhich %in% colnames(dapred)) return(NULL)
|
|
tominimize <- -dapred[, input$maxprobWhich];
|
|
}
|
|
values$queryQueue <- order(tominimize)
|
|
}
|
|
}
|
|
)
|
|
|
|
|
|
## Update uniqueLabels and uniqueLabelsAll if necessary on values$label change
|
|
observeEvent(values$label, {
|
|
if (is.null(values$label)) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG uniqueLabels\n")
|
|
dalabs <- sort(na.omit(unique(values$label)))
|
|
# if (!length(dalabs)) return(NULL)
|
|
if (!identical(dalabs, values$uniqueLabels))
|
|
values$uniqueLabels <- dalabs
|
|
if (any(! dalabs %in% values$uniqueLabelsAll))
|
|
values$uniqueLabelsAll <- c(values$uniqueLabelsAll,
|
|
dalabs[! dalabs %in% values$uniqueLabelsAll])
|
|
})
|
|
|
|
|
|
|
|
##############################################################################
|
|
## Project management
|
|
##############################################################################
|
|
|
|
output$cpDataMessage <- renderUI({
|
|
req(values$cpDataMessage)
|
|
p(values$cpDataMessage)
|
|
})
|
|
|
|
output$cpConfirmMessage <- renderUI({
|
|
req(values$cpConfirmMessage)
|
|
p(strong(paste0("Error: ", values$cpConfirmMessage)))
|
|
})
|
|
|
|
output$cpIdcolUI <- renderUI({
|
|
req(values$cpNewData)
|
|
if (!is.data.frame(values$cpNewData)) return(NULL)
|
|
selectInput("cpIdcol", NULL, colnames(values$cpNewData))
|
|
})
|
|
|
|
output$cpTextcolUI <- renderUI({
|
|
req(values$cpNewData)
|
|
if (!is.data.frame(values$cpNewData)) return(NULL)
|
|
selectInput("cpTextcol", NULL, colnames(values$cpNewData), multiple = TRUE)
|
|
})
|
|
|
|
output$cpContextcolUI <- renderUI({
|
|
req(values$cpNewData)
|
|
if (!is.data.frame(values$cpNewData)) return(NULL)
|
|
selectInput("cpContextcol", NULL, colnames(values$cpNewData), multiple = TRUE)
|
|
})
|
|
|
|
output$cpTagcolUI <- renderUI({
|
|
req(values$cpNewData)
|
|
if (!is.data.frame(values$cpNewData)) return(NULL)
|
|
selectInput("cpTagcol", NULL, colnames(values$cpNewData), multiple = TRUE)
|
|
})
|
|
|
|
output$cpCommcolUI <- renderUI({
|
|
req(values$cpNewData)
|
|
if (!is.data.frame(values$cpNewData)) return(NULL)
|
|
selectInput("cpCommcol", NULL, c("none", colnames(values$cpNewData)))
|
|
})
|
|
|
|
output$cp_spacyUI <- renderUI(
|
|
textInput("cp_use_spacy_model", NULL,
|
|
modelnames$spacy_name[modelnames$short == input$cp_lang],
|
|
placeholder = "(spacy model name)")
|
|
)
|
|
|
|
output$cp_spacyDlUI <- renderUI(HTML(paste(
|
|
"<em>Model must be downloaded once, from python:</em><br>",
|
|
input$cp_which_python, "-m spacy download",
|
|
modelnames$spacy_name[modelnames$short == input$cp_lang], "<br><br>"
|
|
)))
|
|
|
|
output$cp_ftUI <- renderUI(
|
|
textInput("cp_use_ft_model", NULL,
|
|
modelnames$fasttext_name[modelnames$short == input$cp_lang],
|
|
placeholder = "(fasttext model path)")
|
|
)
|
|
|
|
output$cp_ftDlUI <- renderUI(list(HTML(paste(
|
|
"<em>Model can be downloaded <a href='",
|
|
modelnames$fasttext_url[modelnames$short == input$cp_lang],
|
|
"'>here</a></em>")),
|
|
br(), br()))
|
|
|
|
output$cp_sbUI <- renderUI(
|
|
textInput("cp_use_sb_model", NULL, ifelse(
|
|
input$cp_lang %in% c("ar", "zh", "nl", "en", "fr", "de",
|
|
"it", "ko", "pl", "pt", "ru", "es", "tr"),
|
|
"distiluse-base-multilingual-cased-v1",
|
|
"distiluse-base-multilingual-cased-v2"),
|
|
placeholder = "(custom sentence_transformers model)")
|
|
)
|
|
|
|
|
|
|
|
## Create new project, with modal dialog
|
|
observeEvent(input$createProject, {
|
|
if (verbose)
|
|
cat("DEBUG create project\n")
|
|
showModal(modalDialog(
|
|
title = "New project",
|
|
|
|
p("Create a new text tagging project."),
|
|
p("This mainly involves choosing a dataset, and how to process it."),
|
|
p("Items marked by a star ", strong("*"),
|
|
" cannot be changed once the project is created."),
|
|
|
|
hr(),
|
|
h4("Files and folders"),
|
|
|
|
fluidRow(
|
|
column(3, p(strong("*Project name"))),
|
|
column(5, textInput("cpName", NULL, placeholder = "(Required)")),
|
|
column(4, p("Tags will be stored in a new directory by this name."))
|
|
),
|
|
fluidRow(
|
|
column(3, p(strong("*Data directory"))),
|
|
column(5, textInput("cpDatadir", NULL, placeholder = "(Required)")),
|
|
column(4, p("Place (on the server) where the data and project are stored"))
|
|
),
|
|
fluidRow(
|
|
column(3, p(strong("*Data filename"))),
|
|
column(5, checkboxInput("cpDoImport", "New data", TRUE)),
|
|
column(4, p("Main file, containing id and text columns"))
|
|
),
|
|
|
|
conditionalPanel("!input.cpDoImport", list(
|
|
## Existing data
|
|
fluidRow(
|
|
column(3, p(strong("Existing file"))),
|
|
column(5, textInput("cpDatafile", NULL, placeholder = "(Required)")),
|
|
column(4, actionButton("cpDatafileGo", "Import"))
|
|
)
|
|
)),
|
|
conditionalPanel("input.cpDoImport", {
|
|
## Import data
|
|
wellPanel(
|
|
selectInput('cpNDfiletype', NULL,
|
|
choices = c("Text file (.csv, .txt)" = "csv_txt",
|
|
"Feather" = "feather",
|
|
"Parquet" = "parquet",
|
|
"OpenDocument (.ods)" = "ods",
|
|
"Microsoft Excel (.xls, .xlsx)" = "excel",
|
|
"SPSS (.sav, .por)" = "spss",
|
|
"SAS (.sas7bdat)" = "sas_data",
|
|
"Stata v5-v12 (.dta)" = "stata"),
|
|
selected = "csv_txt"
|
|
),
|
|
fileInput('cpNDfile', 'Choose File'),
|
|
|
|
checkboxInput("cpNDparams", "File parameters"),
|
|
|
|
conditionalPanel(
|
|
"input.cpNDparams",
|
|
conditionalPanel(
|
|
"input.cpNDfiletype == 'csv_txt'",
|
|
|
|
fluidRow(column(4, p('Header')),
|
|
column(8, selectInput('cpCSVheader', NULL,
|
|
c("Header" = TRUE,
|
|
"No Header" = FALSE),
|
|
"Auto"))),
|
|
fluidRow(column(4, p('Separator')),
|
|
column(8, selectInput('cpCSVsep', NULL,
|
|
c("Comma ','" = ",",
|
|
"Semicolon ';'" = ";",
|
|
"Tab" = "\t",
|
|
"Space" = " "),
|
|
"Auto"))),
|
|
fluidRow(column(4, p('Quote')),
|
|
column(8, selectInput('cpCSVquote', NULL,
|
|
c("Double Quote \"" = "\"",
|
|
"Single Quote '" = "'",
|
|
"None" = ""),
|
|
"Double Quote \""))),
|
|
fluidRow(column(4, p('Decimal mark')),
|
|
column(8, selectInput('cpCSVdec', NULL,
|
|
c('Period "."' = ".",
|
|
'Comma ","' = ","),
|
|
'Period "."'))),
|
|
fluidRow(column(4, p('File Encoding')),
|
|
column(8, selectInput('cpCSVencoding', NULL,
|
|
c("unknown", "UTF-8", "Latin-1"),
|
|
"unknown")))),
|
|
|
|
## Options for ods files
|
|
conditionalPanel(
|
|
"input.cpNDfiletype == 'ods'",
|
|
fluidRow(column(4, p('Sheet')),
|
|
column(8, numericInput('cpODSsheet', NULL, 1, 1,
|
|
step = 1))),
|
|
checkboxInput("cpODScolnames", "Column names", TRUE),
|
|
fluidRow(column(4, p('NA symbol')),
|
|
column(8, textInput('cpODSna', NULL, value = ""))),
|
|
fluidRow(column(4, p('Skip rows')),
|
|
column(8, numericInput('cpODSskip', NULL, 0, 0,
|
|
step = 1))),
|
|
fluidRow(column(4, p('Specify range')),
|
|
column(8, textInput('cpODSrange', NULL, value = "")))
|
|
),
|
|
|
|
## Options for xls / xlsx files
|
|
conditionalPanel(
|
|
"input.cpNDfiletype == 'excel'",
|
|
fluidRow(column(4, p('Column names')),
|
|
column(8, selectInput('cpXLScolnames', NULL,
|
|
choices = c("Yes" = "TRUE",
|
|
"No" = "FALSE"),
|
|
selected = TRUE ))),
|
|
fluidRow(column(4, p('Skip rows')),
|
|
column(8, numericInput('cpXLSskip', NULL, 0, 0,
|
|
step = 1))),
|
|
fluidRow(column(4, p('Trim whitespaces')),
|
|
column(8, selectInput('cpXLStrim', NULL,
|
|
choices = c("Yes" = "TRUE",
|
|
"No" = "FALSE"),
|
|
selected = TRUE ))),
|
|
checkboxInput("cpXLSsheet",
|
|
"Specify Worksheet", FALSE),
|
|
conditionalPanel("input.cpXLSsheet",
|
|
textInput("cpXLSsheet_specs", NULL, "")),
|
|
checkboxInput("cpXLSrange", "Specify Range", FALSE),
|
|
conditionalPanel("input.cpXLSrange",
|
|
textInput("cpXLSrange_specs", NULL, "")
|
|
)),
|
|
|
|
## Options for SPSS files
|
|
conditionalPanel(
|
|
"input.cpNDfiletype == 'spss'",
|
|
fluidRow(
|
|
column(4, p('Skip rows')),
|
|
column(8, numericInput('cpSPSSskip', NULL, 0, 0, step = 1))),
|
|
checkboxInput("cpSPSSna", "User-defined NA", FALSE)),
|
|
|
|
## Options for SAS files
|
|
conditionalPanel(
|
|
"input.cpNDfiletype == 'sas_data'",
|
|
fluidRow(
|
|
column(4, p('Skip rows')),
|
|
column(8, numericInput("cpSASskip", NULL, 0, 0, step = 1))),
|
|
checkboxInput("cpSAScatalog", "Use catalog file", FALSE),
|
|
conditionalPanel(
|
|
"input.cpSAScatalog",
|
|
fileInput("cpSAScatalog_file", "Catalog file"))
|
|
),
|
|
|
|
## Options for STATA dta files
|
|
conditionalPanel(
|
|
"input.cpNDfiletype == 'stata'",
|
|
checkboxInput("cpSTATAfactors", "Convert factors", FALSE))
|
|
)
|
|
)
|
|
}),
|
|
|
|
uiOutput("cpDataMessage"),
|
|
hr(),
|
|
h4("Data"),
|
|
|
|
fluidRow(
|
|
column(6, numericInput(
|
|
"cpNrows", "N. rows for working sample", 500, 1, step = 1)),
|
|
column(6, numericInput(
|
|
"cpNskip", "Rows to skip before working sample", 0, 0, step = 1))
|
|
),
|
|
|
|
fluidRow(
|
|
column(3, p(strong("*ID"))),
|
|
column(5, uiOutput("cpIdcolUI")),
|
|
column(4, p("Name of the id variable, unique identifier of each text"))
|
|
),
|
|
fluidRow(
|
|
column(3, p(strong("*Text"))),
|
|
column(5, uiOutput("cpTextcolUI")),
|
|
column(4, p("Name of the text variables: if more than one, texts are concatenated in the specified order"))
|
|
),
|
|
fluidRow(
|
|
column(3, p(strong("*Tags"))),
|
|
column(5, uiOutput("cpTagcolUI")),
|
|
column(4, p("(optional) Names of variables that are already tagged: each will create a new scheme"))
|
|
),
|
|
fluidRow(
|
|
column(3, p(strong("Comments"))),
|
|
column(5, uiOutput("cpCommcolUI")),
|
|
column(4, p("(optional) Name of the comments variable"))
|
|
),
|
|
fluidRow(
|
|
column(3, p(strong("Context"))),
|
|
column(5, uiOutput("cpContextcolUI")),
|
|
column(4, p("(optional) Names of variables not used in the models, but may be displayed during tagging"))
|
|
),
|
|
|
|
|
|
hr(),
|
|
h4("System"),
|
|
|
|
fluidRow(
|
|
column(3, checkboxInput("cp_use_python", "Python backend", FALSE)),
|
|
column(5, conditionalPanel(
|
|
"input.cp_use_python",
|
|
textInput("cp_which_python", NULL, value = "python3",
|
|
placeholder = "(custom python path)"))),
|
|
column(4, conditionalPanel(
|
|
"input.cp_use_python",
|
|
p("This must be a working python3 environment, with the required modules installed (see documentation)")))
|
|
),
|
|
conditionalPanel("input.cp_use_python", list(
|
|
fluidRow(
|
|
column(3, p("Language")),
|
|
column(5, selectInput("cp_lang", NULL, modelnames_labels, "en")),
|
|
column(4, p("Used to preset tokenization and embedding models"))
|
|
),
|
|
fluidRow(
|
|
column(3, checkboxInput("cp_use_spacy", "SpaCy tokenization", FALSE)),
|
|
column(5, conditionalPanel("input.cp_use_spacy", uiOutput("cp_spacyUI"))),
|
|
column(4, p("Name of the spacy tokenizer model, used in DTM and word embeddings"))
|
|
),
|
|
conditionalPanel("input.cp_use_spacy", fluidRow(
|
|
column(3),
|
|
column(9, uiOutput("cp_spacyDlUI")))
|
|
),
|
|
fluidRow(
|
|
column(3, checkboxInput("cp_use_ft", "FastText word embeddings", FALSE)),
|
|
column(5, conditionalPanel("input.cp_use_ft", uiOutput("cp_ftUI"))),
|
|
column(4, p("Path to the local fasttext model binary"))
|
|
),
|
|
conditionalPanel("input.cp_use_ft", fluidRow(
|
|
column(3),
|
|
column(9, uiOutput("cp_ftDlUI")))),
|
|
fluidRow(
|
|
column(3, checkboxInput("cp_use_sb", "SBERT sentence embeddings", FALSE)),
|
|
column(5, conditionalPanel("input.cp_use_sb", uiOutput("cp_sbUI"))),
|
|
column(4, p("(GPU recommended) Name or path of the sentence-transformers model"))
|
|
),
|
|
|
|
conditionalPanel("input.cp_use_python", {
|
|
checkboxInput("cp_use_gpu", "GPU support (CUDA, for SBERT and BERT)", FALSE)
|
|
})
|
|
)),
|
|
|
|
uiOutput("cpConfirmMessage"),
|
|
footer = tagList(actionButton("cpConfirm", "Create"),
|
|
modalButton("Cancel"))))
|
|
})
|
|
|
|
observeEvent(input$cpDatafileGo, {
|
|
dataname <- input$cpDatafile
|
|
dataname <- gsub("[.]feather$", "", dataname)
|
|
tmpdat <- try(arrow::read_feather(
|
|
paste0(gsub("/+$", "/", paste0(input$cpDatadir, "/")),
|
|
dataname, ".feather")))
|
|
if (inherits(tmpdat, "try-error")) {
|
|
values$cpDataMessage <- paste0(
|
|
"Data import error: ", as.character(tmpdat))
|
|
values$cpNewData <- NULL
|
|
return(NULL)
|
|
}
|
|
if (!is.data.frame(tmpdat)) {
|
|
values$cpDataMessage <- "Data import error: object not a data.frame"
|
|
values$cpNewData <- NULL
|
|
return(NULL)
|
|
}
|
|
if (ncol(tmpdat) < 2) {
|
|
values$cpDataMessage <- "Data import error: only one column detected"
|
|
values$cpNewData <- NULL
|
|
return(NULL)
|
|
}
|
|
|
|
values$cpDataMessage <- paste0(
|
|
"Data import success: ", nrow(tmpdat), " rows, ", ncol(tmpdat), " cols.")
|
|
values$cpNewData <- tmpdat
|
|
values$cpNewDataname <- dataname
|
|
|
|
})
|
|
|
|
## Data import mechanism
|
|
observeEvent(input$cpNDfile, {
|
|
req(input$cpNDfile)
|
|
if(input$cpNDfiletype == "csv_txt") {
|
|
res <- try(read.csv(
|
|
input$cpNDfile$datapath,
|
|
header = as.logical(input$cpCSVheader), sep = input$cpCSVsep,
|
|
quote = input$cpCSVquote, dec = input$cpCSVdec, stringsAsFactors = FALSE,
|
|
encoding = input$cpCSVencoding, check.names = TRUE))
|
|
|
|
} else if(input$cpNDfiletype == "feather") {
|
|
res <- try(arrow::read_feather(input$cpNDfile$datapath))
|
|
|
|
} else if(input$cpNDfiletype == "parquet") {
|
|
res <- try(arrow::read_parquet(input$cpNDfile$datapath))
|
|
|
|
} else if (input$cpNDfiletype == "ods") {
|
|
range <- input$cpODSrange
|
|
if (range == "") range <- NULL
|
|
res <- try(readODS::read_ods(
|
|
path = input$cpNDfile$datapath, sheet = input$cpODSsheet,
|
|
col_names = input$cpODScolnames, na = input$cpODSna,
|
|
skip = input$cpODSskip, range = input$cpODSrange))
|
|
|
|
} else if(input$cpNDfiletype == "excel"){
|
|
column_names <- as.logical(input$cpXLScolnames)
|
|
trim_spaces <- as.logical(input$cpXLStrim)
|
|
the.range <- NULL
|
|
if(input$cpXLSrange == TRUE & input$cpXLSrange_specs != "")
|
|
the.range <- input$cpXLSrange_specs
|
|
the.sheet <- NULL
|
|
if(input$cpXLSsheet == TRUE & input$cpXLSsheet_specs != "")
|
|
the.sheet <- input$cpXLSsheet_specs
|
|
res <- try(data.frame(readxl::read_excel(
|
|
dataFile$datapath, col_names = column_names, range = the.range,
|
|
sheet= the.sheet, trim_ws = trim_spaces, skip = rows_to_skip)))
|
|
|
|
} else if(input$cpNDfiletype == "spss"){
|
|
res <- try(data.frame(haven::read_spss(
|
|
file = input$cpNDfile$datapath,
|
|
skip= input$cpSPSSskip, user_na = input$cpSPSSna)))
|
|
if (!inherits(res, "try-error")) {
|
|
res <- data.frame(lapply(res, function(x) {
|
|
attr(x, "format.spss") <- NULL
|
|
if ("haven_labelled" %in% class(x))
|
|
x <- haven::as_factor(x, levels= "labels")
|
|
x
|
|
}))
|
|
}
|
|
|
|
} else if(input$cpNDfiletype == "sas_data") {
|
|
res <- try(data.frame(haven::read_sas(
|
|
data_file = input$cpNDfile$datapath,
|
|
catalog_file = input$cpSAScatalog_file$datapath,
|
|
skip = input$cpSASskip)))
|
|
|
|
} else if(input$cpNDfiletype == "stata") {
|
|
res <- try(data.frame(foreign::read.dta(
|
|
file = input$cpNDfile$datapath, convert.factors = input$cpSTATAfactors)))
|
|
}
|
|
|
|
if(inherits(res, "try-error")) {
|
|
values$cpDataMessage <- paste0("Data import error: ", res)
|
|
values$cpNewData <- NULL
|
|
return(NULL)
|
|
}
|
|
if (ncol(res) < 2) {
|
|
values$cpDataMessage <- "Data import error: only one column detected"
|
|
values$cpNewData <- NULL
|
|
return(NULL)
|
|
}
|
|
values$cpDataMessage <- paste0(
|
|
"Data import success: ", nrow(res), " rows, ", ncol(res), " columns.")
|
|
values$cpNewData <- res
|
|
})
|
|
|
|
## New project confirm
|
|
observeEvent(input$cpConfirm, {
|
|
if (verbose)
|
|
cat("DEBUG cpConfirm\n")
|
|
newconf <- list()
|
|
|
|
tmpdir <- gsub("/+$", "/", paste0(input$cpDatadir, "/"))
|
|
if (!dir.exists(tmpdir))
|
|
dir.create(tmpdir)
|
|
newconf$datadir <- tmpdir
|
|
|
|
tmpname <- cleanFileName(input$cpName)
|
|
if (!nchar(tmpname)) {
|
|
values$cpConfirmMessage <- "Project name is required"
|
|
return(NULL)
|
|
}
|
|
if (dir.exists(paste0(newconf$datadir, tmpname))) {
|
|
values$cpConfirmMessage <- paste0(
|
|
"A project with the same name (", tmpname,
|
|
") already exists in the data directory.")
|
|
return(NULL)
|
|
}
|
|
newconf$projectid <- tmpname
|
|
|
|
if (!is.data.frame(values$cpNewData)) {
|
|
values$cpConfirmMessage <- "Import data first"
|
|
return(NULL)
|
|
}
|
|
|
|
if (input$cpDoImport) {
|
|
newconf$dataname <- newconf$projectid
|
|
} else
|
|
newconf$dataname <- values$cpNewDataname
|
|
|
|
if (any(is.na(values$cpNewData[[input$cpIdcol]]))) {
|
|
values$cpConfirmMessage <- "ID variable contains missing values"
|
|
return(NULL)
|
|
}
|
|
if (any(duplicated(values$cpNewData[[input$cpIdcol]]))) {
|
|
values$cpConfirmMessage <- "ID variable contains duplicates"
|
|
return(NULL)
|
|
}
|
|
newconf$idcol <- input$cpIdcol
|
|
|
|
if (!length(input$cpTextcol)) {
|
|
values$cpConfirmMessage <- "Select at least one text variable"
|
|
return(NULL)
|
|
}
|
|
newconf$textcols <- input$cpTextcol
|
|
|
|
if (input$cpCommcol == "none") {
|
|
newconf$commcol <- paste0("comm_", newconf$projectid)
|
|
} else
|
|
newconf$commcol <- input$cpCommcol
|
|
|
|
if (!length(input$cpTagcol)) {
|
|
newconf$tagcols <- "scheme0"
|
|
} else
|
|
newconf$tagcols <- input$cpTagcol
|
|
|
|
newconf$contextcols <- input$cpContextcol
|
|
|
|
newconf$dataNrows <- input$cpNrows
|
|
newconf$dataSkipRows <- input$cpNskip
|
|
|
|
if (input$cp_use_python) {
|
|
pytest <- try(system(paste(input$cp_which_python, "--version"),
|
|
intern = TRUE))
|
|
if (inherits(pytest, "try-error")) {
|
|
values$cpConfirmMessage <- paste(
|
|
"Python path `", input$cp_which_python, "` not valid")
|
|
return(NULL)
|
|
}
|
|
}
|
|
newconf$use_python <- input$cp_use_python
|
|
newconf$python <- input$cp_which_python
|
|
newconf$use_gpu <- input$cp_use_gpu
|
|
|
|
if (input$cp_use_spacy) {
|
|
sptest <- system(paste0(
|
|
newconf$python, " -m spacy info ", input$cp_use_spacy_model), intern = TRUE)
|
|
if (length(sptest) == 0) {
|
|
values$cpConfirmMessage <- paste(
|
|
"Error loading spacy, check that it is installed in the specified python env")
|
|
return(NULL)
|
|
}
|
|
if (length(attr(sptest, "status"))) {
|
|
values$cpConfirmMessage <- paste(
|
|
"Error loading spacy model, check that it has been downloaded")
|
|
return(NULL)
|
|
}
|
|
}
|
|
newconf$use_spacy <- input$cp_use_spacy
|
|
newconf$use_spacy_model <- input$cp_use_spacy_model
|
|
|
|
if (input$cp_use_ft) if (!file.exists(input$cp_use_ft_model)) {
|
|
values$cpConfirmMessage <- paste(
|
|
"Error loading fasttext model, check the specified path")
|
|
return(NULL)
|
|
}
|
|
newconf$use_ft <- input$cp_use_ft
|
|
newconf$use_ft_model <- input$cp_use_ft_model
|
|
|
|
newconf$use_sb <- input$cp_use_sb
|
|
newconf$use_sb_model <- input$cp_use_sb_model
|
|
|
|
writeLines(RJSONIO::toJSON(newconf),
|
|
paste0("tigger_", newconf$projectid, ".json"))
|
|
|
|
values$confnames <- c(newconf$projectid, values$confnames)
|
|
values$conf <- newconf
|
|
|
|
## On new data import, write a feather file with the name of the project
|
|
if (input$cpDoImport)
|
|
arrow::write_feather(values$cpNewData, paste0(
|
|
newconf$datadir, newconf$dataname, ".feather"
|
|
))
|
|
|
|
removeModal()
|
|
})
|
|
|
|
##############################################################################
|
|
## Scheme management
|
|
##############################################################################
|
|
|
|
## Print active scheme in scheme management panel
|
|
output$printScheme <- renderUI(h4(input$selectScheme))
|
|
|
|
## Create new scheme on request, with modal dialog
|
|
observeEvent(input$createScheme, {
|
|
if (verbose)
|
|
cat("DEBUG create scheme\n")
|
|
showModal(modalDialog(
|
|
title = "Create tagging scheme",
|
|
p(paste0("This will create a new scheme for this project")),
|
|
|
|
textInput("newScheme", label = NULL, placeholder = "Required: new scheme name"),
|
|
textAreaInput("newSchemeDescr", label = NULL,
|
|
placeholder = "Optional: scheme description"),
|
|
checkboxInput("schemeDuplicate", "Duplicate existing scheme:"),
|
|
conditionalPanel(
|
|
"input.schemeDuplicate",
|
|
selectInput("schemeDuplicateFrom", NULL, rev(values$conf$tagcols))),
|
|
|
|
footer = tagList(actionButton("createSchemeConfirm", "Create"),
|
|
modalButton("Cancel"))))
|
|
})
|
|
|
|
observeEvent(input$createSchemeConfirm, {
|
|
if (is.null(ok.data())) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG create scheme event\n")
|
|
|
|
## Make sure new scheme name is a correct file name
|
|
if (!grepl("\\S", input$newScheme)) {
|
|
showNotification(type = "error",
|
|
"Cannot create scheme: name empty.")
|
|
return(NULL)
|
|
}
|
|
|
|
## Check that new scheme name doesn't exist
|
|
## Re-read tagcols from conf file, to prevent scheme disappearances
|
|
tmpname <- cleanFileName(input$newScheme)
|
|
tagpath <- paste0(values$projectdir, tmpname, ".csv")
|
|
confpath <- paste0("tigger_", values$conf$projectid, ".json")
|
|
if (verbose)
|
|
cat("DEBUG create scheme check json:", confpath,"\n")
|
|
tmp_tagcols <- RJSONIO::fromJSON(confpath)$tagcols
|
|
if (verbose)
|
|
cat("DEBUG create scheme json OK\n")
|
|
if (tmpname %in% tmp_tagcols | file.exists(tagpath)) {
|
|
showNotification(type = "error",
|
|
"Cannot create scheme: name already exists.")
|
|
return(NULL)
|
|
}
|
|
|
|
## Create new scheme description
|
|
if (nchar(input$newSchemeDescr))
|
|
writeLines(input$newSchemeDescr,
|
|
paste0(values$projectdir, tmpname, ".txt"))
|
|
|
|
## Update conf file and reactives
|
|
values$conf$tagcols <- c(tmp_tagcols, tmpname)
|
|
# values$confs[[values$conf$projectid]]$tagcols <- c(tmp_tagcols, tmpname)
|
|
writeLines(RJSONIO::toJSON(values$conf), confpath)
|
|
|
|
if (input$schemeDuplicate) {
|
|
tmpmat <- matrix(values$tagmat[, input$schemeDuplicateFrom])
|
|
tmpmathist <- matrix(values$tagmathist[, input$schemeDuplicateFrom])
|
|
} else {
|
|
tmpmat <- matrix(rep(NA, nrow(ok.data())))
|
|
tmpmathist <- matrix(rep(NA, nrow(ok.data())))
|
|
}
|
|
colnames(tmpmat) <- tmpname
|
|
colnames(tmpmathist) <- tmpname
|
|
|
|
values$tagmat <- cbind(values$tagmat, tmpmat)
|
|
values$tagmathist <- cbind(values$tagmat, tmpmathist)
|
|
|
|
## Create new tagging file if duplicating
|
|
if (input$schemeDuplicate) {
|
|
export <- data.frame(ok.data()[, values$conf$idcol],
|
|
values$tagmat[, tmpname])
|
|
colnames(export) <- c(values$conf$idcol, tmpname)
|
|
export <- na.omit(export)
|
|
write.table(export, tagpath, sep = ",", qmethod = "double",
|
|
fileEncoding = "UTF-8", row.names = FALSE,
|
|
append = FALSE, col.names = TRUE)
|
|
}
|
|
|
|
cat("DEBUG create scheme exit\n")
|
|
removeModal()
|
|
})
|
|
|
|
## Button action: delete scheme
|
|
observeEvent(input$schemeDelete, {
|
|
if (verbose)
|
|
cat("DEBUG delete scheme\n")
|
|
if (length(values$conf$tagcols) < 2) {
|
|
showNotification(type = "error",
|
|
"Cannot delete: at least one scheme must remain.")
|
|
return(NULL)
|
|
}
|
|
showModal(modalDialog(
|
|
title = "Delete tagging scheme",
|
|
paste0("Confirm delete '", input$selectScheme,
|
|
"': ", sum(!is.na(values$label)), " tags will be deleted",
|
|
", along with scheme description."),
|
|
footer = tagList(actionButton("schemeDeleteConfirm", "Delete"),
|
|
modalButton("Cancel"))))
|
|
})
|
|
|
|
observeEvent(input$schemeDeleteConfirm, {
|
|
file.remove(paste0(values$projectdir, input$selectScheme, ".csv"))
|
|
file.remove(paste0(values$projectdir, input$selectScheme, ".txt"))
|
|
file.remove(paste0(values$projectdir, input$selectScheme, "_regex.json"))
|
|
values$conf$tagcols <-
|
|
values$conf$tagcols[values$conf$tagcols != input$selectScheme]
|
|
writeLines(RJSONIO::toJSON(values$conf),
|
|
paste0("tigger_", input$selectProject, ".json"))
|
|
removeModal()
|
|
})
|
|
|
|
|
|
observeEvent(input$schemeDescrSave, {
|
|
req(input$selectScheme)
|
|
writeLines(input$schemeDescr,
|
|
paste0(values$conf$datadir, values$conf$projectid,
|
|
"/", input$selectScheme, ".txt"))
|
|
})
|
|
|
|
|
|
##############################################################################
|
|
##############################################################################
|
|
|
|
## Tag selection : populate
|
|
observe({
|
|
values$conf$tagcols
|
|
updateSelectInput(
|
|
# session, "selectScheme", choices = c(rev(values$conf$tagcols), "<NEW>"))
|
|
session, "selectScheme", choices = rev(values$conf$tagcols))
|
|
})
|
|
|
|
|
|
## Populate oracle buttons
|
|
output$oracleButtons <- renderUI({
|
|
if (is.null(ok.data())) return(NULL)
|
|
# if (is.null(values$label)) return(NULL)
|
|
if (is.null(values$uniqueLabels)) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG populate oracle buttons\n")
|
|
|
|
do.call(fluidRow, lapply(values$uniqueLabels, function(ilab)
|
|
actionButton(paste0("oracle_", label2hash(ilab)),
|
|
strong(ilab))))
|
|
})
|
|
|
|
## Populate maxprob variable selector
|
|
observe({
|
|
updateSelectInput(session, "maxprobWhich", choices = values$uniqueLabels)
|
|
updateSelectInput(session, "taggedWhich",
|
|
choices = c("All" = "all", values$uniqueLabels))
|
|
})
|
|
|
|
## Data panel message
|
|
observeEvent(ok.data(), {
|
|
if (verbose)
|
|
cat("DEBUG data panel message\n")
|
|
if (is.null(ok.data())) {
|
|
output$dataMessage <- renderUI(p("Importing data..."))
|
|
}
|
|
output$dataMessage <- NULL
|
|
})
|
|
|
|
## On config change, update dataView and retag options
|
|
observeEvent(list(values$conf), {
|
|
|
|
if (is.null(values$conf)) return(NULL)
|
|
output$panelData <- renderUI(list(
|
|
DT::dataTableOutput("dataView")
|
|
))
|
|
|
|
output$panelRetag <- renderUI(c(
|
|
list(
|
|
br(),
|
|
h4("Rename tags"),
|
|
fluidRow(
|
|
column(4, strong("Current")),
|
|
column(2, strong("Count")),
|
|
column(6, strong("New"))
|
|
),
|
|
br()),
|
|
lapply(values$uniqueLabels, function(iLab) {
|
|
iHash <- label2hash(iLab)
|
|
fluidRow(
|
|
column(4, p(iLab)),
|
|
column(2, p(sum(values$label == iLab, na.rm = TRUE))),
|
|
column(4, textInput(
|
|
paste0("newtag_", iHash), NULL,
|
|
placeholder = "(new name, leave empty to untag)")),
|
|
column(2, actionButton(paste0("retag_", iHash), "Rename")))
|
|
})
|
|
))
|
|
})
|
|
|
|
output$panelExtraRegex <- renderUI(list(
|
|
p(strong("Regex predictors")),
|
|
fluidRow(
|
|
column(8, textInput("extraRegexText", NULL,
|
|
placeholder = "(new regex)", width = "100%")),
|
|
column(4, actionButton(
|
|
"extraRegexSearch", strong("+"), width = "100%"))
|
|
),
|
|
fluidRow(
|
|
style="overflow-y:scroll; max-height: 25vh",
|
|
fluidRow(
|
|
column(2, strong("")),
|
|
column(1, strong("Use")),
|
|
column(1, strong("Case")),
|
|
column(1, p(strong("N"))),
|
|
column(7, p(strong("Regex")))
|
|
),
|
|
|
|
lapply(values$extraRegex, function(iRegex) {
|
|
iHash <- label2hash(iRegex)
|
|
tmp_cased <- values[[paste0("caseregex_", iHash)]]
|
|
if (is.null(tmp_cased)) tmp_cased <- FALSE
|
|
fluidRow(
|
|
column(2, actionButton(paste0("delregex_", iHash), "🗑️", width="100%")),
|
|
column(1, checkboxInput(
|
|
paste0("useregex_", iHash), NULL,
|
|
value = isolate(!isFALSE(values[[paste0("useregex_", iHash)]])))),
|
|
column(1, checkboxInput(
|
|
paste0("caseregex_", iHash), NULL,
|
|
value = isolate(isTRUE(values[[paste0("caseregex_", iHash)]])))),
|
|
column(1, br(), p(sum(
|
|
stringi::stri_detect_regex(
|
|
ok.nicetext(), iRegex,
|
|
opts_regex = list(case_insensitive = !tmp_cased)),
|
|
na.rm = TRUE))),
|
|
column(7, br(), p(iRegex))
|
|
)
|
|
})
|
|
)
|
|
|
|
))
|
|
|
|
## Process new regex
|
|
observeEvent(input$extraRegexSearch, {
|
|
if (is.null(ok.nicetext())) return(NULL)
|
|
req(nchar(input$extraRegexText) > 0)
|
|
if (input$extraRegexText %in% values$extraRegex) return(NULL)
|
|
try_regex <- try(stringi::stri_detect_regex(
|
|
ok.nicetext(), input$extraRegexText,
|
|
opts_regex = list(case_insensitive = TRUE)))
|
|
if (inherits(try_regex, "try-error")) return(NULL)
|
|
new_regex <- input$extraRegexText
|
|
new_hash <- label2hash(new_regex)
|
|
values$extraRegex <- c(new_regex, values$extraRegex)
|
|
names(values$extraRegex)[1] <- new_hash
|
|
if (verbose)
|
|
cat("DEBUG regex search", input$extraRegexText, "\n")
|
|
})
|
|
|
|
## Regex predictors: populate delete and use events on first creation
|
|
useregex_trigger <- reactiveVal(0)
|
|
delregex_trigger <- reactiveVal(0)
|
|
caseregex_trigger <- reactiveVal(0)
|
|
observeEvent(list(values$extraRegex), {
|
|
if (!length(values$extraRegex)) return(NULL)
|
|
if (any(! values$extraRegex %in% values$extraRegexHist)) {
|
|
if (verbose)
|
|
cat("DEBUG regex predictor names updates\n")
|
|
tmpregex <- values$extraRegex[! values$extraRegex %in% values$extraRegexHist]
|
|
values$extraRegexHist <- c(tmpregex, values$extraRegexHist)
|
|
|
|
c(lapply(1:length(tmpregex), function(iregex) {
|
|
observeEvent(
|
|
input[[paste0("delregex_", names(tmpregex)[iregex])]], {
|
|
if (verbose)
|
|
cat("DEBUG regex delete", names(tmpregex)[iregex], "\n")
|
|
values$extraRegex <- values$extraRegex[values$extraRegex != tmpregex[iregex]]
|
|
delregex_trigger(delregex_trigger() + 1)
|
|
})
|
|
}),
|
|
lapply(1:length(tmpregex), function(iregex) {
|
|
tmpname <- paste0("useregex_", names(tmpregex)[iregex])
|
|
observeEvent(
|
|
input[[tmpname]], {
|
|
values[[tmpname]] <- input[[tmpname]]
|
|
useregex_trigger(useregex_trigger() + 1)
|
|
})
|
|
}),
|
|
lapply(1:length(tmpregex), function(iregex) {
|
|
tmpname <- paste0("caseregex_", names(tmpregex)[iregex])
|
|
observeEvent(
|
|
input[[tmpname]], {
|
|
values[[tmpname]] <- input[[tmpname]]
|
|
caseregex_trigger(caseregex_trigger() + 1)
|
|
})
|
|
})
|
|
)
|
|
}
|
|
})
|
|
|
|
observeEvent(list(delregex_trigger(), useregex_trigger(), caseregex_trigger()), {
|
|
req(ok.data(), input$selectScheme)
|
|
regex_all <- values$extraRegex
|
|
values$regex_inuse <- sapply(names(regex_all), function(iname)
|
|
values[[paste0("useregex_", iname)]])
|
|
values$regex_case <- sapply(names(regex_all), function(iname)
|
|
values[[paste0("caseregex_", iname)]])
|
|
if (verbose) if (any(values$regex_inuse))
|
|
cat("DEBUG regex in use", paste0(collapse = " ", regex_all[values$regex_inuse]), "\n")
|
|
writeLines(
|
|
RJSONIO::toJSON(lapply(FUN = unname, list(
|
|
regex = regex_all, use = values$regex_inuse, case = values$regex_case))),
|
|
paste0(values$projectdir, input$selectScheme, "_regex.json"))
|
|
})
|
|
|
|
output$dataView <- DT::renderDataTable({
|
|
# if (is.null(ok.text()) | ok.data.running()) return(NULL)
|
|
req(ok.text())
|
|
if (verbose)
|
|
cat("DEBUG enter dataView\n")
|
|
if (verbose)
|
|
cat("DEBUG render dataView\n")
|
|
DT::datatable(
|
|
rownames = F,
|
|
data.frame(
|
|
row = 1:nrow(ok.data()),
|
|
id = ok.data()[, values$conf$idcol],
|
|
text = ok.text()),
|
|
options = list(
|
|
pageLength = 3,
|
|
columnDefs = list(list(
|
|
targets = 2,
|
|
render = DT::JS(
|
|
"function(data, type, row, meta) {",
|
|
"return type === 'display' && data.length > 200 ?",
|
|
"'<span title=\"' + data + '\">' + data.substr(0, 200) + '...</span>' : data;",
|
|
"}")
|
|
))
|
|
),
|
|
callback = DT::JS('table.page(0).draw(false);')
|
|
)
|
|
})
|
|
|
|
## Triggers for mass rename, created with each new label, with confirm
|
|
observeEvent(values$uniqueLabelsAll, {
|
|
if (is.null(values$uniqueLabelsAll)) return(NULL)
|
|
notthere <- unique(na.omit(
|
|
values$uniqueLabelsAll[! values$uniqueLabelsAll %in% values$retagLabels]))
|
|
lapply(
|
|
notthere,
|
|
function(iTag) {
|
|
iHash <- label2hash(iTag)
|
|
|
|
observeEvent(input[[paste0("retag_", iHash)]], {
|
|
tmp_oldtag <- iTag
|
|
tmp_retagged <- which(values$label == tmp_oldtag)
|
|
tmp_newtag <- gsub(
|
|
"^\\s+|\\s+$", "", input[[paste0("newtag_", iHash)]])
|
|
showModal(modalDialog(
|
|
title = "Mass retag",
|
|
paste0("Confirm retag: ", length(tmp_retagged), " ",
|
|
tmp_oldtag, " tags will be ",
|
|
ifelse(nchar(tmp_newtag),
|
|
paste("renamed to", tmp_newtag) , "deleted")),
|
|
footer = tagList(actionButton(paste0("retag_confirm_", iTag), "Retag"),
|
|
modalButton("Cancel"))))
|
|
})
|
|
|
|
observeEvent(input[[paste0("retag_confirm_", iTag)]], {
|
|
tmp_oldtag <- iTag
|
|
tmp_retagged <- which(values$label == tmp_oldtag)
|
|
tmp_newtag <- gsub(
|
|
"^\\s+|\\s+$", "", input[[paste0("newtag_", iHash)]])
|
|
if (!nchar(tmp_newtag)) tmp_newtag <- NA
|
|
values$tagTrigger <- list(
|
|
id = ok.data()[[values$conf$idcol]][tmp_retagged],
|
|
tag = rep(tmp_newtag, length(tmp_retagged)))
|
|
values$queries <- c(values$queries, tmp_retagged)
|
|
|
|
removeModal()
|
|
})
|
|
|
|
})
|
|
values$retagLabels <- c(values$retagLabels, notthere)
|
|
})
|
|
|
|
|
|
|
|
##############################################################################
|
|
## UI rendering of Panel Tagging / Visualization
|
|
##############################################################################
|
|
|
|
####################
|
|
## Tagging left panel
|
|
|
|
|
|
# ## Trigger from Oops
|
|
# observeEvent(input$oops, {
|
|
# if (is.null(ok.data()))
|
|
# return(NULL)
|
|
# if (verbose)
|
|
# cat("DEBUG enter Oops\n")
|
|
# if (!is.null(values$retagged)) if (values$queries[length(values$queries)] == values$retagged[length(values$retagged)])
|
|
# values$retagged <- values$retagged[-length(values$retagged)]
|
|
# values$label[values$queries[length(values$queries)]] <- NA
|
|
# if (ok.commentCol() != "(None)")
|
|
# values$comment[values$queries[length(values$queries)]] <- ok.data()[values$queries[length(values$queries)], ok.commentCol()]
|
|
# values$queries <- values$queries[-length(values$queries)]
|
|
# ## tagTrigger ?
|
|
#
|
|
# ready2tag(0)
|
|
# queryNext(queryNext() + 1)
|
|
# })
|
|
|
|
|
|
## Tagging triggers for Oracle buttons, created with each new label
|
|
observeEvent(values$uniqueLabelsAll, {
|
|
if (is.null(values$label)) return(NULL)
|
|
if (is.null(values$uniqueLabelsAll)) return(NULL)
|
|
if (all(is.na(values$label))) return(NULL)
|
|
notthere <- unique(na.omit(
|
|
values$uniqueLabelsAll[! values$uniqueLabelsAll %in% values$oracleLabels]
|
|
))
|
|
if (!length(notthere)) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG triggers for oracle buttons\n")
|
|
lapply(
|
|
notthere,
|
|
function(iLab) {
|
|
observeEvent(
|
|
input[[paste0("oracle_", label2hash(iLab))]], {
|
|
if (is.null(ok.text())) return(NULL)
|
|
if (is.null(values$newQuery)) return(NULL)
|
|
if (!ready2tag()) {cat("DEBUG not ready to tag in Button\n"); return(NULL)}
|
|
# ready2tag(0)
|
|
# if (input$allowRetag | sum(is.na(values$label)) == 0)
|
|
if (!is.na(values$label[values$lastQuery]))
|
|
values$retagged <- c(values$retagged, values$lastQuery)
|
|
# values$label[values$lastQuery] <- iLab
|
|
values$comment[values$lastQuery] <- input$currentComment
|
|
# values$queries <- c(values$queries, values$lastQuery)
|
|
values$tagTrigger <- list(
|
|
id = ok.data()[values$lastQuery, values$conf$idcol],
|
|
tag = iLab,
|
|
comment = input$currentComment)
|
|
})
|
|
})
|
|
values$oracleLabels <- c(values$oracleLabels, notthere)
|
|
})
|
|
|
|
## Trigger from Oracle Create value button
|
|
observeEvent(input$currentAction, {
|
|
if (is.null(ok.data())) return(NULL)
|
|
if (is.null(values$newQuery)) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG enter create value\n")
|
|
# if (input$allowRetag | sum(is.na(values$label)) == 0)
|
|
if (!is.na(values$label[values$lastQuery]))
|
|
values$retagged <- c(values$retagged, values$lastQuery)
|
|
if (input$newLab == "") {
|
|
return(NULL)
|
|
} else {
|
|
# values$label[values$lastQuery] <- input$newLab
|
|
updateTextInput(session, "newLab", value= "")
|
|
}
|
|
values$comment[values$lastQuery] <- input$currentComment
|
|
# values$queries <- c(values$queries, values$lastQuery)
|
|
values$tagTrigger <- list(
|
|
id = ok.data()[values$lastQuery, values$conf$idcol],
|
|
tag = input$newLab,
|
|
comment = input$currentComment)
|
|
})
|
|
|
|
## Trigger from Oracle Confirm button
|
|
observeEvent(input$oracleConfirm, {
|
|
req(ok.data(), ok.train(), values$newQuery)
|
|
# if (is.null(ok.data())) return(NULL)
|
|
# if (is.null(values$newQuery)) return(NULL)
|
|
if (!ready2tag()) {cat("DEBUG not ready to tag in OC\n"); return(NULL)}
|
|
# ready2tag(0)
|
|
if (!ok.train.possible()) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG oracle confirm\n")
|
|
# if (input$allowRetag | sum(is.na(values$label)) == 0)
|
|
if (!is.na(values$label[values$lastQuery]))
|
|
values$retagged <- c(values$retagged, values$lastQuery)
|
|
# values$label[values$lastQuery] <- ok.predlab1()[values$lastQuery]
|
|
# values$queries <- c(values$queries, values$lastQuery)
|
|
values$comment[values$lastQuery] <- input$currentComment
|
|
values$tagTrigger <- list(
|
|
id = ok.data()[values$lastQuery, values$conf$idcol],
|
|
tag = ok.predlab1()[values$lastQuery],
|
|
comment = input$currentComment)
|
|
})
|
|
|
|
## Trigger for CV glm (async)
|
|
glmCV_nclicks <- reactiveVal(0)
|
|
observeEvent(input$glmCV, {
|
|
if (is.null(ok.predictor())) return(NULL)
|
|
if (glmCV_nclicks() != 0) {
|
|
showNotification("LASSO CV already running")
|
|
return(NULL)
|
|
}
|
|
glmCV_nclicks(1)
|
|
glmCV_future <- reactiveVal()
|
|
|
|
tmpvalues <- values$label
|
|
tmppred <- ok.predictor()
|
|
for (ival in na.omit(unique(tmpvalues)))
|
|
if (sum(tmpvalues == ival, na.rm = T) <= 8)
|
|
tmpvalues[which(tmpvalues == ival)] <- NA
|
|
glmCV_async <- future(seed = TRUE, {
|
|
glmnet::cv.glmnet(
|
|
x= tmppred[!is.na(tmpvalues), ],
|
|
y= as.factor(tmpvalues[!is.na(tmpvalues)]),
|
|
family= "multinomial")
|
|
}) %...>% glmCV_future()
|
|
|
|
glmCV_async <- catch(glmCV_async, function(e) {
|
|
showNotification(type = "error", paste0("LASSO CV error: ", e))
|
|
})
|
|
glmCV_async <- finally(glmCV_async, function() {
|
|
glmCV_nclicks(0)
|
|
if (is.null(glmCV_future())) return(NULL)
|
|
updateNumericInput(session, "glmLambda",
|
|
value = glmCV_future()$lambda.min)
|
|
})
|
|
NULL
|
|
})
|
|
|
|
## Trigger for CV liblinear (async)
|
|
liblinCV_nclicks <- reactiveVal(0)
|
|
observeEvent(input$liblinCV, {
|
|
if (is.null(ok.predictor())) return(NULL)
|
|
if (liblinCV_nclicks() != 0) {
|
|
showNotification("LibLineaR CV already running")
|
|
return(NULL)
|
|
}
|
|
liblinCV_nclicks(1)
|
|
liblinCV_future <- reactiveVal()
|
|
|
|
tmpvalues <- values$label
|
|
tmppred <- ok.predictor()
|
|
for (ival in na.omit(unique(tmpvalues)))
|
|
if (sum(tmpvalues == ival, na.rm = T) <= 3)
|
|
tmpvalues[which(tmpvalues == ival)] <- NA
|
|
|
|
liblinCV_async <- future(seed = TRUE, {
|
|
LiblineaR::LiblineaR(
|
|
data= tmppred[!is.na(tmpvalues), ],
|
|
target= as.factor(tmpvalues[!is.na(tmpvalues)]),
|
|
type= 0, findC= T)
|
|
}) %...>% liblinCV_future()
|
|
liblinCV_async <- catch(liblinCV_async, function(e) {
|
|
showNotification(type = "error", paste0("LibLineaR CV error: ", e))
|
|
})
|
|
liblinCV_async <- finally(liblinCV_async, function() {
|
|
liblinCV_nclicks(0)
|
|
if (is.null(liblinCV_future())) return(NULL)
|
|
updateNumericInput(session, "liblinCost", value= liblinCV_future())
|
|
})
|
|
NULL
|
|
})
|
|
|
|
|
|
output$currentContext <- renderUI({
|
|
if (verbose)
|
|
cat("DEBUG 1rentContext\n")
|
|
if ((! is.null(ok.text())) & (length(ok.contextCol()) > 0))
|
|
HTML(paste(paste(ok.contextCol(),
|
|
as.character(ok.data()[values$newQuery, ok.contextCol()]),
|
|
sep = " : "),
|
|
collapse= "<br/><br/>"))
|
|
})
|
|
|
|
output$makeOracleConfirm <- renderUI({
|
|
if (verbose)
|
|
cat("DEBUG update printPredicted\n")
|
|
if (is.null(ok.pred())) {
|
|
tmp <- "No prediction"
|
|
} else if (is.null(values$newQuery)) {
|
|
tmp <- "No query"
|
|
} else {
|
|
tmp <- paste0(
|
|
ifelse(is.na(values$label[values$newQuery]), "", "Pred: "),
|
|
ok.predlab1()[values$newQuery],
|
|
" (", round(max(ok.pred()[values$newQuery, ]), 3), ")")
|
|
}
|
|
res <- list(actionButton("oracleConfirm", label= paste("🤖", tmp), width = "100%"))
|
|
if (!is.null(values$label) & !is.null(values$newQuery)) {
|
|
if (!is.na(values$label[values$newQuery]))
|
|
res <- list(res[[1]], HTML(paste0(
|
|
"<center><strong> Current: ", values$label[values$newQuery],
|
|
"</strong></center>")))
|
|
}
|
|
res
|
|
})
|
|
|
|
|
|
## Show training diagnostics on new model train
|
|
output$trainDiagno <-
|
|
renderText(paste0(ok.msgtagged(), "\n", values$modelDiagno))
|
|
|
|
## Diagnostics event
|
|
observeEvent(diagTrigger(), {
|
|
if (verbose)
|
|
cat("DEBUG update modelDiagno\n")
|
|
if (is.null(ok.data())) {
|
|
values$modelDiagno <- "No model"
|
|
return(NULL)
|
|
}
|
|
if (!ok.train.possible()) {
|
|
values$modelDiagno <- "No model (not enough labelled data)."
|
|
return(NULL)
|
|
}
|
|
|
|
if (input$predModel == "random forest") {
|
|
tmp <- paste0(
|
|
"Train Accuracy: ",
|
|
round(100 * mean(ok.predlab1()[!is.na(values$label)] ==
|
|
values$label[!is.na(values$label)]), 1),
|
|
"% ; Wtd. F1: ",
|
|
sprintf("%f", round(wtdF1(values$label[!is.na(values$label)],
|
|
ok.predlab1()[!is.na(values$label)]), 3)),
|
|
"%\nOOB Accuracy : ",
|
|
round(100 * mean(
|
|
colnames(ok.train()$predictions)[apply(ok.train()$predictions, 1, which.max)] ==
|
|
values$label[!is.na(values$label)]), 1),
|
|
"% ; Wtd. F1: ",
|
|
sprintf("%.3f", wtdF1(
|
|
values$label[!is.na(values$label)],
|
|
colnames(ok.train()$predictions)[apply(ok.train()$predictions, 1, which.max)]))
|
|
)
|
|
} else if (input$predModel %in% c("lasso", "linear", "naive bayes", "knn")) {
|
|
tmp <- paste0(
|
|
"Train Accuracy: ",
|
|
round(100 * mean(ok.predlab1()[!is.na(values$label)] ==
|
|
values$label[!is.na(values$label)]), 1),
|
|
"% ; Wtd. F1: ",
|
|
sprintf("%.3f", wtdF1(
|
|
values$label[!is.na(values$label)],
|
|
ok.predlab1()[!is.na(values$label)])))
|
|
}
|
|
values$modelDiagno <- tmp
|
|
})
|
|
|
|
## Update comment input field
|
|
observeEvent(values$newQuery, {
|
|
if (is.null(ok.text())) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG update comment field\n")
|
|
updateTextInput(session, "currentComment",
|
|
value = values$comment[values$newQuery])
|
|
})
|
|
|
|
|
|
## Save event: tag + comment in dedicated csv
|
|
observeEvent(values$tagTrigger, {
|
|
if (is.null(values$tagTrigger)) return(NULL)
|
|
if (verbose)
|
|
cat("DEBUG enter event tagTrigger", length(values$tagTrigger$id), "\n")
|
|
ready2tag(0) # Prevent new tagging until next query
|
|
dapath <- paste0(values$projectdir, ok.labelcol(), ".csv")
|
|
darows <- match(values$tagTrigger$id, ok.data()[, values$conf$idcol])
|
|
|
|
export <- data.frame(values$tagTrigger$id, values$tagTrigger$tag)
|
|
colnames(export) <- c(values$conf$idcol, ok.labelcol())
|
|
if (verbose)
|
|
cat("DEBUG tagTrigger tag",
|
|
paste(export[, 1], export[, 2], collapse = " ; "), "\n")
|
|
write.table(export, dapath, sep = ",", qmethod = "double",
|
|
fileEncoding = "UTF-8", row.names = F,
|
|
append = ifelse(file.exists(dapath), T, F),
|
|
col.names = ifelse(file.exists(dapath), F, T))
|
|
|
|
if (any(nchar(values$tagTrigger$comment))) {
|
|
tmp_filter <- which(nchar(values$tagTrigger$comment) > 0)
|
|
dapath <- paste0(values$projectdir, values$conf$commcol, ".csv")
|
|
export <- data.frame(values$tagTrigger$id[tmp_filter],
|
|
values$tagTrigger$comment[tmp_filter])
|
|
colnames(export) <- c(values$conf$idcol, values$conf$commcol)
|
|
if (verbose)
|
|
cat("DEBUG tagTrigger comment", export[1,1], export[1, 2])
|
|
write.table(export, dapath, sep = ",", qmethod = "double",
|
|
fileEncoding = "UTF-8", row.names = F,
|
|
append = ifelse(file.exists(dapath), T, F),
|
|
col.names = ifelse(file.exists(dapath), F, T))
|
|
}
|
|
|
|
## Update label hist
|
|
values$labelhist[match(values$tagTrigger$id, ok.data()[, values$conf$idcol])] <-
|
|
max(values$labelhist, na.rm = T) + 1
|
|
## Update wasTagged and wasRetagged
|
|
itag <- match(values$tagTrigger$id, ok.data()[, values$conf$idcol])
|
|
if (input$sampleChoice == "untagged") {
|
|
values$wasTagged[itag] <- TRUE
|
|
} else if (input$sampleChoice == "tagged") {
|
|
values$wasRetagged[itag] <- TRUE
|
|
} else if (input$sampleChoice == "all") {
|
|
if (is.na(values$label[itag])) {
|
|
values$wasTagged[itag] <- TRUE
|
|
} else
|
|
values$wasRetagged[itag] <- TRUE
|
|
}
|
|
|
|
## Call queryNext event, or launch training
|
|
if (trainCountdown() == 1) {
|
|
trainCountdown(input$trainCountdown)
|
|
trainTrigger(trainTrigger() + 1)
|
|
} else if (trainCountdown() > 1) {
|
|
trainCountdown(trainCountdown() - 1)
|
|
queryNext(queryNext() + 1)
|
|
} else {
|
|
queryNext(queryNext() + 1)
|
|
}
|
|
|
|
## Update values$label etc
|
|
values$label[darows] <- values$tagTrigger$tag
|
|
values$queries <- c(values$queries, darows)
|
|
|
|
if (verbose)
|
|
cat("DEBUG exit event tagTrigger", nrow(export), "rows\n")
|
|
})
|
|
|
|
|
|
####################
|
|
## Tagging main panel
|
|
|
|
output$textVisuCols <- renderUI({
|
|
if (verbose)
|
|
cat("DEBUG render text/visu panel\n")
|
|
leftsize <- 6
|
|
if (!input$panelText) leftsize <- 1
|
|
if (input$panelText & !input$panelVisu) leftsize <- 11
|
|
|
|
fluidRow(
|
|
column(
|
|
leftsize,
|
|
conditionalPanel(
|
|
"input.panelText",
|
|
wellPanel(htmlOutput("currentText"))
|
|
)
|
|
),
|
|
column(
|
|
12 - leftsize,
|
|
conditionalPanel(
|
|
"input.panelVisu",
|
|
fluidRow(
|
|
column(2, HTML(paste0('<div title="Compute new visualization">',
|
|
actionButton("visuCompute", "🎲"),
|
|
'</div>'))),
|
|
column(2, HTML(paste0('<div title="Zoom out/into selected area">',
|
|
actionButton("visuGoZoom", "🔍±"),
|
|
'</div>'))),
|
|
column(2, HTML(paste0('<div title="Query only from zoom area">',
|
|
checkboxInput("visuLock", "🔒", value = FALSE),
|
|
'</div>'))),
|
|
column(2, HTML(paste0('<div title="Visualization options">',
|
|
checkboxInput("visuOptions", "🔧"),
|
|
'</div>'))),
|
|
column(3, HTML(paste0('<div title="Plot size">',
|
|
numericInput("visuHeight", NULL, 400, 20, 2e12, 10),
|
|
'</div>')))
|
|
),
|
|
conditionalPanel(
|
|
'input.visuOptions',
|
|
flowLayout(
|
|
selectInput(
|
|
"visuAlgo", "Visu. method", c("umap", "t-sne"), "umap", width = "100%"),
|
|
selectizeInput(
|
|
"visuSource", "Visu. source",
|
|
c("Word counts (DFM)" = "dfm",
|
|
"Word embeddings (FastText)" = "ft",
|
|
"Sentence embeddings (SBERT)" = "sb",
|
|
"BERT predictions" = "bertpred",
|
|
"Regex" = "regex"),
|
|
c("sb", "ft"), multiple = TRUE)
|
|
)
|
|
),
|
|
conditionalPanel( # umap options
|
|
'input.visuAlgo == "umap" & input.visuOptions',
|
|
flowLayout(
|
|
numericInput(
|
|
"umapNeighb", "Nb. Neighbors", 15, 1, 500, 1),
|
|
numericInput(
|
|
"umapSpread", "Spread", 1, 0, 16, 1e-2),
|
|
numericInput(
|
|
"umapMindist", "Min dist.", .001, 0, 16, 1e-3),
|
|
selectInput(
|
|
"umapMetric", "Metric", selected = "cosine",
|
|
c("euclidean", "cosine", "manhattan", "hamming",
|
|
"correlation", "categorical")
|
|
)
|
|
)
|
|
),
|
|
conditionalPanel( # t-SNE options
|
|
'input.visuAlgo == "t-sne" & input.visuOptions',
|
|
flowLayout(
|
|
numericInput(
|
|
"tsnePerplex", "Perplexity", 15, 1, 500, 1),
|
|
numericInput(
|
|
"tsneTheta", "Theta", .5, 0, 1, 1e-2),
|
|
numericInput(
|
|
"tsnePcaDim", "PCA dims", 50, 1, 100, 1)
|
|
)
|
|
),
|
|
uiOutput("visuMsg"),
|
|
plotOutput(
|
|
"visuPlot", width = "100%",
|
|
dblclick = "visuDblclick",
|
|
brush = brushOpts("visuBrush", resetOnNew = T))
|
|
)
|
|
)
|
|
)
|
|
})
|
|
|
|
##################
|
|
## Subpanel "Text"
|
|
##################
|
|
|
|
output$currentText <- renderUI({
|
|
if (verbose)
|
|
cat("DEBUG render currentText\n")
|
|
if (is.null(ok.data()) | is.null(ok.nicetext()))
|
|
return(HTML("Import data to start training."))
|
|
|
|
if (input$strategy %in% c("entropy", "maxprob") & is.null(ok.train()))
|
|
return(HTML("<em>No model: train one, or try 'random' or 'sequential' strategy</em>"))
|
|
|
|
if (is.null(values$newQuery))
|
|
return(HTML("<em>No query</em>"))
|
|
|
|
bastext <- ok.nicetext()[values$newQuery]
|
|
if (nchar(input$regexFilter) > 0)
|
|
bastext <- gsub(paste0("(", isolate(input$regexFilter), ")"),
|
|
"<b>\\1</b>", bastext, ignore.case = isolate(!input$regexCaseSens))
|
|
baslen <- nchar(bastext)
|
|
if (!length(baslen)) {
|
|
if (nchar(input$regexFilter) > 0)
|
|
return(HTML("<b><em>Regex filter: no match</em></b>"))
|
|
return(HTML("<b><em>No text matches the filters</em></b>"))
|
|
}
|
|
if (is.na(baslen))
|
|
return(HTML("<em>No query</em>"))
|
|
if (baslen > 1200) {
|
|
bastext <- paste0(substring(bastext, 1, 1200), '<em title="> 512 tokens (not read by BERT)">',
|
|
substring(bastext, 1201), "</em>")
|
|
}
|
|
bastext <- gsub("\n", "<br/>", bastext)
|
|
HTML(bastext)
|
|
})
|
|
|
|
|
|
|
|
##############################################################################
|
|
## Panel "Visualize"
|
|
##############################################################################
|
|
|
|
output$visuMsg <- renderUI({
|
|
if (!is.null(values$visuMsg))
|
|
# strong(values$visuMsg)
|
|
h5(values$visuMsg, style = "text-align:center")
|
|
})
|
|
|
|
## Compute visualization points (async)
|
|
visu_nclicks <- reactiveVal(0)
|
|
ok.visu <- reactiveVal()
|
|
observe({
|
|
if (!input$panelVisu)
|
|
values$visuGo <- FALSE
|
|
if (input$panelVisu & !values$visuGo)
|
|
values$visuGo <- TRUE
|
|
})
|
|
observeEvent(list(values$visuGo, input$visuCompute), {
|
|
if (is.null(input$visuSource)) return(NULL)
|
|
if (!values$visuGo) return(NULL)
|
|
if (is.null(ok.data())) {
|
|
values$visuMsg <- "No data imported."
|
|
return(NULL)
|
|
}
|
|
|
|
if (visu_nclicks() > 0) {
|
|
values$visuMsg <- "Already computing visualization"
|
|
return(NULL)
|
|
}
|
|
visu_nclicks(1)
|
|
|
|
values$visuMsg <- "Computing visualization..."
|
|
|
|
## Prepare options and objects for async computation
|
|
dasources <- input$visuSource
|
|
daalgo <- input$visuAlgo
|
|
|
|
if (verbose)
|
|
cat("DEBUG compute visu embedding: ", daalgo, paste(dasources, collapse = " "), "\n")
|
|
|
|
visudat <- NULL
|
|
if ("dfm" %in% dasources) dadfm <- ok.dfm()
|
|
if ("ft" %in% dasources) {
|
|
visudat <- ok.data()[, values$cols_ft]
|
|
}
|
|
if ("sb" %in% dasources) {
|
|
if (is.null(visudat)) {
|
|
visudat <- ok.data()[, values$cols_sb]
|
|
} else
|
|
visudat <- cbind(visudat, ok.data()[, values$cols_sb])
|
|
}
|
|
if ("bertpred" %in% dasources) {
|
|
if (is.null(visudat)) {
|
|
visudat <- ok.data()[, do.call(c, values$cols_bertpred)]
|
|
} else
|
|
visudat <- cbind(visudat, ok.data()[, do.call(c, values$cols_bertpred)])
|
|
}
|
|
if ("regex" %in% dasources) {
|
|
if (is.null(visudat)) {
|
|
visudat <- ok.extraRegex.matrix()
|
|
} else
|
|
visudat <- cbind(visudat, ok.extraRegex.matrix())
|
|
}
|
|
if (daalgo == "umap") {
|
|
visu_args <- list(
|
|
n_neighbors = input$umapNeighb, metric = input$umapMetric,
|
|
spread = input$umapSpread, min_dist = input$umapMindist)
|
|
} else if (daalgo == "t-sne") {
|
|
visu_args <- list(
|
|
perplexity = input$tsnePerplex, theta = input$tsneTheta,
|
|
initial_dims = input$tsnePcaDim, check_duplicates = FALSE)
|
|
}
|
|
|
|
visu_async <- future(seed = TRUE, {
|
|
if ("dfm" %in% dasources) {
|
|
## TODO: CA treatment buggy, switch to SVD?
|
|
# da_ca <- quanteda.textmodels::textmodel_ca(
|
|
# quanteda::as.dfm(dadfm), nd = min(100, nrow(dadfm)))
|
|
# da_ca <- (da_ca$rowcoord %*% diag(da_ca$sv))[, !is.na(da_ca$sv)]
|
|
da_ca <- as.matrix(dadfm)
|
|
if (is.null(visudat)) {
|
|
visudat <- da_ca
|
|
} else
|
|
visudat <- cbind(da_ca, visudat)
|
|
}
|
|
|
|
if (daalgo == "umap") {
|
|
do.call(uwot::umap, c(list(visudat), visu_args))
|
|
} else if (daalgo == "t-sne") {
|
|
visudat_dupli <- duplicated(visudat)
|
|
if (any(visudat_dupli))
|
|
visudat[visudat_dupli, ] <- jitter(visudat[visudat_dupli, ])
|
|
do.call(Rtsne::Rtsne, c(list(visudat), visu_args))$Y
|
|
}
|
|
}) %...>% ok.visu()
|
|
|
|
visu_async <- catch(visu_async, function(error) {
|
|
values$visuMsg <- paste0("Error: ", error)
|
|
})
|
|
visu_async <- finally(visu_async, function() {
|
|
visu_nclicks(0)
|
|
if (input$visuGoZoom == 0) {
|
|
values$visuMsg <- "Double-click to select, drag to select zooming zone."
|
|
} else
|
|
values$visuMsg <- NULL
|
|
|
|
nice_choices <- c("FastText" = "ft", "SBERT" = "sb", "visu" = daalgo)
|
|
names(nice_choices)[3] <- ifelse(daalgo == "t-sne", "t-SNE", "UMAP")
|
|
updateSelectInput(
|
|
session, "dlEmbedSelect", choices = nice_choices, selected = daalgo)
|
|
|
|
if (verbose)
|
|
cat("DEBUG Visu async out\n")
|
|
})
|
|
|
|
NULL
|
|
})
|
|
|
|
## Compute visualization plot (async)
|
|
ok.ggvisu <- reactiveVal()
|
|
observe({
|
|
# if (is.null(ok.visu())) return(NULL)
|
|
if (is.null(ok.visu())) {
|
|
ok.ggvisu(NULL)
|
|
return(NULL)
|
|
}
|
|
# if (!isTRUE(values$visugo)) return(NULL)
|
|
if (!input$panelVisu) return(NULL)
|
|
|
|
if (verbose)
|
|
cat("DEBUG compute visu plot\n")
|
|
ggdat <- data.frame(ok.visu(), tag = values$label)
|
|
if (!is.null(ok.predlab1()))
|
|
ggdat$tag[is.na(values$label)] <- ok.predlab1()[is.na(values$label)]
|
|
da_predlabs <- ok.predlab1()
|
|
da_tagged <- ! is.na(values$label)
|
|
da_query <- values$newQuery
|
|
|
|
ggvisu_async <- future({
|
|
ggres <- ggplot(ggdat, aes(X1, X2)) + theme_bw() +
|
|
xlab("") + ylab("") +
|
|
theme(legend.position = "bottom") +
|
|
scale_shape_manual(values = rep(1:8, 40)) # TODO : adapt to tags
|
|
|
|
## Tagged points
|
|
if (any(da_tagged)) {
|
|
ggres <- ggres +
|
|
geom_point(data = ggdat[da_tagged, ],
|
|
aes(X1, X2, color = tag, shape = tag),
|
|
size = 1.5, stroke = 1.5, alpha = .8)
|
|
}
|
|
|
|
## Not tagged points
|
|
if (!is.null(da_predlabs)) {
|
|
ggres <- ggres +
|
|
geom_point(data = ggdat[!da_tagged, ],
|
|
aes(color = tag, shape = tag), show.legend = FALSE)
|
|
} else {
|
|
ggres <- ggres +
|
|
geom_point(alpha = .8, data = ggdat[is.na(ggdat$tag), ])
|
|
}
|
|
|
|
## Current query
|
|
if (!is.null(da_query)) {
|
|
if (is.null(da_predlabs)) {
|
|
ggres <- ggres +
|
|
geom_point(data = ggdat[da_query, ], color = 2,
|
|
stroke = 3, shape = 3, show.legend = FALSE)
|
|
} else {
|
|
ggres <- ggres +
|
|
geom_point(data = ggdat[da_query, ],
|
|
stroke = 3, shape = 3, show.legend = FALSE)
|
|
}
|
|
}
|
|
ggres
|
|
}) %...>% ok.ggvisu()
|
|
|
|
ggvisu_async <- catch(ggvisu_async, function(error) {
|
|
values$visuMsg <- paste0("Error in ggplot: ", error)
|
|
})
|
|
|
|
})
|
|
|
|
observe({
|
|
if (verbose)
|
|
cat("DEBUG update visuPlot\n")
|
|
if (is.null(ok.ggvisu())) {
|
|
values$visuMsg <- "No visualization yet."
|
|
output$visuPlot <- NULL
|
|
values$visuZoom$xlim <- NULL
|
|
values$visuZoom$ylim <- NULL
|
|
return(NULL)
|
|
}
|
|
output$visuPlot <- renderPlot(height = input$visuHeight, {
|
|
# if (is.null(ok.ggvisu())) return(NULL)
|
|
ok.ggvisu() +
|
|
coord_fixed(xlim = values$visuZoom$xlim, ylim = values$visuZoom$ylim)
|
|
})
|
|
})
|
|
|
|
observeEvent(input$visuDblclick, {
|
|
if (!is.null(values$visuMsg))
|
|
values$visuMsg <- NULL
|
|
tmp <- input$visuDblclick
|
|
bmu <- t(ok.visu()) - c(tmp$x, tmp$y)
|
|
bmu <- which.min(colSums(bmu^2))
|
|
values$lastQuery <- bmu
|
|
values$newQuery <- bmu
|
|
ready2tag(1)
|
|
})
|
|
|
|
observeEvent(input$visuGoZoom, {
|
|
if (!is.null(values$visuMsg))
|
|
values$visuMsg <- NULL
|
|
values$visuZoom$xlim <- c(input$visuBrush$xmin, input$visuBrush$xmax)
|
|
values$visuZoom$ylim <- c(input$visuBrush$ymin, input$visuBrush$ymax)
|
|
})
|
|
|
|
|
|
##############################################################################
|
|
## Panel History
|
|
##############################################################################
|
|
|
|
## Create history link and retag events as they appear
|
|
observeEvent(input$histDTable_rows_current, {
|
|
histrows <- order(values$labelhist)
|
|
histrows <- rev(histrows[!is.na(values$labelhist[histrows])])
|
|
histrows <- histrows[!is.na(values$label[histrows])]
|
|
histrows <- histrows[input$histDTable_rows_current]
|
|
notthere <- histrows[! histrows %in% values$histQueries]
|
|
|
|
if (!length(notthere)) return(NULL)
|
|
lapply(notthere, function(daquery) {
|
|
if (verbose) cat("DEBUG create history events", daquery, "\n")
|
|
observeEvent(input[[paste0("hist", daquery)]], {
|
|
if (verbose) cat("DEBUG history link", daquery, "\n")
|
|
values$lastQuery <- daquery
|
|
values$newQuery <- daquery
|
|
updateTabsetPanel(session, "mainPanelset", selected = "Tagging")
|
|
ready2tag(1)
|
|
})
|
|
|
|
observeEvent(input[[paste0("histTag", daquery)]], {
|
|
if (verbose) cat("DEBUG history retag", daquery, "\n")
|
|
values$histSaveStack <- rbind(
|
|
values$histSaveStack,
|
|
data.frame(id = ok.data()[daquery, values$conf$idcol],
|
|
tag = input[[paste0("histTag", daquery)]],
|
|
comment = values$comment[daquery])
|
|
)
|
|
})
|
|
})
|
|
values$histQueries <- c(values$histQueries, notthere)
|
|
})
|
|
|
|
## History save action
|
|
observeEvent(input$histSave, {
|
|
req(is.data.frame(values$histSaveStack))
|
|
values$tagTrigger <- as.list(values$histSaveStack)
|
|
values$label[match(values$histSaveStack$id, ok.data()[[values$conf$idcol]])] <-
|
|
values$histSaveStack$tag
|
|
values$histSaveStack <- NULL
|
|
})
|
|
|
|
## Update save name with number of unsaved changes
|
|
observeEvent(length(values$histSaveStack$id), {
|
|
updateActionButton(
|
|
session, "histSave",
|
|
label = paste0("Save changes (", length(unique(values$histSaveStack$id)),")"))
|
|
})
|
|
|
|
## History table, with clickable links and retagging
|
|
output$histDTable <- DT::renderDataTable({
|
|
histrows <- order(values$labelhist)
|
|
histrows <- rev(histrows[!is.na(values$labelhist[histrows])])
|
|
histrows <- histrows[!is.na(values$label[histrows])]
|
|
|
|
# histrows <- rev(values$queries)
|
|
hist_df <- data.frame(
|
|
# history = length(histrows):1,
|
|
history = values$labelhist[histrows],
|
|
id = sapply(histrows, function(irow) {
|
|
as.character(actionLink(
|
|
paste0("hist", irow),
|
|
label = ok.data()[irow, values$conf$idcol],
|
|
onclick = paste0('Shiny.onInputChange(\"hist', irow, '\", this.id)')))
|
|
}),
|
|
Tag = values$label[histrows],
|
|
Retag = sapply(histrows, function(irow) {
|
|
paste0(
|
|
"<select id=\"histTag", irow, "\" onchange=\"Shiny.onInputChange('histTag", irow, "', this.value)\">",
|
|
paste0("<option value=\"", values$uniqueLabels, "\" ",
|
|
ifelse(values$uniqueLabels == values$label[irow], "selected", ""),
|
|
">", values$uniqueLabels, "</option>", collapse = " "),
|
|
"</select>"
|
|
)
|
|
}),
|
|
Comment = values$comment[histrows],
|
|
Text = ok.nicetext()[histrows])
|
|
if (!is.null(values$conf$contextcols))
|
|
hist_df <- cbind(hist_df,
|
|
ok.data()[histrows, values$conf$contextcols])
|
|
|
|
DT::datatable(hist_df, escape = FALSE, rownames = FALSE, filter = "top",
|
|
options = list(
|
|
columnDefs = list(list(
|
|
targets = 5,
|
|
render = DT::JS(
|
|
"function(data, type, row, meta) {",
|
|
"return type === 'display' && data.length > 200 ?",
|
|
"'<span title=\"' + data + '\">' + data.substr(0, 200) + '...</span>' : data;",
|
|
"}")))
|
|
))
|
|
})
|
|
|
|
##############################################################################
|
|
## Panel "Stats"
|
|
##############################################################################
|
|
|
|
output$statsTagTable <- renderTable(rownames = F, {
|
|
table(tag = values$label)
|
|
})
|
|
|
|
|
|
## Model diagnostics by CV
|
|
output$statsCVoutput <- reactive({
|
|
if (is.null(values$modelcv))
|
|
return("Model diagnostics will appear here")
|
|
values$modelcv
|
|
})
|
|
|
|
output$statsCVtable <- DT::renderDataTable({
|
|
if (is.null(values$cvtable))
|
|
return(NULL)
|
|
DT::datatable(values$cvtable, list(pageLength = 25), rownames = F)
|
|
})
|
|
|
|
## Button action: compute CV (async)
|
|
cv_nclicks <- reactiveVal(0)
|
|
observeEvent(input$statsCVgo, {
|
|
if (is.null(ok.train())) {
|
|
values$modelcv <- "Error in model training"
|
|
return(NULL)
|
|
}
|
|
if (cv_nclicks() != 0) {
|
|
values$modelcv <- "CV already running"
|
|
return(NULL)
|
|
}
|
|
cv_nclicks(cv_nclicks() + 1)
|
|
|
|
predmat <- ok.predictor()[!is.na(values$label), ]
|
|
predlab <- values$label[!is.na(values$label)]
|
|
cvsamp <- sample(10, nrow(predmat), replace = TRUE)
|
|
cvres <- rep(NA, nrow(predmat))
|
|
cvres_future <- reactiveVal()
|
|
|
|
tmp_model <- input$predModel
|
|
if (tmp_model == "random forest") {
|
|
cv_args <- list(
|
|
num.trees = input$rfNumTrees, mtry = if (input$rfMtry > 0) input$rfMtry,
|
|
sample.fraction = input$rfSampleFrac, probability = FALSE)
|
|
} else if (tmp_model == "linear") {
|
|
cv_args <- list(type= 0, cost = input$liblinCost)
|
|
} else if (tmp_model == "lasso") {
|
|
cv_args <- input$glmLambda
|
|
} else if (tmp_model == "naive bayes") {
|
|
cv_args <- list(smooth = input$naiveSmooth, prior = input$naivePrior,
|
|
distribution = input$naiveDistri)
|
|
} else if (tmp_model == "knn") {
|
|
cv_args <- list(k = input$knnK)
|
|
}
|
|
|
|
cv_status_file <- paste0(session$token, "_cv")
|
|
|
|
cv_async <- future(seed = TRUE, {
|
|
for (icv in 1:10) {
|
|
set_status(cv_status_file, paste0("Computing CV fold ", icv, " / 10"))
|
|
if (tmp_model == "random forest") {
|
|
cvmodel <- do.call(ranger::ranger, c(cv_args, list(
|
|
x= predmat[cvsamp != icv, ],
|
|
y= as.factor(predlab[cvsamp != icv]))))
|
|
cvres[cvsamp == icv] <- as.character(
|
|
predict(cvmodel, data= predmat[cvsamp == icv, ])$predictions)
|
|
} else {
|
|
tmpvalues <- predlab[cvsamp != icv]
|
|
# for (ival in na.omit(unique(tmpvalues)))
|
|
# if (sum(tmpvalues == ival, na.rm = T) == 1)
|
|
# tmpvalues[which(tmpvalues == ival)] <- NA
|
|
|
|
if (tmp_model == "lasso") {
|
|
cvmodel <- suppressWarnings(
|
|
glmnet::glmnet(x= predmat[cvsamp != icv, ][!is.na(tmpvalues), ],
|
|
y= as.factor(tmpvalues[!is.na(tmpvalues)]),
|
|
family= "multinomial"))
|
|
cvres[cvsamp == icv] <- predict(
|
|
cvmodel, newx = predmat[cvsamp == icv, ],
|
|
type = "class", s= cv_args)
|
|
} else if (tmp_model == "linear") {
|
|
cvmodel <- do.call(LiblineaR::LiblineaR, c(
|
|
list(data= predmat[cvsamp != icv, ][!is.na(tmpvalues), ],
|
|
target= as.factor(tmpvalues[!is.na(tmpvalues)])),
|
|
cv_args))
|
|
cvres[cvsamp == icv] <- as.character(
|
|
predict(cvmodel, newx= predmat[cvsamp == icv, ])$predictions)
|
|
} else if (tmp_model == "naive bayes") {
|
|
cvmodel <- do.call(quanteda.textmodels::textmodel_nb, c(
|
|
list(x= predmat[cvsamp != icv, ][!is.na(tmpvalues), ],
|
|
y= as.factor(tmpvalues[!is.na(tmpvalues)])),
|
|
cv_args))
|
|
cvres[cvsamp == icv] <- as.character(
|
|
predict(
|
|
cvmodel, newdata= predmat[cvsamp == icv, ], type= "class"))
|
|
} else if (isolate(tmp_model) == "knn") {
|
|
cvres[cvsamp == icv] <-
|
|
as.character(do.call(class::knn, c(cv_args, list(
|
|
train = predmat[cvsamp != icv, ],
|
|
test = predmat[cvsamp == icv, ],
|
|
cl = predlab[cvsamp != icv]))))
|
|
}
|
|
}
|
|
}
|
|
cvres
|
|
}) %...>% cvres_future()
|
|
|
|
cv_async <- catch(cv_async, function(e) {
|
|
cvres_future(NULL)
|
|
values$modelcv <- e$message
|
|
})
|
|
|
|
cv_async <- finally(cv_async, function() {
|
|
cv_nclicks(0)
|
|
if (file.exists(cv_status_file)) unlink(cv_status_file)
|
|
if (is.null(cvres_future())) return(NULL)
|
|
cvres <- cvres_future()
|
|
predlab <- values$label[!is.na(values$label)]
|
|
dametrics <- metricsTable(predlab, cvres)
|
|
values$cvtable <- dametrics
|
|
res <- "10-CV OOB evaluation:\n"
|
|
# if (any(grepl("^bertpred", input$use_regressors)))
|
|
if (any(grepl("^bertpred", values$new_use_regressors)))
|
|
res <- paste0(
|
|
res,
|
|
"⚠️ Scores are biased upwards if BERT predictions were trained on current data ⚠️ \n")
|
|
res <- paste0(
|
|
res,
|
|
"* Accuracy : ", round(100 * mean(cvres == predlab), 2), "%\n",
|
|
"* Macro F1 : ", sprintf("%f", mean(as.numeric(dametrics$F1))), "\n",
|
|
"* Weighted F1 : ", sprintf("%f", weighted.mean(as.numeric(dametrics$F1),
|
|
dametrics$N.cases)), "\n"
|
|
)
|
|
values$modelcv <- res
|
|
})
|
|
|
|
NULL
|
|
})
|
|
|
|
## Automatic message update during CV computation
|
|
observe({
|
|
if (cv_nclicks() == 0) return(NULL)
|
|
invalidateLater(200)
|
|
if (!file.exists(paste0(session$token, "_cv"))) return(NULL)
|
|
values$modelcv <- get_status(paste0(session$token, "_cv"))
|
|
values$cvtable <- NULL
|
|
})
|
|
|
|
|
|
##############################################################################
|
|
## Panel BERT
|
|
##############################################################################
|
|
|
|
##########
|
|
## Bert UI left panel
|
|
|
|
## Update list of saved models and dlSelect on init and on saveTrigger
|
|
|
|
observeEvent(list(ok.data(), values$bertSaveTrigger), {
|
|
damodels <- dir(pattern = "^tiggerbert_saved_")
|
|
if (!length(damodels)) return(NULL)
|
|
damodels <- gsub("^tiggerbert_saved_", "", damodels)
|
|
values$bertSaved <- damodels
|
|
updateSelectInput(session, "dlBPSelect", choices = damodels)
|
|
})
|
|
|
|
## Populate saved models list, with buttons
|
|
|
|
output$bertSaved <- renderUI({
|
|
if (verbose)
|
|
cat("DEBUG bert update saved list\n")
|
|
HTML(paste0(
|
|
"<table><tbody>",
|
|
paste0(sapply(values$bertSaved, function(dabert) {
|
|
bertshort <- dabert
|
|
if (nchar(bertshort) > 23)
|
|
bertshort <- paste0(substr(bertshort, 1, 20), "...")
|
|
paste0(
|
|
"<tr><td>",
|
|
actionLink(paste0("saved_", dabert), bertshort, title = dabert,
|
|
style="margin-right: 5px;"), "</td><td>",
|
|
actionButton(paste0("bert_copypars_", dabert), "📋",
|
|
title = "Copy parameters"), "</td><td>",
|
|
actionButton(paste0("bert_infer_", dabert), "🤖",
|
|
title = "Infer predictions on current data"), "</td><td>",
|
|
actionButton(paste0("bert_delete_", dabert), "🗑",
|
|
title = "Delete model"),
|
|
"</td></tr>")
|
|
}), collapse = "\n"),
|
|
"</tbody></table>"
|
|
))
|
|
})
|
|
|
|
##########
|
|
## Bert UI main panel
|
|
|
|
## UI outputs : message and stats table and plot
|
|
output$bertMsg <- reactive(
|
|
ifelse(is.null(values$bertMsg),
|
|
"Train new BERT, or select saved model.",
|
|
values$bertMsg))
|
|
|
|
output$bertValstats <- DT::renderDataTable(
|
|
DT::datatable(values$bertValstats, list(pageLength = 25)))
|
|
|
|
output$bertValPlot <- renderPlot(values$bertValPlot)
|
|
|
|
output$bertMsgHyperpar <- reactive(values$bertMsgHyperpar)
|
|
|
|
##################################
|
|
## Async handling of BERT training
|
|
|
|
## Status File
|
|
bert_status_file <- paste0("tiggerbert_", session$token, "_trainstatus")
|
|
|
|
fire_interrupt <- function(dafile) set_status(dafile, "interrupt")
|
|
fire_ready <- function(dafile) set_status(dafile, "Ready")
|
|
fire_running <- function(dafile, perc_complete = NULL){
|
|
if(is.null(perc_complete))
|
|
msg <- "Training..."
|
|
else
|
|
msg <- paste0("Training... ", perc_complete, "% complete")
|
|
set_status(dafile, msg)
|
|
}
|
|
interrupted <- function(dafile) get_status(dafile) == "interrupt"
|
|
|
|
## Create Status File
|
|
fire_ready(bert_status_file)
|
|
|
|
|
|
## Button action preparation
|
|
bert_nclicks <- reactiveVal(0)
|
|
bert_result_val <- reactiveVal()
|
|
bert_hyperpars <- reactiveVal()
|
|
|
|
## Button appearance: write "Stop" if training is ongoing
|
|
observeEvent(bert_nclicks(), {
|
|
updateActionButton(session, "bertTrain",
|
|
label = ifelse(bert_nclicks() > 0, "Stop", "Train BERT"))
|
|
})
|
|
|
|
## Button action: Train new BERT
|
|
observeEvent(input$bertTrain,{
|
|
|
|
## Don't do anything if analysis is already being run
|
|
# if(bert_nclicks() != 0){
|
|
# values$bertMsg <- "BERT is already training"
|
|
# return(NULL)
|
|
# }
|
|
tmpsession <- paste0("tiggerbert_", ok.labelcol(), "_", session$token)
|
|
if(bert_nclicks() != 0){
|
|
write("stop", paste0(tmpsession, "_stop"))
|
|
bert_nclicks(0)
|
|
return(NULL)
|
|
}
|
|
if (file.exists(paste0(tmpsession, "_stop")))
|
|
file.remove(paste0(tmpsession, "_stop"))
|
|
|
|
## Increment clicks and prevent concurrent analyses
|
|
bert_nclicks(bert_nclicks() + 1)
|
|
|
|
bert_result_val(data.frame(Status="Running..."))
|
|
fire_running(bert_status_file)
|
|
|
|
## Prepare async training
|
|
values$bertLoadSaved <- NULL
|
|
# tmpsession <- paste0("tiggerbert_", ok.labelcol(), "_", session$token)
|
|
tmpmodel <- input$bertModel
|
|
system(paste0("rm ", tmpsession, "_done"))
|
|
|
|
tmpdat <- data.frame(
|
|
id = ok.data()[, values$conf$idcol],
|
|
text = ok.nicetext(),
|
|
label = values$label
|
|
)
|
|
tmpdat <- tmpdat[!is.na(tmpdat$label), ]
|
|
tmpdat <- tmpdat[grepl("\\S", tmpdat$text), ]
|
|
|
|
## Filter data: min occurences, balance classes, validation split
|
|
tmplabtable <- table(tmpdat$label)
|
|
if (is.numeric(input$bertMinOccur)) if (input$bertMinOccur > 1) {
|
|
tmpdat <- tmpdat[tmpdat$label %in%
|
|
names(which(tmplabtable >= input$bertMinOccur)), ]
|
|
tmplabtable <- table(tmpdat$label)
|
|
}
|
|
set.seed(input$bertValidSeed)
|
|
if (input$bertBalance) {
|
|
tmpminocc <- min(tmplabtable)
|
|
tmptrain <- sample(do.call(c, lapply(unique(tmpdat$label), function(dalabel)
|
|
sample(which(tmpdat$label == dalabel), round((1-input$bertValidFrac) * tmpminocc)))))
|
|
tmpvalid <- sample(do.call(c, lapply(unique(tmpdat$label), function(dalabel) {
|
|
dasamp <- which(tmpdat$label == dalabel)
|
|
dasamp <- dasamp[! dasamp %in% tmptrain]
|
|
sample(dasamp, round(input$bertValidFrac * tmpminocc))
|
|
})))
|
|
} else {
|
|
tmptrain <- sample(1:nrow(tmpdat), round((1 - input$bertValidFrac) * nrow(tmpdat)))
|
|
tmpvalid <- (1:nrow(tmpdat))[-tmptrain]
|
|
}
|
|
|
|
write.csv(tmpdat[tmptrain, ], paste0(tmpsession, "_dat_train.csv"), row.names = FALSE)
|
|
write.csv(tmpdat[tmpvalid, ], paste0(tmpsession, "_dat_valid.csv"), row.names = FALSE)
|
|
|
|
iwait <- 0
|
|
while (iwait < 10) {
|
|
if (!file.exists(paste0(tmpsession, "_dat_valid.csv"))) Sys.sleep(500)
|
|
iwait <- iwait + 1
|
|
}
|
|
|
|
tmp_cmd <- paste0(
|
|
values$conf$python, " gobert.py -m ", tmpmodel,
|
|
" -t ", tmpsession, "_dat_train.csv",
|
|
" -v ", tmpsession, "_dat_valid.csv",
|
|
" -b ", input$bertBatchsize,
|
|
" -g ", input$bertGradacc,
|
|
" -e ", input$bertEpochs,
|
|
" -l ", input$bertLrate,
|
|
" -w ", input$bertWdecay,
|
|
" -B ", ifelse(input$bertBest, 1, 0),
|
|
" -E ", input$bertNeval,
|
|
" -s ", tmpsession,
|
|
" -G ", as.numeric(values$conf$use_gpu),
|
|
" -A ", as.numeric(input$bertAdapt),
|
|
" 2>&1 ; touch ", tmpsession, "_done"
|
|
)
|
|
|
|
## Save hyperpars
|
|
bert_hyperpars(list(bertModel = input$bertModel,
|
|
bertEpochs = input$bertEpochs,
|
|
bertLrate = input$bertLrate,
|
|
bertWdecay = input$bertWdecay,
|
|
bertBatchsize = input$bertBatchsize,
|
|
bertGradacc = input$bertGradacc,
|
|
bertNeval = input$bertNeval,
|
|
bertBest = input$bertBest,
|
|
bertValidFrac = input$bertValidFrac,
|
|
bertValidSeed = input$bertValidSeed,
|
|
bertNtrain = length(tmptrain),
|
|
bertTrainTable = as.list(table(tmpdat$label[tmptrain])),
|
|
bertScheme = ok.labelcol()))
|
|
|
|
## Launch async training
|
|
bert_async <- future({
|
|
if (file.exists(tmpsession))
|
|
system(paste0("rm -R ", tmpsession, "*"))
|
|
|
|
# system(tmp_cmd, wait = FALSE, intern = FALSE)
|
|
tmp_exec <- system(tmp_cmd, wait = FALSE, intern = TRUE)
|
|
writeLines(tmp_exec, paste0(tmpsession, "_log"))
|
|
|
|
## After training, get trainer state from last checkpoint for diagnostics
|
|
chkpt <- dir(paste0(tmpsession, "_train"), pattern = "^checkpoint")
|
|
chkpt <-
|
|
chkpt[order(as.numeric(gsub("\\D", "", chkpt)), decreasing = T)[1]]
|
|
system(paste0(
|
|
"cp ", tmpsession, "_train/", chkpt, "/trainer_state.json ",
|
|
tmpsession, "/"))
|
|
}) %...>% bert_result_val()
|
|
|
|
## Catch interrupt (or any other error) and notify user
|
|
bert_async <- catch(bert_async, function(e){
|
|
bert_result_val(NULL)
|
|
showNotification(e$message)
|
|
values$bertMsg <- e$message
|
|
})
|
|
|
|
## After the promise has been evaluated set nclicks to 0 to allow another Run
|
|
bert_async <- finally(bert_async, function() {
|
|
system(paste0("rm -R ", tmpsession, "_train"))
|
|
system(paste0("rm ", tmpsession, "_done"))
|
|
|
|
fire_ready(bert_status_file)
|
|
bert_nclicks(0)
|
|
|
|
if (is.null(bert_result_val())) return(NULL)
|
|
|
|
bertpreds <- try(read.csv(paste0(tmpsession, "_predval.csv")))
|
|
if (inherits(bertpreds, "try-error")) {
|
|
# values$bertMsg <- "BERT error - try again"
|
|
values$bertMsg <- try(paste(readLines(paste0(tmpsession, "_log")), collapse = "\n"))
|
|
values$bertValstats <- NULL
|
|
values$bertValPlot <- NULL
|
|
values$bertLastUnsaved <- NULL
|
|
values$bertMsgHyperpar <- NULL
|
|
values$bertLastHyperpar <- NULL
|
|
return(NULL)
|
|
}
|
|
|
|
datruth <- tmpdat[tmpvalid, "label"]
|
|
dapred <- bertpreds$bertpred
|
|
dametrics <- metricsTable(datruth, dapred)
|
|
damsg <- paste0(
|
|
"Unsaved model (", tmpmodel, ")\n\n",
|
|
"BERT validation stats:\n",
|
|
"* Accuracy : ", round(100 * mean(datruth == dapred), 2), "%\n",
|
|
"* Macro F1 : ", sprintf("%f", mean(as.numeric(dametrics$F1))), "\n",
|
|
"* Weighted F1 : ", sprintf("%f", weighted.mean(as.numeric(dametrics$F1),
|
|
dametrics$N.cases)), "\n")
|
|
hypermsg <- bertHyperToMsg(bert_hyperpars())
|
|
writeLines(RJSONIO::toJSON(bert_hyperpars()),
|
|
paste0(tmpsession, "/tiggertrain.json"))
|
|
|
|
values$bertValstats <- dametrics
|
|
values$bertMsg <- damsg
|
|
values$bertValPlot <- bertPlotFromPath(tmpsession)
|
|
values$bertLastUnsaved <- list(
|
|
metrics = dametrics, msg = damsg, session = tmpsession)
|
|
values$bertMsgHyperpar <- hypermsg
|
|
values$bertLastHyperpar <- bert_hyperpars()
|
|
})
|
|
|
|
values$bertMsg <- "BERT is training"
|
|
values$bertValstats <- NULL
|
|
values$bertValPlot <- NULL
|
|
values$bertLastUnsaved <- NULL
|
|
values$bertMsgHyperpar <- NULL
|
|
values$bertLastHyperpar <- NULL
|
|
|
|
## Return something other than the promise so shiny remains responsive
|
|
NULL
|
|
})
|
|
|
|
## Automatic check of BERT training status
|
|
observe({
|
|
if (bert_nclicks() == 0) return(NULL)
|
|
isolate({
|
|
tmpsession <- paste0("tiggerbert_", ok.labelcol(), "_", session$token)
|
|
## Check for checkpoint dirs
|
|
checkdirs <-
|
|
length(dir(paste0(tmpsession, "_train"), pattern = "^checkpoint"))
|
|
# fire_running(bert_status_file,
|
|
# min(100, round(100 * checkdirs / input$bertNeval, 1)))
|
|
# dastate <- try(RJSONIO::fromJSON(paste0(tmpsession, "_train/trainer_state.json")))
|
|
# if (!inherits(dastate, "try-error"))
|
|
# fire_running(bert_status_file,
|
|
# round(100 * as.numeric(dastate$epoch) / input$bertEpochs, 1))
|
|
try({
|
|
dapoints <- dir(paste0(tmpsession, "_train"),
|
|
pattern = "trainer_state[.]json$", recursive = T)
|
|
dapoints_num <- as.numeric(gsub("^checkpoint-(\\d+)/.*$", "\\1", dapoints))
|
|
statefile <- paste0(
|
|
tmpsession, "_train/", dapoints[which.max(dapoints_num)])
|
|
if (file.exists(statefile)) {
|
|
state <- RJSONIO::fromJSON(statefile)
|
|
fire_running(bert_status_file,
|
|
round(100 * as.numeric(state$epoch) / input$bertEpochs, 1))
|
|
}
|
|
})
|
|
})
|
|
if (checkdirs < isolate(input$bertNeval) & file.exists(paste0(tmpsession, "_done"))) {
|
|
values$bertMsg <- "BERT Error - try again"
|
|
# values$bertMsg <- paste(readLines(paste0(tmpsession, "_log")), collapse = "\n")
|
|
} else {
|
|
invalidateLater(1e3)
|
|
loss_progress <- ""
|
|
if (checkdirs > 0) {
|
|
## Get training diagnostics
|
|
try({
|
|
dapoints <- dir(paste0(tmpsession, "_train"),
|
|
pattern = "trainer_state[.]json$", recursive = T)
|
|
dapoints_num <- as.numeric(gsub("^checkpoint-(\\d+)/.*$", "\\1", dapoints))
|
|
statefile <- paste0(
|
|
tmpsession, "_train/", dapoints[which.max(dapoints_num)])
|
|
if (file.exists(statefile)) {
|
|
state <- RJSONIO::fromJSON(statefile)
|
|
logs <- data.table::rbindlist(lapply(state$log_history, as.list),
|
|
fill = TRUE)
|
|
logs <- logs[, .(loss = max(loss, na.rm = T),
|
|
eval_loss = max(eval_loss, na.rm = T)), by = epoch]
|
|
loss_progress <- paste0(
|
|
"\n* Epoch : ", sprintf("%.02f", logs$epoch),
|
|
"\ttrain loss : ", sprintf("%.05f",logs$loss),
|
|
"\teval loss : ", sprintf("%.05f", logs$eval_loss), collapse = "")
|
|
}
|
|
})
|
|
}
|
|
values$bertMsg <-
|
|
ifelse(checkdirs == 0, "Pre-processing...",
|
|
paste0(get_status(bert_status_file), loss_progress))
|
|
}
|
|
values$bertValstats <- NULL
|
|
values$bertValPlot <- NULL
|
|
values$bertLoadSaved <- NULL
|
|
values$bertMsgHyperpar <- NULL
|
|
})
|
|
|
|
|
|
## Action: show last BERT model
|
|
observeEvent(input$bertLast, {
|
|
values$bertMsg <- values$bertLastUnsaved$msg
|
|
values$bertValstats <- values$bertLastUnsaved$metrics
|
|
values$bertValPlot <- bertPlotFromPath(values$bertLastUnsaved$session)
|
|
values$bertMsgHyperpar <- bertHyperToMsg(values$bertLastHyperpar)
|
|
values$bertLoadSaved <- NULL
|
|
})
|
|
|
|
|
|
## Action: save BERT model
|
|
observeEvent(input$bertSave, {
|
|
tmpsession <- paste0("tiggerbert_", ok.labelcol(), "_", session$token)
|
|
if (!file.exists(paste0(tmpsession)))
|
|
return(NULL)
|
|
|
|
if (!grepl("\\S", input$bertSaveName)) {
|
|
tmpname <- paste0(
|
|
ok.labelcol(), "_", gsub("\\D+$", "", gsub("\\D", "-", Sys.time())))
|
|
} else
|
|
tmpname <- cleanFileName(input$bertSaveName)
|
|
|
|
savedir <- paste0("tiggerbert_saved_", tmpname)
|
|
system(paste("cp -R", tmpsession, savedir))
|
|
system(paste0("cp ", tmpsession, "_dat_valid.csv ",
|
|
savedir, "/tiggerbert_dat_valid.csv"))
|
|
system(paste0("cp ", tmpsession, "_predval.csv ",
|
|
savedir, "/tiggerbert_pred_valid.csv"))
|
|
|
|
system(paste0("rm -R ", tmpsession, "*"))
|
|
values$bertMsg <- paste0("BERT model successfully saved: ", tmpname)
|
|
values$bertValstats <- NULL
|
|
values$bertValPlot <- NULL
|
|
values$bertMsgHyperpar <- NULL
|
|
|
|
if (is.null(values$bertSaveTrigger)) {
|
|
values$bertSaveTrigger <- 0
|
|
} else
|
|
values$bertSaveTrigger <- values$bertSaveTrigger + 1
|
|
values$bertLastUnsaved <- NULL
|
|
updateTextInput(session, "bertSaveName", value = "")
|
|
})
|
|
|
|
|
|
## Actions: load saved model (list updated only with new models)
|
|
observeEvent(values$bertSaved, {
|
|
if (!length(values$bertSaved)) return(NULL)
|
|
tmpsaved <- values$bertSaved[! values$bertSaved %in% values$bertSavedAll]
|
|
|
|
lapply(tmpsaved, function(dabert) {
|
|
############
|
|
## Actions to load saved model
|
|
observeEvent(input[[paste0("saved_", dabert)]], {
|
|
bertconf <- RJSONIO::fromJSON(paste0(
|
|
"tiggerbert_saved_", dabert, "/config.json"))
|
|
truth <- read.csv(paste0(
|
|
"tiggerbert_saved_", dabert, "/tiggerbert_dat_valid.csv"))$label
|
|
pred <- read.csv(paste0(
|
|
"tiggerbert_saved_", dabert, "/tiggerbert_pred_valid.csv"))$bertpred
|
|
|
|
dametrics <- metricsTable(truth, pred)
|
|
values$bertValstats <- dametrics
|
|
values$bertMsg <- paste0(
|
|
"Saved model ", dabert, " (", bertconf[["_name_or_path"]], ")\n\n",
|
|
"BERT validation stats:\n",
|
|
"* Accuracy : ", round(100 * mean(truth == pred), 2), "%\n",
|
|
"* Macro F1 : ", sprintf("%f", mean(as.numeric(dametrics$F1))), "\n",
|
|
"* Weighted F1 : ", sprintf("%f", weighted.mean(as.numeric(dametrics$F1),
|
|
dametrics$N.cases)), "\n")
|
|
|
|
## Hyperparameters
|
|
tiggertrain_file <- paste0("tiggerbert_saved_", dabert, "/tiggertrain.json")
|
|
if (file.exists(tiggertrain_file)) {
|
|
try({
|
|
values$bertMsgHyperpar <- bertHyperToMsg(RJSONIO::fromJSON(tiggertrain_file))
|
|
})
|
|
} else
|
|
values$bertMsgHyperpar <- "Training parameters not saved."
|
|
|
|
values$bertValPlot <-
|
|
bertPlotFromPath(paste0("tiggerbert_saved_", dabert))
|
|
values$bertLoadSaved <- dabert
|
|
})
|
|
|
|
############
|
|
## Actions to copy hyperparameters
|
|
observeEvent(input[[paste0("bert_copypars_", dabert)]], {
|
|
tiggertrain_file <- paste0("tiggerbert_saved_", dabert, "/tiggertrain.json")
|
|
if (!file.exists(tiggertrain_file)) return(NULL)
|
|
try({
|
|
tmppars <- RJSONIO::fromJSON(tiggertrain_file)
|
|
updateSelectInput(session, "bertModel", selected = tmppars$bertModel)
|
|
updateCheckboxInput(session, "bertBest", value = tmppars$bertBest)
|
|
numinputs <- c("bertEpochs", "bertLrate", "bertWdecay",
|
|
"bertBatchsize", "bertGradacc")
|
|
for (iinput in numinputs)
|
|
updateNumericInput(session, iinput, value = tmppars[[iinput]])
|
|
})
|
|
})
|
|
|
|
############
|
|
## Actions to delete saved model (with confirm)
|
|
observeEvent(input[[paste0("bert_delete_", dabert)]], {
|
|
showModal(modalDialog(
|
|
title = "Delete BERT model",
|
|
paste0("Confirm delete: ", dabert,
|
|
" (model and predictions will be deleted)."),
|
|
footer = tagList(actionButton(paste0("bert_delete_confirm_", dabert), "Delete"),
|
|
modalButton("Cancel"))))
|
|
})
|
|
|
|
observeEvent(input[[paste0("bert_delete_confirm_", dabert)]], {
|
|
system(paste0("rm -R tiggerbert_saved_", dabert))
|
|
system(paste0(
|
|
"rm ", values$conf$datadir, values$conf$dataname, "_bertpred_",
|
|
dabert, ".feather"))
|
|
# values$bertLoadSaved <- NULL
|
|
if (is.null(values$bertSaveTrigger)) {
|
|
values$bertSaveTrigger <- 0
|
|
} else
|
|
values$bertSaveTrigger <- values$bertSaveTrigger + 1
|
|
removeModal()
|
|
values$bertMsg <- NULL
|
|
values$bertValstats <- NULL
|
|
values$bertMsgHyperpar <- NULL
|
|
})
|
|
|
|
############
|
|
## Actions to infer on current data from saved BERT (async)
|
|
observeEvent(input[[paste0("bert_infer_", dabert)]], {
|
|
if (bertpred_nclicks() > 0 | bpall_nclicks() > 0) {
|
|
values$bertMsg <- "Inference already running"
|
|
values$bertMsgHyperpar <- NULL
|
|
values$bertValPlot <- NULL
|
|
values$bertValstats <- NULL
|
|
return(NULL)
|
|
}
|
|
bertpred_nclicks(1)
|
|
|
|
saved_model <- paste0("tiggerbert_saved_", dabert)
|
|
out_path <- paste0(
|
|
values$conf$datadir, values$conf$dataname, "_bertpred_",
|
|
dabert, ".feather")
|
|
|
|
if (file.exists(out_path)) {
|
|
old_infer <- arrow::read_feather(out_path)
|
|
} else
|
|
old_infer <- NULL
|
|
|
|
to_infer <- ok.data()[[values$conf$idcol]]
|
|
to_infer <- to_infer[! to_infer %in% old_infer[[values$conf$idcol]]]
|
|
to_infer_row <- match(to_infer, ok.data()[[values$conf$idcol]])
|
|
|
|
if (!length(to_infer)) {
|
|
values$bertMsg <- paste0(
|
|
"All current ", nrow(ok.data()),
|
|
" texts already infered by ", dabert)
|
|
values$bertMsgHyperpar <- NULL
|
|
values$bertValPlot <- NULL
|
|
values$bertValstats <- NULL
|
|
bertpred_nclicks(0)
|
|
return(NULL)
|
|
}
|
|
|
|
values$bertValPlot <- NULL
|
|
values$bertValstats <- NULL
|
|
values$bertMsgHyperpar <- NULL
|
|
values$bertMsg <- paste0(
|
|
"Preparing inference on ", length(to_infer), " new texts")
|
|
tmp_dat <- paste0("tiggerbert_infer_", session$token, ".feather")
|
|
arrow::write_feather(
|
|
data.frame(
|
|
ok.data()[to_infer_row, values$conf$idcol, drop = FALSE],
|
|
text = ok.nicetext()[to_infer_row]),
|
|
tmp_dat)
|
|
|
|
values$bertMsg <- paste0(
|
|
"Infering ", dabert, " predictions on ",
|
|
length(to_infer), " new texts")
|
|
infer_cmd <- paste0(
|
|
values$conf$python, " gobert_infer.py -m ", saved_model,
|
|
" -o ", out_path,
|
|
" -d ", tmp_dat,
|
|
" -i ", values$conf$idcol,
|
|
" -l ", paste0("tiggerbert_infer_", session$token, ".log"),
|
|
" -G ", as.numeric(values$conf$use_gpu),
|
|
" -b ", 128)
|
|
bertpred_res <- reactiveVal()
|
|
bertpred_async <- future({
|
|
system(infer_cmd)
|
|
system(paste0("rm ", tmp_dat))
|
|
|
|
if (!is.null(old_infer)) {
|
|
new_infer <- arrow::read_feather(out_path)
|
|
arrow::write_feather(rbind(old_infer, new_infer), out_path)
|
|
}
|
|
}) %...>% bertpred_res
|
|
bertpred_async <- catch(bertpred_async, function(error) {
|
|
bertpred_nclicks(0)
|
|
values$bertMsg <- paste0("BERT inference error: ", error)
|
|
system(paste0("rm ", tmp_dat))
|
|
})
|
|
bertpred_async <- finally(bertpred_async, function() {
|
|
bertpred_nclicks(0)
|
|
values$bertMsg <-
|
|
"Inference complete!\nRe-import data in Project/Sample panel to use the predictions for tagging."
|
|
values$bertValPlot <- NULL
|
|
values$bertValstats <- NULL
|
|
values$bertMsgHyperpar <- NULL
|
|
})
|
|
NULL
|
|
})
|
|
})
|
|
values$bertSavedAll <- c(values$bertSavedAll, tmpsaved)
|
|
})
|
|
|
|
## Automatic check of BERT inference progress
|
|
observe({
|
|
if (bertpred_nclicks() == 0) return(NULL)
|
|
invalidateLater(1e3)
|
|
logfile <- paste0("tiggerbert_infer_", isolate(session$token), ".log")
|
|
if (file.exists(logfile)) {
|
|
values$bertMsg <- readLines(logfile)[1]
|
|
values$bertValPlot <- NULL
|
|
values$bertValstats <- NULL
|
|
values$bertMsgHyperpar <- NULL
|
|
}
|
|
})
|
|
|
|
|
|
|
|
|
|
##############################################################################
|
|
## Export panel
|
|
##############################################################################
|
|
|
|
## Export tags and full model predictions
|
|
output$dlTagSave <-
|
|
downloadHandler(
|
|
function()
|
|
paste0(Sys.Date(), "-activeTigger-", ok.labelcol(),".", input$dlTagFormat),
|
|
function(con) {
|
|
if (is.null(ok.data())) return(NULL)
|
|
dadat <- ok.data()[, values$conf$idcol, drop = FALSE]
|
|
if ("tags" %in% input$dlTagSelect)
|
|
dadat[[ok.labelcol()]] <- values$label
|
|
if ("comments" %in% input$dlTagSelect) if (ok.commentCol() != "(None)")
|
|
dadat[, ok.commentCol()] <- values$comment
|
|
if ("predictions" %in% input$dlTagSelect) if (ok.train.possible()) {
|
|
dadat$tigger.predict <- ok.predlab1()
|
|
dadat$tigger.predprob <- apply(ok.pred(), 1, max)
|
|
tmp_pred <- ok.pred()
|
|
colnames(tmp_pred) <- paste0("tiggerpred_", colnames(tmp_pred))
|
|
dadat <- cbind(dadat, tmp_pred)
|
|
}
|
|
othercols <- input$dlTagSelect
|
|
othercols <- othercols[! othercols %in% c("tags", "comments", "predictions")]
|
|
if (length(othercols))
|
|
dadat <- cbind(dadat, ok.data()[, othercols, drop = FALSE])
|
|
|
|
if (input$dlTagFormat == "csv") {
|
|
write.csv(dadat, row.names = F, con)
|
|
} else
|
|
arrow::write_feather(dadat, con)
|
|
})
|
|
|
|
|
|
## Export embeddings (ft, sb, umap, t-sne)
|
|
output$dlEmbedSave <- downloadHandler(
|
|
function()
|
|
paste0(Sys.Date(), "-activeTigger-emb-",
|
|
paste(input$dlEmbedSelect, collapse = "-"),
|
|
".", input$dlEmbedFormat),
|
|
function (file) {
|
|
if (is.null(input$dlEmbedSelect)) return(NULL)
|
|
export <- ok.data()[, values$conf$idcol, drop = FALSE]
|
|
if ("ft" %in% input$dlEmbedSelect)
|
|
export <- data.frame(export, ok.data()[, values$cols_ft])
|
|
if ("sb" %in% input$dlEmbedSelect)
|
|
export <- data.frame(export, ok.data()[, values$cols_sb])
|
|
if (any(c("t-sne", "umap") %in% input$dlEmbedSelect)) {
|
|
tmpvisu <- ok.visu()
|
|
tmpalgo <- input$dlEmbedSelect[input$dlEmbedSelect %in% c("t-sne", "umap")]
|
|
colnames(tmpvisu) <- paste0(gsub("-", "", tmpalgo), 1:2)
|
|
export <- data.frame(export, tmpvisu)
|
|
}
|
|
if (input$dlEmbedFormat == "csv") {
|
|
write.csv(export, file, row.names = FALSE)
|
|
} else if (input$dlEmbedFormat == "feather") {
|
|
arrow::write_feather(export, file)
|
|
}
|
|
})
|
|
|
|
## Export BERT predictions
|
|
|
|
output$dlBPMsg <- reactive(values$dlBPMsg)
|
|
|
|
|
|
|
|
# output$dlBertPredCsv <-
|
|
# downloadHandler(paste0(Sys.Date(), "-bertpred-", ok.labelcol(),".csv"),
|
|
# content= function(con) {
|
|
# if (is.null(ok.data())) return(NULL)
|
|
# dadat <- ok.data()[, c(values$conf$idcol, ok.labelcol())]
|
|
# dadat[[ok.labelcol()]] <- values$label
|
|
# if (ok.commentCol() != "(None)") {
|
|
# dadat[, ok.commentCol()] <- values$comment
|
|
# }
|
|
# if (ok.train.possible()) {
|
|
# dadat$tigger.predict <- ok.predlab1()
|
|
# dadat$tigger.predprob <- apply(ok.pred(), 1, max)
|
|
# }
|
|
# dadat <- cbind(dadat, ok.pred())
|
|
# write.csv(dadat, row.names = F, con)
|
|
# })
|
|
|
|
############
|
|
## Action to infer on ALL data from saved BERT (async)
|
|
bpall_res <- reactiveVal()
|
|
observeEvent(input$dlBPInfer, {
|
|
if (bpall_nclicks() > 0 | bertpred_nclicks() > 0) {
|
|
values$dlBPMsg <- "Inference already running"
|
|
bpall_res(NULL)
|
|
return(NULL)
|
|
}
|
|
bpall_nclicks(1)
|
|
bpall_res_async <- reactiveVal()
|
|
dabert <- input$dlBPSelect
|
|
|
|
saved_model <- paste0("tiggerbert_saved_", dabert)
|
|
out_path <- paste0(
|
|
values$conf$datadir, values$conf$dataname, "_bertpredall_",
|
|
dabert, ".feather")
|
|
tmp_dat <- paste0("tiggerbert_inferall_", session$token, ".feather")
|
|
tmp_log <- paste0("tiggerbert_inferall_", session$token, ".log")
|
|
tmp_done <- paste0("tiggerbert_inferall_", session$token, "_done")
|
|
if (file.exists(tmp_done))
|
|
system(paste0("rm ", tmp_done))
|
|
|
|
if (file.exists(out_path)) {
|
|
values$dlBPMsg <- "Inference already complete, ready for download"
|
|
bpall_nclicks(0)
|
|
bpall_res(out_path)
|
|
return(NULL)
|
|
# old_infer <- arrow::read_feather(out_path)
|
|
}
|
|
|
|
fulldat <- arrow::read_feather(paste0(
|
|
values$conf$datadir, values$conf$dataname, ".feather"))
|
|
values$dlBPMsg <- paste0(
|
|
"Preparing inference on ", nrow(fulldat), " texts")
|
|
if (length(values$conf$textcols) > 1) {
|
|
fulldat$text <- do.call(paste, c(
|
|
fulldat[, values$conf$textcols, drop = FALSE], sep = "\n\n"))
|
|
} else {
|
|
fulldat$text <- fulldat[, values$conf$textcols]
|
|
}
|
|
arrow::write_feather(fulldat[, c(values$conf$idcol, "text")], tmp_dat)
|
|
|
|
infer_cmd <- paste0(
|
|
values$conf$python, " gobert_infer.py -m ", saved_model,
|
|
" -o ", out_path,
|
|
" -d ", tmp_dat,
|
|
" -i ", values$conf$idcol,
|
|
" -l ", tmp_log,
|
|
" -G ", as.numeric(values$conf$use_gpu),
|
|
" -b ", 128,
|
|
"; touch ", tmp_done)
|
|
|
|
bpall_async <- future({
|
|
system(infer_cmd)
|
|
system(paste0("rm ", tmp_dat))
|
|
}) %...>% bpall_res_async
|
|
|
|
bpall_async <- catch(bpall_async, function(error) {
|
|
values$dlBPMsg <- paste0("BERT inference error: ", error)
|
|
system(paste0("rm ", tmp_dat))
|
|
system(paste0("rm ", tmp_done))
|
|
})
|
|
|
|
bpall_async <- finally(bpall_async, function() {
|
|
bpall_nclicks(0)
|
|
values$dlBPMsg <-
|
|
"Inference complete, ready for download"
|
|
bpall_res(out_path)
|
|
})
|
|
NULL
|
|
})
|
|
|
|
## Automatic check of BERT all prediction progress
|
|
observe({
|
|
if (bpall_nclicks() == 0) return(NULL)
|
|
invalidateLater(1e3)
|
|
logfile <- paste0("tiggerbert_inferall_", isolate(session$token), ".log")
|
|
if (file.exists(logfile))
|
|
values$dlBPMsg <- readLines(logfile)[1]
|
|
})
|
|
|
|
## Show BERTpred download button when data is ready
|
|
output$dlBPDlButton <- renderUI({
|
|
if (is.null(bpall_res())) return(NULL)
|
|
downloadButton("dlBPDl", NULL)
|
|
})
|
|
|
|
output$dlBPDl <- downloadHandler(
|
|
function()
|
|
paste0(Sys.Date(), "-tiggerbert-", values$conf$dataname,
|
|
input$dlBPSelect, ".", input$dlBPFormat),
|
|
function(file) {
|
|
if (is.null(bpall_res())) return(NULL)
|
|
tmp_bert <- gsub("^.*_bertpredall_(.*)[.]feather$", "\\1", bpall_res())
|
|
if (tmp_bert != input$dlBPSelect) {
|
|
values$dlBPMsg <- "BERT model changed - predict again or select current model"
|
|
return(NULL)
|
|
}
|
|
tmp <- arrow::read_feather(bpall_res())
|
|
if (input$dlBPFormat == "csv") {
|
|
write.csv(tmp, file, row.names = FALSE)
|
|
} else if (input$dlBPFormat == "feather") {
|
|
arrow::write_feather(tmp, file)
|
|
}
|
|
}
|
|
)
|
|
|
|
|
|
##############################################################################
|
|
## Delete files at end of session
|
|
onStop(function() {
|
|
if(file.exists(bert_status_file)) unlink(bert_status_file)
|
|
if(length(dir(pattern = paste(session$token))))
|
|
system(paste0("rm -R *", session$token, "*"))
|
|
})
|
|
|
|
})
|