Создать поддельный каталог курсов

Question

У меня действительно ужасный код, который занимает ДЛИННОЕ время для запуска.Сначала, если составлен список поддельных курсов колледжа:

library(tidyverse)
library(lubridate)
library(gtools)
rm(list = ls())


course_subjects<-c("Math", "English", "History","Writing","Engineering","Chemistry","Biology","Business","Physics","Economics","Music","Art")


course_numbers<-sprintf("%04d",seq(900,2050,by = 15)) 
course.offerings<-expand.grid("course_subject" = course_subjects,
                            "course_number" = course_numbers)%>%
  mutate(course = paste0(course_subject,"-",course_number),# specify the course name
         offerings = ceiling(8.75*rchisq(length(course_numbers)*length(course_subjects),0.0001,3)+1))%>%#randomly assign the number of sections, assume the distribution of number of sections offered is skewed right
  dplyr::select(course,
                offerings)


rm(course_subjects)
rm(course_numbers)

, затем создайте коды для доступных аудиторий в 10 кампусах, обозначенных буквами, и с 20 комнатами на кампус

lecture.halls<-expand.grid("campus" = LETTERS[1:10],
                           "classroom" = sprintf("%03d",seq(1,20,by = 1)))%>%
  mutate(lecture_hall = paste0(campus,classroom))%>%
  dplyr::select(lecture_hall)

Одинпоследний шаг перед запуском реального кода -f * ckery.Сделайте так, чтобы количество разделов, предлагаемых для каждого из этих курсов, было несколько искажено, чтобы у вас были действительно популярные классы, которым нужно много разделов и курсов, в которых не так много предлагаемых разделов, и создавайте уникальные идентификаторы разделов.

expanded.offerings<-as.data.frame(course.offerings[rep(row.names(course.offerings), course.offerings$offerings),])%>%
  group_by(course)%>%
  mutate(section = paste0(course,"-",sprintf("%03d",row_number(course))))%>%
  ungroup()%>%
  dplyr::select(section)

Как и было обещано, в этом разделе я чувствую, что делаю что-то очень глупое.Я использую цикл for для перехода один за другим и заполняю первый, второй, третий, четвертый, пятый, шестой и седьмой временные блоки, доступные для каждого дня недели, и удаляю строки из набора данных предложения курса, которые я пробую, чтобычтобы быть уверенным, что если я буду преподавать один и тот же курс в одном классе в день, они будут, по крайней мере, в разных секциях, и иллюзия выборки из реального каталога курсов может продолжаться.Я знаю, что если бы я знал больше о функциях отображения, это, вероятно, было бы быстрее и эффективнее, мне просто нужен способ заполнить матрицу путем выборки из 1-го списка.Примечание: я выбрал цикл for, потому что хочу создать некоторую сложность с генерацией данных, чтобы я мог составлять расписания, которые бы учитывали курсы с различными атрибутами, такими как количество дней в неделю, продолжительность занятий и т. Д. ...

В любом случае, цикл for, который генерирует данные, которые выглядят примерно так, как я собираюсь, ниже

