Schuljahre 2017-2022

Autor:innen

Zugehörigkeit

Toni Wöhrl

Universität Erfurt

Florian Bähr

Universität Erfurt

Setup and data

library(tidyverse)
library(dplyr)
library(kableExtra)
library(readxl)
library(sf)
library(leaflet)
library(leaflet.extras)
library(leafpop)
library(htmlwidgets)
library(webshot)
library(readxl)
library(reactable)
d <- readxl::read_excel("./data/bekigeki_Urdaten_bis_2022-2023-05-24.xlsx") 

Long data

Component <- c("Star","Run","S20","BPT","SLJ","OLB")

d_long <- d |> 
  pivot_longer(cols=Component,
               names_to = "Component",
               values_to = "score")|>
  mutate(score = as.numeric(score),
        # change 0 values to NA
        score = ifelse(score==0,NA,score))|>
  dplyr::select(-dateiname) |>
  # zScore based on all years
  group_by(Sex, Component) |> 
  mutate(zScore_All  = scale(score),
         q_Upper_All = quantile(score,.80,na.rm=TRUE),
         q_Lower_All = quantile(score,.20,na.rm=TRUE),
         upper_all =ifelse(Component == "Star" | Component == "S20",
                              score <= q_Lower_All,
                              score >= q_Upper_All),
         lower_all =ifelse(Component == "Star" | Component == "S20",
                              score >= q_Upper_All,
                              score <= q_Lower_All))|>  
  # zScore per Year
  ungroup()|>
  group_by(Sex, Component, cohort) |> 
  mutate(zScore_Cohort  = scale(score),
         q_Upper_Cohort = quantile(score,.80,na.rm=TRUE),
         q_Lower_Cohort = quantile(score,.20,na.rm=TRUE),
         upper_cohort =ifelse(Component == "Star" | Component == "S20",
                              score <= q_Lower_Cohort,
                              score >= q_Upper_Cohort),
         lower_cohort =ifelse(Component == "Star" | Component == "S20",
                              score >= q_Upper_Cohort,
                              score <= q_Lower_Cohort)
         )|> 
  ungroup()

Warning: Using an external vector in selections was deprecated in tidyselect 1.1.0.
ℹ Please use `all_of()` or `any_of()` instead.
  # Was:
  data %>% select(Component)

  # Now:
  data %>% select(all_of(Component))

See <https://tidyselect.r-lib.org/reference/faq-external-vector.html>.

d_summary <- d_long |> 
  dplyr::filter(Sex == "m" | Sex == "w")|>
  group_by(Child,Sex) |>
  reframe(
   # Component=Component,
   #  zScore_All=zScore_All,
    Absence = sum(is.na(zScore_All)),
    qUpperAll = sum(upper_all,na.rm=TRUE),
    qLowerAll = sum(lower_all,na.rm = TRUE),
    qUpperCohort = sum(upper_cohort,na.rm=TRUE),
    qLowerCohort = sum(lower_cohort,na.rm=TRUE))|>
  ungroup()|>
  mutate(qAll = qUpperAll - qLowerAll,
         qCohort = qUpperCohort - qLowerCohort)|>
  mutate(
    Fitness_q_All = ifelse(Absence<4,
                           ifelse(qAll <=-2,"F",
                                 ifelse(qAll>=2,"T",
                                         ifelse(qAll<2 & qAll>-2,"N",NA))),NA),
    Fitness_q_Cohort = ifelse(Absence<4,
                              ifelse(qCohort <=-3,"F",
                                     ifelse(qCohort>=3,"T",
                                            ifelse(-qCohort<3 & qCohort>-3,"N",NA))),NA),
    Fitness_q_Cohort_T6 = ifelse(Absence<4,
                                 ifelse(qCohort <=-2,"F",
                                        ifelse(qCohort>=2 & Absence ==0 ,"T",
                                               ifelse((-qCohort<2 & qCohort>-2) | qCohort>=2 & Absence !=0,"N",NA))),NA))

    # 
    # qLowerAll = 
    #   sum((score <= q_Lower_All & (Component!="S20" | Component != "Star")) | 
    #         (score >= q_Upper_All & (Component=="S20" | Component == "Star")),na.rm=TRUE),
    # qUpperAll = 
    #   sum((score >= q_Upper_All & (Component!="S20" | Component != "Star")) |
    #         (score <= q_Lower_All & (Component=="S20" | Component == "Star")),na.rm=TRUE),
    # qLowerCohort = 
    #   sum(((score <= q_Lower_Cohort & (Component!="S20" | Component != "Star")) |
    #         (score >= q_Upper_Cohort & (Component=="S20" | Component == "Star"))),na.rm=TRUE),
    # qUpperCohort = 
    #   sum(((score >= q_Upper_Cohort & (Component!="S20" | Component != "Star")) |
    #         (score <= q_Lower_Cohort & (Component=="S20" | Component == "Star"))),na.rm=TRUE),


