Introduction

Vụ gian lận thi cử trong năm 2018 đã được nhiều báo chí đưa tin (ví dụ, ở đây). Với dữ liệu có được và cũng chỉ bằng hình ảnh hóa dữ liệu chúng ta có thể có cơ sở để nghi ngờ rằng có gian lận, ví dụ, ở điểm thi môn Toán ở Hà Giang:

Plot này chỉ ra rằng mức độ tập trung các thí sinh có điểm thi Toán cao của Hà Giang là cao hơn so với phần còn lại. Và thậm chí còn cao hơn so với Hà Nội. Đây rõ ràng là một bất thường.

Nếu chưa hiểu ý nghĩa của loại plot này bạn đọc có thể tham khảo ở đây.

R codes

Bộ dữ liệu về điểm thi quốc gia năm 2018 có thể download ở đây trong đó có một cột biến là SoBD là số báo danh của thí sinh. Hai số đầu tiên của số báo danh chính là mã tỉnh. Do vậy trước hết chúng ta lấy dữ liệu về mã tỉnh trong kì thi này:

# Load some R packages: 

library(rvest)
library(tidyverse)
library(stringi)

# URL for collecting data: 

base_url <- "https://thuvienphapluat.vn/cong-van/Giao-duc/Cong-van-417-BGDDT-KTKDCLGD-huong-dan-thuc-hien-Quy-che-thi-trung-hoc-pho-thong-quoc-gia-2017-339311.aspx"

# Collect data: 

base_url %>% 
  read_html() %>% 
  html_nodes(xpath = '//*[@id="divContentDoc"]/div/div/div/table[7]') %>% 
  html_table() %>% 
  .[[1]] -> df_sbd

# Convert text to Latin character: 

df_sbd %>% 
  mutate_all(function(x) {stri_trans_general(x, "Latin-ASCII")}) %>% 
  slice(-1) -> df_sbd_latin

# Select and rename for some columns: 

df_sbd_latin %>% 
  select(code = X1, province = X2) %>% 
  mutate(province = str_replace_all(province, "So GDDT ", "")) -> df_sbd_latin

Những thí sinh có số báo danh mà bắt đầu là 0 ở đầu thì sẽ bị xóa, do vậy chúng ta cần cho thêm số 0 vào những cases này để khôi phục lại số báo danh gốc:

# Load data: 

df_score <- read_csv("C:/Users/Admin/Documents/THPT 2018 Quoc gia.csv")

# Extract province code: 

df_score %>% 
  mutate(SoBD = as.character(SoBD)) %>% 
  mutate(SoBD = case_when(str_count(SoBD) == 7 ~ paste0("0", SoBD), TRUE ~ SoBD)) %>% 
  mutate(code = str_sub(SoBD, start = 1, end = 2)) -> df_score

# Join data sets: 

full_join(df_score, df_sbd_latin, by = "code") -> df_final

Với dữ liệu đã có chúng ta có thể dùng công cụ hình ảnh (Data Visualization) để so sánh phân bố điểm thi toán của Hà Giang và các tỉnh thành còn lại như sau:

# Prepare data for ploting: 

df_final %>% 
  select(Math, province) %>%
  na.omit() %>%  
  mutate(province = case_when(province == "Ha Giang" ~ "Ha Giang", TRUE ~ "Others")) -> math


math_mean_by_province <- math %>% 
  group_by(province) %>% 
  summarise(tb = mean(Math)) %>% 
  ungroup()

# Plot distribution of math scores: 

my_font <- "Ubuntu Condensed"
my_colors <- c("Tomato", "#377eb8")

math %>% 
  ggplot(aes(Math, fill = province, color = province)) + 
  geom_density(alpha = 0.2) -> draft

# Decor our draft plot: 

