From 73bdac829acf116fd5bb15245810f257a6bcc7de Mon Sep 17 00:00:00 2001 From: Andreas Gammelgaard Damsbo Date: Thu, 11 Jan 2024 13:42:03 +0100 Subject: [PATCH] RSymphony is not ported to webR. Will not run. Will come back. --- DESCRIPTION | 3 +- R/group_assign.R | 100 ++++++++++++++++++++---------------- R/server.R | 86 +++++++++++++++---------------- R/ui.R | 129 ++++++++++++++++++++++++----------------------- README.md | 8 ++- docs/app.json | 2 +- renv.lock | 35 +++++++++++++ shinylive init.R | 9 +++- 8 files changed, 215 insertions(+), 157 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 9390f5a..8927fb7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -24,7 +24,8 @@ Imports: httpuv, here, shiny, - cpp11 + cpp11, + ROI.plugin.alabama Suggests: pak, usethis diff --git a/R/group_assign.R b/R/group_assign.R index ef1a7fd..aab762d 100644 --- a/R/group_assign.R +++ b/R/group_assign.R @@ -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 <- function(ds, cap_classes = NULL, - excess_space = NULL, - pre_assign = NULL) { + excess_space = 1.2, + pre_assign = NULL, + set_solver="symphony") { require(ROI) require(ROI.plugin.symphony) - + 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 - } - + excess <- excess_space + # generous round up of capacities if (is.null(cap_classes)) { capacity <- rep(ceiling(excess*num_sub/num_groups), num_groups) @@ -39,7 +50,7 @@ group_assignment <- } 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 @@ -52,30 +63,30 @@ group_assignment <- 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 <- ompr::MIPModel() %>% + + m <- ompr::MIPModel() |> ompr::add_variable(grp[i, j], i = i_m, j = j_m, - type = "binary") %>% + type = "binary") |> ## The first constraint says that group size should not exceed capacity ompr::add_constraint(ompr::sum_expr(grp[i, j], j = j_m) <= capacity[i], - i = i_m) %>% + i = i_m) |> ## The second constraint says each subject can only be in one group - ompr::add_constraint(ompr::sum_expr(grp[i, j], i = i_m) == 1, j = j_m) %>% + ompr::add_constraint(ompr::sum_expr(grp[i, j], i = i_m) == 1, j = j_m) |> ## The objective is set to minimize the cost of the assignments ## Giving subjects the group with the highest possible ranking ompr::set_objective(ompr::sum_expr( @@ -83,14 +94,15 @@ group_assignment <- i = i_m, j = j_m ), - "min") %>% - ompr::solve_model(ompr.roi::with_ROI(solver = "symphony", verbosity = 1)) - + "min") |> + # ompr::solve_model(ompr.roi::with_ROI(solver = "symphony", verbosity = 1)) + ompr::solve_model(ompr.roi::with_ROI(solver = set_solver, verbosity = 1)) + ## Getting assignments - solution <- ompr::get_solution(m, grp[i, j]) %>% filter(value > 0) - - assign <- solution |> select(i,j) - + solution <- ompr::get_solution(m, grp[i, j]) |> dplyr::filter(value > 0) + + assign <- solution |> dplyr::select(i,j) + if (!is.null(rownames(cost))){ assign$i <- rownames(cost)[assign$i] } @@ -98,39 +110,39 @@ group_assignment <- 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, @@ -149,7 +161,7 @@ group_assignment <- ## 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]] @@ -159,20 +171,20 @@ assignment_plot <- function(lst){ 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]] ggplot2::ggplot() + ggplot2::geom_bar(ggplot2::aes(cnts,fill=cnts)) + 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::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 ,")")) - })) + })) } diff --git a/R/server.R b/R/server.R index 1ca9ab6..dd22479 100644 --- a/R/server.R +++ b/R/server.R @@ -1,64 +1,62 @@ +library(shiny) server <- function(input, output, session) { - library(dplyr) - library(tidyr) - library(ROI) - library(ROI.plugin.symphony) - library(ompr) - library(ompr.roi) - library(magrittr) - library(ggplot2) - library(viridisLite) - library(patchwork) - library(openxlsx) # source("https://git.nikohuru.dk/au-phd/PhysicalActivityandStrokeOutcome/raw/branch/main/side%20projects/assignment.R") source(here::here("R/group_assign.R")) - - dat <- shiny::reactive({ + + dat <- reactive({ # input$file1 will be NULL initially. After the user selects # and uploads a file, head of that data file by default, # or all rows if selected, will be shown. - + 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'") - } - + + tryCatch( + { + if (ext == "csv") { + df <- read.csv(input$file1$datapath,na.strings = c("NA", '""',"")) + } else if (ext %in% c("xls", "xlsx")) { + df <- openxlsx::read.xlsx(input$file1$datapath,na.strings = c("NA", '""',"")) + + } else { + stop("Input file format has to be either '.csv', '.xls' or '.xlsx'") + } + }, + error = function(e) { + # return a safeError if a parsing error occurs + stop(safeError(e)) + } + ) + return(df) }) - - dat_pre <- shiny::reactive({ - + + dat_pre <- reactive({ + # req(input$file2) # Make laoding dependent of file name extension (file_ext()) 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 <- - shiny::reactive({ + reactive({ assigned <- group_assignment( ds = dat(), excess_space = input$ecxess, @@ -66,31 +64,31 @@ server <- function(input, output, session) { ) return(assigned) }) - - - output$raw.data.tbl <- shiny::renderTable({ + + + output$raw.data.tbl <- renderTable({ assign()$export }) - - output$pre.assign <- shiny::renderTable({ + + output$pre.assign <- renderTable({ dat_pre() }) - - output$input <- shiny::renderTable({ + + output$input <- renderTable({ dat() }) - - output$assign.plt <- shiny::renderPlot({ + + output$assign.plt <- renderPlot({ assignment_plot(assign()) }) - + # Downloadable csv of selected dataset ---- - output$downloadData <- shiny::downloadHandler( + output$downloadData <- downloadHandler( filename = "group_assignment.csv", content = function(file) { write.csv(assign()$export, file, row.names = FALSE) } ) - + } diff --git a/R/ui.R b/R/ui.R index 1796d42..6c4de31 100644 --- a/R/ui.R +++ b/R/ui.R @@ -1,43 +1,44 @@ -ui <- shiny::fluidPage( +library(shiny) +ui <- fluidPage( ## ----------------------------------------------------------------------------- ## Application title ## ----------------------------------------------------------------------------- - - shiny::titlePanel("Assign groups based on costs/priorities.", + + titlePanel("Assign groups based on costs/priorities.", windowTitle = "Group assignment calculator"), - shiny::h5( + h5( "Please note this calculator is only meant as a proof of concept for educational purposes, and the author will take no responsibility for the results of the calculator. Uploaded data is not kept, but please, do not upload any sensitive data." ), - + ## ----------------------------------------------------------------------------- ## Side panel ## ----------------------------------------------------------------------------- - - + + ## ----------------------------------------------------------------------------- ## Single entry ## ----------------------------------------------------------------------------- - shiny::sidebarLayout( - shiny::sidebarPanel( - shiny::numericInput( + sidebarLayout( + sidebarPanel( + numericInput( inputId = "ecxess", label = "Excess space", value = 1, step = .05 ), - shiny::p("As default, the program will try to evenly distribute subjects in groups. - This factor will add more capacity to each group, for an overall lesser cost, + p("As default, the program will try to evenly distribute subjects in groups. + This factor will add more capacity to each group, for an overall lesser cost, but more uneven group numbers. More adjustments can be performed with the source script."), - shiny::a(href='https://git.nikohuru.dk/au-phd/PhysicalActivityandStrokeOutcome/src/branch/main/apps/Assignment', "Source", target="_blank"), + a(href='https://git.nikohuru.dk/au-phd/PhysicalActivityandStrokeOutcome/src/branch/main/apps/Assignment', "Source", target="_blank"), ## ----------------------------------------------------------------------------- ## File upload ## ----------------------------------------------------------------------------- - + # Input: Select a file ---- - - shiny::fileInput( + + fileInput( inputId = "file1", label = "Choose main data file", multiple = FALSE, @@ -45,14 +46,14 @@ ui <- shiny::fluidPage( ".csv",".xls",".xlsx" ) ), - shiny::strong("Columns: ID, group1, group2, ... groupN."), - shiny::strong("NOTE: 0s will be interpreted as lowest score."), - shiny::p("Cells should contain cost/priorities. + strong("Columns: ID, group1, group2, ... groupN."), + strong("NOTE: 0s will be interpreted as lowest score."), + p("Cells should contain cost/priorities. Lowest score, for highest priority. Non-ranked should contain a number (eg lowest score+1). Will handle missings but try to avoid."), - - shiny::fileInput( + + fileInput( inputId = "file2", label = "Choose data file for pre-assigned subjects", multiple = FALSE, @@ -60,61 +61,61 @@ ui <- shiny::fluidPage( ".csv",".xls",".xlsx" ) ), - shiny::h6("Columns: ID, group"), - - - + h6("Columns: ID, group"), + + + ## ----------------------------------------------------------------------------- ## Download output ## ----------------------------------------------------------------------------- - + # Horizontal line ---- tags$hr(), - - shiny::h4("Download results"), - + + h4("Download results"), + # Button - shiny::downloadButton("downloadData", "Download") + downloadButton("downloadData", "Download") ), - - shiny::mainPanel(shiny::tabsetPanel( + + mainPanel(tabsetPanel( ## ----------------------------------------------------------------------------- ## Plot tab ## ----------------------------------------------------------------------------- - - shiny::tabPanel( - "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) + ) - + )) ) ) diff --git a/README.md b/README.md index 70f216b..073569b 100644 --- a/README.md +++ b/README.md @@ -5,4 +5,10 @@ Reviving an old project to use shinylive with R ## Shortcoming -This will only deploy a static site. No uploaded file processing is available apparently. Looking forward to developments. +This project requires ROI.plugin.symphony to solve the problem, which depends on the RSymphony project (which again adapts SYMPHONY MILP), which is not [compiled for webR](https://repo.r-wasm.org/). + +Clone the project and run the solver with +``` +shiny::runApp(appDir = here::here("R/"),launch.browser = TRUE) +``` + diff --git a/docs/app.json b/docs/app.json index 8c7ee9d..d596f9a 100644 --- a/docs/app.json +++ b/docs/app.json @@ -1 +1 @@ -[{"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"}] +[{"name":"server.R","content":"library(shiny)\nserver <- function(input, output, session) {\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 <- 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 <- 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 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 <- renderTable({\n assign()$export\n })\n\n output$pre.assign <- renderTable({\n dat_pre()\n })\n\n output$input <- renderTable({\n dat()\n })\n\n output$assign.plt <- renderPlot({\n assignment_plot(assign())\n })\n\n # Downloadable csv of selected dataset ----\n output$downloadData <- 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":"library(shiny)\nui <- fluidPage(\n ## -----------------------------------------------------------------------------\n ## Application title\n ## -----------------------------------------------------------------------------\n\n titlePanel(\"Assign groups based on costs/priorities.\",\n windowTitle = \"Group assignment calculator\"),\n 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 sidebarLayout(\n sidebarPanel(\n numericInput(\n inputId = \"ecxess\",\n label = \"Excess space\",\n value = 1,\n step = .05\n ),\n 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 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 fileInput(\n inputId = \"file1\",\n label = \"Choose main data file\",\n multiple = FALSE,\n accept = c(\n \".csv\",\".xls\",\".xlsx\"\n )\n ),\n strong(\"Columns: ID, group1, group2, ... groupN.\"),\n strong(\"NOTE: 0s will be interpreted as lowest score.\"),\n 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 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 h6(\"Columns: ID, group\"),\n\n\n\n ## -----------------------------------------------------------------------------\n ## Download output\n ## -----------------------------------------------------------------------------\n\n # Horizontal line ----\n tags$hr(),\n\n h4(\"Download results\"),\n\n # Button\n downloadButton(\"downloadData\", \"Download\")\n ),\n\n mainPanel(tabsetPanel(\n ## -----------------------------------------------------------------------------\n ## Plot tab\n ## -----------------------------------------------------------------------------\n\n tabPanel(\n \"Summary\",\n h3(\"Assignment plot\"),\n 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 plotOutput(\"assign.plt\")\n\n ),\n\n tabPanel(\n \"Results\",\n h3(\"Raw Results\"),\n p(\"This is identical to the downloaded file (see panel on left)\"),\n\n htmlOutput(\"raw.data.tbl\", container = span)\n\n ),\n\n tabPanel(\n \"Input data Results\",\n h3(\"Costs/prioritis overview\"),\n\n\n htmlOutput(\"input\", container = span),\n\n h3(\"Pre-assigned groups\"),\n p(\"Appears empty if none is uploaded.\"),\n\n 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]) |> dplyr::filter(value > 0)\n\n assign <- solution |> dplyr::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"}] diff --git a/renv.lock b/renv.lock index 3c62688..a3a5747 100644 --- a/renv.lock +++ b/renv.lock @@ -76,6 +76,20 @@ ], "Hash": "42ce9ee4c1cf168869f4386d2cdeadd2" }, + "ROI.plugin.alabama": { + "Package": "ROI.plugin.alabama", + "Version": "1.0-2", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "ROI", + "alabama", + "methods", + "stats", + "utils" + ], + "Hash": "097f1b625baf91f0d8999a1385054250" + }, "ROI.plugin.symphony": { "Package": "ROI.plugin.symphony", "Version": "1.0-0", @@ -110,6 +124,17 @@ ], "Hash": "3f55239fe534fe91e739c77d99a4ffbf" }, + "alabama": { + "Package": "alabama", + "Version": "2023.1.0", + "Source": "Repository", + "Repository": "CRAN", + "Requirements": [ + "R", + "numDeriv" + ], + "Hash": "593db7eb170506e6b61ca0c803201924" + }, "archive": { "Package": "archive", "Version": "1.1.7", @@ -692,6 +717,16 @@ ], "Hash": "a623a2239e642806158bc4dc3f51565d" }, + "numDeriv": { + "Package": "numDeriv", + "Version": "2016.8-1.1", + "Source": "Repository", + "Repository": "RSPM", + "Requirements": [ + "R" + ], + "Hash": "df58958f293b166e4ab885ebcad90e02" + }, "ompr": { "Package": "ompr", "Version": "1.0.4", diff --git a/shinylive init.R b/shinylive init.R index 4b0c9f8..c183367 100644 --- a/shinylive init.R +++ b/shinylive init.R @@ -1,3 +1,8 @@ -shinylive::export("R", "docs") +# Typical shiny +shiny::runApp(appDir = here::here("R/"),launch.browser = TRUE) -httpuv::runStaticServer("docs") \ No newline at end of file + +# Shinylive version +shinylive::export(appdir = "R", destdir = "docs") + +httpuv::runStaticServer(dir = "docs")