r1 <- d_summary |> 
  merge(d[,c("Child","cohort")])|> 
  pivot_longer(cols = c(
                        Fitness_q_All,
                        Fitness_q_Cohort,
                        Fitness_q_Cohort_T6),
               names_to = "Norm",values_to = "Result")|>
  group_by(Norm,Result,cohort)|>
  summarize(Number = n())|>
  pivot_wider(names_from=Norm,values_from = c(Number))|>
  t() |> as.data.frame()

`summarise()` has grouped output by 'Norm', 'Result'. You can override using
the `.groups` argument.

r1

                      V1   V2   V3   V4   V5   V6   V7   V8   V9  V10  V11  V12
Result                 F    F    F    F    F    F    N    N    N    N    N    N
cohort              2017 2018 2019 2020 2021 2022 2017 2018 2019 2020 2021 2022
Fitness_q_All        368 1288 1647  681 1632 3831  787 2721 3139 1097 2771 6124
Fitness_q_Cohort     248  856 1053  352  895 1861 1162 3923 4604 1641 4085 9116
Fitness_q_Cohort_T6  423 1482 1869  628 1603 3331  827 2820 3197 1165 2811 6531
                     V13  V14  V15  V16  V17  V18  V19  V20  V21
Result                 T    T    T    T    T    T <NA> <NA> <NA>
cohort              2017 2018 2019 2020 2021 2022 2017 2021 2022
Fitness_q_All        520 1611 1834  568 1501 2834   38    2   23
Fitness_q_Cohort     265  841  963  353  924 1812   38    2   23
Fitness_q_Cohort_T6  425 1318 1554  553 1490 2927   38    2   23

d_wide <- d_long |>
#  rename(District = Kreis)|>
  pivot_wider(id_cols = c(Child,Sex,cohort,
                          School,Name,District,
                          lat,lon,
                          AGS,
                          Sport,Club,
                          club_1,club_2,club_3,
                          Inclusion),
              names_from = Component,
              values_from = c("score","q_Upper_Cohort","q_Lower_Cohort")) |>
  merge(d_summary) 

t1 <- d_wide |> 
  filter(!is.na(Sport))|>
  filter(!is.na(Club))|>
  group_by(cohort,District,School,Name,Sex,Club,Sport) |>
  summarise(Gesamtzahl = n(),
            `auswertbar` = sum(
              (Sex=="m" | Sex == "w") & 
                Absence < 4 & 
                !is.na(Sport) &
                !is.na(Club) & 
                !is.na(Fitness_q_Cohort)),
            T = sum(Fitness_q_Cohort =="T",na.rm=TRUE),
            F = sum(Fitness_q_Cohort =="F",na.rm=TRUE),
            N = sum(Fitness_q_Cohort =="N",na.rm=TRUE)
            ) |>
  mutate(T_rel = round(T/auswertbar*100),
         F_rel = round(F/auswertbar*100),
         N_rel = round(N/auswertbar*100)
         # check_rel = T_rel + F_rel + N_rel,
         # check = T + F + N - auswertbar
         )|>
  ungroup()

`summarise()` has grouped output by 'cohort', 'District', 'School', 'Name',
'Sex', 'Club'. You can override using the `.groups` argument.

with_tooltip2 <- function(value, tooltip) {
  tags$abbr(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help",
            title = tooltip,value)
}