draft + 
  geom_vline(data = math_mean_by_province %>% filter(province == "Ha Giang"), 
             aes(xintercept = tb), linetype = "dashed", color = my_colors[1]) + 
  geom_vline(data = math_mean_by_province %>% filter(province != "Ha Giang"), 
             aes(xintercept = tb), linetype = "dashed", color = my_colors[2]) + 
  annotate("text", 
           label = "Math scores are\n  unusually high", family = my_font, 
           x = 8.2, y = 0.105, size = 4, hjust = -0.2, vjust = 1, color = "grey20") + 
  annotate("curve", 
           curvature = 0,
           x = 9, 
           xend = 9,
           y = 0.07, 
           yend = 0.019,
           arrow = arrow(angle = 20, length = unit(.3, "cm")), size = 0.3) + 
  scale_y_continuous(labels = scales::percent, 
                     breaks = seq(0, 0.4, 0.1), expand = c(0.07, 0)) + 
  labs(x = NULL, y = NULL, 
       title = "Math Score Distribution by Ha Giang and Others", 
       caption = "Data Source: Ministry of Education and Training") + 
  theme_minimal() + 
  theme(legend.position = "top") + 
  theme(panel.grid = element_line(size = 0.2)) + 
  theme(plot.title = element_text(family = my_font, size = 20)) + 
  theme(axis.text = element_text(family = my_font, size = 13)) + 
  theme(plot.caption = element_text(family = my_font, size = 10, vjust = -2, colour = "grey30", face = "italic")) + 
  theme(plot.margin = unit(rep(1, 4), "cm")) + 
  theme(legend.title = element_blank()) + 
  theme(legend.text = element_text(family = my_font, size = 11, color = "grey30")) + 
  theme(plot.background = element_rect(fill = "seashell", color = NA)) + 
  scale_color_manual(values = my_colors) + 
  scale_fill_manual(values = my_colors)

Conclusion

Chỉ bằng hình ảnh hóa dữ liệu chúng ta có thể tìm ra nhiều insights có ý nghĩa. Như trong trường hợp này là tìm ra bằng chứng để nghi ngờ rằng có sự gian lận một cách có hệ thống trong kì thi quốc gia 2018. Và thực tế đúng là vậy.

