Interaktive Datenverifizierung mit Shiny o.ä.

Wie rufe ich R-Funktionen auf, wie selektiere ich Daten, ich weiß nicht genau ....

Moderatoren: EDi, jogo

pfischer
Beiträge: 31
Registriert: Mi Mär 29, 2017 5:31 pm

Interaktive Datenverifizierung mit Shiny o.ä.

Beitrag von pfischer »

Liebes Forum,
wir haben bei uns große Sensordatensätze z.B. Temperature eines Gewässers über die Zeit die wir teilweise maschinell validieren können. Trotz bester Routinen bleiben aber immer noch Fehler in den Daten, so das wir abschliessend die Daten Plotten und manuell schauen, ob noch Daten im Datensatz sind, die unsere automatisierten Qualitätskontrollen nicht geflaggt haben.

Nun habe ich im Netz eine gute Shiny Application dazu gefunden die mir eine Datensatz plottet und mit der ich mittels Mauszeiger bestimmte Daten (die ich als fefhlerhaft klassifiziere) auswählen kann und mir die ausgewählten Daten dann numerisch unter dem Plot anzeigen lassen . Den Code & Beispieldatensatz habe ich angehängt. Nun komme ich aber nicht weiter. Ich muss/möchte folgende Features einbauen, bin aber bisher auf keien grünen Zweig gekommen:

1) Die Daten die ich angezeigt bekomme sollen im Sourcefile mit einer bestimmten Kennung versehen werden, z.B. 99, so das ich diese Werte dann später eliminieren kann, oder die selektierten Daten sollen zumindest in einen File geschrieben werden so dass ich sie später aus dme Orginaldatensatz löschen kann. Dabei sollte es so sein, das alle Auswahlen in einem Plot in ein und denselben Datenfile geschrieben werden, so dass ich zum Schluss eine Datensatz habe der alle "fehlerhaften" Daten eines Plots zeigt (oder noch besser alle Auswahlen in einem Plott im Orginaldatensatz mit 99 geflaggt sind)

2) Wie Ihr sehr, ist der Datensatz sehr groß und die einzelnen Punkte sind nicht auflösbar. Ich würde dazu gerne die in Shiny ansonsten möglichen Slider verwenden so das ich die Möglichkeit habe bestimmte x-Bereiche des Plots zu vergrößern / auszuwählen, d.h. z.B. immer eine Woche oder einen Tag so vergrößern, dass ich die einzelnen Punkte auf der x-Achse gut auflösen und dann auswählen kann.

3) Sehr schön wäre es natürlich, wenn die einzelnen Punkte die von mir ausgewählt und als "fehlerhaft" klassifiziert wurden in dem Plot dann andersfarbig dargestellt würden.

Ich habe zwar früher schon in Shiny codes geschrieben, aber das übersteigt meine Fähigkeiten. Hat jemand evtl. eine Tip zu den einzelnen / allen 3 Punkten wo ich nachlesen könnte um diese Features in dem Code zu implementieren. Das wäre wirklich sehr sehr hilfreich.

Herzlichen Dank
Philipp

Code: Alles auswählen

library(shiny)
library(plotly)

ui <- fluidPage(
  plotlyOutput("plot"),
  verbatimTextOutput("click"),
  verbatimTextOutput("brush")
)

server <- function(input, output, session) {
  
  nms <- row.names(mtcars)
  
  output$plot <- renderPlotly({
    p <- ggplot(data_temperature, aes(x = datetime, y = temperature_value, key = datetime)) + geom_point()
    ggplotly(p) %>% layout(dragmode = "lasso")
  })
  
  output$click <- renderPrint({
    d <- event_data("plotly_click")
    if (!is.null(d)) d
  })
  
  output$brush <- renderPrint({
    d <- event_data("plotly_selected")
    if (!is.null(d)) d
  })
  
}

shinyApp(ui, server)

Dateianhänge
temp_data.RData.zip
(237.99 KiB) 21-mal heruntergeladen
Benutzeravatar
EDi
Beiträge: 1599
Registriert: Sa Okt 08, 2016 3:39 pm

Re: Interaktive Datenverifizierung mit Shiny o.ä.

Beitrag von EDi »

Das hier macht Punkt 1 & 3:

Code: Alles auswählen

library(shiny)
library(plotly)


ui <- fluidPage(
  plotlyOutput("plot"),
  actionButton("submit", "Submit selection"),
  tableOutput("table")
)

