In fnaufel/PlanneR: Gerador de calendário de curso (aplicativo Shiny)

library(knitr)

opts_chunk$set(
  echo = TRUE, 
  # collapse = TRUE,
  # cache = TRUE,
  out.width = "75%",
  fig.align = 'center',
  fig.width = 6,
  fig.show = "hold"
)

options(dplyr.print_min = 6, dplyr.print_max = 6)

# Supress crayon output
options(crayon.enabled = FALSE)

# Useful libraries
library(glue)
library(patchwork)
library(latex2exp)
library(kableExtra)

# For nice dataframe summaries
library(summarytools)
st_options(
  plain.ascii = FALSE,
  dfSummary.varnumbers = FALSE,
  dfSummary.style = 'grid',
  dfSummary.graph.magnif = .75
)

# Tidy!
library(tidyverse)

# Sober theme for ggplot
theme_set(
  theme_linedraw() +                         # Set simple theme for ggplot
    theme(                                   # with some tweaks
      axis.title.y.left = element_text(
         angle = 0,                          # Never rotate y axis title
         margin = margin(r = 20),            # Separate y axis title a little 
         vjust = .5                          # Leave y axis title in the middle
      ),
      axis.title.y.right = element_text(
         angle = 0,                          # Never rotate y axis title
         margin = margin(l = 20),            # Separate y axis title a little
         vjust = .5                          # Leave y axis title in the middle
      ),
      axis.ticks.y.right = element_blank(),  # No ticks on secondary y axis
      axis.title.x.bottom = element_text(
         margin = margin(t = 20)             # Separate x axis title a little 
      ),
      axis.line = element_blank(),           # No axis lines
      panel.border = element_blank(),        # No frame
      panel.grid.minor = element_blank()     # No grid minor lines
    )
)

# Avoid scientific notation and use a comma as decimal separator
options(
  scipen = 15,
  OutDec = ','
)

# Format a number with thousand separators (default point)
# and decimal comma enclosed in curly braces for LaTeX printing.
# CAREFUL: if called outside math mode, will print the braces!
fm <- function(x, big = '.', decimal = '{,}', ...) {
  if (!is.numeric(x)) {
    x
  } else {
    prettyNum(x, big.mark = big, decimal.mark = decimal, ...)
  }

}

# Set this as a hook for inline R code
knitr::knit_hooks$set(inline = fm)


# To center the results of a chunk (image, video etc.)
# Usage: 
#         out.extra=center()
#         
center <- function(){

  if (is_html_output()) {
    'class="center"'
  }

}


# To embed YT videos in HTML and the link (centered) in LaTeX
embed_yt <- function(code) {

  if (is_html_output()) {
    include_url(
      paste0(
        'https://www.youtube.com/embed/',
        code
      )
    )
  } else {
    cat(
      paste0(
        '```{=latex}\n',
        '\\begin{center} \\url{https://youtu.be/',
        code,
        '} \\end{center}\n',
        '```'
      )
    )
  }

}

library(lubridate)
library(shiny)
library(gt)

```{js javascript-init, echo=FALSE}

// Make off-site links open in a new window/tab function changeTargets() { $("a").attr( "target", function() { // Load local links locally if (this.host == location.host) return "_self" // Load off-site links in a new window else return "_blank"; } ); }

// Execute when document is ready $( changeTargets )

# To do

* Continue coding functions in this Rmd

* One function per file

* Document

* Test

# Read holidays file

Using absolute path only for this Rmd.

```r
read_holidays_file <- function() {

  # readr::read_file(
  #   '/home/fnaufel/Development/00-Present/PlanneR/inst/extdata/holidays.csv'
  # )

  readr::read_file(
    system.file('extdata', 'holidays.csv', package = 'PlanneR', mustWork = TRUE)
  )

}

read_holidays_file()

Load holidays

Only convert from text to tibble.

load_holidays <- function(text) {

  # If text is empty, return NULL
  if (str_trim(text) == '') {
    return(NULL)
  }

  tryCatch(
    {
      df <- readr::read_csv2(
        text,
        col_names = c('name', 'from', 'to'),
        col_types = 'ccc',
        locale = readr::locale('pt'),
        quoted_na = FALSE,
        trim_ws = TRUE
      ) %>%
        dplyr::mutate(
          name = stringr::str_squish(name),
          from = lubridate::as_date(from, format = '%d/%m/%y'),
          to = lubridate::as_date(to, format = '%d/%m/%y')
        )
    },
    error = function(e) {

      error_modal('Lista de feriados tem um problema. Verifique.')
      req(FALSE)
      return(NULL)

    }
  )

  # If a from date is missing, error
  if (any(is.na(df$from))) {
    error_modal('Um ou mais feriados não tem data. Verifique.')
    req(FALSE)
    return(NULL)
  }

  df

}

