inst/shiny/server.R
In aklxao2/SDEFSR: Subgroup Discovery Algorithms for R
# This is the server logic for a Shiny web application.
# You can find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com
#
library(shiny)
#Limit size for an input file
MAX_SIZE_MB = 10
options(shiny.maxRequestSize= MAX_SIZE_MB * 1024^2)
# The colors for the graphs (obtened from Material Design: http://www.google.ch/design/spec/style/color.html#color-color-palette)
colors <- c("#E8F5E9", "#A5D6A7", "#4CAF50", "#388E3C", "#FFF9C4", "#FFF176",
"#FFEB3B", "#FDD835", "#F9A825")
#Add more colors, this is are for the variable vs variable plots
colorsWithContrast <- grDevices::rainbow(30)[c(1,10,20,30,4,14,24,6,16,28)]
#Starts the server logic
shinyServer(function(input, output, session) {
# All this must be session variables
dataTra <- NULL # The SDEFSR_Dataset object for the training file
dataMatrixTra <- NULL # The representation of the data as a matrix
dataTst <- NULL #The SDEFSR_Dataset object for the test file
dataMatrixTst <- NULL # The representation of the data as a matrix
pathTra <- "" #Tha path of the training file
pathTst <- ""
ruleSet <- NULL # The resulting rule set after the execution of an SD algorithm
data <- NULL # SDEFSR_Dataset of the actual selected dataset (it could be train or test)
dataMatrix <- NULL # The data of the actual selected dataset as a dataframe
pieChart <- T # Checks if "pie chart" visualization is selected
fileBefore <- "Tra" #To change the visualization between tra/tst files
ranges1 <- NULL # This are the numeric ranges for the visualization filters
ranges2 <- NULL
lastValue <- 0 #This is a control variable for the buttons
#on exit clean temporal file
on.exit({
if(file.exists(paste(getwd(), "/rulesFile.txt", sep = ""))) file.remove(paste(getwd(), "/rulesFile.txt", sep = ""))
if(file.exists(paste(getwd(), "/optionsFile.txt", sep = ""))) file.remove(paste(getwd(), "/optionsFile.txt", sep = ""))
if(file.exists(paste(getwd(), "/testQualityMeasures.txt", sep = ""))) file.remove(paste(getwd(), "/testQualityMeasures.txt", sep = ""))
})
#Observe "Keep this data" button
observe({
input$filterData #Observe this variable
if(isolate(input$traTstRadio) == "Training File"){
# Keep the data on variable vs variable, look at ranges1 and ranges2
if(isolate(input$visualization) == "Variable vs Variable"){
pos1 <- which(data[[2]] == isolate(input$Variables1))
pos2 <- which(data[[2]] == isolate(input$Variables2))
toKeep <- intersect(ranges1, ranges2)
dataMatrix <<- dataMatrix[,toKeep]
#Store data toKeep
data$data <<- dataTra$data <<- dataTra$data[toKeep]
#Modify Ns value
data$Ns <<- dataTra$Ns <<- length(toKeep)
#Modify examplesPerClass
clValues <- unlist(lapply(data$data, '[', data$nVars + 1))
examplesPerClass <- lapply(X = seq_len(length(data$class_names)) - 1, FUN = function(x, data) sum(data == x), clValues)
names(examplesPerClass) <- data$class_names
data$examplesPerClass <<- dataTra$examplesPerClass <<- examplesPerClass
#Modify min and max
data$min[pos1] <<- dataTra$min[pos1] <<- isolate(input$numericRange1)[1]
data$min[pos2] <<- dataTra$min[pos2] <<- isolate(input$numericRange2)[1]
data$max[pos1] <<- dataTra$max[pos1] <<- isolate(input$numericRange1)[2]
data$max[pos2] <<- dataTra$max[pos2] <<- isolate(input$numericRange2)[2]
} else if(isolate(input$visualization) == "Pie Chart"){
toKeep <- which((dataMatrix[nrow(dataMatrix),] +1) %in% which(data$class_names %in% isolate(input$classNames)))
dataMatrix <<- dataMatrix[,toKeep]
#Store data toKeep
data$data <<- dataTra$data <<- dataTra$data[toKeep]
#Modify Ns value
data$Ns <<- dataTra$Ns <<- length(toKeep)
#Modify examplesPerClass
clValues <- unlist(lapply(data$data, '[', data$nVars + 1))
examplesPerClass <- lapply(X = seq_len(length(data$class_names)) - 1, FUN = function(x, data) sum(data == x), clValues)
names(examplesPerClass) <- data$class_names
data$examplesPerClass <<- dataTra$examplesPerClass <<- examplesPerClass
#Modify max value
pos <- which(data[[2]] == isolate(input$targetClassSelect))
data$max <<- dataTra$max <<- length(isolate(input$classNames))
} else {
toKeep <- ranges1
dataMatrix <<- dataMatrix[,toKeep]
#Store data toKeep
data$data <<- dataTra$data <<- dataTra$data[toKeep]
#Modify Ns value
data$Ns <<- dataTra$Ns <<- length(toKeep)
#Modify examplesPerClass
clValues <- unlist(lapply(data$data, '[', data$nVars + 1))
examplesPerClass <- lapply(X = seq_len(length(data$class_names)) - 1, FUN = function(x, data) sum(data == x), clValues)
names(examplesPerClass) <- data$class_names
data$examplesPerClass <<- dataTra$examplesPerClass <<- examplesPerClass
#Modify min and max
pos <- which(data[[2]] == isolate(input$targetClassSelect))
data$min[pos] <<- dataTra$min[pos] <<- isolate(input$numericRangeVisualization)[1]
data$max[pos] <<- dataTra$max[pos] <<- isolate(input$numericRangeVisualization)[2]
}
} else {
#Test File
if(isolate(input$visualization) == "Variable vs Variable"){
pos1 <- which(data[[2]] == isolate(input$Variables1))
pos2 <- which(data[[2]] == isolate(input$Variables2))
toKeep <- intersect(ranges1, ranges2)
dataMatrix <<- dataMatrix[,toKeep]
#Store data toKeep
data$data <<- dataTst$data <<- dataTst$data[toKeep]
#Modify Ns value
data$Ns <<- dataTst$Ns <<- length(toKeep)
#Modify examplesPerClass
clValues <- unlist(lapply(data$data, '[', data$nVars + 1))
examplesPerClass <- lapply(X = seq_len(length(data$class_names)) - 1, FUN = function(x, data) sum(data == x), clValues)
names(examplesPerClass) <- data$class_names
data$examplesPerClass <<- dataTst$examplesPerClass <<- examplesPerClass
#Modify min and max
data$min[pos1] <<- dataTst$min[pos1] <<- isolate(input$numericRange1)[1]
data$min[pos2] <<- dataTst$min[pos2] <<- isolate(input$numericRange2)[1]
data$max[pos1] <<- dataTst$max[pos1] <<- isolate(input$numericRange1)[2]
data$max[pos2] <<- dataTst$max[pos2] <<- isolate(input$numericRange2)[2]
} else if(isolate(input$visualization) == "Pie Chart"){
toKeep <- which((dataMatrix[nrow(dataMatrix),] +1) %in% which(data$class_names %in% isolate(input$classNames)))
dataMatrix <<- dataMatrix[,toKeep]
#Store data toKeep
data$data <<- dataTst$data <<- dataTst$data[toKeep]
#Modify Ns value
data$Ns <<- dataTst$Ns <<- length(toKeep)
#Modify examplesPerClass
clValues <- unlist(lapply(data$data, '[', data$nVars + 1))
examplesPerClass <- lapply(X = seq_len(length(data$class_names)) - 1, FUN = function(x, data) sum(data == x), clValues)
names(examplesPerClass) <- data$class_names
data$examplesPerClass <<- dataTst$examplesPerClass <<- examplesPerClass
#Modify max value
pos <- which(data[[2]] == isolate(input$targetClassSelect))
data$max <<- dataTst$max <<- length(isolate(input$classNames))
} else {
toKeep <- ranges1
dataMatrix <<- dataMatrix[,toKeep]
#Store data toKeep
data$data <<- dataTst$data <<- dataTst$data[toKeep]
#Modify Ns value
data$Ns <<- dataTst$Ns <<- length(toKeep)
#Modify examplesPerClass
clValues <- unlist(lapply(data$data, '[', data$nVars + 1))
examplesPerClass <- lapply(X = seq_len(length(data$class_names)) - 1, FUN = function(x, data) sum(data == x), clValues)
names(examplesPerClass) <- data$class_names
data$examplesPerClass <<- dataTst$examplesPerClass <<- examplesPerClass
#Modify min and max
pos <- which(data[[2]] == isolate(input$targetClassSelect))
data$min[pos] <<- dataTst$min[pos] <<- isolate(input$numericRangeVisualization)[1]
data$max[pos] <<- dataTst$max[pos] <<- isolate(input$numericRangeVisualization)[2]
}
}
})
#--------- Statistics Table --------------------
output$statistics <- renderTable({
#----Inputs this function observe ------
input$traTstRadio
input$classNames
input$traFile
input$tstFile
input$filterData
#------------------------------
#If nothing is select, dont do anything
if(input$targetClassSelect == "NA" || length(input$targetClassSelect) == 0 || is.null(input$targetClassSelect))
return(NULL)
#Find the position of the target variable
pos <- which(data[[2]] == input$targetClassSelect)
if(length(pos) > 0){
if(data[[3]][pos] != 'c'){
#If variable selected is numeric, simply make a summary
as.matrix(summary(dataMatrix[pos, ]))
}else{
#If it is categoriical, simply count the number of examples
# but it is neccesary to take into account the selected values on the visualization
positions <- NULL
for(i in input$classNames){ # For each selected value
p <- which(data[[15]][[pos]][dataMatrix[pos,] + 1] == i)
if(length(p) > 0)
positions <- c(positions, p)
}
# make the summary of the selected data
as.matrix(summary(data[[2]][dataMatrix[which(data[[2]] == input$targetClassSelect), positions] + 1]))
}
}
})
#Observer input target class
observe({
# ---- Inputs to obseve --------
input$targetClassSelect
input$Variables1
input$Variables2
input$filterData
#-------------------------------
#Update values if necessary
posClass <- which(data[[2]] == input$targetClassSelect)
if(!is.null(ranges2)){
pos <- which(data[[2]] == input$Variables1)
updateSliderInput(session, "numericRange1", min = min(dataMatrix[pos,]), max = max(dataMatrix[pos,]), value = c(min(dataMatrix[pos,]), max(dataMatrix[pos,])), step = (max(dataMatrix[pos,]) - min(dataMatrix[pos,])) / 250)
updateSliderInput(session, "numericRangeVisualization", min = min(dataMatrix[posClass,]), max = max(dataMatrix[posClass,]), value = c(min(dataMatrix[posClass,]), max(dataMatrix[posClass,])), step = (max(dataMatrix[posClass,]) - min(dataMatrix[posClass,])) / 250)
}
if(!is.null(ranges1)){
pos <- which(data[[2]] == input$Variables2)
updateSliderInput(session, "numericRange2", min = min(dataMatrix[pos,]), max = max(dataMatrix[pos,]), value = c(min(dataMatrix[pos,]), max(dataMatrix[pos,])), step = (max(dataMatrix[pos,]) - min(dataMatrix[pos,])) / 250)
}
})
#---------------- PLOT EXPLORATORY ANALISIS ----------------------------------
output$datasetInfo <- renderPlot({
#----Inputs to observe ------
tra <- input$traTstRadio
pieChart <- input$visualization == "Pie Chart"
input$traTstRadio
input$execute
#------------------------------------
if(input$targetClassSelect == "NA" || length(input$targetClassSelect) == 0 || is.null(input$targetClassSelect))
return(NULL)
pos <- which(data[[2]] == input$targetClassSelect)
if(length(pos) == 0)
return(NULL)
#Check if selected variable is categorical
categorical <- data[[3]][pos] == 'c'
if(pieChart & categorical){
# If "pie chart" and is a categorical variable, then show the pie chart
positions <- NULL
for(i in input$classNames){
#Get only those examples which classes are in the selected variables
p <- which(data[[15]][[pos]][dataMatrix[pos,] + 1] == i)
if(length(p) > 0 )
positions <- c(positions, p)
}
#Show the plot.
if(!is.null(positions)){
tabla <- table(data[[15]][[pos]][dataMatrix[pos,]+1][positions])
pie(x = tabla,
labels = paste(names(tabla), tabla, sep = ": "),
radius = 1,
clockwise = TRUE,
col = colors,
main = "Distribution of examples over variables"
)
}
#If visualization is not pie chart or it is not a continuous variableand it is diferent of variable vs variable
# it is or histogram or a boxplot
} else if(input$visualization != "Variable vs Variable"){
#by defaut, choose histogram as visualization
updateRadioButtons(session, "visualization", selected = "Histogram")
if( categorical){
#If the variable is categorical, the histogram is visualized for those selected values only, as in the pie chart
positions <- NULL
for(i in input$classNames){
p <- which(data[[15]][[pos]][dataMatrix[pos,] + 1] == i)
if(length(p) > 0 )
positions <- c(positions, p)
}
updateSliderInput(session, "numericRangeVisualization", min = 0, max = 0, value = 0)
updateRadioButtons(session, "visualization", selected = "Histogram")
barplot(tabla <- table(data[[15]][[pos]][dataMatrix[pos,]+1][positions]),
main = "Distribution of examples over variables",
col = colors
)
} else if(input$visualization == "Histogram") {
#If the variable is not categorical
updateRadioButtons(session, "visualization", selected = "Histogram")
#Select those instances within the range and show the histogram
ranges1 <<- which(dataMatrix[pos,] >= input$numericRangeVisualization[1] & dataMatrix[pos,] <= input$numericRangeVisualization[2])
hist(x = dataMatrix[pos, ranges1],
col = colors,
main = "Distribution of examples over variables",
ylab = "Frequency",
xlab = "Value")
} else if(input$visualization == "Box Plot"){
#If Box plot is selected, then filter instances within the ranges and visualize the box plot
updateRadioButtons(session, "visualization", selected = "Box Plot")
ranges1 <<- which(dataMatrix[pos,] >= input$numericRangeVisualization[1] & dataMatrix[pos,] <= input$numericRangeVisualization[2])
boxplot(dataMatrix[pos, ranges1],
main = "Distribution of examples over variables",
xlab = input$targetClassSelect,
ylab = "Value",
col = "royalblue2",
outcol="red"
)
}
} else {
#Variable vs Variable visualization
updateRadioButtons(session, "visualization", selected = "Variable vs Variable")
#Get positions of the variables
pos1 <- which(data[[2]] == input$Variables1)
pos2 <- which(data[[2]] == input$Variables2)
#There are 3 plots possibilities:
# - Categorical vs numeric: Not defined
# - Categorical vs Categorical: Bar plots
# - Numeric vs numeric: Scatter plots
if(data$attributeTypes[pos1] == "c" & data$attributeTypes[pos1] == "c"){
#Categorigcal vs categorical
mat <- print(data)
plot(x = as.factor(mat[,pos1]),
y = as.factor(mat[,pos2]),
col = colorsWithContrast, #Change this colors to other with high contrast
main = "Variable vs Variable Plot")
} else if((data$attributeTypes[pos1] == "r" | data$attributeTypes[pos1] == "e") & (data$attributeTypes[pos2] == "r" | data$attributeTypes[pos2] == "e")){
#Numeric vs numeric
cols <- colorsWithContrast[dataMatrix[nrow(dataMatrix), ] + 1]
ranges1 <<- which(dataMatrix[pos1,] >= input$numericRange1[1] & dataMatrix[pos1,] <= input$numericRange1[2])
ranges2 <<- which(dataMatrix[pos2,] >= input$numericRange2[1] & dataMatrix[pos2,] <= input$numericRange2[2])
#Take the intersection of examples that match both ranges to have the same number of examples on both axis.
valuesToShow <- intersect(ranges1, ranges2)
#Show the plot
plot(x = dataMatrix[pos1, valuesToShow],
y = dataMatrix[pos2, valuesToShow],
main = "Variable vs Variable Plot",
pch = 19,
col = cols,
xlab = data$attributeNames[pos1],
ylab = data$attributeNames[pos2]
)
#Make the legend
legend("bottomright", legend = data$class_names, pch = 19, title = "Class", col = colorsWithContrast[1:length(data$class_names)])
} else {
#Categorical vs numeric
NULL
}
}
})
# Observe Training File
observe({
if(! is.null(input$traFile)){
tryCatch({
#if path is different for the actual chosen
if(pathTra != paste(input$traFile[,1],input$traFile[,4])){
#get the file
file <- input$traFile
file.rename(file$datapath, paste(file$datapath, regmatches(x = file, m = gregexpr(pattern = "\\.[[:alnum:]]+$", text = file))[[1]], sep = ""))
file$datapath <- paste(file$datapath, regmatches(x = file, m = gregexpr(pattern = "\\.[[:alnum:]]+$", text = file))[[1]], sep = "")
pathTra <<- paste(input$traFile[,1],input$traFile[,4])
#Read the file
dataTra <<- SDEFSR::read.dataset(file$datapath)
#Update the values, the select variable is the last one.
updateSelectInput(session = session,
inputId = "targetClassSelect",
label = "Select the target variable",
choices = dataTra[[2]], selected = dataTra[[2]][length(dataTra[[2]])])
updateSelectInput(session = session,
inputId = "Variables1",
label = "Variable X",
choices = dataTra[[2]], selected = dataTra[[2]][length(dataTra[[2]])])
updateSelectInput(session = session,
inputId = "Variables2",
label = "Variable Y",
choices = dataTra[[2]], selected = dataTra[[2]][length(dataTra[[2]])])
updateSelectInput(session = session,
inputId = "targetValueSelect",
label = "Select the target value",
choices = if(dataTra[[3]][length(dataTra[[2]])] == 'c')
c("All Values", dataTra[[15]][[length(dataTra[[2]])]])
else
"This is not a categorical variable!"
)
updateRadioButtons(session, "traTstRadio",
label = "Visualize file: ",
choices = c("Training File", "Test File"),
selected = "Training File")
#update global variables
data <<- dataTra
dataMatrixTra <<- matrix(unlist(dataTra$data), nrow = dataTra$nVars + 1)
dataMatrix <<- dataMatrixTra
.updateAttributes(session, dataTra[[2]][length(dataTra[[2]])], data)
ranges1 <<- 1:ncol(dataMatrix)
ranges2 <<- 1:ncol(dataMatrix)
}
} , error = function(e) print(e)) #If an error occur, shows to the user the error.
}
})
# Observe Test File (is the same as before, but for the test file)
observe({
if(! is.null(input$tstFile)){
if(pathTst != paste(input$tstFile[,1], input$tstFile[,4])){
file <- input$tstFile
file.rename(file$datapath, paste(file$datapath, regmatches(x = file, m = gregexpr(pattern = "\\.[[:alnum:]]+$", text = file))[[1]], sep = ""))
file$datapath <- paste(file$datapath, regmatches(x = file, m = gregexpr(pattern = "\\.[[:alnum:]]+$", text = file))[[1]], sep = "")
pathTst <<- paste(input$tstFile[,1], input$tstFile[,4])
dataTst <<- SDEFSR::read.dataset(file$datapath)
updateSelectInput(session = session,
inputId = "targetClassSelect",
label = "Select the target variable",
choices = dataTst[[2]], selected = dataTst[[2]][length(dataTst[[2]])])
updateSelectInput(session = session,
inputId = "Variables1",
label = "Variable 1",
choices = dataTst[[2]], selected = dataTst[[2]][length(dataTst[[2]])])
updateSelectInput(session = session,
inputId = "Variables2",
label = "Variable 2",
choices = dataTst[[2]], selected = dataTst[[2]][length(dataTst[[2]])])
updateSelectInput(session = session,
inputId = "targetValueSelect",
label = "Select the target value",
choices = if(dataTst[[3]][length(dataTst[[2]])] == 'c')
c("All Values", dataTst[[15]][[length(dataTst[[2]])]] )
else
"This is not a categorical variable!"
)
updateRadioButtons(session, "traTstRadio",
label = "Visualize file: ",
choices = c("Training File", "Test File"),
selected = "Test File")
data <<- dataTst
dataMatrixTst <<- matrix(unlist(dataTst$data), nrow = dataTst$nVars + 1)
dataMatrix <<- dataMatrixTst
.updateAttributes(session, dataTst[[2]][length(dataTst[[2]])], data)
ranges1 <<- 1:ncol(dataMatrix)
ranges2 <<- 1:ncol(dataMatrix)
}
}
})
#Observe Visualize File
observe({
file <- input$traTstRadio
#Changes variables between the training and test file
if(file == "Training File" & fileBefore == "Tst"){
fileBefore <<- "Tra"
data <<- dataTra
dataMatrix <<- dataMatrixTra
updateSelectInput(session = session,
inputId = "targetClassSelect",
label = "Select the target variable",
choices = data[[2]], selected = data[[2]][length(data[[2]])])
updateSelectInput(session = session,
inputId = "targetValueSelect",
label = "Select the target value",
choices = if(!is.null(data) ) if(data[[3]][length(data[[2]])] == 'c')
c("All Values", data[[15]][[length(data[[2]])]])
else
"This is not a categorical variable!"
)
updateSelectInput(session = session,
inputId = "Variables1",
label = "Variable 1",
choices = data[[2]], selected = data[[2]][length(data[[2]])])
updateSelectInput(session = session,
inputId = "Variables2",
label = "Variable 2",
choices = data[[2]], selected = data[[2]][length(data[[2]])])
ranges1 <<- 1:ncol(dataMatrix)
ranges2 <<- 1:ncol(dataMatrix)
.updateAttributes(session, data[[2]][length(data[[2]])], data)
} else if(file == "Test File" & fileBefore == "Tra") {
fileBefore <<- "Tst"
data <<- dataTst
dataMatrix <<- dataMatrixTst
updateSelectInput(session = session,
inputId = "targetClassSelect",
label = "Select the target variable",
choices = data[[2]], selected = data[[2]][length(data[[2]])])
updateSelectInput(session = session,
inputId = "targetValueSelect",
label = "Select the target value",
choices = if(!is.null(data) )if(data[[3]][length(data[[2]])] == 'c')
c("All Values", data[[15]][[length(data[[2]])]])
else
"This is not a categorical variable!"
)
updateSelectInput(session = session,
inputId = "Variables1",
label = "Variable 1",
choices = data[[2]], selected = data[[2]][length(data[[2]])])
updateSelectInput(session = session,
inputId = "Variables2",
label = "Variable 2",
choices = data[[2]], selected = data[[2]][length(data[[2]])])
.updateAttributes(session, data[[2]][length(data[[2]])], data)
ranges1 <<- 1:ncol(dataMatrix)
ranges2 <<- 1:ncol(dataMatrix)
}
})
#Observe Target Variable
observe({
#Change the target variable and update necessary fields
pos <- which(data[[2]] == input$targetClassSelect)
if(length(pos) > 0){
updateSelectInput(session = session,
inputId = "targetValueSelect",
label = "Select the target value",
choices = if(data[[3]][pos] == 'c')
c("All Values", data[[15]][[pos]])
else
"This is not a categorical variable!"
)
.updateAttributes(session, input$targetClassSelect, data)
if(data$attributeTypes[pos] != 'c'){
ranges1 <<- which(dataMatrix[pos,] >= min(dataMatrix[pos,]) & dataMatrix[pos,] <= max(dataMatrix[pos,]))
updateNumericInput(session, "numericRangeVisualization", min = min(dataMatrix[pos,]), max = max(dataMatrix[pos,]))
}
}
})
#EXECUTE ALGORITHM
observe({
input$execute
value <- input$execute
if(input$execute <= lastValue) return(NULL)
tryCatch({
# Read parameters and check errors
# ----------------------------------------------
if(any(is.null(dataTra)) )
stop("You must supply a training file and a test file. ")
if(!is.null(dataTst)){
if(dataTra[[1]] != dataTst[[1]])
stop("Training and test file must be the same relation.")
}
targetValue <- isolate(input$targetValueSelect)
if(targetValue == "This is not a categorical variable!")
stop("No categorical variable selected as target variable.")
if(targetValue == "All Values")
targetValue <- "null"
#Set target Variable.
#dataTst <<- SDEFSR::changeTargetVariable(dataTst, which(input$targetClassSelect == dataTst[[2]]))
#dataTra <<- SDEFSR::changeTargetVariable(dataTra, which(input$targetClassSelect == dataTra[[2]]))
#Catch all necessary parameters
targetClass <- isolate(input$targetClassSelect)
algorithm <- isolate(input$algorithm)
nLabels <- isolate(input$nLabels)
rulesRep <- if(isolate(input$rulesRep == "Canonical")) "can" else "dnf"
nEvals <- isolate(input$nEval)
popSize <- isolate(input$popSize)
crossProb <- isolate(input$crossProb)
mutProb <- isolate(input$mutProb)
seed <- isolate(input$seed)
#------------------------------------------------------
# Preparation of specific parameters and execution of the algoritm.
switch(algorithm,
"SDIGA"= {
minConf <- isolate(input$minConf)
Obj1 <- .getObjetives(isolate(input$Obj1))
w1 <- isolate(input$w1)
Obj2 <- .getObjetives(isolate(input$Obj2))
w2 <- isolate(input$w2)
Obj3 <- .getObjetives(isolate(input$Obj3))
w3 <- isolate(input$w3)
lSearch = if(isolate(input$lSearch)) "yes" else "no"
# Execute the algorithm
#sink("tempFile.txt")
ruleSet <<- SDEFSR::SDIGA(training = dataTra,
test = dataTst,
seed = seed,
nLabels = nLabels,
nEval = nEvals,
popLength = popSize,
mutProb = mutProb,
RulesRep = rulesRep,
Obj1 = Obj1,
w1 = w1,
Obj2 = Obj2,
w2 = w2,
Obj3 = Obj3,
w3 = w3,
minConf = minConf,
lSearch = lSearch,
targetVariable = isolate(input$targetClassSelect),
targetClass = targetValue )
#sink(NULL)
},
"MESDIF" = {
elitePop <- isolate(input$elitePop)
if(elitePop > popSize) stop("Elite population must be smaller than population size")
Obj1 <- .getObjetives(isolate(input$Obj1M))
Obj2 <- .getObjetives(isolate(input$Obj2M))
Obj3 <- .getObjetives(isolate(input$Obj3M))
Obj4 <- .getObjetives(isolate(input$Obj4M))
crossProb <- isolate(input$crossProbM)
# Execute the algorithm
#sink("tempFile.txt")
ruleSet <<- SDEFSR::MESDIF(training = dataTra,
test = dataTst,
seed = seed,
nLabels = nLabels,
nEval = nEvals,
popLength = popSize,
eliteLength = elitePop,
crossProb = crossProb,
mutProb = mutProb,
RulesRep = rulesRep,
Obj1 = Obj1,
Obj2 = Obj2,
Obj3 = Obj3,
Obj4 = Obj4,
targetVariable = isolate(input$targetClassSelect),
targetClass = targetValue)
#sink(NULL)
},
"NMEEF-SD" = {
minCnf <- isolate(input$minConf)
Obj1 <- .getObjetives(isolate(input$Obj1N))
Obj2 <- .getObjetives(isolate(input$Obj2N))
Obj3 <- .getObjetives(isolate(input$Obj3N))
strictDominance <- if(isolate(input$strictDominance)) "yes" else "no"
reInit <- if(isolate(input$reInitPob)) "yes" else "no"
porcCob <- isolate(input$porcCob)
#Execute the algorithm
ruleSet <<- SDEFSR::NMEEF_SD(training = dataTra,
test = dataTst,
seed = seed,
nLabels = nLabels,
nEval = nEvals,
popLength = popSize,
mutProb = mutProb,
crossProb = crossProb,
Obj1 = Obj1,
Obj2 = Obj2,
Obj3 = Obj3,
minCnf = minCnf,
reInitCoverage = reInit,
porcCob = porcCob,
StrictDominance = strictDominance,
targetVariable = isolate(input$targetClassSelect),
targetClass = targetValue)
},
"FuGePSD" = {
t_norm <- isolate(input$tnorm)
ruleWeight <- isolate(input$ruleWeight)
frm <- isolate(input$frm)
insProb <- isolate(input$insProb)
dropProb <- isolate(input$dropProb)
tSize <- isolate(input$tournamentSize)
gfw <- c(isolate(input$gfw1), isolate(input$gfw2), isolate(input$gfw3), isolate(input$gfw4) )
allClass <- isolate(input$allClass)
ruleSet <<- SDEFSR::FUGEPSD(paramFile = NULL,
training = dataTra,
test = dataTst,
seed = seed,
t_norm = t_norm,
ruleWeight = ruleWeight,
frm = frm,
numGenerations = nEvals,
numberOfInitialRules = popSize,
crossProb = crossProb,
mutProb = mutProb,
insProb = insProb,
dropProb = dropProb,
tournamentSize = tSize,
globalFitnessWeights = gfw,
ALL_CLASS = allClass,
targetVariable = isolate(input$targetClassSelect))
}
)
},
error = function(e){
cat(as.character(e), file = "rulesFile.txt")
cat(as.character(e), file = "optionsFile.txt")
cat(as.character(e), file = "testQualityMeasures.txt")
return(NULL)
}
)
#After execution of the algorithm, put "Rules Generated" tab as selected.
if (input$execute > 0){
updateTabsetPanel(session = session, inputId = "tabSet", selected = "Rules Generated")
}
lastValue <<- value
})
#---- Observe the algorithm choosed to change values -----
observe({
algo <- input$algorithm
if(algo == "FuGePSD"){
updateNumericInput(session, "nEval", label = "Number of generations", value = 300, min = 1, max = Inf, step = 1)
updateSelectInput(session, "rulesRep", "Type of rules: ", choices = c("Canonical"))
} else if(algo %in% c("SDIGA", "MESDIF")){
updateNumericInput(session, "nEval", label = "Number of evaluations", value = 10000, min = 1, max = Inf, step = 1)
updateSelectInput(session, "rulesRep", "Type of rules: ", choices = c("Canonical", "DNF (Disyuntive Normal Form)"))
} else if (algo == "NMEEF-SD"){
updateNumericInput(session, "nEval", label = "Number of evaluations", value = 10000, min = 1, max = Inf, step = 1)
updateSelectInput(session, "rulesRep", "Type of rules: ", choices = c("Canonical"))
}
})
# ------------ DATA TABLE OF RULES OBTAINED -------------
output$results <- renderDataTable({
input$execute
#Gets a matrix with number of the rule and the string that represents that rule by rows.
dataMatrix <- t(sapply(1:length(ruleSet), function(x,b) c(x, b[[x]]$rule), ruleSet))
#Return as data frame
data.frame(Rule_Number = dataMatrix[,1], Value = dataMatrix[,2])
}, escape = FALSE, options = list(pageLength = 10)) #By default, shows the first 10 rules.
# ------- FOR THE EXECUTION INFO TAB --------------------------
output$execInfo <- renderUI({
input$execute
if(file.exists("optionsFile.txt")){
#get and process results
contents <- readChar("optionsFile.txt", file.info("optionsFile.txt")$size)
contents <- gsub(pattern = "\n", replacement = "<br/>", x = contents, fixed = TRUE)
file.remove("optionsFile.txt")
#Show results as html
strong( HTML(contents), style = "font-family: 'consolas'" )
}
})
# ------- FOR THE QUALITY MEASURES TAB --------------------------
output$measures <- renderDataTable({
input$execute
if(input$execute > 0){
#Generate a matrix for each measure of the ruleSet by rows
dataMatrix <- t(sapply(ruleSet, function(x) c(x$qualityMeasures$nVars,
x$qualityMeasures$Coverage,
x$qualityMeasures$Unusualness,
x$qualityMeasures$Significance,
x$qualityMeasures$FuzzySupport,
x$qualityMeasures$FuzzyConfidence,
x$qualityMeasures$CrispConfidence,
x$qualityMeasures$Tpr,
x$qualityMeasures$Fpr)))
#Add means on the last row and return
dataMatrix <- rbind(dataMatrix, colMeans(dataMatrix))
dataMatrix <- cbind(c(1:length(ruleSet), "MEAN: "), dataMatrix)
colnames(dataMatrix) <- c("Rule_Number", "Num_Variables", "Coverage", "Unusualness", "Significance", "Fuzzy_Support", "Fuzzy_Confidence", "Crisp_Confidence", "TPR","FPR")
as.data.frame(dataMatrix)
}
})
# UI FOR PLOTTING QUALITY MEASURES
output$plotResultUI <- renderUI({
#the button shows the rules plot or hides it (this only create the space for the plot, it does not generate it)
if(input$displayQMGraph %% 2 == 1 & isolate(input$execute) > 0){
plotOutput("rulesPlot")
} else {
NULL
}
})
#PLOT OF THE QUALITY MEASURES
#Here the plot is generated
output$rulesPlot <- renderPlot({
print(SDEFSR::plotRules(ruleSet))
})
})
.getObjetives <- function(obj){
switch(obj,
"null" = {"null"},
"Crisp Support" = {"CSUP"},
"Fuzzy Support" = {"FSUP"},
"Crisp Confidence" = {"CCNF"},
"Fuzzy Confidence" = {"FCNF"},
"Coverage" = {"COVE"},
"Significance" = {"SIGN"},
"Unusualness" = {"UNUS"}
)
}
.updateAttributes <- function(session, attribute, data){
if(attribute == "NA" || length(attribute) == 0 || is.null(attribute))
return(NULL)
if( data[[3]][which(data[[2]] == attribute)] == 'c' )
updateCheckboxGroupInput(session, inputId = "classNames", label = "Select attributes", choices = data[[15]][[which(data[[2]] == attribute)]], selected = data[[15]][[which(data[[2]] == attribute)]], inline = T)
else
updateCheckboxGroupInput(session, "classNames", label = "Select attributes", choices = NA, inline = T)
}
aklxao2/SDEFSR documentation built on May 12, 2019, 5:36 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# This is the server logic for a Shiny web application.
# You can find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com
#
library(shiny)
#Limit size for an input file
MAX_SIZE_MB = 10
options(shiny.maxRequestSize= MAX_SIZE_MB * 1024^2)
# The colors for the graphs (obtened from Material Design: http://www.google.ch/design/spec/style/color.html#color-color-palette)
colors <- c("#E8F5E9", "#A5D6A7", "#4CAF50", "#388E3C", "#FFF9C4", "#FFF176",
"#FFEB3B", "#FDD835", "#F9A825")
#Add more colors, this is are for the variable vs variable plots
colorsWithContrast <- grDevices::rainbow(30)[c(1,10,20,30,4,14,24,6,16,28)]
#Starts the server logic
shinyServer(function(input, output, session) {
# All this must be session variables
dataTra <- NULL # The SDEFSR_Dataset object for the training file
dataMatrixTra <- NULL # The representation of the data as a matrix
dataTst <- NULL #The SDEFSR_Dataset object for the test file
dataMatrixTst <- NULL # The representation of the data as a matrix
pathTra <- "" #Tha path of the training file
pathTst <- ""
ruleSet <- NULL # The resulting rule set after the execution of an SD algorithm
data <- NULL # SDEFSR_Dataset of the actual selected dataset (it could be train or test)
dataMatrix <- NULL # The data of the actual selected dataset as a dataframe
pieChart <- T # Checks if "pie chart" visualization is selected
fileBefore <- "Tra" #To change the visualization between tra/tst files
ranges1 <- NULL # This are the numeric ranges for the visualization filters
ranges2 <- NULL
lastValue <- 0 #This is a control variable for the buttons
#on exit clean temporal file
on.exit({
if(file.exists(paste(getwd(), "/rulesFile.txt", sep = ""))) file.remove(paste(getwd(), "/rulesFile.txt", sep = ""))
if(file.exists(paste(getwd(), "/optionsFile.txt", sep = ""))) file.remove(paste(getwd(), "/optionsFile.txt", sep = ""))
if(file.exists(paste(getwd(), "/testQualityMeasures.txt", sep = ""))) file.remove(paste(getwd(), "/testQualityMeasures.txt", sep = ""))
})
#Observe "Keep this data" button
observe({
input$filterData #Observe this variable
if(isolate(input$traTstRadio) == "Training File"){
# Keep the data on variable vs variable, look at ranges1 and ranges2
if(isolate(input$visualization) == "Variable vs Variable"){
pos1 <- which(data[[2]] == isolate(input$Variables1))
pos2 <- which(data[[2]] == isolate(input$Variables2))
toKeep <- intersect(ranges1, ranges2)
dataMatrix <<- dataMatrix[,toKeep]
#Store data toKeep
data$data <<- dataTra$data <<- dataTra$data[toKeep]
#Modify Ns value
data$Ns <<- dataTra$Ns <<- length(toKeep)
#Modify examplesPerClass
clValues <- unlist(lapply(data$data, '[', data$nVars + 1))
examplesPerClass <- lapply(X = seq_len(length(data$class_names)) - 1, FUN = function(x, data) sum(data == x), clValues)
names(examplesPerClass) <- data$class_names
data$examplesPerClass <<- dataTra$examplesPerClass <<- examplesPerClass
#Modify min and max
data$min[pos1] <<- dataTra$min[pos1] <<- isolate(input$numericRange1)[1]
data$min[pos2] <<- dataTra$min[pos2] <<- isolate(input$numericRange2)[1]
data$max[pos1] <<- dataTra$max[pos1] <<- isolate(input$numericRange1)[2]
data$max[pos2] <<- dataTra$max[pos2] <<- isolate(input$numericRange2)[2]
} else if(isolate(input$visualization) == "Pie Chart"){
toKeep <- which((dataMatrix[nrow(dataMatrix),] +1) %in% which(data$class_names %in% isolate(input$classNames)))
dataMatrix <<- dataMatrix[,toKeep]
#Store data toKeep
data$data <<- dataTra$data <<- dataTra$data[toKeep]
#Modify Ns value
data$Ns <<- dataTra$Ns <<- length(toKeep)
#Modify examplesPerClass
clValues <- unlist(lapply(data$data, '[', data$nVars + 1))
examplesPerClass <- lapply(X = seq_len(length(data$class_names)) - 1, FUN = function(x, data) sum(data == x), clValues)
names(examplesPerClass) <- data$class_names
data$examplesPerClass <<- dataTra$examplesPerClass <<- examplesPerClass
#Modify max value
pos <- which(data[[2]] == isolate(input$targetClassSelect))
data$max <<- dataTra$max <<- length(isolate(input$classNames))
} else {
toKeep <- ranges1
dataMatrix <<- dataMatrix[,toKeep]
#Store data toKeep
data$data <<- dataTra$data <<- dataTra$data[toKeep]
#Modify Ns value
data$Ns <<- dataTra$Ns <<- length(toKeep)
#Modify examplesPerClass
clValues <- unlist(lapply(data$data, '[', data$nVars + 1))
examplesPerClass <- lapply(X = seq_len(length(data$class_names)) - 1, FUN = function(x, data) sum(data == x), clValues)
names(examplesPerClass) <- data$class_names
data$examplesPerClass <<- dataTra$examplesPerClass <<- examplesPerClass
#Modify min and max
pos <- which(data[[2]] == isolate(input$targetClassSelect))
data$min[pos] <<- dataTra$min[pos] <<- isolate(input$numericRangeVisualization)[1]
data$max[pos] <<- dataTra$max[pos] <<- isolate(input$numericRangeVisualization)[2]
}
} else {
#Test File
if(isolate(input$visualization) == "Variable vs Variable"){
pos1 <- which(data[[2]] == isolate(input$Variables1))
pos2 <- which(data[[2]] == isolate(input$Variables2))
toKeep <- intersect(ranges1, ranges2)
dataMatrix <<- dataMatrix[,toKeep]
#Store data toKeep
data$data <<- dataTst$data <<- dataTst$data[toKeep]
#Modify Ns value
data$Ns <<- dataTst$Ns <<- length(toKeep)
#Modify examplesPerClass
clValues <- unlist(lapply(data$data, '[', data$nVars + 1))
examplesPerClass <- lapply(X = seq_len(length(data$class_names)) - 1, FUN = function(x, data) sum(data == x), clValues)
names(examplesPerClass) <- data$class_names
data$examplesPerClass <<- dataTst$examplesPerClass <<- examplesPerClass
#Modify min and max
data$min[pos1] <<- dataTst$min[pos1] <<- isolate(input$numericRange1)[1]
data$min[pos2] <<- dataTst$min[pos2] <<- isolate(input$numericRange2)[1]
data$max[pos1] <<- dataTst$max[pos1] <<- isolate(input$numericRange1)[2]
data$max[pos2] <<- dataTst$max[pos2] <<- isolate(input$numericRange2)[2]
} else if(isolate(input$visualization) == "Pie Chart"){
toKeep <- which((dataMatrix[nrow(dataMatrix),] +1) %in% which(data$class_names %in% isolate(input$classNames)))
dataMatrix <<- dataMatrix[,toKeep]
#Store data toKeep
data$data <<- dataTst$data <<- dataTst$data[toKeep]
#Modify Ns value
data$Ns <<- dataTst$Ns <<- length(toKeep)
#Modify examplesPerClass
clValues <- unlist(lapply(data$data, '[', data$nVars + 1))
examplesPerClass <- lapply(X = seq_len(length(data$class_names)) - 1, FUN = function(x, data) sum(data == x), clValues)
names(examplesPerClass) <- data$class_names
data$examplesPerClass <<- dataTst$examplesPerClass <<- examplesPerClass
#Modify max value
pos <- which(data[[2]] == isolate(input$targetClassSelect))
data$max <<- dataTst$max <<- length(isolate(input$classNames))
} else {
toKeep <- ranges1
dataMatrix <<- dataMatrix[,toKeep]
#Store data toKeep
data$data <<- dataTst$data <<- dataTst$data[toKeep]
#Modify Ns value
data$Ns <<- dataTst$Ns <<- length(toKeep)
#Modify examplesPerClass
clValues <- unlist(lapply(data$data, '[', data$nVars + 1))
examplesPerClass <- lapply(X = seq_len(length(data$class_names)) - 1, FUN = function(x, data) sum(data == x), clValues)
names(examplesPerClass) <- data$class_names
data$examplesPerClass <<- dataTst$examplesPerClass <<- examplesPerClass
#Modify min and max
pos <- which(data[[2]] == isolate(input$targetClassSelect))
data$min[pos] <<- dataTst$min[pos] <<- isolate(input$numericRangeVisualization)[1]
data$max[pos] <<- dataTst$max[pos] <<- isolate(input$numericRangeVisualization)[2]
}
}
})
#--------- Statistics Table --------------------
output$statistics <- renderTable({
#----Inputs this function observe ------
input$traTstRadio
input$classNames
input$traFile
input$tstFile
input$filterData
#------------------------------
#If nothing is select, dont do anything
if(input$targetClassSelect == "NA" || length(input$targetClassSelect) == 0 || is.null(input$targetClassSelect))
return(NULL)
#Find the position of the target variable
pos <- which(data[[2]] == input$targetClassSelect)
if(length(pos) > 0){
if(data[[3]][pos] != 'c'){
#If variable selected is numeric, simply make a summary
as.matrix(summary(dataMatrix[pos, ]))
}else{
#If it is categoriical, simply count the number of examples
# but it is neccesary to take into account the selected values on the visualization
positions <- NULL
for(i in input$classNames){ # For each selected value
p <- which(data[[15]][[pos]][dataMatrix[pos,] + 1] == i)
if(length(p) > 0)
positions <- c(positions, p)
}
# make the summary of the selected data
as.matrix(summary(data[[2]][dataMatrix[which(data[[2]] == input$targetClassSelect), positions] + 1]))
}
}
})
#Observer input target class
observe({
# ---- Inputs to obseve --------
input$targetClassSelect
input$Variables1
input$Variables2
input$filterData
#-------------------------------
#Update values if necessary
posClass <- which(data[[2]] == input$targetClassSelect)
if(!is.null(ranges2)){
pos <- which(data[[2]] == input$Variables1)
updateSliderInput(session, "numericRange1", min = min(dataMatrix[pos,]), max = max(dataMatrix[pos,]), value = c(min(dataMatrix[pos,]), max(dataMatrix[pos,])), step = (max(dataMatrix[pos,]) - min(dataMatrix[pos,])) / 250)
updateSliderInput(session, "numericRangeVisualization", min = min(dataMatrix[posClass,]), max = max(dataMatrix[posClass,]), value = c(min(dataMatrix[posClass,]), max(dataMatrix[posClass,])), step = (max(dataMatrix[posClass,]) - min(dataMatrix[posClass,])) / 250)
}
if(!is.null(ranges1)){
pos <- which(data[[2]] == input$Variables2)
updateSliderInput(session, "numericRange2", min = min(dataMatrix[pos,]), max = max(dataMatrix[pos,]), value = c(min(dataMatrix[pos,]), max(dataMatrix[pos,])), step = (max(dataMatrix[pos,]) - min(dataMatrix[pos,])) / 250)
}
})
#---------------- PLOT EXPLORATORY ANALISIS ----------------------------------
output$datasetInfo <- renderPlot({
#----Inputs to observe ------
tra <- input$traTstRadio
pieChart <- input$visualization == "Pie Chart"
input$traTstRadio
input$execute
#------------------------------------
if(input$targetClassSelect == "NA" || length(input$targetClassSelect) == 0 || is.null(input$targetClassSelect))
return(NULL)
pos <- which(data[[2]] == input$targetClassSelect)
if(length(pos) == 0)
return(NULL)
#Check if selected variable is categorical
categorical <- data[[3]][pos] == 'c'
if(pieChart & categorical){
# If "pie chart" and is a categorical variable, then show the pie chart
positions <- NULL
for(i in input$classNames){
#Get only those examples which classes are in the selected variables
p <- which(data[[15]][[pos]][dataMatrix[pos,] + 1] == i)
if(length(p) > 0 )
positions <- c(positions, p)
}
#Show the plot.
if(!is.null(positions)){
tabla <- table(data[[15]][[pos]][dataMatrix[pos,]+1][positions])
pie(x = tabla,
labels = paste(names(tabla), tabla, sep = ": "),
radius = 1,
clockwise = TRUE,
col = colors,
main = "Distribution of examples over variables"
)
}
#If visualization is not pie chart or it is not a continuous variableand it is diferent of variable vs variable
# it is or histogram or a boxplot
} else if(input$visualization != "Variable vs Variable"){
#by defaut, choose histogram as visualization
updateRadioButtons(session, "visualization", selected = "Histogram")
if( categorical){
#If the variable is categorical, the histogram is visualized for those selected values only, as in the pie chart
positions <- NULL
for(i in input$classNames){
p <- which(data[[15]][[pos]][dataMatrix[pos,] + 1] == i)
if(length(p) > 0 )
positions <- c(positions, p)
}
updateSliderInput(session, "numericRangeVisualization", min = 0, max = 0, value = 0)
updateRadioButtons(session, "visualization", selected = "Histogram")
barplot(tabla <- table(data[[15]][[pos]][dataMatrix[pos,]+1][positions]),
main = "Distribution of examples over variables",
col = colors
)
} else if(input$visualization == "Histogram") {
#If the variable is not categorical
updateRadioButtons(session, "visualization", selected = "Histogram")
#Select those instances within the range and show the histogram
ranges1 <<- which(dataMatrix[pos,] >= input$numericRangeVisualization[1] & dataMatrix[pos,] <= input$numericRangeVisualization[2])
hist(x = dataMatrix[pos, ranges1],
col = colors,
main = "Distribution of examples over variables",
ylab = "Frequency",
xlab = "Value")
} else if(input$visualization == "Box Plot"){
#If Box plot is selected, then filter instances within the ranges and visualize the box plot
updateRadioButtons(session, "visualization", selected = "Box Plot")
ranges1 <<- which(dataMatrix[pos,] >= input$numericRangeVisualization[1] & dataMatrix[pos,] <= input$numericRangeVisualization[2])
boxplot(dataMatrix[pos, ranges1],
main = "Distribution of examples over variables",
xlab = input$targetClassSelect,
ylab = "Value",
col = "royalblue2",
outcol="red"
)
}
} else {
#Variable vs Variable visualization
updateRadioButtons(session, "visualization", selected = "Variable vs Variable")
#Get positions of the variables
pos1 <- which(data[[2]] == input$Variables1)
pos2 <- which(data[[2]] == input$Variables2)
#There are 3 plots possibilities:
# - Categorical vs numeric: Not defined
# - Categorical vs Categorical: Bar plots
# - Numeric vs numeric: Scatter plots
if(data$attributeTypes[pos1] == "c" & data$attributeTypes[pos1] == "c"){
#Categorigcal vs categorical
mat <- print(data)
plot(x = as.factor(mat[,pos1]),
y = as.factor(mat[,pos2]),
col = colorsWithContrast, #Change this colors to other with high contrast
main = "Variable vs Variable Plot")
} else if((data$attributeTypes[pos1] == "r" | data$attributeTypes[pos1] == "e") & (data$attributeTypes[pos2] == "r" | data$attributeTypes[pos2] == "e")){
#Numeric vs numeric
cols <- colorsWithContrast[dataMatrix[nrow(dataMatrix), ] + 1]
ranges1 <<- which(dataMatrix[pos1,] >= input$numericRange1[1] & dataMatrix[pos1,] <= input$numericRange1[2])
ranges2 <<- which(dataMatrix[pos2,] >= input$numericRange2[1] & dataMatrix[pos2,] <= input$numericRange2[2])
#Take the intersection of examples that match both ranges to have the same number of examples on both axis.
valuesToShow <- intersect(ranges1, ranges2)
#Show the plot
plot(x = dataMatrix[pos1, valuesToShow],
y = dataMatrix[pos2, valuesToShow],
main = "Variable vs Variable Plot",
pch = 19,
col = cols,
xlab = data$attributeNames[pos1],
ylab = data$attributeNames[pos2]
)
#Make the legend
legend("bottomright", legend = data$class_names, pch = 19, title = "Class", col = colorsWithContrast[1:length(data$class_names)])
} else {
#Categorical vs numeric
NULL
}
}
})
# Observe Training File
observe({
if(! is.null(input$traFile)){
tryCatch({
#if path is different for the actual chosen
if(pathTra != paste(input$traFile[,1],input$traFile[,4])){
#get the file
file <- input$traFile
file.rename(file$datapath, paste(file$datapath, regmatches(x = file, m = gregexpr(pattern = "\\.[[:alnum:]]+$", text = file))[[1]], sep = ""))
file$datapath <- paste(file$datapath, regmatches(x = file, m = gregexpr(pattern = "\\.[[:alnum:]]+$", text = file))[[1]], sep = "")
pathTra <<- paste(input$traFile[,1],input$traFile[,4])
#Read the file
dataTra <<- SDEFSR::read.dataset(file$datapath)
#Update the values, the select variable is the last one.
updateSelectInput(session = session,
inputId = "targetClassSelect",
label = "Select the target variable",
choices = dataTra[[2]], selected = dataTra[[2]][length(dataTra[[2]])])
updateSelectInput(session = session,
inputId = "Variables1",
label = "Variable X",
choices = dataTra[[2]], selected = dataTra[[2]][length(dataTra[[2]])])
updateSelectInput(session = session,
inputId = "Variables2",
label = "Variable Y",
choices = dataTra[[2]], selected = dataTra[[2]][length(dataTra[[2]])])
updateSelectInput(session = session,
inputId = "targetValueSelect",
label = "Select the target value",
choices = if(dataTra[[3]][length(dataTra[[2]])] == 'c')
c("All Values", dataTra[[15]][[length(dataTra[[2]])]])
else
"This is not a categorical variable!"
)
updateRadioButtons(session, "traTstRadio",
label = "Visualize file: ",
choices = c("Training File", "Test File"),
selected = "Training File")
#update global variables
data <<- dataTra
dataMatrixTra <<- matrix(unlist(dataTra$data), nrow = dataTra$nVars + 1)
dataMatrix <<- dataMatrixTra
.updateAttributes(session, dataTra[[2]][length(dataTra[[2]])], data)
ranges1 <<- 1:ncol(dataMatrix)
ranges2 <<- 1:ncol(dataMatrix)
}
} , error = function(e) print(e)) #If an error occur, shows to the user the error.
}
})
# Observe Test File (is the same as before, but for the test file)
observe({
if(! is.null(input$tstFile)){
if(pathTst != paste(input$tstFile[,1], input$tstFile[,4])){
file <- input$tstFile
file.rename(file$datapath, paste(file$datapath, regmatches(x = file, m = gregexpr(pattern = "\\.[[:alnum:]]+$", text = file))[[1]], sep = ""))
file$datapath <- paste(file$datapath, regmatches(x = file, m = gregexpr(pattern = "\\.[[:alnum:]]+$", text = file))[[1]], sep = "")
pathTst <<- paste(input$tstFile[,1], input$tstFile[,4])
dataTst <<- SDEFSR::read.dataset(file$datapath)
updateSelectInput(session = session,
inputId = "targetClassSelect",
label = "Select the target variable",
choices = dataTst[[2]], selected = dataTst[[2]][length(dataTst[[2]])])
updateSelectInput(session = session,
inputId = "Variables1",
label = "Variable 1",
choices = dataTst[[2]], selected = dataTst[[2]][length(dataTst[[2]])])
updateSelectInput(session = session,
inputId = "Variables2",
label = "Variable 2",
choices = dataTst[[2]], selected = dataTst[[2]][length(dataTst[[2]])])
updateSelectInput(session = session,
inputId = "targetValueSelect",
label = "Select the target value",
choices = if(dataTst[[3]][length(dataTst[[2]])] == 'c')
c("All Values", dataTst[[15]][[length(dataTst[[2]])]] )
else
"This is not a categorical variable!"
)
updateRadioButtons(session, "traTstRadio",
label = "Visualize file: ",
choices = c("Training File", "Test File"),
selected = "Test File")
data <<- dataTst
dataMatrixTst <<- matrix(unlist(dataTst$data), nrow = dataTst$nVars + 1)
dataMatrix <<- dataMatrixTst
.updateAttributes(session, dataTst[[2]][length(dataTst[[2]])], data)
ranges1 <<- 1:ncol(dataMatrix)
ranges2 <<- 1:ncol(dataMatrix)
}
}
})
#Observe Visualize File
observe({
file <- input$traTstRadio
#Changes variables between the training and test file
if(file == "Training File" & fileBefore == "Tst"){
fileBefore <<- "Tra"
data <<- dataTra
dataMatrix <<- dataMatrixTra
updateSelectInput(session = session,
inputId = "targetClassSelect",
label = "Select the target variable",
choices = data[[2]], selected = data[[2]][length(data[[2]])])
updateSelectInput(session = session,
inputId = "targetValueSelect",
label = "Select the target value",
choices = if(!is.null(data) ) if(data[[3]][length(data[[2]])] == 'c')
c("All Values", data[[15]][[length(data[[2]])]])
else
"This is not a categorical variable!"
)
updateSelectInput(session = session,
inputId = "Variables1",
label = "Variable 1",
choices = data[[2]], selected = data[[2]][length(data[[2]])])
updateSelectInput(session = session,
inputId = "Variables2",
label = "Variable 2",
choices = data[[2]], selected = data[[2]][length(data[[2]])])
ranges1 <<- 1:ncol(dataMatrix)
ranges2 <<- 1:ncol(dataMatrix)
.updateAttributes(session, data[[2]][length(data[[2]])], data)
} else if(file == "Test File" & fileBefore == "Tra") {
fileBefore <<- "Tst"
data <<- dataTst
dataMatrix <<- dataMatrixTst
updateSelectInput(session = session,
inputId = "targetClassSelect",
label = "Select the target variable",
choices = data[[2]], selected = data[[2]][length(data[[2]])])
updateSelectInput(session = session,
inputId = "targetValueSelect",
label = "Select the target value",
choices = if(!is.null(data) )if(data[[3]][length(data[[2]])] == 'c')
c("All Values", data[[15]][[length(data[[2]])]])
else
"This is not a categorical variable!"
)
updateSelectInput(session = session,
inputId = "Variables1",
label = "Variable 1",
choices = data[[2]], selected = data[[2]][length(data[[2]])])
updateSelectInput(session = session,
inputId = "Variables2",
label = "Variable 2",
choices = data[[2]], selected = data[[2]][length(data[[2]])])
.updateAttributes(session, data[[2]][length(data[[2]])], data)
ranges1 <<- 1:ncol(dataMatrix)
ranges2 <<- 1:ncol(dataMatrix)
}
})
#Observe Target Variable
observe({
#Change the target variable and update necessary fields
pos <- which(data[[2]] == input$targetClassSelect)
if(length(pos) > 0){
updateSelectInput(session = session,
inputId = "targetValueSelect",
label = "Select the target value",
choices = if(data[[3]][pos] == 'c')
c("All Values", data[[15]][[pos]])
else
"This is not a categorical variable!"
)
.updateAttributes(session, input$targetClassSelect, data)
if(data$attributeTypes[pos] != 'c'){
ranges1 <<- which(dataMatrix[pos,] >= min(dataMatrix[pos,]) & dataMatrix[pos,] <= max(dataMatrix[pos,]))
updateNumericInput(session, "numericRangeVisualization", min = min(dataMatrix[pos,]), max = max(dataMatrix[pos,]))
}
}
})
#EXECUTE ALGORITHM
observe({
input$execute
value <- input$execute
if(input$execute <= lastValue) return(NULL)
tryCatch({
# Read parameters and check errors
# ----------------------------------------------
if(any(is.null(dataTra)) )
stop("You must supply a training file and a test file. ")
if(!is.null(dataTst)){
if(dataTra[[1]] != dataTst[[1]])
stop("Training and test file must be the same relation.")
}
targetValue <- isolate(input$targetValueSelect)
if(targetValue == "This is not a categorical variable!")
stop("No categorical variable selected as target variable.")
if(targetValue == "All Values")
targetValue <- "null"
#Set target Variable.
#dataTst <<- SDEFSR::changeTargetVariable(dataTst, which(input$targetClassSelect == dataTst[[2]]))
#dataTra <<- SDEFSR::changeTargetVariable(dataTra, which(input$targetClassSelect == dataTra[[2]]))
#Catch all necessary parameters
targetClass <- isolate(input$targetClassSelect)
algorithm <- isolate(input$algorithm)
nLabels <- isolate(input$nLabels)
rulesRep <- if(isolate(input$rulesRep == "Canonical")) "can" else "dnf"
nEvals <- isolate(input$nEval)
popSize <- isolate(input$popSize)
crossProb <- isolate(input$crossProb)
mutProb <- isolate(input$mutProb)
seed <- isolate(input$seed)
#------------------------------------------------------
# Preparation of specific parameters and execution of the algoritm.
switch(algorithm,
"SDIGA"= {
minConf <- isolate(input$minConf)
Obj1 <- .getObjetives(isolate(input$Obj1))
w1 <- isolate(input$w1)
Obj2 <- .getObjetives(isolate(input$Obj2))
w2 <- isolate(input$w2)
Obj3 <- .getObjetives(isolate(input$Obj3))
w3 <- isolate(input$w3)
lSearch = if(isolate(input$lSearch)) "yes" else "no"
# Execute the algorithm
#sink("tempFile.txt")
ruleSet <<- SDEFSR::SDIGA(training = dataTra,
test = dataTst,
seed = seed,
nLabels = nLabels,
nEval = nEvals,
popLength = popSize,
mutProb = mutProb,
RulesRep = rulesRep,
Obj1 = Obj1,
w1 = w1,
Obj2 = Obj2,
w2 = w2,
Obj3 = Obj3,
w3 = w3,
minConf = minConf,
lSearch = lSearch,
targetVariable = isolate(input$targetClassSelect),
targetClass = targetValue )
#sink(NULL)
},
"MESDIF" = {
elitePop <- isolate(input$elitePop)
if(elitePop > popSize) stop("Elite population must be smaller than population size")
Obj1 <- .getObjetives(isolate(input$Obj1M))
Obj2 <- .getObjetives(isolate(input$Obj2M))
Obj3 <- .getObjetives(isolate(input$Obj3M))
Obj4 <- .getObjetives(isolate(input$Obj4M))
crossProb <- isolate(input$crossProbM)
# Execute the algorithm
#sink("tempFile.txt")
ruleSet <<- SDEFSR::MESDIF(training = dataTra,
test = dataTst,
seed = seed,
nLabels = nLabels,
nEval = nEvals,
popLength = popSize,
eliteLength = elitePop,
crossProb = crossProb,
mutProb = mutProb,
RulesRep = rulesRep,
Obj1 = Obj1,
Obj2 = Obj2,
Obj3 = Obj3,
Obj4 = Obj4,
targetVariable = isolate(input$targetClassSelect),
targetClass = targetValue)
#sink(NULL)
},
"NMEEF-SD" = {
minCnf <- isolate(input$minConf)
Obj1 <- .getObjetives(isolate(input$Obj1N))
Obj2 <- .getObjetives(isolate(input$Obj2N))
Obj3 <- .getObjetives(isolate(input$Obj3N))
strictDominance <- if(isolate(input$strictDominance)) "yes" else "no"
reInit <- if(isolate(input$reInitPob)) "yes" else "no"
porcCob <- isolate(input$porcCob)
#Execute the algorithm
ruleSet <<- SDEFSR::NMEEF_SD(training = dataTra,
test = dataTst,
seed = seed,
nLabels = nLabels,
nEval = nEvals,
popLength = popSize,
mutProb = mutProb,
crossProb = crossProb,
Obj1 = Obj1,
Obj2 = Obj2,
Obj3 = Obj3,
minCnf = minCnf,
reInitCoverage = reInit,
porcCob = porcCob,
StrictDominance = strictDominance,
targetVariable = isolate(input$targetClassSelect),
targetClass = targetValue)
},
"FuGePSD" = {
t_norm <- isolate(input$tnorm)
ruleWeight <- isolate(input$ruleWeight)
frm <- isolate(input$frm)
insProb <- isolate(input$insProb)
dropProb <- isolate(input$dropProb)
tSize <- isolate(input$tournamentSize)
gfw <- c(isolate(input$gfw1), isolate(input$gfw2), isolate(input$gfw3), isolate(input$gfw4) )
allClass <- isolate(input$allClass)
ruleSet <<- SDEFSR::FUGEPSD(paramFile = NULL,
training = dataTra,
test = dataTst,
seed = seed,
t_norm = t_norm,
ruleWeight = ruleWeight,
frm = frm,
numGenerations = nEvals,
numberOfInitialRules = popSize,
crossProb = crossProb,
mutProb = mutProb,
insProb = insProb,
dropProb = dropProb,
tournamentSize = tSize,
globalFitnessWeights = gfw,
ALL_CLASS = allClass,
targetVariable = isolate(input$targetClassSelect))
}
)
},
error = function(e){
cat(as.character(e), file = "rulesFile.txt")
cat(as.character(e), file = "optionsFile.txt")
cat(as.character(e), file = "testQualityMeasures.txt")
return(NULL)
}
)
#After execution of the algorithm, put "Rules Generated" tab as selected.
if (input$execute > 0){
updateTabsetPanel(session = session, inputId = "tabSet", selected = "Rules Generated")
}
lastValue <<- value
})
#---- Observe the algorithm choosed to change values -----
observe({
algo <- input$algorithm
if(algo == "FuGePSD"){
updateNumericInput(session, "nEval", label = "Number of generations", value = 300, min = 1, max = Inf, step = 1)
updateSelectInput(session, "rulesRep", "Type of rules: ", choices = c("Canonical"))
} else if(algo %in% c("SDIGA", "MESDIF")){
updateNumericInput(session, "nEval", label = "Number of evaluations", value = 10000, min = 1, max = Inf, step = 1)
updateSelectInput(session, "rulesRep", "Type of rules: ", choices = c("Canonical", "DNF (Disyuntive Normal Form)"))
} else if (algo == "NMEEF-SD"){
updateNumericInput(session, "nEval", label = "Number of evaluations", value = 10000, min = 1, max = Inf, step = 1)
updateSelectInput(session, "rulesRep", "Type of rules: ", choices = c("Canonical"))
}
})
# ------------ DATA TABLE OF RULES OBTAINED -------------
output$results <- renderDataTable({
input$execute
#Gets a matrix with number of the rule and the string that represents that rule by rows.
dataMatrix <- t(sapply(1:length(ruleSet), function(x,b) c(x, b[[x]]$rule), ruleSet))
#Return as data frame
data.frame(Rule_Number = dataMatrix[,1], Value = dataMatrix[,2])
}, escape = FALSE, options = list(pageLength = 10)) #By default, shows the first 10 rules.
# ------- FOR THE EXECUTION INFO TAB --------------------------
output$execInfo <- renderUI({
input$execute
if(file.exists("optionsFile.txt")){
#get and process results
contents <- readChar("optionsFile.txt", file.info("optionsFile.txt")$size)
contents <- gsub(pattern = "\n", replacement = "<br/>", x = contents, fixed = TRUE)
file.remove("optionsFile.txt")
#Show results as html
strong( HTML(contents), style = "font-family: 'consolas'" )
}
})
# ------- FOR THE QUALITY MEASURES TAB --------------------------
output$measures <- renderDataTable({
input$execute
if(input$execute > 0){
#Generate a matrix for each measure of the ruleSet by rows
dataMatrix <- t(sapply(ruleSet, function(x) c(x$qualityMeasures$nVars,
x$qualityMeasures$Coverage,
x$qualityMeasures$Unusualness,
x$qualityMeasures$Significance,
x$qualityMeasures$FuzzySupport,
x$qualityMeasures$FuzzyConfidence,
x$qualityMeasures$CrispConfidence,
x$qualityMeasures$Tpr,
x$qualityMeasures$Fpr)))
#Add means on the last row and return
dataMatrix <- rbind(dataMatrix, colMeans(dataMatrix))
dataMatrix <- cbind(c(1:length(ruleSet), "MEAN: "), dataMatrix)
colnames(dataMatrix) <- c("Rule_Number", "Num_Variables", "Coverage", "Unusualness", "Significance", "Fuzzy_Support", "Fuzzy_Confidence", "Crisp_Confidence", "TPR","FPR")
as.data.frame(dataMatrix)
}
})
# UI FOR PLOTTING QUALITY MEASURES
output$plotResultUI <- renderUI({
#the button shows the rules plot or hides it (this only create the space for the plot, it does not generate it)
if(input$displayQMGraph %% 2 == 1 & isolate(input$execute) > 0){
plotOutput("rulesPlot")
} else {
NULL
}
})
#PLOT OF THE QUALITY MEASURES
#Here the plot is generated
output$rulesPlot <- renderPlot({
print(SDEFSR::plotRules(ruleSet))
})
})
.getObjetives <- function(obj){
switch(obj,
"null" = {"null"},
"Crisp Support" = {"CSUP"},
"Fuzzy Support" = {"FSUP"},
"Crisp Confidence" = {"CCNF"},
"Fuzzy Confidence" = {"FCNF"},
"Coverage" = {"COVE"},
"Significance" = {"SIGN"},
"Unusualness" = {"UNUS"}
)
}
.updateAttributes <- function(session, attribute, data){
if(attribute == "NA" || length(attribute) == 0 || is.null(attribute))
return(NULL)
if( data[[3]][which(data[[2]] == attribute)] == 'c' )
updateCheckboxGroupInput(session, inputId = "classNames", label = "Select attributes", choices = data[[15]][[which(data[[2]] == attribute)]], selected = data[[15]][[which(data[[2]] == attribute)]], inline = T)
else
updateCheckboxGroupInput(session, "classNames", label = "Select attributes", choices = NA, inline = T)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.