inst/biblioshiny/utils.R
In massimoaria/bibliometrix: Comprehensive Science Mapping Analysis
### COMMON FUNCTIONS ####
# LOAD FUNCTIONS -----
formatDB <- function(obj) {
ext <- sub(".*\\.", "", obj[1])
switch(ext,
txt = {
format <- "plaintext"
},
csv = {
format <- "csv"
},
bib = {
format <- "bibtex"
},
ciw = {
format <- "endnote"
},
xlsx = {
format <- "excel"
}
)
return(format)
}
## smart_load function ----
smart_load <- function(file) {
var <- load(file)
n <- length(var)
if (!"M" %in% var) {
if (n == 1) {
eval(parse(text = paste0("M <- ", var)))
} else {
stop("I could not find bibliometrixDB object in your data file: ", file)
}
}
rm(list = var[var != "M"])
if (("M" %in% ls()) & inherits(M, "bibliometrixDB")) {
return(M)
} else {
stop("Please make sure your RData/Rda file contains a bibliometrixDB object (M).")
}
}
## merge collections ----
merge_files <- function(files) {
## load xlsx or rdata bibliometrix files
if ("datapath" %in% names(files)) {
file <- files$datapath
ext <- unlist(lapply(file, getFileNameExtension))
}
Mfile <- list()
n <- 0
for (i in 1:length(file)) {
extF <- ext[i]
filename <- file[i]
switch(tolower(extF),
xlsx = {
Mfile[[i]] <- readxl::read_excel(filename, col_types = "text") %>% as.data.frame()
Mfile[[i]]$PY <- as.numeric(Mfile[[i]]$PY)
Mfile[[i]]$TC <- as.numeric(Mfile[[i]]$TC)
},
rdata = {
Mfile[[i]] <- smart_load(filename)
}
)
n <- n + nrow(Mfile[[i]])
}
# merge bibliometrix files
M <- mergeDbSources(Mfile, remove.duplicated = T)
# save original size as attribute
attr(M, "nMerge") <- n
return(M)
}
# DATA TABLE FORMAT ----
DTformat <- function(df, nrow = 10, filename = "Table", pagelength = TRUE, left = NULL, right = NULL, numeric = NULL, dom = TRUE, size = "85%", filter = "top",
columnShort = NULL, columnSmall = NULL, round = 2, title = "", button = FALSE, escape = FALSE, selection = FALSE, scrollX = FALSE, scrollY = FALSE) {
if ("text" %in% names(df)) {
df <- df %>%
mutate(text = gsub("<|>", "", text))
}
if (length(columnShort) > 0) {
columnDefs <- list(
list(
className = "dt-center", targets = 0:(length(names(df)) - 1)
),
list(
targets = columnShort - 1,
render = JS(
"function(data, type, row, meta) {",
"return type === 'display' && data.length > 500 ?",
"'<span title=\"' + data + '\">' + data.substr(0, 500) + '...</span>' : data;",
"}"
)
)
)
} else {
columnDefs <- list(list(
className = "dt-center", targets = 0:(length(names(df)) - 1)
))
}
if (isTRUE(button)) {
if (isTRUE(pagelength)) {
buttons <- list(
list(extend = "pageLength"),
list(
extend = "excel",
filename = paste0(filename, "_bibliometrix_", Sys.Date()),
title = " ",
header = TRUE,
exportOptions = list(
modifier = list(page = "all")
)
)
)
} else {
buttons <- list(
list(
extend = "excel",
filename = paste0(filename, "_bibliometrix_", Sys.Date()),
title = " ",
header = TRUE,
exportOptions = list(
modifier = list(page = "all")
)
)
)
}
} else {
buttons <- list(list(extend = "pageLength"))
}
if (isTRUE(dom)) {
dom <- "Brtip"
} else if (dom == FALSE) {
dom <- "Bftp"
} else {
dom <- "t"
}
if (nchar(title) > 0) {
caption <- htmltools::tags$caption(style = "caption-side: top; text-align: center; color:black; font-size:140% ;", title)
} else {
caption <- htmltools::tags$caption(style = "caption-side: top; text-align: center; color:black; font-size:140% ;", "")
}
if (isTRUE(selection)) {
extensions <- c("Buttons", "Select", "ColReorder", "FixedHeader")
buttons <- c(buttons, c("selectAll", "selectNone"))
select <- list(style = "multiple", items = "row", selected = 1:nrow(df))
# selection = list(mode = 'multiple', selected = 1:nrow(df), target = 'row')
} else {
extensions <- c("Buttons", "ColReorder", "FixedHeader")
select <- NULL
# selection = "none"
}
tab <- DT::datatable(df,
escape = escape, rownames = FALSE,
caption = caption,
selection = "none",
extensions = extensions,
filter = filter,
options = list(
headerCallback = DT::JS(
"function(thead) {",
" $(thead).css('font-size', '1em');",
"}"
),
colReorder = TRUE,
fixedHeader = TRUE,
pageLength = nrow,
autoWidth = TRUE, scrollX = scrollX, scrollY = scrollY,
dom = dom,
buttons = buttons,
select = select,
lengthMenu = list(
c(10, 25, 50, -1),
c("10 rows", "25 rows", "50 rows", "Show all")
),
columnDefs = columnDefs
),
class = "cell-border compact stripe"
) %>%
DT::formatStyle(
names(df),
backgroundColor = "white",
textAlign = "center",
fontSize = size
)
## left aligning
if (!is.null(left)) {
tab <- tab %>%
DT::formatStyle(
names(df)[left],
backgroundColor = "white",
textAlign = "left",
fontSize = size
)
}
# right aligning
if (!is.null(right)) {
tab <- tab %>%
DT::formatStyle(
names(df)[right],
backgroundColor = "white",
textAlign = "right",
fontSize = size
)
}
# numeric round
if (!is.null(numeric)) {
tab <- tab %>%
formatRound(names(df)[c(numeric)], digits = round)
}
tab
}
authorNameFormat <- function(M, format) {
if (format == "AF" & "AF" %in% names(M)) {
M <- M %>%
rename(
AU_IN = AU,
AU = AF
)
}
return(M)
}
split_text_numbers <- function(input_str, UT) {
# Split the string into components based on "; "
components <- unlist(strsplit(input_str, "; ", fixed = TRUE))
# Initialize two vectors to store the separated parts
texts <- character(length(components))
numbers <- numeric(length(components))
# Iterate through each component to separate text and numbers
for (i in seq_along(components)) {
# Extract the text using regex, matching everything up to " ("
texts[i] <- gsub("\\s\\(.*$", "", components[i])
# Extract the numbers using regex, matching digits inside parentheses
numbers[i] <- as.numeric(gsub(".*\\((\\d+)\\).*", "\\1", components[i]))
}
# Return a list with texts and numbers separated
data.frame(Texts = texts, Numbers = numbers, UT = UT)
}
AuthorNameMerge <- function(M) {
df_list <- list()
for (i in 1:nrow(M)) {
if (nchar(M$AU[i]) > 0) {
df_list[[i]] <- split_text_numbers(M$AU[i], M$UT[i])
}
}
df <- do.call(rbind, df_list)
AU <- df %>%
group_by(Numbers, Texts) %>%
count() %>%
group_by(Numbers) %>%
arrange(desc(n)) %>%
mutate(AU = Texts[1]) %>%
select(-"n", -"Texts") %>%
ungroup() %>%
distinct()
df <- df %>%
left_join(AU, by = "Numbers") %>%
group_by(UT) %>%
summarize(
AU = paste0(AU, collapse = ";"),
AU_ID = paste0(Numbers, collapse = ";")
)
M <- M %>%
rename(AU_original = AU) %>%
left_join(df, by = "UT")
return(M)
}
getFileNameExtension <- function(fn) {
# remove a path
splitted <- strsplit(x = fn, split = "/")[[1]]
# or use .Platform$file.sep in stead of '/'
fn <- splitted[length(splitted)]
ext <- ""
splitted <- strsplit(x = fn, split = "\\.")[[1]]
l <- length(splitted)
if (l > 1 && sum(splitted[1:(l - 1)] != "")) ext <- splitted[l]
# the extention must be the suffix of a non-empty name
ext
}
# Initial to upper case
firstup <- function(x) {
x <- tolower(x)
substr(x, 1, 1) <- toupper(substr(x, 1, 1))
x
}
# string preview (stopwords)
strPreview <- function(string, sep = ",") {
str1 <- unlist(strsplit(string, sep))
str1 <- str1[1:min(c(length(str1), 5))]
str1 <- paste(str1, collapse = sep)
HTML(paste("<pre>", "File Preview: ", str1, "</pre>", sep = "<br/>"))
}
# string preview (synonyms)
strSynPreview <- function(string) {
string <- string[1]
str1 <- unlist(strsplit(string, ";"))
str1 <- str1[1:min(c(length(str1), 5))]
str1 <- paste(paste(str1[1], " <- ", collapse = ""), paste(str1[-1], collapse = ";"), collapse = "")
HTML(paste("<pre>", "File Preview: ", str1, "</pre>", sep = "<br/>"))
}
# from igraph to png file
igraph2PNG <- function(x, filename, width = 10, height = 7, dpi = 75) {
V(x)$centr <- centr_betw(x)$res
df <- data.frame(name = V(x)$label, cluster = V(x)$color, centr = V(x)$centr) %>%
group_by(cluster) %>%
slice_head(n = 3)
V(x)$label[!(V(x)$label %in% df$name)] <- ""
png(filename = filename, width = width, height = height, unit = "in", res = dpi)
grid::grid.draw(plot(x))
dev.off()
}
# from ggplot to plotly
plot.ly <- function(g, flip = FALSE, side = "r", aspectratio = 1, size = 0.15, data.type = 2, height = 0, customdata = NA) {
g <- g + labs(title = NULL)
gg <- ggplotly(g, tooltip = "text") %>%
config(
displaylogo = FALSE,
modeBarButtonsToRemove = c(
"toImage",
"sendDataToCloud",
"pan2d",
"select2d",
"lasso2d",
"toggleSpikelines",
"hoverClosestCartesian",
"hoverCompareCartesian"
)
)
return(gg)
}
freqPlot <- function(xx, x, y, textLaby, textLabx, title, values, string.max = 70) {
xl <- c(max(xx[, x]) - 0.02 - diff(range(xx[, x])) * 0.125, max(xx[, x]) - 0.02) + 1
yl <- c(1, 1 + length(unique(xx[, y])) * 0.125)
Text <- paste(textLaby, ": ", xx[, y], "\n", textLabx, ": ", xx[, x])
if (title == "Most Local Cited References" & values$M$DB[1] == "SCOPUS") {
xx[, y] <- gsub("^(.+?)\\.,.*\\((\\d{4})\\)$", paste0("\\1", "., ", "\\2"), xx[, y])
}
xx[, y] <- substr(xx[, y], 1, string.max)
g <- ggplot(xx, aes(x = xx[, x], y = xx[, y], label = xx[, x], text = Text)) +
geom_segment(aes(x = 0, y = xx[, y], xend = xx[, x], yend = xx[, y]), color = "grey50") +
geom_point(aes(color = -xx[, x], size = xx[, x]), show.legend = FALSE) +
scale_radius(range = c(5, 12)) +
geom_text(color = "white", size = 3) +
scale_y_discrete(limits = rev(xx[, y])) +
scale_fill_continuous(type = "gradient") +
labs(title = title, y = textLaby) +
labs(x = textLabx) +
expand_limits(y = c(1, length(xx[, y]) + 1)) +
theme_minimal() +
theme(axis.text.y = element_text(angle = 0, hjust = 0)) +
annotation_custom(values$logoGrid, xmin = xl[1], xmax = xl[2], ymin = yl[1], ymax = yl[2])
return(g)
}
emptyPlot <- function(errortext) {
g <- ggplot() +
theme_void() +
theme(legend.position = "none") +
annotate("text", x = 4, y = 25, label = errortext, size = 10)
plot(g)
}
count.duplicates <- function(DF) {
x <- do.call("paste", c(DF, sep = "\r"))
ox <- order(x)
rl <- rle(x[ox])
cbind(DF[ox[cumsum(rl$lengths)], , drop = FALSE], count = rl$lengths)
}
reduceRefs <- function(A) {
ind <- unlist(regexec("*V[0-9]", A))
A[ind > -1] <- substr(A[ind > -1], 1, (ind[ind > -1] - 1))
ind <- unlist(regexec("*DOI ", A))
A[ind > -1] <- substr(A[ind > -1], 1, (ind[ind > -1] - 1))
return(A)
}
notifications <- function() {
## check connection and download notifications
online <- is_online()
location <- "https://www.bibliometrix.org/bs_notifications/biblioshiny_notifications.csv"
notifOnline <- NULL
if (isTRUE(is_online())) {
## add check to avoid blocked app when internet connection is to slow
envir <- environment()
# setTimeLimit(cpu = 1, elapsed = 1, transient = TRUE)
# on.exit({
# setTimeLimit(cpu = Inf, elapsed = Inf, transient = FALSE)
# })
tryCatch(
{
eval(expr = suppressWarnings(notifOnline <- read.csv(location, header = TRUE, sep = ",")), envir = envir)
},
error = function(ex) {
notifOnLine <- NULL
}
)
if (is.null(notifOnline)) {
online <- FALSE
} else {
notifOnline$href[nchar(notifOnline$href) < 6] <- NA
}
}
## check if a file exists on the local machine and load it
home <- homeFolder()
file <- paste(home, "/biblioshiny_notifications.csv", sep = "")
fileTrue <- file.exists(file)
if (isTRUE(fileTrue)) {
suppressWarnings(notifLocal <- read.csv(file, header = TRUE, sep = ","))
# notifLocal <- readLines(file)
# linksLocal[nchar(linksLocal)<6] <- NA
}
A <- c("noA", "A")
B <- c("noB", "B")
status <- paste(A[online + 1], B[fileTrue + 1], sep = "")
switch(status,
# missing both files (online and local)
noAnoB = {
notifTot <- data.frame(nots = "No notifications", href = NA, status = "info") %>% mutate(status = "info")
},
# missing online file. The local one exists.
noAB = {
notifTot <- notifLocal %>%
filter(action == TRUE) %>%
mutate(status = "info")
},
# missing the local file. The online one exists.
AnoB = {
# notifOnline <- notifOnline %>%
# dplyr::slice_head(n = 5)
notifTot <- notifOnline %>%
filter(action == TRUE) %>%
mutate(status = "danger") %>%
dplyr::slice_head(n = 5)
notifOnline %>%
filter(action == TRUE) %>%
write.csv(file = file, quote = FALSE, row.names = FALSE)
},
# both files exist.
AB = {
notifTot <- left_join(notifOnline %>% mutate(status = "danger"),
notifLocal %>% mutate(status = "info"),
by = "nots"
) %>%
mutate(status = tidyr::replace_na(status.y, "danger")) %>%
rename(
href = href.x,
action = action.x
) %>%
select(nots, href, action, status) %>%
arrange(status) %>%
filter(action == TRUE) %>%
dplyr::slice_head(n = 5)
notifTot %>%
select(-status) %>%
write.csv(file = file, quote = FALSE, row.names = FALSE)
}
)
# notifTot <- notifTot[1:(min(5,nrow(notifTot))),]
return(notifTot)
}
is_online <- function(timeout = 3) {
RCurl::url.exists("www.bibliometrix.org", timeout = timeout)
}
# is_online <- function(){
# ## add check to avoid blocked app when internet connection is to slow
# envir <- environment()
# setTimeLimit(cpu = 1, elapsed = 1, transient = TRUE)
# on.exit({
# setTimeLimit(cpu = Inf, elapsed = Inf, transient = FALSE)
# })
# tryCatch({
# eval(expr=suppressWarnings(resp <- curl::has_internet()), envir = envir)
# }, error = function(ex) {resp <- FALSE}
# )
# return(resp)
# }
initial <- function(values) {
values$results <- list("NA")
values$log <- "working..."
values$load <- "FALSE"
values$field <- values$cocngrams <- "NA"
values$citField <- values$colField <- values$citSep <- "NA"
values$NetWords <- values$NetRefs <- values$ColNetRefs <- matrix(NA, 1, 1)
values$Title <- "Network"
values$Histfield <- "NA"
values$histlog <- "working..."
values$kk <- 0
values$histsearch <- "NA"
values$citShortlabel <- "NA"
values$S <- list("NA")
values$GR <- "NA"
values$nMerge <- NULL
values$collection_description <- NULL
### column to export in TALL
values$corpusCol <- c("Title" = "TI", "Abstract" = "AB", "Author's Keywords" = "DE")
values$metadataCol <- c("Publication Year" = "PY", "Document Type" = "DT", "DOI" = "DI", "Open Access" = "OA", "Language" = "LA", "First Author" = "AU1")
# Chrome enviroment variable
if (inherits(try(pagedown::find_chrome(), silent=T), "try-error")) {
values$Chrome_url <- NULL
}else{
values$Chrome_url <- pagedown::find_chrome()
}
return(values)
}
### TALL Export functions ----
tallExport <- function(M, tallFields, tallMetadata, metadataCol) {
corpus <- NULL
## Corpus Fields ##
if ("Abstract" %in% tallFields) {
if (!"AB_raw" %in% names(M)) {
M <- M %>%
mutate(AB_raw = sapply(AB, capitalize_after_dot, USE.NAMES = FALSE))
}
corpus <- c(corpus, "AB_raw")
}
if ("Title" %in% tallFields) {
if (!"TI_raw" %in% names(M)) {
M <- M %>%
mutate(TI_raw = sapply(TI, capitalize_after_dot, USE.NAMES = FALSE))
}
corpus <- c(corpus, "TI_raw")
}
if ("Author's Keywords" %in% tallFields) {
if (!"DE_raw" %in% names(M)) {
M <- M %>%
mutate(DE_raw = sapply(DE, capitalize_after_dot, USE.NAMES = FALSE))
}
corpus <- c(corpus, "DE_raw")
}
corpus <- c(corpus, as.character(metadataCol[tallMetadata]))
M <- M %>%
select(SR, any_of(corpus)) %>%
rename(doc_id = SR)
names(M) <- gsub("_raw", "", names(M))
return(M)
}
capitalize_after_dot <- function(text) {
# Tutto minuscolo
text <- tolower(text)
# Prima lettera della stringa maiuscola
text <- paste0(toupper(substr(text, 1, 1)), substr(text, 2, nchar(text)))
# Maiuscola dopo punto (o ! o ?) + spazio
text <- gsub("([\\.\\!\\?]\\s*)([a-z])", "\\1\\U\\2", text, perl = TRUE)
return(text)
}
### ANALYSIS FUNCTIONS ####
### Descriptive functions ----
ValueBoxes <- function(M) {
# calculate statistics for Biblioshiny ValueBoxes
df <- data.frame(Description = rep(NA, 12), Results = rep(NA, 12))
## VB 1 - Time span
df[1, ] <- c("Timespan", paste(range(M$PY, na.rm = T), collapse = ":"))
## VB 2 - Authors
listAU <- (strsplit(M$AU, ";"))
nAU <- lengths(listAU)
listAU <- unique(trimws((unlist(listAU))))
listAU <- listAU[!is.na(listAU)]
df[2, ] <- c("Authors", length(listAU))
## VB 3 - Author's Keywords (DE)
if (!"DE" %in% names(M)) {
M$DE <- ""
}
DE <- unique(trimws(gsub("\\s+|\\.|\\,", " ", unlist(strsplit(M$DE, ";")))))
DE <- DE[!is.na(DE)]
df[3, ] <- c("Author's Keywords (DE)", length(DE))
## VB 4 - Sources
df[4, ] <- c("Sources (Journals, Books, etc)", length(unique(M$SO)))
## VB 5 - Authors of single-authored docs
df[5, ] <- c("Authors of single-authored docs", length(unique(M$AU[nAU == 1])))
## VB 6 - References
CR <- trimws(gsub("\\s+|\\.|\\,", " ", unlist(strsplit(M$CR, ";"))))
CR <- CR[nchar(CR) > 0 & !is.na(CR)]
nCR <- length(unique(CR))
if (nCR == 1) {
nCR <- 0
}
df[6, ] <- c("References", nCR)
## VB 7 - Documents
df[7, ] <- c("Documents", nrow(M))
## VB 8 - International Co-Authorship
if (!"AU_CO" %in% names(M)) {
M <- metaTagExtraction(M, "AU_CO")
}
AU_CO <- strsplit(M$AU_CO, ";")
Coll <- unlist(lapply(AU_CO, function(l) {
length(unique(l)) > 1
}))
Coll <- sum(Coll) / nrow(M) * 100
df[8, ] <- c("International co-authorships %", format(Coll, digits = 4))
## VB 9 - Document Average Age
age <- as.numeric(substr(Sys.Date(), 1, 4)) - M$PY
df[9, ] <- c("Document Average Age", format(mean(age, na.rm = TRUE), digits = 3))
## VB 10 - Annual Growth Rate
Y <- table(M$PY)
ny <- diff(range(M$PY, na.rm = TRUE))
CAGR <- as.numeric(round(((Y[length(Y)] / Y[1])^(1 / (ny)) - 1) * 100, 2))
df[10, ] <- c("Annual Growth Rate %", CAGR)
## VB 11 - Co-Authors per Doc
df[11, ] <- c("Co-Authors per Doc", format(mean(nAU, na.rm = T), digit = 3))
## VB 12 - Average citations per doc
df[12, ] <- c("Average citations per doc", format(mean(M$TC, na.rm = T), digit = 4))
DT <- M %>%
mutate(DT = tolower(DT)) %>%
count(DT) %>%
rename(
Description = DT,
Results = n
)
# Indexed Keywords (ID)
ID <- unique(trimws(gsub("\\s+|\\.|\\,", " ", unlist(strsplit(M$ID, ";")))))
ID <- ID[!is.na(ID)]
df[nrow(df) + 1, ] <- c("Keywords Plus (ID)", length(ID))
# Single authored docs
df[nrow(df) + 1, ] <- c("Single-authored docs", sum(nAU == 1))
df2 <- data.frame(Description = c(
"MAIN INFORMATION ABOUT DATA", "Timespan", "Sources (Journals, Books, etc)", "Documents",
"Annual Growth Rate %", "Document Average Age", "Average citations per doc", "References",
"DOCUMENT CONTENTS", "Keywords Plus (ID)", "Author's Keywords (DE)", "AUTHORS", "Authors", "Authors of single-authored docs",
"AUTHORS COLLABORATION", "Single-authored docs", "Co-Authors per Doc", "International co-authorships %", "DOCUMENT TYPES"
))
df <- left_join(df2, df, by = "Description") %>%
rbind(DT) %>%
mutate(Results = replace_na(Results, ""))
return(df)
}
countryCollab <- function(M) {
sep <- ";"
if (!("AU_CO" %in% names(M))) {
M <- metaTagExtraction(M, Field = "AU_CO", sep)
}
if (!("AU1_CO" %in% names(M))) {
M <- metaTagExtraction(M, Field = "AU1_CO", sep)
}
M$nCO <- as.numeric(unlist(lapply(strsplit(M$AU_CO, ";"), function(l) {
length(unique(l)) > 1
})))
M$AU1_CO <- trim(gsub("[[:digit:]]", "", M$AU1_CO))
M$AU1_CO <- gsub("UNITED STATES", "USA", M$AU1_CO)
M$AU1_CO <- gsub("RUSSIAN FEDERATION", "RUSSIA", M$AU1_CO)
M$AU1_CO <- gsub("TAIWAN", "CHINA", M$AU1_CO)
M$AU1_CO <- gsub("ENGLAND", "UNITED KINGDOM", M$AU1_CO)
M$AU1_CO <- gsub("SCOTLAND", "UNITED KINGDOM", M$AU1_CO)
M$AU1_CO <- gsub("WALES", "UNITED KINGDOM", M$AU1_CO)
M$AU1_CO <- gsub("NORTH IRELAND", "UNITED KINGDOM", M$AU1_CO)
df <- M %>%
group_by(AU1_CO) %>%
select(AU1_CO, nCO) %>%
summarize(
Articles = n(),
SCP = sum(nCO == 0),
MCP = sum(nCO == 1)
) %>%
rename(Country = AU1_CO) %>%
arrange(desc(Articles))
return(df)
}
Hindex_plot <- function(values, type, input) {
hindex <- function(values, type, input) {
switch(type,
author = {
# AU <- trim(gsub(",","",names(tableTag(values$M,"AU"))))
values$H <- Hindex(values$M, field = "author", elements = NULL, sep = ";", years = Inf)$H %>%
arrange(desc(h_index))
},
source = {
# SO <- names(sort(table(values$M$SO),decreasing = TRUE))
values$H <- Hindex(values$M, field = "source", elements = NULL, sep = ";", years = Inf)$H %>%
arrange(desc(h_index))
}
)
return(values)
}
values <- hindex(values, type = type, input)
xx <- values$H
if (type == "author") {
K <- input$Hkauthor
measure <- input$HmeasureAuthors
title <- "Authors' Local Impact"
xn <- "Authors"
} else {
K <- input$Hksource
measure <- input$HmeasureSources
title <- "Sources' Local Impact"
xn <- "Sources"
}
if (K > dim(xx)[1]) {
k <- dim(xx)[1]
} else {
k <- K
}
switch(measure,
h = {
m <- 2
},
g = {
m <- 3
},
m = {
m <- 4
xx[, m] <- round(xx[, m], 2)
},
tc = {
m <- 5
}
)
xx <- xx[order(-xx[, m]), ]
xx <- xx[1:k, c(1, m)]
g <- freqPlot(xx, x = 2, y = 1, textLaby = xn, textLabx = paste("Impact Measure:", toupper(measure)), title = paste(title, "by", toupper(measure), "index"), values)
res <- list(values = values, g = g)
return(res)
}
descriptive <- function(values, type) {
switch(type,
"tab2" = {
TAB <- values$M %>%
group_by(PY) %>%
count() %>%
rename(
Year = PY,
Articles = n
) %>%
right_join(data.frame(Year = seq(min(values$M$PY, na.rm = TRUE), max(values$M$PY, na.rm = TRUE))), by = "Year") %>%
mutate(Articles = replace_na(Articles, 0)) %>%
arrange(Year) %>%
as.data.frame()
ny <- diff(range(TAB$Year))
values$GR <- round(((TAB[nrow(TAB), 2] / TAB[1, 2])^(1 / (ny)) - 1) * 100, digits = 2)
},
"tab3" = {
listAU <- (strsplit(values$M$AU, ";"))
nAU <- lengths(listAU)
fracAU <- rep(1 / nAU, nAU)
TAB <- tibble(Author = unlist(listAU), fracAU = fracAU) %>%
group_by(Author) %>%
summarize(
Articles = n(),
AuthorFrac = sum(fracAU)
) %>%
arrange(desc(Articles)) %>%
as.data.frame()
names(TAB) <- c("Authors", "Articles", "Articles Fractionalized")
# print(S$MostProdAuthors)
},
"tab4" = {
y <- as.numeric(substr(Sys.Date(), 1, 4))
TAB <- values$M %>%
mutate(TCperYear = TC / (y + 1 - PY)) %>%
select(SR, DI, TC, TCperYear, PY) %>%
group_by(PY) %>%
mutate(NTC = TC / mean(TC)) %>%
ungroup() %>%
select(-PY) %>%
arrange(desc(TC)) %>%
as.data.frame()
names(TAB) <- c("Paper", "DOI", "Total Citations", "TC per Year", "Normalized TC")
},
"tab5" = {
TAB <- countryCollab(values$M)
TAB <- TAB %>%
mutate(Freq = Articles / sum(Articles)) %>%
mutate(MCP_Ratio = MCP / Articles) %>%
drop_na(Country)
},
"tab6" = {
if (!"AU1_CO" %in% names(values$M)) {
values$M <- metaTagExtraction(values$M, "AU1_CO")
}
TAB <- values$M %>%
select(AU1_CO, TC) %>%
drop_na(AU1_CO) %>%
rename(
Country = AU1_CO,
TotalCitation = TC
) %>%
group_by(Country) %>%
summarise("TC" = sum(TotalCitation), "Average Article Citations" = round(sum(TotalCitation) / length(TotalCitation), 1)) %>%
arrange(-TC) %>%
as.data.frame(.data)
},
"tab7" = {
TAB <- values$M %>%
select(SO) %>%
group_by(SO) %>%
count() %>%
arrange(desc(n)) %>%
rename(
Sources = SO,
Articles = n
) %>%
as.data.frame()
},
"tab10" = {
TAB <- mapworld(values$M)$tab
},
"tab11" = {
if (!("AU_UN" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "AU_UN")
}
TAB <- data.frame(Affiliation = unlist(strsplit(values$M$AU_UN, ";"))) %>%
group_by(Affiliation) %>%
count() %>%
drop_na(Affiliation) %>%
arrange(desc(n)) %>%
rename(Articles = n) %>%
filter(Affiliation != "NA") %>%
as.data.frame()
},
"tab12" = {
TAB <- tableTag(values$M, "C1")
TAB <- data.frame(Affiliations = names(TAB), Articles = as.numeric(TAB))
TAB <- TAB[nchar(TAB[, 1]) > 4, ]
# names(TAB)=c("Affiliations", "Articles")
},
"tab13" = {
CR <- localCitations(values$M, fast.search = FALSE, verbose = FALSE)
TAB <- CR$Authors
# TAB=data.frame(Authors=names(CR$Authors$Author), Citations=as.numeric(CR$Cited))
}
)
values$TAB <- TAB
res <- list(values = values, TAB = TAB)
return(res)
}
AffiliationOverTime <- function(values, n) {
if (!("AU_UN" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "AU_UN")
}
AFF <- strsplit(values$M$AU_UN, ";")
nAFF <- lengths(AFF)
AFFY <- data.frame(Affiliation = unlist(AFF), Year = rep(values$M$PY, nAFF)) %>%
filter(Affiliation != "NA") %>%
drop_na(Affiliation, Year) %>%
group_by(Affiliation, Year) %>%
count() %>%
group_by(Affiliation) %>%
arrange(Year) %>%
ungroup() %>%
pivot_wider(Affiliation, names_from = Year, values_from = n) %>%
mutate_all(~ replace(., is.na(.), 0)) %>%
pivot_longer(cols = !Affiliation, names_to = "Year", values_to = "Articles") %>%
group_by(Affiliation) %>%
mutate(Articles = cumsum(Articles))
Affselected <- AFFY %>%
filter(Year == max(Year)) %>%
ungroup() %>%
slice_max(Articles, n = n)
values$AffOverTime <- AFFY %>%
filter(Affiliation %in% Affselected$Affiliation) %>%
mutate(Year = Year %>% as.numeric())
Text <- paste(values$AffOverTime$Affiliation, " (", values$AffOverTime$Year, ") ", values$AffOverTime$Articles, sep = "")
width_scale <- 1.7 * 26 / length(unique(values$AffOverTime$Affiliation))
x <- c(max(values$AffOverTime$Year) - 0.02 - diff(range(values$AffOverTime$Year)) * 0.15, max(values$AffOverTime$Year) - 0.02) + 1
y <- c(min(values$AffOverTime$Articles), min(values$AffOverTime$Articles) + diff(range(values$AffOverTime$Articles)) * 0.15)
values$AffOverTimePlot <- ggplot(values$AffOverTime, aes(x = Year, y = Articles, group = Affiliation, color = Affiliation, text = Text)) +
geom_line() +
labs(
x = "Year",
y = "Articles",
title = "Affiliations' Production over Time"
) +
scale_x_continuous(breaks = (values$AffOverTime$Year[seq(1, length(values$AffOverTime$Year), by = ceiling(length(values$AffOverTime$Year) / 20))])) +
geom_hline(aes(yintercept = 0), alpha = 0.1) +
labs(color = "Affiliation") +
theme(
text = element_text(color = "#444444"),
legend.text = ggplot2::element_text(size = width_scale),
legend.box.margin = margin(6, 6, 6, 6),
legend.title = ggplot2::element_text(size = 1.5 * width_scale, face = "bold"),
legend.position = "bottom",
legend.direction = "vertical",
legend.key.size = grid::unit(width_scale / 50, "inch"),
legend.key.width = grid::unit(width_scale / 50, "inch"),
plot.caption = element_text(size = 9, hjust = 0.5, color = "black", face = "bold"),
panel.background = element_rect(fill = "#FFFFFF"),
panel.grid.minor = element_line(color = "#EFEFEF"),
panel.grid.major = element_line(color = "#EFEFEF"),
plot.title = element_text(size = 24),
axis.title = element_text(size = 14, color = "#555555"),
axis.title.y = element_text(vjust = 1, angle = 90),
axis.title.x = element_text(hjust = 0.95, angle = 0),
axis.text.x = element_text(size = 10, angle = 90),
axis.line.x = element_line(color = "black", linewidth = 0.5),
axis.line.y = element_line(color = "black", linewidth = 0.5)
) +
annotation_custom(values$logoGrid, xmin = x[1], xmax = x[2], ymin = y[1], ymax = y[2])
return(values)
}
CountryOverTime <- function(values, n) {
if (!("AU_CO" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "AU_CO")
}
AFF <- strsplit(values$M$AU_CO, ";")
nAFF <- lengths(AFF)
AFFY <- data.frame(Affiliation = unlist(AFF), Year = rep(values$M$PY, nAFF)) %>%
drop_na(Affiliation, Year) %>%
group_by(Affiliation, Year) %>%
count() %>%
group_by(Affiliation) %>%
arrange(Year) %>%
ungroup() %>%
pivot_wider(Affiliation, names_from = Year, values_from = n) %>%
mutate_all(~ replace(., is.na(.), 0)) %>%
pivot_longer(cols = !Affiliation, names_to = "Year", values_to = "Articles") %>%
group_by(Affiliation) %>%
mutate(Articles = cumsum(Articles))
Affselected <- AFFY %>%
filter(Year == max(Year)) %>%
ungroup() %>%
slice_max(Articles, n = n)
values$CountryOverTime <- AFFY %>%
filter(Affiliation %in% Affselected$Affiliation) %>%
mutate(Year = Year %>% as.numeric()) %>%
rename(Country = Affiliation)
Text <- paste(values$CountryOverTime$Country, " (", values$CountryOverTime$Year, ") ", values$CountryOverTime$Articles, sep = "")
width_scale <- 1.7 * 26 / length(unique(values$CountryOverTime$Country))
x <- c(max(values$CountryOverTime$Year) - 0.02 - diff(range(values$CountryOverTime$Year)) * 0.15, max(values$CountryOverTime$Year) - 0.02) + 1
y <- c(min(values$CountryOverTime$Articles), min(values$CountryOverTime$Articles) + diff(range(values$CountryOverTime$Articles)) * 0.15)
values$CountryOverTimePlot <- ggplot(values$CountryOverTime, aes(x = Year, y = Articles, group = Country, color = Country, text = Text)) +
geom_line() +
labs(
x = "Year",
y = "Articles",
title = "Country Production over Time"
) +
scale_x_continuous(breaks = (values$CountryOverTime$Year[seq(1, length(values$CountryOverTime$Year), by = ceiling(length(values$CountryOverTime$Year) / 20))])) +
geom_hline(aes(yintercept = 0), alpha = 0.1) +
labs(color = "Country") +
theme(
text = element_text(color = "#444444"),
legend.text = ggplot2::element_text(size = width_scale),
legend.box.margin = margin(6, 6, 6, 6),
legend.title = ggplot2::element_text(size = 1.5 * width_scale, face = "bold"),
legend.position = "bottom",
legend.direction = "vertical",
legend.key.size = grid::unit(width_scale / 50, "inch"),
legend.key.width = grid::unit(width_scale / 50, "inch"),
plot.caption = element_text(size = 9, hjust = 0.5, color = "black", face = "bold"),
panel.background = element_rect(fill = "#FFFFFF"),
panel.grid.minor = element_line(color = "#EFEFEF"),
panel.grid.major = element_line(color = "#EFEFEF"),
plot.title = element_text(size = 24),
axis.title = element_text(size = 14, color = "#555555"),
axis.title.y = element_text(vjust = 1, angle = 90),
axis.title.x = element_text(hjust = 0.95, angle = 0),
axis.text.x = element_text(size = 10, angle = 90),
axis.line.x = element_line(color = "black", linewidth = 0.5),
axis.line.y = element_line(color = "black", linewidth = 0.5)
) +
annotation_custom(values$logoGrid, xmin = x[1], xmax = x[2], ymin = y[1], ymax = y[2])
return(values)
}
wordlist <- function(M, Field, n, measure, ngrams, remove.terms = NULL, synonyms = NULL) {
switch(Field,
ID = {
v <- tableTag(M, "ID", remove.terms = remove.terms, synonyms = synonyms)
},
DE = {
v <- tableTag(M, "DE", remove.terms = remove.terms, synonyms = synonyms)
},
KW_Merged = {
v <- tableTag(M, "KW_Merged", remove.terms = remove.terms, synonyms = synonyms)
},
TI = {
if (!("TI_TM" %in% names(M))) {
v <- tableTag(M, "TI", ngrams = ngrams, remove.terms = remove.terms, synonyms = synonyms)
}
},
AB = {
if (!("AB_TM" %in% names(M))) {
v <- tableTag(M, "AB", ngrams = ngrams, remove.terms = remove.terms, synonyms = synonyms)
}
},
WC = {
v <- tableTag(M, "WC")
}
)
names(v) <- tolower(names(v))
# v=tableTag(values$M,"ID")
n <- min(c(n, length(v)))
Words <- data.frame(Terms = names(v)[1:n], Frequency = (as.numeric(v)[1:n]), stringsAsFactors = FALSE)
W <- Words
switch(measure,
identity = {},
sqrt = {
W$Frequency <- sqrt(W$Frequency)
},
log = {
W$Frequency <- log(W$Frequency + 1)
},
log10 = {
W$Frequency <- log10(W$Frequency + 1)
}
)
results <- list(v = v, W = W, Words = Words)
return(results)
}
readStopwordsFile <- function(file, sep = ",") {
if (!is.null(file)) {
req(file$datapath)
remove.terms <- unlist(strsplit(readr::read_lines(file$datapath), sep))
} else {
remove.terms <- NULL
}
return(remove.terms)
}
readSynWordsFile <- function(file, sep = ",") {
if (!is.null(file)) {
req(file$datapath)
syn.terms <- readr::read_lines(file$datapath)
if (sep != ";") syn.terms <- gsub(sep, ";", syn.terms)
} else {
syn.terms <- NULL
}
return(syn.terms)
}
mapworld <- function(M, values) {
if (!("AU_CO" %in% names(M))) {
M <- metaTagExtraction(M, "AU_CO")
}
CO <- as.data.frame(tableTag(M, "AU_CO"))
CO$Tab <- gsub("[[:digit:]]", "", CO$Tab)
CO$Tab <- gsub(".", "", CO$Tab, fixed = TRUE)
CO$Tab <- gsub(";;", ";", CO$Tab, fixed = TRUE)
CO$Tab <- gsub("UNITED STATES", "USA", CO$Tab)
CO$Tab <- gsub("RUSSIAN FEDERATION", "RUSSIA", CO$Tab)
CO$Tab <- gsub("TAIWAN", "CHINA", CO$Tab)
CO$Tab <- gsub("ENGLAND", "UNITED KINGDOM", CO$Tab)
CO$Tab <- gsub("SCOTLAND", "UNITED KINGDOM", CO$Tab)
CO$Tab <- gsub("WALES", "UNITED KINGDOM", CO$Tab)
CO$Tab <- gsub("NORTH IRELAND", "UNITED KINGDOM", CO$Tab)
CO$Tab <- gsub("UNITED KINGDOM", "UK", CO$Tab)
CO$Tab <- gsub("KOREA", "SOUTH KOREA", CO$Tab)
map.world <- map_data("world")
map.world$region <- toupper(map.world$region)
# dplyr::anti_join(CO, map.world, by = c('Tab' = 'region'))
country.prod <- dplyr::left_join(map.world, CO, by = c("region" = "Tab"))
tab <- data.frame(country.prod %>%
dplyr::group_by(region) %>%
dplyr::summarise(Freq = mean(Freq)))
tab <- tab[!is.na(tab$Freq), ]
tab <- tab[order(-tab$Freq), ]
# breaks=as.numeric(round(quantile(CO$Freq,c(0.2,0.4,0.6,0.8,1))))
# names(breaks)=breaks
# breaks=log(breaks)
breaks <- as.numeric(cut(CO$Freq, breaks = 10))
names(breaks) <- breaks
g <- ggplot(country.prod, aes(x = long, y = lat, group = group, text = paste("Country: ", region, "\nN.of Documents: ", Freq))) +
geom_polygon(aes(fill = Freq, group = group)) +
scale_fill_continuous(low = "#87CEEB", high = "dodgerblue4", breaks = breaks, na.value = "grey80") +
guides(fill = guide_legend(reverse = T)) +
# geom_text(data=centroids, aes(label = centroids$Tab, x = centroids$long, y = centroids$lat, group=centroids$Tab)) +
labs(
fill = "N.Documents",
title = "Country Scientific Production",
x = NULL,
y = NULL
) +
theme(
text = element_text(color = "#333333"),
plot.title = element_text(size = 28),
plot.subtitle = element_text(size = 14),
axis.ticks = element_blank(),
axis.text = element_blank(),
panel.grid = element_blank(),
panel.background = element_rect(fill = "#FFFFFF") #' #333333'
, plot.background = element_rect(fill = "#FFFFFF"),
legend.position = "none"
# ,legend.background = element_blank()
# ,legend.key = element_blank()
) +
annotation_custom(values$logoGrid, xmin = 143, xmax = 189.5, ymin = -69, ymax = -48)
results <- list(g = g, tab = tab)
return(results)
}
### Structure fuctions ----
CAmap <- function(input, values) {
if ((input$CSfield %in% names(values$M))) {
if (input$CSfield %in% c("TI", "AB")) {
ngrams <- as.numeric(input$CSngrams)
} else {
ngrams <- 1
}
### load file with terms to remove
if (input$CSStopFile == "Y") {
remove.terms <- trimws(values$CSremove.terms$stopword)
} else {
remove.terms <- NULL
}
# values$CSremove.terms <- remove.terms
### end of block
### load file with synonyms
if (input$FASynFile == "Y") {
synonyms <- values$FAsyn.terms %>%
group_by(term) %>%
mutate(term = paste0(term, ";", synonyms)) %>%
select(term)
synonyms <- synonyms$term
} else {
synonyms <- NULL
}
# values$FAsyn.terms <- synonyms
### end of block
tab <- tableTag(values$M, input$CSfield, ngrams = ngrams)
if (length(tab >= 2)) {
minDegree <- as.numeric(tab[input$CSn])
values$CS <- conceptualStructure(values$M,
method = input$method, field = input$CSfield, minDegree = minDegree, clust = input$nClustersCS,
k.max = 8, stemming = F, labelsize = input$CSlabelsize / 2, documents = input$CSdoc, graph = FALSE, ngrams = ngrams,
remove.terms = remove.terms, synonyms = synonyms
)
if (input$method != "MDS") {
CSData <- values$CS$docCoord
CSData <- data.frame(Documents = row.names(CSData), CSData)
CSData$dim1 <- round(CSData$dim1, 2)
CSData$dim2 <- round(CSData$dim2, 2)
CSData$contrib <- round(CSData$contrib, 2)
values$CS$CSData <- CSData
} else {
values$CS$CSData <- data.frame(Docuemnts = NA, dim1 = NA, dim2 = NA)
}
switch(input$method,
CA = {
WData <- data.frame(
word = row.names(values$CS$km.res$data.clust), values$CS$km.res$data.clust,
stringsAsFactors = FALSE
)
names(WData)[4] <- "cluster"
},
MCA = {
WData <- data.frame(
word = row.names(values$CS$km.res$data.clust), values$CS$km.res$data.clust,
stringsAsFactors = FALSE
)
names(WData)[4] <- "cluster"
},
MDS = {
WData <- data.frame(
word = row.names(values$CS$res), values$CS$res,
cluster = values$CS$km.res$cluster
)
}
)
WData$Dim1 <- round(WData$Dim1, 2)
WData$Dim2 <- round(WData$Dim2, 2)
values$CS$WData <- WData
} else {
emptyPlot("Selected field is not included in your data collection")
values$CS <- list("NA")
}
} else {
emptyPlot("Selected field is not included in your data collection")
values$CS <- list("NA")
}
return(values)
}
historiograph <- function(input, values) {
min.cit <- 0
# if (values$Histfield=="NA"){
values$histResults <- histNetwork(values$M, min.citations = min.cit, sep = ";")
# values$Histfield="done"
# }
# titlelabel <- input$titlelabel
values$histlog <- (values$histPlot <- histPlot(values$histResults, n = input$histNodes, size = input$histsize, remove.isolates = (input$hist.isolates == "yes"), labelsize = input$histlabelsize, label = input$titlelabel, verbose = FALSE))
values$histResults$histData$DOI <- paste0('<a href=\"https://doi.org/', values$histResults$histData$DOI, '\" target=\"_blank\">', values$histResults$histData$DOI, "</a>")
values$histResults$histData <- values$histResults$histData %>%
left_join(
values$histPlot$layout %>%
select(name, color),
by = c("Paper" = "name")
) %>%
drop_na(color) %>%
mutate(cluster = match(color, unique(color))) %>%
select(!color) %>%
group_by(cluster) %>%
arrange(Year, .by_group = TRUE)
return(values)
}
### Network functions ----
degreePlot <- function(net) {
# deg <- data.frame(node = names(net$nodeDegree), x= (1:length(net$nodeDegree)), y = net$nodeDegree)
ma <- function(x, n = 5) {
stats::filter(x, rep(1 / n, n), sides = 1)
}
deg <- net$nodeDegree %>%
mutate(x = row_number())
p <- ggplot(data = deg, aes(
x = x, y = degree,
text = paste(node, " - Degree ", round(degree, 3), sep = "")
)) +
geom_point() +
geom_line(aes(group = "NA"), color = "#002F80", alpha = .5) +
# geom_hline(yintercept=cutting$degree, linetype="dashed",color = '#002F80', alpha = .5)+
theme(
text = element_text(color = "#444444"),
panel.background = element_rect(fill = "#FFFFFF"),
panel.grid.minor = element_line(color = "#EFEFEF"),
panel.grid.major = element_line(color = "#EFEFEF"),
plot.title = element_text(size = 24),
axis.title = element_text(size = 14, color = "#555555"),
axis.title.y = element_text(vjust = 1, angle = 0),
axis.title.x = element_text(hjust = 0),
axis.line.x = element_line(color = "black", linewidth = 0.5),
axis.line.y = element_line(color = "black", linewidth = 0.5)
) +
labs(x = "Node", y = "Cumulative Degree", title = "Node Degrees")
return(p)
}
cocNetwork <- function(input, values) {
n <- input$Nodes
label.n <- input$Labels
### load file with terms to remove
if (input$COCStopFile == "Y") {
remove.terms <- trimws(values$COCremove.terms$stopword)
} else {
remove.terms <- NULL
}
# values$COCremove.terms <- remove.terms
### end of block
### load file with synonyms
if (input$COCSynFile == "Y") {
synonyms <- values$COCsyn.terms %>%
group_by(term) %>%
mutate(term = paste0(term, ";", synonyms)) %>%
select(term)
synonyms <- synonyms$term
} else {
synonyms <- NULL
}
# values$COCsyn.terms <- synonyms
### end of block
if ((input$field %in% names(values$M))) {
if ((dim(values$NetWords)[1]) == 1 | !(input$field == values$field) | !(input$cocngrams == values$cocngrams) | ((dim(values$NetWords)[1]) != input$Nodes)) {
values$field <- input$field
values$ngrams <- input$cocngrams
switch(input$field,
ID = {
values$NetWords <- biblioNetwork(values$M, analysis = "co-occurrences", network = "keywords", n = n, sep = ";", remove.terms = remove.terms, synonyms = synonyms)
values$Title <- "Keywords Plus Network"
},
DE = {
values$NetWords <- biblioNetwork(values$M, analysis = "co-occurrences", network = "author_keywords", n = n, sep = ";", remove.terms = remove.terms, synonyms = synonyms)
values$Title <- "Authors' Keywords network"
},
KW_Merged ={
values$NetWords <- biblioNetwork(values$M, analysis = "co-occurrences", network = "all_keywords", n = n, sep = ";", remove.terms = remove.terms, synonyms = synonyms)
values$Title <- "All Keywords network"
},
TI = {
# if(!("TI_TM" %in% names(values$M))){
values$M <- termExtraction(values$M, Field = "TI", verbose = FALSE, ngrams = as.numeric(input$cocngrams), remove.terms = remove.terms, synonyms = synonyms)
# }
values$NetWords <- biblioNetwork(values$M, analysis = "co-occurrences", network = "titles", n = n, sep = ";")
values$Title <- "Title Words network"
},
AB = {
# if(!("AB_TM" %in% names(values$M))){
values$M <- termExtraction(values$M, Field = "AB", verbose = FALSE, ngrams = as.numeric(input$cocngrams), remove.terms = remove.terms, synonyms = synonyms)
# }
values$NetWords <- biblioNetwork(values$M, analysis = "co-occurrences", network = "abstracts", n = n, sep = ";")
values$Title <- "Abstract Words network"
},
WC = {
WSC <- cocMatrix(values$M, Field = "WC", binary = FALSE)
values$NetWords <- crossprod(WSC, WSC)
values$Title <- "Subject Categories network"
}
)
}
if (label.n > n) {
label.n <- n
}
if (input$normalize == "none") {
normalize <- NULL
} else {
normalize <- input$normalize
}
if (input$label.cex == "Yes") {
label.cex <- TRUE
} else {
label.cex <- FALSE
}
if (input$coc.curved == "Yes") {
curved <- TRUE
} else {
curved <- FALSE
}
values$cocnet <- networkPlot(values$NetWords,
normalize = normalize, Title = values$Title, type = input$layout,
size.cex = TRUE, size = 5, remove.multiple = F, edgesize = input$edgesize * 3, labelsize = input$labelsize, label.cex = label.cex,
label.n = label.n, edges.min = input$edges.min, label.color = F, curved = curved, alpha = input$cocAlpha,
cluster = input$cocCluster, remove.isolates = (input$coc.isolates == "yes"),
community.repulsion = input$coc.repulsion / 2, verbose = FALSE
)
if (input$cocyears == "Yes") {
Y <- fieldByYear(values$M, field = input$field, graph = FALSE)
g <- values$cocnet$graph
label <- igraph::V(g)$name
ind <- which(tolower(Y$df$item) %in% label)
df <- Y$df[ind, ]
col <- hcl.colors((diff(range(df$year_med)) + 1) * 10, palette = "Blues 3")
igraph::V(g)$color <- col[(max(df$year_med) - df$year_med + 1) * 10]
igraph::V(g)$year_med <- df$year_med
values$cocnet$graph <- g
}
} else {
emptyPlot("Selected field is not included in your data collection")
}
return(values)
}
intellectualStructure <- function(input, values) {
n <- input$citNodes
label.n <- input$citLabels
if ((dim(values$NetRefs)[1]) == 1 | !(input$citField == values$citField) | !(input$citSep == values$citSep) | !(input$citShortlabel == values$citShortlabel) | ((dim(values$NetRefs)[1]) != input$citNodes)) {
values$citField <- input$citField
values$citSep <- input$citSep
if (input$citShortlabel == "Yes") {
shortlabel <- TRUE
} else {
shortlabel <- FALSE
}
values$citShortlabel <- input$citShortlabel
switch(input$citField,
CR = {
values$NetRefs <- biblioNetwork(values$M, analysis = "co-citation", network = "references", n = n, sep = input$citSep, shortlabel = shortlabel)
values$Title <- "Cited References network"
},
CR_AU = {
if (!("CR_AU" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "CR_AU", sep = input$citSep)
}
values$NetRefs <- biblioNetwork(values$M, analysis = "co-citation", network = "authors", n = n, sep = input$citSep)
values$Title <- "Cited Authors network"
},
CR_SO = {
if (!("CR_SO" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "CR_SO", sep = input$citSep)
}
values$NetRefs <- biblioNetwork(values$M, analysis = "co-citation", network = "sources", n = n, sep = input$citSep)
values$Title <- "Cited Sources network"
}
)
}
if (label.n > n) {
label.n <- n
}
if (input$citlabel.cex == "Yes") {
label.cex <- TRUE
} else {
label.cex <- FALSE
}
if (input$cocit.curved == "Yes") {
curved <- TRUE
} else {
curved <- FALSE
}
values$cocitnet <- networkPlot(values$NetRefs,
normalize = NULL, Title = values$Title, type = input$citlayout,
size.cex = TRUE, size = 5, remove.multiple = F, edgesize = input$citedgesize * 3,
labelsize = input$citlabelsize, label.cex = label.cex, curved = curved,
label.n = label.n, edges.min = input$citedges.min, label.color = F, remove.isolates = (input$cit.isolates == "yes"),
alpha = 0.7, cluster = input$cocitCluster,
community.repulsion = input$cocit.repulsion / 2, verbose = FALSE
)
return(values)
}
socialStructure <- function(input, values) {
n <- input$colNodes
label.n <- input$colLabels
if ((dim(values$ColNetRefs)[1]) == 1 | !(input$colField == values$colField) | ((dim(values$ColNetRefs)[1]) != input$colNodes)) {
values$colField <- input$colField
# values$cluster="walktrap"
switch(input$colField,
COL_AU = {
values$ColNetRefs <- biblioNetwork(values$M, analysis = "collaboration", network = "authors", n = n, sep = ";")
values$Title <- "Author Collaboration network"
},
COL_UN = {
if (!("AU_UN" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "AU_UN", sep = ";")
}
values$ColNetRefs <- biblioNetwork(values$M, analysis = "collaboration", network = "universities", n = n, sep = ";")
values$Title <- "Edu Collaboration network"
},
COL_CO = {
if (!("AU_CO" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "AU_CO", sep = ";")
}
values$ColNetRefs <- biblioNetwork(values$M, analysis = "collaboration", network = "countries", n = n, sep = ";")
values$Title <- "Country Collaboration network"
# values$cluster="none"
}
)
}
if (label.n > n) {
label.n <- n
}
if (input$colnormalize == "none") {
normalize <- NULL
} else {
normalize <- input$colnormalize
}
if (input$collabel.cex == "Yes") {
label.cex <- TRUE
} else {
label.cex <- FALSE
}
if (input$soc.curved == "Yes") {
curved <- TRUE
} else {
curved <- FALSE
}
type <- input$collayout
if (input$collayout == "worldmap") {
type <- "auto"
}
values$colnet <- networkPlot(values$ColNetRefs,
normalize = normalize, Title = values$Title, type = type,
size.cex = TRUE, size = 5, remove.multiple = F, edgesize = input$coledgesize * 3,
labelsize = input$collabelsize, label.cex = label.cex, curved = curved,
label.n = label.n, edges.min = input$coledges.min, label.color = F, alpha = input$colAlpha,
remove.isolates = (input$col.isolates == "yes"), cluster = input$colCluster,
community.repulsion = input$col.repulsion / 2, verbose = FALSE
)
return(values)
}
countrycollaboration <- function(M, label, edgesize, min.edges, values) {
M <- metaTagExtraction(M, "AU_CO")
net <- biblioNetwork(M, analysis = "collaboration", network = "countries")
CO <- data.frame(Tab = rownames(net), Freq = diag(net))
bsk.network <- igraph::graph_from_adjacency_matrix(net, mode = "undirected")
COedges <- as.data.frame(igraph::ends(bsk.network, igraph::E(bsk.network), names = TRUE))
map.world <- map_data("world")
map.world$region <- toupper(map.world$region)
map.world$region <- gsub("^UK$", "UNITED KINGDOM", map.world$region)
map.world$region <- gsub("^SOUTH KOREA$", "KOREA", map.world$region)
country.prod <- dplyr::left_join(map.world, CO, by = c("region" = "Tab"))
# breaks <- as.numeric(round(quantile(CO$Freq,seq(0.1,1,by=0.1))))
breaks <- as.numeric(cut(CO$Freq, breaks = 10))
names(breaks) <- breaks
# breaks=breaks
data("countries", envir = environment())
names(countries)[1] <- "Tab"
COedges <- dplyr::inner_join(COedges, countries, by = c("V1" = "Tab"))
COedges <- dplyr::inner_join(COedges, countries, by = c("V2" = "Tab"))
COedges <- COedges[COedges$V1 != COedges$V2, ]
COedges <- count.duplicates(COedges)
tab <- COedges
COedges <- COedges[COedges$count >= min.edges, ]
COedges$region <- paste("\nCollaboration between\n", COedges$V1, "\n and \n", COedges$V2)
g <- ggplot(country.prod, aes(x = long, y = lat, group = group, text = paste("Country: ", region))) +
geom_polygon(aes(fill = Freq)) +
scale_fill_continuous(low = "#87CEEB", high = "dodgerblue4", breaks = breaks, na.value = "grey80") +
# guides(fill = guide_legend(reverse = T)) +
guides(colour = FALSE, fill = FALSE) +
# geom_curve(data=COedges, aes(x = Longitude.x , y = Latitude.x, xend = Longitude.y, yend = Latitude.y, # draw edges as arcs
# color = "firebrick4", size = count, group=continent.x),
# curvature = 0.33,
# alpha = 0.5) +
geom_segment(
data = COedges, aes(
x = Longitude.x, y = Latitude.x, xend = Longitude.y, yend = Latitude.y, # draw edges as arcs
size = count, group = continent.x
),
color = "orangered4", # FFB347",
# curvature = 0.33,
alpha = 0.3
) +
scale_size_continuous(guide = FALSE, range = c(0.25, edgesize)) +
labs(title = NULL, x = "Latitude", y = "Longitude") +
theme(
text = element_text(color = "#333333"),
plot.title = element_text(size = 28),
plot.subtitle = element_text(size = 14),
axis.ticks = element_blank(),
axis.text = element_blank(),
panel.grid = element_blank(),
panel.background = element_rect(fill = "#FFFFFF") #' #333333'
, plot.background = element_rect(fill = "#FFFFFF"),
legend.position = c(.18, .36),
legend.background = element_blank(),
legend.key = element_blank()
) +
annotation_custom(values$logoGrid, xmin = 143, xmax = 189.5, ymin = -69, ymax = -48)
if (isTRUE(label)) {
CO <- dplyr::inner_join(CO, countries, by = c("Tab" = "Tab"))
g <- g +
# ggrepel::geom_text_repel(data=CO, aes(x = Longitude, y = Latitude, label = Tab, group=continent), # draw text labels
# hjust = 0, nudge_x = 1, nudge_y = 4,
# size = 3, color = "orange", fontface = "bold")
ggrepel::geom_text(
data = CO, aes(x = Longitude, y = Latitude, label = Tab, group = continent), # draw text labels
hjust = 0, nudge_x = 1, nudge_y = 4,
size = 3, color = "orange", fontface = "bold"
)
}
results <- list(g = g, tab = tab)
return(results)
}
### visNetwork tools ----
netLayout <- function(type) {
switch(type,
auto = {
l <- "layout_nicely"
},
circle = {
l <- "layout_in_circle"
},
mds = {
l <- "layout_with_mds"
},
star = {
l <- "layout_as_star"
},
sphere = {
l <- "layout_on_sphere"
},
fruchterman = {
l <- "layout_with_fr"
},
kamada = {
l <- "layout_with_kk"
}
)
return(l)
}
savenetwork <- function(con, VIS) {
VIS %>%
visOptions(height = "800px") %>%
visNetwork::visSave(con)
}
igraph2vis <- function(g, curved, labelsize, opacity, type, shape, net, shadow = TRUE, edgesize = 5, noOverlap = TRUE) {
LABEL <- igraph::V(g)$name
LABEL[igraph::V(g)$labelsize == 0] <- ""
vn <- visNetwork::toVisNetworkData(g)
vn$nodes$label <- LABEL
vn$edges$num <- 1
vn$edges$dashes <- FALSE
vn$edges$dashes[vn$edges$lty == 2] <- TRUE
## opacity
vn$nodes$color <- adjustcolor(vn$nodes$color, alpha.f = min(c(opacity, 1)))
## set a darkest gray for iter-cluster edges
vn$edges$color <- paste(substr(vn$edges$color, 1, 7), "90", sep = "")
vn$edges$color[substr(vn$edges$color, 1, 7) == "#B3B3B3"] <- "#69696960"
vn$edges$color <- adjustcolor(vn$edges$color, alpha.f = opacity)
## removing multiple edges
vn$edges <- unique(vn$edges)
vn$edges$width <- vn$edges$width^2 / (max(vn$edges$width^2)) * (10 + edgesize)
# if (edgesize==0){
# vn$edges$hidden <- TRUE
# }else{vn$edges$hidden <- FALSE}
## labelsize
vn$nodes$font.size <- vn$nodes$deg
scalemin <- 20
scalemax <- 150
Min <- min(vn$nodes$font.size)
Max <- max(vn$nodes$font.size)
if (Max > Min) {
size <- (vn$nodes$font.size - Min) / (Max - Min) * 15 * labelsize + 10
} else {
size <- 10 * labelsize
}
size[size < scalemin] <- scalemin
size[size > scalemax] <- scalemax
vn$nodes$font.size <- size
l <- netLayout(type)
### TO ADD SHAPE AND FONT COLOR OPTIONS
coords <- net$layout
vn$nodes$size <- vn$nodes$font.size * 0.7
# vn$nodes$font.color <- adjustcolor("black", alpha.f = min(c(opacity,1)))
if (shape %in% c("dot", "square")) {
vn$nodes$font.vadjust <- -0.7 * vn$nodes$font.size
} else {
vn$nodes$font.vadjust <- 0
}
opacity_font <- sqrt((vn$nodes$font.size - min(vn$nodes$font.size)) / diff(range(vn$nodes$font.size))) * opacity + 0.3
if (is.nan(opacity_font[1])) opacity_font <- rep(0.3, length(opacity_font))
if (labelsize > 0) {
vn$nodes$font.color <- unlist(lapply(opacity_font, function(x) adjustcolor("black", alpha.f = x)))
} else {
vn$nodes$font.color <- adjustcolor("black", alpha.f = 0)
}
## avoid label overlaps
if (noOverlap) {
threshold <- 0.05
ymax <- diff(range(coords[, 2]))
xmax <- diff(range(coords[, 1]))
threshold2 <- threshold * mean(xmax, ymax)
w <- data.frame(x = coords[, 1], y = coords[, 2], labelToPlot = vn$nodes$label, dotSize = size, row.names = vn$nodes$label)
labelToRemove <- avoidNetOverlaps(w, threshold = threshold2)
} else {
labelToRemove <- ""
}
vn$nodes <- vn$nodes %>%
mutate(
label = ifelse(label %in% labelToRemove, "", label),
title = id
)
##
VIS <-
visNetwork::visNetwork(nodes = vn$nodes, edges = vn$edges, type = "full", smooth = TRUE, physics = FALSE) %>%
visNetwork::visNodes(shadow = shadow, shape = shape, font = list(color = vn$nodes$font.color, size = vn$nodes$font.size, vadjust = vn$nodes$font.vadjust)) %>%
visNetwork::visIgraphLayout(layout = "layout.norm", layoutMatrix = coords, type = "full") %>%
visNetwork::visEdges(smooth = list(type = "horizontal")) %>%
visNetwork::visOptions(highlightNearest = list(enabled = T, hover = T, degree = 1), nodesIdSelection = T) %>%
visNetwork::visInteraction(dragNodes = TRUE, navigationButtons = F, hideEdgesOnDrag = TRUE, zoomSpeed = 0.4) %>%
visNetwork::visOptions(manipulation = curved, height = "100%", width = "100%")
return(list(VIS = VIS, vn = vn, type = type, l = l, curved = curved))
}
## function to avoid label overlapping ----
avoidNetOverlaps <- function(w, threshold = 0.10) {
w[, 2] <- w[, 2] / 2
Ds <- dist(
w %>%
dplyr::filter(labelToPlot != "") %>%
select(1:2),
method = "manhattan", upper = T
) %>%
dist2df() %>%
rename(
from = row,
to = col,
dist = value
) %>%
left_join(
w %>% dplyr::filter(labelToPlot != "") %>%
select(labelToPlot, dotSize),
by = c("from" = "labelToPlot")
) %>%
rename(w_from = dotSize) %>%
left_join(
w %>% dplyr::filter(labelToPlot != "") %>%
select(labelToPlot, dotSize),
by = c("to" = "labelToPlot")
) %>%
rename(w_to = dotSize) %>%
filter(dist < threshold)
if (nrow(Ds) > 0) {
st <- TRUE
i <- 1
label <- NULL
case <- "n"
while (isTRUE(st)) {
if (Ds$w_from[i] > Ds$w_to[i] & Ds$dist[i] < threshold) {
case <- "y"
lab <- Ds$to[i]
} else if (Ds$w_from[i] <= Ds$w_to[i] & Ds$dist[i] < threshold) {
case <- "y"
lab <- Ds$from[i]
}
switch(case,
"y" = {
Ds <- Ds[Ds$from != lab, ]
Ds <- Ds[Ds$to != lab, ]
label <- c(label, lab)
},
"n" = {
Ds <- Ds[-1, ]
}
)
if (i >= nrow(Ds)) {
st <- FALSE
}
case <- "n"
# print(nrow(Ds))
}
} else {
label <- NULL
}
label
}
## visnetwork for subgraphs
igraph2visClust <- function(g, curved = FALSE, labelsize = 3, opacity = 0.7, shape = "dot", shadow = TRUE, edgesize = 5) {
LABEL <- igraph::V(g)$name
LABEL[igraph::V(g)$labelsize == 0] <- ""
vn <- visNetwork::toVisNetworkData(g)
vn$nodes$label <- LABEL
vn$edges$num <- 1
vn$edges$dashes <- FALSE
vn$edges$dashes[vn$edges$lty == 2] <- TRUE
## opacity
vn$nodes$color <- adjustcolor(vn$nodes$color, alpha.f = min(c(opacity, 1)))
## set a darkest gray for iter-cluster edges
vn$edges$color <- paste(substr(vn$edges$color, 1, 7), "90", sep = "")
vn$edges$color[substr(vn$edges$color, 1, 7) == "#B3B3B3"] <- "#69696960"
vn$edges$color <- adjustcolor(vn$edges$color, alpha.f = opacity)
## removing multiple edges
vn$edges <- unique(vn$edges)
vn$edges$width <- vn$edges$width^2 / (max(vn$edges$width^2)) * (5 + edgesize)
## labelsize
scalemin <- 20
scalemax <- 100
# aggiunta
vn$nodes$font.size <- vn$nodes$deg
#
Min <- min(vn$nodes$font.size)
Max <- max(vn$nodes$font.size)
if (Max > Min) {
size <- (vn$nodes$font.size - Min) / (Max - Min) * 15 * labelsize #+10
} else {
size <- 5 * labelsize
}
size[size < scalemin] <- scalemin
size[size > scalemax] <- scalemax
vn$nodes$font.size <- size
# l<-netLayout(type)
### TO ADD SHAPE AND FONT COLOR OPTIONS
vn$nodes$size <- vn$nodes$font.size * 0.4
if (shape %in% c("dot", "square")) {
vn$nodes$font.vadjust <- -0.7 * vn$nodes$font.size
} else {
vn$nodes$font.vadjust <- 0
}
opacity_font <- sqrt((vn$nodes$font.size - min(vn$nodes$font.size)) / diff(range(vn$nodes$font.size))) * opacity + 0.3
if (is.nan(opacity_font[1])) opacity_font <- rep(0.3, length(opacity_font))
if (labelsize > 0) {
vn$nodes$font.color <- unlist(lapply(opacity_font, function(x) adjustcolor("black", alpha.f = x)))
} else {
vn$nodes$font.color <- adjustcolor("black", alpha.f = 0)
}
VIS <-
visNetwork::visNetwork(nodes = vn$nodes, edges = vn$edges, type = "full", smooth = TRUE, physics = FALSE) %>%
visNetwork::visNodes(shadow = shadow, shape = shape, font = list(color = vn$nodes$font.color, size = vn$nodes$font.size, vadjust = vn$nodes$font.vadjust)) %>%
visNetwork::visIgraphLayout(layout = "layout_nicely", type = "full") %>%
visNetwork::visEdges(smooth = list(type = "horizontal")) %>%
visNetwork::visOptions(highlightNearest = list(enabled = T, hover = T, degree = 1), nodesIdSelection = T) %>%
visNetwork::visInteraction(dragNodes = TRUE, navigationButtons = F, hideEdgesOnDrag = TRUE, zoomSpeed = 0.4) %>%
visNetwork::visOptions(manipulation = curved, height = "100%", width = "100%")
return(list(VIS = VIS, vn = vn))
}
hist2vis <- function(net, labelsize = 2, nodesize = 2, curved = FALSE, shape = "dot", opacity = 0.7, labeltype = "short", timeline = TRUE) {
LABEL <- igraph::V(net$net)$id
LABEL[igraph::V(net$net)$labelsize == 0] <- ""
layout <- net$layout %>%
dplyr::select(x, y, color, name)
vn <- visNetwork::toVisNetworkData(net$net)
vn$nodes$short_label <- LABEL
if (labeltype != "short") {
vn$nodes$label <- paste0(vn$nodes$years, ": ", LABEL)
} else {
vn$nodes$label <- LABEL
}
vn$nodes <- dplyr::left_join(vn$nodes, layout, by = c("id" = "name"))
vn$edges$num <- 1
vn$edges$dashes <- FALSE
vn$edges$dashes[vn$edges$lty == 2] <- TRUE
vn$edges$color <- "grey"
## opacity
vn$nodes$font.color <- vn$nodes$color
vn$nodes$color <- adjustcolor(vn$nodes$color, alpha.f = min(c(opacity - 0.2, 1)))
vn$edges$color <- adjustcolor(vn$edges$color, alpha.f = opacity - 0.2)
vn$edges$smooth <- curved
## removing multiple edges
vn$edges <- unique(vn$edges)
## labelsize
scalemin <- 20
scalemax <- 150
size <- 10 * labelsize
size[size < scalemin] <- scalemin
size[size > scalemax] <- scalemax
vn$nodes$font.size <- size * 0.5
vn$nodes$size <- nodesize * 2
if (shape %in% c("dot", "square")) {
vn$nodes$font.vadjust <- -0.7 * vn$nodes$font.size
} else {
vn$nodes$font.vadjust <- 0
}
text_data <- net$graph.data %>%
select(Label, DOI, LCS, GCS) %>%
rename(id = Label) %>%
filter(!duplicated(id))
vn$nodes <- vn$nodes %>% left_join(text_data, by = "id")
## split node tooltips into two strings
title <- strsplit(stringi::stri_trans_totitle(vn$nodes$title), " ")
vn$nodes$title <- unlist(lapply(title, function(l) {
n <- floor(length(l) / 2)
paste0(paste(l[1:n], collapse = " ", sep = ""), "<br>", paste(l[(n + 1):length(l)], collapse = " ", sep = ""))
}))
vn$nodes <- vn$nodes %>%
mutate(title_orig = title,
title = paste("<b>Title</b>: ",
title,
"<br><b>DOI</b>: ",
paste0(
'<a href=\"https://doi.org/',
DOI,
'\" target=\"_blank\">',
# "DOI: ",
DOI, "</a>"
),
"<br><b>GCS</b>: ",
GCS, "<br><b>LCS</b>: ",
LCS,
sep = ""
))
## add time line
vn$nodes$group <- "normal"
vn$nodes$shape <- "dot"
vn$nodes$shadow <- TRUE
# nr <- nrow(vn$nodes)
# y <- max(vn$nodes$y)
# vn$nodes[nr + 1, c("id", "title", "label", "color", "font.color")] <-
# c(rep("logo", 3), "black", "white")
# vn$nodes$x[nr + 1] <- max(vn$nodes$x, na.rm = TRUE) + 1
# vn$nodes$y[nr + 1] <- y
# vn$nodes$size[nr + 1] <- vn$nodes$size[nr] * 4
# vn$nodes$years[nr + 1] <- as.numeric(vn$nodes$x[nr + 1])
# vn$nodes$font.size[nr + 1] <- vn$nodes$font.size[nr]
# vn$nodes$group[nr + 1] <- "logo"
# vn$nodes$shape[nr + 1] <- "image"
# vn$nodes$image[nr + 1] <- "logo.jpg"
# vn$nodes$fixed.x <- TRUE
# vn$nodes$fixed.y <- FALSE
# vn$nodes$fixed.y[nr + 1] <- TRUE
# vn$nodes$shadow[nr + 1] <- FALSE
# coords <- vn$nodes[, c("x", "y")] %>%
# as.matrix()
#
# coords[, 2] <- coords[, 2]^(1 / 2)
tooltipStyle <- ("position: fixed;visibility:hidden;padding: 5px;white-space: nowrap;
font-size:12px;font-color:black;background-color:white;")
## Font opacity
vn$nodes$LCS[is.na(vn$nodes$LCS)] <- max(vn$nodes$LCS, na.rm = TRUE)
opacity_font <- sqrt((vn$nodes$LCS - min(vn$nodes$LCS)) / diff(range(vn$nodes$LCS))) * 0.6 + 0.4
vn$nodes$size <- opacity_font * 5 * nodesize
vn$nodes$size[nrow(vn$nodes)] <- max(5 * nodesize)
for (i in 1:nrow(vn$nodes)) vn$nodes$font.color[i] <- adjustcolor(vn$nodes$font.color[i], alpha.f = opacity_font[i])
x <- vn$nodes$x
y <- vn$nodes$y
vn$nodes$x <- y
vn$nodes$y <- x
vn$nodes <- assign_horizontal_coords_clusters_adaptive(vn$nodes)
vn$nodes$fixed.x <- FALSE
vn$nodes$fixed.y <-TRUE
coords <- vn$nodes[, c("x", "y")] %>%
as.matrix()
coords[,2] <- coords[,2]
VIS <-
visNetwork::visNetwork(nodes = vn$nodes, edges = vn$edges, type = "full", smooth = TRUE, physics = FALSE) %>%
visNetwork::visNodes(shadow = vn$nodes$shadow, shape = shape, size = vn$nodes$size, font = list(color = vn$nodes$font.color, size = vn$nodes$font.size, vadjust = vn$nodes$font.vadjust)) %>%
visNetwork::visIgraphLayout(layout = "layout.norm", layoutMatrix = coords, type = "full") %>%
#visNetwork::visEdges(smooth = list(type = "horizontal"), arrows = list(to = list(enabled = TRUE, scaleFactor = 0.5))) %>%
visNetwork::visEdges(smooth = list(enabled = TRUE, type = "dynamic", roundness = 0.3),
arrows = list(to = list(enabled = TRUE, scaleFactor = 0.5))) %>%
visNetwork::visInteraction(dragNodes = T, navigationButtons = F, hideEdgesOnDrag = F, tooltipStyle = tooltipStyle, zoomSpeed = 0.2) %>%
visNetwork::visOptions(
highlightNearest = list(enabled = T, hover = T, degree = list(from = 1), algorithm = "hierarchical"), nodesIdSelection = F,
manipulation = FALSE, height = "100%", width = "100%"
)
return(list(VIS = VIS, vn = vn, type = "historiograph", curved = curved))
}
## calculate node coordinates in historiograph
assign_horizontal_coords_clusters_adaptive <- function(nodes_df, spacing_base = 1.0, cluster_spacing = 6, tol=0.15) {
clusters <- nodes_df %>%
count(color, name = "n_cluster") %>%
arrange(desc(n_cluster)) %>%
mutate(cluster_id = row_number(),
cluster_center = (cluster_id - mean(cluster_id)) * cluster_spacing)
nodes_df <- nodes_df %>%
left_join(clusters, by = "color")
nodes_df <- nodes_df %>%
group_by(years, color) %>%
mutate(
n_nodes = n(),
spacing = spacing_base * n_nodes, # USA direttamente il numero di nodi
x = (cluster_center[1] + spacing[1] * (row_number() - (n() + 1)/2))*runif(1,1-tol,1+tol)
) %>%
ungroup()
return(nodes_df)
}
## Pajek Export
graph2Pajek <- function(graph, filename = "my_pajek_network") {
nodes <- igraph::as_data_frame(graph, what = c("vertices")) %>%
mutate(id = row_number())
edges <- igraph::as_data_frame(graph, what = c("edges"))
edges <- edges %>%
left_join(nodes %>% select(id, name), by = c("from" = "name")) %>%
rename(id_from = id) %>%
left_join(nodes %>% select(id, name), by = c("to" = "name")) %>%
rename(id_to = id)
### Creation of NET file
file <- paste0(filename, ".net")
# Nodes
write(paste0("*Vertices ", nrow(nodes)), file = file)
write(paste0(nodes$id, ' "', nodes$name, '"'), file = file, append = T)
# Edges
write(paste0("*Edges ", nrow(nodes)), file = file, append = T)
write(paste0(edges$id_from, " ", edges$id_to, " ", edges$weight), file = file, append = T)
### Creation of VEC file
file <- paste0(filename, ".vec")
# Nodes
write(paste0("*Vertices ", nrow(nodes)), file = file)
write(paste0(nodes$deg), file = file, append = T)
### Creation of CLU file
file <- paste0(filename, ".clu")
# Nodes
write(paste0("*Vertices ", nrow(nodes)), file = file)
write(paste0(nodes$community), file = file, append = T)
}
## Dendogram to Visnetwork
dend2vis <- function(hc, labelsize, nclusters = 1, community = FALSE) {
# community = TRUE means that hc is an igraph community detection object
# community = FALSE mean that hc is a hclust object
# transform and plot a community igraph object using dendrogram
if (community) {
hc <- as.hclust(hc, use.modularity = TRUE)
}
h_tail <- round((max(hc$height) * 0.12), 1)
hc$height <- hc$height + h_tail
VIS <- visHclust(hc, cutree = nclusters, colorEdges = "grey60", horizontal = TRUE, export = FALSE)
VIS$x$edges <- data.frame(color = unique(VIS$x$edges$color)) %>%
mutate(new_color = colorlist()[1:nrow(.)]) %>%
right_join(VIS$x$edges, by = "color") %>%
select(-color) %>%
rename(color = new_color)
VIS$x$nodes <- VIS$x$nodes %>%
mutate(
label = ifelse(group != "individual", NA, label),
group = ifelse(group == "individual", "word", group),
title = gsub("individuals", "words", title),
value = 1,
scaling.min = 10,
scaling.max = 10
)
coords <- VIS$x$nodes %>%
select(x, y) %>%
as.matrix()
edges <- VIS$x$edges
nodes <- VIS$x$nodes %>%
select(id, label) %>%
dplyr::filter(label != "1")
VIS$x$edges <- edges %>%
select(-id) %>%
left_join(nodes, by = c("to" = "id")) %>%
select(-label.x) %>%
rename(label = label.y) %>%
mutate(
value = 10,
font.color = color,
font.size = labelsize * 10,
font.vadjust = -0.2 * font.size,
label = ifelse(is.na(label), "", label)
)
VIS <- VIS %>%
visGroups(
groupname = "group", color = "gray90",
shape = "dot", size = 10
) %>%
visGroups(
groupname = "word",
font = list(size = 0),
color = list(
background = "white", border = "#80B1D3",
highlight = "#e2e9e9", hover = "orange"
), shape = "box"
) %>%
visNodes(font = list(align = VIS$x$nodes$font.align)) %>%
visNetwork::visOptions(
highlightNearest = list(enabled = T, hover = T, degree = list(to = 1000, from = 0), algorithm = "hierarchical"), nodesIdSelection = FALSE,
manipulation = FALSE, height = "100%", width = "100%"
) %>%
visNetwork::visInteraction(dragNodes = FALSE, navigationButtons = F, hideEdgesOnDrag = TRUE, zoomSpeed = 0.4) %>%
visIgraphLayout(layout = "layout.norm", layoutMatrix = coords, type = "full") %>%
visEdges(font = list(align = "top", size = VIS$x$edges$font.size)) %>%
visEvents(click = "function(nodes){
Shiny.onInputChange('click_dend', nodes.nodes[0]);
;}")
for (i in 1:nrow(VIS$x$nodes)) {
if (VIS$x$nodes$group[i] == "group") {
old_inertia <- as.character(VIS$x$nodes$inertia[i])
inertia <- as.character(VIS$x$nodes$inertia[i] - h_tail)
VIS$x$nodes$title[i] <- gsub(old_inertia, inertia, VIS$x$nodes$title[i])
}
}
VIS
}
## Factorial Analysis dynamic plots
ca2plotly <- function(CS, method = "MCA", dimX = 1, dimY = 2, topWordPlot = Inf, threshold = 0.10, labelsize = 16, size = 5) {
LABEL <- CS$WData$word
switch(method,
CA = {
contrib <- rowSums(CS$coord$contrib %>% as.data.frame()) / 2
wordCoord <- CS$coord$coord[, 1:2] %>%
data.frame() %>%
mutate(
label = LABEL,
contrib = contrib
) %>%
select(c(3, 1, 2, 4))
row.names(wordCoord) <- LABEL
xlabel <- paste0("Dim 1 (", round(CS$res$eigCorr$perc[1], 2), "%)")
ylabel <- paste0("Dim 2 (", round(CS$res$eigCorr$perc[2], 2), "%)")
},
MCA = {
contrib <- rowSums(CS$coord$contrib %>% as.data.frame()) / 2
wordCoord <- CS$coord$coord[, 1:2] %>%
data.frame() %>%
mutate(
label = LABEL,
contrib = contrib
) %>%
select(c(3, 1, 2, 4))
row.names(wordCoord) <- LABEL
xlabel <- paste0("Dim 1 (", round(CS$res$eigCorr$perc[1], 2), "%)")
ylabel <- paste0("Dim 2 (", round(CS$res$eigCorr$perc[2], 2), "%)")
},
MDS = {
contrib <- size
xlabel <- "Dim 1"
ylabel <- "Dim 2"
wordCoord <- CS$WData %>%
data.frame() %>%
select(1:3) %>%
mutate(contrib = contrib / 2) %>%
rename(label = "word")
}
)
dimContrLabel <- paste0("Contrib", c(dimX, dimY))
ymax <- diff(range((wordCoord[, 3])))
xmax <- diff(range((wordCoord[, 2])))
threshold2 <- threshold * mean(xmax, ymax)
# scaled size for dots
dotScale <- (wordCoord$contrib) + size
# Threshold labels to plot
thres <- sort(dotScale, decreasing = TRUE)[min(topWordPlot, nrow(wordCoord))]
names(wordCoord)[2:3] <- c("Dim1", "Dim2")
wordCoord <- wordCoord %>%
mutate(
dotSize = dotScale,
groups = CS$km.res$cluster,
labelToPlot = ifelse(dotSize >= thres, label, ""),
font.color = ifelse(labelToPlot == "", NA, adjustcolor(colorlist()[groups], alpha.f = 0.85)),
font.size = round(dotSize * 2, 0)
)
## Avoid label overlapping
labelToRemove <- avoidOverlaps(wordCoord, threshold = threshold2, dimX = dimX, dimY = dimY)
wordCoord <- wordCoord %>%
mutate(labelToPlot = ifelse(labelToPlot %in% labelToRemove, "", labelToPlot)) %>%
mutate(
label = gsub("_1", "", label),
labelToPlot = gsub("_1", "", labelToPlot)
)
hoverText <- paste(" <b>", wordCoord$label, "</b>\n Contribute: ", round(wordCoord$contrib, 3), sep = "")
fig <- plot_ly(
data = wordCoord, x = wordCoord[, "Dim1"], y = wordCoord[, "Dim2"], # customdata=results$wordCoord,
type = "scatter",
mode = "markers",
marker = list(
size = dotScale,
color = adjustcolor(colorlist()[wordCoord$groups], alpha.f = 0.3), #' rgb(79, 121, 66, .5)',
line = list(
color = adjustcolor(colorlist()[wordCoord$groups], alpha.f = 0.3), #' rgb(79, 121, 66, .8)',
width = 2
)
),
text = hoverText,
hoverinfo = "text",
alpha = .3
)
fig <- fig %>% layout(
yaxis = list(title = ylabel, showgrid = TRUE, showline = FALSE, showticklabels = TRUE, domain = c(0, 1)),
xaxis = list(title = xlabel, zeroline = TRUE, showgrid = TRUE, showline = FALSE, showticklabels = TRUE),
plot_bgcolor = "rgba(0, 0, 0, 0)",
paper_bgcolor = "rgba(0, 0, 0, 0)"
)
for (i in seq_len(max(wordCoord$groups))) {
if (method == "MDS") {
w <- wordCoord %>%
dplyr::filter(groups == i) %>%
mutate(
Dim1 = Dim1 + 0.005,
Dim2 = Dim2 + 0.005
)
} else {
w <- wordCoord %>%
dplyr::filter(groups == i) %>%
mutate(
Dim1 = Dim1 + dotSize * 0.005,
Dim2 = Dim2 + dotSize * 0.01
)
}
if (max(CS$hull_data$clust) > 1) {
hull_df <- CS$hull_data %>% dplyr::filter(clust == i)
fig <- fig %>% add_polygons(
x = hull_df$Dim1, y = hull_df$Dim2, inherit = FALSE, showlegend = FALSE,
color = I(hull_df$color[1]), opacity = 0.3, line = list(width = 2),
text = paste0("Cluster ", i), hoverinfo = "text", hoveron = "points"
)
}
fig <- fig %>%
add_annotations(
data = w, x = ~Dim1, y = ~Dim2, xref = "x1", yref = "y",
text = ~labelToPlot,
font = list(family = "sans serif", size = labelsize, color = w$font.color[1]), #' rgb(79, 121, 66)'),
showarrow = FALSE
)
}
fig <- fig %>%
config(
displaylogo = FALSE,
modeBarButtonsToRemove = c(
#' toImage',
"sendDataToCloud",
"pan2d",
"select2d",
"lasso2d",
"toggleSpikelines",
"hoverClosestCartesian",
"hoverCompareCartesian"
)
) %>%
event_register("plotly_selecting")
return(fig)
}
## function to avoid label overlapping ----
avoidOverlaps <- function(w, threshold = 0.10, dimX = 1, dimY = 2) {
w[, "Dim2"] <- w[, "Dim2"] / 3
Ds <- dist(
w %>%
dplyr::filter(labelToPlot != "") %>%
select(Dim1, Dim2),
method = "manhattan", upper = T
) %>%
dist2df() %>%
rename(
from = row,
to = col,
dist = value
) %>%
left_join(
w %>% dplyr::filter(labelToPlot != "") %>%
select(labelToPlot, dotSize),
by = c("from" = "labelToPlot")
) %>%
rename(w_from = dotSize) %>%
left_join(
w %>% dplyr::filter(labelToPlot != "") %>%
select(labelToPlot, dotSize),
by = c("to" = "labelToPlot")
) %>%
rename(w_to = dotSize) %>%
filter(dist < threshold)
st <- TRUE
i <- 1
label <- NULL
case <- "n"
while (isTRUE(st)) {
if (Ds$w_from[i] > Ds$w_to[i] & Ds$dist[i] < threshold) {
case <- "y"
lab <- Ds$to[i]
} else if (Ds$w_from[i] <= Ds$w_to[i] & Ds$dist[i] < threshold) {
case <- "y"
lab <- Ds$from[i]
}
switch(case,
"y" = {
Ds <- Ds[Ds$from != lab, ]
Ds <- Ds[Ds$to != lab, ]
label <- c(label, lab)
},
"n" = {
Ds <- Ds[-1, ]
}
)
if (i >= nrow(Ds)) {
st <- FALSE
}
case <- "n"
# print(nrow(Ds))
}
label
}
## convert a distance object into a data.frame ----
dist2df <- function(inDist) {
if (class(inDist) != "dist") stop("wrong input type")
A <- attr(inDist, "Size")
B <- if (is.null(attr(inDist, "Labels"))) sequence(A) else attr(inDist, "Labels")
if (isTRUE(attr(inDist, "Diag"))) attr(inDist, "Diag") <- FALSE
if (isTRUE(attr(inDist, "Upper"))) attr(inDist, "Upper") <- FALSE
data.frame(
row = B[unlist(lapply(sequence(A)[-1], function(x) x:A))],
col = rep(B[-length(B)], (length(B) - 1):1),
value = as.vector(inDist)
)
}
### Excel report functions
addDataWb <- function(list_df, wb, sheetname) {
l <- length(list_df)
startRow <- 1
for (i in 1:l) {
df <- list_df[[i]]
n <- nrow(df)
writeDataTable(wb, sheetname, df, startRow = startRow, startCol = 1, tableStyle = "TableStyleMedium20")
startRow <- startRow + n + 3
}
return(wb)
}
addDataScreenWb <- function(list_df, wb, sheetname) {
ind <- which(regexpr(sheetname, wb$sheet_names) > -1)
if (length(ind) > 0) {
sheetname <- paste(sheetname, "(", length(ind) + 1, ")", sep = "")
}
addWorksheet(wb = wb, sheetName = sheetname, gridLines = FALSE)
if (!is.null(list_df)) {
addDataWb(list_df, wb, sheetname)
col <- max(unlist(lapply(list_df, ncol))) + 2
} else {
col <- 1
}
results <- list(wb = wb, col = col, sheetname = sheetname)
return(results)
}
addGgplotsWb <- function(list_plot, wb, sheetname, col, width = 10, height = 7, dpi = 75) {
l <- length(list_plot)
startRow <- 1
for (i in 1:l) {
fileName <- tempfile(
pattern = "figureImage",
fileext = ".png"
)
if (inherits(list_plot[[i]], "ggplot")) {
ggsave(
plot = list_plot[[i]], filename = fileName, width = width, height = height,
units = "in", dpi = dpi
)
}
if (inherits(list_plot[[i]], "igraph")) {
igraph2PNG(x = list_plot[[i]], filename = fileName, width = width, height = height, dpi = dpi)
}
if (inherits(list_plot[[i]], "bibliodendrogram")) {
# print("dendrogram plot")
# 1. Open jpeg file
png(filename = fileName, width = width, height = height, res = 300, units = "in")
# 2. Create the plot
plot(list_plot[[i]])
# 3. Close the file
dev.off()
}
insertImage(
wb = wb, sheet = sheetname, file = fileName, width = width,
height = height, startRow = startRow, startCol = col,
units = "in", dpi = dpi
)
startRow <- startRow + (height * 6) + 1
}
return(wb)
}
screenSh <- function(p, zoom = 2, type = "vis") {
tmpdir <- tempdir()
fileName <- tempfile(
pattern = "figureImage",
tmpdir = tmpdir,
fileext = ".png"
) # %>% substr(.,2,nchar(.))
plot2png(p, filename = fileName, zoom = zoom, type = type, tmpdir = tmpdir)
return(fileName)
}
screenShot <- function(p, filename, type) {
home <- homeFolder()
# setting up the main directory
# filename <- paste0(file.path(home,"downloads/"),filename)
if ("downloads" %in% tolower(dir(home))) {
filename <- paste0(file.path(home, "downloads"), "/", filename)
} else {
filename <- paste0(home, "/", filename)
}
plot2png(p, filename, zoom = 2, type = type, tmpdir = tempdir())
}
plot2png <- function(p, filename, zoom = 2, type = "vis", tmpdir) {
html_name <- tempfile(
fileext = ".html",
tmpdir = tmpdir
)
switch(type,
vis = {
visSave(p, html_name)
},
plotly = {
htmlwidgets::saveWidget(p, file = html_name)
}
)
biblioShot(url = html_name, zoom = zoom, file = filename) # , verbose=FALSE)
popUpGeneric(
title = NULL, type = "success", color = c("#1d8fe1"),
subtitle = paste0("Plot was saved in the following path: ", filename),
btn_labels = "OK", size = "40%"
)
}
addScreenWb <- function(df, wb, width = 14, height = 8, dpi = 75) {
names(df) <- c("sheet", "file", "n")
if (nrow(df) > 0) {
sheet <- unique(df$sheet)
for (i in 1:length(sheet)) {
sh <- sheet[i]
df_sh <- df %>% dplyr::filter(sheet == sh)
l <- nrow(df_sh)
startRow <- 1
for (j in 1:l) {
fileName <- df_sh$file[j]
insertImage(
wb = wb, sheet = sh, file = fileName, width = width,
height = height, startRow = startRow, startCol = df_sh$n[j],
units = "in", dpi = dpi
)
startRow <- startRow + (height * 10) + 3
}
}
}
return(wb)
}
addSheetToReport <- function(list_df, list_plot, sheetname, wb, dpi = 75) {
ind <- which(regexpr(sheetname, wb$sheet_names) > -1)
if (length(ind) > 0) {
sheetname <- paste(sheetname, "(", length(ind) + 1, ")", sep = "")
}
addWorksheet(wb, sheetname, gridLines = FALSE)
if (!is.null(list_df)) {
col <- max(unlist(lapply(list_df, ncol))) + 2
wb <- addDataWb(list_df, wb = wb, sheetname = sheetname)
} else {
col <- 1
}
if (!is.null(list_plot)) {
wb <- addGgplotsWb(list_plot, wb = wb, sheetname = sheetname, col = col, dpi = dpi)
}
# values$sheet_name <- sheetname
return(wb)
}
short2long <- function(df, myC) {
z <- unlist(lapply(myC, function(x) {
y <- gsub(r"{\s*\([^\)]+\)}", "", x)
gsub(y, df$long[df$short == y], x)
}))
names(myC) <- z
return(myC)
}
dfLabel <- function() {
short <- c(
"Empty Report", "MissingData", "MainInfo", "AnnualSciProd", "AnnualCitPerYear", "ThreeFieldsPlot", "MostRelSources", "MostLocCitSources", "BradfordLaw", "SourceLocImpact",
"SourceProdOverTime", "MostRelAuthors", "MostLocCitAuthors", "AuthorProdOverTime", "LotkaLaw", "AuthorLocImpact", "MostRelAffiliations", "AffOverTime",
"CorrAuthCountries", "CountrySciProd", "CountryProdOverTime", "MostCitCountries", "MostGlobCitDocs", "MostLocCitDocs", "MostLocCitRefs", "RPYS",
"MostFreqWords", "WordCloud", "TreeMap", "WordFreqOverTime", "TrendTopics", "CouplingMap", "CoWordNet", "ThematicMap", "ThematicEvolution",
"TE_Period_1", "TE_Period_2", "TE_Period_3", "TE_Period_4", "TE_Period_5", "FactorialAnalysis", "CoCitNet", "Historiograph", "CollabNet", "CollabWorldMap"
)
long <- c(
"Empty Report", "Missing Data Table", "Main Information", "Annual Scientific Production", "Annual Citation Per Year", "Three-Field Plot", "Most Relevant Sources", "Most Local Cited Sources", "Bradfords Law", "Sources Local Impact",
"Sources Production over Time", "Most Relevant Authors", "Most Local Cited Authors", "Authors Production over Time", "Lotkas Law", "Authors Local Impact", "Most Relevant Affiliations", "Affiliations Production over Time",
"Corresponding Authors Countries", "Countries Scientific Production", "Countries Production over Time", "Most Cited Countries", "Most Global Cited Documents", "Most Local Cited Documents", "Most Local Cited References", "Reference Spectroscopy",
"Most Frequent Words", "WordCloud", "TreeMap", "Words Frequency over Time", "Trend Topics", "Clustering by Coupling", "Co-occurence Network", "Thematic Map", "Thematic Evolution",
"TE_Period_1", "TE_Period_2", "TE_Period_3", "TE_Period_4", "TE_Period_5", "Factorial Analysis", "Co-citation Network", "Historiograph", "Collaboration Network", "Countries Collaboration World Map"
)
data.frame(short = short, long = long)
}
## Generic PopUp
popUpGeneric <- function(title = NULL, type = "success", color = c("#1d8fe1", "#913333", "#FFA800"),
subtitle = "",
btn_labels = "OK", size = "40%") {
showButton <- TRUE
timer <- NA
show_alert(
title = title,
text = subtitle,
type = type,
size = size,
closeOnEsc = TRUE,
closeOnClickOutside = TRUE,
html = FALSE,
showConfirmButton = showButton,
showCancelButton = FALSE,
btn_labels = btn_labels,
btn_colors = color,
timer = timer,
imageUrl = "",
animation = TRUE
)
}
## Ad to Report PopUp
popUp <- function(title = NULL, type = "success", btn_labels = "OK") {
switch(type,
success = {
title <- paste(title, "\n added to report", sep = "")
subtitle <- ""
btn_colors <- "#1d8fe1"
showButton <- TRUE
timer <- 3000
},
error = {
title <- "No results to add to the report "
subtitle <- "Please Run the analysis and then Add it to the report"
btn_colors <- "#913333"
showButton <- TRUE
timer <- 3000
},
waiting = {
title <- "Please wait... "
subtitle <- "Adding results to report"
btn_colors <- "#FFA800"
showButton <- FALSE
btn_labels <- NA
timer <- NA
}
)
show_alert(
title = title,
text = subtitle,
type = type,
size = "s",
closeOnEsc = TRUE,
closeOnClickOutside = TRUE,
html = FALSE,
showConfirmButton = showButton,
showCancelButton = FALSE,
btn_labels = btn_labels,
btn_colors = btn_colors,
timer = timer,
imageUrl = "",
animation = TRUE
)
}
colorlist <- function() {
c(
"#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", "#FF7F00", "#A65628", "#F781BF", "#999999", "#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3", "#A6D854", "#FFD92F",
"#B3B3B3", "#A6CEE3", "#1F78B4", "#B2DF8A", "#33A02C", "#FB9A99", "#E31A1C", "#FDBF6F", "#FF7F00", "#CAB2D6", "#6A3D9A", "#B15928", "#8DD3C7", "#BEBADA",
"#FB8072", "#80B1D3", "#FDB462", "#B3DE69", "#D9D9D9", "#BC80BD", "#CCEBC5"
)
}
overlayPlotly <- function(VIS) {
# colorscale_VOS=matrix(c(0, 'rgba(66,65,135,255)', 0.1, 'rgba(34,170,134,255)',
# 0.3, 'rgba(202,224,31,255)',
# 1, 'rgba(244,227,92,255)'),4,2, byrow=T)
# colorscale_Our=matrix(c(0, 'rgba(238,238,238,255)',
# 0.1, 'rgba(232,202,177,255)',
# 0.2, 'rgba(217,137,100,255)',
# 0.6, 'rgba(199,107,90,255)',
# 0.9, 'rgba(164,38,39,255)',
# 1, 'rgba(178,34,34,255)'),
# 6,2, byrow=T)
Reds <- matrix(
c(
"0", "rgb(255,255,255)",
"0.05", "rgb(238,238,238)",
"0.125", "rgb(254,224,210)",
"0.25", "rgb(252,187,161)",
"0.375", "rgb(252,146,114)",
"0.5", "rgb(251,106,74)",
"0.625", "rgb(239,59,44)",
"0.75", "rgb(203,24,29)",
"0.875", "rgb(165,15,21)",
"1", "rgb(103,0,13)"
)
)
nodes <- VIS$x$nodes %>%
mutate(
y = y * (-1),
font.size = (((font.size - min(font.size)) / diff(range(font.size))) * 20) + 10
)
colori <- c(
"Blackbody", "Bluered", "Blues", "Cividis", "Earth", "Electric", "Greens", "Greys", "Hot", "Jet", "Picnic", "Portland",
"Rainbow", "RdBu", "Reds", "Viridis", "YlGnBu", "YlOrRd"
)
nodes2 <- nodes %>%
group_by(id) %>%
mutate(log = ceiling(log(deg))) %>%
slice(rep(1, each = log))
p <- plot_ly(nodes2, x = ~x, y = ~y) %>%
add_histogram2d(
histnorm = "density", zsmooth = "fast",
colorscale = Reds,
# colorscale=colori[15],
showscale = FALSE
)
for (i in 1:nrow(nodes)) {
p <- p %>%
add_annotations(
xref = "x1", yref = "y",
x = nodes$x[i], y = nodes$y[i],
text = nodes$label[i],
font = list(family = "Arial", size = nodes$font.size[i], color = adjustcolor(nodes$font.color[i], alpha.f = 0.8)),
showarrow = FALSE
)
}
p <- p %>%
layout(
yaxis = list(
title = "", zeroline = FALSE, showgrid = FALSE, showline = FALSE,
showticklabels = FALSE, domain = c(-1, 1), gridcolor = "#FFFFFF",
tickvals = list(NA)
),
xaxis = list(
title = "", zeroline = FALSE, showgrid = FALSE, showline = FALSE,
showticklabels = FALSE, domain = c(-1, 1), gridcolor = "#FFFFFF",
tickvals = list(NA)
),
plot_bgcolor = "rgba(0, 0, 0, 0)",
paper_bgcolor = "rgba(0, 0, 0, 0)",
showlegend = FALSE
) %>%
style(hoverinfo = "none") %>%
config(
displaylogo = FALSE,
modeBarButtonsToRemove = c(
#' toImage',
"sendDataToCloud",
"pan2d",
"select2d",
"lasso2d",
"toggleSpikelines",
"hoverClosestCartesian",
"hoverCompareCartesian"
)
)
return(p)
}
menuList <- function(values) {
TC <- ISI <- MLCS <- MLCA <- AFF <- MCC <- DB_TC <- DB_CR <- CR <- FALSE
if (!"TC" %in% values$missTags) TC <- TRUE
if ("ISI" %in% values$M$DB[1] & !"CR" %in% values$missTags) MLCS <- TRUE
if ("ISI" %in% values$M$DB[1] & !"CR" %in% values$missTags) MLCA <- TRUE
if ("ISI" %in% values$M$DB[1]) ISI <- TRUE
if (!"C1" %in% values$missTags) AFF <- TRUE
if (!"CR" %in% values$missTags) CR <- TRUE
if (!"TC" %in% values$missTags & !"C1" %in% values$missTags) MCC <- TRUE
if (sum(c("SCOPUS", "ISI") %in% values$M$DB[1]) > 0) DB_CR <- TRUE
if (sum(c("SCOPUS", "ISI", "OPENALEX", "LENS") %in% values$M$DB[1]) > 0) DB_TC <- TRUE
# out <- list(TC,ISI,MLCS,AFF,MCC,DB_TC,DB_CR,CR)
out <- NULL
L <- list()
L[[length(L) + 1]] <-
menuItem("Filters", tabName = "filters", icon = fa_i(name = "filter"))
L[[length(L) + 1]] <-
menuItem("Overview",
tabName = "overview", icon = fa_i(name = "table"), startExpanded = FALSE,
menuSubItem("Main Information", tabName = "mainInfo", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("Annual Scientific Production", tabName = "annualScPr", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(TC)) {
menuSubItem("Average Citations per Year", tabName = "averageCitPerYear", icon = icon("chevron-right", lib = "glyphicon"))
},
menuSubItem("Three-Field Plot", tabName = "threeFieldPlot", icon = icon("chevron-right", lib = "glyphicon"))
)
L[[length(L) + 1]] <-
menuItem("Sources",
tabName = "sources", icon = fa_i(name = "book"), startExpanded = FALSE,
menuSubItem("Most Relevant Sources", tabName = "relevantSources", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(MLCS)) {
menuSubItem("Most Local Cited Sources", tabName = "localCitedSources", icon = icon("chevron-right", lib = "glyphicon"))
},
menuSubItem("Bradford's Law", tabName = "bradford", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(TC)) {
menuSubItem("Sources' Local Impact", tabName = "sourceImpact", icon = icon("chevron-right", lib = "glyphicon"))
},
menuSubItem("Sources' Production over Time", tabName = "sourceDynamics", icon = icon("chevron-right", lib = "glyphicon"))
)
AU <-
menuItem("Authors",
tabName = "authors", icon = fa_i(name = "user"), startExpanded = FALSE,
"Authors",
menuSubItem("Most Relevant Authors", tabName = "mostRelAuthors", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(MLCA)) {
menuSubItem("Most Local Cited Authors", tabName = "mostLocalCitedAuthors", icon = icon("chevron-right", lib = "glyphicon"))
},
menuSubItem("Authors' Production over Time", tabName = "authorsProdOverTime", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("Lotka's Law", tabName = "lotka", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(TC)) {
menuSubItem("Authors' Local Impact", tabName = "authorImpact", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(AFF)) {
"Affiliations"
},
if (isTRUE(AFF)) {
menuSubItem("Most Relevant Affiliations", tabName = "mostRelAffiliations", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(AFF)) {
menuSubItem("Affiliations' Production over Time", tabName = "AffOverTime", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(AFF)) {
"Countries"
},
if (isTRUE(AFF)) {
menuSubItem("Corresponding Author's Countries", tabName = "correspAuthorCountry", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(AFF)) {
menuSubItem("Countries' Scientific Production", tabName = "countryScientProd", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(AFF)) {
menuSubItem("Countries' Production over Time", tabName = "COOverTime", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(MCC)) {
menuSubItem("Most Cited Countries", tabName = "mostCitedCountries", icon = icon("chevron-right", lib = "glyphicon"))
}
)
L[[length(L) + 1]] <- AU
DOC <-
menuItem("Documents",
tabName = "documents", icon = fa_i(name = "layer-group"), startExpanded = FALSE,
if (isTRUE(TC) | isTRUE(DB_TC)) {
"Documents"
},
if (isTRUE(TC)) {
menuSubItem("Most Global Cited Documents", tabName = "mostGlobalCitDoc", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(DB_TC) & isTRUE(CR) & isTRUE(TC)) {
menuSubItem("Most Local Cited Documents", tabName = "mostLocalCitDoc", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(DB_CR)) {
"Cited References"
},
if (isTRUE(DB_CR)) {
menuSubItem("Most Local Cited References", tabName = "mostLocalCitRef", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(DB_CR)) {
menuSubItem("References Spectroscopy", tabName = "ReferenceSpect", icon = icon("chevron-right", lib = "glyphicon"))
},
"Words",
menuSubItem("Most Frequent Words", tabName = "mostFreqWords", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("WordCloud", tabName = "wcloud", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("TreeMap", tabName = "treemap", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("Words' Frequency over Time", tabName = "wordDynamics", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("Trend Topics", tabName = "trendTopic", icon = icon("chevron-right", lib = "glyphicon"))
)
L[[length(L) + 1]] <- DOC
L[[length(L) + 1]] <-
menuItem("Clustering",
tabName = "clustering", icon = fa_i(name = "spinner"), startExpanded = FALSE,
menuSubItem("Clustering by Coupling", tabName = "coupling", icon = icon("chevron-right", lib = "glyphicon"))
)
L[[length(L) + 1]] <-
menuItem("Conceptual Structure",
tabName = "concepStructure", icon = fa_i(name = "spell-check"), startExpanded = FALSE,
"Network Approach",
menuSubItem("Co-occurence Network", tabName = "coOccurenceNetwork", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("Thematic Map", tabName = "thematicMap", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("Thematic Evolution", tabName = "thematicEvolution", icon = icon("chevron-right", lib = "glyphicon")),
"Factorial Approach",
menuSubItem("Factorial Analysis", tabName = "factorialAnalysis", icon = icon("chevron-right", lib = "glyphicon"))
)
if (!"CR" %in% values$missTags) {
L[[length(L) + 1]] <-
menuItem("Intellectual Structure",
tabName = "intStruct", icon = fa_i(name = "gem"), startExpanded = FALSE,
menuSubItem("Co-citation Network", tabName = "coCitationNetwork", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(DB_TC) & isTRUE(CR)) {
menuSubItem("Historiograph", tabName = "historiograph", icon = icon("chevron-right", lib = "glyphicon"))
}
)
}
L[[length(L) + 1]] <-
menuItem("Social Structure",
tabName = "socialStruct", icon = fa_i("users"), startExpanded = FALSE,
menuSubItem("Collaboration Network", tabName = "collabNetwork", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(AFF)) {
menuSubItem("Countries' Collaboration World Map", tabName = "collabWorldMap", icon = icon("chevron-right", lib = "glyphicon"))
}
)
L[[length(L) + 1]] <- menuItem("Report", tabName = "report", icon = fa_i(name = "list-alt"))
L[[length(L) + 1]] <- menuItem("TALL Export", tabName = "tall", icon = icon("text-size", lib = "glyphicon"))
# L[[length(L) + 1]] <- menuItem("Settings", tabName = "settings", icon = fa_i(name = "sliders"))
if (!isTRUE(TC)) {
out <- c(
out, "Average Citations per Year", "Sources' Local Impact", "Authors' Local Impact",
"Most Global Cited Documents"
)
}
if (!isTRUE(MLCS)) {
out <- c(out, "Most Local Cited Sources")
}
if (!isTRUE(ISI)) {
out <- c(out, "Most Local Cited Authors")
}
if (!isTRUE(AFF)) {
out <- c(
out, "Most Relevant Affiliations", "Affiliations' Production over Time",
"Corresponding Author's Countries", "Countries' Scientific Production",
"Countries' Production over Time", "Countries' Collaboration World Map"
)
}
if (!isTRUE(MCC)) {
out <- c(out, "Most Cited Countries")
}
if (!(isTRUE(DB_TC) & isTRUE(CR) & isTRUE(TC))) {
out <- c(out, "Most Local Cited Documents")
}
if (!isTRUE(DB_CR)) {
out <- c(out, "Most Local Cited References", "References Spectroscopy")
}
if (!isTRUE(CR)) {
out <- c(out, "Co-citation Network")
}
if (!(isTRUE(DB_TC) & isTRUE(CR))) {
out <- c(out, "Historiograph")
}
values$out <- out
return(L)
}
# find home folder
homeFolder <- function() {
switch(Sys.info()[["sysname"]],
Windows = {
home <- Sys.getenv("R_USER")
},
Linux = {
home <- Sys.getenv("HOME")
},
Darwin = {
home <- Sys.getenv("HOME")
}
)
return(home)
}
massimoaria/bibliometrix documentation built on June 15, 2025, 2:06 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
### COMMON FUNCTIONS ####
# LOAD FUNCTIONS -----
formatDB <- function(obj) {
ext <- sub(".*\\.", "", obj[1])
switch(ext,
txt = {
format <- "plaintext"
},
csv = {
format <- "csv"
},
bib = {
format <- "bibtex"
},
ciw = {
format <- "endnote"
},
xlsx = {
format <- "excel"
}
)
return(format)
}
## smart_load function ----
smart_load <- function(file) {
var <- load(file)
n <- length(var)
if (!"M" %in% var) {
if (n == 1) {
eval(parse(text = paste0("M <- ", var)))
} else {
stop("I could not find bibliometrixDB object in your data file: ", file)
}
}
rm(list = var[var != "M"])
if (("M" %in% ls()) & inherits(M, "bibliometrixDB")) {
return(M)
} else {
stop("Please make sure your RData/Rda file contains a bibliometrixDB object (M).")
}
}
## merge collections ----
merge_files <- function(files) {
## load xlsx or rdata bibliometrix files
if ("datapath" %in% names(files)) {
file <- files$datapath
ext <- unlist(lapply(file, getFileNameExtension))
}
Mfile <- list()
n <- 0
for (i in 1:length(file)) {
extF <- ext[i]
filename <- file[i]
switch(tolower(extF),
xlsx = {
Mfile[[i]] <- readxl::read_excel(filename, col_types = "text") %>% as.data.frame()
Mfile[[i]]$PY <- as.numeric(Mfile[[i]]$PY)
Mfile[[i]]$TC <- as.numeric(Mfile[[i]]$TC)
},
rdata = {
Mfile[[i]] <- smart_load(filename)
}
)
n <- n + nrow(Mfile[[i]])
}
# merge bibliometrix files
M <- mergeDbSources(Mfile, remove.duplicated = T)
# save original size as attribute
attr(M, "nMerge") <- n
return(M)
}
# DATA TABLE FORMAT ----
DTformat <- function(df, nrow = 10, filename = "Table", pagelength = TRUE, left = NULL, right = NULL, numeric = NULL, dom = TRUE, size = "85%", filter = "top",
columnShort = NULL, columnSmall = NULL, round = 2, title = "", button = FALSE, escape = FALSE, selection = FALSE, scrollX = FALSE, scrollY = FALSE) {
if ("text" %in% names(df)) {
df <- df %>%
mutate(text = gsub("<|>", "", text))
}
if (length(columnShort) > 0) {
columnDefs <- list(
list(
className = "dt-center", targets = 0:(length(names(df)) - 1)
),
list(
targets = columnShort - 1,
render = JS(
"function(data, type, row, meta) {",
"return type === 'display' && data.length > 500 ?",
"'<span title=\"' + data + '\">' + data.substr(0, 500) + '...</span>' : data;",
"}"
)
)
)
} else {
columnDefs <- list(list(
className = "dt-center", targets = 0:(length(names(df)) - 1)
))
}
if (isTRUE(button)) {
if (isTRUE(pagelength)) {
buttons <- list(
list(extend = "pageLength"),
list(
extend = "excel",
filename = paste0(filename, "_bibliometrix_", Sys.Date()),
title = " ",
header = TRUE,
exportOptions = list(
modifier = list(page = "all")
)
)
)
} else {
buttons <- list(
list(
extend = "excel",
filename = paste0(filename, "_bibliometrix_", Sys.Date()),
title = " ",
header = TRUE,
exportOptions = list(
modifier = list(page = "all")
)
)
)
}
} else {
buttons <- list(list(extend = "pageLength"))
}
if (isTRUE(dom)) {
dom <- "Brtip"
} else if (dom == FALSE) {
dom <- "Bftp"
} else {
dom <- "t"
}
if (nchar(title) > 0) {
caption <- htmltools::tags$caption(style = "caption-side: top; text-align: center; color:black; font-size:140% ;", title)
} else {
caption <- htmltools::tags$caption(style = "caption-side: top; text-align: center; color:black; font-size:140% ;", "")
}
if (isTRUE(selection)) {
extensions <- c("Buttons", "Select", "ColReorder", "FixedHeader")
buttons <- c(buttons, c("selectAll", "selectNone"))
select <- list(style = "multiple", items = "row", selected = 1:nrow(df))
# selection = list(mode = 'multiple', selected = 1:nrow(df), target = 'row')
} else {
extensions <- c("Buttons", "ColReorder", "FixedHeader")
select <- NULL
# selection = "none"
}
tab <- DT::datatable(df,
escape = escape, rownames = FALSE,
caption = caption,
selection = "none",
extensions = extensions,
filter = filter,
options = list(
headerCallback = DT::JS(
"function(thead) {",
" $(thead).css('font-size', '1em');",
"}"
),
colReorder = TRUE,
fixedHeader = TRUE,
pageLength = nrow,
autoWidth = TRUE, scrollX = scrollX, scrollY = scrollY,
dom = dom,
buttons = buttons,
select = select,
lengthMenu = list(
c(10, 25, 50, -1),
c("10 rows", "25 rows", "50 rows", "Show all")
),
columnDefs = columnDefs
),
class = "cell-border compact stripe"
) %>%
DT::formatStyle(
names(df),
backgroundColor = "white",
textAlign = "center",
fontSize = size
)
## left aligning
if (!is.null(left)) {
tab <- tab %>%
DT::formatStyle(
names(df)[left],
backgroundColor = "white",
textAlign = "left",
fontSize = size
)
}
# right aligning
if (!is.null(right)) {
tab <- tab %>%
DT::formatStyle(
names(df)[right],
backgroundColor = "white",
textAlign = "right",
fontSize = size
)
}
# numeric round
if (!is.null(numeric)) {
tab <- tab %>%
formatRound(names(df)[c(numeric)], digits = round)
}
tab
}
authorNameFormat <- function(M, format) {
if (format == "AF" & "AF" %in% names(M)) {
M <- M %>%
rename(
AU_IN = AU,
AU = AF
)
}
return(M)
}
split_text_numbers <- function(input_str, UT) {
# Split the string into components based on "; "
components <- unlist(strsplit(input_str, "; ", fixed = TRUE))
# Initialize two vectors to store the separated parts
texts <- character(length(components))
numbers <- numeric(length(components))
# Iterate through each component to separate text and numbers
for (i in seq_along(components)) {
# Extract the text using regex, matching everything up to " ("
texts[i] <- gsub("\\s\\(.*$", "", components[i])
# Extract the numbers using regex, matching digits inside parentheses
numbers[i] <- as.numeric(gsub(".*\\((\\d+)\\).*", "\\1", components[i]))
}
# Return a list with texts and numbers separated
data.frame(Texts = texts, Numbers = numbers, UT = UT)
}
AuthorNameMerge <- function(M) {
df_list <- list()
for (i in 1:nrow(M)) {
if (nchar(M$AU[i]) > 0) {
df_list[[i]] <- split_text_numbers(M$AU[i], M$UT[i])
}
}
df <- do.call(rbind, df_list)
AU <- df %>%
group_by(Numbers, Texts) %>%
count() %>%
group_by(Numbers) %>%
arrange(desc(n)) %>%
mutate(AU = Texts[1]) %>%
select(-"n", -"Texts") %>%
ungroup() %>%
distinct()
df <- df %>%
left_join(AU, by = "Numbers") %>%
group_by(UT) %>%
summarize(
AU = paste0(AU, collapse = ";"),
AU_ID = paste0(Numbers, collapse = ";")
)
M <- M %>%
rename(AU_original = AU) %>%
left_join(df, by = "UT")
return(M)
}
getFileNameExtension <- function(fn) {
# remove a path
splitted <- strsplit(x = fn, split = "/")[[1]]
# or use .Platform$file.sep in stead of '/'
fn <- splitted[length(splitted)]
ext <- ""
splitted <- strsplit(x = fn, split = "\\.")[[1]]
l <- length(splitted)
if (l > 1 && sum(splitted[1:(l - 1)] != "")) ext <- splitted[l]
# the extention must be the suffix of a non-empty name
ext
}
# Initial to upper case
firstup <- function(x) {
x <- tolower(x)
substr(x, 1, 1) <- toupper(substr(x, 1, 1))
x
}
# string preview (stopwords)
strPreview <- function(string, sep = ",") {
str1 <- unlist(strsplit(string, sep))
str1 <- str1[1:min(c(length(str1), 5))]
str1 <- paste(str1, collapse = sep)
HTML(paste("<pre>", "File Preview: ", str1, "</pre>", sep = "<br/>"))
}
# string preview (synonyms)
strSynPreview <- function(string) {
string <- string[1]
str1 <- unlist(strsplit(string, ";"))
str1 <- str1[1:min(c(length(str1), 5))]
str1 <- paste(paste(str1[1], " <- ", collapse = ""), paste(str1[-1], collapse = ";"), collapse = "")
HTML(paste("<pre>", "File Preview: ", str1, "</pre>", sep = "<br/>"))
}
# from igraph to png file
igraph2PNG <- function(x, filename, width = 10, height = 7, dpi = 75) {
V(x)$centr <- centr_betw(x)$res
df <- data.frame(name = V(x)$label, cluster = V(x)$color, centr = V(x)$centr) %>%
group_by(cluster) %>%
slice_head(n = 3)
V(x)$label[!(V(x)$label %in% df$name)] <- ""
png(filename = filename, width = width, height = height, unit = "in", res = dpi)
grid::grid.draw(plot(x))
dev.off()
}
# from ggplot to plotly
plot.ly <- function(g, flip = FALSE, side = "r", aspectratio = 1, size = 0.15, data.type = 2, height = 0, customdata = NA) {
g <- g + labs(title = NULL)
gg <- ggplotly(g, tooltip = "text") %>%
config(
displaylogo = FALSE,
modeBarButtonsToRemove = c(
"toImage",
"sendDataToCloud",
"pan2d",
"select2d",
"lasso2d",
"toggleSpikelines",
"hoverClosestCartesian",
"hoverCompareCartesian"
)
)
return(gg)
}
freqPlot <- function(xx, x, y, textLaby, textLabx, title, values, string.max = 70) {
xl <- c(max(xx[, x]) - 0.02 - diff(range(xx[, x])) * 0.125, max(xx[, x]) - 0.02) + 1
yl <- c(1, 1 + length(unique(xx[, y])) * 0.125)
Text <- paste(textLaby, ": ", xx[, y], "\n", textLabx, ": ", xx[, x])
if (title == "Most Local Cited References" & values$M$DB[1] == "SCOPUS") {
xx[, y] <- gsub("^(.+?)\\.,.*\\((\\d{4})\\)$", paste0("\\1", "., ", "\\2"), xx[, y])
}
xx[, y] <- substr(xx[, y], 1, string.max)
g <- ggplot(xx, aes(x = xx[, x], y = xx[, y], label = xx[, x], text = Text)) +
geom_segment(aes(x = 0, y = xx[, y], xend = xx[, x], yend = xx[, y]), color = "grey50") +
geom_point(aes(color = -xx[, x], size = xx[, x]), show.legend = FALSE) +
scale_radius(range = c(5, 12)) +
geom_text(color = "white", size = 3) +
scale_y_discrete(limits = rev(xx[, y])) +
scale_fill_continuous(type = "gradient") +
labs(title = title, y = textLaby) +
labs(x = textLabx) +
expand_limits(y = c(1, length(xx[, y]) + 1)) +
theme_minimal() +
theme(axis.text.y = element_text(angle = 0, hjust = 0)) +
annotation_custom(values$logoGrid, xmin = xl[1], xmax = xl[2], ymin = yl[1], ymax = yl[2])
return(g)
}
emptyPlot <- function(errortext) {
g <- ggplot() +
theme_void() +
theme(legend.position = "none") +
annotate("text", x = 4, y = 25, label = errortext, size = 10)
plot(g)
}
count.duplicates <- function(DF) {
x <- do.call("paste", c(DF, sep = "\r"))
ox <- order(x)
rl <- rle(x[ox])
cbind(DF[ox[cumsum(rl$lengths)], , drop = FALSE], count = rl$lengths)
}
reduceRefs <- function(A) {
ind <- unlist(regexec("*V[0-9]", A))
A[ind > -1] <- substr(A[ind > -1], 1, (ind[ind > -1] - 1))
ind <- unlist(regexec("*DOI ", A))
A[ind > -1] <- substr(A[ind > -1], 1, (ind[ind > -1] - 1))
return(A)
}
notifications <- function() {
## check connection and download notifications
online <- is_online()
location <- "https://www.bibliometrix.org/bs_notifications/biblioshiny_notifications.csv"
notifOnline <- NULL
if (isTRUE(is_online())) {
## add check to avoid blocked app when internet connection is to slow
envir <- environment()
# setTimeLimit(cpu = 1, elapsed = 1, transient = TRUE)
# on.exit({
# setTimeLimit(cpu = Inf, elapsed = Inf, transient = FALSE)
# })
tryCatch(
{
eval(expr = suppressWarnings(notifOnline <- read.csv(location, header = TRUE, sep = ",")), envir = envir)
},
error = function(ex) {
notifOnLine <- NULL
}
)
if (is.null(notifOnline)) {
online <- FALSE
} else {
notifOnline$href[nchar(notifOnline$href) < 6] <- NA
}
}
## check if a file exists on the local machine and load it
home <- homeFolder()
file <- paste(home, "/biblioshiny_notifications.csv", sep = "")
fileTrue <- file.exists(file)
if (isTRUE(fileTrue)) {
suppressWarnings(notifLocal <- read.csv(file, header = TRUE, sep = ","))
# notifLocal <- readLines(file)
# linksLocal[nchar(linksLocal)<6] <- NA
}
A <- c("noA", "A")
B <- c("noB", "B")
status <- paste(A[online + 1], B[fileTrue + 1], sep = "")
switch(status,
# missing both files (online and local)
noAnoB = {
notifTot <- data.frame(nots = "No notifications", href = NA, status = "info") %>% mutate(status = "info")
},
# missing online file. The local one exists.
noAB = {
notifTot <- notifLocal %>%
filter(action == TRUE) %>%
mutate(status = "info")
},
# missing the local file. The online one exists.
AnoB = {
# notifOnline <- notifOnline %>%
# dplyr::slice_head(n = 5)
notifTot <- notifOnline %>%
filter(action == TRUE) %>%
mutate(status = "danger") %>%
dplyr::slice_head(n = 5)
notifOnline %>%
filter(action == TRUE) %>%
write.csv(file = file, quote = FALSE, row.names = FALSE)
},
# both files exist.
AB = {
notifTot <- left_join(notifOnline %>% mutate(status = "danger"),
notifLocal %>% mutate(status = "info"),
by = "nots"
) %>%
mutate(status = tidyr::replace_na(status.y, "danger")) %>%
rename(
href = href.x,
action = action.x
) %>%
select(nots, href, action, status) %>%
arrange(status) %>%
filter(action == TRUE) %>%
dplyr::slice_head(n = 5)
notifTot %>%
select(-status) %>%
write.csv(file = file, quote = FALSE, row.names = FALSE)
}
)
# notifTot <- notifTot[1:(min(5,nrow(notifTot))),]
return(notifTot)
}
is_online <- function(timeout = 3) {
RCurl::url.exists("www.bibliometrix.org", timeout = timeout)
}
# is_online <- function(){
# ## add check to avoid blocked app when internet connection is to slow
# envir <- environment()
# setTimeLimit(cpu = 1, elapsed = 1, transient = TRUE)
# on.exit({
# setTimeLimit(cpu = Inf, elapsed = Inf, transient = FALSE)
# })
# tryCatch({
# eval(expr=suppressWarnings(resp <- curl::has_internet()), envir = envir)
# }, error = function(ex) {resp <- FALSE}
# )
# return(resp)
# }
initial <- function(values) {
values$results <- list("NA")
values$log <- "working..."
values$load <- "FALSE"
values$field <- values$cocngrams <- "NA"
values$citField <- values$colField <- values$citSep <- "NA"
values$NetWords <- values$NetRefs <- values$ColNetRefs <- matrix(NA, 1, 1)
values$Title <- "Network"
values$Histfield <- "NA"
values$histlog <- "working..."
values$kk <- 0
values$histsearch <- "NA"
values$citShortlabel <- "NA"
values$S <- list("NA")
values$GR <- "NA"
values$nMerge <- NULL
values$collection_description <- NULL
### column to export in TALL
values$corpusCol <- c("Title" = "TI", "Abstract" = "AB", "Author's Keywords" = "DE")
values$metadataCol <- c("Publication Year" = "PY", "Document Type" = "DT", "DOI" = "DI", "Open Access" = "OA", "Language" = "LA", "First Author" = "AU1")
# Chrome enviroment variable
if (inherits(try(pagedown::find_chrome(), silent=T), "try-error")) {
values$Chrome_url <- NULL
}else{
values$Chrome_url <- pagedown::find_chrome()
}
return(values)
}
### TALL Export functions ----
tallExport <- function(M, tallFields, tallMetadata, metadataCol) {
corpus <- NULL
## Corpus Fields ##
if ("Abstract" %in% tallFields) {
if (!"AB_raw" %in% names(M)) {
M <- M %>%
mutate(AB_raw = sapply(AB, capitalize_after_dot, USE.NAMES = FALSE))
}
corpus <- c(corpus, "AB_raw")
}
if ("Title" %in% tallFields) {
if (!"TI_raw" %in% names(M)) {
M <- M %>%
mutate(TI_raw = sapply(TI, capitalize_after_dot, USE.NAMES = FALSE))
}
corpus <- c(corpus, "TI_raw")
}
if ("Author's Keywords" %in% tallFields) {
if (!"DE_raw" %in% names(M)) {
M <- M %>%
mutate(DE_raw = sapply(DE, capitalize_after_dot, USE.NAMES = FALSE))
}
corpus <- c(corpus, "DE_raw")
}
corpus <- c(corpus, as.character(metadataCol[tallMetadata]))
M <- M %>%
select(SR, any_of(corpus)) %>%
rename(doc_id = SR)
names(M) <- gsub("_raw", "", names(M))
return(M)
}
capitalize_after_dot <- function(text) {
# Tutto minuscolo
text <- tolower(text)
# Prima lettera della stringa maiuscola
text <- paste0(toupper(substr(text, 1, 1)), substr(text, 2, nchar(text)))
# Maiuscola dopo punto (o ! o ?) + spazio
text <- gsub("([\\.\\!\\?]\\s*)([a-z])", "\\1\\U\\2", text, perl = TRUE)
return(text)
}
### ANALYSIS FUNCTIONS ####
### Descriptive functions ----
ValueBoxes <- function(M) {
# calculate statistics for Biblioshiny ValueBoxes
df <- data.frame(Description = rep(NA, 12), Results = rep(NA, 12))
## VB 1 - Time span
df[1, ] <- c("Timespan", paste(range(M$PY, na.rm = T), collapse = ":"))
## VB 2 - Authors
listAU <- (strsplit(M$AU, ";"))
nAU <- lengths(listAU)
listAU <- unique(trimws((unlist(listAU))))
listAU <- listAU[!is.na(listAU)]
df[2, ] <- c("Authors", length(listAU))
## VB 3 - Author's Keywords (DE)
if (!"DE" %in% names(M)) {
M$DE <- ""
}
DE <- unique(trimws(gsub("\\s+|\\.|\\,", " ", unlist(strsplit(M$DE, ";")))))
DE <- DE[!is.na(DE)]
df[3, ] <- c("Author's Keywords (DE)", length(DE))
## VB 4 - Sources
df[4, ] <- c("Sources (Journals, Books, etc)", length(unique(M$SO)))
## VB 5 - Authors of single-authored docs
df[5, ] <- c("Authors of single-authored docs", length(unique(M$AU[nAU == 1])))
## VB 6 - References
CR <- trimws(gsub("\\s+|\\.|\\,", " ", unlist(strsplit(M$CR, ";"))))
CR <- CR[nchar(CR) > 0 & !is.na(CR)]
nCR <- length(unique(CR))
if (nCR == 1) {
nCR <- 0
}
df[6, ] <- c("References", nCR)
## VB 7 - Documents
df[7, ] <- c("Documents", nrow(M))
## VB 8 - International Co-Authorship
if (!"AU_CO" %in% names(M)) {
M <- metaTagExtraction(M, "AU_CO")
}
AU_CO <- strsplit(M$AU_CO, ";")
Coll <- unlist(lapply(AU_CO, function(l) {
length(unique(l)) > 1
}))
Coll <- sum(Coll) / nrow(M) * 100
df[8, ] <- c("International co-authorships %", format(Coll, digits = 4))
## VB 9 - Document Average Age
age <- as.numeric(substr(Sys.Date(), 1, 4)) - M$PY
df[9, ] <- c("Document Average Age", format(mean(age, na.rm = TRUE), digits = 3))
## VB 10 - Annual Growth Rate
Y <- table(M$PY)
ny <- diff(range(M$PY, na.rm = TRUE))
CAGR <- as.numeric(round(((Y[length(Y)] / Y[1])^(1 / (ny)) - 1) * 100, 2))
df[10, ] <- c("Annual Growth Rate %", CAGR)
## VB 11 - Co-Authors per Doc
df[11, ] <- c("Co-Authors per Doc", format(mean(nAU, na.rm = T), digit = 3))
## VB 12 - Average citations per doc
df[12, ] <- c("Average citations per doc", format(mean(M$TC, na.rm = T), digit = 4))
DT <- M %>%
mutate(DT = tolower(DT)) %>%
count(DT) %>%
rename(
Description = DT,
Results = n
)
# Indexed Keywords (ID)
ID <- unique(trimws(gsub("\\s+|\\.|\\,", " ", unlist(strsplit(M$ID, ";")))))
ID <- ID[!is.na(ID)]
df[nrow(df) + 1, ] <- c("Keywords Plus (ID)", length(ID))
# Single authored docs
df[nrow(df) + 1, ] <- c("Single-authored docs", sum(nAU == 1))
df2 <- data.frame(Description = c(
"MAIN INFORMATION ABOUT DATA", "Timespan", "Sources (Journals, Books, etc)", "Documents",
"Annual Growth Rate %", "Document Average Age", "Average citations per doc", "References",
"DOCUMENT CONTENTS", "Keywords Plus (ID)", "Author's Keywords (DE)", "AUTHORS", "Authors", "Authors of single-authored docs",
"AUTHORS COLLABORATION", "Single-authored docs", "Co-Authors per Doc", "International co-authorships %", "DOCUMENT TYPES"
))
df <- left_join(df2, df, by = "Description") %>%
rbind(DT) %>%
mutate(Results = replace_na(Results, ""))
return(df)
}
countryCollab <- function(M) {
sep <- ";"
if (!("AU_CO" %in% names(M))) {
M <- metaTagExtraction(M, Field = "AU_CO", sep)
}
if (!("AU1_CO" %in% names(M))) {
M <- metaTagExtraction(M, Field = "AU1_CO", sep)
}
M$nCO <- as.numeric(unlist(lapply(strsplit(M$AU_CO, ";"), function(l) {
length(unique(l)) > 1
})))
M$AU1_CO <- trim(gsub("[[:digit:]]", "", M$AU1_CO))
M$AU1_CO <- gsub("UNITED STATES", "USA", M$AU1_CO)
M$AU1_CO <- gsub("RUSSIAN FEDERATION", "RUSSIA", M$AU1_CO)
M$AU1_CO <- gsub("TAIWAN", "CHINA", M$AU1_CO)
M$AU1_CO <- gsub("ENGLAND", "UNITED KINGDOM", M$AU1_CO)
M$AU1_CO <- gsub("SCOTLAND", "UNITED KINGDOM", M$AU1_CO)
M$AU1_CO <- gsub("WALES", "UNITED KINGDOM", M$AU1_CO)
M$AU1_CO <- gsub("NORTH IRELAND", "UNITED KINGDOM", M$AU1_CO)
df <- M %>%
group_by(AU1_CO) %>%
select(AU1_CO, nCO) %>%
summarize(
Articles = n(),
SCP = sum(nCO == 0),
MCP = sum(nCO == 1)
) %>%
rename(Country = AU1_CO) %>%
arrange(desc(Articles))
return(df)
}
Hindex_plot <- function(values, type, input) {
hindex <- function(values, type, input) {
switch(type,
author = {
# AU <- trim(gsub(",","",names(tableTag(values$M,"AU"))))
values$H <- Hindex(values$M, field = "author", elements = NULL, sep = ";", years = Inf)$H %>%
arrange(desc(h_index))
},
source = {
# SO <- names(sort(table(values$M$SO),decreasing = TRUE))
values$H <- Hindex(values$M, field = "source", elements = NULL, sep = ";", years = Inf)$H %>%
arrange(desc(h_index))
}
)
return(values)
}
values <- hindex(values, type = type, input)
xx <- values$H
if (type == "author") {
K <- input$Hkauthor
measure <- input$HmeasureAuthors
title <- "Authors' Local Impact"
xn <- "Authors"
} else {
K <- input$Hksource
measure <- input$HmeasureSources
title <- "Sources' Local Impact"
xn <- "Sources"
}
if (K > dim(xx)[1]) {
k <- dim(xx)[1]
} else {
k <- K
}
switch(measure,
h = {
m <- 2
},
g = {
m <- 3
},
m = {
m <- 4
xx[, m] <- round(xx[, m], 2)
},
tc = {
m <- 5
}
)
xx <- xx[order(-xx[, m]), ]
xx <- xx[1:k, c(1, m)]
g <- freqPlot(xx, x = 2, y = 1, textLaby = xn, textLabx = paste("Impact Measure:", toupper(measure)), title = paste(title, "by", toupper(measure), "index"), values)
res <- list(values = values, g = g)
return(res)
}
descriptive <- function(values, type) {
switch(type,
"tab2" = {
TAB <- values$M %>%
group_by(PY) %>%
count() %>%
rename(
Year = PY,
Articles = n
) %>%
right_join(data.frame(Year = seq(min(values$M$PY, na.rm = TRUE), max(values$M$PY, na.rm = TRUE))), by = "Year") %>%
mutate(Articles = replace_na(Articles, 0)) %>%
arrange(Year) %>%
as.data.frame()
ny <- diff(range(TAB$Year))
values$GR <- round(((TAB[nrow(TAB), 2] / TAB[1, 2])^(1 / (ny)) - 1) * 100, digits = 2)
},
"tab3" = {
listAU <- (strsplit(values$M$AU, ";"))
nAU <- lengths(listAU)
fracAU <- rep(1 / nAU, nAU)
TAB <- tibble(Author = unlist(listAU), fracAU = fracAU) %>%
group_by(Author) %>%
summarize(
Articles = n(),
AuthorFrac = sum(fracAU)
) %>%
arrange(desc(Articles)) %>%
as.data.frame()
names(TAB) <- c("Authors", "Articles", "Articles Fractionalized")
# print(S$MostProdAuthors)
},
"tab4" = {
y <- as.numeric(substr(Sys.Date(), 1, 4))
TAB <- values$M %>%
mutate(TCperYear = TC / (y + 1 - PY)) %>%
select(SR, DI, TC, TCperYear, PY) %>%
group_by(PY) %>%
mutate(NTC = TC / mean(TC)) %>%
ungroup() %>%
select(-PY) %>%
arrange(desc(TC)) %>%
as.data.frame()
names(TAB) <- c("Paper", "DOI", "Total Citations", "TC per Year", "Normalized TC")
},
"tab5" = {
TAB <- countryCollab(values$M)
TAB <- TAB %>%
mutate(Freq = Articles / sum(Articles)) %>%
mutate(MCP_Ratio = MCP / Articles) %>%
drop_na(Country)
},
"tab6" = {
if (!"AU1_CO" %in% names(values$M)) {
values$M <- metaTagExtraction(values$M, "AU1_CO")
}
TAB <- values$M %>%
select(AU1_CO, TC) %>%
drop_na(AU1_CO) %>%
rename(
Country = AU1_CO,
TotalCitation = TC
) %>%
group_by(Country) %>%
summarise("TC" = sum(TotalCitation), "Average Article Citations" = round(sum(TotalCitation) / length(TotalCitation), 1)) %>%
arrange(-TC) %>%
as.data.frame(.data)
},
"tab7" = {
TAB <- values$M %>%
select(SO) %>%
group_by(SO) %>%
count() %>%
arrange(desc(n)) %>%
rename(
Sources = SO,
Articles = n
) %>%
as.data.frame()
},
"tab10" = {
TAB <- mapworld(values$M)$tab
},
"tab11" = {
if (!("AU_UN" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "AU_UN")
}
TAB <- data.frame(Affiliation = unlist(strsplit(values$M$AU_UN, ";"))) %>%
group_by(Affiliation) %>%
count() %>%
drop_na(Affiliation) %>%
arrange(desc(n)) %>%
rename(Articles = n) %>%
filter(Affiliation != "NA") %>%
as.data.frame()
},
"tab12" = {
TAB <- tableTag(values$M, "C1")
TAB <- data.frame(Affiliations = names(TAB), Articles = as.numeric(TAB))
TAB <- TAB[nchar(TAB[, 1]) > 4, ]
# names(TAB)=c("Affiliations", "Articles")
},
"tab13" = {
CR <- localCitations(values$M, fast.search = FALSE, verbose = FALSE)
TAB <- CR$Authors
# TAB=data.frame(Authors=names(CR$Authors$Author), Citations=as.numeric(CR$Cited))
}
)
values$TAB <- TAB
res <- list(values = values, TAB = TAB)
return(res)
}
AffiliationOverTime <- function(values, n) {
if (!("AU_UN" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "AU_UN")
}
AFF <- strsplit(values$M$AU_UN, ";")
nAFF <- lengths(AFF)
AFFY <- data.frame(Affiliation = unlist(AFF), Year = rep(values$M$PY, nAFF)) %>%
filter(Affiliation != "NA") %>%
drop_na(Affiliation, Year) %>%
group_by(Affiliation, Year) %>%
count() %>%
group_by(Affiliation) %>%
arrange(Year) %>%
ungroup() %>%
pivot_wider(Affiliation, names_from = Year, values_from = n) %>%
mutate_all(~ replace(., is.na(.), 0)) %>%
pivot_longer(cols = !Affiliation, names_to = "Year", values_to = "Articles") %>%
group_by(Affiliation) %>%
mutate(Articles = cumsum(Articles))
Affselected <- AFFY %>%
filter(Year == max(Year)) %>%
ungroup() %>%
slice_max(Articles, n = n)
values$AffOverTime <- AFFY %>%
filter(Affiliation %in% Affselected$Affiliation) %>%
mutate(Year = Year %>% as.numeric())
Text <- paste(values$AffOverTime$Affiliation, " (", values$AffOverTime$Year, ") ", values$AffOverTime$Articles, sep = "")
width_scale <- 1.7 * 26 / length(unique(values$AffOverTime$Affiliation))
x <- c(max(values$AffOverTime$Year) - 0.02 - diff(range(values$AffOverTime$Year)) * 0.15, max(values$AffOverTime$Year) - 0.02) + 1
y <- c(min(values$AffOverTime$Articles), min(values$AffOverTime$Articles) + diff(range(values$AffOverTime$Articles)) * 0.15)
values$AffOverTimePlot <- ggplot(values$AffOverTime, aes(x = Year, y = Articles, group = Affiliation, color = Affiliation, text = Text)) +
geom_line() +
labs(
x = "Year",
y = "Articles",
title = "Affiliations' Production over Time"
) +
scale_x_continuous(breaks = (values$AffOverTime$Year[seq(1, length(values$AffOverTime$Year), by = ceiling(length(values$AffOverTime$Year) / 20))])) +
geom_hline(aes(yintercept = 0), alpha = 0.1) +
labs(color = "Affiliation") +
theme(
text = element_text(color = "#444444"),
legend.text = ggplot2::element_text(size = width_scale),
legend.box.margin = margin(6, 6, 6, 6),
legend.title = ggplot2::element_text(size = 1.5 * width_scale, face = "bold"),
legend.position = "bottom",
legend.direction = "vertical",
legend.key.size = grid::unit(width_scale / 50, "inch"),
legend.key.width = grid::unit(width_scale / 50, "inch"),
plot.caption = element_text(size = 9, hjust = 0.5, color = "black", face = "bold"),
panel.background = element_rect(fill = "#FFFFFF"),
panel.grid.minor = element_line(color = "#EFEFEF"),
panel.grid.major = element_line(color = "#EFEFEF"),
plot.title = element_text(size = 24),
axis.title = element_text(size = 14, color = "#555555"),
axis.title.y = element_text(vjust = 1, angle = 90),
axis.title.x = element_text(hjust = 0.95, angle = 0),
axis.text.x = element_text(size = 10, angle = 90),
axis.line.x = element_line(color = "black", linewidth = 0.5),
axis.line.y = element_line(color = "black", linewidth = 0.5)
) +
annotation_custom(values$logoGrid, xmin = x[1], xmax = x[2], ymin = y[1], ymax = y[2])
return(values)
}
CountryOverTime <- function(values, n) {
if (!("AU_CO" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "AU_CO")
}
AFF <- strsplit(values$M$AU_CO, ";")
nAFF <- lengths(AFF)
AFFY <- data.frame(Affiliation = unlist(AFF), Year = rep(values$M$PY, nAFF)) %>%
drop_na(Affiliation, Year) %>%
group_by(Affiliation, Year) %>%
count() %>%
group_by(Affiliation) %>%
arrange(Year) %>%
ungroup() %>%
pivot_wider(Affiliation, names_from = Year, values_from = n) %>%
mutate_all(~ replace(., is.na(.), 0)) %>%
pivot_longer(cols = !Affiliation, names_to = "Year", values_to = "Articles") %>%
group_by(Affiliation) %>%
mutate(Articles = cumsum(Articles))
Affselected <- AFFY %>%
filter(Year == max(Year)) %>%
ungroup() %>%
slice_max(Articles, n = n)
values$CountryOverTime <- AFFY %>%
filter(Affiliation %in% Affselected$Affiliation) %>%
mutate(Year = Year %>% as.numeric()) %>%
rename(Country = Affiliation)
Text <- paste(values$CountryOverTime$Country, " (", values$CountryOverTime$Year, ") ", values$CountryOverTime$Articles, sep = "")
width_scale <- 1.7 * 26 / length(unique(values$CountryOverTime$Country))
x <- c(max(values$CountryOverTime$Year) - 0.02 - diff(range(values$CountryOverTime$Year)) * 0.15, max(values$CountryOverTime$Year) - 0.02) + 1
y <- c(min(values$CountryOverTime$Articles), min(values$CountryOverTime$Articles) + diff(range(values$CountryOverTime$Articles)) * 0.15)
values$CountryOverTimePlot <- ggplot(values$CountryOverTime, aes(x = Year, y = Articles, group = Country, color = Country, text = Text)) +
geom_line() +
labs(
x = "Year",
y = "Articles",
title = "Country Production over Time"
) +
scale_x_continuous(breaks = (values$CountryOverTime$Year[seq(1, length(values$CountryOverTime$Year), by = ceiling(length(values$CountryOverTime$Year) / 20))])) +
geom_hline(aes(yintercept = 0), alpha = 0.1) +
labs(color = "Country") +
theme(
text = element_text(color = "#444444"),
legend.text = ggplot2::element_text(size = width_scale),
legend.box.margin = margin(6, 6, 6, 6),
legend.title = ggplot2::element_text(size = 1.5 * width_scale, face = "bold"),
legend.position = "bottom",
legend.direction = "vertical",
legend.key.size = grid::unit(width_scale / 50, "inch"),
legend.key.width = grid::unit(width_scale / 50, "inch"),
plot.caption = element_text(size = 9, hjust = 0.5, color = "black", face = "bold"),
panel.background = element_rect(fill = "#FFFFFF"),
panel.grid.minor = element_line(color = "#EFEFEF"),
panel.grid.major = element_line(color = "#EFEFEF"),
plot.title = element_text(size = 24),
axis.title = element_text(size = 14, color = "#555555"),
axis.title.y = element_text(vjust = 1, angle = 90),
axis.title.x = element_text(hjust = 0.95, angle = 0),
axis.text.x = element_text(size = 10, angle = 90),
axis.line.x = element_line(color = "black", linewidth = 0.5),
axis.line.y = element_line(color = "black", linewidth = 0.5)
) +
annotation_custom(values$logoGrid, xmin = x[1], xmax = x[2], ymin = y[1], ymax = y[2])
return(values)
}
wordlist <- function(M, Field, n, measure, ngrams, remove.terms = NULL, synonyms = NULL) {
switch(Field,
ID = {
v <- tableTag(M, "ID", remove.terms = remove.terms, synonyms = synonyms)
},
DE = {
v <- tableTag(M, "DE", remove.terms = remove.terms, synonyms = synonyms)
},
KW_Merged = {
v <- tableTag(M, "KW_Merged", remove.terms = remove.terms, synonyms = synonyms)
},
TI = {
if (!("TI_TM" %in% names(M))) {
v <- tableTag(M, "TI", ngrams = ngrams, remove.terms = remove.terms, synonyms = synonyms)
}
},
AB = {
if (!("AB_TM" %in% names(M))) {
v <- tableTag(M, "AB", ngrams = ngrams, remove.terms = remove.terms, synonyms = synonyms)
}
},
WC = {
v <- tableTag(M, "WC")
}
)
names(v) <- tolower(names(v))
# v=tableTag(values$M,"ID")
n <- min(c(n, length(v)))
Words <- data.frame(Terms = names(v)[1:n], Frequency = (as.numeric(v)[1:n]), stringsAsFactors = FALSE)
W <- Words
switch(measure,
identity = {},
sqrt = {
W$Frequency <- sqrt(W$Frequency)
},
log = {
W$Frequency <- log(W$Frequency + 1)
},
log10 = {
W$Frequency <- log10(W$Frequency + 1)
}
)
results <- list(v = v, W = W, Words = Words)
return(results)
}
readStopwordsFile <- function(file, sep = ",") {
if (!is.null(file)) {
req(file$datapath)
remove.terms <- unlist(strsplit(readr::read_lines(file$datapath), sep))
} else {
remove.terms <- NULL
}
return(remove.terms)
}
readSynWordsFile <- function(file, sep = ",") {
if (!is.null(file)) {
req(file$datapath)
syn.terms <- readr::read_lines(file$datapath)
if (sep != ";") syn.terms <- gsub(sep, ";", syn.terms)
} else {
syn.terms <- NULL
}
return(syn.terms)
}
mapworld <- function(M, values) {
if (!("AU_CO" %in% names(M))) {
M <- metaTagExtraction(M, "AU_CO")
}
CO <- as.data.frame(tableTag(M, "AU_CO"))
CO$Tab <- gsub("[[:digit:]]", "", CO$Tab)
CO$Tab <- gsub(".", "", CO$Tab, fixed = TRUE)
CO$Tab <- gsub(";;", ";", CO$Tab, fixed = TRUE)
CO$Tab <- gsub("UNITED STATES", "USA", CO$Tab)
CO$Tab <- gsub("RUSSIAN FEDERATION", "RUSSIA", CO$Tab)
CO$Tab <- gsub("TAIWAN", "CHINA", CO$Tab)
CO$Tab <- gsub("ENGLAND", "UNITED KINGDOM", CO$Tab)
CO$Tab <- gsub("SCOTLAND", "UNITED KINGDOM", CO$Tab)
CO$Tab <- gsub("WALES", "UNITED KINGDOM", CO$Tab)
CO$Tab <- gsub("NORTH IRELAND", "UNITED KINGDOM", CO$Tab)
CO$Tab <- gsub("UNITED KINGDOM", "UK", CO$Tab)
CO$Tab <- gsub("KOREA", "SOUTH KOREA", CO$Tab)
map.world <- map_data("world")
map.world$region <- toupper(map.world$region)
# dplyr::anti_join(CO, map.world, by = c('Tab' = 'region'))
country.prod <- dplyr::left_join(map.world, CO, by = c("region" = "Tab"))
tab <- data.frame(country.prod %>%
dplyr::group_by(region) %>%
dplyr::summarise(Freq = mean(Freq)))
tab <- tab[!is.na(tab$Freq), ]
tab <- tab[order(-tab$Freq), ]
# breaks=as.numeric(round(quantile(CO$Freq,c(0.2,0.4,0.6,0.8,1))))
# names(breaks)=breaks
# breaks=log(breaks)
breaks <- as.numeric(cut(CO$Freq, breaks = 10))
names(breaks) <- breaks
g <- ggplot(country.prod, aes(x = long, y = lat, group = group, text = paste("Country: ", region, "\nN.of Documents: ", Freq))) +
geom_polygon(aes(fill = Freq, group = group)) +
scale_fill_continuous(low = "#87CEEB", high = "dodgerblue4", breaks = breaks, na.value = "grey80") +
guides(fill = guide_legend(reverse = T)) +
# geom_text(data=centroids, aes(label = centroids$Tab, x = centroids$long, y = centroids$lat, group=centroids$Tab)) +
labs(
fill = "N.Documents",
title = "Country Scientific Production",
x = NULL,
y = NULL
) +
theme(
text = element_text(color = "#333333"),
plot.title = element_text(size = 28),
plot.subtitle = element_text(size = 14),
axis.ticks = element_blank(),
axis.text = element_blank(),
panel.grid = element_blank(),
panel.background = element_rect(fill = "#FFFFFF") #' #333333'
, plot.background = element_rect(fill = "#FFFFFF"),
legend.position = "none"
# ,legend.background = element_blank()
# ,legend.key = element_blank()
) +
annotation_custom(values$logoGrid, xmin = 143, xmax = 189.5, ymin = -69, ymax = -48)
results <- list(g = g, tab = tab)
return(results)
}
### Structure fuctions ----
CAmap <- function(input, values) {
if ((input$CSfield %in% names(values$M))) {
if (input$CSfield %in% c("TI", "AB")) {
ngrams <- as.numeric(input$CSngrams)
} else {
ngrams <- 1
}
### load file with terms to remove
if (input$CSStopFile == "Y") {
remove.terms <- trimws(values$CSremove.terms$stopword)
} else {
remove.terms <- NULL
}
# values$CSremove.terms <- remove.terms
### end of block
### load file with synonyms
if (input$FASynFile == "Y") {
synonyms <- values$FAsyn.terms %>%
group_by(term) %>%
mutate(term = paste0(term, ";", synonyms)) %>%
select(term)
synonyms <- synonyms$term
} else {
synonyms <- NULL
}
# values$FAsyn.terms <- synonyms
### end of block
tab <- tableTag(values$M, input$CSfield, ngrams = ngrams)
if (length(tab >= 2)) {
minDegree <- as.numeric(tab[input$CSn])
values$CS <- conceptualStructure(values$M,
method = input$method, field = input$CSfield, minDegree = minDegree, clust = input$nClustersCS,
k.max = 8, stemming = F, labelsize = input$CSlabelsize / 2, documents = input$CSdoc, graph = FALSE, ngrams = ngrams,
remove.terms = remove.terms, synonyms = synonyms
)
if (input$method != "MDS") {
CSData <- values$CS$docCoord
CSData <- data.frame(Documents = row.names(CSData), CSData)
CSData$dim1 <- round(CSData$dim1, 2)
CSData$dim2 <- round(CSData$dim2, 2)
CSData$contrib <- round(CSData$contrib, 2)
values$CS$CSData <- CSData
} else {
values$CS$CSData <- data.frame(Docuemnts = NA, dim1 = NA, dim2 = NA)
}
switch(input$method,
CA = {
WData <- data.frame(
word = row.names(values$CS$km.res$data.clust), values$CS$km.res$data.clust,
stringsAsFactors = FALSE
)
names(WData)[4] <- "cluster"
},
MCA = {
WData <- data.frame(
word = row.names(values$CS$km.res$data.clust), values$CS$km.res$data.clust,
stringsAsFactors = FALSE
)
names(WData)[4] <- "cluster"
},
MDS = {
WData <- data.frame(
word = row.names(values$CS$res), values$CS$res,
cluster = values$CS$km.res$cluster
)
}
)
WData$Dim1 <- round(WData$Dim1, 2)
WData$Dim2 <- round(WData$Dim2, 2)
values$CS$WData <- WData
} else {
emptyPlot("Selected field is not included in your data collection")
values$CS <- list("NA")
}
} else {
emptyPlot("Selected field is not included in your data collection")
values$CS <- list("NA")
}
return(values)
}
historiograph <- function(input, values) {
min.cit <- 0
# if (values$Histfield=="NA"){
values$histResults <- histNetwork(values$M, min.citations = min.cit, sep = ";")
# values$Histfield="done"
# }
# titlelabel <- input$titlelabel
values$histlog <- (values$histPlot <- histPlot(values$histResults, n = input$histNodes, size = input$histsize, remove.isolates = (input$hist.isolates == "yes"), labelsize = input$histlabelsize, label = input$titlelabel, verbose = FALSE))
values$histResults$histData$DOI <- paste0('<a href=\"https://doi.org/', values$histResults$histData$DOI, '\" target=\"_blank\">', values$histResults$histData$DOI, "</a>")
values$histResults$histData <- values$histResults$histData %>%
left_join(
values$histPlot$layout %>%
select(name, color),
by = c("Paper" = "name")
) %>%
drop_na(color) %>%
mutate(cluster = match(color, unique(color))) %>%
select(!color) %>%
group_by(cluster) %>%
arrange(Year, .by_group = TRUE)
return(values)
}
### Network functions ----
degreePlot <- function(net) {
# deg <- data.frame(node = names(net$nodeDegree), x= (1:length(net$nodeDegree)), y = net$nodeDegree)
ma <- function(x, n = 5) {
stats::filter(x, rep(1 / n, n), sides = 1)
}
deg <- net$nodeDegree %>%
mutate(x = row_number())
p <- ggplot(data = deg, aes(
x = x, y = degree,
text = paste(node, " - Degree ", round(degree, 3), sep = "")
)) +
geom_point() +
geom_line(aes(group = "NA"), color = "#002F80", alpha = .5) +
# geom_hline(yintercept=cutting$degree, linetype="dashed",color = '#002F80', alpha = .5)+
theme(
text = element_text(color = "#444444"),
panel.background = element_rect(fill = "#FFFFFF"),
panel.grid.minor = element_line(color = "#EFEFEF"),
panel.grid.major = element_line(color = "#EFEFEF"),
plot.title = element_text(size = 24),
axis.title = element_text(size = 14, color = "#555555"),
axis.title.y = element_text(vjust = 1, angle = 0),
axis.title.x = element_text(hjust = 0),
axis.line.x = element_line(color = "black", linewidth = 0.5),
axis.line.y = element_line(color = "black", linewidth = 0.5)
) +
labs(x = "Node", y = "Cumulative Degree", title = "Node Degrees")
return(p)
}
cocNetwork <- function(input, values) {
n <- input$Nodes
label.n <- input$Labels
### load file with terms to remove
if (input$COCStopFile == "Y") {
remove.terms <- trimws(values$COCremove.terms$stopword)
} else {
remove.terms <- NULL
}
# values$COCremove.terms <- remove.terms
### end of block
### load file with synonyms
if (input$COCSynFile == "Y") {
synonyms <- values$COCsyn.terms %>%
group_by(term) %>%
mutate(term = paste0(term, ";", synonyms)) %>%
select(term)
synonyms <- synonyms$term
} else {
synonyms <- NULL
}
# values$COCsyn.terms <- synonyms
### end of block
if ((input$field %in% names(values$M))) {
if ((dim(values$NetWords)[1]) == 1 | !(input$field == values$field) | !(input$cocngrams == values$cocngrams) | ((dim(values$NetWords)[1]) != input$Nodes)) {
values$field <- input$field
values$ngrams <- input$cocngrams
switch(input$field,
ID = {
values$NetWords <- biblioNetwork(values$M, analysis = "co-occurrences", network = "keywords", n = n, sep = ";", remove.terms = remove.terms, synonyms = synonyms)
values$Title <- "Keywords Plus Network"
},
DE = {
values$NetWords <- biblioNetwork(values$M, analysis = "co-occurrences", network = "author_keywords", n = n, sep = ";", remove.terms = remove.terms, synonyms = synonyms)
values$Title <- "Authors' Keywords network"
},
KW_Merged ={
values$NetWords <- biblioNetwork(values$M, analysis = "co-occurrences", network = "all_keywords", n = n, sep = ";", remove.terms = remove.terms, synonyms = synonyms)
values$Title <- "All Keywords network"
},
TI = {
# if(!("TI_TM" %in% names(values$M))){
values$M <- termExtraction(values$M, Field = "TI", verbose = FALSE, ngrams = as.numeric(input$cocngrams), remove.terms = remove.terms, synonyms = synonyms)
# }
values$NetWords <- biblioNetwork(values$M, analysis = "co-occurrences", network = "titles", n = n, sep = ";")
values$Title <- "Title Words network"
},
AB = {
# if(!("AB_TM" %in% names(values$M))){
values$M <- termExtraction(values$M, Field = "AB", verbose = FALSE, ngrams = as.numeric(input$cocngrams), remove.terms = remove.terms, synonyms = synonyms)
# }
values$NetWords <- biblioNetwork(values$M, analysis = "co-occurrences", network = "abstracts", n = n, sep = ";")
values$Title <- "Abstract Words network"
},
WC = {
WSC <- cocMatrix(values$M, Field = "WC", binary = FALSE)
values$NetWords <- crossprod(WSC, WSC)
values$Title <- "Subject Categories network"
}
)
}
if (label.n > n) {
label.n <- n
}
if (input$normalize == "none") {
normalize <- NULL
} else {
normalize <- input$normalize
}
if (input$label.cex == "Yes") {
label.cex <- TRUE
} else {
label.cex <- FALSE
}
if (input$coc.curved == "Yes") {
curved <- TRUE
} else {
curved <- FALSE
}
values$cocnet <- networkPlot(values$NetWords,
normalize = normalize, Title = values$Title, type = input$layout,
size.cex = TRUE, size = 5, remove.multiple = F, edgesize = input$edgesize * 3, labelsize = input$labelsize, label.cex = label.cex,
label.n = label.n, edges.min = input$edges.min, label.color = F, curved = curved, alpha = input$cocAlpha,
cluster = input$cocCluster, remove.isolates = (input$coc.isolates == "yes"),
community.repulsion = input$coc.repulsion / 2, verbose = FALSE
)
if (input$cocyears == "Yes") {
Y <- fieldByYear(values$M, field = input$field, graph = FALSE)
g <- values$cocnet$graph
label <- igraph::V(g)$name
ind <- which(tolower(Y$df$item) %in% label)
df <- Y$df[ind, ]
col <- hcl.colors((diff(range(df$year_med)) + 1) * 10, palette = "Blues 3")
igraph::V(g)$color <- col[(max(df$year_med) - df$year_med + 1) * 10]
igraph::V(g)$year_med <- df$year_med
values$cocnet$graph <- g
}
} else {
emptyPlot("Selected field is not included in your data collection")
}
return(values)
}
intellectualStructure <- function(input, values) {
n <- input$citNodes
label.n <- input$citLabels
if ((dim(values$NetRefs)[1]) == 1 | !(input$citField == values$citField) | !(input$citSep == values$citSep) | !(input$citShortlabel == values$citShortlabel) | ((dim(values$NetRefs)[1]) != input$citNodes)) {
values$citField <- input$citField
values$citSep <- input$citSep
if (input$citShortlabel == "Yes") {
shortlabel <- TRUE
} else {
shortlabel <- FALSE
}
values$citShortlabel <- input$citShortlabel
switch(input$citField,
CR = {
values$NetRefs <- biblioNetwork(values$M, analysis = "co-citation", network = "references", n = n, sep = input$citSep, shortlabel = shortlabel)
values$Title <- "Cited References network"
},
CR_AU = {
if (!("CR_AU" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "CR_AU", sep = input$citSep)
}
values$NetRefs <- biblioNetwork(values$M, analysis = "co-citation", network = "authors", n = n, sep = input$citSep)
values$Title <- "Cited Authors network"
},
CR_SO = {
if (!("CR_SO" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "CR_SO", sep = input$citSep)
}
values$NetRefs <- biblioNetwork(values$M, analysis = "co-citation", network = "sources", n = n, sep = input$citSep)
values$Title <- "Cited Sources network"
}
)
}
if (label.n > n) {
label.n <- n
}
if (input$citlabel.cex == "Yes") {
label.cex <- TRUE
} else {
label.cex <- FALSE
}
if (input$cocit.curved == "Yes") {
curved <- TRUE
} else {
curved <- FALSE
}
values$cocitnet <- networkPlot(values$NetRefs,
normalize = NULL, Title = values$Title, type = input$citlayout,
size.cex = TRUE, size = 5, remove.multiple = F, edgesize = input$citedgesize * 3,
labelsize = input$citlabelsize, label.cex = label.cex, curved = curved,
label.n = label.n, edges.min = input$citedges.min, label.color = F, remove.isolates = (input$cit.isolates == "yes"),
alpha = 0.7, cluster = input$cocitCluster,
community.repulsion = input$cocit.repulsion / 2, verbose = FALSE
)
return(values)
}
socialStructure <- function(input, values) {
n <- input$colNodes
label.n <- input$colLabels
if ((dim(values$ColNetRefs)[1]) == 1 | !(input$colField == values$colField) | ((dim(values$ColNetRefs)[1]) != input$colNodes)) {
values$colField <- input$colField
# values$cluster="walktrap"
switch(input$colField,
COL_AU = {
values$ColNetRefs <- biblioNetwork(values$M, analysis = "collaboration", network = "authors", n = n, sep = ";")
values$Title <- "Author Collaboration network"
},
COL_UN = {
if (!("AU_UN" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "AU_UN", sep = ";")
}
values$ColNetRefs <- biblioNetwork(values$M, analysis = "collaboration", network = "universities", n = n, sep = ";")
values$Title <- "Edu Collaboration network"
},
COL_CO = {
if (!("AU_CO" %in% names(values$M))) {
values$M <- metaTagExtraction(values$M, Field = "AU_CO", sep = ";")
}
values$ColNetRefs <- biblioNetwork(values$M, analysis = "collaboration", network = "countries", n = n, sep = ";")
values$Title <- "Country Collaboration network"
# values$cluster="none"
}
)
}
if (label.n > n) {
label.n <- n
}
if (input$colnormalize == "none") {
normalize <- NULL
} else {
normalize <- input$colnormalize
}
if (input$collabel.cex == "Yes") {
label.cex <- TRUE
} else {
label.cex <- FALSE
}
if (input$soc.curved == "Yes") {
curved <- TRUE
} else {
curved <- FALSE
}
type <- input$collayout
if (input$collayout == "worldmap") {
type <- "auto"
}
values$colnet <- networkPlot(values$ColNetRefs,
normalize = normalize, Title = values$Title, type = type,
size.cex = TRUE, size = 5, remove.multiple = F, edgesize = input$coledgesize * 3,
labelsize = input$collabelsize, label.cex = label.cex, curved = curved,
label.n = label.n, edges.min = input$coledges.min, label.color = F, alpha = input$colAlpha,
remove.isolates = (input$col.isolates == "yes"), cluster = input$colCluster,
community.repulsion = input$col.repulsion / 2, verbose = FALSE
)
return(values)
}
countrycollaboration <- function(M, label, edgesize, min.edges, values) {
M <- metaTagExtraction(M, "AU_CO")
net <- biblioNetwork(M, analysis = "collaboration", network = "countries")
CO <- data.frame(Tab = rownames(net), Freq = diag(net))
bsk.network <- igraph::graph_from_adjacency_matrix(net, mode = "undirected")
COedges <- as.data.frame(igraph::ends(bsk.network, igraph::E(bsk.network), names = TRUE))
map.world <- map_data("world")
map.world$region <- toupper(map.world$region)
map.world$region <- gsub("^UK$", "UNITED KINGDOM", map.world$region)
map.world$region <- gsub("^SOUTH KOREA$", "KOREA", map.world$region)
country.prod <- dplyr::left_join(map.world, CO, by = c("region" = "Tab"))
# breaks <- as.numeric(round(quantile(CO$Freq,seq(0.1,1,by=0.1))))
breaks <- as.numeric(cut(CO$Freq, breaks = 10))
names(breaks) <- breaks
# breaks=breaks
data("countries", envir = environment())
names(countries)[1] <- "Tab"
COedges <- dplyr::inner_join(COedges, countries, by = c("V1" = "Tab"))
COedges <- dplyr::inner_join(COedges, countries, by = c("V2" = "Tab"))
COedges <- COedges[COedges$V1 != COedges$V2, ]
COedges <- count.duplicates(COedges)
tab <- COedges
COedges <- COedges[COedges$count >= min.edges, ]
COedges$region <- paste("\nCollaboration between\n", COedges$V1, "\n and \n", COedges$V2)
g <- ggplot(country.prod, aes(x = long, y = lat, group = group, text = paste("Country: ", region))) +
geom_polygon(aes(fill = Freq)) +
scale_fill_continuous(low = "#87CEEB", high = "dodgerblue4", breaks = breaks, na.value = "grey80") +
# guides(fill = guide_legend(reverse = T)) +
guides(colour = FALSE, fill = FALSE) +
# geom_curve(data=COedges, aes(x = Longitude.x , y = Latitude.x, xend = Longitude.y, yend = Latitude.y, # draw edges as arcs
# color = "firebrick4", size = count, group=continent.x),
# curvature = 0.33,
# alpha = 0.5) +
geom_segment(
data = COedges, aes(
x = Longitude.x, y = Latitude.x, xend = Longitude.y, yend = Latitude.y, # draw edges as arcs
size = count, group = continent.x
),
color = "orangered4", # FFB347",
# curvature = 0.33,
alpha = 0.3
) +
scale_size_continuous(guide = FALSE, range = c(0.25, edgesize)) +
labs(title = NULL, x = "Latitude", y = "Longitude") +
theme(
text = element_text(color = "#333333"),
plot.title = element_text(size = 28),
plot.subtitle = element_text(size = 14),
axis.ticks = element_blank(),
axis.text = element_blank(),
panel.grid = element_blank(),
panel.background = element_rect(fill = "#FFFFFF") #' #333333'
, plot.background = element_rect(fill = "#FFFFFF"),
legend.position = c(.18, .36),
legend.background = element_blank(),
legend.key = element_blank()
) +
annotation_custom(values$logoGrid, xmin = 143, xmax = 189.5, ymin = -69, ymax = -48)
if (isTRUE(label)) {
CO <- dplyr::inner_join(CO, countries, by = c("Tab" = "Tab"))
g <- g +
# ggrepel::geom_text_repel(data=CO, aes(x = Longitude, y = Latitude, label = Tab, group=continent), # draw text labels
# hjust = 0, nudge_x = 1, nudge_y = 4,
# size = 3, color = "orange", fontface = "bold")
ggrepel::geom_text(
data = CO, aes(x = Longitude, y = Latitude, label = Tab, group = continent), # draw text labels
hjust = 0, nudge_x = 1, nudge_y = 4,
size = 3, color = "orange", fontface = "bold"
)
}
results <- list(g = g, tab = tab)
return(results)
}
### visNetwork tools ----
netLayout <- function(type) {
switch(type,
auto = {
l <- "layout_nicely"
},
circle = {
l <- "layout_in_circle"
},
mds = {
l <- "layout_with_mds"
},
star = {
l <- "layout_as_star"
},
sphere = {
l <- "layout_on_sphere"
},
fruchterman = {
l <- "layout_with_fr"
},
kamada = {
l <- "layout_with_kk"
}
)
return(l)
}
savenetwork <- function(con, VIS) {
VIS %>%
visOptions(height = "800px") %>%
visNetwork::visSave(con)
}
igraph2vis <- function(g, curved, labelsize, opacity, type, shape, net, shadow = TRUE, edgesize = 5, noOverlap = TRUE) {
LABEL <- igraph::V(g)$name
LABEL[igraph::V(g)$labelsize == 0] <- ""
vn <- visNetwork::toVisNetworkData(g)
vn$nodes$label <- LABEL
vn$edges$num <- 1
vn$edges$dashes <- FALSE
vn$edges$dashes[vn$edges$lty == 2] <- TRUE
## opacity
vn$nodes$color <- adjustcolor(vn$nodes$color, alpha.f = min(c(opacity, 1)))
## set a darkest gray for iter-cluster edges
vn$edges$color <- paste(substr(vn$edges$color, 1, 7), "90", sep = "")
vn$edges$color[substr(vn$edges$color, 1, 7) == "#B3B3B3"] <- "#69696960"
vn$edges$color <- adjustcolor(vn$edges$color, alpha.f = opacity)
## removing multiple edges
vn$edges <- unique(vn$edges)
vn$edges$width <- vn$edges$width^2 / (max(vn$edges$width^2)) * (10 + edgesize)
# if (edgesize==0){
# vn$edges$hidden <- TRUE
# }else{vn$edges$hidden <- FALSE}
## labelsize
vn$nodes$font.size <- vn$nodes$deg
scalemin <- 20
scalemax <- 150
Min <- min(vn$nodes$font.size)
Max <- max(vn$nodes$font.size)
if (Max > Min) {
size <- (vn$nodes$font.size - Min) / (Max - Min) * 15 * labelsize + 10
} else {
size <- 10 * labelsize
}
size[size < scalemin] <- scalemin
size[size > scalemax] <- scalemax
vn$nodes$font.size <- size
l <- netLayout(type)
### TO ADD SHAPE AND FONT COLOR OPTIONS
coords <- net$layout
vn$nodes$size <- vn$nodes$font.size * 0.7
# vn$nodes$font.color <- adjustcolor("black", alpha.f = min(c(opacity,1)))
if (shape %in% c("dot", "square")) {
vn$nodes$font.vadjust <- -0.7 * vn$nodes$font.size
} else {
vn$nodes$font.vadjust <- 0
}
opacity_font <- sqrt((vn$nodes$font.size - min(vn$nodes$font.size)) / diff(range(vn$nodes$font.size))) * opacity + 0.3
if (is.nan(opacity_font[1])) opacity_font <- rep(0.3, length(opacity_font))
if (labelsize > 0) {
vn$nodes$font.color <- unlist(lapply(opacity_font, function(x) adjustcolor("black", alpha.f = x)))
} else {
vn$nodes$font.color <- adjustcolor("black", alpha.f = 0)
}
## avoid label overlaps
if (noOverlap) {
threshold <- 0.05
ymax <- diff(range(coords[, 2]))
xmax <- diff(range(coords[, 1]))
threshold2 <- threshold * mean(xmax, ymax)
w <- data.frame(x = coords[, 1], y = coords[, 2], labelToPlot = vn$nodes$label, dotSize = size, row.names = vn$nodes$label)
labelToRemove <- avoidNetOverlaps(w, threshold = threshold2)
} else {
labelToRemove <- ""
}
vn$nodes <- vn$nodes %>%
mutate(
label = ifelse(label %in% labelToRemove, "", label),
title = id
)
##
VIS <-
visNetwork::visNetwork(nodes = vn$nodes, edges = vn$edges, type = "full", smooth = TRUE, physics = FALSE) %>%
visNetwork::visNodes(shadow = shadow, shape = shape, font = list(color = vn$nodes$font.color, size = vn$nodes$font.size, vadjust = vn$nodes$font.vadjust)) %>%
visNetwork::visIgraphLayout(layout = "layout.norm", layoutMatrix = coords, type = "full") %>%
visNetwork::visEdges(smooth = list(type = "horizontal")) %>%
visNetwork::visOptions(highlightNearest = list(enabled = T, hover = T, degree = 1), nodesIdSelection = T) %>%
visNetwork::visInteraction(dragNodes = TRUE, navigationButtons = F, hideEdgesOnDrag = TRUE, zoomSpeed = 0.4) %>%
visNetwork::visOptions(manipulation = curved, height = "100%", width = "100%")
return(list(VIS = VIS, vn = vn, type = type, l = l, curved = curved))
}
## function to avoid label overlapping ----
avoidNetOverlaps <- function(w, threshold = 0.10) {
w[, 2] <- w[, 2] / 2
Ds <- dist(
w %>%
dplyr::filter(labelToPlot != "") %>%
select(1:2),
method = "manhattan", upper = T
) %>%
dist2df() %>%
rename(
from = row,
to = col,
dist = value
) %>%
left_join(
w %>% dplyr::filter(labelToPlot != "") %>%
select(labelToPlot, dotSize),
by = c("from" = "labelToPlot")
) %>%
rename(w_from = dotSize) %>%
left_join(
w %>% dplyr::filter(labelToPlot != "") %>%
select(labelToPlot, dotSize),
by = c("to" = "labelToPlot")
) %>%
rename(w_to = dotSize) %>%
filter(dist < threshold)
if (nrow(Ds) > 0) {
st <- TRUE
i <- 1
label <- NULL
case <- "n"
while (isTRUE(st)) {
if (Ds$w_from[i] > Ds$w_to[i] & Ds$dist[i] < threshold) {
case <- "y"
lab <- Ds$to[i]
} else if (Ds$w_from[i] <= Ds$w_to[i] & Ds$dist[i] < threshold) {
case <- "y"
lab <- Ds$from[i]
}
switch(case,
"y" = {
Ds <- Ds[Ds$from != lab, ]
Ds <- Ds[Ds$to != lab, ]
label <- c(label, lab)
},
"n" = {
Ds <- Ds[-1, ]
}
)
if (i >= nrow(Ds)) {
st <- FALSE
}
case <- "n"
# print(nrow(Ds))
}
} else {
label <- NULL
}
label
}
## visnetwork for subgraphs
igraph2visClust <- function(g, curved = FALSE, labelsize = 3, opacity = 0.7, shape = "dot", shadow = TRUE, edgesize = 5) {
LABEL <- igraph::V(g)$name
LABEL[igraph::V(g)$labelsize == 0] <- ""
vn <- visNetwork::toVisNetworkData(g)
vn$nodes$label <- LABEL
vn$edges$num <- 1
vn$edges$dashes <- FALSE
vn$edges$dashes[vn$edges$lty == 2] <- TRUE
## opacity
vn$nodes$color <- adjustcolor(vn$nodes$color, alpha.f = min(c(opacity, 1)))
## set a darkest gray for iter-cluster edges
vn$edges$color <- paste(substr(vn$edges$color, 1, 7), "90", sep = "")
vn$edges$color[substr(vn$edges$color, 1, 7) == "#B3B3B3"] <- "#69696960"
vn$edges$color <- adjustcolor(vn$edges$color, alpha.f = opacity)
## removing multiple edges
vn$edges <- unique(vn$edges)
vn$edges$width <- vn$edges$width^2 / (max(vn$edges$width^2)) * (5 + edgesize)
## labelsize
scalemin <- 20
scalemax <- 100
# aggiunta
vn$nodes$font.size <- vn$nodes$deg
#
Min <- min(vn$nodes$font.size)
Max <- max(vn$nodes$font.size)
if (Max > Min) {
size <- (vn$nodes$font.size - Min) / (Max - Min) * 15 * labelsize #+10
} else {
size <- 5 * labelsize
}
size[size < scalemin] <- scalemin
size[size > scalemax] <- scalemax
vn$nodes$font.size <- size
# l<-netLayout(type)
### TO ADD SHAPE AND FONT COLOR OPTIONS
vn$nodes$size <- vn$nodes$font.size * 0.4
if (shape %in% c("dot", "square")) {
vn$nodes$font.vadjust <- -0.7 * vn$nodes$font.size
} else {
vn$nodes$font.vadjust <- 0
}
opacity_font <- sqrt((vn$nodes$font.size - min(vn$nodes$font.size)) / diff(range(vn$nodes$font.size))) * opacity + 0.3
if (is.nan(opacity_font[1])) opacity_font <- rep(0.3, length(opacity_font))
if (labelsize > 0) {
vn$nodes$font.color <- unlist(lapply(opacity_font, function(x) adjustcolor("black", alpha.f = x)))
} else {
vn$nodes$font.color <- adjustcolor("black", alpha.f = 0)
}
VIS <-
visNetwork::visNetwork(nodes = vn$nodes, edges = vn$edges, type = "full", smooth = TRUE, physics = FALSE) %>%
visNetwork::visNodes(shadow = shadow, shape = shape, font = list(color = vn$nodes$font.color, size = vn$nodes$font.size, vadjust = vn$nodes$font.vadjust)) %>%
visNetwork::visIgraphLayout(layout = "layout_nicely", type = "full") %>%
visNetwork::visEdges(smooth = list(type = "horizontal")) %>%
visNetwork::visOptions(highlightNearest = list(enabled = T, hover = T, degree = 1), nodesIdSelection = T) %>%
visNetwork::visInteraction(dragNodes = TRUE, navigationButtons = F, hideEdgesOnDrag = TRUE, zoomSpeed = 0.4) %>%
visNetwork::visOptions(manipulation = curved, height = "100%", width = "100%")
return(list(VIS = VIS, vn = vn))
}
hist2vis <- function(net, labelsize = 2, nodesize = 2, curved = FALSE, shape = "dot", opacity = 0.7, labeltype = "short", timeline = TRUE) {
LABEL <- igraph::V(net$net)$id
LABEL[igraph::V(net$net)$labelsize == 0] <- ""
layout <- net$layout %>%
dplyr::select(x, y, color, name)
vn <- visNetwork::toVisNetworkData(net$net)
vn$nodes$short_label <- LABEL
if (labeltype != "short") {
vn$nodes$label <- paste0(vn$nodes$years, ": ", LABEL)
} else {
vn$nodes$label <- LABEL
}
vn$nodes <- dplyr::left_join(vn$nodes, layout, by = c("id" = "name"))
vn$edges$num <- 1
vn$edges$dashes <- FALSE
vn$edges$dashes[vn$edges$lty == 2] <- TRUE
vn$edges$color <- "grey"
## opacity
vn$nodes$font.color <- vn$nodes$color
vn$nodes$color <- adjustcolor(vn$nodes$color, alpha.f = min(c(opacity - 0.2, 1)))
vn$edges$color <- adjustcolor(vn$edges$color, alpha.f = opacity - 0.2)
vn$edges$smooth <- curved
## removing multiple edges
vn$edges <- unique(vn$edges)
## labelsize
scalemin <- 20
scalemax <- 150
size <- 10 * labelsize
size[size < scalemin] <- scalemin
size[size > scalemax] <- scalemax
vn$nodes$font.size <- size * 0.5
vn$nodes$size <- nodesize * 2
if (shape %in% c("dot", "square")) {
vn$nodes$font.vadjust <- -0.7 * vn$nodes$font.size
} else {
vn$nodes$font.vadjust <- 0
}
text_data <- net$graph.data %>%
select(Label, DOI, LCS, GCS) %>%
rename(id = Label) %>%
filter(!duplicated(id))
vn$nodes <- vn$nodes %>% left_join(text_data, by = "id")
## split node tooltips into two strings
title <- strsplit(stringi::stri_trans_totitle(vn$nodes$title), " ")
vn$nodes$title <- unlist(lapply(title, function(l) {
n <- floor(length(l) / 2)
paste0(paste(l[1:n], collapse = " ", sep = ""), "<br>", paste(l[(n + 1):length(l)], collapse = " ", sep = ""))
}))
vn$nodes <- vn$nodes %>%
mutate(title_orig = title,
title = paste("<b>Title</b>: ",
title,
"<br><b>DOI</b>: ",
paste0(
'<a href=\"https://doi.org/',
DOI,
'\" target=\"_blank\">',
# "DOI: ",
DOI, "</a>"
),
"<br><b>GCS</b>: ",
GCS, "<br><b>LCS</b>: ",
LCS,
sep = ""
))
## add time line
vn$nodes$group <- "normal"
vn$nodes$shape <- "dot"
vn$nodes$shadow <- TRUE
# nr <- nrow(vn$nodes)
# y <- max(vn$nodes$y)
# vn$nodes[nr + 1, c("id", "title", "label", "color", "font.color")] <-
# c(rep("logo", 3), "black", "white")
# vn$nodes$x[nr + 1] <- max(vn$nodes$x, na.rm = TRUE) + 1
# vn$nodes$y[nr + 1] <- y
# vn$nodes$size[nr + 1] <- vn$nodes$size[nr] * 4
# vn$nodes$years[nr + 1] <- as.numeric(vn$nodes$x[nr + 1])
# vn$nodes$font.size[nr + 1] <- vn$nodes$font.size[nr]
# vn$nodes$group[nr + 1] <- "logo"
# vn$nodes$shape[nr + 1] <- "image"
# vn$nodes$image[nr + 1] <- "logo.jpg"
# vn$nodes$fixed.x <- TRUE
# vn$nodes$fixed.y <- FALSE
# vn$nodes$fixed.y[nr + 1] <- TRUE
# vn$nodes$shadow[nr + 1] <- FALSE
# coords <- vn$nodes[, c("x", "y")] %>%
# as.matrix()
#
# coords[, 2] <- coords[, 2]^(1 / 2)
tooltipStyle <- ("position: fixed;visibility:hidden;padding: 5px;white-space: nowrap;
font-size:12px;font-color:black;background-color:white;")
## Font opacity
vn$nodes$LCS[is.na(vn$nodes$LCS)] <- max(vn$nodes$LCS, na.rm = TRUE)
opacity_font <- sqrt((vn$nodes$LCS - min(vn$nodes$LCS)) / diff(range(vn$nodes$LCS))) * 0.6 + 0.4
vn$nodes$size <- opacity_font * 5 * nodesize
vn$nodes$size[nrow(vn$nodes)] <- max(5 * nodesize)
for (i in 1:nrow(vn$nodes)) vn$nodes$font.color[i] <- adjustcolor(vn$nodes$font.color[i], alpha.f = opacity_font[i])
x <- vn$nodes$x
y <- vn$nodes$y
vn$nodes$x <- y
vn$nodes$y <- x
vn$nodes <- assign_horizontal_coords_clusters_adaptive(vn$nodes)
vn$nodes$fixed.x <- FALSE
vn$nodes$fixed.y <-TRUE
coords <- vn$nodes[, c("x", "y")] %>%
as.matrix()
coords[,2] <- coords[,2]
VIS <-
visNetwork::visNetwork(nodes = vn$nodes, edges = vn$edges, type = "full", smooth = TRUE, physics = FALSE) %>%
visNetwork::visNodes(shadow = vn$nodes$shadow, shape = shape, size = vn$nodes$size, font = list(color = vn$nodes$font.color, size = vn$nodes$font.size, vadjust = vn$nodes$font.vadjust)) %>%
visNetwork::visIgraphLayout(layout = "layout.norm", layoutMatrix = coords, type = "full") %>%
#visNetwork::visEdges(smooth = list(type = "horizontal"), arrows = list(to = list(enabled = TRUE, scaleFactor = 0.5))) %>%
visNetwork::visEdges(smooth = list(enabled = TRUE, type = "dynamic", roundness = 0.3),
arrows = list(to = list(enabled = TRUE, scaleFactor = 0.5))) %>%
visNetwork::visInteraction(dragNodes = T, navigationButtons = F, hideEdgesOnDrag = F, tooltipStyle = tooltipStyle, zoomSpeed = 0.2) %>%
visNetwork::visOptions(
highlightNearest = list(enabled = T, hover = T, degree = list(from = 1), algorithm = "hierarchical"), nodesIdSelection = F,
manipulation = FALSE, height = "100%", width = "100%"
)
return(list(VIS = VIS, vn = vn, type = "historiograph", curved = curved))
}
## calculate node coordinates in historiograph
assign_horizontal_coords_clusters_adaptive <- function(nodes_df, spacing_base = 1.0, cluster_spacing = 6, tol=0.15) {
clusters <- nodes_df %>%
count(color, name = "n_cluster") %>%
arrange(desc(n_cluster)) %>%
mutate(cluster_id = row_number(),
cluster_center = (cluster_id - mean(cluster_id)) * cluster_spacing)
nodes_df <- nodes_df %>%
left_join(clusters, by = "color")
nodes_df <- nodes_df %>%
group_by(years, color) %>%
mutate(
n_nodes = n(),
spacing = spacing_base * n_nodes, # USA direttamente il numero di nodi
x = (cluster_center[1] + spacing[1] * (row_number() - (n() + 1)/2))*runif(1,1-tol,1+tol)
) %>%
ungroup()
return(nodes_df)
}
## Pajek Export
graph2Pajek <- function(graph, filename = "my_pajek_network") {
nodes <- igraph::as_data_frame(graph, what = c("vertices")) %>%
mutate(id = row_number())
edges <- igraph::as_data_frame(graph, what = c("edges"))
edges <- edges %>%
left_join(nodes %>% select(id, name), by = c("from" = "name")) %>%
rename(id_from = id) %>%
left_join(nodes %>% select(id, name), by = c("to" = "name")) %>%
rename(id_to = id)
### Creation of NET file
file <- paste0(filename, ".net")
# Nodes
write(paste0("*Vertices ", nrow(nodes)), file = file)
write(paste0(nodes$id, ' "', nodes$name, '"'), file = file, append = T)
# Edges
write(paste0("*Edges ", nrow(nodes)), file = file, append = T)
write(paste0(edges$id_from, " ", edges$id_to, " ", edges$weight), file = file, append = T)
### Creation of VEC file
file <- paste0(filename, ".vec")
# Nodes
write(paste0("*Vertices ", nrow(nodes)), file = file)
write(paste0(nodes$deg), file = file, append = T)
### Creation of CLU file
file <- paste0(filename, ".clu")
# Nodes
write(paste0("*Vertices ", nrow(nodes)), file = file)
write(paste0(nodes$community), file = file, append = T)
}
## Dendogram to Visnetwork
dend2vis <- function(hc, labelsize, nclusters = 1, community = FALSE) {
# community = TRUE means that hc is an igraph community detection object
# community = FALSE mean that hc is a hclust object
# transform and plot a community igraph object using dendrogram
if (community) {
hc <- as.hclust(hc, use.modularity = TRUE)
}
h_tail <- round((max(hc$height) * 0.12), 1)
hc$height <- hc$height + h_tail
VIS <- visHclust(hc, cutree = nclusters, colorEdges = "grey60", horizontal = TRUE, export = FALSE)
VIS$x$edges <- data.frame(color = unique(VIS$x$edges$color)) %>%
mutate(new_color = colorlist()[1:nrow(.)]) %>%
right_join(VIS$x$edges, by = "color") %>%
select(-color) %>%
rename(color = new_color)
VIS$x$nodes <- VIS$x$nodes %>%
mutate(
label = ifelse(group != "individual", NA, label),
group = ifelse(group == "individual", "word", group),
title = gsub("individuals", "words", title),
value = 1,
scaling.min = 10,
scaling.max = 10
)
coords <- VIS$x$nodes %>%
select(x, y) %>%
as.matrix()
edges <- VIS$x$edges
nodes <- VIS$x$nodes %>%
select(id, label) %>%
dplyr::filter(label != "1")
VIS$x$edges <- edges %>%
select(-id) %>%
left_join(nodes, by = c("to" = "id")) %>%
select(-label.x) %>%
rename(label = label.y) %>%
mutate(
value = 10,
font.color = color,
font.size = labelsize * 10,
font.vadjust = -0.2 * font.size,
label = ifelse(is.na(label), "", label)
)
VIS <- VIS %>%
visGroups(
groupname = "group", color = "gray90",
shape = "dot", size = 10
) %>%
visGroups(
groupname = "word",
font = list(size = 0),
color = list(
background = "white", border = "#80B1D3",
highlight = "#e2e9e9", hover = "orange"
), shape = "box"
) %>%
visNodes(font = list(align = VIS$x$nodes$font.align)) %>%
visNetwork::visOptions(
highlightNearest = list(enabled = T, hover = T, degree = list(to = 1000, from = 0), algorithm = "hierarchical"), nodesIdSelection = FALSE,
manipulation = FALSE, height = "100%", width = "100%"
) %>%
visNetwork::visInteraction(dragNodes = FALSE, navigationButtons = F, hideEdgesOnDrag = TRUE, zoomSpeed = 0.4) %>%
visIgraphLayout(layout = "layout.norm", layoutMatrix = coords, type = "full") %>%
visEdges(font = list(align = "top", size = VIS$x$edges$font.size)) %>%
visEvents(click = "function(nodes){
Shiny.onInputChange('click_dend', nodes.nodes[0]);
;}")
for (i in 1:nrow(VIS$x$nodes)) {
if (VIS$x$nodes$group[i] == "group") {
old_inertia <- as.character(VIS$x$nodes$inertia[i])
inertia <- as.character(VIS$x$nodes$inertia[i] - h_tail)
VIS$x$nodes$title[i] <- gsub(old_inertia, inertia, VIS$x$nodes$title[i])
}
}
VIS
}
## Factorial Analysis dynamic plots
ca2plotly <- function(CS, method = "MCA", dimX = 1, dimY = 2, topWordPlot = Inf, threshold = 0.10, labelsize = 16, size = 5) {
LABEL <- CS$WData$word
switch(method,
CA = {
contrib <- rowSums(CS$coord$contrib %>% as.data.frame()) / 2
wordCoord <- CS$coord$coord[, 1:2] %>%
data.frame() %>%
mutate(
label = LABEL,
contrib = contrib
) %>%
select(c(3, 1, 2, 4))
row.names(wordCoord) <- LABEL
xlabel <- paste0("Dim 1 (", round(CS$res$eigCorr$perc[1], 2), "%)")
ylabel <- paste0("Dim 2 (", round(CS$res$eigCorr$perc[2], 2), "%)")
},
MCA = {
contrib <- rowSums(CS$coord$contrib %>% as.data.frame()) / 2
wordCoord <- CS$coord$coord[, 1:2] %>%
data.frame() %>%
mutate(
label = LABEL,
contrib = contrib
) %>%
select(c(3, 1, 2, 4))
row.names(wordCoord) <- LABEL
xlabel <- paste0("Dim 1 (", round(CS$res$eigCorr$perc[1], 2), "%)")
ylabel <- paste0("Dim 2 (", round(CS$res$eigCorr$perc[2], 2), "%)")
},
MDS = {
contrib <- size
xlabel <- "Dim 1"
ylabel <- "Dim 2"
wordCoord <- CS$WData %>%
data.frame() %>%
select(1:3) %>%
mutate(contrib = contrib / 2) %>%
rename(label = "word")
}
)
dimContrLabel <- paste0("Contrib", c(dimX, dimY))
ymax <- diff(range((wordCoord[, 3])))
xmax <- diff(range((wordCoord[, 2])))
threshold2 <- threshold * mean(xmax, ymax)
# scaled size for dots
dotScale <- (wordCoord$contrib) + size
# Threshold labels to plot
thres <- sort(dotScale, decreasing = TRUE)[min(topWordPlot, nrow(wordCoord))]
names(wordCoord)[2:3] <- c("Dim1", "Dim2")
wordCoord <- wordCoord %>%
mutate(
dotSize = dotScale,
groups = CS$km.res$cluster,
labelToPlot = ifelse(dotSize >= thres, label, ""),
font.color = ifelse(labelToPlot == "", NA, adjustcolor(colorlist()[groups], alpha.f = 0.85)),
font.size = round(dotSize * 2, 0)
)
## Avoid label overlapping
labelToRemove <- avoidOverlaps(wordCoord, threshold = threshold2, dimX = dimX, dimY = dimY)
wordCoord <- wordCoord %>%
mutate(labelToPlot = ifelse(labelToPlot %in% labelToRemove, "", labelToPlot)) %>%
mutate(
label = gsub("_1", "", label),
labelToPlot = gsub("_1", "", labelToPlot)
)
hoverText <- paste(" <b>", wordCoord$label, "</b>\n Contribute: ", round(wordCoord$contrib, 3), sep = "")
fig <- plot_ly(
data = wordCoord, x = wordCoord[, "Dim1"], y = wordCoord[, "Dim2"], # customdata=results$wordCoord,
type = "scatter",
mode = "markers",
marker = list(
size = dotScale,
color = adjustcolor(colorlist()[wordCoord$groups], alpha.f = 0.3), #' rgb(79, 121, 66, .5)',
line = list(
color = adjustcolor(colorlist()[wordCoord$groups], alpha.f = 0.3), #' rgb(79, 121, 66, .8)',
width = 2
)
),
text = hoverText,
hoverinfo = "text",
alpha = .3
)
fig <- fig %>% layout(
yaxis = list(title = ylabel, showgrid = TRUE, showline = FALSE, showticklabels = TRUE, domain = c(0, 1)),
xaxis = list(title = xlabel, zeroline = TRUE, showgrid = TRUE, showline = FALSE, showticklabels = TRUE),
plot_bgcolor = "rgba(0, 0, 0, 0)",
paper_bgcolor = "rgba(0, 0, 0, 0)"
)
for (i in seq_len(max(wordCoord$groups))) {
if (method == "MDS") {
w <- wordCoord %>%
dplyr::filter(groups == i) %>%
mutate(
Dim1 = Dim1 + 0.005,
Dim2 = Dim2 + 0.005
)
} else {
w <- wordCoord %>%
dplyr::filter(groups == i) %>%
mutate(
Dim1 = Dim1 + dotSize * 0.005,
Dim2 = Dim2 + dotSize * 0.01
)
}
if (max(CS$hull_data$clust) > 1) {
hull_df <- CS$hull_data %>% dplyr::filter(clust == i)
fig <- fig %>% add_polygons(
x = hull_df$Dim1, y = hull_df$Dim2, inherit = FALSE, showlegend = FALSE,
color = I(hull_df$color[1]), opacity = 0.3, line = list(width = 2),
text = paste0("Cluster ", i), hoverinfo = "text", hoveron = "points"
)
}
fig <- fig %>%
add_annotations(
data = w, x = ~Dim1, y = ~Dim2, xref = "x1", yref = "y",
text = ~labelToPlot,
font = list(family = "sans serif", size = labelsize, color = w$font.color[1]), #' rgb(79, 121, 66)'),
showarrow = FALSE
)
}
fig <- fig %>%
config(
displaylogo = FALSE,
modeBarButtonsToRemove = c(
#' toImage',
"sendDataToCloud",
"pan2d",
"select2d",
"lasso2d",
"toggleSpikelines",
"hoverClosestCartesian",
"hoverCompareCartesian"
)
) %>%
event_register("plotly_selecting")
return(fig)
}
## function to avoid label overlapping ----
avoidOverlaps <- function(w, threshold = 0.10, dimX = 1, dimY = 2) {
w[, "Dim2"] <- w[, "Dim2"] / 3
Ds <- dist(
w %>%
dplyr::filter(labelToPlot != "") %>%
select(Dim1, Dim2),
method = "manhattan", upper = T
) %>%
dist2df() %>%
rename(
from = row,
to = col,
dist = value
) %>%
left_join(
w %>% dplyr::filter(labelToPlot != "") %>%
select(labelToPlot, dotSize),
by = c("from" = "labelToPlot")
) %>%
rename(w_from = dotSize) %>%
left_join(
w %>% dplyr::filter(labelToPlot != "") %>%
select(labelToPlot, dotSize),
by = c("to" = "labelToPlot")
) %>%
rename(w_to = dotSize) %>%
filter(dist < threshold)
st <- TRUE
i <- 1
label <- NULL
case <- "n"
while (isTRUE(st)) {
if (Ds$w_from[i] > Ds$w_to[i] & Ds$dist[i] < threshold) {
case <- "y"
lab <- Ds$to[i]
} else if (Ds$w_from[i] <= Ds$w_to[i] & Ds$dist[i] < threshold) {
case <- "y"
lab <- Ds$from[i]
}
switch(case,
"y" = {
Ds <- Ds[Ds$from != lab, ]
Ds <- Ds[Ds$to != lab, ]
label <- c(label, lab)
},
"n" = {
Ds <- Ds[-1, ]
}
)
if (i >= nrow(Ds)) {
st <- FALSE
}
case <- "n"
# print(nrow(Ds))
}
label
}
## convert a distance object into a data.frame ----
dist2df <- function(inDist) {
if (class(inDist) != "dist") stop("wrong input type")
A <- attr(inDist, "Size")
B <- if (is.null(attr(inDist, "Labels"))) sequence(A) else attr(inDist, "Labels")
if (isTRUE(attr(inDist, "Diag"))) attr(inDist, "Diag") <- FALSE
if (isTRUE(attr(inDist, "Upper"))) attr(inDist, "Upper") <- FALSE
data.frame(
row = B[unlist(lapply(sequence(A)[-1], function(x) x:A))],
col = rep(B[-length(B)], (length(B) - 1):1),
value = as.vector(inDist)
)
}
### Excel report functions
addDataWb <- function(list_df, wb, sheetname) {
l <- length(list_df)
startRow <- 1
for (i in 1:l) {
df <- list_df[[i]]
n <- nrow(df)
writeDataTable(wb, sheetname, df, startRow = startRow, startCol = 1, tableStyle = "TableStyleMedium20")
startRow <- startRow + n + 3
}
return(wb)
}
addDataScreenWb <- function(list_df, wb, sheetname) {
ind <- which(regexpr(sheetname, wb$sheet_names) > -1)
if (length(ind) > 0) {
sheetname <- paste(sheetname, "(", length(ind) + 1, ")", sep = "")
}
addWorksheet(wb = wb, sheetName = sheetname, gridLines = FALSE)
if (!is.null(list_df)) {
addDataWb(list_df, wb, sheetname)
col <- max(unlist(lapply(list_df, ncol))) + 2
} else {
col <- 1
}
results <- list(wb = wb, col = col, sheetname = sheetname)
return(results)
}
addGgplotsWb <- function(list_plot, wb, sheetname, col, width = 10, height = 7, dpi = 75) {
l <- length(list_plot)
startRow <- 1
for (i in 1:l) {
fileName <- tempfile(
pattern = "figureImage",
fileext = ".png"
)
if (inherits(list_plot[[i]], "ggplot")) {
ggsave(
plot = list_plot[[i]], filename = fileName, width = width, height = height,
units = "in", dpi = dpi
)
}
if (inherits(list_plot[[i]], "igraph")) {
igraph2PNG(x = list_plot[[i]], filename = fileName, width = width, height = height, dpi = dpi)
}
if (inherits(list_plot[[i]], "bibliodendrogram")) {
# print("dendrogram plot")
# 1. Open jpeg file
png(filename = fileName, width = width, height = height, res = 300, units = "in")
# 2. Create the plot
plot(list_plot[[i]])
# 3. Close the file
dev.off()
}
insertImage(
wb = wb, sheet = sheetname, file = fileName, width = width,
height = height, startRow = startRow, startCol = col,
units = "in", dpi = dpi
)
startRow <- startRow + (height * 6) + 1
}
return(wb)
}
screenSh <- function(p, zoom = 2, type = "vis") {
tmpdir <- tempdir()
fileName <- tempfile(
pattern = "figureImage",
tmpdir = tmpdir,
fileext = ".png"
) # %>% substr(.,2,nchar(.))
plot2png(p, filename = fileName, zoom = zoom, type = type, tmpdir = tmpdir)
return(fileName)
}
screenShot <- function(p, filename, type) {
home <- homeFolder()
# setting up the main directory
# filename <- paste0(file.path(home,"downloads/"),filename)
if ("downloads" %in% tolower(dir(home))) {
filename <- paste0(file.path(home, "downloads"), "/", filename)
} else {
filename <- paste0(home, "/", filename)
}
plot2png(p, filename, zoom = 2, type = type, tmpdir = tempdir())
}
plot2png <- function(p, filename, zoom = 2, type = "vis", tmpdir) {
html_name <- tempfile(
fileext = ".html",
tmpdir = tmpdir
)
switch(type,
vis = {
visSave(p, html_name)
},
plotly = {
htmlwidgets::saveWidget(p, file = html_name)
}
)
biblioShot(url = html_name, zoom = zoom, file = filename) # , verbose=FALSE)
popUpGeneric(
title = NULL, type = "success", color = c("#1d8fe1"),
subtitle = paste0("Plot was saved in the following path: ", filename),
btn_labels = "OK", size = "40%"
)
}
addScreenWb <- function(df, wb, width = 14, height = 8, dpi = 75) {
names(df) <- c("sheet", "file", "n")
if (nrow(df) > 0) {
sheet <- unique(df$sheet)
for (i in 1:length(sheet)) {
sh <- sheet[i]
df_sh <- df %>% dplyr::filter(sheet == sh)
l <- nrow(df_sh)
startRow <- 1
for (j in 1:l) {
fileName <- df_sh$file[j]
insertImage(
wb = wb, sheet = sh, file = fileName, width = width,
height = height, startRow = startRow, startCol = df_sh$n[j],
units = "in", dpi = dpi
)
startRow <- startRow + (height * 10) + 3
}
}
}
return(wb)
}
addSheetToReport <- function(list_df, list_plot, sheetname, wb, dpi = 75) {
ind <- which(regexpr(sheetname, wb$sheet_names) > -1)
if (length(ind) > 0) {
sheetname <- paste(sheetname, "(", length(ind) + 1, ")", sep = "")
}
addWorksheet(wb, sheetname, gridLines = FALSE)
if (!is.null(list_df)) {
col <- max(unlist(lapply(list_df, ncol))) + 2
wb <- addDataWb(list_df, wb = wb, sheetname = sheetname)
} else {
col <- 1
}
if (!is.null(list_plot)) {
wb <- addGgplotsWb(list_plot, wb = wb, sheetname = sheetname, col = col, dpi = dpi)
}
# values$sheet_name <- sheetname
return(wb)
}
short2long <- function(df, myC) {
z <- unlist(lapply(myC, function(x) {
y <- gsub(r"{\s*\([^\)]+\)}", "", x)
gsub(y, df$long[df$short == y], x)
}))
names(myC) <- z
return(myC)
}
dfLabel <- function() {
short <- c(
"Empty Report", "MissingData", "MainInfo", "AnnualSciProd", "AnnualCitPerYear", "ThreeFieldsPlot", "MostRelSources", "MostLocCitSources", "BradfordLaw", "SourceLocImpact",
"SourceProdOverTime", "MostRelAuthors", "MostLocCitAuthors", "AuthorProdOverTime", "LotkaLaw", "AuthorLocImpact", "MostRelAffiliations", "AffOverTime",
"CorrAuthCountries", "CountrySciProd", "CountryProdOverTime", "MostCitCountries", "MostGlobCitDocs", "MostLocCitDocs", "MostLocCitRefs", "RPYS",
"MostFreqWords", "WordCloud", "TreeMap", "WordFreqOverTime", "TrendTopics", "CouplingMap", "CoWordNet", "ThematicMap", "ThematicEvolution",
"TE_Period_1", "TE_Period_2", "TE_Period_3", "TE_Period_4", "TE_Period_5", "FactorialAnalysis", "CoCitNet", "Historiograph", "CollabNet", "CollabWorldMap"
)
long <- c(
"Empty Report", "Missing Data Table", "Main Information", "Annual Scientific Production", "Annual Citation Per Year", "Three-Field Plot", "Most Relevant Sources", "Most Local Cited Sources", "Bradfords Law", "Sources Local Impact",
"Sources Production over Time", "Most Relevant Authors", "Most Local Cited Authors", "Authors Production over Time", "Lotkas Law", "Authors Local Impact", "Most Relevant Affiliations", "Affiliations Production over Time",
"Corresponding Authors Countries", "Countries Scientific Production", "Countries Production over Time", "Most Cited Countries", "Most Global Cited Documents", "Most Local Cited Documents", "Most Local Cited References", "Reference Spectroscopy",
"Most Frequent Words", "WordCloud", "TreeMap", "Words Frequency over Time", "Trend Topics", "Clustering by Coupling", "Co-occurence Network", "Thematic Map", "Thematic Evolution",
"TE_Period_1", "TE_Period_2", "TE_Period_3", "TE_Period_4", "TE_Period_5", "Factorial Analysis", "Co-citation Network", "Historiograph", "Collaboration Network", "Countries Collaboration World Map"
)
data.frame(short = short, long = long)
}
## Generic PopUp
popUpGeneric <- function(title = NULL, type = "success", color = c("#1d8fe1", "#913333", "#FFA800"),
subtitle = "",
btn_labels = "OK", size = "40%") {
showButton <- TRUE
timer <- NA
show_alert(
title = title,
text = subtitle,
type = type,
size = size,
closeOnEsc = TRUE,
closeOnClickOutside = TRUE,
html = FALSE,
showConfirmButton = showButton,
showCancelButton = FALSE,
btn_labels = btn_labels,
btn_colors = color,
timer = timer,
imageUrl = "",
animation = TRUE
)
}
## Ad to Report PopUp
popUp <- function(title = NULL, type = "success", btn_labels = "OK") {
switch(type,
success = {
title <- paste(title, "\n added to report", sep = "")
subtitle <- ""
btn_colors <- "#1d8fe1"
showButton <- TRUE
timer <- 3000
},
error = {
title <- "No results to add to the report "
subtitle <- "Please Run the analysis and then Add it to the report"
btn_colors <- "#913333"
showButton <- TRUE
timer <- 3000
},
waiting = {
title <- "Please wait... "
subtitle <- "Adding results to report"
btn_colors <- "#FFA800"
showButton <- FALSE
btn_labels <- NA
timer <- NA
}
)
show_alert(
title = title,
text = subtitle,
type = type,
size = "s",
closeOnEsc = TRUE,
closeOnClickOutside = TRUE,
html = FALSE,
showConfirmButton = showButton,
showCancelButton = FALSE,
btn_labels = btn_labels,
btn_colors = btn_colors,
timer = timer,
imageUrl = "",
animation = TRUE
)
}
colorlist <- function() {
c(
"#E41A1C", "#377EB8", "#4DAF4A", "#984EA3", "#FF7F00", "#A65628", "#F781BF", "#999999", "#66C2A5", "#FC8D62", "#8DA0CB", "#E78AC3", "#A6D854", "#FFD92F",
"#B3B3B3", "#A6CEE3", "#1F78B4", "#B2DF8A", "#33A02C", "#FB9A99", "#E31A1C", "#FDBF6F", "#FF7F00", "#CAB2D6", "#6A3D9A", "#B15928", "#8DD3C7", "#BEBADA",
"#FB8072", "#80B1D3", "#FDB462", "#B3DE69", "#D9D9D9", "#BC80BD", "#CCEBC5"
)
}
overlayPlotly <- function(VIS) {
# colorscale_VOS=matrix(c(0, 'rgba(66,65,135,255)', 0.1, 'rgba(34,170,134,255)',
# 0.3, 'rgba(202,224,31,255)',
# 1, 'rgba(244,227,92,255)'),4,2, byrow=T)
# colorscale_Our=matrix(c(0, 'rgba(238,238,238,255)',
# 0.1, 'rgba(232,202,177,255)',
# 0.2, 'rgba(217,137,100,255)',
# 0.6, 'rgba(199,107,90,255)',
# 0.9, 'rgba(164,38,39,255)',
# 1, 'rgba(178,34,34,255)'),
# 6,2, byrow=T)
Reds <- matrix(
c(
"0", "rgb(255,255,255)",
"0.05", "rgb(238,238,238)",
"0.125", "rgb(254,224,210)",
"0.25", "rgb(252,187,161)",
"0.375", "rgb(252,146,114)",
"0.5", "rgb(251,106,74)",
"0.625", "rgb(239,59,44)",
"0.75", "rgb(203,24,29)",
"0.875", "rgb(165,15,21)",
"1", "rgb(103,0,13)"
)
)
nodes <- VIS$x$nodes %>%
mutate(
y = y * (-1),
font.size = (((font.size - min(font.size)) / diff(range(font.size))) * 20) + 10
)
colori <- c(
"Blackbody", "Bluered", "Blues", "Cividis", "Earth", "Electric", "Greens", "Greys", "Hot", "Jet", "Picnic", "Portland",
"Rainbow", "RdBu", "Reds", "Viridis", "YlGnBu", "YlOrRd"
)
nodes2 <- nodes %>%
group_by(id) %>%
mutate(log = ceiling(log(deg))) %>%
slice(rep(1, each = log))
p <- plot_ly(nodes2, x = ~x, y = ~y) %>%
add_histogram2d(
histnorm = "density", zsmooth = "fast",
colorscale = Reds,
# colorscale=colori[15],
showscale = FALSE
)
for (i in 1:nrow(nodes)) {
p <- p %>%
add_annotations(
xref = "x1", yref = "y",
x = nodes$x[i], y = nodes$y[i],
text = nodes$label[i],
font = list(family = "Arial", size = nodes$font.size[i], color = adjustcolor(nodes$font.color[i], alpha.f = 0.8)),
showarrow = FALSE
)
}
p <- p %>%
layout(
yaxis = list(
title = "", zeroline = FALSE, showgrid = FALSE, showline = FALSE,
showticklabels = FALSE, domain = c(-1, 1), gridcolor = "#FFFFFF",
tickvals = list(NA)
),
xaxis = list(
title = "", zeroline = FALSE, showgrid = FALSE, showline = FALSE,
showticklabels = FALSE, domain = c(-1, 1), gridcolor = "#FFFFFF",
tickvals = list(NA)
),
plot_bgcolor = "rgba(0, 0, 0, 0)",
paper_bgcolor = "rgba(0, 0, 0, 0)",
showlegend = FALSE
) %>%
style(hoverinfo = "none") %>%
config(
displaylogo = FALSE,
modeBarButtonsToRemove = c(
#' toImage',
"sendDataToCloud",
"pan2d",
"select2d",
"lasso2d",
"toggleSpikelines",
"hoverClosestCartesian",
"hoverCompareCartesian"
)
)
return(p)
}
menuList <- function(values) {
TC <- ISI <- MLCS <- MLCA <- AFF <- MCC <- DB_TC <- DB_CR <- CR <- FALSE
if (!"TC" %in% values$missTags) TC <- TRUE
if ("ISI" %in% values$M$DB[1] & !"CR" %in% values$missTags) MLCS <- TRUE
if ("ISI" %in% values$M$DB[1] & !"CR" %in% values$missTags) MLCA <- TRUE
if ("ISI" %in% values$M$DB[1]) ISI <- TRUE
if (!"C1" %in% values$missTags) AFF <- TRUE
if (!"CR" %in% values$missTags) CR <- TRUE
if (!"TC" %in% values$missTags & !"C1" %in% values$missTags) MCC <- TRUE
if (sum(c("SCOPUS", "ISI") %in% values$M$DB[1]) > 0) DB_CR <- TRUE
if (sum(c("SCOPUS", "ISI", "OPENALEX", "LENS") %in% values$M$DB[1]) > 0) DB_TC <- TRUE
# out <- list(TC,ISI,MLCS,AFF,MCC,DB_TC,DB_CR,CR)
out <- NULL
L <- list()
L[[length(L) + 1]] <-
menuItem("Filters", tabName = "filters", icon = fa_i(name = "filter"))
L[[length(L) + 1]] <-
menuItem("Overview",
tabName = "overview", icon = fa_i(name = "table"), startExpanded = FALSE,
menuSubItem("Main Information", tabName = "mainInfo", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("Annual Scientific Production", tabName = "annualScPr", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(TC)) {
menuSubItem("Average Citations per Year", tabName = "averageCitPerYear", icon = icon("chevron-right", lib = "glyphicon"))
},
menuSubItem("Three-Field Plot", tabName = "threeFieldPlot", icon = icon("chevron-right", lib = "glyphicon"))
)
L[[length(L) + 1]] <-
menuItem("Sources",
tabName = "sources", icon = fa_i(name = "book"), startExpanded = FALSE,
menuSubItem("Most Relevant Sources", tabName = "relevantSources", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(MLCS)) {
menuSubItem("Most Local Cited Sources", tabName = "localCitedSources", icon = icon("chevron-right", lib = "glyphicon"))
},
menuSubItem("Bradford's Law", tabName = "bradford", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(TC)) {
menuSubItem("Sources' Local Impact", tabName = "sourceImpact", icon = icon("chevron-right", lib = "glyphicon"))
},
menuSubItem("Sources' Production over Time", tabName = "sourceDynamics", icon = icon("chevron-right", lib = "glyphicon"))
)
AU <-
menuItem("Authors",
tabName = "authors", icon = fa_i(name = "user"), startExpanded = FALSE,
"Authors",
menuSubItem("Most Relevant Authors", tabName = "mostRelAuthors", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(MLCA)) {
menuSubItem("Most Local Cited Authors", tabName = "mostLocalCitedAuthors", icon = icon("chevron-right", lib = "glyphicon"))
},
menuSubItem("Authors' Production over Time", tabName = "authorsProdOverTime", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("Lotka's Law", tabName = "lotka", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(TC)) {
menuSubItem("Authors' Local Impact", tabName = "authorImpact", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(AFF)) {
"Affiliations"
},
if (isTRUE(AFF)) {
menuSubItem("Most Relevant Affiliations", tabName = "mostRelAffiliations", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(AFF)) {
menuSubItem("Affiliations' Production over Time", tabName = "AffOverTime", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(AFF)) {
"Countries"
},
if (isTRUE(AFF)) {
menuSubItem("Corresponding Author's Countries", tabName = "correspAuthorCountry", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(AFF)) {
menuSubItem("Countries' Scientific Production", tabName = "countryScientProd", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(AFF)) {
menuSubItem("Countries' Production over Time", tabName = "COOverTime", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(MCC)) {
menuSubItem("Most Cited Countries", tabName = "mostCitedCountries", icon = icon("chevron-right", lib = "glyphicon"))
}
)
L[[length(L) + 1]] <- AU
DOC <-
menuItem("Documents",
tabName = "documents", icon = fa_i(name = "layer-group"), startExpanded = FALSE,
if (isTRUE(TC) | isTRUE(DB_TC)) {
"Documents"
},
if (isTRUE(TC)) {
menuSubItem("Most Global Cited Documents", tabName = "mostGlobalCitDoc", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(DB_TC) & isTRUE(CR) & isTRUE(TC)) {
menuSubItem("Most Local Cited Documents", tabName = "mostLocalCitDoc", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(DB_CR)) {
"Cited References"
},
if (isTRUE(DB_CR)) {
menuSubItem("Most Local Cited References", tabName = "mostLocalCitRef", icon = icon("chevron-right", lib = "glyphicon"))
},
if (isTRUE(DB_CR)) {
menuSubItem("References Spectroscopy", tabName = "ReferenceSpect", icon = icon("chevron-right", lib = "glyphicon"))
},
"Words",
menuSubItem("Most Frequent Words", tabName = "mostFreqWords", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("WordCloud", tabName = "wcloud", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("TreeMap", tabName = "treemap", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("Words' Frequency over Time", tabName = "wordDynamics", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("Trend Topics", tabName = "trendTopic", icon = icon("chevron-right", lib = "glyphicon"))
)
L[[length(L) + 1]] <- DOC
L[[length(L) + 1]] <-
menuItem("Clustering",
tabName = "clustering", icon = fa_i(name = "spinner"), startExpanded = FALSE,
menuSubItem("Clustering by Coupling", tabName = "coupling", icon = icon("chevron-right", lib = "glyphicon"))
)
L[[length(L) + 1]] <-
menuItem("Conceptual Structure",
tabName = "concepStructure", icon = fa_i(name = "spell-check"), startExpanded = FALSE,
"Network Approach",
menuSubItem("Co-occurence Network", tabName = "coOccurenceNetwork", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("Thematic Map", tabName = "thematicMap", icon = icon("chevron-right", lib = "glyphicon")),
menuSubItem("Thematic Evolution", tabName = "thematicEvolution", icon = icon("chevron-right", lib = "glyphicon")),
"Factorial Approach",
menuSubItem("Factorial Analysis", tabName = "factorialAnalysis", icon = icon("chevron-right", lib = "glyphicon"))
)
if (!"CR" %in% values$missTags) {
L[[length(L) + 1]] <-
menuItem("Intellectual Structure",
tabName = "intStruct", icon = fa_i(name = "gem"), startExpanded = FALSE,
menuSubItem("Co-citation Network", tabName = "coCitationNetwork", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(DB_TC) & isTRUE(CR)) {
menuSubItem("Historiograph", tabName = "historiograph", icon = icon("chevron-right", lib = "glyphicon"))
}
)
}
L[[length(L) + 1]] <-
menuItem("Social Structure",
tabName = "socialStruct", icon = fa_i("users"), startExpanded = FALSE,
menuSubItem("Collaboration Network", tabName = "collabNetwork", icon = icon("chevron-right", lib = "glyphicon")),
if (isTRUE(AFF)) {
menuSubItem("Countries' Collaboration World Map", tabName = "collabWorldMap", icon = icon("chevron-right", lib = "glyphicon"))
}
)
L[[length(L) + 1]] <- menuItem("Report", tabName = "report", icon = fa_i(name = "list-alt"))
L[[length(L) + 1]] <- menuItem("TALL Export", tabName = "tall", icon = icon("text-size", lib = "glyphicon"))
# L[[length(L) + 1]] <- menuItem("Settings", tabName = "settings", icon = fa_i(name = "sliders"))
if (!isTRUE(TC)) {
out <- c(
out, "Average Citations per Year", "Sources' Local Impact", "Authors' Local Impact",
"Most Global Cited Documents"
)
}
if (!isTRUE(MLCS)) {
out <- c(out, "Most Local Cited Sources")
}
if (!isTRUE(ISI)) {
out <- c(out, "Most Local Cited Authors")
}
if (!isTRUE(AFF)) {
out <- c(
out, "Most Relevant Affiliations", "Affiliations' Production over Time",
"Corresponding Author's Countries", "Countries' Scientific Production",
"Countries' Production over Time", "Countries' Collaboration World Map"
)
}
if (!isTRUE(MCC)) {
out <- c(out, "Most Cited Countries")
}
if (!(isTRUE(DB_TC) & isTRUE(CR) & isTRUE(TC))) {
out <- c(out, "Most Local Cited Documents")
}
if (!isTRUE(DB_CR)) {
out <- c(out, "Most Local Cited References", "References Spectroscopy")
}
if (!isTRUE(CR)) {
out <- c(out, "Co-citation Network")
}
if (!(isTRUE(DB_TC) & isTRUE(CR))) {
out <- c(out, "Historiograph")
}
values$out <- out
return(L)
}
# find home folder
homeFolder <- function() {
switch(Sys.info()[["sysname"]],
Windows = {
home <- Sys.getenv("R_USER")
},
Linux = {
home <- Sys.getenv("HOME")
},
Darwin = {
home <- Sys.getenv("HOME")
}
)
return(home)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.