utils::globalVariables(c("group","MNLCS","name", "pagerank_centrality",
"MNLCS2", "impact", "freq", "centrality", "color",
"words", "rcentrality", "rimpact", "label", "Cluster",
"w"))
#' Coupling Analysis
#'
#' It performs a coupling network analysis and plots community detection results on a bi-dimensional map (Coupling Map).
#'
#' The analysis can be performed on three different units: documents, authors or sources and
#' the coupling strength can be measured using the classical approach (coupled by references)
#' or a novel approach based on unit contents (keywords or terms from titles and abstracts)
#'
#' The x-axis measures the cluster centrality (by Callon's Centrality index) while the y-axis measures the cluster impact
#' by Mean Normalized Local Citation Score (MNLCS).
#' The Normalized Local Citation Score (NLCS) of a document is calculated
#' by dividing the actual count of local citing items by the expected citation rate for documents with the same year of publication.
#'
#' @param M is a bibliographic dataframe.
#' @param analysis is the textual attribute used to select the unit of analysis. It can be \code{analysis = c("documents", "authors", "sources")}.
#' @param field is the textual attribute used to measure the coupling strength. It can be \code{field = c("CR", "ID","DE", "TI", "AB")}.
#' @param n is an integer. It indicates the number of units to include in the analysis.
#' @param label.term is a character. It indicates which content metadata have to use for cluster labeling. It can be \code{label.term = c("ID","DE","TI","AB")}.
#' If \code{label.term = NULL} cluster items will be use for labeling.
#' @param ngrams is an integer between 1 and 4. It indicates the type of n-gram to extract from texts.
#' An n-gram is a contiguous sequence of n terms. The function can extract n-grams composed by 1, 2, 3 or 4 terms. Default value is \code{ngrams=1}.
#' @param impact.measure is a character. It indicates the impact measure used to rank cluster elements (documents, authors or sources).
#' It can be \code{impact.measure = c("local", "global")}.\\
#' With \code{impact.measure = "local"}, \link{couplingMap} calculates elements impact using the Normalized Local Citation Score while
#' using \code{impact.measure = "global"}, the function uses the Normalized Global Citation Score to measure elements impact.
#' @param minfreq is a integer. It indicates the minimum frequency (per thousand) of a cluster. It is a number in the range (0,1000).
#' @param community.repulsion is a real. It indicates the repulsion force among network communities. It is a real number between 0 and 1. Default is \code{community.repulsion = 0.1}.
#' @param stemming is logical. If it is TRUE the word (from titles or abstracts) will be stemmed (using the Porter's algorithm).
#' @param size is numerical. It indicates the size of the cluster circles and is a number in the range (0.01,1).
#' @param n.labels is integer. It indicates how many labels associate to each cluster. Default is \code{n.labels = 1}.
#' @param repel is logical. If it is TRUE ggplot uses geom_label_repel instead of geom_label.
#' @param cluster is a character. It indicates the type of cluster to perform among ("optimal", "louvain","leiden", "infomap","edge_betweenness","walktrap", "spinglass", "leading_eigen", "fast_greedy").
#' @return a list containing:
#' \tabular{lll}{
#' \code{map}\tab \tab The coupling map as ggplot2 object\cr
#' \code{clusters}\tab \tab Centrality and Density values for each cluster. \cr
#' \code{data}\tab \tab A list of units following in each cluster\cr
#' \code{nclust}\tab \tab The number of clusters\cr
#' \code{NCS}\tab \tab The Normalized Citation Score dataframe\cr
#' \code{net}\tab \tab A list containing the network output (as provided from the networkPlot function)}
#'
#' @examples
#'
#' \dontrun{
#' data(management, package = "bibliometrixData")
#' res <- couplingMap(management, analysis = "authors", field = "CR", n = 250, impact.measure="local",
#' minfreq = 3, size = 0.5, repel = TRUE)
#' plot(res$map)
#' }
#'
#' @seealso \code{\link{biblioNetwork}} function to compute a bibliographic network.
#' @seealso \code{\link{cocMatrix}} to compute a bibliographic bipartite network.
#' @seealso \code{\link{networkPlot}} to plot a bibliographic network.
#'
#' @export
couplingMap <- function(M, analysis = "documents", field="CR", n=500, label.term=NULL, ngrams=1, impact.measure="local", minfreq=5,
community.repulsion = 0.1,
stemming=FALSE, size=0.5, n.labels=1, repel=TRUE, cluster= "walktrap"){
if (!(analysis %in% c("documents", "authors", "sources"))) {
cat('\nanalysis argument is incorrect.\n\nPlease select one of the following choices: "documents", "authors", "sources"\n\n')
return(NA)
}
minfreq <- max(0,floor(minfreq*nrow(M)/1000))
Net <- network(M, analysis=analysis, field=field, stemming=stemming,n=n, cluster=cluster, community.repulsion = community.repulsion)
net=Net$graph
NCS <- normalizeCitationScore(M,field=analysis, impact.measure = impact.measure)
if (impact.measure == "global"){
NCS$MNLCS <- NCS$MNGCS
NCS$LC <- NCS$TC
}
NCS[,1] <- toupper(NCS[,1])
### Citation for documents
label <- V(net)$name
L <- tibble(id=toupper(label))
names(L) <- analysis
D <- left_join(L,NCS, by = analysis, copy=T)
L <- tibble(id=tolower(label))
names(L) <- names(Net$cluster_res)[1] <- analysis
C <- left_join(L,Net$cluster_res, by = analysis, copy=T)
group=Net$cluster_obj$membership
color=V(net)$color
color[is.na(color)]="#D3D3D3"
D$group <- group
D$color <- color
DC <- cbind(D,C[,-1])
DC$name <- DC[,1]
df_lab <- DC %>% group_by(group) %>%
mutate(MNLCS2 = replace(MNLCS,MNLCS<1,NA), ## remove NCS<1
MNLCS = round(MNLCS,2),
name = tolower(name),
freq = length(MNLCS)) %>%
arrange(desc(MNLCS), .by_group = TRUE)
df <- df_lab %>%
mutate(centrality = mean(pagerank_centrality),
impact = mean(MNLCS2,na.rm=TRUE),
impact = replace(impact, is.na(impact),0)) %>%
top_n(MNLCS, n=10) %>%
summarize(freq = freq[1],
centrality = centrality[1]*100,
impact = impact[1],
label_cluster = group[1],
color = color[1],
label = tolower(paste(name[1:min(n.labels,length(name))],collapse = "\n")),
words = tolower(paste(name,MNLCS,collapse = "\n"))) %>%
mutate(rcentrality = rank(centrality),
words = unlist(lapply(words, function(l){
l <- unlist(strsplit(l,"\\\n"))
l <- l[1:(min(length(l),10))]
l <- paste0(l,collapse="\n")
})),
rimpact = rank(impact)) %>%
arrange(group) %>% as.data.frame()
row.names(df) <- df$label
meandens <- mean(df$rimpact)
meancentr <- mean(df$rcentrality)
df <- df[df$freq>=minfreq,]
df_lab<- df_lab %>%
dplyr::filter(group %in% df$group)
rangex <- max(c(meancentr-min(df$rcentrality),max(df$rcentrality)-meancentr))
rangey <- max(c(meandens-min(df$rimpact),max(df$rimpact)-meandens))
xlimits <- c(meancentr-rangex-0.5,meancentr+rangex+0.5)
ylimits <- c(meandens-rangey-0.5,meandens+rangey+0.5)
df_lab <- df_lab[,c(1,7,15,8,4)]
names(df_lab)=c(analysis, "Cluster","ClusterFrequency", "ClusterColor","NormalizedLocalCitationScore")
df_lab$ClusterName <- df$label[df_lab$Cluster]
#quadrant_names=rep(" ",4) ## empty tooltips for quadrant names
if (is.null(label.term)){
label.term="null"
}
if (label.term %in% c("DE", "ID", "TI","AB")){
w <- labeling(M, df_lab, term=label.term, n=n, n.labels=n.labels, analysis = analysis, ngrams=ngrams)
df$label <- w
}
data("logo",envir=environment())
logo <- grid::rasterGrob(logo,interpolate = TRUE)
x <- c(max(df$rcentrality)-0.02-diff(range(df$rcentrality))*0.125, max(df$rcentrality)-0.02)+0.5
y <- c(min(df$rimpact),min(df$rimpact)+diff(range(df$rimpact))*0.125)
g <- ggplot(df, aes(x=rcentrality, y=rimpact, text=(words))) +
geom_point(group="NA",aes(size=log(as.numeric(freq))),shape=20,col=adjustcolor(df$color,alpha.f=0.5)) # Use hollow circles
if (size>0){
if (isTRUE(repel)){
g=g+geom_label_repel(aes(group="NA",label=ifelse(freq>1,unlist(tolower(label)),'')),size=3*(1+size),angle=0)}else{
g=g+geom_text(aes(group="NA",label=ifelse(freq>1,unlist(tolower(label)),'')),size=3*(1+size),angle=0)
}
}
g=g+geom_hline(yintercept = meandens,linetype=2, color=adjustcolor("black",alpha.f=0.7)) +
geom_vline(xintercept = meancentr,linetype=2, color=adjustcolor("black",alpha.f=0.7)) +
theme(legend.position="none") +
scale_radius(range=c(10*(1+size), 30*(1+size)))+
labs(x = "Centrality",y = "Impact") +
xlim(xlimits)+
ylim(ylimits)+
ggtitle(paste("Clusters by ", toupper(substr(analysis,1,1)),substr(analysis,2,nchar(analysis))," Coupling" ,sep="")) +
theme(axis.text.x=element_blank(),
panel.background = element_rect(fill = '#FFFFFF'),
axis.line.x = element_line(color="black",linewidth=0.5),
axis.line.y = element_line(color="black",linewidth=0.5),
axis.ticks.x=element_blank(),
axis.text.y=element_blank(),
axis.ticks.y=element_blank()
) +
annotation_custom(logo, xmin = x[1], xmax = x[2], ymin = y[1], ymax = y[2])
row.names(df)=NULL
df <- df %>% rename(items = words)
params <- list(analysis = analysis,
field=field,
n=n,
minfreq=minfreq,
label.term=label.term,
ngrams=ngrams,
impact.measure=impact.measure,
stemming=stemming,
n.labels=n.labels,
size=size,
community.repulsion = community.repulsion,
repel=repel,
cluster=cluster)
params <- data.frame(params=names(unlist(params)),values=unlist(params), row.names = NULL)
results=list(map=g, clusters=df, data=df_lab,nclust=dim(df)[1], NCS = D, net=Net, params=params)
return(results)
}
coupling <- function(M,field, analysis){
if (field=="TI"){field <- "TI_TM"}
if (field=="AB") field <- "AB_TM"
switch(analysis,
documents = {
WF <- t(cocMatrix(M, Field = field, short=TRUE))
NetMatrix <- crossprod(WF, WF)
},
authors = {
WF <- cocMatrix(M, Field = field, short=TRUE)
WA <- cocMatrix(M,Field = "AU", short=TRUE)
FA <- t(crossprod(WA,WF))
NetMatrix <- crossprod(FA,FA)
},
sources = {
WF <- cocMatrix(M, Field = field, short=TRUE)
WS <- cocMatrix(M,Field = "SO", short=TRUE)
FS <- t(crossprod(WS,WF))
NetMatrix <- crossprod(FS,FS)
})
return(NetMatrix)
}
network <- function(M, analysis,field, stemming, n, cluster, community.repulsion){
switch(analysis,
documents = {
switch(field,
CR = {
NetMatrix <- biblioNetwork(M, analysis = "coupling", network = "references", short = TRUE, shortlabel = FALSE, sep=";")
type <- "D_CR"
},
{
#field ID, DE, TI, AB
if (field %in% c("TI","AB")){
M=termExtraction(M,Field=field,verbose=FALSE, stemming = stemming)
type <- "D_KW"
}
NetMatrix <- coupling(M, field, analysis = "documents")
})
},
authors = {
switch(field,
CR = {
NetMatrix <- biblioNetwork(M, analysis = "coupling", network = "authors", short = TRUE)
type <- "AU_CR"
},
{
#field ID, DE, TI, AB
if (field %in% c("TI","AB")){
M=termExtraction(M,Field=field,verbose=FALSE, stemming = stemming)
type <- "AU_KW"
}
NetMatrix <- coupling(M, field, analysis = "authors")
})
},
sources = {
switch(field,
CR = {
NetMatrix <- biblioNetwork(M, analysis = "coupling", network = "sources", short = TRUE)
type <- "SO_CR"
},
{
#field ID, DE, TI, AB
if (field %in% c("TI","AB")){
M=termExtraction(M,Field=field,verbose=FALSE, stemming = stemming)
type <- "SO_KW"
}
NetMatrix <- coupling(M, field, analysis = "sources")
})
})
# delete empty vertices
NetMatrix <- NetMatrix[nchar(colnames(NetMatrix)) != 0, nchar(colnames(NetMatrix)) != 0]
if (nrow(NetMatrix)>0){
Net <- networkPlot(NetMatrix, normalize="salton",n=n, Title = paste("Coupling network of ",analysis," using ",field,sep=""),type="auto",
labelsize = 2, halo = F,cluster=cluster,remove.isolates=TRUE, community.repulsion = community.repulsion,
remove.multiple=FALSE, noloops=TRUE, weighted=TRUE,label.cex=T,edgesize=5,
size=1,edges.min = 1, label.n=n, verbose = FALSE)
}else{
cat("\n\nNetwork matrix is empty!\nThe analysis cannot be performed\n\n")
return()
}
return(Net)
}
## cluster labeling
labeling <- function(M, df_lab, term, n, n.labels, analysis, ngrams){
if (term %in% c("TI", "AB")){
M <- termExtraction(M, Field = term,ngrams = ngrams, verbose=FALSE)
term <- paste(term,"_TM",sep="")
}
switch(analysis,
documents={
df <- left_join(df_lab,M, by=c("documents" = "SR" ))
},
authors={
WF <- cocMatrix(M, Field = term, short=TRUE)
WA <- cocMatrix(M,Field = "AU", n=n, short=TRUE)
AF <- (crossprod(WA,WF))
A <- apply(AF,1,function(x){
paste(rep(names(x)[x>0],x[x>0]), collapse=";")
})
A <- data.frame(AU=names(A),words=A)
names(A)[2]=term
df <- left_join(df_lab,A, by=c("authors" = "AU"))
},
sources={
df <- left_join(df_lab,M, by=c("sources" = "SO" ))
})
#clusters <- unique(df$Cluster)
#w <- character(length(clusters))
df$SR <- df[,1]
tab_global <- tableTag(df, term)
tab_global <- data.frame(label=names(tab_global),tot=as.numeric(tab_global), n=nrow(M))
df <- df %>%
group_by(Cluster) %>%
do(w = best_lab(.data,tab_global, n.labels, term)) %>%
unnest(w) %>%
as.data.frame()
return(df$w)
}
best_lab <- function(d, tab_global, n.labels, term){
tab <- tableTag(d, term)
tab <- data.frame(label=names(tab), value=as.numeric(tab), stringsAsFactors = FALSE)
tab <- tab %>%
left_join(tab_global, by = "label") %>%
mutate(conf = round(.data$value/.data$tot*100,1),
supp = round(.data$tot/n*100,1),
relevance = round(.data$conf*.data$supp/100,1)) %>%
arrange(desc(.data$relevance)) %>%
slice(1:n.labels)
#tolower(paste(tab$label," Supp ",tab$supp,"% - Conf ", tab$conf,"%", sep="", collapse="\n"))
tolower(paste(tab$label," - Conf ", tab$conf,"%", sep="", collapse="\n"))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.