################################################## ## Project: The Universal Decay of Collective Memory and Attention ## Script purpose: Example of the calculation of Universal Decay of Collectrive Memory for a anonymized journal from 1980 ## Date: October 2018 ## Author: Cristian Candia-Castro-Vallejos ## email: crcandiav@gmail.com / ccandiav@mit.edu / ccandiav@udd.cl ## coments: The anonymized data is in the file: Example_citation_data.RData" ## Start the example by specifing your workin path below and then loading the packages, and finally go to "Start the example from here" section. ################################################## rm(list = ls()) path<-"INSERT_YOUR_PATH" setwd(path) #####Packages##### library(lubridate) library(zoo) library(foreign) library(MonetDB.R) library(DBI) library(reshape2) library(AICcmodavg) library(bbmle) library(stats4) agg_parameters<-data.frame('Journal'=NA,'Year'=0,"BIN"=0, 'AIC_biexp'=0,'AIC_exp'=0,'AIC_log'=0, 'AICc_biexp'=0,'AICc_exp'=0,'AICc_log'=0, 'p_nov0'=0,'p_nov0.sd'=0,'p_nov0.pv'=0, 'q_nov0'=0,'q_nov0.sd'=0,'q_nov0.pv'=0, 'N_nov0'=0,'N_nov0.sd'=0,'N_nov0.pv'=0, 'o_nov0'=0,'o_nov0.sd'=0,'o_nov0.pv'=0, 'r2_biexp'=0,'r2_exp'=0,'r2_log'=0,'tc'=0,'tc.sd'=0,stringsAsFactors=FALSE) ##### From here to the "Start the example from here" section is merely illustrative on how we get the data from the database ##### and how we calculate (in the query) the inflation factor. #for(journal in c('PRD','PRL','PRB','PRA','PRC','PRE')){ # for(ti in 1970:2003){ #print(paste0('Journal ',journal,' Year ',ti)) #con <- dbConnect(MonetDB.R(),user="XXXXXXX", password="XXXXXXXX", host="XXXXXXXX", dbname="PAPERS_APS") ##DBI::dbDisconnect(con, shutdown=TRUE) #citation_dat<-dbGetQuery(con ,paste0("SELECT tc.doi,tc.pjid,ti.sem,ti.yr,sum(tc.ncit) as ncit,sum(tc.ncit*ti.inflation) as ncit_inf FROM # (SELECT pt.doi,pt.jid as pjid,CASE WHEN ps.mth> 6 THEN '5'ELSE '0' END AS sem,ps.yr,1 as ncit FROM citations c # INNER JOIN papers pt ON pt.doi = c.doi_cited # INNER JOIN papers ps ON ps.doi = c.doi_citing # WHERE pt.yr=",ti," AND pt.mth<13 AND pt.jid=",shQuote(journal, 'sh')," ) tc # INNER JOIN # (SELECT t1.jid,t2.sem,t2.yr,cast(t1.npubs as Float)/cast(t2.npubs_y as float) as inflation FROM # (SELECT p.jid,count(*) as npubs FROM papers p # WHERE p.yr=",ti," AND p.mth<7 GROUP BY p.jid) as t1 # INNER JOIN # (SELECT p.jid,CASE WHEN p.mth> 6 THEN '5'ELSE '0' END AS sem,p.yr,count(*) as npubs_y FROM papers p # GROUP BY p.jid,sem,p.yr) t2 # ON t1.jid=t2.jid) ti # ON tc.pjid=ti.jid AND tc.sem=ti.sem AND tc.yr=ti.yr # GROUP BY tc.doi,tc.pjid,ti.sem,ti.yr; # " # )) #if(length(citation_dat[,1])==0){next} ####Data pre-processing #### #names(citation_dat)<-c('doi','journal','sem','yr','N_cit','N_cit_Infla') #citation_dat<-subset(citation_dat,yr>=ti) #citation_dat$yr2<-as.numeric(paste0(citation_dat$yr,'.',citation_dat$sem)) #citation_dat<-subset(citation_dat,select=c(-yr,-sem,-journal,-N_cit))## ESTE PRA SEMESTRE #citation_dat<-anonymize(citation_dat, 1) #save(citation_dat,file='Example_citation_data.RData') ####Start the example from here ####### ##doi is anonymized setwd(path) load('Example_citation_data.RData') ti=1980;journal='Anon' ### INFLATION RATE (Accounted in the Query)#### names(citation_dat)[grepl('yr',names(citation_dat))]<-'time'###comentar para semestres citation_columns<-reshape(citation_dat,idvar='time',timevar = 'doi',direction='wide') citation_columns<-citation_columns[with(citation_columns, order(time)), ];rownames(citation_columns)<-1:length(citation_columns$time) base_time<-citation_columns ### Cumulated sum #### base<-subset(base_time,select = c(-time))#base0 m<-as.matrix(base)#como matriz es mas rapido el reemplazo m[is.na(m)]<-0 m_cumu<-apply(m, 2, cumsum) base_cumu<-as.data.frame(m_cumu) cumu_resh<-melt(base_cumu) summary(cumu_resh$value[cumu_resh$value!=0]) summary(cumu_resh$value) ### Bining temporal decay #### bins<-exp(seq(log(1.1),log(250),0.5));bins base_index<-ifelse(base_cumu>11&base_cumu<=36,1,F)#mid=27 base_index<-ifelse(base_cumu>3.3&base_cumu<=11,2,base_index)#mid=10 base_index<-ifelse(base_cumu>=1.1&base_cumu<=3.3,3,base_index)#mid=3 ### Merge base and index #### base_resh<-melt(base_time,id='time') rownames(base_index)<-sort(unique(base_resh$time),decreasing = F) base_index_resh<-melt(base_index) patent10<-merge(base_resh,base_index_resh,by.x = c('time','variable'),by.y = c('Var1','Var2')) ### Filter by Preferential Attachment Level #### filter_accomplish<-function(data,bin_name,agrega,journal,ti,parameters){ ####Isolate the Temporal Dimension patent10<-data #bin_name=2 patent10_f<-subset(patent10,value.y==bin_name) patent10_f$ago<-patent10_f$time patent10_f$t<-patent10_f$time-ti #Initial conditions for fits (given the vertical base) if(bin_name==1){N=10;q=0.1;p=0.65;o=0.06;p0=p-o }else if(bin_name==2){N=8;q=0.08;p=0.65;o=0.06;p0=p-o }else if(bin_name==3){N=1.05;q=0.075;p=0.6;o=0.05;p0=p-o }else{N=10;p=0.5;p0=p-o} #Data arragement (NA and first value) patent10_f$Norm_Pop<-patent10_f$value.x patent10_f$Norm_Pop[is.na(patent10_f$Norm_Pop)]<-0 patent10_f$lt<-log(patent10_f$t);patent10_f$lt[is.infinite(patent10_f$lt)]<-NA patent10_f$t[patent10_f$t==0]<-NA ##### FIT ##### agree_data_f<-aggregate(patent10_f$Norm_Pop,list('t'=patent10_f$t),FUN=function(x)c(mean=mean(x,na.rm=T),sd=sd(x,na.rm=T),len=length(x))) agree_data_f$lt<-log(agree_data_f$t);agree_data_f$lt[is.infinite(agree_data_f$lt)]<-NA #agree_data_f<-subset(agree_data_f,x>0) #Bi-Exponential Fit trian_fit_patentsnov0<-nls(log(x[,'mean'])~log(N*((exp(-(p0+o)*t))+(((o)/(p0+o-q))*(-exp(-(p0+o)*t)+exp(-q*t))))), start=list(p0=p0,q=q,N=N,o=0.1),data=agree_data_f,control =list(maxiter = 900000),algorithm = 'port',lower=c(q=0)) #Log-Normal Fit nls_log<-nls(log(x[,'mean'])~(b+b1*lt-b2*(lt)^2), start=list(b=1,b1=-0.67,b2=0),data=agree_data_f, control = list(maxiter = 900000), algorithm = 'port')#, lower=c(-10000,-0.67,0) #Exponential Fit exp_fit<-nls(log(x[,'mean'])~log(exp(-qq*t)*(c)),start=list(qq=0.1,c=.07),data=agree_data_f[agree_data_f$t>5,]) #Summary sumar_nov0<-summary(trian_fit_patentsnov0);sumar_nov0 sumar2<-summary(nls_log);sumar2 sumar_exp<-summary(exp_fit);sumar_exp #To dataframe agree_data_f$Model<-exp(predict(trian_fit_patentsnov0,agree_data_f)) agree_data_f$Fit_log<-exp(predict(nls_log,agree_data_f)) agree_data_f$Sec_Exp<-exp(predict(exp_fit,agree_data_f)) #Goodness of fit r2_biexp<-cor(log(agree_data_f$x),log(agree_data_f$Model),use='complete.obs')^2 r2_log<-cor(log(agree_data_f$x),log(agree_data_f$Fit_log),use='complete.obs')^2 r2_exp<-cor(log(agree_data_f$x),log(agree_data_f$Sec_Exp),use='complete.obs')^2 #AIC aic_biexp<-(AIC(trian_fit_patentsnov0,k=2)) aic_exp<-(AIC(exp_fit,k=2)) aic_log<-(AIC(nls_log,k=2)) #AICc (compensated by sample size) aicc_biexp<-(AICc(trian_fit_patentsnov0,k=2));if(length(aicc_biexp)==0){aicc_biexp=99999999} aicc_exp<-(AICc(exp_fit,k=2));if(length(aicc_exp)==0){aicc_exp=99999999} aicc_log<-(AICc(nls_log,k=2));if(length(aicc_log)==0){aicc_log=99999999} #Calculate Tc pn=sumar_nov0$coefficients['p0','Estimate'] qn=sumar_nov0$coefficients['q','Estimate'] rn=sumar_nov0$coefficients['o','Estimate'] pn.sd<-sumar_nov0$coefficients['p0',2] qn.sd<-sumar_nov0$coefficients['q',2] rn.sd<-sumar_nov0$coefficients['o',2] tc=1/(pn+rn-qn)*log((pn+rn)*(pn-qn)/(qn*rn)) tc.std<-((pn.sd^2+rn.sd^2-qn.sd^2)+(((2*pn*pn.sd/pn^2)^2+(rn.sd/rn)^2+(qn.sd/qn)^2)/(pn^4/(rn^2*qn^2))+(pn.sd^2/pn^2+rn.sd^2/rn^2+pn.sd^2/pn^2+qn.sd^2/qn^2))^(1/2)/(log((pn+rn)*(pn-qn)/(qn*rn))))^(1/2) #Parameters paramm2<-c(journal,ti,bin_name, aic_biexp,aic_exp,aic_log, aicc_biexp,aicc_exp,aicc_log, sumar_nov0$coefficients['p0','Estimate'],sumar_nov0$coefficients['p0',2],sumar_nov0$coefficients['p0',4], sumar_nov0$coefficients['q','Estimate'],sumar_nov0$coefficients['q',2],sumar_nov0$coefficients['q',4], sumar_nov0$coefficients['N','Estimate'],sumar_nov0$coefficients['N',2],sumar_nov0$coefficients['N',4], sumar_nov0$coefficients['o','Estimate'],sumar_nov0$coefficients['o',2],sumar_nov0$coefficients['o',4], r2_biexp,r2_log,r2_exp,tc,tc.std) agg_parameters<-rbind(agg_parameters,paramm2) results<-list(agg_parameters,agree_data_f) return(results) } res1_try<-try(res1<-filter_accomplish(patent10,3,agrega,journal,ti,parameters)) try(agg_parameters<-res1[[1]]) res2_try<-try(res2<-filter_accomplish(patent10,2,agrega,journal,ti,parameters)) try(agg_parameters<-res2[[1]]) res3_try<-try(res3<-filter_accomplish(patent10,1,agrega,journal,ti,parameters)) try(agg_parameters<-res3[[1]]) ### Merge bins: 1, 2 y 3 #### patent10_f_agree<-merge(res2[[2]],res3[[2]],by = 't',all = T) patent10_f_agree<-merge(patent10_f_agree,res1[[2]],by='t',all=T) ### Preferential attachment #### pref_att<-function(year,data,data_cum){ ### Isolate preferential attachment dimension base=data base_cumu=data_cum pos<-which(row.names(base)==year) pref3<-as.data.frame(t(base[pos,]));names(pref3)<-c('cit') pref3$cum<-as.data.frame(t(base_cumu[pos,]))[,1];names(pref3)[2]<-c('cum') bins<-(seq((0),(50),1));bins#bins cumu pref3$cumu_cat<-bins[findInterval(pref3$cum ,bins)] pref3$cit[is.na(pref3$cit)]<-0 agre_pref3<-aggregate(pref3$cit,list('cum'=pref3$cumu_cat),FUN=function(x)c(mean=mean(x,na.rm=T),sd=sd(x,na.rm=T),len=length(x))) agre_pref3$cum<-bins[1:length(agre_pref3[,1])] agre_pref3$lcum<-log(agre_pref3$cum);agre_pref3$lcum[is.infinite(agre_pref3$lcum)]<-NA agre_pref3$lcit<-log(agre_pref3$x[,'mean']);agre_pref3$lcit[is.infinite(agre_pref3$lcit)]<-NA reg_PA<-lm(agre_pref3$lcit~agre_pref3$lcum) agre_pref3$fit<-predict(reg_PA,agre_pref3) return(agre_pref3) } pref6<-pref_att(2,base,base_cumu) pref8<-pref_att(5,base,base_cumu) pref10<-pref_att(9,base,base_cumu) pref<-merge(pref6,pref8,by='cum',all = T) pref<-merge(pref,pref10,by='cum',all=T) pref$cum[pref$cum==0]<-NA ### Plot preferential attachment dimension #### library(ggplot2) library(cowplot) attachment_plot<-function(ti, journal,pref){ ### Plot the preferential attachment dimension conf=1 tam_let=30 library(ggplot2) library(cowplot) pref_plot<-ggplot()+ geom_line(data=pref,aes(x=cum,y=exp(fit.x),col='t=2 years'),linetype='solid',size=2)+#red geom_point(data=pref,aes(x=cum,y=x.x[,'mean']),color='black',shape=16,size=4)+#black geom_errorbar(data=pref,aes(x=cum,ymin=x.x[,'mean']-conf*x.x[,'sd']/sqrt(x.x[,"len"]), ymax=x.x[,'mean']+conf*x.x[,'sd']/sqrt(x.x[,"len"])), width=0.01)+ geom_line(data=pref,aes(x=cum,y=exp(fit.y),col='t=5 years'),linetype='solid',size=2)+#red geom_point(data=pref,aes(x=cum,y=x.y[,'mean']),color='red',shape=16,size=4)+#black geom_errorbar(data=pref,aes(x=cum,ymin=x.y[,'mean']-conf*x.y[,'sd']/sqrt(x.y[,"len"]), ymax=x.y[,'mean']+conf*x.y[,'sd']/sqrt(x.y[,"len"])), width=0.01)+ geom_line(data=pref,aes(x=cum,y=exp(fit),col='t=9 years'),linetype='solid',size=2)+#red geom_point(data=pref,aes(x=cum,y=x[,'mean']),color='blue',shape=16,size=4)+#black geom_errorbar(data=pref,aes(x=cum,ymin=x[,'mean']-conf*x[,'sd']/sqrt(x[,"len"]), ymax=x[,'mean']+conf*x[,'sd']/sqrt(x[,"len"])), width=0.01)+ #scale_y_continuous(limits = c(Y_min,Y_max),trans='log10',breaks = scales::trans_breaks("log10", function(x) round(10^x,2))) + scale_y_continuous(limits = c(0.03,18),trans='log10',breaks = scales::trans_breaks("log10", function(x) 10^x),labels = scales::trans_format("log10", scales::math_format(10^.x))) + #scale_x_continuous(breaks=seq(min(patent10_f_agree$Time,na.rm = T),max(patent10_f_agree$Time,na.rm = T),by = 2),limits = c(min(patent10_f_agree$Time,na.rm = T),max(patent10_f_agree$Time,na.rm = T)+0.5),expand = c(0.01,0))+ scale_x_continuous(limits = c(0.8,30),trans='log10',breaks = scales::trans_breaks("log10", function(x) 10^x),labels = scales::trans_format("log10", scales::math_format(10^.x)),expand = c(0.06,0)) + xlab('Cumulated citations')+ ylab('Average of new citations')+ guides(fill = guide_legend(override.aes = list(linetype = 1, shape='')), colour = guide_legend(override.aes = list(linetype=c(1,1,1))))+ theme(plot.title = element_text(lineheight=.8, face="bold",size=tam_let))+ scale_colour_manual("", breaks = c('t=2 years','t=5 years','t=9 years') ,values = c('black','red','blue'))+ background_grid(major = "xy", minor = "none")+ theme(legend.key.size = unit(tam_let,"points"))+ theme(axis.text = element_text(size = tam_let))+ # changes axis labels theme(axis.title = element_text(size = tam_let))+ # change axis titles theme(text = element_text(size = tam_let))+ # this will change all text size theme(legend.title=element_text(size=5), legend.text=element_text(size=tam_let))+ theme(legend.justification=c(0,0), legend.position=c(0.05,0.8)) return(pref_plot) } setwd(path) pref_plot<-attachment_plot(ti,journal,pref) try(dev.off()) pdf(file =paste0("forgetting_pref_att",ti,"_",journal,".pdf"),width=12,height=9,paper='special') print(pref_plot) dev.off() ### Plot temporal dimension #### plotea<-function(patent10_f_agree,k1,k2,k3,Y_max,Ymin,ti,journal,xby){ ###Plot the temporal dimension conf=1.96#Nivel de confianza tam_let=30 patent10_f_agree$t[patent10_f_agree$t==0]<-NA patent10_f_agree$Time<-patent10_f_agree$t#+ti bins<-exp(seq(log(0.1),log(max(patent10_f_agree$Time,na.rm=T)+4),0.1));bins#Genera bins y centros even_indexes<-seq(2,length(bins)+1,2) odd_indexes<-seq(1,length(bins)+1,2) odd_bins<-bins[odd_indexes];odd_bins<-odd_bins[!is.na(odd_bins)]#Selecciona los centros even_bins<-bins[even_indexes];even_bins<-even_bins[!is.na(even_bins)]#Selecciona los extremos de los bins patent10_f_agree$logtime<-even_bins[findInterval(patent10_f_agree$Time ,odd_bins ) ]##Asigna el bin y nombra el centro patent10_f_agree2<-aggregate(list("x.x"=patent10_f_agree$x.x[,'mean'],"x.y"=patent10_f_agree$x.y[,'mean'],"x"=patent10_f_agree$x[,'mean']),list('logtime'=patent10_f_agree$logtime),FUN=function(x)c(mean=mean(x,na.rm=T),sd=sd(x,na.rm=T),len=length(x))) grap<-ggplot()+ geom_errorbar(data=patent10_f_agree2[!is.na(patent10_f_agree2$x[,1]),],aes(x=logtime,ymin=x[,'mean']-conf*x[,'sd']/sqrt(x[,"len"]), ymax=x[,'mean']+conf*x[,'sd']/sqrt(x[,"len"])),color='gray75', width=0.01)+ geom_errorbar(data=patent10_f_agree2[!is.na(patent10_f_agree2$x.x[,1]),],aes(x=logtime,ymin=x.x[,'mean']-conf*x.x[,'sd']/sqrt(x.x[,"len"]), ymax=x.x[,'mean']+conf*x.x[,'sd']/sqrt(x.x[,"len"])),color='gray75', width=0.01)+ geom_errorbar(data=patent10_f_agree2[!is.na(patent10_f_agree2$x.y[,1]),],aes(x=logtime,ymin=x.y[,'mean']-conf*x.y[,'sd']/sqrt(x.y[,"len"]), ymax=x.y[,'mean']+conf*x.y[,'sd']/sqrt(x.y[,"len"])),color='gray75', width=0.01)+ geom_line(data=patent10_f_agree[!is.na(patent10_f_agree$x[,1]),],aes(x=Time,y=Model,col=(paste0("k*=",k3))),size=2)+#red geom_line(data=patent10_f_agree[!is.na(patent10_f_agree$x[,1]),],aes(x=Time,y=Sec_Exp),color='Black',linetype='dashed',size=1)+#red geom_line(data=patent10_f_agree[!is.na(patent10_f_agree$x[,1]),],aes(x=Time,y=Fit_log),color='black',linetype='dotted',size=1)+#red geom_line(data=patent10_f_agree[!is.na(patent10_f_agree$x.x[,1]),],aes(x=Time,y=Model.x,col=(paste0("k*=",k2))),size=2)+#red geom_line(data=patent10_f_agree[!is.na(patent10_f_agree$x.x[,1]),],aes(x=Time,y=Sec_Exp.x),color='black',linetype='dashed',size=1)+#red geom_line(data=patent10_f_agree[!is.na(patent10_f_agree$x.y[,1]),],aes(x=Time,y=Fit_log.x),color='black',linetype='dotted',size=1)+#red geom_line(data=patent10_f_agree[!is.na(patent10_f_agree$x.y[,1]),],aes(x=Time,y=Model.y,col=(paste0("k*=",k1))),size=2)+#red geom_line(data=patent10_f_agree[!is.na(patent10_f_agree$x.y[,1]),],aes(x=Time,y=Sec_Exp.y),color='black',linetype='dashed',size=1)+#red geom_line(data=patent10_f_agree[!is.na(patent10_f_agree$x.y[,1]),],aes(x=Time,y=Fit_log.y),color='black',linetype='dotted',size=1)+#red geom_point(data=patent10_f_agree2[!is.na(patent10_f_agree2$x[,1]),],aes(x=logtime,y=x[,'mean']),color='grey60',shape=15,size=4)+#black geom_point(data=patent10_f_agree2[!is.na(patent10_f_agree2$x.x[,1]),],aes(x=logtime,y=x.x[,'mean']),color='grey60',shape=17,size=4)+#black geom_point(data=patent10_f_agree2[!is.na(patent10_f_agree2$x.y[,1]),],aes(x=logtime,y=x.y[,'mean']),color='grey60',shape=18,size=5)+#black scale_y_continuous(limits = c(Y_min,Y_max+2),trans='log10',breaks = scales::trans_breaks("log10", function(x) 10^x),labels = scales::trans_format("log10", scales::math_format(10^.x))) + scale_x_continuous(trans='log10',limits = c(0.5,max(patent10_f_agree$t,na.rm = T)+4),breaks = scales::trans_breaks("log10", function(x) 10^x),labels = scales::trans_format("log10", scales::math_format(10^.x))) + xlab(paste0('Age [t-',ti,']'))+ ylab('Average of new citations')+ guides(fill = guide_legend(override.aes = list(linetype = 1, shape='')), colour = guide_legend(override.aes = list(linetype=c(1,1,1))))+ theme(legend.key.size = unit(tam_let,"points"))+ theme(plot.title = element_text(lineheight=.8, face="bold",size=tam_let))+ scale_colour_manual("", breaks = c(paste0('k*=',k1),paste0('k*=',k2),paste0('k*=',k3)) ,values = c('red','red','red'))+ background_grid(major = "none", minor = "none")+ theme(legend.key.size = unit(tam_let,"points"))+ theme(axis.text = element_text(size = tam_let))+ # changes axis labels theme(axis.title = element_text(size = tam_let))+ # change axis titles theme(text = element_text(size = tam_let))+ # this will change all text size theme(legend.title=element_text(size=5), legend.text=element_text(size=tam_let))+ theme(legend.justification=c(0,0), legend.position=c(0.7,0.75))+ theme(panel.background = element_rect(fill = "white", colour = "black",linetype = "solid",size = 1)) return(grap) ### } k1=13;k2=5;k3=2;Y_max=40;Y_min=0.004;xby=4 setwd(path) grap<-plotea(patent10_f_agree,k1,k2,k3,Y_max,Ymin,ti,journal,xby) try(dev.off()) pdf(file = paste0("forgetting_scie_",ti,"_",journal,".pdf"),width=12,height=9,paper='special') #png(filename = paste0("t0_forgetting_scie_",ti,"_",journal,".png"),res=100, width = 1300, height = 1100,pointsize = 12, bg = "white") print(grap) dev.off() cat("Dashed line = Exponential fit \nDotted line = Log-normal fit \nRed line = Bi-Exponential fit") #} #}