LS0tDQp0aXRsZTogJ01hdGggU2NvcmUgRGlzdHJpYnV0aW9uIGJ5IEhhIEdpYW5nJw0KYXV0aG9yOiAnQXV0aG9yOiBOZ3V5ZW4gQ2hpIER1bmcnDQpzdWJ0aXRsZTogIkRhaWx5IEdyYXBoIFNlcmllcyINCm91dHB1dDoNCiAgaHRtbF9kb2N1bWVudDogDQogICAgY29kZV9kb3dubG9hZDogdHJ1ZQ0KICAgICMgY29kZV9mb2xkaW5nOiBoaWRlDQogICAgaGlnaGxpZ2h0OiB6ZW5idXJuDQogICAgIyBudW1iZXJfc2VjdGlvbnM6IHllcw0KICAgIHRoZW1lOiAiZmxhdGx5Ig0KICAgIHRvYzogVFJVRQ0KICAgIHRvY19mbG9hdDogVFJVRQ0KLS0tDQoNCmBgYHtyIHNldHVwLGluY2x1ZGU9RkFMU0V9DQprbml0cjo6b3B0c19jaHVuayRzZXQoZWNobyA9IFRSVUUsIHdhcm5pbmcgPSBGQUxTRSwgbWVzc2FnZSA9IEZBTFNFLCBmaWcud2lkdGggPSAxMCwgZmlnLmhlaWdodCA9IDYsIGV2YWwgPSBGQUxTRSkNCmBgYA0KDQoNCiMgSW50cm9kdWN0aW9uDQoNClbhu6UgZ2lhbiBs4bqtbiB0aGkgY+G7rSB0cm9uZyBuxINtIDIwMTggxJHDoyDEkcaw4bujYyBuaGnhu4F1IGLDoW8gY2jDrSDEkcawYSB0aW4gKHbDrSBk4bulLCBb4bufIMSRw6J5XShodHRwczovL2xhb2Rvbmcudm4vaW5mb2dyYXBoaWMvdnUtZ2lhbi1sYW4tdGhpLWN1LW8taG9hLWJpbmgtY2hpLXRpZXQtbXVjLWFuLWN1YS0xNS1iaS1jYW8tODA3MDg4LmxkbykpLiBW4bubaSBk4buvIGxp4buHdSBjw7MgxJHGsOG7o2MgdsOgIGPFqW5nIGNo4buJIGLhurFuZyBow6xuaCDhuqNuaCBow7NhIGThu68gbGnhu4d1IGNow7puZyB0YSBjw7MgdGjhu4MgY8OzIGPGoSBz4bufIMSR4buDIG5naGkgbmfhu50gcuG6sW5nIGPDsyBnaWFuIGzhuq1uLCB2w60gZOG7pSwg4bufIMSRaeG7g20gdGhpIG3DtG4gVG/DoW4g4bufIEjDoCBHaWFuZzogDQoNCg0KIVtdKEM6L1VzZXJzL0FkbWluL0Rlc2t0b3AvZGllbV90aGkuanBnKQ0KDQpQbG90IG7DoHkgY2jhu4kgcmEgcuG6sW5nICoqbeG7qWMgxJHhu5kgdOG6rXAgdHJ1bmcgY8OhYyB0aMOtIHNpbmggY8OzIMSRaeG7g20gdGhpIFRvw6FuIGNhbyBj4bunYSBIw6AgR2lhbmcgbMOgIGNhbyBoxqFuIHNvIHbhu5tpIHBo4bqnbiBjw7JuIGzhuqFpKiouIFbDoCB0aOG6rW0gY2jDrSBjw7JuIGNhbyBoxqFuIHNvIHbhu5tpIEjDoCBO4buZaS4gxJDDonkgcsO1IHLDoG5nIGzDoCBt4buZdCBi4bqldCB0aMaw4budbmcuIA0KDQpO4bq/dSBjaMawYSBoaeG7g3Ugw70gbmdoxKlhIGPhu6dhIGxv4bqhaSBwbG90IG7DoHkgYuG6oW4gxJHhu41jIGPDsyB0aOG7gyB0aGFtIGto4bqjbyBb4bufIMSRw6J5XShodHRwczovL3d3dy55b3V0dWJlLmNvbS93YXRjaD92PVNtNXhGLVVZZ2RnKS4gDQoNCiMgUiBjb2Rlcw0KDQpC4buZIGThu68gbGnhu4d1IHbhu4EgxJFp4buDbSB0aGkgcXXhu5FjIGdpYSBuxINtIDIwMTggY8OzIHRo4buDIGRvd25sb2FkIFvhu58gxJHDonldKGh0dHA6Ly93d3cubWVkaWFmaXJlLmNvbS9maWxlL3YwNGI0N2JpOGRhZDQ3bi9USFBUXzIwMThfUXVvY19naWEuY3N2L2ZpbGUpIHRyb25nIMSRw7MgY8OzIG3hu5l0IGPhu5l0IGJp4bq/biBsw6AgU29CRCBsw6Agc+G7kSBiw6FvIGRhbmggY+G7p2EgdGjDrSBzaW5oLiBIYWkgc+G7kSDEkeG6p3UgdGnDqm4gY+G7p2Egc+G7kSBiw6FvIGRhbmggY2jDrW5oIGzDoCBtw6MgdOG7iW5oLiBEbyB24bqteSB0csaw4bubYyBo4bq/dCBjaMO6bmcgdGEgbOG6pXkgZOG7ryBsaeG7h3UgduG7gSBtw6MgdOG7iW5oIHRyb25nIGvDrCB0aGkgbsOgeTogDQoNCg0KYGBge3J9DQojIExvYWQgc29tZSBSIHBhY2thZ2VzOiANCg0KbGlicmFyeShydmVzdCkNCmxpYnJhcnkodGlkeXZlcnNlKQ0KbGlicmFyeShzdHJpbmdpKQ0KDQojIFVSTCBmb3IgY29sbGVjdGluZyBkYXRhOiANCg0KYmFzZV91cmwgPC0gImh0dHBzOi8vdGh1dmllbnBoYXBsdWF0LnZuL2NvbmctdmFuL0dpYW8tZHVjL0NvbmctdmFuLTQxNy1CR0REVC1LVEtEQ0xHRC1odW9uZy1kYW4tdGh1Yy1oaWVuLVF1eS1jaGUtdGhpLXRydW5nLWhvYy1waG8tdGhvbmctcXVvYy1naWEtMjAxNy0zMzkzMTEuYXNweCINCg0KIyBDb2xsZWN0IGRhdGE6IA0KDQpiYXNlX3VybCAlPiUgDQogIHJlYWRfaHRtbCgpICU+JSANCiAgaHRtbF9ub2Rlcyh4cGF0aCA9ICcvLypbQGlkPSJkaXZDb250ZW50RG9jIl0vZGl2L2Rpdi9kaXYvdGFibGVbN10nKSAlPiUgDQogIGh0bWxfdGFibGUoKSAlPiUgDQogIC5bWzFdXSAtPiBkZl9zYmQNCg0KIyBDb252ZXJ0IHRleHQgdG8gTGF0aW4gY2hhcmFjdGVyOiANCg0KZGZfc2JkICU+JSANCiAgbXV0YXRlX2FsbChmdW5jdGlvbih4KSB7c3RyaV90cmFuc19nZW5lcmFsKHgsICJMYXRpbi1BU0NJSSIpfSkgJT4lIA0KICBzbGljZSgtMSkgLT4gZGZfc2JkX2xhdGluDQoNCiMgU2VsZWN0IGFuZCByZW5hbWUgZm9yIHNvbWUgY29sdW1uczogDQoNCmRmX3NiZF9sYXRpbiAlPiUgDQogIHNlbGVjdChjb2RlID0gWDEsIHByb3ZpbmNlID0gWDIpICU+JSANCiAgbXV0YXRlKHByb3ZpbmNlID0gc3RyX3JlcGxhY2VfYWxsKHByb3ZpbmNlLCAiU28gR0REVCAiLCAiIikpIC0+IGRmX3NiZF9sYXRpbg0KDQpgYGANCg0KTmjhu69uZyB0aMOtIHNpbmggY8OzIHPhu5EgYsOhbyBkYW5oIG3DoCBi4bqvdCDEkeG6p3UgbMOgIDAg4bufIMSR4bqndSB0aMOsIHPhur0gYuG7iyB4w7NhLCBkbyB24bqteSBjaMO6bmcgdGEgY+G6p24gY2hvIHRow6ptIHPhu5EgMCB2w6BvIG5o4buvbmcgY2FzZXMgbsOgeSDEkeG7gyBraMO0aSBwaOG7pWMgbOG6oWkgc+G7kSBiw6FvIGRhbmggZ+G7kWM6IA0KDQoNCmBgYHtyfQ0KIyBMb2FkIGRhdGE6IA0KDQpkZl9zY29yZSA8LSByZWFkX2NzdigiQzovVXNlcnMvQWRtaW4vRG9jdW1lbnRzL1RIUFQgMjAxOCBRdW9jIGdpYS5jc3YiKQ0KDQojIEV4dHJhY3QgcHJvdmluY2UgY29kZTogDQoNCmRmX3Njb3JlICU+JSANCiAgbXV0YXRlKFNvQkQgPSBhcy5jaGFyYWN0ZXIoU29CRCkpICU+JSANCiAgbXV0YXRlKFNvQkQgPSBjYXNlX3doZW4oc3RyX2NvdW50KFNvQkQpID09IDcgfiBwYXN0ZTAoIjAiLCBTb0JEKSwgVFJVRSB+IFNvQkQpKSAlPiUgDQogIG11dGF0ZShjb2RlID0gc3RyX3N1YihTb0JELCBzdGFydCA9IDEsIGVuZCA9IDIpKSAtPiBkZl9zY29yZQ0KDQojIEpvaW4gZGF0YSBzZXRzOiANCg0KZnVsbF9qb2luKGRmX3Njb3JlLCBkZl9zYmRfbGF0aW4sIGJ5ID0gImNvZGUiKSAtPiBkZl9maW5hbA0KDQpgYGANCg0KVuG7m2kgZOG7ryBsaeG7h3UgxJHDoyBjw7MgY2jDum5nIHRhIGPDsyB0aOG7gyBkw7luZyBjw7RuZyBj4bulIGjDrG5oIOG6o25oIChEYXRhIFZpc3VhbGl6YXRpb24pIMSR4buDIHNvIHPDoW5oIHBow6JuIGLhu5EgxJFp4buDbSB0aGkgdG/DoW4gY+G7p2EgSMOgIEdpYW5nIHbDoCBjw6FjIHThu4luaCB0aMOgbmggY8OybiBs4bqhaSBuaMawIHNhdTogDQoNCmBgYHtyfQ0KDQojIFByZXBhcmUgZGF0YSBmb3IgcGxvdGluZzogDQoNCmRmX2ZpbmFsICU+JSANCiAgc2VsZWN0KE1hdGgsIHByb3ZpbmNlKSAlPiUNCiAgbmEub21pdCgpICU+JSAgDQogIG11dGF0ZShwcm92aW5jZSA9IGNhc2Vfd2hlbihwcm92aW5jZSA9PSAiSGEgR2lhbmciIH4gIkhhIEdpYW5nIiwgVFJVRSB+ICJPdGhlcnMiKSkgLT4gbWF0aA0KDQoNCm1hdGhfbWVhbl9ieV9wcm92aW5jZSA8LSBtYXRoICU+JSANCiAgZ3JvdXBfYnkocHJvdmluY2UpICU+JSANCiAgc3VtbWFyaXNlKHRiID0gbWVhbihNYXRoKSkgJT4lIA0KICB1bmdyb3VwKCkNCg0KIyBQbG90IGRpc3RyaWJ1dGlvbiBvZiBtYXRoIHNjb3JlczogDQoNCm15X2ZvbnQgPC0gIlVidW50dSBDb25kZW5zZWQiDQpteV9jb2xvcnMgPC0gYygiVG9tYXRvIiwgIiMzNzdlYjgiKQ0KDQptYXRoICU+JSANCiAgZ2dwbG90KGFlcyhNYXRoLCBmaWxsID0gcHJvdmluY2UsIGNvbG9yID0gcHJvdmluY2UpKSArIA0KICBnZW9tX2RlbnNpdHkoYWxwaGEgPSAwLjIpIC0+IGRyYWZ0DQoNCiMgRGVjb3Igb3VyIGRyYWZ0IHBsb3Q6IA0KDQpkcmFmdCArIA0KICBnZW9tX3ZsaW5lKGRhdGEgPSBtYXRoX21lYW5fYnlfcHJvdmluY2UgJT4lIGZpbHRlcihwcm92aW5jZSA9PSAiSGEgR2lhbmciKSwgDQogICAgICAgICAgICAgYWVzKHhpbnRlcmNlcHQgPSB0YiksIGxpbmV0eXBlID0gImRhc2hlZCIsIGNvbG9yID0gbXlfY29sb3JzWzFdKSArIA0KICBnZW9tX3ZsaW5lKGRhdGEgPSBtYXRoX21lYW5fYnlfcHJvdmluY2UgJT4lIGZpbHRlcihwcm92aW5jZSAhPSAiSGEgR2lhbmciKSwgDQogICAgICAgICAgICAgYWVzKHhpbnRlcmNlcHQgPSB0YiksIGxpbmV0eXBlID0gImRhc2hlZCIsIGNvbG9yID0gbXlfY29sb3JzWzJdKSArIA0KICBhbm5vdGF0ZSgidGV4dCIsIA0KICAgICAgICAgICBsYWJlbCA9ICJNYXRoIHNjb3JlcyBhcmVcbiAgdW51c3VhbGx5IGhpZ2giLCBmYW1pbHkgPSBteV9mb250LCANCiAgICAgICAgICAgeCA9IDguMiwgeSA9IDAuMTA1LCBzaXplID0gNCwgaGp1c3QgPSAtMC4yLCB2anVzdCA9IDEsIGNvbG9yID0gImdyZXkyMCIpICsgDQogIGFubm90YXRlKCJjdXJ2ZSIsIA0KICAgICAgICAgICBjdXJ2YXR1cmUgPSAwLA0KICAgICAgICAgICB4ID0gOSwgDQogICAgICAgICAgIHhlbmQgPSA5LA0KICAgICAgICAgICB5ID0gMC4wNywgDQogICAgICAgICAgIHllbmQgPSAwLjAxOSwNCiAgICAgICAgICAgYXJyb3cgPSBhcnJvdyhhbmdsZSA9IDIwLCBsZW5ndGggPSB1bml0KC4zLCAiY20iKSksIHNpemUgPSAwLjMpICsgDQogIHNjYWxlX3lfY29udGludW91cyhsYWJlbHMgPSBzY2FsZXM6OnBlcmNlbnQsIA0KICAgICAgICAgICAgICAgICAgICAgYnJlYWtzID0gc2VxKDAsIDAuNCwgMC4xKSwgZXhwYW5kID0gYygwLjA3LCAwKSkgKyANCiAgbGFicyh4ID0gTlVMTCwgeSA9IE5VTEwsIA0KICAgICAgIHRpdGxlID0gIk1hdGggU2NvcmUgRGlzdHJpYnV0aW9uIGJ5IEhhIEdpYW5nIGFuZCBPdGhlcnMiLCANCiAgICAgICBjYXB0aW9uID0gIkRhdGEgU291cmNlOiBNaW5pc3RyeSBvZiBFZHVjYXRpb24gYW5kIFRyYWluaW5nIikgKyANCiAgdGhlbWVfbWluaW1hbCgpICsgDQogIHRoZW1lKGxlZ2VuZC5wb3NpdGlvbiA9ICJ0b3AiKSArIA0KICB0aGVtZShwYW5lbC5ncmlkID0gZWxlbWVudF9saW5lKHNpemUgPSAwLjIpKSArIA0KICB0aGVtZShwbG90LnRpdGxlID0gZWxlbWVudF90ZXh0KGZhbWlseSA9IG15X2ZvbnQsIHNpemUgPSAyMCkpICsgDQogIHRoZW1lKGF4aXMudGV4dCA9IGVsZW1lbnRfdGV4dChmYW1pbHkgPSBteV9mb250LCBzaXplID0gMTMpKSArIA0KICB0aGVtZShwbG90LmNhcHRpb24gPSBlbGVtZW50X3RleHQoZmFtaWx5ID0gbXlfZm9udCwgc2l6ZSA9IDEwLCB2anVzdCA9IC0yLCBjb2xvdXIgPSAiZ3JleTMwIiwgZmFjZSA9ICJpdGFsaWMiKSkgKyANCiAgdGhlbWUocGxvdC5tYXJnaW4gPSB1bml0KHJlcCgxLCA0KSwgImNtIikpICsgDQogIHRoZW1lKGxlZ2VuZC50aXRsZSA9IGVsZW1lbnRfYmxhbmsoKSkgKyANCiAgdGhlbWUobGVnZW5kLnRleHQgPSBlbGVtZW50X3RleHQoZmFtaWx5ID0gbXlfZm9udCwgc2l6ZSA9IDExLCBjb2xvciA9ICJncmV5MzAiKSkgKyANCiAgdGhlbWUocGxvdC5iYWNrZ3JvdW5kID0gZWxlbWVudF9yZWN0KGZpbGwgPSAic2Vhc2hlbGwiLCBjb2xvciA9IE5BKSkgKyANCiAgc2NhbGVfY29sb3JfbWFudWFsKHZhbHVlcyA9IG15X2NvbG9ycykgKyANCiAgc2NhbGVfZmlsbF9tYW51YWwodmFsdWVzID0gbXlfY29sb3JzKQ0KDQoNCmBgYA0KDQojIENvbmNsdXNpb24NCg0KQ2jhu4kgYuG6sW5nIGjDrG5oIOG6o25oIGjDs2EgZOG7ryBsaeG7h3UgY2jDum5nIHRhIGPDsyB0aOG7gyB0w6xtIHJhIG5oaeG7gXUgaW5zaWdodHMgY8OzIMO9IG5naMSpYS4gTmjGsCB0cm9uZyB0csaw4budbmcgaOG7o3AgbsOgeSBsw6AgdMOsbSByYSBi4bqxbmcgY2jhu6luZyDEkeG7gyBuZ2hpIG5n4budIHLhurFuZyBjw7Mgc+G7sSBnaWFuIGzhuq1uIG3hu5l0IGPDoWNoIGPDsyBo4buHIHRo4buRbmcgdHJvbmcga8OsIHRoaSBxdeG7kWMgZ2lhIDIwMTguIFbDoCB0aOG7sWMgdOG6vyDEkcO6bmcgbMOgIHbhuq15LiANCg0KDQo=