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, httpuv,
here, here,
shiny, shiny,
cpp11 cpp11,
ROI.plugin.alabama
Suggests: Suggests:
pak, pak,
usethis usethis

100
R/group_assign.R
View file

@ -1,32 +1,43 @@
#' 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 <- group_assignment <-
function(ds, function(ds,
cap_classes = NULL, cap_classes = NULL,
excess_space = NULL, excess_space = 1.2,
pre_assign = NULL) { pre_assign = NULL,
set_solver="symphony") {
require(ROI) require(ROI)
require(ROI.plugin.symphony) require(ROI.plugin.symphony)
if (!is.data.frame(ds)){ if (!is.data.frame(ds)){
stop("Supplied data has to be a data frame, with each row stop("Supplied data has to be a data frame, with each row
are subjects and columns are groups, with the first column being are subjects and columns are groups, with the first column being
subject identifiers")} subject identifiers")}
## This program very much trust the user to supply correctly formatted data ## This program very much trust the user to supply correctly formatted data
cost <- t(ds[,-1]) #Transpose converts to matrix cost <- t(ds[,-1]) #Transpose converts to matrix
colnames(cost) <- ds[,1] colnames(cost) <- ds[,1]
num_groups <- dim(cost)[1] num_groups <- dim(cost)[1]
num_sub <- dim(cost)[2] num_sub <- dim(cost)[2]
## Adding the option to introduce a bit of head room to the classes by ## Adding the option to introduce a bit of head room to the classes by
## the groups to a little bigger than the smallest possible ## the groups to a little bigger than the smallest possible
## Default is to allow for an extra 20 % fill ## Default is to allow for an extra 20 % fill
if (is.null(excess_space)) { excess <- excess_space
excess <- 1.2
} else {
excess <- excess_space
}
# generous round up of capacities # generous round up of capacities
if (is.null(cap_classes)) { if (is.null(cap_classes)) {
capacity <- rep(ceiling(excess*num_sub/num_groups), num_groups) capacity <- rep(ceiling(excess*num_sub/num_groups), num_groups)
@ -39,7 +50,7 @@ group_assignment <-
} else { } else {
stop("cap_classes has to be either length 1 or same as number of groups") stop("cap_classes has to be either length 1 or same as number of groups")
} }
## This test should be a little more elegant ## This test should be a little more elegant
## pre_assign should be a data.frame or matrix with an ID and assignment column ## pre_assign should be a data.frame or matrix with an ID and assignment column
with_pre_assign <- FALSE with_pre_assign <- FALSE
@ -52,30 +63,30 @@ group_assignment <-
capacity <- capacity-lengths(pre) capacity <- capacity-lengths(pre)
# Making sure pre_assigned are removed from main data set # Making sure pre_assigned are removed from main data set
ds <- ds[!ds[[1]] %in% pre_assign[[1]],] ds <- ds[!ds[[1]] %in% pre_assign[[1]],]
cost <- t(ds[,-1]) cost <- t(ds[,-1])
colnames(cost) <- ds[,1] colnames(cost) <- ds[,1]
num_groups <- dim(cost)[1] num_groups <- dim(cost)[1]
num_sub <- dim(cost)[2] num_sub <- dim(cost)[2]
} }
## Simple NA handling. Better to handle NAs yourself! ## Simple NA handling. Better to handle NAs yourself!
cost[is.na(cost)] <- num_groups cost[is.na(cost)] <- num_groups
i_m <- seq_len(num_groups) i_m <- seq_len(num_groups)
j_m <- seq_len(num_sub) j_m <- seq_len(num_sub)
m <- ompr::MIPModel() %>% m <- ompr::MIPModel() |>
ompr::add_variable(grp[i, j], ompr::add_variable(grp[i, j],
i = i_m, i = i_m,
j = j_m, j = j_m,
type = "binary") %>% type = "binary") |>
## The first constraint says that group size should not exceed capacity ## 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], 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 ## 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 ## The objective is set to minimize the cost of the assignments
## Giving subjects the group with the highest possible ranking ## Giving subjects the group with the highest possible ranking
ompr::set_objective(ompr::sum_expr( ompr::set_objective(ompr::sum_expr(
@ -83,14 +94,15 @@ group_assignment <-
i = i_m, i = i_m,
j = j_m j = j_m
), ),
"min") %>% "min") |>
ompr::solve_model(ompr.roi::with_ROI(solver = "symphony", verbosity = 1)) # 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 ## 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))){ if (!is.null(rownames(cost))){
assign$i <- rownames(cost)[assign$i] assign$i <- rownames(cost)[assign$i]
} }
@ -98,39 +110,39 @@ group_assignment <-
if (!is.null(colnames(cost))){ if (!is.null(colnames(cost))){
assign$j <- colnames(cost)[assign$j] assign$j <- colnames(cost)[assign$j]
} }
## Splitting into groups based on assignment ## Splitting into groups based on assignment
assign_ls <- split(assign$j,assign$i) assign_ls <- split(assign$j,assign$i)
## Extracting subject cost for the final assignment for evaluation ## Extracting subject cost for the final assignment for evaluation
if (is.null(rownames(cost))){ if (is.null(rownames(cost))){
rownames(cost) <- seq_len(nrow(cost)) rownames(cost) <- seq_len(nrow(cost))
} }
if (is.null(colnames(cost))){ if (is.null(colnames(cost))){
colnames(cost) <- seq_len(ncol(cost)) colnames(cost) <- seq_len(ncol(cost))
} }
eval <- lapply(seq_len(length(assign_ls)),function(i){ eval <- lapply(seq_len(length(assign_ls)),function(i){
ndx <- match(names(assign_ls)[i],rownames(cost)) ndx <- match(names(assign_ls)[i],rownames(cost))
cost[ndx,assign_ls[[i]]] cost[ndx,assign_ls[[i]]]
}) })
names(eval) <- names(assign_ls) names(eval) <- names(assign_ls)
if (with_pre_assign){ if (with_pre_assign){
names(pre) <- names(assign_ls) names(pre) <- names(assign_ls)
assign_all <- mapply(c, assign_ls, pre, SIMPLIFY=FALSE) assign_all <- mapply(c, assign_ls, pre, SIMPLIFY=FALSE)
out <- list(all_assigned=assign_all) out <- list(all_assigned=assign_all)
} else { } else {
out <- list(all_assigned=assign_ls) out <- list(all_assigned=assign_ls)
} }
export <- do.call(rbind,lapply(seq_along(out[[1]]),function(i){ export <- do.call(rbind,lapply(seq_along(out[[1]]),function(i){
cbind("ID"=out[[1]][[i]],"Group"=names(out[[1]])[i]) cbind("ID"=out[[1]][[i]],"Group"=names(out[[1]])[i])
})) }))
out <- append(out, out <- append(out,
list(evaluation=eval, list(evaluation=eval,
assigned=assign_ls, assigned=assign_ls,
@ -149,7 +161,7 @@ group_assignment <-
## Assessment performance overview ## Assessment performance overview
## The function plots costs of assignment for each subject in every group ## The function plots costs of assignment for each subject in every group
assignment_plot <- function(lst){ assignment_plot <- function(lst){
dl <- lst[[2]] dl <- lst[[2]]
cost_scale <- unique(lst[[8]]) cost_scale <- unique(lst[[8]])
cap <- lst[[5]] cap <- lst[[5]]
@ -159,20 +171,20 @@ assignment_plot <- function(lst){
require(ggplot2) require(ggplot2)
require(patchwork) require(patchwork)
require(viridisLite) require(viridisLite)
y_max <- max(lengths(dl)) y_max <- max(lengths(dl))
wrap_plots(lapply(seq_along(dl),function(i){ wrap_plots(lapply(seq_along(dl),function(i){
ttl <- names(dl)[i] ttl <- names(dl)[i]
ns <- length(dl[[i]]) ns <- length(dl[[i]])
cnts <- cnts_ls[[i]] cnts <- cnts_ls[[i]]
ggplot2::ggplot() + ggplot2::geom_bar(ggplot2::aes(cnts,fill=cnts)) + ggplot2::ggplot() + ggplot2::geom_bar(ggplot2::aes(cnts,fill=cnts)) +
ggplot2::scale_x_discrete(name = NULL, breaks=cost_scale, drop=FALSE) + ggplot2::scale_x_discrete(name = NULL, breaks=cost_scale, drop=FALSE) +
ggplot2::scale_y_continuous(name = NULL, limits = c(0,y_max)) + ggplot2::scale_y_continuous(name = NULL, limits = c(0,y_max)) +
ggplot2::scale_fill_manual(values = viridisLite::viridis(length(cost_scale), direction = -1)) + ggplot2::scale_fill_manual(values = viridisLite::viridis(length(cost_scale), direction = -1)) +
ggplot2::guides(fill=FALSE) + ggplot2::guides(fill=FALSE) +
ggplot2::labs(title=paste0(ttl," (fill=",round(ns/cap[[i]],1),";m=",round(mean(dl[[i]]),1),";n=",ns ,")")) ggplot2::labs(title=paste0(ttl," (fill=",round(ns/cap[[i]],1),";m=",round(mean(dl[[i]]),1),";n=",ns ,")"))
})) }))
} }

86
R/server.R
View file

@ -1,64 +1,62 @@
library(shiny)
server <- function(input, output, session) { 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("https://git.nikohuru.dk/au-phd/PhysicalActivityandStrokeOutcome/raw/branch/main/side%20projects/assignment.R")
source(here::here("R/group_assign.R")) source(here::here("R/group_assign.R"))
dat <- shiny::reactive({ dat <- reactive({
# input$file1 will be NULL initially. After the user selects # input$file1 will be NULL initially. After the user selects
# and uploads a file, head of that data file by default, # and uploads a file, head of that data file by default,
# or all rows if selected, will be shown. # or all rows if selected, will be shown.
req(input$file1) req(input$file1)
# Make laoding dependent of file name extension (file_ext()) # Make laoding dependent of file name extension (file_ext())
ext <- file_extension(input$file1$datapath) ext <- file_extension(input$file1$datapath)
if (ext == "csv") { tryCatch(
df <- read.csv(input$file1$datapath,na.strings = c("NA", '""',"")) {
} else if (ext %in% c("xls", "xlsx")) { if (ext == "csv") {
df <- openxlsx::read.xlsx(input$file1$datapath,na.strings = c("NA", '""',"")) df <- read.csv(input$file1$datapath,na.strings = c("NA", '""',""))
} else if (ext %in% c("xls", "xlsx")) {
} else { df <- openxlsx::read.xlsx(input$file1$datapath,na.strings = c("NA", '""',""))
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) return(df)
}) })
dat_pre <- shiny::reactive({ dat_pre <- reactive({
# req(input$file2) # req(input$file2)
# Make laoding dependent of file name extension (file_ext()) # Make laoding dependent of file name extension (file_ext())
if (!is.null(input$file2$datapath)){ if (!is.null(input$file2$datapath)){
ext <- file_extension(input$file2$datapath) ext <- file_extension(input$file2$datapath)
if (ext == "csv") { if (ext == "csv") {
df <- read.csv(input$file2$datapath,na.strings = c("NA", '""',"")) df <- read.csv(input$file2$datapath,na.strings = c("NA", '""',""))
} else if (ext %in% c("xls", "xlsx")) { } else if (ext %in% c("xls", "xlsx")) {
df <- openxlsx::read.xlsx(input$file2$datapath,na.strings = c("NA", '""',"")) df <- openxlsx::read.xlsx(input$file2$datapath,na.strings = c("NA", '""',""))
} else { } else {
stop("Input file format has to be either '.csv', '.xls' or '.xlsx'") stop("Input file format has to be either '.csv', '.xls' or '.xlsx'")
} }
return(df) return(df)
} else { } else {
return(NULL) return(NULL)
} }
}) })
assign <- assign <-
shiny::reactive({ reactive({
assigned <- group_assignment( assigned <- group_assignment(
ds = dat(), ds = dat(),
excess_space = input$ecxess, excess_space = input$ecxess,
@ -66,31 +64,31 @@ server <- function(input, output, session) {
) )
return(assigned) return(assigned)
}) })
output$raw.data.tbl <- shiny::renderTable({ output$raw.data.tbl <- renderTable({
assign()$export assign()$export
}) })
output$pre.assign <- shiny::renderTable({ output$pre.assign <- renderTable({
dat_pre() dat_pre()
}) })
output$input <- shiny::renderTable({ output$input <- renderTable({
dat() dat()
}) })
output$assign.plt <- shiny::renderPlot({ output$assign.plt <- renderPlot({
assignment_plot(assign()) assignment_plot(assign())
}) })
# Downloadable csv of selected dataset ---- # Downloadable csv of selected dataset ----
output$downloadData <- shiny::downloadHandler( output$downloadData <- downloadHandler(
filename = "group_assignment.csv", filename = "group_assignment.csv",
content = function(file) { content = function(file) {
write.csv(assign()$export, file, row.names = FALSE) write.csv(assign()$export, file, row.names = FALSE)
} }
) )
} }

129
R/ui.R
View file

@ -1,43 +1,44 @@
ui <- shiny::fluidPage( library(shiny)
ui <- fluidPage(
## ----------------------------------------------------------------------------- ## -----------------------------------------------------------------------------
## Application title ## Application title
## ----------------------------------------------------------------------------- ## -----------------------------------------------------------------------------
shiny::titlePanel("Assign groups based on costs/priorities.", titlePanel("Assign groups based on costs/priorities.",
windowTitle = "Group assignment calculator"), windowTitle = "Group assignment calculator"),
shiny::h5( h5(
"Please note this calculator is only meant as a proof of concept for educational purposes, "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. 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." Uploaded data is not kept, but please, do not upload any sensitive data."
), ),
## ----------------------------------------------------------------------------- ## -----------------------------------------------------------------------------
## Side panel ## Side panel
## ----------------------------------------------------------------------------- ## -----------------------------------------------------------------------------
## ----------------------------------------------------------------------------- ## -----------------------------------------------------------------------------
## Single entry ## Single entry
## ----------------------------------------------------------------------------- ## -----------------------------------------------------------------------------
shiny::sidebarLayout( sidebarLayout(
shiny::sidebarPanel( sidebarPanel(
shiny::numericInput( numericInput(
inputId = "ecxess", inputId = "ecxess",
label = "Excess space", label = "Excess space",
value = 1, value = 1,
step = .05 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, 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."), 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 ## File upload
## ----------------------------------------------------------------------------- ## -----------------------------------------------------------------------------
# Input: Select a file ---- # Input: Select a file ----
shiny::fileInput( fileInput(
inputId = "file1", inputId = "file1",
label = "Choose main data file", label = "Choose main data file",
multiple = FALSE, multiple = FALSE,
@ -45,14 +46,14 @@ ui <- shiny::fluidPage(
".csv",".xls",".xlsx" ".csv",".xls",".xlsx"
) )
), ),
shiny::strong("Columns: ID, group1, group2, ... groupN."), strong("Columns: ID, group1, group2, ... groupN."),
shiny::strong("NOTE: 0s will be interpreted as lowest score."), strong("NOTE: 0s will be interpreted as lowest score."),
shiny::p("Cells should contain cost/priorities. p("Cells should contain cost/priorities.
Lowest score, for highest priority. Lowest score, for highest priority.
Non-ranked should contain a number (eg lowest score+1). Non-ranked should contain a number (eg lowest score+1).
Will handle missings but try to avoid."), Will handle missings but try to avoid."),
shiny::fileInput( fileInput(
inputId = "file2", inputId = "file2",
label = "Choose data file for pre-assigned subjects", label = "Choose data file for pre-assigned subjects",
multiple = FALSE, multiple = FALSE,
@ -60,61 +61,61 @@ ui <- shiny::fluidPage(
".csv",".xls",".xlsx" ".csv",".xls",".xlsx"
) )
), ),
shiny::h6("Columns: ID, group"), h6("Columns: ID, group"),
## ----------------------------------------------------------------------------- ## -----------------------------------------------------------------------------
## Download output ## Download output
## ----------------------------------------------------------------------------- ## -----------------------------------------------------------------------------
# Horizontal line ---- # Horizontal line ----
tags$hr(), tags$hr(),
shiny::h4("Download results"), h4("Download results"),
# Button # Button
shiny::downloadButton("downloadData", "Download") downloadButton("downloadData", "Download")
), ),
shiny::mainPanel(shiny::tabsetPanel( mainPanel(tabsetPanel(
## ----------------------------------------------------------------------------- ## -----------------------------------------------------------------------------
## Plot tab ## Plot tab
## ----------------------------------------------------------------------------- ## -----------------------------------------------------------------------------
shiny::tabPanel(
"Summary",
shiny::h3("Assignment plot"),
shiny::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")
),
shiny::tabPanel(
"Results",
shiny::h3("Raw Results"),
shiny::p("This is identical to the downloaded file (see panel on left)"),
shiny::htmlOutput("raw.data.tbl", container = span)
),
shiny::tabPanel(
"Input data Results",
shiny::h3("Costs/prioritis overview"),
shiny::htmlOutput("input", container = span),
shiny::h3("Pre-assigned groups"),
shiny::p("Appears empty if none is uploaded."),
shiny::htmlOutput("pre.assign", container = span) tabPanel(
"Summary",
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."),
plotOutput("assign.plt")
),
tabPanel(
"Results",
h3("Raw Results"),
p("This is identical to the downloaded file (see panel on left)"),
htmlOutput("raw.data.tbl", container = span)
),
tabPanel(
"Input data Results",
h3("Costs/prioritis overview"),
htmlOutput("input", container = span),
h3("Pre-assigned groups"),
p("Appears empty if none is uploaded."),
htmlOutput("pre.assign", container = span)
) )
)) ))
) )
) )

8
README.md
View file

@ -5,4 +5,10 @@ Reviving an old project to use shinylive with R
## Shortcoming ## 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" "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": { "ROI.plugin.symphony": {
"Package": "ROI.plugin.symphony", "Package": "ROI.plugin.symphony",
"Version": "1.0-0", "Version": "1.0-0",
@ -110,6 +124,17 @@
], ],
"Hash": "3f55239fe534fe91e739c77d99a4ffbf" "Hash": "3f55239fe534fe91e739c77d99a4ffbf"
}, },
"alabama": {
"Package": "alabama",
"Version": "2023.1.0",
"Source": "Repository",
"Repository": "CRAN",
"Requirements": [
"R",
"numDeriv"
],
"Hash": "593db7eb170506e6b61ca0c803201924"
},
"archive": { "archive": {
"Package": "archive", "Package": "archive",
"Version": "1.1.7", "Version": "1.1.7",
@ -692,6 +717,16 @@
], ],
"Hash": "a623a2239e642806158bc4dc3f51565d" "Hash": "a623a2239e642806158bc4dc3f51565d"
}, },
"numDeriv": {
"Package": "numDeriv",
"Version": "2016.8-1.1",
"Source": "Repository",
"Repository": "RSPM",
"Requirements": [
"R"
],
"Hash": "df58958f293b166e4ab885ebcad90e02"
},
"ompr": { "ompr": {
"Package": "ompr", "Package": "ompr",
"Version": "1.0.4", "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")