server <- function(input, output, session) {
  
  data <- mtcars
  # create id column
  data$id = rownames(mtcars)
  # create selected columns
  data$selected = FALSE
  
  # save as reactive values (we want to modify it and react to this modification)
  rv <- reactiveValues(data = data)
  
  # observe selections and change selected accordingly
  observeEvent(input$submit, {
    # Change to TRUE if selected by lasso
    lasso <- event_data("plotly_selected")
    if (!is.null(lasso)) {
      rv$data$selected <- ifelse(rv$data$id %in% lasso$key, TRUE, rv$data$selected)
    }
  })

  output$plot <- renderPlotly({
    
    p <- ggplot(rv$data, aes(x = mpg, y = wt, colour = selected, key = id)) + 
      geom_point()
    ggplotly(p) %>% 
      layout(dragmode = "lasso")
  })
  
  output$table <- renderTable({
    rv$data
  })
}

shinyApp(ui, server)
Zu Punkt 1: Das rausschreiben überlass ich dir wie du das machen willst - ich hab nur die Tablle unten rangepackt.

Punkt2 bekommst du auch so hin ;)
Bitte immer ein reproduzierbares Minimalbeispiel angeben. Meinungen gehören mir und geben nicht die meines Brötchengebers wieder.

Dieser Beitrag ist lizensiert unter einer CC BY 4.0 Lizenz
Bild.
pfischer
Beiträge: 31
Registriert: Mi Mär 29, 2017 5:31 pm

Re: Interaktive Datenverifizierung mit Shiny o.ä.

Beitrag von pfischer »

Ganz ganz herzlichen Dank EDi,
Das ist wunderbar, genau so habe ich es mir genau gedacht :) :) :) und Du hattest Recht, nach Deiner überaus super Hilfe habe ich nun den Slider hinbekommen und das funktioniert super. Ich habe den neuen code mit slider unten eingefügt.

Nun hätte ich aber noch eine Frage, welche ich auch nach intensiver Suche nicht hinbekommen habe. Sobald ich den Button "Submitt selection" drücke, springt die Auswahl des Sliders wieder auf den Ursprung zurück. Wenn ich größere Datensätze bearbeite ist das ziemlich mühsehlig nach jeder Auswahl und dem Drücken des Buttons immer wieder den gleichen Bereich auszuwählen. Dürfte ich nochmals auf einen so super Tip hoffen, wie der Auswahlbereich auch nach dem Drücken des Buttons "Submitt selection" erhalten bleibt.
Ganz herzlichen Dank im Voraus
Philipp

Code: Alles auswählen

library(shiny)
library(plotly)


ui <- fluidPage(
  plotlyOutput("plot"),
  actionButton("submit", "Submit selection"),
  tableOutput("table")
)

server <- function(input, output, session) {
  
  data <- mtcars
  # create id column
  data$id = rownames(mtcars)
  # create selected columns
  data$selected = FALSE
  
  # save as reactive values (we want to modify it and react to this modification)
  rv <- reactiveValues(data = data)
  
  # observe selections and change selected accordingly
  observeEvent(input$submit, {
    # Change to TRUE if selected by lasso
    lasso <- event_data("plotly_selected")
    if (!is.null(lasso)) {
      rv$data$selected <- ifelse(rv$data$id %in% lasso$key, TRUE, rv$data$selected)
    }
  })
  
  output$plot <- renderPlotly({
    
    p <- ggplot(rv$data, aes(x = mpg, y = wt, colour = selected, key = id)) + 
      geom_point()
    ggplotly(p) %>% 
      layout(dragmode = "lasso"
             , xaxis = list(
               rangeslider = list()))
  })
  
  output$table <- renderTable({
    rv$data
  })
}

shinyApp(ui, server)


Benutzeravatar
EDi
Beiträge: 1599
Registriert: Sa Okt 08, 2016 3:39 pm

Re: Interaktive Datenverifizierung mit Shiny o.ä.

Beitrag von EDi »

Nunja, dadurch das sich rv$data ändert, invalidiert das den plot und ein neuer wird erzeugt.

Entweder, übergibst du irgendwie die alten ranges an den neuen plot, oder du machst den slider außerhalb...
Bitte immer ein reproduzierbares Minimalbeispiel angeben. Meinungen gehören mir und geben nicht die meines Brötchengebers wieder.

Dieser Beitrag ist lizensiert unter einer CC BY 4.0 Lizenz
Bild.
pfischer
Beiträge: 31
Registriert: Mi Mär 29, 2017 5:31 pm

Re: Interaktive Datenverifizierung mit Shiny o.ä.

Beitrag von pfischer »

