R/report_table.r

In sooyongl/ESS:

#' @include tab_function.r
#'
tab2_table_effpage <- function(dataInp) {

    dataInp <- dataInp %>%
      select(-ends_with("_p")) %>%
      mutate(
        # Table = if_else(Table == 0, "All", as.character(Table)),
        Correlation = round(Correlation, 3)
      )

    dataUse_1 <- dataInp

    ln <- names(dataUse_1)[str_detect(names(dataUse_1), "_W")]
    ln <-
      str_split(ln, "_W") %>%
      map(., ~ .x[[1]]) %>%
      unlist() %>%
      str_replace(., "L", "Level")

    level_break <-
      foreach(lll = 1:length(ln), .combine = 'c') %do% {
        a1 <- ln[lll]
        glue::glue("'{a1}' = 2")
      } %>% paste(., collapse = ", ")


    level_break <- glue::glue('c(" " = 3, {level_break},"SUM" = 2)')

    dataUse_1 %>%
      knitr::kable(format = "html", escape = F,
                   align = 'c') %>%
      kable_styling(
        c("striped","condensed"),
        full_width = F,
        font_size = 13
      ) %>%

      row_spec(0, bold = T) %>%

      add_header_above(
        eval(parse(text =level_break))
      )
  }
#
tab2_table <-
  function(dataInp, WESS = information$base_data$WESS_nm) {

    dataUse_1 <- dataInp

    ln_0 <- names(dataUse_1)[(which(names(dataUse_1) == "ALD")+1):(ncol(dataUse_1)-1)]
    ln <- sort(ln_0)

    new_order_name <- c( names(dataUse_1)[1:which(names(dataUse_1) == "ALD")], ln,
                         names(dataUse_1)[ncol(dataUse_1)])

    dataUse_1 <- dataUse_1 %>% select(all_of(new_order_name))

    coloring <- function(x) {
      cell_spec(x, "html", background = ifelse(x == min(x),
                                               "#00FFFD", "transparent"))
    }

    oplv <- dataUse_1 %>% pull(Operational_Lv)
    oplv_names <- oplv %>% unique()

    kable.line <- c()
    for(oi in 1:length(oplv_names)){
      o_p <- which(oplv == oplv_names[oi])
      kable.line[oi] <- o_p[length(o_p)]
    }

    unselect <- (which(names(dataUse_1) == "GCA")+1):(which(names(dataUse_1) == "Item_ID")-1)

    selected <- names(dataUse_1)[-unselect]

    dataUse_1 <-
      dataUse_1 %>%
      select(all_of(selected))

    if(WESS){
      ln_1 <- ln_0[str_detect(ln_0, "_W")]
    } else {
      ln_1 <- ln_0[!str_detect(ln_0, "_W")]
    }
    shading_cols <- which(names(dataUse_1) %in% ln_1)

    lvs <- ln_0[!str_detect(ln_0, "_W")]

    level_break <-
      foreach(lll = 1:length(lvs), .combine = 'c') %do% {
        a1 <- lvs[lll]
        glue::glue("'{a1}' = 2")
      } %>% paste(., collapse = ", ")


    level_break <- glue::glue('c(" " = 5, {level_break}," " = 1)')

    aa <- ncol(dataUse_1)

    dataUse_1 %>%
      mutate_at(ln, list(coloring)) %>%
      mutate(Operational_Lv =
               cell_spec(Operational_Lv,
                         background =
                           eval(parse(text = gen_ifelse("Operational_Lv",oplv_names)
                           )
                           )
               )
      ) %>%
      knitr::kable(format = "html", escape = F,
                   align = 'c') %>%
      kable_styling(
        c("striped","condensed"),
        full_width = F,
        font_size = 13
      ) %>%
      column_spec(aa, bold = T, border_left = T) %>%
      column_spec(shading_cols, background = "#D8E0DF") %>%
      # column_spec(1:ncol(dataUse_1), align = "center") %>%
      row_spec(0, bold = T) %>%
      collapse_rows(., columns = 1:2, valign = "top") %>%

      row_spec(., kable.line, extra_css = "border-bottom: 1px solid") %>%
      add_header_above(
        eval(parse(text =level_break))
      )
  }