library(tippy)
with_tooltip <- function(value, tooltip, ...) {
  div(style = "text-decoration: underline; text-decoration-style: dotted; cursor: help",
      tippy(value, tooltip, ...))
}

Tables

Filter definitions

# Render a bar chart in the background of the cell
bar_style <- function(width = 1, fill = "#e6e6e6", height = "75%",
                      align = c("left", "right"), color = NULL) {
  align <- match.arg(align)
  if (align == "left") {
    position <- paste0(width * 100, "%")
    image <- sprintf("linear-gradient(90deg, %1$s %2$s, transparent %2$s)", fill, position)
  } else {
    position <- paste0(100 - width * 100, "%")
    image <- sprintf("linear-gradient(90deg, transparent %1$s, %2$s %1$s)", position, fill)
  }
  list(
    backgroundImage = image,
    backgroundSize = paste("100%", height),
    backgroundRepeat = "no-repeat",
    backgroundPosition = "center",
    color = color
  )
}

bar_chart <- function(label, width = "100%", height = "1rem", fill = "#00bfc4", background = NULL) {
  bar <- div(style = list(background = fill, width = width, height = height))
  chart <- div(style = list(height = height,flexGrow = 1, marginLeft = "0rem",marginRight = "0.5rem", background = background), bar)
 # div(style = list(display = "flex", alignItems = "left"), label, chart)
div(div(style = list(display = "flex", 
                 align = "right"), paste0(label," %")),div(style = list(display = "flex", 
                 alignItems = "center"),chart))

}
# Source: https://glin.github.io/reactable/articles/custom-filtering.html
# 2022-03-23
# Custom range input filter with label and value
rangeFilter1 <- function(tableId, columnId, label, min, max, value = NULL, step = NULL, width = "200px") {
  value <- if (!is.null(value)) value else min
  inputId <- sprintf("filter_%s_%s", tableId, columnId)
  valueId <- sprintf("filter_%s_%s__value", tableId, columnId)
  oninput <- paste(
    sprintf("document.getElementById('%s').textContent = this.value;", valueId),
    sprintf("Reactable.setFilter('%s', '%s', this.value)", tableId, columnId)
  )
  
  div(
    tags$label(`for` = inputId, label),
    div(
      style = sprintf("display: flex; align-items: center; width: %s", validateCssUnit(width)),
      tags$input(
        id = inputId,
        type = "range",
        min = min,
        max = max,
        step = step,
        value = value,
        oninput = oninput,
        onchange = oninput, # For IE11 support
        style = "width: 100%;"
      ),
      span(id = valueId, style = "margin-left: 8px;", value)
    )
  )
}

# Source: https://glin.github.io/reactable/articles/custom-filtering.html
rangeFilter2 <- function(values, name) {
        tags$select(
          # Set to undefined to clear the filter
          onchange = sprintf("Reactable.setFilter('cars-select', '%s', event.target.value || undefined)", name),
          # "All" has an empty value to clear the filter, and is the default option
          tags$option(value = "", "Alle"),
          lapply(unique(values), tags$option),
          "aria-label" = sprintf("Filter %s", name),
          style = "width: 100%; height: 28px;"
        )
}

# Custom range input filter with label and value
rangeFilter <- function(tableId, columnId, label, min, max, value = NULL, step = NULL, width = "200px") {
  value <- if (!is.null(value)) value else min
  inputId <- sprintf("filter_%s_%s", tableId, columnId)
  valueId <- sprintf("filter_%s_%s__value", tableId, columnId)
  oninput <- paste(
    sprintf("document.getElementById('%s').textContent = this.value;", valueId),
    sprintf("Reactable.setFilter('%s', '%s', this.value)", tableId, columnId)
  )
  
  div(
    tags$label(`for` = inputId, label),
    div(
      style = sprintf("display: flex; align-items: center; width: %s", validateCssUnit(width)),
      tags$input(
        id = inputId,
        type = "range",
        min = min,
        max = max,
        step = step,
        value = value,
        oninput = oninput,
        onchange = oninput, # For IE11 support
        style = "width: 100%;"
      ),
      span(id = valueId, style = "margin-left: 8px;", value)
    )
  )
}

