server.R

## simpleIC Shiny/R app server.R                                           
##                                                                      
## Author(s) :
## -----------
## J.J.
## Orginal version by Grégoire Vincke http://www.uclouvain.be/gregoire.vincke       
## For Statistical eLearning Tools http://sites.uclouvain.be/selt/      
##                                                                      
## Licences : 
## ---------
## CC-BY for the web page http://sites.uclouvain.be/selt/shiny/testhypic
## see http://creativecommons.org/licenses/by/2.0/be/ for more informations       
##
## GPLv2 for source code on https://github.com/uclouvain-selt/shiny  
## See LICENCE.tx or http://www.gnu.org/licenses/old-licenses/gpl-2.0.html for more informations

Sys.setlocale("LC_ALL", "de_DE.UTF-8")#to be sure that accents in text will be allowed in plots
library(shiny)
library(plotrix)
library(xtable)
library(ggplot2)

debug<-0

color.brown<-rgb(0.5,0.2,0)
color.blue<-rgb(0,0,0.9)
color.true<-rgb(0,0.7,0)
color.false<-rgb(1,0,0,0.9)
oui.color.false<-rgb(0.3,0.3,0.3)
oui.color.true<-rgb(.6,.6,.6)
text.color.false<-rgb(0.2,0.2,0.2)
text.color.true<-rgb(.5,.5,.5)
non.color.true<-rgb(0.8,0.8,0.8)
non.color.false<-rgb(0.93,0.93,0.93)


density.true<-10
density.false<-25

y.delta<-0.1 #factor to set delta between rows of datas in plots

hypoth.text.levels<-c(1,0.7,0.4,0.1)

x.lim.min<-0
x.lim.max<-60
x.amp<-x.lim.max-x.lim.min

# possible values for the mean, cf ui.R mx1, mx0, mx
mu.vec<-c(x.lim.min:x.lim.max)#c(25:75)

shinyServer(function(input, output,session){
  
  rv <- reactiveValues()# Create a reactiveValues object, to let us use settable reactive values
  
  rv$last.takesample.value<-0
  rv$samples.mat<-c() # matrix of all observations, each line one sample
  rv$new.sample<-c() # new matrix of observations, each line one sample
  rv$cv.ls<-list() # calculated values
  
  rv$lastAction <- 'none' # To start out, lastAction == NULL, meaning nothing clicked yet

  # Calculations only needed if one of these values are changed, so observe them
  rv$mx0.c<-0 # hypothesis mean
  rv$mx.c<-0 # population mean
  rv$sx.c<-0 # population deviation
  rv$IC.k.c<-0 # IC length
  rv$typIC.c<-'' # Type 'eCVk' empiric, 'vCVk' variance connue, 'sCVk' variance inconnue
  rv$test.c<-'' # Type '=' bilateral, '<=' unilateral, '=>' unilateral
  # Create all samples new if a change is made in sample size
  rv$n.c<-0 # sample size as in ui
  rv$tn.c<-0 # total numer of samples


  testicPl.choices.ls<- list("Choix" = "false",
                             "Indiquer couverture par les IC" = "cvPl", 
                                 "Indiquer la décision" = "testPl",
                                 "Afficher  % de rejet" = "rejFreqPl")
  
  observe({
      if(input$visM){
          js_string <- '$(".span8").width(500);'
          session$sendCustomMessage(type='jsCode', list(value = js_string))
      }
  })

  # reset option if IC off or Hypotheses off
  observe({
      if(!(input$icPl &&  input$hypPl!="false")){
          updateSelectInput(session, "testicPl","",testicPl.choices.ls, "false")
      }
  })

  # if IC Model with sigma known, show sigma
  observe({
      if(input$CVk == "vCVk"){
          updateCheckboxInput(session, "sigKn",value=TRUE)
      } else {
          updateCheckboxInput(session, "sigKn",value=FALSE)
      }
  })

  
  # if take sample
  observe({
      if (input$takesample != 0) {
          rv$lastAction <- 'takesample'
      }

      })

  # if reset all new
  observe({
      if(input$reset !=0){
          rv$lastAction <- 'reset'
          rv$last.takesample.value<-0

          rv$samples.mat<-c()
          rv$cv.ls<-list()
          rv$mx.c<-0 # population mean
          rv$sx.c<-0 # population deviation
          rv$IC.k.c<-0 # IC length
          rv$typIC.c<-'' # Type 'eCVk' empiric, 'vCVk' variance connue, 'sCVk' variance inconnue
          rv$n.c<-0 # sample size as in ui
          rv$tn.c<-0 # total numer of samples
          updateSliderInput(session, "mx1",value = sample(c(31:35),1))
          updateSliderInput(session, "sx",value = sample(seq(from = 2, to = 3.5, by = 0.5),1))
          updateCheckboxInput(session, "muKn",value=FALSE)
          updateCheckboxInput(session, "sigKn",value=FALSE)
      }
  })


  getSamples<-reactive({#créee n valeurs aléatoires N(0;1) quand input$takesample est implémenté (quand le bouton takesample est pressé)
      if(input$takesample > rv$last.takesample.value && rv$lastAction == "takesample"){
          return(isolate({#Now do the expensive stuff
              rv$new.sample<-matrix(rnorm(input$ns*input$n),ncol=input$n)
              return(TRUE)
          }))
      } else {
          return(FALSE)
      }
  })

  getPlotHeight <- function() {
      if(input$display=="default") {
	unit.height<-250 #cannot be auto because height is already "auto" in ui and double auto = conflict
      }
      if(input$display=="1024") {
	unit.height<-180
      }
      if(input$display=="800") {
	unit.height<-140 #160 for real full page
      }
    return(3*unit.height)
  }
  
  getPlotWidth <- function() {
      if(input$display=="default") {
	full.plot.width<-1310-310#"auto"
      }
      if(input$display=="1024") {
	full.plot.width<-900-310
      }
      if(input$display=="800") {
	full.plot.width<-700-310
      }
      if(input$visM && input$display!="default"){
	full.plot.width<-full.plot.width+310
      }
    return(full.plot.width)
  }
    
  getInputValues<-reactive({
      return(input)#collect all inputs
  })
  
  getComputedValues<-reactive({
      # returns TRUE if new calculations other wise FALSE
      # results hold in rv$cv.ls
      # gives TRUE back if new values calculated otherwise FALSE
      calc.new<-FALSE # we do not want  to calculate all values again
      # did we create new samples?
      sample.new<-getSamples() # if TRUE then append new observations from rv$new.sample
      v<-getInputValues() # get all values of input list
      # check if sample size was changed
      if (v$n != rv$n.c){# if changed create a new observation matrix of correct size
          rv$n.c<-v$n
          if(rv$tn.c>0){
              rv$samples.mat<-matrix(rnorm(rv$tn.c*rv$n.c),ncol=rv$n.c)
          }
          calc.new<-TRUE # we have to calculate all values again
      }
      if(sample.new){#if new observations created, append them
          sample.mat<-mat.or.vec(rv$tn.c + v$ns,v$n)
          if(rv$tn.c>0){
              sample.mat[1:rv$tn.c,]<-rv$samples.mat
          }
          sample.mat[(rv$tn.c+1):(rv$tn.c+v$ns),]<-rv$new.sample
          rv$samples.mat<-sample.mat  # new observations
          rv$tn.c<-length(rv$samples.mat[,1]) # new total number of samples