#'

tab2_table_crosst <- function(crosstabs){
  ct_1 <- crosstabs

  num_level <- ncol(ct_1)
  ct_1 <- as.data.frame.matrix(ct_1) %>%
    mutate(".." := rownames(.),
           .before = 1) %>%
    mutate("." := "Operational Level",
           .before = 1)

  rownames(ct_1) <- NULL

  ct_1 %>%
    kable() %>%
    kable_styling(
      c("striped"),
      full_width = F,
      font_size = 14
    ) %>%
    column_spec(
      1,
      bold = T,
      width="3em",extra_css="transform: rotate(-90deg);"
    ) %>%
    collapse_rows(., columns = 1, valign = "middle") %>%
    add_header_above( c(" " = 2, "Aligned_ALD" = num_level ))
}

#'
tab3_table_pagetb <- function(tab3) {

  page_data <- tab3$eff_page %>% data.frame()

  forline <- page_data %>% pull(1) %>% unique() %>% length()
  kable.line <- 1:forline
  for(fl in 1:forline){
    kable.line[fl] <- 5*fl + 0
  }

  effpage <-
    page_data %>%
    kable(.,"html", escape = F, align = "c",
          table.attr = "style='width:50%;'") %>%
    kable_styling(bootstrap_options = c("striped"),
                  # full_width = F,
                  position = "left",
                  font_size = 18,
                  fixed_thead = T) %>%
    row_spec(1:nrow(page_data), color = "black") %>%
    row_spec(0, angle = 0,
             background = "floralwhite",
             extra_css = "border-bottom: 1px solid") %>%
    collapse_rows(columns = 1:2, valign = "top") %>%
    row_spec(., kable.line, extra_css = "border-bottom: 1px solid")

  effpage
}

tab3_plots <- function(tab3) {

  p_page1 <-
    tab3$scale_scores %>%
    ggplot() +
    geom_line(aes(x = GCA, y = scaleScore,
                  colour = Level, group = Level),size = 2) +
    geom_text(aes(label = scaleScore,
                  x = GCA, y = scaleScore, group = Level), size = 6,
              vjust = 1) +
    labs(title = "Scale Score Cut Scores",
         y = "Scale Score Cut Scores") +
    theme_bw(base_size = 20) +
    scale_color_brewer(palette="Paired")



  p_page2 <-
    tab3$perc_ins %>%
    mutate(Level = factor(Level),
           Level = factor(Level, levels = rev(levels(Level)))
    ) %>%
    ggplot() +
    geom_col(aes(x = GCA, y = percIn, fill = Level)) +
    geom_text(aes(label = percIn,
                  x = GCA, y = percIn, group = Level),
              size = 6,
              position = position_stack(vjust = .5)) +
    labs(title = "Percentage in Level",
         y =  "Percentage in Level") +
    theme_bw(base_size = 20) +
    scale_fill_brewer(palette="Paired")


  p_page3 <-
    tab3$perc_atabos %>%
    ggplot() +
    geom_line(
      aes(x = GCA, y = percAtabo, colour = Level, group = Level),
      size = 1.5) +
    geom_text(aes(label = percAtabo,
                  x = GCA, y = percAtabo, group = Level), size = 6,
              vjust = 1) +

    labs(title = "Percentage At or Above Cut Score",
         y = "Percentage At or Above Cut Score") +
    theme_bw(base_size = 20) +
    scale_color_brewer(palette="Paired")

  list(p_page1 = p_page1, p_page2 = p_page2, p_page3 = p_page3)
}

#'
tab4_table_review <- function(tab4) {

  maxRow <- nrow(tab4$for_tab4_out)
  grades <- tab4$for_tab4_out %>% pull(1) %>% unique()
  colors <- c('#DAF7A6',"#A6B1F7","#A6F7C3","#A6DAF7","#FFC300")

  tab4_out <- tab4$for_tab4_out

  item_review <-
    DT::datatable(tab4_out,
                  rownames = F,
                  options = table_options_new_2(maxRow)
    ) %>%
    formatStyle(1,
                backgroundColor = styleEqual(grades,colors[1:length(grades)])
    )

  item_review
}