df <- read_holidays_file() %>% 
  load_holidays()

df

To test

Ignore extra columns

'Feriado 1; 1/1/2021; 2/1/2021; 3/1/2021
Feriado 2; 4/1/2021' %>% 
  load_holidays()

Error when missing columns

'
Feriado 1; 1/1/2021; 2/1/2021;
Feriado 2;
' %>% 
  load_holidays()

Error when unable to convert to date

'
Feriado 1; 1/1/2021; 2/1/2021;
Feriado 2; abc; 
Feriado 3; 123;
' %>% 
  load_holidays()

Expand holidays

expand_holidays <- function(df) {

  # Return NULL if df is empty
  if (is.null(df)) {
    return(NULL)
  }

  # Save rows that represent single-day holidays (minus `to` column)
  df1 <- df %>%
    dplyr::filter(is.na(to)) %>%
    dplyr::select(-to) %>%
    dplyr::rename(date = from)

  # Save rows that represent multiple-day holidays
  df2 <- df %>%
    dplyr::filter(!is.na(to))

  # If there are no multiple-day holidays, return original df
  if (nrow(df2) == 0) {
    return(df1)
  }

  # Create list column with vector of dates for each holiday
  # and unnest this list column
  expanded_df <- df2 %>%
    dplyr::mutate(
      expanded = purrr::pmap(., ~ lubridate::as_date(..2:..3))
    ) %>%
    dplyr::select(-from, -to) %>%
    tidyr::unnest(cols = expanded) %>%
    dplyr::rename(date = expanded)

  # Eliminate rows whose date already appear in df1
  expanded_df <- expanded_df %>%
    dplyr::filter(!(date %in% df1$date))

  # Returned merged df
  df1 %>%
    rbind(expanded_df) %>%
    dplyr::arrange(date)

}

Validate all

validate_all <- function(
  dates,
  days
) {

  # Start or end dates must not be NA
  if (is.null(dates) || any(is.na(dates))) {
    error_modal('Preencha datas de início e de fim do curso.')
    return(FALSE)
  }

  # End must come before start
  if (dates[1] >= dates[2]) {
    error_modal('Data de início deve ser anterior à data de fim.')
    return(FALSE)
  }

  # Course must not last more than a year
  if (dates[1] %--% dates[2] > years(2) ) {
    error_modal(
      'Curso não pode durar mais de 2 anos. Verifique as datas de início e fim.'
    )
    return(FALSE)
  }

  # At least one weekday must be chosen
  if (is.null(days)) {
    error_modal('Marque pelo menos um dia da semana.')
    return(FALSE)
  }

  TRUE

}

start <- lubridate::dmy('14/06/2021')
end <- lubridate::dmy('25/09/2021')
days <- c(2, 4, 6)
dates <- c(start, end)
validate_all(dates, days)

Build plan