Hallo EDi
ich habe das nun weitgehend hinbekommen durch das Auslesen von "plotly_relayout" und der Verwendung von plot_ly anstelle von ggplotly. Die Lösung dazu habe ich hier gefunden. https://stackoverflow.com/questions/565 ... ck-returns. Scheint ganz gut zu funktionieren und die Rangeslider-Auswahl bleibt nun auch bestehen wenn man "Submitt" drückt.
ABER: Auch nach intensivem Suchen bekomme ich mit plot_ly den Farbwechsel der ausgewählten Punkte nicht mehr hin. Ich habe alles probiert, aber die Funktion nimmt den Parameter colour anscheinend nicht an.

Wäre wirklich super, wenn Du Dir das nochmals anschauen könntest und mir eine Tip geben würdest wie ich demn Farbwechsel wieder hinbekomme.

Viele Grüße
Philipp


P.S.: Und noch ne Frage. Der Tabellenoutput scheint nicht richtig sortiert zu sein, daber das bekomm e ich wohl selbnst hin:-)



Code: Alles auswählen

if (!require("shiny")) install.packages("shiny")
library(shiny)
if (!require("plotly")) install.packages("plotly")
library(plotly)


ui <- fluidPage(
  plotlyOutput("plot"),
  actionButton("submit", "Submit selection"),
  tableOutput("table")
)
[attachment=0]data_select.RData.zip[/attachment]
server <- function(input, output, session) {

  data <- data_select
  
  d <- reactive({ e <- event_data("plotly_relayout")
   if (is.null(e)) {
     e$xaxis.range <- c(min(data_select$date), max(data_select$date))
   }
  e })
  # create id column
  data$id = rownames(data_select)
  # create selected columns
  data$selected = FALSE
  
  # save as reactive values (we want to modify it and react to this modification)
  rv <- reactiveValues(data = data)
  
  # observe selections and change selected accordingly
  observeEvent(input$submit, {
    # Change to TRUE if selected by lasso
    lasso <- event_data("plotly_selected")
    if (!is.null(lasso)) {
      rv$data$selected <- ifelse(rv$data$id %in% lasso$key, TRUE, rv$data$selected)
    }
  })
  
  output$plot <- renderPlotly({
    plot_ly(data, x = ~datetime, y = ~temperature_value, color = ~selected, key=~id) %>%
    rangeslider(start =  d()$xaxis.range[[1]], end =  d()$xaxis.range[[2]], borderwidth = 1) %>%
    layout(dragmode = "lasso"
            , xaxis = list(
              rangeselector = list(
                buttons = list(
                  list(count = 5, label = "5 hours",
                       step = "hour", stepmode = "backward"),
                  list(step = "all")))))
  })
  
  output$table <- renderTable({
    rv$data
  })
}

shinyApp(ui, server)

Dateianhänge
data_select.RData.zip
(1.35 KiB) 19-mal heruntergeladen
pfischer
Beiträge: 31
Registriert: Mi Mär 29, 2017 5:31 pm

Re: Interaktive Datenverifizierung mit Shiny o.ä.

Beitrag von pfischer »

Hallo EDi
entwarnung. Ich habe die Lösung gefunden. Ich habe auf den falschen Datensatz zugegriffen der gar keine variable für die Farbe hatte. Nun klappt alles. Nochmals ganz ganz herzlichen Dank für die Hilfe und die Hilfe zur Selbsthilfe.
Viele Grüße

Anbei noch mal der lauffähige code.

Code: Alles auswählen

if (!require("shiny")) install.packages("shiny")
library(shiny)
if (!require("plotly")) install.packages("plotly")
library(plotly)
startdate="2012-07-01 00:00:00"
enddate="2012-12-31 23:59:00"

data_select <- select(data_temperature, datetime, temperature_value)
data_select <- data_select[data_select$datetime > startdate & data_select$datetime <= enddate, ]
data_select <- data_select[order(data_select$datetime),]

ui <- fluidPage(
  plotlyOutput("plot"),
  actionButton("submit", "Submit selection"),
  downloadButton('download',"Download the data"),
  tableOutput("table")
)

