inst/server.R
In rsangole/tslabeler: Labeling Tool For Time Series Data
function(input, output, session) {
observe({
hide(selector = "#main_navbar li a[data-value=label]")
hide(selector = "#main_navbar li a[data-value=features]")
hide(selector = "#main_navbar li a[data-value=save]")
})
#----------------------------------------------------
# Instantiate values
preprocess <- shiny::reactiveValues(
df_name = NULL,
sample = NULL,
checkprep_complete = FALSE,
checkprep_results = NULL,
enable_select_btn = FALSE,
csv_preview = NULL
)
metadata <- shiny::reactiveValues(
tag_values = NULL,
tag_choices = NULL,
total_pts = NULL,
total_grps = NULL,
count_existing_anomalies = NULL,
grp_unique_list = NULL,
col_list = NULL,
tag_selected = NULL,
grp_selected = NULL,
tag_color = NULL,
pts_selected_grps = NULL
)
working_data <- shiny::reactiveValues(
dat = NULL,
filter_dat = NULL
)
plotopts <- shiny::reactiveValues(
# labeler_chkbox_plotopts = c("Show Legend"),
labeler_brush_direction = "xy",
labeler_brush_direction_zoomed = "xy"
)
#----------------------------------------------------
# Input Data UI - Data Frames
shiny::observeEvent(input$df_to_load, {
if (input$df_to_load != "None") {
preprocess$df_name <- input$df_to_load
preprocess$sample <- head(eval(parse(text = input$df_to_load)), 6)
preprocess$col_names <- colnames(preprocess$sample)
preprocess$numeric_cols <-
colnames(preprocess$sample)[sapply(preprocess$sample, is.numeric)]
if (".tag" %in% preprocess$col_names) {
preprocess$preselected_tag <- ".tag"
preprocess$choices_tag <- preprocess$col_names
} else {
preprocess$preselected_tag <- "No tag column"
preprocess$choices_tag <-
c(preprocess$preselected_tag,
preprocess$col_names)
}
if (".anomaly" %in% preprocess$col_names) {
preprocess$preselected_anomaly <- ".anomaly"
preprocess$choices_anomaly <- preprocess$col_names
} else {
preprocess$preselected_anomaly <- "No anomaly column"
preprocess$choices_anomaly <-
c(preprocess$preselected_anomaly,
preprocess$col_names)
}
if (".grp" %in% preprocess$col_names) {
preprocess$preselected_grp <- ".grp"
preprocess$choices_grp <- preprocess$col_names
} else {
preprocess$preselected_grp <- "No group column"
preprocess$choices_grp <- c(preprocess$preselected_grp,
preprocess$col_names)
}
preprocess$enable_select_btn <- FALSE
preprocess$checkprep_complete <- FALSE
}
})
output$sample_data <- DT::renderDataTable({
if (!is.null(preprocess$sample))
preprocess$sample %>%
DT::datatable(
caption = htmltools::tags$caption(style = 'caption-side: top; text-align: center;',
'', htmltools::em("Sample rows")),
options = list(dom = "t"),
class = 'cell-border stripe compact',
rownames = F
)
})
output$ui_select_df <- shiny::renderUI({
shiny::req(input$df_to_load)
if (!is.null(preprocess$sample)) {
if (input$df_to_load != "None") {
shiny::tagList(
hr(),
tags$style(
type = 'text/css',
".selectize-input {font-size: 13px; line-height: 13px;} .selectize-dropdown { font-size: 13px; line-height: 13px; }"
),
shiny::selectInput(
inputId = "picker_select_datecol",
label = "Date/Time Column",
choices = preprocess$col_names,
selected = preprocess$col_names[1],
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_select_grpcol",
label = "Group Column",
choices = preprocess$choices_grp,
selected = preprocess$preselected_grp,
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_select_valuecol",
label = "Value Column",
choices = preprocess$numeric_cols,
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_select_tagcol",
label = "Tag Column",
choices = preprocess$choices_tag,
selected = preprocess$preselected_tag,
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_select_anomalycol",
label = "Anomaly Column",
choices = preprocess$choices_anomaly,
selected = preprocess$preselected_anomaly,
multiple = FALSE
),
hr(),
shinyWidgets::actionBttn(
inputId = "btn_checkprep_df",
label = "Check & Prepare",
style = "material-flat",
size = "xs"
)
)
}
}
})
shiny::observeEvent(input$btn_checkprep_df, {
preprocess$picker_select_datecol <- input$picker_select_datecol
preprocess$picker_select_grpcol <- input$picker_select_grpcol
preprocess$picker_select_valuecol <- input$picker_select_valuecol
preprocess$picker_select_tagcol <- input$picker_select_tagcol
preprocess$picker_select_anomalycol <- input$picker_select_anomalycol
df_full <- eval(parse(text = input$df_to_load))
preprocess$checkprep_results <- tslabeler:::checkprep_dt_from_env(
df_full = df_full,
picker_select_datecol = preprocess$picker_select_datecol,
picker_select_grpcol = preprocess$picker_select_grpcol,
picker_select_valuecol = preprocess$picker_select_valuecol,
picker_select_tagcol = preprocess$picker_select_tagcol,
picker_select_anomalycol = preprocess$picker_select_anomalycol
)
if(preprocess$checkprep_results$preprocess_steps$go_nogo)
preprocess$enable_select_btn <- TRUE
else
preprocess$enable_select_btn <- FALSE
preprocess$checkprep_complete <- TRUE
})
output$ui_check_df <- shiny::renderPrint({
shiny::req(preprocess$checkprep_complete)
preprocess_steps <- preprocess$checkprep_results$preprocess_steps
usethis::ui_info("Performing quality checks & prepping data for usage")
if(preprocess_steps$df_class$convert_to_datatable){
usethis::ui_info(preprocess_steps$df_class$msg)
} else {
usethis::ui_done("Input data is a `data.table`")
}
usethis::ui_line("---- Date/Times Column ----")
if(preprocess_steps$datetime_col$initial_data_type_check_successful){
usethis::ui_done(preprocess_steps$datetime_col$msg)
} else {
usethis::ui_info("Attempting to prepare Date/Time column")
if(preprocess_steps$datetime_col$conversion_successful)
usethis::ui_done(preprocess_steps$datetime_col$msg)
else
usethis::ui_oops(preprocess_steps$datetime_col$msg)
}
usethis::ui_line("---- Tag Column ----")
if(preprocess_steps$tag_col$add_tag_col)
usethis::ui_info(preprocess_steps$tag_col$msg)
if(preprocess_steps$tag_col$NA_replaced)
usethis::ui_info(preprocess_steps$tag_col$msg)
usethis::ui_done("done")
usethis::ui_line("---- Anomaly Column ----")
if(preprocess_steps$anomaly_col$add_anomaly_col)
usethis::ui_info(preprocess_steps$anomaly_col$msg)
if(!preprocess_steps$anomaly_col$only_contains_T_or_F)
usethis::ui_info(preprocess_steps$anomaly_col$msg)
usethis::ui_done("done")
usethis::ui_line("---- Value Column ----")
if(preprocess_steps$value_col$initial_data_type_check_successful)
usethis::ui_done(preprocess_steps$value_col$msg)
usethis::ui_line("---- Other Column ----")
if(preprocess_steps$other_col$other_cols_exist)
usethis::ui_info(preprocess_steps$other_col$msg)
if(!preprocess_steps$other_col$other_cols_exist)
usethis::ui_done(preprocess_steps$other_col$msg)
usethis::ui_line("---- Quality Checks ----")
if(preprocess_steps$quality_checks$anomaly1_tag_empty)
usethis::ui_warn(preprocess_steps$quality_checks$anomaly1_tag_empty_msg)
if(preprocess_steps$quality_checks$anomaly0_tag_nonempty)
usethis::ui_warn(preprocess_steps$quality_checks$anomaly0_tag_nonempty_msg)
usethis::ui_done("Sorted data by date/time & group (if present)")
usethis::ui_done("done")
usethis::ui_line("---- Data Information ----")
usethis::ui_info(paste0("Total rows: ", preprocess_steps$metadata$total_pts))
usethis::ui_info(paste0("Unique Group Levels: ", preprocess_steps$metadata$total_grps))
usethis::ui_info(paste0("Count of existing anomalies: ", preprocess_steps$metadata$count_existing_anomalies))
usethis::ui_info(paste0("Custom anomaly tags: ", preprocess_steps$metadata$custom_tags))
usethis::ui_line("---- CHECK & PREP RESULT ----")
if(preprocess_steps$go_nogo)
usethis::ui_done("Data ready for labeling")
else
usethis::ui_oops("Something's not quite right.")
})
output$ui_select_btn_after_checkprep <- shiny::renderUI({
shiny::req(preprocess$enable_select_btn)
shiny::tagList(
hr(),
shinyWidgets::actionBttn(
inputId = "btn_selectdata_df",
label = "Select Data",
color = "success",
style = "material-flat",
size = "xs"
)
)
})
shiny::observeEvent(input$btn_selectdata_df, {
chklist <- preprocess$checkprep_results$preprocess_steps
# Store metadata
metadata$total_pts <- chklist$metadata$total_pts
metadata$total_grps <- chklist$metadata$total_grps
metadata$count_existing_anomalies <- chklist$metadata$count_existing_anomalies
metadata$tag_choices <- chklist$metadata$tag_choices
metadata$tag_values <- chklist$metadata$tag_values
metadata$tag_selected <- metadata$tag_values[1]
metadata$col_list <- chklist$col_list
metadata$grp_unique_list <- chklist$metadata$grp_unique_list
metadata$grp_selected <- chklist$metadata$grp_unique_list[1]
# Store data to `select`
working_data$dat <- preprocess$checkprep_results$preprocessed_df
preprocess$checkprep_results$preprocessed_df <- NULL
# Switch to labeler tab
shiny::updateNavbarPage(session = session,
inputId = "main_navbar",
selected = "Label")
shinyjs::show(selector = "#main_navbar li a[data-value=features]")
shinyjs::show(selector = "#main_navbar li a[data-value=label]")
shinyjs::show(selector = "#main_navbar li a[data-value=save]")
})
#----------------------------------------------------
# Input Data UI - CSV
shiny::observeEvent(input$filein_rawdata, {
preprocess$csv_preview <- data.table::fread(
file = input$filein_rawdata$datapath,
sep = input$filein_sep,
quote = input$filein_quote,
header = as.logical(input$filein_header)
)
preprocess$df_name <- input$filein_rawdata$name
preprocess$sample <- head(preprocess$csv_preview, 6)
preprocess$col_names <- colnames(preprocess$sample)
preprocess$numeric_cols <-
colnames(preprocess$sample)[sapply(preprocess$sample, is.numeric)]
if (".tag" %in% preprocess$col_names) {
preprocess$preselected_tag <- ".tag"
preprocess$choices_tag <- preprocess$col_names
} else {
preprocess$preselected_tag <- "No tag column"
preprocess$choices_tag <-
c(preprocess$preselected_tag,
preprocess$col_names)
}
if (".anomaly" %in% preprocess$col_names) {
preprocess$preselected_anomaly <- ".anomaly"
preprocess$choices_anomaly <- preprocess$col_names
} else {
preprocess$preselected_anomaly <- "No anomaly column"
preprocess$choices_anomaly <-
c(preprocess$preselected_anomaly,
preprocess$col_names)
}
if (".grp" %in% preprocess$col_names) {
preprocess$preselected_grp <- ".grp"
preprocess$choices_grp <- preprocess$col_names
} else {
preprocess$preselected_grp <- "No group column"
preprocess$choices_grp <- c(preprocess$preselected_grp,
preprocess$col_names)
}
preprocess$enable_csv_select_btn <- FALSE
preprocess$checkprep_csv_complete <- FALSE
})
output$DT_filein_preview <- DT::renderDT({
shiny::req(preprocess$csv_preview)
DT::datatable(preprocess$csv_preview,
autoHideNavigation = T,
class = 'cell-border compact',
options = list(dom = 'ft'
# deferRender = TRUE,
# scrollY = 100,
# scroller = TRUE
),
extensions = "Scroller",
caption = htmltools::tags$caption(
style = 'caption-side: bottom; text-align: center;',
'', htmltools::em(paste0('CSV Preview'))
)
)
})
output$ui_select_csv <- shiny::renderUI({
shiny::req(preprocess$csv_preview)
shiny::tagList(
hr(),
tags$style(
type = 'text/css',
".selectize-input {font-size: 13px; line-height: 13px;} .selectize-dropdown { font-size: 13px; line-height: 13px; }"
),
shiny::selectInput(
inputId = "picker_csv_select_datecol",
label = "Date/Time Column",
choices = preprocess$col_names,
selected = preprocess$col_names[1],
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_csv_select_grpcol",
label = "Group Column",
choices = preprocess$choices_grp,
selected = preprocess$preselected_grp,
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_csv_select_valuecol",
label = "Value Column",
choices = preprocess$numeric_cols,
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_csv_select_tagcol",
label = "Tag Column",
choices = preprocess$choices_tag,
selected = preprocess$preselected_tag,
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_csv_select_anomalycol",
label = "Anomaly Column",
choices = preprocess$choices_anomaly,
selected = preprocess$preselected_anomaly,
multiple = FALSE
),
hr(),
shinyWidgets::actionBttn(
inputId = "btn_checkprep_csv",
label = "Check & Prepare",
style = "material-flat",
size = "xs"
)
)
})
shiny::observeEvent(input$btn_checkprep_csv, {
preprocess$picker_select_datecol <- input$picker_csv_select_datecol
preprocess$picker_select_grpcol <- input$picker_csv_select_grpcol
preprocess$picker_select_valuecol <- input$picker_csv_select_valuecol
preprocess$picker_select_tagcol <- input$picker_csv_select_tagcol
preprocess$picker_select_anomalycol <- input$picker_csv_select_anomalycol
preprocess$checkprep_results <- tslabeler:::checkprep_dt_from_env(
df_full = preprocess$csv_preview,
picker_select_datecol = preprocess$picker_select_datecol,
picker_select_grpcol = preprocess$picker_select_grpcol,
picker_select_valuecol = preprocess$picker_select_valuecol,
picker_select_tagcol = preprocess$picker_select_tagcol,
picker_select_anomalycol = preprocess$picker_select_anomalycol
)
if(preprocess$checkprep_results$preprocess_steps$go_nogo)
preprocess$enable_csv_select_btn <- TRUE
else
preprocess$enable_csv_select_btn <- FALSE
preprocess$checkprep_csv_complete <- TRUE
})
output$ui_check_csv <- shiny::renderPrint({
shiny::req(preprocess$checkprep_csv_complete)
preprocess_steps <- preprocess$checkprep_results$preprocess_steps
usethis::ui_info("Performing quality checks & prepping data for usage")
usethis::ui_line("---- Date/Times Column ----")
if(preprocess_steps$datetime_col$initial_data_type_check_successful){
usethis::ui_done(preprocess_steps$datetime_col$msg)
} else {
usethis::ui_info("Attempting to prepare Date/Time column")
if(preprocess_steps$datetime_col$conversion_successful)
usethis::ui_done(preprocess_steps$datetime_col$msg)
else
usethis::ui_oops(preprocess_steps$datetime_col$msg)
}
usethis::ui_line("---- Tag Column ----")
if(preprocess_steps$tag_col$add_tag_col)
usethis::ui_info(preprocess_steps$tag_col$msg)
if(preprocess_steps$tag_col$NA_replaced)
usethis::ui_info(preprocess_steps$tag_col$msg)
usethis::ui_done("done")
usethis::ui_line("---- Anomaly Column ----")
if(preprocess_steps$anomaly_col$add_anomaly_col)
usethis::ui_info(preprocess_steps$anomaly_col$msg)
if(!preprocess_steps$anomaly_col$only_contains_T_or_F)
usethis::ui_info(preprocess_steps$anomaly_col$msg)
usethis::ui_done("done")
usethis::ui_line("---- Value Column ----")
if(preprocess_steps$value_col$initial_data_type_check_successful)
usethis::ui_done(preprocess_steps$value_col$msg)
usethis::ui_line("---- Other Column ----")
if(preprocess_steps$other_col$other_cols_exist)
usethis::ui_info(preprocess_steps$other_col$msg)
if(!preprocess_steps$other_col$other_cols_exist)
usethis::ui_done(preprocess_steps$other_col$msg)
usethis::ui_line("---- Quality Checks ----")
if(preprocess_steps$quality_checks$anomaly1_tag_empty)
usethis::ui_warn(preprocess_steps$quality_checks$anomaly1_tag_empty_msg)
if(preprocess_steps$quality_checks$anomaly0_tag_nonempty)
usethis::ui_warn(preprocess_steps$quality_checks$anomaly0_tag_nonempty_msg)
usethis::ui_done("Sorted data by date/time & group (if present)")
usethis::ui_done("done")
usethis::ui_line("---- Data Information ----")
usethis::ui_info(paste0("Total rows: ", preprocess_steps$metadata$total_pts))
usethis::ui_info(paste0("Unique Group Levels: ", preprocess_steps$metadata$total_grps))
usethis::ui_info(paste0("Count of existing anomalies: ", preprocess_steps$metadata$count_existing_anomalies))
usethis::ui_info(paste0("Custom anomaly tags: ", preprocess_steps$metadata$custom_tags))
usethis::ui_line("---- CHECK & PREP RESULT ----")
if(preprocess_steps$go_nogo)
usethis::ui_done("Data ready for labeling")
else
usethis::ui_oops("Something's not quite right.")
})
output$ui_select_btn_after_checkprep_csv <- shiny::renderUI({
shiny::req(preprocess$enable_csv_select_btn)
shiny::tagList(
br(),
shinyWidgets::actionBttn(
inputId = "btn_selectdata_csv",
label = "Select Data",
color = "success",
style = "material-flat",
size = "xs"
)
)
})
shiny::observeEvent(input$btn_selectdata_csv, {
chklist <- preprocess$checkprep_results$preprocess_steps
# Store metadata
metadata$total_pts <- chklist$metadata$total_pts
metadata$total_grps <- chklist$metadata$total_grps
metadata$count_existing_anomalies <- chklist$metadata$count_existing_anomalies
metadata$tag_choices <- chklist$metadata$tag_choices
metadata$tag_values <- chklist$metadata$tag_values
metadata$tag_selected <- metadata$tag_values[1]
metadata$col_list <- chklist$col_list
metadata$grp_unique_list <- chklist$metadata$grp_unique_list
metadata$grp_selected <- chklist$metadata$grp_unique_list[1]
# Store data to `select`
working_data$dat <- preprocess$checkprep_results$preprocessed_df
preprocess$checkprep_results$preprocessed_df <- NULL
# Switch to labeler tab
shinyjs::show(selector = "#main_navbar li a[data-value=features]")
shinyjs::show(selector = "#main_navbar li a[data-value=label]")
shinyjs::show(selector = "#main_navbar li a[data-value=save]")
shiny::updateNavbarPage(session = session,
inputId = "main_navbar",
selected = "Label")
})
#----------------------------------------------------
# Labeler
output$ui_labeler_sidemenu <- shiny::renderUI({
fluidPage(
tags$style(
type = 'text/css',
".selectize-input {font-size: 13px; line-height: 13px;}
.selectize-dropdown { font-size: 13px; line-height: 13px; } .filter-option-inner-inner {font-size: 13px; line-height: 13px;} .shiny-date-range-input {font-size: 13px; line-height: 13px;}"
),
if(metadata$col_list$grpcol != "No group column"){
tagList(
fluidRow(
shinyWidgets::pickerInput(
inputId = "labeler_picker_grp",
label = "Group",
choices = metadata$grp_unique_list,
selected = metadata$grp_selected,
options = shinyWidgets::pickerOptions(liveSearch = TRUE,
actionsBox = TRUE,
size = 10),
multiple = TRUE
),
shinyWidgets::actionBttn(
inputId = "labeler_btn_selectgrp",
label = "Select Group",
style = "material-flat",
color = "primary",
size = "xs"
)
),
hr()
)
},
fluidRow(
shiny::dateRangeInput(
inputId = "labeler_daterange",
label = "Date range",
start = working_data$dat[, min(get(metadata$col_list$datecol))],
end = working_data$dat[, max(get(metadata$col_list$datecol))],
weekstart = 1,
format = "dd M yy"
)
),
fluidRow(
shinyWidgets::awesomeCheckboxGroup(
inputId = "labeler_chkbox_plotopts",
label = "Plot Options",
choices = c(
"Show Anomalies",
"Show Legend"
),
status = "danger",
selected = plotopts$labeler_chkbox_plotopts
),
hr()
),
fluidRow(
shinyWidgets::actionBttn(
inputId = "labeler_btn_newtag",
label = "Custom Tag",
style = "material-flat",
color = "primary",
size = "xs"
)
),
br(),
fluidRow(
shinyWidgets::awesomeRadio(
inputId = "labeler_radio_taglist",
label = "Tags",
choices = metadata$tag_choices,
selected = metadata$tag_selected,
inline = F,
status = "danger"
)
),
fluidRow(
shinyWidgets::actionBttn(
inputId = "labeler_mark",
label = "Mark Tags",
style = "material-flat",
size = "xs",
icon = shiny::icon("bullseye"))
)
)
})
filtered_data <- shiny::reactive({
input$labeler_btn_selectgrp
if(!is.null(metadata$grp_unique_list))
filt_dat <- working_data$dat[get(metadata$col_list$grpcol) %in% shiny::isolate(input$labeler_picker_grp)]
else
filt_dat <- working_data$dat
filt_dat <-
filt_dat[data.table::between(
get(metadata$col_list$datecol),
as.POSIXct(as.character(input$labeler_daterange[1]), tz = "UTC"),
as.POSIXct(as.character(input$labeler_daterange[2]), tz = "UTC")
)]
metadata$pts_selected_grps <- filt_dat[, .N]
filt_dat
})
shiny::observeEvent(input$labeler_btn_selectgrp, {
metadata$grp_selected <- shiny::isolate(input$labeler_picker_grp)
})
shiny::observeEvent(input$labeler_radio_taglist, {
metadata$tag_selected <- input$labeler_radio_taglist
})
shiny::observeEvent(input$labeler_chkbox_plotopts, {
plotopts$labeler_chkbox_plotopts <- input$labeler_chkbox_plotopts
})
shiny::observeEvent(input$labeler_btn_newtag, {
shiny::showModal(
shiny::modalDialog(
shiny::textInput(
inputId = "textinput_customtag",
label = "What's your custom tag?"
),
footer = shiny::tagList(shiny::actionButton("labeler_btn_customtag_ok", "Add")),
easyClose = TRUE
)
)
})
shiny::observeEvent(input$labeler_btn_customtag_ok, {
if (input$textinput_customtag != "") {
metadata$tag_values <- c(
metadata$tag_values,
input$textinput_customtag
)
metadata$tag_choices <- c(
metadata$tag_choices,
input$textinput_customtag
)
}
})
shiny::observeEvent(input$user_dblclick, {
if (plotopts$labeler_brush_direction == "xy") {
plotopts$labeler_brush_direction <- "x"
} else {
plotopts$labeler_brush_direction <- "xy"
}
})
shiny::observeEvent(input$user_dblclick_zoomed, {
if (plotopts$labeler_brush_direction_zoomed == "xy") {
plotopts$labeler_brush_direction_zoomed <- "x"
} else {
plotopts$labeler_brush_direction_zoomed <- "xy"
}
})
output$labeler_plot_tsplot <- shiny::renderPlot(
{
shiny::req(working_data$dat)
dat <- filtered_data()
# dat <- working_data$filter_dat
tags <- dat[get(metadata$col_list$anomalycol) == 1, unique(get(metadata$col_list$tagcol))]
tag_colors <- 1:length(tags)
names(tag_colors) <- tags
metadata$tag_color <- tag_colors
par(mar = c(3,2,0.2,0.2)) #(bottom, left, top, right)
tslabeler:::ts_plotter(dat = dat,
col_list = metadata$col_list,
plotopts = input$labeler_chkbox_plotopts,
colors = tag_colors,
grp_unique_list = metadata$grp_unique_list)
},
res = 65
)
output$labeler_ui_tsplot <- shiny::renderUI({
shinycssloaders::withSpinner(
shiny::plotOutput("labeler_plot_tsplot",
brush = brushOpts(
id = "user_brush",
direction = plotopts$labeler_brush_direction
),
dblclick = "user_dblclick",
height = "390px"
)
)
})
selectedPoints <- shiny::reactive({
shiny::brushedPoints(
df = filtered_data(),
brush = input$user_brush,
xvar = "ds",
yvar = "value"
)
})
output$labeler_tsplot_zoomed <- shiny::renderPlot(
{
shiny::req(input$user_brush)
dat <- selectedPoints()
shiny::req(dat[, .N] > 0)
# dat[anomaly == 0, tag := ""]
par(mar = c(3,2,0.2,0.2)) #(bottom, left, top, right)
tslabeler:::ts_plotter(dat = dat,
col_list = metadata$col_list,
plotopts = input$labeler_chkbox_plotopts,
colors = metadata$tag_color,
grp_unique_list = metadata$grp_unique_list)
},
res = 65
)
output$labeler_ui_tsplot_zoomed <- shiny::renderUI({
shinycssloaders::withSpinner(
shiny::plotOutput("labeler_tsplot_zoomed",
brush = brushOpts(
id = "user_brush_zoomed",
direction = plotopts$labeler_brush_direction_zoomed
),
dblclick = "user_dblclick_zoomed",
height = "390px"
)
)
})
selectedPoints_zoomed <- shiny::reactive({
shiny::brushedPoints(
df = selectedPoints(),
brush = input$user_brush_zoomed,
xvar = "ds",
yvar = "value"
)
})
output$DT_selectionpreview <- DT::renderDT({
shiny::req(input$user_brush)
# shiny::req(input$user_brush_zoomed)
dat <- selectedPoints_zoomed()
if (nrow(dat) == 0) {
dat <- selectedPoints()
}
DT::datatable(dat,
autoHideNavigation = T,
class = 'cell-border compact',
options = list(dom = 'ft',
deferRender = TRUE,
scrollY = 100,
scroller = TRUE),
extensions = "Scroller",
caption = htmltools::tags$caption(
style = 'caption-side: bottom; text-align: center;',
'', htmltools::em(paste0(dat[,.N], ' points selected'))
)
) %>%
DT::formatDate(columns = metadata$col_list$datecol,
method = "toISOString")
})
shiny::observeEvent(input$labeler_mark, {
seldat <- selectedPoints_zoomed()
if (nrow(seldat) == 0) {
seldat <- selectedPoints()
}
seldat[, c(metadata$col_list$anomalycol) := ifelse(input$labeler_radio_taglist == "remove tag", F, T)]
seldat[, c(metadata$col_list$tagcol) := input$labeler_radio_taglist]
if(!is.na(metadata$grp_unique_list))
unmodified <- working_data$dat[!seldat, on = c(metadata$col_list$datecol, metadata$col_list$grpcol)]
if(is.na(metadata$grp_unique_list))
unmodified <- working_data$dat[!seldat, on = c(metadata$col_list$datecol)]
new <- data.table::rbindlist(list(unmodified, seldat))
data.table::setkeyv(new, metadata$col_list$datecol)
working_data$dat <- new
})
output$labeler_metatable <- shiny::renderTable({
shiny::req(working_data$dat)
dat <- filtered_data()
if (!is.na(metadata$grp_unique_list))
meta <- data.table::data.table(
Parameter = c(
"Groups (Selected/Total)",
"Pts in Selected Groups",
"Pts in Filtered View",
"Anomalies in Filtered View"
),
Value = c(
paste0(dat[, length(unique(get(metadata$col_list$grpcol)))], "/", metadata$total_grps),
scales::label_number_si(accuracy = 0.01)(metadata$pts_selected_grps),
scales::label_number_si(accuracy = 0.01)(dat[, .N]),
scales::label_number_si(accuracy = 1)(dat[, sum(get(metadata$col_list$anomalycol))])
)
)
else
meta <- data.table::data.table(
Parameter = c(
"Pts in Filtered View",
"Anomalies in Filtered View"
),
Value = c(
scales::label_number_si(accuracy = 0.01)(dat[, .N]),
scales::label_number_si(accuracy = 1)(dat[, sum(get(metadata$col_list$anomalycol))])
)
)
meta
},
spacing = "s",
colnames = FALSE,
bordered = FALSE
)
#----------------------------------------------------
# Features
featpreview <- shiny::reactive({
list(
"data" = working_data$dat[1:10],
"count" = scales::label_comma()(working_data$dat[,.N])
)
})
output$DT_featpreview <- DT::renderDT({
input$btn_dofeat
featpreview()$data %>%
DT::datatable(
autoHideNavigation = T,
class = 'cell-border compact',
options = list(dom = 't',
deferRender = TRUE
# scrollY = 100,
# scroller = TRUE
),
extensions = "Scroller",
caption = htmltools::tags$caption(
style = 'caption-side: bottom; text-align: center;',
'', htmltools::em(paste0('Previewing 10 / ', featpreview()$count , ' points'))
)) %>%
DT::formatDate(columns = metadata$col_list$datecol,
method = "toISOString")
})
shiny::observeEvent(input$btn_dofeat, {
dat <- working_data$dat
if(input$feat_monthnum){
dat[, .month_num := lubridate::month(get(metadata$col_list$datecol))]
}
if(input$feat_monthname){
dat[, .month := lubridate::month(get(metadata$col_list$datecol), label = TRUE)]
}
if(input$feat_qtr){
dat[, .qtr := lubridate::quarter(get(metadata$col_list$datecol))]
}
if(input$feat_wday){
dat[, .wkday := ifelse(lubridate::wday(get(metadata$col_list$datecol), label = TRUE) %in% c("Sat", "Sun"),
TRUE, FALSE)]
}
if(input$feat_daywk){
dat[, .day := lubridate::wday(get(metadata$col_list$datecol), label = TRUE)]
}
working_data$dat <- dat
})
#----------------------------------------------------
# Save
output$DT_savetodisk <- DT::renderDataTable({
shiny::req(working_data$dat)
working_data$dat %>%
DT::datatable(
class = 'cell-border compact',
options = list(dom = 'Bfti',
pageLength = 20,
deferRender = TRUE,
scrollY = 100,
scroller = TRUE,
buttons = list(
list(
extend = "collection",
text = 'Download CSV',
action = DT::JS("function ( e, dt, node, config ) {Shiny.setInputValue('download_working_dat', true, {priority: 'event'});}")
)
)),
extensions = c("Scroller", "Buttons")
)
})
output$download_working_dat <- downloadHandler(
filename = paste0(preprocess$df_name, ".csv"),
content = function(file){
data.table::fwrite(working_data$dat, file)
})
observeEvent(input$download_working_dat, {
sm <- div(
id = "download_working_dat",
shiny::modalDialog(shiny::downloadButton("download_working_dat",
"Download the data"),
easyClose = TRUE, title = "Download Table")
)
shiny::showModal(ui = sm)
})
shiny::observeEvent(input$btn_save_to_env, {
assign(preprocess$df_name, working_data$dat, envir = .GlobalEnv)
})
}
rsangole/tslabeler documentation built on April 4, 2020, 8:26 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
function(input, output, session) {
observe({
hide(selector = "#main_navbar li a[data-value=label]")
hide(selector = "#main_navbar li a[data-value=features]")
hide(selector = "#main_navbar li a[data-value=save]")
})
#----------------------------------------------------
# Instantiate values
preprocess <- shiny::reactiveValues(
df_name = NULL,
sample = NULL,
checkprep_complete = FALSE,
checkprep_results = NULL,
enable_select_btn = FALSE,
csv_preview = NULL
)
metadata <- shiny::reactiveValues(
tag_values = NULL,
tag_choices = NULL,
total_pts = NULL,
total_grps = NULL,
count_existing_anomalies = NULL,
grp_unique_list = NULL,
col_list = NULL,
tag_selected = NULL,
grp_selected = NULL,
tag_color = NULL,
pts_selected_grps = NULL
)
working_data <- shiny::reactiveValues(
dat = NULL,
filter_dat = NULL
)
plotopts <- shiny::reactiveValues(
# labeler_chkbox_plotopts = c("Show Legend"),
labeler_brush_direction = "xy",
labeler_brush_direction_zoomed = "xy"
)
#----------------------------------------------------
# Input Data UI - Data Frames
shiny::observeEvent(input$df_to_load, {
if (input$df_to_load != "None") {
preprocess$df_name <- input$df_to_load
preprocess$sample <- head(eval(parse(text = input$df_to_load)), 6)
preprocess$col_names <- colnames(preprocess$sample)
preprocess$numeric_cols <-
colnames(preprocess$sample)[sapply(preprocess$sample, is.numeric)]
if (".tag" %in% preprocess$col_names) {
preprocess$preselected_tag <- ".tag"
preprocess$choices_tag <- preprocess$col_names
} else {
preprocess$preselected_tag <- "No tag column"
preprocess$choices_tag <-
c(preprocess$preselected_tag,
preprocess$col_names)
}
if (".anomaly" %in% preprocess$col_names) {
preprocess$preselected_anomaly <- ".anomaly"
preprocess$choices_anomaly <- preprocess$col_names
} else {
preprocess$preselected_anomaly <- "No anomaly column"
preprocess$choices_anomaly <-
c(preprocess$preselected_anomaly,
preprocess$col_names)
}
if (".grp" %in% preprocess$col_names) {
preprocess$preselected_grp <- ".grp"
preprocess$choices_grp <- preprocess$col_names
} else {
preprocess$preselected_grp <- "No group column"
preprocess$choices_grp <- c(preprocess$preselected_grp,
preprocess$col_names)
}
preprocess$enable_select_btn <- FALSE
preprocess$checkprep_complete <- FALSE
}
})
output$sample_data <- DT::renderDataTable({
if (!is.null(preprocess$sample))
preprocess$sample %>%
DT::datatable(
caption = htmltools::tags$caption(style = 'caption-side: top; text-align: center;',
'', htmltools::em("Sample rows")),
options = list(dom = "t"),
class = 'cell-border stripe compact',
rownames = F
)
})
output$ui_select_df <- shiny::renderUI({
shiny::req(input$df_to_load)
if (!is.null(preprocess$sample)) {
if (input$df_to_load != "None") {
shiny::tagList(
hr(),
tags$style(
type = 'text/css',
".selectize-input {font-size: 13px; line-height: 13px;} .selectize-dropdown { font-size: 13px; line-height: 13px; }"
),
shiny::selectInput(
inputId = "picker_select_datecol",
label = "Date/Time Column",
choices = preprocess$col_names,
selected = preprocess$col_names[1],
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_select_grpcol",
label = "Group Column",
choices = preprocess$choices_grp,
selected = preprocess$preselected_grp,
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_select_valuecol",
label = "Value Column",
choices = preprocess$numeric_cols,
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_select_tagcol",
label = "Tag Column",
choices = preprocess$choices_tag,
selected = preprocess$preselected_tag,
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_select_anomalycol",
label = "Anomaly Column",
choices = preprocess$choices_anomaly,
selected = preprocess$preselected_anomaly,
multiple = FALSE
),
hr(),
shinyWidgets::actionBttn(
inputId = "btn_checkprep_df",
label = "Check & Prepare",
style = "material-flat",
size = "xs"
)
)
}
}
})
shiny::observeEvent(input$btn_checkprep_df, {
preprocess$picker_select_datecol <- input$picker_select_datecol
preprocess$picker_select_grpcol <- input$picker_select_grpcol
preprocess$picker_select_valuecol <- input$picker_select_valuecol
preprocess$picker_select_tagcol <- input$picker_select_tagcol
preprocess$picker_select_anomalycol <- input$picker_select_anomalycol
df_full <- eval(parse(text = input$df_to_load))
preprocess$checkprep_results <- tslabeler:::checkprep_dt_from_env(
df_full = df_full,
picker_select_datecol = preprocess$picker_select_datecol,
picker_select_grpcol = preprocess$picker_select_grpcol,
picker_select_valuecol = preprocess$picker_select_valuecol,
picker_select_tagcol = preprocess$picker_select_tagcol,
picker_select_anomalycol = preprocess$picker_select_anomalycol
)
if(preprocess$checkprep_results$preprocess_steps$go_nogo)
preprocess$enable_select_btn <- TRUE
else
preprocess$enable_select_btn <- FALSE
preprocess$checkprep_complete <- TRUE
})
output$ui_check_df <- shiny::renderPrint({
shiny::req(preprocess$checkprep_complete)
preprocess_steps <- preprocess$checkprep_results$preprocess_steps
usethis::ui_info("Performing quality checks & prepping data for usage")
if(preprocess_steps$df_class$convert_to_datatable){
usethis::ui_info(preprocess_steps$df_class$msg)
} else {
usethis::ui_done("Input data is a `data.table`")
}
usethis::ui_line("---- Date/Times Column ----")
if(preprocess_steps$datetime_col$initial_data_type_check_successful){
usethis::ui_done(preprocess_steps$datetime_col$msg)
} else {
usethis::ui_info("Attempting to prepare Date/Time column")
if(preprocess_steps$datetime_col$conversion_successful)
usethis::ui_done(preprocess_steps$datetime_col$msg)
else
usethis::ui_oops(preprocess_steps$datetime_col$msg)
}
usethis::ui_line("---- Tag Column ----")
if(preprocess_steps$tag_col$add_tag_col)
usethis::ui_info(preprocess_steps$tag_col$msg)
if(preprocess_steps$tag_col$NA_replaced)
usethis::ui_info(preprocess_steps$tag_col$msg)
usethis::ui_done("done")
usethis::ui_line("---- Anomaly Column ----")
if(preprocess_steps$anomaly_col$add_anomaly_col)
usethis::ui_info(preprocess_steps$anomaly_col$msg)
if(!preprocess_steps$anomaly_col$only_contains_T_or_F)
usethis::ui_info(preprocess_steps$anomaly_col$msg)
usethis::ui_done("done")
usethis::ui_line("---- Value Column ----")
if(preprocess_steps$value_col$initial_data_type_check_successful)
usethis::ui_done(preprocess_steps$value_col$msg)
usethis::ui_line("---- Other Column ----")
if(preprocess_steps$other_col$other_cols_exist)
usethis::ui_info(preprocess_steps$other_col$msg)
if(!preprocess_steps$other_col$other_cols_exist)
usethis::ui_done(preprocess_steps$other_col$msg)
usethis::ui_line("---- Quality Checks ----")
if(preprocess_steps$quality_checks$anomaly1_tag_empty)
usethis::ui_warn(preprocess_steps$quality_checks$anomaly1_tag_empty_msg)
if(preprocess_steps$quality_checks$anomaly0_tag_nonempty)
usethis::ui_warn(preprocess_steps$quality_checks$anomaly0_tag_nonempty_msg)
usethis::ui_done("Sorted data by date/time & group (if present)")
usethis::ui_done("done")
usethis::ui_line("---- Data Information ----")
usethis::ui_info(paste0("Total rows: ", preprocess_steps$metadata$total_pts))
usethis::ui_info(paste0("Unique Group Levels: ", preprocess_steps$metadata$total_grps))
usethis::ui_info(paste0("Count of existing anomalies: ", preprocess_steps$metadata$count_existing_anomalies))
usethis::ui_info(paste0("Custom anomaly tags: ", preprocess_steps$metadata$custom_tags))
usethis::ui_line("---- CHECK & PREP RESULT ----")
if(preprocess_steps$go_nogo)
usethis::ui_done("Data ready for labeling")
else
usethis::ui_oops("Something's not quite right.")
})
output$ui_select_btn_after_checkprep <- shiny::renderUI({
shiny::req(preprocess$enable_select_btn)
shiny::tagList(
hr(),
shinyWidgets::actionBttn(
inputId = "btn_selectdata_df",
label = "Select Data",
color = "success",
style = "material-flat",
size = "xs"
)
)
})
shiny::observeEvent(input$btn_selectdata_df, {
chklist <- preprocess$checkprep_results$preprocess_steps
# Store metadata
metadata$total_pts <- chklist$metadata$total_pts
metadata$total_grps <- chklist$metadata$total_grps
metadata$count_existing_anomalies <- chklist$metadata$count_existing_anomalies
metadata$tag_choices <- chklist$metadata$tag_choices
metadata$tag_values <- chklist$metadata$tag_values
metadata$tag_selected <- metadata$tag_values[1]
metadata$col_list <- chklist$col_list
metadata$grp_unique_list <- chklist$metadata$grp_unique_list
metadata$grp_selected <- chklist$metadata$grp_unique_list[1]
# Store data to `select`
working_data$dat <- preprocess$checkprep_results$preprocessed_df
preprocess$checkprep_results$preprocessed_df <- NULL
# Switch to labeler tab
shiny::updateNavbarPage(session = session,
inputId = "main_navbar",
selected = "Label")
shinyjs::show(selector = "#main_navbar li a[data-value=features]")
shinyjs::show(selector = "#main_navbar li a[data-value=label]")
shinyjs::show(selector = "#main_navbar li a[data-value=save]")
})
#----------------------------------------------------
# Input Data UI - CSV
shiny::observeEvent(input$filein_rawdata, {
preprocess$csv_preview <- data.table::fread(
file = input$filein_rawdata$datapath,
sep = input$filein_sep,
quote = input$filein_quote,
header = as.logical(input$filein_header)
)
preprocess$df_name <- input$filein_rawdata$name
preprocess$sample <- head(preprocess$csv_preview, 6)
preprocess$col_names <- colnames(preprocess$sample)
preprocess$numeric_cols <-
colnames(preprocess$sample)[sapply(preprocess$sample, is.numeric)]
if (".tag" %in% preprocess$col_names) {
preprocess$preselected_tag <- ".tag"
preprocess$choices_tag <- preprocess$col_names
} else {
preprocess$preselected_tag <- "No tag column"
preprocess$choices_tag <-
c(preprocess$preselected_tag,
preprocess$col_names)
}
if (".anomaly" %in% preprocess$col_names) {
preprocess$preselected_anomaly <- ".anomaly"
preprocess$choices_anomaly <- preprocess$col_names
} else {
preprocess$preselected_anomaly <- "No anomaly column"
preprocess$choices_anomaly <-
c(preprocess$preselected_anomaly,
preprocess$col_names)
}
if (".grp" %in% preprocess$col_names) {
preprocess$preselected_grp <- ".grp"
preprocess$choices_grp <- preprocess$col_names
} else {
preprocess$preselected_grp <- "No group column"
preprocess$choices_grp <- c(preprocess$preselected_grp,
preprocess$col_names)
}
preprocess$enable_csv_select_btn <- FALSE
preprocess$checkprep_csv_complete <- FALSE
})
output$DT_filein_preview <- DT::renderDT({
shiny::req(preprocess$csv_preview)
DT::datatable(preprocess$csv_preview,
autoHideNavigation = T,
class = 'cell-border compact',
options = list(dom = 'ft'
# deferRender = TRUE,
# scrollY = 100,
# scroller = TRUE
),
extensions = "Scroller",
caption = htmltools::tags$caption(
style = 'caption-side: bottom; text-align: center;',
'', htmltools::em(paste0('CSV Preview'))
)
)
})
output$ui_select_csv <- shiny::renderUI({
shiny::req(preprocess$csv_preview)
shiny::tagList(
hr(),
tags$style(
type = 'text/css',
".selectize-input {font-size: 13px; line-height: 13px;} .selectize-dropdown { font-size: 13px; line-height: 13px; }"
),
shiny::selectInput(
inputId = "picker_csv_select_datecol",
label = "Date/Time Column",
choices = preprocess$col_names,
selected = preprocess$col_names[1],
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_csv_select_grpcol",
label = "Group Column",
choices = preprocess$choices_grp,
selected = preprocess$preselected_grp,
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_csv_select_valuecol",
label = "Value Column",
choices = preprocess$numeric_cols,
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_csv_select_tagcol",
label = "Tag Column",
choices = preprocess$choices_tag,
selected = preprocess$preselected_tag,
multiple = FALSE
),
shiny::selectInput(
inputId = "picker_csv_select_anomalycol",
label = "Anomaly Column",
choices = preprocess$choices_anomaly,
selected = preprocess$preselected_anomaly,
multiple = FALSE
),
hr(),
shinyWidgets::actionBttn(
inputId = "btn_checkprep_csv",
label = "Check & Prepare",
style = "material-flat",
size = "xs"
)
)
})
shiny::observeEvent(input$btn_checkprep_csv, {
preprocess$picker_select_datecol <- input$picker_csv_select_datecol
preprocess$picker_select_grpcol <- input$picker_csv_select_grpcol
preprocess$picker_select_valuecol <- input$picker_csv_select_valuecol
preprocess$picker_select_tagcol <- input$picker_csv_select_tagcol
preprocess$picker_select_anomalycol <- input$picker_csv_select_anomalycol
preprocess$checkprep_results <- tslabeler:::checkprep_dt_from_env(
df_full = preprocess$csv_preview,
picker_select_datecol = preprocess$picker_select_datecol,
picker_select_grpcol = preprocess$picker_select_grpcol,
picker_select_valuecol = preprocess$picker_select_valuecol,
picker_select_tagcol = preprocess$picker_select_tagcol,
picker_select_anomalycol = preprocess$picker_select_anomalycol
)
if(preprocess$checkprep_results$preprocess_steps$go_nogo)
preprocess$enable_csv_select_btn <- TRUE
else
preprocess$enable_csv_select_btn <- FALSE
preprocess$checkprep_csv_complete <- TRUE
})
output$ui_check_csv <- shiny::renderPrint({
shiny::req(preprocess$checkprep_csv_complete)
preprocess_steps <- preprocess$checkprep_results$preprocess_steps
usethis::ui_info("Performing quality checks & prepping data for usage")
usethis::ui_line("---- Date/Times Column ----")
if(preprocess_steps$datetime_col$initial_data_type_check_successful){
usethis::ui_done(preprocess_steps$datetime_col$msg)
} else {
usethis::ui_info("Attempting to prepare Date/Time column")
if(preprocess_steps$datetime_col$conversion_successful)
usethis::ui_done(preprocess_steps$datetime_col$msg)
else
usethis::ui_oops(preprocess_steps$datetime_col$msg)
}
usethis::ui_line("---- Tag Column ----")
if(preprocess_steps$tag_col$add_tag_col)
usethis::ui_info(preprocess_steps$tag_col$msg)
if(preprocess_steps$tag_col$NA_replaced)
usethis::ui_info(preprocess_steps$tag_col$msg)
usethis::ui_done("done")
usethis::ui_line("---- Anomaly Column ----")
if(preprocess_steps$anomaly_col$add_anomaly_col)
usethis::ui_info(preprocess_steps$anomaly_col$msg)
if(!preprocess_steps$anomaly_col$only_contains_T_or_F)
usethis::ui_info(preprocess_steps$anomaly_col$msg)
usethis::ui_done("done")
usethis::ui_line("---- Value Column ----")
if(preprocess_steps$value_col$initial_data_type_check_successful)
usethis::ui_done(preprocess_steps$value_col$msg)
usethis::ui_line("---- Other Column ----")
if(preprocess_steps$other_col$other_cols_exist)
usethis::ui_info(preprocess_steps$other_col$msg)
if(!preprocess_steps$other_col$other_cols_exist)
usethis::ui_done(preprocess_steps$other_col$msg)
usethis::ui_line("---- Quality Checks ----")
if(preprocess_steps$quality_checks$anomaly1_tag_empty)
usethis::ui_warn(preprocess_steps$quality_checks$anomaly1_tag_empty_msg)
if(preprocess_steps$quality_checks$anomaly0_tag_nonempty)
usethis::ui_warn(preprocess_steps$quality_checks$anomaly0_tag_nonempty_msg)
usethis::ui_done("Sorted data by date/time & group (if present)")
usethis::ui_done("done")
usethis::ui_line("---- Data Information ----")
usethis::ui_info(paste0("Total rows: ", preprocess_steps$metadata$total_pts))
usethis::ui_info(paste0("Unique Group Levels: ", preprocess_steps$metadata$total_grps))
usethis::ui_info(paste0("Count of existing anomalies: ", preprocess_steps$metadata$count_existing_anomalies))
usethis::ui_info(paste0("Custom anomaly tags: ", preprocess_steps$metadata$custom_tags))
usethis::ui_line("---- CHECK & PREP RESULT ----")
if(preprocess_steps$go_nogo)
usethis::ui_done("Data ready for labeling")
else
usethis::ui_oops("Something's not quite right.")
})
output$ui_select_btn_after_checkprep_csv <- shiny::renderUI({
shiny::req(preprocess$enable_csv_select_btn)
shiny::tagList(
br(),
shinyWidgets::actionBttn(
inputId = "btn_selectdata_csv",
label = "Select Data",
color = "success",
style = "material-flat",
size = "xs"
)
)
})
shiny::observeEvent(input$btn_selectdata_csv, {
chklist <- preprocess$checkprep_results$preprocess_steps
# Store metadata
metadata$total_pts <- chklist$metadata$total_pts
metadata$total_grps <- chklist$metadata$total_grps
metadata$count_existing_anomalies <- chklist$metadata$count_existing_anomalies
metadata$tag_choices <- chklist$metadata$tag_choices
metadata$tag_values <- chklist$metadata$tag_values
metadata$tag_selected <- metadata$tag_values[1]
metadata$col_list <- chklist$col_list
metadata$grp_unique_list <- chklist$metadata$grp_unique_list
metadata$grp_selected <- chklist$metadata$grp_unique_list[1]
# Store data to `select`
working_data$dat <- preprocess$checkprep_results$preprocessed_df
preprocess$checkprep_results$preprocessed_df <- NULL
# Switch to labeler tab
shinyjs::show(selector = "#main_navbar li a[data-value=features]")
shinyjs::show(selector = "#main_navbar li a[data-value=label]")
shinyjs::show(selector = "#main_navbar li a[data-value=save]")
shiny::updateNavbarPage(session = session,
inputId = "main_navbar",
selected = "Label")
})
#----------------------------------------------------
# Labeler
output$ui_labeler_sidemenu <- shiny::renderUI({
fluidPage(
tags$style(
type = 'text/css',
".selectize-input {font-size: 13px; line-height: 13px;}
.selectize-dropdown { font-size: 13px; line-height: 13px; } .filter-option-inner-inner {font-size: 13px; line-height: 13px;} .shiny-date-range-input {font-size: 13px; line-height: 13px;}"
),
if(metadata$col_list$grpcol != "No group column"){
tagList(
fluidRow(
shinyWidgets::pickerInput(
inputId = "labeler_picker_grp",
label = "Group",
choices = metadata$grp_unique_list,
selected = metadata$grp_selected,
options = shinyWidgets::pickerOptions(liveSearch = TRUE,
actionsBox = TRUE,
size = 10),
multiple = TRUE
),
shinyWidgets::actionBttn(
inputId = "labeler_btn_selectgrp",
label = "Select Group",
style = "material-flat",
color = "primary",
size = "xs"
)
),
hr()
)
},
fluidRow(
shiny::dateRangeInput(
inputId = "labeler_daterange",
label = "Date range",
start = working_data$dat[, min(get(metadata$col_list$datecol))],
end = working_data$dat[, max(get(metadata$col_list$datecol))],
weekstart = 1,
format = "dd M yy"
)
),
fluidRow(
shinyWidgets::awesomeCheckboxGroup(
inputId = "labeler_chkbox_plotopts",
label = "Plot Options",
choices = c(
"Show Anomalies",
"Show Legend"
),
status = "danger",
selected = plotopts$labeler_chkbox_plotopts
),
hr()
),
fluidRow(
shinyWidgets::actionBttn(
inputId = "labeler_btn_newtag",
label = "Custom Tag",
style = "material-flat",
color = "primary",
size = "xs"
)
),
br(),
fluidRow(
shinyWidgets::awesomeRadio(
inputId = "labeler_radio_taglist",
label = "Tags",
choices = metadata$tag_choices,
selected = metadata$tag_selected,
inline = F,
status = "danger"
)
),
fluidRow(
shinyWidgets::actionBttn(
inputId = "labeler_mark",
label = "Mark Tags",
style = "material-flat",
size = "xs",
icon = shiny::icon("bullseye"))
)
)
})
filtered_data <- shiny::reactive({
input$labeler_btn_selectgrp
if(!is.null(metadata$grp_unique_list))
filt_dat <- working_data$dat[get(metadata$col_list$grpcol) %in% shiny::isolate(input$labeler_picker_grp)]
else
filt_dat <- working_data$dat
filt_dat <-
filt_dat[data.table::between(
get(metadata$col_list$datecol),
as.POSIXct(as.character(input$labeler_daterange[1]), tz = "UTC"),
as.POSIXct(as.character(input$labeler_daterange[2]), tz = "UTC")
)]
metadata$pts_selected_grps <- filt_dat[, .N]
filt_dat
})
shiny::observeEvent(input$labeler_btn_selectgrp, {
metadata$grp_selected <- shiny::isolate(input$labeler_picker_grp)
})
shiny::observeEvent(input$labeler_radio_taglist, {
metadata$tag_selected <- input$labeler_radio_taglist
})
shiny::observeEvent(input$labeler_chkbox_plotopts, {
plotopts$labeler_chkbox_plotopts <- input$labeler_chkbox_plotopts
})
shiny::observeEvent(input$labeler_btn_newtag, {
shiny::showModal(
shiny::modalDialog(
shiny::textInput(
inputId = "textinput_customtag",
label = "What's your custom tag?"
),
footer = shiny::tagList(shiny::actionButton("labeler_btn_customtag_ok", "Add")),
easyClose = TRUE
)
)
})
shiny::observeEvent(input$labeler_btn_customtag_ok, {
if (input$textinput_customtag != "") {
metadata$tag_values <- c(
metadata$tag_values,
input$textinput_customtag
)
metadata$tag_choices <- c(
metadata$tag_choices,
input$textinput_customtag
)
}
})
shiny::observeEvent(input$user_dblclick, {
if (plotopts$labeler_brush_direction == "xy") {
plotopts$labeler_brush_direction <- "x"
} else {
plotopts$labeler_brush_direction <- "xy"
}
})
shiny::observeEvent(input$user_dblclick_zoomed, {
if (plotopts$labeler_brush_direction_zoomed == "xy") {
plotopts$labeler_brush_direction_zoomed <- "x"
} else {
plotopts$labeler_brush_direction_zoomed <- "xy"
}
})
output$labeler_plot_tsplot <- shiny::renderPlot(
{
shiny::req(working_data$dat)
dat <- filtered_data()
# dat <- working_data$filter_dat
tags <- dat[get(metadata$col_list$anomalycol) == 1, unique(get(metadata$col_list$tagcol))]
tag_colors <- 1:length(tags)
names(tag_colors) <- tags
metadata$tag_color <- tag_colors
par(mar = c(3,2,0.2,0.2)) #(bottom, left, top, right)
tslabeler:::ts_plotter(dat = dat,
col_list = metadata$col_list,
plotopts = input$labeler_chkbox_plotopts,
colors = tag_colors,
grp_unique_list = metadata$grp_unique_list)
},
res = 65
)
output$labeler_ui_tsplot <- shiny::renderUI({
shinycssloaders::withSpinner(
shiny::plotOutput("labeler_plot_tsplot",
brush = brushOpts(
id = "user_brush",
direction = plotopts$labeler_brush_direction
),
dblclick = "user_dblclick",
height = "390px"
)
)
})
selectedPoints <- shiny::reactive({
shiny::brushedPoints(
df = filtered_data(),
brush = input$user_brush,
xvar = "ds",
yvar = "value"
)
})
output$labeler_tsplot_zoomed <- shiny::renderPlot(
{
shiny::req(input$user_brush)
dat <- selectedPoints()
shiny::req(dat[, .N] > 0)
# dat[anomaly == 0, tag := ""]
par(mar = c(3,2,0.2,0.2)) #(bottom, left, top, right)
tslabeler:::ts_plotter(dat = dat,
col_list = metadata$col_list,
plotopts = input$labeler_chkbox_plotopts,
colors = metadata$tag_color,
grp_unique_list = metadata$grp_unique_list)
},
res = 65
)
output$labeler_ui_tsplot_zoomed <- shiny::renderUI({
shinycssloaders::withSpinner(
shiny::plotOutput("labeler_tsplot_zoomed",
brush = brushOpts(
id = "user_brush_zoomed",
direction = plotopts$labeler_brush_direction_zoomed
),
dblclick = "user_dblclick_zoomed",
height = "390px"
)
)
})
selectedPoints_zoomed <- shiny::reactive({
shiny::brushedPoints(
df = selectedPoints(),
brush = input$user_brush_zoomed,
xvar = "ds",
yvar = "value"
)
})
output$DT_selectionpreview <- DT::renderDT({
shiny::req(input$user_brush)
# shiny::req(input$user_brush_zoomed)
dat <- selectedPoints_zoomed()
if (nrow(dat) == 0) {
dat <- selectedPoints()
}
DT::datatable(dat,
autoHideNavigation = T,
class = 'cell-border compact',
options = list(dom = 'ft',
deferRender = TRUE,
scrollY = 100,
scroller = TRUE),
extensions = "Scroller",
caption = htmltools::tags$caption(
style = 'caption-side: bottom; text-align: center;',
'', htmltools::em(paste0(dat[,.N], ' points selected'))
)
) %>%
DT::formatDate(columns = metadata$col_list$datecol,
method = "toISOString")
})
shiny::observeEvent(input$labeler_mark, {
seldat <- selectedPoints_zoomed()
if (nrow(seldat) == 0) {
seldat <- selectedPoints()
}
seldat[, c(metadata$col_list$anomalycol) := ifelse(input$labeler_radio_taglist == "remove tag", F, T)]
seldat[, c(metadata$col_list$tagcol) := input$labeler_radio_taglist]
if(!is.na(metadata$grp_unique_list))
unmodified <- working_data$dat[!seldat, on = c(metadata$col_list$datecol, metadata$col_list$grpcol)]
if(is.na(metadata$grp_unique_list))
unmodified <- working_data$dat[!seldat, on = c(metadata$col_list$datecol)]
new <- data.table::rbindlist(list(unmodified, seldat))
data.table::setkeyv(new, metadata$col_list$datecol)
working_data$dat <- new
})
output$labeler_metatable <- shiny::renderTable({
shiny::req(working_data$dat)
dat <- filtered_data()
if (!is.na(metadata$grp_unique_list))
meta <- data.table::data.table(
Parameter = c(
"Groups (Selected/Total)",
"Pts in Selected Groups",
"Pts in Filtered View",
"Anomalies in Filtered View"
),
Value = c(
paste0(dat[, length(unique(get(metadata$col_list$grpcol)))], "/", metadata$total_grps),
scales::label_number_si(accuracy = 0.01)(metadata$pts_selected_grps),
scales::label_number_si(accuracy = 0.01)(dat[, .N]),
scales::label_number_si(accuracy = 1)(dat[, sum(get(metadata$col_list$anomalycol))])
)
)
else
meta <- data.table::data.table(
Parameter = c(
"Pts in Filtered View",
"Anomalies in Filtered View"
),
Value = c(
scales::label_number_si(accuracy = 0.01)(dat[, .N]),
scales::label_number_si(accuracy = 1)(dat[, sum(get(metadata$col_list$anomalycol))])
)
)
meta
},
spacing = "s",
colnames = FALSE,
bordered = FALSE
)
#----------------------------------------------------
# Features
featpreview <- shiny::reactive({
list(
"data" = working_data$dat[1:10],
"count" = scales::label_comma()(working_data$dat[,.N])
)
})
output$DT_featpreview <- DT::renderDT({
input$btn_dofeat
featpreview()$data %>%
DT::datatable(
autoHideNavigation = T,
class = 'cell-border compact',
options = list(dom = 't',
deferRender = TRUE
# scrollY = 100,
# scroller = TRUE
),
extensions = "Scroller",
caption = htmltools::tags$caption(
style = 'caption-side: bottom; text-align: center;',
'', htmltools::em(paste0('Previewing 10 / ', featpreview()$count , ' points'))
)) %>%
DT::formatDate(columns = metadata$col_list$datecol,
method = "toISOString")
})
shiny::observeEvent(input$btn_dofeat, {
dat <- working_data$dat
if(input$feat_monthnum){
dat[, .month_num := lubridate::month(get(metadata$col_list$datecol))]
}
if(input$feat_monthname){
dat[, .month := lubridate::month(get(metadata$col_list$datecol), label = TRUE)]
}
if(input$feat_qtr){
dat[, .qtr := lubridate::quarter(get(metadata$col_list$datecol))]
}
if(input$feat_wday){
dat[, .wkday := ifelse(lubridate::wday(get(metadata$col_list$datecol), label = TRUE) %in% c("Sat", "Sun"),
TRUE, FALSE)]
}
if(input$feat_daywk){
dat[, .day := lubridate::wday(get(metadata$col_list$datecol), label = TRUE)]
}
working_data$dat <- dat
})
#----------------------------------------------------
# Save
output$DT_savetodisk <- DT::renderDataTable({
shiny::req(working_data$dat)
working_data$dat %>%
DT::datatable(
class = 'cell-border compact',
options = list(dom = 'Bfti',
pageLength = 20,
deferRender = TRUE,
scrollY = 100,
scroller = TRUE,
buttons = list(
list(
extend = "collection",
text = 'Download CSV',
action = DT::JS("function ( e, dt, node, config ) {Shiny.setInputValue('download_working_dat', true, {priority: 'event'});}")
)
)),
extensions = c("Scroller", "Buttons")
)
})
output$download_working_dat <- downloadHandler(
filename = paste0(preprocess$df_name, ".csv"),
content = function(file){
data.table::fwrite(working_data$dat, file)
})
observeEvent(input$download_working_dat, {
sm <- div(
id = "download_working_dat",
shiny::modalDialog(shiny::downloadButton("download_working_dat",
"Download the data"),
easyClose = TRUE, title = "Download Table")
)
shiny::showModal(ui = sm)
})
shiny::observeEvent(input$btn_save_to_env, {
assign(preprocess$df_name, working_data$dat, envir = .GlobalEnv)
})
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.