originally just a small idea. Took way more time.
This commit is contained in:
parent
6fae593845
commit
d9e96209f2
134
apps/Assignment/assign_sample.csv
Normal file
134
apps/Assignment/assign_sample.csv
Normal file
@ -0,0 +1,134 @@
|
||||
"ID","a","b","c","d","e","f","g","h","i","j","k","l","m","n","o","p","q"
|
||||
"sub1",,,3,,,,,5,,,1,4,,,,2,
|
||||
"sub2",,,,3,,5,,,,,,1,,2,,,4
|
||||
"sub3",4,,,,2,,3,,,,,,,,,5,1
|
||||
"sub4",,,,,2,,5,4,,,,1,,3,,,
|
||||
"sub5",,,,5,,,2,,4,,1,,,,,3,
|
||||
"sub6",,4,,,,,,,2,,1,,5,3,,,
|
||||
"sub7",3,,,,,4,,,,,1,,,,2,5,
|
||||
"sub8",,,,,2,,4,,1,,3,,,,,5,
|
||||
"sub9",,3,,,,,,,1,5,,,4,,,,2
|
||||
"sub10",,,,4,,,,,,3,,,5,,2,1,
|
||||
"sub11",,5,,4,,,2,,1,,,,,3,,,
|
||||
"sub12",,,2,5,,,,,,,,,3,4,,,1
|
||||
"sub13",,,,5,,,,,,,,1,,3,2,,4
|
||||
"sub14",,3,4,,,5,,,,,,,,,2,,1
|
||||
"sub15",4,,,,5,,,2,1,,,,,,,,3
|
||||
"sub16",5,,,2,4,,,,,,1,,,,3,,
|
||||
"sub17",,4,,,3,1,5,,,,,,,2,,,
|
||||
"sub18",,,,,1,2,,,3,5,,,,,,4,
|
||||
"sub19",,,4,,,,3,,1,,2,,,,5,,
|
||||
"sub20",,,2,,,,1,,,3,4,5,,,,,
|
||||
"sub21",5,4,,,,2,,,,,1,,,,,,3
|
||||
"sub22",,,,,1,,3,2,,,5,,,,4,,
|
||||
"sub23",1,,,,4,,,,,,,,3,,2,,5
|
||||
"sub24",,,5,,,,,,,,,1,4,2,,3,
|
||||
"sub25",2,5,,,,3,,,,,,,,,,1,4
|
||||
"sub26",,2,,5,,,4,,,,,,,,3,,1
|
||||
"sub27",,,,,3,2,,,5,,,,,4,,1,
|
||||
"sub28",,,5,,,,,4,,,1,,,2,,3,
|
||||
"sub29",2,,,,,3,,,1,,5,4,,,,,
|
||||
"sub30",,,,,,,1,,,4,,3,,,2,,5
|
||||
"sub31",,,3,,,,,,,5,,1,,4,,,2
|
||||
"sub32",3,,,,,,,,2,5,,1,,,4,,
|
||||
"sub33",,2,,,4,,1,5,,,,,,3,,,
|
||||
"sub34",,,3,1,,,,4,,,5,,,,,,2
|
||||
"sub35",1,4,,,,,,2,,,,,,,3,5,
|
||||
"sub36",,5,,3,,4,1,2,,,,,,,,,
|
||||
"sub37",,,4,,3,,,,,,,1,2,5,,,
|
||||
"sub38",,,,4,,,,3,,,,2,,1,5,,
|
||||
"sub39",5,,,,1,4,,2,,,,,,3,,,
|
||||
"sub40",,,,,4,2,5,1,,,,,,,3,,
|
||||
"sub41",,1,,,,3,,5,,,,4,2,,,,
|
||||
"sub42",,,,,,3,,,,,,1,5,,2,,4
|
||||
"sub43",,,,,,,,,,,1,,3,,4,2,5
|
||||
"sub44",,4,,,,,,,,,2,,,5,3,,1
|
||||
"sub45",2,3,,,,,4,,1,,,,,,,,5
|
||||
"sub46",,3,,,4,,,,,5,1,,,,,,2
|
||||
"sub47",,2,1,,5,,,,,3,,4,,,,,
|
||||
"sub48",,2,,,1,3,,,,,5,4,,,,,
|
||||
"sub49",,,,1,,,,3,,,,2,,,,4,5
|
||||
"sub50",3,,,,,,,5,,1,,,4,,,2,
|
||||
"sub51",,,1,3,4,,,,2,,,,,,,5,
|
||||
"sub52",,,1,,,,,,,4,5,,,,2,3,
|
||||
"sub53",,,,2,5,,,,,1,,3,,,,4,
|
||||
"sub54",,,,3,,,,,4,,,1,,2,,5,
|
||||
"sub55",,,2,,,,4,,,,,,1,3,5,,
|
||||
"sub56",,,,,,,,,3,,1,5,4,2,,,
|
||||
"sub57",,,4,,2,,1,,,,,3,,,,,5
|
||||
"sub58",,3,,,,,,,,,,4,,,1,5,2
|
||||
"sub59",,,,4,,,1,,3,,5,2,,,,,
|
||||
"sub60",,,,,,,,2,,,,1,3,5,,4,
|
||||
"sub61",,,1,,,3,,2,4,,,,,5,,,
|
||||
"sub62",1,2,,,,,,5,,4,,,,,,3,
|
||||
"sub63",,2,,,3,,4,,,,,,,5,,,1
|
||||
"sub64",,,5,,,1,2,,,,3,,,,,,4
|
||||
"sub65",1,,3,2,,,,,,4,,,5,,,,
|
||||
"sub66",,,,,,,1,,,,,2,,4,5,,3
|
||||
"sub67",4,5,,,,,2,,1,,,,,3,,,
|
||||
"sub68",3,,,2,5,,4,,,1,,,,,,,
|
||||
"sub69",5,,1,,,,4,,,,,3,,,2,,
|
||||
"sub70",,2,,,,5,1,,,,3,,4,,,,
|
||||
"sub71",5,,,,4,2,,1,,,3,,,,,,
|
||||
"sub72",5,,,4,1,,,,,,3,,,,,2,
|
||||
"sub73",5,3,,,,,,,4,,,1,,,2,,
|
||||
"sub74",,5,,2,,3,,,4,,,,,,,,1
|
||||
"sub75",,,,,,,,,4,1,,5,2,,,,3
|
||||
"sub76",,1,,,,,2,5,4,,,3,,,,,
|
||||
"sub77",5,,,,,,3,,,,,,,1,2,,4
|
||||
"sub78",4,,,,,,1,3,,2,,,,,,5,
|
||||
"sub79",,,,3,,,,,,,4,1,5,,2,,
|
||||
"sub80",,2,,,5,4,,,,,,,,,1,3,
|
||||
"sub81",,,4,,,,2,,1,,,3,,,,,5
|
||||
"sub82",5,,,,,,,2,4,,,3,,,,,1
|
||||
"sub83",,2,,,,,4,5,1,,,,,,3,,
|
||||
"sub84",,,,3,1,,,,,,2,,4,,,5,
|
||||
"sub85",,,,1,4,,,5,,,,,,,2,,3
|
||||
"sub86",,,3,,,,,5,1,,,2,4,,,,
|
||||
"sub87",,,,,2,5,4,,,,,,1,,,3,
|
||||
"sub88",,,,,,,,,,,,2,3,1,,4,5
|
||||
"sub89",,,5,2,,,4,,,,,,,1,,3,
|
||||
"sub90",,5,,1,,,,,,4,,3,,2,,,
|
||||
"sub91",5,,,,,3,,,4,,2,,,1,,,
|
||||
"sub92",,,,,,4,,5,,,2,,,,1,3,
|
||||
"sub93",,,,,1,,,,,4,2,,5,,,3,
|
||||
"sub94",1,,,,,,2,,,,,,4,5,,,3
|
||||
"sub95",,,,,4,2,3,,,5,,1,,,,,
|
||||
"sub96",,5,,2,,,1,,,,,3,,4,,,
|
||||
"sub97",1,3,,,,,,4,2,,,,,,5,,
|
||||
"sub98",,,5,,3,,,,,,1,,,2,4,,
|
||||
"sub99",,,4,,,,,5,,,,,1,3,2,,
|
||||
"sub100",,2,,,,4,5,,,3,,,1,,,,
|
||||
"sub101",,3,,1,2,,,,,,4,,,,,,5
|
||||
"sub102",1,,,2,,5,,,,,,3,,,,4,
|
||||
"sub103",,3,,,,,5,,1,,,,,2,,,4
|
||||
"sub104",,5,,4,,1,2,3,,,,,,,,,
|
||||
"sub105",,,,2,5,,,3,4,,1,,,,,,
|
||||
"sub106",,,,4,5,3,2,,,,,1,,,,,
|
||||
"sub107",2,1,3,,,,,,5,,4,,,,,,
|
||||
"sub108",,,4,,,,,,,1,,,5,,2,,3
|
||||
"sub109",,4,,,,,,2,1,,,5,,3,,,
|
||||
"sub110",,,,,3,,,,1,,,,,4,5,,2
|
||||
"sub111",,,,,,3,,,4,1,,,,,,2,5
|
||||
"sub112",,1,,,,,,,2,5,,,3,,,4,
|
||||
"sub113",,,3,,,,,,,,1,5,,4,2,,
|
||||
"sub114",,,,,1,3,,,,,5,,4,,2,,
|
||||
"sub115",,1,,,4,2,,,,,3,5,,,,,
|
||||
"sub116",,2,4,,,3,,5,1,,,,,,,,
|
||||
"sub117",,,,,,2,,,,4,,1,,5,,3,
|
||||
"sub118",,4,5,,,1,,,3,,,,,2,,,
|
||||
"sub119",5,,,3,,,1,,,4,,,2,,,,
|
||||
"sub120",1,2,4,,,,,,,,,,5,,,,3
|
||||
"sub121",,2,,,,5,,,,,,1,3,,,,4
|
||||
"sub122",3,,1,5,,,,,,,,4,,2,,,
|
||||
"sub123",,1,3,,,,4,5,,,,,,,,2,
|
||||
"sub124",,,2,,,4,,,,3,,,,,5,,1
|
||||
"sub125",,,,2,,,,,,,4,1,,5,,,3
|
||||
"sub126",,,,2,5,,3,,4,,,,,,,1,
|
||||
"sub127",4,,,,,1,2,,,,,,5,3,,,
|
||||
"sub128",,,,,1,4,,,,,,3,,,,2,5
|
||||
"sub129",,,,3,1,2,,4,,,,5,,,,,
|
||||
"sub130",4,,,,1,,,5,,3,2,,,,,,
|
||||
"sub131",,,,,1,3,,,,5,2,,,,,,4
|
||||
"sub132",,,,,2,,5,,,,3,,1,,,,4
|
||||
"sub133",,4,,,,,,3,,,,,,1,,2,5
|
||||
|
BIN
apps/Assignment/assign_sample.xlsx
Normal file
BIN
apps/Assignment/assign_sample.xlsx
Normal file
Binary file not shown.
188
apps/Assignment/group_assign.R
Normal file
188
apps/Assignment/group_assign.R
Normal file
@ -0,0 +1,188 @@
|
||||
group_assignment <-
|
||||
function(ds,
|
||||
cap_classes = NULL,
|
||||
excess_space = NULL,
|
||||
pre_assign = NULL) {
|
||||
require(dplyr)
|
||||
require(tidyr)
|
||||
require(ROI)
|
||||
require(ROI.plugin.symphony)
|
||||
require(ompr)
|
||||
require(ompr.roi)
|
||||
|
||||
if (!is.data.frame(ds)){
|
||||
stop("Supplied data has to be a data frame, with each row
|
||||
are subjects and columns are groups, with the first column being
|
||||
subject identifiers")}
|
||||
|
||||
## This program very much trust the user to supply correctly formatted data
|
||||
cost <- t(ds[,-1]) #Transpose converts to matrix
|
||||
colnames(cost) <- ds[,1]
|
||||
|
||||
num_groups <- dim(cost)[1]
|
||||
num_sub <- dim(cost)[2]
|
||||
|
||||
## 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
|
||||
}
|
||||
|
||||
# generous round up of capacities
|
||||
if (is.null(cap_classes)) {
|
||||
capacity <- rep(ceiling(excess*num_sub/num_groups), num_groups)
|
||||
# } else if (!is.numeric(cap_classes)) {
|
||||
# stop("cap_classes has to be numeric")
|
||||
} else if (length(cap_classes)==1){
|
||||
capacity <- ceiling(rep(cap_classes,num_groups)*excess)
|
||||
} else if (length(cap_classes)==num_groups){
|
||||
capacity <- ceiling(cap_classes*excess)
|
||||
} else {
|
||||
stop("cap_classes has to be either length 1 or same as number of groups")
|
||||
}
|
||||
|
||||
## This test should be a little more elegant
|
||||
## pre_assign should be a data.frame or matrix with an ID and assignment column
|
||||
with_pre_assign <- FALSE
|
||||
if (!is.null(pre_assign)){
|
||||
# Setting flag for later and export list
|
||||
with_pre_assign <- TRUE
|
||||
# Splitting to list for later merging
|
||||
pre <- split(pre_assign[,1],factor(pre_assign[,2],levels = seq_len(num_groups)))
|
||||
# Subtracting capacity numbers, to reflect already filled spots
|
||||
capacity <- capacity-lengths(pre)
|
||||
# Making sure pre_assigned are removed from main data set
|
||||
ds <- ds[!ds[[1]] %in% pre_assign[[1]],]
|
||||
|
||||
cost <- t(ds[,-1])
|
||||
colnames(cost) <- ds[,1]
|
||||
|
||||
num_groups <- dim(cost)[1]
|
||||
num_sub <- dim(cost)[2]
|
||||
}
|
||||
|
||||
## Simple NA handling. Better to handle NAs yourself!
|
||||
cost[is.na(cost)] <- num_groups
|
||||
|
||||
i_m <- seq_len(num_groups)
|
||||
j_m <- seq_len(num_sub)
|
||||
|
||||
m <- MIPModel() %>%
|
||||
add_variable(grp[i, j],
|
||||
i = i_m,
|
||||
j = j_m,
|
||||
type = "binary") %>%
|
||||
## The first constraint says that group size should not exceed capacity
|
||||
add_constraint(sum_expr(grp[i, j], j = j_m) <= capacity[i],
|
||||
i = i_m) %>%
|
||||
## The second constraint says each subject can only be in one group
|
||||
add_constraint(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
|
||||
set_objective(sum_expr(
|
||||
cost[i, j] * grp[i, j],
|
||||
i = i_m,
|
||||
j = j_m
|
||||
),
|
||||
"min") %>%
|
||||
solve_model(with_ROI(solver = "symphony", verbosity = 1))
|
||||
|
||||
## Getting assignments
|
||||
solution <- get_solution(m, grp[i, j]) %>% filter(value > 0)
|
||||
|
||||
assign <- solution |> select(i,j)
|
||||
|
||||
if (!is.null(rownames(cost))){
|
||||
assign$i <- rownames(cost)[assign$i]
|
||||
}
|
||||
|
||||
if (!is.null(colnames(cost))){
|
||||
assign$j <- colnames(cost)[assign$j]
|
||||
}
|
||||
|
||||
## Splitting into groups based on assignment
|
||||
assign_ls <- split(assign$j,assign$i)
|
||||
|
||||
|
||||
## Extracting subject cost for the final assignment for evaluation
|
||||
if (is.null(rownames(cost))){
|
||||
rownames(cost) <- seq_len(nrow(cost))
|
||||
}
|
||||
|
||||
if (is.null(colnames(cost))){
|
||||
colnames(cost) <- seq_len(ncol(cost))
|
||||
}
|
||||
|
||||
eval <- lapply(seq_len(length(assign_ls)),function(i){
|
||||
ndx <- match(names(assign_ls)[i],rownames(cost))
|
||||
cost[ndx,assign_ls[[i]]]
|
||||
})
|
||||
names(eval) <- names(assign_ls)
|
||||
|
||||
if (with_pre_assign){
|
||||
names(pre) <- names(assign_ls)
|
||||
assign_all <- mapply(c, assign_ls, pre, SIMPLIFY=FALSE)
|
||||
|
||||
out <- list(all_assigned=assign_all)
|
||||
} else {
|
||||
out <- list(all_assigned=assign_ls)
|
||||
}
|
||||
|
||||
export <- do.call(rbind,lapply(seq_along(out[[1]]),function(i){
|
||||
cbind("ID"=out[[1]][[i]],"Group"=names(out[[1]])[i])
|
||||
}))
|
||||
|
||||
out <- append(out,
|
||||
list(evaluation=eval,
|
||||
assigned=assign_ls,
|
||||
solution = solution,
|
||||
capacity = capacity,
|
||||
excess = excess,
|
||||
pre_assign = with_pre_assign,
|
||||
cost_scale = levels(factor(cost)),
|
||||
input=ds,
|
||||
export=export))
|
||||
# exists("excess")
|
||||
return(out)
|
||||
}
|
||||
|
||||
|
||||
## Assessment performance overview
|
||||
## The function plots costs of assignment for each subject in every group
|
||||
assignment_plot <- function(lst){
|
||||
|
||||
dl <- lst[[2]]
|
||||
cost_scale <- unique(lst[[8]])
|
||||
cap <- lst[[5]]
|
||||
cnts_ls <- lapply(dl,function(i){
|
||||
factor(i,levels=cost_scale)
|
||||
})
|
||||
require(ggplot2)
|
||||
require(patchwork)
|
||||
require(viridisLite)
|
||||
|
||||
y_max <- max(lengths(dl))
|
||||
|
||||
wrap_plots(lapply(seq_along(dl),function(i){
|
||||
ttl <- names(dl)[i]
|
||||
ns <- length(dl[[i]])
|
||||
cnts <- cnts_ls[[i]]
|
||||
ggplot() + geom_bar(aes(cnts,fill=cnts)) +
|
||||
scale_x_discrete(name = NULL, breaks=cost_scale, drop=FALSE) +
|
||||
scale_y_continuous(name = NULL, limits = c(0,y_max)) +
|
||||
scale_fill_manual(values = viridisLite::viridis(length(cost_scale), direction = -1)) +
|
||||
guides(fill=FALSE) + labs(title=paste0(ttl," (fill=",round(ns/cap[[i]],1),";m=",round(mean(dl[[i]]),1) ,")"))
|
||||
}))
|
||||
}
|
||||
|
||||
|
||||
## Helper function for Shiny
|
||||
file_extension <- function(filenames) {
|
||||
sub(pattern = "^(.*\\.|[^.]+)(?=[^.]*)", replacement = "", filenames, perl = TRUE)
|
||||
}
|
||||
|
||||
|
||||
|
||||
11
apps/Assignment/pre_grouped.csv
Normal file
11
apps/Assignment/pre_grouped.csv
Normal file
@ -0,0 +1,11 @@
|
||||
"ID","group"
|
||||
"sub36",16
|
||||
"sub105",10
|
||||
"sub112",3
|
||||
"sub61",15
|
||||
"sub27",8
|
||||
"sub78",7
|
||||
"sub110",1
|
||||
"sub129",2
|
||||
"sub109",12
|
||||
"sub46",14
|
||||
|
96
apps/Assignment/server.R
Normal file
96
apps/Assignment/server.R
Normal file
@ -0,0 +1,96 @@
|
||||
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("group_assign.R")
|
||||
|
||||
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.
|
||||
|
||||
req(input$file1)
|
||||
# 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", '""',""))
|
||||
|
||||
} else {
|
||||
stop("Input file format has to be either '.csv', '.xls' or '.xlsx'")
|
||||
}
|
||||
|
||||
return(df)
|
||||
})
|
||||
|
||||
dat_pre <- reactive({
|
||||
|
||||
# req(input$file2)
|
||||
# Make laoding dependent of file name extension (file_ext())
|
||||
if (!is.null(input$file2$datapath)){
|
||||
ext <- file_extension(input$file2$datapath)
|
||||
|
||||
if (ext == "csv") {
|
||||
df <- read.csv(input$file2$datapath,na.strings = c("NA", '""',""))
|
||||
} else if (ext %in% c("xls", "xlsx")) {
|
||||
df <- openxlsx::read.xlsx(input$file2$datapath,na.strings = c("NA", '""',""))
|
||||
|
||||
} else {
|
||||
stop("Input file format has to be either '.csv', '.xls' or '.xlsx'")
|
||||
}
|
||||
|
||||
return(df)
|
||||
} else {
|
||||
return(NULL)
|
||||
}
|
||||
|
||||
})
|
||||
|
||||
assign <-
|
||||
reactive({
|
||||
assigned <- group_assignment(
|
||||
ds = dat(),
|
||||
excess_space = input$ecxess,
|
||||
pre_assign = dat_pre()
|
||||
)
|
||||
return(assigned)
|
||||
})
|
||||
|
||||
|
||||
output$raw.data.tbl <- renderTable({
|
||||
assign()$export
|
||||
})
|
||||
|
||||
output$pre.assign <- renderTable({
|
||||
dat_pre()
|
||||
})
|
||||
|
||||
output$input <- renderTable({
|
||||
dat()
|
||||
})
|
||||
|
||||
output$assign.plt <- renderPlot({
|
||||
assignment_plot(assign())
|
||||
})
|
||||
|
||||
# Downloadable csv of selected dataset ----
|
||||
output$downloadData <- downloadHandler(
|
||||
filename = "group_assignment.csv",
|
||||
|
||||
content = function(file) {
|
||||
write.csv(assign()$export, file, row.names = FALSE)
|
||||
}
|
||||
)
|
||||
|
||||
}
|
||||
120
apps/Assignment/ui.R
Normal file
120
apps/Assignment/ui.R
Normal file
@ -0,0 +1,120 @@
|
||||
library(shiny)
|
||||
library(ggplot2)
|
||||
|
||||
ui <- fluidPage(
|
||||
## -----------------------------------------------------------------------------
|
||||
## Application title
|
||||
## -----------------------------------------------------------------------------
|
||||
|
||||
titlePanel("Assign groups based on costs/priorities.",
|
||||
windowTitle = "Group assignment calculator"),
|
||||
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."
|
||||
),
|
||||
|
||||
## -----------------------------------------------------------------------------
|
||||
## Side panel
|
||||
## -----------------------------------------------------------------------------
|
||||
|
||||
|
||||
## -----------------------------------------------------------------------------
|
||||
## Single entry
|
||||
## -----------------------------------------------------------------------------
|
||||
sidebarLayout(
|
||||
sidebarPanel(
|
||||
numericInput(
|
||||
inputId = "ecxess",
|
||||
label = "Excess space",
|
||||
value = 1,
|
||||
step = .05
|
||||
),
|
||||
|
||||
## -----------------------------------------------------------------------------
|
||||
## File upload
|
||||
## -----------------------------------------------------------------------------
|
||||
|
||||
# Input: Select a file ----
|
||||
|
||||
fileInput(
|
||||
inputId = "file1",
|
||||
label = "Choose main data file",
|
||||
multiple = FALSE,
|
||||
accept = c(
|
||||
".csv",".xls",".xlsx"
|
||||
)
|
||||
),
|
||||
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."),
|
||||
|
||||
fileInput(
|
||||
inputId = "file2",
|
||||
label = "Choose data file for pre-assigned subjects",
|
||||
multiple = FALSE,
|
||||
accept = c(
|
||||
".csv",".xls",".xlsx"
|
||||
)
|
||||
),
|
||||
h6("Columns: ID, group"),
|
||||
|
||||
|
||||
|
||||
## -----------------------------------------------------------------------------
|
||||
## Download output
|
||||
## -----------------------------------------------------------------------------
|
||||
|
||||
# Horizontal line ----
|
||||
tags$hr(),
|
||||
|
||||
h4("Download results"),
|
||||
|
||||
# Button
|
||||
downloadButton("downloadData", "Download")
|
||||
),
|
||||
|
||||
mainPanel(tabsetPanel(
|
||||
## -----------------------------------------------------------------------------
|
||||
## Plot tab
|
||||
## -----------------------------------------------------------------------------
|
||||
|
||||
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)
|
||||
|
||||
)
|
||||
|
||||
))
|
||||
)
|
||||
)
|
||||
39
apps/Group assignment app.R
Normal file
39
apps/Group assignment app.R
Normal file
@ -0,0 +1,39 @@
|
||||
## -----------------------------------------------------------------------------
|
||||
## Group assignment app
|
||||
## -----------------------------------------------------------------------------
|
||||
##
|
||||
## Special cases to consider
|
||||
## - duplicate scores
|
||||
## - missing scores
|
||||
## - Pre-assignment of special cases - SOLVED
|
||||
## - Make sure to remove assigned subjects from all subjects when pre-assigning
|
||||
## - Set class to output list and have plot function only accept correct class (not necessary for Shiny)
|
||||
## - Use knitr::kable() to show sample data, alternatively use gt()
|
||||
## - Handle [NA, 0, ""]
|
||||
##
|
||||
## I believe we are ready for a shiny app!
|
||||
|
||||
|
||||
## -- START WITH THIS -- ##
|
||||
old_wd<-getwd()
|
||||
|
||||
setwd(paste0(old_wd,"/apps/Assignment"))
|
||||
|
||||
shiny::runApp(appDir = "/Users/au301842/PAaSO/apps/Assignment",launch.browser = TRUE)
|
||||
|
||||
## App deployment
|
||||
|
||||
require(rsconnect)
|
||||
|
||||
keys<-suppressWarnings(read.csv("/Users/au301842/shinyapp_token.csv",colClasses = "character"))
|
||||
|
||||
rsconnect::setAccountInfo(name='cognitiveindex',
|
||||
token=keys$key[1], secret=keys$key[2])
|
||||
|
||||
deployApp()
|
||||
|
||||
source(paste0(old_wd,"/apps/app_deploy.R"))
|
||||
|
||||
setwd(old_wd)
|
||||
|
||||
## Raw sketch, doesn't load correctly...
|
||||
@ -1,172 +1,73 @@
|
||||
group_assignment <-
|
||||
function(ds,
|
||||
cap_classes = NULL,
|
||||
excess_space = NULL,
|
||||
pre_assign = NULL) {
|
||||
require(dplyr)
|
||||
require(tidyr)
|
||||
require(ROI)
|
||||
require(ROI.plugin.symphony)
|
||||
require(ompr)
|
||||
require(ompr.roi)
|
||||
# Sample data set is generated with rownames and colnames
|
||||
ds <- do.call(cbind,lapply(1:133,function(i){
|
||||
sample(c(1,2,3,4,5,rep(NA,12)),size=17)
|
||||
}))
|
||||
rownames(ds) <- letters[seq_len(nrow(ds))]
|
||||
colnames(ds) <- paste0("sub",seq_len(ncol(ds)))
|
||||
|
||||
if (!is.data.frame(ds)){
|
||||
stop("Supplied data has to be a data frame, with each row
|
||||
are subjects and columns are groups, with the first column being
|
||||
subject identifiers")}
|
||||
# df[as.character(as.matrix(ds))==0] <- 17
|
||||
|
||||
## This program very much trust the user to supply correctly formatted data
|
||||
cost <- t(ds[-1]) #Transpose converts to matrix
|
||||
# Clearing NAs and applying the max cost instead
|
||||
# ds[is.na(ds)] <- 17
|
||||
|
||||
num_groups <- dim(cost)[1]
|
||||
num_sub <- dim(cost)[2]
|
||||
|
||||
## 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(cap_classes)) {
|
||||
if (is.null(excess_space)) {
|
||||
excess <- 1.2
|
||||
} else {
|
||||
excess <- excess_space
|
||||
}
|
||||
capacity <- rep(ceiling(excess*num_sub/num_groups), num_groups)
|
||||
} else {
|
||||
capacity <- cap_classes
|
||||
}
|
||||
|
||||
## This test should be a little more elegant
|
||||
## pre_assign should be a data.frame or matrix with an ID and assignment column
|
||||
with_pre_assign <- FALSE
|
||||
if (!is.null(pre_assign)){
|
||||
with_pre_assign <- TRUE
|
||||
pre <- split(pre_assign[,1],factor(pre_assign[,2],levels = seq_len(num_groups)))
|
||||
capacity <- capacity-lengths(pre)
|
||||
}
|
||||
# I believe this would actually be the organic data set
|
||||
df <- data.frame("ID"=colnames(ds),t(ds))
|
||||
|
||||
|
||||
i_m <- seq_len(num_groups)
|
||||
j_m <- seq_len(num_sub)
|
||||
|
||||
m <- MIPModel() %>%
|
||||
add_variable(grp[i, j],
|
||||
i = i_m,
|
||||
j = j_m,
|
||||
type = "binary") %>%
|
||||
## The first constraint says that group size should not exceed capacity
|
||||
add_constraint(sum_expr(grp[i, j], j = j_m) <= capacity[i],
|
||||
i = i_m) %>%
|
||||
## The second constraint says each subject can only be in one group
|
||||
add_constraint(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
|
||||
set_objective(sum_expr(
|
||||
cost[i, j] * grp[i, j],
|
||||
i = i_m,
|
||||
j = j_m
|
||||
),
|
||||
"min") %>%
|
||||
solve_model(with_ROI(solver = "symphony", verbosity = 1))
|
||||
|
||||
## Getting assignments
|
||||
assign <- get_solution(m, grp[i, j]) %>%
|
||||
filter(value > 0) |> select(i,j)
|
||||
|
||||
if (!is.null(rownames(cost))){
|
||||
assign$i <- rownames(cost)[assign$i]
|
||||
}
|
||||
|
||||
if (!is.null(colnames(cost))){
|
||||
assign$j <- colnames(cost)[assign$j]
|
||||
}
|
||||
|
||||
## Splitting into groups based on assignment
|
||||
assign_ls <- split(assign$j,assign$i)
|
||||
openxlsx::write.xlsx(df,"assign_sample.xlsx")
|
||||
write.csv(df,"assign_sample.csv",na = "",row.names = FALSE)
|
||||
|
||||
|
||||
## Extracting subject cost for the final assignment for evaluation
|
||||
if (is.null(rownames(cost))){
|
||||
rownames(cost) <- seq_len(nrow(cost))
|
||||
}
|
||||
|
||||
if (is.null(colnames(cost))){
|
||||
colnames(cost) <- seq_len(ncol(cost))
|
||||
}
|
||||
|
||||
eval <- lapply(seq_len(length(assign_ls)),function(i){
|
||||
ndx <- match(names(assign_ls)[i],rownames(cost))
|
||||
cost[ndx,assign_ls[[i]]]
|
||||
})
|
||||
names(eval) <- names(assign_ls)
|
||||
|
||||
if (with_pre_assign){
|
||||
names(pre) <- names(assign_ls)
|
||||
assign_all <- mapply(c, assign_ls, pre, SIMPLIFY=FALSE)
|
||||
|
||||
return(list("Group assignment"=assign_all,
|
||||
"Cost evaluation"=eval,
|
||||
"Group assigned"=assign_ls))
|
||||
} else {
|
||||
return(list("Group assignment"=assign_ls,
|
||||
"Cost evaluation"=eval))
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
## Assessment performance overview
|
||||
## The function plots costs of assignment for each subject in every group
|
||||
assignment_plot <- function(dl,cost_scale){
|
||||
require(ggplot2)
|
||||
require(patchwork)
|
||||
df[as.matrix(df)==0] <- 17
|
||||
|
||||
y_max <- max(lengths(dl))
|
||||
assigned <- df |>
|
||||
group_assignment(cap_classes = rep(8, 17),excess_space = 1)
|
||||
|
||||
wrap_plots(lapply(seq_along(dl),function(i){
|
||||
ttl <- names(dl)[i]
|
||||
ns <- length(dl[[i]])
|
||||
cnts <- factor(dl[[i]],levels=cost_scale)
|
||||
ggplot() + geom_bar(aes(cnts,fill=cnts)) +
|
||||
scale_x_discrete(name = NULL, breaks=cost_scale, drop=FALSE) +
|
||||
scale_y_continuous(name = NULL, limits = c(0,y_max)) +
|
||||
# coord_cartesian(ylim=c(0,1)) +
|
||||
guides(fill=FALSE) + labs(title=paste0(ttl," (n=",ns,")"))
|
||||
}))
|
||||
}
|
||||
df |> group_assignment()
|
||||
|
||||
## Sample data set is generated with rownames and colnames
|
||||
# ds <- do.call(cbind,lapply(1:133,function(i){
|
||||
# sample(c(1,2,2,3,4,rep(0,12)),size=17)
|
||||
# }))
|
||||
# rownames(ds) <- letters[seq_len(nrow(ds))]
|
||||
# colnames(ds) <- paste0("sub",seq_len(ncol(ds)))
|
||||
|
||||
## Clearing NAs and applying the max cost instead
|
||||
# ds[is.na(ds)] <- 17
|
||||
assigned$`Group assignment`
|
||||
|
||||
assigned$`Cost evaluation` |> assignment_plot(1:5)
|
||||
|
||||
|
||||
|
||||
|
||||
pre_grouped <- data.frame("ID"=sample(df$ID,10),"group"=sample(1:17,10))
|
||||
ds <- df
|
||||
|
||||
assigned <- df |>
|
||||
group_assignment(excess_space = 1.05,
|
||||
pre_assign = pre_grouped)
|
||||
|
||||
lengths(assigned[[1]])
|
||||
|
||||
## I believe this would actually be the organic data set
|
||||
# df <- data.frame("ID"=colnames(ds),t(ds))
|
||||
#
|
||||
# df[as.matrix(df)==0] <- 17
|
||||
#
|
||||
# assigned <- df |>
|
||||
# group_assignment(cap_classes = rep(8, 17),excess_space = 1)
|
||||
#
|
||||
#
|
||||
# assigned$`Group assignment`
|
||||
#
|
||||
# assigned$`Cost evaluation` |> assignment_plot(1:5)
|
||||
# ds <- read.csv("assign_sample.csv")
|
||||
#
|
||||
# ls <- read.csv("assign_sample.csv") |> group_assignment(cap_classes = 8, excess_space = 1)
|
||||
#
|
||||
# ls |> assignment_plot()
|
||||
#
|
||||
# lst <- ls
|
||||
#
|
||||
# "[["(ls,4) |> head(10)
|
||||
|
||||
# View(ls$export)
|
||||
#
|
||||
# pre_grouped <- data.frame("ID"=sample(ds$ID,10),"group"=sample(1:17,10))
|
||||
# write.csv(pre_grouped,"pre_grouped.csv",row.names = FALSE)
|
||||
#
|
||||
# assigned <- ds |>
|
||||
# group_assignment(excess_space = 1.05,
|
||||
# pre_assign = pre_grouped)
|
||||
|
||||
## Special cases to consider
|
||||
## - duplicate scores
|
||||
## - missing scores
|
||||
## - Pre-assignment of special cases - SOLVED
|
||||
##
|
||||
## I believe we are ready for a shiny app!
|
||||
|
||||
# pre_grouped <- data.frame("ID"=sample(df$ID,10),"group"=sample(1:17,10))
|
||||
# assigned <- df |>
|
||||
# group_assignment(excess_space = 1.05,
|
||||
# pre_assign = pre_grouped)
|
||||
#
|
||||
# lengths(assigned[[1]])
|
||||
# ls <-
|
||||
# read.csv("assign_sample.csv") |> group_assignment(
|
||||
# cap_classes = 8,
|
||||
# excess_space = 1,
|
||||
# pre_assign = read.csv("pre_grouped.csv")
|
||||
# )
|
||||
Loading…
Reference in New Issue
Block a user