server <- function(input, output, session) {

  data <- data_select
  
  d <- reactive({ e <- event_data("plotly_relayout")
   if (is.null(e)) {
     e$xaxis.range <- c(min(data_select$datetime), max(data_select$datetime))
   }
  e })
  # create id column
  data$id = rownames(data_select)
  # create selected columns
  data$selected = "good value"
  
  # save as reactive values (we want to modify it and react to this modification)
  rv <- reactiveValues(data = data)
  
  # observe selections and change selected accordingly
  observeEvent(input$submit, {
    # Change to TRUE if selected by lasso
    lasso <- event_data("plotly_selected")
    if (!is.null(lasso)) {
      rv$data$selected <- ifelse(rv$data$id %in% lasso$key, "bad value", rv$data$selected)
    }
  })
  output$plot <- renderPlotly({
    plot_ly(rv$data, type ="scatter", mode = "markers", x = ~datetime, y = ~temperature_value, color = ~selected, colors="Set1", key =~id) %>%
    rangeslider(start =  d()$xaxis.range[[1]], end =  d()$xaxis.range[[2]], borderwidth = 1) %>%
    layout(dragmode = "lasso"
            , xaxis = list(
              rangeselector = list(
                buttons = list(
                  list(count = 1, label = "1 day",
                       step = "day", stepmode = "todate"),
                  list(count = 1, label = "1 week",
                       step = "week", stepmode = "todate"),
                  list(step = "all")))))
  })
  
  #color = factor(isbreached)
  # plot_ly(
  #   mtcars,
  #   x = mpg,
  #   y = wt,
  #   group = factor(cyl),
  #   mode = "markers",
  #   marker = list(
  #     color = factor(mtcars$cyl,labels=c("red","purple","blue"))  
  #   ) 
  # )
  # 
  
  
  
  
   output$table <- renderTable({rv$data})
   output$download <- downloadHandler(
     filename = function(){"result_manual_flagging.csv"}, 
     content = function(fname){
       write.csv(rv$data, fname)
     }
   )
}

shinyApp(ui, server)
pfischer
Beiträge: 31
Registriert: Mi Mär 29, 2017 5:31 pm

Re: Interaktive Datenverifizierung mit Shiny o.ä.

Beitrag von pfischer »

Hallo EDi,
ich habe nun noch eine Frage zgur Interaktion zwischen Shiny und R. Ich rufe die Shiny App zur Interactiven Datenverifizierung (siehe code unten) aus einem R Studio Script auf. Dazu verwende ich runApp(). Nun habe ich aber ein Problem das ich bisher nicht lösen kann.

1) Wie kann ich eine data frame den ich in R Studio erstellt habe in Shiny verwenden. Wenn ich die App selbst laufen lasse, kann ich in der App den data frame aufrufen. Wenn ich die App aber über runApp() aufrufe findet er den data frame nicht obwohl er im selben working directory liegt wie die app.

2) Wie kann ich rv$data in einen data.frame in RStudio zurückschreiben. Ich habe dazu in der App eine Button erstellt der mit, wenn alle Korektiurten fertig sind, den Datenfile zurückschreiuben aoll, so dass er in dem R Script weiter verwendet werden kann.

3) Wie beende ich die App innerhalb einem R Studio Script, so das das R Schript aus dem ich die App mit runApp() aufgerufen habe an der Stelle weiterläuft nachdem die App geschlossen ist und das Script den in der App erzeugten data.frame weiter bearbeiten kann.

Klingt eigentlich alles nicht wirklich schwierig, aber ich bekomme es einfach nicht hin.

Vielen Dank für die Hilfe
Philipp

Code: Alles auswählen

if (!require("shiny")) install.packages("shiny")
library(shiny)
if (!require("plotly")) install.packages("plotly")
library(plotly)

#selected_data <- test 

#load("~/RemOs/Interactive data flagging/selected_data.rds")
selected_data <- selected_data[order(selected_data$datetime),]
names(selected_data)[2] <- "temperature_value"


ui <- fluidPage(
  plotlyOutput("plot"),
  actionButton("submit_bad", "Flag selection (lasso or box) as 'bad (level 5)'"),
  actionButton("submit_good", "Flag selection (lasso or box) as 'good (level 1)'"),
#  actionButton("show_flagged_values", "Show flagged data (level >5)'"),
  actionButton('write_data_back',"Write flagged data back to file"),
  tableOutput("table")
)

server <- function(input, output, session) {
  
  data <- selected_data
  # create id column
  data$id = rownames(selected_data)
  # create selected columns
  data$qflag_step = 14
  
  # save as reactive values (we want to modify it and react to this modification)
  rv <- reactiveValues(data = data)
  
  # observe selections and change selected accordingly
  observeEvent(input$submit_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) ) {
      rv$data$quality_flag <- ifelse(rv$data$id %in% lasso$key, 5, rv$data$quality_flag)
    }
  })
  
  observeEvent(input$submit_good, {
    # Change to TRUE if selected by lasso
    lasso <- event_data("plotly_selected")
    if (!is.null(lasso) | !is.null(box)) {
      rv$data$quality_flag <- ifelse(rv$data$id %in% lasso$key, 1, rv$data$quality_flag)
    }
  })
  
