andreas/prioritized.grouping
1
0
Fork 0
mirror of https://github.com/agdamsbo/prioritized.grouping.git synced 2025-09-12 02:29:40 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

RSymphony is not ported to webR. Will not run. Will come back.

Browse source
This commit is contained in:
Andreas Gammelgaard Damsbo 2024-01-11 13:42:03 +01:00
parent 2d63d67cee
commit 73bdac829a
8 changed files with 215 additions and 157 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
DESCRIPTION
View file

@ -24,7 +24,8 @@ Imports:
httpuv,
here,
shiny,
cpp11
cpp11,
ROI.plugin.alabama
Suggests:
pak,
usethis

42
R/group_assign.R
View file

@ -1,8 +1,23 @@
#' Solve group assignment based on
#'
#' @param ds data set
#' @param cap_classes class capacity. Numeric vector length 1 or length=number
#' of groups. If NULL equal group sizes are calculated. Default is NULL.
#' @param excess_space allowed excess group fill. Default is 1.2.
#' @param pre_assign Pre assigned data set. Optional.
#' @param set_solver choose the desired solver (originally "symphony").
#'
#' @return
#' @export
#'
#' @examples
#' read.csv(here::here("data/assign_sample.csv")) |> group_assignment()
group_assignment <-
function(ds,
cap_classes = NULL,
excess_space = NULL,
pre_assign = NULL) {
excess_space = 1.2,
pre_assign = NULL,
set_solver="symphony") {
require(ROI)
require(ROI.plugin.symphony)
@ -21,11 +36,7 @@ group_assignment <-
## Adding the option to introduce a bit of head room to the classes by
## the groups to a little bigger than the smallest possible
## Default is to allow for an extra 20 % fill
if (is.null(excess_space)) {
excess <- 1.2
} else {
excess <- excess_space
}
excess <- excess_space
# generous round up of capacities
if (is.null(cap_classes)) {
@ -66,16 +77,16 @@ group_assignment <-
i_m <- seq_len(num_groups)
j_m <- seq_len(num_sub)
m <- ompr::MIPModel() %>%
m <- ompr::MIPModel() |>
ompr::add_variable(grp[i, j],
i = i_m,
j = j_m,
type = "binary") %>%
type = "binary") |>
## The first constraint says that group size should not exceed capacity
ompr::add_constraint(ompr::sum_expr(grp[i, j], j = j_m) <= capacity[i],
i = i_m) %>%
i = i_m) |>
## The second constraint says each subject can only be in one group
ompr::add_constraint(ompr::sum_expr(grp[i, j], i = i_m) == 1, j = j_m) %>%
ompr::add_constraint(ompr::sum_expr(grp[i, j], i = i_m) == 1, j = j_m) |>
## The objective is set to minimize the cost of the assignments
## Giving subjects the group with the highest possible ranking
ompr::set_objective(ompr::sum_expr(
@ -83,13 +94,14 @@ group_assignment <-
i = i_m,
j = j_m
),
"min") %>%
ompr::solve_model(ompr.roi::with_ROI(solver = "symphony", verbosity = 1))
"min") |>
# ompr::solve_model(ompr.roi::with_ROI(solver = "symphony", verbosity = 1))
ompr::solve_model(ompr.roi::with_ROI(solver = set_solver, verbosity = 1))
## Getting assignments
solution <- ompr::get_solution(m, grp[i, j]) %>% filter(value > 0)
solution <- ompr::get_solution(m, grp[i, j]) |> dplyr::filter(value > 0)
assign <- solution |> select(i,j)
assign <- solution |> dplyr::select(i,j)
if (!is.null(rownames(cost))){
assign$i <- rownames(cost)[assign$i]

50
R/server.R
View file

@ -1,19 +1,9 @@
library(shiny)
server <- function(input, output, session) {
library(dplyr)
library(tidyr)
library(ROI)
library(ROI.plugin.symphony)
library(ompr)
library(ompr.roi)
library(magrittr)
library(ggplot2)
library(viridisLite)
library(patchwork)
library(openxlsx)
# source("https://git.nikohuru.dk/au-phd/PhysicalActivityandStrokeOutcome/raw/branch/main/side%20projects/assignment.R")
source(here::here("R/group_assign.R"))
dat <- shiny::reactive({
dat <- reactive({
# input$file1 will be NULL initially. After the user selects
# and uploads a file, head of that data file by default,
# or all rows if selected, will be shown.
@ -22,19 +12,27 @@ server <- function(input, output, session) {
# Make laoding dependent of file name extension (file_ext())
ext <- file_extension(input$file1$datapath)
if (ext == "csv") {
df <- read.csv(input$file1$datapath,na.strings = c("NA", '""',""))
} else if (ext %in% c("xls", "xlsx")) {
df <- openxlsx::read.xlsx(input$file1$datapath,na.strings = c("NA", '""',""))
tryCatch(
{
if (ext == "csv") {
df <- read.csv(input$file1$datapath,na.strings = c("NA", '""',""))
} else if (ext %in% c("xls", "xlsx")) {
df <- openxlsx::read.xlsx(input$file1$datapath,na.strings = c("NA", '""',""))
} else {
stop("Input file format has to be either '.csv', '.xls' or '.xlsx'")
}
} else {
stop("Input file format has to be either '.csv', '.xls' or '.xlsx'")
}
},
error = function(e) {
# return a safeError if a parsing error occurs
stop(safeError(e))
}
)
return(df)
})
dat_pre <- shiny::reactive({
dat_pre <- reactive({
# req(input$file2)
# Make laoding dependent of file name extension (file_ext())
@ -58,7 +56,7 @@ server <- function(input, output, session) {
})
assign <-
shiny::reactive({
reactive({
assigned <- group_assignment(
ds = dat(),
excess_space = input$ecxess,
@ -68,24 +66,24 @@ server <- function(input, output, session) {
})
output$raw.data.tbl <- shiny::renderTable({
output$raw.data.tbl <- renderTable({
assign()$export
})
output$pre.assign <- shiny::renderTable({
output$pre.assign <- renderTable({
dat_pre()
})
output$input <- shiny::renderTable({
output$input <- renderTable({
dat()
})
output$assign.plt <- shiny::renderPlot({
output$assign.plt <- renderPlot({
assignment_plot(assign())
})
# Downloadable csv of selected dataset ----
output$downloadData <- shiny::downloadHandler(
output$downloadData <- downloadHandler(
filename = "group_assignment.csv",
content = function(file) {

63
R/ui.R
View file

@ -1,11 +1,12 @@
ui <- shiny::fluidPage(
library(shiny)
ui <- fluidPage(
## -----------------------------------------------------------------------------
## Application title
## -----------------------------------------------------------------------------
shiny::titlePanel("Assign groups based on costs/priorities.",
titlePanel("Assign groups based on costs/priorities.",
windowTitle = "Group assignment calculator"),
shiny::h5(
h5(
"Please note this calculator is only meant as a proof of concept for educational purposes,
and the author will take no responsibility for the results of the calculator.
Uploaded data is not kept, but please, do not upload any sensitive data."
@ -19,25 +20,25 @@ ui <- shiny::fluidPage(
## -----------------------------------------------------------------------------
## Single entry
## -----------------------------------------------------------------------------
shiny::sidebarLayout(
shiny::sidebarPanel(
shiny::numericInput(
sidebarLayout(
sidebarPanel(
numericInput(
inputId = "ecxess",
label = "Excess space",
value = 1,
step = .05
),
shiny::p("As default, the program will try to evenly distribute subjects in groups.
p("As default, the program will try to evenly distribute subjects in groups.
This factor will add more capacity to each group, for an overall lesser cost,
but more uneven group numbers. More adjustments can be performed with the source script."),
shiny::a(href='https://git.nikohuru.dk/au-phd/PhysicalActivityandStrokeOutcome/src/branch/main/apps/Assignment', "Source", target="_blank"),
a(href='https://git.nikohuru.dk/au-phd/PhysicalActivityandStrokeOutcome/src/branch/main/apps/Assignment', "Source", target="_blank"),
## -----------------------------------------------------------------------------
## File upload
## -----------------------------------------------------------------------------
# Input: Select a file ----
shiny::fileInput(
fileInput(
inputId = "file1",
label = "Choose main data file",
multiple = FALSE,
@ -45,14 +46,14 @@ ui <- shiny::fluidPage(
".csv",".xls",".xlsx"
)
),
shiny::strong("Columns: ID, group1, group2, ... groupN."),
shiny::strong("NOTE: 0s will be interpreted as lowest score."),
shiny::p("Cells should contain cost/priorities.
strong("Columns: ID, group1, group2, ... groupN."),
strong("NOTE: 0s will be interpreted as lowest score."),
p("Cells should contain cost/priorities.
Lowest score, for highest priority.
Non-ranked should contain a number (eg lowest score+1).
Will handle missings but try to avoid."),
shiny::fileInput(
fileInput(
inputId = "file2",
label = "Choose data file for pre-assigned subjects",
multiple = FALSE,
@ -60,7 +61,7 @@ ui <- shiny::fluidPage(
".csv",".xls",".xlsx"
)
),
shiny::h6("Columns: ID, group"),
h6("Columns: ID, group"),
@ -71,47 +72,47 @@ ui <- shiny::fluidPage(
# Horizontal line ----
tags$hr(),
shiny::h4("Download results"),
h4("Download results"),
# Button
shiny::downloadButton("downloadData", "Download")
downloadButton("downloadData", "Download")
),
shiny::mainPanel(shiny::tabsetPanel(
mainPanel(tabsetPanel(
## -----------------------------------------------------------------------------
## Plot tab
## -----------------------------------------------------------------------------
shiny::tabPanel(
tabPanel(
"Summary",
shiny::h3("Assignment plot"),
shiny::p("These plots are to summarise simple performance meassures for the assignment.
h3("Assignment plot"),
p("These plots are to summarise simple performance meassures for the assignment.
'f' is group fill fraction and 'm' is mean cost in group."),
shiny::plotOutput("assign.plt")
plotOutput("assign.plt")
),
shiny::tabPanel(
tabPanel(
"Results",
shiny::h3("Raw Results"),
shiny::p("This is identical to the downloaded file (see panel on left)"),
h3("Raw Results"),
p("This is identical to the downloaded file (see panel on left)"),
shiny::htmlOutput("raw.data.tbl", container = span)
htmlOutput("raw.data.tbl", container = span)
),
shiny::tabPanel(
tabPanel(
"Input data Results",
shiny::h3("Costs/prioritis overview"),
h3("Costs/prioritis overview"),
shiny::htmlOutput("input", container = span),
htmlOutput("input", container = span),
shiny::h3("Pre-assigned groups"),
shiny::p("Appears empty if none is uploaded."),
h3("Pre-assigned groups"),
p("Appears empty if none is uploaded."),
shiny::htmlOutput("pre.assign", container = span)
htmlOutput("pre.assign", container = span)
)

8
README.md
View file

@ -5,4 +5,10 @@ Reviving an old project to use shinylive with R
## Shortcoming
This will only deploy a static site. No uploaded file processing is available apparently. Looking forward to developments.
This project requires ROI.plugin.symphony to solve the problem, which depends on the RSymphony project (which again adapts SYMPHONY MILP), which is not [compiled for webR](https://repo.r-wasm.org/).
Clone the project and run the solver with
```
shiny::runApp(appDir = here::here("R/"),launch.browser = TRUE)
```

2
docs/app.json
View file

File diff suppressed because one or more lines are too long

35
renv.lock
View file

@ -76,6 +76,20 @@
],
"Hash": "42ce9ee4c1cf168869f4386d2cdeadd2"
},
"ROI.plugin.alabama": {
"Package": "ROI.plugin.alabama",
"Version": "1.0-2",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"ROI",
"alabama",
"methods",
"stats",
"utils"
],
"Hash": "097f1b625baf91f0d8999a1385054250"
},
"ROI.plugin.symphony": {
"Package": "ROI.plugin.symphony",
"Version": "1.0-0",
@ -110,6 +124,17 @@
],
"Hash": "3f55239fe534fe91e739c77d99a4ffbf"
},
"alabama": {
"Package": "alabama",
"Version": "2023.1.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"numDeriv"
],
"Hash": "593db7eb170506e6b61ca0c803201924"
},
"archive": {
"Package": "archive",
"Version": "1.1.7",
@ -692,6 +717,16 @@
],
"Hash": "a623a2239e642806158bc4dc3f51565d"
},
"numDeriv": {
"Package": "numDeriv",
"Version": "2016.8-1.1",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"R"
],
"Hash": "df58958f293b166e4ab885ebcad90e02"
},
"ompr": {
"Package": "ompr",
"Version": "1.0.4",

9
shinylive init.R
View file

@ -1,3 +1,8 @@
shinylive::export("R", "docs")
# Typical shiny
shiny::runApp(appDir = here::here("R/"),launch.browser = TRUE)
httpuv::runStaticServer("docs")
# Shinylive version
shinylive::export(appdir = "R", destdir = "docs")
httpuv::runStaticServer(dir = "docs")