Skip to content
Extraits de code Groupes Projets
Valider 3f0f07b4 rédigé par Alain Guillet's avatar Alain Guillet
Parcourir les fichiers

Server file.

parent 0cc3a67c
Aucune branche associée trouvée
Aucune étiquette associée trouvée
Aucune requête de fusion associée trouvée
##########################################################################
## ic Shiny/R app server.R ##
## ##
## Author Grégoire Vincke http://www.uclouvain.be/gregoire.vincke ##
## For Statistical eLearning Tools http://sites.uclouvain.be/selt/ ##
## ##
## Licences : CC-BY for http://sites.uclouvain.be/selt/shiny/ic ##
## GPL for source code on http://github.com ##
##########################################################################
Sys.setlocale("LC_ALL", "fr_FR.UTF-8")#to be sure that accents in text will be allowed in plots
#initiate global counters
SP<-list()
SP$n.ic<-0
SP$n.ic.z.inc.mu<-0
SP$n.ic.z.noninc.mu<-0
SP$pc.ic.z.inc.mu<-0
SP$n.ic.t.inc.mu<-0
SP$n.ic.t.noninc.mu<-0
SP$pc.ic.t.inc.mu<-0
SP$l.n.ic<-list()
SP$l.pc.ic.z.inc.mu<-list()
SP$l.pc.ic.t.inc.mu<-list()
shinyServer(function(input, output) {
# Create a reactiveValues object, to let us use settable reactive values
rv <- reactiveValues()
# To start out, lastAction == NULL, meaning nothing clicked yet
rv$lastAction <- 'none'
# An observe block for each button, to record that the action happened
observe({
if (input$takeech != 0) {
rv$lastAction <- 'takeech'
}
})
observe({
if (input$reset != 0) {
rv$lastAction <- 'reset'
}
})
getech<-reactive({#créee n valeurs aléatoires N(0;1) quand input$takeech est implémenté (quand le bouton takeech est pressé)
#don't do anything until after the first button is pushed
if(input$takeech == 0)
return(NULL)
return(isolate({
#Now do the expensive stuff
rnorm(input$n)#créee n valeurs aléatoires N(0;1)
}))
})
getInputValues<-reactive({
v<-list()
v<-input #collect all inputs
return(v)
})
getComputedValues<-reactive({
cv<-list()#created empty computed values list
v<-getInputValues() # get all values of input list
cv$sx.dech<-v$sx/sqrt(v$n)#ecart-type de la distribution d'échantillonnage
cv$vx<-v$sx^2
cv$vx.dech<-cv$sx.dech^2
#Calcul de la densité maximale entre la distribution d'origine et celle d'échantillonnage
cv$dmx<-dnorm(v$mx,mean=v$mx,sd=v$sx)
cv$dmx.dech<-dnorm(v$mx,mean=v$mx,sd=cv$sx.dech)
if(v$seedech){
cv$maxdmx<-max(cv$dmx,cv$dmx.dech)
} else {
cv$maxdmx<-cv$dmx
}
cv$yaxislim<-cv$maxdmx+(cv$maxdmx*0.2)
# Calcul des valeurs des X pour tracer les polygones des distributions
z<-seq(-5,5,length=100)
cv$xr<-(z*v$sx)+v$mx #x pour tracer la distribution "réalité"
cv$xr.dech<-(z*cv$sx.dech)+v$mx #x pour tracer la distribution d'échantillonnage
cv$yr<-dnorm(cv$xr,mean=v$mx,sd=v$sx)
cv$yr.dech<-dnorm(cv$xr.dech,mean=v$mx,sd=cv$sx.dech)
# Tout ce qui est relatif à l'échantillon aléatoire prélevé dans la réalité
cv$ech.z<-getech()#créee n valeurs aléatoires N(0;1) quand input$takeech est implémenté (quand le bouton takeech est pressé)
if (rv$lastAction=='reset') {
cv$ech.z<-NULL
SP$n.ic<<-0
SP$n.ic.z.inc.mu<<-0
SP$n.ic.z.noninc.mu<<-0
SP$pc.ic.z.inc.mu<<-0
SP$n.ic.t.inc.mu<<-0
SP$n.ic.t.noninc.mu<<-0
SP$pc.ic.t.inc.mu<<-0
SP$l.n.ic<<-list()
SP$l.pc.ic.z.inc.mu<<-list()
SP$l.pc.ic.t.inc.mu<<-list()
}
cv$ech.exist<-length(cv$ech.z)#ne pas prendre n mais calculer le nombre de valeurs dans l'échantillon juste pour s'assurer qu'un échantillon a été créé = le bouton action a été poussé
cv$ech.x<-(cv$ech.z*v$sx)+v$mx
if(cv$ech.exist){
cv$ech.m<-mean(cv$ech.x)
cv$ech.sd<-sd(cv$ech.x)
cv$ech.m.z<-(cv$ech.m-v$mx)/v$sx
cv$ech.m.z.dech<-(cv$ech.m-v$mx)/cv$sx.dech
cv$ech.m.pvalue<-signif(1-pnorm(cv$ech.m.z),2)
cv$ech.m.pvalue.dech<-signif(1-pnorm(cv$ech.m.z.dech),2)
if(cv$ech.m.pvalue<0.001){
cv$ech.m.pvalue.text<-" <0.001"
} else {
cv$ech.m.pvalue.text<-cv$ech.m.pvalue
}
if(cv$ech.m.pvalue.dech<0.001){
cv$ech.m.pvalue.dech.text<-" <0.001"
} else {
cv$ech.m.pvalue.dech.text<-cv$ech.m.pvalue.dech
}
cv$ech.y.value<-0.30
cv$ech.y<-seq(cv$ech.y.value,cv$ech.y.value,length=cv$ech.exist)#liste des coordonnées y des points de l'échantillon
# Tout ce qui est relatif à la puissance, confiance, alpha, et beta
cv$alpha<-round(1-v$confidence,3)
cv$alpha.z<-round(qnorm(v$confidence),3)
cv$alpha.x<-(cv$alpha.z*v$sx)+v$mx
cv$alpha.y<-dnorm(cv$alpha.x, mean=v$mx, sd=v$sx)
cv$alpha.z.polygon<-seq(cv$alpha.z,5,length=100)
cv$alpha.x.polygon<-(cv$alpha.z.polygon*v$sx)+v$mx
cv$alpha.y.polygon<-dnorm(cv$alpha.x.polygon,mean=v$mx,sd=v$sx)
cv$confidence.z.polygon<-seq(-5,cv$alpha.z,length=100)
cv$confidence.x.polygon<-(cv$confidence.z.polygon*v$sx)+v$mx
cv$confidence.y.polygon<-dnorm(cv$confidence.x.polygon,mean=v$mx,sd=v$sx)
#Tout ce qui est relatif à l'IC àa la moyennes
cv$ic.z<-qnorm(1-cv$alpha/2)
cv$ic.t<-qt(1-cv$alpha/2,v$n-1)
cv$ic.z.limit.inf<-mean(cv$ech.x)-cv$ic.z*cv$sx.dech
cv$ic.z.limit.sup<-mean(cv$ech.x)+cv$ic.z*cv$sx.dech
cv$ic.t.limit.inf<-mean(cv$ech.x)-cv$ic.t*(cv$ech.sd/sqrt(v$n))
cv$ic.t.limit.sup<-mean(cv$ech.x)+cv$ic.t*(cv$ech.sd/sqrt(v$n))
SP$n.ic<<-SP$n.ic+1
if(v$mx >= cv$ic.z.limit.inf && v$mx <= cv$ic.z.limit.sup){
SP$n.ic.z.inc.mu<<-SP$n.ic.z.inc.mu+1
cv$ic.z.color<-rgb(0,0.7,0,0.5)#'lightgreen'
cv$ic.z.density<-10
} else {
SP$n.ic.z.noninc.mu<<-SP$n.ic.z.noninc.mu+1
cv$ic.z.color<-rgb(1,0,0,0.5)#'indianred1'
cv$ic.z.density<-25
}
if(v$mx >= cv$ic.t.limit.inf && v$mx <= cv$ic.t.limit.sup){
SP$n.ic.t.inc.mu<<-SP$n.ic.t.inc.mu+1
cv$ic.t.color<-rgb(0,0.7,0,0.5)#'lightgreen'
cv$ic.t.density<-10
} else {
SP$n.ic.t.noninc.mu<<-SP$n.ic.t.noninc.mu+1
cv$ic.t.color<-rgb(1,0,0,0.5)#'indianred1'
cv$ic.t.density<-25
}
SP$pc.ic.z.inc.mu<<-round(SP$n.ic.z.inc.mu/SP$n.ic,4)
SP$pc.ic.t.inc.mu<<-round(SP$n.ic.t.inc.mu/SP$n.ic,4)
SP$l.n.ic<<-c(SP$l.n.ic,list(SP$n.ic))
SP$l.pc.ic.z.inc.mu<<-c(SP$l.pc.ic.z.inc.mu,list(SP$pc.ic.z.inc.mu))
SP$l.pc.ic.t.inc.mu<<-c(SP$l.pc.ic.t.inc.mu,list(SP$pc.ic.t.inc.mu))
}
return(cv)
})
output$plotReality <- renderPlot({
v<-getInputValues()
cv<-getComputedValues()
#par(mfrow=c(3,1))
##################
## Plot Reality ##
##################
par(mai=c(0.5,1,0.2,1))
plot(c(0),c(0),type="l",lty=1,lwd=1,col="black",yaxt="n",bty="n",las=1,xaxs="i",yaxs="i",cex.lab=1,cex.axis=1,xlim=c(0,100),ylim=c(0,cv$yaxislim),ylab="density",xlab="",xaxp=c(0,100,20)) #trace une courbe a partir de tous les couples x;y, et la colore en rouge. bty : A character string which determined the type of box which is drawn about plots. If bty is one of "o" (the default), "l", "7", "c", "u", or "]" the resulting box resembles the corresponding upper case letter. A value of "n" suppresses the box. xaxt="n" = pas dessiner axe des x
if(v$seedor){
polygon(cv$xr,cv$yr)
text(0,signif(cv$maxdmx,1)*0.9,labels=bquote(paste("Distribution d'origine :" ,sep='')),cex=1, pos=4)
lines(x<-c(1,3),y <- c(signif(cv$maxdmx,1)*0.825,signif(cv$maxdmx,1)*0.825),lty=1,type="l",col="black")
text(3,signif(cv$maxdmx,1)*0.8,labels=bquote(paste(N *"~"* ( mu *","* sigma^2 ) ," ", N *"~"* (.(v$mx)*","*.(cv$vx)) ,sep='')),cex=1, pos=4)
}
if(v$seedech){
polygon(c(-5,cv$xr.dech),c(0,cv$yr.dech),lty=3)
text(0,signif(cv$maxdmx,1)*0.5,labels=bquote(paste("Distribution d'échantillonnage : ",sep='')),cex=1, pos=4)
lines(x<-c(1,3),y <- c(signif(cv$maxdmx,1)*0.375,signif(cv$maxdmx,1)*0.375),lty=3,type="l",col="black")
text(3,signif(cv$maxdmx,1)*0.35,labels=bquote(paste(N *"~"* ( mu *","* frac(sigma^2,n) ) ," ", N *"~"* (.(v$mx)*","*.(signif(cv$vx/v$n,2))) ,sep='')),cex=1, pos=4)
}
axis(2,las=2,yaxp=c(0,signif(cv$maxdmx,1),4))
if(v$seemu){
lines(x<-c(v$mx,v$mx),y <- c(0,cv$maxdmx),lty=1,lwd=1)
text(v$mx,cv$maxdmx*1.05,labels=bquote(mu),cex=1)
}
if(cv$ech.exist){
#points(cv$ech.x,cv$ech.y)
m.ech.z.y.delta<-0.7#1.05
m.ech.t.y.delta<-0.35#1.05
rug(cv$ech.x,lwd=2)
text(cv$ech.m,cv$maxdmx*1.05,labels=bquote(bar(x)),cex=1)#,pos=2
lines(x<-c(cv$ech.m,cv$ech.m),y <- c(0,cv$maxdmx),lty=2,lwd=1)
if(v$seeicvarknown){
text(99,cv$maxdmx*m.ech.z.y.delta,labels=bquote(paste("IC",.(v$confidence*100)," pour ",sigma^2," connue : [",.(round(cv$ic.z.limit.inf,2)),";",.(round(cv$ic.z.limit.sup,2)),"]",sep="")),cex=1,pos=2)
text(99,cv$maxdmx*m.ech.z.y.delta*0.75,labels=bquote(paste("%IC couvrant ",mu," = ",frac(.(SP$n.ic.z.inc.mu),.(SP$n.ic))," = ",.(SP$pc.ic.z.inc.mu*100),"%",sep="")),cex=1,pos=2)
polygon(c(cv$ic.z.limit.inf,cv$ic.z.limit.inf,cv$ic.z.limit.sup,cv$ic.z.limit.sup),c(cv$maxdmx*m.ech.z.y.delta+cv$maxdmx*m.ech.z.y.delta*-0.1,cv$maxdmx*m.ech.z.y.delta+cv$maxdmx*m.ech.z.y.delta*0.1,cv$maxdmx*m.ech.z.y.delta+cv$maxdmx*m.ech.z.y.delta*0.1,cv$maxdmx*m.ech.z.y.delta+cv$maxdmx*m.ech.z.y.delta*-0.1),col=cv$ic.z.color)#,density=cv$ic.z.density
text(cv$ech.m,cv$maxdmx*m.ech.z.y.delta,labels=bquote(bar(x)),cex=1)#,pos=2
lines(x<-c(cv$ech.m,cv$ech.m),y <- c(0,cv$maxdmx*m.ech.z.y.delta),lty=2,lwd=1)
if(v$seeiconx){
lines(x<-c(cv$ic.z.limit.inf,cv$ic.z.limit.inf),y <- c(0,cv$maxdmx*m.ech.z.y.delta),lty=4,lwd=1)
lines(x<-c(cv$ic.z.limit.sup,cv$ic.z.limit.sup),y <- c(0,cv$maxdmx*m.ech.z.y.delta),lty=4,lwd=1)
}
text(cv$ic.z.limit.inf,cv$maxdmx*m.ech.z.y.delta,labels="[",cex=2)#col=cv$ic.z.color
text(cv$ic.z.limit.sup,cv$maxdmx*m.ech.z.y.delta,labels="]",cex=2)#,col=cv$ic.z.color2
lines(x<-c(cv$ic.z.limit.inf,cv$ech.m-1),y <- c(cv$maxdmx*m.ech.z.y.delta,cv$maxdmx*m.ech.z.y.delta),lwd=2,lty=2)
lines(x<-c(cv$ech.m+1,cv$ic.z.limit.sup),y <- c(cv$maxdmx*m.ech.z.y.delta,cv$maxdmx*m.ech.z.y.delta),lwd=2,lty=2)
}
if(v$seeicvarunknown){
text(99,cv$maxdmx*m.ech.t.y.delta,labels=bquote(paste("IC",.(v$confidence*100)," pour ",sigma^2," inconnue : [",.(round(cv$ic.t.limit.inf,2)),";",.(round(cv$ic.t.limit.sup,2)),"]",sep="")),cex=1,pos=2)
text(99,cv$maxdmx*m.ech.t.y.delta*0.5,labels=bquote(paste("%IC couvrant ",mu," = ",frac(.(SP$n.ic.t.inc.mu),.(SP$n.ic))," = ",.(SP$pc.ic.t.inc.mu*100),"%",sep="")),cex=1,pos=2)
polygon(c(cv$ic.t.limit.inf,cv$ic.t.limit.inf,cv$ic.t.limit.sup,cv$ic.t.limit.sup),c(cv$maxdmx*m.ech.t.y.delta+cv$maxdmx*m.ech.z.y.delta*-0.1,cv$maxdmx*m.ech.t.y.delta+cv$maxdmx*m.ech.z.y.delta*0.1,cv$maxdmx*m.ech.t.y.delta+cv$maxdmx*m.ech.z.y.delta*0.1,cv$maxdmx*m.ech.t.y.delta+cv$maxdmx*m.ech.z.y.delta*-0.1),col=cv$ic.t.color)#,density=cv$ic.t.density
text(cv$ech.m,cv$maxdmx*m.ech.t.y.delta,labels=bquote(bar(x)),cex=1)#,pos=2
lines(x<-c(cv$ech.m,cv$ech.m),y <- c(0,cv$maxdmx*m.ech.t.y.delta),lty=2,lwd=1)
if(v$seeiconx){
lines(x<-c(cv$ic.t.limit.inf,cv$ic.t.limit.inf),y <- c(0,cv$maxdmx*m.ech.t.y.delta),lty=4,lwd=1)
lines(x<-c(cv$ic.t.limit.sup,cv$ic.t.limit.sup),y <- c(0,cv$maxdmx*m.ech.t.y.delta),lty=4,lwd=1)
}
text(cv$ic.t.limit.inf,cv$maxdmx*m.ech.t.y.delta,labels="[",cex=2)#,pos=2,col=cv$ic.z.color
text(cv$ic.t.limit.sup,cv$maxdmx*m.ech.t.y.delta,labels="]",cex=2)#,pos=2,col=cv$ic.z.color
lines(x<-c(cv$ic.t.limit.inf,cv$ech.m-1),y <- c(cv$maxdmx*m.ech.t.y.delta,cv$maxdmx*m.ech.t.y.delta),lwd=2,lty=2)
lines(x<-c(cv$ech.m+1,cv$ic.t.limit.sup),y <- c(cv$maxdmx*m.ech.t.y.delta,cv$maxdmx*m.ech.t.y.delta),lwd=2,lty=2)
}
}
}, height = 250)
output$plotSample <- renderPlot({
v<-getInputValues()
cv<-getComputedValues()
#par(mfrow=c(3,1))
#par(mai=c(0.2,1,0.2,1))
if(cv$ech.exist){
########################
## Plot sample values ##
########################
values.labels.y<-0.55
values.lines.y<-0.625
par(mai=c(0,1,0,1),bty="n")#,pin=c(11,0.3)
plot(cv$ech.x,cv$ech.y,pch=23,cex=1,lty=2,lwd=1,col="black",bty="n",las=1,xaxs="i",yaxs="i",cex.lab=1,cex.axis=1,xlim=c(0,100),ylim=c(0,0.50),ylab="",xlab="",xaxp=c(0,100,20), xaxt="n", yaxt="n") #trace une courbe a partir de tous les couples
#axis(2,las=2,yaxp=c(0,0.40,4))
text(1,cv$ech.y.value,labels="Echantillon",cex=1,pos=4)
text(99,cv$ech.y.value,labels=bquote(bar(x) == .(round(cv$ech.m,2))),cex=1.25,pos=2)
# text(cv$ech.m,cv$ech.y.value+0.10,labels=bquote(bar(x)),cex=1)#,pos=2
# text(cv$ic.z.limit.inf,cv$ech.y.value+0.10,labels="[",cex=1)#,pos=2
# text(cv$ic.z.limit.sup,cv$ech.y.value+0.10,labels="]",cex=1)#,pos=2
# lines(x<-c(cv$ic.z.limit.inf,cv$ech.m-1),y <- c(cv$ech.y.value+0.10,cv$ech.y.value+0.10),lwd=0.5)#lty=4,
# lines(x<-c(cv$ech.m+1,cv$ic.z.limit.sup),y <- c(cv$ech.y.value+0.10,cv$ech.y.value+0.10),lwd=0.5)#lty=4,
#lines(x<-c(cv$ic.z.limit.sup,cv$ic.z.limit.sup),y <- c(cv$ech.y+0.15,0.5),lty=4,lwd=1)
boxplot(cv$ech.x,horizontal = TRUE,add = TRUE,at = 0.1, boxwex = 0.3, xaxt="n", yaxt="n")#, xaxt="n", yaxt="n"
}
}, height = 50)
output$plotPercent<- renderPlot({
v<-getInputValues()
cv<-getComputedValues()
if(v$seeicpcevolution){
###########################
## Plot % IC including µ ##
###########################
if(cv$ech.exist){
if(SP$n.ic<20){
SP$n.ic.lim<-20
} else {
SP$n.ic.lim<-SP$n.ic
}
} else {
SP$l.n.ic<-c(0)
SP$n.ic.lim<-20
SP$l.pc.ic.z.inc.mu<-c(0)
SP$l.pc.ic.t.inc.mu<-c(0)
}
par(mai=c(0.5,1,0.2,1))
plot(SP$l.n.ic,SP$l.pc.ic.z.inc.mu,type="l",lwd=1,col="black",yaxt="n",bty="n",las=1,xaxs="i",yaxs="i",cex.lab=1,cex.axis=1,ylim=c(0,1),ylab=bquote(paste("%IC couvrant ",mu,sep="")),xlab="",xaxp=c(0,SP$n.ic.lim,SP$n.ic.lim),xlim=c(0,SP$n.ic.lim))#xlim=c(0,100),xaxp=c(0,100,20),type="l",
axis(2,las=2,yaxp=c(0,1,2))
lines(x<-c(0,SP$n.ic.lim),y <- c(v$confidence,v$confidence),lty=3)
text(SP$n.ic.lim*0.01,v$confidence*0.95,expression(1-alpha),pos=4)
#legend(1,0.25,c(bquote(paste("%IC couvrant ",mu," quand ",sigma^2," est connue ",sep="")),bquote(paste("%IC couvrant ",mu," quand ",sigma^2," est inconnue ",sep=""))))
text(SP$n.ic.lim*0.05,0.20,labels=bquote(paste(sigma^2," connue ",sep="")),cex=1,pos=4)#"%IC couvrant ",mu," quand ",
lines(x<-c(SP$n.ic.lim*0.01,SP$n.ic.lim*0.04),y <- c(0.20,0.20),lty=1,type="l",col="black",lwd=1,las=1)
if(v$seeicvarunknown){
lines(SP$l.n.ic,SP$l.pc.ic.t.inc.mu,type="l", lwd=1,lty=2)
text(SP$n.ic.lim*0.05,0.10,labels=bquote(paste(sigma^2," inconnue ",sep="")),cex=1,pos=4)#"%IC couvrant ",mu," quand ",
lines(x<-c(SP$n.ic.lim*0.01,SP$n.ic.lim*0.04),y <- c(0.10,0.10),lty=2,type="l",col="black",lwd=1)
}
}
}, height = 250)
})
0% Chargement en cours ou .
You are about to add 0 people to the discussion. Proceed with caution.
Terminez d'abord l'édition de ce message.
Veuillez vous inscrire ou vous pour commenter