mirror of
https://github.com/agdamsbo/prioritized.grouping.git
synced 2025-09-12 02:29:40 +02:00
1 line
13 KiB
JSON
1 line
13 KiB
JSON
[{"name":"server.R","content":"server <- function(input, output, session) {\n library(dplyr)\n library(tidyr)\n library(ROI)\n library(ROI.plugin.symphony)\n library(ompr)\n library(ompr.roi)\n library(magrittr)\n library(ggplot2)\n library(viridisLite)\n library(patchwork)\n library(openxlsx)\n # source(\"https://git.nikohuru.dk/au-phd/PhysicalActivityandStrokeOutcome/raw/branch/main/side%20projects/assignment.R\")\n source(here::here(\"R/group_assign.R\"))\n \n dat <- shiny::reactive({\n # input$file1 will be NULL initially. After the user selects\n # and uploads a file, head of that data file by default,\n # or all rows if selected, will be shown.\n \n req(input$file1)\n # Make laoding dependent of file name extension (file_ext())\n ext <- file_extension(input$file1$datapath)\n \n if (ext == \"csv\") {\n df <- read.csv(input$file1$datapath,na.strings = c(\"NA\", '\"\"',\"\"))\n } else if (ext %in% c(\"xls\", \"xlsx\")) {\n df <- openxlsx::read.xlsx(input$file1$datapath,na.strings = c(\"NA\", '\"\"',\"\"))\n \n } else {\n stop(\"Input file format has to be either '.csv', '.xls' or '.xlsx'\")\n }\n \n return(df)\n })\n \n dat_pre <- shiny::reactive({\n \n # req(input$file2)\n # Make laoding dependent of file name extension (file_ext())\n if (!is.null(input$file2$datapath)){\n ext <- file_extension(input$file2$datapath)\n \n if (ext == \"csv\") {\n df <- read.csv(input$file2$datapath,na.strings = c(\"NA\", '\"\"',\"\"))\n } else if (ext %in% c(\"xls\", \"xlsx\")) {\n df <- openxlsx::read.xlsx(input$file2$datapath,na.strings = c(\"NA\", '\"\"',\"\"))\n \n } else {\n stop(\"Input file format has to be either '.csv', '.xls' or '.xlsx'\")\n }\n \n return(df)\n } else {\n return(NULL)\n }\n\n })\n \n assign <-\n shiny::reactive({\n assigned <- group_assignment(\n ds = dat(),\n excess_space = input$ecxess,\n pre_assign = dat_pre()\n )\n return(assigned)\n })\n \n \n output$raw.data.tbl <- shiny::renderTable({\n assign()$export\n })\n \n output$pre.assign <- shiny::renderTable({\n dat_pre()\n })\n \n output$input <- shiny::renderTable({\n dat()\n })\n \n output$assign.plt <- shiny::renderPlot({\n assignment_plot(assign())\n })\n \n # Downloadable csv of selected dataset ----\n output$downloadData <- shiny::downloadHandler(\n filename = \"group_assignment.csv\",\n\n content = function(file) {\n write.csv(assign()$export, file, row.names = FALSE)\n }\n )\n \n}\n","type":"text"},{"name":"ui.R","content":"ui <- shiny::fluidPage(\n ## -----------------------------------------------------------------------------\n ## Application title\n ## -----------------------------------------------------------------------------\n \n shiny::titlePanel(\"Assign groups based on costs/priorities.\",\n windowTitle = \"Group assignment calculator\"),\n shiny::h5(\n \"Please note this calculator is only meant as a proof of concept for educational purposes,\n and the author will take no responsibility for the results of the calculator.\n Uploaded data is not kept, but please, do not upload any sensitive data.\"\n ),\n \n ## -----------------------------------------------------------------------------\n ## Side panel\n ## -----------------------------------------------------------------------------\n \n \n ## -----------------------------------------------------------------------------\n ## Single entry\n ## -----------------------------------------------------------------------------\n shiny::sidebarLayout(\n shiny::sidebarPanel(\n shiny::numericInput(\n inputId = \"ecxess\",\n label = \"Excess space\",\n value = 1,\n step = .05\n ),\n shiny::p(\"As default, the program will try to evenly distribute subjects in groups. \n This factor will add more capacity to each group, for an overall lesser cost, \n but more uneven group numbers. More adjustments can be performed with the source script.\"),\n shiny::a(href='https://git.nikohuru.dk/au-phd/PhysicalActivityandStrokeOutcome/src/branch/main/apps/Assignment', \"Source\", target=\"_blank\"),\n ## -----------------------------------------------------------------------------\n ## File upload\n ## -----------------------------------------------------------------------------\n \n # Input: Select a file ----\n \n shiny::fileInput(\n inputId = \"file1\",\n label = \"Choose main data file\",\n multiple = FALSE,\n accept = c(\n \".csv\",\".xls\",\".xlsx\"\n )\n ),\n shiny::strong(\"Columns: ID, group1, group2, ... groupN.\"),\n shiny::strong(\"NOTE: 0s will be interpreted as lowest score.\"),\n shiny::p(\"Cells should contain cost/priorities.\n Lowest score, for highest priority.\n Non-ranked should contain a number (eg lowest score+1).\n Will handle missings but try to avoid.\"),\n \n shiny::fileInput(\n inputId = \"file2\",\n label = \"Choose data file for pre-assigned subjects\",\n multiple = FALSE,\n accept = c(\n \".csv\",\".xls\",\".xlsx\"\n )\n ),\n shiny::h6(\"Columns: ID, group\"),\n \n \n \n ## -----------------------------------------------------------------------------\n ## Download output\n ## -----------------------------------------------------------------------------\n \n # Horizontal line ----\n tags$hr(),\n \n shiny::h4(\"Download results\"),\n \n # Button\n shiny::downloadButton(\"downloadData\", \"Download\")\n ),\n \n shiny::mainPanel(shiny::tabsetPanel(\n ## -----------------------------------------------------------------------------\n ## Plot tab\n ## -----------------------------------------------------------------------------\n \n shiny::tabPanel(\n \"Summary\",\n shiny::h3(\"Assignment plot\"),\n shiny::p(\"These plots are to summarise simple performance meassures for the assignment. \n 'f' is group fill fraction and 'm' is mean cost in group.\"),\n \n shiny::plotOutput(\"assign.plt\")\n \n ),\n \n shiny::tabPanel(\n \"Results\",\n shiny::h3(\"Raw Results\"),\n shiny::p(\"This is identical to the downloaded file (see panel on left)\"),\n \n shiny::htmlOutput(\"raw.data.tbl\", container = span)\n \n ),\n \n shiny::tabPanel(\n \"Input data Results\",\n shiny::h3(\"Costs/prioritis overview\"),\n \n \n shiny::htmlOutput(\"input\", container = span),\n \n shiny::h3(\"Pre-assigned groups\"),\n shiny::p(\"Appears empty if none is uploaded.\"),\n\n shiny::htmlOutput(\"pre.assign\", container = span)\n \n )\n \n ))\n )\n)\n","type":"text"},{"name":"group_assign.R","content":"group_assignment <-\n function(ds,\n cap_classes = NULL,\n excess_space = NULL,\n pre_assign = NULL) {\n require(ROI)\n require(ROI.plugin.symphony)\n \n if (!is.data.frame(ds)){\n stop(\"Supplied data has to be a data frame, with each row\n are subjects and columns are groups, with the first column being\n subject identifiers\")}\n \n ## This program very much trust the user to supply correctly formatted data\n cost <- t(ds[,-1]) #Transpose converts to matrix\n colnames(cost) <- ds[,1]\n \n num_groups <- dim(cost)[1]\n num_sub <- dim(cost)[2]\n \n ## Adding the option to introduce a bit of head room to the classes by\n ## the groups to a little bigger than the smallest possible\n ## Default is to allow for an extra 20 % fill\n if (is.null(excess_space)) {\n excess <- 1.2\n } else {\n excess <- excess_space\n }\n \n # generous round up of capacities\n if (is.null(cap_classes)) {\n capacity <- rep(ceiling(excess*num_sub/num_groups), num_groups)\n # } else if (!is.numeric(cap_classes)) {\n # stop(\"cap_classes has to be numeric\")\n } else if (length(cap_classes)==1){\n capacity <- ceiling(rep(cap_classes,num_groups)*excess)\n } else if (length(cap_classes)==num_groups){\n capacity <- ceiling(cap_classes*excess)\n } else {\n stop(\"cap_classes has to be either length 1 or same as number of groups\")\n }\n \n ## This test should be a little more elegant\n ## pre_assign should be a data.frame or matrix with an ID and assignment column\n with_pre_assign <- FALSE\n if (!is.null(pre_assign)){\n # Setting flag for later and export list\n with_pre_assign <- TRUE\n # Splitting to list for later merging\n pre <- split(pre_assign[,1],factor(pre_assign[,2],levels = seq_len(num_groups)))\n # Subtracting capacity numbers, to reflect already filled spots\n capacity <- capacity-lengths(pre)\n # Making sure pre_assigned are removed from main data set\n ds <- ds[!ds[[1]] %in% pre_assign[[1]],]\n \n cost <- t(ds[,-1])\n colnames(cost) <- ds[,1]\n \n num_groups <- dim(cost)[1]\n num_sub <- dim(cost)[2]\n }\n \n ## Simple NA handling. Better to handle NAs yourself!\n cost[is.na(cost)] <- num_groups\n \n i_m <- seq_len(num_groups)\n j_m <- seq_len(num_sub)\n \n m <- ompr::MIPModel() %>%\n ompr::add_variable(grp[i, j],\n i = i_m,\n j = j_m,\n type = \"binary\") %>%\n ## The first constraint says that group size should not exceed capacity\n ompr::add_constraint(ompr::sum_expr(grp[i, j], j = j_m) <= capacity[i],\n i = i_m) %>%\n ## The second constraint says each subject can only be in one group\n ompr::add_constraint(ompr::sum_expr(grp[i, j], i = i_m) == 1, j = j_m) %>%\n ## The objective is set to minimize the cost of the assignments\n ## Giving subjects the group with the highest possible ranking\n ompr::set_objective(ompr::sum_expr(\n cost[i, j] * grp[i, j],\n i = i_m,\n j = j_m\n ),\n \"min\") %>%\n ompr::solve_model(ompr.roi::with_ROI(solver = \"symphony\", verbosity = 1))\n \n ## Getting assignments\n solution <- ompr::get_solution(m, grp[i, j]) %>% filter(value > 0)\n \n assign <- solution |> select(i,j)\n \n if (!is.null(rownames(cost))){\n assign$i <- rownames(cost)[assign$i]\n }\n\n if (!is.null(colnames(cost))){\n assign$j <- colnames(cost)[assign$j]\n }\n \n ## Splitting into groups based on assignment\n assign_ls <- split(assign$j,assign$i)\n \n \n ## Extracting subject cost for the final assignment for evaluation\n if (is.null(rownames(cost))){\n rownames(cost) <- seq_len(nrow(cost))\n }\n \n if (is.null(colnames(cost))){\n colnames(cost) <- seq_len(ncol(cost))\n }\n \n eval <- lapply(seq_len(length(assign_ls)),function(i){\n ndx <- match(names(assign_ls)[i],rownames(cost))\n cost[ndx,assign_ls[[i]]]\n })\n names(eval) <- names(assign_ls)\n \n if (with_pre_assign){\n names(pre) <- names(assign_ls)\n assign_all <- mapply(c, assign_ls, pre, SIMPLIFY=FALSE)\n \n out <- list(all_assigned=assign_all)\n } else {\n out <- list(all_assigned=assign_ls)\n }\n \n export <- do.call(rbind,lapply(seq_along(out[[1]]),function(i){\n cbind(\"ID\"=out[[1]][[i]],\"Group\"=names(out[[1]])[i])\n }))\n \n out <- append(out,\n list(evaluation=eval,\n assigned=assign_ls,\n solution = solution,\n capacity = capacity,\n excess = excess,\n pre_assign = with_pre_assign,\n cost_scale = levels(factor(cost)),\n input=ds,\n export=export))\n # exists(\"excess\")\n return(out)\n }\n\n\n## Assessment performance overview\n## The function plots costs of assignment for each subject in every group\nassignment_plot <- function(lst){\n \n dl <- lst[[2]]\n cost_scale <- unique(lst[[8]])\n cap <- lst[[5]]\n cnts_ls <- lapply(dl,function(i){\n factor(i,levels=cost_scale)\n })\n require(ggplot2)\n require(patchwork)\n require(viridisLite)\n \n y_max <- max(lengths(dl))\n \n wrap_plots(lapply(seq_along(dl),function(i){\n ttl <- names(dl)[i]\n ns <- length(dl[[i]])\n cnts <- cnts_ls[[i]]\n ggplot2::ggplot() + ggplot2::geom_bar(ggplot2::aes(cnts,fill=cnts)) +\n ggplot2::scale_x_discrete(name = NULL, breaks=cost_scale, drop=FALSE) +\n ggplot2::scale_y_continuous(name = NULL, limits = c(0,y_max)) + \n ggplot2::scale_fill_manual(values = viridisLite::viridis(length(cost_scale), direction = -1)) +\n ggplot2::guides(fill=FALSE) + \n ggplot2::labs(title=paste0(ttl,\" (fill=\",round(ns/cap[[i]],1),\";m=\",round(mean(dl[[i]]),1),\";n=\",ns ,\")\"))\n })) \n}\n\n\n## Helper function for Shiny\nfile_extension <- function(filenames) {\n sub(pattern = \"^(.*\\\\.|[^.]+)(?=[^.]*)\", replacement = \"\", filenames, perl = TRUE)\n}\n\n\n\n","type":"text"}]
|