for(i in 1:nrow(lecture.halls)){
  #MONDAY COURSES
  mon1.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$mon1[i]<-expanded.offerings[mon1.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-mon1.remove.this.row,]
  mon2.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$mon2[i]<-expanded.offerings[mon2.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-mon2.remove.this.row,]
  mon3.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$mon3[i]<-expanded.offerings[mon3.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-mon3.remove.this.row,]
  mon4.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$mon4[i]<-expanded.offerings[mon4.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-mon4.remove.this.row,]
  mon5.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$mon5[i]<-expanded.offerings[mon5.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-mon5.remove.this.row,]
  mon6.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$mon6[i]<-expanded.offerings[mon6.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-mon6.remove.this.row,]
  mon7.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$mon7[i]<-expanded.offerings[mon7.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-mon7.remove.this.row,]
  #TUESDAY COURSES
  tues1.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$tues1[i]<-expanded.offerings[tues1.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-tues1.remove.this.row,]
  tues2.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$tues2[i]<-expanded.offerings[tues2.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-tues2.remove.this.row,]
  tues3.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$tues3[i]<-expanded.offerings[tues3.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-tues3.remove.this.row,]
  tues4.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$tues4[i]<-expanded.offerings[tues4.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-tues4.remove.this.row,]
  tues5.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$tues5[i]<-expanded.offerings[tues5.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-tues5.remove.this.row,]
  tues6.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$tues6[i]<-expanded.offerings[tues6.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-tues6.remove.this.row,]
  tues7.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$tues7[i]<-expanded.offerings[tues7.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-tues7.remove.this.row,]
  #WEDNESDAY COURSES
  wed1.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$wed1[i]<-expanded.offerings[wed1.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-wed1.remove.this.row,]
  wed2.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$wed2[i]<-expanded.offerings[wed2.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-wed2.remove.this.row,]
  wed3.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$wed3[i]<-expanded.offerings[wed3.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-wed3.remove.this.row,]
  wed4.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$wed4[i]<-expanded.offerings[wed4.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-wed4.remove.this.row,]
  wed5.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$wed5[i]<-expanded.offerings[wed5.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-wed5.remove.this.row,]
  wed6.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$wed6[i]<-expanded.offerings[wed6.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-wed6.remove.this.row,]
  wed7.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$wed7[i]<-expanded.offerings[wed7.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-wed7.remove.this.row,]
  #THURSDAY COURSES
  thu1.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$thu1[i]<-expanded.offerings[thu1.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-thu1.remove.this.row,]
  thu2.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$thu2[i]<-expanded.offerings[thu2.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-thu2.remove.this.row,]
  thu3.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$thu3[i]<-expanded.offerings[thu3.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-thu3.remove.this.row,]
  thu4.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$thu4[i]<-expanded.offerings[thu4.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-thu4.remove.this.row,]
  thu5.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$thu5[i]<-expanded.offerings[thu5.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-thu5.remove.this.row,]
  thu6.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$thu6[i]<-expanded.offerings[thu6.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-thu6.remove.this.row,]
  thu7.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$thu7[i]<-expanded.offerings[thu7.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-thu7.remove.this.row,]
  #FRIDAY COURSES
  fri1.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$fri1[i]<-expanded.offerings[fri1.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-fri1.remove.this.row,]
  fri2.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$fri2[i]<-expanded.offerings[fri2.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-fri2.remove.this.row,]
  fri3.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$fri3[i]<-expanded.offerings[fri3.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-fri3.remove.this.row,]
  fri4.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$fri4[i]<-expanded.offerings[fri4.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-fri4.remove.this.row,]
  fri5.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$fri5[i]<-expanded.offerings[fri5.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-fri5.remove.this.row,]
  fri6.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$fri6[i]<-expanded.offerings[fri6.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-fri6.remove.this.row,]
  fri7.remove.this.row<-sample(1:nrow(expanded.offerings),1,replace = F)
  lecture.halls$fri7[i]<-expanded.offerings[fri7.remove.this.row,1]
  expanded.offerings<-expanded.offerings[-fri7.remove.this.row,]
}
rm(list = ls.str(mode = 'numeric'))

Любая помощь в повышении эффективности этого кода или идеи о том, как выполнить построение расписанияБыло бы очень полезно, если бы он мог работать с 3 секционными заседаниями (в одном и том же лекционном зале в одно и то же время дня, но в разные дни недели) и / или позволять различным курсам иметь разную продолжительность лекций.Снова извините за безобразие

Answer 1

Возможно, я неправильно понял ваше намерение, но что-то вроде этого поможет:

replicate(NROW(lecture.halls), sample(expanded.offerings$section, 5))