# This function assumes everything is ok with the start, end, and days
build_plan <- function(start, end, days, wday_names, holidays, topics) {

  # Generate ALL dates between start and end
  all_dates <- lubridate::as_date(start:end)

  # Create data frame (date, weekday name) and filter for class days
  df <- tibble(class_date = all_dates) %>% 
    mutate(weekday = lubridate::wday(class_date)) %>% 
    filter(weekday %in% days) %>% 
    mutate(weekday = wday_names[weekday])  

  if (!is.null(holidays)) {
    # If holidays df is not empty, join with holidays df to fill in holiday
    # names on the right dates. I use distinct(class_date) because one date
    # may be associated with more than one holiday, and I want such a date to
    # appear only once.
    df <- df %>%
      left_join(holidays, by = c('class_date' = 'date')) %>%
      rename(contents = name) %>% 
      distinct(class_date, .keep_all = TRUE)
  } else {
    # If holidays df is empty, just add an empty contents column
    df <- df %>% 
      mutate(contents = NA_character_)
  }

  # Fill in class numbers

  # Number of available class days
  n_classes <- nrow(
    df %>% 
      filter(is.na(contents))
  )

  # Class numbers
  numbers <- 1:n_classes

  # Add class numbers only to non holidays (contents is NA)
  df <- df %>% 
    filter(is.na(contents)) %>% 
    mutate(class_no = numbers) %>% 
    rbind(
      df %>% 
        filter(!is.na(contents)) %>% 
        mutate(class_no = NA_integer_)
    ) %>% 
    arrange(class_date) %>% 
    select(class_date, weekday, class_no, contents)

  # If no topics yet, return
  if (is.null(topics)) {
    return(df)
  }

  # n_classes is number of available class days
  # n_topics is number of topics
  n_topics <- length(topics)

  if (n_classes > n_topics) {
    # Add empty topics
    difference <- n_classes - n_topics
    topics <- c(topics, rep(NA, difference))
  } else if (n_classes < n_topics) {
    # truncate topics and emit warning
    topics <- topics[1:n_classes]
    difference <- n_topics - n_classes
    warning_modal(
      paste0(
        'Aulas (',
        n_classes,
        ') < Tópicos (',
        n_topics,
        '). ',
        difference,
        ' tópicos não foram incluídos.'
      )
    )
  }

  # Fill in topics
  df <- df %>% 
    filter(is.na(contents)) %>% 
    mutate(contents = topics) %>% 
    rbind(
      df %>% 
        filter(!is.na(contents))
    ) %>% 
    arrange(class_date)

  # Return
  df

}

start <- lubridate::dmy('14/06/2021')
end <- lubridate::dmy('25/09/2021')
days <- c(2, 4, 6)
wday_names <- c(
  'DOM',
  'SEG',
  'TER',
  'QUA',
  'QUI',
  'SEX',
  'SAB'
)
topics <- paste('Tópico', 1:29)
holidays <- read_holidays_file() %>% 
  load_holidays() %>% 
  expand_holidays()

plan <- build_plan(start, end, days, wday_names, holidays, topics)
plan

Build gt table

build_gt_table <- function(plan) {

  plan %>% 
    mutate(
      class_date = strftime(class_date, format = '%d/%m/%y')
    ) %>% 
    gt() %>% 
    fmt_missing(
      columns = everything(),
      missing_text = ''
    ) %>% 
    cols_label(
      class_date = 'Data',
      weekday = 'Dia',
      class_no = 'Aula',
      contents = 'Conteúdo'
    ) %>% 
    cols_align(
      'right',
      columns = c('class_no', 'class_date')
    ) %>% 
    tab_style(
      style = list(
        cell_text(weight = 'bold'),
        cell_fill()
      ),
      locations = cells_column_labels(
        columns = everything()
      )
    ) %>% 
    tab_style(
      style = cell_text(size = 'large'),
      locations = list(
        cells_column_labels(
          columns = everything()
        ),
        cells_body()
      )
    ) %>% 
    tab_style(
      style = cell_text(indent = px(15)),
      locations = list(
        cells_column_labels(columns = c(weekday, contents)),
        cells_body(columns = c(weekday, contents))
      )
    ) %>% 
    tab_style(
      style = cell_text(indent = px(5)),
      locations = list(
        cells_column_labels(columns = c(class_no)),
        cells_body(columns = c(class_no))
      )
    ) %>% 
    tab_style(
      style = cell_text(
        style = 'italic',
        color = '#777777'
      ),
      locations = cells_body(
        columns = 'contents',
        rows = is.na(class_no)
      )
    ) %>% 
    tab_source_note(
      md(
        paste0(
          'Gerado por [planneR](https://fnaufel.shinyapps.io/planner/): ',
          'https://fnaufel.shinyapps.io/planner/.  ',
          '\n',
          'Desenvolvido por [fnaufel](https://fnaufel.github.io/site), ',
          'com [R](https://cran.r-project.org/), ',
          '[Shiny](https://shiny.rstudio.com/), ',
          'e o pacote [gt.](https://gt.rstudio.com/)  ',
          '\n',
          '[Licença Creative Commons BY-NC-SA.]',
          '(https://creativecommons.org/licenses/by-nc-sa/4.0/deed.pt_BR)  ',
          '\n',
          '[![](https://licensebuttons.net/l/by-nc-sa/4.0/80x15.png)]',
          '(https://creativecommons.org/licenses/by-nc-sa/4.0/deed.pt_BR)'
        )
      )
    )

}

plan_table <- build_gt_table(plan)
plan_table

fnaufel/PlanneR documentation built on March 19, 2022, 4:10 p.m.