Hallo Edi, hallo Forum,
Edi, vielen Dank für die wirklich gute Hilfe, ich habe die letzten Wochen alles soweit hinbekommen und das Script tut gute Dienste. Also nochmals herzlichen Dank für die super Unterstützung.
Nun habe ich aber eine erneutes Problem mit dem Shiny Script (s.u,), das ich nun auch nach mehrtägiger Suche und intensiven Testes nicht lösen kann, obwohl es trivial erscheint.
Kurz zur Beschreibung:
Das hier gezeigte Script liest den Datensatz("~/R/stat_res_outlier.Rds") in eine Shiny Umgebung ein und benennt in als "selected_data". Ziel ist einzelne Datenpunkte auswähglen zu können und mit einem 'flag_value' 3 als probably bad zu kennzeichnen. Das klappt auch alles prima. Nun aber das Problem:
Ich wende das Script u.a. zur visuellen Abschlusskontrolle eines Datensatze über ein ganzes Jahr an. Da wird der Datensatz recht groß. Aktuell sind es durchschnittlich 2Mio. Datenreihen mit 11 Variablen die eingelesen werden sollten, von denen 4 Variablen visualisiert werden. Das verkraftet Shiny nicht mehr und wird zu langsam oder stürzt ab. Ok, ist einzusehen.
Daher ist nun in dem Datensatz eine Variable vorhandnen, (parameter_value_stud_filter) welche mir zeigt, welche Datenreihen besonders auffällig sind. Das sind dann in der Regel evtl. noch 1000 bis 3000 Datenreihen aus den 2 Mio. Die kann Shiny gut verkraften und das Script läuft. Wenn ich nun bestimmte Punkte in dem Subset von Daten zum Flaggen auswähle (Zeile
subset_data <- selected_data[which(!is.na(selected_data$parameter_value_stud_filter)), ])
macht mein Programm das auch.
Mich interessieren eigentlich nicht die einzelne Datenpunkte in dem Subset sondern der ganze Zeitraum den ein ausgewählter Bereich umspannt. Daher lasse ich mir, wenn ich eine bestimmten Bereich ausgewählt habe
Sektion
observeEvent(input$submit_probably_bad, {
das Startdatum und das Enddatum der Auswahl ausgeben
tmp <- rv$data[which(rv$data$id %in% lasso$key | rv$data$id %in% box$key), ]
flag_from <<- min(tmp$datetime)
flag_to <<- max(tmp$datetime)
und wende das dann NICHT nur auf das subset (subset_data) an (um die Daten zu visualieieren)
rv$data$flag_value <- ifelse(strftime(rv$data$datetime, format="%Y-%m-%d %H:%M:%S") >= flag_from & strftime(rv$data$datetime ,format="%Y-%m-%d %H:%M:%S") <= flag_to, 3, rv$data$flag_value)
rv$data$comment <- ifelse(strftime(rv$data$datetime, format="%Y-%m-%d %H:%M:%S") >= flag_from & strftime(rv$data$datetime ,format="%Y-%m-%d %H:%M:%S") <= flag_to, "Selected as 'probably bad' by manual quality check (level 15)", rv$data$comment)
sondern anschliessend auch auf den gesamten Ursprungsdatensatz (selected_data) an um den gesamten Bereich zu flaggen.
selected_data$flag_value <<- ifelse(strftime(selected_data$datetime, format="%Y-%m-%d %H:%M:%S") >= flag_from & strftime(selected_data$datetime ,format="%Y-%m-%d %H:%M:%S") <= flag_to, 3, selected_data$flag_value)
selected_data$comment <<- ifelse(strftime(selected_data$datetime, format="%Y-%m-%d %H:%M:%S") >= flag_from & strftime(selected_data$datetime ,format="%Y-%m-%d %H:%M:%S") <= flag_to, "Selected as 'probably bad' by manual quality check (level 15)", selected_data$comment)
Soweit die IDEE - aber es klappt nictht, was ich absolut nicht verstehe.
Ich habe zwar die richtigen Flags in meine subset datensatz "rv$data$flag_value" (das zeigt es auch an) aber die Übertragung in den Orginaldatensatz (selected_data$flag_value) geht nicht, egal was ich mache.
Wenn ich das Script ohne die App laufen zu lassen, quasi Zeile für Zeile, funktioniert alles prima und die Übertragung in den Orginaldatensatz geht. Wenn ich das Script aber als App laufen lassen geht es nicht. Es muss also irgendwie daran liegen, dass das Script als App die entspechenden Codezeilen nicht umsetzt.
Da ich an dem Problem nun schon mehrere Tage hänge und es das finle Element des gesamten Programems ist wäre ich für eine Tip / eine Vermutung zum Problem wirklich sehr dankbar.
Ich habe einen Datensatz (stat_res_outlier.Rds) als ZIP file ebenfalls beigelegt.
VG Philipp
Code: Alles auswählen
if (!require("shiny")) install.packages("shiny")
library(shiny)
if (!require("plotly")) install.packages("plotly")
library(plotly)
if (!require("DT")) install.packages("DT")
library(DT)
if (!require("R.filesets")) install.packages("R.filesets")
library(R.filesets)
if (!require("shinyBS")) install.packages("shinyBS")
library(shinyBS)
if (!require("plotly")) install.packages("plotly")
library(plotly)
setwd("~")
getwd()
selected_data <- readRDS("~/R/stat_res_outlier.Rds")
selected_data$flag_value <- ifelse(is.na(selected_data$flag_value),1,selected_data$flag_value)
selected_data$flag_level = 15
selected_data$comment = NA
selected_data$datetime <- as.POSIXct(selected_data$datetime, format = "%Y-%m-%d %H:%M:%S")
selected_data <- selected_data[order(selected_data$datetime),]
selected_data$flag_value <- as.integer(selected_data$flag_value)
subset_data <- selected_data[which(!is.na(selected_data$parameter_value_stud_filter)), ]
ui <- fluidPage(
plotlyOutput("plot"),
br(),
br(),
actionButton("submit_probably_bad", "Flag selection as 'probably bad (level 3)'"),
actionButton("submit_good", "Flag selection as 'good (level 1)'"),
br(),
br(),
actionButton("show_good", "Display only good (level 1) values"),
actionButton("show_1_3", "Display good -> probably bad (level 1-3) values"),
actionButton("show_all", "Display all (level 1-5) values"),
actionButton('save_and_exit',"Exit visual data verification and proceed"),
br(),
br(),
DT::dataTableOutput("table")
)
server <- function(input, output, session) {
data <- subset_data
data$datetime <- as.POSIXct(data$datetime)
# create id column
data$id = rownames(subset_data)
# save as reactive values (we want to modify it and react to this modification)
rv <- reactiveValues(data = data)
observeEvent(input$submit_probably_bad, {
# Change to TRUE if selected by lasso
lasso <- event_data("plotly_selected")
box <- event_data("plotly_selected")
if (!is.null(lasso) | !is.null(box) ) {
tmp <- rv$data[which(rv$data$id %in% lasso$key | rv$data$id %in% box$key), ]
flag_from <<- min(tmp$datetime)
flag_to <<- max(tmp$datetime)
rv$data$flag_value <- ifelse(strftime(rv$data$datetime, format="%Y-%m-%d %H:%M:%S") >= flag_from & strftime(rv$data$datetime ,format="%Y-%m-%d %H:%M:%S") <= flag_to, 3, rv$data$flag_value)
rv$data$comment <- ifelse(strftime(rv$data$datetime, format="%Y-%m-%d %H:%M:%S") >= flag_from & strftime(rv$data$datetime ,format="%Y-%m-%d %H:%M:%S") <= flag_to, "Selected as 'probably bad' by manual quality check (level 15)", rv$data$comment)
}
selected_data$flag_value <<- ifelse(strftime(selected_data$datetime, format="%Y-%m-%d %H:%M:%S") >= flag_from & strftime(selected_data$datetime ,format="%Y-%m-%d %H:%M:%S") <= flag_to, 3, selected_data$flag_value)
selected_data$comment <<- ifelse(strftime(selected_data$datetime, format="%Y-%m-%d %H:%M:%S") >= flag_from & strftime(selected_data$datetime ,format="%Y-%m-%d %H:%M:%S") <= flag_to, "Selected as 'probably bad' by manual quality check (level 15)", selected_data$comment)
output$plot <- renderPlotly({
showdata <- rv$data[ which(rv$data$flag_value == 1), ]
showdata$flag_value <- as.factor(showdata$flag_value)
plot_title = paste("Data between", flag_from, "to", flag_to," flagged as probable bad (3).")
p <- ggplot() +
ggtitle(plot_title) +
geom_point(data = showdata, aes(x = datetime, y = parameter_value_stud_filter, colour = par_id, key = id), size=0.8) +
geom_point(na.rm = TRUE) +
scale_color_brewer(palette = "Set2")
ggplotly(p) %>%
layout(dragmode = "lasso"
, xaxis = list(
rangeslider = list())
, hovermode = "x")
})
})
observeEvent(input$flag_yes, {
# Change to TRUE if selected by lasso
start_time <- input$start_time
stop_time <- input$end_time
rv$data$flag_value <- ifelse(strftime(rv$data$datetime, format="%Y-%m-%d %H:%M:%S") >= start_time & strftime(rv$data$datetime ,format="%Y-%m-%d %H:%M:%S") <= stop_time, 3, rv$data$flag_value)
rv$data$comment <- ifelse(strftime(rv$data$datetime, format="%Y-%m-%d %H:%M:%S") >= start_time & strftime(rv$data$datetime ,format="%Y-%m-%d %H:%M:%S") <= stop_time, "Selected as 'probably bad' by manual quality check (level 15)", rv$data$comment)
output$plot <- renderPlotly({
showdata <- rv$data[ which(rv$data$flag_value ==1), ]
showdata$flag_value <- as.factor(showdata$flag_value)
p <- ggplot() +
geom_point(data = showdata, aes(x = datetime, y = parameter_value_stud_filter_stud_filter, colour = par_id, key = id), size=0.8) +
geom_point(na.rm = TRUE) +
scale_color_brewer(palette = "Set2")
ggplotly(p) %>%
layout(dragmode = "lasso"
, xaxis = list(
rangeslider = list())
, hovermode = "x")
})
})
observeEvent(input$submit_good, {
# Change to TRUE if selected by lasso
lasso <- event_data("plotly_selected")
if (!is.null(lasso) | !is.null(box)) {
tmp <- rv$data[which(rv$data$id %in% lasso$key | rv$data$id %in% box$key), ]
flag_from <- min(tmp$datetime)
flag_to <- max(tmp$datetime)
rv$data$flag_value <- ifelse(rv$data$id %in% lasso$key, 1, rv$data$flag_value)
rv$data$comment <- ifelse(rv$data$id %in% lasso$key, "Selected as 'good' by manual quality check (level 15)", rv$data$comment)
selected_data$flag_value <- ifelse(strftime(selected_data$datetime, format="%Y-%m-%d %H:%M:%S") >= flag_from & strftime(selected_data$datetime ,format="%Y-%m-%d %H:%M:%S") <= flag_to, 1, selected_data$flag_value)
selected_data$comment <- ifelse(strftime(selected_data$datetime, format="%Y-%m-%d %H:%M:%S") >= flag_from & strftime(selected_data$datetime ,format="%Y-%m-%d %H:%M:%S") <= flag_to, "Selected as 'good' by manual quality check (level 15)", selected_data$comment)
}
output$plot <- renderPlotly({
showdata <- rv$data[ which(rv$data$flag_value >=1 & !is.na(rv$data$parameter_value_stud_filter)), ]
showdata$flag_value <- as.factor(showdata$flag_value)
plot_title = paste("Data between", flag_from, "to", flag_to," flagged as good (1).")
p <- ggplot() +
ggtitle(plot_title) +
geom_point(data = showdata, aes(x = datetime, y = parameter_value_stud_filter_stud_filter, colour = par_id, key = id), size=0.8) +
geom_point(na.rm = TRUE) +
scale_color_brewer(palette = "Set2")
ggplotly(p) %>%
layout(dragmode = "lasso"
, xaxis = list(
rangeslider = list())
, hovermode = "x")
})
})
observeEvent(input$save_and_exit, {
# Stop app and leave shiny
selected_data$flag_value <- ifelse(strftime(selected_data$datetime, format="%Y-%m-%d %H:%M:%S") >= flag_from & strftime(selected_data$datetime ,format="%Y-%m-%d %H:%M:%S") <= flag_to, 3, selected_data$flag_value)
selected_data$comment <- ifelse(strftime(selected_data$datetime, format="%Y-%m-%d %H:%M:%S") >= flag_from & strftime(selected_data$datetime ,format="%Y-%m-%d %H:%M:%S") <= flag_to, "Selected as 'probably bad' by manual quality check (level 15)", selected_data$comment)
saveRDS(selected_data, "~/R/stat_res_outlier.Rds")
showdata <- rv$data[ which(rv$data$flag_value ==1 & rv$data$flag_value <=5), ]
showdata$flag_value <- as.factor(showdata$flag_value)
p <- ggplot() +
geom_point(data = showdata, aes(x = datetime, y = parameter_value_stud_filter, colour = par_id, key = id), size=0.8) +
geom_point(na.rm = TRUE) +
scale_color_brewer(palette = "Set2")
p4<-ggplotly(p) %>%
layout(dragmode = "lasso"
, xaxis = list(
rangeslider = list())
, hovermode = "x")
ss_filename <- gsub("pc1", "single_sensor", basename(Rdatafile))
ss_filename <- file_path_sans_ext(ss_filename)
filename_ss.html <- paste(ss_filename,".html",sep="")
save_html(p4, file=filename_ss.html)
saveWidget(p4, filename_ss.html, selfcontained = T, libdir = "lib")
stopApp()
})
observeEvent(input$show_good, {
output$plot <- renderPlotly({
showdata <- rv$data[ which(rv$data$flag_value==1), ]
showdata$flag_value <- as.factor(showdata$flag_value)
p <- ggplot() +
geom_point(data = showdata, aes(x = datetime, y = parameter_value_stud_filter, colour = par_id, key = id), size=0.8) +
geom_point(na.rm = TRUE) +
scale_color_brewer(palette = "Set2")
ggplotly(p) %>%
layout(dragmode = "lasso"
, xaxis = list(
rangeslider = list())
, hovermode = "x")
})
})
observeEvent(input$show_1_3, {
# Select level 1 data
output$plot <- renderPlotly({
showdata_good <- rv$data[ which(rv$data$flag_value >=1 & rv$data$flag_value <=3), ]
showdata_good$flag_value <- as.factor(showdata_good$flag_value)
p <- ggplot() +
geom_point(data = showdata, aes(x = datetime, y = parameter_value_stud_filter, colour = par_id, key = id), size=0.8) +
geom_point(na.rm = TRUE) +
scale_color_brewer(palette = "Set2")
ggplotly(p) %>%
layout(dragmode = "lasso"
, xaxis = list(
rangeslider = list())
, hovermode = "x")
})
})
observeEvent(input$show_all, {
# Select level 1 data
output$plot <- renderPlotly({
showdata <- rv$data[ which(rv$data$flag_value >=1 & rv$data$flag_value <=5), ]
showdata$flag_value <- as.factor(showdata$flag_value)
p <- ggplot() +
geom_point(data = showdata, aes(x = datetime, y = parameter_value_stud_filter, colour = par_id, key = id), size=0.8) +
geom_point(na.rm = TRUE) +
scale_color_brewer(palette = "Set2")
ggplotly(p) %>%
layout(dragmode = "lasso"
, xaxis = list(
rangeslider = list())
, hovermode = "x")
})
})
output$table <- DT::renderDataTable({
rv$data[!is.na(rv$data$parameter_value_stud_filter), ]
})
output$plot <- renderPlotly({
style <- isolate(input$style)
showdata <- rv$data[ which(rv$data$flag_value >=1 & rv$data$flag_value <=5), ]
showdata$flag_value <- as.factor(showdata$flag_value)
# plot_title = paste("The plot ONLY shows a subset of the data where the studentized residuals are more than",stud_res_thres,"x 1.96.\n")
p <- ggplot() +
# ggtitle(plot_title) +
geom_point(data = showdata, aes(x = datetime, y = parameter_value_stud_filter, colour = par_id, key = id), size=0.8) +
geom_point(na.rm = TRUE) +
scale_color_brewer(palette = "Set2")
ggplotly(p) %>%
layout(dragmode = "lasso"
, xaxis = list(
rangeslider = list())
, hovermode = "x")
})
}
shinyApp(ui, server)