Что он делает, это рисует 5 секций из expanded.offerings (для каждого дня недели) без замена (таким образом, вы гарантируете, что это будут разные секции, и повторите эту процедуру для каждого из аудиторий. Он возвращает матрицу измерения 5 x NROW(lecture.halls), которую вы могли бы дополнительно сформировать для своих нужд.

---

Редактировать

На самом деле вы также можете извлечь из expanded.offerings$section за один раз и отформатировать результаты самостоятельно, что может быть даже быстрее. Таким образом, вы гарантируете, что ни один курс не будет выбран более, чемодин раз за целую неделю:

res <- sample(expanded.offerings$section, 5 * NROW(lecture.halls))
dim(res) <- c(NROW(lecture.halls), 5)
res

---

Результаты

replicate(NROW(lecture.halls), sample(expanded.offerings$section, 5)) %>% 
   t() %>%
   as_tibble(.name_repair = ~ c("Monday", "Tuesday", "Wednesday", 
                                "Thursday", "Friday")) %>% 
   mutate(room = lecture.halls$lecture_hall) %>% 
   select(room, everything())
# A tibble: 200 x 6
   room  Monday            Tuesday              Wednesday            Thursday             Friday              
#    <chr> <chr>             <chr>                <chr>                <chr>                <chr>               
#  1 A001  Business-1035-012 English-1770-010     Engineering-1500-001 Engineering-1545-006 History-1335-028    
#  2 B001  Math-1905-016     Economics-1080-015   Writing-1155-029     Art-1125-003         Art-1080-001        
#  3 C001  Business-1155-031 Business-1950-034    English-1785-006     Business-0915-032    Physics-1275-002    
#  4 D001  History-0915-002  Physics-1500-017     Economics-1665-017   Writing-1860-049     Art-1140-019        
#  5 E001  Writing-1785-004  Economics-1695-044   Economics-1815-016   Economics-1560-031   Chemistry-1845-032  
#  6 F001  English-1680-012  Music-1725-011       Art-1140-074         English-1800-023     Physics-1935-033    
#  7 G001  History-1845-003  Art-1980-009         Biology-1770-001     Economics-1860-001   Economics-1590-091  
#  8 H001  Art-1365-029      Math-1140-165        Music-1710-016       Economics-1920-029   Business-1680-009   
#  9 I001  Biology-1410-037  Math-1515-010        Music-1935-036       Art-1140-031         Engineering-1830-006
# 10 J001  Music-1545-009    Engineering-1755-017 Music-1770-018       Business-2040-013    History-1170-076    
# # ... with 190 more rows

Answer 2

Этот подход осуществляет выборку для всех строк одновременно.Подмножественные строки затем преобразуются в матрицу и переназначаются обратно на lecture.hall data.frame:

# lecture hall days and periods
cols <- Reduce(function(x,y) paste0(y, x), expand.grid(1:7, c('mon','tue','wed','thu','fri')))

# do all of the sampling of expanded.offerings at once
class_selections <- sample(nrow(expanded.offerings),
                           size = nrow(lecture.halls) * (length(cols)),
                           replace = F)

# subset expanded.offerings and assign back to the lecture.halls
lecture.halls[, cols] <- matrix(unlist(expanded.offerings, use.names = F)[class_selections],
                                 ncol = length(cols))

# remove used rows form exapnded.offerings
expanded.offerings <- slice(expanded.offerings, -class_selections)

# or I would have made expanded.offerings a vector
#expanded.offerings <- unlist(expanded.offerings, use.names = F)[-class_selections]

lecture.halls

# 200 total rows; 36 variables.
#
#   lecture_hall                 mon1                 mon2                 mon3
#1          A001 Engineering-1125-009     Physics-1050-025   Chemistry-1455-022
#2          B001         Art-1875-001     English-1425-014     Physics-1335-024
#3          C001         Art-1890-042   Chemistry-1650-012        Math-1200-057
#4          D001        Math-1830-020     English-1770-004   Chemistry-1170-022
#5          E001        Math-1260-013     History-1125-023   Chemistry-2010-034
#6          F001   Chemistry-0945-043     Writing-1680-024       Music-1740-033

Кроме того, здесь будет мой полный переписать код.На моем компьютере это занимает 0,02 с по сравнению с 3,5 с, которые выполняла оригинальная функция.Это также полностью основание.

set.seed(1)
# Create unique courses AKA Music-915 or English-2050 ---------------------
courses <- Reduce(function(x,y) paste(x, y, sep = '-'),
                  expand.grid(c("Math", "English", "History","Writing","Engineering","Chemistry","Biology","Business","Physics","Economics","Music","Art"),
                              sprintf("%04d",seq(900,2050,by = 15))
                              )
                  )

# Generate random sections ------------------------------------------------
course_offerings <- ceiling(8.75 * rchisq(length(courses), 0.0001, 3) + 1)


# Repeat the courses to include all sections ------------------------------

# This was group_by() and mutate() in the original. sequence() will 
# create the numbers much faster
expanded_courses <- Reduce(function(x,y) paste(x,y, sep = '-'),
                           list(rep(courses, course_offerings),
                                sprintf("%03d", sequence(course_offerings))
                                )
                           )

# Create lecture halls for the courses to be held -------------------------
lecture_halls <- Reduce(paste0,
                        expand.grid(LETTERS[1:10],
                                    sprintf("%03d",seq(1,20,by = 1)))
                        )

# Lecture Hall Days and Periods -------------------------------------------
cols <- Reduce(function(x,y) paste0(y, x),
               expand.grid(1:7,
                           c('mon','tue','wed','thu','fri')))

# do all of the sampling of expanded.offerings at once
class_selections <- sample(length(expanded_courses),
                           size = length(lecture_halls) * length(cols),
                           replace = F)

# subset expanded.offerings and assign back to the lecture.halls
class_catalog <- data.frame(lecture_halls,
                            matrix(expanded_courses[class_selections],
                                   ncol = length(cols),
                                   dimnames = list(NULL, cols))
                            , stringsAsFactors = F)

# remove used courses. Note, if we didn't have to subset, 
# we could have used sample(expanded.offerings) a couple of commands ago.
expanded_courses <- expanded_courses[-class_selections]