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 <-
|
# Sample data set is generated with rownames and colnames
|
||||||
function(ds,
|
ds <- do.call(cbind,lapply(1:133,function(i){
|
||||||
cap_classes = NULL,
|
sample(c(1,2,3,4,5,rep(NA,12)),size=17)
|
||||||
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
|
|
||||||
|
|
||||||
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_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)
|
|
||||||
|
|
||||||
|
|
||||||
## 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)
|
|
||||||
|
|
||||||
y_max <- max(lengths(dl))
|
|
||||||
|
|
||||||
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,")"))
|
|
||||||
}))
|
}))
|
||||||
}
|
rownames(ds) <- letters[seq_len(nrow(ds))]
|
||||||
|
colnames(ds) <- paste0("sub",seq_len(ncol(ds)))
|
||||||
|
|
||||||
## Sample data set is generated with rownames and colnames
|
# df[as.character(as.matrix(ds))==0] <- 17
|
||||||
# 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
|
# Clearing NAs and applying the max cost instead
|
||||||
# ds[is.na(ds)] <- 17
|
# ds[is.na(ds)] <- 17
|
||||||
|
|
||||||
## I believe this would actually be the organic data set
|
# I believe this would actually be the organic data set
|
||||||
# df <- data.frame("ID"=colnames(ds),t(ds))
|
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)
|
|
||||||
|
|
||||||
|
|
||||||
## 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))
|
openxlsx::write.xlsx(df,"assign_sample.xlsx")
|
||||||
# assigned <- df |>
|
write.csv(df,"assign_sample.csv",na = "",row.names = FALSE)
|
||||||
# group_assignment(excess_space = 1.05,
|
|
||||||
# pre_assign = pre_grouped)
|
|
||||||
|
|
||||||
|
|
||||||
|
df[as.matrix(df)==0] <- 17
|
||||||
|
|
||||||
|
assigned <- df |>
|
||||||
|
group_assignment(cap_classes = rep(8, 17),excess_space = 1)
|
||||||
|
|
||||||
|
df |> group_assignment()
|
||||||
|
|
||||||
|
|
||||||
|
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]])
|
||||||
|
|
||||||
#
|
#
|
||||||
# lengths(assigned[[1]])
|
# 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)
|
||||||
|
|
||||||
|
# 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