inst/apps/Design-Verifikation_v0.1.1/server.R

In stephanGit/leistungstests: Supplies Functions to calculate 'leistungstests'

library(tidyverse)
library(shiny)
library(rhandsontable)
library(magrittr)
library(ggplot2)
library(knitr)
library(plotly)
library(boot)
library(pander)
library(rmarkdown)

library(leistungstests)
#library(shinyjs)

# set upload-size limit to max
options(shiny.maxRequestSize=30*1024^2)

shinyServer(function(input, output, session) {

  # APP-DATA DEFINITION -----------------
  ostit <- reactiveValues(

    #raw-data setup as tibble
    raw_data = tibble(valid = TRUE, Messwert = as.numeric(rep(NA, 7)),  Kommentar = ""),
    messwerte = NA,
    valid_data = NA,

    # meta-data
    variable_name = "",
    variable_unit = "",

    # dokumentation
    versuchsziel = "",
    sollwert = "",
    versuchsbeschreibung = "",
    ergebnis = "",
    schlussfolgerung = "",
    general_comment = "",
    stichprobengroessenbestimmung = "",

    # test-spec
    spec = 0,
    spec_type = "lsl",
    p_min = 95,
    power = 75,

    # statistics
    sample_size = 0,
    sample_mean = NA,
    sample_sd = NA,
    kc = NA,
    ltl = NA,
    utl = NA,
    nr_io_items = NA,
    test_result = NA,

    # design-aid ostit
    p_pass_desired = 98,
    sample_size_desired = 3
  )


  # APP-DATA EVENT-HANDLING  -----------------
  observe({

    # messwert handling
    if (!is.null(input$raw_data)){# in app-start-up input$raw_data is null!
      ostit$raw_data <-  as_tibble(hot_to_r(input$raw_data))
    }

    # valid-data enthält ausgewählte observationen und !is.na(Messwerte)
    # valid_data hat zwei-Variablen: obsNr[numeric], Messwerte[numeric]
    ostit$valid_data <-
      ostit$raw_data %>%
      #rownames_to_column(var = "obsNr") %>% # does not work as row-names are stored as character-vector
      mutate(obsNr = as.numeric(row.names(ostit$raw_data))) %>%
      filter(valid & !is.na(Messwert)) %>%
      select(obsNr, Messwert)

    # meta-data
    ostit$variable_name <- input$variable_name
    ostit$variable_unit <- input$variable_unit

    # dokumentation
    ostit$versuchsziel <- input$versuchsziel
    ostit$sollwert <- input$sollwert
    ostit$versuchsbeschreibung <- input$versuchsbeschreibung
    ostit$ergebnis <- input$ergebnis
    ostit$schlussfolgerung <- input$schlussfolgerung
    ostit$general_comment <- input$general_comment
    ostit$vorversuchsergebnisse<- input$vorversuchsergebnisse

    # test-spec
    ostit$spec <- input$spec
    ostit$spec_type <- input$spec_type
    ostit$p_min <- input$p_min/100
    ostit$power <- input$power/100

    ostit$sample_size <- ostit$raw_data %>% filter(valid & !is.na(Messwert)) %>% nrow()
    ostit$sample_mean <-  ostit$raw_data %>% filter(valid & !is.na(Messwert)) %$% mean(Messwert)
    ostit$sample_sd <- ostit$raw_data %>% filter(valid & !is.na(Messwert)) %$% sd(Messwert)
    ostit$kc <- kc(p = ostit$p_min, alpha = (1 - ostit$power), n = ostit$sample_size)

    ostit$ltl <- ostit$sample_mean - ostit$kc * ostit$sample_sd
    ostit$nr_io_items <- ostit$raw_data %>% filter(valid & !is.na(Messwert)) %$% sum(Messwert > ostit$spec)

    ostit$utl <- ostit$sample_mean + ostit$kc * ostit$sample_sd
    ostit$nr_io_items <- ostit$raw_data %>% filter(valid & !is.na(Messwert)) %$% sum(Messwert < ostit$spec)

    ostit$test_result <- ifelse(ostit$spec_type == "lsl",
                                ifelse(ostit$ltl > ostit$spec, "bestanden", "nicht bestanden"),
                                ifelse(ostit$utl < ostit$spec, "bestanden", "nicht bestanden"))
    # setup test-design
    ostit$p_pass_desired <- input$p_pass_desired/100
    ostit$sample_size_desired <- input$sample_size_desired

  })

  #INIT DATA DISPLAY ------------
  output$raw_data <- renderRHandsontable({ rhandsontable(ostit$raw_data)})
  # dies wird nur zum programm start ausgeführt !!!! ????
  # this is simply to register the rhandsontable with the output/display



  # VARIABLE ------------
  source(file.path("design_aid", "server_design_aid_plot.R"), local = TRUE, encoding = "UTF-8")$value
  source(file.path("qq_plot", "server_qq_plot.R"), local = TRUE, encoding = "UTF-8")$value
  source(file.path("auswertung", "server_messwert_plot.R"), local = TRUE, encoding = "UTF-8")$value


  # ATTRIBUTIV ---------------------
  source(file.path("attributiv", "server_attributiv.R"), local = TRUE, encoding = "UTF-8")$value

  # DOKUMENATION ------------

  # HELP pages
  source(file.path("dokumentation", "help_dialogs.R"), local = TRUE, encoding = "UTF-8")$value

  # LOAD/SAVE
  source(file.path("dokumentation", "server_load_save.R"), local = TRUE, encoding = "UTF-8")$value

  # GENERATE REPORTS
  source(file.path("dokumentation", "server_gen_reports.R"), local = TRUE, encoding = "UTF-8")$value

})