# Filter method that filters numeric columns by minimum value
filterMinValue <- JS("function(rows, columnId, filterValue) {
  return rows.filter(function(row) {
    return row.values[columnId] >= filterValue
  })
}")
# Filter method that filters numeric columns by minimum value
filterMinValue <- JS("function(rows, columnId, filterValue) {
  return rows.filter(function(row) {
    return row.values[columnId] >= filterValue
  })
}")

# Source: https://github.com/glin/reactable/blob/HEAD/vignettes/popular-movies/popular-movies.Rmd
# 2023-03-23
select_filter <- function(id, label, shared_data, group, choices = NULL,
                          width = "100%", class = "filter-input") {
  values <- shared_data$data()[[group]]
  keys <- shared_data$key()
  if (is.list(values)) {
    # Multiple values per row
    flat_keys <- unlist(mapply(rep, keys, sapply(values, length)))
    keys_by_value <- split(flat_keys, unlist(values), drop = TRUE)
    choices <- if (is.null(choices)) sort(unique(unlist(values))) else choices
  } else {
    # Single value per row
    keys_by_value <- split(seq_along(keys), values, drop = TRUE)
    choices <- if (is.null(choices)) sort(unique(values)) else choices
  }

  script <- sprintf("
    window['__ct__%s'] = (function() {
      const handle = new window.crosstalk.FilterHandle('%s')
      const keys = %s
      return {
        filter: function(value) {
          if (!value) {
            handle.clear()
          } else {
            handle.set(keys[value])
          }
        }
      }
    })()
  ", id, shared_data$groupName(), toJSON(keys_by_value))

  div(
    class = class,
    tags$label(`for` = id, label),
    tags$select(
      id = id,
      onchange = sprintf("window['__ct__%s'].filter(this.value)", id),
      style = sprintf("width: %s", validateCssUnit(width)),
      tags$option(value = "", "Alle"),
      lapply(choices, function(value) tags$option(value = value, value))
    ),
    tags$script(HTML(script))
  )
}

# https://glin.github.io/reactable/articles/custom-filtering.html
# 2023-02-23
# Creates a data list column filter for a table with the given ID
dataListFilter <- function(tableId, style = "width: 100%; height: 28px;") {
  function(values, name) {
    dataListId <- sprintf("%s-%s-list", tableId, name)
    tagList(
      tags$input(
        type = "text",
        list = dataListId,
        oninput = sprintf("Reactable.setFilter('%s', '%s', event.target.value || undefined)", tableId, name),
        "aria-label" = sprintf("Filter %s", name),
        style = style
      ),
      tags$datalist(
        id = dataListId,
        lapply(unique(values), function(value) tags$option(value = value))
      )
    )
  }
}

Shared HTML Table

library(crosstalk)
# shared table
t2 <- t1 |> select(-Gesamtzahl,-T_rel,-F_rel,-N_rel)
shared_data <- SharedData$new(t2)

# styles
sticky_style <- list(backgroundColor = "#f7f7f7")
sticky_style_r <- list(borderTop = "0px solid #eee",borderLeft = "0px solid #eee",borderRight = "0px solid #eee")

rotate_header_style<- list(
          `white-space` = "nowrap",
          `transform-origin` = "0% 50%",
           transform = "rotate(-90deg)",
          `margin-top` = "10px",
          `margin-bottom` = "10px",
           borderColor = "#ffffff"
        )
small_header_style <- list(`font-size` =  "10px")
sticky_style_l <- list(borderLeft = "0px solid #eee")

library(htmltools)
# reactable
tbl<-reactable(
  shared_data,
  defaultColDef = colDef(
  #  headerStyle = sticky_style_r,
    align = "right",
    footerStyle = list(fontWeight = "bold"),
    #   maxWidth = 120,
    vAlign="top"),
  searchable = TRUE,
  resizable = TRUE,
  wrap = TRUE,
  pagination=TRUE,
  paginateSubRows = TRUE,
  # paginationType = "jump", 
  defaultPageSize = 10,
  showSortable = TRUE,
  bordered = FALSE,
  compact=TRUE,
  # details = function(index) {
  #t1$Name[index]},
  #  onClick = "select",
  #height = 800,
  #  width=600,
  # defaultPageSize = 20,
  striped = TRUE,
  #elementId = "cars-vis-table",
  elementId = "cars-grouping-table",
  highlight = TRUE,
  
  filterable = FALSE,
  groupBy = c("cohort"),
  columns = list(
    Sport = colDef(name = "Sport-AG",
                   align="left",
                   width=70,
                   headerStyle = small_header_style,
                   filterable = FALSE),
    cohort = colDef(name = "Jahr",
                    align="left",
                    minWidth=60,
                    headerStyle = small_header_style,
                    filterable = FALSE),
    Sex = colDef(name="Geschlecht",
                 align="left",
                 width=70,
                 sortable = FALSE,
                 #  width = 50,
                      headerStyle = small_header_style,
                 filterable=FALSE),
    Club = colDef(name="Verein",
                  sortable = FALSE,
                  filterable=FALSE,
                  width=60,
                      headerStyle = small_header_style,
                  align="left"),
    Name = colDef(name = "Schule",
                  sortable = TRUE,
                  show=TRUE,
                  minWidth = 100,
                  align="left",
                  headerStyle = small_header_style,
                  #style = "font-weight: 100",
                  # Show species under character names
                  cell = function(value, index) {
                    School<- t1$School[index]
                    School <- if (!is.na(School)) School else "Unknown"
                    div(
                      div(style = "font-weight: 100", value),
                      div(style = "font-size: 0.75rem", School)
                    )
                  }),
    School = colDef(show=FALSE,
                    minWidth = 100,
                    headerStyle = small_header_style,
                    sortable = TRUE), #Schulnummer
    #  School = colDef(show=FALSE),
    District = colDef(name="Kreis",
                      minWidth = 80,
                      headerStyle = small_header_style,
                      show=TRUE,align="left",sortable = TRUE),
    # Gesamtzahl= colDef(name="N",
    #                    width=90,
    #                    align = "right",
    #           aggregate = "sum",
    #           html=TRUE,
    #         
    #        #   footer = function(values) 
    #         #    sprintf("&#x2211; %.0f", 
    #          #           #sum(shared_data$Gesamtzahl)
    #           #           sum(values)
    #                     
    #            #         )
    #               footer = JS("function(colInfo) {
    #     var total = 0
    #     colInfo.data.forEach(function(row) {
    #       total += row['Gesamtzahl']
    #     })
    #     return '&#x2211; ' + total.toFixed(0)
    #   }")
    #           ),
    auswertbar= colDef(name="N<sub>a</sub>",
                       html=TRUE,
                       width=90,
                       headerStyle = small_header_style,
                       header = with_tooltip("Gesamtzahl <div style=\"font-size: 10px; font-weight:normal\"> (Anzahl auswertbar)</div>","vollständig auswertbare Datensätze für diese Darstellungsform (Teilnahme an mind. 4 Testaufgaben, Information zu Geschlecht, Verein UND Sport-AG vorhanden)"),
                       align = "right",
                       sticky = "right",
                       aggregate = "sum",
                       #   footer = function(values) 
                       #    sprintf("&#x2211; %.0f", sum(values))
                       #https://github.com/glin/reactable/issues/78
                       footer = JS("function(colInfo) {
        var total = 0
        colInfo.data.forEach(function(row) {
          total += row['auswertbar']
        })
        return '&#x2211; ' + total.toFixed(0)
      }")
    ),
    T= colDef(align = "right",
              name="positiv",
              html=TRUE,
              width=80,
              headerStyle = small_header_style,
              header = with_tooltip("positiv <div style=\"font-size: 10px; font-weight:normal\"> (Anzahl)</div>","'Potentielle Talente:' Anzahl an Schülerinnen und Schülern, die an mindestens vier Motorik-Tests teilnahmen UND mindestens zweimal öfter Testergebnisse im oberen Quintil als im unteren Quintil in Bezug auf die Gesamtstichprobe aus Thüringen für das jeweilige Jahr und Geschlecht erzielten."),
              aggregate = "sum",
              #  footer = function(values) 
              #     sprintf("%.0f", sum(values))
              footer = JS("function(colInfo) {
        var total = 0
        colInfo.data.forEach(function(row) {
          total += row['T']
        })
        return '&#x2211; ' + total.toFixed(0)
      }")
    ),
    F= colDef(align = "right",
              name="negativ",
              html=TRUE,
              headerStyle = small_header_style,
              header = with_tooltip("negativ <div style=\"font-size: 10px; font-weight:normal\"> (Anzahl)</div>","'Eventueller Förderbedarf:' Anzahl an Schülerinnen und Schülern, die an mindestens vier Motorik-Tests teilnahmen UND die mindestens zweimal öfter Testergebnisse im unteren Quintil als im oberen Quintil in Bezug auf die Gesamtstichprobe aus Thüringen für das jeweilige Jahr und Geschlecht erzielten."),
              width=60,
              aggregate = "sum",
              #  footer = function(values) 
              #     sprintf("%.0f", sum(values))
              footer = JS("function(colInfo) {
        var total = 0
        colInfo.data.forEach(function(row) {
          total += row['F']
        })
        return '&#x2211; ' + total.toFixed(0)
      }")
    ),
    N= colDef(align = "right",
              name="unauffällig",
              html=TRUE,
              headerStyle = small_header_style,
              sticky = "right",
             
              header = with_tooltip("unauffällig <div style=\"font-size: 10px; font-weight:normal\"> (Anzahl)</div>","'Erwartungsgemäß:' Anzahl an Schülerinnen und Schülern, die an mindestens vier Motorik-Tests teilnahmen UND für die NICHT die anderen beiden Bedingungen zutreffen (siehe Tooltips)."),
              width=70,
              aggregate = "sum",
              #  footer = function(values) 
              #     sprintf("%.0f", sum(values))
              footer = JS("function(colInfo) {
        var total = 0
        colInfo.data.forEach(function(row) {
          total += row['N']
        })
        return '&#x2211; ' + total.toFixed(0)
      }")
            )),
columnGroups = list(
  colGroup(
  name = "motorisch auffällig", 
  sticky = "right",
           columns = c(
                       "T","F"))
  # colGroup(name = "Gesamtzahl", 
  #          sticky="left",
  #          columns = c("Gesamtzahl", 
  #                      "auswertbar"))
  
 ))
 

library(jsonlite)

Interaktive Tabelle

Filter:

Jahr Alle 2017 2018 2019 2020 2021 2022

Kreis Alle Altenburger Land Eichsfeld Eisenach, Stadt Erfurt, Stadt Gera, Stadt Gotha Greiz Hildburghausen Ilm-Kreis Jena, Stadt Kyffhäuserkreis Nordhausen Saale-Holzland-Kreis Saale-Orla-Kreis Saalfeld-Rudolstadt Schmalkalden-Meiningen Sömmerda Sonneberg Suhl, Stadt Unstrut-Hainich-Kreis Wartburgkreis Weimar, Stadt Weimarer Land

Geschlecht Alle m w

Sport-AG Alle ja nein

Vereinsmitgliedschaft Alle ja nein

Gruppierung

Keine Jahr Kreis Geschlecht Schule Sport-AG Vereinsmitgliedschaft

TODO

• Vereinigung mit Daten aus Schuljahr 2023/2024
• Erläuterungen
• Dokumentenarchiv

Aktualisierungen

• 2024-03-28: Umzug ins “Archiv”
• 2023-05-17: Kriterien positiv/negativ motor. auffällig
• 2023-05-10: Download als CSV Button, paginateSubRows
• 2023-04-25: Anpassung Spalten der Tabelle (Entfernen der Barcharts Prozentangaben)
• 2023-04-24: Erstellen der Seite

Wiederverwendung

Zitat

Bitte zitieren Sie diese Arbeit als:

Wöhrl, T., & Bähr, F. (2023, April 24). Schuljahre 2017-2022. https://bekigeki.github.io/002.html