Nothing
AdaptGauss = function(Data,Means=NaN,SDs=NaN,Weights=NaN,ParetoRadius=NaN,LB=NaN,HB=NaN,ListOfAdaptGauss,fast=T){
# V=AdaptGauss(Data,Means,SDs,Weights,ParetoRadius,LB,HB);
# Means <- V$Means
# SDs <- V$SDs
# Weights <- V$Weights
# Pareto_Radius <- V$ParetoRadius
# RMS <- V$RMS
# BayesBoundaries <- V$BB
#
# adapt interactively a Gaussians Mixture Model GMM to the empirical PDF of the data such that N(M,S)*W is a model for Data
#
# INPUT
# Data(1:n) Vector of Data, may contain NaN
#
# OPTIONAL
# Means(1:c) The means of the distribution; default: nanmean(Data)
# SDs(1:c) The StandardDeviatons of the distributions default: nanstd(Data)
# Weights(1:c) The weights of the distributions default: 1
# ParetoRadius the ParetoRadius for PDE on Data,
# It is calculated, if not given
# LB,HB limits where the adaptation is done, default: [min(Data) max(Data)]
# ListOfAdaptGauss if given in return Format of AdaptGauss, the modell can be edited
#
# OUTPUT
# V$Means(1:L) The adapted means of the distributions
# V$SDs(1:L) The adapted sdev of the distributions
# V$Weights(1:L) The adapted weights of the distributions
# V$ParetoRadius Pareto Radius used for empirical PDE
# V$RMS Root Mean Square Distance between empirical PDE and pdf(GMM)
# RMS == sqrt(sum(empirical PDE - pdf(GMM))^2)
# Out$BayesBoundaries Bayes Boundaries between gaussians
# author: Onno-Hansen Goos
# 1.Editor: MT 08/2015
Data; #Bricht bei nicht existierendem Bezeichner ab
## Starte Shiny
# library(shiny)
if(!missing(ListOfAdaptGauss)){
if(is.list(ListOfAdaptGauss)){
Means<-ListOfAdaptGauss$Means
if(is.null(Means)) Means=NaN
SDs<-ListOfAdaptGauss$SDs
if(is.null(SDs)) SDs=NaN
Weights<-ListOfAdaptGauss$Weights
if(is.null(Weights)) Weights=NaN
}
}
if (!(hasArg(Data))){
stop("No Data Input.")
}
if(!missing(Data)){
if(!is.vector(Data)){
stop("Data has to be a vector, maybe use as.vector(Data)")
}
if(!is.numeric(Data)){
stop("Data has to be numeric, maybe use as.numeric(Data)")
}
}
outputApp=runApp(list(
## ui.R --> stellt oberfl?che her
ui = fluidPage(
#Ueberschrift-Panel
#headerPanel("Adapt Gauss"), # oh! die Kommas sind wichtig! ^^
fluidRow(
column(3,
fluidRow(
wellPanel(# Legt aktuellen Gauss fest (welcher gerade bearbeitet werden kann)
tags$div(class = "row",
uiOutput("sliderCurrGauss"),
actionButton("AddGaussButton", "Add", icon = icon("plus-square")),
actionButton("DeleteGaussButton", "Delete Current",icon = icon("bitbucket"))#,
)
)
)
),
column(2,offset = 1,
fluidRow(
h6("Expectation Maximation Algorithm with Iterations:"),
numericInput("numIterations",
label ="", value = 10),
actionButton("expMax", "", icon = icon("calculator")),
actionButton("restore", " ", icon = icon("undo"))
)
),
column(3,
#wellPanel(# weights
h6("Weights"),
actionButton("normAll", "Normalize All", icon = icon("balance-scale")),
actionButton("normOth", "Normalize Other", icon = icon("angle-double-down")),
h6("Options"),
checkboxInput("showComponents", "Show Components", TRUE),
checkboxInput("showBayes", "Show Bayes Boundaries", FALSE)
#)
),
column(3,
wellPanel(
h6("General"),
actionButton("PlotFig", "Plot Figure", icon = icon("area-chart")),
actionButton("RestoreBestRMS", "Restore Best RMS", icon = icon("backward")),
actionButton("ChiSquareAnalysis", "Chi Square Analysis"),
h6("AdaptGauss:"),
actionButton("CloseButton", "Close", icon = icon("close"))
)
),
fluidRow(
column(12,offset=1,
plotOutput('PDE',width = 700, height = 450)
)
),
fluidRow(
column(2,
wellPanel(h5(textOutput('gaussianNumber'))),
uiOutput("minMean"),
uiOutput("minSdev"),
uiOutput("minWeight")
),
column(6,
uiOutput("sliderM"),
uiOutput("sliderS"),
uiOutput("sliderW")
),
column(2,
uiOutput("numericM"),
uiOutput("numericS"),
uiOutput("numericW")
),
column(2,
wellPanel(h5(textOutput('ScreenMessage'))),
uiOutput("maxMean"),
uiOutput("maxSdev"),
uiOutput("maxWeight")
)
)
)),
server = function(input, output, session){
## server.R --> Ab hier keine Oberflaeche mehr, ist aber mit ui.R (Oberflaeche) verkn?pft
# Default values for Data if no input
data <- Data
#?bertrage Input Werte (koennen sonst von Shiny nicht korrekt verwendet werden)
GM <- Means
GS <- SDs
GW <- Weights
ParetoRadius <- ParetoRadius
LB <- LB
HB <- HB
nSignif <- 4 # Auf wie viele "echte" Stellen soll nach dem Komma gerundet werden (zB. RMS)
numGaussSave <- NULL
MLimit <- NULL
GSSave <- NULL
GSBestRMS <- NULL
GMSave <- NULL
GMBestRMS <- NULL
GWSave <- NULL
GWBestRMS <- NULL
MonitorStopReactions <- FALSE
# Index f?r Befehle (siehe interactive value befehl)
iBefehl <- 0
# Lada Daten, definiere Variablen
#observe({ # Wird ein mal am Anfang ausgef?hrt. Erzeugt means, stds usw.
print("Start Session")
#print("Load Data")
if(length(data)==0)
return("Error: Data could not be loaded");
# Wie viele Gauss sollen getestet werden? noch nicht implentiert!
suggestedMaxGauss <- 5
# Eliminate NaNs in Data
dataNew <- 0
j <- 1
for (i in 1:length(data)){
if (!is.nan(data[i]) && !is.na(data[i])){
dataNew[j] <- data[i]
j <- j+1
}
}
data <- dataNew
# Setzte LB (low Boundary) und HB (high boundary) Falls nicht im Input
if(is.nan(LB)) LB <- min(data)
if(is.nan(HB)) HB <- max(data)
# Eliminate Values below LB and above HB in Data
dataNew <- 0
j <- 1
for (i in 1:length(data)){
if (data[i]>=LB && data[i]<=HB){
dataNew[j] <- data[i]
j <- j+1
}
}
data <- dataNew
# Reduce Data to 25000 Elements, if larger than 25000 (ueberschuessige Datenpunkte werden randomisiert entfernt)
if (length(data)>25000){
data <- data[rsampleAdaptGauss(25000,length(data))];
print("Reducing to 25000 datapoints");
}
# Bestimme Pareto Density inkl. Kernels
if (is.nan(ParetoRadius)){
ParetoRadius<-DataVisualizations::ParetoRadius(data)
nRow=length(data)
#MT: Halte ich nicht fuer plausibel
#if (nRow>1024){
# ParetoRadius = ParetoRadius * 4 /(nRow^0.2);
#}
}
ParetoDensityEstimationVar <- DataVisualizations::ParetoDensityEstimation(data,paretoRadius=ParetoRadius);
ParetoDensity <- ParetoDensityEstimationVar$paretoDensity;
Kernels <- ParetoDensityEstimationVar$kernels;
# Setze Werte f?r Means, deviations und weights, falls nicht ?bergeben
if (is.nan(sum(GM)) || is.nan(sum(GS)) || is.nan(sum(GW)) || length(GM)!=length(GS) || length(GM)!=length(GW) ){
vars=getOptGauss(Data=data, Kernels, ParetoDensity,fast=fast)
GM <- vars$means
GS <- vars$deviations
GW <- vars$weights
}
BB <- NaN # Bayes Boundaries (wird berechnet, bevor es das erste mal ausgegeben wird)
#GM <<- means #Mean der Gaussians
#GS <<- deviations #StdDev der Gaussians
#GW <<- weights #Weight der Gaussians
numGauss <- length(GM)#Anzahl der Gaussians
numIterations <- 10 # Default value for number of Iterations (in EMGauss)
RMS <- 99 # Root Mean Sqare (wird berechnet, bevor es das erste mal ausgegeben wird)
meanRMS0 <- mean(data)
DeviationRMS0 <- sd(data)
Fi <- dnorm(Kernels,meanRMS0,DeviationRMS0)
RMS0 <- sqrt(sum((Fi-ParetoDensity)^2))
currGauss <- 1 # Current Gauss (der Gauss, welcher gerade bearbeitet werden kann)
# Speicher Werte f?r "restore Best RMS
GMBestRMS <- GM
GSBestRMS <- GS
GWBestRMS <- GW
BestRMS <- RMS
numGaussBestRMS <- numGauss
currGaussBestRMS <- currGauss
xlimit <- c(min(Kernels), max(Kernels));
ylimit <- c(0,max(ParetoDensity*1.2))
numKernels <- length(Kernels)
MDefault <- mean(data) # Default Werte f?r neu erzeugte Gauss
SDefault <- sd(data)
WDefault <- 0.5
MLimit <- xlimit # Legt bereiche fest, in welchen sich die Werte f?r die Gaussians befinden k?nnen
SLimit <- c(0,max(SDefault*2,max(GS)))
WLimit <- c(0,1)
#print("[DONE]");
#})
## Output Part: lege slider, Felder und Buttons fest (sind im ui.R part eingebunden)
# Text Output
output$Header <- renderText({'PDE Plot of uploaded Data'})
output$gaussianNumber <- renderText({
befehl$updateCurrGauss
paste0("GaussianNo.",currGauss)
})
# Slider Output
output$sliderCurrGauss <- renderUI({
if (numGauss > 1){
sliderInput('currGauss', 'Gaussian No.',ticks=FALSE,width='50%', sep="" ,min = 1, max = numGauss, value = currGauss, step= 1)
}
})
output$sliderM <- renderUI({
befehl$drawSliderMSW
sliderInput("M", h5("Mean"), width='150%', min=MLimit[1], max=MLimit[2], value = GM[currGauss], step= (MLimit[2]-MLimit[1])*0.001)
})
output$sliderS <- renderUI({
befehl$drawSliderMSW
sliderInput("S", h5("SD"), width='150%', min=SLimit[1], max=SLimit[2], value = GS[currGauss], step=(SLimit[2]-SLimit[1])*0.001)
})
output$sliderW <- renderUI({
befehl$drawSliderMSW
sliderInput("W", h5("Weight"), width='150%',min=WLimit[1], max=WLimit[2], value = GW[currGauss], step=0.0001)
})
output$numericM <- renderUI({
#numericInput("numericM", h5("Mean"), min=MLimit[1], max=MLimit[2], value = GM[currGauss], step=(MLimit[2]-MLimit[1])*0.001)
numericInput("numericM", h5("Mean"), min=MLimit[1], max=MLimit[2], value = GM[currGauss], step=1)
})
output$numericS <- renderUI({
numericInput("numericS", h5("SD"), min=MLimit[1], max=MLimit[2], value = GM[currGauss], step=(SLimit[2]-SLimit[1])*0.001)
})
output$numericW <- renderUI({
numericInput("numericW", h5("Weight"), min=MLimit[1], max=MLimit[2], value = GM[currGauss], step=0.0001)
})
output$minMean <- renderUI({
befehl$updateMinMax
numericInput("minMean",
label = h6("Min Mean"),
value = signif(MLimit[1],digits=nSignif)
)
})
output$maxMean <- renderUI({
befehl$updateMinMax
numericInput("maxMean",
label = h6("Max Mean"),
value = signif(MLimit[2],digits=nSignif)
)
})
output$minSdev <- renderUI({
befehl$updateMinMax
numericInput("minSdev",
label = h6("Min SD"),
value = signif(SLimit[1],digits=nSignif)
)
})
output$maxSdev <- renderUI({
befehl$updateMinMax
numericInput("maxSdev",
label = h6("Max SD"),
value = signif(SLimit[2],digits=nSignif)
)
})
output$minWeight <- renderUI({
befehl$updateMinMax
numericInput("minWeight",
label = h6("Min Weight"),
value = signif(WLimit[1],digits=nSignif)
)
})
output$maxWeight <- renderUI({
befehl$updateMinMax
numericInput("maxWeight",
label = h6("Max Weight"),
value = signif(WLimit[2],digits=nSignif)
)
})
## Interaktive Variablen: befehl$... fungiert als Funktionsaufruf.
befehl <- reactiveValues(plot = 0, updateSlider=0, updateSliderCurrGauss=0, drawSliderMSW=0, updateRMS=0, updateMinMax=0) #Signal zum update des Plots / der Slider
# die numerischen eingabekaesten (numericM, ...) werden aktualisiert,
# sollte sich der Wert eines sliders veraendern
observe({
updateNumericInput(session, "numericM", value=input$M)
updateNumericInput(session, "numericS", value=input$S)
updateNumericInput(session, "numericW", value=input$W)
})
# die Slider werden aktualisiert, sollte sich der Wert
# eines numerischen eingabekaesten veraendern
observe({
input$numericM
input$numericS
input$numericW
# der numeric input darf nicht zu scnell andere werte updaten sonst gibt es eine endlosschleife mit dem slider
if(MonitorStopReactions==F){
MonitorStopReactions<<-T
if(is.numeric(input$numericM))
updateSliderInput(session, "M", value=input$numericM)
if(is.numeric(input$numericS))
updateSliderInput(session, "S", value=input$numericS)
if(is.numeric(input$numericW))
updateSliderInput(session, "W", value=input$numericW)
# MonitorStopReactions<<-F
}
})
# alle 500ms darf der numeric input wieder einen neuen wert setzen
# solange MonitorStopReactions auf False steht, kann ein Input System seinen Wert
# veraendern und auf das analoge gegenstueck uebertragen (slider <-> kaesten)
# sobald ein system etwas aendert ist das erste was es tut, den Flag zu aktivieren
validationTimer <- reactiveTimer(500)
observe({
validationTimer()
MonitorStopReactions <<- F
})
## Observe Part: warte auf Input
observe({ # Grenzen f?r die Werte von means, sdevs und weights
#print("AdaptGauss: Enforce Limits for Mean, Sdev and Weight")
if (!is.null(input$minMean)){
if ( is.numeric(input$minMean) && input$minMean<min(GM) ) MLimit[1] <<- input$minMean
if ( is.numeric(input$maxMean) && input$maxMean>max(GM) ) MLimit[2] <<- input$maxMean
if ( is.numeric(input$minSdev) && input$minSdev<min(GS) ) SLimit[1] <<- input$minSdev
if ( is.numeric(input$maxSdev) && input$maxSdev>max(GS) ) SLimit[2] <<- input$maxSdev
if ( is.numeric(input$minWeight) && input$minWeight<min(GW) ) WLimit[1] <<- input$minWeight
if ( is.numeric(input$maxWeight) && input$maxWeight>max(GW) ) WLimit[2] <<- input$maxWeight
iBefehl <<- iBefehl+1
befehl$drawSliderMSW <- iBefehl
}
})
# Normalisiert alle Gaussians
observe({
#print("AdaptGauss: Normalize All")
#print("Normalize All")
if (input$normAll>0){
sumWeight <- sum(GW)
for (i in 1:numGauss){
GW[i] <<- GW[i]/sumWeight
}
iBefehl <<- iBefehl+1
befehl$plot <- iBefehl
befehl$updateSlider <- iBefehl
}
})
# Normalisiert andere Gaussians (alle ausser dem aktuellen)
observe({
#print("AdaptGauss: Normalize Other")
#print("Normalize Other")
if (input$normOth>0){
sumWeight <- sum(GW)
sumWeightOther <- sumWeight-GW[currGauss]
zielSum <- 1-GW[currGauss]
for (i in 1:numGauss){
if (i!=currGauss){
GW[i] <<- GW[i]/sumWeightOther*zielSum
}
}
iBefehl <<- iBefehl+1
befehl$plot <- iBefehl
befehl$updateSlider <- iBefehl
}
})
# wechsel den aktuellen Gauss
observe({
#print("AdaptGauss: Update CurGauss")
#print("Update currGauss")
if (!is.null(input$currGauss)){
currGauss <<- input$currGauss
iBefehl <<- iBefehl+1
befehl$updateCurrGauss <- iBefehl
}
})
#Erneuert Slider f?r M/S/W, (zB. wenn der Gauss gewechselt wurde)
observe({
#print("AdaptGauss: Update Slider for M, S and W")
befehl$updateSlider
befehl$updateCurrGauss
#print("Update Slieder M/S/W")
updateSliderInput(session, "M", value = GM[currGauss])
updateSliderInput(session, "S", value = GS[currGauss])
updateSliderInput(session, "W", value = GW[currGauss])
})
# Erneuert slider f?r den aktuellen Gauss (falls numGauss==0 --> lehrer output --> slider wird nicht angezeigt)
observe({
#print("AdaptGauss:Update CurGauss Slider")
befehl$updateSliderCurrGauss
if (numGauss>1){
output$sliderCurrGauss <- renderUI({
sliderInput('currGauss', h6('Gaussian No.'), min = 1, max = numGauss, value = currGauss, step= 1)
})
updateSliderInput(session, "currGauss", value = currGauss)
} else {
output$sliderCurrGauss <- renderUI({
})
}
})
#Erneuert Werte f?r M/S/W, wenn der Slider bewegt wird
observe({
#print("Refresh Values for M")
#print("AdaptGauss:RefreshM")
if (!is.null(input$M)){
GM[currGauss] <<- input$M
iBefehl <<- iBefehl+1
befehl$plot <- iBefehl
}
})
observe({
#print("AdaptGauss:RefreshS")
#print("Refresh Values for S")
if (!is.null(input$S)){
GS[currGauss] <<- input$S
iBefehl <<- iBefehl+1
befehl$plot <- iBefehl
}
})
observe({
#print("AdaptGauss:RefreshW")
#print("Refresh Values for W")
if (!is.null(input$W)){
GW[currGauss] <<- input$W
iBefehl <<- iBefehl+1
befehl$plot <- iBefehl
}
})
observe({
#print("Refresh numIterations")
numIterations <<- input$numIterations
if (numIterations<1) {numIterations <<- 1}
})
# Starte EMGauss()
observe({
#print("AdaptGauss:EMGauss")
GMSave <<- GM
GSSave <<- GS
GWSave <<- GW
numGaussSave <<- numGauss
if (input$expMax>0){
print("Expectation Maximation")
Var <- EMGauss(data,length(GM),GM,GS,GW,numIterations,fast=fast)
GM <<- Var$Means
GS <<- Var$SDs
GW <<- round(Var$Weights,4)
}
# L?sche Gauss mit Weight==0
for (i in length(GW):1){
if (GW[i]==0){
if (i<numGauss){
for (j in i:(numGauss-1)){
GM[j] <<- GM[j+1]
GS[j] <<- GS[j+1]
GW[j] <<- GW[j+1]
}
}
GM <<- GM[1:numGauss-1]
GS <<- GS[1:numGauss-1]
GW <<- GW[1:numGauss-1]
numGauss <<- numGauss-1
if (currGauss>i) currGauss <<- currGauss-1
if (currGauss==i) currGauss <<- 1
}
}
for (i in 1:numGauss){
if (GM[i]<MLimit[1]) MLimit[1] <<- GM[i]*1.01^(sign(-GM[i])) #Faktor 1.01^(sign(-GM[i]), weil nach dem runden von GM oder MLimit sonst Fehler auftreten k?nnen
if (GM[i]>MLimit[2]) MLimit[2] <<- GM[i]*1.01^(sign(GM[i]))
if (GS[i]<SLimit[1]) SLimit[1] <<- GS[i]*1.01^(sign(-GS[i]))
if (GS[i]>SLimit[2]) SLimit[2] <<- GS[i]*1.01^(sign(GS[i]))
if (GW[i]<WLimit[1]) WLimit[1] <<- GW[i]*1.01^(sign(-GW[i]))
if (GW[i]>WLimit[2]) WLimit[2] <<- GW[i]*1.01^(sign(GW[i]))
}
iBefehl <<- iBefehl+1
befehl$updateCurrGauss <- iBefehl
befehl$updateSliderCurrGauss <- iBefehl
befehl$drawSliderMSW <- iBefehl
befehl$updateSlider <- iBefehl
befehl$plot <- iBefehl
befehl$updateMinMax <- iBefehl
})
# Lade Werte (wurden vor Expectation Maximation gespeichert)
observe({
print("AdaptGauss: Restore Previous Values")
if (input$restore>0){
print("Restore previous Values")
GM <<- GMSave
GS <<- GSSave
GW <<- GWSave
numGauss <<- numGaussSave
currGauss <<- 1
}
iBefehl <<- iBefehl+1
befehl$updateSliderCurrGauss <- iBefehl
befehl$updateSlider <- iBefehl
befehl$plot <- iBefehl
})
#Lade Werte f?r best RMS
observe({
#print("AdaptGauss:RestoreBestRMS")
if (input$RestoreBestRMS>0){
print("Restore Values of Best RMS")
GM <<- GMBestRMS
GS <<- GSBestRMS
GW <<- GWBestRMS
numGauss <<- numGaussBestRMS
currGauss <<- 1
}
iBefehl <<- iBefehl+1
befehl$updateSliderCurrGauss <- iBefehl
befehl$updateSlider <- iBefehl
befehl$plot <- iBefehl
})
observeEvent(input$ChiSquareAnalysis,{
Chi2testMixtures(Data, GM, GS, GW, PlotIt = T,NoRepetitions=50)
})
# Plotten der Grafik (nur bei Befehl (befehl$plot))
output$PDE <- renderPlot({
befehl$plot
#print("AdaptGauss:renderPlot")
#print("PDE estimation using DataVisualizations::ParetoDensityEstimation... ");
#Plotte Pareto Density
plot(Kernels, ParetoDensity,xlim=xlimit,ylim=ylimit, col="black", axes = FALSE, xlab = "Data", ylab = "Pareto Density Estimation", type="l", lwd=3,xaxs='i',yaxs='i')
axis(1,xlim=xlimit,col="black",las=1) #x-Achse
axis(2,ylim=ylimit,col="black",las=1) #y-Achse
par(xaxs='i')
par(yaxs='i')
u <- par("usr")
arrows(u[1], u[3], 1.05*u[2],u[3], code = 2, xpd = TRUE,lwd=2)
arrows(u[1], u[3], u[1], 1.1*u[4], code = 2, xpd = TRUE,lwd=2)
#box() #Kasten um Graphen
par(new = TRUE) # der befehl das der n?chste den alten nicht ?bermalt
# plotte gaussians (in Schwarz)
FSum=0
for (i in 1:numGauss){
Fi=dnorm(Kernels,GM[i],GS[i])*GW[i]
FSum=FSum+Fi
if (input$showComponents){
if (i==currGauss){
points(Kernels, Fi,xlim=xlimit,ylim=ylimit, col="green", type="l", lwd=3)
} else {
points(Kernels, Fi,xlim=xlimit,ylim=ylimit, col="blue", type="l", lwd=3)
}
par(new = TRUE) # der befehl das der n?chste den alten nicht ?bermalt
}
}
# Plotte Summe ?ber alle gaussians (in Rot)
points(Kernels, FSum,xlim=xlimit,ylim=ylimit, col="red", type="l", lwd=3)
par(new = TRUE) # der befehl das der n?chste den alten nicht ?bermalt
#Plot Ende
#Berechne RMS
RMS <<- sqrt(sum((FSum-ParetoDensity)^2))/RMS0
#output$RMS <- renderText({
# paste("RMS = ",signif(RMS, digits=nSignif))
#})
str=paste('AdaptGauss(): GMM with',"RMS = ",signif(RMS, digits=nSignif))
if (RMS<BestRMS){ # Speichere Werte, falls RMS optimiert wurde
GMBestRMS <<- GM
GSBestRMS <<- GS
GWBestRMS <<- GW
BestRMS <<- RMS
numGaussBestRMS <<- numGauss
currGaussBestRMS <<- currGauss
}
# Berechne (immer) und Plotte (nur wenn angeklickt) Bayes Boundaries
if (numGauss>1 && sum(GW>0)>1){ # sum(GW>0)>1: Sicherstellen, dass mindestens 2 Gauss ein weight von ?ber 0 haben, sonst ist Berechnung von BayesBoundaries nicht m?glich
BayesBoundaries <- BayesDecisionBoundaries(GM[GW>0],GS[GW>0],GW[GW>0])
#BB <<- BayesBoundaries$DecisionBoundaries;
BB <<- BayesBoundaries
if (input$showBayes){
for (i in 1:length(BB)){
abline(v=BB[i],col="Magenta")
#plot(c(BB[i],BB[i]), ylimit,xlim=xlimit,ylim=ylimit, col="Magenta", axes = FALSE, xlab = " ", , ylab = " ", type="l", lwd=3)
par(new = TRUE) # der befehl das der n?chste den alten nicht ?bermalt
}
BBText=paste(round(BB[1],digits=5-round(log(xlimit[2]-xlimit[1],10)))) #BB wird angepasst an den betrachteten X-Bereich (xlimit[2]-xlimit[1]) gerundet.
if (length(BB)>1){
for (i in 2:length(BB)){
BBText=paste(BBText,", ",round(BB[i],digits=5-round(log(xlimit[2]-xlimit[1],10)))) #BB wird wieder angepasst an den betrachteten X-Bereich (xlimit[2]-xlimit[1]) gerundet.
}
}
title(paste(str,", BayesBoundaries = ",BBText))
# output$Bayes <- renderText({
# paste("BayesBoundaries = ",BBText)
# })
} else {
#output$Bayes <- renderText({ })
title(str)
}
}
else{
BB <<- NaN
title(str)
#output$Bayes <- renderText({ })
}
})
# Fuege Gauss hinzu (bei Knopfdruck)
observe({
if (input$AddGaussButton > 0){
print("Add Gauss")
numGauss <<- numGauss+1
GM[numGauss] <<- MDefault
GS[numGauss] <<- SDefault
GW[numGauss] <<- WDefault
currGauss <<- numGauss
}
iBefehl <<- iBefehl+1
befehl$updateSliderCurrGauss <- iBefehl
befehl$plot <- iBefehl
})
# L?sche aktuellen Gauss: alle Gauss mit gr??erem Index rutschen eins nach link; neuer aktueller Gauss wird der, welcher vorher rechts vom gel?schten gauss stand. currGauss bleibt also gleich. Ausnahme: der Gaus mit dem gr??ten Index wird gel?scht, dann currGauss -> currGauss-1
observe({
if (input$DeleteGaussButton > 0 && numGauss>1){
print("DeleteGauss")
if (currGauss<numGauss){
for (i in currGauss:(numGauss-1)){
GM[i] <<- GM[i+1]
GS[i] <<- GS[i+1]
GW[i] <<- GW[i+1]
}
}
if (currGauss==numGauss){
currGauss <<- numGauss-1
}
GM <<- GM[1:numGauss-1]
GS <<- GS[1:numGauss-1]
GW <<- GW[1:numGauss-1]
numGauss <<- numGauss-1
}
iBefehl <<- iBefehl+1
befehl$updateCurrGauss <- iBefehl
befehl$updateSlider <- iBefehl
befehl$updateSliderCurrGauss <- iBefehl
befehl$plot <- iBefehl
})
#Closing APP oder plot figure
observe({
input$CloseButton
input$PlotFig
if (input$CloseButton+input$PlotFig > 0){
print("Plot Figure")
# Plotte Ergebnis
plot(Kernels, ParetoDensity,xlim=xlimit,ylim=ylimit, col="black", axes = FALSE, xlab = "Data", ylab = "Pareto Density Estimation", main='GMM with AdaptGauss()',type="l", lwd=3)
axis(1,xlim=xlimit,col="black",las=1) #x-Achse
axis(2,ylim=ylimit,col="black",las=1) #y-Achse
u <- par("usr")
arrows(u[1], u[3], 1.05*u[2],u[3], code = 2, xpd = TRUE,lwd=2)
arrows(u[1], u[3], u[1], 1.1*u[4], code = 2, xpd = TRUE,lwd=2)
#box() #Kasten um Graphen
par(new = TRUE) # der befehl das der n?chste den alten nicht ?bermalt
FSum=0
for (i in 1:numGauss){
Fi=dnorm(Kernels,GM[i],GS[i])*GW[i]
FSum=FSum+Fi
if (isolate(input$showComponents)){
points(Kernels, Fi,xlim=xlimit,ylim=ylimit, col="blue", type="l", lwd=3)
par(new = TRUE) # der befehl das der n?chste den alten nicht ?bermalt
}
}
if (input$showBayes && numGauss>1){
for (i in 1:length(BB)){
abline(v=BB[i], col="Magenta")
#plot(c(BB[i],BB[i]), ylimit,xlim=xlimit,ylim=ylimit, col="Magenta", axes = FALSE, xlab = " ", , ylab = " ", type="l", lwd=3)
par(new = TRUE) # der befehl das der n?chste den alten nicht ?bermalt
}
}
#Fi=dnorm(Kernels,GM[currGauss],GS[currGauss])*GW[currGauss]
#FSum=FSum+Fi
#plot(Kernels, Fi,xlim=xlimit,ylim=ylimit, col="green", axes = FALSE, xlab = " ", , ylab = " ", type="l", lwd=3)
#par(new = TRUE) # der befehl das der n?chste den alten nicht ?bermalt
plot(Kernels, FSum,xlim=xlimit,ylim=ylimit, col="red", axes = FALSE, xlab = " ", , ylab = " ", type="l", lwd=3)
# Plot Ende
}
if (input$CloseButton > 0){
print("close App")
output <- list(Means=GM,SDs=GS,Weights=GW,ParetoRadius=ParetoRadius,RMS=RMS,BayesBoundaries=BB)
stopApp(output)
}
})# end observe CloseButton and PlotFig
session$onSessionEnded(function() {
print("close App")
output <- list(Means=GM,SDs=GS,Weights=GW,ParetoRadius=ParetoRadius,RMS=RMS,BayesBoundaries=BB)
stopApp(output)
# write out everything into files
})
}# end function server
))
#outputApp=runApp(paste0(dbtDirectory(),'/dbt/dbt.EMforGauss/R/AdaptGauss2'));
return(outputApp)
}
## Benutzte Funktionen: Subversion\PUB\dbt\...
# dbt.EMforGauss\EMGauss.R
# dbt.ClusteringAlgorithms\KmeansCluster.R
# dbt.BayesDecision\BayesDecisionBoundaries.R
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.