observeEvent(input$write_data_back, {
    # Write data back to file
    test1 <- renderTable({
    rv$data
    })
})   

  output$plot <- renderPlotly({
    
    p <- ggplot(rv$data, aes(x = datetime, y = temperature_value, colour = quality_flag, key = id)) + 
    geom_point()
    ggplotly(p) %>% 
      layout(dragmode = "lasso"
             , xaxis = list(
               rangeslider = list()))
  })

  output$table <- renderTable({
    rv$data[rv$data$quality_flag>1,]
  })
  }

shinyApp(ui, server)

Benutzeravatar
EDi
Beiträge: 1599
Registriert: Sa Okt 08, 2016 3:39 pm

Re: Interaktive Datenverifizierung mit Shiny o.ä.

Beitrag von EDi »

Wie kann ich eine data frame den ich in R Studio erstellt habe in Shiny verwenden. Wenn ich die App selbst laufen lasse, kann ich in der App den data frame aufrufen. Wenn ich die App aber über runApp() aufrufe findet er den data frame nicht obwohl er im selben working directory liegt wie die app.
:?:

Ein data.frame ist ein Objekt in R das in einem Environment liegt. runApp() sollte (?) alle Objekte im globalEnv sehen. Was das mit dem working directort zu tun hat verstehe ich nicht, da geht es ja um Dateien (und nicht um Objekte.
Wie kann ich rv$data in einen data.frame in RStudio zurückschreiben. Ich habe dazu in der App eine Button erstellt der mit, wenn alle Korektiurten fertig sind, den Datenfile zurückschreiuben aoll, so dass er in dem R Script weiter verwendet werden kann.
Wie oben beschrieben würde ich zum globalEnv zurückschreiben, ?assign oder ?`<<-`
Wie beende ich die App innerhalb einem R Studio Script, so das das R Schript aus dem ich die App mit runApp() aufgerufen habe an der Stelle weiterläuft nachdem die App geschlossen ist und das Script den in der App erzeugten data.frame weiter bearbeiten kann.
:?: Auch das verstehe ich nicht. meinst du ?stopApp?

Das liegt aber vielleicht auch daran, dass ich in dieser Art und Weise shiny nicht verwende. Schau dich mal nach "RStudio Addins" um, das ist glaube ich eher was du haben willst.
Bitte immer ein reproduzierbares Minimalbeispiel angeben. Meinungen gehören mir und geben nicht die meines Brötchengebers wieder.

Dieser Beitrag ist lizensiert unter einer CC BY 4.0 Lizenz
Bild.
pfischer
Beiträge: 31
Registriert: Mi Mär 29, 2017 5:31 pm

Re: Interaktive Datenverifizierung mit Shiny o.ä.

Beitrag von pfischer »

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)


Dateianhänge
stat_res_outlier.Rds.zip
(200.83 KiB) 22-mal heruntergeladen
Benutzeravatar
EDi
Beiträge: 1599
Registriert: Sa Okt 08, 2016 3:39 pm

Re: Interaktive Datenverifizierung mit Shiny o.ä.

Beitrag von EDi »

Das ist mir jetzt etwas zu viel für dieses Forum.

i) Bitte auf ein minimales reproduzierbares Beispiel runterbrechen. Dann helfe ich hier gerne - ich und andere können dabei etwas lernen und es zeit dass du gewillt bist Zeit reinzustecken. Aber ganze Anwendungen für lau debuggen - dafür ist mir meine Zeit zu schade. Das mach ich in meiner Arbeit mit der ich meinen Unterhalt verdiene...

ii) Bitte auch meine Post oben beachten: Shiny ist für webanwendungen. Diese ganze globalAssign ist nicht gut und bereit mehr bauchschmerzen je mehr ich es in deinem code sehe (programmieren mit Nebeneffekten) - Ich hätte dir diese Technik vermutlich nicht zeigen sollen - es ist schlechter Stil.
Hast du dir die Addins mal angeschaut.
Bitte immer ein reproduzierbares Minimalbeispiel angeben. Meinungen gehören mir und geben nicht die meines Brötchengebers wieder.

Dieser Beitrag ist lizensiert unter einer CC BY 4.0 Lizenz
Bild.
Antworten