Commit 84b5d97e authored by gross47's avatar gross47
Browse files

test

parent b9ec5ca0
......@@ -2,47 +2,37 @@
#### Data preparation ####
##--##################--##
# Tue Oct 13 15:41:41 2020 ------------------------------
# Tue Dec 01 14:26:52 2020 ------------------------------
#' Preparation of the data for the robust optimization
#'
#'
#' @param dat Untransformed data table as shown in the example.
#' @param uncertainty Indicates whether the uncertainty shall be repesented by SE or SD. Please be aware that the respective chosen uncertainty must be included in the data. Best would be to consider the format of the exemplary data (database.xlsx) in the GitLab.
#' @return An initialized landUse object ready for initScenario.
#' @import dplyr
#' @export
dataPreparation <- function(dat, uncertainty = "SE", expVAL = "mean"){ #added expected value
## Convert input Data to dat.final ##
## Convert input Data to dat.final ##
## Filter all Rows with only NA ##
dat.final <- dat[rowSums(is.na(dat)) != ncol(dat), ]
dat.final <- dat[rowSums(is.na(dat)) != ncol(dat), ]
dat.final <- dat.final[colSums(!is.na(dat.final)) > 2] # columns filled with NAs will otherwise be deleted <- can be fatal if e.g., column "branch" left empty
if(any(is.na(dat.final[, 1]))){dat.final <- dat.final[-1, ]}
## Create column names ##
colnames(dat.final) <- dat.final[1, ]
dat.final <- dat.final[-1, ]
## rename duplicated Columnnames ##
names(dat.final) <- make.unique(colnames(dat.final))
## detect and set classes of a dat.final
dat.final <- lapply(dat.final, type.convert) %>% bind_cols()
## rename first columns for initScenario function and define data structure ##
chtr.cols <- unlist(lapply(dat.final[1,],is.numeric))
chtr.cols <- length(chtr.cols[chtr.cols == FALSE])
dat.final[, (chtr.cols+1):ncol(dat.final)][is.na(dat.final[, (chtr.cols+1):ncol(dat.final)])] <- 0
dat.final[, (chtr.cols+1) : ncol(dat.final)][is.na(dat.final[, (chtr.cols + 1) : ncol(dat.final)])] <- 0
## warn and delete factor rows with NA ##
if(any(is.na(dat.final[, 1:chtr.cols]))){warning("Some Indicators have missing value, rows got deleted")}
# which(is.na(dat.final[, 1:chtr.cols]), arr.ind = TRUE)
dat.final <- na.omit(dat.final)
## select landUse names ##
landUse <- dat[1, ]
landUse <- landUse[, colSums(is.na(landUse)) != nrow(landUse)]
......@@ -51,12 +41,12 @@ dataPreparation <- function(dat, uncertainty = "SE", expVAL = "mean"){ #added
landUse <- names(landUse)
## select mean values, rename columns and gather ##
importValues <- dat.final %>% select((1:chtr.cols), starts_with(expVAL))
importValues <- dat.final %>% select((1:all_of(chtr.cols)), starts_with(expVAL))
colnames(importValues)[grepl(expVAL, colnames(importValues))] <- landUse
importValues <- importValues %>% gather(key = "landUse", value = "indicatorValue", landUse[1]:landUse[length(landUse)])
## select uncertainty, rename columns and gather ##
importUnc <- dat.final %>% select((1:chtr.cols), starts_with(uncertainty))
importUnc <- dat.final %>% select((1:all_of(chtr.cols)), starts_with(uncertainty))
colnames(importUnc)[grepl(uncertainty, colnames(importUnc))] <- landUse
importUnc <- importUnc %>% gather(key = "landUse", value = "indicatorUncertainty", landUse[1]:landUse[length(landUse)])
......@@ -64,3 +54,4 @@ dataPreparation <- function(dat, uncertainty = "SE", expVAL = "mean"){ #added
dataSource <- left_join(importValues, importUnc, by = c(names(dat.final)[1:chtr.cols], "landUse"))
return(dataSource)
}
......@@ -3,7 +3,6 @@
#----------------------------------------------------------#
# Calculate coefficients, one for each variable from the scenario table
#' @export
defineObjectiveCoefficients <- function(scenarioTable) {
# Set "less is better to negative" and divide by maximum difference
scenarioTable[scenarioTable$direction == "less is better", grep(c("^adjSem"), names(scenarioTable))] <-
......@@ -21,7 +20,6 @@ defineObjectiveCoefficients <- function(scenarioTable) {
#### Define the constraints matrix ####
#-------------------------------------#
#' @export
defineConstraintCoefficients <- function (scenarioTable) {
tempTableMore <- scenarioTable %>% filter(direction == "more is better") %>%
mutate_at(vars(starts_with("adjSem")), funs(modified = (. - minAdjSem) / diffAdjSem))
......
......@@ -2,29 +2,39 @@
#### Transform the input table in an optimLanduse object ####
##--#####################################################--##
# Fri Jan 24 23:53:50 2020 ------------------------------
# Tue Dec 01 14:26:32 2020 ------------------------------
#' Initialize the robust optimization
#'
#' The function translates the indicators values and uncertainties for the land-use options into a solvable *optimLanduse* object.
#'
#' @param coefTable See the exemplary import folder.
#' @param uValue u Value.
#' @param optimisticRule Either *expectation* or *uncertaintyAdjustedExpectation*. It indicates weather the optimistic outcomes of an indicator are directly reflected by the *expectation* or if the indicator is *adjusted*.
#' @return An initialized landUse portfolio ready for optimization.
#' @import dplyr
#' @import tidyr
#' @export
initScenario <- function(coefTable, uValue = 3, optimisticRule = "expectation") {
initScenario <- function(coefTable, uValue = 3, optimisticRule = "expectation", fixDistance = NULL) {
#-----------------------------------------#
#### Check the format of the coefTable ####
#-----------------------------------------#
if (!all(c("indicator", "direction", "landUse", "indicatorValue", "indicatorUncertainty") %in% names(coefTable))) {
stop ("At least one necessary variable for the optimization is not available. Are the requirements of the data structure met? Check the variable names.")
}
indicatorNames <- as.character(unique(coefTable$indicator))
# all(indicatorNamesCheck %in% coefTable$indicator[coefTable$landUse == "Forest"]) # useless
testLandUseIndicators <- function (x) {
all(indicatorNames %in% x)
}
if (!coefTable %>% group_by(landUse) %>% summarise(checkLanduse = testLandUseIndicators(indicator)) %>% pull(checkLanduse) %>% all()) {
stop ("At least one indicator is not available for at least one land-use option.")
}
if (!length(indicatorNames) * length(unique(coefTable$landUse)) == nrow(coefTable)) {
stop ("The indicator names are not unique. Have you assigned an indicator name twice?")
}
#----------------------------#
#### Initialise the table ####
#----------------------------#
landUse <- as.character(unique(coefTable$landUse))
indicatorNames <- as.character(unique(coefTable$indicator))
expandList <- list()
expandList[landUse] <- list(c("High", "Low"))
......@@ -37,7 +47,10 @@ initScenario <- function(coefTable, uValue = 3, optimisticRule = "expectation")
# left_join(indicatorNames, by = "indicator") %>% bind_cols(as_tibble(expandMatrix2))
# Alter Version. Evtl relevant bei Fehlersuche. Ich weiß nicht mehr was ich mir bei dem left join gedacht habe.
# tbd. Tidy raus
scenarioTable <- scenarioTable %>% rename_at(.vars = vars(!!landUse[1] : !!landUse[length(landUse)]), .funs = funs(paste0("outcome", .)))
# scenarioTable <- scenarioTable %>% rename_at(.vars = vars(!!landUse[1] : !!landUse[length(landUse)]),
# .funs = funs(paste0("outcome", .))) #.funs deprecated
names(scenarioTable)[names(scenarioTable) %in% landUse] <- paste0("outcome",names(scenarioTable)[names(scenarioTable) %in% landUse])
#--------------------#
## Attach direction ##
......@@ -68,7 +81,7 @@ initScenario <- function(coefTable, uValue = 3, optimisticRule = "expectation")
scenarioTable <- left_join(scenarioTable, spread2[, c("indicator", paste0("sem", i))], by = byIndicator)
}
scenarioTable <- scenarioTable %>% select(-contains("mean"), everything()) # Order the variables, such that the means and uncertainties follow in direct succession
# scenarioTable <- scenarioTable %>% select(-contains("mean"), everything()) # Order the variables, such that the means and uncertainties follow in direct succession
scenarioTable <- scenarioTable %>% select(-contains("sem"), everything()) # Alternatively, but slower, a second loop would be suitable
if(!dim(scenarioTableTemp1)[1] == dim(scenarioTable)[1]) {cat("Error: Attaching expectation or uncertainty failed.")}
......@@ -117,15 +130,23 @@ initScenario <- function(coefTable, uValue = 3, optimisticRule = "expectation")
#--------------------------#
## calculate Min Max Diff ##
#--------------------------#
if(is.null(fixDistance)){
scenarioTable[, c("minAdjSem", "maxAdjSem", "diffAdjSem")] <-
apply(scenarioTable[, startsWith(names(scenarioTable), "adjSem")], 1,
function(x) {c(min(x), max(x), (max(x) - min(x)))}) %>% t()
} else if (length(fixDistance) == dim(scenarioTable)[1]) {
scenarioTable[, c("minAdjSem", "maxAdjSem")] <-
apply(scenarioTable[, startsWith(names(scenarioTable), "adjSem")], 1,
function(x) {c(min(x), max(x))}) %>% t()
scenarioTable$diffAdjSem <- fixDistance
} else {stop("The dimension of the fixed distance does not fit the dimension of the scenario table.")}
scenarioTable[, c("minAdjSem", "maxAdjSem", "diffAdjSem")] <-
apply(scenarioTable[, startsWith(names(scenarioTable), "adjSem")], 1, function(x) {c(min(x), max(x), (max(x) - min(x)))}) %>% t()
#-------------------------------------------------------------#
## Define the coefficients for the linear objective function ##
#-------------------------------------------------------------#
#and the restrictions.
#and the restrictions. (Simplify the scenario to a row problem)
coefObjective <- defineObjectiveCoefficients(scenarioTable)
#-------------------------------------#
......@@ -139,6 +160,7 @@ initScenario <- function(coefTable, uValue = 3, optimisticRule = "expectation")
scenarioTable = scenarioTable,
coefObjective = coefObjective,
coefConstraint = constraintCoefficients,
distance = scenarioTable$diffAdjSem,
status = "initialized",
beta = NA,
landUse = setNames(data.frame(matrix(rep(NA, length(landUse)), ncol = length(landUse), nrow = 1)), landUse),
......@@ -148,3 +170,4 @@ initScenario <- function(coefTable, uValue = 3, optimisticRule = "expectation")
return(retList)
}
......@@ -48,12 +48,63 @@ server <- function(input, output, session) {
})
# Model --------------------------------------------------------------
dataSourceSelect <- reactive({
dataSource() %>%
filter(indicatorGroup %in% input$IndicatorGroups)
})
inVars <- reactive({
unique(dataSourceSelect()$landUse)
})
output$slidersMin <- renderUI({
pvars <- length(inVars())
if (pvars > 0) {
div(
lapply(seq(pvars), function(i) {
numericInput(inputId = paste0("rangeMin", inVars()[i]),label = inVars()[i], min = 0, max = 1, value = 0, step = 0.1)
}),
actionButton("getValues", "Get values"),
tableOutput('table')
)
}
})
output$slidersMax<- renderUI({
pvars <- length(inVars())
if (pvars > 0) {
div(
lapply(seq(pvars), function(i) {
numericInput(inputId = paste0("rangeMax", inVars()[i]),label = inVars()[i], min = 0, max = 1, value = 0, step = 0.1)
}),
actionButton("getValues", "Get values"),
tableOutput('table')
)
}
})
# get the values of each numericInput and store them in "values"
observeEvent(
$getValues, {
# initialize vector
valuesMin <<- rep(NA, length(inVars()))
valuesMax <<- rep(NA, length(inVars()))
names(values) <<- inVars()
for(k in 1:length(inVars())) {
inputName <- paste0("rangeMin", inVars()[k])
# only get a value if the numeric input exists
if (!is.null(inputName))
valuesMin[[k]] <<- input[[inputName]]
valuesMax[[k]] <<- input[[inputName]]
}
# show values as a table
output$table <- renderTable(data.frame(
variable = inVars(),
valuesMin, ValueMax))
})
ownResultData <- reactive({
ownResult <- setNames(data.frame(matrix(ncol = length(unique(dataSource()$landUse)) + 1, nrow = 0)), c("u", unique(dataSource()$landUse)))
......
......@@ -2,21 +2,11 @@
##--#############################--##
#### Solve a optimLandUse object ####
##--#############################--##
# Mon Jan 27 10:35:54 2020 ------------------------------
# Tue Dec 01 14:27:27 2020 ------------------------------
#' Perform the robust optimization
#'
#' The function solves the initialized *optimLanduse* object.
#'
#' @param x The *optimLanduse* object.
#' @param digitsPrecision Precision.
#' @return A solved landUse portfolio.
#' @import lpSolveAPI
#' @export
solveScenario <- function (x, digitsPrecision = 4) {
# Bases on funDraft4 (rProgramming/uncertaintyOptimization/helperFunctions.R)
coefObjective <- x$coefObjective
piConstraintCoefficients <- x$coefConstraint
......@@ -32,12 +22,18 @@ solveScenario <- function (x, digitsPrecision = 4) {
# Init lpa Object
lpaObj <- make.lp(nrow = 0, ncol = length(coefObjective))
set.objfn(lprec = lpaObj, obj = coefObjective)
add.constraint(lprec = lpaObj, xt = rep(1, length(coefObjective)), type = "=", rhs = 1)
apply(piConstraintCoefficients, 1, function(x) {add.constraint(lprec = lpaObj, xt =x, type = ">=", rhs = piConstraintRhs[2])})
add.constraint(lprec = lpaObj, xt = rep(1, length(coefObjective)),
type = "=", rhs = 1)
# Additional min-max constraints could be implemented here
apply(piConstraintCoefficients,
1,
function(x) {add.constraint(lprec = lpaObj, xt =x, type = ">=", rhs = piConstraintRhs[2])}
)
lp.control(lprec = lpaObj, sense = "max")
counter <- 1 # 1 as the first iteration is outside the loop
set.rhs(lprec = lpaObj, b = c(1, rep(piConstraintRhs[2], dim(piConstraintCoefficients)[1])))
set.rhs(lprec = lpaObj, b = c(1, rep(piConstraintRhs[2],
dim(piConstraintCoefficients)[1])))
statusOpt <- lpSolveAPI::solve.lpExtPtr(lpaObj)
# Stepwise approximation loop
......@@ -45,6 +41,10 @@ solveScenario <- function (x, digitsPrecision = 4) {
solutionFeasible <- TRUE
counter <- counter + 1
#if (refreshCoef) {
# tbd. Bisher platzhalter.
#}
if (statusOpt == 0) {
......@@ -54,7 +54,7 @@ solveScenario <- function (x, digitsPrecision = 4) {
}
set.rhs(lprec = lpaObj, b = c(1, rep(piConstraintRhs[2], dim(piConstraintCoefficients)[1])))
statusOpt <- lpSolveAPI::solve.lpExtPtr(lpaObj)
statusOpt <- lpSolveAPI::solve.lpExtPtr(lpaObj)
if(all(c(piConstraintRhs[3] - piConstraintRhs[2], piConstraintRhs[2] - piConstraintRhs[1]) <= precision)) {
break()
......
......@@ -38,7 +38,7 @@ library(shinyjs)
ui <- navbarPage(title = img(src="Logo_TUM_GOE.jpg", height = "40px", width = "250px"), id = "navBar",
theme = "test.css",
# inverse = TRUE,
# inverse = TRUE,
windowTitle = "Robust multi-criterial optimization",
position = "fixed-top",
header = tags$style(
......@@ -46,11 +46,11 @@ ui <- navbarPage(title = img(src="Logo_TUM_GOE.jpg", height = "40px", width = "2
float: right !important;
}",
"body {padding-top: 75px;}"),
tabPanel("Home", value = "home",
shinyjs::useShinyjs(),
fluidRow(
HTML("
......@@ -137,26 +137,24 @@ ui <- navbarPage(title = img(src="Logo_TUM_GOE.jpg", height = "40px", width = "2
tableOutput("contents")
)
)),
tabPanel(title = "Model",
headerPanel(""),
fluidRow(
column(4,
sidebarPanel(
checkboxGroupInput(inputId = "IndicatorGroups", "IndicatorGroups", "",
selected = "")
)),
column(6,
mainPanel(
plotOutput("plot1")
)),
column(2)),
tags$hr(),
fluidRow(
downloadButton('downloadPlot','Download Plot')
)
),
tabPanel(
title = "Model",
plotOutput("plot1"),
hr(),
fluidRow(
column(3,
checkboxGroupInput(inputId = "IndicatorGroups", "IndicatorGroups", "", selected = ""),
),
column(4, offset = 1, uiOutput("slidersMin"),
),
column(4,
uiOutput("slidersMax"),
),
column(4,
downloadButton('downloadPlot','Download Plot')))),
tabPanel(title = "About us")
)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment