# # This is the server logic of a Shiny web application. You can run the # application by clicking 'Run App' above. # # Find out more about building applications with Shiny here: # # http://shiny.rstudio.com/ # ###########3 devtools::install_github("apache/arrow/r", ref = "tags/apache-arrow-14.0.0", subdir = "arrow/r") source("./server-helper.R") shinyServer(function(input, output, session) { options(shiny.verbose = TRUE) #options(shiny.error = function() { # traceback() # stopApp() #}) ###################### # REACTIVES VALUES # ###################### # Reactive values created to update the current range of the main slider input #slider_range <- reactiveValues(min_value = 1, max_value = 2) # Reactive value created to keep updated the selected precomputed clusters_labels artifact precomputed_clusters <- reactiveValues(selected = NULL) # Reactive value created to keep updated the selected clustering option clustering_options <- reactiveValues(selected = "no_clusters") # Reactive value created to configure the graph brush ranges <- reactiveValues(x = NULL, y = NULL) # Reactive value created to configure clusters options clusters_config <- reactiveValues( metric_hdbscan = DEFAULT_VALUES$metric_hdbscan, min_cluster_size_hdbscan = DEFAULT_VALUES$min_cluster_size_hdbscan, min_samples_hdbscan = DEFAULT_VALUES$min_samples_hdbscan, cluster_selection_epsilon_hdbscan = DEFAULT_VALUES$cluster_selection_epsilon_hdbscan ) # Reactive values created to configure the appearance of the projections graph. config_style <- reactiveValues( path_line_size = DEFAULT_VALUES$path_line_size, path_alpha = DEFAULT_VALUES$path_alpha, point_alpha = DEFAULT_VALUES$point_alpha, point_size = DEFAULT_VALUES$point_size ) # Reactive value created to store time series selected variables ts_variables <- reactiveValues(selected = NULL) # Reactive value created to store the encoder_input X <- reactiveVal() # Reactive value created to store encoder artifact stride enc_ar_stride <- eventReactive(enc_ar(), { stride = ceiling(enc_ar()$metadata$stride/2) }) # Time series artifact ts_ar <- eventReactive( input$dataset, { req(input$dataset) ar <- api$artifact(input$dataset, type='dataset') on.exit({print("eventReactive ts_ar -->"); flush.console()}) ar }, label = "ts_ar") # Reactive value for indexing saved projections plot prj_plot_id <- reactiveVal(0) ################################# # OBSERVERS & OBSERVERS EVENTS # ################################# observeEvent( req(exists("encs_l")), { freezeReactiveValue(input, "dataset") print("observeEvent encoders list enc_l | update dataset list | after freeze") updateSelectizeInput( session = session, inputId = "dataset", choices = encs_l %>% map(~.$metadata$train_artifact) %>% set_names() ) on.exit({print("observeEvent encoders list encs_l | update dataset list -->"); flush.console()}) }, label = "input_dataset" ) observeEvent(input$dataset, { #req(encs_l) print("--> observeEvent input_dataset | update encoder list") print(input$dataset) freezeReactiveValue(input, "encoder") print(paste0("observeEvent input_dataset | update encoders for dataset ", input$dataset)) updateSelectizeInput( session = session, inputId = "encoder", choices = encs_l %>% keep(~ .$metadata$train_artifact == input$dataset) %>% #map(~ .$metadata$enc_artifact) %>% names ) ### TODO: Ver cómo poner bien esta ñapa para que no se actualizen los gráficos antes que el stride updateSliderInput(session, "stride", value = 0) ################ on.exit( {print("observeEvent input_dataset | update encoder list -->"); flush.console()} ) }, label = "input_encoder") observeEvent( input$encoder, { #req(input$dataset, encs_l) #enc_ar = req(enc_ar()) print("--> observeEvent input_encoder | update wlen") freezeReactiveValue(input, "wlen") print("observeEvent input_encoder | update wlen | Before enc_ar") enc_ar = enc_ar() print(paste0("observeEvent input_encoder | update wlen | enc_ar: ", enc_ar)) print("observeEvent input_encoder | update wlen | Set wlen slider values") if (is.null(enc_ar$metadata$mvp_ws)) { print("observeEvent input_encoder | update wlen | Set wlen slider values from w | ") enc_ar$metadata$mvp_ws = c(enc_ar$metadata$w, enc_ar$metadata$w) } print(paste0("observeEvent input_encoder | update wlen | enc_ar$metadata$mvp_ws ", enc_ar$metadata$mvp_ws )) wmin <- enc_ar$metadata$mvp_ws[1] wmax <- enc_ar$metadata$mvp_ws[2] wlen <- enc_ar$metadata$w print(paste0("observeEvent input_encoder | update wlen | Update slider input (", wmin, ", ", wmax, " ) -> ", wlen )) updateSliderInput(session = session, inputId = "wlen", min = wmin, max = wmax, value = wlen ) updateSliderInput( session = session, inputId = "stride", min = 1, max = input$wlen, value = enc_ar_stride() ) on.exit({print("observeEvent input_encoder | update wlen -->"); flush.console()}) } ) # Obtener el valor de stride enc_ar_stride = reactive({ print("--> reactive enc_ar_stride") stride = ceiling(enc_ar()$metadata$mvp_ws[2]/2) #<- enc_ar()$metadata$stride on.exit({print(paste0("reactive_enc_ar_stride | --> ", stride)); flush.console()}) stride }) observeEvent(input$wlen, { req(input$wlen) print(paste0("--> observeEvent input_wlen | update slide stride value | wlen ", input$wlen)) tryCatch({ old_value = input$stride if (input$stride == 0 | input$stride == 1){ old_value = enc_ar_stride() print(paste0("enc_ar_stride: ", old_value)) } freezeReactiveValue(input, "stride") print(paste0("oserveEvent input_wlen | update slide stride value | Update stride to ", old_value)) updateSliderInput( session = session, inputId = "stride", min = 1, max = input$wlen, value = ifelse(old_value <= input$wlen, old_value, 1) ) }, error = function(e){ print(paste0("observeEvent input_wlen | update slide stride value | Error | ", e$message)) }, warning = function(w) { message(paste0("observeEvent input_wlen | update slide stride value | Warning | ", w$message)) } ) on.exit({print(paste0( "observeEvent input_wlen | update slide stride value | Finally | wlen min ", 1, " max ", input$wlen, " current value ", input$stride, " -->")); flush.console()}) }) # Update "metric_hdbscan" selectInput when the app is loaded observe({ updateSelectInput( session = session, inputId = "metric_hdbscan", choices = names(req(hdbscan_metrics)) ) }) # Update the range of point selection when there is new data # observeEvent(X(), { # #max_ = ts_ar()$metadata$TS$n_samples # max_ = dim(X())[[1]] # freezeReactiveValue(input, "points_emb") # updateSliderInput(session = session, inputId = "points_emb", # min = 1, max = max_, value = c(1, max_)) # }) # Update selected time series variables and update interface config observeEvent(tsdf(), { print("--> observeEvent tsdf | update select variables") on.exit({print("--> observeEvent tsdf | update select variables -->"); flush.console()}) freezeReactiveValue(input, "select_variables") #ts_variables$selected = names(tsdf())[names(tsdf()) != "timeindex"] ts_variables$selected = names(isolate(tsdf())) print(paste0("observeEvent tsdf | select variables ", ts_variables$selected)) updateCheckboxGroupInput( session = session, inputId = "select_variables", choices = ts_variables$selected, selected = ts_variables$selected ) }, label = "select_variables") # Update precomputed_clusters reactive value when the input changes observeEvent(input$clusters_labels_name, { print("--> observe | precomputed_cluster selected ") precomputed_clusters$selected <- req(input$clusters_labels_name) print(paste0("observe | precomputed_cluster selected --> | ", precomputed_cluster$selected)) }) # Update clustering_options reactive value when the input changes observe({ print("--> Observe clustering options") clustering_options$selected <- req(input$clustering_options) print("Observe clustering options -->") }) # Update clusters_config reactive values when user clicks on "calculate_clusters" button observeEvent(input$calculate_clusters, { print("--> observe event calculate_clusters | update clusters_config") clusters_config$metric_hdbscan <- req(input$metric_hdbscan) clusters_config$min_cluster_size_hdbscan <- req(input$min_cluster_size_hdbscan) clusters_config$min_samples_hdbscan <- req(input$min_samples_hdbscan) clusters_config$cluster_selection_epsilon_hdbscan <- req(input$cluster_selection_epsilon_hdbscan) #on.exit({print("observe event calculate_clusters | update clusters_config -->")) }) # Observe the events related to zoom the projections graph observeEvent(input$zoom_btn, { print("--> observeEvent zoom_btn") brush <- input$projections_brush if (!is.null(brush)) { if(isTRUE(input$zoom_btn)){ ranges$x <- c(brush$xmin, brush$xmax) ranges$y <- c(brush$ymin, brush$ymax) }else { ranges$x <- NULL ranges$y <- NULL } } else { ranges$x <- NULL ranges$y <- NULL } }) # Observe the events related to change the appearance of the projections graph observeEvent(input$update_prj_graph,{ style_values <- list(path_line_size = input$path_line_size , path_alpha = input$path_alpha, point_alpha = input$point_alpha, point_size = input$point_size) if (!is.null(style_values)) { config_style$path_line_size <- style_values$path_line_size config_style$path_alpha <- style_values$path_alpha config_style$point_alpha <- style_values$point_alpha config_style$point_size <- style_values$point_size } else { config_style$path_line_size <- NULL config_style$path_alpha <- NULL config_style$point_alpha <- NULL config_style$point_size <- NULL } }) # Update ts_variables reactive value when time series variable selection changes observeEvent(input$select_variables, { ts_variables$selected <- input$select_variables }) # Observe to check/uncheck all variables observeEvent(input$selectall,{ req(tsdf) ts_variables$selected <- names(isolate(tsdf())) if(input$selectall %%2 == 0){ updateCheckboxGroupInput(session = session, inputId = "select_variables", choices = ts_variables$selected, selected = ts_variables$selected) } else { updateCheckboxGroupInput(session = session, inputId = "select_variables", choices = ts_variables$selected, selected = NULL) } }) # Observe to update encoder input (enc_input = X()) observe({ #Event(input$dataset, input$encoder, input$wlen, input$stride, { req(input$wlen != 0, input$stride != 0, input$stride != 1) print(paste0("Check reactiveness | X | wlen, stride |")) if ( is.null(X()) || !identical( input$dataset, isolate(input$dataset)) || !identical(input$encoder, isolate(input$encoder)) || input$wlen != isolate(input$wlen) || input$stride != isolate(input$stride) ) { print("--> ReactiveVal X | Update Sliding Window") print(paste0("reactive X | wlen ", input$wlen, " | stride ", input$stride, " | Let's prepare data")) print("reactive X | SWV") t_x_0 <- Sys.time() enc_input = dvats$exec_with_feather_k_output( function_name = "prepare_forecasting_data", module_name = "tsai.data.preparation", path = file.path(DEFAULT_PATH_WANDB_ARTIFACTS, ts_ar()$metadata$TS$hash), k_output = as.integer(0), print_flag = TRUE, time_flag = TRUE, fcst_history = input$wlen ) t_x_1 <- Sys.time() t_sliding_window_view = t_x_1 - t_x_0 print(paste0("reactive X | SWV: ", t_sliding_window_view, " secs ")) print(paste0("reactive X | Update sliding window | Apply stride ", input$stride," | enc_input ~ ", dim(enc_input), "-->")) print("| Update | X" ) on.exit({print("| Outside| X"); flush.console()}) X(enc_input) } X() }) ############### # REACTIVES # ############### # Get timeseries artifact metadata ts_ar_config = reactive({ print("--> reactive ts_ar_config | List used artifacts") ts_ar = req(ts_ar()) print(paste0("reactive ts_ar_config | List used artifacts | hash", ts_ar$hash)) list_used_arts = ts_ar$metadata$TS list_used_arts$vars = ts_ar$metadata$TS$vars %>% stringr::str_c(collapse = "; ") list_used_arts$name = ts_ar$name list_used_arts$aliases = ts_ar$aliases list_used_arts$artifact_name = ts_ar$name list_used_arts$id = ts_ar$id list_used_arts$created_at = ts_ar$created_at list_used_arts on.exit({print("reactive ts_ar_config -->"); flush.console()}) }) # Get encoder artifact enc_ar <- eventReactive ( input$encoder, { print(paste0("eventReactive enc_ar | Enc. Artifact: ", input$encoder)) result <- tryCatch({ api$artifact(input$encoder, type = 'learner') }, error = function(e){ print(paste0("eventReactive enc_ar | Error: ", e$message)) NULL }) on.exit({print("envent reactive enc_ar -->"); flush.console()}) result }, ignoreInit = T ) # Encoder enc <- eventReactive( enc_ar(), { req(input$dataset, input$encoder) print("--> eventReactive enc | load encoder ") encoder_artifact <- enc_ar() #Añadido para Jacinto path = file.path(DEFAULT_PATH_WANDB_ARTIFACTS, encoder_artifact$metadata$ref$hash) print(paste0("Reactive enc | Load object ", path )) flush.console() #enc_dir= encoder_artifact$download() #print(paste0("Reactive enc | Load object | enc dir | Test sin root ", enc_dir )) #enc_dir = encoder_artifact$download( # root=DEFAULT_PATH_WANDB_ARTIFACTS #) #print(paste0("Reactive enc | Load object | enc dir ", enc_dir )) print(paste0("eventReactive enc | load encoder | Enc. Artifact: ", input$encoder)) enc <- py_load_object( file.path( DEFAULT_PATH_WANDB_ARTIFACTS, encoder_artifact$metadata$ref$hash ) ) on.exit({print("eventReactive enc | load encoder -->"); flush.console()}) enc }) embs <- reactive({ req(X(), enc_l <- enc()) print("--> reactive embs | get embeddings") if (torch$cuda$is_available()){ print(paste0("CUDA devices: ", torch$cuda$device_count())) } else { print("CUDA NOT AVAILABLE") } t_embs_0 <- Sys.time() print( paste0( "reactive embs | get embeddings | Just about to get embedings. Device number: ", torch$cuda$current_device() ) ) print("reactive embs | get embeddings | Get batch size and dataset") dataset_logged_by <- enc_ar()$logged_by() bs = dataset_logged_by$config$batch_size stride = input$stride print(paste0("reactive embs | get embeddings (set stride set batch size) | Stride ", input$stride, " | batch size: ", bs )) enc_input = X() #chunk_max = 10000000 #shape <- dim(enc_input) #print(paste0("reactive embs | get embeddings (set stride set batch size) | enc_input shape: ", shape )) #chunk_size_ = min(shape[1]*shape[2],chunk_max/(shape[1]*shape[2])) #N = max(3200,floor(chunk_size_/32)) chunk_size = 10000000 #N*32 #print(paste0("reactive embs | get embeddings (set stride set batch size) | Chunk_size ", chunk_size, " | shape[1]*shape[2]: ", shape[1]*shape[2] )) print(paste0("reactive embs | get embeddings (set stride set batch size) | Chunk_size ", chunk_size)) # python_string = paste0(" #import dvats.all cpu_flag = ifelse(input$cpu_flag == "CPU", TRUE, FALSE) result = dvats$get_enc_embs_set_stride_set_batch_size( X = X(), print_flag = TRUE, enc_learn = enc_l, stride = input$stride, batch_size = bs, cpu = cpu_flag, print_flag = FALSE, time_flag = TRUE, chunk_size = chunk_size, check_memory_usage = TRUE ) #result <- system(python_string) t_embs_1 <- Sys.time() diff <- t_embs_1 - t_embs_0 diff_secs <- as.numeric(diff, units = "secs") diff_mins <- as.numeric(diff, units = "mins") print(paste0("get_enc_embs total time: ", diff_secs, " secs thus ", diff_mins, " mins")) X <- NULL gc(verbose=TRUE) on.exit({print("reactive embs | get embeddings -->"); flush.console()}) result }) prj_object_cpu <- reactive({ embs = req(embs(), input$dr_method) embs = embs[complete.cases(embs),] print("--> prj_object") #print(embs) #-- #print(paste0("--> prj_object | UMAP params ", str(umap_params_))) print("--> prj_object | UMAP params ") res = switch( input$dr_method, #### Comprobando parametros para saber por qué salen diferentes los embeddings ######### Comprobando los parámetros #UMAP = dvats$get_UMAP_prjs(input_data = embs, cpu=F, n_neighbors = 15, min_dist = 0.1, random_state=as.integer(1234)), UMAP = dvats$get_UMAP_prjs( input_data = embs, cpu = TRUE, print_flag = TRUE, n_neighbors = input$prj_n_neighbors, min_dist = input$prj_min_dist, random_state= as.integer(input$prj_random_state) ), TSNE = dvats$get_TSNE_prjs( X = embs, cpu = TRUE, random_state=as.integer(input$prj_random_state) ), PCA = dvats$get_PCA_prjs( X = embs, cpu = TRUE, random_state=as.integer(input$prj_random_state) ) ) res = res %>% as.data.frame # TODO: This should be a matrix for improved efficiency colnames(res) = c("xcoord", "ycoord") on.exit({print(" prj_object -->"); flush.console()}) flush.console() #browser() res }) prj_object <- reactive({ req(embs(), input$dr_method) print("--> prj_object") t_prj_0 = Sys.time() embs = req(embs()) print("prj_object | Before complete cases ") embs = embs[complete.cases(embs),] #print(embs) #-- #print(paste0("--> prj_object | UMAP params ", str(umap_params_))) print("prj_object | Before switch ") cpu_flag = ifelse(input$cpu_flag == "CPU", TRUE, FALSE) res = switch( input$dr_method, #### Comprobando parametros para saber por qué salen diferentes los embeddings ######### Comprobando los parámetros #UMAP = dvats$get_UMAP_prjs(input_data = embs, cpu=F, n_neighbors = 15, min_dist = 0.1, random_state=as.integer(1234)), UMAP = dvats$get_UMAP_prjs( input_data = embs, cpu = cpu_flag, print_flag = TRUE, n_neighbors = input$prj_n_neighbors, min_dist = input$prj_min_dist, random_state= as.integer(input$prj_random_state) ), TSNE = dvats$get_TSNE_prjs( X = embs, cpu=FALSE, random_state=as.integer(input$prj_random_state) ), PCA = dvats$get_PCA_prjs( X = embs, cpu=FALSE, random_state=as.integer(input$prj_random_state) ) ) res = res %>% as.data.frame # TODO: This should be a matrix for improved efficiency colnames(res) = c("xcoord", "ycoord") t_prj_1 = Sys.time() on.exit({print(paste0(" prj_object | ", t_prj_1-t_prj_0, " seconds -->")); flush.console()}) flush.console() res }) # Load and filter TimeSeries object from wandb tsdf <- reactive( { req(input$encoder, ts_ar()) ts_ar <- req(ts_ar()) print(paste0("--> Reactive tsdf | ts artifact ", ts_ar)) flush.console() t_init <- Sys.time() path = file.path(DEFAULT_PATH_WANDB_ARTIFACTS, ts_ar$metadata$TS$hash) print(paste0("Reactive tsdf | Read feather ", path )) flush.console() #artifact_dir = ts_ar$download(root=DEFAULT_PATH_WANDB_ARTIFACTS) #print(paste0("Reactive tsdf | Read feather | Downloaded: ", artifact_dir)) print(system('ls -la /.artifacts', intern=TRUE)) print(system('ls -la /.artifacts/mvp-SWV:v1', intern=TRUE)) df <- read_feather(path, as_data_frame = TRUE, mmap = FALSE) %>% rename('timeindex' = `__index_level_0__`) t_end = Sys.time() print(paste0("Reactive tsdf | Read feather | Execution time: ", t_end - t_init, " seconds")) flush.console() t_end = Sys.time() on.exit({print(paste0("Reactive tsdf | Column to index | Execution time: ", t_end - t_init, " seconds"));flush.console()}) df }) # Auxiliary object for the interaction ts->projections tsidxs_per_embedding_idx <- reactive({ req(input$wlen != 0, input$stride != 0) get_window_indices(1:nrow(isolate(projections())), w = input$wlen, s = input$stride) }) # Filter the embedding points and calculate/show the clusters if conditions are met. projections <- reactive({ print("--> Projections") req(prj_object(), input$dr_method) #prjs <- req(prj_object()) %>% slice(input$points_emb[[1]]:input$points_emb[[2]]) print("Projections | before prjs") prjs <- prj_object() req(input$dataset, input$encoder, input$wlen, input$stride) print("Projections | before switch") switch(clustering_options$selected, precomputed_clusters = { filename <- req(selected_clusters_labels_ar())$metadata$ref$hash clusters_labels <- py_load_object(filename = file.path(DEFAULT_PATH_WANDB_ARTIFACTS, filename)) #prjs$cluster <- clusters_labels[input$points_emb[[1]]:input$points_emb[[2]]] prjs$cluster <- clusters_labels }, calculate_clusters = { clusters = hdbscan$HDBSCAN( min_cluster_size = as.integer(clusters_config$min_cluster_size_hdbscan), min_samples = as.integer(clusters_config$min_samples_hdbscan), cluster_selection_epsilon = clusters_config$cluster_selection_epsilon_hdbscan, metric = clusters_config$metric_hdbscan )$fit(prjs) score = 0 unique_labels <- unique(clusters$labels_) total_unique_labels <- length(unique_labels) if(total_unique_labels > 1){ score = dvats$cluster_score(prjs, clusters$labels_, TRUE) } print(paste0("Projections | Score ", score)) if (score <= 0) { print(paste0("Projections | Repeat projections with CPU because of low quality clusters | score ", score)) prjs <- prj_object_cpu() clusters = hdbscan$HDBSCAN( min_cluster_size = as.integer(clusters_config$min_cluster_size_hdbscan), min_samples = as.integer(clusters_config$min_samples_hdbscan), cluster_selection_epsilon = clusters_config$cluster_selection_epsilon_hdbscan, metric = clusters_config$metric_hdbscan )$fit(prjs) score = 0 unique_labels <- unique(clusters$labels_) total_unique_labels <- length(unique_labels) if(total_unique_labels > 1){ score = dvats$cluster_score(prjs, clusters$labels_, TRUE) } print(paste0("Projections | Repeat projections with CPU because of low quality clusters | score ", score)) } prjs$cluster <- clusters$labels_ }) on.exit({print("Projections -->"); flush.console()}) prjs }) # Update the colour palette for the clusters update_palette <- reactive({ prjs <- req(projections()) if ("cluster" %in% names(prjs)) { unique_labels <- unique(prjs$cluster) print(unique_labels) ## IF the value "-1" exists, assign the first element of mycolors to #000000, if not, assign the normal colorRampPalette if (as.integer(-1) %in% unique_labels) colour_palette <- append("#000000", colorRampPalette(brewer.pal(12,"Paired"))(length(unique_labels)-1)) else colour_palette <- colorRampPalette(brewer.pal(12,"Paired"))(length(unique_labels)) } else colour_palette <- "red" colour_palette }) color_palete_window_plot <- colorRampPalette( colors = c("blue", "green"), space = "Lab" # Option used when colors do not represent a quantitative scale ) start_date <- reactive({ isolate(tsdf())$timeindex[1] }) end_date <- reactive({ end_date_id = 100000 end_date_id = min(end_date_id, nrow(isolate(tsdf()))) isolate(tsdf())$timeindex[end_date_id] }) ts_plot_base <- reactive({ print("--> ts_plot_base") on.exit({print("ts_plot_base -->"); flush.console()}) start_date =isolate(start_date()) end_date = isolate(end_date()) print(paste0("ts_plot_base | start_date: ", start_date, " end_date: ", end_date)) t_init <- Sys.time() tsdf_ <- isolate(tsdf()) %>% select(ts_variables$selected, - "timeindex") tsdf_xts <- xts(tsdf_, order.by = tsdf()$timeindex) t_end <- Sys.time() print(paste0("ts_plot_base | tsdf_xts time", t_end-t_init)) print(head(tsdf_xts)) print(tail(tsdf_xts)) ts_plt = dygraph( tsdf_xts, width="100%", height = "400px" ) %>% dyRangeSelector(c(start_date, end_date)) %>% dyHighlight(hideOnMouseOut = TRUE) %>% dyOptions(labelsUTC = FALSE ) %>% dyCrosshair(direction = "vertical")%>% dyLegend(show = "follow", hideOnMouseOut = TRUE) %>% dyUnzoom() %>% dyHighlight(highlightSeriesOpts = list(strokeWidth = 3)) %>% dyCSS( textConnection( ".dygraph-legend > span { display: none; } .dygraph-legend > span.highlight { display: inline; }" ) ) }) embedding_ids <- reactive({ print("--> embedding idx") on.exit(print("embedding idx -->")) bp = brushedPoints(prj_object(), input$projections_brush, allRows = TRUE) #%>% debounce(miliseconds) #Wait 1 seconds: 1000 bp %>% rownames_to_column("index") %>% dplyr::filter(selected_ == TRUE) %>% pull(index) %>% as.integer }) window_list <- reactive({ print("--> window_list") on.exit(print("window_list -->")) # Get the window indices req(length(embedding_ids() > 0)) embedding_idxs = embedding_ids() window_indices = get_window_indices(embedding_idxs, input$wlen, input$stride) # Put all the indices in one list and remove duplicates unlist_window_indices = unique(unlist(window_indices)) # Calculate a vector of differences to detect idx where a new window should be created diff_vector <- diff(unlist_window_indices,1) # Take indexes where the difference is greater than one (that represent a change of window) idx_window_limits <- which(diff_vector!=1) # Include the first and last index to have a whole set of indexes. idx_window_limits <- c(1, idx_window_limits, length(unlist_window_indices)) # Create a reduced window list reduced_window_list <- vector(mode = "list", length = length(idx_window_limits)-1) # Populate the first element of the list with the idx of the first window. reduced_window_list[[1]] = c( isolate(tsdf())$timeindex[unlist_window_indices[idx_window_limits[1]+1]], isolate(tsdf())$timeindex[unlist_window_indices[idx_window_limits[2]]] ) # Populate the rest of the list for (i in 2:(length(idx_window_limits)-1)){ reduced_window_list[[i]]<- c( #unlist_window_indices[idx_window_limits[i]+1], #unlist_window_indices[idx_window_limits[i+1]] isolate(tsdf())$timeindex[unlist_window_indices[idx_window_limits[i]+1]], isolate(tsdf())$timeindex[unlist_window_indices[idx_window_limits[i+1]]] ) } reduced_window_list }) # Generate timeseries data for dygraph dygraph ts_plot <- reactive({ print("--> ts_plot | Before req 1") on.exit({print("ts_plot -->"); flush.console()}) req(tsdf(), ts_variables, input$wlen != 0, input$stride) ts_plt = ts_plot_base() print("ts_plot | bp") #miliseconds <- ifelse(nrow(tsdf()) > 1000000, 2000, 1000) #if (!is.data.frame(bp)) {bp = bp_} print("ts_plot | embedings idxs ") embedding_idxs = embedding_ids() # Calculate windows if conditions are met (if embedding_idxs is !=0, that means at least 1 point is selected) print("ts_plot | Before if") if ((length(embedding_idxs)!=0) & isTRUE(input$plot_windows)) { reduced_window_list = req(window_list()) print(paste0("ts_plot | reduced_window_list[1] = ", reduced_window_list[1])) start_indices = min(sapply(reduced_window_list, function(x) x[1])) end_indices = max(sapply(reduced_window_list, function(x) x[2])) view_size = end_indices-start_indices+1 max_size = 10000 start_date = isolate(tsdf())$timeindex[start_indices] end_date = isolate(tsdf())$timeindex[end_indices] print(paste0("ts_plot | reuced_window_list (", start_date, end_date, ")", "view size ", view_size, "max size ", max_size)) if (view_size > max_size) { end_date = isolate(tsdf())$timeindex[start_indices + max_size - 1] #range_color = "#FF0000" # Red } range_color = "#CCEBD6" # Original # # Plot the windows count = 0 for(ts_idxs in reduced_window_list) { count = count + 1 start_event_date = isolate(tsdf())$timeindex[head(ts_idxs, 1)] end_event_date = isolate(tsdf())$timeindex[tail(ts_idxs, 1)] ts_plt <- ts_plt %>% dyShading( from = start_event_date, to = end_event_date, color = range_color ) ts_plt <- ts_plt %>% dyRangeSelector(c(start_date, end_date)) #%>% dyEvent( # start_event_date, # label = paste0("SW-", count), # labelLoc="bottom" , # strokePattern = "solid", # color = range_color # ) %>% dyEvent( # end_event_date, # label = paste0("SW-",paste0("SW-", count), # labelLoc="bottom", # strokePattern = "solid"), # color = range_color # ) } ts_plt <- ts_plt # NOTE: This code block allows you to plot shadyng at once. # The traditional method has to plot the dygraph n times # (n being the number of rectangles to plot). With the adjacent # code it is possible to plot the dygraph only once. Currently # it does not work well because there are inconsistencies in the # timezones of the time series and shiny (there is a two-hour shift[the current plot method works well]), # which does not allow this method to be used correctly. If that # were fixed in the future everything would work fine. # num_rects <- length(reduced_window_list) # rects_ini <- vector(mode = "list", length = num_rects) # rects_fin <- vector(mode = "list", length = num_rects) # for(i in 1:num_rects) { # rects_ini[[i]] <- head(reduced_window_list[[i]],1) # rects_fin[[i]] <- tail(reduced_window_list[[i]],1) # } # ts_plt <- vec_dyShading(ts_plt,rects_ini, rects_fin,"red", rownames(tsdf())) } ts_plt }) # Get projections plot name for saving prjs_plot_name <- reactive({ dataset_name <- basename(input$dataset) encoder_name <- basename(input$encoder) get_prjs_plot_name(dataset_name, encoder_name, clustering_options$selected, prjs_$cluster, prj_plot_id, input) }) # Get timeserie plot name for saving ts_plot_name <- reactive({ dataset_name <- basename(input$dataset) encoder_name <- basename(input$encoder) get_ts_plot_name(dataset_name, encoder_name, prj_plot_id, input) }) ############# # OUTPUTS # ############# output$windows_plot <- renderPlot({ req(length(embedding_ids()) > 0) reduced_window_list = req(window_list()) # Convertir a fechas POSIXct reduced_window_df <- do.call(rbind, lapply(reduced_window_list, function(x) { data.frame( start = as.POSIXct(isolate(tsdf())$timeindex[x[1]], origin = "1970-01-01"), end = as.POSIXct(isolate(tsdf())$timeindex[x[2]], origin = "1970-01-01") ) })) # Establecer límites basados en los datos first_date = min(reduced_window_df$start) last_date = max(reduced_window_df$end) left = as.POSIXct(isolate(tsdf())$timeindex[1], origin = "1970-01-01") right = as.POSIXct(isolate(tsdf())$timeindex[nrow(isolate(tsdf()))], origin = "1970-01-01") # Configuración del gráfico base par(mar = c(5, 4, 4, 0) + 0.1) #Down Up Left Right plt <- plot( NA, xlim = c(left, right), ylim = c(0, 1), type = "n", xaxt = "n", yaxt = "n", xlab = "", ylab = "", bty = "n") f = "%F %H:%M:%S" axis(1, at = as.numeric(c(left, right)), labels = c(format(first_date, f), format(last_date, f)), cex.axis = 0.7) # Añadir líneas verticales colors = color_palete_window_plot(2) abline( v = as.numeric(reduced_window_df$start), col = rep(colors, length.out = nrow(reduced_window_df)), lwd = 1 ) abline( v = as.numeric(reduced_window_df$end), col = rep(colors, length.out = nrow(reduced_window_df)), lwd = 1 ) segments( x0 = as.numeric(reduced_window_df$start), x1 = as.numeric(reduced_window_df$end), y0 = 0, y1 = 0, col = rep(colors, length.out = nrow(reduced_window_df)), lwd = 1 ) text( x = as.numeric(reduced_window_df$start), y = 0, srt = 90, adj = c(1,0.5), labels = paste0("SW-", seq_len(nrow(reduced_window_df)), format(reduced_window_df$start, f)), cex = 1, xpd = TRUE, col = rep(colors, length.out = nrow(reduced_window_df)) ) points(x = as.numeric(left),y = 0, col = "black", pch = 20, cex = 1) points(x = as.numeric(right),y = 0, col = "black", pch = 20, cex = 1) plt }, height=200 ) output$windows_text <- renderUI({ req(length(embedding_ids()) > 0) reduced_window_list = req(window_list()) # Crear un conjunto de etiquetas de texto con información de las ventanas window_info <- lapply(1:length(reduced_window_list), function(i) { window <- reduced_window_list[[i]] start <- format(as.POSIXct(isolate(tsdf())$timeindex[window[1]], origin = "1970-01-01"), "%b %d") end <- format(as.POSIXct(isolate(tsdf())$timeindex[window[2]], origin = "1970-01-01"), "%b %d") color <- ifelse(i %% 2 == 0, "green", "blue") HTML(paste0("
Window ", i, ": ", start, " - ", end, "
")) }) # Devuelve todos los elementos de texto como una lista de HTML do.call(tagList, window_info) }) # Generate encoder info table output$enc_info = renderDataTable({ selected_encoder_name <- req(input$encoder) on.exit({print("Encoder artiffact -->"); flush.console()}) print(paste0("--> Encoder artiffact", selected_encoder_name)) selected_encoder <- encs_l[[selected_encoder_name]] encoder_metadata <- req(selected_encoder$metadata) print(paste0("Encoder artiffact | encoder metadata ", selected_encoder_name)) encoder_metadata %>%enframe() }) # Generate time series info table output$ts_ar_info = renderDataTable({ ts_ar_config() %>% enframe() }) # Generate projections plot output$projections_plot <- renderPlot({ req(input$dataset, input$encoder, input$wlen != 0, input$stride != 0) print("--> Projections_plot") prjs_ <- req(projections()) print("projections_plot | Prepare column highlights") # Prepare the column highlight to color data if (!is.null(input$ts_plot_dygraph_click)) { selected_ts_idx = which(ts_plot()$x$data[[1]] == input$ts_plot_dygraph_click$x_closest_point) projections_idxs = tsidxs_per_embedding_idx() %>% map_lgl(~ selected_ts_idx %in% .) prjs_$highlight = projections_idxs } else { prjs_$highlight = FALSE } # Prepare the column highlight to color data. If input$generate_cluster has not been clicked # the column cluster will not exist in the dataframe, so we create with the value FALSE if(!("cluster" %in% names(prjs_))) prjs_$cluster = FALSE print("projections_plot | GoGo Plot!") plt <- ggplot(data = prjs_) + aes(x = xcoord, y = ycoord, fill = highlight, color = as.factor(cluster)) + scale_colour_manual(name = "clusters", values = req(update_palette())) + geom_point(shape = 21,alpha = config_style$point_alpha, size = config_style$point_size) + scale_shape(solid = FALSE) + #geom_path(size=config_style$path_line_size, colour = "#2F3B65",alpha = config_style$path_alpha) + guides() + scale_fill_manual(values = c("TRUE" = "green", "FALSE" = "NA"))+ coord_cartesian(xlim = ranges$x, ylim = ranges$y, expand = TRUE)+ theme_void() + theme(legend.position = "none") if (input$show_lines){ #plt <- plt + geom_path(size=config_style$path_line_size, colour = "#2F3B65",alpha = config_style$path_alpha) plt <- plt + geom_path(linewidth=config_style$path_line_size, colour = "#2F3B65",alpha = config_style$path_alpha) } observeEvent(input$savePlot, { plt <- plt + theme(plot.background = element_rect(fill = "white")) ggsave(filename = prjs_plot_name(), plot = plt, path = "../data/plots/") }) #observeEvent(c(input$dataset, input$encoder, clustering_options$selected), { #req(input$dataset, input$encoder) #print("!-- CUDA?: ", torch$cuda$is_available()) #prjs_ <- req(projections()) #filename <- prjs_plot_name() #print(paste("saving embedding plot to ",filename)) #ggsave(filename = filename, plot = plt, path="../data/plots/") #print("Embeding plot saved") #}) plt }) # Render projections plot output$projections_plot_ui <- renderUI( { plotOutput( "projections_plot", click = "projections_click", brush = "projections_brush", height = input$embedding_plot_height ) %>% withSpinner() } ) # Render information about the selected point in the time series graph output$point <- renderText({ req(input$ts_plot_dygraph_click$x_closest_point) ts_idx = which(ts_plot()$ts$x$data[[1]] == input$ts_plot_dygraph_click$x_closest_point) paste0('X = ', strftime(req(input$ts_plot_dygraph_click$x_closest_point), "%F %H:%M:%S"), '; Y = ', req(input$ts_plot_dygraph_click$y_closest_point), '; X (raw) = ', req(input$ts_plot_dygraph_click$x_closest_point)) }) # Render information about the selected point and brush in the projections graph output$projections_plot_interaction_info <- renderText({ xy_str <- function(e) { if(is.null(e)) return("NULL\n") paste0("x=", round(e$x, 1), " y=", round(e$y, 1), "\n") } xy_range_str <- function(e) { if(is.null(e)) return("NULL\n") paste0("xmin=", round(e$xmin, 1), " xmax=", round(e$xmax, 1), " ymin=", round(e$ymin, 1), " ymax=", round(e$ymax, 1)) } paste0( "click: ", xy_str(input$projections_click), "brush: ", xy_range_str(input$projections_brush) ) }) # Generate time series plot output$ts_plot_dygraph <- renderDygraph( { req ( input$dataset, input$encoder, input$wlen != 0, input$stride != 0 ) #print("Saving time series plot") ts_plot <- req(ts_plot()) #save_path <- file.path("..", "data", "plots", ts_plot_name()) #htmlwidgets::saveWidget(ts_plot, file = save_path, selfcontained=TRUE) #print(paste0("Time series plot saved to", save_path)) ts_plot #req(ts_plot()) } ) prjs_plot_name <- reactive({ dataset_name <- basename(input$dataset) encoder_name <- basename(input$encoder) get_prjs_plot_name(dataset_name, encoder_name, clustering_options$selected, prjs_$cluster) }) ts_plot_name <- reactive({ dataset_name <- basename(input$dataset) encoder_name <- basename(input$encoder) get_ts_plot_name(dataset_name, encoder_name) }) })