Dans cet annexe, nous détaillons la construction de la base de données et nous présentons les codes utilisés pour les analyses.
Notre jeux de données se compose de plusieurs tables:
Malheureusement, nous ne pouvons pas partager les textes entiers pour des raisons de droits d’auteurs. Le reste des données sont consultable et téléchargeable dans les tableaux interactifs ci-dessous.
# load data
documents <- read_xlsx(here(clean_corpus_path, "re_metadata_1950_2023.xlsx"),
col_types = "text") %>% unique
authors <- read_xlsx(here(clean_corpus_path, "re_authors_1950_2023.xlsx"),
col_types = "text") %>% unique
editors <- read_xlsx(here(clean_corpus_path, "re_editors.xlsx"),
col_types = "text") %>% uniqueNous avons utilisés trois sources principales pour la construction de notre base de données des documents et des auteurs. La première source est un document interne à la revue économique qui répertorie les documents publiés dans la Revue Economique entre 1950 et 2019. Ce document comprend plusieurs metadonnées des documents que nous avons exploité: les titres, les auteurs, leur genre, l’année de publication, les numéros spéciaux, le type de document (note de lecture, article, etc.).
Nous avons enrichie cette base de données avec deux autres sources, les deux bibliothèques numériques Persée, qui archive la revue économique entre 1950 et 2000, et Cairn, qui couvre la période de 2001 à aujourd’hui. Nous avons notamment utilisé les API de ces deux bibliothèques pour récupérer les résumés des articles (https://oai.cairn.info/ et https://www.persee.fr/entrepot-oai). Nous avons également eu accès, après demande, aux textes entiers. Ces derniers ne sont malheureusement pas open data. Cairn nous a également donné accès aux citations entrantes et sortantes pour chaque documents.
La table des éditeurs a été construite par nos soins. Nous avons recoupé les informations sur Cairn, Persée, Jstor et d’autres entrepôts de la recherche en France comme https://data.bnf.fr/, https://www.sudoc.abes.fr/ ou https://theses.fr/?domaine=theses.
L’usage de différentes sources permet d’obtenir une base de donnée enrichie mais augmente aussi le risque de doublon, soit par ce que le doublon existe déjà dans les différentes sources utilisées, soit par ce que nous avons fait des erreurs dans notre travail de fusions des différentes sources. L’algorithme ci-dessous vise à identifier des doublons par le biais de la stratégie suivante:
R via le package stringdist (Van der Loo et al. 2014).#' Identify potential duplicates in corpus of documents with at least a title and an author
#'
#' This function detects potential duplicates in thesis metadata by comparing titles within groups
#' of the same author. It calculates string distances between pairs of titles using the Optimal
#' String Alignment (OSA) algorithm and filters results based on predefined thresholds.
#'
#' @param data_dt A `data.table` containing the thesis metadata, with at least three columns:
#' - `authors`: Normalized author names used for grouping.
#' - `title`: Normalized thesis titles.
#' - `id`: Unique identifiers for each thesis.
#' @param threshold_distance Numeric. The maximum absolute string distance between two titles for them
#' to be considered duplicates.
#' @param threshold_normalization Numeric. The maximum normalized string distance (distance divided by
#' the product of the title lengths) for two titles to be considered duplicates.
#'
#' @return A `data.table` containing the following columns:
#' - `id`: The identifier for the primary thesis in the duplicate group.
#' - `id`: The identifier for the duplicate thesis.
#' - `authors`: The author associated with the duplicates.
#' - `text1`: The first title in the comparison.
#' - `text2`: The second title in the comparison.
#' - `distance`: The absolute string distance between the titles.
#' - `normalized_distance`: The normalized string distance between the titles.
#' If no duplicates are found, the function returns `NULL`.
#'
#' @details
#' The function first groups titles by `authors`, then compares all pairs of titles within each group.
#' String distances are calculated using the OSA algorithm, which accounts for single-character
#' substitutions, deletions, and transpositions. The results are filtered based on the provided
#' thresholds to minimize false positives.
#'
#' @examples
#' # Sample data
#' data_dt <- data.table(
#' authors = c("smith john", "smith john", "doe jane"),
#' title = c("My document Title", "My document titlé", "Another document"),
#' id = c("ID1", "ID2", "ID3")
#' )
#'
#' # Detect duplicates with specific thresholds
#' find_duplicates(data_dt, threshold_distance = 2, threshold_normalization = 0.05)
#'
#' @export
find_duplicates <- function(data_dt, threshold_distance, threshold_normalization, workers) {
# as data.table
data_dt <- as.data.table(data_dt)
# Group data by authors to avoid unnecessary comparisons
data_dt <- data_dt[, .(titles = list(title), ids = list(id)), by = authors]
data_dt <- data_dt[lengths(titles) > 1] # Keep only groups with more than one title for safety (should not be necessary if data is clean)
# Define a helper function for processing a single group
process_group <- function(titles, ids, author) {
# Compare all title pairs within the group
comparison <- CJ(titles, titles, sorted = FALSE, unique = TRUE)
setnames(comparison, c("text1", "text2"))
# comparison <- comparison[text1 <= text2] # Avoid redundant comparisons
# Calculate string distance and normalized distance
comparison[, distance := stringdist::stringdist(text1, text2, method = "osa")]
comparison[, normalized_distance := distance / (str_count(text1) * str_count(text2))]
if (nrow(comparison) > 0) {
comparison[, authors := author]
title_match <- comparison %>%
as.data.table() %>%
merge(data.table(title1 = titles, id_1 = ids), by.x = "text1", by.y = "title1", allow.cartesian = TRUE) %>%
merge(data.table(title2 = titles, id_2 = ids), by.x = "text2", by.y = "title2", allow.cartesian = TRUE) %>%
.[id_1 != id_2, .(id_1, id_2, authors, text1, text2, distance, normalized_distance)]
return(title_match)
}
return(NULL)
}
# Set up parallel processing
plan(multisession, workers = workers)
# Use future_map to parallelize the processing of each group
results <- future_map(
1:nrow(data_dt),
~ process_group(
titles = data_dt$titles[[.x]],
ids = data_dt$ids[[.x]],
author = data_dt$authors[.x]
),
.progress = TRUE
)
if(length(results) > 0) {
results <- results %>%
rbindlist()
setkey(results, key = id_1)
duplicates <- results[normalized_distance < threshold_normalization & distance < threshold_distance, ]
setnames(duplicates, "id_1", "id")
duplicates <- unique(duplicates)
return(duplicates)
} else {
return(NULL)
}
}
# first delete forthcoming article that are duplicates
# remove duplicates and save
documents <- documents %>%
filter(!issue == "Forthcoming")
# select author information used in find_duplicate()
authors_info_to_join <- authors %>%
select(id_document, authors)
# join
documents_with_authors <- documents %>%
left_join(authors_info_to_join, by = c("id" = "id_document"))
# create metadata for stm
data_to_check <- documents_with_authors %>%
filter(type %in% c("varia", "numéro spécial", "")) %>%
# nest author
group_by(id) %>%
mutate(authors_list = list(authors)) %>%
mutate(authors = first(authors)) %>%
# remove non unique line
unique %>%
# harmonize authors
mutate(authors = str_remove_all(authors, "[[:punct:]]"),
authors = str_to_lower(authors),
authors = str_squish(authors)) %>%
#remove special cases, regular chroniques
filter(!title %in%
c("Chronique de la pensée économique en Italie",
"Commentaires",
"La situation économique",
"Avant-propos",
"Introduction",
"introduction"))
duplicates <- find_duplicates(data_dt = data_to_check,
threshold_distance = 6,
threshold_normalization = 0.1,
workers = 4)
duplicates <- duplicates %>%
group_by(id) %>%
mutate(duplicates = list(c(id, id_2)),
duplicates = map(duplicates, ~ .x %>% sort()))
# Add duplicates to the main metadata table
documents <- documents %>%
left_join(duplicates %>%
select(id, duplicates)) %>%
mutate(duplicates = ifelse(duplicates == "NULL", NA_character_, duplicates))
duplicates_to_keep <- documents %>%
filter(!is.na(duplicates)) %>%
# sort
unique %>%
group_by(duplicates) %>%
arrange(!is.na(abstract_fr),
# Prioritize rows where abstract_fr is not NA
as.numeric(issue),
# Prioritize numeric issues (NA if not numeric)
issue != "Forthcoming",
# Ensure "Forthcoming" is deprioritized
.by_group = TRUE) %>%
slice(1) %>% # Keep only the first row within each group
ungroup() %>%
unique()
documents <- documents %>%
filter(is.na(duplicates)) %>%
bind_rows(duplicates_to_keep)
# maj authors data removing lines with duplicates
id_to_keep <- documents$id
authors <- authors %>%
filter(id_document %in% id_to_keep)
saveRDS(documents, here(clean_corpus_path, "documents_no_duplicates.rds"))
saveRDS(authors, here(clean_corpus_path, "authors_no_duplicates.rds"))Dans la table des métadonnées, chaque ligne est un document qui possède un identifiant unique, id. Cet identifiant est soit l’identifiant persée ou l’identifiant cairn. Certaines lignes partagent le même id car quelques documents dans la base de donnée originale de la Revue Economique correspondent à une même notice bibliographique dans Persée ou Cairn. Une url est disponible pour chaque document pour consulter la notice Persée ou Cairn en ligne.
# load data with no duplicates
documents <- readRDS(here(clean_corpus_path, "documents_no_duplicates.rds"))
authors <- readRDS(here(clean_corpus_path, "authors_no_duplicates.rds"))
# plot document distribution
p <- documents %>%
mutate(type = ifelse(str_detect(type, "varia|numéro spécial"), type, "autre"),
type = factor(type, levels = c("autre", "numéro spécial", "varia"))) %>%
count(year, type) %>%
mutate(tooltip = paste("Année:", year, "<br>Nombre de documents:", n, "<br>Type:", type)) %>%
ggplot(aes(x = as.integer(year), y = n, fill = type, text = tooltip)) +
geom_histogram(stat = "identity") +
scale_fill_manual(values = colors[1:3]) +
theme_light(base_size = 15) +
labs(x = "", y = "Nombre de documents", fill = "")
ggsave(
"distribution_par_type.png",
device = "png",
plot = p,
path = figures_path,
width = 8,
height = 4.5,
dpi = 300
)
ggplotly(p, tooltip = "text") %>%
config(displayModeBar = FALSE)file_ftz <- system.file("language_identification/lid.176.ftz", package = "fastText") # importing the pre-trained model
# languages <- documents %>%
# select(id, title) %>%
# mutate(
# # language_cld3 = cld3::detect_language(title, size = 2),
# language_fasttext = furrr::future_map(
# title,
# ~ fastText::language_identification(
# input_obj = .x,
# pre_trained_language_model_path = file_ftz,
# k = 1,
# th = 0.0,
# )
# )
# )
#
# saveRDS(languages, here(intermediate_data_path, "language_fasttext.rds"))
languages <- readRDS(here(intermediate_data_path, "language_fasttext.rds"))
# cleaning errors
title_fr <- c("Introduction")
id_fr <- c("reco_0035-2764_1958_num_9_2_407293",
"reco_0035-2764_1964_num_15_4_407617",
"reco_0035-2764_1962_num_13_5_407529_t1_0849_0000_001",
"reco_0035-2764_1977_num_28_6_408364_t1_1030_0000_000",
"reco_0035-2764_1969_num_20_6_407897_t1_1062_0000_002")
id_en <- c("reco_0035-2764_2000_num_51_3_410526",
"reco_0035-2764_1994_num_45_5_409606")
languages_clean <- languages %>%
unnest(language_fasttext) %>%
rename(language = iso_lang_1) %>%
mutate(language = ifelse(title %in% title_fr, "fr", language),
language = ifelse(id %in% id_fr, "fr", language),
language = ifelse(id %in% id_en, "en", language),
language = ifelse(!language %in% c("fr", "en", "de", "it"), "autres", language),
language = factor(language, levels = c("autres", "it", "de", "en", "fr")))
# add manally color for consistency between plots
language_colors <- c("fr" = "#0072B280", "autres" = "#009E7380", "en" = "#CC79A780", "de" = "#F0E44280", "it" = "#D55E0080")
p1 <- languages_clean %>%
left_join(documents %>% select(year, type, id), by = "id") %>%
filter(type %in% c("varia", "numéro spécial")) %>%
count(language, year) %>%
mutate(tooltip = paste("Année:", year, "<br>Nombre de documents:", n, "<br>Langue:", language)) %>%
ggplot(aes(x = as.integer(year), y = n, fill = language, text = tooltip)) +
geom_col() +
scale_fill_manual(values = language_colors) +
theme_light(base_size = 15) +
labs(x = "", y = "Nombre de documents", fill = "")
p2 <- languages_clean %>%
left_join(documents %>% select(year, type, id), by = "id") %>%
filter(!type %in% c("varia", "numéro spécial")) %>%
count(language, year) %>%
mutate(tooltip = paste("Année:", year, "<br>Nombre de documents:", n, "<br>Langue:", language)) %>%
ggplot(aes(x = as.integer(year), y = n, fill = language, text = tooltip)) +
geom_col() +
scale_fill_manual(values = language_colors) +
theme_light(base_size = 15) +
labs(x = "", y = "Nombre de documents", fill = "")
ggplotly(p1, tooltip = "text") %>%
config(displayModeBar = FALSE)
ggplotly(p2, tooltip = "text") %>%
config(displayModeBar = FALSE)
ggsave(
"langues_articles.png",
device = "png",
plot = p1,
path = figures_path,
width = 8,
height = 4.5,
dpi = 300
)
ggsave(
"langues_recension.png",
device = "png",
plot = p2,
path = figures_path,
width = 8,
height = 4.5,
dpi = 300
)
p <- p2 + p1 + theme(legend.position = "none") +
plot_layout(axes = "collect")
ggsave(
"langues_all.png",
device = "png",
plot = p,
path = figures_path,
width = 11,
height = 6,
dpi = 300
)# trunc abstracts for table lisibility
documents <- documents %>%
mutate(abstract_fr = str_trunc(abstract_fr, 100, ellipsis = "..."),
abstract_en = str_trunc(abstract_en, 100, ellipsis = "..."))
DT::datatable(
documents,
extensions = 'Buttons',
options = list(
dom = 'Blfrtip',
buttons = c('excel', 'csv'),
pageLength = 3
)
)Dans la table des auteurs, chaque ligne correspond à un auteur d’un document et nous leur avons attribué un identifiant unique id_authors. Chaque auteur est associé à ses documents par un identifiant que nous avons créé id_document. Les auteurs sont identifiés par leur nom, prénom, genre. Pour les documents archivés par persée, nous avons également enrichi la base de donnée avec les informations issues d’idref, une base de données qui recense les informations sur les auteurs de l’enseignement et de la recherche en France.
# same but only articles
articles <- documents %>% filter(str_detect(type, "varia|spécial") | type == "")
p1 <- authors %>%
filter(!is.na(gender),
!id_document %in% articles$id) %>%
group_by(gender, year) %>%
summarise(n = n()) %>%
ungroup %>%
mutate(tooltip = paste("Année:", year, "<br>Nombre d'auteurs:", n, "<br>Genre:", gender)) %>%
ggplot(aes(
x = as.integer(year),
y = n,
fill = gender,
text = tooltip
)) +
geom_col() +
theme_light() +
labs(x = "", y = "Nombre d'auteurs", fill = "Genre") +
scale_fill_scico_d(begin = 0.3, end = 0.9, palette = "oleron") +
theme_light(base_size = 15)
p2 <- authors %>%
filter(!is.na(gender),
id_document %in% articles$id) %>%
group_by(gender, year) %>%
reframe(n = n()) %>%
ungroup %>%
mutate(tooltip = paste("Année:", year, "<br>Nombre d'auteurs:", n, "<br>Genre:", gender)) %>%
ggplot(aes(
x = as.integer(year),
y = n,
fill = gender,
text = tooltip
)) +
geom_col() +
theme_light() +
labs(x = "", y = "Nombre d'auteurs", fill = "Genre") +
scale_fill_scico_d(begin = 0.3, end = 0.9, palette = "oleron") +
theme_light(base_size = 15)
ggplotly(p1, tooltip = "text") %>%
config(displayModeBar = FALSE)
ggplotly(p2, tooltip = "text") %>%
config(displayModeBar = FALSE)
# both
p <- p1 + p2 +
plot_layout(axes = "collect",
guides = "collect")
ggsave(
"distribution_genre_no_articles.png",
device = "png",
plot = p1,
path = figures_path,
width = 8,
height = 4.5,
dpi = 300
)
ggsave(
"distribution_genre_seulement_articles.png",
device = "png",
plot = p2,
path = figures_path,
width = 8,
height = 4.5,
dpi = 300
)
ggsave(
"distribution_genre_all.png",
device = "png",
plot = p,
path = figures_path,
width = 11,
height = 6,
dpi = 300
)p <- authors %>%
# keep only articles
filter(id_document %in% articles$id) %>%
group_by(id_document) %>%
reframe(n = n(),
year) %>%
mutate(is_coauthor = ifelse(n > 1, 1, 0)) %>%
add_count(year) %>%
group_by(year, is_coauthor) %>%
reframe(total = nn,
n = n(),
percentage = n/total*100) %>%
filter(is_coauthor == 1) %>%
mutate(tooltip = paste("Année:", year, "<br>Articles en co-écriture:", n, "<br>%", percentage)) %>%
ggplot(aes(x = as.integer(year), y = percentage)) +
geom_smooth(se = FALSE, method = 'loess', span = 0.75, color = colors[[1]]) +
geom_point(aes(text = tooltip)) +
theme_light(base_size = 15) +
labs(x = "",
y = "%")
ggsave(
"proportion_coauteurs.png",
device = "png",
plot = p,
path = figures_path,
width = 8,
height = 4.5,
dpi = 300
)
ggplotly(p, tooltip = "text") p <- authors %>%
left_join(documents %>% select(id, type), by = c("id_document" = "id")) %>%
mutate(type = ifelse(str_detect(type, "varia|numéro spécial"), "article", "others")) %>%
filter(type == "article") %>%
count(authors) %>%
count(n) %>%
mutate(tooltip = paste("Nombre d'articles publiés:", n, "<br>Nombre d'auteurs:", nn)) %>%
ggplot(aes(x = n, y = nn, text = tooltip)) +
# light red
geom_col(fill = colors[[1]]) +
# zoom on the first range of y
theme_light() +
labs(x = "Nombre d'articles publiés",
y = "Nombre d'auteurs",
title = "Uniquement les articles (books reviews et autres exclus)")
ggplotly(p, tooltip = "text") authors_nested <- authors %>%
group_by(id_authors) %>%
mutate(id_document = list(id_document),
institution = list(institution),
year = list(year)) %>%
select(-"Type d'institution", -"Discipline 1", -"Discipline 2") %>%
unique()
DT::datatable(
authors_nested,
extensions = 'Buttons',
options = list(
dom = 'Blfrtip',
buttons = c('excel', 'csv'),
pageLength = 3
)
)editors <- editors %>%
filter(!is.na(Nom)) %>%
mutate(date_departure = ifelse(is.na(date_departure), 2023, date_departure)) %>%
rename(field = `discipline 1`)
editors_annually <- editors %>%
rowwise() %>%
mutate(years = list(seq(date_entrance, date_departure, by = 1))) %>%
unnest(years) %>%
select(years, Nom, Prénom, genre, field) %>%
unique
p1 <- editors_annually %>%
count(years, genre) %>%
group_by(years) %>%
mutate(percentage = n/sum(n)*100) %>%
filter(genre == "F") %>%
mutate(tooltip = paste("Année:", years, "<br>Genre:", genre, "<br>Nombre d'éditeurs:", n)) %>%
ggplot(aes(x = years, y = percentage)) +
geom_smooth(se = FALSE, method = 'loess', span = 0.75, alpha = 0.5, color = colors[[1]]) +
geom_point(aes(text = tooltip), color = "black") +
labs(x = "",
y = "%") +
theme_light(base_size = 15)
ggsave(
"editors_genre.png",
device = "png",
plot = p1,
path = figures_path,
width = 8,
height = 4.5,
dpi = 300
)
ggplotly(p1, tooltip = "text") %>%
config(displayModeBar = FALSE)p2 <- editors_annually %>%
count(years, field) %>%
group_by(years) %>%
mutate(percentage = n/sum(n)*100) %>%
filter(!is.na(field)) %>%
mutate(tooltip = paste("Année:", years, "<br>Discipline:", field, "<br>Nombre d'éditeurs:", n)) %>%
ggplot(aes(x = years, y = percentage, color = field, text = tooltip)) +
geom_point(aes(text = tooltip)) +
scale_color_brewer(palette = "Set2") +
theme_light(base_size = 15) +
labs(color = "Discipline",
y = "%",
x = "")
ggsave(
"editors_field.png",
device = "png",
plot = p2,
path = figures_path,
width = 8,
height = 4.5,
dpi = 300
)
#save both last plot together
p <- p1 + p2
ggsave(
"editors_genre_field.png",
device = "png",
plot = p1 + p2,
path = figures_path,
width = 11,
height = 6,
dpi = 300
)
# print
ggplotly(p2, tooltip = "text") %>%
config(displayModeBar = FALSE)DT::datatable(
editors,
extensions = 'Buttons',
options = list(
dom = 'Blfrtip',
buttons = c('excel', 'csv'),
pageLength = 3
)
)Pour analyser les citations extra-disciplinaires des documents de la revue économique, nous avons utilisé les données de citation de cairn—malheureusement ces données ne sont pas disponibles pour les documents archivés par persée et cairn ne nous autorise pas à les diffuser.
Nous avons classifié à la main les journaux des documents qui sont cités au moins deux fois dans la revue économique, soit 1639 journaux (voir Table 4). Nous avons ensuite classifier ces journaux par disciplines en utilisant le nom du journal, et en consultant le board éditorial de chaque journal en cas d’ambiguïté (i.e. the journal of economics and sociology). Les journaux de finance sont des cas particuliers puisqu’il pourrait légitimement être classifié en économie ou en management. Nous avons donc décidé de créer une catégorie à part.
Nous calculons ensuite la fréquence de chaque discipline au sein des documents, normalisée par le nombre de références. Plus un article cite de références moins ses références comptent.
# Normalize references
# get fields and journal frequency
field <- read_xlsx(here(clean_corpus_path, "ref_journals.xlsx"))
#get references
cairn_ref <- read_xlsx(here(cairn_data_path,"RECO_31-01-2024_références_sortantes.xlsx"))
# join field and references
ref_journals <- cairn_ref %>%
# renaming for simplicity
rename(journal = `Titre revue citée`,
year = `Année source`,
id = `ID_ARTICLE source`) %>%
# keep only id in the official document database
filter(id %in% documents$id) %>%
# count number of references (use in the chunk later)
add_count(id, name = "n_ref") %>%
mutate(journal = str_to_lower(journal) %>%
str_remove(., "^\\s?the") %>%
str_trim(., "both")) %>%
# add field and journal frequency
left_join(field, by = "journal") %>%
select(id, journal, field, year, n, n_ref) %>%
filter(!is.na(journal),
!is.na(field))
# estimate the normalized frequency of journals
ref_journals_normalize_weak <- ref_journals %>%
group_by(field, id) %>%
reframe(n = n(),
n_normalize = n / n_ref,
n_ref = n_ref,
year = year) %>%
unique() Nous reprenons ensuite la méthodologie de Truc et al. (2023) pour identifier le ratio de citations extra-disciplinaires, c’est à dire le pourcentage de citations en dehors de l’économie par rapport au nombre total de citations. La Figure 8 montre l’évolution de ce ratio pour les disciplines les plus citées (les autres disciplines sont regroupées dans la variable “other”). La Figure 9 montre l’évolution du ratio de citations extra-disciplinaires sur le total des citations.
# plot extra-disciplinary citation for the 12th most important fields
# find the 12th
field_to_keep <- ref_journals_normalize_weak %>%
group_by(field) %>%
reframe(sum_n = sum(n_normalize)) %>%
arrange(desc(sum_n)) %>%
slice_max(sum_n, n = 12) %>%
distinct(field)
data_summary_weak <- ref_journals_normalize_weak %>%
# keep the the 12th most represented fields
mutate(field = ifelse(field %in% field_to_keep$field, field, "Other")) %>%
# estimate the normalized frequency each year
group_by(year) %>%
mutate(sum_by_year = sum(n_normalize)) %>%
group_by(field, year) %>%
reframe(sum_by_year_field = sum(n_normalize),
sum_by_year = sum_by_year) %>%
unique %>%
group_by(field, year) %>%
mutate(ratio = sum_by_year_field/sum_by_year*100)
field_levels <- unique(data_summary_weak$field[data_summary_weak$field != "Other"])
# assign color to each field level
color_values <- c("Other" = "lightgray",
"Total" = "black",
setNames(RColorBrewer::brewer.pal(length(field_levels), "Paired"), field_levels))
gg <- data_summary_weak %>%
# remove economics
filter(field != "Economics") %>%
ggplot(aes(x = year, y = ratio, color = field, linetype = field, group = field)) +
geom_smooth(se = FALSE, method = 'loess', linewidth = 1.5, span = 0.75) +
labs(
x = "",
y = "% du total des références") +
scale_color_manual(values = color_values) + # Apply custom color scale
guides(color = guide_legend(title = "", nrow = 4),
linetype = guide_legend(title = "", nrow = 5)) +
theme_light(base_size = 16) +
theme(legend.position = "bottom")
ggsave(
"references_disciplines.png",
device = "png",
plot = gg,
path = figures_path,
width = 10,
height = 8,
dpi = 300
)
ggplotly(gg, tooltip = c("x","y","color")) %>%
config(displayModeBar = FALSE) %>%
layout(xaxis = list(fixedrange = TRUE), yaxis = list(fixedrange = TRUE))# total extra-disciplinary citations
data_summary_weak2 <- data_summary_weak %>%
mutate(field = ifelse(str_detect(field, "Economics"), "Intra", "Extra")) %>%
group_by(field, year) %>%
reframe(ratio = sum(ratio)) %>%
unique
p <- data_summary_weak2 %>%
filter(field == "Extra") %>%
mutate(field = "Total") %>%
ggplot(aes(x = year, y = ratio, color = field)) +
geom_point() +
geom_smooth(se=F, method = 'loess', span = 0.50,
linewidth= 1.5,
alpha = 0.2) +
scale_color_manual(values = color_values) +
labs(
color = "",
x = "",
y = "% du total des références") +
theme_light(base_size = 15) +
theme(legend.position = "none")
ggsave(
"references_extradisciplinaire.png",
device = "png",
plot = p,
path = figures_path,
width = 10,
height = 5,
dpi = 300
)
# save both plots
total <- gg + p +
patchwork::plot_layout(guides = "collect", widths = c(3, 2)) & labs(field = "") &
theme(legend.position = "bottom")
ggsave(
"references_total_disciplines.png",
device = "png",
plot = total,
path = figures_path,
width = 11,
height = 6,
dpi = 300
)
# print the last plot
ggplotly(p, tooltip = c("x","y"))# Output a table for users
field_weak <- ref_journals %>%
select(journal, n, field) %>%
distinct() %>%
# sort by frequency
arrange(desc(n))
DT::datatable(
field_weak,
extensions = 'Buttons',
options = list(
dom = 'Blfrtip',
buttons = c('excel', 'csv'),
pageLength = 10
)
)Afin de confirmer ces résultats, nous avons reclassé les journaux en utilisant une classification plus stricte de l’économie. Nous avons considéré que n’importe quel journal utilisant le mot économie dans son titre est un journal d’économie. Nous avons ensuite recalculé le ratio de citations extra-disciplinaires. La tendance haussière reste la même même si (logiquement) le ratio de citations extra-disciplinaires est plus faible.
# estimate normalized frequency
ref_journals_normalize_strong <- ref_journals %>%
mutate(field2 = ifelse(str_detect(journal, "[ée]conom"), "Economics", field)) %>%
group_by(field2, id) %>%
reframe(n = n(),
n_normalize = n / n_ref,
n_ref = n_ref,
year = year) %>%
unique %>%
rename(field = field2)
# estimate normalized frequency each year
data_summary_strong <- ref_journals_normalize_strong %>%
mutate(field = ifelse(field %in% field_to_keep$field, field, "Other")) %>%
group_by(year) %>%
mutate(sum_by_year = sum(n_normalize)) %>%
group_by(field, year) %>%
reframe(sum_by_year_field = sum(n_normalize),
sum_by_year = sum_by_year) %>%
unique %>%
group_by(field, year) %>%
mutate(ratio = sum_by_year_field/sum_by_year*100)
# total extra-disciplinary citations
data_summary_strong2 <- data_summary_strong %>%
mutate(field = ifelse(str_detect(field, "Economics"), "Intra", "Extra")) %>%
group_by(field, year) %>%
reframe(ratio = sum(ratio)) %>%
unique
# plot
p <- data_summary_strong2 %>%
filter(field == "Extra") %>%
ggplot(aes(x = year, y = ratio)) +
geom_point() +
geom_smooth(se=F, method = 'loess', span = 0.50,
linewidth= 1,
color = colors[[1]],
alpha = 0.2) +
labs(
x = "",
y = "% du total des références") +
theme_light(base_size = 15)
ggsave(
"references_extradisciplinaire_strong.png",
device = "png",
plot = p,
path = figures_path,
width = 8,
height = 4.5,
dpi = 300
)
ggplotly(p, tooltip = c("x","y"))# output users with field2
field_strict <- ref_journals %>%
# add a stronger definition of economics
mutate(field2 = ifelse(str_detect(journal, "[ée]conom"), "Economics", field)) %>%
select(journal, n, field2) %>%
distinct() %>%
arrange(desc(n))
DT::datatable(
field_strict,
extensions = 'Buttons',
options = list(
dom = 'Blfrtip',
buttons = c('excel', 'csv'),
pageLength = 10
)
)Le structural topic model est implémenté dans R dans le package stm (Roberts et al. 2013). L’ensemble des informations relatives à cette implémentation est disponible sur le site web dédié. Pour une exploration avancée, l’ensemble du code R est disponible sur le github. Une série d’articles des auteurs présentent le modèle. Roberts, Stewart, and Airoldi (2016) est la présentation la plus complète pour une exploration avancée de l’inférence bayésienne utilisée.
Dans cette section, nous détaillons les étapes suivies pour le prétraitement des données textuelles en vue de leur utilisation dans un topic model. En plus d’un pré-nettoyage et le formatage habituel des données textuelles, nous créons les deux variables indicatrices is_varia et has_female pour la future régression.
#' SCRIPT FOR CHOOSING K
# Load packages and data
source(here::here("scripts","paths_and_packages.R"))
source(here::here("scripts", "producing_results", "_functions_for_tm.R"))
documents <- readRDS(here(clean_corpus_path, "documents_no_duplicates.rds"))
authors <- readRDS(here(clean_corpus_path, "authors_no_duplicates.rds"))
full_text <- readRDS(here(clean_corpus_path, "full_text.rds")) %>%
mutate(id = str_remove_all(id, "_[:digit:]{4}.txt$"))
### JOINING TABLES ###
# select relevant authors information
authors_info_to_join <- authors %>%
select(id_document,
authors,
gender)
# join tables
documents_with_authors <- documents %>%
left_join(authors_info_to_join, by = c("id" = "id_document")) %>%
# create dummy variables has female and isvaria
group_by(id) %>%
mutate(has_female = as.integer(any(gender == "F")),
is_varia = ifelse(type == "varia", 1, 0)) %>%
# nest author
group_by(id) %>%
# keep only first author or first title for some id duplicates
slice(1) %>%
# remove duplicates from joining
select(id, authors, title, abstract_fr, year, has_female, is_varia, -gender, type) %>%
unique
# join fulltext
full_text_filtered <- documents_with_authors %>%
filter(type %in% c("varia", "numéro spécial")) %>%
left_join(full_text, by = "id") %>%
# filter na covariates
filter(!is.na(has_female), !is.na(is_varia))
#### PRE-CLEANING ####
# using data.table for efficiency
# Convert to data.table if not already
setDT(full_text_filtered)
# Select relevant columns
df_text <- full_text_filtered[, .(id, authors, title, abstract_fr, text, year, has_female, is_varia)]
# Clean abstracts
df_text[, abstract_fr := str_squish(abstract_fr)]
df_text[, abstract_fr := str_trim(str_remove_all(abstract_fr, "^[Rr]ésumé"))]
df_text[, abstract_fr := str_remove_all(abstract_fr, "Classification JEL.*$")]
df_text[, abstract_fr := str_remove_all(abstract_fr, "JEL [Cc]ode(s)?.*$")]
df_text[, abstract_fr := str_remove_all(abstract_fr, "JEL [Cc]lassification.*$")]
df_text[, abstract_fr := str_remove_all(abstract_fr, "(JEL : D11, L13, Q42.)|(Classification jel : A14, B10, F13)")]
df_text[, abstract_fr := fifelse(is.na(abstract_fr), "", abstract_fr)]
# Clean texts
df_text[, text := str_squish(text)]
# remove revue economique in body text
df_text[, text := str_remove_all(text, "Revue économique")]
df_text[, text := str_remove_all(text, "Revue Economique")]
df_text[, text := str_remove_all(text, "REVUE ECONOMIQUE")]
df_text[, text := str_remove_all(text, "REVUE CONOMIQUE")]
# remove vol + number
df_text[, text := str_remove_all(text, "vol. [0-9]+")]
# remove references bibliographique
df_text[, text := str_remove_all(text, regex("Références bibliographiques.*", ignore_case = TRUE))]
df_text[, text := str_remove_all(text, regex("REFERENCES BIBLIOGRAPHIQUES.*", ignore_case = TRUE))]
df_text[, text := str_remove_all(text, regex("Notes bibliographiques.*", ignore_case = TRUE))]
df_text[, text := str_remove_all(text, regex("Bibliographie .*", ignore_case = TRUE))]
df_text[, text := str_remove_all(text, regex("Bibliography .*", ignore_case = TRUE))]
df_text[, text := str_remove_all(text, regex("APPENDIX .*", ignore_case = TRUE))]
# handle french special character
df_text[, text := str_replace_all(text, "fa on", "façon")]
df_text[, text := str_replace_all(text, regex("fran ais", ignore_case = TRUE), "Français")]
df_text[, text := str_replace_all(text, regex("fran e", ignore_case = TRUE), "France")]
df_text[, text := str_replace_all(text, " uvre ", "oeuvre")]
df_text[, text := str_replace_all(text, "e ment ", "ement")]
df_text[, text := str_replace_all(text, " tion ", "tion ")]
# Construct final text column
df_text[, text := tolower(paste(title, ".", abstract_fr, text)), by = id]
saveRDS(df_text, here(intermediate_data_path, "df_full_text.rds"), compress = TRUE)
#### TOKENIZATION ####
# df_text <- readRDS(here(intermediate_data_path, "df_full_text.rds"))
# Tokenize sentences while keeping the document ID
df_tokens <- df_text %>%
select(id, text) %>%
mutate(tokens = tokenizers::tokenize_words(text,
lowercase = TRUE,
strip_punct = TRUE, # delete punctuation
strip_numeric = TRUE, # delete numbers
simplify = FALSE)) %>%
ungroup %>%
unnest(tokens) %>% # Expand token lists into rows
group_by(id) %>%
mutate(token_id = row_number()) %>%
rename(token = tokens) %>% # Rename column for clarity
select(id, token, token_id)
#### STOPWORDS ####
# prepare stop_words
stop_words <- bind_rows(get_stopwords(language = "fr", source = "stopwords-iso"),
get_stopwords(language = "fr", source = "snowball"),
get_stopwords(language = "en", source = "stopwords-iso"),
get_stopwords(language = "en", source = "snowball")) %>%
distinct(word) %>%
pull(word)
custom_stop_words <- c(
"faire",
"faut",
"résumé",
"article",
"analyse",
"analyser",
"analysons",
"analysent",
"approche",
"étude",
"étudie",
"étudions",
"étudient",
"montrons",
"montrer",
"montre",
"montrent",
"permettre",
"permet",
"permettent",
"proposer",
"propose",
"proposons",
"proposent",
"utiliser",
"mettre",
"présente",
"présentons",
"présenter",
"role",
"rôle"
)
stop_words <- c(stop_words, custom_stop_words)
# use data.table for efficiency
# Convert to data.table if not already
setDT(df_tokens)
# Remove article contractions, punctuation from tokens
df_tokens[, token := str_remove_all(token, "^(.*qu|[mjldscn])[\u0027\u2019\u2032\u0060]")]
df_tokens[, token := str_remove_all(token, "[[:punct:]]")]
# once, token are cleaned, we can remove stopwords, non-latin characters, digits and one letter characters
df_tokens <- df_tokens[!token %in% stop_words]
df_tokens <- df_tokens[!str_detect(token, "[^\\p{Latin}]")]
# df_tokens <- df_tokens[!str_detect(token, "[\u0370-\u03FF]")]
df_tokens <- df_tokens[!str_detect(token, "^.*\\d+.*$")]
df_tokens <- df_tokens[str_detect(token, "[[:letter:]]")]
#### BIGRAMS ####
# Create bigrams
df_tokens <- df_tokens[order(id, token_id)] # Ensure correct order
df_tokens[, bigram := ifelse(token_id < shift(token_id, type = "lead"),
paste(token, shift(token, type = "lead"), sep = "_"),
NA),
by = .(id)]
# filter na and count bigrams, keep only bigrams that appear more than 10 times
bigram_counts <- df_tokens[!is.na(bigram)]
bigram_counts <- bigram_counts[, .N, by = .(id, token, bigram)]
bigram_counts <- bigram_counts[N > 20]
# Split bigram into word_1 and word_2
bigram_counts[, c("word_1", "word_2") := tstrsplit(bigram, "_", fixed = TRUE)]
# Remove bigrams where either word is a stopword
bigram_counts <- bigram_counts[!(word_1 %in% stop_words | word_2 %in% stop_words)]
# Assign a unique window ID to each bigram (acts like `window_id`)
bigram_counts[, window_id := .I] # .I is the row number (unique ID), the context window is thus only the bigram itself
# Convert to long format (similar to pivot_longer)
bigram_long <- melt(bigram_counts,
id.vars = "window_id",
measure.vars = c("word_1", "word_2"),
variable.name = "rank",
value.name = "word") %>%
as.data.table()
# Calculate PMI values
#Count occurrences of each word
word_prob <- df_tokens[, .N, by = token]
total_tokens <- sum(word_prob$N)
word_prob[, prob := N / total_tokens]
#Count occurrences of each bigram
bigram_prob <- df_tokens[!is.na(bigram), .N, by = bigram]
total_bigrams <- sum(bigram_prob$N)
bigram_prob[, prob := N / total_bigrams]
# Merge word_1 probabilities into bigram table and rename
bigram_counts <- merge(bigram_counts, word_prob[, .(token, prob)], by.x = "word_1", by.y = "token", all.x = TRUE)
setnames(bigram_counts, "prob", "prob_word_1")
# Merge word_2 probabilities into bigram table and rename
bigram_counts <- merge(bigram_counts, word_prob[, .(token, prob)], by.x = "word_2", by.y = "token", all.x = TRUE)
setnames(bigram_counts, "prob", "prob_word_2")
# merge bigram probabilities into bigram table and rename
bigram_counts <- merge(bigram_counts, bigram_prob, by = "bigram")
setnames(bigram_counts, "prob", "prob_bigram")
# compute pmi
bigram_counts[, pmi := log2(prob_bigram / (prob_word_1 * prob_word_2))]
# keep only bigrams with pmi > 0
bigram_to_keep <- bigram_counts[pmi > 0]
bigram_to_keep <- bigram_to_keep[, keep_bigram := TRUE]
# Add bigrams to the token list
df_tokens_final <- df_tokens %>%
left_join(bigram_to_keep) %>%
mutate(token = if_else(keep_bigram, bigram, token, missing = token),
token = if_else(lag(keep_bigram), lag(bigram), token, missing = token),
token_id = if_else(lag(keep_bigram), token_id - 1, token_id, missing = token_id)) %>%
distinct(id, token_id, token)
# save in term list format
term_list <- df_tokens_final %>%
rename(term = token)
saveRDS(term_list, here(intermediate_data_path, "term_list_FULL_TEXT.rds"))
#### PREPROCESSING ####
term_list <- readRDS(here(intermediate_data_path, "term_list_FULL_TEXT.rds"))
# create stm objects diff pre-processing
corpora_in_dfm <- list()
corpora_in_stm <- list()
treshsholds <- c(1, 5, 10, 15, 20, 30)
# manage duplicate id from persée
for (i in 1:length(treshsholds)) {
term_to_remove <- term_list %>%
distinct(id, term) %>%
count(term, name = "frequency") %>%
filter(frequency <= i) %>%
distinct(term)
#remove words
terms_list_filtered <- term_list %>%
filter(!term %in% term_to_remove$term)
#transform list of terms into stm object
corpus_in_dfm <- terms_list_filtered %>%
add_count(term, id) %>%
cast_dfm(id, term, n)
treshold <- treshsholds[[i]] %>% as.character()
# dfm object
corpora_in_dfm[[treshold]] <- corpus_in_dfm
# stm object with covariate
metadata <- terms_list_filtered %>%
select(id) %>%
left_join(df_text, by = "id") %>%
mutate(year = as.integer(year),
has_female = as.factor(has_female),
is_varia = as.factor(is_varia),
has_female = relevel(has_female, ref = "0"),
is_varia = relevel(is_varia, ref = "0")) %>%
select(id, text, authors, title, abstract_fr, year, has_female, is_varia) %>%
unique
corpus_in_stm <- quanteda::convert(corpus_in_dfm, to = "stm", docvars = metadata)
corpora_in_stm[[treshold]] <- corpus_in_stm
}
saveRDS(corpora_in_stm, here(intermediate_data_path, "corpora_in_stm_FULL_TEXT.rds"))Entre 1969 et 2023, 3677 documents possèdent un résumé en français. La Figure 11 montre la distribution des résumés par année sur la période.
gg <- df_text %>%
count(year) %>%
mutate(tooltip = paste("Année:", year, "<br>Count:", n)) %>%
ggplot(aes(x = as.integer(year), y = n, text = tooltip)) +
geom_col(binwidth = 1,
fill = colors[[1]]) +
labs(x = "", y = "Nombre de documents par année") +
theme_light(base_size = 15)
ggsave(
"distribution_texts_tm.png",
device = "png",
plot = gg,
path = figures_path,
width = 8,
height = 4.5,
dpi = 300
)
plotly::ggplotly(gg, tooltip = "text") %>%
config(displayModeBar = FALSE) La tokenization a été réalisés grâce à la bibliothèque tokenizers. La liste des mots qui en découle est ensuite nettoyée pour supprimer les mots peu informatifs, typiquement certains caractères spéciaux, les chiffres et les mots d’une lettre, ainsi qu’une liste de stopwords. Les tokens sont généralement des unigrams mais nous avons également inclu des bigrams. Nous avons conservé les bigram leur score de Point Mutual Information (PMI):
\[ PMI(w_1, w_2) = \log\left( \frac{P(w_1, w_2)}{P(w_1)P(w_2)} \right) \]
Le PMI estime les chances d’observer deux mots ensemble par rapport à la probabilité d’observer ces mots indépendamment. Un PMI positif indique que les mots sont plus souvent observés ensemble que séparément. Nous avons conservé les bigrams qui apparaissent plus de 10 fois dans le corpus et présentant un PMI supérieur à 0.
Une pratique standard en modélisation thématique consiste à réduire la liste du vocabulaire en filtrant les mots peu utilisés. Par exemple, il est théoriquement peu utile de conserver les mots utilisés uniquement dans un seul document puisque par construction, une thématique est un ensemble de mots qui tendent à co-occurer ensemble. Filtrer les mots utilisés uniquement par un document ne fait pas perdre pas beaucoup d’information mais augmente le temps computationnel en réduisant la taille du vocabulaire. Filtrer les mots peut également augmenter l’interprétabilité des thématiques. Intuitivement, un mot utilisé dans seulement quelques documents est peu informatif puisque les mots apparaissant rarement ne participent pas significativement à la structuration des thématiques et peuvent introduire du bruit dans l’analyse. Pour tester l’effet de différents filtrages, nous construisons différentes représentations du corpus en filtrant les mots qui apparaissent dans moins de \(N\) documents, avec \(N \in [1, 5, 10, 15, 20, 30]\).
A partir de six représentations du corpus, nous cherchons à estimer le nombre de thématique de notre modèle \(K\). Pour déterminer \(K\), nous entraînons une série de modèles avec \(K \in {10, 20, ..., 70}\). Nous estimons un modèle pour chaque valeur de \(K\) (nombre de thématiques) et chaque valeur de \(N\) représentation du corpus (filtrage des mots), soit 42 modèles.
#' K evaluation
#' to start the session open
library(stm)
library(furrr)
library(tidyverse)
corpora_in_stm <- readRDS(here::here(intermediate_data_path, "corpora_in_stm.rds"))
#prepare furrr parallélisation
#
# nb_cores <- availableCores() / 2
# plan(multisession, workers = nb_cores)
#run multiple topic models
seed <- 123
many_stm <- tibble::tibble(
K = seq(10, 70, by = 10),
preprocessing = list(names(corpora_in_stm))) %>%
tidyr::unnest(cols = c(K, preprocessing)) %>%
dplyr::mutate(st_models = map2(
K,
preprocessing,
~ {
# run stm
stm::stm(
documents = corpora_in_stm[[.y]]$documents,
vocab = corpora_in_stm[[.y]]$vocab,
data = corpora_in_stm[[.y]]$meta,
prevalence = as.formula("~has_female + is_varia + s(year)"),
K = .x,
init.type = "Spectral",
max.em.its = 800,
verbose = FALSE,
seed = seed
)
},
.progress = TRUE,
.options = furrr_options(seed = seed)
))
saveRDS(many_stm, here::here(intermediate_data_path, "many_stm.rds"), compress = TRUE)Il n’existe pas de choix non ambigu de \(K\). Ce dernier dépends essentiellement de la question de recherche et d’une évaluation qualitative de différents modèles. Plusieurs métriques quantitatives peuvent cependant aider à restreindre le choix parmi les valeurs de \(K\) possibles. Nous avons utilisés deux métriques: la FREX et la cohérence sémantique pour chacune de ces combinaisons.
La cohérence sémantique mesure la similarité entre les mots d’un thème (Mimno et al. 2011). Similaire à la PMI dans l’esprit, la cohérence sémantique mesure la probabilité de voir deux mots ensemble dans un thème. A partir d’une liste de \(M\) mots les plus probables par thématique, la cohérence d’un topic \(k \in K\) est calculée comme suit:
\[C_k = \sum_{i = 2}^{M} \sum_{j=1}^{i-1} \log\left( \frac{D(w_{i,k}, w_{j,k}) + 1}{D(w_{j,k})} \right)\] Où \(D(w_{i}, w_{j})\) est le nombre de documents où les mots \(w_{i,k}\) et \(w_{j,k}\) apparaissent ensemble au moins une fois et \(D(w_{j})\) est le nombre de documents où le mot \(w_{j,k}\) apparaît au moins une fois. \(M\) est fixé à 10 par défaut et nous avons utilisé cette valeur dans nos calculs. Plus la cohérence est élevée, plus les mots d’une thématique ont tendance à apparaître ensemble. Quand \(K\) est grand, la cohérence des thématiques tend à diminuer.
La FREX (ou FREquent EXclusivity) est une mesure qui partage l’esprit de la célèbre mesure tf-idf et vise à évaluer l’importance d’un mot \(w\) dans un thème \(k\), en tenant compte à la fois de sa fréquence et de son exclusivité (Bischof and Airoldi 2012). Elle est définie par la formule suivante :
\[FREX(w, k) = \left(\frac{a}{F} + \frac{1 - a}{E}\right)^{-1}\]
Avec \(F\) est le rang normalisé du mot \(w\) en terme de fréquence dans le thème \(k\) et \(E\) est le rang normalisé du mot \(w\) en terme d’exclusivité du mot \(w\) dans le thème \(k\).1. L’exclusivité est la probabilité que le mot \(w\) appartienne à la thématique \(j\), probabilité donné par la distribution \(\beta_{j}\), sur la somme des probabilités \(\beta_{w, 1:K}\), soit \(\frac{\beta_{w,j}}{\sum_1^K\beta_{w,k}}\). La valeur \(\beta_{w,j}\) estime quel est la probabilité que le mot \(w\) appartienne à \(j\). Normalisé, cela mesure à quel point \(w\) est exclusif à \(j\) par rapport aux autres thématiques.
La moyenne harmonique accorde moins d’importance aux mots qui ont un score élévé pour seulement une seule dimension. L’idée est de pénaliser à la fois les mots très fréquents mais peu exclusif et les mots rares peu fréquent mais très exclusif. \(a\) est une variable pondérant l’importance accordée aux deux mesures respectives - \(a\) est fixé à \(0.3\) par défaut et nous avons utilisé cette valeur dans nos calculs.2 La FREX d’une thématique est calculé pour les 10 mots les plus probables de chaque thématiques. Plus la FREX est elevé, plus la thématique est exclusive et considérer de qualité. Quand \(K\) est grand, la FREX d’une thématique tend à augmenter.
Les Figure 12 estime la FREX et l’exlusivité pour différents \(K\) et pour différents prétraitements. Nous avons utilisé la bibliothèque stm pour estimer ces métriques, respectivement les fonctions stm::semanticCoherence, stm::exclusivity. Ces résultats indiquent que, quelque soit le prétraitement, un nombre de thèmes de 50 semble être un bon compromis entre la cohérence sémantique et la FREX.
many_stm <- readRDS(here::here(intermediate_data_path, "many_stm.rds"))
corpora_in_stm <- readRDS(here(intermediate_data_path, "corpora_in_stm.rds"))
# estimate exclusivity and coherence
setDT(many_stm)
# unnest corpus_in_stm by K
many_stm[, corpus_in_stm := corpora_in_stm, by = K]
# many_stm[, heldout := future_map(corpus_in_stm, ~ make.heldout(.x$documents, .x$vocab))]
many_stm[, exclusivity := map(st_models, exclusivity)]
many_stm[, semantic_coherence := map2(st_models, corpus_in_stm, ~ semanticCoherence(.x, .y$documents))]
evaluation_result <- many_stm[, .(
K,
preprocessing,
# heldout = mean(unlist(map(eval_heldout, "expected.heldout"))),
# residual = mean(unlist(map(residual, "dispersion"))),
semantic_coherence = map_dbl(semantic_coherence, mean),
exclusivity = map_dbl(exclusivity, mean)
# lbound
)]evaluation_result <- readRDS(here(intermediate_data_path, "evaluation_result_FULL_TEXT.rds"))
# plotting general metrics and choose a preprocessing treshold
k_metric_summary <- evaluation_result %>%
# rename(`Heldout` = heldout) %>%
select(K, preprocessing, semantic_coherence, exclusivity) %>%
rename(frex = exclusivity) %>%
gather(Metric, Value, -K, -preprocessing) %>%
mutate(preprocessing = factor(preprocessing,
levels = c("1", "5", "10", "15", "20", "30"))) %>%
mutate(Metric = recode(Metric,
"semantic_coherence" = "Cohérence",
"frex" = "FREX"))
gg <- k_metric_summary %>%
ggplot(aes(K, Value, color = preprocessing)) + # Include preprocessing in aes()
geom_point(size = 2) +
geom_line() +
# Removed show.legend = FALSE
facet_wrap(~ Metric, scales = "free_y") +
labs(
x = "K (Nombre de thématiques)",
y = NULL,
color = "Filtre",
linetype = "Filtre",
) +
theme_light(base_size = 15) +
# delete grey background
theme(legend.key = element_blank(),
strip.background = element_rect(colour="white",fill="white"),
# color in black
strip.text = element_text(color = "black"),
)
# add specific geom point
colors <- c(
"#0072B280", # Bleu foncé (anciennement "fr")
"#009E7380", # Vert (anciennement "other")
"#CC79A780", # Magenta/Rose (anciennement "en")
"#F0E44280", # Jaune (anciennement "de")
"#E69F0080", # Orange
"#76428A80" # Bleu ciel
)
gg1 <- gg +
geom_point(data = k_metric_summary %>%
filter((K == 30 & preprocessing %in% c("30", "15") & Metric == "FREX") |
(K == 40 & preprocessing %in% c("5") & Metric == "Cohérence") |
(K == 50 & preprocessing %in% c("30") & Metric == "FREX")),
aes(K, Value),
color = "red",
size = 3) +
scale_color_manual(values = colors)
ggsave(
"K_eval_FULL_text.jpg",
device = "jpg",
plot = gg1,
path = here(figures_path),
width = 8,
height = 4.5,
dpi = 300
)
gg1
table_exclusivity_coherence <- evaluation_result %>%
select(K, preprocessing, semantic_coherence, exclusivity)
DT::datatable(
table_exclusivity_coherence,
extensions = 'Buttons',
options = list(
dom = 'Blfrtip',
buttons = c('excel', 'csv'),
pageLength = 10
)
)Nous avons inclus trois covariates: l’année de publication des articles, une variable de genre, has_female et une variable sur le type de publication is_varia. has_female est une variable muette qui indique si un article comprend une auteure is_varia est une variable muette qui indique si un article est un varia (ou sinon un numéro spécial) et nous permettra d’analyser la politique éditoriale de la revue.
library(tidyverse)
library(stm)
#' Running Topic model
# load data
corpus_in_stm <- readRDS(here(intermediate_data_path, "corpora_in_stm_FULL_TEXT.rds"))[["15"]]
many_stm <- readRDS(many_stm_path <- here::here(intermediate_data_path, "many_stm_full_text.rds"))
structured_topic_model <- many_stm %>% filter(K == 30 & preprocessing == "15") %>% pull(st_models) %>% .[[1]]
saveRDS(structured_topic_model, here::here(intermediate_data_path, "structured_topic_model.rds"))
# save distributions in separated tibbles
label_topic <- labelTopics(structured_topic_model, n = 5)
meta <- corpus_in_stm$meta %>%
mutate(document = row_number(),
# cut text
text = str_trunc(text, 500)
)
top_terms_prob <- label_topic %>% .[[1]] %>%
as_tibble() %>%
reframe(topic_label_prob = pmap_chr(., ~ paste(c(...), collapse = ", "))) %>%
mutate(topic = row_number())
top_terms_frex <- label_topic %>% .[[2]] %>%
as_tibble() %>%
reframe(topic_label_frex = pmap_chr(., ~ paste(c(...), collapse = ", "))) %>%
mutate(topic = row_number())
gamma <- tidy(structured_topic_model,
matrix = "gamma") %>%
left_join(meta) %>%
left_join(top_terms_prob, by = "topic") %>%
left_join(top_terms_frex, by = "topic")
beta <- tidy(structured_topic_model, matrix = "beta")
saveRDS(gamma, here(intermediate_data_path, "gamma.rds"))
saveRDS(beta, here(intermediate_data_path, "beta.rds"))gamma <- readRDS(here(intermediate_data_path, "gamma.rds"))
beta <- readRDS(here(intermediate_data_path, "beta.rds"))
gamma_mean <- gamma %>%
group_by(topic, topic_label_prob, topic_label_frex) %>%
summarise(gamma = mean(gamma)) %>%
ungroup %>%
mutate(topic = reorder(topic, gamma))
gg <- gamma_mean %>%
ggplot() +
geom_segment(
aes(x = 0, xend = gamma, y = topic, yend = topic),
color = "black",
size = 0.5
) +
geom_text(
aes(
x = gamma,
y = topic,
label = paste0("Thématique ", topic, ": ", topic_label_prob)
),
size = 6,
hjust = -.01,
nudge_y = 0.0005
) +
scale_x_continuous(
expand = c(0, 0),
limits = c(0, max(gamma_mean$gamma) + 0.05)
) +
theme_light() +
theme(
text = element_text(size = 20),
axis.text.y = element_blank(), # Removes y-axis text
axis.ticks.y = element_blank() # Removes y-axis ticks
) +
labs(
x = "Prévalences moyennes des thématiques",
y = NULL,
caption = "\n\n Note: chaque thématique est associée à ses mots les plus probables selon la distribution beta"
)
ggsave(
glue::glue("stm_summary.png"),
device = "png",
plot = gg,
path = figures_path,
width = 15,
height = 15,
dpi = 300
)
print(gg)
# Filtrer les 10 documents les plus associés à chaque topic
gamma_top10 <- gamma %>%
group_by(topic) %>%
slice_max(order_by = gamma, n = 10) %>%
ungroup() %>%
select(topic, id, gamma, title, authors) %>%
# cut text
# mutate(text = str_trunc(text, 500))
arrange(topic, desc(gamma))
# Affichage avec DT
gamma_top10 %>%
DT::datatable(
extensions = c('Buttons', 'ColReorder', 'FixedHeader'),
options = list(
dom = 'Bfrtip',
buttons = c('excel', 'csv'),
pageLength = 10,
colReorder = TRUE,
fixedHeader = TRUE,
order = list(list(2, 'desc')),
search = list(regex = TRUE, caseInsensitive = TRUE),
columnDefs = list(
list(width = '500px', targets = 3)
)
),
filter = "top"
)# facet wrap
gg <- gamma %>%
filter(gamma > 0.3) %>%
ggplot(aes(x = gamma)) +
geom_density(alpha = 0.5) + # Density plot with transparency
facet_wrap(~ factor(topic, levels = sort(unique(topic))), scales = "free") + theme_light() +
labs(x = "Valeur de la prévalence",
y = "Densité",
caption = "Distribution des prévalences par documents et par thématiques (uniquement pour les valeurs de theta > 0.3)") +
theme(legend.position = "none") # Remove redundant legend
ggsave(
"distribution_theta.png",
device = "png",
plot = gg,
path = here(figures_path),
width = 50,
height = 50,
units = "cm",
)
print(gg)
# Filtrer les 10 documents les plus associés à chaque topic
beta_top10 <- beta %>%
group_by(topic) %>%
slice_max(order_by = beta, n = 10) %>%
ungroup()
# Affichage avec DT
beta_top10 %>%
DT::datatable(
extensions = c('Buttons', 'ColReorder', 'FixedHeader'),
options = list(
dom = 'Bfrtip',
buttons = c('excel', 'csv'),
pageLength = 10,
colReorder = TRUE,
fixedHeader = TRUE,
order = list(list(2, 'desc')),
search = list(regex = TRUE, caseInsensitive = TRUE),
columnDefs = list(
list(width = '500px', targets = 3)
)
),
filter = "top"
)structured_topic_model <- readRDS(here(intermediate_data_path, "structured_topic_model.rds"))
corpus_in_stm <- readRDS(here(intermediate_data_path, "corpora_in_stm_FULL_TEXT.rds"))[["15"]]
corr <- stm::topicCorr(structured_topic_model, cutoff = 0.001)
# matric to table
corr_table <- reshape2::melt(corr$cor)
label_topic <- labelTopics(structured_topic_model, n = 10)
nodes <- label_topic %>% .[[1]] %>%
as_tibble() %>%
reframe(topic_label_prob = pmap_chr(., ~ paste(c(...), collapse = ", "))) %>%
mutate(source_id = row_number())
edges <- corr_table %>%
dplyr::filter(Var1 != Var2) %>%
rename(source_id = Var1,
target_id = Var2,
weight = value)
graph <- tidygraph::tbl_graph(nodes = nodes, edges = edges, directed = FALSE)
# if you want to normalize weigth to handle negative value
# graph_normalize <- graph %>%
# activate(edges) %>%
# mutate(weight = rescale(weight, to = c(0.01, 1)))
# fa 2
graph_layout <- vite::complete_forceatlas2(graph, first.iter = 50000, kgrav = 1)
#add leiden clusters
# graph_cluster <- networkflow::add_clusters(graph_layout,
# clustering_method = "leiden",
# objective_function = "modularity",
# resolution = 1)
# save
saveRDS(graph_layout, here(intermediate_data_path, "graph_layout.rds"))
saveRDS(corr_table, here(intermediate_data_path, "corr.rds"))graph_layout <- readRDS(here(intermediate_data_path, "graph_layout.rds"))
gg <- ggraph(graph_layout,
"manual",
x = x,
y = y) +
geom_edge_arc0(aes(
# color = cluster_leiden,
width = weight),
alpha = 0.1, strength = 0.2, show.legend = FALSE) +
scale_edge_width_continuous(range = c(0.1,0.3)) +
# scale_edge_colour_identity() +
geom_point(aes(x = x, y = y)) +
geom_label_repel_interactive(aes(x = x,
y = y,
# color = cluster_leiden,
label = source_id,
tooltip = topic_label_prob,
data_id = source_id)) +
scale_size_continuous(range = c(0.5,3)) +
# scale_fill_identity() +
theme_void()
girafe(ggobj = gg,
width_svg = 8,
height_svg = 4.5)corr_table <- readRDS(here(intermediate_data_path, "corr.rds"))
corr_table %>%
DT::datatable(
extensions = 'Buttons',
options = list(
dom = 'Blfrtip',
buttons = c('excel', 'csv'),
pageLength = 5
)
)# load meta topics
structured_topic_model <- readRDS(here(intermediate_data_path, "structured_topic_model.rds"))
corpus_in_stm <- readRDS(here(intermediate_data_path, "corpora_in_stm_FULL_TEXT.rds"))[["15"]]
metatopics <- xlsx::read.xlsx(here(intermediate_data_path, "metatopics_k30_f15_thomas.xlsx"),
sheetIndex = 1)
metatopics <- metatopics %>%
select(-remarques)
# output metatopics in latex format
# latex_output <- metatopics %>%
# left_join(top_terms_prob)
#
# kableExtra::kable(latex_output, format = "latex", booktabs = TRUE, escape = FALSE)
metatopics %>%
rename("meta-thématiques" = champ) %>%
DT::datatable(
extensions = 'Buttons',
options = list(
dom = 'Blfrtip',
buttons = c('excel', 'csv'),
pageLength = 5
)
)manual_color <- c("Analyse historique" = "#D55E00",
"Macroéconomie" = "#009E73",
"Expertise économique" = "#CC79A7",
"Microéconomie" = "#E69F00",
"Economie internationale" = "#56B4E9"
# "Finance et banque" = "#F0E442", # Jaune
# "Macroéconométrie" = "#0072B2" # Bleu
)
label_topic <- labelTopics(structured_topic_model, n = 5)
meta <- corpus_in_stm$meta %>%
mutate(document = row_number())
top_terms_prob <- label_topic %>% .[[1]] %>%
as_tibble() %>%
reframe(topic_label_prob = pmap_chr(., ~ paste(c(...), collapse = ", "))) %>%
mutate(topic = row_number())
gamma <- tidy(structured_topic_model,
matrix = "gamma") %>%
left_join(meta) %>%
left_join(top_terms_prob, by = "topic")
meta_gamma_mean_year <- gamma %>%
left_join(metatopics %>% select(topic, label, champ), by = "topic") %>%
select(topic, champ, gamma, year) %>%
group_by(year, topic) %>%
mutate(gamma = mean(gamma)) %>%
unique %>%
group_by(year, champ) %>%
reframe(sum = sum(gamma))
gg1 <- meta_gamma_mean_year %>%
ggplot(aes(
x = year,
y = sum,
group = champ,
fill = champ,
)) +
stat_smooth(geom = 'area',
position = 'stack',
method = "loess",
span = 0.25) +
labs(title = "",
x = "",
y = "Somme des prévalences moyennes par année",
fill = "Meta-thématiques") +
scale_fill_manual(values = manual_color) +
theme(text = element_text(size = 12)) +
theme_light()
ggsave(
"meta_gamma_year.png",
device = "png",
plot = gg1,
path = here(figures_path),
width = 16,
height = 9,
units = "cm",
)
gg1
meta_gamma_mean_year %>%
DT::datatable(
extensions = 'Buttons',
options = list(
dom = 'Blfrtip',
buttons = c('excel', 'csv'),
pageLength = 5
)
)Pour chaque thématique \(k\) et document \(d\), nous cherchons à prédire la prévalence \(\theta_{d,k}\) en fonction des covariables choisies. Nous estimons le modèle suivant:
\[ \theta_{d,k} = \beta_0 + \beta_1 * hasfemale_d + \beta_2 * isvaria_d + \beta_3 * year_d + \epsilon_{d,k} \] Où \(hasfemale\) est une variable muette indiquant si le document a un auteur féminin (1) ou non (0), \(isvaria_d\) est une variable muette indiquant si le document est un varia (1) ou non (0), et \(year_d\) est l’année de publication du document. Nous appliquons une transformation b-spline à l’année pour capturer d’éventuels effets non linéaires.
Dans un modèle linéaire, l’estimateur \(\beta_3\) d’une variable temps comme l’année mesure l’effet marginal d’une année supplémentaire sur la prévalence espérée de la thématique. Cette linéarité ne permet pas d’identifier des effets non-linéaires, par exemple une prévalence importante durant les années 1990 et suivie d’une décroissance. Pour ce faire, nous appliquons une fonction b-spline à l’année pour capturer d’éventuels effets non linéaires Formellement, notre estimateur de la variable \(year_d\) devient une combinaison linéaire de \(n\) estimateurs et de fonctions polynomiale \(B(x)\), aussi appelé dans ce contexte fonctions de base:
\[\beta_3 * year_d = \sum_1^n \alpha_1 \times B_{1}(year_d) + ... + \alpha_{n}\times B_{n}(year_d)\]
Cette transformation b-spline est réalisée sous R via la fonction stm::s(df = 10), un wrapper de la fonction splines:bs().
# compute basis function
splines <- cbind(tibble(year = 1969:2023), stm::s(1969:2023, df = 10))
splines <- reshape2::melt(splines, id.var = "year")
ggplot(splines, aes(
x = year,
y = value,
color = variable,
group = variable
)) +
geom_line() +
labs(x = "x",
y = unname(latex2exp::TeX("$B_n(x)$")),
color = "n")+
theme_light()
L’inconvénient d’un tel traitement est que les estimateurs \(\alpha_1 ... \alpha_n\) ne sont pas interprétables. Chaque coefficient represente le poids d’une fonction polynomiale \(B_n\) dans la prévalence totale. Plutôt que de se focaliser sur la table de regression, il est plus intéressant de calculer directement la prévalence espérée du modèle pour une valeur de \(year\).
Figure 17 montre le résultat d’une telle estimation pour un topic avec et sans le traitement stm::s(). Chaque point represente la prévalence espérée pour un point donnée dans l’intervalle \([1969:2023]\) (avec le reste des covariates avec une valeur 0 de référence). Si l’estimation sans traitement permet d’identifier l’effet linéaire d’une baisse dans la popularité de cette thématique, l’estimation non linéaire permet d’identifier une évolution beaucoup plus subtile de la prévalence de ce topic dont la popularité s’accroit à la fin du 20ème siècle avant de progressivement diminuer.
# load data
corpora_in_stm <- readRDS(here::here(intermediate_data_path, "corpora_in_stm_full_text.rds"))
corpus_in_stm <- corpora_in_stm[["15"]]
structured_topic_model <- readRDS(here(intermediate_data_path, "structured_topic_model.rds"))
topic_chosen <- 28
# average prevalence
metadata <- corpus_in_stm$meta %>%
as_tibble %>%
mutate(document = row_number()) %>%
select(year, document)
# tidy call gamma the prevalence matrix, stm calls it theta
theta <- broom::tidy(structured_topic_model, matrix = "gamma") %>%
# broom called stm theta matrix gamma
left_join(metadata, by = "document")
theta_mean <- theta %>%
filter(topic == topic_chosen) %>%
group_by(topic, year) %>%
reframe(theta_mean = mean(gamma))
#plot
gg_average <- theta_mean %>%
ggplot(aes(x = year, y = theta_mean)) +
geom_line(color = "red") +
labs(y = "Prévalence moyenne",
x = "Année") +
theme_light(base_size = 15)
# run regressions
formula_spline <- as.formula("~ has_female + is_varia + s(year)")
formula_nospline <- as.formula("~ has_female + is_varia + year")
metadata <- corpus_in_stm$meta %>% as_tibble %>%
mutate(year = as.numeric(year),
has_female = as.factor(has_female),
is_varia = as.factor(is_varia),
has_female = relevel(has_female, ref = "0"),
is_varia = relevel(is_varia, ref = "0"))
# estimate effect with spline and without
estimate_effect_spline <- estimateEffect(formula_spline,
structured_topic_model,
metadata = metadata,
documents = corpus_in_stm$documents,
uncertainty = "None",
nsims = 25)
estimate_effect_nospline <- estimateEffect(formula_nospline,
structured_topic_model,
metadata = metadata,
documents = corpus_in_stm$documents,
uncertainty = "None",
nsims = 25)
# plot
gg_nospline <- tidystm::extract.estimateEffect(
estimate_effect_nospline,
"year",
method = "continuous",
topic = topic_chosen,
model = structured_topic_model,
labeltype = "prob",
npoints = length(1950:2023),
n = 5
) %>%
ggplot(aes(x = covariate.value)) +
geom_line(aes(y = estimate), color = "red") +
geom_line(aes(y = ci.lower), color = "red", linetype = "dashed") +
geom_line(aes(y = ci.upper), color = "red", linetype = "dashed") +
labs(y = "Prévalence espérée de la thématique",
x = "Valeur de variable année") +
theme_light(base_size = 15)
gg_spline <- tidystm::extract.estimateEffect(
estimate_effect_spline,
"year",
method = "continuous",
topic = topic_chosen,
model = structured_topic_model,
labeltype = "prob",
npoints = length(1950:2023),
n = 5
) %>%
ggplot(aes(x = covariate.value)) +
geom_line(aes(y = estimate), color = "red") +
geom_line(aes(y = ci.lower), color = "red", linetype = "dashed") +
geom_line(aes(y = ci.upper), color = "red", linetype = "dashed") +
geom_hline(yintercept = 0, linetype = "dashed") +
labs(y = "Prévalence espérée de la thématique",
x = "Valeur de variable année") +
theme_light(base_size = 15)
label <- top_terms_prob %>% filter(topic == topic_chosen)
gg <- gg_average + gg_spline
ggsave(
glue::glue("theta_average_{topic_chosen}.png"),
device = "png",
plot = gg,
path = figures_path,
width = 8,
height = 4.5,
dpi = 300
)
gg_average
gg_nospline
gg_spline
Le package stm propose également de prendre en compte l’incertitude sur l’estimation de la prévalence dans les régressions de prévalence. Le nombre de prévalences simulées (et donc de régressions) par thématique est fixé à 25 par défaut. Nous avons suivi ce paramétrage. Cette fonctionnalité est intégrée dans la fonction stm::estimateEffect. Pour chaque \(K\) thématiques, 25 régressions estiment la prévalence par document.
# data
structured_topic_model <- readRDS(here::here(intermediate_data_path, "structured_topic_model.rds"))
# load data
corpora_in_stm <- readRDS(here::here(intermediate_data_path, "corpora_in_stm_FULL_TEXT.rds"))
corpus_in_stm <- corpora_in_stm[["15"]]
# create covariates and check level
metadata <- corpus_in_stm$meta %>% as_tibble %>%
mutate(year = as.numeric(year),
has_female = as.factor(has_female),
is_varia = as.factor(is_varia),
has_female = relevel(has_female, ref = "0"),
is_varia = relevel(is_varia, ref = "0"))
# check level factor variable
# levels(metadata$has_female)
# levels(metadata$is_varia)
# create regression formula
formula_obj <- as.formula("~ has_female + is_varia + s(year)")
estimate_effect <- estimateEffect(formula_obj,
structured_topic_model,
metadata = metadata,
documents = corpus_in_stm$documents,
uncertainty = "Local",
nsims = 25)
saveRDS(estimate_effect, here::here(intermediate_data_path, paste0("estimate_effect_Local.rds")))
# interaction date & gender
formula_obj <- as.formula("~ + has_female*s(year)")
estimate_effect <- estimateEffect(formula_obj,
structured_topic_model,
metadata = metadata,
documents = corpus_in_stm$documents,
uncertainty = "Local",
nsims = 25)
saveRDS(estimate_effect, here::here(intermediate_data_path, "estimate_effect_Local_interaction.rds"))Table 9 donne les résultats avec la prise en compte de l’incertitude. Chaque estimateur est une moyenne des 25 estimateurs simulés.
estimate_effect <- readRDS(here::here(intermediate_data_path, "estimate_effect_Local.rds"))
summary <- summary(estimate_effect)
summary_tibble <- summary$tables %>%
purrr::imap_dfr(~ {
tibble(
topic = .y, # Extract topic number
term = rownames(.x), # Covariate names
estimate = .x[, 1], # Coefficients
std_error = .x[, 2], # Standard errors
t_value = .x[, 3], # Confidence interval lower bound
p_value = .x[, 4] # Confidence interval upper bound
)
})
summary_tibble %>%
DT::datatable(
rownames = FALSE,
extensions = 'Buttons',
options = list(
dom = 'Blfrtip',
buttons = c('excel', 'csv'),
pageLength = 13
)
)estimate_effect <- readRDS(here::here(intermediate_data_path, "estimate_effect_Local.rds"))
label_topic <- labelTopics(structured_topic_model, n = 5)
top_terms_prob <- label_topic %>% .[[1]] %>%
as_tibble() %>%
reframe(topic_label_prob = pmap_chr(., ~ paste(c(...), collapse = ", "))) %>%
mutate(topic = row_number())
ee_date <- extract_ee(
estimate_effect,
"year",
structured_topic_model,
method = "continuous",
npoints = 500) %>%
left_join(top_terms_prob, by = "topic")
topics <- 1:30
has_female_significant <- summary_tibble %>%
filter(term == "has_female1")
gg <- has_female_significant %>%
left_join(top_terms_prob, by = "topic") %>%
left_join(metatopics %>% select(topic, label)) %>%
mutate(
topic = reorder(topic, estimate),
effect = ifelse(estimate > 0, "Positive", "Negative"),
effect = ifelse(p_value > .10, "Non significatif au seuil de 90 %", effect),
tooltip = paste("Estimate:", estimate)
) %>%
ggplot(aes(
x = estimate,
y = topic,
label = paste0(topic, ": ", label),
fill = effect
)) +
geom_col(size = 5) +
geom_text(size = 3.5, position = position_stack(vjust = .5)) +
scale_fill_manual(
name = "Effect",
values = c(
"Negative" = "#F2D3A9",
"Positive" = "#99A6DA",
"Non significatif au seuil de 90 %" = "grey")) +
labs(x = "Effet estimé", y = NULL) +
theme_light() +
theme(
legend.position = "bottom",
text = element_text(size = 15),
axis.text.y = element_blank(), # Removes y-axis text
axis.ticks.y = element_blank()) # Removes y-axis ticks +
ggsave(
"female_effect.png",
device = "png",
plot = gg,
path = figures_path,
width = 8,
height = 5,
dpi = 300
)
gg
varia_significant <- summary_tibble %>%
filter(term == "is_varia1")
gg <- varia_significant %>%
left_join(top_terms_prob, by = "topic") %>%
mutate(
topic = reorder(topic, estimate),
effect = ifelse(estimate > 0, "Positive", "Negative"),
effect = ifelse(p_value > .10, "Non significatif au seuil de 90 %", effect),
tooltip = paste("Estimate:", estimate)) %>%
ggplot(aes(
x = estimate,
y = topic,
label = paste(topic, "-", topic_label_prob),
fill = effect
)) +
geom_col() +
geom_text(size = 3.5, position = position_stack(vjust = .5)) +
scale_fill_manual(
name = "Effect",
values = c("Negative" = "#1B9E77", "Positive" = "#D95F02", "Non significatif au seuil de 90 %" = "grey")
) +
labs(x = "Prévalence espérée", y = NULL) +
theme_light() +
theme(
legend.position = "bottom",
text = element_text(size = 15),
axis.text.y = element_blank(), # Removes y-axis text
axis.ticks.y = element_blank()) # Removes y-axis ticks +
ggsave(
"varia_effect.png",
device = "png",
plot = gg,
path = figures_path,
width = 8,
height = 5,
dpi = 300
)
print(gg)
ee_date <- ee_date %>%
select(-label) %>%
left_join(metatopics %>% select(topic, label))
library(glue)
list_metatopics <- metatopics %>% pull(unique(champ))
for (metatopic in list_metatopics){
list_topics <- metatopics %>%
filter(champ == metatopic) %>%
pull(topic)
# Filter data for the topic
topic_per_year <- ee_date %>%
filter(topic == list_topics)
# Generate the plot
gg <- topic_per_year %>%
ggplot(aes(x = covariate.value, color = paste0("Thématique ", topic, " : ", label)), linewidth = 1) +
geom_line(aes(y = estimate), size = 1.5) +
# geom_line(aes(y = ci.lower), color = "red", linetype = "dashed") +
# geom_line(aes(y = ci.upper), color = "red", linetype = "dashed") +
geom_hline(yintercept = 0, linetype = "dashed") +
scale_color_brewer(palette = "Paired") +
labs(
# title = glue("Meta-thématiques: {metatopic}"),
subtile = "Evolution des thématiques",
x = "Valeur de la variable année",
y = "Prévalence espérée",
color = ""
) +
theme_light(base_size = 15) +
theme(
legend.position = "bottom",
# Positionne la légende en bas du graphique
legend.text = element_text(size = 10)) +
guides(color = guide_legend(nrow = ceiling(length(list_topics)/2)))
ggsave(
glue::glue("year_effect_{metatopic}.png"),
device = "png",
plot = gg,
path = figures_path,
width = 8,
height = 4.5,
dpi = 300
)
}list_topics_macro <- metatopics %>%
filter(champ %in% "Macroéconomie") %>%
pull(topic)
list_topics_macro_tradi <- c(14, 20, 21, 25, 29, 5)
list_topics_macro_modern <- list_topics_macro %>% setdiff(list_topics_macro_tradi)
topic_per_year_facet <- ee_date %>%
select(-label) %>%
filter(topic %in% list_topics_macro) %>%
left_join(metatopics, by = "topic") %>%
mutate(facet = ifelse(topic %in% list_topics_macro_tradi, "Macroéconomie traditionnelle", "Macroéconomie moderne"),
facet = factor(facet, levels = c("Macroéconomie traditionnelle", "Macroéconomie moderne")),
topic = factor(topic, levels = c(list_topics_macro_tradi, list_topics_macro_modern)))
gg_facet <- topic_per_year_facet %>%
ggplot(aes(
x = covariate.value,
color = paste0("Thématique ", topic, " : ", label)
)) +
geom_line(aes(y = estimate), size = 2) +
geom_hline(yintercept = 0, linetype = "dashed") +
scale_color_brewer(palette = "Paired") +
facet_wrap( ~ facet, scales = "fixed") +
labs(
# title = "Meta-thématiques: Finance et banque, Macroéconométrie et Économie internationale",
x = "Valeur de la variable année",
y = "Prévalence espérée de la thématique",
color = ""
) +
theme_light(base_size = 15) +
theme(
legend.position = "bottom",
legend.text = element_text(size = 16),
legend.title = element_text(size = 18),
legend.key = element_blank(),
strip.background = element_rect(colour="white",fill="white"),
# color in black the strip background
strip.text = element_text(size = 18, color = "black")
) +
guides(color = guide_legend(nrow = ceiling(length(list_topics_macro)/2)),
legend.spacing.y = unit(0.05, 'cm')) # Place la légende sur une seule ligne
ggsave(
"year_effect_facet_plot.png",
device = "png",
plot = gg_facet,
path = figures_path,
width = 16,
height = 9,
dpi = 300
)Le rang normalisé est calculé par la fonction de répartition empirique, c’est à dire, intuivement, le nombre de points d’observations inférieur aux points observés sur le nombre total de poi,nts d’observation.↩︎
Ici, nous avons repris la formule de la FREX de l’article. Dans le package stm, la formule est inversée. Le paramètre \(a = 0.7\) mais est associé à \(E\) et \((1-a)\) à \(F\) dans la fonction stm::exclusivity().↩︎