transfer from old repo

apps/Assignment/assign_sample.csv

@@ -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

apps/Assignment/group_assign.R

@@ -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),";n=",ns ,")"))
+  })) 
+}
+
+
+## Helper function for Shiny
+file_extension <- function(filenames) {
+  sub(pattern = "^(.*\\.|[^.]+)(?=[^.]*)", replacement = "", filenames, perl = TRUE)
+}
+
+
+

apps/Assignment/pre_grouped.csv

@@ -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

apps/Assignment/rsconnect/shinyapps.io/cognitiveindex/assignment.dcf

@@ -0,0 +1,10 @@
+name: assignment
+title:
+username: cognitiveindex
+account: cognitiveindex
+server: shinyapps.io
+hostUrl: https://api.shinyapps.io/v1
+appId: 9832455
+bundleId: 7671734
+url: https://cognitiveindex.shinyapps.io/assignment/
+version: 1

apps/Assignment/server.R

@@ -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)
+    }
+  )
+  
+}

apps/Assignment/ui.R

@@ -0,0 +1,123 @@
+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
+      ),
+      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."),
+      a(href='https://git.nikohuru.dk/au-phd/PhysicalActivityandStrokeOutcome/src/branch/main/apps/Assignment', "Source", target="_blank"),
+      ## -----------------------------------------------------------------------------
+      ## 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)
+        
+      )
+      
+    ))
+  )
+)