In zoometh/iconr: Graphical and Spatial Analysis for Prehistoric Iconography
knitr::opts_chunk$set(echo = TRUE)
knitr::opts_chunk$set(fig.pos = 'H') # stabilise les images au bon endroit
options(warn=-1)
library(kableExtra)
library(FactoMineR)
library(factoextra)
library(MASS)
library(ggplot2)
library(ggrepel)
library(scales)
library(gridExtra)
library(lsmeans)
library(RColorBrewer)
library(png)
library(ggspatial)
library(sp)
library(sf)
library(spatstat)
library(rgdal)
library(maptools)
library(raster)
library(rgeos)
library(maptools)
library(cowplot)
library(dplyr)
library(data.table)
library(grid)
library(RPostgreSQL)
library(rpostgis)
library(tmap)
library(DescTools)
library(ade4)
library(dplyr)
library(knitr)
library(magick)
library(magrittr)
library(igraph)
library(gridExtra)
library(ggpubr)
library(dendextend)
library(ggdendro)
library(openxlsx)
library(stringr)
library(inlmisc)
library(grid)
library(ggplotify)
# library(ggtern)
library(seriation)
library(tibble)
library(tidyverse)
library(curl)
library(car)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# select a list of décors ('select.obj') and theme ('select.thm')
# the list of décors is the same to select décors and to create Postgis view for spatial
# pairwise comparison of common links, ex. 'visage'--'casque'
# create a correlation matrix
# objects decoration = graphs
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# ldecors.all <- source("_listes.R")
## objects, famille, themes - - - - - - - -
select.family <- select.obj <- "stele bouclier" # stats & spat for the whole family
select.superfamily <- "steles Bz du SO europeen"
# the dataset
select.choice <- "select.family" # 'select.superfamily', 'select.obj', 'select.family'
a.sel.grp <- F # load 'lgroups.all'
#rm.attributes <- T # remove attributes from same edges
chrono.limit <- c(-2000,-600) # limit chrono
# - - - - - - - - - - - - - - - -
meta <- T # 'meta' is textual description, '!= meta' is statistics
# - - - - - - - - - - - - - - - -
# graphs
# TODO: change v.select.obj & v.select.family to v.select
v.select <- paste0("ico_l_",eval(parse(text = select.choice))) # add "icol_l" for alphabetical ordering in db
v.select <- gsub(" ","_",v.select) # replace space
# TODO: remove these unecessary 'v.select'
# selected obj
v.select.obj <- paste0("ico_l_",select.obj) # add "icol_l" for alphabetical ordering in db
v.select.obj <- gsub(" ","_",v.select.obj) # replace space
# selected family
v.select.family <- paste0("ico_l_",select.family) # add "icol_l" for alphabetical ordering in db
v.select.family <- gsub(" ","_",v.select.family) # replace space
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# list of superfamilles (for Pg update, see. f.superf.update)
superfam.all <- list(list("steles Bz du SO europeen",c("stele bouclier",
"stele alentejo",
"stele corse"))
)
# list of origins for odered dendrograms, = 'orig.thm'
lorigins.all <- list(list("stele bouclier",c("Baracal","Baracal")),
list("stele alentejo",c("Abela","Abela")),
list("miscellaneous",c("Foios","Foios"))
)
# list of groups: specific analyses/plots for a sample
lgroups.all <- list(list("stele bouclier",
list("group1",c(7,5,16,28,30,33,38,39)),
list("group2",c(3,6,11,25,31,42)))
)
# selected themes for orientation/sens
thm.orient.select.all <- list(list("stele bouclier",c("epee","lance","bouclier")),
list("stele alentejo",c("epee","anciforme","hache")),
list("stele corse",c("epee","poignard")),
list("stele anepigraphe",c("epee")),
list("stele lunigiana C",c("hache","javelot","epee")),
list("miscellaneous",c("epee","lance","bouclier"))
)
# lists for analysis
ldecors.all <- list(list("vases_anthrop",
list('Capo Alfiere','item97'),
list('Cimino%','item28'),
list('Madonna delle Grazi%',''),
list('San Michele %','item151'),
list('Ripa Tett%','item1'),
list('Masseria Mansueto%','item311'),
list('Sospiro%','item297'),
list('Poggio Mon%','item95'),
list('Rendina%','item30')),
list("miscellaneous",
list('Foios',''),
list('Substantio','stele%'),
list('Torrejon R%','Torrejon R%1'),
list('Cerro Muria%',''),
list('Cortijo de la R%','Cortijo de la R%1'),
list('Tabuyo Del%',''),
list('Solana de C%',''),
list('Brozas%','')),
list("stele corse",
list('Apazzu','Apazzu 1'),
list('Apazzu','Apazzu 2'),
list('Apazzu','Apazzu 8'),
list('Apazzu','Apazzu 10'),
list('Apazzu','Apazzu 13'),
list('Castaldu','stele_zj'),
list('Capu Castincu','stele_zj'),
list('Filitosa','Filitosa 1'),
list('Filitosa','Filitosa 3'),
list('Filitosa','Filitosa 4'),
list('Filitosa','Filitosa 5'),
list('Filitosa','Filitosa 6'),
list('Filitosa','Filitosa 7'),
list('Filitosa','Filitosa 9'),
list('Filitosa','Filitosa 13'),
list('I Stantari','I Stantari 2'),
list('I Stantari','I Stantari 4'),
list('I Stantari','I Stantari 5'),
list('I Stantari','I Stantari 7'),
#list('I Stantari','I Stantari 8'),
list('Palaggiu','Palaggiu 2'),
list('Petra Pinzuta','Petra Pinzuta'),
list('Portigliolo','stele_zj'),
list('Pozzone','stele_zj'),
list('Santa Naria 1','stele_zk'),
list('Scalsa Murta','stele'),
list('Tramezzu','stele_zj'),
list('U Scumunicatu','stele_zj'),
list('Castello Valle','Castello_Valle')
),
list("stele alentejo",
list('Abela','Abela'),
list('Abaixo (Monte de)','Monte De Abaixo'),
list('Alfarrobeira','Alfarrobeira'),
list('Assento','Assento'),
list('Defesa','Defesa'),
## list('Ervidel','Ervidel 1'),
## list('Gomes Aires','Gomes Aires'),
list('Mombeja','Mombeja 1'),
list('Pedreirinha','Pedreirinha'),
list('Joao de Negrilhos (San)','San Joao De Negrilhos'),
list('Vitoria (Santa)','Santa Vitoria'),
list('Tapada da Moita','Tapada Da Moita'),
list('Trigaxes','Trigaxes 1')),
list("stele bouclier",
list('Alamillo','Alamillo'),
list('Aldea del Rey','Aldea Del Rey 1'),
list('Aldeanueva de San Bartolome','Aldeanueva De San Bartolome'),
list('Almaden de la Plata','Almaden De La Plata 2'),
list('Arroyo Bonaval','Arroyo Bonaval-Almendralejo'),
list('Ategua','Ategua%'),
list('Baracal','Baracal%'),
list('Brozas','Brozas%'),
list('Burguillos','Burguillos'),
list('Cabeza de Bu%','Cabeza De Bu%1'),
list('Cabeza de Bu%','Cabeza De Bu%2'),
list('Cabeza de Bu%','Cabeza De Bu%3'),
list('Cabeza de Bu%','Cabeza De Bu%4%'),
list('Carneril (El)','El Carneril_Trujillo'),
list('Capilla','Capilla 3'),
list('Capilla','Capilla 8'),
#list('Capote','Capote'),
list('Cerro Muriano','Cerro Muriano 1'),
list('Cerro Muriano','Cerro Muriano 2'),
list('Cortijo de la Reina','Cortijo de La Reina 1'),
list('Cortijo de la Reina','Cortijo de La Reina 2'),
list('Cuatro Casas','Cuatro Casas_Carmona'),
list('Ecija','Ecija 1'),
list('Ecija','Ecija 2'),
list('Ecija','Ecija 3'),
list('Ecija','Ecija 5_El Berraco'),
list('Ervidel','Ervidel 2'),
list('Esparragosa de Lares','Esparragosa De Lares 1_Castuera'), # indet en attribut
list('Foios','Foios'),
list('Fuente de Cantos','Fuente De Cantos'),
list('Granja de Cespedes','Granja De Cespedes-Badajoz'),
list('Ibahernando','Ibahernando'),
list('Herencias (Las)','Las Herencias 1'),
list('Herencias (Las)','Las Herencias 2'),
list('Magacela','Magacela'),
list('Montemolin','Montemolin'),
list('Pedro Abad','Pedro Abad'),
list('Quinterias','Quinterias'),
list('Ribera Alta','Cordoba 2_Ribera Alta'),
list('Robledillo de Trujillo','Robledillo De Trujillo'),
list('Salen','Buoux 1'),
list('Martin de Trevejo (San)','San Martin De Trevejo'),
list('Santa Ana De Trujillo','Santa Ana de Trujillo'),
list('Setefilla','Setefilla'),
list('Solana de Cabanas','Solana De Cabanas'),
list('Substantio','stele_pn'),
list('Torrejon Rubio','Torrejon Rubio 1'),
list('Torrejon Rubio','Torrejon Rubio 3'),
list('Tres Arroyos', 'Tres Arroyos - Albuquerque'),
list('Valdetorres','Valdetorres 1'), # utile pour superpositions
#list('Valpalmas','Luna_Valpalmas'),
list('Viso (El)','El Viso 1'),
list('Viso (El)','El Viso 2'),
list('Viso (El)','El Viso 4'),
list('Zarza de Montanchez','Zarza De Montanchez'),
list('Zarza Capilla','Zarza Capilla 1')
),
## for META
list("var_cs",list('Catal Huyuk','p_taureau_rouge__aeh'))
#list("var_cs",list('Cerro Muriano','Cerro Muriano 1'))
# list("var_cs",list('Cortijo de la Reina','Cortijo de La Reina 1'))
# # list('Salen','Buoux 2'), # 1 seule UG
# list('Touries','stele_1_ze'),
# list('Touries','stele_2_ze'),
# list('Touries','stele_3_ze'),
# list('Touries','stele_31_aab'))
)
# - - - - - - - - - -
# blank theme for ggplot
blank_theme <- theme_minimal()+
theme(
axis.title.x = element_blank(),
axis.title.y = element_blank(),
panel.border = element_blank(),
panel.grid=element_blank(),
axis.ticks = element_blank(),
plot.title=element_text(size=12, face="bold")
)
## paths - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# #select.obj.name <- gsub("ico_l_","",select.obj) # remove "ico_l_"
chm <- "D:/Projet Art Rupestre_1/decors/"
chm.ug <- paste0(chm,"ug/")
chm.ug.typo <- paste0(chm.ug,"typo/")
chm.obj <- paste0(chm,"obj")
# chm.super.family <- paste0(chm,"obj",select.superfamily)
chm.doc <- paste0(chm,"doc/")
# chm.ugs <- paste0(chm,"ug")
# chm.ugs.typo <- paste0(chm.obj,"/typo")
# chm.thm <- "D:/Projet Art Rupestre/decors/thm" # "F:/Collaborations et concours/Colloques
#chm.thm <- paste0(chm,"ug")
chm.signes <- "C:/Rprojects/iconr/doc/ugs/"
# chm.signes <- paste0(chm, "ug/signes/") # "D:/Projet Art Rupestre/decors/ug/signes/"
# if not exist, create a folder with the name of the list, ex: "vases_anthrop"
#### output folders
### super.family - - - - - - - - - -
ifelse(!dir.exists(file.path(chm.obj, select.superfamily)),
dir.create(file.path(chm.obj, select.superfamily)),
FALSE)
### family or objects - - - - - - - - - -
ifelse(!dir.exists(file.path(chm.obj, select.obj)),
dir.create(file.path(chm.obj, select.obj)),
FALSE)
chm.etude <- paste0(chm.obj,"/",select.obj,"/")
# if super.family, change
if (select.choice == "select.superfamily"){
select.obj <- select.superfamily
chm.etude <- paste0(chm.obj,"/",select.superfamily,"/")
}
# # matrix folder
obj.matrix <- paste0(select.obj,"/matrix")
ifelse(!dir.exists(file.path(chm.obj, obj.matrix)),
dir.create(file.path(chm.obj, obj.matrix)),
FALSE)
chm.matrix <- paste0(file.path(chm.obj, obj.matrix),'/')
# corpus folder
obj.corpus <- paste0(select.obj,"/corpus")
ifelse(!dir.exists(file.path(chm.obj, obj.corpus)),
dir.create(file.path(chm.obj, obj.corpus)),
FALSE)
chm.corpus <- paste0(file.path(chm.obj, obj.corpus),'/')
# var folder
obj.var <- paste0(select.obj,"/var")
ifelse(!dir.exists(file.path(chm.obj, obj.var)),
dir.create(file.path(chm.obj, obj.var)),
FALSE)
chm.var <- paste0(file.path(chm.obj, obj.var),'/')
# # groups folder
# obj.groups <- paste0(select.obj,"/groups")
# ifelse(!dir.exists(file.path(chm.obj, obj.groups)),
# dir.create(file.path(chm.obj, obj.groups)),
# FALSE)
# chm.groups <- paste0(file.path(chm.obj, obj.groups),'/')
# family folder, to suppress
# obj.family<- paste0(select.obj,"/family")
# ifelse(!dir.exists(file.path(chm.obj, obj.family)),
# dir.create(file.path(chm.obj, obj.family)),
# FALSE)
# chm.family<- paste0(file.path(chm.obj, obj.family),'/')
# thms folder
obj.thms <- paste0(select.obj,"/thms")
ifelse(!dir.exists(file.path(chm.obj, obj.thms)),
dir.create(file.path(chm.obj, obj.thms)),
FALSE)
chm.thm <- paste0(file.path(chm.obj, obj.thms),'/')
### analysis folders - - - - - - - - - -
obj.analysis <- paste0(select.obj,"/analysis1D")
ifelse(!dir.exists(file.path(chm.obj, obj.analysis)),
dir.create(file.path(chm.obj, obj.analysis)),
FALSE)
chm.analysis <- paste0(file.path(chm.obj, obj.analysis),'/')
## objects
# chrono
obj.analysis.o.chr <- paste0(obj.analysis,"/obj_chrono")
ifelse(!dir.exists(file.path(chm.obj, obj.analysis.o.chr)),
dir.create(file.path(chm.obj, obj.analysis.o.chr)),
FALSE)
chm.analysis.o.chr <- paste0(file.path(chm.obj, obj.analysis.o.chr),'/')
## decorations
# histo
dec.analysis.histo <- paste0(obj.analysis,"/dec_histo")
ifelse(!dir.exists(file.path(chm.obj, dec.analysis.histo)),
dir.create(file.path(chm.obj, dec.analysis.histo)),
FALSE)
chm.analysis.dec.histo <- paste0(file.path(chm.obj, dec.analysis.histo),'/')
## objects
# dimensions
obj.analysis.o.dimensions <- paste0(obj.analysis,"/obj_dimensions")
ifelse(!dir.exists(file.path(chm.obj, obj.analysis.o.dimensions)),
dir.create(file.path(chm.obj, obj.analysis.o.dimensions)),
FALSE)
chm.analysis.o.dimensions <- paste0(file.path(chm.obj, obj.analysis.o.dimensions),'/')
# raw materials
obj.analysis.o.rawmaterial <- paste0(obj.analysis,"/obj_raw_material")
ifelse(!dir.exists(file.path(chm.obj, obj.analysis.o.rawmaterial)),
dir.create(file.path(chm.obj, obj.analysis.o.rawmaterial)),
FALSE)
chm.analysis.o.rawmaterial <- paste0(file.path(chm.obj, obj.analysis.o.rawmaterial),'/')
# spatial folder
obj.spat <- paste0(obj.analysis,"/obj_spatial")
ifelse(!dir.exists(file.path(chm.obj, obj.spat)),
dir.create(file.path(chm.obj, obj.spat)),
FALSE)
chm.spatial<- paste0(file.path(chm.obj, obj.spat),'/')
### ugs
## graphs
# # histo
# ug.analysis.histo <- paste0(obj.analysis,"/ug__histo")
# ifelse(!dir.exists(file.path(chm.obj, ug.analysis.histo)),
# dir.create(file.path(chm.obj, ug.analysis.histo)),
# FALSE)
# chm.analysis.histo <- paste0(file.path(chm.obj, ug.analysis.histo),'/')
## edges
# # histo
# ug.analysis.e.histo <- paste0(obj.analysis,"/ug_e_histo")
# ifelse(!dir.exists(file.path(chm.obj, ug.analysis.e.histo)),
# dir.create(file.path(chm.obj, ug.analysis.e.histo)),
# FALSE)
# chm.analysis.e.histo <- paste0(file.path(chm.obj, ug.analysis.e.histo),'/')
## nodes
# complet/incomplet
ug.analysis.n.compl <- paste0(obj.analysis,"/ug_n_complet")
ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.compl)),
dir.create(file.path(chm.obj, ug.analysis.n.compl)),
FALSE)
chm.analysis.n.compl<- paste0(file.path(chm.obj, ug.analysis.n.compl),'/')
# typo
ug.analysis.n.typo<- paste0(obj.analysis,"/ug_n_typo")
ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.typo)),
dir.create(file.path(chm.obj, ug.analysis.n.typo)),
FALSE)
chm.analysis.n.typo <- paste0(file.path(chm.obj, ug.analysis.n.typo),'/')
# chrono
ug.analysis.n.chrono <- paste0(obj.analysis,"/ug_n_chrono")
ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.chrono)),
dir.create(file.path(chm.obj, ug.analysis.n.chrono)),
FALSE)
chm.analysis.n.chrono <- paste0(file.path(chm.obj, ug.analysis.n.chrono),'/')
# dimensions
ug.analysis.n.dim <- paste0(obj.analysis,"/ug_n_dimensions")
ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.dim)),
dir.create(file.path(chm.obj, ug.analysis.n.dim)),
FALSE)
chm.analysis.n.dimensions <- paste0(file.path(chm.obj, ug.analysis.n.dim),'/')
# orientations
ug.analysis.n.orient <- paste0(obj.analysis,"/ug_n_orientations")
ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.orient)),
dir.create(file.path(chm.obj, ug.analysis.n.orient)),
FALSE)
chm.analysis.n.orientations <- paste0(file.path(chm.obj, ug.analysis.n.orient),'/')
# proximities
ug.analysis.n.proximities <- paste0(obj.analysis,"/ug_n_proximities")
ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.proximities)),
dir.create(file.path(chm.obj, ug.analysis.n.proximities)),
FALSE)
chm.analysis.n.proximities <- paste0(file.path(chm.obj, ug.analysis.n.proximities),'/')
# closeness
ug.analysis.n.centralities <- paste0(obj.analysis,"/ug_n_centralities")
ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.centralities)),
dir.create(file.path(chm.obj, ug.analysis.n.centralities)),
FALSE)
chm.analysis.n.centralities <- paste0(file.path(chm.obj, ug.analysis.n.centralities),'/')
#### ugs clustering, regression, etc.
obj.clustering <- paste0(select.obj,"/analysis2D")
ifelse(!dir.exists(file.path(chm.obj, obj.clustering)),
dir.create(file.path(chm.obj, obj.clustering)),
FALSE)
chm.clustering <- paste0(file.path(chm.obj, obj.clustering),'/')
# themes - - - - - - - -
offset.img <- 0 # default value
# to shorter names of common links
new.col.nmes <- c(LETTERS,
paste0("A",LETTERS),
paste0("B",LETTERS),
paste0("C",LETTERS),
paste0("D",LETTERS),
paste0("E",LETTERS),
paste0("F",LETTERS),
paste0("G",LETTERS),
paste0("H",LETTERS),
paste0("I",LETTERS),
paste0("J",LETTERS))
# les types d'étude
NWvoisins <- TRUE
NWobj_reel <- TRUE
NWvoisins_spatial <- TRUE
AFattributs <- TRUE # va lire un fichier sorti de python
spatial <- TRUE
# flags
flag.dendro.color <- F
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# distances étudiées
dist <- 1
# parametres des tableuax
mythm <- ttheme_default(base_size = 7)
# parametres des graphes
siz.txt <- 3;lgd.size <- 8;symb.size <- 2
# parametres des tableaux
nb.col.tab <- 3;size.txt.tab <- 7;padd.tab <- 1
# par défaut
supp_var <- supp_ind <- nclust <- NA # par défaut
doss_geo <- "D:/Projet Art Rupestre/Sources/1_CONTINENTS/Europe/ADMIN/"
# \fontspec{Arial}
#library(dendextend)
# - - - - - - - - - - - - - - -
# spatial
spat.marg <- 0.5 # buff margin for map ggplot (in ° lat/long)
#chm.spat.admin <- "D:/Projet Art Rupestre/Sources/1_CONTINENTS/Europe/ADMIN"
wgs84 <- "+proj=longlat +datum=WGS84 +ellps=WGS84 +towgs84=0,0,0"
# list of shapefiles background
lspat.bck.grd <- list(
# call name, path folder, shapefile name
list("FFF","chm FFF","shapefile FFF"),
list("Europe","D:/Projet Art Rupestre/Sources/1_CONTINENTS/Europe/ADMIN","Europe_2012")
)
# functions - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Expert <- F
# layout.df.objects <- function(df.objects,gs){
# # take df.objects from 'objects' or 'family' and make some changes
# df.objects$lbl <- paste0(df.objects$site,'.',df.objects$numero) # lbl
# df.objects$img <- gsub('%20',' ',df.objects$img) # remove %20 used by windows
# df.objects <- df.objects[match(gs$lbl, df.objects$lbl),] # reorder on graphs
# df.objects$idf.objects <- rownames(df.objects) <- 1:nrow(df.objects) # rename
# return(df.objects)
# }
f.superfam.update <- function(superfam){
## get the list with the 'superfamily' name and the subfamilies and update Pg 'objects' table
## superfam <- superf.all
# TODO: get index instead of first [[1]]
# select.superfamily
superfam.nme <- superfam.all[[1]][[1]]
families.nmes <- superfam.all[[1]][[2]]
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
for (a.family in families.nmes){
# i <- 1
sqll <- paste0("update objets set famille_super='",superfam.nme,"' where famille='",a.family,"'")
# print(sqll)
dbGetQuery(con,sqll)
print(paste0("'famille_super' field of 'object' table is updated for '",a.family,"' family"))
}
dbDisconnect(con) # disconnect
}
# f.superfam.update("steles Bz du SO europeen")
f.var <- function(tab.var){
# return a table with list of attributes, colors, etc.
# ex: return 'mp' and 'mp_color' from "mp" Pg table
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
tab_var <- dbGetQuery(con,paste0("SELECT * FROM ",tab.var))
dbDisconnect(con) # disconnect
return(tab_var)
}
objects.df <- function(gs){
# selections on table 'objects'
# gs <- graphs ; gs <- graphs.objects
# create list
lobj.sit <- paste0("('",paste0(gs$site,collapse="','"),"')")
lobj.num <- paste0("('",paste0(gs$numero,collapse="','"),"')")
# the selection
sqll.SELECT <- paste0("site,numero,self,type,famille as fam, mp,incomplet,",
"tpq,taq,chr_1,tpq_cul,taq_cul,tp_taq_dat,",
"long,larg,epai,",
"ST_X(geom) as x,ST_Y(geom) as y, img")
# condition & order
sqll <- paste0("select ",sqll.SELECT," from objets WHERE site IN ",
lobj.sit," AND numero IN ",
lobj.num)
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
df.objects <- dbGetQuery(con,sqll);dbDisconnect(con)
# take df.objects from 'objects' or 'family' and make some changes
df.objects$lbl <- paste0(df.objects$site,'.',df.objects$numero) # lbl
df.objects$img <- gsub('%20',' ',df.objects$img) # remove %20 used by windows
# self
df.objects$self.shp <- NA
df.objects$self[is.na(df.objects$self)] <- ""
df.objects$self.shp <- ifelse(df.objects$self == "",16, # circle
ifelse(df.objects$self=='anthropomorphe',15, # square
16))
# incomplet
df.objects$incomplet[is.na(df.objects$incomplet)] <- 0
# get graphs idf
graphs.idf <- subset(gs,select=c("lbl","idf"))
df.objects <- merge(df.objects,graphs.idf,by="lbl",all.x=T)
# replace NA in idf by 999*
for (i in 1:nrow(df.objects)){
start.idf.miss <- 9900
if(is.na(df.objects[i,"idf"])){
df.objects[i,"idf"] <- start.idf.miss
start.idf.miss <- start.idf.miss+1
}
}
# reorder and rename
df.objects <- df.objects[match(gs$lbl, df.objects$lbl),] # reorder on graphs
# df.objects$idf <- rownames(df.objects) <- 1:nrow(df.objects) # rename
#df.objects <- layout.df(df.objects,gs)
return(df.objects)
}
family.df <- function(select.family){
# selections on table 'objects'
# the selection
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
sqll.SELECT <- paste0("site,numero,self,type,mp,",
"tpq,taq,chr_1,tpq_cul,taq_cul,tp_taq_dat,",
"long,larg,epai,",
"ST_X(geom) as x,ST_Y(geom) as y, img")
# condition & order
sqll <- paste0("select ",sqll.SELECT," from objets ",
"WHERE famille like '",select.family,
"' ORDER BY site,numero")
df.family <- dbGetQuery(con,sqll)
df.family$lbl <- paste0(df.family$site,'.',df.family$numero) # lbl
df.family$img <- gsub('%20',' ',df.family$img) # remove %20 used by windows
df.family$idf.objects <- rownames(df.family) <- 1:nrow(df.family) # rename
## aestethic
# mp color
df.mp <- dbGetQuery(con,"SELECT * FROM mp")
# NA <- "black" by default
# df.mp$mp_colors <- ifelse(is.na(df.mp$mp_colors),"black",df.mp$mp_colors)
# merge
df.family.merg <- merge(df.family,df.mp,by="mp",all.x=T)
df.family.merg$mp[is.na(df.family.merg$mp)] <- 'unknown'
df.family.merg$mp_colors[is.na(df.family.merg$mp_colors)] <- 'black'
# reorder on site/decor
df.family.merg <- df.family.merg[with(df.family.merg, order(site,numero)), ]
#df.family <- layout.df(df.family,gs)
dbDisconnect(con)
return(df.family.merg)
}
#crp <- family.df(select.family)
map.colors <- function(var,df){
# colors for 'mp','self',etc.
for (r in 1:nrow(df)){
if (!is.na(df[,var])){
if(var == "mp"){
}
}
}
}
family.ico.df <- function(select.family){
sqll <- paste0(
"SELECT table_noeuds.site,table_noeuds.decor,table_noeuds.structure,",
"table_noeuds.id,table_noeuds.type,table_noeuds.technologie,objets.famille,objets.img,",
"ST_X(objets.geom) as x, ST_Y(objets.geom) as y ",
"FROM table_noeuds,objets WHERE table_noeuds.site=objets.site ",
"AND table_noeuds.decor=objets.numero ",
"AND objets.famille like '",select.family,"' ",
"ORDER by site, decor;"
)
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
family.spat <- dbGetQuery(con,sqll)
family.spat$lbl <- paste0(family.spat$site,'.',family.spat$decor,'.',family.spat$id)
dbDisconnect(con) # disconnect
return(family.spat)
}
ugs.select.df <- function(select.family,corpus){
# this is the generalisation of 'ugs_x_family.df' function
# selection of ugs from selected objects or family
# corpus <- "objects" ; select.family <- "stele alentejo"
sqll.SELECT <- paste0(
"SELECT table_noeuds.site,table_noeuds.decor,table_noeuds.structure,",
"table_noeuds.id,table_noeuds.type,objets.famille,",
"table_noeuds.long,table_noeuds.sens,objets.img,",
"ST_X(table_noeuds.geom) as x_ug, ST_Y(table_noeuds.geom) as y_ug,",
"ST_X(objets.geom) as x_obj, ST_Y(objets.geom) as y_obj ",
"FROM table_noeuds,objets WHERE table_noeuds.site=objets.site ",
"AND table_noeuds.decor=objets.numero ")
if(corpus == 'family'){
sqll.SELECT <- paste0(sqll.SELECT,"AND objets.famille LIKE '",select.family,"' ")
}
if(corpus == 'objects'){
gs <- create.graph.view(v.select.obj,corpus) # call function to create view
objets <- objects.df(gs)
lobj.sit <- paste0("('",paste0(gs$site,collapse="','"),"')")
lobj.num <- paste0("('",paste0(gs$numero,collapse="','"),"')")
# sqll <- paste0("select ",sqll.SELECT," from objets WHERE site IN ",
# lobj.sit," AND numero IN ",
# lobj.num)
sqll.SELECT <- paste0(sqll.SELECT,"AND objets.site IN ",lobj.sit,
" AND objets.numero IN ",lobj.num)
}
# order,
sqll.ORDER <- paste0(sqll.SELECT," ORDER by site,decor;")
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
ugs <- dbGetQuery(con,sqll.ORDER)
dbDisconnect(con) # disconnect
return(ugs)
}
ugs_x_family.df <- function(select.family){
# selection of ugs within a family
sqll <- paste0(
"SELECT table_noeuds.site,table_noeuds.decor,table_noeuds.structure,",
"table_noeuds.id,table_noeuds.type,objets.famille,",
"table_noeuds.long,table_noeuds.sens,objets.img,",
"ST_X(table_noeuds.geom) as x_ug, ST_Y(table_noeuds.geom) as y_ug,",
"ST_X(objets.geom) as x_obj, ST_Y(objets.geom) as y_obj ",
"FROM table_noeuds,objets WHERE table_noeuds.site=objets.site ",
"AND table_noeuds.decor=objets.numero ",
"AND objets.famille LIKE '",select.family,"' ",
"ORDER by site,decor;"
)
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
ugs <- dbGetQuery(con,sqll)
dbDisconnect(con) # disconnect
return(ugs)
}
ugs.df <- function(select.thm){
# select.thm <- "casque"
sqll.ugs <- paste0("SELECT site,decor,famille,ST_X(geom) as x,ST_Y(geom) as y FROM objets
WHERE famille like '",select.family,"' ORDER BY site,numero")
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
ugs.spat <- dbGetQuery(con,sqll.ugs)
dbDisconnect(con) # disconnect
return(family.spat)
}
f.chm.ug <- function(select.thms){
# create out folder for ug if not exist
for (sel.thm in select.thms){
# sel.thm <- select.thm
chm.ico.ug <- paste0(chm.ug.typo,sel.thm,"/")
ifelse(!dir.exists(chm.ico.ug),
dir.create(chm.ico.ug),
FALSE)
}
}
create.graph.view <- function(typ.select,typ.v){
## create postgis view for of decors based on
## list of selected "objects" or "family" or "super.family"
## return a dataframe with idf of all decorations
# typ.v <- "objects"; typ.v <- "family"; typ.select <- v.select.family
# typ.select <- "ico_l_var_cs"; typ.v <- "objects"
# typ.select <- "ico_l_miscellaneous" ; typ.v <- "objects"
# typ.select <- v.select.family ; typ.v <- "family"
# typ.select <- v.select ; typ.v <- "super.family"
sll.DROP <- paste0("DROP VIEW IF EXISTS ",typ.select)
sqll.ldec <-paste0(
"CREATE OR REPLACE VIEW ",typ.select," AS SELECT objets.site,objets.structure,
objets.numero,objets.type,objets.self,objets.tpq, objets.taq,objets.chr_1,
objets.tpq_cul,objets.taq_cul,objets.geom,objets.img,objets.id,objets.famille
as fam FROM objets ")
sqll.order <- " ORDER BY objets.famille, objets.site,objets.numero;"
# condition for SQL postgis
sqll.condition <- "WHERE "
# selected objects xor families xor super.familiers
if (typ.v == "objects"){
for (a.dec in 2:length(ldecors)){ # avoid the title
# a.dec <- 2
sit <- as.character(ldecors[[a.dec]][1])
num <- as.character(ldecors[[a.dec]][2])
print(paste(sit,num))
if (num == ''){
# all objects of this site
sqll.condition <- paste0(sqll.condition,"objets.site LIKE '", sit,"' OR ")
}
if (num != ''){
sqll.condition <- paste0(sqll.condition,"(objets.site LIKE '",sit,
"' AND objets.numero LIKE '",num,"') OR ")
}
}
sqll.condition <- gsub('.{4}$', '', sqll.condition) # remove the 4 least characters (" OR ")
}
if (typ.v == "family"){
sqll.condition <- paste0(sqll.condition,"objets.famille LIKE '", select.family,"'")
}
if (typ.v == "super.family"){
# test if 'famille_super' Pg field has the same value
sqll.condition <- paste0(sqll.condition,"objets.famille_super LIKE '",
eval(parse(text = select.choice)),"'")
}
# conca sqll
sqll.completed <- paste0(sqll.ldec,sqll.condition,sqll.order)
# cat(sqll.completed,sep="\n")
# connect
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
# drop view if exists
dbGetQuery(con,sll.DROP)
# create the Postgis view
dbGetQuery(con,sqll.completed)
# select from this view
sqll <- paste0("select site,numero,self,fam from ",typ.select)
# sqll <- paste0("select site,numero,self from ",typ.select)
graphs <- dbGetQuery(con,sqll)
graphs$idf <- 1:nrow(graphs) # idfs of graphs
graphs$lbl <- paste0(graphs$site,'.',graphs$numero)
dbDisconnect(con) # disconnect
return(graphs)
}
f.df.ico <- function(v.select){
# read the posgres view
# TODO: try to rm this unnecessary functio
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
# list ico
sqll.ico <- paste0("SELECT site,structure,numero,img FROM ",v.select)
df.icos <- dbGetQuery(con,sqll.ico);dbDisconnect(con)
df.icos$img <- gsub('%20',' ',df.icos$img) # remove %20 used by windows
df.icos$idf <- paste0(df.icos$site,'.',df.icos$numero)
return(df.icos)
}
f.g.infos <- function(l.of.graph){
# get infos from graph
# l.of.graph <- lgrph
df.graph.infos <- data.frame(idf=numeric(0),
site=character(0),
decor=character(0),
n.nodes=integer(0),
n.edges=integer(0),
diam=numeric(0),
dens=numeric(0),
n.comp=numeric(0),
est.simp=character(0),
stringsAsFactors = F)
# plot number of components
for (a.g in 1:length(l.of.graph)){
# a.g <- 1
ga <- l.of.graph[[a.g]]
# id <- a.g
site <- as.character(unique(V(ga)$site))
decor <- as.character(unique(V(ga)$decor))
idf <- as.character(unique(V(ga)$idf))
n.nodes <- gorder(ga)
n.edges <- gsize(ga)
# n.nodes <- as.integer(length(V(ga)))
# n.edges <- as.integer(length(E(ga)))
diam <- diameter(ga,directed=F,unconnected=F,weights=NULL)
dens <- round(graph.density(ga),2)
n.comp <- components(ga)$no
est.simp <- as.integer(is.simple(ga))
new.g.infos <- c(idf,site,decor,n.nodes,n.edges,diam,dens,n.comp,est.simp)
df.graph.infos[nrow(df.graph.infos)+1,] <- new.g.infos
# df.graph.infos <- rbind(df.graph.infos,
# c(id,site,decor,n.nodes,n.edges,n.comp))
}
return(df.graph.infos)
}
load.graphs <- function(gs){
# load graphs from list of objects
# return list of graphs and list of non graphs (none edges)
# gs <- graphs
lgrph <- lgrph.no <- list() # list of graphs and non graphs
lgrph_nmes <- c() # list of graphs names
num.indet <- 1 # to differentiate 'indet' nodes
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
print("* load graphs *")
for (r in 1:nrow(gs)){
#r <- 3; gs <- graphs.objects
#r <- 6; gs <- graphs.family
# gs <- g
# select nodes
idf.g <- gs[r,"idf"]
sit.g <- gs[r,"site"]
numero.g <- gs[r,"numero"]
print (paste0(" ",r,"-",sit.g," . ",numero.g))
# nodes - - - -
sqll_a <- paste0("SELECT id as name,id as id, type,ST_X(geom) as x, ST_Y(geom) as y,",
"site,decor from table_noeuds ")
sqll_b <- paste0("WHERE site ='",sit.g,"' AND decor='",numero.g,"'")
sqll_ab <- paste0(sqll_a,sqll_b)
nodes <- dbGetQuery(con,sqll_ab)
#print (sqll_ab)
if (nrow(nodes)>0){
# only for graphs
# nodes - - - - -
# at least one node
# add an incremented suffix to differentiate 'indet' nodes
for (n in 1:nrow(nodes)){
typ.n <- nodes[n,"type"]
if (typ.n == "indet"){
nodes[n,"type"] <- paste0(typ.n,num.indet)
num.indet <- num.indet+1
}
}
# links - - - -
sqll_c <- "SELECT a,b,typ,site,decor FROM table_liens "
sqll_d <- paste0("WHERE site ='",sit.g,"' AND decor='",numero.g,"'")
sqll_cd <- paste0(sqll_c,sqll_d)
links <- dbGetQuery(con,sqll_cd)
if (length(links)>0){
g <- graph_from_data_frame(links, directed=F, vertices=nodes)
# name and attributes
g$name <- paste0(sit.g,'.',numero.g)
g$id.in.serie <- r # an absolute number in the serie, useful when sampling
g <- set_edge_attr(g, "nd.a", index = E(g), links$a)
g <- set_edge_attr(g, "nd.b", index = E(g), links$b)
# index of _na ugs and remove
NAs <- which(V(g)$type == "_na"); g <- g - NAs # remove _na ugs
# TODO : traduire les types
V(g)$name <- V(g)$type # remplace les numeros par leur types
V(g)$idf <- idf.g
# append to list
lgrph[[length(lgrph)+1]] <- g # graph_from_data_frame(links, directed = F, vertices = NULL)
}
if (length(links)==0){
lgrph.no[[length(lgrph.no)+1]] <- paste0(sit.g,'.',numero.g)
print(" NO EDGES")
}
}
}
dbDisconnect(con)
l.out <- list(lgrph,lgrph.no)
return(l.out)
}
rm.specific.nd <- function(l.of.graph,xthm){
# create new edges between nodes adjacent to specific nodes
# before deleting specific nodes (ex. xthm="indet")
# without deleting xthm when they are attributes
# return a clean list of graphs
#l.of.graph <- lgrph; xthm <- "indet"
l.graph.out <- list() # output
for (a.g in 1:length(l.of.graph)){
# a.g <- 1
# loop through graphs
ga <- l.of.graph[[a.g]] # ex. 14 = Capilla 3
#plot(ga,main=ga$name)
if (!any(str_detect(V(ga)$name,xthm))){
#if (!(xthm %in% V(ga)$name)){
# the specific thm is not in the graph, keep original graph
print(paste0(a.g,'.',ga$name," | total number of nodes: ",length(V(ga))))
l.graph.out[[length(l.graph.out)+1]] <- ga
}
if (any(str_detect(V(ga)$name,xthm))){
#if (xthm %in% V(ga)$name){
# the specific thm is in the graph
print(paste0(a.g,'.',ga$name," | total number of nodes: ",length(V(ga))))
print(' - there is nodes to merge')
# put vertices names to new column to avoid error on duplicated rownames
ga <- set.vertex.attribute(ga, "type", value=V(ga)$name)
V(ga)$name <- 1:length(V(ga)) # rename vertices
ids.n <- igraph::as_data_frame(ga, what="vertices")
a.sit <- unique(ids.n$site);a.dec <- unique(ids.n$decor)
ids.n$idx.in.graph <- 1:nrow(ids.n) # ids from graph
names(ids.n)[names(ids.n)=="id"] <- "idx.in.sig"
ids.n.sub <- subset(ids.n, select=c("idx.in.graph","idx.in.sig","type"))
idxs <- which(str_detect(ids.n.sub$type,xthm)) # get indexes when match
for (idx in idxs){
# replace 'indetx' by 'indet'
ids.n.sub[idx,"type"] <- 'indet'
}
l.n.xthm <- as.character(ids.n.sub[ids.n.sub$type == xthm,]$idx.in.graph) # get number in graph
# plot(ga)
for (n.xthm in l.n.xthm){
#n.xthm <- "18"
adj.edges <- E(ga)[from(n.xthm)]
a.adj.edge <- as_ids(adj.edges)
#a.adj.edge <- paste0(as_ids(adj.edges),collapse = "|") # a string
a.adj.edge <- strsplit(a.adj.edge, "\\|") # split
a.adj.edge <- a.adj.edge[[1]] # split
# check if the specific xthm is an attribute ('+')
edg.id <- get.edge.ids(ga, c(a.adj.edge[1],a.adj.edge[2]))
xthm.is.attr <- edge.attributes(ga,edg.id)$typ == '+' # test if attribute, can be NA
# if result of test is NA, then F
ifelse(is.na(xthm.is.attr), xthm.is.attr <- F, xthm.is.attr <- T)
if (!xthm.is.attr){
# remove the xthm node from the edge list if not attribute
a.adj.edge <- a.adj.edge[!a.adj.edge == n.xthm]
if (length(a.adj.edge)==1){
# only one adjacent edge to specific thm
df.adj.edge <- as.matrix(data.frame(a=c(a.adj.edge),b=c(n.xthm)))
}
if (length(a.adj.edge)>1){
# more than one adjacent edge to specific thm
df.adj.edge <- t(combn(a.adj.edge, 2)) # all pairwise edges
}
# add edges with attributes
for (e in 1:nrow(df.adj.edge)){
#e <- 1
a <- df.adj.edge[e,1];b <- df.adj.edge[e,2]
if (!are.connected(ga, a, b)){
# add new edge with attributes when no connections
ga <- add_edges(ga,c(a,b),
attr=list(typ=NA,
site=a.sit,
decor=a.dec))
}
}
# remove the selected n.xthm node
print (paste0(" - remove node: ",n.xthm))
ga <- delete.vertices(ga,n.xthm)
}
}
#is.simple(ga.n); ga.n <- simplify(ga.n) # avoid multiedges
# rehab ancient names
V(ga)$name <- get.vertex.attribute(ga, "type", index=V(ga))
print(paste0(" = the new total number of nodes is: ",length(V(ga))))
# strore clean graph
l.graph.out[[length(l.graph.out)+1]] <- ga
}
}
return(l.graph.out)
}
df.nodes.are.attributs <- function(grph){
# create a df of all nodes which are nodes atributes
# ex: 1 -+- 2, node 2 is recorded
# grph <- graphs ; grph <- graphs.family
lgrph <- load.graphs(grph)[[1]]
df.nd.attributs <- data.frame("site"=character(),
"decor"=character(),
"nd.b"=character(),
"to"=character(),stringsAsFactors=FALSE)
for (i in 1:length(lgrph)){
g <- lgrph[[i]]
df <- igraph::as_data_frame(g, what="edges")
df <- subset(df, typ == '+')
# attributes are always 'b' nodes
df <- subset(df, select=c("site","decor","nd.b","to"))
df.nd.attributs <- rbind(df.nd.attributs,df)
}
df.nd.attributs$lbl <- paste0(df.nd.attributs$site,'.',df.nd.attributs$decor,'.',df.nd.attributs$nd.b)
return(df.nd.attributs)
}
rm.by.edge.type <- function(g,edge.type){
# remove nodes from graph depending on edge types (ex: '+')
# return a graph
# g <- lgrph[[4]] ; edge.type <- '+'
# plot(g)
a.df <- igraph::as_data_frame(g, what="edges")
a.df <- a.df[a.df$typ == edge.type,] # select edges by type
a.df <- a.df[!is.na(a.df$from),]
#as.numeric(row.names(a.df)) # these edges are attributes
# delete edges
g1 <- delete.edges(g, as.numeric(row.names(a.df)))
v.ids <- V(g1)$id
# remove attributes nodes
attribute.node <- unique(a.df$nd.b)
nd.to.rm <- match(attribute.node,v.ids)
#g2 <- delete.vertices(g1, 9)
g2 <- delete.vertices(g1, nd.to.rm)
# plot(g)
# # remove isolated new nodes
# isolated = which(degree(g)==0)
# g <- delete.vertices(g, isolated)
return(g2)
}
ug.select.obj <- function(gs){
# select ug which are in the list of graphs 'graphs'
# gs <- objets
lugs.sit <- paste0("('",paste0(gs$site,collapse="','"),"')")
lugs.num <- paste0("('",paste0(gs$numero,collapse="','"),"')")
# the selection
sqll.temp.ugs <- paste0("site,decor,id,type,",
"long,long_cm,larg,larg_cm,dim_is_abs,incomplet,",
"tpq,taq,chr_1,tpq_cul,taq_cul,tp_taq_dat,",
"ST_X(geom) as x_ug, ST_Y(geom) as y_ug")
sqll.ugs <- paste0("select ",sqll.temp.ugs," from table_noeuds WHERE site IN ",
lugs.sit," AND decor IN ",
lugs.num)
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
df.ugs <- dbGetQuery(con,sqll.ugs);dbDisconnect(con)
# na <- 'xxx'
my.cols <- c("chr_1","tpq_cul","taq_cul")
df.ugs[,my.cols][is.na(df.ugs[,my.cols])] <- 'xxx'
# na <- '0'
my.cols <- c("incomplet")
df.ugs[,my.cols][is.na(df.ugs[,my.cols])] <- 0
return(df.ugs)
}
f.ugs.incomplete <- function(lgrph, compl.threshold, contactsheet, n.col){
# return a vector with indices of too incomplete decorations
# 'compl.threshold' is the threshold in % for sampling most complete decoration
# 'contactsheet' if TRUE create a contactsheet of pie charts counting (in)complete ugs by decoration
# 'n.col' is the nb of columns
alpha.val <- 0.3
lugs.compl <- list() # list for pie charts
lugs.incompl <- c() # for indexes of incomplete
for (i in 1:length(lgrph)){
# i <- 1
g <- lgrph[[i]]
list.vertex.attributes(g)
a.site <- unique(get.vertex.attribute(g, "site", index=V(g)))
a.dec <- unique(get.vertex.attribute(g, "decor", index=V(g)))
print(paste0(i," *read ", a.site," . ", a.dec))
a.decoration <- nodes.df(a.site,a.dec)
a.decoration.compl <- as.data.frame(table(a.decoration$incomplet)) # get the count
ct.complete <- a.decoration.compl[a.decoration.compl$Var1 == 0,"Freq"]
ct.incomplete <- a.decoration.compl[a.decoration.compl$Var1 == 1,"Freq"]
alpha.threshold <- 1 # by default
# test completness of ugs
if (length(ct.incomplete) > 0){ # get if value exist
if(ct.incomplete > 0){ # get when exist incomplete
if(length(ct.complete) > 0){ # get when exist incomplete
compl.vs.incompl <- ct.complete/(ct.complete+ct.incomplete)
alpha.threshold <- ifelse(compl.vs.incompl >= compl.threshold, 1, alpha.val)
}
if(length(ct.complete) == 0){ # there's no complete -> alpha
alpha.threshold <- alpha.val
}
}
}
# if incompletness, add to bad list
if (alpha.threshold != 1){lugs.incompl <- c(lugs.incompl,i)}
if(contactsheet){
# create a contactsheet
tit <- paste0(a.site,"\n",a.dec)
a.gg <- ggplot(data = a.decoration.compl, aes(x = "", y = Freq, fill = Var1)) +
ggtitle(tit)+
geom_bar(stat = "identity",
alpha = alpha.threshold) +
# alpha=) +
geom_text(aes(label = Freq),
color="black",
position = position_stack(vjust = 0.5),
cex=3,
alpha = alpha.threshold+0.2) +
coord_polar(theta = "y") +
blank_theme +
theme(plot.title = element_text(size = 7),
legend.position = "none",
axis.text.x=element_blank())+
scale_fill_manual(values=c("skyblue","orangered"))
lugs.compl[[length(lugs.compl)+1]] <- a.gg
}
}
if(contactsheet){
g.out <- paste0(chm.analysis.n.compl,"ug_complete.png")
a.tit <- paste0("counts of complete (blue) and incomplete (red) ugs by decoration",
"\nshaded decoration are those which have a percent of incomplete ugs",
"below the threshold (",compl.threshold*100," %)")
ggsave(file = g.out,
arrangeGrob(grobs = lugs.compl, ncol = n.col,
top = grid::textGrob(a.tit,x=0,hjust=0,gp = gpar(fontsize =9))),
width = n.col*2,
height = ceiling(length(lugs.compl)/n.col)*2)
}
# shell.exec(g.out)
return(lugs.incompl)
}
f.thm.orient.select <- function(select.obj){
# select themes in a list depending on a subgroup
# for orientations
for (i in 1:length(thm.orient.select.all)){
#i <- 1
if (thm.orient.select.all[[i]][[1]] == select.obj){
return(thm.orient.select.all[[i]][[2]])
}
}
}
nodes.df <- function(sit.1,num.1){
# get nodes data
sqll.temp.nds <- paste0("site,decor,id,type,sens,technologie,",
"long,long_cm,larg,larg_cm,incomplet,",
"chr_1,tpq,taq,",
"ST_X(geom) as x,ST_Y(geom) as y") # the selection
sqll.nodes <- paste0("select ",sqll.temp.nds," from table_noeuds WHERE site LIKE '",
sit.1,"' AND decor LIKE '",
num.1,"'")
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
df.nodes <- dbGetQuery(con,sqll.nodes);dbDisconnect(con)
# to merge raster and nodes, modify origin of nodes
df.nodes$y <- offset.img+df.nodes$y # add the offset
return(df.nodes)
}
edges.coordinates <- function(sit.1,num.1){
# get edges coordinates of a decoration
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
# extract coordinates of edges points(start and end)
sqll.temp.edg <- "site,decor,a,b,typ,ST_X(ST_StartPoint(geom)) as xa, ST_Y(ST_StartPoint(geom)) as ya,ST_X(ST_EndPoint(geom)) as xb, ST_Y(ST_EndPoint(geom)) as yb"
sqll.edges <- paste0("select ",sqll.temp.edg," from table_liens WHERE site LIKE '",
sit.1,"' AND decor LIKE '",
num.1,"'")
df.edges <- dbGetQuery(con,sqll.edges);dbDisconnect(con)
return(df.edges)
}
f.list.edges.type <- function(nd.a, nd.b){
# return df with edges listed and types of nodes
# could take a very long time...
# df.x_x <- f.list.edges.type("arc","fleche")
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
tab_var <- dbGetQuery(con,paste0("SELECT * FROM table_liens_type_a_b"))
dbDisconnect(con) # disconnect
# whether a-b or b-a
df.epee_ceinture <- tab_var[tab_var$type_a==nd.a & tab_var$type_b==nd.b,]
df.ceinture_epee <- tab_var[tab_var$type_a==nd.b & tab_var$type_b==nd.a,]
df.x_x <- rbind(df.epee_ceinture,df.ceinture_epee)
df.x_x <- df.x_x[order(df.x_x$site,df.x_x$numero),]
return(df.x_x)
}
edges.df <- function(n,dec,sit.1,num.1){
# sit.1 <- num.1 <- "Alamillo"; n <- dec <- 1
# sit.1 <- "Capilla"; num.1 <- "Capilla 8"; n <- dec <- 1
# n,dec,sit.1,num.1
# con <- dbConnect(drv,
# dbname="mailhac_9",
# host="localhost",
# port=5432,
# user="postgres",
# password="postgres")
# # extract coordinates of edges points(start and end)
# sqll.temp.edg <- "site,decor,a,b,typ,ST_X(ST_StartPoint(geom)) as xa, ST_Y(ST_StartPoint(geom)) as ya,ST_X(ST_EndPoint(geom)) as xb, ST_Y(ST_EndPoint(geom)) as yb"
# sqll.edges <- paste0("select ",sqll.temp.edg," from table_liens WHERE site LIKE '",
# sit.1,"' AND decor LIKE '",
# num.1,"'")
# df.edges <- dbGetQuery(con,sqll.edges);dbDisconnect(con)
# to merge raster and nodes, modify origin of edges
df.edges <- edges.coordinates(sit.1,num.1)
df.edges$ya <- offset.img+df.edges$ya # add the offset
df.edges$yb <- offset.img+df.edges$yb # add the offset
# get the relations
df.edges$relAB <- df.edges$relBA <- NA
for (edg in 1:nrow(df.edges)){
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
typo.rel <- df.edges[edg,"typ"] # relation type: normal(NA), attribute(+), etc.
if(is.na(typo.rel)){typo.rel<-'='}
# type of first node
sqll.typ.a <- paste0("select type from table_noeuds WHERE site LIKE '",
sit.1,"' AND decor LIKE '",num.1,"' AND id=",df.edges[edg,"a"])
typ.a <- dbGetQuery(con,sqll.typ.a)[1,1]
# type of second node
sqll.typ.b <- paste0("select type from table_noeuds WHERE site LIKE '",
sit.1,"' AND decor LIKE '",num.1,"' AND id=",df.edges[edg,"b"])
typ.b <- dbGetQuery(con,sqll.typ.b)[1,1]
dbDisconnect(con) # disconnect
# undirected, choice 'or' for comparisons
df.edges[edg,"relAB"] <- paste0(typ.a,typo.rel,typ.b) # ex. nez=epee
df.edges[edg,"relBA"] <- paste0(typ.b,typo.rel,typ.a) # ex. epee=nez
}
tot.edges <- f.tot.edges(lgrph)
used.LETTERS <- new.col.nmes[1:length(tot.edges)] # only used letters
df.edges$rel <- NA
df.edges$typ <- NULL
# loop through 'used.LETTERS' and add the corresponding letter
# in the edges dataframe
# edges with NA have already been suppressed
for (typ.rel in used.LETTERS){
letter.rel <- tot.edges[match(typ.rel,new.col.nmes)]
for (edg in 1:nrow(df.edges)){
if (df.edges[edg,"relAB"] == letter.rel | df.edges[edg,"relBA"] == letter.rel){
df.edges[edg,"rel"] <- used.LETTERS[match(typ.rel,new.col.nmes)]
}
}
}
df.edges$relAB <- df.edges$relBA <- NULL
#if(is.na(df.edges)){typo.rel<-'='}
df.edges.comp <- df.edges[complete.cases(df.edges), ] # remove NA
df.edges.comp$image.dec <- image.dec # add image path
return(df.edges.comp)
}
# edges
f.tot.edges <- function(lgrph){
# return all edges as a vector character
# lgrph <- load.graphs(graphs)[[1]] # load graphs
# lgrph <- lgraphs
tot.edges <- data.frame("V1"=character(),
"V2"=character(),
"typ"=character(),stringsAsFactors=FALSE)
# all unique type of edges
for(i in 1:length(lgrph)){
a.g <- lgrph[[i]]
#print(paste0(i,".",a.g$name))
g.edg <- as.data.frame(as_edgelist(a.g)) # edges
g.edg$typ <- edge.attributes(a.g)$typ # typ of edges
g.edg$typ[is.na(g.edg$typ)] <- "=" # change NA to =
# if (rm.attributes){
# g.edg <- g.edg[g.edg$typ != "+",]
# }
tot.edges <- rbind(tot.edges,g.edg)
}
#tot.edges$typ[is.na(tot.edges$typ)] <- "=" # change NA to =
# opt suppress duplicated
tot.edges <- tot.edges[!duplicated(t(apply(tot.edges[c("V1", "V2","typ")], 1, sort))), ]
tot.edges <- paste0(tot.edges[,1],tot.edges[,"typ"],tot.edges[,2]) # like "nez=vide"
return(tot.edges)
}
#ledges <- f.tot.edges()
f.typ.edges <- function(sel.edges,lgrph){
# presence/absence type of edge, to dataframe
df.typ_edges <- as.data.frame(matrix(nrow = length(lgrph),
ncol = length(sel.edges)))
# rename col and row
rownames(df.typ_edges) <- 1:length(lgrph)
colnames(df.typ_edges) <- sel.edges
df.typ_edges[is.na(df.typ_edges)] <- 0 # default empty cells
for (i in 1:length(lgrph)){
# graph have same idf in the list and in dataframes
#print(i)
#mat <- as_edgelist(lgrph[[i]])
mat <- as.data.frame(as_edgelist(lgrph[[i]])) # edges
mat$typ <- edge.attributes(lgrph[[i]])$typ # typ of edges
mat$typ[is.na(mat$typ)] <- "=" # change NA to =
for (j in 1:nrow(mat)){
#j <- 1
AB <- paste0(mat[j,1],mat[j,"typ"],mat[j,2])
BA <- paste0(mat[j,2],mat[j,"typ"],mat[j,1])
# undirected graphs
# fill with "nez=vide" or "vide=nez"
if (AB %in% colnames(df.typ_edges)){
df.typ_edges[i,AB] <- df.typ_edges[i,AB]+1 # add +1
}
if (BA %in% colnames(df.typ_edges)){
df.typ_edges[i,BA] <- df.typ_edges[i,BA]+1 # add +1
}
}
}
return(df.typ_edges)
}
f.sel.edges <- function(lgrph,rm.att){
# fill a new vector of edges without certain types (ex: +,..)
# rm.att <- c("+") ; rm.att <- c("")
tot.edges <- f.tot.edges(lgrph) # load all edges
sel.edges <- c()
if(length(rm.att)>0){
for (a.edg in tot.edges){
# loop through edges
for(att.to.rm in rm.att){
# loop through attributes to rm
if (att.to.rm == "+"){rm.regex <- grepl("\\+",a.edg)}
if (att.to.rm == ">"){rm.regex <- grepl(att.to.rm,a.edg)}
# if the edge has not a value to rm, add to 'sel.edges'
if(!rm.regex){sel.edges <- c(sel.edges,a.edg)}
}
}
}
if(length(rm.att)==0){sel.edges <- tot.edges}
return(sel.edges)
}
f.same.edges <- function(lgrph,rm.att){
# find same edges within a pairwise comparison of graphs
# get same edges, remove attributes (+, >, etc.) if needed
# output a square matrix
# rm.att: when empty, no remove
# lgrph <- load.graphs(graphs.objects) ; rm.att <- c("")
mat.same_edges <- matrix(nrow = length(lgrph),
ncol = length(lgrph))
mat.same_edges <- as.data.frame(mat.same_edges)
colnames(mat.same_edges)<- 1:ncol(mat.same_edges)
mat.same_edges[is.na(mat.same_edges)] <- 0 # replace NA
lgrph_nmes <- c()
for (i in 1:length(lgrph)){
lgrph_nmes <- c(lgrph_nmes,lgrph[[i]]$name)
#print (lgrph[[i]]$name)
}
# remove attributes (+, >, etc.) if 'rm.att' has values
ifelse (rm.att != "",
sel.edges <- f.sel.edges(lgrph,rm.att), # a selection
sel.edges <- f.tot.edges(lgrph) # no selection
)
# identify same edges btw graphs
df.typ_edges <- f.typ.edges(sel.edges,lgrph)
# at least a common edge appears 2 times, limit the df
df.typ_edges.sub <- df.typ_edges[,colSums(df.typ_edges) > 1]
for (c in 1:ncol(df.typ_edges.sub)){
#c <- 2
a.col <- df.typ_edges.sub[,c] # get column
# at least 2 decoration without 0
if(length(a.col[!a.col %in% 0]) > 1){
idxs <- which(a.col %in% c(1:100)) # count of egal betw 1 and Inf
all.comb <- subset(expand.grid(rep(list(idxs),2)), Var1 != Var2)
for (r in 1:nrow(all.comb)){
#r <- 1
x <- all.comb[r,"Var1"];y <- all.comb[r,"Var2"]
mat.same_edges[x,y] <- mat.same_edges[x,y]+1
mat.same_edges[y,x] <- mat.same_edges[y,x]+1
}
}
}
# divide all cells by 2 (sic)
mat.same_edges[] <- lapply(mat.same_edges, function(x) x/2)
colnames(mat.same_edges) <- row.names(mat.same_edges) <- lgrph_nmes
return(mat.same_edges)
}
f.edge.similarity <- function(df.same_edges,around){
# calculate the similarity as the product of nb
# of common edges divided by total number of edges
# m.cor <- data.frame(nrow = 1:nrow(df.same_edges),
# ncol = 1:nrow(df.same_edges))
m.cor <- data.frame(matrix(ncol = nrow(df.same_edges),
nrow = nrow(df.same_edges))
)
colnames(m.cor) <- 1:nrow(df.same_edges)
n.links <- c()
for (i in 1:length(lgrph)){
n.links <- c(n.links,gsize(lgrph[[i]]))
}
for (r in 1:nrow(df.same_edges)){
for (c in 1:ncol(df.same_edges)){
if (around){
# for heatmap ploting
m.cor[r,c] <- round(df.same_edges[r,c]/n.links[r],1)
}
if (!around){
# for dendrogram
m.cor[r,c] <- df.same_edges[r,c]
}
}
}
return(m.cor)
}
# return a dist matrix from same edges correlation
f.edge.dist <- function(df.edg.cor,grphs){
# populate lower triangle
df.edg.cor[lower.tri(df.edg.cor)] <- t(df.edg.cor)[lower.tri(df.edg.cor)]
lbls <- paste0(rownames(grphs),'.',grphs$site,'.',grphs$numero)
row.names(df.edg.cor) <- colnames(df.edg.cor) <- lbls
# get the exact name
# a.list.dec <- colnames(df.edg.cor)
# dendrog
dist.mat <- dist(df.edg.cor)
return(dist.mat)
}
f.dist.df <- function(lgrph){
# calculate distances btw nodes for each graphs
dist.df <- data.frame(Var1=character(0),
Var2=character(0),
value=character(0),
dec=character(0))
# length(lgrph)
for (i in 1:length(lgrph)){
# i <- 3
g <- lgrph[[i]]
print(paste0(i,") read distance for graph ",g$name))
g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>')
if(gsize(g) == 0){next}
# shorter paths
if (gsize(g) > 0){
# there a connexion at least
distmatrix <- shortest.paths(g, v=V(g), to=V(g))
distmatrix.melt <- reshape2::melt(distmatrix)
distmatrix.melt <- distmatrix.melt[distmatrix.melt$value != 0,] # remove selfes
distmatrix.melt$dec <- row.names(graphs[graphs$lbl==g$name,])
dist.df <- rbind(dist.df,distmatrix.melt)
}
}
dist.df <- dist.df[dist.df$value != Inf,]
# color nodes after dendrogramm
if (flag.dendro.color){
# merge on dendrogramm colors
df.colors <- subset(df.dist.mat.sel.ord,select=c("idf","color"))
dist.df <- merge(dist.df,df.colors,by.x="dec",by.y="idf")
}
if (!flag.dendro.color){dist.df$color <- "black"}
return(dist.df)
}
# spatial functions - - -- - - - - -
f.spat.bck.grd <- function(spat.bck.grd){
#spat.bck.grd <- "Europe"
# get background information
for (i in 1:length(lspat.bck.grd)){
# test
#i <- 2
a.match <- match(spat.bck.grd,lspat.bck.grd[[i]][1])
if (!is.na(a.match)){
chm.spat.bck <- unlist(lspat.bck.grd[[i]][2])
shp.spat.bck <- unlist(lspat.bck.grd[[i]][3])
#print(paste0("* read geometry '",shp.spat.bck,"' as geographical background *"))
sf.fd.carto <- st_read(dsn = chm.spat.bck, layer = shp.spat.bck) # read geo background
return(sf.fd.carto)
}
}
}
f.split.df <- function(sf.obj.tab,max.lign,sz.police){
# split a df depending on 'max.lign'
# max.lign <- 42 ; sf.obj.tab <- df.clss.spat ; sz.police <- 7
n.obj <- nrow(sf.obj.tab)
n.col.tab <- ceiling(n.obj/(max.lign+1)) # max.lign+1 because of iteration
ltab <- list()
mytheme.listing <- ttheme_default(base_size = sz.police,
padding = unit(c(2,2), "mm"))
if(n.col.tab > 1){
strt <- 1
for (i in 1:n.col.tab){
end<-strt+max.lign
print(paste0(strt,' ',end))
sub.obj <- sf.obj.tab[c(strt:end),] # select rows
ltab[[length(ltab)+1]] <- tableGrob(sub.obj,theme=mytheme.listing,rows=NULL)
strt<-end+1
}
}
# tgrob <- tableGrob(df.tab.c,
# theme = ttheme_default(base_size = 8,
# padding = unit(c(2,2), "mm")),
# cols = NULL,rows=F)
if(n.col.tab == 1){
ltab[[length(ltab)+1]] <- tableGrob(sf.obj.tab,theme=mytheme.listing,rows=NULL)
}
return(ltab)
}
f.xy.to.sp <- function(xy, ID=NULL) {
# creating a SpatialPolygons object from data.frame of coords
if(is.null(ID)) ID <- sample(1e12, size=1)
SpatialPolygons(list(Polygons(list(Polygon(xy)), ID=ID)),
# proj4string=CRS("+proj=merc"))
proj4string=CRS(wgs84))
}
f.spat.distrib <- function(obj,sf.fd.carto,map.type,map.name,v,n.rows,sz.police){
# YYY
# 'obj' is a dataframe with x and y columns
# 'bck.grd' is a sf background from the 'f.spat.bck.grd' function
# 'map.type' the type of map (ex: "family","archeo","ugs")
# 'map.name' the name of the map (ex: "stele alentejo")
# colored bt 'famille'
# export a map
# - - - - - - - - - - - - - -
# obj <- family.spat ; map.type <- "family" ; map.name <- "stele bouclier"
# obj <- ugs.spat ; map.type <-"ugs" ; map.name <-"casque"
# obj <- family.spat ; map.type <-"family" ; select.family <-"Aclasser" ; v <- "all"
# obj <- family.spat ; map.name <- "stele bouclier" ; v <- "all"
# obj <- family.spat ; map.name <- "stele bouclier" ; map.type <- "map.type" ; v <- "type"
# obj <- df.clss.spat ; map.name <- "super.family" ; map.type <- "super.family" ; v <- "clss"
#no.family <- "zz_nofamily"
# make some changes for archeo obj
# create field when not exists
fam <- c("famille" = select.family) # famille
obj <- add_column(obj, !!!fam[setdiff("famille", names(obj))])
nbr <- c("Freq" = 1) # famille
obj <- add_column(obj, !!!nbr[setdiff("Freq", names(obj))])
names(obj)[names(obj) == 'numero'] <- "decor" # replace colname
# modify output folder depending type of carto
#ifelse(map.type=="family", chm.loc.spatial <- chm.family, chm.loc.spatial <- chm.thm)
n.obj <- nrow(obj)
tit <- paste0("Distribution of all '",map.type,"' like '",map.name,"' (n=",n.obj,")")
#tit <- paste0("Distribution of all objects from '",map.name,"' ",map.type," (n=",n.obj,")")
sp.obj <- SpatialPointsDataFrame(coords = obj[,c("x","y")],
data = obj,
proj4string= CRS(wgs84))
sf.obj <- st_as_sf(sp.obj)
roi <- st_bbox(sf.obj) # create polygon from bbox on objets
# add margins
roi[1]<-roi[1]-spat.marg;roi[2]<-roi[2]-spat.marg;roi[3]<-roi[3]+spat.marg;roi[4]<-roi[4]+spat.marg
roi.sf <- st_as_sfc(roi) # create polygon from bbox on objets
# sf.fd.carto <- st_read(dsn = chm.spat.admin, layer = "Europe_2012") # read geo background
sf.fd.carto.inter <- st_intersection(sf.fd.carto, roi.sf) # recut background
#sf.fd.carto <- data.frame(sf.fd.carto)
# spatial - - - - - - - -
#objets.selected <- objets[objets$idf %in% grp.num.decs,]
#objets.selected.tab <- subset(objets.selected,select=c('idf','site','numero'))
g.map <- ggplot2::ggplot(sf.fd.carto.inter) +
geom_sf(aes(geometry = geometry),fill = NA)+
annotation_scale(location = "bl",
height = unit(0.15,"cm"),
width_hint = 0.2)+
#geom_point(data=objets, aes(x=x,y=y),cex=1)+
theme_bw() +
theme(axis.text = element_blank())+
#theme(plot.title = element_text(size = 7))+
theme(axis.ticks=element_blank())+
theme(panel.border=element_blank())+
theme(panel.grid = element_blank())+
theme(axis.title = element_blank())
if(v=="all"){
# TODO: adapt legend
g.map <- g.map +
geom_point(data=obj,
aes(x=x,y=y,fill=famille,color='black',cex=Freq*.5),
alpha = .50,
shape = 21) +
# geom_point(data=obj, aes(x=x,y=y,color=famille,cex=(Freq/3)+1.5))+
geom_text_repel(data=obj, aes(x=x,y=y,label=idf),color='black',size=2.5,
segment.alpha = 0.5,segment.size = 0.3) +
# legend
scale_size_continuous(breaks=sort(unique(obj$Freq)))+
#scale_size_continuous(breaks=c(0,1,2,3,4,5,10,25,50,100,500))+
theme(legend.title = element_text(size = 10),
legend.text = element_text(size = 8))+
labs(size = "nb")+
# change order
guides(color = guide_legend(order = 1),
size = guide_legend(order = 2)) +
theme(legend.position = "none") # no legend
}
if(v=="mp"){
g.map <- g.map +
geom_point(data=obj, aes(x=x,y=y,color=mp),cex=1.5) +
# scale_color_identity() +
# scale_fill_identity()
geom_text_repel(data=obj, aes(x=x,y=y,label=idf,color=mp),size=2.5,
segment.alpha = 0.5,segment.size = 0.3) +
scale_colour_manual(values=mp.colors)
# g.map <- g.map +
# geom_point(data=obj, aes(x=x,y=y,color=mp_colors),cex=1.5)+
# geom_text_repel(data=obj, aes(x=x,y=y,label=idf,color=mp_colors),size=2.5,
# segment.alpha = 0.5,segment.size = 0.3)+
# scale_color_identity()+
# scale_fill_identity()
}
if(v=="type"){
g.map <- g.map +
geom_point(data=obj, aes(x=x,y=y),cex=1.5)+
geom_text_repel(data=obj, aes(x=x,y=y,label=idf),size=2.5,
segment.alpha = 0.5,segment.size = 0.3)
# scale_color_identity()+
# scale_fill_identity()
}
if(v=="clss"){
# on dendrogram classifications
g.map <- g.map +
geom_point(data=obj, aes(x=x,y=y,color=color),cex=1.5)+
geom_text_repel(data=obj, aes(x=x,y=y,label=idf,color=color),size=2.5,
segment.alpha = 0.5,segment.size = 0.3)+
scale_color_identity()+
scale_fill_identity()
}
margin = theme(plot.margin = unit(c(0,0,0,0), "cm"))
# the tab of correspondances - - - - - - - - - - - -
if (map.type != 'super.family'){
select.fields.df <- c('idf','site','decor')
obj <- subset(obj,select=select.fields.df)
}
if (map.type == 'super.family'){
select.fields.df <- c('idf','site','decor','fam')
obj <- subset(obj,select=select.fields.df)
names(obj)[names(obj) == 'fam'] <- "famille"
}
ltab <- f.split.df(obj,n.rows,sz.police) # idf is necessary
n.col <- length(ltab)
corres.tab <- gridExtra::grid.arrange(grobs = ltab, ncol = n.col)
g.map <- list(g.map+margin,corres.tab)
return(g.map)
}
# g.map <- f.spat.distrib(family.ico.ct,sf.fd.carto,map.type,select.family,m.var) # create map
# layout functions - - - - - -
f.corresp.tab <- function(obj,max.lign){
# TODO: reduce margins
# split the df to plot long df
# obj <- ico.listing.var ; n.max.h <- 25
# obj <- df.g.infos ; max.lign <- 50
mytheme <- ttheme_default(
base_size = 7,
plot.margin = unit(c(0,0,0,0), "cm"),
core = list(padding=unit(c(1, 1), "mm"))
)
#margin = theme(plot.margin = unit(c(0,0,0,0), "cm"))
# the tab of correspondances
#sf.obj.tab <- subset(obj,select=c('site','decor'))
n.obj <- nrow(obj)
n.col.tab <- ceiling(n.obj/max.lign)
ltab <- list()
if(n.col.tab > 1){
# split into col
strt <- 1
for (i in 1:n.col.tab){
end <- strt+max.lign
print(paste0(strt,' ',end))
sub.obj <- obj[c(strt:end),] # select rows
sub.obj.na <- sub.obj[complete.cases(sub.obj[ ,3:6]),] # remove NA row if any
ltab[[length(ltab)+1]] <- tableGrob(sub.obj,rows=NULL) # break if NA (= all done)
if(nrow(sub.obj)>nrow(sub.obj.na)){break}
strt<-end+1
}
}
if(n.col.tab == 1){
# same as original
ltab[[length(ltab)+1]] <- tableGrob(obj,theme = mytheme,rows=NULL)
}
# margin = theme(plot.margin = unit(c(0,0,0,0), "cm"))
corres.tab <- gridExtra::grid.arrange(grobs = ltab, ncol= length(ltab))
#corres.tab <- gridExtra::grid.arrange(grobs = lapply(ltab, "+", margin))
return(corres.tab)
}
# adjust size of listing png depending on max
fpng.df <- function(df,nme){
#df <- df.g.infos
#nme.p <- paste0(chm.etude,"2-listing_variables.png")
conc.colnmes <- paste0(colnames(df),collapse = "")
conc.rows <- apply(df[ ,colnames(df) ],1,paste,collapse = "")
w.max <- max(nchar(conc.rows),nchar(conc.colnmes))
#paste0(as.character(ico.listing[1,]),collapse = '')
width.n <- w.max*35
#width.n <- max(nchar(paste0(df$idf,df$var)))*20
height.n <- nrow(df)*60
png(nme,res=150,width=width.n,height =height.n)
}
# # extract legend of ggplot
# g_legend<-function(a.gplot){
# tmp <- ggplot_gtable(ggplot_build(a.gplot))
# leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
# legend <- tmp$grobs[[leg]]
# legend
# }
ggsave_to_variable <- function(p,width,height,dpi){
# save ggplot as image-magick
# ggsave_to_variable <- function(p, width = 10, height = 10, dpi = 300){
# z.image,siz.of.img+1,siz.of.img,300
# pixel_width = (width * dpi) / 2.54
# pixel_height = (height * dpi) / 2.54
# img <- magick::image_graph(pixel_width, pixel_height, res = dpi)
# width <- img.a.w ; height <- img.a.h ; dpi <- 300 ; p <- a.image.graph.a
img <- magick::image_graph(width, height, res = dpi)
on.exit(utils::capture.output({
grDevices::dev.off()}))
plot(p)
return(img)
}
fdat.columned <- function(df,n_col){
# df <- df.table
# n_col <- 2
# met un dataframe en colonnes (largeur)
# n_col: nb de colonnes voulues # n_col <- 6
nenr_ <- ceiling(nrow(df)/n_col)
nrow_ <- as.integer(nenr_)
sit.df.plot <- data.frame(matrix(0, ncol = 1, nrow = nrow_))
n <- 0
for (i in seq(1,n_col)){
sup_ <- nrow_ + n
inf_ <- sup_-nrow_+1
ct <- i+1
idfs <- df[c(seq(inf_,sup_)),"idf"]
sites <- df[c(seq(inf_,sup_)),"numero"]
sit.df.plot <- cbind(sit.df.plot,idfs)
sit.df.plot <- cbind(sit.df.plot,sites)
n <- n+nrow_
}
sit.df.plot[,1] <- NULL
return(sit.df.plot)
}
g_legend<-function(a.gplot){
#extract legend
tmp <- ggplot_gtable(ggplot_build(a.gplot))
leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
legend <- tmp$grobs[[leg]]
return(legend)
}
t_reduce_col<-function(df){
# rename columns
colnames(df)[which(names(df)=="boucles_oreilles")] <- 'b_oreil'
colnames(df)[which(names(df)=="cardiophylax")] <- 'cardioph'
colnames(df)[which(names(df)=="casque_cornes")] <- 'casq_corn'
colnames(df)[which(names(df)=="epee_antennes")] <- 'ep_anten'
colnames(df)[which(names(df)=="epee_langue_carpe")] <- 'ep_carp'
colnames(df)[which(names(df)=="epee_pistilliforme")] <- 'ep_pistil'
colnames(df)[which(names(df)=="fibule_arco_violin")] <- 'fib_arc_viol'
colnames(df)[which(names(df)=="lance_lame_lanceol")] <- 'lance_lanceol'
colnames(df)[which(names(df)=="lance_lame_ovale")] <- 'lance_oval'
colnames(df)[which(names(df)=="sexe_masculin")] <- 'sexe_m'
return(df)
}
findex <- function(a.list,a.lname){
# found the index of the name in the list
ldec <- c()
for (i in 1:length(a.list)){
ldec <- unlist(c(ldec,a.list[[i]][1]))
}
return(match(a.lname,ldec))
}
ffind_index_graph <- function(gname){
# renvoie l'index du graph dont le nom est lu
ct <- 1
for (i in 1:length(lgrph)){
if (gname==lgrph[[i]]$name){
return (ct)
}
ct <- ct + 1
}
return (NA)
}
f.sample.coloramp.dist <- function(df){
# colormap with sample of labels on rounded vales
df$x <- as.integer(rownames(df))
df$x <- factor(df$x, levels = df$x)
df$y <- 0
df$lbl <- NA
the.range <- df$value
the.l.range <- nrow(df)
a.min <- min(the.range)
a.second.min <- sort(the.range, FALSE)[2]
a.20e <- the.range[ceiling(the.l.range/20)]
a.10e <- the.range[ceiling(the.l.range/10)]
a.5e <- the.range[ceiling(the.l.range/5)]
a.3e <- the.range[ceiling(the.l.range/3)]
a.2e <- the.range[ceiling(the.l.range/2)]
a.1.5e <- the.range[ceiling(the.l.range/1.5)]
a.max <- max(the.range)
the.sample <- c(a.min,a.second.min,a.20e,a.10e,a.5e,a.3e,a.2e,a.1.5e,a.max)
# select only samples values
for (i in 1:the.l.range){
a.val <- df[i,"value"]
if (a.val %in% the.sample){
df[i,"lbl"] <- round(a.val,1) # round values
}
}
return(df)
}
plot.a.graph <- function(g){
# retrun a simple plot of a graph
a.plot <- plot(g,
main=g$name,
vertex.label=paste0(V(g)$id,".",V(g)$type),
edge.label = E(g)$typ)
return(a.plot)
}
f.family.listdecoration <- function(select.obj){
# create planche of all the family object - - - - - - - - - - - - - - - - - - -
# select.obj <- select.family ; n.col <- 10
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
all.families <- dbGetQuery(con,"SELECT DISTINCT famille FROM famille")
famille.exist <- select.obj %in% all.families$famille # test if family exist
if (famille.exist){
# list ico
sqll.ico.planche <- paste0("SELECT site,numero,self,img FROM objets WHERE famille LIKE '",select.obj,"'")
df.sqll.ico.planche <- dbGetQuery(con,sqll.ico.planche)
df.sqll.ico.planche <- df.sqll.ico.planche[with(df.sqll.ico.planche, order(site,numero)), ]
#dim.planche <- c(3,5) # height & width in inches
n.row <- ceiling(nrow(df.sqll.ico.planche)/n.col)
# max.imgs <- dim.planche[1]*dim.planche[2]
empty.obj <- image_read(paste0(chm.obj,"/empty_obj.gif"))
ll.img.planche <- list()
for (im in 1:nrow(df.sqll.ico.planche)){
#im <- 6
enr <- df.sqll.ico.planche[im,]
idf.enr <- paste0(as.character(im),'.',enr[,"site"],"\n",enr[,"numero"])
self <- as.character(enr[1,"self"])
print(paste0(im,") read decoration: ",idf.enr))
img.enr.txt <- enr[,"img"]
img.enr.txt <- gsub('%20',' ',img.enr.txt) # remove %20 used by windows
# test if image exists
e.img <- any(str_detect(img.enr.txt,c(".jpg",".gif",".tif")))
na.img <- is.na(img.enr.txt)
if (e.img & !na.img){
img.enr <- image_read(img.enr.txt) # read
img.enr <- image_trim(img.enr)
}
if (!e.img | na.img){
# empty image
img.enr <- empty.obj
}
img.enr <- image_scale(img.enr,"1000x1000")
# support name
img.enr <- image_annotate(img.enr, idf.enr, size = 40,
gravity = "southwest", color = "black")
if(self=="anthropomorphe" & !is.na(self)){
# if anthropomorph support plot red square
img.enr <- image_annotate(img.enr, " ", size = 40,
gravity = "southeast",color = "red", boxcolor = "red")
}
ll.img.planche[[length(ll.img.planche)+1]] <- image_ggplot(img.enr)
}
# write
a.tit <- paste0(" nb total '",select.obj,"' : ",length(ll.img.planche),
"\nanthromorphic support are identified with red square")
a.marg <- 0.2
margin = theme(plot.margin = unit(c(a.marg,a.marg,a.marg,a.marg), "cm"))
for (dev in c(".png",".pdf")){
ggsave(file = paste0(chm.etude,"ico_contactsheet",dev),
arrangeGrob(grobs = lapply(ll.img.planche, "+", margin),ncol = n.col,
top = grid::textGrob(a.tit,x=0,hjust=0,gp = gpar(fontsize =8))),
width = n.col*3.5,
height = n.row*3.5)
}
}
dbDisconnect(con)
}
f.family.contactsheet <- function(select.obj,n.col){
# TODO fucking contact sheet
# create planche of all the family object - - - - - - - - - - - - - - - - - - -
# select.obj <- select.family ; n.col <- 3
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
all.families <- dbGetQuery(con,"SELECT DISTINCT famille FROM famille")
famille.exist <- select.obj %in% all.families$famille # test if family exist
if (famille.exist){
# exist family
# list ico
sqll.ico.planche <- paste0("SELECT site,numero,self,incomplet,img FROM ",
"objets WHERE famille LIKE '",select.obj,"'")
df.sqll.ico.planche <- dbGetQuery(con,sqll.ico.planche)
#df.sqll.ico.planche <- head(df.sqll.ico.planche) # sample
df.sqll.ico.planche <- df.sqll.ico.planche[with(df.sqll.ico.planche, order(site,numero)), ]
df.sqll.ico.planche$incomplet[is.na(df.sqll.ico.planche$incomplet)] <- 0
#dim.planche <- c(3,5) # height & width in inches
n.row <- ceiling(nrow(df.sqll.ico.planche)/n.col)
# max.imgs <- dim.planche[1]*dim.planche[2]
empty.obj <- image_read(paste0(chm.obj,"/empty_obj.gif"))
# ll.img.planche <- list()
# ll.img.planche.c <- c()
for (im in 1:nrow(df.sqll.ico.planche)){
# im <- 1
enr <- df.sqll.ico.planche[im,]
a.sit <- enr[,"site"]
a.num <- enr[,"numero"]
idf.enr <- paste0(as.character(im),'.',a.sit,"\n",a.num)
self <- as.character(enr[1,"self"])
# add (A) to anthromophe
if(self=="anthropomorphe" & !is.na(self)){
idf.enr <- paste0(idf.enr," (A)")
}
print(paste0(im,") read decoration: ",idf.enr))
img.enr.incomp <- enr[,"incomplet"]
img.enr.txt <- enr[,"img"]
img.enr.txt <- gsub('%20',' ',img.enr.txt) # remove %20 used by windows
# test if image exists
e.img <- any(str_detect(img.enr.txt,c(".jpg",".gif",".tif")))
na.img <- is.na(img.enr.txt)
if (e.img & !na.img){
img.enr <- image_read(img.enr.txt) # read
img.enr <- image_trim(img.enr)
}
if (!e.img | na.img){
# empty image
img.enr <- empty.obj
}
img.enr <- image_scale(img.enr,"1000x1000")
# support name
img.enr <- image_annotate(img.enr, idf.enr, size = 40,
gravity = "southwest", color = "black")
if(img.enr.incomp){
# if anthropomorph support plot red square
img.enr <- image_annotate(img.enr, " ", size = 40,
gravity = "southeast",color = "red", boxcolor = "red")
}
chm.out <- paste0(chm.corpus,a.sit,'_',a.num,'.png')
image_write(img.enr, path = chm.out, format = "png",flatten = T) # write 1 img
# ll.img.planche.c <- image_join(ll.img.planche.c,img.enr)
# ll.img.planche[[length(ll.img.planche)+1]] <- image_ggplot(img.enr)
}
}
# limgs <- list.files(chm.corpus)
# # setup plot
# # dev.off()
# while (!is.null(dev.list())) dev.off()
# par(mai=rep(0,4)) # no margins
# # layout the plots into a matrix w/ 12 columns, by row
# layout(matrix(1:length(limgs), ncol=n.col, byrow=TRUE))
# # do the plotting
# for(j in 1:length(limgs)) {
# # j <- 1
# a.img <- paste0(chm.corpus,limgs[j])
# a.img <- readPNG(a.img)
# plot(NA,xlim=0:1,ylim=0:1,xaxt="n",yaxt="n",bty="n")
# plot(NA,xlim=0:1,ylim=0:1,bty="n",axes=0,xaxs = 'i',yaxs='i')
# rasterImage(a.img,0,0,1,1)
# # a <- rasterGrob(a.img,interpolate=FALSE)
# }
#
# # write to PDF
# dev.print(pdf, "output.pdf")
#
#
#
# nchunks <- ceiling(length(ll.img.planche.c)/n.col)
# x.chk <- seq_along(ll.img.planche.c) # serie
# d1 <- split(ll.img.planche.c, ceiling(x.chk/nchunks))
# ico.images <- image_append(d1, stack = F)
# d1 <- split(ll.img.planche.c,nchunks)
# # write
# a.tit <- paste0(" nb total '",select.obj,"' : ",length(ll.img.planche),
# "\nincomplete supports are identified with red square",
# "\anthropomorph supports are identified with (A)")
# a.marg <- 0.2
# margin = theme(plot.margin = unit(c(a.marg,a.marg,a.marg,a.marg), "cm"))
# for (dev in c(".png")){
# ggsave(file = paste0(chm.etude,"ico_contactsheet",dev),
# arrangeGrob(grobs = lapply(ll.img.planche, "+", margin),ncol = n.col,
# top = grid::textGrob(a.tit,x=0,hjust=0,gp = gpar(fontsize =8))),
# width = n.col*3.5,
# height = n.row*3.5)
# }
# }
if (!famille.exist){
# select from decorations
}
dbDisconnect(con)
}
f.archeo <- function(select.thm){
# for archeo/real objets
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
sqll <- paste0("SELECT site,structure,numero as decor,type,tpq,taq,img,",
"ST_X(geom) as x,ST_Y(geom) as y ",
"FROM objets WHERE type LIKE '",select.thm,"'")
df <- dbGetQuery(con,sqll)
dbDisconnect(con)
return(df)
}
# f.archeo <- function(select.thm){
# # for archeo/real objets
# drv <- dbDriver("PostgreSQL")
# con <- dbConnect(drv,
# dbname="mailhac_9",
# host="localhost",
# port=5432,
# user="postgres",
# password="postgres")
# sqll <- paste0("SELECT site,structure,numero as decor,type,tpq,taq,img,",
# "ST_X(geom) as x,ST_Y(geom) as y ",
# "FROM objets WHERE type LIKE '",select.thm,"'")
# df <- dbGetQuery(con,sqll)
# dbDisconnect(con)
# return(df)
# }
f.ugs <- function(select.thm){
# select.thm <- "bracelet"
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
sqll <- paste0(
"SELECT table_noeuds.site,table_noeuds.decor,table_noeuds.id,",
"table_noeuds.long_cm,table_noeuds.incomplet,",
"table_noeuds.type,objets.img,",
"objets.famille,",
"ST_X(table_noeuds.geom) as x_ug, ST_Y(table_noeuds.geom) as y_ug,",
"ST_X(objets.geom) as x, ST_Y(objets.geom) as y ",
"FROM table_noeuds,objets WHERE table_noeuds.site=objets.site ",
"AND table_noeuds.decor=objets.numero ",
"AND table_noeuds.type like '",select.thm,"' ",
"ORDER by famille, site, decor;"
)
df <- dbGetQuery(con,sqll)
df$site.dec <- paste0(df$site,'.',df$decor)
# same idf for same decorations
df.idf <- as.data.frame(subset(df,select=c("site.dec")))
df.idf <- as.data.frame(df.idf[!duplicated(df.idf), ])
colnames(df.idf)[1] <- "site.dec"
df.idf$idf <- row.names(df.idf)
# merge
df.merg <- merge(df,df.idf,by='site.dec',all.x=T)
dbDisconnect(con)
return(df.merg)
}
f.img.list <- function(select.obj){
# export individual decoration in 'corpus' folder
# select.obj <- "Monte Hijido" ; select.obj <- "stele bouclier"
# select.obj <- "steles Bz du SO europeen"
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
sqll.condition <- "SELECT site,numero,img FROM objets WHERE "
if(select.choice == "select.family" | select.choice == "select.objet"){
all.families <- dbGetQuery(con,"SELECT DISTINCT famille FROM famille")
famille.exist <- select.obj %in% all.families$famille # test if family exist
sqll.img <- paste0(sqll.condition,"famille LIKE '", select.obj,"'")
}
if(select.choice == "select.superfamily"){
all.families <- dbGetQuery(con,"SELECT DISTINCT famille_super FROM famille_super")
famille.exist <- select.obj %in% all.families$famille_super # test if superfamily exist
sqll.img <- paste0(sqll.condition,"famille_super LIKE '", select.obj,"'")
}
if (!famille.exist){
print("NO familiy")
df.img <- data.frame(site=character(0),
decor=character(0),
img=character(0),
stringsAsFactors = F)
for(i in 2:length(ldecors)){
# some decoration
# fill the df
# i <- 5
a.site <- ldecors[[i]][[1]]
a.dec <- ldecors[[i]][[2]]
print(paste0(" ",i-1,") read ",a.site," ",a.dec))
if (a.dec == ''){
# all objects of this site
sqll.img <- paste0(sqll.condition,"objets.site LIKE '", a.site,"'")
}
if (a.dec != ''){
sqll.img <- paste0(sqll.condition,"objets.site LIKE '",a.site,
"' AND objets.numero LIKE '",a.dec,"'")
}
img.enr <- dbGetQuery(con,sqll.img) # get image
df.img <- rbind(df.img,img.enr)
}
}
if (famille.exist){
# all the family
print("EXISTS a family or a superfamily")
df.img <- dbGetQuery(con,sqll.img) # get image
df.img <- df.img[with(df.img, order(site, numero)), ]
rownames(df.img) <- 1:nrow(df.img)
}
# plot the images
for (i in 1:nrow(df.img)){
# i <- 1
site.a <- df.img[i,1]
dec.a <- df.img[i,2]
img.a <- df.img[i,3]
print(paste0(" ",i-1,") read image ",site.a," ",dec.a))
img.enr.txt <- gsub('%20',' ',img.a) # remove %20 used by windows
img.is.not.na <- !is.na(any(str_detect(img.enr.txt,c(".jpg",".gif",".tif"))))
img.is.not.false <- any(str_detect(img.enr.txt,c(".jpg",".gif",".tif")))
img.exist <- img.is.not.na & img.is.not.false
if (img.exist){
# image exists
img.enr <- image_read(img.enr.txt) # read
}
if (!img.exist){
# empty image
img.enr <- image_read(paste0(chm.obj,"/empty_obj.gif"))
}
img.enr <- image_trim(img.enr) # trim
img.enr <- image_scale(img.enr,"1000x1000")
img.enr <- image_border(img.enr,"#FFFFFF", "100x100") # add small white margins
img.out <- paste0(chm.corpus,i,"_",site.a,"_",dec.a,".png")
image_write(img.enr, path = img.out, format = "png")
}
dbDisconnect(con)
}
f.img.list(select.superfamily) #
contact.sheet <- function(df,select.thm,obj.nat){
# 'obj.nat' is the nature of the object (ex: 'ugs','objects','archeo'; etc.)
# this function has a long history of [not]working properly
# see previous versions (like 19_35) where 'ggsave_to_variable' used to work
# - - - - - - - -
# select.thm <- "poignard"; obj.nat <- "ugs"; df <- df.ico.thm
# df <- df.ico.thm ; obj.nat <- "ugs" ; select.thm <- "fibule"
df.ugs.xy <- copy(df) # copy for x,y plot
no.family <- "zz_nofamily"
# make some changes for archeo obj
cols <- c("famille" = no.family)
df <- add_column(df, !!!cols[setdiff("famille", names(df))])
#names(df)[names(df) == 'numero'] <- "decor" # replace colname
#
df$lbl <- paste0(df$site,'.',df$decor)
df$famille[is.na(df$famille)] <- no.family
num.of.imgs <- nrow(df)
# get nb of occurences
t.ct.ugs <- as.data.frame(table(df$lbl)) # counts
df <- merge(df,t.ct.ugs,by.x="lbl",by.y="Var1")
df$x_ug <- df$y_ug <- NULL # remove x,y of ugs
# remove duplicated
df <- df[!duplicated(df), ]
df <- df[order(df$famille,df$lbl),]
#df <- df[with(df, order(site,numero)), ]
# height & width in inches
#n.row <- ceiling(num.of.imgs/n.col)
#dim.planche <- c(n.row,n.col)
n.row <- n.col <- ceiling(sqrt(nrow(df))) # for square matrix
dim.planche <- c(n.row,n.col)
max.imgs <- dim.planche[1]*dim.planche[2]
#empty.obj <- image_read(paste0(chm.obj,"/empty_obj.gif"))
ll.img.planche <- ll.img.planche.r <- ll.img.planche.g <-list()
for (im in 1:nrow(df)){
# im <- 1
mult <- 1
print(paste0(" ",im,") read decoration ",df[im,"lbl"]))
enr <- df[im,]
a.sit <- enr[,"site"]
a.dec <- enr[,"decor"]
a.ug <- enr[,"id"]
a.lbl <- paste0(a.sit,"_",a.dec,"_",a.ug)
img.enr.txt <- enr[,"img"] # get image
img.enr.txt <- gsub('%20',' ',img.enr.txt) # remove %20 used by windows
img.is.not.na <- !is.na(any(str_detect(img.enr.txt,c(".jpg",".gif",".tif"))))
img.is.not.false <- any(str_detect(img.enr.txt,c(".jpg",".gif",".tif")))
img.exist <- img.is.not.na & img.is.not.false
# test if image exists
if (img.exist){
#img.enr <- image_read(img.enr.txt, width = 500) # read
img.enr <- image_read(img.enr.txt) # read
img.a.h <- image_info(img.enr)$height # height (offset)
img.a.w <- image_info(img.enr)$width # width
img.a.d <- image_info(img.enr)$density # res
img.a.d <- as.numeric(gsub( "x.*$","",img.a.d)) # res 300x300 -> res 300
if (img.a.h > 1000){mult <- 1.5}
if (obj.nat == 'ugs'){
# TODO: problem with trim and/or resize
# get coordinates of selected themes/ugs
ugs.sel <- df.ugs.xy[df.ugs.xy$site == a.sit & df.ugs.xy$decor == a.dec & df.ugs.xy$id == a.ug,]
ugs.xy <- subset(ugs.sel,select=c(x_ug,y_ug)) # get x,y
out.img <- paste0(chm.ug.typo,select.thm,"/corpus/",a.lbl,".png")
a.image.graph <- image_ggplot(img.enr) # convert image-magick to ggplot
# plot ugs on their x,y
# functions from 'ggrepel' package can create error
# like 'Error in grid.Call...'
# in RStudio, because of window (small) size
# ERROR: problem with 'image_ggplot'
# see last version _19_39.Rmd
a.image.graph.a <- a.image.graph +
# point - - - - - - - - - - - - -
# # YES
geom_point(aes(x=ugs.sel$x_ug,y=(img.a.h+ugs.sel$y_ug)),
color='red',
cex=2*mult)
# # label - - - - - - - - - - - - -
# geom_text(aes(x=ugs.sel$x_ug,y=(img.a.h+ugs.sel$y_ug)),
# #x=ugs.sel$x_ug,y=ugs.sel$y_ug,
# label=ugs.sel$id,
# angle = 180,
# hjust = 0,vjust = 1,
# # point.padding = unit(0.15, "lines"),
# # min.segment.length = 0.05,
# # box.padding = unit(0.08, 'lines'),
# # label.padding = unit(0.08, 'lines'),
# # segment.size = 0.3,
# color='red',
# cex=5*mult)
# plot(a.image.graph.a)
# save on 'corpus' folder,... necessary
ggsave(out.img,
a.image.graph.a,
width =6,
height=6,
dpi = img.a.d)
# read the exported image
img.enr.1 <- image_read(out.img) # read
img.enr.1 <- image_flip(img.enr.1) # flip vertical
# img.enr <- image_rotate(img.enr,180)
img.enr.1 <- image_trim(img.enr.1) # trim
# img.enr <- ggsave_to_variable(a.image.graph.a,img.a.h,img.a.w,img.a.d)
# img.enr <- image_graph(width = img.a.w,
# height = img.a.h,
# bg = "white",
# res = img.a.d,
# clip = TRUE,
# antialias = TRUE)
# img.enr <- image_trim(img.enr) # trim
}
# - - - - - - - - - - - - -
# img.enr <- image_trim(img.enr) # trim
}
if (!img.exist){
# empty image
img.enr.1 <- image_read(paste0(chm.obj,"/empty_obj.gif"))
}
img.enr.1 <- image_scale(img.enr.1,"1000x1000")
img.enr.1 <- image_border(img.enr.1,"#FFFFFF", "50x50") # add small white margins
#idf.enr <- paste0(enr[,"lbl"]," (n=",enr[,"Freq"],")")
idf.enr <- paste0(im,'.',a.sit,"\n",a.dec,"\n","(ug: ",ugs.sel$id,")")
# idf.enr <- paste0(im,'.',a.sit,"\n",a.dec,"\n","(nb=",enr[,"Freq"],")")
idf.famille <- enr[,"famille"]
img.enr.1 <- image_annotate(img.enr.1, idf.famille, size = 45,
gravity = "northwest",boxcolor = "white",
color = "black")
img.enr.1 <- image_annotate(img.enr.1, idf.enr, size = 35,
gravity = "southwest",boxcolor = "white",
color = "black")
# ll.img.planche[[length(ll.img.planche)+1]] <- img.enr
# ll.img.planche.r[[length(ll.img.planche.r)+1]] <- as.raster(img.enr)
ll.img.planche.g[[length(ll.img.planche.g)+1]] <- as_ggplot(as.grob(img.enr.1))
# ll.img.planche[[length(ll.img.planche)+1]] <- image_ggplot(img.enr)
}
# write
a.tit <- paste0("contactsheet of '",select.thm,"' selected ",obj.nat,
", total nb: ",length(ll.img.planche.g))
if (obj.nat == "ugs"){
a.tit <- paste0(a.tit,"\nwith numeros and positions (red point)")
}
a.marg <- 0.2
margin = theme(plot.margin = unit(c(a.marg,a.marg,a.marg,a.marg), "cm"))
# loop through devices
for (dev in c(".png")){
# dev <- ".png"
if(obj.nat == "ugs"){
g.out <- paste0(chm.ug.typo,select.thm,"/",obj.nat,"_contactsheet",dev)
}
ggsave(file = g.out,
arrangeGrob(grobs = lapply(ll.img.planche.g, "+", margin),
ncol = dim.planche[2],
top = grid::textGrob(a.tit,x=0,hjust=0,gp = gpar(fontsize =10))),
width = dim.planche[2]*2,
height = dim.planche[2]*2)
}
#return(chm.ico.planche)
}
# contact.sheet.select.ugs(c("fibule")) # thms and number of img for a line
contact.sheet.select.ugs <- function(select.thms){
# create contact sheet of all the ug having a certain type, here 'select.thm' (ex: "carquois")
# 'n.col' is the number of images in columns
# TODO: get img dim to expand/reduce label ug sizes
# select.thms <- c("casque");select.thms <- c("fibule")
# list ico
for (select.thm in select.thms){
# select.thm <- "fibule"
print (paste0("* read ugs: ",select.thm," *"))
# create 'corpus' folder if not exists
chm.ug.typo.thm <- paste0(chm.ug.typo,"/",select.thm)
ifelse(!dir.exists(file.path(chm.ug.typo.thm, "corpus")),
dir.create(file.path(chm.ug.typo.thm, "corpus")),
FALSE)
# chm.ico.ug <- paste0(chm.ug,select.thm,"/")
df.ico.thm <- f.ugs(select.thm) # load selected ugs from Pg
contact.sheet(df.ico.thm,select.thm,"ugs") # launch the cs function
cat("\014") # clear console
}
}
contact.sheet.real.objects <- function(select.thms){
# select.thms <- c("casque");select.thms <- c("carquois","epee")
for (select.thm in select.thms){
# select.thm <- "casque"
print (paste0("* read ugs: ",select.thm," *"))
df <- f.archeo(select.thm) # load from db
if(nrow(df)>0){
contact.sheet(df,select.thm,"archeo")
} # create the cs function
}
dbDisconnect(con)
}
contact.sheet.grph <- function(lgrph,df.icos,g.stats,is.meta){
ll.graphs <- list()
n.img <- length(g.stats)
n.dec <- length(lgrph)
siz.of.img <- 4
v.box.padding <- .04
v.label.padding <- .08
# e.label.padding <- round(v.label.padding*e.coef.cex,2)
v.segment.size <- .4
v.cex.txt <- 1.5
#e.cex.txt <- round(v.cex.txt*e.coef.cex,2)
v.cex.node <- .8
for (a.g in 1:n.dec){
# a.g <- 1
g <- lgrph[[a.g]]
a.sit <- unique(get.vertex.attribute(g, "site", index=V(g)))
a.dec <- unique(get.vertex.attribute(g, "decor", index=V(g)))
a.idf <- unique(get.vertex.attribute(g, "idf", index=V(g)))
g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>')
# gt.index.df <- c("closeness") # names of the graph analysis functions
for (gt.i in g.stats){
# gt.i <- "closeness"
print(paste0("'",gt.i,"' measurement centralities"))
# path name of the function
gt.i.val <- eval(parse(text = paste0("as.data.frame(",gt.i,"(g))")))
colnames(gt.i.val)[1] <- "stat.graph" # modi fy function name
u.gt.i.val <- sort(unique(gt.i.val$stat.graph),decreasing = T) # unique vals
# change id
g.ids <- get.vertex.attribute(g, "id", index=V(g))
g <- set.vertex.attribute(g, "name", value=g.ids)
g.df <- igraph::as_data_frame(g, what="vertices")
g.df <- merge(g.df,gt.i.val,by="row.names") # merge 'g' and 'gt.i.val'
g.df <- subset(g.df,select=c("name","id","type","x","y","stat.graph"))
# # order on 'stat.graph' value and color
# g.df <- g.df[with(g.df, order(-stat.graph)), ]
# row.names(g.df) <- 1:nrow(g.df)
n.colors <- brewer.pal(length(u.gt.i.val),"Spectral") # gradient color ramp for 'stat.graph'
df.color <- data.frame(stat.graph=u.gt.i.val,
stat.graph.color=n.colors)
# merge color and df
g.df <- merge(g.df,df.color,by="stat.graph",all.x=T)
# g.df$stat.graph.color <- n.colors
# image
img.a <- df.icos[df.icos$site == a.sit & df.icos$num == a.dec,]$img # image
img.exist <- !(is.na(img.a) | img.a=="")
if (!img.exist){a.img <- image_read(paste0(chm.obj,"/empty_obj.gif"))}
if (img.exist){a.img <- image_read(img.a)} # read image
a.text <- paste0("nodes '",gt.i,"'")
# a.img <- image_annotate(a.img,a.text, size = annot.size,
# gravity = "north", color = "black")
a.image <- image_ggplot(a.img) # convert image-magick to ggplot
z.image <- a.image +
ggtitle(a.text)+
geom_point(data=g.df,x=g.df$x,y=g.df$y,aes(color=g.df$stat.graph.color),cex=2)+
geom_label_repel(data=g.df,x=g.df$x,y=g.df$y,
label=paste0(g.df$type,"\n",round(g.df$stat.graph,2)),
box.padding = unit(v.box.padding, "lines"),
label.padding = unit(v.label.padding, "lines"),
segment.size = v.segment.size,
color=g.df$stat.graph.color,
cex=1.5)+
scale_colour_identity(guide="legend",breaks=n.colors,labels=round(u.gt.i.val,2))+
theme(legend.title = element_text(size = 7),
legend.text = element_text(size = 7))+
labs(color=paste0(a.text,"\nvalues"))
# img.out <- ggsave_to_variable(z.image,siz.of.img+1,siz.of.img,300)
# img.out %>% magick::image_write(n.file)
if(is.meta){
# save images separetly
n.file <- paste0(chm.doc,as.character(a.g),"_stats_graph_",gt.i,".png")
ggsave(n.file,z.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE)
}
ll.graphs[[length(ll.graphs)+1]] <- z.image
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# create a planche of contact of m x n images
margin = theme(plot.margin = unit(c(0.5,0.5,0.5,0.5), "cm"))
if(!is.meta){
for (dev in c(".png",".pdf")){
a.contact.sheet <- paste0(chm.analysis,"/stats_ugs.png")
ggsave(file = a.contact.sheet,
arrangeGrob(grobs = lapply(ll.graphs, "+", margin), padding = unit(0.05, "line"), ncol = n.img),
height = n.dec*siz.of.img,
width = n.img*siz.of.img, dpi=300,
limitsize = FALSE)
}
}
# if(is.meta){
# a.contact.sheet <- paste0(chm.doc,"stats_graph_ugs.png")
# ggsave(file = a.contact.sheet,
# arrangeGrob(grobs = lapply(ll.graphs, "+", margin), padding = unit(0.05, "line"), ncol = n.img),
# height = n.dec*siz.of.img,
# width = n.img*(siz.of.img+1), dpi=300,
# # height = length(g.img)*siz.of.img,
# # width = nrow(crp)*siz.of.img, dpi=300,
# limitsize = FALSE)
# }
print(paste0(" ",a.contact.sheet," saved !"))
# r.start <- r.end+1 # increment start
# r.end <- r.end+max.row.cs
# #grid.arrange(grobs = ll.dec, ncol = 3)
}
# g.stats <- c("closeness","betweenness","degree") # names of the graph analysis functions
# contact.sheet.grph(lgrph,df.icos,g.stats,is.meta)
contact.sheet.var <- function(lgrph,crp.all,df.icos,g.img,writ.imgs,is.meta){
# create contactsheet displaying all 'ug' variables
# Fill the 'corpus' directory with 3 images for each objects by lines
# and regroup in contact sheet
# 1) simple image
# 2) 'graph' (nodes + edges)
# 3) image with themes 'types'
# 4) image with themes 'chronology'
# n) ...
# TODO: sens, dim, change edge color depending wheter attributes or not
# TODO: change cs name to correspond with decor ID
# parameters - - - - - - - - - - - - -
n.img <- length(g.img)+1 # number of images in line
siz.of.img <- 4 # size of images in inch
# maximum of row for one contact sheet
max.row.cs <- ceiling(50/(siz.of.img+1)) # /!\ max is 50 inches, add a marg in as a security
annot.size <- 20 # size of annotations
e.coef.cex <- 2/3 # size for edges are proportions node sizes
v.box.padding <- .04
v.label.padding <- .08
e.label.padding <- round(v.label.padding*e.coef.cex,2)
v.segment.size <- .4
v.cex.txt <- 1.5
e.cex.txt <- round(v.cex.txt*e.coef.cex,2)
v.cex.node <- .8
# - - - - - - - - - - - - - - - - - - -
#crp.all <- crp.all[c(10:15),] # sample/try
#crp <- crp.all[c(1:50),]
n.crp <- nrow(crp.all) # total nb of decor to display
n.crp.cs <- ceiling(n.crp/max.row.cs) # number of contact sheet
r.start <- 1;r.end <- max.row.cs
for (cs in 1:n.crp.cs){
# cs <- 1
ll.dec <- list() # list of images for contact sheet
first.row <- T # will plot columns headers
# create different contact sheet
crp <- crp.all[c(r.start:r.end),] # get a chunk subset
crp <- crp[!(is.na(crp$site)),] # remove some NA rows
#n.r <- length(r.start:r.end) # number of rows by contactsheet
a.start <- min(crp$idf);a.end <- max(crp$idf)
n.chunk <- paste0(as.character(a.start),"-",as.character(a.end)) # add lbl of the cs
print(paste0("create contact sheet [",cs,"] between decors '",n.chunk,"'"))
for (i in 1:nrow(crp)){
#for (i in r.start:r.end){
#print(paste0(" ",i))
# i <- 1
sit.a<-crp[i,"site"]
num.a<-crp[i,"numero"]
lbl.a<-crp[i,"lbl"]
idf.a<-crp[i,"idf"]
print(paste0(" ",idf.a,") read decor: ",lbl.a))
# outputs
chm.a <- paste0(chm.corpus,idf.a,'_',lbl.a)
if (writ.imgs){
chm.out.dec <- paste0(chm.a,'.png')
chm.out.dec.grph <- paste0(chm.a,'_grph.png')
chm.out.dec.type <- paste0(chm.a,'_ico.png')
chm.out.dec.chr <- paste0(chm.a,'_tpq.png')
chm.out.dec.sens <- paste0(chm.a,'_sens.png')
chm.out.dec.long_cm <- paste0(chm.a,'_long_cm.png')
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - -
# read edges
dd.edges <- edges.coordinates(sit.a,num.a) # edges
#dd.edges.copy <- dd.edges
#dd.edges.copy$typ <- gsub('+', 'att', dd.edges.copy$typ)
dd.edges$typ[is.na(dd.edges$typ)] <- '=' # change NA to =
#img.a <- crp[crp$site == sit.a & crp$num == num.a,]$img # image
img.a <- df.icos[df.icos$site == sit.a & df.icos$num == num.a,]$img # image
#img.a <- image_trim(image_read(img.a)) # read & trim
# test if image exists
img.formats <- c(".jpg", ".tif", ".gif")
img.exist <- length(unique (grep(paste(img.formats,collapse="|"),img.a)))
if (!img.exist){img.a <- image_read(paste0(chm.obj,"/empty_obj.gif"))}
if (img.exist){img.a <- image_read(img.a)} # read image
# img.exist <- !(is.na(img.a) | img.a=="")
# if (!img.exist){img.a <- image_read(paste0(chm.obj,"/empty_obj.gif"))}
# if (img.exist){img.a <- image_read(img.a)} # read image
#img.a <- image_scale(img.a,"500x500")
img.a.h <- image_info(img.a)$height # height (offset)
img.a.w <- image_info(img.a)$width # width
img.a.d <- image_info(img.a)$density # res
img.a.d <- as.numeric(gsub( "x.*$","",img.a.d)) # res 300x300 -> res 300
#rast.a <- as.raster(a.img) # image to raster
#nodes.a <- nodes.df("Brozas","Brozas") # get nodes
nodes.a <- nodes.df(sit.a,num.a) # get nodes
nodes.a$color.chr <- ifelse(is.na(nodes.a$tpq),'grey','red') # color on 'tpq'
nodes.a$color.sens <- ifelse(is.na(nodes.a$sens),'grey','red') # color on 'sens'
nodes.a$color.long_cm <- ifelse(is.na(nodes.a$long_cm),'grey','red') # color on 'long_cm'
# label long_cm, italic if 'incomplet'
nodes.a$lbl.dim <- ifelse(nodes.a$incomplet == 1,
paste0("italic('",
as.character(nodes.a$long_cm),
"')"),as.character(nodes.a$long_cm))
# color on 'technologie'
nodes.a$color.tek <- ifelse(is.na(nodes.a$technologie),'grey',
ifelse(nodes.a$technologie == 'g_piq','orange',
ifelse(nodes.a$technologie == 'g_inc','violet',
'blue')))
nodes.a1 <- nodes.a # a copy, util ?
#- - - - - - - - - - - - - - - - - - - - - - - - - - -
# xx) decor only : decor - - - - - - - - -
print (" + image")
img.init <- image_scale(img.a,"500x500")
if(first.row){
# the title of the cs
image.tag <- image_annotate(img.init, paste0("Contactsheet of decors:",r.start,"-",r.end),
size = annot.size+5,gravity = "northwest", color = "black")
}
if(!first.row){image.tag <- img.init} # no tag
# the name of the row
image.tag <- image_annotate(image.tag, paste0(idf.a,'_',lbl.a), size = annot.size,
gravity = "southwest", color = "black")
tag.image <- image_ggplot(image.tag)
ll.dec[[length(ll.dec)+1]] <- tag.image
# write ?
if(writ.imgs){image_write(image.tag,chm.out.dec, format = "png")}
if(is.meta){
out.img <- paste0(chm.doc,"dec.png")
ggsave(out.img,tag.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE)
}
#- - - - - - - - - - - - - - - - - - - - - - - - - - -
if("g.grp" %in% g.img){
# xx) graph : decor + graph (nodes + edges) - - - - -
print (" + graph")
# add tag on column if first row
if(first.row){
image.graph <- image_annotate(img.a,"nodes and edges", size = annot.size,
gravity = "north", color = "black")
}
if(!first.row){image.graph <- img.a} # no tag
a.image.graph <- image_ggplot(image.graph) # convert image-magick to ggplot
intit <- "ba.image <- a.image.graph +"
if (nrow(dd.edges)>0){
# at least exist 1 edge
# store geom_segment in a string because not working properly with ggplot
# intit <- "ba.image <- a.image.graph +"
segm.ggplot <- label.edges.ggplot <- c()
for (i in 1:nrow(dd.edges)){
segm.ggplot <- paste0(segm.ggplot,
"geom_segment(x=",dd.edges[i,"xa"],
", y=",dd.edges[i,"ya"],
", xend=",dd.edges[i,"xb"],
", yend=",dd.edges[i,"yb"],
", color='red', size =.4, alpha=.5, ",
", linetype=ifelse('",dd.edges[i,"typ"],"'=='+',2,1)",
")+")
# label.edges.ggplot <- paste0(label.edges.ggplot,
# "geom_label(x=",(dd.edges[i,"xa"]+dd.edges[i,"xb"])/2,
# ", y=",(dd.edges[i,"ya"]+dd.edges[i,"yb"])/2,
# ", label= '",dd.edges[i,"typ"],"'",
# ", box.padding = unit(v.box.padding, 'lines')",
# ", label.padding = unit(v.label.padding, 'lines')",
# # ", color=ifelse('",dd.edges[i,"typ"],"'=='+','blue','red'),",
# ", color='red',",
# "cex=e.cex.txt)+")
}
}
if (nrow(dd.edges)==0){segm.ggplot <- label.edges.ggplot <- ""} # none edges
#segm.ggplot <- gsub('.{1}$', '', segm.ggplot) # remove the last +
nodes.ggplot <- "geom_point(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y, color='red',cex=v.cex.node)+"
label.nodes.ggplot <- "geom_label_repel(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,
label=nodes.a1$id,
box.padding = unit(v.box.padding, 'lines'),
label.padding = unit(v.label.padding, 'lines'),
segment.size = v.segment.size,
color='red',
cex=v.cex.txt)"
# concat all strings
dec.grph <- paste0(intit,
segm.ggplot,label.edges.ggplot, # edges
nodes.ggplot,label.nodes.ggplot # nodes
)
eval(parse(text=dec.grph)) # create the 'ba.image'
ll.dec[[length(ll.dec)+1]] <- ba.image
my_img.ba <- ggsave_to_variable(ba.image,img.a.h,img.a.w,img.a.d)
# write ?
if(writ.imgs){my_img.ba %>% magick::image_write(chm.out.dec.grph)}
if(is.meta){
out.img <- paste0(chm.doc,"dec_graph.png")
ggsave(out.img,ba.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE)
}
}
#- - - - - - - - - - - - - - - - - - - - - - - - - - -
if("g.thm" %in% g.img){
# xx) decor + type of nodes - - - - - - - - - - - - - - - -
print (" + typology")
# add tag on column if first row
if(first.row){
image.thm <- image_annotate(img.a,"nodes types", size = annot.size,
gravity = "north", color = "black")
}
if(!first.row){image.thm <- img.a} # no tag
a.image <- image_ggplot(image.thm) # convert image-magick to ggplot
bb.image <- a.image +
geom_point(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,
color='red',cex=v.cex.node) +
geom_label_repel(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,
label=paste0(nodes.a1$id,'.',nodes.a1$type),
box.padding = unit(v.box.padding, "lines"),
label.padding = unit(v.label.padding, "lines"),
segment.size = v.segment.size,
color='red',
cex=v.cex.txt)
ll.dec[[length(ll.dec)+1]] <- bb.image
my_img.bb <- ggsave_to_variable(bb.image,img.a.h,img.a.w,img.a.d)
# write ?
if(writ.imgs){my_img.bb %>% magick::image_write(chm.out.dec.type)}
if(is.meta){
out.img <- paste0(chm.doc,"dec_thm.png")
ggsave(out.img,bb.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE)
}
}
#- - - - - - - - - - - - - - - - - - - - - - - - - - -
if("g.chr" %in% g.img){
# xx) decor + chr - - - - - - - - - - - - - - -
print (" + chronology")
# add tag on column if first row
if(first.row){
image.chr <- image_annotate(img.a,"nodes chronology", size = annot.size,
gravity = "north", color = "black")
}
if(!first.row){image.chr <- img.a} # no tag
a.image <- image_ggplot(image.chr) # convert image-magick to ggplot
c.image <- a.image +
geom_point(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,color=nodes.a1$color.chr,cex=v.cex.node)+
geom_label_repel(data=nodes.a1,
x=nodes.a1$x,y=nodes.a1$y,
label=paste0(nodes.a1$id,'.',nodes.a1$chr_1,"\n",nodes.a1$tpq,"/",nodes.a1$taq),
box.padding = unit(v.box.padding, "lines"),
label.padding = unit(v.label.padding, "lines"),
segment.size = v.segment.size,
color=nodes.a1$color.chr,
cex=v.cex.txt)
ll.dec[[length(ll.dec)+1]] <- c.image
#ll.c[[length(ll.c)+1]] <- c.image
my_img.c <- ggsave_to_variable(c.image,img.a.h,img.a.w,img.a.d)
# write ?
if(writ.imgs){my_img.c %>% magick::image_write(chm.out.dec.chr)}
if(is.meta){
out.img <- paste0(chm.doc,"dec_chrono.png")
ggsave(out.img,bb.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE)
}
}
#- - - - - - - - - - - - - - - - - - - - - - - - - - -
if("g.dim" %in% g.img){
# xx) decor + long_cm - - - - - - - - - - - - - - -
print (" + length")
# add tag on column if first row
if(first.row){
image.dim <- image_annotate(img.a,"nodes length (in cm)", size = annot.size,
gravity = "north", color = "black")
}
if(!first.row){image.dim <- img.a} # no tag
a.image <- image_ggplot(image.dim) # convert image-magick to ggplot
e.image <- a.image +
geom_point(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,color=nodes.a1$color.long_cm,cex=v.cex.node)+
geom_label_repel(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,
label=nodes.a1$lbl.dim,
box.padding = unit(v.box.padding, "lines"),
label.padding = unit(v.label.padding, "lines"),
segment.size = v.segment.size,
color=nodes.a1$color.long_cm,
cex=v.cex.txt,
parse = TRUE)
ll.dec[[length(ll.dec)+1]] <- e.image
#ll.c[[length(ll.c)+1]] <- c.image
my_img.e <- ggsave_to_variable(e.image,img.a.h,img.a.w,img.a.d)
# write ?
if(writ.imgs){my_img.e %>% magick::image_write(chm.out.dec.long_cm)}
if(is.meta){
out.img <- paste0(chm.doc,"dec_dim.png")
ggsave(out.img,e.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE)
}
}
#- - - - - - - - - - - - - - - - - - - - - - - - - - -
if("g.ort" %in% g.img){
# xx) decor + sens - - - - - - - - - - - - - - -
print (" + orientation")
# add tag on column if first row
if(first.row){
image.ort <- image_annotate(img.a,"nodes orientation (0°-359°)", size = annot.size,
gravity = "north", color = "black")
}
if(!first.row){image.ort <- img.a} # no tag
a.image <- image_ggplot(image.ort) # convert image-magick to ggplot
d.image <- a.image +
geom_point(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,color=nodes.a1$color.sens,cex=v.cex.node)+
geom_label_repel(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,
label=paste0(nodes.a1$sens),
box.padding = unit(v.box.padding, "lines"),
label.padding = unit(v.label.padding, "lines"),
segment.size = v.segment.size,
color=nodes.a1$color.sens,
cex=v.cex.txt)
ll.dec[[length(ll.dec)+1]] <- d.image
#ll.c[[length(ll.c)+1]] <- c.image
my_img.d <- ggsave_to_variable(d.image,img.a.h,img.a.w,img.a.d)
# write ?
if(writ.imgs){my_img.d %>% magick::image_write(chm.out.dec.sens)}
if(is.meta){
out.img <- paste0(chm.doc,"dec_ort.png")
ggsave(out.img,d.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE)
}
}
#- - - - - - - - - - - - - - - - - - - - - - - - - - -
if("g.tek" %in% g.img){
# xx) decor + sens - - - - - - - - - - - - - - -
print (" + technologie")
# add tag on column if first row
if(first.row){
image.ort <- image_annotate(img.a,"nodes technology", size = annot.size,
gravity = "north", color = "black")
}
if(!first.row){image.ort <- img.a} # no tag
a.image <- image_ggplot(image.ort) # convert image-magick to ggplot
d.image <- a.image +
geom_point(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,color=nodes.a1$color.tek,cex=v.cex.node)+
geom_label_repel(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,
label=paste0(nodes.a1$technologie),
box.padding = unit(v.box.padding, "lines"),
label.padding = unit(v.label.padding, "lines"),
segment.size = v.segment.size,
color=nodes.a1$color.tek,
cex=v.cex.txt)
ll.dec[[length(ll.dec)+1]] <- d.image
#ll.c[[length(ll.c)+1]] <- c.image
my_img.d <- ggsave_to_variable(d.image,img.a.h,img.a.w,img.a.d)
# write ?
if(writ.imgs){my_img.d %>% magick::image_write(chm.out.dec.sens)}
if(is.meta){
out.img <- paste0(chm.doc,"dec_tek.png")
ggsave(out.img,d.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE)
}
}
first.row <- F # for not ploting columns headers
}
# # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# # stats on graph - - - - - - - - - - - - - - - - - - - - - - - - - - -
# ll.graphs <- list()
# for (a.g in 1:length(lgrph)){
# # a.g <- 1
# g <- lgrph[[a.g]]
# a.sit <- unique(get.vertex.attribute(g, "site", index=V(g)))
# a.dec <- unique(get.vertex.attribute(g, "decor", index=V(g)))
# a.idf <- unique(get.vertex.attribute(g, "idf", index=V(g)))
# g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>')
# gt.index.df <- c("closeness","betweenness","degree") # names of the graph analysis functions
# # gt.index.df <- c("closeness") # names of the graph analysis functions
# for (gt.i in gt.index.df){
# # gt.i <- "closeness"
# print(paste0("'",gt.i,"' measurement centralities"))
# # path name of the function
# gt.i.val <- eval(parse(text = paste0("as.data.frame(",gt.i,"(g))")))
# colnames(gt.i.val)[1] <- "stat.graph" # modi fy function name
# u.gt.i.val <- sort(unique(gt.i.val$stat.graph),decreasing = T) # unique vals
# # change id
# g.ids <- get.vertex.attribute(g, "id", index=V(g))
# g <- set.vertex.attribute(g, "name", value=g.ids)
# g.df <- igraph::as_data_frame(g, what="vertices")
# g.df <- merge(g.df,gt.i.val,by="row.names") # merge 'g' and 'gt.i.val'
# g.df <- subset(g.df,select=c("name","id","type","x","y","stat.graph"))
# # # order on 'stat.graph' value and color
# # g.df <- g.df[with(g.df, order(-stat.graph)), ]
# # row.names(g.df) <- 1:nrow(g.df)
# n.colors <- brewer.pal(length(u.gt.i.val),"Spectral") # gradient color ramp for 'stat.graph'
# df.color <- data.frame(stat.graph=u.gt.i.val,
# stat.graph.color=n.colors)
# # merge color and df
# g.df <- merge(g.df,df.color,by="stat.graph",all.x=T)
# # g.df$stat.graph.color <- n.colors
# # image
# a.img <- df.icos[df.icos$site == sit.a & df.icos$num == num.a,]$img # image
# img.exist <- !(is.na(a.img) | a.img=="")
# if (!img.exist){a.img <- image_read(paste0(chm.obj,"/empty_obj.gif"))}
# if (img.exist){a.img <- image_read(a.img)} # read image
# a.text <- paste0("nodes '",gt.i,"'")
# a.img <- image_annotate(a.img,a.text, size = annot.size,
# gravity = "north", color = "black")
# a.image <- image_ggplot(a.img) # convert image-magick to ggplot
# z.image <- a.image +
# geom_point(data=g.df,x=g.df$x,y=g.df$y,aes(color=g.df$stat.graph.color),cex=2)+
# geom_label_repel(data=g.df,x=g.df$x,y=g.df$y,
# label=paste0(g.df$type,"\n",round(g.df$stat.graph,2)),
# box.padding = unit(v.box.padding, "lines"),
# label.padding = unit(v.label.padding, "lines"),
# segment.size = v.segment.size,
# color=g.df$stat.graph.color,
# cex=3)+
# scale_colour_identity(guide="legend",breaks=n.colors,labels=round(u.gt.i.val,2))+
# labs(color=paste0(a.text,"\nvalues"))
# ll.graphs[[length(ll.graphs)+1]] <- z.image
# }
# }
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# create a planche of contact of m x n images
margin = theme(plot.margin = unit(c(0,0,0,0), "cm"))
#ll.dec.t <- ll.dec[1:18]
#ifelse(nrow(objets)>50, h <- 49, h <- nrow(objets)/1.5)
#scale_x_reverse(breaks=rev(a.min:a.max))
if(!is.meta){
for (dev in c(".png",".pdf")){
a.contact.sheet <- paste0(chm.etude,"ico_contactsheet_[",cs,"]_decors_(",a.start,"-",a.end,")",dev)
ggsave(file = a.contact.sheet,
arrangeGrob(grobs = lapply(ll.dec, "+", margin), padding = unit(0.05, "line"), ncol = n.img),
height = nrow(crp)*siz.of.img,
width = n.img*siz.of.img, dpi=300,
limitsize = FALSE)
}
# a.contact.sheet <- paste0(chm.etude,"ico_contactsheet_[",cs,"]_decors_(",a.start,"-",a.end,").png")
# ggsave(file = a.contact.sheet,
# arrangeGrob(grobs = lapply(ll.dec, "+", margin), padding = unit(0.05, "line"), ncol = n.img),
# height = nrow(crp)*siz.of.img,
# width = n.img*siz.of.img, dpi=300,
# limitsize = FALSE)
}
if(is.meta){
#a.contact.sheet <- paste0(chm.obj,"/(Etude)/ico_contactsheet_[",cs,"]_decors_(",a.start,"-",a.end,").png")
ggsave(file = a.contact.sheet,
arrangeGrob(grobs = lapply(ll.dec, "+", margin), padding = unit(0.05, "line"), ncol = n.img),
height = nrow(crp)*siz.of.img,
width = n.img*siz.of.img, dpi=300,
# height = length(g.img)*siz.of.img,
# width = nrow(crp)*siz.of.img, dpi=300,
limitsize = FALSE)
}
print(paste0(" ",a.contact.sheet," saved !"))
r.start <- r.end+1 # increment start
r.end <- r.end+max.row.cs
# #grid.arrange(grobs = ll.dec, ncol = 3)
}
}
# contact.sheet.var(lgrph,crp.all,df.icos,g.img,writ.imgs,is.meta) # create cs
f.update.orient <- function(){
# update orientation of ug in 'table_noeuds' by +90°
# ex. "bouclier en V"
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
sqll <- paste0("SELECT site,structure,decor,id,type,chr_1,sens FROM ",
"table_noeuds WHERE type LIKE 'bouclier' AND chr_1 LIKE '%en V' ORDER BY site,decor;")
all.bouc <- dbGetQuery(con,sqll)
all.bouc$n_sens <- NA
for (r in 1:nrow(all.bouc)){
#r <-26
a <- all.bouc[r,"sens"]
if (a >= 0 & a < 90){
b <- a+270
}
if (a >= 90 & a < 180){
b <- a-90
}
if (a >= 180){
b <- (a+90)-180
}
all.bouc[r,"n_sens"] <- b
}
for (i in 1:nrow(all.bouc)){
a.sit <- all.bouc[i,"site"]
#a.str <- all.bouc[i,"structure"]
a.dec <- all.bouc[i,"decor"]
a.idf <- all.bouc[i,"id"]
n.sens <- all.bouc[i,"n_sens"]
a.chr1 <- all.bouc[i,"chr_1"]
sqll <- paste0("UPDATE table_noeuds SET sens=",n.sens,
" WHERE site LIKE '",a.sit,"' AND ",
"decor LIKE '",a.dec,"' AND ",
"id = ",a.idf," AND ",
"chr_1 LIKE '",a.chr1,"'")
print (sqll)
#dbGetQuery(con,sqll)
}
dbDisconnect(con)
}
alpha.incomp <- 0.3 # alpha for ugs where 'incomplet' = 1
fg.dim.by.dec <- function(ugs,
corpus,
dim,
typ.dim,
text.size = 10,
label.size.dimension = 3,
label.size.type = 4
){
# TODO: plot also decoration without graphs or without dim
# TODO: why alpha is that clear ?
# dim: 'long' or 'long_cm'
# typ.dim='rel': compute relative dimensions from the longest ug to the smallest
# typ.dim='abs': compute absolute dimensions from the longest ug to the smallest
# dim <- "long" ; typ.dim <-"abs" ; corpus <- 'family'
nb.miss <- 0
ugs.sub <- subset(ugs,select=c("lbl","type",dim,"incomplet","id","chr_1"))
df.ugs.dim <- data.frame(lbl=character(0),
type=character(0),
long=numeric(0),
incomplet=numeric(0),
id=numeric(0),
chr_1=character(0),
dim=numeric(0),
idf=numeric(0))
for (i in 1:nrow(graphs)){
# i <- 4
g.idf <- graphs[i,"idf"]; g.dec <- graphs[i,"lbl"]
g.lbl <- paste0(g.idf,'.',g.dec)
#ug.select <- subset(ugs,select=c("lbl","type","long","id","chr_1"))
ug.select <- ugs.sub[ugs.sub$lbl == g.lbl,] # subset
if(nrow(ug.select)==0){nb.miss <- nb.miss+1 ; next} # if no graph, no
ug.select$idf <- g.idf
# long
ug.select <- ug.select[ug.select[,dim] != 'NA' & !is.na(ug.select[,dim]),]
if(typ.dim == "rel"){
# relative, normalized btw 1 and ~0.1
ug.select$dim <- round(ug.select[,dim]/max(ug.select[,dim]),2)
}
if(typ.dim == "abs"){
ug.select$dim <- round(ug.select[,dim],2)
}
ug.select <- ug.select[rev(order(ug.select[,dim])),]
df.ugs.dim <- rbind(df.ugs.dim,ug.select)
}
# reorder df
df.ugs.dim$lbl <- factor(df.ugs.dim$lbl,levels=rev(unique(df.ugs.dim$lbl)))
## italic and alpha = .5 if incomplet
# label type
df.ugs.dim$type.lbl <- ifelse(df.ugs.dim$incomplet == 1,
paste0("italic('",
df.ugs.dim$type,
"')"),df.ugs.dim$type)
# label dim
df.ugs.dim$dim.lbl <- ifelse(df.ugs.dim$incomplet == 1,
paste0("italic('",
df.ugs.dim$dim,
"')"),df.ugs.dim$dim)
# alpha
df.ugs.dim$alpha <- ifelse(df.ugs.dim$incomplet == 1,alpha.incomp,1)
#df.ugs.#dim$lbl <- factor(df.ugs.dim$lbl,levels=df.ugs.dim$lbl)
# title - - - - - - - - -
# if(corpus=='objects'){tit.corpus <- "selected objects"}
# if(corpus=='family'){tit.corpus <- paste0("family '",select.family,"'")}
tit.corpus <- f.tit.corpus(corpus,length(unique(ugs$idf)),nrow(ugs))
# tit.corpus <- ifelse(corpus=="objects"," selected objects ",
# paste0(" all '",select.family,"' family "))
# tit.nb <- paste0(" (n = ",length(unique(ugs$idf))," objects + ",nb.miss," missing, ",nrow(ugs)," ugs)")
if(dim == "long"){tit.unite <- ", in pixel"}
if(dim == "long_cm"){tit.unite <- ", in cm"}
tit.sup <- "\nincomplete ugs are displayed in shaded italic"
if(typ.dim == "abs"){tit <- paste0("absolute dimension on ",tit.corpus,tit.unite,tit.sup)}
if(typ.dim == "rel"){tit <- paste0("relative dimension on ",tit.corpus,tit.nb,
" from the largest theme (max=1) to the smallest one (min~.1)",
tit.sup)}
a.min <- ceiling(min(df.ugs.dim$dim))
a.max <- ceiling(max(df.ugs.dim$dim))
# the graph
g.dim <- ggplot(df.ugs.dim)+
ggtitle(tit)+
geom_point(aes(x = dim, y = lbl, alpha = alpha))+
theme_bw()+
theme(plot.title = element_text(size = text.size))+
theme(axis.text = element_text(size = text.size))+
theme(legend.position = "none")
n.row <- length(unique(df.ugs.dim$lbl))
if(typ.dim == "rel"){
g.dim <- g.dim +
# type
geom_text_repel(aes(x = dim, y = lbl,label=type.lbl,alpha=alpha,segment.alpha=alpha),
segment.size = 0.3,#segment.alpha = 0.5,
parse = TRUE)+
scale_x_reverse(breaks=rev(seq(0, 1, 0.1)))
out.g <- paste0(chm.analysis.n.dimensions,"_ugs_rel_dim_by_decorations_",corpus,"_.png")
}
if(typ.dim == "abs"){
g.dim <- g.dim +
# dimension
geom_text_repel(aes(x = dim, y = lbl,
label = dim.lbl, color = "gray30", alpha = alpha,segment.alpha=alpha),
segment.color = "gray30",min.segment.length = 0.7,
segment.size = 0.3,#segment.alpha = 0.5,
point.padding=0.9, nudge_y = 0.07,
size = label.size.dimension,
parse = TRUE)+
# type
geom_text_repel(aes(x=dim,y=lbl,label=type.lbl,alpha=alpha,segment.alpha=alpha),
segment.size = 0.3, size = label.size.type,#segment.alpha = 0.5,
parse = TRUE) +
scale_color_identity() +
scale_alpha_identity()
if(dim == "long_cm"){
g.dim <- g.dim +
scale_x_reverse(breaks = rev(seq(0,max(df.ugs.dim[,"dim"]),5)))
}
if(dim == "long"){
g.dim <- g.dim +
scale_x_reverse()
}
}
#scale_x_reverse(breaks=rev(a.min:a.max))
for (dev in c(".png",".pdf")){
out.g <- paste0(chm.analysis.n.dimensions,"ugs_",typ.dim,"_dim_by_decorations_",corpus,"_",dim,dev)
ggsave(out.g,
g.dim,
height = (n.row/3)+7,
width = 18)
}
shell.exec(out.g)
}
f.tit.corpus <- function(corpus,nb.dec,nb.ugs){
## to uniformize ggplot titles
# 'nb.dec'= number of objects, 'nb.ugs'= number of decorations
# corpus <- "super.family" ; nb.dec <- 11 ; nb.ugs <- 999
# nb.dec <- length(lg.angles) ; nb.ugs <- length(unique(ugs$decor))
effectifs <- paste0("(nb obj: ",nb.dec,", nb ugs: ",nb.ugs,")")
ifelse (corpus=='family', tit.crp <- paste0("on all '",select.family,"' family ",effectifs),
ifelse (corpus=='objects',tit.crp <- paste0("on selected objects from the '",
select.obj,"' list ",effectifs),
tit.crp <- paste0("on all '",select.superfamily,"' super-family ",effectifs)))
return(tit.crp)
}
f.dendro.color <- function(flag,df){
# TODO change column name 'color' to 'egdedist.color'
# TODO SOMEWHERE ELS: create a column color named 'clust.color' for cluster results
# df <- dim.obj ; flag <- flag.dendro.color
if (flag){
# merge on dendrogramm colors
df.colors <- subset(df.dist.mat.sel.ord,select=c("idf","color"))
df <- merge(df,df.colors,by="idf",all.x=T)
df$color[is.na(df$color)]<-"grey"
#mytit <- paste0()
}
if (!flag){df$color <- "black"}
return(df)
}
f.shapiro <- function(ds,thres,txt){
# normality test
# thres <- 0.05 ; ds <- ugs.dim.complets$long_cm
n <- length(ds)
res.test <- shapiro.test(ds)
p.value <- round(res.test$p.value,2)
tit.test.incip <- paste0("Shapiro test on '",txt,"' shows distribution (n = ",n,") is ")
tit.test.thres <- paste0("for threshold '",thres,"' (p-value=",p.value,")")
tit.res.test <- ifelse(p.value > thres,
paste0(tit.test.incip,"'normal' ",tit.test.thres),
paste0(tit.test.incip,"'not normal' ",tit.test.thres)
)
return(tit.res.test)
}
# opposite of %in% funct
`%notin%` <- Negate(`%in%`)
# loads graphs
# selection of a list
idx <- findex(ldecors.all,select.obj)
ldecors <- ldecors.all[[idx]]
# selection of group(s)
idx <- findex(lgroups.all,select.obj)
lgroups <- lgroups.all[[idx]]
#Expert <- T
shell.exec(paste0(chm.etude)) # open the folder
#plot.a.graph(lgrph[[1]])
TODO: All iconography
FAMILY AND OBJECTS
listing TODO
Plot the dataframes of objets and variables
# export xlsx listing with hyperlinks for decoration
graphs.objects <- create.graph.view(v.select.obj,corpus) # call function to create view
objets <- objects.df(graphs.objects) # objects
objets$idf <- rownames(objets)
objets.imgs <- subset(objets,select=c("idf","lbl","img"))
objets.imgs$img <- paste0("file:///",objets.imgs$img ) # for local hyperlinks
class(objets.imgs$img) <- "hyperlink" # class
write.xlsx(objets.imgs,paste0(chm.etude,"listing_images.xlsx"))
corpus
Objects with decorations, as stele, are grouped into families or types depending on their proximities (iconographic, etc.
list of decorations
# export indiviudal images of decorations to 'corpus' folder, ~ contactsheet
f.img.list(select.superfamily) #
variables
f.nodes.plot <- function(nodes.a,sv){
# nodes - - - - - - - - - - - -
for (n in 1:nrow(nodes.a)){
# n <- 1
ax <- nodes.a[n,"x"];ay <- abs(nodes.a[n,"y"])
if (sv %in% c("graph","ug_typo")){
nodecol <- nodes.a[n,"color.typo"]
}
if (sv == "ug_orient"){
nodecol <- nodes.a[n,"color.sens"]
}
if (sv == "ug_techno"){
nodecol <- nodes.a[n,"color.tek"]
}
if (sv == "ug_long_cm"){
nodecol <- nodes.a[n,"color.long_cm"]
}
if (sv == "ug_complet"){
nodecol <- nodes.a[n,"color.incomp"]
}
if (sv == "ug_chr_1"){
nodecol <- nodes.a[n,"color.chr_1"]
}
if (sv == "ug_tq"){
nodecol <- nodes.a[n,"color.tq"]
}
if (sv == "ug_closeness"){
nodecol <- nodes.a[n,"color.closeness"]
}
if (sv == "ug_betweenness"){
nodecol <- nodes.a[n,"color.betweenness"]
}
if (sv == "ug_degree"){
nodecol <- nodes.a[n,"color.degree"]
}
if (sv == "ug_domition"){
nodecol <- nodes.a[n,"color.domition"]
}
points(ax,ay,
pch=21,
col=nodecol,
bg=nodecol,
cex=nd.sz)
}
}
f.labels.shadow <- function(x, y=NULL, labels, col='white', bg='black',
theta= seq(0, 2*pi, length.out=50), r=0.1, ... ) {
xy <- xy.coords(x,y)
xo <- r*strwidth('A')
yo <- r*strheight('A')
# draw background text with small shift in x and y in background colour
for (i in theta) {
text( xy$x + cos(i)*xo, xy$y + sin(i)*yo, labels, col=bg, ... )
}
# draw actual text in exact xy position in foreground colour
text(xy$x, xy$y, labels, col=col, ... )
}
f.labels.plot <- function(nodes.a,sv){
# labels - - - - - - - - - - -
for (n in 1:nrow(nodes.a)){
ax <- nodes.a[n,"x"];ay <- abs(nodes.a[n,"y"])
if (sv == "graph"){
labeltext <- nodes.a[n,"id"]
labelcol <- nodes.a[n,"color.typo"]
}
if (sv == "ug_typo"){
labeltext <- nodes.a[n,"type"]
labelcol <- nodes.a[n,"color.typo"]
}
if (sv == "ug_orient"){
labeltext <- nodes.a[n,"sens"]
labelcol <- nodes.a[n,"color.sens"]
}
if (sv == "ug_techno"){
labeltext <- nodes.a[n,"technologie"]
labelcol <- nodes.a[n,"color.tek"]
}
if (sv == "ug_long_cm"){
labeltext <- nodes.a[n,"long_cm"]
labelcol <- nodes.a[n,"color.long_cm"]
}
if (sv == "ug_complet"){
labeltext <- nodes.a[n,"id"]
labelcol <- nodes.a[n,"color.incomp"]
}
if (sv == "ug_chr_1"){
labeltext <- ifelse(nodes.a[n,"chr_1"] != 'xxx',nodes.a[n,"chr_1"],'')
labelcol <- nodes.a[n,"color.chr_1"]
}
if (sv == "ug_tq"){
labeltext <- ifelse(!is.na(nodes.a[n,"tpq"]),
paste0(nodes.a[n,"tpq"],"/",nodes.a[n,"taq"]),'')
labelcol <- nodes.a[n,"color.tq"]
}
if (sv == "ug_closeness"){
labeltext <- ifelse(!is.na(nodes.a[n,"closeness"]),
round(nodes.a[n,"closeness"],2),'')
labelcol <- nodes.a[n,"color.closeness"]
}
if (sv == "ug_betweenness"){
labeltext <- ifelse(!is.na(nodes.a[n,"betweenness"]),
round(nodes.a[n,"betweenness"],2),'')
labelcol <- nodes.a[n,"color.betweenness"]
}
if (sv == "ug_degree"){
labeltext <- ifelse(!is.na(nodes.a[n,"degree"]),
nodes.a[n,"degree"],'')
labelcol <- nodes.a[n,"color.degree"]
}
if (sv == "ug_domition"){
labeltext <- nodes.a[n,"domition"]
labelcol <- nodes.a[n,"color.domition"]
}
f.labels.shadow(ax,ay,
label=labeltext,
col=labelcol,
bg="white",
cex=lab.sz,
r=0.2,
pos=3)
# text(ax,ay,
# pch=21,
# label=labeltext,
# col=labelcol,
# bg=labelcol,
# cex=lab.sz,
# pos=3)
}
}
f.edge.plot <- function(dd.edges,sv){
# loop through df and add edges to image
for (e in 1:nrow(dd.edges)){
xa <- dd.edges[e,"xa"];ya <- abs(dd.edges[e,"ya"])
xb <- dd.edges[e,"xb"];yb <- abs(dd.edges[e,"yb"])
typseg <- dd.edges[e,"lty"]
colseg <- dd.edges[e,"typ.color"]
segments(xa,ya,xb,yb,
col=colseg,
lty=typseg)
}
}
f.annotate <- function(img,sv,sit.a,num.a){
## annotations
# studied variable up
img <- image_annotate(img, sv, size = 30,
gravity = "northwest", color = "black")
# decor title down
tit.img <- paste0(sit.a,"\n",num.a)
img <- image_annotate(img, tit.img, size = 30,
gravity = "southwest", color = "black")
}
lab.sz <- 1.2
nd.sz <- 1.7
colramp <- c("blue","darkgreen","darkorange","darkred")
colfunc <- colorRampPalette(colramp)
is.meta <- F
verb <- F
g.stats <- c("closeness","betweenness","degree") # names of the graph analysis functions
if (is.meta){
# only for one graph/ for methodological purposes, -> doc/
chm.out.folder <- chm.doc
idx <- findex(ldecors.all,"var_cs") # read the selected decor
ldecors <- ldecors.all[[idx]]
graphs <- create.graph.view("ico_l_var_cs","objects") # call function to create view
lgrph <- load.graphs(graphs)[[1]] # load graphs
df.icos <- f.df.ico("ico_l_var_cs")
}
if (!is.meta){
# for the whole corpus, ->var/
if(corpus=="family"){
chm.out.folder <- chm.var
graphs <- create.graph.view(v.select.family,"family") # call function to create view
crp.all <- objects.df(graphs)
df.icos <- f.df.ico(v.select.family)
}
#crp.all <- crp.all[c(1:3),];df.icos <- df.icos[c(1:3),] # subset
lgrph <- load.graphs(graphs)[[1]] # load graphs
}
# lgrph <- lgrph[13:16] # subset
# lgrph[[1]]$id.in.serie
if (verb){
print(paste0("Study of variables of ",length(lgrph)," graphs ",
"saved in '",chm.out.folder,"' folder"))
}
for (a.gr in 1:length(lgrph)){
# loop through graphs
# a.gr <- 4
g <- lgrph[[a.gr]]
id.in.serie <- g$id.in.serie
print(paste0("-",id.in.serie," ",g$name))
# df.icos <- f.df.ico(v.select.obj)
# read nodes attributes
g.df <- igraph::as_data_frame(g)
sit.a <- unique(g.df$site) ; num.a<- unique(g.df$decor)
## edges - - - - - - - - - - - - - - - - - - - - - - - - - - -
dd.edges <- edges.coordinates(sit.a,num.a) # edges
dd.edges$typ[is.na(dd.edges$typ)] <- "=" # replace NA
dd.edges$lty <- ifelse(dd.edges$typ == "+",2,1)
dd.edges$typ.color <- ifelse(dd.edges$typ == "=","red",ifelse(dd.edges$typ == "x","blue","orange"))
## nodes - - - - - - - - - - - - - - - - - - - - - - - - - - -
nodes.a <- nodes.df(sit.a,num.a) # get nodes
# attributes and colors
dd.edges.sub <- subset(dd.edges, typ == "+")
nd.att <- dd.edges.sub$b
nodes.a$is.attribute <- nodes.a$id %in% nd.att
nodes.a$color.typo <- ifelse(nodes.a$is.attribute,"orange","red")
# incomplet
nodes.a$color.incomp <- ifelse(nodes.a$incomplet == 1,"grey","red")
# long_cm
llong_cm <- unique(as.numeric(na.omit(sort(nodes.a$long_cm)))) #♦ unique dim
# n.colors <- brewer.pal(length(u.val),"Spectral"),
# if no long then orange
ifelse(length(llong_cm) > 2, n.colors <- colfunc(length(llong_cm)),
ifelse(length(llong_cm) == 2, n.colors <- c(colramp[1],colramp[length(colramp)]),
ifelse(length(llong_cm) == 1, n.colors <- "orange",n.colors <- "orange")
)
) # min, max, gradient color ramp for 'stat.graph'
# add 0 when no long, TODO: change to 'X', clearer
if(length(llong_cm)==0){llong_cm <- c(0)}
df.long_cm <- data.frame(long_cm=llong_cm,
color.long_cm=n.colors,
stringsAsFactors = F)
nodes.a <- merge(nodes.a,df.long_cm,by='long_cm',all.x=T)[,union(names(nodes.a),names(df.long_cm))]
# chrono
nodes.a$color.chr_1 <- ifelse(nodes.a$chr_1 == 'xxx',"grey","red")
# # domition
# nodes.a$domition <- ifelse(is.na(nodes.a$domition),"grey","red") # useful ?
# tpq/taq
nodes.a$color.tq <- ifelse(is.na(nodes.a$tpq),"grey","red")
# verb <- T
for (a.stat in g.stats){
# a.stat <- "closeness"
if (verb){
print(paste0(" '",a.stat,"' measurement centralities"))
}
# get site & decor
g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>')
gt.i.val <- eval(parse(text = paste0("as.data.frame(",a.stat,"(g))")))
# print(paste0(" ",i,") read '",gt.i,"' for graph ",g$name))
#idf.g <- unique(vertex_attr(g, "idf", index = V(g))) # idf
# path name of the function
colnames(gt.i.val)[1] <- a.stat # modify function name
#clos <- as.data.frame(closeness(g))
#gt.i.val$dec <- unique(vertex_attr(g, "idf", index = V(g))) # idf
#clos$dec <- g$name
nd.ids <- get.vertex.attribute(g, "id", index=V(g))
gt.i.val$id <- nd.ids # remplace ids with nodes ids
# merge
nodes.a <- merge(nodes.a,gt.i.val,by='id',all.x=T)[,union(names(nodes.a),names(gt.i.val))]
# reset ?
# }
# ## values & colors - - - - - - - - - - - - - - - -
# # from graph centralities
# for (a.stat in g.stats){
# # a.stat <- "degree"
# if (verb){
# print(paste0(" '",a.stat,"' measurement centralities"))
# }
u.val <- as.numeric(na.omit(unique(nodes.a[,a.stat]))) # remove NA
# nb of different color to display
ifelse(length(u.val)>2,
n.colors <- colfunc(length(u.val)),
# n.colors <- brewer.pal(length(u.val),"Spectral"),
n.colors <- c(colramp[1],colramp[2])) # gradient color ramp for 'stat.graph'
if(length(u.val)==0){
a.stat.col.df <- data.frame(val=numeric(0),
col=character(0),
stringsAsFactors = F)
}
if(length(u.val)>0){
a.stat.col.df <- data.frame(val=u.val,
col=n.colors,
stringsAsFactors = F)
}
colnames(a.stat.col.df)[1] <- a.stat # modify with function name
colnames(a.stat.col.df)[2] <- paste0('color.',a.stat) # modify with function name
a.stat.col.df[nrow(a.stat.col.df) + 1,] = c(NA,"#D3D3D3") # add NA as light grey
nodes.a <- merge(nodes.a,a.stat.col.df,by=a.stat,all.x=T)[,union(names(nodes.a),names(a.stat.col.df))] # merge
}
# from GIS (y, x)
# high (domition) reversed
high.df <- data.frame(y=rev(sort(nodes.a$y)),
domition=length(nodes.a$y):1)
ifelse(nrow(high.df)>2,
n.colors <- colfunc(nrow(high.df)),
# n.colors <- brewer.pal(length(u.val),"Spectral"),
n.colors <- c(colramp[1],colramp[2])) # gradient color ramp for 'stat.graph'
high.df$color.domition <- rev(n.colors)
nodes.a <- merge(nodes.a,high.df,by="y",all.x=T)[,union(names(nodes.a),names(high.df))] # merge
# TODO: rank from central feature - - - - - -
# library(aspace)
# xy <- data.frame(a=nodes.a$x,b=nodes.a$y)
# res.cf <- CF(points=xy) # calcultate the central feature
# - - - - - - - - - - - - - - - - - - - - - -
# colors from attributes
# nodes.a$color.typo <- ifelse(nodes.a$type == 'indet','grey','red') # color on 'typo'
nodes.a$color.chr <- ifelse(is.na(nodes.a$tpq),'grey','red') # color on 'tpq'
nodes.a$color.sens <- ifelse(is.na(nodes.a$sens),'grey','red') # color on 'sens'
# nodes.a$color.long_cm <- ifelse(is.na(nodes.a$long_cm),'grey','red') # color on 'long_cm'
nodes.a$color.tek <- ifelse(is.na(nodes.a$technologie),'grey',
ifelse(nodes.a$technologie == 'g_piq','orange',
ifelse(nodes.a$technologie == 'g_inc','violet',
'blue')))
## labels - - - - - - - - - - - - - - - -
# label from attributes, italic if 'incomplet'
nodes.a$lbl.long_cm <- ifelse(nodes.a$incomplet == 1,
paste0("italic('",
as.character(nodes.a$long_cm),
"')"),as.character(nodes.a$long_cm))
## get nodes, edges and image
# image
img.a <- df.icos[df.icos$site == sit.a & df.icos$num == num.a,]$img # image
img.a <- image_read(img.a)
# list of studied var
studied.vars <- c("graph","ug_typo","ug_orient","ug_techno",
"ug_long_cm","ug_complet",
"ug_domition",
"ug_chr_1","ug_tq",
"ug_closeness","ug_betweenness","ug_degree")
# studied.vars <- c("ug_long_cm")
# studied.vars <- c("graph",
# "ug_domition",
# "ug_degree")
for (sv in studied.vars){
# loop through studied vars and plot infos
# sv <- "ug_long_cm"
chm.out <- paste0(chm.out.folder,id.in.serie,'_',sit.a,'_',num.a,'_',sv,'.png')
img <- image_draw(img.a)
# plot the graph with nodes numbers
f.edge.plot(dd.edges) # edges
f.nodes.plot(nodes.a,sv)
f.labels.plot(nodes.a,sv)
img <- f.annotate(img,sv,sit.a,num.a)
image_write(img,chm.out)
}
if (verb){
print (paste0(' *SAVED*'))
}
graphics.off() # close all
}
# this chunk crask because of ggplot/magick stuff
corpus <- "family" # choose 'objects' or 'family'
g.img <- c("g.grp","g.thm","g.chr","g.ort","g.dim","g.tek") # list of img to plot
writ.imgs <- F # write images in 'corpus' folder ?
idx <- findex(ldecors.all,"var_cs") # read the selected decor
ldecors <- ldecors.all[[idx]]
graphs <- create.graph.view("ico_l_var_cs","objects") # call function to create view
lgrph <- load.graphs(graphs)[[1]] # load graphs
crp.all <- objects.df(graphs)
df.icos <- f.df.ico("ico_l_var_cs")
is.meta <- T
a.contact.sheet <- paste0(chm.doc,"ico_contactsheet_xxx.png")
# save in 'D:/Projet Art Rupestre/decors/doc/'
contact.sheet.var(lgrph,crp.all,df.icos,g.img,writ.imgs,is.meta) # create cs
#include_graphics(a.contact.sheet)
shell.exec(a.contact.sheet)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# TODO:
# put the following instructions in the function "contact.sheet.grph"
# see "D:\Projet Art Rupestre\scripts\scripts_r" file "graph_analysis_by_var" working well
# but function "contact.sheet.grph()" do not create legend, or create problems
# (sic)
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
ll.graphs <- list()
n.img <- length(g.stats)
n.dec <- length(lgrph)
siz.of.img <- 4
v.box.padding <- .04
v.label.padding <- .08
# e.label.padding <- round(v.label.padding*e.coef.cex,2)
v.segment.size <- .4
v.cex.txt <- 1.5
#e.cex.txt <- round(v.cex.txt*e.coef.cex,2)
v.cex.node <- .8
for (a.g in 1:n.dec){
# a.g <- 1
g <- lgrph[[a.g]]
a.sit <- unique(get.vertex.attribute(g, "site", index=V(g)))
a.dec <- unique(get.vertex.attribute(g, "decor", index=V(g)))
a.idf <- unique(get.vertex.attribute(g, "idf", index=V(g)))
g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>')
# gt.index.df <- c("closeness") # names of the graph analysis functions
for (gt.i in g.stats){
# gt.i <- "closeness"
print(paste0("'",gt.i,"' measurement centralities"))
# path name of the function
gt.i.val <- eval(parse(text = paste0("as.data.frame(",gt.i,"(g))")))
colnames(gt.i.val)[1] <- "stat.graph" # modi fy function name
u.gt.i.val <- sort(unique(gt.i.val$stat.graph),decreasing = T) # unique vals
# change id
g.ids <- get.vertex.attribute(g, "id", index=V(g))
g <- set.vertex.attribute(g, "name", value=g.ids)
g.df <- igraph::as_data_frame(g, what="vertices")
g.df <- merge(g.df,gt.i.val,by="row.names") # merge 'g' and 'gt.i.val'
g.df <- subset(g.df,select=c("name","id","type","x","y","stat.graph"))
# # order on 'stat.graph' value and color
# g.df <- g.df[with(g.df, order(-stat.graph)), ]
# row.names(g.df) <- 1:nrow(g.df)
n.colors <- brewer.pal(length(u.gt.i.val),"Spectral") # gradient color ramp for 'stat.graph'
df.color <- data.frame(stat.graph=u.gt.i.val,
stat.graph.color=n.colors)
# merge color and df
g.df <- merge(g.df,df.color,by="stat.graph",all.x=T)
# g.df$stat.graph.color <- n.colors
# image
img.a <- df.icos[df.icos$site == a.sit & df.icos$num == a.dec,]$img # image
img.exist <- !(is.na(img.a) | img.a=="")
if (!img.exist){a.img <- image_read(paste0(chm.obj,"/empty_obj.gif"))}
if (img.exist){a.img <- image_read(img.a)} # read image
a.text <- paste0("nodes '",gt.i,"'")
# a.img <- image_annotate(a.img,a.text, size = annot.size,
# gravity = "north", color = "black")
a.image <- image_ggplot(a.img) # convert image-magick to ggplot
z.image <- a.image +
ggtitle(a.text)+
geom_point(data=g.df,x=g.df$x,y=g.df$y,aes(color=g.df$stat.graph.color),cex=2)+
geom_label_repel(data=g.df,x=g.df$x,y=g.df$y,
label=paste0(g.df$type,"\n",round(g.df$stat.graph,2)),
box.padding = unit(v.box.padding, "lines"),
label.padding = unit(v.label.padding, "lines"),
segment.size = v.segment.size,
color=g.df$stat.graph.color,
cex=1.5)+
scale_colour_identity(guide="legend",breaks=n.colors,labels=round(u.gt.i.val,2))+
theme(legend.title = element_text(size = 7),
legend.text = element_text(size = 7))+
labs(color=paste0(a.text,"\nvalues"))
# img.out <- ggsave_to_variable(z.image,siz.of.img+1,siz.of.img,300)
# img.out %>% magick::image_write(n.file)
if(is.meta){
# save images separetly
n.file <- paste0(chm.doc,as.character(a.g),"_stats_graph_",gt.i,".png")
ggsave(n.file,z.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE)
}
ll.graphs[[length(ll.graphs)+1]] <- z.image
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# create a planche of contact of m x n images
margin = theme(plot.margin = unit(c(0.5,0.5,0.5,0.5), "cm"))
if(!is.meta){
for (dev in c(".png",".pdf")){
a.contact.sheet <- paste0(chm.analysis,"/stats_ugs.png")
ggsave(file = a.contact.sheet,
arrangeGrob(grobs = lapply(ll.graphs, "+", margin), padding = unit(0.05, "line"), ncol = n.img),
height = n.dec*siz.of.img,
width = n.img*siz.of.img, dpi=300,
limitsize = FALSE)
}
}
# if(is.meta){
# a.contact.sheet <- paste0(chm.doc,"stats_graph_ugs.png")
# ggsave(file = a.contact.sheet,
# arrangeGrob(grobs = lapply(ll.graphs, "+", margin), padding = unit(0.05, "line"), ncol = n.img),
# height = n.dec*siz.of.img,
# width = n.img*(siz.of.img+1), dpi=300,
# # height = length(g.img)*siz.of.img,
# # width = nrow(crp)*siz.of.img, dpi=300,
# limitsize = FALSE)
# }
print(paste0(" ",a.contact.sheet," saved !"))
# r.start <- r.end+1 # increment start
# r.end <- r.end+max.row.cs
# #grid.arrange(grobs = ll.dec, ncol = 3)
contactsheet & variables TODO
# create one cs with all decoration from family
# select 'select.familiy' or 'select.obj'
# fill the 'corpus' folder
# TODO: create fucking contact sheet
n.col <- 10
f.family.contactsheet(select.family,n.col) #
# plot var values for each decorations
corpus <- "family" # choose 'objects' or 'family'
g.img <- c("g.grp","g.thm","g.chr","g.ort","g.dim","g.tek") # list of img to plot
# g.img <- c("g.grp","g.thm") # list of img to plot
writ.imgs <- F # write images in 'corpus' folder ?
#graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
if(corpus=="objects"){
graphs <- create.graph.view(v.select.obj,"objects") # call function to create view
crp.all <- objects.df(graphs)
df.icos <- f.df.ico(v.select.obj)
} # 'graphs.objects' or 'graphs.family'
if(corpus=="family"){
graphs <- create.graph.view(v.select.family,"family") # call function to create view
crp.all <- objects.df(graphs)
df.icos <- f.df.ico(v.select.family)
}
#crp.all <- crp.all[c(1:3),];df.icos <- df.icos[c(1:3),] # subset
is.meta <- F
lgrph <- load.graphs(graphs)[[1]] # load graphs
contact.sheet.var(lgrph,crp.all,df.icos,g.img,writ.imgs,is.meta) # create cs
#shell.exec(a.contact.sheet)
spatial
general map
# map of all the objetc of a selected family
map.type <- "family"; m.var <- "all"
family.spat <- family.df(select.family) # get objects coordinates for the family
# family.spat$idf <- as.integer(row.names(family.spat))
family.spat$idf <- as.integer(family.spat$idf.objects)
family.spat <- family.spat[with(family.spat, order(idf)), ]
# family.spat <- family.spat[c(1:15),] # sample
rownames(family.spat) <- family.spat$idf
sf.fd.carto <- f.spat.bck.grd("Europe") # load background
g.map <- f.spat.distrib(family.spat,sf.fd.carto,map.type,select.family,m.var,25,8) # create map
tit <- paste0("distribution of '",m.var,"' from '",
map.type,"' objects of '",select.family,"' (n=",nrow(family.spat),")")
if(map.type == "family"){
chm.out <- paste0(chm.etude,"spat_",select.family,".png")
}
if(map.type != "family"){
chm.out <- paste0(chm.etude,"_",select.family,"_spat.png")
}
ggsave(file = chm.out,
arrangeGrob(grobs = g.map,
top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)),
padding = unit(0.1, "line"),ncol = 1),
width = 17,height =17)
shell.exec(chm.out)
K-Ripley map
library(ggthemes)
# map of all the objetc of a selected family
# TODO R/R internet: ggthemes::geom_rug
# TODO: data ellipse center : start from central features and n nearest neighbours
# TODO: projected SRID for Kripley
spain.crs <- "+init=epsg:25830"
perc.dat <- 0.6 # percent of selected data
map.type <- "family"; m.var <- "all"
family.spat <- family.df(select.family) # get objects coordinates for the family
# family.spat$idf <- as.integer(row.names(family.spat))
family.spat$idf <- as.integer(family.spat$idf.objects)
family.spat <- family.spat[with(family.spat, order(idf)), ]
rownames(family.spat) <- family.spat$idf
sf.fd.carto <- f.spat.bck.grd("Europe") # load background
xy <- family.spat[,c("x","y")] # objects
sp.obj.prj <- SpatialPointsDataFrame(coords = xy,
data = family.spat,
proj4string= CRS(wgs84))
ell <- dataEllipse(xy$x, xy$y, levels=perc.dat) # get a 60% data ellipse
ell <- f.xy.to.sp(ell) # convert ellispe to polygon
sel.obj <- gIntersection(ell, sp.obj.prj) # objects within the data ellipse
sel.obj.dt <- data.frame(sel.obj) # for ggplot
xy <- coordinates(sel.obj) # points coordinates
ch <- chull(xy) # convexhull
coords <- xy[c(ch, ch[1]), ] # closed convexhull polygon
# convexhull to SpatialPolygon
sp.cxhl <- SpatialPolygons(list(Polygons(list(Polygon(coords)), ID=1)))
proj4string(sp.cxhl) <- CRS(wgs84)
sp.cxhl.df <- SpatialPolygonsDataFrame(sp.cxhl, data=data.frame(ID=1))
# plot(xy, pch=19);lines(coords, col="red") # plot
sf.obj <- st_as_sf(sp.obj.prj) # convert to sf
roi <- st_bbox(sf.obj) # create polygon from bbox on objets
# add margins
roi[1]<-roi[1]-spat.marg;roi[2]<-roi[2]-spat.marg;roi[3]<-roi[3]+spat.marg;roi[4]<-roi[4]+spat.marg
roi.sf <- st_as_sfc(roi) # create polygon from bbox on objets
sf.fd.carto.inter <- st_intersection(sf.fd.carto, roi.sf) # recut background
sp.obj.dt <- data.frame(sp.obj.prj)
ct <- 1
# all dataset
tit.all <- paste0("map of all '",select.obj,"' decorations (in red)")
g.all.pts <- ggplot2::ggplot(sf.fd.carto.inter) +
ggtitle(paste0(ct,". ",tit.all))+
geom_sf(aes(geometry = geometry),fill = NA)+
geom_point(data= sp.obj.dt, aes(x=x, y=y), color="red")+
annotation_scale(location = "bl",
height = unit(0.15,"cm"),
width_hint = 0.2)+
#geom_point(data=objets, aes(x=x,y=y),cex=1)+
theme_bw()
# .. + ellipse
tit.ell <- paste0(tit.all,"\nwith ",perc.dat*100,"% selection data ellipse (in blue)")
ct <- ct+1
g.all.pts.ell <- ggplot2::ggplot(sf.fd.carto.inter) +
ggtitle(paste0(ct,". ",tit.ell))+
geom_sf(aes(geometry = geometry),fill = NA)+
geom_point(data= sp.obj.dt, aes(x=x, y=y), color="red")+
# geom_sf(data=ell)
geom_polygon(data=ell,aes(x = long, y = lat), color="blue",fill=NA)+
annotation_scale(location = "bl",
height = unit(0.15,"cm"),
width_hint = 0.2)+
#geom_point(data=objets, aes(x=x,y=y),cex=1)+
theme_bw()
# selected decorations
tit.select <- paste0("map of objects inside the ellipse (selected '",select.obj,"' decorations, in red)")
ct <- ct+1
g.select.pts <- ggplot2::ggplot(sf.fd.carto.inter) +
ggtitle(paste0(ct,". ",tit.select))+
geom_sf(aes(geometry = geometry),fill = NA)+
geom_point(data= sp.obj.dt, aes(x=x, y=y), color="grey", alpha=.8)+
geom_point(data= sel.obj.dt, aes(x=x, y=y), color="red")+
annotation_scale(location = "bl",
height = unit(0.15,"cm"),
width_hint = 0.2)+
#geom_point(data=objets, aes(x=x,y=y),cex=1)+
theme_bw()
# .. + convexhull
tit.select.cvhl <- paste0(tit.select,
"\nwith convexhull as K-Ripley window (in green)")
ct <- ct+1
g.select.pts.cvhl <- ggplot2::ggplot(sf.fd.carto.inter) +
ggtitle(paste0(ct,". ",tit.select.cvhl))+
geom_sf(aes(geometry = geometry),fill = NA)+
geom_point(data= sp.obj.dt, aes(x=x, y=y), color="grey", alpha=.8)+
geom_point(data= sel.obj.dt, aes(x=x, y=y), color="red")+
# geom_sf(data=ell)
geom_polygon(data=sp.cxhl,aes(x = long, y = lat), color="green",fill=NA)+
annotation_scale(location = "bl",
height = unit(0.15,"cm"),
width_hint = 0.2)+
#geom_point(data=objets, aes(x=x,y=y),cex=1)+
theme_bw()
# inside convexhull
# TODO: pass to metric system
sel.obj.prj <- spTransform(sel.obj,CRS(spain.crs))
sel.obj.prj.dt <- data.frame(sel.obj.prj) # for ggplot
sp.cxhl.prj <- spTransform(sp.cxhl,CRS(spain.crs))
sf.fd.carto.inter.1 <- st_intersection(sf.fd.carto, st_as_sfc(sp.cxhl)) # recut background
sf.fd.carto.inter.1.prj <- st_transform(sf.fd.carto.inter.1,25830)
tit.select.in.cvhl <- paste0(tit.select,"\ninside the convexhull (region of interest, ROI)")
ct <- ct+1
g.select.pts.in.cvhl <- ggplot2::ggplot(sf.fd.carto.inter.1.prj) +
ggtitle(paste0(ct,". ",tit.select.in.cvhl))+
geom_sf(aes(geometry = geometry),fill = NA)+
# coord_sf(crs=st_crs(25830))+
coord_sf(datum=spain.crs)+
geom_point(data= sel.obj.prj.dt, aes(x=x, y=y), color="red")+
# geom_sf(data=ell)
geom_polygon(data=sp.cxhl.prj,aes(x = long, y = lat), color="green",fill=NA)+
annotation_scale(location = "bl",
height = unit(0.15,"cm"),
width_hint = 0.2)+
#geom_point(data=objets, aes(x=x,y=y),cex=1)+
theme_bw()
# sf.fd.carto.inter.1 <- st_intersection(sf.fd.carto, st_as_sfc(sp.cxhl)) # recut background
# tit.select.in.cvhl <- paste0(tit.select,"\ninside the convexhull (ROI)")
# g.select.pts.in.cvhl <- ggplot2::ggplot(sf.fd.carto.inter.1) +
# ggtitle(tit.select.in.cvhl)+
# geom_sf(aes(geometry = geometry),fill = NA)+
# geom_point(data= sel.obj.dt, aes(x=x, y=y), color="red")+
# # geom_sf(data=ell)
# geom_polygon(data=sp.cxhl,aes(x = long, y = lat), color="green",fill=NA)+
# annotation_scale(location = "bl",
# height = unit(0.15,"cm"),
# width_hint = 0.2)+
# #geom_point(data=objets, aes(x=x,y=y),cex=1)+
# theme_bw()
# K-Ripley
# sel.obj.prj <- spTransform(sel.obj,CRS(spain.crs))
# # sel.objxx <- as(st_multipoint(st_as_sf(sel.obj)),"Spatial")
# sp.cxhl.prj <- spTransform(sp.cxhl,CRS(spain.crs))
w <- as.owin(sp.cxhl.prj) # convert to owin obj
Kpts <- ppp(coordinates(sel.obj.prj)[,1],
coordinates(sel.obj.prj)[,2],
window=w)
L <- Lest(Kpts,correction="Ripley") # L-Besag
env.data <- as.data.frame(L) # to dataframe
l.stats <- colnames(env.data)
tit.select.krip <- paste0("L-Besag function of selected '",select.family,"' inside the ROI")
ct <- ct+1
# plot
g.select.pts.krip <- ggplot(env.data, aes(r, iso))+
ggtitle(paste0(ct,". ",tit.select.krip))+
# observed value
geom_line(aes(colour=c("#4d4d4d")))+
# Poisson value
# axes names and limits
ylim(min(env.data$theo)-1, max(env.data$theo)+2) +
xlab("distance (m)") + ylab("K(d)")+
theme_bw()+
theme(legend.position = c(0.1,.8))
# theme(legend.position = "left")
lbls <- c("L.iso(r)")
if ("theo" %in% l.stats){
g.select.pts.krip <- g.select.pts.krip +
geom_line(aes(r,theo,colour=c("red")),linetype = "dashed")
lbls <- c(lbls,"L.theo(r)")
}
if ("border" %in% l.stats){
g.select.pts.krip <- g.select.pts.krip +
geom_line(aes(r,theo,colour=c("blue")),linetype = "dashed")
lbls <- c(lbls,"L.bord(r)")
}
# append legend
g.select.pts.krip <- g.select.pts.krip +
scale_color_discrete(name="stats",labels = lbls)
# save
g.out <- paste0(chm.spatial,"kripley.png")
gg.kripley <- ggpubr::ggarrange(g.all.pts, g.all.pts.ell,
g.select.pts,g.select.pts.cvhl,
g.select.pts.in.cvhl,g.select.pts.krip,
ncol = 2, nrow = 3) #, align = "hv",
#widths = c(5,1), heights = c(5,1),
#common.legend = TRUE)
ggsave(file = g.out, gg.kripley,
width = 12, height=16)
shell.exec(g.out)
statistics
dimensions
# 3 diffrent plots: formats, Lxl, ternary plot
# TODO : plot 'self' = anthropomorphe
# TODO : plot objet 'incomplet'
# TODO : change 'geom_rect' to 'geom_ellispe' when 'self' = anthropomorphe
#df[sample(nrow(df),10),"self"] <- 1
gdim.formats <- function(df,
n.tot){
# TODO: not plot by list, here 'grp' var
# df <- dim.obj.Ll
# - -- - - - - - - - - - - - - - - - - - - - - - -
n.incomplet <- nrow(dim.obj.Ll[dim.obj.Ll$incomplet==1,])
mytit <- paste0("supports dimensions formats in cm (height x width) for '",select.family,"' family",
"\n",nrow(df)," with recorded dimensions on a total of ",n.tot," supports",
"\nanthropomorphic supports are displayed in 'blue'",
"\ntransparent and italic decorations names identify fragmentary supports",
" (",n.incomplet," incompletes)") # BLUE OR GREY
ll.dims <- list()
# all formats as rectangles
# for (grp in 1:nrow(df)){
for (grp in 1:max(df$grp)){
# for (grp in df$grp){
# grp <- 2
df.grp <- df[df$grp == grp,]
#df.grp <- df[grp,]
#gg.dim.formats <- ggplot(df.grp, aes(fill=ifelse(!is.na(self),"red","grey70")))+
# gg.dim.formats <- ggplot(df.grp) +
gg.dim.formats <- ggplot(df) +
#ggtitle("Supports dimensions in cm (height x width)")+
# anthropomrphe or not
geom_rect(aes(xmin = 0, xmax = larg,
ymin = 0, ymax = long,
fill = ifelse(self == 'anthropomorphe', "blue",
"red")),
alpha = .5
) +
# dimensions
geom_text(aes(x=larg/2+((larg/2)/2),y=long,label=larg,
alpha = ifelse(incomplet == 0,1,.6),
fontface = ifelse(incomplet == 0,"plain","italic")),
hjust=0,size=2.5,parse = F) +
geom_text(aes(x=larg,y=long/2,label=long,
alpha = ifelse(incomplet == 0,1,.6),
fontface = ifelse(incomplet == 0,"plain","italic")),
hjust=0,angle=270,size=2.5,parse = F) +
# name of the object
geom_text(aes(x=larg/2,y=5,label=lbl,
alpha = ifelse(incomplet == 0,1,.6),
fontface = ifelse(incomplet == 0,"plain","italic")),
hjust=0,angle=90,size=3.5,parse = F) +
xlab("width (cm)")+ylab("height (cm)") +
facet_grid( . ~idf) +
coord_fixed() +
theme_bw() +
theme(plot.title = element_text(size = 9),
axis.line = element_blank(),
panel.border = element_blank(),
panel.background = element_blank()) +
scale_colour_identity() +
scale_fill_identity() +
scale_alpha_identity() +
theme(legend.position = "none")
#scale_color_manual(guide=FALSE, values=c("red", "grey70"))+ #turn off the legend, define the colors+
ll.dims[[length(ll.dims)+1]] <- gg.dim.formats
}
#☻tG <- textGrob(mytit)
margin = theme(plot.margin = unit(c(0,0,0,0), "cm"))
g.out <- paste0(chm.analysis.o.dimensions,"obj_dim_formats.png")
# ggsave(file = g.out,
# arrangeGrob(grobs = list(tG,ll.dims),
# #top = grid::textGrob(mytit,x=0,hjust=0,gp = gpar(fontsize =10)),
# padding = unit(0, "line"), ncol = 1),
# width = 10, height=ceiling(nrow(df)/10)*3+1)
ggsave(file = g.out,
arrangeGrob(grobs = lapply(ll.dims, "+", margin),
top = grid::textGrob(mytit,x=0,hjust=0,gp = gpar(fontsize =10)),
padding = unit(0.5, "line"), ncol = 1),
width = 15, height=ceiling(nrow(df)/10)*3+1)
}
#gdim.formats(dim.obj.Ll,n.tot)
gdim.reg <- function(df,n.tot){
# TODO : plot as much as regline depending on clusters/groups
# - - - - - - - - - - - - - - - - - - - - - - - - -
# 2 dimensions - - - - - - - - - -
# df <- dim.obj.Ll
# df.data <- df[df$long > 0,]
# df.data <- df[df$larg > 0,]
# exclude incomplets from reg
# df[is.na(df$incomplet),"incomplet"] <- 0
# df <- dim.obj.Ll
min.L <- min(df$long);max.L <- max(df$long)+5
min.l <- min(df$larg);max.l <- max(df$larg)+5
df.incomplets <- df[df$incomplet == 1,]
df.complets <- df[df$incomplet == 0,]
# normality
shapiro.L <- f.shapiro(df.complets$long,0.05,"height")
shapiro.l <- f.shapiro(df.complets$larg,0.05,"width")
# mean
m.L <- mean(df.complets$long);m.l <- mean(df.complets$larg)
df.mean <- data.frame(L=m.L,
l=m.l)
fit <- lm(long ~ larg, data = df.complets)
reg.coef <- signif(summary(fit)$adj.r.squared, 5)
mytit <- paste0("supports dimensions in cm (height x width) with numeros (",nrow(df)," supports)",
"\nlinear regression (R2 = ",round(reg.coef,2),") for complete supports",
"\nmarginal plots show heights (right) and widths (bottom) for complete supports",
" with averages in cm (in red)",
"\n",shapiro.L,"\n",shapiro.l,
"\nanthropomophic supports are displayed by squares",
"\ntransparent and italic decorations names identify incomplete supports",
" (",nrow(df.incomplets)," incompletes)") # BLUE OR GREY)
if(flag.dendro.color){mytit <- paste0(mytit,"\ncolors refer to dendrogram classification except black symbols out of classification")}
# scatterplot
gg.dim.2 <- ggplot(df,aes(x=larg,y=long,colour=color,shape=self.shp))+
ggtitle(mytit)+
stat_smooth(data=df.complets, method = "lm", col = "red", alpha=0.3)+
# incomplets
geom_point(data=df.incomplets,cex=1.5,alpha=.5)+
geom_text_repel(data=df.incomplets,aes(label=idf,fontface ="italic"),alpha=.5,size=3)+
# complets
geom_point(data=df.complets,cex=1.5)+
geom_text_repel(data=df.complets,aes(label=idf),size=3)+
theme_bw()+
xlab("width (cm)")+ylab("height (cm)")+
theme(plot.title = element_text(size = 9),
axis.text = element_text(size = 7),
axis.title = element_text(size = 8),
axis.line = element_blank(),
panel.border = element_blank(),
panel.background = element_blank())+
scale_colour_identity()+
scale_shape_identity()+
scale_x_continuous(position = "top", limits = c(min(df$larg), max.l))+
ylim(min(df$long), max.L)+
theme(legend.position = "none")
## marginales plots
# width/larg - horizontal marginal boxplot - to appear at the bottom of the chart
hbp <- ggplot(df.complets, aes(x=factor(1),y=larg)) +
geom_boxplot(outlier.colour = NA,lwd=0.3) +
geom_jitter(position = position_jitter(width = 0.05)) +
# mean
geom_point(data=df.mean,x=1,y=df.mean$l,shape=3,size=4,color="red")+
geom_text_repel(data=df.mean, x=1,y=df.mean$l,label=round(df.mean$l,1),
color="red",cex=3.5,
nudge_x = 1.5) +
ylim(min(df$larg), max.l) +
coord_flip() +
theme_bw()+
theme(axis.text = element_blank(),
axis.title = element_blank(),
axis.ticks = element_blank(),
panel.border = element_blank())
# heights/long - vertical marginal boxplot - to appear at the right of the chart
vbp <- ggplot(df.complets, aes(x=factor(1),y=long)) +
geom_boxplot(outlier.colour = NA,lwd=0.3) +
geom_jitter(position = position_jitter(width = 0.05)) +
# mean
geom_point(data=df.mean,x=1,y=df.mean$L,shape=3,size=4,color="red")+
geom_text_repel(data=df.mean, x=1,y=df.mean$L,label=round(df.mean$L,1),
color="red",cex=3.5,
nudge_x = -1)+
ylim(min(df$long), max.L)+
theme_bw()+
theme(axis.text = element_blank(),
axis.title = element_blank(),
axis.ticks = element_blank(),
panel.border = element_blank())
gg.2reg <- ggpubr::ggarrange(gg.dim.2, vbp,hbp,NULL,
ncol = 2, nrow = 2, align = "hv",
widths = c(5,1), heights = c(5,1),
common.legend = TRUE)
g.out <- paste0(chm.analysis.o.dimensions,"obj_dim_lin.png")
# save
ggsave(file = g.out, gg.2reg,
width = 12, height=12)
}
# gdim.reg(dim.obj.Ll,n.tot)
# - - - - - - - - - - - - - - - - - - - - - - - - -
gdim.tern <- function(df,n.tot){
# ternary diagram for epaisseur
# TODO : plot self = anthropomorphe;closeup on data
df.tri <- df[!is.na(df$long) & !is.na(df$larg) & !is.na(df$epai),]
Tmax <- max(df.tri$long)
Lmax <- max(df.tri$larg)
Rmax <- max(df.tri$epai)
tit <- paste0("supports dimensions in cm (height, width and depth)",
"\nwith numeros of decorations",
"\ntransparent and italic decorations names identify fragmentary supports")
g.tern <-ggtern(data=df.tri,aes(long,larg,epai,colour=color)) +
#geom_point() +
ggtitle(tit)+
geom_text(aes(label=idf, alpha = ifelse(incomplet==0,1,.6),
fontface = ifelse(incomplet==0,"plain","italic")),
size=3)+
scale_colour_identity()+
scale_alpha_identity()+
theme_bw()+
theme_showarrows()+
theme(legend.position = "none")+
scale_alpha_identity()
#tern_limits(T=max(Tmax), L=max(Lmax), R=max(Rmax))
g.out <- paste0(chm.analysis.o.dimensions,"obj_dim_ternaire.png")
ggsave(file = g.out,
width = 12, height=12)
}
#"ico_l_stele_bouclier" v.select.obj
graphs.objects <- create.graph.view(v.select.obj,"family") # call function to create view
objets <- objects.df(graphs.objects) # objects
dim.obj <- subset(objets,select=c("idf", "numero", "lbl",
"long", "larg", "epai",
"self", "self.shp","incomplet"))
dim.obj$idf <- as.integer(dim.obj$idf)
n.tot <- nrow(dim.obj)
dim.obj.Ll <- dim.obj[!is.na(dim.obj$long) & !is.na(dim.obj$larg),]
dim.obj.Ll <- dim.obj.Ll[dim.obj.Ll$long > 0 & dim.obj.Ll$larg > 0,]
#dim.obj.Ll <- dim.obj[is.na(dim.obj$lbl),]
row.names(dim.obj.Ll) <- 1:nrow(dim.obj.Ll) # rename on selected
dim.obj.Ll$grp <- ceiling(as.numeric(row.names(dim.obj.Ll))/10) # to plot formats
#dim.obj.Ll$grp <- ceiling(dim.obj.Ll$idf/10) # to plot
dim.obj.Ll <- f.dendro.color(flag.dendro.color, dim.obj.Ll)
# call plots
head(dim.obj.Ll)
dim.obj.Ll <- dim.obj.Ll[dim.obj.Ll$numero %in% gr1.steles, ]
gdim.formats(df = dim.obj.Ll,
n.tot = n.tot)
gdim.reg(dim.obj.Ll,n.tot)
dim.obj.Lle <- dim.obj.Ll[!is.na(dim.obj.Ll$epai),]
# gdim.tern(dim.obj.Lle,n.tot) # PRB with ggtern
#shell.exec(g.out)
raw material
pie chart
l.objet <- family.df(select.family)
mp.tab <- f.var("mp")
df.objet.mp <- as.data.frame(table(l.objet$mp)) # effectifs
# merge on type of mp
df.objet.mp <- merge(df.objet.mp,mp.tab,by.x="Var1",by.y="mp",all.x=T)
df.objet.mp$mp_colors[is.na(df.objet.mp$mp_colors)] <- 'white'
nb.val <- length(unique(df.objet.mp$Freq))
# reorder
df.objet.mp <- df.objet.mp[with(df.objet.mp, order(Freq)), ]
df.objet.mp$mp_colors <- factor(df.objet.mp$mp_colors,levels = df.objet.mp$mp_colors)
tit <- paste0("raw materials of '",select.family,"' family (n = ",
nrow(l.objet[l.objet$mp != 'unknown',])," with raw material recorded)")
# plot
gg.mp <- ggplot(data = df.objet.mp, aes(x = "", y = Freq, fill = mp_colors)) +
ggtitle(tit)+
geom_bar(stat = "identity") +
#bck
geom_text(aes(label = Freq, fontface="bold"),
color="white",position = position_stack(vjust = 0.5),cex=4) +
geom_text(aes(label = Freq),
color="black",position = position_stack(vjust = 0.5),cex=4) +
coord_polar(theta = "y") +
blank_theme +
theme(plot.title = element_text(size = 9),
legend.title = element_text(size = 8),
legend.text = element_text(size = 7),
legend.key.size = unit(1,"line"),
axis.text.x=element_blank())+
scale_fill_identity("mp",guide = "legend",labels = df.objet.mp$Var1)
g.out <- paste0(chm.analysis.o.rawmaterial,"stat_raw_materials.png")
ggsave(g.out,
gg.mp)
shell.exec(g.out)
spatial
# TODO: K-ripley
map.type <- "family"
m.var <- "mp"
mp.tab <- f.var("mp")
# named vector
mp.colors <- mp.tab$mp_colors
names(mp.colors) <- as.character(mp.tab$mp)
family.spat <- family.df(select.family) # get objects coordinates for the family
family.spat$idf <- as.integer(family.spat$idf.objects)
# family.spat <- family.spat[c(1:15),] # sample
sf.fd.carto <- f.spat.bck.grd("Europe") # load background
g.map <- f.spat.distrib(family.spat,sf.fd.carto,map.type,select.family,m.var,25,8) # create map
nb.miss.mp <- nrow(family.spat[family.spat$mp == 'unknown',]) # nb of missiong mp
tit <- paste0("distribution of '",m.var,"' from '",
map.type,"' objects from '",select.family,"' (n = ",nrow(family.spat)," )",
"\n with ",nb.miss.mp," objects having a missing information for raw material (white symbols)")
chm.out <- paste0(chm.analysis.o.rawmaterial,"spat_raw_materials.png")
ggsave(file = chm.out,
arrangeGrob(grobs = g.map,
top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)),
padding = unit(0.1, "line"),ncol = 1),
width = 17,height =17)
shell.exec(chm.out)
chronologie TODO
# chronology of objects
## TODO seriate, lbl, order...
map.type <- "family"
family.chr <- family.df(select.family) # get objects coordinates for the family
family.chr$idf <- as.integer(row.names(family.chr))
#family.chr$lbl <- paste0(family.chr$site,'.',family.chr$numero)
family.chr$lbl <- gsub(" ", "", family.chr$lbl, fixed = TRUE)
family.chr$lbl <- gsub("(", "", family.chr$lbl, fixed = TRUE)
family.chr$lbl <- gsub(")", "", family.chr$lbl, fixed = TRUE)
#objets$lbl <- stringr::str_replace_all(objets$lbl, "[^[:alnum:]]", "")
#gsub(" ", "", paste0(objets$site,'.',objets$numero), fixed = TRUE)
tit <- paste0("chronology of '",
map.type,"' objects from '",select.family,"' (n=",nrow(family.chr),")")
g.chr <- ggplot(objets) +
ggtitle(tit)+
geom_rect(aes(xmin = tpq, xmax = taq,
ymin = idf-.4, ymax = idf+.4,
fill=chr_1))+
geom_text(aes(x = tpq+(abs(tpq-taq)/2), y = idf,
label = lbl), size=3,parse = TRUE)+
scale_y_continuous(breaks = seq(1, nrow(objets), by=1))+
theme_bw()+
theme(panel.grid.minor = element_blank())
g.out <- paste0(chm.analysis.o.chr,"obj_chrono_frise.png")
ggsave(file = g.out, g.chr,
width = 17,height =17)
shell.exec(g.out)
DECORATIONS
Graph analysis
info
dataframe
# listing describing graphs
# export listings of decors and list of common links as png
# with or without attributes of the graphs (density, n of edges, etc.)
# TODO: check rm.attributes on/off
corpus <- "family" # choose 'objects' or 'family'
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
lgrph <- load.graphs(graphs)[[1]] # load graphs
df.g.infos <- f.g.infos(lgrph)
#fpng.df(df.g.infos,paste0(chm.analysis.histo,"info_graphs.png"))
p.var <- f.corresp.tab(df.g.infos,50)
tit <- paste0("graph informations for '",select.family,"' family",
"\nonly for existing graphs, at least one edge (n = ",length(lgrph),")")
#ifelse(rm.attributes, tit <- paste0(tit," without nodes/edges attributes"),tit)
g.out <- paste0(chm.analysis.dec.histo,"all_graphs_info.png")
ggsave(file = g.out, grid.arrange(top=tit, p.var),
width=length(p.var)*10, height=ceiling(length(lgrph)/10)+9)
shell.exec(g.out)
by decorations TODO
corpus <- "family" # choose 'objects' or 'family'
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
lgrph <- load.graphs(graphs)[[1]] # load graphs
a.graph <- lgrph[[40]]
df.g.infos <- f.g.infos(lgrph)
histograms
ug types
histo
# TODO: stacked with chr_1
# TODO: adapt for "objects"
graphs.family <- create.graph.view(v.select.family,"family") # choose "family" or "objects"
for (rm.att in c(T,F)){
# with attributes and withourt attributes
# rm.att <- F # remove attributes
family.ico <- family.ico.df(select.family)
if (rm.att){
# rm attributes
df.nd.attributs <- df.nodes.are.attributs(graphs.family)
family.ico <- family.ico[family.ico$lbl %notin% df.nd.attributs$lbl,]
att.text <- "without"
}
if (!rm.att){att.text <- ""}
#a.family <- unique(family.ico$famille)
tit <- paste0("number of themes from '",select.family,
"' family objects, ",att.text,
" counting nodes attributes (nb total of ugs = ",nrow(family.ico),")")
df.family.ico <- as.data.frame(table(family.ico$type))
df.family.ico <- df.family.ico[df.family.ico$Var1 != 'indet',] # rm
df.family.ico <- df.family.ico[df.family.ico$Var1 != 'ug',] # rm
# reorder
df.family.ico <- df.family.ico[rev(order(df.family.ico$Freq)),]
df.family.ico$Var1 <- factor(df.family.ico$Var1,levels = df.family.ico$Var1)
#rownames(df.family.ico) <- 1:nrow(df.family.ico)
gg.histo <- ggplot(df.family.ico, aes(x=Var1,y=Freq)) +
ggtitle(tit)+
geom_bar(stat = "identity",alpha=.3)+
geom_text(aes(label=Freq),hjust=0.5,vjust=-1,size=2.5,parse = F)+
blank_theme +
theme(plot.title = element_text(size = 9),
axis.text = element_text(size = 8),
axis.text.x = element_text(angle = 90, hjust=1, vjust=0))
margin = theme(plot.margin = unit(c(0,0,0,0), "cm"))
#out.histo <- paste0(chm.analysis.dec.histo,tit.typedg,"_histo",".png")
out.histo <- paste0(chm.analysis.dec.histo,"nodes_",att.text,"_attributes_histo.png")
ggsave(file = out.histo,
width = 8, height=6)
}
shell.exec(out.histo)
listing TODO
# TODO
edges types
histograms
corpus <- "family" # choose 'objects' or 'family'
thres <- 50 # only the x more numerous
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
lgrph <- load.graphs(graphs)[[1]] # load graphs
studied.edg <- f.tot.edges(lgrph) # load all edges
df.typ_edges <- f.typ.edges(studied.edg,lgrph) # call funct
sum.col <- as.numeric(as.data.frame(df.typ_edges %>% summarise_all(funs(sum))))
nme.col <- colnames(df.typ_edges)
df.typ_edges.count <- data.frame(typedge=nme.col,
nb=sum.col,
stringsAsFactors = F)
for(typrel in c('=','+')){
# typrel <- '+'
# subset
typrel.regex <- paste0("\\",typrel)
df.typ_edges.count.sel <- df.typ_edges.count[grep(typrel.regex,df.typ_edges.count$typedge),]
df.typ_edges.count.sel <- df.typ_edges.count.sel[!is.na(df.typ_edges.count.sel$typedge),]
nmax <- max(df.typ_edges.count.sel$nb)
# reorder
df.typ_edges.count.sel <- df.typ_edges.count.sel[rev(order(df.typ_edges.count.sel$nb)),]
df.typ_edges.count.sel$typedge <- factor(df.typ_edges.count.sel$typedge,
levels = df.typ_edges.count.sel$typedge)
df.typ_edges.count.sel <- df.typ_edges.count.sel[c(1:thres),]
df.typ_edges.count.sel <- df.typ_edges.count.sel[!is.na(df.typ_edges.count.sel$typedge),]
#rownames(df.family.ico) <- 1:nrow(df.family.ico)
if(typrel == '='){tit.typedg <- "edges_normal"}
if(typrel == '+'){tit.typedg <- "edges_attributes"}
tit <- paste0("number of the ",thres," more common '",tit.typedg,
"' from the '",select.family,"' family objects",
"\n(nb of '",typrel,"' edges = ",sum(df.typ_edges.count.sel$nb),")")
gg.histo <- ggplot(df.typ_edges.count.sel, aes(x=typedge,y=nb)) +
ggtitle(tit)+
geom_bar(stat = "identity",alpha=.3)+
geom_text(aes(label=nb),hjust=0.5,vjust=1.5,size=2.5,parse = F)+
geom_text(aes(label=typedge,angle = 45),hjust=0,vjust=-.5,size=3,parse = F)+
blank_theme+
theme(axis.text.x = element_blank())+
coord_cartesian(clip = 'off') +
theme(plot.margin = unit(c(0,2,0,0), "cm"))+
scale_y_continuous(limits = c(0, nmax +20))
margin = theme(plot.margin = unit(c(0,0,0,0), "cm"))
out.histo <- paste0(chm.analysis.dec.histo,tit.typedg,"_histo",".png")
ggsave(file = out.histo, gg.histo,
width = 10, height=6)
}
shell.exec(out.histo)
listing TODO
# export listings of decors and list of common links as png
# with or without attributes of the graphs (density, n of edges, etc.)
# TODO : check rm.attributes on/off
corpus <- "family" # choose 'objects' or 'family'
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
lgrph <- load.graphs(graphs)[[1]] # load graphs
studied.edg <- f.tot.edges(lgrph) # load all edges
indet.rm <- grep("indet",studied.edg)
if (length(indet.rm)>0){
studied.edg <- studied.edg[-indet.rm] # rm indet
}
df.typ_edges <- f.typ.edges(studied.edg,lgrph) # call funct
ico.listing.var <- data.frame(idf=new.col.nmes[1:ncol(df.typ_edges)],
var=colnames(df.typ_edges),
stringsAsFactors = F)
# usefull ?
colnames(df.typ_edges) <- new.col.nmes[1:ncol(df.typ_edges)] # simplify colnames
n.max.h <- 50
corres.tab <- f.corresp.tab(ico.listing.var,n.max.h)
#n.row <- nrow(ico.listing.var)/n.max.h
#fpng.df(ico.listing.var,paste0(chm.analysis.e.histo,"listing.png"))
#p.var <- tableGrob(ico.listing.var,theme=ttheme_default(base_size = 7),rows=NULL)
tit <- "edges informations"
#ifelse(rm.attributes, tit <- paste0(tit," \nwithout edges from nodes attributes"),tit)
g.out <- paste0(chm.analysis.dec.histo,"edges_listing.png") # chm.analysis.dec.histo
ggsave(file = g.out,
corres.tab,
height = ceiling(nrow(ico.listing.var)/7)+3,
width = (length(corres.tab)*4)+2)
shell.exec(g.out)
Nodes analysis
Plot dendrogramm colors on objects identifiers if 'flag.dendro.color' is TRUE
types
spatial XXX
# list missing scales
# map.type <- "type"
# TODO: distinguish btw ug and attributes
# TODO: change size depending on count in 'type' field
m.var <- "type"; map.type <- "all"
graphs.family <- create.graph.view(v.select.family,"family") # choose "family" or "objects"
# with attributes and withourt attributes
# rm.att <- T # remove attributes
# recover the object number
family.ico <- family.ico.df(select.family)
family.ico$num.objects <- paste0(family.ico$site,'.',family.ico$decor)
family.numb <- family.df(select.family)
family.numb <- subset(family.numb, select=c(lbl,idf.objects))
family.ico <- merge(family.ico,family.numb,by.x="num.objects",by.y="lbl",all.x=T)
# family.ico <- subset(family.ico, select=c(num.objects,site,decor,type))
# lgrph <- load.graphs(graphs)[[1]] # load graphs
# rm attributes
df.nd.attributs <- df.nodes.are.attributs(graphs.family)
family.ico <- family.ico[family.ico$lbl %notin% df.nd.attributs$lbl,]
att.text <- "without"
# order on count
nb.types <- as.data.frame(table(family.ico$type))
nb.types <- nb.types[with(nb.types, order(-Freq)), ]
rownames(nb.types) <- 1:nrow(nb.types)
# remove 'ug' and 'indet'
nb.types <- nb.types[nb.types$Var1 %notin% c("indet","ug"),]
ct <- 1 # for filenames
# nb.types$Var1 <- head(nb.types$Var1,3)
for (typ in nb.types$Var1){
# typ <- "bouclier"
family.ico.sel <- family.ico[family.ico$type == typ,]
# count by decoration
family.ico.ct <- aggregate(type ~ idf.objects + site + decor + x + y,
data = family.ico.sel,
FUN = length)
typ.tot <- sum(family.ico.ct$type) # total nub of occurences
# family.ico.ct$idf <- 1:nrow(family.ico.ct)
# to get the right number and ordered df
family.ico.ct$idf <- family.ico.ct$idf.objects
family.ico.ct <- family.ico.ct[with(family.ico.ct, order(idf.objects)), ]
sf.fd.carto <- f.spat.bck.grd("Europe") # load background
g.map <- f.spat.distrib(family.ico.ct,sf.fd.carto,map.type,select.family,m.var,25,8) # create map
# family.ico.ct <- aggregate(x=family.ico.sel$type,
# by=list(family.ico.sel$site,family.ico.sel$decor),
# FUN = count)
tit <- paste0("distribution of '",typ,"' from '",
map.type,"' objects of '",select.family,"' (n=",nrow(family.ico.ct),")")
chm.out <- paste0(chm.analysis.n.typo,"ugs_typ_",ct,"_",typ,"_(",typ.tot,"_occurences).png")
ggsave(file = chm.out,
arrangeGrob(grobs = g.map,
top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)),
padding = unit(0.1, "line"),ncol = 1),
width = 17,height =17)
ct <- ct+1
}
# shell.exec(chm.out)
#
# }
# if (!rm.att){att.text <- ""}
# #a.family <- unique(family.ico$famille)
# tit <- paste0("number of themes from '",select.family,
# "' family objects, ",att.text,
# " counting nodes attributes (nb total of ugs = ",nrow(family.ico),")")
# df.family.ico <- as.data.frame(table(family.ico$type))
# df.family.ico <- df.family.ico[df.family.ico$Var1 != 'indet',] # rm
# df.family.ico <- df.family.ico[df.family.ico$Var1 != 'ug',] # rm
# # reorder
# df.family.ico <- df.family.ico[rev(order(df.family.ico$Freq)),]
# df.family.ico$Var1 <- factor(df.family.ico$Var1,levels = df.family.ico$Var1)
# #rownames(df.family.ico) <- 1:nrow(df.family.ico)
# }
#
# map.type <- "family";m.var <- "all"
# family.spat <- family.df(select.family) # get objects coordinates for the family
# # family.spat$idf <- as.integer(row.names(family.spat))
# family.spat$idf <- as.integer(family.spat$idf.objects)
# family.spat <- family.spat[with(family.spat, order(idf)), ]
# rownames(family.spat) <- family.spat$idf
# sf.fd.carto <- f.spat.bck.grd("Europe") # load background
# g.map <- f.spat.distrib(family.spat,sf.fd.carto,map.type,select.family,m.var) # create map
# tit <- paste0("distribution of '",m.var,"' from '",
# map.type,"' objects from '",select.family,"' (n=",nrow(family.spat),")")
# if(map.type == "family"){
# chm.out <- paste0(chm.etude,"spat_",select.family,".png")
# }
# if(map.type != "family"){
# chm.out <- paste0(chm.etude,"_",select.family,"_spat.png")
# }
# ggsave(file = chm.out,
# arrangeGrob(grobs = g.map,
# top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)),
# padding = unit(0.1, "line"),ncol = 1),
# width = 17,height =17)
dimensions
missing scales
# list missing scales
corpus <- "family" # choose 'objects' or 'family'
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
# condition
if (corpus == 'family'){
sqll.CONDITION <- paste0(" famille LIKE '",select.family,"' AND ")
}
if (corpus == 'objects'){
# create list
lobj.sit <- paste0("('",paste0(graphs$site,collapse="','"),"')")
lobj.num <- paste0("('",paste0(graphs$numero,collapse="','"),"')")
# condition
sqll.CONDITION <- paste0(" site IN ",lobj.sit," AND numero IN ",lobj.num," AND ")
}
# select
sqll.SELECT <- paste0("SELECT site,numero FROM objets WHERE ",sqll.CONDITION,
"(site,numero) IN (SELECT site,decor FROM table_echelles) ",
"ORDER BY site,numero")
sqll.SELECT.NOT <- paste0("SELECT site,numero FROM objets WHERE ",sqll.CONDITION,
"(site,numero) NOT IN (SELECT site,decor FROM table_echelles) ",
"ORDER BY site,numero")
df.missing.scales <- dbGetQuery(con,sqll.SELECT.NOT)
df.missing.scales$scale <- "MISSING"
df.existing.scales <- dbGetQuery(con,sqll.SELECT)
df.existing.scales$scale <- "EXISTS"
dbDisconnect(con)
print(paste0("there are ",nrow(df.existing.scales)," decors with EXISTING scales"))
print(df.existing.scales)
#print(df.missing.scales)
#grid.arrange(top="missing.scales", tableGrob(df.missing.scales))
print(paste0("there are ",nrow(df.missing.scales)," decors with MISSING scales"))
print(df.missing.scales)
lengths
by decorations
Compute the absolute or relative length for each ug of decorations
# study dimensions of ug
# corpus <- "family" # choose 'objects' or 'family'
# graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
# lgrph <- load.graphs(graphs) # load graphs
# lgrph <- rm.specific.nd(lgrph,"indet") # remove 'indetx'
# ugs <- ug.select.obj(graphs)
# ugs$lbl <- paste0(ugs$site,'.',ugs$decor)
# ugs <- merge(ugs,graphs,by="lbl")
# ugs$lbl <- paste0(ugs$idf,'.',ugs$lbl)
corpus <- "family" # choose 'objects' or 'family'
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
graphs <- graphs[graphs$numero %in% gr1.steles, ]
#lgrph <- rm.specific.nd(lgrph,"indet") # remove 'indetx'
ugs <- ug.select.obj(graphs)
# ugs$lbl <- paste0(ugs$decor)
ugs$lbl <- paste0(ugs$site,'.',ugs$decor)
ugs <- merge(ugs, graphs,by = "lbl")
ugs$lbl <- paste0(ugs$idf,'.',ugs$lbl)
# ugs$lbl <- paste0(ugs$idf,'.',ugs$decor)
#ugs <- ugs[!is.na(ugs$long_cm),] # remove NA
if (length(grep("indet", ugs$type)) > 0){
ugs <- ugs[-grep("indet",ugs$type),] # remove 'indet*'
}
#ugs <- head(ugs,400)
fg.dim.by.dec(ugs,
corpus,
"long_cm",
"abs",
text.size = 16,
label.size.dimension = 4,
label.size.type = 6) # 'long' or 'long_cm' | 'rel' or 'abs'
by types
# TODO: italic and alpha on incomplets
corpus <- "family" # choose 'objects' or 'family'
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
ugs <- ug.select.obj(graphs)
ugs$lbl <- paste0(ugs$site,'.',ugs$decor)
ugs <- merge(ugs,graphs,by="lbl")
ugs.long_cm <- ugs[!is.na(ugs$long_cm),] # remove NA
if (length(grep("indet",ugs.long_cm$type))>0){
ugs.long_cm <- ugs.long_cm[-grep("indet",ugs.long_cm$type),] # remove 'indet*'
}
ugs.long_cm <- f.dendro.color(flag.dendro.color,ugs.long_cm)
# classification colors
if (flag.dendro.color){
# merge on dendrogramm colors
#ugs.long_cm <- merge(ugs.long_cm,df.dist.mat.sel.ord,by.x="idf",by.y="idf")
tit.colored <- paste0("\ncolors refer to the dendrogram reordered on '",orig.thm,"' distance except grey colors out of dendrogram")
}
if (!flag.dendro.color){ugs.long_cm$color <- "black"}
# incomplets
flag.incomplet <- F
ugs.long_cm.incomp <- ugs.long_cm[ugs.long_cm$incomplet == 1,] # get incomplet
if (nrow(ugs.long_cm.incomp)>0){
ugs.long_cm.incomp$idf.lbl <- paste0("italic('",as.character(ugs.long_cm.incomp$idf),"')")
ugs.long_cm <- ugs.long_cm[ugs.long_cm$incomplet != 1,] # remove incomplet
flag.incomplet <- T
}
# ugs.long_cm <- head(ugs.long_cm,100) # subset
# counts on complete
n.ugs <- nrow(ugs.long_cm) # nb of different ugs, ie nb of points, for ggplot height
n.thm <- length(unique(ugs.long_cm$type)) # nb of different types, for ggplot width
ugs.long_cm.mean <- aggregate(ugs.long_cm$long_cm,
by=list(Category=ugs.long_cm$type), FUN=mean)
ugs.long_cm.mean <- ugs.long_cm.mean[with(ugs.long_cm.mean, order(-x)), ]
ugs.long_cm.mean$lbl <- paste0(" ",as.character(round(ugs.long_cm.mean$x,1))) # mean label for ggplot
ugs.long_cm$type <- factor(ugs.long_cm$type, levels=ugs.long_cm.mean$Category) # order on mean
n.obj <- length(unique(ugs.long_cm$lbl))
bxplt.w <- .3
pos <- position_jitter(width = bxplt.w, seed = 1)
# title
tit.corpus <- f.tit.corpus(corpus,length(unique(ugs.long_cm$decor)),n.ugs)
tit.sup <- "\nwith numeros of decorations"
if (flag.incomplet){
tit.sup <- paste0(tit.sup,"\nincomplete ugs are displayed in shaded italic")
}
tit <- paste0("seriation of length of ugs ",tit.corpus," by types of ugs, in cm",tit.sup)
if (flag.dendro.color){tit <- paste0(tit,tit.colored)}
# ugs.long_cm <- ugs.long_cm[c(1:50),] # sample
# graph
gg.ugs.dim.by.types <- ggplot(ugs.long_cm,aes(x=type,y=long_cm,color=color))+
ggtitle(tit)+
geom_boxplot(color="darkgrey", fill = NA, fatten = 1.5,
width=bxplt.w,lwd=0.5,outlier.shape = NA) +
# mean
geom_point(data=ugs.long_cm.mean,aes(x=Category, y= x), pch =3, size=2, color="red")+
geom_text(data=ugs.long_cm.mean,aes(x=Category, y= x, label=lbl, hjust=0), size = 2.5, color = "red")+
# ugs
geom_point(position = pos,size=1.5)+ # ugs
geom_label_repel(aes(label=idf),
force = .5,
segment.size = .3, segment.alpha = .5,
size = 3, label.size = NA, fill= NA, position = pos)+
theme_bw()+
theme(plot.title = element_text(size = 10))+
theme(axis.title.x = element_blank())+
theme(axis.text=element_text(size=7))+
scale_alpha_identity()+
scale_color_identity()+
scale_y_continuous(breaks = seq(0,max(ugs.long_cm$long_cm), by = 5))
if (flag.incomplet){
# add incomplets to the plot
gg.ugs.dim.by.types <- gg.ugs.dim.by.types +
geom_point(data=ugs.long_cm.incomp,
aes(x=type,y=long_cm,alpha=alpha.incomp),
size = 1.5) +
geom_text_repel(data=ugs.long_cm.incomp,
aes(x=type,y=long_cm, label=idf.lbl,alpha=alpha.incomp),
size = 3,parse = TRUE)
}
for (dev in c(".png")){
g.out <- paste0(chm.analysis.n.dimensions,"ugs_abs_dim_by_types",dev)
ggsave(g.out,
gg.ugs.dim.by.types,
height = (n.obj/5)+5,
width = (n.obj/3)+6)
}
shell.exec(g.out)
relative dimensions groups TODO
Calculate the dimension group of ugs dependeing on their relative proportions
f.dim.proport <- function(listing.prop){
# read the listing of inter-ugs relative lengths
# ex: if val=1 and proport.coef=2 then realistic proportions = [1/2:1*2])
# => [0.5:2]
df.proport <- openxlsx::read.xlsx(paste0(chm.ug,listing.prop),
sheet="proportions",
colNames = T,
skipEmptyRows=TRUE)
#df.proport <- df.proport[-c(1,2),]
df.names <- as.character(na.omit(df.proport[,1]))
row.names(df.proport) <- df.names
df.proport <- df.proport[,-1]
# populate upper triangle with inverted proportions
df.proport[upper.tri(df.proport)] <- 1/t(df.proport)[upper.tri(df.proport)]
# replace 'NULL' values with NA
df.proport <- df.proport %>% replace(.=="NULL", NA)
return(df.proport)
}
f.dim.rules <- function(listing.prop){
# read the listing of inter-ugs relative dimensions rules
# that will be eval() in R
# ex: 'lance' > 'bouclier' means 'lance' must be superior to dim 'bouclier'
# listing.prop <- proportions.rel
df.proport <- openxlsx::read.xlsx(paste0(chm.ug,listing.prop),
sheet="rules",
colNames = T,
skipEmptyRows=TRUE)
return(df.proport)
}
f.dim.rules.test <- function(thm.a,thm.b,long.a,long.b){
# check if there is a specific rule for themes
dim.rules <- F
for (rule in 1:nrow(df.dim.rules)){
# loop through rules
# rule <- 1
a.rule <- df.dim.rules[rule,]
thm.a.in.rule <- str_detect(a.rule,thm.a)
thm.b.in.rule <- str_detect(a.rule,thm.b)
if (thm.a.in.rule & thm.b.in.rule){
dim.rules <- T
# split in 3 parts, ex: 'lance' '>' 'bouclier'
exp <- strsplit(a.rule, " ")[[1]]
termA <- exp[1];oper <- exp[2];termB <- exp[3]
if (thm.a == termA){
# normal
exp.normal <- paste0(long.a,oper,long.b)
rule.result <- eval(parse(text=exp.normal))
print(paste0("'",a.rule,"' with '",
thm.a,"'(",long.a,"px) ",
oper," '",thm.b,"'(",long.b,"px) gives: ",
rule.result))
return(rule.result)
}
if (thm.a == termB){
# inverse
# if(oper=='>'){not.oper <- "<"}
# if(oper=='<'){not.oper <- ">"}
# if(oper=='>='){not.oper <- "<="}
# if(oper=='<='){not.oper <- ">="}
exp.inverted <- paste0(long.b,oper,long.a)
rule.result <- eval(parse(text=exp.inverted))
print(paste0("'",a.rule,"' with '",
thm.b,"'(",long.b,"px) ",
oper," '",thm.a,"'(",long.a,"px) gives: ",
rule.result))
return(rule.result)
}
}
return(NA) # no rules
}
}
# TODO: peut certainement etre simplifié
proportions.rel <- "proportions.xlsx" # listing of inter-ugs relative lengths
proport.coef <- 2 # coefficient of proportion
verb <- T # verbose
graphs.objects <- create.graph.view(v.select.obj,"objects") # call function to create view
graphs <- graphs.objects # choose 'graphs.objects' or 'graphs.family'
lgrph <- load.graphs(graphs)[[1]] # load graphs
#plot(lgrph[[1]])
df.dim.proport <- f.dim.proport(proportions.rel) # load proportion listing
df.dim.rules <- f.dim.rules(proportions.rel) # load proportion listing
# loop through graphs
graphs <- graphs[4,]
for(a.g in 1:nrow(graphs)){
# a.g <- 1
lproport <- lreal.ids <- lirreal.ids <- lna.val <- list() # lists of OK, NOT OK and NA val
a.sit <- graphs[a.g,"site"]
a.dec <- graphs[a.g,"numero"]
print(paste0(a.sit,".",a.dec))
# get nodes attributes
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
# get ugs
sqll.ugs <- paste0("SELECT id,type,long FROM table_noeuds WHERE ",
"site LIKE '",a.sit,"' AND decor LIKE '",a.dec,"' ",
"AND long IS NOT NULL")
df.ugs <- dbGetQuery(con,sqll.ugs)
# clear gr_dim
sqll.update <- paste0("UPDATE table_noeuds SET gr_dim=NULL WHERE ",
"site LIKE '",a.sit,"' AND decor LIKE '",a.dec,"'")
dbGetQuery(con,sqll.update)
dbDisconnect(con)
#df.ugs$prop.family <- NA
# all pairwise combinations
df.compar.ugs <- as.data.frame(t(combn(df.ugs$id, 2)))
colnames(df.compar.ugs) <- c('a','b')
for (a.ug in 1:nrow(df.compar.ugs)){
# loop through id
# a.ug <- 1
# get row
id.a <- df.compar.ugs[a.ug,"a"]
id.b <- df.compar.ugs[a.ug,"b"]
# get thm min and max proportions in 'df.dim.proport'
thm.a <- df.ugs[df.ugs$id == id.a,"type"]
long.a <- df.ugs[df.ugs$id == id.a,"long"]
thm.b <- df.ugs[df.ugs$id == id.b,"type"]
long.b <- df.ugs[df.ugs$id == id.b,"long"]
if(is.na(long.a)){long.a <- "XX"};if(is.na(long.b)){long.b <- "XX"}
long.exist <- (is.numeric(long.a) & is.numeric(long.b)) # exist numerical values
val <- as.numeric(df.dim.proport[thm.a,thm.b])
if (verb){
print(paste0("row ",a.ug,": ",
"[",id.a,"] ",thm.a," (",long.a,"px) - *",
val," - [",id.b,"] ",thm.b," (",long.b,"px)"))
}
# first, test on rules if exist - - - - - - - - - - - - - - - - -
if(long.exist){
res.rule <- f.dim.rules.test(thm.a,thm.b,long.a,long.b)
if (!is.na(res.rule)){
# if res.rule = NA means there's no rule yet for these thm
if(res.rule){
# # in one sublists
# if (length(lproport) == 0){
# lproport[[length(lproport)+1]] <- c(id.a,id.b)
# }
# if (length(lproport) > 0){
# # find index
# }
lreal.ids[[length(lreal.ids)+1]] <- c(id.a,id.b)
}
if(!res.rule){
# # in two different sublists
# if (length(lproport) == 0){
# lproport[[length(lproport)+1]] <- id.a
# lproport[[length(lproport)+1]] <- id.b
# }
# if (length(lproport) > 0){
# # find index
# }
# useful ?
lirreal.ids[[length(lirreal.ids)+1]] <- c(id.a,id.b)
}
}
}
# if no rules, test on proportions - - - - - - - - - - - - - - - - - - - -
# thm exist in 'df.dim.proport'
exist.thm <- (thm.a %in% row.names(df.dim.proport) & thm.b %in% row.names(df.dim.proport))
if(exist.thm & is.na(res.rule)){
if(!is.na(val) & long.exist){
if(val>=1){
# normal
dim.max <- long.a/(val/proport.coef)
dim.min <- long.a/(val*proport.coef)
}
if(val<1){
# inverse
dim.min <- long.a*(1/(val*proport.coef))
dim.max <- long.a*(1/(val/proport.coef))
}
realistic.prop <- (long.b >= dim.min & long.b <= dim.max)
if (realistic.prop){
# strore ids with realistic proportions
lreal.ids[[length(lreal.ids)+1]] <- c(id.a,id.b)
if (verb){
print(paste0(" Yes realistic : coef= ",round(val,2),", ",thm.b,
" btw ",round(dim.min,2),"px and ",round(dim.max,2),"px"))
}
}
if (!realistic.prop){
if (verb){
print(paste0(" NO irrealistic : coef= ",round(val,2),", ",thm.b,
" btw ",round(dim.min,2),"px and ",round(dim.max,2),"px"))
}
}
}
}
}
# # group ids with realistic proportions
reduced <- T ; thick <- 1
while (reduced){
# loop until impossible to reduce length of list
if (thick == 1){
# start
# all pairwise combinations
if(length(lreal.ids)>1){
df.in <- as.data.frame(t(combn(c(1:length(lreal.ids)), 2)))
colnames(df.in) <- c("g1","g2")
}
if(length(lreal.ids)==1){
df.in <- data.frame(g1=lreal.ids[[1]][1],
g2=lreal.ids[[1]][2])
}
ll.in <- lreal.ids
}
if (thick > 1){
# steps
df.in <- as.data.frame(t(combn(c(1:length(ll.out)), 2)))
colnames(df.in) <- c("g1","g2")
ll.in <- ll.out
}
lenIN <- length(ll.in)
if (verb){print(paste0("loop ",thick," - length of IN list : ",lenIN))}
ll.out <- list() # new out list
# compare groups and merge intersected group in new list
for (r in 1:nrow(df.in)){
# r <- 1
g1 <- df.in[r,"g1"];g2 <- df.in[r,"g2"]
if(length(ll.in)>1){
same.grp <- intersect(ll.in[[g1]],ll.in[[g2]]) # pick in the list
if(length(same.grp)>0){
grp <- sort(unique(c(ll.in[[g1]],ll.in[[g2]])))
#names(my_list)
ll.out[[length(ll.out)+1]] <- grp
}
}
}
ll.out <- unique(ll.out)
# merge with nodes existing in ll.in
if(length(ll.in)>0){
# ex: not Substantio
for (i in 1:length(unique(ll.in))){
#i <- 1
#already.in <- length(intersect(ll.in[[i]],ll.out))
already.in <- length(intersect(ll.in[[i]],unlist(ll.out)))
if (already.in == 0){
# add
ll.out[[length(ll.out)+1]] <- ll.in[[i]]
}
}
}
lenOUT <- length(ll.out)
if (verb){print(paste0(" length of OUT list : ",lenOUT))}
thick <- thick+1 # increment
if (lenOUT == 1 | lenIN == lenOUT){
# two possible conditions to break while loop
# - out.list.length == 1, then impossible to reduce
# - out.list.length == in.list.length, then impossible to reduce
reduced <- F
}
}
# append isolated ug if exist, if long exist, etc.
ugs.with.gr_dim <- unlist(ll.out)
ugs.all <- df.ugs$id
isolated.ug <- setdiff(ugs.all,ugs.with.gr_dim)
for (n in isolated.ug){
# - must be in the proportion table
ug.exist.in.df.proport <- n %in% rownames(df.dim.proport)
# - must have a long
ug.has.long <- !is.na(df.ugs[df.ugs$id == n,"long"])
if(ug.exist.in.df.proport & ug.has.long){
print (paste0(" append [",isolated.ug,"] in the list of 'gr_dim'"))
ll.out[[length(ll.out)+1]] <- isolated.ug
}
}
# update 'gr_dim' in Pg
print (" ugs dimension groups: ")
if (length(ll.out)>0){
for (gr in 1:length(ll.out)){
# loop through list of same proportions
# gr <- 1
for (idf in ll.out[[gr]]){
sql.gr.dim <- paste0("UPDATE table_noeuds SET gr_dim = ",gr,
" WHERE site LIKE '",a.sit,"' AND decor LIKE '",a.dec,"' AND",
" id = ",idf)
# print(sql.gr.dim)
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
dbGetQuery(con,sql.gr.dim);dbDisconnect(con)
print(paste0(" [",idf,"] gr_dim:",gr))
}
}
}
}
orientations/sens
by decorations
gr1.steles <- c("Baracal", "Arroyo Bonaval-Almendralejo", "El Carneril_Trujillo", "Cordoba 2_Ribera Alta", "Foios", "Granja De Cespedes-Badajoz", "Ibahernando", "Robledillo De Trujillo")
# create a stack of images with the direction of different selected types of ugs
# TODO : probably split by chunk when corpus too numerous
# TODO: the ggplot -> img function mess up
corpus <- "family"
siz.of.img <- 2 # size of images in inch
n.img <- 3 # number of images in row
#df.icos <- f.df.ico()
if(corpus=="objects"){
graphs <- create.graph.view(v.select.obj,"objects") # call function to create view
objets <- objects.df(graphs)
df.icos <- f.df.ico(v.select.obj)
# select the theme that will be studied (ex. épée) from a list
thms.selected <- f.thm.orient.select(select.obj)
} # 'graphs.objects' or 'graphs.family'
if(corpus=="family"){
graphs <- create.graph.view(v.select.family,"family") # call function to create view
objets <- objects.df(graphs)
df.icos <- f.df.ico(v.select.family)
# select the theme that will be studied (ex. épée) from a list
thms.selected <- f.thm.orient.select(select.family)
}
objets <- objets[objets$numero %in% gr1.steles, ]
df.icos <- df.icos[df.icos$numero %in% gr1.steles, ]
#objets <- objects.df(graphs.objects) # objects
#ugs.selected.all <- f.thm.orient.select()
# thms.selected <- f.thm.orient.select("stele bouclier") # select the theme that will be studied (ex. épée)
#thms.selected <- f.thm.orient.select(select.obj) # select the theme that will be studied (ex. épée)
lg.angles <- list()
# list themes with orientations
thm.with.orientations <- c()
n.tot <- nrow(objets)
# n.tot <- 10
for (i in 1:n.tot){
#i <- 1
sit.a <- objets[i,"site"];num.a <- objets[i,"numero"]
#color.a <- objets[i,"color"]
img.a <- df.icos[df.icos$site == sit.a & df.icos$num == num.a,]$img
ugs <- nodes.df(sit.a,num.a) # get nodes data
ugs <- ugs[ugs$type %in% thms.selected,] # select in thm
if (length(ugs) > 0){
# at least 1 ug
ugs <- ugs[!is.na(ugs$sens),] # remove orientation = NA
thm.with.orientations <- unique(c(thm.with.orientations,ugs$type))
}
}
# colors as named vectors
n.colors <- brewer.pal(length(thm.with.orientations),"Set1") # color ramp for thm
n.colors <- n.colors[1:length(thm.with.orientations)] # remove NA
names(n.colors) <- thm.with.orientations
# plot
for (i in 1:n.tot){
#i <- 6
id.a <- objets[i,"idf"]
sit.a <- objets[i,"site"]
num.a <- objets[i,"numero"]
color.a <- objets[i,"color"]
print(paste0(" ",i,") read ",sit.a,".",num.a))
img.a <- df.icos[df.icos$site == sit.a & df.icos$num == num.a,]$img
ugs <- nodes.df(sit.a,num.a)
ugs <- ugs[ugs$type %in% thm.with.orientations,] # select in thm.with.orientations
# colors
idf.dec <- paste0(id.a,'.',sit.a,'\n',num.a)
if (length(rownames(ugs))>0){
g.angle <- ggplot(ugs, aes(x = sens, y = .8)) +
ggtitle(idf.dec)+
geom_text_repel(aes(x=sens,
y=.9,
label=id,
color = type,
fontface="bold"),
alpha=.7,
segment.color = 'transparent',
force=0.1,
cex=3)+
geom_segment(aes(y = 0, xend = sens, yend = .7,color = type),
size=.8,
alpha=.7,
arrow=arrow(length = unit(0.1,"cm")))+
scale_color_manual(values = n.colors)+
geom_point(aes(0,0),color="black") +
coord_polar() +
theme_bw()+
theme(plot.title = element_text(size = 8, color=color.a),
axis.line = element_blank(),
axis.title=element_blank(),
axis.text=element_blank(),
axis.ticks=element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
panel.border = element_blank(),
panel.background = element_blank())+
scale_x_continuous(breaks = seq(45, 360, 45), limits = c(0, 360))
# take the legend
#leg <- get_legend(g.angle)
# remove the legend
g.angle <- g.angle+theme(legend.position="none")
# add to list
lg.angles[[length(lg.angles)+1]] <- g.angle
}
}
# how many empty images to complete the line
add.empty <- length(lg.angles) %% n.img
if(add.empty > 0){
n.empty.img <- n.img - add.empty
for (n.img.empty in 1:n.empty.img){
lg.angles[[length(lg.angles)+1]] <- ggplot() + theme_void()
}
}
# create a legend - - - - - - - - - - - - - - - - - - -
color.col <- n.colors[!is.na(n.colors)]
color.legend <- as.data.frame(color.col)
color.legend$idf <- 1:nrow(color.legend)
color.legend$thm <- rownames(color.legend)
leg <- ggplot(color.legend, aes(x=0,y=idf,colour=color.col)) +
geom_point() +
geom_text(aes(label=paste0(" ",thm),hjust=0),cex=2)+
xlim(0,0.05)+
blank_theme+
theme(axis.text = element_blank())+
scale_colour_identity()
# thumbnails of thms - - - - - - - - - - - - - - - - - -
ll.sign <- list()
# all or selected theme with orientation without NA values
thms.selected <- intersect(thm.with.orientations,thms.selected)
for (ug in thms.selected){
a.color <- as.character(color.col[ug]) # color of the thm
a.sign <- image_read(paste0(chm.signes,ug,".jpg"))
a.sign <- image_scale(a.sign,"200x200")
a.sign <- image_trim(a.sign)
a.sign <- image_border(a.sign,a.color, "10x10") # add white margins
a.sign <- image_border(a.sign,"#FFFFFF", "100x100") # add white margins
# a.sign <- image_border(a.sign,a.color, "10x10") # add white margins
# a.sign <- image_flip(a.sign)
# a.sign.tag <- image_annotate(a.sign, ug, size = 35,gravity="center",
# color = a.color, boxcolor = "white")
# plot(a.sign)
# gg.a.sign.tag <- image_graph(a.sign.tag)
gg.a.sign.tag <- image_ggplot(a.sign)
# plot(gg.a.sign.tag)
# a.sign.tag <- image_annotate(a.sign, ug, size = 25,gravity="southwest",color = "black")
ll.sign[[length(ll.sign)+1]] <- gg.a.sign.tag
}
tit.corpus <- f.tit.corpus(corpus,length(lg.angles),length(thm.with.orientations) * length(lg.angles))
the.tit <- paste0("themes orientations for ",tit.corpus," with numeros of ugs",
#"\for themes: ",paste0(thms.selected,collapse = ', '),
"\ncolors refer to ugs themes: ",paste0(thms.selected,collapse = ', '),
" (see legend below)",
"\nthe defaut orientation (0°) is given by thumbnails with colored squares",
" (see legend below)\n")
# lg.complete <- lg.angles
#lg.complete[[length(lg.complete)+1]] <- leg # add the legend to the list
#lg.complete[[length(lg.complete)+1]] <- as_ggplot(leg) # add the legend to the list
#lg.complete <- append(lg.complete, ll.sign) # add signs thumbnails
dim.h <- (ceiling(length(lg.angles)/n.img)+ceiling(length(ll.sign)/n.img))*siz.of.img
margin = theme(plot.margin = unit(c(0,0,0,0), "cm"))
langles <- lapply(lg.angles, "+", margin)
#llegend <-
for (dev in c(".png")){
out.plot <- paste0(chm.analysis.n.orientations, "ugs_orient_by_decorations", dev)
ggsave(file = out.plot,
arrangeGrob(grobs = c(langles,ll.sign),
top = grid::textGrob(the.tit,x=0,hjust=0,gp = gpar(fontsize =9)),
padding = unit(0, "line"), ncol = n.img),
width = siz.of.img * n.img,
height = dim.h
)
}
shell.exec(out.plot)
by types
# radar plot of cumulated orientations by themes
g.add.thumb.thm <- function(thm){
# create a thumbnail of the theme with cardinal orientations
orient.sz <- 15
thumbnail.thm <- paste0(chm.signes,thm,".jpg")
if(!file.exists(thumbnail.thm)){
thumbnail.thm <- paste0(chm.signes,"zz_img.jpg")
}
if(file.exists(thumbnail.thm)){
thumb.thm <- image_read(thumbnail.thm)
thumb.thm <- image_scale(thumb.thm,"x150")
thumb.thm <- image_border(thumb.thm,"#FFFFFF", "20x20") # add white margins
thumb.thm <- image_annotate(thumb.thm,"0/360°","north",size=orient.sz)
thumb.thm <- image_annotate(thumb.thm,"90°","east",size=orient.sz)
thumb.thm <- image_annotate(thumb.thm,"180°","south",size=orient.sz)
thumb.thm <- image_annotate(thumb.thm,"270°","west",size=orient.sz)
}
return(thumb.thm)
}
corpus <- "family"
# select ugs of family
if(corpus=="objects"){
ugs <- ugs.select.df(select.obj,corpus)
# tit.selec.corpus <- paste0("of '",select.obj,"' selected objects")
}
if(corpus=="family"){
ugs <- ugs.select.df(select.family,corpus)
# tit.selec.corpus <- paste0("of all '",select.family,"' family")
}
#ugs <- ugs_x_family.df(select.family) # select ugs of family
ugs <- subset(ugs, select=c("site","decor","id","type","sens"))
ugs$lbl <- paste0(ugs$site,'.',ugs$decor)
ugs <- ugs[!is.na(ugs$sens),] # remove
# get the different thms ordered by n
t.thm <- as.data.frame(table(ugs$type))
t.thm <- t.thm[with(t.thm, rev(order(Freq))), ]
# cleanup
t.thm <- t.thm[t.thm$Freq>1,] # rm when only 1
t.thm <- t.thm[t.thm$Var1 != "indet",] # rm indet
print("* orientations of themes *")
#t.thm$Var1 # c("bouclier")
for(thm in t.thm$Var1){
# thm <- "anciforme"
n.thm <- t.thm[t.thm$Var1 == thm,"Freq"]
n.dec <- length(unique(ugs[ugs$type == thm,]$lbl))
tit.corpus <- f.tit.corpus(corpus,n.dec,n.thm)
the.tit <- paste0("'",thm,"' orientations \n",tit.corpus)
print(paste0(" ",thm))
ugs.thm <- ugs[ugs$type == thm,] # select thm
ugs.thm <- as.data.frame(table(ugs.thm$sens))
ugs.thm$Var1 <- as.numeric(as.character(ugs.thm$Var1)) # factor to numeric
names(ugs.thm)[names(ugs.thm) == 'Freq'] <- "nb.total"
a.interval <- 15
orient.classes <- seq(0,360, by=a.interval)
# center on vertical
orient.classes.centred <- c(orient.classes[length(orient.classes)],
orient.classes[-length(orient.classes)])
gr.2x <- seq(from=2,to=length(orient.classes.centred), by =2)
orient.classes.centred.g <- orient.classes.centred[-gr.2x]
orient.classes.centred.g <- orient.classes.centred.g[-1]
ugs.thm$orient <- cut(ugs.thm$Var1, orient.classes.centred.g,
labels = F,right = F)
# na = 350-10
#ugs.thm[is.na(ugs.thm)] <- 1
ugs.thm$orient.class.inf <- orient.classes.centred.g[ugs.thm[,"orient"]]
ugs.thm$orient.class.sup <- orient.classes.centred.g[ugs.thm[,"orient"]+1]
#ugs.thm$orient.class.mean <- ugs.thm$orient.class.inf+(a.interval/2)
# replace 370
ugs.thm[is.na(ugs.thm$orient.class.inf),"orient.class.inf"] <- 345
ugs.thm[is.na(ugs.thm$orient.class.sup),"orient.class.sup"] <- 15
ugs.thm$orient.class.med <- ugs.thm$orient.class.inf+a.interval
if (nrow(ugs.thm)>0){
ugs.thm$orient.lbl <- paste0("[",as.character(ugs.thm$orient.class.inf),
"-",as.character(ugs.thm$orient.class.sup),"[")
}
# group
ugs.thm <- ugs.thm %>%
group_by(orient.lbl,orient.class.med) %>%
summarise(nb.total = sum(nb.total))
# aggregate(ugs.thm$nb.total, by=list(Category=ugs.thm$orient.lbl), FUN=sum)
# ugs.thm$orient <- NULL
#gg.radar <- ggplot(data = ugs.thm, aes(x = log10(nb.total), y = orient.class.inf)) +
gg.radar <- ggplot(data = ugs.thm, aes(x = nb.total, y = orient.class.med)) +
#ggtitle(the.tit)+
geom_point(stat = "identity",aes(size=nb.total/3),color="darkgrey") +
geom_text(aes(label = orient.lbl), color="black", segment.alpha = .7,
vjust=-1,
cex=1) +
geom_text(aes(label = nb.total), color="black", segment.alpha = .7,
vjust=.75,
cex=1.3) +
coord_polar(theta = "y") +
scale_y_continuous(breaks = orient.classes,limits = c(0,360))+
scale_x_continuous(breaks = c(1,2,3,4,5,10,15,20,30,50),
limits = c(0,max(ugs.thm$nb.total))) +
#scale_x_log10()+ # log
#scale_x_log10(limits = c(0,max(ugs.thm$nb.total)))+ # log
theme_bw()+
theme(#plot.title = element_text(size = 7,hjust=0,margin = margin(0.1,-1,0.1,0.1)),
#legend.title = element_text(size = 8),
#legend.text = element_text(size = 7),
axis.title.x =element_blank(),
axis.text.x = element_text(size = 4, vjust= 1),
axis.title.y = element_text(size = 5, hjust=0.75),
axis.text.y = element_text(size = 4),
axis.ticks.length=unit(.05, "cm"),
legend.key.size = unit(1,"line"),
panel.border = element_blank())+
theme(legend.position = "none")
img.gg.radar <- ggsave_to_variable(gg.radar,1000,1000,300) # ggplot -> magick-image
img.gg.radar <- image_annotate(img.gg.radar,the.tit,"northwest",size=24)
thumb.thm <- g.add.thumb.thm(thm) # add annotated thumbnail
# img.comp <- image_composite(img.gg.radar, thumb.thm, gravity = "southwest")
img.comp <- image_composite(img.gg.radar, thumb.thm, offset = "+20+20", gravity = "southwest")
#plot(img.comp)
out.orient <- paste0(chm.analysis.n.orientations,
"ugs_orient_by_types_",thm,".png")
#out.orient <- paste0(chm.analysis.n.orientations,"ugs_",select.family,"_",thm,"_orientations.png")
image_write(img.comp, out.orient, format = "png")
}
# plot
if (length(rownames(t.thm))>0){shell.exec(out.orient)}
relative node positions
Explore x and y values of ug in the GIS to identify top most ugs (y-axis, ie relative deepness) and centered most ugs (x-axis, ie relative centre)
centreness TODO
# based on the 'x' variable of nodes
deepness
# based on the 'y' variable of nodes
corpus <- "family" # choose 'objects' or 'family'
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
lgrph <- load.graphs(graphs)[[1]] # load graphs
#lgrph <- rm.specific.nd(lgrph,"indet") # remove indet
ugs <- ug.select.obj(graphs)
if (length(grep("indet",ugs$type))>0){
ugs <- ugs[-grep("indet",ugs$type),] # remove 'indet*'
}
# to get and remove nodes which are attributes
ugs$lbl <- paste0(ugs$site,'.',ugs$decor,'.',ugs$id)
df.nd.are.attr <- df.nodes.are.attributs(graphs)
ugs <- ugs[ugs$lbl %notin% df.nd.are.attr$lbl,]
sel.ugs.all <- data.frame(dec=character(0),
type=character(0),
rel.h=numeric(0))
# ugs <- head(ugs,100)
# loop throug objects
for (i in 1:length(lgrph)){
# i <- 11
g <- lgrph[[i]]
print(paste0(i,") ",g$name,", nb nodes (without attributes nodes): ",gorder(g)," ; nb of edges: ",gsize(g)))
# get the vertex id
df.all <- as.data.frame(vertex_attr(g))
# updated graph by removing some nodes
g <- rm.by.edge.type(g,'+') #;g <- rm.by.edge.type(g,'>')
if (gorder(g)==0){print(paste0(" 0 nodes -> NEXT")) ; next}
df <- as.data.frame(vertex_attr(g))
a.sit <- as.character(df[1,"site"])
a.dec <- as.character(df[1,"decor"])
sel.ugs <- ugs[ugs$site == a.sit & ugs$decor == a.dec,]
if (nrow(sel.ugs)==0){print(paste0(" only 'indent' nodes -> NEXT")) ; next}
# only nodes in the updated graph
sel.ugs <- sel.ugs[sel.ugs$id %in% df$id,]
sel.ugs <- sel.ugs[with(sel.ugs, order(-y_ug)), ]
sel.ugs$rel.h <- 1:nrow(sel.ugs) # record the order
sel.ugs$dec <- as.character(df[1,"idf"]) # the idf of the object
sel.ugs <- subset(sel.ugs,select=c(dec,type,rel.h))
sel.ugs.all <- rbind(sel.ugs.all,sel.ugs)
}
# df.dist.mat.sel
# mean of closeness by thm
mean.by.var <- aggregate(sel.ugs.all$rel.h,
by=list(thm=sel.ugs.all$type), FUN=mean)
# reorder
mean.by.var <- mean.by.var[with(mean.by.var,order(x)), ]
mean.by.var$thm <- factor(mean.by.var$thm,levels = mean.by.var$thm)
# reorder
sel.ugs.all$type <- factor(sel.ugs.all$type,levels = mean.by.var$thm)
max.d <- max(sel.ugs.all$rel.h)
n.thm <- length(unique(sel.ugs.all$type))
tit.corpus <- f.tit.corpus(corpus,length(unique(sel.ugs.all$dec)),nrow(sel.ugs.all))
tit.sup <- "\nwith numeros of decorations"
tit.corpus <- paste0(tit.corpus,tit.sup)
the.tit <- paste0("relative deepness seriation of ugs types",tit.corpus)
if (flag.dendro.color){
# merge on dendrogramm colors
sel.ugs.all <- merge(sel.ugs.all,df.dist.mat.sel.ord,by.x="dec",by.y="idf")
the.tit <- paste0(the.tit,"and colors refer to the dendrogramm except grey colors out of dendrogram")
}
if (!flag.dendro.color){sel.ugs.all$color <- "black"}
#pos <- position_jitter(w=0,h=.1)
gg.heights <- ggplot(sel.ugs.all, aes(x=type, y=rel.h, colour=color)) +
ggtitle(the.tit)+
geom_point(data=mean.by.var, aes(x=thm,y=x), pch =3, size=2, color="red")+
geom_point(size=.7, alpha=.5)+
geom_label_repel(data=sel.ugs.all,
#position = pos, # jitter
label=sel.ugs.all$dec,
segment.alpha = .5,segment.size = .2,
min.segment.length = 0,
size=3,
label.size=NA,fill = NA, # no box, no frame
force=0.01, # repulsion between lables
box.padding=0.1,
#direction="y", # move only on y-axis
hjust= 0
)+
geom_text_repel(data=mean.by.var, aes(x=thm,y=x,label=round(x,2)), color="red", size=3)+
theme_bw() +
theme(axis.text.x = element_text(size = 7,hjust = 1, vjust=0))+
ylab(paste0("relative deepness indice"))+
theme(plot.title = element_text(size = 9))+
theme(axis.title.y = element_text(size=6))+
theme(axis.text.y = element_text(size = 7, vjust = 0, hjust=0.5))+
theme(axis.title.x = element_blank())+
theme(axis.ticks.length = unit(2, "pt"))+
theme(axis.ticks = element_line(colour = "black", size = 0.2))+
theme(panel.border=element_rect(colour="black",size=0.2))+
theme(panel.grid.minor = element_blank())+
theme(panel.grid.major = element_line(colour = "lightgrey", size = 0.1))+
theme(panel.spacing = unit(2, "mm"))+
theme(strip.text = element_text(size=8),
strip.background = element_rect(colour="black",size=0.2))+
theme(legend.position = "none")+
scale_colour_identity()+
#scale_y_continuous(breaks=rev(seq(1,max.d)))
scale_y_reverse(breaks=rev(seq(1,max.d)))
#scale_x_continuous(breaks=-seq(0,max.d,by=0.05))+
#scale_x_continuous(breaks=seq(1,max.d))+
#expand_limits(x = c(.1,max.d+.1))
for (dev in c(".png",".pdf")){
g.out <- paste0(chm.analysis.n.centralities,"ugs_rel_deepness_by_types",dev)
ggsave(g.out,
gg.heights,
height = (nrow(mean.by.var)/2)+4,
width = n.thm+8)
}
shell.exec(g.out)
graph analysis
Graph analysis
ug centralities
# realize different graph centralities measures and make a seriation on values
corpus <- "family" # choose 'objects' or 'family'
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
lgrph <- load.graphs(graphs)[[1]] # load graphs
dist.df <- f.dist.df(lgrph) # get distances btw nodes
# # get colors
# if (flag.dendro.color){
# # merge on dendrogramm colors
# df.colors <- subset(df.dist.mat.sel.ord,select=c("idf","color"))
# dist.df <- merge(dist.df,df.colors,by.x="dec",by.y="idf")
# }
# if (!flag.dendro.color){dist.df$color <- "black"}
dist.df <- subset(dist.df,select=c("dec","color"))
dist.df <- dist.df[!duplicated(dist.df), ]
#lgrph <- lgrph[1:10] # subset
gt.index.df <- c("closeness","betweenness","degree") # names of the graph analysis functions
# gt.index.df <- c("closeness") # names of the graph analysis functions
for (gt.i in gt.index.df){
# gt.i <- "closeness"
print(paste0("'",gt.i,"' measurement centralities"))
gt.index.df <- data.frame(gt.index=numeric(0),
dec=character(0),
thm=character(0))
ugs <- ug.select.obj(graphs)
ugs.types <- unique(ugs$type)
for (i in 1:length(lgrph)){
# i <- 1
g <- lgrph[[i]]
# print(paste0(" ",i,") read '",gt.i,"' for graph ",g$name))
#idf.g <- unique(vertex_attr(g, "idf", index = V(g))) # idf
g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>')
# path name of the function
gt.i.val <- eval(parse(text = paste0("as.data.frame(",gt.i,"(g))")))
colnames(gt.i.val)[1] <- "stat.graph" # modify function name
#clos <- as.data.frame(closeness(g))
gt.i.val$dec <- unique(vertex_attr(g, "idf", index = V(g))) # idf
#clos$dec <- g$name
gt.i.val$thm <- row.names(gt.i.val)
#names(gt.i.val)[names(clos) == 'closeness(g)'] <- "closeness"
gt.index.df <- rbind(gt.index.df,gt.i.val)
}
gt.index.df <- gt.index.df[gt.index.df$thm %in% ugs.types,] # ?
# mean of graph index by thm
mean.by.var <- aggregate(gt.index.df$stat.graph,
by=list(thm=gt.index.df$thm), FUN=mean)
# reorder
mean.by.var <- mean.by.var[with(mean.by.var,order(x)), ]
mean.by.var$thm <- factor(mean.by.var$thm,levels = mean.by.var$thm)
gt.index.df$thm <- factor(gt.index.df$thm,levels = mean.by.var$thm)
# if (flag.dendro.color){
# # merge on dendrogramm colors
# df.colors <- subset(df.dist.mat.sel.ord,select=c("idf","color"))
# dist.df <- merge(dist.df,df.colors,by.x="dec",by.y="idf")
# }
# if (!flag.dendro.color){dist.df$color <- "black"}
# dist.df <- subset(dist.df,select=c("dec","color"))
# dist.df <- dist.df[!duplicated(dist.df), ]
gt.index.df <- merge(gt.index.df,dist.df,by="dec",all.x=T) # get colors
max.d <- max(gt.index.df$stat.graph)
pos <- position_jitter(w=0,h=.1)
nb.dec <- length(lgrph);nb.ugs <- nrow(gt.index.df)
tit.corpus <- f.tit.corpus(corpus,nb.dec,nb.ugs)
the.tit <- paste0("'",gt.i,"' average index seriation ",tit.corpus,"\nwith numero of decorations")
if (flag.dendro.color){the.tit <- paste0(the.tit," and colors refer to dendrogramm classification")}
gg.glob <- ggplot(gt.index.df, aes(x=stat.graph, y=thm, colour=color)) +
ggtitle(the.tit)+
geom_point(data=mean.by.var, aes(x=x,y=thm), pch=3, size=2, color="red")+
geom_point(size=1, position = pos)+
geom_label_repel(data=gt.index.df,
position = pos, # jitter
label=gt.index.df$dec,
segment.alpha = .5,segment.size = .2,
min.segment.length = 0,
size=3,
label.size=NA,fill = NA, # no box, no frame
force=0.01, # repulsion between lables
box.padding=0.1,
#direction="y", # move only on y-axis
hjust= 0
)+
geom_text_repel(data=mean.by.var, aes(x=x,y=thm,label=round(x,1)), color="red", size=3)+
theme_bw() +
theme(axis.text.x = element_text(size = 7,hjust = 1, vjust=0))+
xlab(paste0(gt.i," indice"))+
theme(plot.title = element_text(size = 9))+
theme(axis.title.x = element_text(size=6))+
theme(axis.text.y = element_text(size = 7, vjust = 0, hjust=0.5))+
theme(axis.title.y = element_blank())+
theme(axis.ticks.length = unit(2, "pt"))+
theme(axis.ticks = element_line(colour = "black", size = 0.2))+
theme(panel.border=element_rect(colour="black",size=0.2))+
theme(panel.grid.minor = element_blank())+
theme(panel.grid.major = element_line(colour = "lightgrey", size = 0.1))+
theme(panel.spacing = unit(2, "mm"))+
theme(strip.text = element_text(size=8),
strip.background = element_rect(colour="black",size=0.2))+
scale_colour_identity()+
scale_x_reverse()
#scale_x_continuous(breaks=-seq(0,max.d,by=0.05))+
#scale_x_continuous(breaks=seq(1,max.d))+
#expand_limits(x = c(.1,max.d+.1))
for (dev in c(".png",".pdf")){
g.out <- paste0(chm.analysis.n.centralities,"ugs_",gt.i,
"_centralities_by_decorations",dev)
ggsave(g.out,
gg.glob,
height = (nrow(mean.by.var)/2)+5,
width = 12)
}
}
shell.exec(g.out)
ug proximities
Calculate the averages of shortestpaths between a each types of nodes
corpus <- "family" # choose 'objects' or 'family'
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
lgrph <- load.graphs(graphs)[[1]] # load graphs
lgrph.no.att <- list()
# remove node attributes
for (i in 1:length(lgrph)){
#i <- 1
g <- lgrph[[i]]
g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>')
lgrph.no.att[[length(lgrph.no.att)+1]] <- g
}
dist.df <- f.dist.df(lgrph.no.att) # get distances btw nodes
# remove indet
dist.df$Var2 <- as.character(dist.df$Var2)
if (length(grep("indet",dist.df$Var2))>0){
dist.df <- dist.df[-grep("indet",dist.df$Var2),]
}
dist.df$Var1 <- as.character(dist.df$Var1)
if (length(grep("indet",dist.df$Var1))>0){
dist.df <- dist.df[-grep("indet",dist.df$Var1),]
}
#unique(dist.df$value)
# TODO: add colors of dendog
lthms <- sort(unique(dist.df$Var1)) # unique thm sorted
# lthms
for (thm in lthms){
#thm <- "bouclier"
dist.df.thm <- dist.df[dist.df$Var1 == thm,]
# remove 'indet*' if exist
#print(paste0("theme '",thm,"', number of other thms: ",nrow(dist.df.thm)))
#my.width <- ceiling(nrow(dist.df.thm)/30)
mean.by.var <- aggregate(dist.df.thm$value,
by=list(thm=dist.df.thm$Var2), FUN=mean)
# reorder
mean.by.var <- mean.by.var[with(mean.by.var,order(-x)), ]
mean.by.var$thm <- factor(mean.by.var$thm,levels = mean.by.var$thm)
#print(nrow(dist.df.thm))
dist.df.thm$Var1 <- NULL
count.by.var <- as.data.frame(t(table(dist.df.thm$Var2))) # effectives
names(count.by.var)[names(count.by.var) == 'Freq'] <- "nb"
sum.by.var <- aggregate(dist.df.thm$value,
by=list(Var2=dist.df.thm$Var2), FUN=sum)
names(sum.by.var)[names(sum.by.var) == 'x'] <- "x"
relfreq.by.var <- merge(sum.by.var,count.by.var,by="Var2")
# reorder
proximite.moyenne <- relfreq.by.var$x/relfreq.by.var$nb
# reoder on average of proximities and effectives
relfreq.by.var <- relfreq.by.var[with(relfreq.by.var,order(-proximite.moyenne, x)), ]
#relfreq.by.var <- relfreq.by.var[rev(order(relfreq.by.var$x/relfreq.by.var$Freq)),]
dist.df.thm$Var2 <- factor(dist.df.thm$Var2,levels = relfreq.by.var$Var2)
tit.corpus <- f.tit.corpus(corpus,length(unique(dist.df.thm$dec)),nrow(dist.df.thm))
the.tit <- paste0("distance between '",thm,"' and other types of ugs ",
tit.corpus,"\nwith numero of decorations, colors refer to dendrogram")
max.d <- max(dist.df.thm$value)
pos <- position_jitter(w=0,h=.2)
llgg <- list()
if (nrow(dist.df.thm)>1){
# if not: Viewport has zero dimension(s) ggplot
gg.dist <- ggplot(dist.df.thm, aes(x=value, y=Var2, colour=color)) +
#ggplot(dist.df.thm, aes(x=value, y=Var2)) +
ggtitle(the.tit)+
# the mean
geom_point(data=mean.by.var, aes(x=x,y=thm), pch=3, size=2, color="red")+
geom_text_repel(data=mean.by.var, aes(x=x,y=thm,label=round(x,1)), color="red", size=2)+
# the ugs
geom_point(size=1, position = pos)+
geom_label_repel(data=dist.df.thm,
position = pos, # jitter
label=dist.df.thm$dec,
segment.alpha = .5,segment.size = .2,
#min.segment.length = 0,
size=3,
label.size=NA,fill = NA, # no box, no frame
#force=0.01, # repulsion between lables
box.padding=0.1,
#direction="y", # move only on y-axis
hjust= 0
)+
theme_bw() +
theme(plot.title = element_text(size = 9, hjust = 0))+
theme(axis.text.x = element_text(size = 7,hjust = 1, vjust=0))+
xlab("distance")+
theme(axis.title.x = element_text(size=7))+
theme(axis.text.y = element_text(size = 7, vjust = 0, hjust=0.5))+
theme(axis.title.y = element_blank())+
theme(axis.ticks.length = unit(2, "pt"))+
theme(axis.ticks = element_line(colour = "black", size = 0.2))+
theme(panel.border=element_rect(colour="black",size=0.2))+
theme(panel.grid.minor = element_blank())+
theme(panel.grid.major = element_line(colour = "lightgrey", size = 0.1))+
theme(panel.spacing = unit(2, "mm"))+
theme(strip.text = element_text(size=8),
strip.background = element_rect(colour="black",size=0.2))+
scale_colour_identity()+
scale_x_continuous(breaks=seq(1,max.d+1))+
expand_limits(x = c(.5,max.d+1.5))
llgg[[length(llgg)+1]] <- gg.dist
for (dev in c(".png")){
#for (dev in c(".png",".pdf")){
g.out <- paste0(chm.analysis.n.proximities,"ugs_prox_from_",thm,"_by_types",dev)
ggsave(g.out,
gg.dist,
height = ceiling(length(unique(dist.df.thm$dec))/10)+10,
width =ceiling(length(unique(dist.df.thm$dec))/10)+10
)
}
# ggsave(paste0(chm.analysis.n.proximities,thm,"_prox.png"),
# gg.dist,width =max.d/1.5)
}
}
shell.exec(g.out)
chronologie
# plot dated (left column) and undated ugs (rigth column) by objects
#nme.dec <- paste0(chm.etude,"1-temps_ugs.png")
graphs.objects <- create.graph.view(v.select.obj,"family") # call function to create view
objets <- objects.df(graphs.objects) # objects
#objets <- head(objets,30)
# png(nme.dec,res=150,height = nrow(objets)*90,width = 2500 )
df.ugs <- ug.select.obj(objets)
df.ugs$lbl <- paste0(df.ugs$site,'.',df.ugs$decor)
df.ugs <- merge(df.ugs,graphs,by='lbl',all.x=T) # get the idf from graphs/objects
df.tp.aq <- df.ugs.dat.miss.merged <- df.ugs[0, ]
# loop through objects
df.ugs.tp.aq <- df.ugs[!is.na(df.ugs$tpq),]
df.ugs.dat.miss <- df.ugs[is.na(df.ugs$tpq),]
# append
df.tp.aq <- rbind(df.tp.aq,df.ugs.tp.aq)
df.ugs.dat.miss.merged <- rbind(df.ugs.dat.miss.merged,df.ugs.dat.miss)
# dated ugs
mtpq <- min(df.tp.aq$tpq)-500
Mtaq <- max(df.tp.aq$taq)
# chr_1 <- chr_tpq-chr_taq
for (i in 1:nrow(df.tp.aq)){
if (df.tp.aq[i,"chr_1"] == 'xxx' & df.tp.aq[i,"tpq_cul"] != 'xxx'){
df.tp.aq[i,"chr_1"] <- paste0(df.tp.aq[i,"tpq_cul"],'-',df.tp.aq[i,"taq_cul"])
}
}
g.dated.ugs <- ggplot(df.tp.aq, aes(fill=chr_1)) +
ggtitle("ugs with chronological attribution")+
geom_rect(aes(xmin = tpq, xmax = taq,
ymin = idf-.3, ymax = idf+.3,
color=chr_1),
fill=NA,size=0.7,linetype=5,alpha=0.3)+
geom_label_repel(aes(x = tpq, y = idf,label =paste0(id,'.',type),colour=chr_1),segment.alpha=.5,
size=2.5,box.padding=0,label.padding = 0.1, label.size = NA, fill="white",parse = F)+
geom_text(data=objets,
aes(x =mtpq, y =as.integer(objets$idf),
label=objets$lbl),
size=2.5,hjust=0)+
scale_y_continuous(trans = "reverse", breaks = rev(unique(df.ugs$idf)))+
scale_x_continuous(limits=c(mtpq,Mtaq))+
theme_bw()+
guides(colour = guide_legend(override.aes = list(size = 5)))+
theme(panel.grid.minor = element_blank())+
theme(legend.key=element_rect(fill=NA),
legend.position="bottom")
# undated ugs - - - - - - - - - -
g.undated.ugs <- ggplot(df.ugs.dat.miss.merged) +
ggtitle("ugs without chronological attribution")+
geom_point(aes(id,idf))+
geom_text_repel(aes(id,idf,label=paste0(id,'.',type)),segment.alpha=.5, cex=2.5)+
scale_y_continuous(trans = "reverse", breaks = rev(unique(df.ugs$idf)))+
scale_x_continuous(breaks=seq(1,max(df.ugs.dat.miss.merged$id)))+
theme_bw()+
theme(panel.grid.minor = element_blank())
legend <- g_legend(g.dated.ugs) # extract legend
g.dated.ugs <- g.dated.ugs+theme(legend.position ='none') # remove legend
g.date.ugs <- grid.arrange(g.dated.ugs,g.undated.ugs,legend,
ncol=2,nrow=2,
heights=c(10,1))
n.height <- ceiling(nrow(df.tp.aq)/8)+10 # height
n.width.dat <- df.tp.aq %>% count(lbl)
n.width.undat <- df.ugs.dat.miss.merged %>% count(lbl)
n.width <- max(max(n.width.undat$n),max(n.width.dat$n))
n.width <- ceiling(n.width/2)+10 # height
for (dev in c(".png",".pdf")){
g.out <- paste0(chm.analysis.n.chrono,"ugs_chrono_by_decorations",dev)
ggsave(file = g.out,
g.date.ugs,
height = n.height,
width = n.width)
}
shell.exec(g.out)
Edges analysis
heatmaps
on common edges
# plot the heatmap of common links between gaphs
# renomme colonnes et lignes
# TODO : seriate, see: "D:/Projet Art Rupestre/scripts/scripts_r/seriate_heatmap"
# TODO : show (real) numeros of graphs
corpus <- "family" # choose 'objects' or 'family'
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
# graphs <- head(graphs,30)
lgrph <- load.graphs(graphs)[[1]] # load graphs
# graphs names
lnames.ok <- lnames.no <-c()
for (i in 1:length(lgrph)){
lnames.ok <- c(lnames.ok,lgrph[[i]]$name)
}
# selection of hmap types
loop.matrix <- c("all_decor","only_matching_decor")
loop.attribut <- c(c("+"),c(""))
# loop.matrix <- c("all_decor")
# loop.attribut <- c(c("+"))
for (zero in loop.matrix){
# for (zero in c("all_decor","only_matching_decor")){
# matrix of all decors or matrix of ddecor that match a leats once
for (att in loop.attribut){
# loop on different attributes
#without.attr <- c("+") # choose "+", "", etc. to suppress attributes
# att <- c(""); att <- c("+")
df.same_edges <- f.same.edges(lgrph,att)
if (zero == "only_matching_decor"){
# get where sum is null to remove from df
sums <- as.integer(apply(df.same_edges, 1, sum, na.rm = T)) # row sum
sum.is.0 <- which(!is.na(match(sums, 0)))
df.same_edges <- df.same_edges[-c(sum.is.0),] # rm row
df.same_edges <- df.same_edges[,-c(sum.is.0)] # rm col
tit.match_typ <- "\nwith decorations having at least one common edge with the orthers"
df.tab <- lnames.ok[-sum.is.0]
}
if (zero == "all_decor"){
# no transformations
tit.match_typ <- "\nwith decorations having at least one common edge with the orthers"
df.tab <- lnames.ok
}
# df.same_edges <- df.same_edges[df.same_edges$sum > 0,]
# df.same_edges[nrow(df.same_edges) + 1,] = apply(df.same_edges, 2, sum, na.rm = T) # row sum
# df.same_edges <- f.same.edges(lgrph,c("+"))
df.same_edges[lower.tri(df.same_edges,diag=T)] <- NA
#df.same_edges <- as.data.frame(mat.same_edges)
rownames(df.same_edges) <- seq(1:nrow(df.same_edges))
names(df.same_edges) <- seq(1:ncol(df.same_edges))
melt.df.same_edges <- reshape2::melt(as.matrix(df.same_edges))
ifelse(att == "+",
tit.attr <- "_without_attributes",
tit.attr <- "_with_attributes")
tit <- paste0("hmap_common_e_",zero,tit.attr) # tit for filename
tit.plot <- paste0("heatmap on decoration common edges",
"\nfor '",zero,"' of the family '",select.family,"'",
"\ncommon edges are counted '",tit.attr,"'",
"\nnb of objects: ",nrow(graphs)," ; nb of graphs: ",length(lgrph),"\n")
# heatmap
heat.mat <- ggplot(data = melt.df.same_edges, aes(x=Var1, y=Var2, fill=value)) +
ggtitle(tit.plot)+
geom_tile(na.rm = T) +
scale_fill_gradient2(#low = "blue", high = "red",
name="Symetric matrix\nof the intersections\nbetween graphs",
na.value = 'white',
breaks=c(1,3,8,12,18))+
geom_text(aes(Var1, Var2, label = value),
color = "black", size = 3)+
theme_minimal()+
theme(axis.title = element_blank())+
theme(legend.position = "none")+
scale_x_discrete(position = "top", limits=seq(1:nrow(df.same_edges)))+
scale_y_discrete(limits=seq(1:nrow(df.same_edges)))
## save
# heatmap
dim.hmp <- 3+(nrow(df.same_edges)/4)
out.gg <- paste0(chm.clustering,tit,".png")
ggsave(out.gg,
width = dim.hmp, height = dim.hmp,
units = "in")
# correspondance table
df.tab.c <- as.data.frame(df.tab)
df.tab.c$df.tab <- as.character(df.tab.c$df.tab)
df.tab.c$idf <- rownames(df.tab.c)
df.tab.c$site <- sub("\\..*", "", df.tab.c$df.tab)
df.tab.c$decor <- sub(".*\\.", "", df.tab.c$df.tab)
df.tab.c <- subset(df.tab.c,select=c('idf','site','decor'))
ltab <- f.split.df(df.tab.c,25) # split df
dim.df <- ceiling(nrow(df.tab.c)/length(ltab)*.8) # for heights
out.dd<- paste0(chm.clustering,tit,"_tab.png")
# tgrob <- tableGrob(df.tab.c,
# theme = ttheme_default(base_size = 8,
# padding = unit(c(2,2), "mm")),
# cols = NULL,rows=F)
tgrob <- grid.arrange(grobs = ltab, ncol = length(ltab))
ggsave(out.dd,tgrob,
height = dim.df/2,width = length(ltab)*4)
}
}
shell.exec(out.dd);shell.exec(out.gg)
on edges similarities TODO
corpus <- "objects" # choose 'objects' or 'family'
without.attr <- c("") # choose "+", "", etc. to suppress attributes
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
lgrph <- load.graphs(graphs)[[1]] # load graphs
df.same_edges <- f.same.edges(lgrph,without.attr)
df.same_edges[lower.tri(df.same_edges,diag=T)] <- NA
around <- T
# nb of same edges / total of edges
df.same_edges.cor <- f.edge.similarity(df.same_edges,around)
#diag(df.same_edges.cor) <- NA # remplit la diagonale
df.same_edges.cor[lower.tri(df.same_edges.cor)] <- NA
melt.df.same_edges.cor <- reshape2::melt(as.matrix(df.same_edges.cor))
# title
ifelse(without.attr == "+",
tit.attr <- "without_attributes",
tit.attr <- "with_attributes")
tit <- paste0("hmap_similarity_e_",tit.attr,".png")
# heatmap
heat.mat <- ggplot(data = melt.df.same_edges.cor, aes(x=Var1, y=Var2, fill=value)) +
geom_tile(na.rm = T) +
scale_fill_gradient2(#low = "blue", high = "red",
name="Similarity matrix\nof the intersections\nbetween graphs",
na.value = 'white'
#breaks=c(1,3,8,12,18)
)+
geom_text(aes(Var1, Var2, label = value),
color = "black", size = 3)+
theme_minimal()+
theme(axis.title = element_blank())+
theme(legend.position = "none")+
scale_x_discrete(limits=seq(1:nrow(df.same_edges.cor)))+
scale_y_discrete(limits=seq(1:nrow(df.same_edges.cor)))
# save
out.gg <- paste0(chm.clustering,tit)
ggsave(out.gg,
width = 1+nrow(df.same_edges.cor)/4, height = 1+nrow(df.same_edges.cor)/4,
units = "in")
shell.exec(out.gg)
classifications on edges correlations
dendrogramm
# YYY
# clustering/dendrogramm by edge betweenness
# create the dataframe 'df.dist.mat.sel' with colors
# cf. https://stackoverflow.com/questions/27004890/how-to-transform-the-following-similarity-matrix-to-distance-matrix-for-performi
# TODO: show decoration numbers for "ordered.dendro <- F"
# TODO: 'select.superfamily'
# TODO: change Foios to Baracal as origin for warrior stelaes
# chm.super.family
# parameters - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
select.completness <- T # if TRUE apply the f.ugs.incomplete() function
corpus <- "super.family" # choose 'objects' or 'family' or 'super.family'
without.attr <- c("") # choose "+", "", etc. to suppress attributes
dendro.cut <- T ; nb.clusters <- 3 # cut and color branches for nor reordened dendro
col.clusters <- brewer.pal(nb.clusters,"Paired") # pastel colors for branches
devs <- c('.png') # types of output files, ex: c('.png','.pdf')
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# if origin exists, order dendro leafs and branches on origin,
a.select <- ifelse(corpus=="family", select.family,
ifelse(corpus=="super.family",select.superfamily,
ifelse(corpus=="objects",select.obj,NA)))
idx <- findex(lorigins.all, a.select) # get the name of the origins if exists, for dendrogramm
orig.thm <- lorigins.all[[idx]][[2]] # origin from where the distances/colors are computed
ifelse(!is.null(orig.thm),ordered.dendro <- T,ordered.dendro <- F)
#ordered.dendro <- F
# - - - - - - - - - - - - - - - - - - - - - - - -
graphs <- create.graph.view(v.select,corpus) # call function to create view
lgrph <- load.graphs(graphs)[[1]] # load graphs
if(select.completness){
lugs.incompl <- f.ugs.incomplete(lgrph, 0.75, FALSE, 10) # get index of most incomplet decoration
lgrph <- lgrph[-lugs.incompl] # remove these incomplete decorations
}
# get names, and total number of nodes
g.names <- c() ; g.nb.nd <- 0
for (i in 1:length(lgrph)){
# i <- 1
g <- lgrph[[i]]
g.names <- c(g.names,g$name)
g.nb.nd <- g.nb.nd+gorder(g)
}
tit.corpus <- f.tit.corpus(corpus,length(lgrph),g.nb.nd)
df.same_edges <- f.same.edges(lgrph,without.attr)
# get where sum is null to remove from df
sums <- as.integer(apply(df.same_edges, 1, sum, na.rm = T)) # row sum
sum.is.0 <- which(!is.na(match(sums, 0)))
if(length(sum.is.0)>0){
df.same_edges <- df.same_edges[-c(sum.is.0),] # rm row
df.same_edges <- df.same_edges[,-c(sum.is.0)] # rm col
g.names <- g.names[-sum.is.0]
}
# sort(unique(as.vector(as.matrix(df.same_edges))))
df.same_edges.cor <- f.edge.similarity(df.same_edges,F)
#lbls <- paste0(rownames(graphs),'.',graphs$site,'.',graphs$numero)
row.names(df.same_edges.cor) <- colnames(df.same_edges.cor) <- g.names
dist.mat <- dist(df.same_edges.cor)
res <- hclust(as.dist(dist.mat)) # ,method="ward.D"
# dendro parameter for ggplot
label.siz <- max(nchar(res$labels)) # the max large label of the dendro
height.siz <- max(res$height) # the height of the dendro
# convert from "hclust" to "denddrogram" class
dendro.bc <- as.dendrogram(res)
# - - - - - - - - - - - - - - - - - -
ifelse(without.attr == "+",tit.attr <- "without",tit.attr <- "with")
ifelse(corpus == "objects",
tit.corpus.typ <- paste0("selected objects from ",select.family," family "),
tit.corpus.typ <- paste0("all objects from ",select.family," family ")
)
# title on the file
dendro.title <- "clustering of decoration's compositions based on the 'edge.similarity' index "
dendro.title <- paste0(dendro.title,tit.attr," nodes attributes")
tit <- paste0("clustering of ",tit.corpus.typ,tit.attr) # title of the file
#ordered.dendro <- T
if (!ordered.dendro){
# labels
graphs.labels <- subset(graphs, select=c("idf","lbl","self","fam"))
# remove graphs not in dendro
# setdiff(labels(dendro.bc),graphs.labels$lbl)
miss.in.dendro <- setdiff(graphs.labels$lbl,labels(dendro.bc))
graphs.labels <- subset(graphs.labels, lbl %notin% miss.in.dendro) # rm missing in dendro
graphs.labels$lbl <- factor(graphs.labels$lbl,levels = labels(dendro.bc))
graphs.labels <- graphs.labels[with(graphs.labels, order(lbl)), ] # order
graphs.labels$label <- paste0(graphs.labels$idf,'.',graphs.labels$lbl)
# TODO: color on family
# TODO: a function from text below
if (select.choice == "select.superfamily"){
# studied families
st.families <- paste0("('",paste0(unique(graphs.labels$fam),collapse = "','"),"')")
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
sqll <- paste0("SELECT * FROM famille WHERE famille IN ",st.families)
# print(sqll)
families.colors <- dbGetQuery(con,sqll)
#print(paste0("'famille_super' field of 'object' table is updated for '",a.family,"' family"))
dbDisconnect(con) # disconnect
}
graphs.labels <- merge(graphs.labels,families.colors,by.x="fam",by.y="famille",all.x=T)
# TODO: anthropomorph
graphs.labels$self[graphs.labels$self == "anthropomorphe"] <- 15
graphs.labels$self[is.na(graphs.labels$self)] <- 16
graphs.labels$self <- as.numeric(graphs.labels$self)
# TODO: boxes by clusters
# plot dendrogram
gg.dend <- dendro.bc %>%
set("branches_lwd", .5) %>%
set("leaves_pch", graphs.labels$self) %>%
set("leaves_cex", 1.5) %>%
set("leaves_col", graphs.labels$famille_colors) %>%
set("labels",graphs.labels$label) %>%
set("labels_cex", .6) %>%
set("labels_col", graphs.labels$famille_colors)
if (dendro.cut){
# cut dendro
clust <- cutree(res, k = nb.clusters, h = NULL)
clust <- as.data.frame(clust)
clust$lbl <- rownames(clust)
# colors -> df
df.col.clusters <- data.frame(clust=seq(1,length(col.clusters)),
color=col.clusters)
# merge colors of branches and decor, used in § spatial
df.clust <- merge(clust,df.col.clusters,by.x="clust",by.y="clust",all.x=T)
# add colors for branches
gg.dend <- color_branches(gg.dend, k = 3, col = col.clusters)
# gg.dend <- gg.dend %>%
# set("branches_k_color", k=nb.clusters, col=c(3,1,4))
# plot(gg.dend)
# rect.dendrogram(gg.dend , k=2, border = "red", lty = 5, lwd = 2)
# gg.dend <- gg.dend %>%
# plot %>%
# rect.dendrogram(k=3,)
}
}
if (ordered.dendro){
# plot a dendrogramm colored and reodered on a selected origin, ex: c("Foios","Foios")
flag.dendro.color <- T # update flag for other ananlysis
# dist matrix from the choosed origin
orig.thm <- paste0(orig.thm,collapse=".")
df.dist.mat <- melt(as.matrix(dist.mat), varnames = c("obj.A", "obj.B"))
df.dist.mat.sel <- df.dist.mat[df.dist.mat$obj.A == orig.thm,]
# title
#orig.thm.lbl <- paste0(orig.thm,collapse=".")
dendro.title <- paste0(dendro.title,"\nreordered and colored depending on '",orig.thm,
"' decoration distances (ie, dissimilarities)")
df.dist.mat.sel$obj.A <- NULL
# create df or corresponding colors - - - - -
nb.values <- unique(sort(df.dist.mat.sel$value))
color.offset <- 4 # to avoid too clear colors
nb.colors <- rev(GetColors(n = length(nb.values)+color.offset,scheme = "smooth rainbow"))
nb.colors <- nb.colors[c(1:(length(nb.colors)-color.offset))] # subset colors
df.val.cols <- data.frame(value=nb.values,
color=nb.colors,
stringsAsFactors = F)
# get 'self' to identify 'anthropomorphe' supports
df.self <- subset(graphs,select=c("lbl","self"))
df.self$self[df.self$self == "anthropomorphe"] <- 15
df.self$self[is.na(df.self$self)] <- 16
df.self$self <- as.integer(df.self$self)
#df.self$lbl <- gsub(' ', '.', df.self$lbl) # replace ' ' by '.'
# reorder on value
df.dist.mat.sel <- df.dist.mat.sel[with(df.dist.mat.sel, order(value)), ]
# df.dist.mat.sel$idf <- 1:nrow(df.dist.mat.sel)
df.dist.mat.sel$ord <- 1:nrow(df.dist.mat.sel)
# change rownames
row.names(df.dist.mat.sel) <- df.dist.mat.sel$ord
# order.dend <- as.numeric(row.names(df.dist.mat.sel)) # new order
# merge with idf, colors and self
df.dist.mat.sel <- merge(df.dist.mat.sel,df.val.cols,by="value",all.x=T)
df.dist.mat.sel <- merge(df.dist.mat.sel,df.self,by.x="obj.B",by.y="lbl",all.x=T)
# get original idf
graphs.idf <- subset(graphs,select=c("lbl","idf"))
df.dist.mat.sel <- merge(df.dist.mat.sel,graphs.idf,by.x='obj.B',by.y='lbl',all.x=T)
# graphs.idf <- subset(graphs,select=c("idf","lbl"))
# df.dist.mat.sel <- merge(df.dist.mat.sel,graphs.idf,by.x="obj.B",by.y="lbl",all.x=T)
# order leaves/branches
order.dend <- order.dendrogram(dendro.bc)
val.max <- max(df.dist.mat.sel$value) ; val.min <- min(df.dist.mat.sel$value)
df.wts <- c()
# loop through values to assign weights and get order
for (i in order.dend){
# i <- 21
enr <- df.dist.mat.sel[df.dist.mat.sel$ord == i,]
if(enr$value == val.min){df.wts <- c(df.wts,1000)} # closest
if(enr$value <= val.max/2 & enr$value != val.min){df.wts <- c(df.wts,100)} # first half
if(enr$value > val.max/2 & enr$value != val.max){df.wts <- c(df.wts,10)} # second half
if(enr$value == val.max){df.wts <- c(df.wts,0)} # farsest
}
# order
dendro.bc.reorder <- reorder(dendro.bc, df.wts)
# reverse order
dendro.bc.reorder <- rev(dendro.bc.reorder)
# reoder df from the dendr
order.dend <- order.dendrogram(dendro.bc.reorder)
df.dist.mat.sel.ord <- df.dist.mat.sel[match(order.dend,row.names(df.dist.mat.sel)),]
# sample labels
df.val.cols <- f.sample.coloramp.dist(df.val.cols)
# color ramp from the origin to the highest value - - - - - - - - - - - - - -
g.colormap <- ggplot() +
geom_point(data=df.val.cols, aes(x=x, y=y, colour=color), size=2, show.legend = FALSE) +
geom_text(data=df.val.cols, aes(x=x, y=y, label=lbl, angle=90),
size=2, hjust=1, vjust=0,show.legend = FALSE) +
scale_colour_identity(guide="legend",breaks=df.val.cols$color)+
scale_x_discrete(labels = df.val.cols$value)+
theme_bw()+
theme(panel.border = element_blank(),
panel.background = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.ticks = element_blank(),
axis.text = element_blank(),
axis.title = element_blank())+
theme(plot.margin = unit(c(0,0,0,0), "cm"))
# attributes for "dendrogram" class
gg.dend <- dendro.bc.reorder %>%
set("branches_lwd", .5) %>%
set("leaves_pch", df.dist.mat.sel.ord$self) %>%
set("leaves_cex", 1.5) %>%
set("leaves_col", df.dist.mat.sel.ord$color) %>%
set("labels",paste0(df.dist.mat.sel.ord$idf,'.',df.dist.mat.sel.ord$obj.B)) %>%
set("labels_cex", .6) %>%
set("labels_col", df.dist.mat.sel.ord$color)
}
# convert from "dendrogram" to "ggdend" class
gg.dend.gg <- as.ggdend(gg.dend)
# add to title
dendro.title <- paste0(dendro.title,"\n",tit.corpus,"\nsquares identify 'anthropomorphic' supports")
g.dendro <- ggplot2::ggplot(gg.dend.gg, horiz = TRUE, offset_labels = -0.6)+
# ggtitle(dendro.title)+
# theme(plot.margin = unit(c(-2,0,-2,2), "lines"),
theme(plot.margin = unit(c(0.5,0.5,0.5,0.5), "lines"),
plot.title = element_text(size=9))+
expand_limits(y = c(height.siz,-(label.siz/3)))+
scale_x_continuous(expand = c(0.01,0.01))
out.plot <- g.dendro # by default
# save - - - - - - - - - - - - - - - - - - - -
if(ordered.dendro){
# dendro + colormap
out.plot <- ggarrange(g.dendro,g.colormap,
heights=c(20,1),nrow=2)
# out.plot <- annotate_figure(out.plot,
# top = text_grob(dendro.title, size = 10))
}
h.dend <- ceiling(length(lgrph)/10)+5
for (dev in devs){
g.out <- paste0(chm.clustering,tit,dev)
ggsave(g.out,
arrangeGrob(out.plot, top = grid:: textGrob(dendro.title,x=0,hjust=0,gp = gpar(fontsize =10))),
width = 12, height = h.dend, units = "in")
ext <- dev # for the 'shell.exec'
}
shell.exec(paste0(chm.clustering,tit,ext))
type of edges (presence/absence)
# selected edges
lsme.edg <- list(list("stele bouclier",
list("bouclier","epee"),
list("bouclier","lance"),
list("miroir","epee"),
list("miroir","lance"),
list("miroir","peigne"),
list("personnage","personnage"),
list("personnage","fibule"),
list("personnage","epee"),
#list("bouclier","fibule"),
list("personnage","lance"),
list("bouclier","personnage"),
list("arc","personnage"),
list("personnage","chariot_char"))
)
# get the rigth list
idx <- findex(lsme.edg,select.family)
sme.edg <- lsme.edg[[idx]]
sme.edg[[1]] <- NULL # (sic)
g.colored.dend <- gg.dend.gg$labels
for (i in 1:nrow(g.colored.dend)){
g.colored.dend[i,"idf"]<- unlist(strsplit(as.character(g.colored.dend[i,"label"]),'.',fixed = T))[1]
g.colored.dend[i,"site"] <- unlist(strsplit(as.character(g.colored.dend[i,"label"]),'.',fixed = T))[2]
g.colored.dend[i,"decor"] <- unlist(strsplit(as.character(g.colored.dend[i,"label"]),'.',fixed = T))[3]
}
g.colored.dend$lbl <- paste0(g.colored.dend$site,".",g.colored.dend$decor)
# fill a df with graph attributes
df.graphs <- igraph::as_data_frame(lgrph[[1]]) # template
df.graphs <- df.graphs[0,] # template
for (i in 1:length(lgrph)){
df.graphs <- rbind(df.graphs,igraph::as_data_frame(lgrph[[i]]))
}
df.graphs$lbl <- paste0(df.graphs$site,".",df.graphs$decor)
l.sme.edges <- c()
for (sel.edg in 1:length(sme.edg)){
# loop through selected egdes
# sel.edg <- 7
a.edg <- unlist(sme.edg[[sel.edg]])
edg.nme <- paste0(a.edg[1],'.',a.edg[2]) # name of the selected edge
g.colored.dend[,edg.nme]<-NA # new column
l.sme.edges <- c(l.sme.edges,edg.nme)
for (edg in 1:nrow(df.graphs)){
# edg <- 1
lbl <- df.graphs[edg,"lbl"]
edg.thm <- c(df.graphs[edg,"from"],df.graphs[edg,"to"])
equal.edg <- setequal(edg.thm,a.edg) # test if equal
if(equal.edg){
idx <- as.integer(row.names(g.colored.dend[match(lbl,g.colored.dend$lbl),]))
g.colored.dend[idx,edg.nme] <- 1
#df.sme.edg$lbl <- df.graphs[edg,"lbl"]
}
}
}
lbls <- unique(g.colored.dend$lbl)
sel.fields <- c("lbl",l.sme.edges)
g.df <- subset(g.colored.dend,select=c(sel.fields))
rownames(g.df) <- g.df$lbl
g.df$lbl <- NULL
# melt
tabla2 <- g.df %>%
as.data.frame() %>%
rownames_to_column() %>%
gather(Column, Value, -rowname)
order.col <- unique(tabla2$Column) # same order as list
# get order
g.df$idf <- 1:nrow(g.df)
g.df <- subset(g.df,select=c("idf"))
ggdf <- merge(tabla2,g.df,by="rowname",by.y="row.names")
ggdf$Column <- factor(ggdf$Column, levels = order.col)
# plot
tit <- paste0("partly seriated matrix of presence/absence for a sample of edges",
"decoration are ordered same as clustering dendrogram")
gg.sme.edg <- ggplot(ggdf, aes(x = Column, y = idf, fill = Value)) +
ggtitle(tit) +
geom_tile() +
scale_fill_gradientn(name = "",
colors = terrain.colors(10),
na.value = NA) + #"#FFFFFF"
scale_y_discrete(limits=1:length(lbls),labels=lbls,
position = "left")+
scale_x_discrete(name = "",
position = "top")+
theme_bw()+
theme(axis.text = element_text(size = 8),
axis.text.x = element_text(angle = 45, hjust=0),
axis.title.y = element_blank(),
legend.position = "none",
panel.border = element_blank())
# out.plot <- ggarrange(g.dendro,gg.sme.edg,ncol=2,widths = c(4,2))
# out.plot <- annotate_figure(out.plot,
# top = text_grob(dendro.title, size = 9))
g.out <- paste0(chm.clustering,"dataframe_of_presence_absence_edges",".png")
ggsave(g.out,gg.sme.edg,
width = 20, height = 17,units = "in")
shell.exec(g.out)
dendrogramm + type of edges (presence/absence) TODO
# TODO: plot presence absences of selected edge aside dendrogram
# selected edges
lsme.edg <- list(list("stele bouclier",
list("bouclier","epee"),
list("bouclier","lance"),
list("bouclier","personnage"),
list("personnage","epee"),
list("personnage","lance"),
list("personnage","chariot_char"),
list("miroir","peigne"))
)
# get the rigth list
idx <- findex(lsme.edg,select.obj)
sme.edg <- lsme.edg[[idx]]
g.colored.dend <- gg.dend.gg$labels
for (i in 1:nrow(g.colored.dend)){
g.colored.dend[i,"idf"]<- unlist(strsplit(as.character(g.colored.dend[i,"label"]),'.',fixed = T))[1]
g.colored.dend[i,"site"] <- unlist(strsplit(as.character(g.colored.dend[i,"label"]),'.',fixed = T))[2]
g.colored.dend[i,"decor"] <- unlist(strsplit(as.character(g.colored.dend[i,"label"]),'.',fixed = T))[3]
}
g.colored.dend$lbl <- paste0(g.colored.dend$site,".",g.colored.dend$decor)
# fill a df with graph attributes
df.graphs <- igraph::as_data_frame(lgrph[[1]]) # template
df.graphs <- df.graphs[0,] # template
for (i in 1:length(lgrph)){
df.graphs <- rbind(df.graphs,igraph::as_data_frame(lgrph[[i]]))
}
df.graphs$lbl <- paste0(df.graphs$site,".",df.graphs$decor)
l.sme.edges <- c()
for (sel.edg in 1:length(sme.edg)){
# loop through selected egdes
# sel.edg <- 7
a.edg <- unlist(sme.edg[[sel.edg]])
edg.nme <- paste0(a.edg[1],'.',a.edg[2]) # name of the selected edge
g.colored.dend[,edg.nme]<-NA # new column
l.sme.edges <- c(l.sme.edges,edg.nme)
for (edg in 1:nrow(df.graphs)){
# edg <- 1
lbl <- df.graphs[edg,"lbl"]
edg.thm <- c(df.graphs[edg,"from"],df.graphs[edg,"to"])
equal.edg <- setequal(edg.thm,a.edg) # test if equal
if(equal.edg){
idx <- as.integer(row.names(g.colored.dend[match(lbl,g.colored.dend$lbl),]))
g.colored.dend[idx,edg.nme] <- 1
#df.sme.edg$lbl <- df.graphs[edg,"lbl"]
}
}
}
lbls <- unique(g.colored.dend$lbl)
sel.fields <- c("lbl",l.sme.edges)
g.df <- subset(g.colored.dend,select=c(sel.fields))
rownames(g.df) <- g.df$lbl
g.df$lbl <- NULL
# melt
tabla2 <- g.df %>%
as.data.frame() %>%
rownames_to_column() %>%
gather(Column, Value, -rowname)
# get order
g.df$idf <- 1:nrow(g.df)
g.df <- subset(g.df,select=c("idf"))
ggdf <- merge(tabla2,g.df,by="rowname",by.y="row.names")
# plot
gg.sme.edg <- ggplot(ggdf, aes(x = Column, y = idf, fill = Value)) +
geom_tile() +
scale_fill_gradientn(name = "",
colors = terrain.colors(10),
na.value = NA) + #"#FFFFFF"
scale_y_discrete(limits=1:length(lbls),labels=lbls,
position = "right")+
scale_x_discrete(name = "",
position = "top")+
theme_bw()+
theme(axis.text = element_text(size = 8),
axis.text.x = element_text(angle = 45, hjust=0),
axis.title.y = element_blank(),
legend.position = "none",
panel.border = element_blank())
out.plot <- ggarrange(g.dendro,gg.sme.edg,ncol=2,widths = c(4,2))
out.plot <- annotate_figure(out.plot,
top = text_grob(dendro.title, size = 9))
g.out <- paste0(chm.clustering,"xxBOTH",".png")
ggsave(g.out,out.plot,
width = 20, height = 17,units = "in")
shell.exec(g.out)
spatial family/object
# after classification, spatial
# YYY
map.type <- "super.family" # "family", "super.family"
m.var <- "clss"
if (map.type=="family"){
df.clss <- family.df(select.family) # get objects coordinates for the family
df.clss <- merge(df.clss,df.dist.mat.sel,by.x="idf.objects",by.y="idf",all.x=T)
select.corpus <- select.family
}
if (map.type=="super.family"){
df.xy <- objects.df(graphs) # reload to get x,y
df.xy <- subset(df.xy,select=c("lbl","idf","site","numero","type","x","y","fam"))
# setdiff(df.clust$lbl,df.xy$lbl);setdiff(df.xy$lbl,df.clust$lbl)
df.clss <- merge(df.clust,df.xy,by="lbl",all.x=T)
select.corpus <- select.superfamily
}
# merge with classification colors
sel.field <- c("idf","site","numero","type","x","y","color","fam") # selected fields
df.clss.spat <- subset(df.clss,select=sel.field)
miss.clss <- sum(is.na(df.clss.spat$color))
df.clss.spat$color[is.na(df.clss.spat$color)] <- "#FFFFFF" # white
df.clss.spat$fam <- gsub("stele","st",df.clss.spat$fam) # simplify families
# df.clss.spat$idf <- as.integer(row.names(df.clss.spat)) # for df
# df.clss.spat$color.from <- orig.thm # add the origin of the color (ex: Foios)
df.clss.spat <- df.clss.spat[with(df.clss.spat,order(idf)), ]
rownames(df.clss.spat) <- df.clss.spat$idf
sf.fd.carto <- f.spat.bck.grd("Europe") # load background
g.map <- f.spat.distrib(df.clss.spat,sf.fd.carto,map.type,select.corpus,m.var,42,8) # create map
# nb.miss.mp <- nrow(family.spat[family.spat$mp == 'unknown',]) # nb of missiong mp
tit <- paste0("distribution of '",m.var,"' from '",map.type,
"' objects from '",select.corpus,"' (n = ",nrow(df.clss.spat)," )")
if (ordered.dendro){tit <- paste0(tit,"\ncolor is function of khi2 distance from '",
orig.thm,"' decoration")}
chm.out <- paste0(chm.clustering,"spat_clustering.png")
ggsave(file = chm.out,
arrangeGrob(grobs = g.map,
top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)),
padding = unit(0.1, "line"),ncol = 1),
width = 17,height =17)
shell.exec(chm.out)
matrix TODO
calculate
# calculate the the pairwise matrix
# ex. row 17 of ldecors: 'Madonna delle Grazie.item7' and 'Poggio Monaco.item95' have a common edge
# export different images in 'matrix' folder
size.margins <- "15x15"
corpus <- "family" # choose 'objects' or 'family'
graphs <- create.graph.view(v.select.obj,corpus) # call function to create view
# graphs <- head(graphs,30)
lgrph <- load.graphs(graphs)[[1]] # load graphs
df.icos <- f.df.ico(v.select.obj)
# lgrph <- load.graphs(graphs.objects)[1] # load graphs
lgrph <- rm.specific.nd(lgrph,"indet") # remove indet
# lgrph[[1]]$name
lgrph_nmes <- c()
for (i in 1:length(lgrph)){
lgrph_nmes <- c(lgrph_nmes,lgrph[[i]]$name)
#print (lgrph[[i]]$name)
}
ldecors.comp <- t(combn(lgrph_nmes, 2)) # all pairwise comparisons
print(paste0("there is ",nrow(ldecors.comp)," pairwise comparisons to compute"))
for (dec in 1:nrow(ldecors.comp)){
#dec <- 1
a.compar <- paste0(ldecors.comp[dec,],collapse=' - ')
print (paste0(" ",dec,") comparaison: ",a.compar))
#print (paste0(" ",dec,") decoration ",cat(ldecors[dec,],sep=" - ")))
ledges <- lnodes <- list() # list of two graph edges/nodes
# function call- -
for(n in c(1,2)){
# n <- 1
sit.1 <- df.icos[which(df.icos$idf == ldecors.comp[dec,n]), "site"]
num.1 <- df.icos[which(df.icos$idf == ldecors.comp[dec,n]), "numero"]
image.dec <- df.icos[which(df.icos$idf == ldecors.comp[dec,n]), "img"] # image
rast.1 <- as.raster(image_read(image.dec)) # image to raster
offset.img <- dim(rast.1)[1] # offset depend on raster size
#print (offset.img)
ledges[[length(ledges)+1]] <- edges.df(n,dec,sit.1,num.1)
lnodes[[length(lnodes)+1]] <- nodes.df(sit.1,num.1)
}
# common edges
graph.a <- ledges[[1]];graph.b <- ledges[[2]]
nme.a <- unique(paste0(graph.a$site,'.',graph.a$decor))
nme.b <- unique(paste0(graph.b$site,'.',graph.b$decor))
graphs.nmes <- c(paste0(nme.a,'_',nme.b),paste0(nme.b,'_',nme.a))
l.common.edges <- intersect(unique(graph.a$rel),unique(graph.b$rel))
for (j in c(1,2)){
#j <- 1
nodes.j <- lnodes[[j]];graph.j <- ledges[[j]]
common.edges.j <- graph.j[which(graph.j$rel %in% l.common.edges),]
a.img <- image_read(unique(graph.j$image.dec))
#image.dec.1 <- unique(graph.a$image.dec)
#print(unique(graph.j$image.dec))
#dec.nme <- unique(paste0(graph.j$site,'.',graph.j$decor))
rast.j <- as.raster(a.img) # image to raster
# decor + graph - -
chm.out <- paste0(chm.matrix,graphs.nmes[j],'.png')
png(chm.out);plot(rast.j)
# add all edges
for (edg in 1:nrow(graph.j)){
lines(c(graph.j[edg,"xa"],graph.j[edg,"xb"]),
c(graph.j[edg,"ya"],graph.j[edg,"yb"]),
lwd=4,col="orange")
}
# add common edges
for (edg in 1:nrow(common.edges.j)){
lines(c(common.edges.j[edg,"xa"],common.edges.j[edg,"xb"]),
c(common.edges.j[edg,"ya"],common.edges.j[edg,"yb"]),
lwd=8,col="red")
}
# add nodes
points(c(nodes.j$x), c(nodes.j$y),
pch=16,cex=1.5,col="orange")
dev.off()
}
}
# trim images
for (img in list.files(chm.matrix)){
img.dec <- image_read(paste0(chm.matrix,img))
img.dec <- image_trim(img.dec) # trim
# add white margins
img.dec <- image_border(img.dec,"#FFFFFF", size.margins)
chm.out <- paste0(chm.matrix,img)
image_write(img.dec, chm.out, format = "png")
}
draw
# draw the square matrix planche
df.icos <- f.df.ico(v.select.obj)
df.mtrx <- data.frame(matrix(ncol = nrow(df.icos),
nrow = nrow(df.icos)))
rownames(df.mtrx) <- df.icos$idf
colnames(df.mtrx) <- df.icos$idf
limgs <- list()
intitules <- textGrob(c(1:nrow(df.mtrx)))
# intitules <- c("",LETTERS[1:nrow(df.mtrx)])
#limgs <- list("",textGrob(LETTERS[1:nrow(df.mtrx)])) # to store images
# add first line
# limgs[[length(limgs)+1]] <- textGrob("")
# for (it in 1:nrow(df.mtrx)){
# limgs[[length(limgs)+1]] <- textGrob(it)
# }
objets <- objects.df(graphs)
for (i in 1:nrow(objets)){
# save decor only to the 'matrix' folder for diag
#i <- 1
sit.a<-objets[i,"site"];num.a<-objets[i,"numero"];lbl.a<-objets[i,"lbl"];idf.a<-objets[i,"idf"]
img.diag <- paste0(chm.matrix,sit.a,'.',num.a,".png")
img.a <- df.icos[df.icos$site == sit.a & df.icos$num == num.a,]$img
img.a <- image_read(img.a)
img.a <- image_trim(img.a) # trim
# add white margins
img.a <- image_border(img.a,"#FFFFFF", size.margins) # add border
# add number
img.a <- image_annotate(img.a, i, size = 60,gravity = "northwest",
color = "black", boxcolor = "white")
img.a <- image_negate(img.a) # invert diag image
image_write(img.a, img.diag, format = "png")
}
#limgs[1:nrow(df.mtrx)] <- "",textGrob(LETTERS[1:nrow(df.mtrx)])
for (r in 1:nrow(df.mtrx)){
#r <- 1
#limgs[[length(limgs)+1]] <- textGrob(r) # add numbers
for (c in 1:ncol(df.mtrx)){
if (r == c){
# the diagonal
idf.diag <- df.icos[r,"idf"]
img.diag <- image_read(paste0(chm.matrix,idf.diag,'.png'))
#img.diag <- image_trim(img.diag)
#img.diag <- image_border(img.diag, "black", "5x5")
limgs[[length(limgs)+1]] <- image_ggplot(img.diag)+theme(plot.margin = unit(c(0,0,0,0), "cm"))
}
if (r != c){
# symetric
idf.a <- rownames(df.mtrx)[r]
idf.b <- colnames(df.mtrx)[c]
idf.ab <- paste0(idf.a,"_",idf.b)
img.ab <- image_read(paste0(chm.matrix,idf.ab,'.png'))
img.ab <- image_background(img.ab, "grey") # add backgrond
#img.ab <- image_trim(img.ab)
limgs[[length(limgs)+1]] <- image_ggplot(img.ab)+theme(plot.margin = unit(c(0,0,0,0), "cm"))
}
}
}
# fill
# diagonal with image only
#grid.arrange(grobs = limgs, ncol = ncol(df.mtrx))
ifelse(ncol(df.mtrx)>49, s <- 49, s <-ncol(df.mtrx))
# ggsave(file = paste0(chm.groups,grp.name,"_spat.png"),
# arrangeGrob(grobs = list(g.map+margin,tableGrob(objets.selected.tab,rows=NULL)),
# top = grid::textGrob(grp.name,x=0,hjust=0,gp = gpar(fontsize =10)),
# padding = unit(0.1, "line"),ncol = 1),
# width = 6,height =nrow(objets.selected.tab))
#margin = theme(plot.margin = unit(c(0,0,0,0), "cm"))
ggsave(paste0(chm.etude,"2-ico_matrix.png"),
arrangeGrob(grobs = limgs, ncol = ncol(df.mtrx)),
# arrangeGrob(grobs = limgs, ncol = ncol(df.mtrx)),
width=s,
height=s)
shell.exec(paste0(chm.etude,"2-ico_matrix.png"))
UGS
Themes on decorations (ug) or real objects independently from 'famille' or 'selected objects'
# select.thms <- c("casque","epee","bouclier","carquois","lance","cuirasse","hallebarde","hache","poignard")
#select.thms <- c("carquois","anciforme")
#select.thms <- c("ciseau")
select.thms <- c("piernabierto")
# TODO: stats general Pg
# select type, count (*) as tot from table_noeuds group by type order by tot desc
on decorations
corpus
# create an image with all object having the 'select.thm'
#chm.ico.ug
f.chm.ug(select.thms) # out folders
contact.sheet.select.ugs(select.thms) # thms and number of img for a line
for (select.thm in select.thms){
shell.exec(paste0(chm.ug.typo,select.thm)) # open the folder
}
spatial
# spatial distribution of themes
# select.thms <- "boucles_oreilles"
map.type = "ugs"
f.chm.ug(select.thms) # out folders
for (select.thm in select.thms){
print(paste0("* read theme: ",select.thm," *"))
ugs.spat <- f.ugs(select.thm) # get objects coordinates for the family
sel.fields <- c("site.dec","site","decor","famille","x","y")
ugs.spat <- subset(ugs.spat,select=sel.fields)
df.ct <- as.data.frame(table(ugs.spat$site.dec)) # count of thm by decor
ugs.spat.ct <- merge(ugs.spat,df.ct,by.x="site.dec",by.y="Var1")
ugs.spat.ct <- ugs.spat.ct[!duplicated(ugs.spat.ct), ] # rm duplicated
# ugs.spat <- aggregate(x=ugs.spat$site.dec, by=list(ugs.spat$site,
# ugs.spat$decor,
# ugs.spat$x,
# ugs.spat$y),
# FUN = count)
# order by 'family','site','decor'
ugs.spat.ct <- ugs.spat.ct[with(ugs.spat.ct, order(famille, site, decor)), ]
rownames(ugs.spat.ct) <- 1:nrow(ugs.spat.ct)
ugs.spat.ct$idf <- 1:nrow(ugs.spat.ct)
# ugs.spat$lbl <- paste0(ugs.spat$site,'.',ugs.spat$decor)
# n.obj <- length(unique(ugs.spat$lbl))
n.obj <- nrow(ugs.spat.ct)
n.ugs <- sum(ugs.spat.ct$Freq)
#family.spat$idf <- as.integer(row.names(family.spat))
sf.fd.carto <- f.spat.bck.grd("Europe") # load background
#map.name <- unique(family.spat$famille) # nam for the output
g.map <- f.spat.distrib(ugs.spat.ct,sf.fd.carto,map.type,select.thm,"all",25,8) # export map
tit <- paste0("ugs distribution of '",select.thm,"' (n= ",n.ugs,") from ",n.obj," decorations")
for (dev in c(".png",".pdf")){
g.out <- paste0(chm.ug.typo,select.thm,"/",map.type,"_spat",dev)
# g.out <- paste0(chm.thm,select.thm,"_",map.type,"_spat",dev)
ggsave(file = g.out,
arrangeGrob(grobs = g.map,
top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)),
padding = unit(0.1, "line"),ncol = 1),
width = ceiling(n.obj/10)+10,height =ceiling(n.obj/10)+10)
}
}
# shell.exec(g.out)
stats
dimensions
within themes
# select.thms <- c("bracelet")
for (select.thm in select.thms){
# select.thm <- c("carquois")
print(paste0("* read theme: '",select.thm,"' *"))
ugs.dim <- f.ugs(select.thm) # load
ugs.dim$lbl <- paste0(ugs.dim$idf,".",ugs.dim$id) # like '1.5'
ugs.dim.complets <- ugs.dim[ugs.dim$incomplet == 0,] # complet
ugs.dim.complets <- ugs.dim.complets[!is.na(ugs.dim.complets$long_cm),] # cm exist
ugs.dim.incomplets <- ugs.dim[ugs.dim$incomplet == 1,] # incomplets
ugs.dim.incomplets <- ugs.dim.incomplets[!is.na(ugs.dim.incomplets$long_cm),] # cm exist
exist.complets <- sum(ugs.dim.complets$long_cm,na.rm = T)
exist.incomplets <- sum(ugs.dim.incomplets$long_cm,na.rm = T)
# mean on complete
ugs.long_cm.mean <- aggregate(ugs.dim.complets$long_cm,
by=list(Category=ugs.dim.complets$type), FUN=mean)
tit.res.test <- f.shapiro(ugs.dim.complets$long_cm,0.05,"long") # normality test
# test.thres <- 0.05
# res.test <- shapiro.test(ugs.dim.complets$long_cm)
# p.value <- round(res.test$p.value,2)
# tit.test.incip <- "normality test shows distribution is "
# tit.test.thres <- paste0("\nfor threshold '",test.thres,"' (p-value=",p.value,")")
# tit.res.test <- ifelse(p.value > test.thres,
# paste0(tit.test.incip,"'normal'",tit.test.thres),
# paste0(tit.test.incip,"'not normal'",tit.test.thres)
# )
# plot
dim.max <- ceiling(max(ugs.dim$long_cm,na.rm = T))+1
dim.min <- ceiling(min(ugs.dim$long_cm,na.rm = T))-1
if(exist.complets>0){
tit <- paste0("dimensions of '",select.thm,"' ugs (n=",nrow(ugs.dim),") colored by families",
"\nnumbers before '.' refers to decoration numeros",
"\nnumbers after '.' refers to ugs numeros")
# 1) boxplots - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
bxplt.w <- .02
pos <- position_jitter(width = .05, seed = 1)
gg.dim.bp <- ggplot()+
ggtitle(tit)+
# boxplot on complete
geom_boxplot(data=ugs.dim.complets,
aes(y=long_cm),
color="darkgrey", fill = NA, fatten = 1.5,
width=0.2,lwd=0.5,outlier.shape = NA) +
# mean
geom_point(data=ugs.long_cm.mean,
aes(x=0, y=x),
pch =3, size=3, color="red") +
geom_text(data=ugs.long_cm.mean,
aes(x=0, y= x, label=round(x,2), hjust=-.5),
size = 3, color = "red") +
# complete ugs
geom_point(data=ugs.dim.complets,
aes(x=0,y=long_cm,color=famille),
position = pos,size=2,stroke = 0) + # ugs
geom_label_repel(data=ugs.dim.complets,
aes(x=0,y=long_cm,label=lbl,color=famille),
force = .5,
segment.size = .3, segment.alpha = .5,
size = 3, label.size = NA, fill= NA, position = pos) +
theme_bw()+
theme(plot.title = element_text(size = 10))+
theme(axis.title.x = element_blank())+
theme(axis.text.x = element_blank())+
theme(axis.ticks.x = element_blank())+
theme(axis.text=element_text(size=7))+
theme(legend.position="bottom")+
scale_alpha_identity()+
# scale_color_identity()+
scale_y_continuous(breaks = seq(dim.min,dim.max, by = 2)) +
#ylim(dim.min,dim.max)+
# scale_y_continuous(breaks = seq(0,max(ugs.dim$long_cm), by = 5)) +
#scale_y_continuous(breaks = seq(0,max(ugs.dim$long_cm,na.rm = T),by =2))
scale_x_continuous(breaks = NULL)
# 2) histo - - - - - - - - - - - - - - - - - - - - - - - -
gg.dim.hist <- ggplot(ugs.dim.complets, aes(x = long_cm)) +
geom_histogram(colour = "black", fill = "grey", binwidth = 2,alpha=.5)+
geom_vline(data=ugs.dim.complets,aes(color=famille), xintercept = ugs.long_cm.mean$x)+
stat_function(fun = dnorm, args = list(mean = mean(ugs.dim.complets$long_cm),
sd = sd(ugs.dim.complets$long_cm)))+
scale_x_continuous(breaks = seq(dim.min,dim.max,by=2))+
theme_bw()+
coord_flip()
}
if(exist.incomplets>0){
# add points to boxplots
ugs.dim.incomplets$lbl <- paste0("italic('",as.character(ugs.dim.incomplets$lbl),"')")
gg.dim.bp <- gg.dim.bp +
geom_point(data=ugs.dim.incomplets,
aes(x=0,y=long_cm,alpha=.5,color=famille),
position = pos,size=2,stroke = 0) + # ugs
geom_label_repel(data=ugs.dim.incomplets,
aes(x=0,y=long_cm,label=lbl,color=famille),
force = .5,
segment.size = .3, segment.alpha = .5,
size = 3, label.size = NA, fill= NA, position = pos,
alpha=.5,
parse = TRUE)
}
if(exist.complets>0){
# save
ugs.dim.tab <- subset(ugs.dim,select=c("lbl","site.dec"))
# 3) dataset - - - - - - - - - - - - - - - - - - - - - -
t.grob <- f.corresp.tab(ugs.dim.tab,50) # tableGrob
# 4) test result - - - - - - - - - - - - - -
tit.res.test.grob <- textGrob(tit.res.test,
gp = gpar(fontsize = 8))
# add all to list
plist <- list(gg.dim.bp,gg.dim.hist,t.grob,tit.res.test.grob)
h <- ceiling(nrow(ugs.dim.tab)/3)+5
w <- 5*2
for (dev in c(".png",".pdf")){
# dev <- ".png"
g.out <- paste0(chm.ug.typo,select.thm,"/ugs_dim",dev)
# g.out <- paste0(chm.thm,select.thm,"_",map.type,"_spat",dev)
ggsave(file = g.out, arrangeGrob(grobs = plist, nrow = 2),
width = w,height =h)
}
}
}
#shell.exec(g.out)
between themes
# TODO: plot distributions of different themes in the same plot
#select.thms <- c("carquois","anciforme")
ugs.dim.all <- data.frame(site=character(0),
decor=character(0),
type=character(0),
incomplet=numeric(0),
long_cm=numeric(0),
stringsAsFactors = F)
for (select.thm in select.thms){
# select.thm <- "carquois"
print(paste0("* read theme: '",select.thm,"' *"))
ugs.dim <- f.ugs(select.thm) # load
#ugs.dim$lbl <- paste0(ugs.dim$idf,".",ugs.dim$id) # like '1.5'
#ugs.dim.complets <- ugs.dim[ugs.dim$incomplet == 0,] # complet
ugs.dim <- subset(ugs.dim,select=c("site","decor","type","incomplet","long_cm"))
ugs.dim.all <- rbind(ugs.dim.all,ugs.dim)
}
ugs.dim.all.complets <- ugs.dim.all[ugs.dim.all$incomplet == 0,] # complet
ugs.dim.all.complets.cm <- ugs.dim.all.complets[!is.na(ugs.dim.all.complets$long_cm),] # cm exist
nme.families <- paste0(select.thms,collapse=", ")
# 1) boxplot - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# 2) histo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
tit.hist <- paste0("density distribution with normal curve for:\n'",nme.families,"' families",
"\ncolored by themes")
gg.dim.hist <- ggplot(ugs.dim.all.complets.cm, aes(long_cm, fill = type)) +
ggtitle(tit.hist)+
geom_histogram(alpha = 0.5, aes(y = ..density..), position = 'identity')+
stat_function(fun = dnorm, args = list(mean = mean(ugs.dim.all.complets.cm$long_cm),
sd = sd(ugs.dim.all.complets.cm$long_cm)))+
theme_bw()+
coord_flip()
g.out <- paste0(chm.doc,"ugs_dim.png")
# g.out <- paste0(chm.thm,select.thm,"_",map.type,"_spat",dev)
ggsave(file = g.out, gg.dim.hist,
width = 10,height =10)
# ggplot(vegLengths, aes(length, fill = veg)) +
# geom_histogram(alpha = 0.5, aes(y = ..density..), position = 'identity')
real objects
corpus
contact.sheet.real.objects(select.thms) # thms and number of img for a line
listing TODO
# tableau des objets véritables
# select.thm <- c("casque")
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
sql_obj <- paste0("SELECT objets.site,objets.structure,objets.numero,objets.type,ST_X(objets.geom) as x,ST_Y(objets.geom) as y, tpq,taq FROM objets WHERE objets.type LIKE '",select.thm,"'")
all_obj <- dbGetQuery(con,sql_obj)
# met 'chrono' = 1 quand l'interval correspond
all_obj$chrono <- NA
for (i in seq(1,nrow(all_obj))){
all_obj[i,"chrono"] <- ifelse(Overlap(chrono.limit,c(all_obj[i,"tpq"],all_obj[i,"taq"])) > 0, 1, 0)
}
all_obj <- subset(all_obj, chrono == 1)
all_obj$chrono <- NULL
tab_obj <- subset(all_obj,select=c("site","structure","numero","tpq","taq"))
ktab_obj <- kable(tab_obj, "html", booktabs = TRUE, longtable = TRUE, caption = paste0("Objets véritables identiques au thème <b>",select.thm,"</b>")) %>%
kable_styling(latex_options = c("hold_position", "repeat_header"))
#tt <- ttheme_default(colhead=list(fg_params = list(parse=TRUE)))
#grid.table(ktab_dec,theme=mythm)
#print(paste("les noeuds qui ont aucun lien avec les autres thèmes sont:",ug_ss_liens))
ktab_obj
invisible(dbDisconnect(con))
spatial
map.type <- "archeo"
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
#select.thms <- c("bouclier")
for (select.thm in select.thms){
print(paste0("* read theme: ",select.thm," *"))
sqll <- paste0("SELECT site,numero,type,ST_X(geom) as x,ST_Y(geom) as y FROM objets ",
"wHERE type LIKE '",select.thm,"'")
select.thm.spat <- dbGetQuery(con,sqll)
if (nrow(select.thm.spat)>0){
# at least one object to plot
# ugs.spat <- f.ugs(select.thm) # get objects coordinates
select.thm.spat$idf <- 1:nrow(select.thm.spat)
# ugs.spat$lbl <- paste0(ugs.spat$site,'.',ugs.spat$decor)
n.obj <- nrow(select.thm.spat)
#family.spat$idf <- as.integer(row.names(family.spat))
sf.fd.carto <- f.spat.bck.grd("Europe") # load background
#map.name <- unique(family.spat$famille) # nam for the output
g.map <- f.spat.distrib(select.thm.spat,sf.fd.carto,map.type,select.thm,"all",25,8) # export map
tit <- paste0("real objects distribution of '",select.thm,"' (n= ",nrow(select.thm.spat),")")
for (dev in c(".png",".pdf")){
g.out <- paste0(chm.thm,select.thm,"_",map.type,"_spat",dev)
ggsave(file = g.out,
arrangeGrob(grobs = g.map,
top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)),
padding = unit(0.1, "line"),ncol = 1),
width = 17,height =17)
}
}
}
dbDisconnect(con)
shell.exec(g.out)
COMPARISONS
Procustean analysis
library(png)
# chm.procust <- "D:/Cultures_9/Epees/(Etude)/epees_poignees_branderm/"
chm.procust <- "D:/Cultures_9/Armatures/(Etude)/armatures_clement/"
# chm.procust.orig <- paste0(chm.procust,'originaux/')
chm.procust.etude <- paste0(chm.procust,'(Etude)/')
chm.procust.etude.png <- paste0(chm.procust.etude,'1_1/')
# classification parameters - - - - - - - - - - - - - - -
# essai: "minkowski"*"complete" -> BOF
# "euclidian"*"complete" -> PAS MAL
dist.meth <- "euclidian" # "euclidian"
clust.meth <- "complete" # "ward.D2", "complete", "min"
# clusters
n_clust <- 5 # nb clusters, look to python result
clust.colors <- c("blue","red","green","orange","violet","grey35","brown")
# matrice des distances procusteenne issue de Python
mat.dist <- paste0(chm.procust.etude,"mat_dist.xlsx")
dist.mtx <- openxlsx::read.xlsx(mat.dist,
skipEmptyRows=TRUE)
# chm.procust.etude.png <- paste0(getwd(),'/1_1/',sep='')
row.names(dist.mtx) <- as.character(dist.mtx[,1])
dist.mtx[,1]<- NULL
list.figs <- as.list(colnames(dist.mtx))
# simplify names
colnames(dist.mtx) <- rownames(dist.mtx) <- gsub(x = names(dist.mtx),
pattern = ".tif",
replacement = "")
fig.tot <- length(list.figs)
fig.silex <- 0
fig.comp <- 0
# - - - - - - - - - - - - - - - - - - - -
# classify on hc
dendr <- as.dist(t(dist.mtx),dist.meth) %>%
scale %>%
dist %>%
hclust(clust.meth)
dend1 <- dendr %>% as.dendrogram # créé un 'dendrogram'
# 'df.clusters' get colors on clusters
df.clusters <- as.data.frame(cutree(dend1, k = n_clust, h = NULL)) # enregistre les clusters
colnames(df.clusters)[1] <- 'cluster.hc'
df.clusters$objects <- row.names(df.clusters)
df.clusters$ord <- seq(1,nrow(df.clusters)) # ord initial
df.clusters$ord <- factor(df.clusters$ord, levels = order.dendrogram(dend1))
df.clusters <- df.clusters[order(df.clusters$ord),]
df.clusters$cluster.hc <- as.integer(as.character(df.clusters$cluster.hc)) # convert to integer
df.clusters$color <- clust.colors[df.clusters[,"cluster.hc"]]
dend1 <- dend1 %>%
set("branches_lwd", .2) %>%
set("labels_cex", 0.7) %>% #.3
set("labels_col", df.clusters$color) # get colors of df.clusters
# functions - - - - - - - - - - - - - - -
#diag(dist_mtx) <- 0
f <- function(m) {
m[lower.tri(m)] <- t(m)[lower.tri(m)]
m
}
#nmes_img <- row.names(dist_mtx) # nom des images
fS <- function(dx,sl){
# informations sur les matrices et le dataset
if (sl == "all"){
select.s <- "[0-9]$"
}
if (sl == "silex"){
select.s <- "^p[0-9]"
}
if (sl == "statue"){
select.s <- "stat[0-9]*$"
}
if (sl == "statue_a"){
#print ("ggkj")
select.s <- "a$"
}
if (sl == "kh_ag"){ # Kharaysin et Ain Ghazal
# supprime les statues_a
#dx <- dist_mtx
dist.s <- dx[,c(grep("[0-9]$",names(dx))), drop=F] # colonnes
dist.s <- dist.s[grep("^s[0-9]", row.names(dist.s)),] # lignes
dist.s <- dist.s[,c(grep("^stat",names(dist.s))), drop=F] # colonnes
# quand on veut comparer les deux dataset (kh et ag), on ne supprime que
# les colonnes ou que les lignes
# supprime les statues (en col)
# dist.s <- dist.s[,c(grep("^s[0-9]",names(dx))), drop=F] # colonnes
# dist.s <- dist.s[grep("^s[0-9]", row.names(dist.s)),] # lignes
# dist.s <- dist.s[-grep("^stat", row.names(dist.s)),] # lignes
# dist.s <- dist.s[,c(-grep("^s[0-9]",names(dist.s))), drop=F] # colonnes
# dist.s <- dist.s[,c(-grep("a$",names(dist.s))), drop=F] # colonnes
}
if (sl != "kh_ag"){
dist.s <- dx[,c(grep(select.s,names(dx))), drop=F] # colonnes
dist.s <- dist.s[grep(select.s, row.names(dist.s)),] # lignes
}
#View(dist.s)
# Min
Mmin.s <- which(dist.s== min(dist.s,na.rm = TRUE), arr.ind = TRUE)
Mmin.s.val <- dist.s[Mmin.s[1],Mmin.s[2]]*100
Mmin.s.a <- rownames(Mmin.s)
Mmin.s.b <- colnames(dist.s[Mmin.s[2]])
# total
nb.s <- ncol(dist.s)
return(unique(c(Mmin.s.a,Mmin.s.b,nb.s)))
}
fMDS_init <- function(dist_mtx,n_clust){
# dataframe with coordinates and images
# dist_mtx ; n_clust <- nclustsA
c <- as.dist(t(dist_mtx),dist.meth) # matrice des distances
d <- dist(c)
res <- hclust(as.dist(t(dist_mtx)))
#res <- hclust(d,method=clust.meth)
res$call <-NULL # pour ne pas que cela s'affiche
n <- nrow(dist_mtx) # pour couper l'arbre
MidPoint = (res$height[n-n_clust] + res$height[n-n_clust+1]) / 2
cluster.mds <- cutree(res, k = n_clust, h = NULL) # enregistre les clusters
mds = isoMDS(c,trace = F) #
mds_dat <- as.data.frame(mds$points)
mds_dat <- cbind(mds_dat,as.data.frame(cluster.mds))
#mds_dat$cluster.mds = as.factor(mds_dat$clusters.mds)
# ajoute les images et le lbl
mds_dat$img <- NA
mds_dat$img_nme <- NA
list_png <- list.files(chm.procust.etude.png)
for (png_ in list_png){
# png_ <- "poign104_aad.png"
# match with object name, without bib ref and extension
j <- gsub(".png", replacement = "", png_)
mds_dat[j,"img"] <- paste(chm.procust.etude.png,png_,sep='')
# a simple label
lbl <- gsub("poign", replacement = "p", j)
mds_dat[j,"img_nme"] <- lbl
}
#nme_mds_dat <- gsub(".tif", replacement = "", x = rownames(mds_dat))
return(mds_dat)
}
zoom_clust <- FALSE
if (zoom_clust){
# subset
num_clus <- 1 # le num?ro du cluster s?lectionn?
mds_dat_clust <- mds_dat[mds_dat[, "clusters"] == num_clus,]
}
# return factorial map
fPlotMDS <- function(mds_dat_clust,dim_img_stat,dim_img_s){
# mds_dat_clust,img_nme,image,dim_img_stat,dim_img_s
# add white space to plot images
a.buff <- .02
maxV1 <- max(mds_dat_clust$V1)+a.buff;minV1 <- min(mds_dat_clust$V1)-a.buff
maxV2 <- max(mds_dat_clust$V2)+a.buff;minV2 <- min(mds_dat_clust$V2)-a.buff
p <- ggplot(mds_dat_clust, aes(V1, V2, label = img_nme)) +
geom_point(aes(colour = color), size=1)+
theme_bw()+
xlim(minV1, maxV1)+ylim(minV2, maxV2)
# remplit une liste pour les images
param <- list()
for (i in 1:nrow(mds_dat_clust)){
# i <- 1
image <- mds_dat_clust[i,"img"]
# distingue statues et silex
if (!grepl("stat", image)){
x_min <- mds_dat_clust[i,"V1"]-dim_img_s
x_max <- mds_dat_clust[i,"V1"]+dim_img_s
y_min <- mds_dat_clust[i,"V2"]-dim_img_s
y_max <- mds_dat_clust[i,"V2"]+dim_img_s
}
if (grepl("stat", image)){
x_min <- mds_dat_clust[i,"V1"]-dim_img_stat
x_max <- mds_dat_clust[i,"V1"]+dim_img_stat
y_min <- mds_dat_clust[i,"V2"]-dim_img_stat
y_max <- mds_dat_clust[i,"V2"]+dim_img_stat
}
img1 <- readPNG(image,native = TRUE)
g1 <- rasterGrob(img1, interpolate=FALSE)
param <- list(param,annotation_custom(g1,x_min,x_max,y_min,y_max))
}
# plot images and labels
gMDS <- p+param+
# geom_point(size=1,color = mds_dat_clust$clusters)+
geom_label_repel(aes(colour = color),
size=3,
segment.alpha=0.5,
label.padding = 0.1,
label.size = NA,
fill = NA)+
scale_color_identity("clusters",guide = "legend")
#scale_color_identity()
# scale_colour_manual(values = clust.colors)
#geom_text_repel(size=3, segment.alpha=0.5)
return(gMDS) # obj ggplot
}
Corpus
mat1 <- paste0(chm.procust.orig,'BIB 2892 Brandherm Epees poignees.jpg')
include_graphics(mat1)
Analysis
Dendrogramm
```rDendrogram on the matrix of procustean distances for the complete arrow heads"}
select.s <- "p[0-9]*a" # toutes sans les transformées
dist_mtx_kh <- dist_mtx[-grep(select.s, rownames(dist_mtx)), ]
dist_mtx_kh <- dist_mtx_kh[,-grep(select.s, colnames(dist_mtx_kh)) ]
dendrogramme
gg.dend.gg <- as.ggdend(dend1)
g.dendro <- ggplot2::ggplot(gg.dend.gg, horiz = TRUE)+
theme(plot.margin = unit(c(0.5,0.5,0.5,0.5), "lines"),
plot.title = element_text(size=12))
g.hc <- fPlotDendro(dist_mtx,nclustsA,mds_dat_clust)
g.procust.hc <- paste0(chm.procust.etude,"_herachical_clustering.png")
ggsave(g.procust.hc,
g.dendro,
width = 10,
height = 10)
shell.exec(g.procust.hc)
#### MDS plotting
```rMultidimensional scaling on the matrix of procustean distances for the complete arrow heads"}
dim_img_stat <- dim_img_s <- 0.025 # va servir a la taill de l'image statue et silex
# plan
mds_dat_clust <- fMDS_init(dist.mtx,n_clust) # avec le nb de clustersMDS
mds_dat_clust_color <- merge(mds_dat_clust,df.clusters,by="row.names")
#mds_dat_clust$color.mds <- clust.colors[mds_dat_clust[,"clusters"]] # colors of clusters
g.mds <- fPlotMDS(mds_dat_clust_color,dim_img_stat,dim_img_s) # fonction plot
g.procust.mds <- paste0(chm.procust.etude,"_multidimentional_scaling.png")
ggsave(g.procust.mds,
g.mds,
width = (nrow(mds_dat_clust)/1.5)+1,
height = (nrow(mds_dat_clust)/1.5)+1)
shell.exec(g.procust.mds)
DATATIONS 14C
library(RPostgreSQL)
library(Bchron)
C14.bd <- T
C14.ucl <- !C14.bd
if (C14.bd){
# read Pg BD
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
sqll <- paste0("SELECT site,us,id,bp,delta,taxon,code,culture,bib FROM datations")
df.datations <- dbGetQuery(con,sqll)
dbDisconnect(con)
# sort(unique(df.datations$bib))
# calibrate
a.enr <- df.datations[1,]
a.dat <- BchronCalibrate(ages=a.enr$bp,
ageSds=a.enr$delta,
calCurves=c('intcal13'))
plot(a.dat)
}
if (C14.ucl){
print ("kgkggkgkj")
}
TODO: classer ces chunks
groups
distances
# found the max distances between objects in a group and other objects
#df.dist.mat
lgroups.decors <- lgroups[[3]][[2]] # get numero of objects
df.dist.mat.selected <- df.dist.mat[df.dist.mat$obj.A %in% lgroups.decors,]
df.dist.mat.selected <- df.dist.mat.selected[with(df.dist.mat.selected, order(obj.A,-value)), ] # order on A and dist
images & spatial
# create a stack of image from a selection of decorations
# selected groups of decorations
#spat.admin <- paste0(chm.spatial,"Europe_2012.shp")
#fond.carto <- st_read(spat.admin)
#fond.carto <- as_Spatial(s.sf$geom) (s.sf, 'Spatial')
#fond.carto <- SpatialPolygons(as(s.sf, 'Spatial'), proj4string=CRS("+proj=longlat +datum=WGS84 +no_defs"))
#all objets
for (i in 1:length(lgroups.all)){
if (lgroups.all[[i]][[1]] == select.obj){
for (j in 2:length(lgroups.all[[i]])){
grp.name <- lgroups.all[[i]][[j]][[1]]
grp.num.decs <- lgroups.all[[i]][[j]][[2]]
# }
# grp.name <- lgroups.all[[i]][[2]][[1]]
# grp.num.decs <- lgroups.all[[i]][[2]][[2]]
ll.decs <- list()
# images - - - - - - - -
for (gd in grp.num.decs){
# loop through decorations
num.dec <- paste0(gd,'_',objets[gd,"lbl"],'.png')
#num.dec <- gsub(" ", "", num.dec, fixed = TRUE)
# num.dec <- gsub("(", "", num.dec, fixed = TRUE)
# num.dec <- gsub(")", "", num.dec, fixed = TRUE)
# read images and convert to ggplot
print(paste0(chm.corpus,num.dec))
img <- image_ggplot(image_read(paste0(chm.corpus,num.dec)))
ll.decs[[length(ll.decs)+1]] <- img
}
margin = theme(plot.margin = unit(c(0,0,0,0), "cm"))
ggsave(file = paste0(chm.groups,grp.name,"_ico.png"),
arrangeGrob(grobs = lapply(ll.decs, "+", margin),
top = grid::textGrob(grp.name,x=0,hjust=0,gp = gpar(fontsize =10)),
padding = unit(0.1, "line"), ncol = 4),
width = 2+length(grp.num.decs)/1.5,
height = 2+length(grp.num.decs)/3)
}
}
}
ca
#perCA <- data.frame(perCA1=0,perCA2=0) # enregistre les % des axes
ca <- CA(df.typ_edges,graph = FALSE) # AFC
inertCA1 <- round(as.numeric(ca$eig[,2][1]),1)
inertCA2 <- round(as.numeric(ca$eig[,2][2]),1)
# pour afficher les %
perCA <- data.frame(perCA1=inertCA1,
perCA2=inertCA2)
coords_ind_ca <- as.data.frame(ca$row$coord)
coords_var_ca <- as.data.frame(ca$col$coord)
coords_ca <- rbind(coords_ind_ca,coords_var_ca)
colnames(coords_ca)[1] <- 'CA1'
colnames(coords_ca)[2] <- 'CA2'
coords_ca$num <- rownames(coords_ca)
coords_ca$color <- coords_ca$shape <- NA
# fill color and shapes
for (i in seq(1,nrow(coords_ca))){
if(rownames(coords_ca)[i] %in% new.col.nmes){
# variables
coords_ca[i,"color"] <- "grey"
coords_ca[i,"shape"] <- 17 #
}
if(!(rownames(coords_ca)[i] %in% new.col.nmes)){
# individuals
coords_ca[i,"color"] <- "black"
coords_ca[i,"shape"] <- 16 #
}
}
coords_ca$shape <- as.factor(coords_ca$shape)
coords_ca$color <- as.factor(coords_ca$color)
# graphes CA
gca <- ggplot(coords_ca,aes(CA1, CA2)) +
geom_point(aes(CA1, CA2,
colour=color,
fill=color,
stroke = .5,
pch = as.numeric(levels(coords_ca$shape))[coords_ca$shape]),
size = 1.5) + # 1.5
geom_text_repel(aes(CA1, CA2,label=num),
cex=2,
segment.size = 0.1,
segment.alpha = 0.5)+
geom_hline(yintercept=0, linetype="dashed", size=0.2, alpha=0.3)+
geom_vline(xintercept=0, linetype="dashed",size=0.2, alpha=0.3)+
geom_text(data=perCA,
mapping = aes(x = 0, y = -Inf,
label = paste0(perCA1,"%")),
vjust=-1,
size=2,
alpha=0.5
)+
geom_text(data=perCA,
mapping = aes(x = -Inf, y = 0,
label = paste0(perCA2,"%")),
vjust=1,
angle=90,
size=2,
alpha=0.5)+
theme(axis.text=element_text(size=5),
axis.title.x=element_text(size=8),
axis.title.y=element_text(size=8))+
theme(axis.ticks = element_line(size = 0.2))+
theme(legend.position = "none")+
theme(strip.text.x = element_text(size=8),
strip.text.y = element_blank())+
theme(panel.border = element_rect(colour='black',fill=NA,size = 0.2))+
theme(panel.background = element_rect(fill = 'transparent'))+
theme(panel.spacing.y = unit(0,"lines"))+
# scale_x_continuous(limits = c(-1, 2), expand = c(0, 0))+
# scale_y_continuous(limits = c(-1, 1), expand = c(0, 0))+
scale_colour_identity()+
scale_shape_identity()+
scale_fill_identity()
#facet_grid(per ~ .)
# create a composite figure
listing.sz <- .6 # size of text
# theme for tableGrob
mytheme.listing <- gridExtra::ttheme_default(
core = list(fg_params=list(cex = listing.sz),
padding=unit(c(.5, .5), "mm")),
colhead = list(fg_params=list(cex = listing.sz)),
rowhead = list(fg_params=list(cex = listing.sz)))
# create tableGrob
ico.listing.ind <- data.frame(idf=seq(1:nrow(df.same_edges)),
ind=rownames(df.same_edges),
stringsAsFactors = F)
listing.ind <- tableGrob(ico.listing.ind,rows = NULL, theme = mytheme.listing)
listing.var <- tableGrob(ico.listing.var,rows = NULL, theme = mytheme.listing)
# combine listings
listing.all <- gtable_combine(listing.ind,listing.var, along=2)
# arrange ca and listings
gca.listings <- grid.arrange(gca, listing.all, ncol=2, widths=c(3,0.5))
# save
ggsave(paste0(chm.etude,"4-AF_ca.png"),
gca.listings, width = nrow(df.typ_edges)/2, height = nrow(df.typ_edges)/2)
shell.exec(paste0(chm.etude,"4-AF_ca.png"))
#
# dataset.p <- merge(df_lda.per,coords_ca,by="row.names",all.y=T)
# dataset.ps <- merge(dataset.p,typsit_symb,by.x="Type.site",by.y="tsite",all.x=T)
# dataset.ps$per <- per
# dataset.ps$color <- as.character(dataset.ps$color)
spatial
# a new Postgis table for Qgis spatialization
select.obj.tab <- paste0("z_",v.select.obj)
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
out.tab <- dbGetQuery(con,paste0("select site,numero,ST_X(geom) as x,ST_Y(geom) as y from ",v.select.obj))
# pg.tab.obj <- paste0("DROP TABLE IF EXISTS ",select.obj.tab)
# dbGetQuery(con,pg.tab.obj)
# join dataframe with clusters
df.clusts.obj <- data.frame(idf=names(clusters.obj),
clust=clusters.obj)
out.tab.1 <- merge(out.tab,df.clusts.obj,by.x="row.names",by.y="idf")
colnames(out.tab.1)[which(names(out.tab.1) == "Row.names")] <- "idf"
out.tab.1$id <- NULL
coords <- SpatialPoints(out.tab.1[, c("x", "y")])
spdf <- SpatialPointsDataFrame(coords, out.tab.1)
# insert into postgres
pgInsert(con,
name = c("public", select.obj.tab),
data.obj = spdf,
overwrite=T)
# add PK for Qgis
dbGetQuery(con,paste0("ALTER TABLE ",select.obj.tab," ADD PRIMARY KEY (idf)"))
dbDisconnect(con) # disconnect
themes
représentations
# identification des noeuds qui sont isolés
# tableau des objets qui représente ce thème
ug_ss_liens <- c()
col_nmes <- dcol_nmes <- c()
drv <- dbDriver("PostgreSQL")
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
# MAJ des structures quand = NA
invisible(dbGetQuery(con,"UPDATE table_liens SET structure='xxx' WHERE structure is Null"))
sql_nds <- paste0("SELECT table_noeuds.site,table_noeuds.structure,table_noeuds.decor,table_noeuds.id,table_noeuds.type,ST_X(objets.geom) as x,ST_Y(objets.geom) as y,table_noeuds.tpq,table_noeuds.taq FROM table_noeuds,objets WHERE table_noeuds.type LIKE '",select.thm,"' AND table_noeuds.site = objets.site AND table_noeuds.structure=objets.structure AND table_noeuds.decor = objets.numero")
all_nds <- dbGetQuery(con,sql_nds)
# met 'chrono' = 1 quand l'interval correspond
all_nds$chrono <- NA
for (i in seq(1,nrow(all_nds))){
all_nds[i,"chrono"] <- ifelse(Overlap(chrono,c(all_nds[i,"tpq"],all_nds[i,"taq"])) > 0, 1, 0)
}
all_nds <- subset(all_nds, chrono == 1)
all_nds$chrono <- NULL
#all_nds$label <- apply(all_nds, 1, function(x) paste0(x[trimws(x) != ""], 1)) # faire un concat
#dout <- data.frame(decor=all_nds$decor)
invisible(dbDisconnect(con))
l <- c()
for (i in seq(1,nrow(all_nds))){
#print (as.character(all_nds[i,"decor"]))
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
sit <- all_nds[i,"site"]
struct <- all_nds[i,"structure"]
dec <- all_nds[i,"decor"]
idf <- all_nds[i,"id"]
lbl <- paste(sit, struct,dec,idf, sep="_")
# on ne prend que les noeuds contemporains (typ = NA)
sql_liens <- paste0("SELECT site,structure,decor,typ,a,b FROM table_liens WHERE site='",sit,"' AND structure='",struct,"' AND decor='",dec,"' AND typ is Null AND (a=",idf," OR b=",idf,")")
liens <- dbGetQuery(con,sql_liens)
linktest <- as.character(liens)
#print (is.na(linktest))
if (length(linktest) == 0){
ug_ss_liens <- c(ug_ss_liens,paste0(sit,"_",struct,"_",dec,"_",idf))
}
#print (paste("---------------", linktest))
invisible(dbDisconnect(con))
other_nds <- unique(liens$a)
other_nds <- c(other_nds,unique(liens$b))
other_nds <- unique(other_nds)
other_nds <- other_nds[other_nds != idf] # tous moins le noeud initial
# subset les noeuds
if (!is.null(other_nds)){
for (nd in other_nds){
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
sql_nd <- paste0("SELECT type FROM table_noeuds WHERE id=",nd," AND site='",sit,"' AND structure='",struct,"' AND decor='",dec,"'")
#print(paste("----------------------------",sql_nd))
typo_nd <- dbGetQuery(con,sql_nd)
l <- c(typo_nd,l)
l <- as.character(l)
dl <- do.call("cbind",list(l))
invisible(dbDisconnect(con))
}
}
invisible(dbDisconnect(con))
}
# le tableau de toutes les fa
col_nmes <- sort(unique(l))
dcol_nmes <- as.data.frame(do.call("rbind",list(col_nmes)))
#dcol_nmes <- as.data.frame(sapply(dcol_nmes, as.character)) # chnage le type des colonnes
for (nme in seq(1,ncol(dcol_nmes))){
colnames(dcol_nmes)[nme] <- as.character(dcol_nmes[1,nme])
}
indx <- sapply(dcol_nmes, is.factor)
dcol_nmes[indx] <- lapply(dcol_nmes[indx], function(x) as.numeric(as.character(x)))
dcol_nmes[is.na(dcol_nmes)] <- 0
df_typo <- dcol_nmes
all_nds_ <- all_nds
all_nds_$lbl <- paste(all_nds$site, all_nds$structure, all_nds$decor, sep="_")
tb_nb <- as.data.frame(table(all_nds_$lbl)) # compte
colnames(tb_nb)[which(names(tb_nb)=="Var1")] <- 'lbl'
colnames(tb_nb)[which(names(tb_nb)=="Freq")] <- 'nb'
tab_dec <- merge(all_nds_,tb_nb,by='lbl',all.y=TRUE)
tab_dec <- subset(tab_dec,select=c("site","structure","decor","type","tpq","taq","nb"))
#tab_dec <- subset(tab_dec,select=c("site","structure","decor","nb"))
tab_dec <- tab_dec[!duplicated(tab_dec), ] # sans les doublons
# tbaleau des objets qui présente ce thème
ktab_dec <- kable(tab_dec, "html", booktabs = TRUE, longtable = TRUE, caption = paste0("Présence du thème <b>",select.thm,"</b>")) %>%
kable_styling(latex_options = c("hold_position", "repeat_header"))
#tt <- ttheme_default(colhead=list(fg_params = list(parse=TRUE)))
#grid.table(ktab_dec,theme=mythm)
#print(paste("les noeuds qui ont aucun lien avec les autres thèmes sont:",ug_ss_liens))
ktab_dec
UG proches
j <- c()
#df_typo <- essai
# on remplit le tableau pour chaque decor
for (i in seq(1,nrow(all_nds))){
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
d <- c()
sit <- all_nds[i,"site"]
struct <- all_nds[i,"structure"]
dec <- all_nds[i,"decor"]
idf <- all_nds[i,"id"]
# on ne prend que les noeuds contemporains (typ = NA)
sql_liens <- paste0("SELECT site,structure,decor,typ,a,b FROM table_liens WHERE site='",sit,"' AND structure='",struct,"' AND decor='",dec,"' AND typ is Null AND (a=",idf," OR b=",idf,")")
liens <- dbGetQuery(con,sql_liens)
other_nds <- unique(liens$a)
other_nds <- c(other_nds,unique(liens$b))
other_nds <- unique(other_nds)
other_nds <- other_nds[other_nds != idf] # tous moins le noeud initial
invisible(dbDisconnect(con))
# subset les noeuds attributs
for (nd in other_nds){
con <- dbConnect(drv,
dbname="mailhac_9",
host="localhost",
port=5432,
user="postgres",
password="postgres")
sql_nd <- paste0("SELECT type FROM table_noeuds WHERE id=",nd," AND site='",sit,"' AND structure='",struct,"' AND decor='",dec,"'")
typo_nd <- dbGetQuery(con,sql_nd)
d <- c(typo_nd,d)
d <- as.character(d)
invisible(dbDisconnect(con))
#print (paste(dec, j))
}
df_typo[nrow(df_typo)+1,] <- rep(0,ncol(df_typo)) # créé un nouveau row
lbl <- paste(sit, struct,dec,idf, sep="_")
row.names(df_typo)[i] <- lbl # renomme le row avec le décor
#print (paste(i, lbl))
for (pars_col in seq(1,ncol(df_typo))){
for (thm_ in d){
# /!\ _na -> X_na
#print (paste0(" ",thm_))
if (colnames(df_typo)[pars_col] == thm_ | colnames(df_typo)[pars_col] == paste0('X',thm_)){
df_typo[i,pars_col] <- df_typo[i,pars_col]+1 # ajoute +1
}
}
#df_typo[nrow(df_typo)+1,] <- rep(0,ncol(df_typo)) # créé un nouveau row
#print (paste(dec, d))
# on remplit
#dcol_nmes <- rbind(dcol_nmes, rep(0,ncol(dcol_nmes))) # créé un nouveau row
dcol_nmes[is.na(dcol_nmes)] <- 0 # remplace NA par 0
invisible(dbDisconnect(con))
}
}
#View(df_typo)
df_typo_1 <- df_typo
df_typo$tot <- rowSums(df_typo)
df_typo <- df_typo[df_typo$tot != 0, ]
df_typo$tot <- NULL
#df_typo_1 <- df_typo[rowSums(df_typo)!=0,] # supprime les row artefacts
#View(df_typo_1)
testdt <- data.frame(x = as.character(colnames(df_typo)), count = as.integer(colSums(df_typo)))
testdt <- testdt[rev(order(testdt$count)),] # réorganise sur le total des colonnes
rownames(testdt) <- 1:nrow(testdt)
testdt$x <- factor(testdt$x,levels = testdt$x) # réordonne les levels
tit <- paste0("thèmes à proximité du thème '",select.thm,"'")
ghist <- ggplot(data = testdt) +
ggtitle(tit)+
geom_bar(aes(x = x, y = count), stat = "identity")+
theme(axis.text.x = element_text(angle = 45, hjust = 1))
#theme(plot.title = element_text(face = "bold"))
df_typo <- t_reduce_col(df_typo)
ktab_typo <- kable(df_typo, "html", booktabs = TRUE, longtable = TRUE, caption = paste0("Présence du thème <b>",select.thm,"/<b>")) %>%
kable_styling(latex_options = c("hold_position", "repeat_header"))
ktab_typo
#df_typoGrob <- tableGrob(df_typo,theme = mythm)
#grid.arrange(df_typoGrob, ghist, nrow = 2, heights=c(7,3))
ghist
invisible()
Spatialisation représentations et objets véritables
Distribution spatial des sites
# spatial
all_nds.SP <- st_as_sf(all_nds, coords = c('x', 'y'), crs = 4326)
all_objs.SP <- st_as_sf(all_obj, coords = c('x', 'y'), crs = 4326)
# tmap_leaflet(tm_shape(all_nds.SP) +
# tm_dots(size=0.1,col="red")+
# tm_text("site"))
tmap_leaflet(
# représentation
tm_shape(all_nds.SP) +
tm_dots(size=0.1,col="red")+
tm_text("site")+
# objets veritables
tm_shape(all_objs.SP) +
tm_dots(size=0.1,col="green")+
tm_text("site")
)
vérifications
noeuds isolés
# vérifications
print ("\ ")
print("les noeuds qui ont aucun lien avec les autres thèmes sont:")
print ("\ ")
for (ug_ss_lien in sort(ug_ss_liens)){
print (paste(" ",ug_ss_lien))
}
\newpage
\blandscape
données attributs
# va lire un fichier créé par python
fich <- paste0("AF_",select.thm,"_attributs.xlsx")
# le fichier créé par la fonction 'AFthm' de Python
df <- openxlsx::read.xlsx(paste0("D:/Projet Art Rupestre/decors/stats/",fich),skipEmptyRows=TRUE)
#head_df <- subset(df,select=c("site","structure","decor","id_a")) # ,"tpq_a","taq_a","chr_1_a"
head_df <- subset(df,select=c("num","grp")) # ,"tpq_a","taq_a","chr_1_a"
df.disj <- acm.disjonctif(df[7])
names(df.disj) <- gsub(x = names(df.disj), pattern = "type_b\\.", replacement = "")
df_ <- cbind(head_df,df.disj)
# aggrégation par ug
dataf <- df_ %>%
group_by(num,grp) %>%
#summarise_each(funs(sum))
summarise_all(funs(sum))
dataf <- as.data.frame(dataf)
dataf$num <- gsub('xxx', 'x', dataf$num) # simplifie les numeros de structures
row.names(dataf) <- as.character(dataf$num)
dataf$num <- NULL
########## Subset
# dataf_ <- dataf[c(2,4,8,9),] # que des groupes
# dataf_ <- dataf_[,c(1,2,4,5,7)] # séléction des sumCol > 0
########## Subset
dataf_ <- dataf
ana_pca <- TRUE
ana_ca <- TRUE
ana_lda <- FALSE
# tableau de données
mydf <- t_reduce_col(dataf_)
mydf$grp <- NULL # supprime pour l'affichage
# total des colonnes
colsums <- colSums(mydf)
mydf_ <- rbind(mydf, colsums)
r_names <- row.names(mydf_)
r_names[length(r_names)] <- "TOTAL" # le dernier
row.names(mydf_) <- r_names # renomme
# total des lignes
rowsums <- rowSums(mydf_[,-1])
mydf_ <- cbind(mydf_, rowsums)
colnames(mydf_)[ncol(mydf_)] <- 'TOTAL' # le dernier
# la table
kable(mydf_,"html") %>%
kable_styling(full_width = FALSE,
latex_options=c("scale_down"),
position = "center",
font_size=7) %>%
column_spec(ncol(mydf_)+1, bold = T) %>%
column_spec(1, bold = T) %>%
row_spec(0, bold = T) %>%
row_spec(nrow(mydf_), bold = T)
# suppression des individus et variables ci-dessous, utile en fonction des résultat des AF
# individus supplémentaires - - - - - - - - - - - - - - - - - - -
sup_ind <- c("Ategua_x_Ategua_3")
#dataf_ <- www
dataf_ <- dataf_[!rownames(dataf_) %in% sup_ind, ] # supprime ind
dt <- dataf_[,-1] # on va travailler sur les noms de row et de col
# variables supplémentaires - - - - - - - - - - - - - - - - - - -
supp_var <- colnames(dt[,colSums(dt)==0,]) # les colonnes sum = 0
# ajouter des themes à supprimer
supp_var <- c(supp_var,"fleche","arc","epee_langue_carpe","cheval")
dataf_ <- dataf_[ , !(names(dataf_) %in% supp_var)] # supprime les colonnes
#dataf_ <- dataf_[ , -which(names(dataf_) %in% supp_var)] # supprime les colonnes
# individus
df_sup_ind <- dataf_[ rowSums(dataf_[,-1])==0, ] # qd row = 0 alors suppression
supp_ind <- paste(row.names(df_sup_ind),sup_ind) # stocke
dataf_ <- dataf_[apply(dataf_[,-1], 1, function(x) !all(x==0)),] # supprime les lignes qd sum = 0
#supp_var <- dataf_[,colSums(dataf_[,-1])==0 ]
# kable(df_sup_ind,"latex") %>%
# kable_styling(full_width = FALSE,
# latex_options=c("stripped","scale_down"),
# position = "center",
# font_size=7)
\newpage
# tableau de données
mydf <- dataf_
mydf$grp <- NULL # supprime pour l'affichage
# total des colonnes
colsums <- colSums(mydf)
mydf_ <- rbind(mydf, colsums)
r_names <- row.names(mydf_)
r_names[length(r_names)] <- "TOTAL" # le dernier
row.names(mydf_) <- r_names # renomme
# total des lignes
rowsums <- rowSums(mydf_[,-1])
mydf_ <- cbind(mydf_, rowsums)
colnames(mydf_)[ncol(mydf_)] <- 'TOTAL' # le dernier
# la table
kable(mydf_,"html") %>%
kable_styling(full_width = FALSE,
latex_options=c("scale_down"),
position = "center",
font_size=7) %>%
column_spec(ncol(mydf_)+1, bold = T) %>%
column_spec(1, bold = T) %>%
row_spec(0, bold = T) %>%
row_spec(nrow(mydf_), bold = T)
\elandscape
Analyses factorielles
# out.width = "100%", out.height = "100%",
# tableau de données
xdat <- dataf_[ , -which(names(dataf_) %in% c("grp"))]
# PCA - - - - - - -
pca <- PCA(xdat,graph = FALSE,ncp = 2)
inertPCA1 <- as.numeric(pca$eig[,2][1])
inertPCA2 <- as.numeric(pca$eig[,2][2])
coords_pca <- rbind(pca$ind$coord,pca$var$coord)
colnames(coords_pca)[1] <- 'PCA1'
colnames(coords_pca)[2] <- 'PCA2'
# CA - - - - - - - -
ca <- CA(xdat,graph = FALSE,ncp = 2) # AFC
inertCA1 <- as.numeric(ca$eig[,2][1])
inertCA2 <- as.numeric(ca$eig[,2][2])
coords_ca <- rbind(ca$row$coord,ca$col$coord)
colnames(coords_ca)[1] <- 'CA1'
colnames(coords_ca)[2] <- 'CA2'
# LDA
if (ana_lda){
r <- lda(formula = grp ~ ., data = dataf_) #analyse discriminante
prop.lda = r$svd^2/sum(r$svd^2) #analyse en composantes principales
plda <- predict(object = r,
newdata = dataf_)
coords_lda <- plda$x
}
if (!ana_lda){
# on créé des coordonnées vides
coords_lda <- data.frame(row.names = row.names(dataf_),
LD1 = rep(0,nrow(dataf_)),
LD2 = rep(0,nrow(dataf_))
)
}
#dataset.p <- mergcoords_ldae(ff,plda$x,by="row.names")
# PCA + CA + LDA + grp
df_grp <- subset(dataf_,select=("grp"))
df_ca_grp <- merge(df_grp,coords_ca,by="row.names",all.y=TRUE)
row.names(df_ca_grp) <- df_ca_grp$Row.names
df_ca_grp$Row.names <- NULL
df_ca_pca <- merge(coords_pca,df_ca_grp,by="row.names")
row.names(df_ca_pca) <- df_ca_pca$Row.names
df_ca_pca$Row.names <- NULL
df_ca_pca_lda <- merge(df_ca_pca,coords_lda,by.x="row.names",by.y="row.names", all.x=TRUE)
dataset.p <- df_ca_pca_lda
dataset.p$grp <- as.factor(dataset.p[,"grp"])
#dataset.p$var_et <- NULL
# si 2 groupes uniquement
if (nlevels(dataset.p$grp) < 3){
(jCustom <-
with(dataset.p,
data.frame(grp = levels(grp),
color = c("blue","red"),
shapes = seq(1,nlevels(grp)))))
}
# 3 groupes ou plus mais < 13
if (nlevels(dataset.p$grp) > 2 & nlevels(dataset.p$grp) < 13){
(jCustom <-
with(dataset.p,
data.frame(grp = levels(grp),
color = I(brewer.pal(nlevels(grp), name = 'Paired')),
shapes = seq(1,nlevels(grp)))))
}
if (nlevels(dataset.p$grp) > 12){
jCustom <-
with(dataset.p,
data.frame(grp = levels(grp),
color = seq(1,nlevels(grp)),
shapes = seq(1,nlevels(grp))))
}
jCustom[,"grp"] <- as.character(jCustom[,"grp"])
jCustom[,"shapes"] <- as.character(jCustom[,"shapes"])
sel.typ <- unique(dataset.p$grp)
jCustom <-jCustom[jCustom$grp %in% sel.typ,]
dataset.q <- merge(dataset.p,jCustom,by="grp",all.x=TRUE)
dataset.q$idf <- as.character(seq(1,nrow(dataset.q))) # les idf
# les variables
# remplace les valeurs NA
dataset.q$shapes <- as.integer(dataset.q$shapes)
dataset.q[["shapes"]][is.na(dataset.q[["shapes"]])] <- 25
dataset.q$color <- as.character(dataset.q$color)
dataset.q[["color"]][is.na(dataset.q[["color"]])] <- 'black'
dataset.q$grp <- as.character(dataset.q$grp)
dataset.q[["grp"]][is.na(dataset.q[["grp"]])] <- 'var'
# remplace les idf des variables par leur valeurs pour l'affichage
dataset.q <- dataset.q %>%
mutate(idf = ifelse(grp == "var",
Row.names, idf))
jCustom[,"grp"] <- as.factor(jCustom[,"grp"]) # sinon erreur
jCustom[,"shapes"] <- as.factor(jCustom[,"shapes"]) # sinon erreur
dataset.q$shapes <- as.factor(dataset.q$shapes)
dataset.q$color <- as.factor(dataset.q$color)
dataset.q$grp <- as.factor(dataset.q$grp)
# la table - -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
df.table <- dataset.q[ , -which(names(dataset.q) %in% c("color","shapes"))]
df.table <- df.table[complete.cases(df.table), ]
df.table$numero <- df.table$Row.names
df.table <- subset(df.table,select=c("idf","numero"))
sit.df.plot <- fdat.columned(df.table,nb.col.tab) # en n colnnes
tgrob <- tableGrob(sit.df.plot,
theme = ttheme_default(base_size = size.txt.tab,
padding = unit(c(padd.tab,padd.tab), "mm")),
cols = NULL, rows = NULL)
find_cell <- function(table, row, col, name="core-fg"){
l <- table$layout
which(l$t==row & l$l==col & l$name==name)
}
sel_col <- c()
# met en gras les colonnes des idf
if (nb.col.tab == 1){sel_col <- c(1)}
if (nb.col.tab == 2){sel_col <- c(1,3)}
if (nb.col.tab == 3){sel_col <- c(1,3,5)}
if (nb.col.tab == 4){sel_col <- c(1,3,5,7)}
for (col_ in sel_col){
for (row_ in seq(1,nrow(sit.df.plot))){
ind <- find_cell(tgrob, row_, col_, "core-fg")
tgrob$grobs[ind][[1]][["gp"]] <- gpar(fontsize=size.txt.tab+1, fontface="bold")
}
}
# graphe
# LDA
if (ana_lda){
dg <- dataset.q[complete.cases(dataset.q), ]
#couleurs contours
myColorss <- unique(dg$color)
names(myColorss) <- unique(dg$shapes)
#shapes
myShapes <- unique(dg$shapes)
names(myShapes) <- unique(dg$shapes)
g.lda <- ggplot(dg,aes(LD1, LD2)) +
ggtitle(titre)+
#ggplot(dataset.q,aes(CA1, CA1)) +
geom_point(aes(LD1, LD2,
colour = shapes,
pch = shapes),
size = symb.size) +
geom_text_repel(aes(LD1, LD2,label=idf),
cex=siz.txt,
segment.size = 0.5,
segment.alpha = 0.3,
segment.colour = jCustom[match(dataset.q$grp,jCustom$grp),"color"])+
scale_colour_manual(labels = jCustom$grp, name = grp,values = myColorss)+
scale_shape_manual(labels = jCustom$grp, name = grp, values = myShapes)+
geom_hline(yintercept=0, linetype="dashed",alpha=0.5)+
geom_vline(xintercept=0, linetype="dashed",alpha=0.5)+
labs(color = "type de site\n",
x = paste("LD1 (", percent(prop.lda[1]), ")", sep=""),
y = paste("LD2 (", percent(prop.lda[2]), ")", sep=""))+
# cette légénde sera réutilisées
theme(plot.title = element_text(size = 10),
axis.text=element_text(size=6),
axis.title.x=element_text(size=8),
axis.title.y=element_text(size=8),
legend.direction = "horizontal",
legend.position="bottom",
legend.title = element_text(size=lgd.size+2),
legend.text=element_text(size=lgd.size+1),
panel.background = element_rect(fill = 'transparent'))
}
if (ana_pca){
#dg <- dataset.q[complete.cases(dataset.q), ]
#dg <- dataset.q
#couleurs contours
myColorss <- unique(dataset.q$color)
names(myColorss) <- unique(dataset.q$shapes)
#shapes
myShapes <- unique(dataset.q$shapes)
names(myShapes) <- unique(dataset.q$shapes)
g.pca <- ggplot(dataset.q,aes(PCA1, PCA2)) +
#ggplot(dataset.q,aes(CA1, CA1)) +
geom_point(aes(PCA1, PCA2,
colour = shapes,
pch = shapes),
size = symb.size) +
geom_text_repel(aes(PCA1, PCA2,label=idf),
cex=siz.txt,
segment.size = 0.5,
segment.alpha = 0.3,
segment.colour = jCustom[match(dataset.q$grp,jCustom$grp),"color"])+
scale_colour_manual(name = "shapes",values = myColorss)+
scale_shape_manual(name = "shapes", values = myShapes)+
geom_hline(yintercept=0, linetype="dashed",alpha=0.5)+
geom_vline(xintercept=0, linetype="dashed",alpha=0.5)+
labs(x = paste("PCA1 (", percent(inertPCA1), ")", sep=""),
y = paste("PCA2 (", percent(inertPCA2), ")", sep=""))+
# cette légénde sera réutilisées
theme(plot.title = element_text(size = 10),
axis.text=element_text(size=6),
axis.title.x=element_text(size=8),
axis.title.y=element_text(size=8),
legend.direction = "horizontal",
legend.position="bottom",
legend.title = element_text(size=lgd.size+2),
legend.text=element_text(size=lgd.size+1),
panel.background = element_rect(fill = 'transparent'))
# theme(axis.text=element_text(size=6),
# axis.title.x=element_text(size=8),
# axis.title.y=element_text(size=8))
#theme(legend.position="none")
}
# CA
if (ana_ca){
#couleurs contours
myColorss <- unique(dataset.q$color)
names(myColorss) <- unique(dataset.q$shapes)
#shapes
myShapes <- unique(dataset.q$shapes)
names(myShapes) <- unique(dataset.q$shapes)
g.ca <- ggplot(dataset.q,aes(CA1, CA2)) +
geom_point(aes(CA1, CA2,
colour = shapes,
pch = shapes),
size = symb.size) +
geom_text_repel(aes(CA1, CA2,label=idf),
cex=siz.txt,
segment.size = 0.5,
segment.alpha = 0.3,
segment.colour = jCustom[match(dataset.q$grp,jCustom$grp),"color"])+
scale_colour_manual(name = "shapes",values = myColorss)+
scale_shape_manual(name = "shapes", values = myShapes)+
geom_hline(yintercept=0, linetype="dashed",alpha=0.5)+
geom_vline(xintercept=0, linetype="dashed",alpha=0.5)+
labs(x = paste0("CA1 (", round(inertCA1,2), "%)", sep=""),
y = paste0("CA2 (", round(inertCA2,2), "%)", sep=""))+
# scale_x_continuous(limits = c(-1, 1.5))+
# scale_y_continuous(limits = c(-1, 1))+
# cette légénde sera réutilisées
theme(plot.title = element_text(size = 10),
axis.text=element_text(size=6),
axis.title.x=element_text(size=8),
axis.title.y=element_text(size=8),
legend.direction = "horizontal",
legend.position="bottom",
legend.title = element_text(size=lgd.size+2),
legend.text=element_text(size=lgd.size+1),
panel.background = element_rect(fill = 'transparent'))
# theme(axis.text=element_text(size=6),
# axis.title.x=element_text(size=8),
# axis.title.y=element_text(size=8))
#theme(legend.position="none")
}
#mylegend <- g_legend(g.ca) # récupère la légende
if (ana_lda){
g.lda <- g.lda + theme(legend.position="none") # efface legend
}
if (ana_ca){
g.ca <- g.ca + theme(legend.position="none") # efface legend
}
if (ana_pca){
g.pca <- g.pca + theme(legend.position="none") # efface legend
}
# les paramètres de la grid
grap_sz <- 16
tabgrob_sz <- 10
#legend_sz <- 4 # n'affiche pas la légende
# combine les AF
if (ana_pca & ana_ca){
#grid.arrange(g1,g2,mylegend,dataf,nrow=4,heights=c(10,10,1,3))
library(cowplot)
plot_grid(g.ca,g.pca,tgrob, align = "v", nrow = 3, rel_heights = c(2/5, 2/5, 1/5))
#grid.arrange(g.ca,g.pca,tgrob,nrow=3,heights=c(grap_sz,grap_sz,tabgrob_sz))
}
if (ana_lda & ana_ca){
grid.arrange(g.ca,g.lda,nrow=3,heights=c(grap_sz,grap_sz,tabgrob_sz))
}
if (ana_lda & ana_pca){
# affiche avec la légende de ca
grid.arrange(g.pca,g.lda,tgrob,nrow=3,heights=c(grap_sz,grap_sz,tabgrob_sz))
}
#grid.arrange(g.lda, g.pca,dataf,ncol=1)
#print(plot_grid(g.lda,g.mult,dataf, ncol = 1, nrow = 3, rel_heights=c(2,2,1)))
\newpage
Il faut choisir le nb de cluster sur le dendrogramme :
# clustering
nclust <- 3 # choisir le nb de clust
#rownames(dataset.q) <- dataset.q$Row.names
dataset.q$Row.names <- NULL
#xdat <- dataset.q[,c(oc,bota,sudo,"idf")]
xdat$idf <- as.character(seq(1,nrow(xdat))) # les idf
rownames(xdat) <- xdat$idf
xdat$idf <- NULL
xxdat <- xdat
labs = paste("",1:nrow(xxdat),sep="") #new labels
rownames(xxdat)<-labs #set new row names
xxdat <- xxdat[complete.cases(xxdat), ]
hc <- hclust(dist(xxdat), method = "complete")
clusters <- cutree(hc, k = nclust)
xxdat$clust <- NA
for (i in seq(1,length(clusters))){
xxdat[i,"clust"] <- clusters[[i]]
}
dendr <- dendro_data(hc, type="rectangle") #convert cluster object to use with ggplot
g.hier <- ggplot(segment(dendr)) +
geom_segment(aes(x=x, y=y, xend=xend, yend=yend)) +
coord_flip() +
scale_x_continuous(breaks = ggdendro::label(dendr)$x,
labels = ggdendro::label(dendr)$label,
position = "top") +
scale_y_reverse(expand = c(0, 0)) +
theme_minimal() +
theme(axis.title = element_blank(),
axis.text.y = element_text(size = rel(1)),
panel.grid = element_blank())
print(plot_grid(g.hier,tgrob, ncol = 1, nrow = 2, rel_heights=c(3,1)))
#plot(g.hier)
Cartographie
xdat_ <- xdat[complete.cases(xdat), ]
res.pca <- CA(xdat_,graph = FALSE)
res.hcpc <- HCPC(res.pca,
nb.clust=nclust,
metric="euclidean",
method = "complete",
graph=FALSE)
carto_graph <- fviz_cluster(res.hcpc,
repel = TRUE,
show.clust.cent = TRUE,
palette = "jco",
ggtheme = theme_minimal(),
main = "titre")
#group_col<-c("#E67AA1","#5BBFF3","#962786","#6FBBC0","#304552","#7EB440","#1266B4","#E67AA1","#5BBFF3","#962786") # les couleurs de "jco"
res.hcpc$data.clust_ <- merge(res.hcpc$data.clust,dataset.q,by.x="row.names",by.y="idf")
clusts <- res.hcpc$data.clust_[,c("Row.names","clust")]
colnames(clusts)[which(names(clusts)=="Row.names")] <- 'idf'
colo <- c("gold","steelblue1","seagreen3","red","grey","darkorchid","brown","grey30")
clusts$color <- sapply(clusts$clust, function(x) colo[x]) # map les couleurs
col <- as.character(clusts$color)
names(col) <- as.character(clusts$clust)
grid.arrange(carto_graph,tgrob,ncol=1)
# réalise la carte si spatial == TRUE
# coordonnées
if (spatial){
xmin <- as.numeric(min(df$x))
ymin <- as.numeric(min(df$y))
xmax <- as.numeric(max(df$x))
ymax <- as.numeric(max(df$y))
roi <- c(0.0,3.5,40.3,42.5) # zone d'intérêt
#roi <- c(xmin,xmax,ymin,ymax) # zone d'intérêt
#xy_sites <- df_ca_pca_lda[,c(tsit,"x","y")]
xy_sites <- coords_lda[,c(tsit,"x","y")]
#xy_sites.1 <- merge(xy_sites,df.table,by.x="row.names",by.y="site")
xy_sites.1 <- merge(xy_sites,df.table,by.x="row.names",by.y="site")
shps <- dataset.q[c("shapes","idf")]
df_sig.1 <- merge(xy_sites.1,clusts,by="idf")
df_sig <- merge(df_sig.1,shps,by="idf")
df_sig$x <- as.numeric(df_sig$x)
df_sig$y <- as.numeric(df_sig$y)
coordinates(df_sig)<-~x+y
proj4string(df_sig)<-CRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0")
df_sig.bis <-data.frame(df_sig)
names(df_sig.bis)[names(df_sig.bis)=="longitude"]<-"x"
names(df_sig.bis)[names(df_sig.bis)=="latitude"]<-"y"
roi.geo <- readOGR(paste0(doss_geo,"Europe_2012.shp"))
#roi.geo <- readOGR(paste0(doss,"ESP_adm3.shp"))
roi.geo <- crop(roi.geo, extent(roi)) # recoupe
#couleurs contours
myColorss <- unique(df_sig.bis$color)
names(myColorss) <- unique(df_sig.bis$clust)
#shapes
myShapes <- unique(df_sig.bis$clust)
names(myShapes) <- unique(df_sig.bis$clust)
carto_carto <- ggplot() +
ggtitle("titre")+
geom_polygon(data=roi.geo, aes(x=long, y=lat, group=group),fill = "grey90")+
geom_point(data=df_sig.bis,aes(x, y,
color = clust),
size = symb.size+1) +
scale_colour_manual(name = "clust",values = myColorss)+
#scale_shape_manual(name = "clust", values = myShapes)+
#scale_colour_manual(values=col) +
geom_text_repel(data=df_sig.bis,
aes(x,y,
colour=clust,
label=idf),
cex=siz.txt+1,
fontface='bold',
alpha=0.9,
segment.alpha=0.5)+
theme(legend.position="bottom",
axis.text.x=element_blank(),
axis.text.y=element_blank(),
panel.background = element_rect(fill = 'transparent'))
grid.arrange(carto_carto +coord_fixed(ratio = 1.5),dataf,ncol=1,heights=c(7,2))
}
zoometh/iconr documentation built on Nov. 9, 2023, 10:01 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.
knitr::opts_chunk$set(echo = TRUE) knitr::opts_chunk$set(fig.pos = 'H') # stabilise les images au bon endroit options(warn=-1) library(kableExtra) library(FactoMineR) library(factoextra) library(MASS) library(ggplot2) library(ggrepel) library(scales) library(gridExtra) library(lsmeans) library(RColorBrewer) library(png) library(ggspatial) library(sp) library(sf) library(spatstat) library(rgdal) library(maptools) library(raster) library(rgeos) library(maptools) library(cowplot) library(dplyr) library(data.table) library(grid) library(RPostgreSQL) library(rpostgis) library(tmap) library(DescTools) library(ade4) library(dplyr) library(knitr) library(magick) library(magrittr) library(igraph) library(gridExtra) library(ggpubr) library(dendextend) library(ggdendro) library(openxlsx) library(stringr) library(inlmisc) library(grid) library(ggplotify) # library(ggtern) library(seriation) library(tibble) library(tidyverse) library(curl) library(car) # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # select a list of décors ('select.obj') and theme ('select.thm') # the list of décors is the same to select décors and to create Postgis view for spatial # pairwise comparison of common links, ex. 'visage'--'casque' # create a correlation matrix # objects decoration = graphs # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # ldecors.all <- source("_listes.R") ## objects, famille, themes - - - - - - - - select.family <- select.obj <- "stele bouclier" # stats & spat for the whole family select.superfamily <- "steles Bz du SO europeen" # the dataset select.choice <- "select.family" # 'select.superfamily', 'select.obj', 'select.family' a.sel.grp <- F # load 'lgroups.all' #rm.attributes <- T # remove attributes from same edges chrono.limit <- c(-2000,-600) # limit chrono # - - - - - - - - - - - - - - - - meta <- T # 'meta' is textual description, '!= meta' is statistics # - - - - - - - - - - - - - - - - # graphs # TODO: change v.select.obj & v.select.family to v.select v.select <- paste0("ico_l_",eval(parse(text = select.choice))) # add "icol_l" for alphabetical ordering in db v.select <- gsub(" ","_",v.select) # replace space # TODO: remove these unecessary 'v.select' # selected obj v.select.obj <- paste0("ico_l_",select.obj) # add "icol_l" for alphabetical ordering in db v.select.obj <- gsub(" ","_",v.select.obj) # replace space # selected family v.select.family <- paste0("ico_l_",select.family) # add "icol_l" for alphabetical ordering in db v.select.family <- gsub(" ","_",v.select.family) # replace space # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # list of superfamilles (for Pg update, see. f.superf.update) superfam.all <- list(list("steles Bz du SO europeen",c("stele bouclier", "stele alentejo", "stele corse")) ) # list of origins for odered dendrograms, = 'orig.thm' lorigins.all <- list(list("stele bouclier",c("Baracal","Baracal")), list("stele alentejo",c("Abela","Abela")), list("miscellaneous",c("Foios","Foios")) ) # list of groups: specific analyses/plots for a sample lgroups.all <- list(list("stele bouclier", list("group1",c(7,5,16,28,30,33,38,39)), list("group2",c(3,6,11,25,31,42))) ) # selected themes for orientation/sens thm.orient.select.all <- list(list("stele bouclier",c("epee","lance","bouclier")), list("stele alentejo",c("epee","anciforme","hache")), list("stele corse",c("epee","poignard")), list("stele anepigraphe",c("epee")), list("stele lunigiana C",c("hache","javelot","epee")), list("miscellaneous",c("epee","lance","bouclier")) ) # lists for analysis ldecors.all <- list(list("vases_anthrop", list('Capo Alfiere','item97'), list('Cimino%','item28'), list('Madonna delle Grazi%',''), list('San Michele %','item151'), list('Ripa Tett%','item1'), list('Masseria Mansueto%','item311'), list('Sospiro%','item297'), list('Poggio Mon%','item95'), list('Rendina%','item30')), list("miscellaneous", list('Foios',''), list('Substantio','stele%'), list('Torrejon R%','Torrejon R%1'), list('Cerro Muria%',''), list('Cortijo de la R%','Cortijo de la R%1'), list('Tabuyo Del%',''), list('Solana de C%',''), list('Brozas%','')), list("stele corse", list('Apazzu','Apazzu 1'), list('Apazzu','Apazzu 2'), list('Apazzu','Apazzu 8'), list('Apazzu','Apazzu 10'), list('Apazzu','Apazzu 13'), list('Castaldu','stele_zj'), list('Capu Castincu','stele_zj'), list('Filitosa','Filitosa 1'), list('Filitosa','Filitosa 3'), list('Filitosa','Filitosa 4'), list('Filitosa','Filitosa 5'), list('Filitosa','Filitosa 6'), list('Filitosa','Filitosa 7'), list('Filitosa','Filitosa 9'), list('Filitosa','Filitosa 13'), list('I Stantari','I Stantari 2'), list('I Stantari','I Stantari 4'), list('I Stantari','I Stantari 5'), list('I Stantari','I Stantari 7'), #list('I Stantari','I Stantari 8'), list('Palaggiu','Palaggiu 2'), list('Petra Pinzuta','Petra Pinzuta'), list('Portigliolo','stele_zj'), list('Pozzone','stele_zj'), list('Santa Naria 1','stele_zk'), list('Scalsa Murta','stele'), list('Tramezzu','stele_zj'), list('U Scumunicatu','stele_zj'), list('Castello Valle','Castello_Valle') ), list("stele alentejo", list('Abela','Abela'), list('Abaixo (Monte de)','Monte De Abaixo'), list('Alfarrobeira','Alfarrobeira'), list('Assento','Assento'), list('Defesa','Defesa'), ## list('Ervidel','Ervidel 1'), ## list('Gomes Aires','Gomes Aires'), list('Mombeja','Mombeja 1'), list('Pedreirinha','Pedreirinha'), list('Joao de Negrilhos (San)','San Joao De Negrilhos'), list('Vitoria (Santa)','Santa Vitoria'), list('Tapada da Moita','Tapada Da Moita'), list('Trigaxes','Trigaxes 1')), list("stele bouclier", list('Alamillo','Alamillo'), list('Aldea del Rey','Aldea Del Rey 1'), list('Aldeanueva de San Bartolome','Aldeanueva De San Bartolome'), list('Almaden de la Plata','Almaden De La Plata 2'), list('Arroyo Bonaval','Arroyo Bonaval-Almendralejo'), list('Ategua','Ategua%'), list('Baracal','Baracal%'), list('Brozas','Brozas%'), list('Burguillos','Burguillos'), list('Cabeza de Bu%','Cabeza De Bu%1'), list('Cabeza de Bu%','Cabeza De Bu%2'), list('Cabeza de Bu%','Cabeza De Bu%3'), list('Cabeza de Bu%','Cabeza De Bu%4%'), list('Carneril (El)','El Carneril_Trujillo'), list('Capilla','Capilla 3'), list('Capilla','Capilla 8'), #list('Capote','Capote'), list('Cerro Muriano','Cerro Muriano 1'), list('Cerro Muriano','Cerro Muriano 2'), list('Cortijo de la Reina','Cortijo de La Reina 1'), list('Cortijo de la Reina','Cortijo de La Reina 2'), list('Cuatro Casas','Cuatro Casas_Carmona'), list('Ecija','Ecija 1'), list('Ecija','Ecija 2'), list('Ecija','Ecija 3'), list('Ecija','Ecija 5_El Berraco'), list('Ervidel','Ervidel 2'), list('Esparragosa de Lares','Esparragosa De Lares 1_Castuera'), # indet en attribut list('Foios','Foios'), list('Fuente de Cantos','Fuente De Cantos'), list('Granja de Cespedes','Granja De Cespedes-Badajoz'), list('Ibahernando','Ibahernando'), list('Herencias (Las)','Las Herencias 1'), list('Herencias (Las)','Las Herencias 2'), list('Magacela','Magacela'), list('Montemolin','Montemolin'), list('Pedro Abad','Pedro Abad'), list('Quinterias','Quinterias'), list('Ribera Alta','Cordoba 2_Ribera Alta'), list('Robledillo de Trujillo','Robledillo De Trujillo'), list('Salen','Buoux 1'), list('Martin de Trevejo (San)','San Martin De Trevejo'), list('Santa Ana De Trujillo','Santa Ana de Trujillo'), list('Setefilla','Setefilla'), list('Solana de Cabanas','Solana De Cabanas'), list('Substantio','stele_pn'), list('Torrejon Rubio','Torrejon Rubio 1'), list('Torrejon Rubio','Torrejon Rubio 3'), list('Tres Arroyos', 'Tres Arroyos - Albuquerque'), list('Valdetorres','Valdetorres 1'), # utile pour superpositions #list('Valpalmas','Luna_Valpalmas'), list('Viso (El)','El Viso 1'), list('Viso (El)','El Viso 2'), list('Viso (El)','El Viso 4'), list('Zarza de Montanchez','Zarza De Montanchez'), list('Zarza Capilla','Zarza Capilla 1') ), ## for META list("var_cs",list('Catal Huyuk','p_taureau_rouge__aeh')) #list("var_cs",list('Cerro Muriano','Cerro Muriano 1')) # list("var_cs",list('Cortijo de la Reina','Cortijo de La Reina 1')) # # list('Salen','Buoux 2'), # 1 seule UG # list('Touries','stele_1_ze'), # list('Touries','stele_2_ze'), # list('Touries','stele_3_ze'), # list('Touries','stele_31_aab')) ) # - - - - - - - - - - # blank theme for ggplot blank_theme <- theme_minimal()+ theme( axis.title.x = element_blank(), axis.title.y = element_blank(), panel.border = element_blank(), panel.grid=element_blank(), axis.ticks = element_blank(), plot.title=element_text(size=12, face="bold") ) ## paths - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # #select.obj.name <- gsub("ico_l_","",select.obj) # remove "ico_l_" chm <- "D:/Projet Art Rupestre_1/decors/" chm.ug <- paste0(chm,"ug/") chm.ug.typo <- paste0(chm.ug,"typo/") chm.obj <- paste0(chm,"obj") # chm.super.family <- paste0(chm,"obj",select.superfamily) chm.doc <- paste0(chm,"doc/") # chm.ugs <- paste0(chm,"ug") # chm.ugs.typo <- paste0(chm.obj,"/typo") # chm.thm <- "D:/Projet Art Rupestre/decors/thm" # "F:/Collaborations et concours/Colloques #chm.thm <- paste0(chm,"ug") chm.signes <- "C:/Rprojects/iconr/doc/ugs/" # chm.signes <- paste0(chm, "ug/signes/") # "D:/Projet Art Rupestre/decors/ug/signes/" # if not exist, create a folder with the name of the list, ex: "vases_anthrop" #### output folders ### super.family - - - - - - - - - - ifelse(!dir.exists(file.path(chm.obj, select.superfamily)), dir.create(file.path(chm.obj, select.superfamily)), FALSE) ### family or objects - - - - - - - - - - ifelse(!dir.exists(file.path(chm.obj, select.obj)), dir.create(file.path(chm.obj, select.obj)), FALSE) chm.etude <- paste0(chm.obj,"/",select.obj,"/") # if super.family, change if (select.choice == "select.superfamily"){ select.obj <- select.superfamily chm.etude <- paste0(chm.obj,"/",select.superfamily,"/") } # # matrix folder obj.matrix <- paste0(select.obj,"/matrix") ifelse(!dir.exists(file.path(chm.obj, obj.matrix)), dir.create(file.path(chm.obj, obj.matrix)), FALSE) chm.matrix <- paste0(file.path(chm.obj, obj.matrix),'/') # corpus folder obj.corpus <- paste0(select.obj,"/corpus") ifelse(!dir.exists(file.path(chm.obj, obj.corpus)), dir.create(file.path(chm.obj, obj.corpus)), FALSE) chm.corpus <- paste0(file.path(chm.obj, obj.corpus),'/') # var folder obj.var <- paste0(select.obj,"/var") ifelse(!dir.exists(file.path(chm.obj, obj.var)), dir.create(file.path(chm.obj, obj.var)), FALSE) chm.var <- paste0(file.path(chm.obj, obj.var),'/') # # groups folder # obj.groups <- paste0(select.obj,"/groups") # ifelse(!dir.exists(file.path(chm.obj, obj.groups)), # dir.create(file.path(chm.obj, obj.groups)), # FALSE) # chm.groups <- paste0(file.path(chm.obj, obj.groups),'/') # family folder, to suppress # obj.family<- paste0(select.obj,"/family") # ifelse(!dir.exists(file.path(chm.obj, obj.family)), # dir.create(file.path(chm.obj, obj.family)), # FALSE) # chm.family<- paste0(file.path(chm.obj, obj.family),'/') # thms folder obj.thms <- paste0(select.obj,"/thms") ifelse(!dir.exists(file.path(chm.obj, obj.thms)), dir.create(file.path(chm.obj, obj.thms)), FALSE) chm.thm <- paste0(file.path(chm.obj, obj.thms),'/') ### analysis folders - - - - - - - - - - obj.analysis <- paste0(select.obj,"/analysis1D") ifelse(!dir.exists(file.path(chm.obj, obj.analysis)), dir.create(file.path(chm.obj, obj.analysis)), FALSE) chm.analysis <- paste0(file.path(chm.obj, obj.analysis),'/') ## objects # chrono obj.analysis.o.chr <- paste0(obj.analysis,"/obj_chrono") ifelse(!dir.exists(file.path(chm.obj, obj.analysis.o.chr)), dir.create(file.path(chm.obj, obj.analysis.o.chr)), FALSE) chm.analysis.o.chr <- paste0(file.path(chm.obj, obj.analysis.o.chr),'/') ## decorations # histo dec.analysis.histo <- paste0(obj.analysis,"/dec_histo") ifelse(!dir.exists(file.path(chm.obj, dec.analysis.histo)), dir.create(file.path(chm.obj, dec.analysis.histo)), FALSE) chm.analysis.dec.histo <- paste0(file.path(chm.obj, dec.analysis.histo),'/') ## objects # dimensions obj.analysis.o.dimensions <- paste0(obj.analysis,"/obj_dimensions") ifelse(!dir.exists(file.path(chm.obj, obj.analysis.o.dimensions)), dir.create(file.path(chm.obj, obj.analysis.o.dimensions)), FALSE) chm.analysis.o.dimensions <- paste0(file.path(chm.obj, obj.analysis.o.dimensions),'/') # raw materials obj.analysis.o.rawmaterial <- paste0(obj.analysis,"/obj_raw_material") ifelse(!dir.exists(file.path(chm.obj, obj.analysis.o.rawmaterial)), dir.create(file.path(chm.obj, obj.analysis.o.rawmaterial)), FALSE) chm.analysis.o.rawmaterial <- paste0(file.path(chm.obj, obj.analysis.o.rawmaterial),'/') # spatial folder obj.spat <- paste0(obj.analysis,"/obj_spatial") ifelse(!dir.exists(file.path(chm.obj, obj.spat)), dir.create(file.path(chm.obj, obj.spat)), FALSE) chm.spatial<- paste0(file.path(chm.obj, obj.spat),'/') ### ugs ## graphs # # histo # ug.analysis.histo <- paste0(obj.analysis,"/ug__histo") # ifelse(!dir.exists(file.path(chm.obj, ug.analysis.histo)), # dir.create(file.path(chm.obj, ug.analysis.histo)), # FALSE) # chm.analysis.histo <- paste0(file.path(chm.obj, ug.analysis.histo),'/') ## edges # # histo # ug.analysis.e.histo <- paste0(obj.analysis,"/ug_e_histo") # ifelse(!dir.exists(file.path(chm.obj, ug.analysis.e.histo)), # dir.create(file.path(chm.obj, ug.analysis.e.histo)), # FALSE) # chm.analysis.e.histo <- paste0(file.path(chm.obj, ug.analysis.e.histo),'/') ## nodes # complet/incomplet ug.analysis.n.compl <- paste0(obj.analysis,"/ug_n_complet") ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.compl)), dir.create(file.path(chm.obj, ug.analysis.n.compl)), FALSE) chm.analysis.n.compl<- paste0(file.path(chm.obj, ug.analysis.n.compl),'/') # typo ug.analysis.n.typo<- paste0(obj.analysis,"/ug_n_typo") ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.typo)), dir.create(file.path(chm.obj, ug.analysis.n.typo)), FALSE) chm.analysis.n.typo <- paste0(file.path(chm.obj, ug.analysis.n.typo),'/') # chrono ug.analysis.n.chrono <- paste0(obj.analysis,"/ug_n_chrono") ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.chrono)), dir.create(file.path(chm.obj, ug.analysis.n.chrono)), FALSE) chm.analysis.n.chrono <- paste0(file.path(chm.obj, ug.analysis.n.chrono),'/') # dimensions ug.analysis.n.dim <- paste0(obj.analysis,"/ug_n_dimensions") ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.dim)), dir.create(file.path(chm.obj, ug.analysis.n.dim)), FALSE) chm.analysis.n.dimensions <- paste0(file.path(chm.obj, ug.analysis.n.dim),'/') # orientations ug.analysis.n.orient <- paste0(obj.analysis,"/ug_n_orientations") ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.orient)), dir.create(file.path(chm.obj, ug.analysis.n.orient)), FALSE) chm.analysis.n.orientations <- paste0(file.path(chm.obj, ug.analysis.n.orient),'/') # proximities ug.analysis.n.proximities <- paste0(obj.analysis,"/ug_n_proximities") ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.proximities)), dir.create(file.path(chm.obj, ug.analysis.n.proximities)), FALSE) chm.analysis.n.proximities <- paste0(file.path(chm.obj, ug.analysis.n.proximities),'/') # closeness ug.analysis.n.centralities <- paste0(obj.analysis,"/ug_n_centralities") ifelse(!dir.exists(file.path(chm.obj, ug.analysis.n.centralities)), dir.create(file.path(chm.obj, ug.analysis.n.centralities)), FALSE) chm.analysis.n.centralities <- paste0(file.path(chm.obj, ug.analysis.n.centralities),'/') #### ugs clustering, regression, etc. obj.clustering <- paste0(select.obj,"/analysis2D") ifelse(!dir.exists(file.path(chm.obj, obj.clustering)), dir.create(file.path(chm.obj, obj.clustering)), FALSE) chm.clustering <- paste0(file.path(chm.obj, obj.clustering),'/') # themes - - - - - - - - offset.img <- 0 # default value # to shorter names of common links new.col.nmes <- c(LETTERS, paste0("A",LETTERS), paste0("B",LETTERS), paste0("C",LETTERS), paste0("D",LETTERS), paste0("E",LETTERS), paste0("F",LETTERS), paste0("G",LETTERS), paste0("H",LETTERS), paste0("I",LETTERS), paste0("J",LETTERS)) # les types d'étude NWvoisins <- TRUE NWobj_reel <- TRUE NWvoisins_spatial <- TRUE AFattributs <- TRUE # va lire un fichier sorti de python spatial <- TRUE # flags flag.dendro.color <- F # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # distances étudiées dist <- 1 # parametres des tableuax mythm <- ttheme_default(base_size = 7) # parametres des graphes siz.txt <- 3;lgd.size <- 8;symb.size <- 2 # parametres des tableaux nb.col.tab <- 3;size.txt.tab <- 7;padd.tab <- 1 # par défaut supp_var <- supp_ind <- nclust <- NA # par défaut doss_geo <- "D:/Projet Art Rupestre/Sources/1_CONTINENTS/Europe/ADMIN/" # \fontspec{Arial} #library(dendextend) # - - - - - - - - - - - - - - - # spatial spat.marg <- 0.5 # buff margin for map ggplot (in ° lat/long) #chm.spat.admin <- "D:/Projet Art Rupestre/Sources/1_CONTINENTS/Europe/ADMIN" wgs84 <- "+proj=longlat +datum=WGS84 +ellps=WGS84 +towgs84=0,0,0" # list of shapefiles background lspat.bck.grd <- list( # call name, path folder, shapefile name list("FFF","chm FFF","shapefile FFF"), list("Europe","D:/Projet Art Rupestre/Sources/1_CONTINENTS/Europe/ADMIN","Europe_2012") ) # functions - - - - - - - - - - - - - - - - - - - - - - - - - - - - # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Expert <- F # layout.df.objects <- function(df.objects,gs){ # # take df.objects from 'objects' or 'family' and make some changes # df.objects$lbl <- paste0(df.objects$site,'.',df.objects$numero) # lbl # df.objects$img <- gsub('%20',' ',df.objects$img) # remove %20 used by windows # df.objects <- df.objects[match(gs$lbl, df.objects$lbl),] # reorder on graphs # df.objects$idf.objects <- rownames(df.objects) <- 1:nrow(df.objects) # rename # return(df.objects) # } f.superfam.update <- function(superfam){ ## get the list with the 'superfamily' name and the subfamilies and update Pg 'objects' table ## superfam <- superf.all # TODO: get index instead of first [[1]] # select.superfamily superfam.nme <- superfam.all[[1]][[1]] families.nmes <- superfam.all[[1]][[2]] drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") for (a.family in families.nmes){ # i <- 1 sqll <- paste0("update objets set famille_super='",superfam.nme,"' where famille='",a.family,"'") # print(sqll) dbGetQuery(con,sqll) print(paste0("'famille_super' field of 'object' table is updated for '",a.family,"' family")) } dbDisconnect(con) # disconnect } # f.superfam.update("steles Bz du SO europeen") f.var <- function(tab.var){ # return a table with list of attributes, colors, etc. # ex: return 'mp' and 'mp_color' from "mp" Pg table drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") tab_var <- dbGetQuery(con,paste0("SELECT * FROM ",tab.var)) dbDisconnect(con) # disconnect return(tab_var) } objects.df <- function(gs){ # selections on table 'objects' # gs <- graphs ; gs <- graphs.objects # create list lobj.sit <- paste0("('",paste0(gs$site,collapse="','"),"')") lobj.num <- paste0("('",paste0(gs$numero,collapse="','"),"')") # the selection sqll.SELECT <- paste0("site,numero,self,type,famille as fam, mp,incomplet,", "tpq,taq,chr_1,tpq_cul,taq_cul,tp_taq_dat,", "long,larg,epai,", "ST_X(geom) as x,ST_Y(geom) as y, img") # condition & order sqll <- paste0("select ",sqll.SELECT," from objets WHERE site IN ", lobj.sit," AND numero IN ", lobj.num) drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") df.objects <- dbGetQuery(con,sqll);dbDisconnect(con) # take df.objects from 'objects' or 'family' and make some changes df.objects$lbl <- paste0(df.objects$site,'.',df.objects$numero) # lbl df.objects$img <- gsub('%20',' ',df.objects$img) # remove %20 used by windows # self df.objects$self.shp <- NA df.objects$self[is.na(df.objects$self)] <- "" df.objects$self.shp <- ifelse(df.objects$self == "",16, # circle ifelse(df.objects$self=='anthropomorphe',15, # square 16)) # incomplet df.objects$incomplet[is.na(df.objects$incomplet)] <- 0 # get graphs idf graphs.idf <- subset(gs,select=c("lbl","idf")) df.objects <- merge(df.objects,graphs.idf,by="lbl",all.x=T) # replace NA in idf by 999* for (i in 1:nrow(df.objects)){ start.idf.miss <- 9900 if(is.na(df.objects[i,"idf"])){ df.objects[i,"idf"] <- start.idf.miss start.idf.miss <- start.idf.miss+1 } } # reorder and rename df.objects <- df.objects[match(gs$lbl, df.objects$lbl),] # reorder on graphs # df.objects$idf <- rownames(df.objects) <- 1:nrow(df.objects) # rename #df.objects <- layout.df(df.objects,gs) return(df.objects) } family.df <- function(select.family){ # selections on table 'objects' # the selection drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") sqll.SELECT <- paste0("site,numero,self,type,mp,", "tpq,taq,chr_1,tpq_cul,taq_cul,tp_taq_dat,", "long,larg,epai,", "ST_X(geom) as x,ST_Y(geom) as y, img") # condition & order sqll <- paste0("select ",sqll.SELECT," from objets ", "WHERE famille like '",select.family, "' ORDER BY site,numero") df.family <- dbGetQuery(con,sqll) df.family$lbl <- paste0(df.family$site,'.',df.family$numero) # lbl df.family$img <- gsub('%20',' ',df.family$img) # remove %20 used by windows df.family$idf.objects <- rownames(df.family) <- 1:nrow(df.family) # rename ## aestethic # mp color df.mp <- dbGetQuery(con,"SELECT * FROM mp") # NA <- "black" by default # df.mp$mp_colors <- ifelse(is.na(df.mp$mp_colors),"black",df.mp$mp_colors) # merge df.family.merg <- merge(df.family,df.mp,by="mp",all.x=T) df.family.merg$mp[is.na(df.family.merg$mp)] <- 'unknown' df.family.merg$mp_colors[is.na(df.family.merg$mp_colors)] <- 'black' # reorder on site/decor df.family.merg <- df.family.merg[with(df.family.merg, order(site,numero)), ] #df.family <- layout.df(df.family,gs) dbDisconnect(con) return(df.family.merg) } #crp <- family.df(select.family) map.colors <- function(var,df){ # colors for 'mp','self',etc. for (r in 1:nrow(df)){ if (!is.na(df[,var])){ if(var == "mp"){ } } } } family.ico.df <- function(select.family){ sqll <- paste0( "SELECT table_noeuds.site,table_noeuds.decor,table_noeuds.structure,", "table_noeuds.id,table_noeuds.type,table_noeuds.technologie,objets.famille,objets.img,", "ST_X(objets.geom) as x, ST_Y(objets.geom) as y ", "FROM table_noeuds,objets WHERE table_noeuds.site=objets.site ", "AND table_noeuds.decor=objets.numero ", "AND objets.famille like '",select.family,"' ", "ORDER by site, decor;" ) drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") family.spat <- dbGetQuery(con,sqll) family.spat$lbl <- paste0(family.spat$site,'.',family.spat$decor,'.',family.spat$id) dbDisconnect(con) # disconnect return(family.spat) } ugs.select.df <- function(select.family,corpus){ # this is the generalisation of 'ugs_x_family.df' function # selection of ugs from selected objects or family # corpus <- "objects" ; select.family <- "stele alentejo" sqll.SELECT <- paste0( "SELECT table_noeuds.site,table_noeuds.decor,table_noeuds.structure,", "table_noeuds.id,table_noeuds.type,objets.famille,", "table_noeuds.long,table_noeuds.sens,objets.img,", "ST_X(table_noeuds.geom) as x_ug, ST_Y(table_noeuds.geom) as y_ug,", "ST_X(objets.geom) as x_obj, ST_Y(objets.geom) as y_obj ", "FROM table_noeuds,objets WHERE table_noeuds.site=objets.site ", "AND table_noeuds.decor=objets.numero ") if(corpus == 'family'){ sqll.SELECT <- paste0(sqll.SELECT,"AND objets.famille LIKE '",select.family,"' ") } if(corpus == 'objects'){ gs <- create.graph.view(v.select.obj,corpus) # call function to create view objets <- objects.df(gs) lobj.sit <- paste0("('",paste0(gs$site,collapse="','"),"')") lobj.num <- paste0("('",paste0(gs$numero,collapse="','"),"')") # sqll <- paste0("select ",sqll.SELECT," from objets WHERE site IN ", # lobj.sit," AND numero IN ", # lobj.num) sqll.SELECT <- paste0(sqll.SELECT,"AND objets.site IN ",lobj.sit, " AND objets.numero IN ",lobj.num) } # order, sqll.ORDER <- paste0(sqll.SELECT," ORDER by site,decor;") drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") ugs <- dbGetQuery(con,sqll.ORDER) dbDisconnect(con) # disconnect return(ugs) } ugs_x_family.df <- function(select.family){ # selection of ugs within a family sqll <- paste0( "SELECT table_noeuds.site,table_noeuds.decor,table_noeuds.structure,", "table_noeuds.id,table_noeuds.type,objets.famille,", "table_noeuds.long,table_noeuds.sens,objets.img,", "ST_X(table_noeuds.geom) as x_ug, ST_Y(table_noeuds.geom) as y_ug,", "ST_X(objets.geom) as x_obj, ST_Y(objets.geom) as y_obj ", "FROM table_noeuds,objets WHERE table_noeuds.site=objets.site ", "AND table_noeuds.decor=objets.numero ", "AND objets.famille LIKE '",select.family,"' ", "ORDER by site,decor;" ) drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") ugs <- dbGetQuery(con,sqll) dbDisconnect(con) # disconnect return(ugs) } ugs.df <- function(select.thm){ # select.thm <- "casque" sqll.ugs <- paste0("SELECT site,decor,famille,ST_X(geom) as x,ST_Y(geom) as y FROM objets WHERE famille like '",select.family,"' ORDER BY site,numero") drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") ugs.spat <- dbGetQuery(con,sqll.ugs) dbDisconnect(con) # disconnect return(family.spat) } f.chm.ug <- function(select.thms){ # create out folder for ug if not exist for (sel.thm in select.thms){ # sel.thm <- select.thm chm.ico.ug <- paste0(chm.ug.typo,sel.thm,"/") ifelse(!dir.exists(chm.ico.ug), dir.create(chm.ico.ug), FALSE) } } create.graph.view <- function(typ.select,typ.v){ ## create postgis view for of decors based on ## list of selected "objects" or "family" or "super.family" ## return a dataframe with idf of all decorations # typ.v <- "objects"; typ.v <- "family"; typ.select <- v.select.family # typ.select <- "ico_l_var_cs"; typ.v <- "objects" # typ.select <- "ico_l_miscellaneous" ; typ.v <- "objects" # typ.select <- v.select.family ; typ.v <- "family" # typ.select <- v.select ; typ.v <- "super.family" sll.DROP <- paste0("DROP VIEW IF EXISTS ",typ.select) sqll.ldec <-paste0( "CREATE OR REPLACE VIEW ",typ.select," AS SELECT objets.site,objets.structure, objets.numero,objets.type,objets.self,objets.tpq, objets.taq,objets.chr_1, objets.tpq_cul,objets.taq_cul,objets.geom,objets.img,objets.id,objets.famille as fam FROM objets ") sqll.order <- " ORDER BY objets.famille, objets.site,objets.numero;" # condition for SQL postgis sqll.condition <- "WHERE " # selected objects xor families xor super.familiers if (typ.v == "objects"){ for (a.dec in 2:length(ldecors)){ # avoid the title # a.dec <- 2 sit <- as.character(ldecors[[a.dec]][1]) num <- as.character(ldecors[[a.dec]][2]) print(paste(sit,num)) if (num == ''){ # all objects of this site sqll.condition <- paste0(sqll.condition,"objets.site LIKE '", sit,"' OR ") } if (num != ''){ sqll.condition <- paste0(sqll.condition,"(objets.site LIKE '",sit, "' AND objets.numero LIKE '",num,"') OR ") } } sqll.condition <- gsub('.{4}$', '', sqll.condition) # remove the 4 least characters (" OR ") } if (typ.v == "family"){ sqll.condition <- paste0(sqll.condition,"objets.famille LIKE '", select.family,"'") } if (typ.v == "super.family"){ # test if 'famille_super' Pg field has the same value sqll.condition <- paste0(sqll.condition,"objets.famille_super LIKE '", eval(parse(text = select.choice)),"'") } # conca sqll sqll.completed <- paste0(sqll.ldec,sqll.condition,sqll.order) # cat(sqll.completed,sep="\n") # connect drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") # drop view if exists dbGetQuery(con,sll.DROP) # create the Postgis view dbGetQuery(con,sqll.completed) # select from this view sqll <- paste0("select site,numero,self,fam from ",typ.select) # sqll <- paste0("select site,numero,self from ",typ.select) graphs <- dbGetQuery(con,sqll) graphs$idf <- 1:nrow(graphs) # idfs of graphs graphs$lbl <- paste0(graphs$site,'.',graphs$numero) dbDisconnect(con) # disconnect return(graphs) } f.df.ico <- function(v.select){ # read the posgres view # TODO: try to rm this unnecessary functio drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") # list ico sqll.ico <- paste0("SELECT site,structure,numero,img FROM ",v.select) df.icos <- dbGetQuery(con,sqll.ico);dbDisconnect(con) df.icos$img <- gsub('%20',' ',df.icos$img) # remove %20 used by windows df.icos$idf <- paste0(df.icos$site,'.',df.icos$numero) return(df.icos) } f.g.infos <- function(l.of.graph){ # get infos from graph # l.of.graph <- lgrph df.graph.infos <- data.frame(idf=numeric(0), site=character(0), decor=character(0), n.nodes=integer(0), n.edges=integer(0), diam=numeric(0), dens=numeric(0), n.comp=numeric(0), est.simp=character(0), stringsAsFactors = F) # plot number of components for (a.g in 1:length(l.of.graph)){ # a.g <- 1 ga <- l.of.graph[[a.g]] # id <- a.g site <- as.character(unique(V(ga)$site)) decor <- as.character(unique(V(ga)$decor)) idf <- as.character(unique(V(ga)$idf)) n.nodes <- gorder(ga) n.edges <- gsize(ga) # n.nodes <- as.integer(length(V(ga))) # n.edges <- as.integer(length(E(ga))) diam <- diameter(ga,directed=F,unconnected=F,weights=NULL) dens <- round(graph.density(ga),2) n.comp <- components(ga)$no est.simp <- as.integer(is.simple(ga)) new.g.infos <- c(idf,site,decor,n.nodes,n.edges,diam,dens,n.comp,est.simp) df.graph.infos[nrow(df.graph.infos)+1,] <- new.g.infos # df.graph.infos <- rbind(df.graph.infos, # c(id,site,decor,n.nodes,n.edges,n.comp)) } return(df.graph.infos) } load.graphs <- function(gs){ # load graphs from list of objects # return list of graphs and list of non graphs (none edges) # gs <- graphs lgrph <- lgrph.no <- list() # list of graphs and non graphs lgrph_nmes <- c() # list of graphs names num.indet <- 1 # to differentiate 'indet' nodes drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") print("* load graphs *") for (r in 1:nrow(gs)){ #r <- 3; gs <- graphs.objects #r <- 6; gs <- graphs.family # gs <- g # select nodes idf.g <- gs[r,"idf"] sit.g <- gs[r,"site"] numero.g <- gs[r,"numero"] print (paste0(" ",r,"-",sit.g," . ",numero.g)) # nodes - - - - sqll_a <- paste0("SELECT id as name,id as id, type,ST_X(geom) as x, ST_Y(geom) as y,", "site,decor from table_noeuds ") sqll_b <- paste0("WHERE site ='",sit.g,"' AND decor='",numero.g,"'") sqll_ab <- paste0(sqll_a,sqll_b) nodes <- dbGetQuery(con,sqll_ab) #print (sqll_ab) if (nrow(nodes)>0){ # only for graphs # nodes - - - - - # at least one node # add an incremented suffix to differentiate 'indet' nodes for (n in 1:nrow(nodes)){ typ.n <- nodes[n,"type"] if (typ.n == "indet"){ nodes[n,"type"] <- paste0(typ.n,num.indet) num.indet <- num.indet+1 } } # links - - - - sqll_c <- "SELECT a,b,typ,site,decor FROM table_liens " sqll_d <- paste0("WHERE site ='",sit.g,"' AND decor='",numero.g,"'") sqll_cd <- paste0(sqll_c,sqll_d) links <- dbGetQuery(con,sqll_cd) if (length(links)>0){ g <- graph_from_data_frame(links, directed=F, vertices=nodes) # name and attributes g$name <- paste0(sit.g,'.',numero.g) g$id.in.serie <- r # an absolute number in the serie, useful when sampling g <- set_edge_attr(g, "nd.a", index = E(g), links$a) g <- set_edge_attr(g, "nd.b", index = E(g), links$b) # index of _na ugs and remove NAs <- which(V(g)$type == "_na"); g <- g - NAs # remove _na ugs # TODO : traduire les types V(g)$name <- V(g)$type # remplace les numeros par leur types V(g)$idf <- idf.g # append to list lgrph[[length(lgrph)+1]] <- g # graph_from_data_frame(links, directed = F, vertices = NULL) } if (length(links)==0){ lgrph.no[[length(lgrph.no)+1]] <- paste0(sit.g,'.',numero.g) print(" NO EDGES") } } } dbDisconnect(con) l.out <- list(lgrph,lgrph.no) return(l.out) } rm.specific.nd <- function(l.of.graph,xthm){ # create new edges between nodes adjacent to specific nodes # before deleting specific nodes (ex. xthm="indet") # without deleting xthm when they are attributes # return a clean list of graphs #l.of.graph <- lgrph; xthm <- "indet" l.graph.out <- list() # output for (a.g in 1:length(l.of.graph)){ # a.g <- 1 # loop through graphs ga <- l.of.graph[[a.g]] # ex. 14 = Capilla 3 #plot(ga,main=ga$name) if (!any(str_detect(V(ga)$name,xthm))){ #if (!(xthm %in% V(ga)$name)){ # the specific thm is not in the graph, keep original graph print(paste0(a.g,'.',ga$name," | total number of nodes: ",length(V(ga)))) l.graph.out[[length(l.graph.out)+1]] <- ga } if (any(str_detect(V(ga)$name,xthm))){ #if (xthm %in% V(ga)$name){ # the specific thm is in the graph print(paste0(a.g,'.',ga$name," | total number of nodes: ",length(V(ga)))) print(' - there is nodes to merge') # put vertices names to new column to avoid error on duplicated rownames ga <- set.vertex.attribute(ga, "type", value=V(ga)$name) V(ga)$name <- 1:length(V(ga)) # rename vertices ids.n <- igraph::as_data_frame(ga, what="vertices") a.sit <- unique(ids.n$site);a.dec <- unique(ids.n$decor) ids.n$idx.in.graph <- 1:nrow(ids.n) # ids from graph names(ids.n)[names(ids.n)=="id"] <- "idx.in.sig" ids.n.sub <- subset(ids.n, select=c("idx.in.graph","idx.in.sig","type")) idxs <- which(str_detect(ids.n.sub$type,xthm)) # get indexes when match for (idx in idxs){ # replace 'indetx' by 'indet' ids.n.sub[idx,"type"] <- 'indet' } l.n.xthm <- as.character(ids.n.sub[ids.n.sub$type == xthm,]$idx.in.graph) # get number in graph # plot(ga) for (n.xthm in l.n.xthm){ #n.xthm <- "18" adj.edges <- E(ga)[from(n.xthm)] a.adj.edge <- as_ids(adj.edges) #a.adj.edge <- paste0(as_ids(adj.edges),collapse = "|") # a string a.adj.edge <- strsplit(a.adj.edge, "\\|") # split a.adj.edge <- a.adj.edge[[1]] # split # check if the specific xthm is an attribute ('+') edg.id <- get.edge.ids(ga, c(a.adj.edge[1],a.adj.edge[2])) xthm.is.attr <- edge.attributes(ga,edg.id)$typ == '+' # test if attribute, can be NA # if result of test is NA, then F ifelse(is.na(xthm.is.attr), xthm.is.attr <- F, xthm.is.attr <- T) if (!xthm.is.attr){ # remove the xthm node from the edge list if not attribute a.adj.edge <- a.adj.edge[!a.adj.edge == n.xthm] if (length(a.adj.edge)==1){ # only one adjacent edge to specific thm df.adj.edge <- as.matrix(data.frame(a=c(a.adj.edge),b=c(n.xthm))) } if (length(a.adj.edge)>1){ # more than one adjacent edge to specific thm df.adj.edge <- t(combn(a.adj.edge, 2)) # all pairwise edges } # add edges with attributes for (e in 1:nrow(df.adj.edge)){ #e <- 1 a <- df.adj.edge[e,1];b <- df.adj.edge[e,2] if (!are.connected(ga, a, b)){ # add new edge with attributes when no connections ga <- add_edges(ga,c(a,b), attr=list(typ=NA, site=a.sit, decor=a.dec)) } } # remove the selected n.xthm node print (paste0(" - remove node: ",n.xthm)) ga <- delete.vertices(ga,n.xthm) } } #is.simple(ga.n); ga.n <- simplify(ga.n) # avoid multiedges # rehab ancient names V(ga)$name <- get.vertex.attribute(ga, "type", index=V(ga)) print(paste0(" = the new total number of nodes is: ",length(V(ga)))) # strore clean graph l.graph.out[[length(l.graph.out)+1]] <- ga } } return(l.graph.out) } df.nodes.are.attributs <- function(grph){ # create a df of all nodes which are nodes atributes # ex: 1 -+- 2, node 2 is recorded # grph <- graphs ; grph <- graphs.family lgrph <- load.graphs(grph)[[1]] df.nd.attributs <- data.frame("site"=character(), "decor"=character(), "nd.b"=character(), "to"=character(),stringsAsFactors=FALSE) for (i in 1:length(lgrph)){ g <- lgrph[[i]] df <- igraph::as_data_frame(g, what="edges") df <- subset(df, typ == '+') # attributes are always 'b' nodes df <- subset(df, select=c("site","decor","nd.b","to")) df.nd.attributs <- rbind(df.nd.attributs,df) } df.nd.attributs$lbl <- paste0(df.nd.attributs$site,'.',df.nd.attributs$decor,'.',df.nd.attributs$nd.b) return(df.nd.attributs) } rm.by.edge.type <- function(g,edge.type){ # remove nodes from graph depending on edge types (ex: '+') # return a graph # g <- lgrph[[4]] ; edge.type <- '+' # plot(g) a.df <- igraph::as_data_frame(g, what="edges") a.df <- a.df[a.df$typ == edge.type,] # select edges by type a.df <- a.df[!is.na(a.df$from),] #as.numeric(row.names(a.df)) # these edges are attributes # delete edges g1 <- delete.edges(g, as.numeric(row.names(a.df))) v.ids <- V(g1)$id # remove attributes nodes attribute.node <- unique(a.df$nd.b) nd.to.rm <- match(attribute.node,v.ids) #g2 <- delete.vertices(g1, 9) g2 <- delete.vertices(g1, nd.to.rm) # plot(g) # # remove isolated new nodes # isolated = which(degree(g)==0) # g <- delete.vertices(g, isolated) return(g2) } ug.select.obj <- function(gs){ # select ug which are in the list of graphs 'graphs' # gs <- objets lugs.sit <- paste0("('",paste0(gs$site,collapse="','"),"')") lugs.num <- paste0("('",paste0(gs$numero,collapse="','"),"')") # the selection sqll.temp.ugs <- paste0("site,decor,id,type,", "long,long_cm,larg,larg_cm,dim_is_abs,incomplet,", "tpq,taq,chr_1,tpq_cul,taq_cul,tp_taq_dat,", "ST_X(geom) as x_ug, ST_Y(geom) as y_ug") sqll.ugs <- paste0("select ",sqll.temp.ugs," from table_noeuds WHERE site IN ", lugs.sit," AND decor IN ", lugs.num) drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") df.ugs <- dbGetQuery(con,sqll.ugs);dbDisconnect(con) # na <- 'xxx' my.cols <- c("chr_1","tpq_cul","taq_cul") df.ugs[,my.cols][is.na(df.ugs[,my.cols])] <- 'xxx' # na <- '0' my.cols <- c("incomplet") df.ugs[,my.cols][is.na(df.ugs[,my.cols])] <- 0 return(df.ugs) } f.ugs.incomplete <- function(lgrph, compl.threshold, contactsheet, n.col){ # return a vector with indices of too incomplete decorations # 'compl.threshold' is the threshold in % for sampling most complete decoration # 'contactsheet' if TRUE create a contactsheet of pie charts counting (in)complete ugs by decoration # 'n.col' is the nb of columns alpha.val <- 0.3 lugs.compl <- list() # list for pie charts lugs.incompl <- c() # for indexes of incomplete for (i in 1:length(lgrph)){ # i <- 1 g <- lgrph[[i]] list.vertex.attributes(g) a.site <- unique(get.vertex.attribute(g, "site", index=V(g))) a.dec <- unique(get.vertex.attribute(g, "decor", index=V(g))) print(paste0(i," *read ", a.site," . ", a.dec)) a.decoration <- nodes.df(a.site,a.dec) a.decoration.compl <- as.data.frame(table(a.decoration$incomplet)) # get the count ct.complete <- a.decoration.compl[a.decoration.compl$Var1 == 0,"Freq"] ct.incomplete <- a.decoration.compl[a.decoration.compl$Var1 == 1,"Freq"] alpha.threshold <- 1 # by default # test completness of ugs if (length(ct.incomplete) > 0){ # get if value exist if(ct.incomplete > 0){ # get when exist incomplete if(length(ct.complete) > 0){ # get when exist incomplete compl.vs.incompl <- ct.complete/(ct.complete+ct.incomplete) alpha.threshold <- ifelse(compl.vs.incompl >= compl.threshold, 1, alpha.val) } if(length(ct.complete) == 0){ # there's no complete -> alpha alpha.threshold <- alpha.val } } } # if incompletness, add to bad list if (alpha.threshold != 1){lugs.incompl <- c(lugs.incompl,i)} if(contactsheet){ # create a contactsheet tit <- paste0(a.site,"\n",a.dec) a.gg <- ggplot(data = a.decoration.compl, aes(x = "", y = Freq, fill = Var1)) + ggtitle(tit)+ geom_bar(stat = "identity", alpha = alpha.threshold) + # alpha=) + geom_text(aes(label = Freq), color="black", position = position_stack(vjust = 0.5), cex=3, alpha = alpha.threshold+0.2) + coord_polar(theta = "y") + blank_theme + theme(plot.title = element_text(size = 7), legend.position = "none", axis.text.x=element_blank())+ scale_fill_manual(values=c("skyblue","orangered")) lugs.compl[[length(lugs.compl)+1]] <- a.gg } } if(contactsheet){ g.out <- paste0(chm.analysis.n.compl,"ug_complete.png") a.tit <- paste0("counts of complete (blue) and incomplete (red) ugs by decoration", "\nshaded decoration are those which have a percent of incomplete ugs", "below the threshold (",compl.threshold*100," %)") ggsave(file = g.out, arrangeGrob(grobs = lugs.compl, ncol = n.col, top = grid::textGrob(a.tit,x=0,hjust=0,gp = gpar(fontsize =9))), width = n.col*2, height = ceiling(length(lugs.compl)/n.col)*2) } # shell.exec(g.out) return(lugs.incompl) } f.thm.orient.select <- function(select.obj){ # select themes in a list depending on a subgroup # for orientations for (i in 1:length(thm.orient.select.all)){ #i <- 1 if (thm.orient.select.all[[i]][[1]] == select.obj){ return(thm.orient.select.all[[i]][[2]]) } } } nodes.df <- function(sit.1,num.1){ # get nodes data sqll.temp.nds <- paste0("site,decor,id,type,sens,technologie,", "long,long_cm,larg,larg_cm,incomplet,", "chr_1,tpq,taq,", "ST_X(geom) as x,ST_Y(geom) as y") # the selection sqll.nodes <- paste0("select ",sqll.temp.nds," from table_noeuds WHERE site LIKE '", sit.1,"' AND decor LIKE '", num.1,"'") drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") df.nodes <- dbGetQuery(con,sqll.nodes);dbDisconnect(con) # to merge raster and nodes, modify origin of nodes df.nodes$y <- offset.img+df.nodes$y # add the offset return(df.nodes) } edges.coordinates <- function(sit.1,num.1){ # get edges coordinates of a decoration drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") # extract coordinates of edges points(start and end) sqll.temp.edg <- "site,decor,a,b,typ,ST_X(ST_StartPoint(geom)) as xa, ST_Y(ST_StartPoint(geom)) as ya,ST_X(ST_EndPoint(geom)) as xb, ST_Y(ST_EndPoint(geom)) as yb" sqll.edges <- paste0("select ",sqll.temp.edg," from table_liens WHERE site LIKE '", sit.1,"' AND decor LIKE '", num.1,"'") df.edges <- dbGetQuery(con,sqll.edges);dbDisconnect(con) return(df.edges) } f.list.edges.type <- function(nd.a, nd.b){ # return df with edges listed and types of nodes # could take a very long time... # df.x_x <- f.list.edges.type("arc","fleche") drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") tab_var <- dbGetQuery(con,paste0("SELECT * FROM table_liens_type_a_b")) dbDisconnect(con) # disconnect # whether a-b or b-a df.epee_ceinture <- tab_var[tab_var$type_a==nd.a & tab_var$type_b==nd.b,] df.ceinture_epee <- tab_var[tab_var$type_a==nd.b & tab_var$type_b==nd.a,] df.x_x <- rbind(df.epee_ceinture,df.ceinture_epee) df.x_x <- df.x_x[order(df.x_x$site,df.x_x$numero),] return(df.x_x) } edges.df <- function(n,dec,sit.1,num.1){ # sit.1 <- num.1 <- "Alamillo"; n <- dec <- 1 # sit.1 <- "Capilla"; num.1 <- "Capilla 8"; n <- dec <- 1 # n,dec,sit.1,num.1 # con <- dbConnect(drv, # dbname="mailhac_9", # host="localhost", # port=5432, # user="postgres", # password="postgres") # # extract coordinates of edges points(start and end) # sqll.temp.edg <- "site,decor,a,b,typ,ST_X(ST_StartPoint(geom)) as xa, ST_Y(ST_StartPoint(geom)) as ya,ST_X(ST_EndPoint(geom)) as xb, ST_Y(ST_EndPoint(geom)) as yb" # sqll.edges <- paste0("select ",sqll.temp.edg," from table_liens WHERE site LIKE '", # sit.1,"' AND decor LIKE '", # num.1,"'") # df.edges <- dbGetQuery(con,sqll.edges);dbDisconnect(con) # to merge raster and nodes, modify origin of edges df.edges <- edges.coordinates(sit.1,num.1) df.edges$ya <- offset.img+df.edges$ya # add the offset df.edges$yb <- offset.img+df.edges$yb # add the offset # get the relations df.edges$relAB <- df.edges$relBA <- NA for (edg in 1:nrow(df.edges)){ drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") typo.rel <- df.edges[edg,"typ"] # relation type: normal(NA), attribute(+), etc. if(is.na(typo.rel)){typo.rel<-'='} # type of first node sqll.typ.a <- paste0("select type from table_noeuds WHERE site LIKE '", sit.1,"' AND decor LIKE '",num.1,"' AND id=",df.edges[edg,"a"]) typ.a <- dbGetQuery(con,sqll.typ.a)[1,1] # type of second node sqll.typ.b <- paste0("select type from table_noeuds WHERE site LIKE '", sit.1,"' AND decor LIKE '",num.1,"' AND id=",df.edges[edg,"b"]) typ.b <- dbGetQuery(con,sqll.typ.b)[1,1] dbDisconnect(con) # disconnect # undirected, choice 'or' for comparisons df.edges[edg,"relAB"] <- paste0(typ.a,typo.rel,typ.b) # ex. nez=epee df.edges[edg,"relBA"] <- paste0(typ.b,typo.rel,typ.a) # ex. epee=nez } tot.edges <- f.tot.edges(lgrph) used.LETTERS <- new.col.nmes[1:length(tot.edges)] # only used letters df.edges$rel <- NA df.edges$typ <- NULL # loop through 'used.LETTERS' and add the corresponding letter # in the edges dataframe # edges with NA have already been suppressed for (typ.rel in used.LETTERS){ letter.rel <- tot.edges[match(typ.rel,new.col.nmes)] for (edg in 1:nrow(df.edges)){ if (df.edges[edg,"relAB"] == letter.rel | df.edges[edg,"relBA"] == letter.rel){ df.edges[edg,"rel"] <- used.LETTERS[match(typ.rel,new.col.nmes)] } } } df.edges$relAB <- df.edges$relBA <- NULL #if(is.na(df.edges)){typo.rel<-'='} df.edges.comp <- df.edges[complete.cases(df.edges), ] # remove NA df.edges.comp$image.dec <- image.dec # add image path return(df.edges.comp) } # edges f.tot.edges <- function(lgrph){ # return all edges as a vector character # lgrph <- load.graphs(graphs)[[1]] # load graphs # lgrph <- lgraphs tot.edges <- data.frame("V1"=character(), "V2"=character(), "typ"=character(),stringsAsFactors=FALSE) # all unique type of edges for(i in 1:length(lgrph)){ a.g <- lgrph[[i]] #print(paste0(i,".",a.g$name)) g.edg <- as.data.frame(as_edgelist(a.g)) # edges g.edg$typ <- edge.attributes(a.g)$typ # typ of edges g.edg$typ[is.na(g.edg$typ)] <- "=" # change NA to = # if (rm.attributes){ # g.edg <- g.edg[g.edg$typ != "+",] # } tot.edges <- rbind(tot.edges,g.edg) } #tot.edges$typ[is.na(tot.edges$typ)] <- "=" # change NA to = # opt suppress duplicated tot.edges <- tot.edges[!duplicated(t(apply(tot.edges[c("V1", "V2","typ")], 1, sort))), ] tot.edges <- paste0(tot.edges[,1],tot.edges[,"typ"],tot.edges[,2]) # like "nez=vide" return(tot.edges) } #ledges <- f.tot.edges() f.typ.edges <- function(sel.edges,lgrph){ # presence/absence type of edge, to dataframe df.typ_edges <- as.data.frame(matrix(nrow = length(lgrph), ncol = length(sel.edges))) # rename col and row rownames(df.typ_edges) <- 1:length(lgrph) colnames(df.typ_edges) <- sel.edges df.typ_edges[is.na(df.typ_edges)] <- 0 # default empty cells for (i in 1:length(lgrph)){ # graph have same idf in the list and in dataframes #print(i) #mat <- as_edgelist(lgrph[[i]]) mat <- as.data.frame(as_edgelist(lgrph[[i]])) # edges mat$typ <- edge.attributes(lgrph[[i]])$typ # typ of edges mat$typ[is.na(mat$typ)] <- "=" # change NA to = for (j in 1:nrow(mat)){ #j <- 1 AB <- paste0(mat[j,1],mat[j,"typ"],mat[j,2]) BA <- paste0(mat[j,2],mat[j,"typ"],mat[j,1]) # undirected graphs # fill with "nez=vide" or "vide=nez" if (AB %in% colnames(df.typ_edges)){ df.typ_edges[i,AB] <- df.typ_edges[i,AB]+1 # add +1 } if (BA %in% colnames(df.typ_edges)){ df.typ_edges[i,BA] <- df.typ_edges[i,BA]+1 # add +1 } } } return(df.typ_edges) } f.sel.edges <- function(lgrph,rm.att){ # fill a new vector of edges without certain types (ex: +,..) # rm.att <- c("+") ; rm.att <- c("") tot.edges <- f.tot.edges(lgrph) # load all edges sel.edges <- c() if(length(rm.att)>0){ for (a.edg in tot.edges){ # loop through edges for(att.to.rm in rm.att){ # loop through attributes to rm if (att.to.rm == "+"){rm.regex <- grepl("\\+",a.edg)} if (att.to.rm == ">"){rm.regex <- grepl(att.to.rm,a.edg)} # if the edge has not a value to rm, add to 'sel.edges' if(!rm.regex){sel.edges <- c(sel.edges,a.edg)} } } } if(length(rm.att)==0){sel.edges <- tot.edges} return(sel.edges) } f.same.edges <- function(lgrph,rm.att){ # find same edges within a pairwise comparison of graphs # get same edges, remove attributes (+, >, etc.) if needed # output a square matrix # rm.att: when empty, no remove # lgrph <- load.graphs(graphs.objects) ; rm.att <- c("") mat.same_edges <- matrix(nrow = length(lgrph), ncol = length(lgrph)) mat.same_edges <- as.data.frame(mat.same_edges) colnames(mat.same_edges)<- 1:ncol(mat.same_edges) mat.same_edges[is.na(mat.same_edges)] <- 0 # replace NA lgrph_nmes <- c() for (i in 1:length(lgrph)){ lgrph_nmes <- c(lgrph_nmes,lgrph[[i]]$name) #print (lgrph[[i]]$name) } # remove attributes (+, >, etc.) if 'rm.att' has values ifelse (rm.att != "", sel.edges <- f.sel.edges(lgrph,rm.att), # a selection sel.edges <- f.tot.edges(lgrph) # no selection ) # identify same edges btw graphs df.typ_edges <- f.typ.edges(sel.edges,lgrph) # at least a common edge appears 2 times, limit the df df.typ_edges.sub <- df.typ_edges[,colSums(df.typ_edges) > 1] for (c in 1:ncol(df.typ_edges.sub)){ #c <- 2 a.col <- df.typ_edges.sub[,c] # get column # at least 2 decoration without 0 if(length(a.col[!a.col %in% 0]) > 1){ idxs <- which(a.col %in% c(1:100)) # count of egal betw 1 and Inf all.comb <- subset(expand.grid(rep(list(idxs),2)), Var1 != Var2) for (r in 1:nrow(all.comb)){ #r <- 1 x <- all.comb[r,"Var1"];y <- all.comb[r,"Var2"] mat.same_edges[x,y] <- mat.same_edges[x,y]+1 mat.same_edges[y,x] <- mat.same_edges[y,x]+1 } } } # divide all cells by 2 (sic) mat.same_edges[] <- lapply(mat.same_edges, function(x) x/2) colnames(mat.same_edges) <- row.names(mat.same_edges) <- lgrph_nmes return(mat.same_edges) } f.edge.similarity <- function(df.same_edges,around){ # calculate the similarity as the product of nb # of common edges divided by total number of edges # m.cor <- data.frame(nrow = 1:nrow(df.same_edges), # ncol = 1:nrow(df.same_edges)) m.cor <- data.frame(matrix(ncol = nrow(df.same_edges), nrow = nrow(df.same_edges)) ) colnames(m.cor) <- 1:nrow(df.same_edges) n.links <- c() for (i in 1:length(lgrph)){ n.links <- c(n.links,gsize(lgrph[[i]])) } for (r in 1:nrow(df.same_edges)){ for (c in 1:ncol(df.same_edges)){ if (around){ # for heatmap ploting m.cor[r,c] <- round(df.same_edges[r,c]/n.links[r],1) } if (!around){ # for dendrogram m.cor[r,c] <- df.same_edges[r,c] } } } return(m.cor) } # return a dist matrix from same edges correlation f.edge.dist <- function(df.edg.cor,grphs){ # populate lower triangle df.edg.cor[lower.tri(df.edg.cor)] <- t(df.edg.cor)[lower.tri(df.edg.cor)] lbls <- paste0(rownames(grphs),'.',grphs$site,'.',grphs$numero) row.names(df.edg.cor) <- colnames(df.edg.cor) <- lbls # get the exact name # a.list.dec <- colnames(df.edg.cor) # dendrog dist.mat <- dist(df.edg.cor) return(dist.mat) } f.dist.df <- function(lgrph){ # calculate distances btw nodes for each graphs dist.df <- data.frame(Var1=character(0), Var2=character(0), value=character(0), dec=character(0)) # length(lgrph) for (i in 1:length(lgrph)){ # i <- 3 g <- lgrph[[i]] print(paste0(i,") read distance for graph ",g$name)) g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>') if(gsize(g) == 0){next} # shorter paths if (gsize(g) > 0){ # there a connexion at least distmatrix <- shortest.paths(g, v=V(g), to=V(g)) distmatrix.melt <- reshape2::melt(distmatrix) distmatrix.melt <- distmatrix.melt[distmatrix.melt$value != 0,] # remove selfes distmatrix.melt$dec <- row.names(graphs[graphs$lbl==g$name,]) dist.df <- rbind(dist.df,distmatrix.melt) } } dist.df <- dist.df[dist.df$value != Inf,] # color nodes after dendrogramm if (flag.dendro.color){ # merge on dendrogramm colors df.colors <- subset(df.dist.mat.sel.ord,select=c("idf","color")) dist.df <- merge(dist.df,df.colors,by.x="dec",by.y="idf") } if (!flag.dendro.color){dist.df$color <- "black"} return(dist.df) } # spatial functions - - -- - - - - - f.spat.bck.grd <- function(spat.bck.grd){ #spat.bck.grd <- "Europe" # get background information for (i in 1:length(lspat.bck.grd)){ # test #i <- 2 a.match <- match(spat.bck.grd,lspat.bck.grd[[i]][1]) if (!is.na(a.match)){ chm.spat.bck <- unlist(lspat.bck.grd[[i]][2]) shp.spat.bck <- unlist(lspat.bck.grd[[i]][3]) #print(paste0("* read geometry '",shp.spat.bck,"' as geographical background *")) sf.fd.carto <- st_read(dsn = chm.spat.bck, layer = shp.spat.bck) # read geo background return(sf.fd.carto) } } } f.split.df <- function(sf.obj.tab,max.lign,sz.police){ # split a df depending on 'max.lign' # max.lign <- 42 ; sf.obj.tab <- df.clss.spat ; sz.police <- 7 n.obj <- nrow(sf.obj.tab) n.col.tab <- ceiling(n.obj/(max.lign+1)) # max.lign+1 because of iteration ltab <- list() mytheme.listing <- ttheme_default(base_size = sz.police, padding = unit(c(2,2), "mm")) if(n.col.tab > 1){ strt <- 1 for (i in 1:n.col.tab){ end<-strt+max.lign print(paste0(strt,' ',end)) sub.obj <- sf.obj.tab[c(strt:end),] # select rows ltab[[length(ltab)+1]] <- tableGrob(sub.obj,theme=mytheme.listing,rows=NULL) strt<-end+1 } } # tgrob <- tableGrob(df.tab.c, # theme = ttheme_default(base_size = 8, # padding = unit(c(2,2), "mm")), # cols = NULL,rows=F) if(n.col.tab == 1){ ltab[[length(ltab)+1]] <- tableGrob(sf.obj.tab,theme=mytheme.listing,rows=NULL) } return(ltab) } f.xy.to.sp <- function(xy, ID=NULL) { # creating a SpatialPolygons object from data.frame of coords if(is.null(ID)) ID <- sample(1e12, size=1) SpatialPolygons(list(Polygons(list(Polygon(xy)), ID=ID)), # proj4string=CRS("+proj=merc")) proj4string=CRS(wgs84)) } f.spat.distrib <- function(obj,sf.fd.carto,map.type,map.name,v,n.rows,sz.police){ # YYY # 'obj' is a dataframe with x and y columns # 'bck.grd' is a sf background from the 'f.spat.bck.grd' function # 'map.type' the type of map (ex: "family","archeo","ugs") # 'map.name' the name of the map (ex: "stele alentejo") # colored bt 'famille' # export a map # - - - - - - - - - - - - - - # obj <- family.spat ; map.type <- "family" ; map.name <- "stele bouclier" # obj <- ugs.spat ; map.type <-"ugs" ; map.name <-"casque" # obj <- family.spat ; map.type <-"family" ; select.family <-"Aclasser" ; v <- "all" # obj <- family.spat ; map.name <- "stele bouclier" ; v <- "all" # obj <- family.spat ; map.name <- "stele bouclier" ; map.type <- "map.type" ; v <- "type" # obj <- df.clss.spat ; map.name <- "super.family" ; map.type <- "super.family" ; v <- "clss" #no.family <- "zz_nofamily" # make some changes for archeo obj # create field when not exists fam <- c("famille" = select.family) # famille obj <- add_column(obj, !!!fam[setdiff("famille", names(obj))]) nbr <- c("Freq" = 1) # famille obj <- add_column(obj, !!!nbr[setdiff("Freq", names(obj))]) names(obj)[names(obj) == 'numero'] <- "decor" # replace colname # modify output folder depending type of carto #ifelse(map.type=="family", chm.loc.spatial <- chm.family, chm.loc.spatial <- chm.thm) n.obj <- nrow(obj) tit <- paste0("Distribution of all '",map.type,"' like '",map.name,"' (n=",n.obj,")") #tit <- paste0("Distribution of all objects from '",map.name,"' ",map.type," (n=",n.obj,")") sp.obj <- SpatialPointsDataFrame(coords = obj[,c("x","y")], data = obj, proj4string= CRS(wgs84)) sf.obj <- st_as_sf(sp.obj) roi <- st_bbox(sf.obj) # create polygon from bbox on objets # add margins roi[1]<-roi[1]-spat.marg;roi[2]<-roi[2]-spat.marg;roi[3]<-roi[3]+spat.marg;roi[4]<-roi[4]+spat.marg roi.sf <- st_as_sfc(roi) # create polygon from bbox on objets # sf.fd.carto <- st_read(dsn = chm.spat.admin, layer = "Europe_2012") # read geo background sf.fd.carto.inter <- st_intersection(sf.fd.carto, roi.sf) # recut background #sf.fd.carto <- data.frame(sf.fd.carto) # spatial - - - - - - - - #objets.selected <- objets[objets$idf %in% grp.num.decs,] #objets.selected.tab <- subset(objets.selected,select=c('idf','site','numero')) g.map <- ggplot2::ggplot(sf.fd.carto.inter) + geom_sf(aes(geometry = geometry),fill = NA)+ annotation_scale(location = "bl", height = unit(0.15,"cm"), width_hint = 0.2)+ #geom_point(data=objets, aes(x=x,y=y),cex=1)+ theme_bw() + theme(axis.text = element_blank())+ #theme(plot.title = element_text(size = 7))+ theme(axis.ticks=element_blank())+ theme(panel.border=element_blank())+ theme(panel.grid = element_blank())+ theme(axis.title = element_blank()) if(v=="all"){ # TODO: adapt legend g.map <- g.map + geom_point(data=obj, aes(x=x,y=y,fill=famille,color='black',cex=Freq*.5), alpha = .50, shape = 21) + # geom_point(data=obj, aes(x=x,y=y,color=famille,cex=(Freq/3)+1.5))+ geom_text_repel(data=obj, aes(x=x,y=y,label=idf),color='black',size=2.5, segment.alpha = 0.5,segment.size = 0.3) + # legend scale_size_continuous(breaks=sort(unique(obj$Freq)))+ #scale_size_continuous(breaks=c(0,1,2,3,4,5,10,25,50,100,500))+ theme(legend.title = element_text(size = 10), legend.text = element_text(size = 8))+ labs(size = "nb")+ # change order guides(color = guide_legend(order = 1), size = guide_legend(order = 2)) + theme(legend.position = "none") # no legend } if(v=="mp"){ g.map <- g.map + geom_point(data=obj, aes(x=x,y=y,color=mp),cex=1.5) + # scale_color_identity() + # scale_fill_identity() geom_text_repel(data=obj, aes(x=x,y=y,label=idf,color=mp),size=2.5, segment.alpha = 0.5,segment.size = 0.3) + scale_colour_manual(values=mp.colors) # g.map <- g.map + # geom_point(data=obj, aes(x=x,y=y,color=mp_colors),cex=1.5)+ # geom_text_repel(data=obj, aes(x=x,y=y,label=idf,color=mp_colors),size=2.5, # segment.alpha = 0.5,segment.size = 0.3)+ # scale_color_identity()+ # scale_fill_identity() } if(v=="type"){ g.map <- g.map + geom_point(data=obj, aes(x=x,y=y),cex=1.5)+ geom_text_repel(data=obj, aes(x=x,y=y,label=idf),size=2.5, segment.alpha = 0.5,segment.size = 0.3) # scale_color_identity()+ # scale_fill_identity() } if(v=="clss"){ # on dendrogram classifications g.map <- g.map + geom_point(data=obj, aes(x=x,y=y,color=color),cex=1.5)+ geom_text_repel(data=obj, aes(x=x,y=y,label=idf,color=color),size=2.5, segment.alpha = 0.5,segment.size = 0.3)+ scale_color_identity()+ scale_fill_identity() } margin = theme(plot.margin = unit(c(0,0,0,0), "cm")) # the tab of correspondances - - - - - - - - - - - - if (map.type != 'super.family'){ select.fields.df <- c('idf','site','decor') obj <- subset(obj,select=select.fields.df) } if (map.type == 'super.family'){ select.fields.df <- c('idf','site','decor','fam') obj <- subset(obj,select=select.fields.df) names(obj)[names(obj) == 'fam'] <- "famille" } ltab <- f.split.df(obj,n.rows,sz.police) # idf is necessary n.col <- length(ltab) corres.tab <- gridExtra::grid.arrange(grobs = ltab, ncol = n.col) g.map <- list(g.map+margin,corres.tab) return(g.map) } # g.map <- f.spat.distrib(family.ico.ct,sf.fd.carto,map.type,select.family,m.var) # create map # layout functions - - - - - - f.corresp.tab <- function(obj,max.lign){ # TODO: reduce margins # split the df to plot long df # obj <- ico.listing.var ; n.max.h <- 25 # obj <- df.g.infos ; max.lign <- 50 mytheme <- ttheme_default( base_size = 7, plot.margin = unit(c(0,0,0,0), "cm"), core = list(padding=unit(c(1, 1), "mm")) ) #margin = theme(plot.margin = unit(c(0,0,0,0), "cm")) # the tab of correspondances #sf.obj.tab <- subset(obj,select=c('site','decor')) n.obj <- nrow(obj) n.col.tab <- ceiling(n.obj/max.lign) ltab <- list() if(n.col.tab > 1){ # split into col strt <- 1 for (i in 1:n.col.tab){ end <- strt+max.lign print(paste0(strt,' ',end)) sub.obj <- obj[c(strt:end),] # select rows sub.obj.na <- sub.obj[complete.cases(sub.obj[ ,3:6]),] # remove NA row if any ltab[[length(ltab)+1]] <- tableGrob(sub.obj,rows=NULL) # break if NA (= all done) if(nrow(sub.obj)>nrow(sub.obj.na)){break} strt<-end+1 } } if(n.col.tab == 1){ # same as original ltab[[length(ltab)+1]] <- tableGrob(obj,theme = mytheme,rows=NULL) } # margin = theme(plot.margin = unit(c(0,0,0,0), "cm")) corres.tab <- gridExtra::grid.arrange(grobs = ltab, ncol= length(ltab)) #corres.tab <- gridExtra::grid.arrange(grobs = lapply(ltab, "+", margin)) return(corres.tab) } # adjust size of listing png depending on max fpng.df <- function(df,nme){ #df <- df.g.infos #nme.p <- paste0(chm.etude,"2-listing_variables.png") conc.colnmes <- paste0(colnames(df),collapse = "") conc.rows <- apply(df[ ,colnames(df) ],1,paste,collapse = "") w.max <- max(nchar(conc.rows),nchar(conc.colnmes)) #paste0(as.character(ico.listing[1,]),collapse = '') width.n <- w.max*35 #width.n <- max(nchar(paste0(df$idf,df$var)))*20 height.n <- nrow(df)*60 png(nme,res=150,width=width.n,height =height.n) } # # extract legend of ggplot # g_legend<-function(a.gplot){ # tmp <- ggplot_gtable(ggplot_build(a.gplot)) # leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box") # legend <- tmp$grobs[[leg]] # legend # } ggsave_to_variable <- function(p,width,height,dpi){ # save ggplot as image-magick # ggsave_to_variable <- function(p, width = 10, height = 10, dpi = 300){ # z.image,siz.of.img+1,siz.of.img,300 # pixel_width = (width * dpi) / 2.54 # pixel_height = (height * dpi) / 2.54 # img <- magick::image_graph(pixel_width, pixel_height, res = dpi) # width <- img.a.w ; height <- img.a.h ; dpi <- 300 ; p <- a.image.graph.a img <- magick::image_graph(width, height, res = dpi) on.exit(utils::capture.output({ grDevices::dev.off()})) plot(p) return(img) } fdat.columned <- function(df,n_col){ # df <- df.table # n_col <- 2 # met un dataframe en colonnes (largeur) # n_col: nb de colonnes voulues # n_col <- 6 nenr_ <- ceiling(nrow(df)/n_col) nrow_ <- as.integer(nenr_) sit.df.plot <- data.frame(matrix(0, ncol = 1, nrow = nrow_)) n <- 0 for (i in seq(1,n_col)){ sup_ <- nrow_ + n inf_ <- sup_-nrow_+1 ct <- i+1 idfs <- df[c(seq(inf_,sup_)),"idf"] sites <- df[c(seq(inf_,sup_)),"numero"] sit.df.plot <- cbind(sit.df.plot,idfs) sit.df.plot <- cbind(sit.df.plot,sites) n <- n+nrow_ } sit.df.plot[,1] <- NULL return(sit.df.plot) } g_legend<-function(a.gplot){ #extract legend tmp <- ggplot_gtable(ggplot_build(a.gplot)) leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box") legend <- tmp$grobs[[leg]] return(legend) } t_reduce_col<-function(df){ # rename columns colnames(df)[which(names(df)=="boucles_oreilles")] <- 'b_oreil' colnames(df)[which(names(df)=="cardiophylax")] <- 'cardioph' colnames(df)[which(names(df)=="casque_cornes")] <- 'casq_corn' colnames(df)[which(names(df)=="epee_antennes")] <- 'ep_anten' colnames(df)[which(names(df)=="epee_langue_carpe")] <- 'ep_carp' colnames(df)[which(names(df)=="epee_pistilliforme")] <- 'ep_pistil' colnames(df)[which(names(df)=="fibule_arco_violin")] <- 'fib_arc_viol' colnames(df)[which(names(df)=="lance_lame_lanceol")] <- 'lance_lanceol' colnames(df)[which(names(df)=="lance_lame_ovale")] <- 'lance_oval' colnames(df)[which(names(df)=="sexe_masculin")] <- 'sexe_m' return(df) } findex <- function(a.list,a.lname){ # found the index of the name in the list ldec <- c() for (i in 1:length(a.list)){ ldec <- unlist(c(ldec,a.list[[i]][1])) } return(match(a.lname,ldec)) } ffind_index_graph <- function(gname){ # renvoie l'index du graph dont le nom est lu ct <- 1 for (i in 1:length(lgrph)){ if (gname==lgrph[[i]]$name){ return (ct) } ct <- ct + 1 } return (NA) } f.sample.coloramp.dist <- function(df){ # colormap with sample of labels on rounded vales df$x <- as.integer(rownames(df)) df$x <- factor(df$x, levels = df$x) df$y <- 0 df$lbl <- NA the.range <- df$value the.l.range <- nrow(df) a.min <- min(the.range) a.second.min <- sort(the.range, FALSE)[2] a.20e <- the.range[ceiling(the.l.range/20)] a.10e <- the.range[ceiling(the.l.range/10)] a.5e <- the.range[ceiling(the.l.range/5)] a.3e <- the.range[ceiling(the.l.range/3)] a.2e <- the.range[ceiling(the.l.range/2)] a.1.5e <- the.range[ceiling(the.l.range/1.5)] a.max <- max(the.range) the.sample <- c(a.min,a.second.min,a.20e,a.10e,a.5e,a.3e,a.2e,a.1.5e,a.max) # select only samples values for (i in 1:the.l.range){ a.val <- df[i,"value"] if (a.val %in% the.sample){ df[i,"lbl"] <- round(a.val,1) # round values } } return(df) } plot.a.graph <- function(g){ # retrun a simple plot of a graph a.plot <- plot(g, main=g$name, vertex.label=paste0(V(g)$id,".",V(g)$type), edge.label = E(g)$typ) return(a.plot) } f.family.listdecoration <- function(select.obj){ # create planche of all the family object - - - - - - - - - - - - - - - - - - - # select.obj <- select.family ; n.col <- 10 drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") all.families <- dbGetQuery(con,"SELECT DISTINCT famille FROM famille") famille.exist <- select.obj %in% all.families$famille # test if family exist if (famille.exist){ # list ico sqll.ico.planche <- paste0("SELECT site,numero,self,img FROM objets WHERE famille LIKE '",select.obj,"'") df.sqll.ico.planche <- dbGetQuery(con,sqll.ico.planche) df.sqll.ico.planche <- df.sqll.ico.planche[with(df.sqll.ico.planche, order(site,numero)), ] #dim.planche <- c(3,5) # height & width in inches n.row <- ceiling(nrow(df.sqll.ico.planche)/n.col) # max.imgs <- dim.planche[1]*dim.planche[2] empty.obj <- image_read(paste0(chm.obj,"/empty_obj.gif")) ll.img.planche <- list() for (im in 1:nrow(df.sqll.ico.planche)){ #im <- 6 enr <- df.sqll.ico.planche[im,] idf.enr <- paste0(as.character(im),'.',enr[,"site"],"\n",enr[,"numero"]) self <- as.character(enr[1,"self"]) print(paste0(im,") read decoration: ",idf.enr)) img.enr.txt <- enr[,"img"] img.enr.txt <- gsub('%20',' ',img.enr.txt) # remove %20 used by windows # test if image exists e.img <- any(str_detect(img.enr.txt,c(".jpg",".gif",".tif"))) na.img <- is.na(img.enr.txt) if (e.img & !na.img){ img.enr <- image_read(img.enr.txt) # read img.enr <- image_trim(img.enr) } if (!e.img | na.img){ # empty image img.enr <- empty.obj } img.enr <- image_scale(img.enr,"1000x1000") # support name img.enr <- image_annotate(img.enr, idf.enr, size = 40, gravity = "southwest", color = "black") if(self=="anthropomorphe" & !is.na(self)){ # if anthropomorph support plot red square img.enr <- image_annotate(img.enr, " ", size = 40, gravity = "southeast",color = "red", boxcolor = "red") } ll.img.planche[[length(ll.img.planche)+1]] <- image_ggplot(img.enr) } # write a.tit <- paste0(" nb total '",select.obj,"' : ",length(ll.img.planche), "\nanthromorphic support are identified with red square") a.marg <- 0.2 margin = theme(plot.margin = unit(c(a.marg,a.marg,a.marg,a.marg), "cm")) for (dev in c(".png",".pdf")){ ggsave(file = paste0(chm.etude,"ico_contactsheet",dev), arrangeGrob(grobs = lapply(ll.img.planche, "+", margin),ncol = n.col, top = grid::textGrob(a.tit,x=0,hjust=0,gp = gpar(fontsize =8))), width = n.col*3.5, height = n.row*3.5) } } dbDisconnect(con) } f.family.contactsheet <- function(select.obj,n.col){ # TODO fucking contact sheet # create planche of all the family object - - - - - - - - - - - - - - - - - - - # select.obj <- select.family ; n.col <- 3 drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") all.families <- dbGetQuery(con,"SELECT DISTINCT famille FROM famille") famille.exist <- select.obj %in% all.families$famille # test if family exist if (famille.exist){ # exist family # list ico sqll.ico.planche <- paste0("SELECT site,numero,self,incomplet,img FROM ", "objets WHERE famille LIKE '",select.obj,"'") df.sqll.ico.planche <- dbGetQuery(con,sqll.ico.planche) #df.sqll.ico.planche <- head(df.sqll.ico.planche) # sample df.sqll.ico.planche <- df.sqll.ico.planche[with(df.sqll.ico.planche, order(site,numero)), ] df.sqll.ico.planche$incomplet[is.na(df.sqll.ico.planche$incomplet)] <- 0 #dim.planche <- c(3,5) # height & width in inches n.row <- ceiling(nrow(df.sqll.ico.planche)/n.col) # max.imgs <- dim.planche[1]*dim.planche[2] empty.obj <- image_read(paste0(chm.obj,"/empty_obj.gif")) # ll.img.planche <- list() # ll.img.planche.c <- c() for (im in 1:nrow(df.sqll.ico.planche)){ # im <- 1 enr <- df.sqll.ico.planche[im,] a.sit <- enr[,"site"] a.num <- enr[,"numero"] idf.enr <- paste0(as.character(im),'.',a.sit,"\n",a.num) self <- as.character(enr[1,"self"]) # add (A) to anthromophe if(self=="anthropomorphe" & !is.na(self)){ idf.enr <- paste0(idf.enr," (A)") } print(paste0(im,") read decoration: ",idf.enr)) img.enr.incomp <- enr[,"incomplet"] img.enr.txt <- enr[,"img"] img.enr.txt <- gsub('%20',' ',img.enr.txt) # remove %20 used by windows # test if image exists e.img <- any(str_detect(img.enr.txt,c(".jpg",".gif",".tif"))) na.img <- is.na(img.enr.txt) if (e.img & !na.img){ img.enr <- image_read(img.enr.txt) # read img.enr <- image_trim(img.enr) } if (!e.img | na.img){ # empty image img.enr <- empty.obj } img.enr <- image_scale(img.enr,"1000x1000") # support name img.enr <- image_annotate(img.enr, idf.enr, size = 40, gravity = "southwest", color = "black") if(img.enr.incomp){ # if anthropomorph support plot red square img.enr <- image_annotate(img.enr, " ", size = 40, gravity = "southeast",color = "red", boxcolor = "red") } chm.out <- paste0(chm.corpus,a.sit,'_',a.num,'.png') image_write(img.enr, path = chm.out, format = "png",flatten = T) # write 1 img # ll.img.planche.c <- image_join(ll.img.planche.c,img.enr) # ll.img.planche[[length(ll.img.planche)+1]] <- image_ggplot(img.enr) } } # limgs <- list.files(chm.corpus) # # setup plot # # dev.off() # while (!is.null(dev.list())) dev.off() # par(mai=rep(0,4)) # no margins # # layout the plots into a matrix w/ 12 columns, by row # layout(matrix(1:length(limgs), ncol=n.col, byrow=TRUE)) # # do the plotting # for(j in 1:length(limgs)) { # # j <- 1 # a.img <- paste0(chm.corpus,limgs[j]) # a.img <- readPNG(a.img) # plot(NA,xlim=0:1,ylim=0:1,xaxt="n",yaxt="n",bty="n") # plot(NA,xlim=0:1,ylim=0:1,bty="n",axes=0,xaxs = 'i',yaxs='i') # rasterImage(a.img,0,0,1,1) # # a <- rasterGrob(a.img,interpolate=FALSE) # } # # # write to PDF # dev.print(pdf, "output.pdf") # # # # nchunks <- ceiling(length(ll.img.planche.c)/n.col) # x.chk <- seq_along(ll.img.planche.c) # serie # d1 <- split(ll.img.planche.c, ceiling(x.chk/nchunks)) # ico.images <- image_append(d1, stack = F) # d1 <- split(ll.img.planche.c,nchunks) # # write # a.tit <- paste0(" nb total '",select.obj,"' : ",length(ll.img.planche), # "\nincomplete supports are identified with red square", # "\anthropomorph supports are identified with (A)") # a.marg <- 0.2 # margin = theme(plot.margin = unit(c(a.marg,a.marg,a.marg,a.marg), "cm")) # for (dev in c(".png")){ # ggsave(file = paste0(chm.etude,"ico_contactsheet",dev), # arrangeGrob(grobs = lapply(ll.img.planche, "+", margin),ncol = n.col, # top = grid::textGrob(a.tit,x=0,hjust=0,gp = gpar(fontsize =8))), # width = n.col*3.5, # height = n.row*3.5) # } # } if (!famille.exist){ # select from decorations } dbDisconnect(con) } f.archeo <- function(select.thm){ # for archeo/real objets drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") sqll <- paste0("SELECT site,structure,numero as decor,type,tpq,taq,img,", "ST_X(geom) as x,ST_Y(geom) as y ", "FROM objets WHERE type LIKE '",select.thm,"'") df <- dbGetQuery(con,sqll) dbDisconnect(con) return(df) } # f.archeo <- function(select.thm){ # # for archeo/real objets # drv <- dbDriver("PostgreSQL") # con <- dbConnect(drv, # dbname="mailhac_9", # host="localhost", # port=5432, # user="postgres", # password="postgres") # sqll <- paste0("SELECT site,structure,numero as decor,type,tpq,taq,img,", # "ST_X(geom) as x,ST_Y(geom) as y ", # "FROM objets WHERE type LIKE '",select.thm,"'") # df <- dbGetQuery(con,sqll) # dbDisconnect(con) # return(df) # } f.ugs <- function(select.thm){ # select.thm <- "bracelet" drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") sqll <- paste0( "SELECT table_noeuds.site,table_noeuds.decor,table_noeuds.id,", "table_noeuds.long_cm,table_noeuds.incomplet,", "table_noeuds.type,objets.img,", "objets.famille,", "ST_X(table_noeuds.geom) as x_ug, ST_Y(table_noeuds.geom) as y_ug,", "ST_X(objets.geom) as x, ST_Y(objets.geom) as y ", "FROM table_noeuds,objets WHERE table_noeuds.site=objets.site ", "AND table_noeuds.decor=objets.numero ", "AND table_noeuds.type like '",select.thm,"' ", "ORDER by famille, site, decor;" ) df <- dbGetQuery(con,sqll) df$site.dec <- paste0(df$site,'.',df$decor) # same idf for same decorations df.idf <- as.data.frame(subset(df,select=c("site.dec"))) df.idf <- as.data.frame(df.idf[!duplicated(df.idf), ]) colnames(df.idf)[1] <- "site.dec" df.idf$idf <- row.names(df.idf) # merge df.merg <- merge(df,df.idf,by='site.dec',all.x=T) dbDisconnect(con) return(df.merg) } f.img.list <- function(select.obj){ # export individual decoration in 'corpus' folder # select.obj <- "Monte Hijido" ; select.obj <- "stele bouclier" # select.obj <- "steles Bz du SO europeen" drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") sqll.condition <- "SELECT site,numero,img FROM objets WHERE " if(select.choice == "select.family" | select.choice == "select.objet"){ all.families <- dbGetQuery(con,"SELECT DISTINCT famille FROM famille") famille.exist <- select.obj %in% all.families$famille # test if family exist sqll.img <- paste0(sqll.condition,"famille LIKE '", select.obj,"'") } if(select.choice == "select.superfamily"){ all.families <- dbGetQuery(con,"SELECT DISTINCT famille_super FROM famille_super") famille.exist <- select.obj %in% all.families$famille_super # test if superfamily exist sqll.img <- paste0(sqll.condition,"famille_super LIKE '", select.obj,"'") } if (!famille.exist){ print("NO familiy") df.img <- data.frame(site=character(0), decor=character(0), img=character(0), stringsAsFactors = F) for(i in 2:length(ldecors)){ # some decoration # fill the df # i <- 5 a.site <- ldecors[[i]][[1]] a.dec <- ldecors[[i]][[2]] print(paste0(" ",i-1,") read ",a.site," ",a.dec)) if (a.dec == ''){ # all objects of this site sqll.img <- paste0(sqll.condition,"objets.site LIKE '", a.site,"'") } if (a.dec != ''){ sqll.img <- paste0(sqll.condition,"objets.site LIKE '",a.site, "' AND objets.numero LIKE '",a.dec,"'") } img.enr <- dbGetQuery(con,sqll.img) # get image df.img <- rbind(df.img,img.enr) } } if (famille.exist){ # all the family print("EXISTS a family or a superfamily") df.img <- dbGetQuery(con,sqll.img) # get image df.img <- df.img[with(df.img, order(site, numero)), ] rownames(df.img) <- 1:nrow(df.img) } # plot the images for (i in 1:nrow(df.img)){ # i <- 1 site.a <- df.img[i,1] dec.a <- df.img[i,2] img.a <- df.img[i,3] print(paste0(" ",i-1,") read image ",site.a," ",dec.a)) img.enr.txt <- gsub('%20',' ',img.a) # remove %20 used by windows img.is.not.na <- !is.na(any(str_detect(img.enr.txt,c(".jpg",".gif",".tif")))) img.is.not.false <- any(str_detect(img.enr.txt,c(".jpg",".gif",".tif"))) img.exist <- img.is.not.na & img.is.not.false if (img.exist){ # image exists img.enr <- image_read(img.enr.txt) # read } if (!img.exist){ # empty image img.enr <- image_read(paste0(chm.obj,"/empty_obj.gif")) } img.enr <- image_trim(img.enr) # trim img.enr <- image_scale(img.enr,"1000x1000") img.enr <- image_border(img.enr,"#FFFFFF", "100x100") # add small white margins img.out <- paste0(chm.corpus,i,"_",site.a,"_",dec.a,".png") image_write(img.enr, path = img.out, format = "png") } dbDisconnect(con) } f.img.list(select.superfamily) # contact.sheet <- function(df,select.thm,obj.nat){ # 'obj.nat' is the nature of the object (ex: 'ugs','objects','archeo'; etc.) # this function has a long history of [not]working properly # see previous versions (like 19_35) where 'ggsave_to_variable' used to work # - - - - - - - - # select.thm <- "poignard"; obj.nat <- "ugs"; df <- df.ico.thm # df <- df.ico.thm ; obj.nat <- "ugs" ; select.thm <- "fibule" df.ugs.xy <- copy(df) # copy for x,y plot no.family <- "zz_nofamily" # make some changes for archeo obj cols <- c("famille" = no.family) df <- add_column(df, !!!cols[setdiff("famille", names(df))]) #names(df)[names(df) == 'numero'] <- "decor" # replace colname # df$lbl <- paste0(df$site,'.',df$decor) df$famille[is.na(df$famille)] <- no.family num.of.imgs <- nrow(df) # get nb of occurences t.ct.ugs <- as.data.frame(table(df$lbl)) # counts df <- merge(df,t.ct.ugs,by.x="lbl",by.y="Var1") df$x_ug <- df$y_ug <- NULL # remove x,y of ugs # remove duplicated df <- df[!duplicated(df), ] df <- df[order(df$famille,df$lbl),] #df <- df[with(df, order(site,numero)), ] # height & width in inches #n.row <- ceiling(num.of.imgs/n.col) #dim.planche <- c(n.row,n.col) n.row <- n.col <- ceiling(sqrt(nrow(df))) # for square matrix dim.planche <- c(n.row,n.col) max.imgs <- dim.planche[1]*dim.planche[2] #empty.obj <- image_read(paste0(chm.obj,"/empty_obj.gif")) ll.img.planche <- ll.img.planche.r <- ll.img.planche.g <-list() for (im in 1:nrow(df)){ # im <- 1 mult <- 1 print(paste0(" ",im,") read decoration ",df[im,"lbl"])) enr <- df[im,] a.sit <- enr[,"site"] a.dec <- enr[,"decor"] a.ug <- enr[,"id"] a.lbl <- paste0(a.sit,"_",a.dec,"_",a.ug) img.enr.txt <- enr[,"img"] # get image img.enr.txt <- gsub('%20',' ',img.enr.txt) # remove %20 used by windows img.is.not.na <- !is.na(any(str_detect(img.enr.txt,c(".jpg",".gif",".tif")))) img.is.not.false <- any(str_detect(img.enr.txt,c(".jpg",".gif",".tif"))) img.exist <- img.is.not.na & img.is.not.false # test if image exists if (img.exist){ #img.enr <- image_read(img.enr.txt, width = 500) # read img.enr <- image_read(img.enr.txt) # read img.a.h <- image_info(img.enr)$height # height (offset) img.a.w <- image_info(img.enr)$width # width img.a.d <- image_info(img.enr)$density # res img.a.d <- as.numeric(gsub( "x.*$","",img.a.d)) # res 300x300 -> res 300 if (img.a.h > 1000){mult <- 1.5} if (obj.nat == 'ugs'){ # TODO: problem with trim and/or resize # get coordinates of selected themes/ugs ugs.sel <- df.ugs.xy[df.ugs.xy$site == a.sit & df.ugs.xy$decor == a.dec & df.ugs.xy$id == a.ug,] ugs.xy <- subset(ugs.sel,select=c(x_ug,y_ug)) # get x,y out.img <- paste0(chm.ug.typo,select.thm,"/corpus/",a.lbl,".png") a.image.graph <- image_ggplot(img.enr) # convert image-magick to ggplot # plot ugs on their x,y # functions from 'ggrepel' package can create error # like 'Error in grid.Call...' # in RStudio, because of window (small) size # ERROR: problem with 'image_ggplot' # see last version _19_39.Rmd a.image.graph.a <- a.image.graph + # point - - - - - - - - - - - - - # # YES geom_point(aes(x=ugs.sel$x_ug,y=(img.a.h+ugs.sel$y_ug)), color='red', cex=2*mult) # # label - - - - - - - - - - - - - # geom_text(aes(x=ugs.sel$x_ug,y=(img.a.h+ugs.sel$y_ug)), # #x=ugs.sel$x_ug,y=ugs.sel$y_ug, # label=ugs.sel$id, # angle = 180, # hjust = 0,vjust = 1, # # point.padding = unit(0.15, "lines"), # # min.segment.length = 0.05, # # box.padding = unit(0.08, 'lines'), # # label.padding = unit(0.08, 'lines'), # # segment.size = 0.3, # color='red', # cex=5*mult) # plot(a.image.graph.a) # save on 'corpus' folder,... necessary ggsave(out.img, a.image.graph.a, width =6, height=6, dpi = img.a.d) # read the exported image img.enr.1 <- image_read(out.img) # read img.enr.1 <- image_flip(img.enr.1) # flip vertical # img.enr <- image_rotate(img.enr,180) img.enr.1 <- image_trim(img.enr.1) # trim # img.enr <- ggsave_to_variable(a.image.graph.a,img.a.h,img.a.w,img.a.d) # img.enr <- image_graph(width = img.a.w, # height = img.a.h, # bg = "white", # res = img.a.d, # clip = TRUE, # antialias = TRUE) # img.enr <- image_trim(img.enr) # trim } # - - - - - - - - - - - - - # img.enr <- image_trim(img.enr) # trim } if (!img.exist){ # empty image img.enr.1 <- image_read(paste0(chm.obj,"/empty_obj.gif")) } img.enr.1 <- image_scale(img.enr.1,"1000x1000") img.enr.1 <- image_border(img.enr.1,"#FFFFFF", "50x50") # add small white margins #idf.enr <- paste0(enr[,"lbl"]," (n=",enr[,"Freq"],")") idf.enr <- paste0(im,'.',a.sit,"\n",a.dec,"\n","(ug: ",ugs.sel$id,")") # idf.enr <- paste0(im,'.',a.sit,"\n",a.dec,"\n","(nb=",enr[,"Freq"],")") idf.famille <- enr[,"famille"] img.enr.1 <- image_annotate(img.enr.1, idf.famille, size = 45, gravity = "northwest",boxcolor = "white", color = "black") img.enr.1 <- image_annotate(img.enr.1, idf.enr, size = 35, gravity = "southwest",boxcolor = "white", color = "black") # ll.img.planche[[length(ll.img.planche)+1]] <- img.enr # ll.img.planche.r[[length(ll.img.planche.r)+1]] <- as.raster(img.enr) ll.img.planche.g[[length(ll.img.planche.g)+1]] <- as_ggplot(as.grob(img.enr.1)) # ll.img.planche[[length(ll.img.planche)+1]] <- image_ggplot(img.enr) } # write a.tit <- paste0("contactsheet of '",select.thm,"' selected ",obj.nat, ", total nb: ",length(ll.img.planche.g)) if (obj.nat == "ugs"){ a.tit <- paste0(a.tit,"\nwith numeros and positions (red point)") } a.marg <- 0.2 margin = theme(plot.margin = unit(c(a.marg,a.marg,a.marg,a.marg), "cm")) # loop through devices for (dev in c(".png")){ # dev <- ".png" if(obj.nat == "ugs"){ g.out <- paste0(chm.ug.typo,select.thm,"/",obj.nat,"_contactsheet",dev) } ggsave(file = g.out, arrangeGrob(grobs = lapply(ll.img.planche.g, "+", margin), ncol = dim.planche[2], top = grid::textGrob(a.tit,x=0,hjust=0,gp = gpar(fontsize =10))), width = dim.planche[2]*2, height = dim.planche[2]*2) } #return(chm.ico.planche) } # contact.sheet.select.ugs(c("fibule")) # thms and number of img for a line contact.sheet.select.ugs <- function(select.thms){ # create contact sheet of all the ug having a certain type, here 'select.thm' (ex: "carquois") # 'n.col' is the number of images in columns # TODO: get img dim to expand/reduce label ug sizes # select.thms <- c("casque");select.thms <- c("fibule") # list ico for (select.thm in select.thms){ # select.thm <- "fibule" print (paste0("* read ugs: ",select.thm," *")) # create 'corpus' folder if not exists chm.ug.typo.thm <- paste0(chm.ug.typo,"/",select.thm) ifelse(!dir.exists(file.path(chm.ug.typo.thm, "corpus")), dir.create(file.path(chm.ug.typo.thm, "corpus")), FALSE) # chm.ico.ug <- paste0(chm.ug,select.thm,"/") df.ico.thm <- f.ugs(select.thm) # load selected ugs from Pg contact.sheet(df.ico.thm,select.thm,"ugs") # launch the cs function cat("\014") # clear console } } contact.sheet.real.objects <- function(select.thms){ # select.thms <- c("casque");select.thms <- c("carquois","epee") for (select.thm in select.thms){ # select.thm <- "casque" print (paste0("* read ugs: ",select.thm," *")) df <- f.archeo(select.thm) # load from db if(nrow(df)>0){ contact.sheet(df,select.thm,"archeo") } # create the cs function } dbDisconnect(con) } contact.sheet.grph <- function(lgrph,df.icos,g.stats,is.meta){ ll.graphs <- list() n.img <- length(g.stats) n.dec <- length(lgrph) siz.of.img <- 4 v.box.padding <- .04 v.label.padding <- .08 # e.label.padding <- round(v.label.padding*e.coef.cex,2) v.segment.size <- .4 v.cex.txt <- 1.5 #e.cex.txt <- round(v.cex.txt*e.coef.cex,2) v.cex.node <- .8 for (a.g in 1:n.dec){ # a.g <- 1 g <- lgrph[[a.g]] a.sit <- unique(get.vertex.attribute(g, "site", index=V(g))) a.dec <- unique(get.vertex.attribute(g, "decor", index=V(g))) a.idf <- unique(get.vertex.attribute(g, "idf", index=V(g))) g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>') # gt.index.df <- c("closeness") # names of the graph analysis functions for (gt.i in g.stats){ # gt.i <- "closeness" print(paste0("'",gt.i,"' measurement centralities")) # path name of the function gt.i.val <- eval(parse(text = paste0("as.data.frame(",gt.i,"(g))"))) colnames(gt.i.val)[1] <- "stat.graph" # modi fy function name u.gt.i.val <- sort(unique(gt.i.val$stat.graph),decreasing = T) # unique vals # change id g.ids <- get.vertex.attribute(g, "id", index=V(g)) g <- set.vertex.attribute(g, "name", value=g.ids) g.df <- igraph::as_data_frame(g, what="vertices") g.df <- merge(g.df,gt.i.val,by="row.names") # merge 'g' and 'gt.i.val' g.df <- subset(g.df,select=c("name","id","type","x","y","stat.graph")) # # order on 'stat.graph' value and color # g.df <- g.df[with(g.df, order(-stat.graph)), ] # row.names(g.df) <- 1:nrow(g.df) n.colors <- brewer.pal(length(u.gt.i.val),"Spectral") # gradient color ramp for 'stat.graph' df.color <- data.frame(stat.graph=u.gt.i.val, stat.graph.color=n.colors) # merge color and df g.df <- merge(g.df,df.color,by="stat.graph",all.x=T) # g.df$stat.graph.color <- n.colors # image img.a <- df.icos[df.icos$site == a.sit & df.icos$num == a.dec,]$img # image img.exist <- !(is.na(img.a) | img.a=="") if (!img.exist){a.img <- image_read(paste0(chm.obj,"/empty_obj.gif"))} if (img.exist){a.img <- image_read(img.a)} # read image a.text <- paste0("nodes '",gt.i,"'") # a.img <- image_annotate(a.img,a.text, size = annot.size, # gravity = "north", color = "black") a.image <- image_ggplot(a.img) # convert image-magick to ggplot z.image <- a.image + ggtitle(a.text)+ geom_point(data=g.df,x=g.df$x,y=g.df$y,aes(color=g.df$stat.graph.color),cex=2)+ geom_label_repel(data=g.df,x=g.df$x,y=g.df$y, label=paste0(g.df$type,"\n",round(g.df$stat.graph,2)), box.padding = unit(v.box.padding, "lines"), label.padding = unit(v.label.padding, "lines"), segment.size = v.segment.size, color=g.df$stat.graph.color, cex=1.5)+ scale_colour_identity(guide="legend",breaks=n.colors,labels=round(u.gt.i.val,2))+ theme(legend.title = element_text(size = 7), legend.text = element_text(size = 7))+ labs(color=paste0(a.text,"\nvalues")) # img.out <- ggsave_to_variable(z.image,siz.of.img+1,siz.of.img,300) # img.out %>% magick::image_write(n.file) if(is.meta){ # save images separetly n.file <- paste0(chm.doc,as.character(a.g),"_stats_graph_",gt.i,".png") ggsave(n.file,z.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE) } ll.graphs[[length(ll.graphs)+1]] <- z.image } } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # create a planche of contact of m x n images margin = theme(plot.margin = unit(c(0.5,0.5,0.5,0.5), "cm")) if(!is.meta){ for (dev in c(".png",".pdf")){ a.contact.sheet <- paste0(chm.analysis,"/stats_ugs.png") ggsave(file = a.contact.sheet, arrangeGrob(grobs = lapply(ll.graphs, "+", margin), padding = unit(0.05, "line"), ncol = n.img), height = n.dec*siz.of.img, width = n.img*siz.of.img, dpi=300, limitsize = FALSE) } } # if(is.meta){ # a.contact.sheet <- paste0(chm.doc,"stats_graph_ugs.png") # ggsave(file = a.contact.sheet, # arrangeGrob(grobs = lapply(ll.graphs, "+", margin), padding = unit(0.05, "line"), ncol = n.img), # height = n.dec*siz.of.img, # width = n.img*(siz.of.img+1), dpi=300, # # height = length(g.img)*siz.of.img, # # width = nrow(crp)*siz.of.img, dpi=300, # limitsize = FALSE) # } print(paste0(" ",a.contact.sheet," saved !")) # r.start <- r.end+1 # increment start # r.end <- r.end+max.row.cs # #grid.arrange(grobs = ll.dec, ncol = 3) } # g.stats <- c("closeness","betweenness","degree") # names of the graph analysis functions # contact.sheet.grph(lgrph,df.icos,g.stats,is.meta) contact.sheet.var <- function(lgrph,crp.all,df.icos,g.img,writ.imgs,is.meta){ # create contactsheet displaying all 'ug' variables # Fill the 'corpus' directory with 3 images for each objects by lines # and regroup in contact sheet # 1) simple image # 2) 'graph' (nodes + edges) # 3) image with themes 'types' # 4) image with themes 'chronology' # n) ... # TODO: sens, dim, change edge color depending wheter attributes or not # TODO: change cs name to correspond with decor ID # parameters - - - - - - - - - - - - - n.img <- length(g.img)+1 # number of images in line siz.of.img <- 4 # size of images in inch # maximum of row for one contact sheet max.row.cs <- ceiling(50/(siz.of.img+1)) # /!\ max is 50 inches, add a marg in as a security annot.size <- 20 # size of annotations e.coef.cex <- 2/3 # size for edges are proportions node sizes v.box.padding <- .04 v.label.padding <- .08 e.label.padding <- round(v.label.padding*e.coef.cex,2) v.segment.size <- .4 v.cex.txt <- 1.5 e.cex.txt <- round(v.cex.txt*e.coef.cex,2) v.cex.node <- .8 # - - - - - - - - - - - - - - - - - - - #crp.all <- crp.all[c(10:15),] # sample/try #crp <- crp.all[c(1:50),] n.crp <- nrow(crp.all) # total nb of decor to display n.crp.cs <- ceiling(n.crp/max.row.cs) # number of contact sheet r.start <- 1;r.end <- max.row.cs for (cs in 1:n.crp.cs){ # cs <- 1 ll.dec <- list() # list of images for contact sheet first.row <- T # will plot columns headers # create different contact sheet crp <- crp.all[c(r.start:r.end),] # get a chunk subset crp <- crp[!(is.na(crp$site)),] # remove some NA rows #n.r <- length(r.start:r.end) # number of rows by contactsheet a.start <- min(crp$idf);a.end <- max(crp$idf) n.chunk <- paste0(as.character(a.start),"-",as.character(a.end)) # add lbl of the cs print(paste0("create contact sheet [",cs,"] between decors '",n.chunk,"'")) for (i in 1:nrow(crp)){ #for (i in r.start:r.end){ #print(paste0(" ",i)) # i <- 1 sit.a<-crp[i,"site"] num.a<-crp[i,"numero"] lbl.a<-crp[i,"lbl"] idf.a<-crp[i,"idf"] print(paste0(" ",idf.a,") read decor: ",lbl.a)) # outputs chm.a <- paste0(chm.corpus,idf.a,'_',lbl.a) if (writ.imgs){ chm.out.dec <- paste0(chm.a,'.png') chm.out.dec.grph <- paste0(chm.a,'_grph.png') chm.out.dec.type <- paste0(chm.a,'_ico.png') chm.out.dec.chr <- paste0(chm.a,'_tpq.png') chm.out.dec.sens <- paste0(chm.a,'_sens.png') chm.out.dec.long_cm <- paste0(chm.a,'_long_cm.png') } # - - - - - - - - - - - - - - - - - - - - - - - - - - - # read edges dd.edges <- edges.coordinates(sit.a,num.a) # edges #dd.edges.copy <- dd.edges #dd.edges.copy$typ <- gsub('+', 'att', dd.edges.copy$typ) dd.edges$typ[is.na(dd.edges$typ)] <- '=' # change NA to = #img.a <- crp[crp$site == sit.a & crp$num == num.a,]$img # image img.a <- df.icos[df.icos$site == sit.a & df.icos$num == num.a,]$img # image #img.a <- image_trim(image_read(img.a)) # read & trim # test if image exists img.formats <- c(".jpg", ".tif", ".gif") img.exist <- length(unique (grep(paste(img.formats,collapse="|"),img.a))) if (!img.exist){img.a <- image_read(paste0(chm.obj,"/empty_obj.gif"))} if (img.exist){img.a <- image_read(img.a)} # read image # img.exist <- !(is.na(img.a) | img.a=="") # if (!img.exist){img.a <- image_read(paste0(chm.obj,"/empty_obj.gif"))} # if (img.exist){img.a <- image_read(img.a)} # read image #img.a <- image_scale(img.a,"500x500") img.a.h <- image_info(img.a)$height # height (offset) img.a.w <- image_info(img.a)$width # width img.a.d <- image_info(img.a)$density # res img.a.d <- as.numeric(gsub( "x.*$","",img.a.d)) # res 300x300 -> res 300 #rast.a <- as.raster(a.img) # image to raster #nodes.a <- nodes.df("Brozas","Brozas") # get nodes nodes.a <- nodes.df(sit.a,num.a) # get nodes nodes.a$color.chr <- ifelse(is.na(nodes.a$tpq),'grey','red') # color on 'tpq' nodes.a$color.sens <- ifelse(is.na(nodes.a$sens),'grey','red') # color on 'sens' nodes.a$color.long_cm <- ifelse(is.na(nodes.a$long_cm),'grey','red') # color on 'long_cm' # label long_cm, italic if 'incomplet' nodes.a$lbl.dim <- ifelse(nodes.a$incomplet == 1, paste0("italic('", as.character(nodes.a$long_cm), "')"),as.character(nodes.a$long_cm)) # color on 'technologie' nodes.a$color.tek <- ifelse(is.na(nodes.a$technologie),'grey', ifelse(nodes.a$technologie == 'g_piq','orange', ifelse(nodes.a$technologie == 'g_inc','violet', 'blue'))) nodes.a1 <- nodes.a # a copy, util ? #- - - - - - - - - - - - - - - - - - - - - - - - - - - # xx) decor only : decor - - - - - - - - - print (" + image") img.init <- image_scale(img.a,"500x500") if(first.row){ # the title of the cs image.tag <- image_annotate(img.init, paste0("Contactsheet of decors:",r.start,"-",r.end), size = annot.size+5,gravity = "northwest", color = "black") } if(!first.row){image.tag <- img.init} # no tag # the name of the row image.tag <- image_annotate(image.tag, paste0(idf.a,'_',lbl.a), size = annot.size, gravity = "southwest", color = "black") tag.image <- image_ggplot(image.tag) ll.dec[[length(ll.dec)+1]] <- tag.image # write ? if(writ.imgs){image_write(image.tag,chm.out.dec, format = "png")} if(is.meta){ out.img <- paste0(chm.doc,"dec.png") ggsave(out.img,tag.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE) } #- - - - - - - - - - - - - - - - - - - - - - - - - - - if("g.grp" %in% g.img){ # xx) graph : decor + graph (nodes + edges) - - - - - print (" + graph") # add tag on column if first row if(first.row){ image.graph <- image_annotate(img.a,"nodes and edges", size = annot.size, gravity = "north", color = "black") } if(!first.row){image.graph <- img.a} # no tag a.image.graph <- image_ggplot(image.graph) # convert image-magick to ggplot intit <- "ba.image <- a.image.graph +" if (nrow(dd.edges)>0){ # at least exist 1 edge # store geom_segment in a string because not working properly with ggplot # intit <- "ba.image <- a.image.graph +" segm.ggplot <- label.edges.ggplot <- c() for (i in 1:nrow(dd.edges)){ segm.ggplot <- paste0(segm.ggplot, "geom_segment(x=",dd.edges[i,"xa"], ", y=",dd.edges[i,"ya"], ", xend=",dd.edges[i,"xb"], ", yend=",dd.edges[i,"yb"], ", color='red', size =.4, alpha=.5, ", ", linetype=ifelse('",dd.edges[i,"typ"],"'=='+',2,1)", ")+") # label.edges.ggplot <- paste0(label.edges.ggplot, # "geom_label(x=",(dd.edges[i,"xa"]+dd.edges[i,"xb"])/2, # ", y=",(dd.edges[i,"ya"]+dd.edges[i,"yb"])/2, # ", label= '",dd.edges[i,"typ"],"'", # ", box.padding = unit(v.box.padding, 'lines')", # ", label.padding = unit(v.label.padding, 'lines')", # # ", color=ifelse('",dd.edges[i,"typ"],"'=='+','blue','red'),", # ", color='red',", # "cex=e.cex.txt)+") } } if (nrow(dd.edges)==0){segm.ggplot <- label.edges.ggplot <- ""} # none edges #segm.ggplot <- gsub('.{1}$', '', segm.ggplot) # remove the last + nodes.ggplot <- "geom_point(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y, color='red',cex=v.cex.node)+" label.nodes.ggplot <- "geom_label_repel(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y, label=nodes.a1$id, box.padding = unit(v.box.padding, 'lines'), label.padding = unit(v.label.padding, 'lines'), segment.size = v.segment.size, color='red', cex=v.cex.txt)" # concat all strings dec.grph <- paste0(intit, segm.ggplot,label.edges.ggplot, # edges nodes.ggplot,label.nodes.ggplot # nodes ) eval(parse(text=dec.grph)) # create the 'ba.image' ll.dec[[length(ll.dec)+1]] <- ba.image my_img.ba <- ggsave_to_variable(ba.image,img.a.h,img.a.w,img.a.d) # write ? if(writ.imgs){my_img.ba %>% magick::image_write(chm.out.dec.grph)} if(is.meta){ out.img <- paste0(chm.doc,"dec_graph.png") ggsave(out.img,ba.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE) } } #- - - - - - - - - - - - - - - - - - - - - - - - - - - if("g.thm" %in% g.img){ # xx) decor + type of nodes - - - - - - - - - - - - - - - - print (" + typology") # add tag on column if first row if(first.row){ image.thm <- image_annotate(img.a,"nodes types", size = annot.size, gravity = "north", color = "black") } if(!first.row){image.thm <- img.a} # no tag a.image <- image_ggplot(image.thm) # convert image-magick to ggplot bb.image <- a.image + geom_point(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y, color='red',cex=v.cex.node) + geom_label_repel(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y, label=paste0(nodes.a1$id,'.',nodes.a1$type), box.padding = unit(v.box.padding, "lines"), label.padding = unit(v.label.padding, "lines"), segment.size = v.segment.size, color='red', cex=v.cex.txt) ll.dec[[length(ll.dec)+1]] <- bb.image my_img.bb <- ggsave_to_variable(bb.image,img.a.h,img.a.w,img.a.d) # write ? if(writ.imgs){my_img.bb %>% magick::image_write(chm.out.dec.type)} if(is.meta){ out.img <- paste0(chm.doc,"dec_thm.png") ggsave(out.img,bb.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE) } } #- - - - - - - - - - - - - - - - - - - - - - - - - - - if("g.chr" %in% g.img){ # xx) decor + chr - - - - - - - - - - - - - - - print (" + chronology") # add tag on column if first row if(first.row){ image.chr <- image_annotate(img.a,"nodes chronology", size = annot.size, gravity = "north", color = "black") } if(!first.row){image.chr <- img.a} # no tag a.image <- image_ggplot(image.chr) # convert image-magick to ggplot c.image <- a.image + geom_point(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,color=nodes.a1$color.chr,cex=v.cex.node)+ geom_label_repel(data=nodes.a1, x=nodes.a1$x,y=nodes.a1$y, label=paste0(nodes.a1$id,'.',nodes.a1$chr_1,"\n",nodes.a1$tpq,"/",nodes.a1$taq), box.padding = unit(v.box.padding, "lines"), label.padding = unit(v.label.padding, "lines"), segment.size = v.segment.size, color=nodes.a1$color.chr, cex=v.cex.txt) ll.dec[[length(ll.dec)+1]] <- c.image #ll.c[[length(ll.c)+1]] <- c.image my_img.c <- ggsave_to_variable(c.image,img.a.h,img.a.w,img.a.d) # write ? if(writ.imgs){my_img.c %>% magick::image_write(chm.out.dec.chr)} if(is.meta){ out.img <- paste0(chm.doc,"dec_chrono.png") ggsave(out.img,bb.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE) } } #- - - - - - - - - - - - - - - - - - - - - - - - - - - if("g.dim" %in% g.img){ # xx) decor + long_cm - - - - - - - - - - - - - - - print (" + length") # add tag on column if first row if(first.row){ image.dim <- image_annotate(img.a,"nodes length (in cm)", size = annot.size, gravity = "north", color = "black") } if(!first.row){image.dim <- img.a} # no tag a.image <- image_ggplot(image.dim) # convert image-magick to ggplot e.image <- a.image + geom_point(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,color=nodes.a1$color.long_cm,cex=v.cex.node)+ geom_label_repel(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y, label=nodes.a1$lbl.dim, box.padding = unit(v.box.padding, "lines"), label.padding = unit(v.label.padding, "lines"), segment.size = v.segment.size, color=nodes.a1$color.long_cm, cex=v.cex.txt, parse = TRUE) ll.dec[[length(ll.dec)+1]] <- e.image #ll.c[[length(ll.c)+1]] <- c.image my_img.e <- ggsave_to_variable(e.image,img.a.h,img.a.w,img.a.d) # write ? if(writ.imgs){my_img.e %>% magick::image_write(chm.out.dec.long_cm)} if(is.meta){ out.img <- paste0(chm.doc,"dec_dim.png") ggsave(out.img,e.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE) } } #- - - - - - - - - - - - - - - - - - - - - - - - - - - if("g.ort" %in% g.img){ # xx) decor + sens - - - - - - - - - - - - - - - print (" + orientation") # add tag on column if first row if(first.row){ image.ort <- image_annotate(img.a,"nodes orientation (0°-359°)", size = annot.size, gravity = "north", color = "black") } if(!first.row){image.ort <- img.a} # no tag a.image <- image_ggplot(image.ort) # convert image-magick to ggplot d.image <- a.image + geom_point(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,color=nodes.a1$color.sens,cex=v.cex.node)+ geom_label_repel(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y, label=paste0(nodes.a1$sens), box.padding = unit(v.box.padding, "lines"), label.padding = unit(v.label.padding, "lines"), segment.size = v.segment.size, color=nodes.a1$color.sens, cex=v.cex.txt) ll.dec[[length(ll.dec)+1]] <- d.image #ll.c[[length(ll.c)+1]] <- c.image my_img.d <- ggsave_to_variable(d.image,img.a.h,img.a.w,img.a.d) # write ? if(writ.imgs){my_img.d %>% magick::image_write(chm.out.dec.sens)} if(is.meta){ out.img <- paste0(chm.doc,"dec_ort.png") ggsave(out.img,d.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE) } } #- - - - - - - - - - - - - - - - - - - - - - - - - - - if("g.tek" %in% g.img){ # xx) decor + sens - - - - - - - - - - - - - - - print (" + technologie") # add tag on column if first row if(first.row){ image.ort <- image_annotate(img.a,"nodes technology", size = annot.size, gravity = "north", color = "black") } if(!first.row){image.ort <- img.a} # no tag a.image <- image_ggplot(image.ort) # convert image-magick to ggplot d.image <- a.image + geom_point(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y,color=nodes.a1$color.tek,cex=v.cex.node)+ geom_label_repel(data=nodes.a1,x=nodes.a1$x,y=nodes.a1$y, label=paste0(nodes.a1$technologie), box.padding = unit(v.box.padding, "lines"), label.padding = unit(v.label.padding, "lines"), segment.size = v.segment.size, color=nodes.a1$color.tek, cex=v.cex.txt) ll.dec[[length(ll.dec)+1]] <- d.image #ll.c[[length(ll.c)+1]] <- c.image my_img.d <- ggsave_to_variable(d.image,img.a.h,img.a.w,img.a.d) # write ? if(writ.imgs){my_img.d %>% magick::image_write(chm.out.dec.sens)} if(is.meta){ out.img <- paste0(chm.doc,"dec_tek.png") ggsave(out.img,d.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE) } } first.row <- F # for not ploting columns headers } # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # # stats on graph - - - - - - - - - - - - - - - - - - - - - - - - - - - # ll.graphs <- list() # for (a.g in 1:length(lgrph)){ # # a.g <- 1 # g <- lgrph[[a.g]] # a.sit <- unique(get.vertex.attribute(g, "site", index=V(g))) # a.dec <- unique(get.vertex.attribute(g, "decor", index=V(g))) # a.idf <- unique(get.vertex.attribute(g, "idf", index=V(g))) # g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>') # gt.index.df <- c("closeness","betweenness","degree") # names of the graph analysis functions # # gt.index.df <- c("closeness") # names of the graph analysis functions # for (gt.i in gt.index.df){ # # gt.i <- "closeness" # print(paste0("'",gt.i,"' measurement centralities")) # # path name of the function # gt.i.val <- eval(parse(text = paste0("as.data.frame(",gt.i,"(g))"))) # colnames(gt.i.val)[1] <- "stat.graph" # modi fy function name # u.gt.i.val <- sort(unique(gt.i.val$stat.graph),decreasing = T) # unique vals # # change id # g.ids <- get.vertex.attribute(g, "id", index=V(g)) # g <- set.vertex.attribute(g, "name", value=g.ids) # g.df <- igraph::as_data_frame(g, what="vertices") # g.df <- merge(g.df,gt.i.val,by="row.names") # merge 'g' and 'gt.i.val' # g.df <- subset(g.df,select=c("name","id","type","x","y","stat.graph")) # # # order on 'stat.graph' value and color # # g.df <- g.df[with(g.df, order(-stat.graph)), ] # # row.names(g.df) <- 1:nrow(g.df) # n.colors <- brewer.pal(length(u.gt.i.val),"Spectral") # gradient color ramp for 'stat.graph' # df.color <- data.frame(stat.graph=u.gt.i.val, # stat.graph.color=n.colors) # # merge color and df # g.df <- merge(g.df,df.color,by="stat.graph",all.x=T) # # g.df$stat.graph.color <- n.colors # # image # a.img <- df.icos[df.icos$site == sit.a & df.icos$num == num.a,]$img # image # img.exist <- !(is.na(a.img) | a.img=="") # if (!img.exist){a.img <- image_read(paste0(chm.obj,"/empty_obj.gif"))} # if (img.exist){a.img <- image_read(a.img)} # read image # a.text <- paste0("nodes '",gt.i,"'") # a.img <- image_annotate(a.img,a.text, size = annot.size, # gravity = "north", color = "black") # a.image <- image_ggplot(a.img) # convert image-magick to ggplot # z.image <- a.image + # geom_point(data=g.df,x=g.df$x,y=g.df$y,aes(color=g.df$stat.graph.color),cex=2)+ # geom_label_repel(data=g.df,x=g.df$x,y=g.df$y, # label=paste0(g.df$type,"\n",round(g.df$stat.graph,2)), # box.padding = unit(v.box.padding, "lines"), # label.padding = unit(v.label.padding, "lines"), # segment.size = v.segment.size, # color=g.df$stat.graph.color, # cex=3)+ # scale_colour_identity(guide="legend",breaks=n.colors,labels=round(u.gt.i.val,2))+ # labs(color=paste0(a.text,"\nvalues")) # ll.graphs[[length(ll.graphs)+1]] <- z.image # } # } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # create a planche of contact of m x n images margin = theme(plot.margin = unit(c(0,0,0,0), "cm")) #ll.dec.t <- ll.dec[1:18] #ifelse(nrow(objets)>50, h <- 49, h <- nrow(objets)/1.5) #scale_x_reverse(breaks=rev(a.min:a.max)) if(!is.meta){ for (dev in c(".png",".pdf")){ a.contact.sheet <- paste0(chm.etude,"ico_contactsheet_[",cs,"]_decors_(",a.start,"-",a.end,")",dev) ggsave(file = a.contact.sheet, arrangeGrob(grobs = lapply(ll.dec, "+", margin), padding = unit(0.05, "line"), ncol = n.img), height = nrow(crp)*siz.of.img, width = n.img*siz.of.img, dpi=300, limitsize = FALSE) } # a.contact.sheet <- paste0(chm.etude,"ico_contactsheet_[",cs,"]_decors_(",a.start,"-",a.end,").png") # ggsave(file = a.contact.sheet, # arrangeGrob(grobs = lapply(ll.dec, "+", margin), padding = unit(0.05, "line"), ncol = n.img), # height = nrow(crp)*siz.of.img, # width = n.img*siz.of.img, dpi=300, # limitsize = FALSE) } if(is.meta){ #a.contact.sheet <- paste0(chm.obj,"/(Etude)/ico_contactsheet_[",cs,"]_decors_(",a.start,"-",a.end,").png") ggsave(file = a.contact.sheet, arrangeGrob(grobs = lapply(ll.dec, "+", margin), padding = unit(0.05, "line"), ncol = n.img), height = nrow(crp)*siz.of.img, width = n.img*siz.of.img, dpi=300, # height = length(g.img)*siz.of.img, # width = nrow(crp)*siz.of.img, dpi=300, limitsize = FALSE) } print(paste0(" ",a.contact.sheet," saved !")) r.start <- r.end+1 # increment start r.end <- r.end+max.row.cs # #grid.arrange(grobs = ll.dec, ncol = 3) } } # contact.sheet.var(lgrph,crp.all,df.icos,g.img,writ.imgs,is.meta) # create cs f.update.orient <- function(){ # update orientation of ug in 'table_noeuds' by +90° # ex. "bouclier en V" drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") sqll <- paste0("SELECT site,structure,decor,id,type,chr_1,sens FROM ", "table_noeuds WHERE type LIKE 'bouclier' AND chr_1 LIKE '%en V' ORDER BY site,decor;") all.bouc <- dbGetQuery(con,sqll) all.bouc$n_sens <- NA for (r in 1:nrow(all.bouc)){ #r <-26 a <- all.bouc[r,"sens"] if (a >= 0 & a < 90){ b <- a+270 } if (a >= 90 & a < 180){ b <- a-90 } if (a >= 180){ b <- (a+90)-180 } all.bouc[r,"n_sens"] <- b } for (i in 1:nrow(all.bouc)){ a.sit <- all.bouc[i,"site"] #a.str <- all.bouc[i,"structure"] a.dec <- all.bouc[i,"decor"] a.idf <- all.bouc[i,"id"] n.sens <- all.bouc[i,"n_sens"] a.chr1 <- all.bouc[i,"chr_1"] sqll <- paste0("UPDATE table_noeuds SET sens=",n.sens, " WHERE site LIKE '",a.sit,"' AND ", "decor LIKE '",a.dec,"' AND ", "id = ",a.idf," AND ", "chr_1 LIKE '",a.chr1,"'") print (sqll) #dbGetQuery(con,sqll) } dbDisconnect(con) } alpha.incomp <- 0.3 # alpha for ugs where 'incomplet' = 1 fg.dim.by.dec <- function(ugs, corpus, dim, typ.dim, text.size = 10, label.size.dimension = 3, label.size.type = 4 ){ # TODO: plot also decoration without graphs or without dim # TODO: why alpha is that clear ? # dim: 'long' or 'long_cm' # typ.dim='rel': compute relative dimensions from the longest ug to the smallest # typ.dim='abs': compute absolute dimensions from the longest ug to the smallest # dim <- "long" ; typ.dim <-"abs" ; corpus <- 'family' nb.miss <- 0 ugs.sub <- subset(ugs,select=c("lbl","type",dim,"incomplet","id","chr_1")) df.ugs.dim <- data.frame(lbl=character(0), type=character(0), long=numeric(0), incomplet=numeric(0), id=numeric(0), chr_1=character(0), dim=numeric(0), idf=numeric(0)) for (i in 1:nrow(graphs)){ # i <- 4 g.idf <- graphs[i,"idf"]; g.dec <- graphs[i,"lbl"] g.lbl <- paste0(g.idf,'.',g.dec) #ug.select <- subset(ugs,select=c("lbl","type","long","id","chr_1")) ug.select <- ugs.sub[ugs.sub$lbl == g.lbl,] # subset if(nrow(ug.select)==0){nb.miss <- nb.miss+1 ; next} # if no graph, no ug.select$idf <- g.idf # long ug.select <- ug.select[ug.select[,dim] != 'NA' & !is.na(ug.select[,dim]),] if(typ.dim == "rel"){ # relative, normalized btw 1 and ~0.1 ug.select$dim <- round(ug.select[,dim]/max(ug.select[,dim]),2) } if(typ.dim == "abs"){ ug.select$dim <- round(ug.select[,dim],2) } ug.select <- ug.select[rev(order(ug.select[,dim])),] df.ugs.dim <- rbind(df.ugs.dim,ug.select) } # reorder df df.ugs.dim$lbl <- factor(df.ugs.dim$lbl,levels=rev(unique(df.ugs.dim$lbl))) ## italic and alpha = .5 if incomplet # label type df.ugs.dim$type.lbl <- ifelse(df.ugs.dim$incomplet == 1, paste0("italic('", df.ugs.dim$type, "')"),df.ugs.dim$type) # label dim df.ugs.dim$dim.lbl <- ifelse(df.ugs.dim$incomplet == 1, paste0("italic('", df.ugs.dim$dim, "')"),df.ugs.dim$dim) # alpha df.ugs.dim$alpha <- ifelse(df.ugs.dim$incomplet == 1,alpha.incomp,1) #df.ugs.#dim$lbl <- factor(df.ugs.dim$lbl,levels=df.ugs.dim$lbl) # title - - - - - - - - - # if(corpus=='objects'){tit.corpus <- "selected objects"} # if(corpus=='family'){tit.corpus <- paste0("family '",select.family,"'")} tit.corpus <- f.tit.corpus(corpus,length(unique(ugs$idf)),nrow(ugs)) # tit.corpus <- ifelse(corpus=="objects"," selected objects ", # paste0(" all '",select.family,"' family ")) # tit.nb <- paste0(" (n = ",length(unique(ugs$idf))," objects + ",nb.miss," missing, ",nrow(ugs)," ugs)") if(dim == "long"){tit.unite <- ", in pixel"} if(dim == "long_cm"){tit.unite <- ", in cm"} tit.sup <- "\nincomplete ugs are displayed in shaded italic" if(typ.dim == "abs"){tit <- paste0("absolute dimension on ",tit.corpus,tit.unite,tit.sup)} if(typ.dim == "rel"){tit <- paste0("relative dimension on ",tit.corpus,tit.nb, " from the largest theme (max=1) to the smallest one (min~.1)", tit.sup)} a.min <- ceiling(min(df.ugs.dim$dim)) a.max <- ceiling(max(df.ugs.dim$dim)) # the graph g.dim <- ggplot(df.ugs.dim)+ ggtitle(tit)+ geom_point(aes(x = dim, y = lbl, alpha = alpha))+ theme_bw()+ theme(plot.title = element_text(size = text.size))+ theme(axis.text = element_text(size = text.size))+ theme(legend.position = "none") n.row <- length(unique(df.ugs.dim$lbl)) if(typ.dim == "rel"){ g.dim <- g.dim + # type geom_text_repel(aes(x = dim, y = lbl,label=type.lbl,alpha=alpha,segment.alpha=alpha), segment.size = 0.3,#segment.alpha = 0.5, parse = TRUE)+ scale_x_reverse(breaks=rev(seq(0, 1, 0.1))) out.g <- paste0(chm.analysis.n.dimensions,"_ugs_rel_dim_by_decorations_",corpus,"_.png") } if(typ.dim == "abs"){ g.dim <- g.dim + # dimension geom_text_repel(aes(x = dim, y = lbl, label = dim.lbl, color = "gray30", alpha = alpha,segment.alpha=alpha), segment.color = "gray30",min.segment.length = 0.7, segment.size = 0.3,#segment.alpha = 0.5, point.padding=0.9, nudge_y = 0.07, size = label.size.dimension, parse = TRUE)+ # type geom_text_repel(aes(x=dim,y=lbl,label=type.lbl,alpha=alpha,segment.alpha=alpha), segment.size = 0.3, size = label.size.type,#segment.alpha = 0.5, parse = TRUE) + scale_color_identity() + scale_alpha_identity() if(dim == "long_cm"){ g.dim <- g.dim + scale_x_reverse(breaks = rev(seq(0,max(df.ugs.dim[,"dim"]),5))) } if(dim == "long"){ g.dim <- g.dim + scale_x_reverse() } } #scale_x_reverse(breaks=rev(a.min:a.max)) for (dev in c(".png",".pdf")){ out.g <- paste0(chm.analysis.n.dimensions,"ugs_",typ.dim,"_dim_by_decorations_",corpus,"_",dim,dev) ggsave(out.g, g.dim, height = (n.row/3)+7, width = 18) } shell.exec(out.g) } f.tit.corpus <- function(corpus,nb.dec,nb.ugs){ ## to uniformize ggplot titles # 'nb.dec'= number of objects, 'nb.ugs'= number of decorations # corpus <- "super.family" ; nb.dec <- 11 ; nb.ugs <- 999 # nb.dec <- length(lg.angles) ; nb.ugs <- length(unique(ugs$decor)) effectifs <- paste0("(nb obj: ",nb.dec,", nb ugs: ",nb.ugs,")") ifelse (corpus=='family', tit.crp <- paste0("on all '",select.family,"' family ",effectifs), ifelse (corpus=='objects',tit.crp <- paste0("on selected objects from the '", select.obj,"' list ",effectifs), tit.crp <- paste0("on all '",select.superfamily,"' super-family ",effectifs))) return(tit.crp) } f.dendro.color <- function(flag,df){ # TODO change column name 'color' to 'egdedist.color' # TODO SOMEWHERE ELS: create a column color named 'clust.color' for cluster results # df <- dim.obj ; flag <- flag.dendro.color if (flag){ # merge on dendrogramm colors df.colors <- subset(df.dist.mat.sel.ord,select=c("idf","color")) df <- merge(df,df.colors,by="idf",all.x=T) df$color[is.na(df$color)]<-"grey" #mytit <- paste0() } if (!flag){df$color <- "black"} return(df) } f.shapiro <- function(ds,thres,txt){ # normality test # thres <- 0.05 ; ds <- ugs.dim.complets$long_cm n <- length(ds) res.test <- shapiro.test(ds) p.value <- round(res.test$p.value,2) tit.test.incip <- paste0("Shapiro test on '",txt,"' shows distribution (n = ",n,") is ") tit.test.thres <- paste0("for threshold '",thres,"' (p-value=",p.value,")") tit.res.test <- ifelse(p.value > thres, paste0(tit.test.incip,"'normal' ",tit.test.thres), paste0(tit.test.incip,"'not normal' ",tit.test.thres) ) return(tit.res.test) } # opposite of %in% funct `%notin%` <- Negate(`%in%`) # loads graphs # selection of a list idx <- findex(ldecors.all,select.obj) ldecors <- ldecors.all[[idx]] # selection of group(s) idx <- findex(lgroups.all,select.obj) lgroups <- lgroups.all[[idx]] #Expert <- T shell.exec(paste0(chm.etude)) # open the folder #plot.a.graph(lgrph[[1]])
TODO: All iconography
FAMILY AND OBJECTS
listing TODO
Plot the dataframes of objets and variables
# export xlsx listing with hyperlinks for decoration graphs.objects <- create.graph.view(v.select.obj,corpus) # call function to create view objets <- objects.df(graphs.objects) # objects objets$idf <- rownames(objets) objets.imgs <- subset(objets,select=c("idf","lbl","img")) objets.imgs$img <- paste0("file:///",objets.imgs$img ) # for local hyperlinks class(objets.imgs$img) <- "hyperlink" # class write.xlsx(objets.imgs,paste0(chm.etude,"listing_images.xlsx"))
corpus
Objects with decorations, as stele, are grouped into families or types depending on their proximities (iconographic, etc.
list of decorations
# export indiviudal images of decorations to 'corpus' folder, ~ contactsheet f.img.list(select.superfamily) #
variables
f.nodes.plot <- function(nodes.a,sv){ # nodes - - - - - - - - - - - - for (n in 1:nrow(nodes.a)){ # n <- 1 ax <- nodes.a[n,"x"];ay <- abs(nodes.a[n,"y"]) if (sv %in% c("graph","ug_typo")){ nodecol <- nodes.a[n,"color.typo"] } if (sv == "ug_orient"){ nodecol <- nodes.a[n,"color.sens"] } if (sv == "ug_techno"){ nodecol <- nodes.a[n,"color.tek"] } if (sv == "ug_long_cm"){ nodecol <- nodes.a[n,"color.long_cm"] } if (sv == "ug_complet"){ nodecol <- nodes.a[n,"color.incomp"] } if (sv == "ug_chr_1"){ nodecol <- nodes.a[n,"color.chr_1"] } if (sv == "ug_tq"){ nodecol <- nodes.a[n,"color.tq"] } if (sv == "ug_closeness"){ nodecol <- nodes.a[n,"color.closeness"] } if (sv == "ug_betweenness"){ nodecol <- nodes.a[n,"color.betweenness"] } if (sv == "ug_degree"){ nodecol <- nodes.a[n,"color.degree"] } if (sv == "ug_domition"){ nodecol <- nodes.a[n,"color.domition"] } points(ax,ay, pch=21, col=nodecol, bg=nodecol, cex=nd.sz) } } f.labels.shadow <- function(x, y=NULL, labels, col='white', bg='black', theta= seq(0, 2*pi, length.out=50), r=0.1, ... ) { xy <- xy.coords(x,y) xo <- r*strwidth('A') yo <- r*strheight('A') # draw background text with small shift in x and y in background colour for (i in theta) { text( xy$x + cos(i)*xo, xy$y + sin(i)*yo, labels, col=bg, ... ) } # draw actual text in exact xy position in foreground colour text(xy$x, xy$y, labels, col=col, ... ) } f.labels.plot <- function(nodes.a,sv){ # labels - - - - - - - - - - - for (n in 1:nrow(nodes.a)){ ax <- nodes.a[n,"x"];ay <- abs(nodes.a[n,"y"]) if (sv == "graph"){ labeltext <- nodes.a[n,"id"] labelcol <- nodes.a[n,"color.typo"] } if (sv == "ug_typo"){ labeltext <- nodes.a[n,"type"] labelcol <- nodes.a[n,"color.typo"] } if (sv == "ug_orient"){ labeltext <- nodes.a[n,"sens"] labelcol <- nodes.a[n,"color.sens"] } if (sv == "ug_techno"){ labeltext <- nodes.a[n,"technologie"] labelcol <- nodes.a[n,"color.tek"] } if (sv == "ug_long_cm"){ labeltext <- nodes.a[n,"long_cm"] labelcol <- nodes.a[n,"color.long_cm"] } if (sv == "ug_complet"){ labeltext <- nodes.a[n,"id"] labelcol <- nodes.a[n,"color.incomp"] } if (sv == "ug_chr_1"){ labeltext <- ifelse(nodes.a[n,"chr_1"] != 'xxx',nodes.a[n,"chr_1"],'') labelcol <- nodes.a[n,"color.chr_1"] } if (sv == "ug_tq"){ labeltext <- ifelse(!is.na(nodes.a[n,"tpq"]), paste0(nodes.a[n,"tpq"],"/",nodes.a[n,"taq"]),'') labelcol <- nodes.a[n,"color.tq"] } if (sv == "ug_closeness"){ labeltext <- ifelse(!is.na(nodes.a[n,"closeness"]), round(nodes.a[n,"closeness"],2),'') labelcol <- nodes.a[n,"color.closeness"] } if (sv == "ug_betweenness"){ labeltext <- ifelse(!is.na(nodes.a[n,"betweenness"]), round(nodes.a[n,"betweenness"],2),'') labelcol <- nodes.a[n,"color.betweenness"] } if (sv == "ug_degree"){ labeltext <- ifelse(!is.na(nodes.a[n,"degree"]), nodes.a[n,"degree"],'') labelcol <- nodes.a[n,"color.degree"] } if (sv == "ug_domition"){ labeltext <- nodes.a[n,"domition"] labelcol <- nodes.a[n,"color.domition"] } f.labels.shadow(ax,ay, label=labeltext, col=labelcol, bg="white", cex=lab.sz, r=0.2, pos=3) # text(ax,ay, # pch=21, # label=labeltext, # col=labelcol, # bg=labelcol, # cex=lab.sz, # pos=3) } } f.edge.plot <- function(dd.edges,sv){ # loop through df and add edges to image for (e in 1:nrow(dd.edges)){ xa <- dd.edges[e,"xa"];ya <- abs(dd.edges[e,"ya"]) xb <- dd.edges[e,"xb"];yb <- abs(dd.edges[e,"yb"]) typseg <- dd.edges[e,"lty"] colseg <- dd.edges[e,"typ.color"] segments(xa,ya,xb,yb, col=colseg, lty=typseg) } } f.annotate <- function(img,sv,sit.a,num.a){ ## annotations # studied variable up img <- image_annotate(img, sv, size = 30, gravity = "northwest", color = "black") # decor title down tit.img <- paste0(sit.a,"\n",num.a) img <- image_annotate(img, tit.img, size = 30, gravity = "southwest", color = "black") }
lab.sz <- 1.2 nd.sz <- 1.7 colramp <- c("blue","darkgreen","darkorange","darkred") colfunc <- colorRampPalette(colramp) is.meta <- F verb <- F g.stats <- c("closeness","betweenness","degree") # names of the graph analysis functions if (is.meta){ # only for one graph/ for methodological purposes, -> doc/ chm.out.folder <- chm.doc idx <- findex(ldecors.all,"var_cs") # read the selected decor ldecors <- ldecors.all[[idx]] graphs <- create.graph.view("ico_l_var_cs","objects") # call function to create view lgrph <- load.graphs(graphs)[[1]] # load graphs df.icos <- f.df.ico("ico_l_var_cs") } if (!is.meta){ # for the whole corpus, ->var/ if(corpus=="family"){ chm.out.folder <- chm.var graphs <- create.graph.view(v.select.family,"family") # call function to create view crp.all <- objects.df(graphs) df.icos <- f.df.ico(v.select.family) } #crp.all <- crp.all[c(1:3),];df.icos <- df.icos[c(1:3),] # subset lgrph <- load.graphs(graphs)[[1]] # load graphs } # lgrph <- lgrph[13:16] # subset # lgrph[[1]]$id.in.serie if (verb){ print(paste0("Study of variables of ",length(lgrph)," graphs ", "saved in '",chm.out.folder,"' folder")) } for (a.gr in 1:length(lgrph)){ # loop through graphs # a.gr <- 4 g <- lgrph[[a.gr]] id.in.serie <- g$id.in.serie print(paste0("-",id.in.serie," ",g$name)) # df.icos <- f.df.ico(v.select.obj) # read nodes attributes g.df <- igraph::as_data_frame(g) sit.a <- unique(g.df$site) ; num.a<- unique(g.df$decor) ## edges - - - - - - - - - - - - - - - - - - - - - - - - - - - dd.edges <- edges.coordinates(sit.a,num.a) # edges dd.edges$typ[is.na(dd.edges$typ)] <- "=" # replace NA dd.edges$lty <- ifelse(dd.edges$typ == "+",2,1) dd.edges$typ.color <- ifelse(dd.edges$typ == "=","red",ifelse(dd.edges$typ == "x","blue","orange")) ## nodes - - - - - - - - - - - - - - - - - - - - - - - - - - - nodes.a <- nodes.df(sit.a,num.a) # get nodes # attributes and colors dd.edges.sub <- subset(dd.edges, typ == "+") nd.att <- dd.edges.sub$b nodes.a$is.attribute <- nodes.a$id %in% nd.att nodes.a$color.typo <- ifelse(nodes.a$is.attribute,"orange","red") # incomplet nodes.a$color.incomp <- ifelse(nodes.a$incomplet == 1,"grey","red") # long_cm llong_cm <- unique(as.numeric(na.omit(sort(nodes.a$long_cm)))) #♦ unique dim # n.colors <- brewer.pal(length(u.val),"Spectral"), # if no long then orange ifelse(length(llong_cm) > 2, n.colors <- colfunc(length(llong_cm)), ifelse(length(llong_cm) == 2, n.colors <- c(colramp[1],colramp[length(colramp)]), ifelse(length(llong_cm) == 1, n.colors <- "orange",n.colors <- "orange") ) ) # min, max, gradient color ramp for 'stat.graph' # add 0 when no long, TODO: change to 'X', clearer if(length(llong_cm)==0){llong_cm <- c(0)} df.long_cm <- data.frame(long_cm=llong_cm, color.long_cm=n.colors, stringsAsFactors = F) nodes.a <- merge(nodes.a,df.long_cm,by='long_cm',all.x=T)[,union(names(nodes.a),names(df.long_cm))] # chrono nodes.a$color.chr_1 <- ifelse(nodes.a$chr_1 == 'xxx',"grey","red") # # domition # nodes.a$domition <- ifelse(is.na(nodes.a$domition),"grey","red") # useful ? # tpq/taq nodes.a$color.tq <- ifelse(is.na(nodes.a$tpq),"grey","red") # verb <- T for (a.stat in g.stats){ # a.stat <- "closeness" if (verb){ print(paste0(" '",a.stat,"' measurement centralities")) } # get site & decor g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>') gt.i.val <- eval(parse(text = paste0("as.data.frame(",a.stat,"(g))"))) # print(paste0(" ",i,") read '",gt.i,"' for graph ",g$name)) #idf.g <- unique(vertex_attr(g, "idf", index = V(g))) # idf # path name of the function colnames(gt.i.val)[1] <- a.stat # modify function name #clos <- as.data.frame(closeness(g)) #gt.i.val$dec <- unique(vertex_attr(g, "idf", index = V(g))) # idf #clos$dec <- g$name nd.ids <- get.vertex.attribute(g, "id", index=V(g)) gt.i.val$id <- nd.ids # remplace ids with nodes ids # merge nodes.a <- merge(nodes.a,gt.i.val,by='id',all.x=T)[,union(names(nodes.a),names(gt.i.val))] # reset ? # } # ## values & colors - - - - - - - - - - - - - - - - # # from graph centralities # for (a.stat in g.stats){ # # a.stat <- "degree" # if (verb){ # print(paste0(" '",a.stat,"' measurement centralities")) # } u.val <- as.numeric(na.omit(unique(nodes.a[,a.stat]))) # remove NA # nb of different color to display ifelse(length(u.val)>2, n.colors <- colfunc(length(u.val)), # n.colors <- brewer.pal(length(u.val),"Spectral"), n.colors <- c(colramp[1],colramp[2])) # gradient color ramp for 'stat.graph' if(length(u.val)==0){ a.stat.col.df <- data.frame(val=numeric(0), col=character(0), stringsAsFactors = F) } if(length(u.val)>0){ a.stat.col.df <- data.frame(val=u.val, col=n.colors, stringsAsFactors = F) } colnames(a.stat.col.df)[1] <- a.stat # modify with function name colnames(a.stat.col.df)[2] <- paste0('color.',a.stat) # modify with function name a.stat.col.df[nrow(a.stat.col.df) + 1,] = c(NA,"#D3D3D3") # add NA as light grey nodes.a <- merge(nodes.a,a.stat.col.df,by=a.stat,all.x=T)[,union(names(nodes.a),names(a.stat.col.df))] # merge } # from GIS (y, x) # high (domition) reversed high.df <- data.frame(y=rev(sort(nodes.a$y)), domition=length(nodes.a$y):1) ifelse(nrow(high.df)>2, n.colors <- colfunc(nrow(high.df)), # n.colors <- brewer.pal(length(u.val),"Spectral"), n.colors <- c(colramp[1],colramp[2])) # gradient color ramp for 'stat.graph' high.df$color.domition <- rev(n.colors) nodes.a <- merge(nodes.a,high.df,by="y",all.x=T)[,union(names(nodes.a),names(high.df))] # merge # TODO: rank from central feature - - - - - - # library(aspace) # xy <- data.frame(a=nodes.a$x,b=nodes.a$y) # res.cf <- CF(points=xy) # calcultate the central feature # - - - - - - - - - - - - - - - - - - - - - - # colors from attributes # nodes.a$color.typo <- ifelse(nodes.a$type == 'indet','grey','red') # color on 'typo' nodes.a$color.chr <- ifelse(is.na(nodes.a$tpq),'grey','red') # color on 'tpq' nodes.a$color.sens <- ifelse(is.na(nodes.a$sens),'grey','red') # color on 'sens' # nodes.a$color.long_cm <- ifelse(is.na(nodes.a$long_cm),'grey','red') # color on 'long_cm' nodes.a$color.tek <- ifelse(is.na(nodes.a$technologie),'grey', ifelse(nodes.a$technologie == 'g_piq','orange', ifelse(nodes.a$technologie == 'g_inc','violet', 'blue'))) ## labels - - - - - - - - - - - - - - - - # label from attributes, italic if 'incomplet' nodes.a$lbl.long_cm <- ifelse(nodes.a$incomplet == 1, paste0("italic('", as.character(nodes.a$long_cm), "')"),as.character(nodes.a$long_cm)) ## get nodes, edges and image # image img.a <- df.icos[df.icos$site == sit.a & df.icos$num == num.a,]$img # image img.a <- image_read(img.a) # list of studied var studied.vars <- c("graph","ug_typo","ug_orient","ug_techno", "ug_long_cm","ug_complet", "ug_domition", "ug_chr_1","ug_tq", "ug_closeness","ug_betweenness","ug_degree") # studied.vars <- c("ug_long_cm") # studied.vars <- c("graph", # "ug_domition", # "ug_degree") for (sv in studied.vars){ # loop through studied vars and plot infos # sv <- "ug_long_cm" chm.out <- paste0(chm.out.folder,id.in.serie,'_',sit.a,'_',num.a,'_',sv,'.png') img <- image_draw(img.a) # plot the graph with nodes numbers f.edge.plot(dd.edges) # edges f.nodes.plot(nodes.a,sv) f.labels.plot(nodes.a,sv) img <- f.annotate(img,sv,sit.a,num.a) image_write(img,chm.out) } if (verb){ print (paste0(' *SAVED*')) } graphics.off() # close all }
# this chunk crask because of ggplot/magick stuff corpus <- "family" # choose 'objects' or 'family' g.img <- c("g.grp","g.thm","g.chr","g.ort","g.dim","g.tek") # list of img to plot writ.imgs <- F # write images in 'corpus' folder ? idx <- findex(ldecors.all,"var_cs") # read the selected decor ldecors <- ldecors.all[[idx]] graphs <- create.graph.view("ico_l_var_cs","objects") # call function to create view lgrph <- load.graphs(graphs)[[1]] # load graphs crp.all <- objects.df(graphs) df.icos <- f.df.ico("ico_l_var_cs") is.meta <- T a.contact.sheet <- paste0(chm.doc,"ico_contactsheet_xxx.png") # save in 'D:/Projet Art Rupestre/decors/doc/' contact.sheet.var(lgrph,crp.all,df.icos,g.img,writ.imgs,is.meta) # create cs #include_graphics(a.contact.sheet) shell.exec(a.contact.sheet) # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # TODO: # put the following instructions in the function "contact.sheet.grph" # see "D:\Projet Art Rupestre\scripts\scripts_r" file "graph_analysis_by_var" working well # but function "contact.sheet.grph()" do not create legend, or create problems # (sic) # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ll.graphs <- list() n.img <- length(g.stats) n.dec <- length(lgrph) siz.of.img <- 4 v.box.padding <- .04 v.label.padding <- .08 # e.label.padding <- round(v.label.padding*e.coef.cex,2) v.segment.size <- .4 v.cex.txt <- 1.5 #e.cex.txt <- round(v.cex.txt*e.coef.cex,2) v.cex.node <- .8 for (a.g in 1:n.dec){ # a.g <- 1 g <- lgrph[[a.g]] a.sit <- unique(get.vertex.attribute(g, "site", index=V(g))) a.dec <- unique(get.vertex.attribute(g, "decor", index=V(g))) a.idf <- unique(get.vertex.attribute(g, "idf", index=V(g))) g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>') # gt.index.df <- c("closeness") # names of the graph analysis functions for (gt.i in g.stats){ # gt.i <- "closeness" print(paste0("'",gt.i,"' measurement centralities")) # path name of the function gt.i.val <- eval(parse(text = paste0("as.data.frame(",gt.i,"(g))"))) colnames(gt.i.val)[1] <- "stat.graph" # modi fy function name u.gt.i.val <- sort(unique(gt.i.val$stat.graph),decreasing = T) # unique vals # change id g.ids <- get.vertex.attribute(g, "id", index=V(g)) g <- set.vertex.attribute(g, "name", value=g.ids) g.df <- igraph::as_data_frame(g, what="vertices") g.df <- merge(g.df,gt.i.val,by="row.names") # merge 'g' and 'gt.i.val' g.df <- subset(g.df,select=c("name","id","type","x","y","stat.graph")) # # order on 'stat.graph' value and color # g.df <- g.df[with(g.df, order(-stat.graph)), ] # row.names(g.df) <- 1:nrow(g.df) n.colors <- brewer.pal(length(u.gt.i.val),"Spectral") # gradient color ramp for 'stat.graph' df.color <- data.frame(stat.graph=u.gt.i.val, stat.graph.color=n.colors) # merge color and df g.df <- merge(g.df,df.color,by="stat.graph",all.x=T) # g.df$stat.graph.color <- n.colors # image img.a <- df.icos[df.icos$site == a.sit & df.icos$num == a.dec,]$img # image img.exist <- !(is.na(img.a) | img.a=="") if (!img.exist){a.img <- image_read(paste0(chm.obj,"/empty_obj.gif"))} if (img.exist){a.img <- image_read(img.a)} # read image a.text <- paste0("nodes '",gt.i,"'") # a.img <- image_annotate(a.img,a.text, size = annot.size, # gravity = "north", color = "black") a.image <- image_ggplot(a.img) # convert image-magick to ggplot z.image <- a.image + ggtitle(a.text)+ geom_point(data=g.df,x=g.df$x,y=g.df$y,aes(color=g.df$stat.graph.color),cex=2)+ geom_label_repel(data=g.df,x=g.df$x,y=g.df$y, label=paste0(g.df$type,"\n",round(g.df$stat.graph,2)), box.padding = unit(v.box.padding, "lines"), label.padding = unit(v.label.padding, "lines"), segment.size = v.segment.size, color=g.df$stat.graph.color, cex=1.5)+ scale_colour_identity(guide="legend",breaks=n.colors,labels=round(u.gt.i.val,2))+ theme(legend.title = element_text(size = 7), legend.text = element_text(size = 7))+ labs(color=paste0(a.text,"\nvalues")) # img.out <- ggsave_to_variable(z.image,siz.of.img+1,siz.of.img,300) # img.out %>% magick::image_write(n.file) if(is.meta){ # save images separetly n.file <- paste0(chm.doc,as.character(a.g),"_stats_graph_",gt.i,".png") ggsave(n.file,z.image, height = siz.of.img, width = siz.of.img+1,limitsize = FALSE) } ll.graphs[[length(ll.graphs)+1]] <- z.image } } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # create a planche of contact of m x n images margin = theme(plot.margin = unit(c(0.5,0.5,0.5,0.5), "cm")) if(!is.meta){ for (dev in c(".png",".pdf")){ a.contact.sheet <- paste0(chm.analysis,"/stats_ugs.png") ggsave(file = a.contact.sheet, arrangeGrob(grobs = lapply(ll.graphs, "+", margin), padding = unit(0.05, "line"), ncol = n.img), height = n.dec*siz.of.img, width = n.img*siz.of.img, dpi=300, limitsize = FALSE) } } # if(is.meta){ # a.contact.sheet <- paste0(chm.doc,"stats_graph_ugs.png") # ggsave(file = a.contact.sheet, # arrangeGrob(grobs = lapply(ll.graphs, "+", margin), padding = unit(0.05, "line"), ncol = n.img), # height = n.dec*siz.of.img, # width = n.img*(siz.of.img+1), dpi=300, # # height = length(g.img)*siz.of.img, # # width = nrow(crp)*siz.of.img, dpi=300, # limitsize = FALSE) # } print(paste0(" ",a.contact.sheet," saved !")) # r.start <- r.end+1 # increment start # r.end <- r.end+max.row.cs # #grid.arrange(grobs = ll.dec, ncol = 3)
contactsheet & variables TODO
# create one cs with all decoration from family # select 'select.familiy' or 'select.obj' # fill the 'corpus' folder # TODO: create fucking contact sheet n.col <- 10 f.family.contactsheet(select.family,n.col) #
# plot var values for each decorations corpus <- "family" # choose 'objects' or 'family' g.img <- c("g.grp","g.thm","g.chr","g.ort","g.dim","g.tek") # list of img to plot # g.img <- c("g.grp","g.thm") # list of img to plot writ.imgs <- F # write images in 'corpus' folder ? #graphs <- create.graph.view(v.select.obj,corpus) # call function to create view if(corpus=="objects"){ graphs <- create.graph.view(v.select.obj,"objects") # call function to create view crp.all <- objects.df(graphs) df.icos <- f.df.ico(v.select.obj) } # 'graphs.objects' or 'graphs.family' if(corpus=="family"){ graphs <- create.graph.view(v.select.family,"family") # call function to create view crp.all <- objects.df(graphs) df.icos <- f.df.ico(v.select.family) } #crp.all <- crp.all[c(1:3),];df.icos <- df.icos[c(1:3),] # subset is.meta <- F lgrph <- load.graphs(graphs)[[1]] # load graphs contact.sheet.var(lgrph,crp.all,df.icos,g.img,writ.imgs,is.meta) # create cs #shell.exec(a.contact.sheet)
spatial
general map
# map of all the objetc of a selected family map.type <- "family"; m.var <- "all" family.spat <- family.df(select.family) # get objects coordinates for the family # family.spat$idf <- as.integer(row.names(family.spat)) family.spat$idf <- as.integer(family.spat$idf.objects) family.spat <- family.spat[with(family.spat, order(idf)), ] # family.spat <- family.spat[c(1:15),] # sample rownames(family.spat) <- family.spat$idf sf.fd.carto <- f.spat.bck.grd("Europe") # load background g.map <- f.spat.distrib(family.spat,sf.fd.carto,map.type,select.family,m.var,25,8) # create map tit <- paste0("distribution of '",m.var,"' from '", map.type,"' objects of '",select.family,"' (n=",nrow(family.spat),")") if(map.type == "family"){ chm.out <- paste0(chm.etude,"spat_",select.family,".png") } if(map.type != "family"){ chm.out <- paste0(chm.etude,"_",select.family,"_spat.png") } ggsave(file = chm.out, arrangeGrob(grobs = g.map, top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)), padding = unit(0.1, "line"),ncol = 1), width = 17,height =17) shell.exec(chm.out)
K-Ripley map
library(ggthemes) # map of all the objetc of a selected family # TODO R/R internet: ggthemes::geom_rug # TODO: data ellipse center : start from central features and n nearest neighbours # TODO: projected SRID for Kripley spain.crs <- "+init=epsg:25830" perc.dat <- 0.6 # percent of selected data map.type <- "family"; m.var <- "all" family.spat <- family.df(select.family) # get objects coordinates for the family # family.spat$idf <- as.integer(row.names(family.spat)) family.spat$idf <- as.integer(family.spat$idf.objects) family.spat <- family.spat[with(family.spat, order(idf)), ] rownames(family.spat) <- family.spat$idf sf.fd.carto <- f.spat.bck.grd("Europe") # load background xy <- family.spat[,c("x","y")] # objects sp.obj.prj <- SpatialPointsDataFrame(coords = xy, data = family.spat, proj4string= CRS(wgs84)) ell <- dataEllipse(xy$x, xy$y, levels=perc.dat) # get a 60% data ellipse ell <- f.xy.to.sp(ell) # convert ellispe to polygon sel.obj <- gIntersection(ell, sp.obj.prj) # objects within the data ellipse sel.obj.dt <- data.frame(sel.obj) # for ggplot xy <- coordinates(sel.obj) # points coordinates ch <- chull(xy) # convexhull coords <- xy[c(ch, ch[1]), ] # closed convexhull polygon # convexhull to SpatialPolygon sp.cxhl <- SpatialPolygons(list(Polygons(list(Polygon(coords)), ID=1))) proj4string(sp.cxhl) <- CRS(wgs84) sp.cxhl.df <- SpatialPolygonsDataFrame(sp.cxhl, data=data.frame(ID=1)) # plot(xy, pch=19);lines(coords, col="red") # plot sf.obj <- st_as_sf(sp.obj.prj) # convert to sf roi <- st_bbox(sf.obj) # create polygon from bbox on objets # add margins roi[1]<-roi[1]-spat.marg;roi[2]<-roi[2]-spat.marg;roi[3]<-roi[3]+spat.marg;roi[4]<-roi[4]+spat.marg roi.sf <- st_as_sfc(roi) # create polygon from bbox on objets sf.fd.carto.inter <- st_intersection(sf.fd.carto, roi.sf) # recut background sp.obj.dt <- data.frame(sp.obj.prj) ct <- 1 # all dataset tit.all <- paste0("map of all '",select.obj,"' decorations (in red)") g.all.pts <- ggplot2::ggplot(sf.fd.carto.inter) + ggtitle(paste0(ct,". ",tit.all))+ geom_sf(aes(geometry = geometry),fill = NA)+ geom_point(data= sp.obj.dt, aes(x=x, y=y), color="red")+ annotation_scale(location = "bl", height = unit(0.15,"cm"), width_hint = 0.2)+ #geom_point(data=objets, aes(x=x,y=y),cex=1)+ theme_bw() # .. + ellipse tit.ell <- paste0(tit.all,"\nwith ",perc.dat*100,"% selection data ellipse (in blue)") ct <- ct+1 g.all.pts.ell <- ggplot2::ggplot(sf.fd.carto.inter) + ggtitle(paste0(ct,". ",tit.ell))+ geom_sf(aes(geometry = geometry),fill = NA)+ geom_point(data= sp.obj.dt, aes(x=x, y=y), color="red")+ # geom_sf(data=ell) geom_polygon(data=ell,aes(x = long, y = lat), color="blue",fill=NA)+ annotation_scale(location = "bl", height = unit(0.15,"cm"), width_hint = 0.2)+ #geom_point(data=objets, aes(x=x,y=y),cex=1)+ theme_bw() # selected decorations tit.select <- paste0("map of objects inside the ellipse (selected '",select.obj,"' decorations, in red)") ct <- ct+1 g.select.pts <- ggplot2::ggplot(sf.fd.carto.inter) + ggtitle(paste0(ct,". ",tit.select))+ geom_sf(aes(geometry = geometry),fill = NA)+ geom_point(data= sp.obj.dt, aes(x=x, y=y), color="grey", alpha=.8)+ geom_point(data= sel.obj.dt, aes(x=x, y=y), color="red")+ annotation_scale(location = "bl", height = unit(0.15,"cm"), width_hint = 0.2)+ #geom_point(data=objets, aes(x=x,y=y),cex=1)+ theme_bw() # .. + convexhull tit.select.cvhl <- paste0(tit.select, "\nwith convexhull as K-Ripley window (in green)") ct <- ct+1 g.select.pts.cvhl <- ggplot2::ggplot(sf.fd.carto.inter) + ggtitle(paste0(ct,". ",tit.select.cvhl))+ geom_sf(aes(geometry = geometry),fill = NA)+ geom_point(data= sp.obj.dt, aes(x=x, y=y), color="grey", alpha=.8)+ geom_point(data= sel.obj.dt, aes(x=x, y=y), color="red")+ # geom_sf(data=ell) geom_polygon(data=sp.cxhl,aes(x = long, y = lat), color="green",fill=NA)+ annotation_scale(location = "bl", height = unit(0.15,"cm"), width_hint = 0.2)+ #geom_point(data=objets, aes(x=x,y=y),cex=1)+ theme_bw() # inside convexhull # TODO: pass to metric system sel.obj.prj <- spTransform(sel.obj,CRS(spain.crs)) sel.obj.prj.dt <- data.frame(sel.obj.prj) # for ggplot sp.cxhl.prj <- spTransform(sp.cxhl,CRS(spain.crs)) sf.fd.carto.inter.1 <- st_intersection(sf.fd.carto, st_as_sfc(sp.cxhl)) # recut background sf.fd.carto.inter.1.prj <- st_transform(sf.fd.carto.inter.1,25830) tit.select.in.cvhl <- paste0(tit.select,"\ninside the convexhull (region of interest, ROI)") ct <- ct+1 g.select.pts.in.cvhl <- ggplot2::ggplot(sf.fd.carto.inter.1.prj) + ggtitle(paste0(ct,". ",tit.select.in.cvhl))+ geom_sf(aes(geometry = geometry),fill = NA)+ # coord_sf(crs=st_crs(25830))+ coord_sf(datum=spain.crs)+ geom_point(data= sel.obj.prj.dt, aes(x=x, y=y), color="red")+ # geom_sf(data=ell) geom_polygon(data=sp.cxhl.prj,aes(x = long, y = lat), color="green",fill=NA)+ annotation_scale(location = "bl", height = unit(0.15,"cm"), width_hint = 0.2)+ #geom_point(data=objets, aes(x=x,y=y),cex=1)+ theme_bw() # sf.fd.carto.inter.1 <- st_intersection(sf.fd.carto, st_as_sfc(sp.cxhl)) # recut background # tit.select.in.cvhl <- paste0(tit.select,"\ninside the convexhull (ROI)") # g.select.pts.in.cvhl <- ggplot2::ggplot(sf.fd.carto.inter.1) + # ggtitle(tit.select.in.cvhl)+ # geom_sf(aes(geometry = geometry),fill = NA)+ # geom_point(data= sel.obj.dt, aes(x=x, y=y), color="red")+ # # geom_sf(data=ell) # geom_polygon(data=sp.cxhl,aes(x = long, y = lat), color="green",fill=NA)+ # annotation_scale(location = "bl", # height = unit(0.15,"cm"), # width_hint = 0.2)+ # #geom_point(data=objets, aes(x=x,y=y),cex=1)+ # theme_bw() # K-Ripley # sel.obj.prj <- spTransform(sel.obj,CRS(spain.crs)) # # sel.objxx <- as(st_multipoint(st_as_sf(sel.obj)),"Spatial") # sp.cxhl.prj <- spTransform(sp.cxhl,CRS(spain.crs)) w <- as.owin(sp.cxhl.prj) # convert to owin obj Kpts <- ppp(coordinates(sel.obj.prj)[,1], coordinates(sel.obj.prj)[,2], window=w) L <- Lest(Kpts,correction="Ripley") # L-Besag env.data <- as.data.frame(L) # to dataframe l.stats <- colnames(env.data) tit.select.krip <- paste0("L-Besag function of selected '",select.family,"' inside the ROI") ct <- ct+1 # plot g.select.pts.krip <- ggplot(env.data, aes(r, iso))+ ggtitle(paste0(ct,". ",tit.select.krip))+ # observed value geom_line(aes(colour=c("#4d4d4d")))+ # Poisson value # axes names and limits ylim(min(env.data$theo)-1, max(env.data$theo)+2) + xlab("distance (m)") + ylab("K(d)")+ theme_bw()+ theme(legend.position = c(0.1,.8)) # theme(legend.position = "left") lbls <- c("L.iso(r)") if ("theo" %in% l.stats){ g.select.pts.krip <- g.select.pts.krip + geom_line(aes(r,theo,colour=c("red")),linetype = "dashed") lbls <- c(lbls,"L.theo(r)") } if ("border" %in% l.stats){ g.select.pts.krip <- g.select.pts.krip + geom_line(aes(r,theo,colour=c("blue")),linetype = "dashed") lbls <- c(lbls,"L.bord(r)") } # append legend g.select.pts.krip <- g.select.pts.krip + scale_color_discrete(name="stats",labels = lbls) # save g.out <- paste0(chm.spatial,"kripley.png") gg.kripley <- ggpubr::ggarrange(g.all.pts, g.all.pts.ell, g.select.pts,g.select.pts.cvhl, g.select.pts.in.cvhl,g.select.pts.krip, ncol = 2, nrow = 3) #, align = "hv", #widths = c(5,1), heights = c(5,1), #common.legend = TRUE) ggsave(file = g.out, gg.kripley, width = 12, height=16) shell.exec(g.out)
statistics
dimensions
# 3 diffrent plots: formats, Lxl, ternary plot # TODO : plot 'self' = anthropomorphe # TODO : plot objet 'incomplet' # TODO : change 'geom_rect' to 'geom_ellispe' when 'self' = anthropomorphe #df[sample(nrow(df),10),"self"] <- 1 gdim.formats <- function(df, n.tot){ # TODO: not plot by list, here 'grp' var # df <- dim.obj.Ll # - -- - - - - - - - - - - - - - - - - - - - - - - n.incomplet <- nrow(dim.obj.Ll[dim.obj.Ll$incomplet==1,]) mytit <- paste0("supports dimensions formats in cm (height x width) for '",select.family,"' family", "\n",nrow(df)," with recorded dimensions on a total of ",n.tot," supports", "\nanthropomorphic supports are displayed in 'blue'", "\ntransparent and italic decorations names identify fragmentary supports", " (",n.incomplet," incompletes)") # BLUE OR GREY ll.dims <- list() # all formats as rectangles # for (grp in 1:nrow(df)){ for (grp in 1:max(df$grp)){ # for (grp in df$grp){ # grp <- 2 df.grp <- df[df$grp == grp,] #df.grp <- df[grp,] #gg.dim.formats <- ggplot(df.grp, aes(fill=ifelse(!is.na(self),"red","grey70")))+ # gg.dim.formats <- ggplot(df.grp) + gg.dim.formats <- ggplot(df) + #ggtitle("Supports dimensions in cm (height x width)")+ # anthropomrphe or not geom_rect(aes(xmin = 0, xmax = larg, ymin = 0, ymax = long, fill = ifelse(self == 'anthropomorphe', "blue", "red")), alpha = .5 ) + # dimensions geom_text(aes(x=larg/2+((larg/2)/2),y=long,label=larg, alpha = ifelse(incomplet == 0,1,.6), fontface = ifelse(incomplet == 0,"plain","italic")), hjust=0,size=2.5,parse = F) + geom_text(aes(x=larg,y=long/2,label=long, alpha = ifelse(incomplet == 0,1,.6), fontface = ifelse(incomplet == 0,"plain","italic")), hjust=0,angle=270,size=2.5,parse = F) + # name of the object geom_text(aes(x=larg/2,y=5,label=lbl, alpha = ifelse(incomplet == 0,1,.6), fontface = ifelse(incomplet == 0,"plain","italic")), hjust=0,angle=90,size=3.5,parse = F) + xlab("width (cm)")+ylab("height (cm)") + facet_grid( . ~idf) + coord_fixed() + theme_bw() + theme(plot.title = element_text(size = 9), axis.line = element_blank(), panel.border = element_blank(), panel.background = element_blank()) + scale_colour_identity() + scale_fill_identity() + scale_alpha_identity() + theme(legend.position = "none") #scale_color_manual(guide=FALSE, values=c("red", "grey70"))+ #turn off the legend, define the colors+ ll.dims[[length(ll.dims)+1]] <- gg.dim.formats } #☻tG <- textGrob(mytit) margin = theme(plot.margin = unit(c(0,0,0,0), "cm")) g.out <- paste0(chm.analysis.o.dimensions,"obj_dim_formats.png") # ggsave(file = g.out, # arrangeGrob(grobs = list(tG,ll.dims), # #top = grid::textGrob(mytit,x=0,hjust=0,gp = gpar(fontsize =10)), # padding = unit(0, "line"), ncol = 1), # width = 10, height=ceiling(nrow(df)/10)*3+1) ggsave(file = g.out, arrangeGrob(grobs = lapply(ll.dims, "+", margin), top = grid::textGrob(mytit,x=0,hjust=0,gp = gpar(fontsize =10)), padding = unit(0.5, "line"), ncol = 1), width = 15, height=ceiling(nrow(df)/10)*3+1) } #gdim.formats(dim.obj.Ll,n.tot) gdim.reg <- function(df,n.tot){ # TODO : plot as much as regline depending on clusters/groups # - - - - - - - - - - - - - - - - - - - - - - - - - # 2 dimensions - - - - - - - - - - # df <- dim.obj.Ll # df.data <- df[df$long > 0,] # df.data <- df[df$larg > 0,] # exclude incomplets from reg # df[is.na(df$incomplet),"incomplet"] <- 0 # df <- dim.obj.Ll min.L <- min(df$long);max.L <- max(df$long)+5 min.l <- min(df$larg);max.l <- max(df$larg)+5 df.incomplets <- df[df$incomplet == 1,] df.complets <- df[df$incomplet == 0,] # normality shapiro.L <- f.shapiro(df.complets$long,0.05,"height") shapiro.l <- f.shapiro(df.complets$larg,0.05,"width") # mean m.L <- mean(df.complets$long);m.l <- mean(df.complets$larg) df.mean <- data.frame(L=m.L, l=m.l) fit <- lm(long ~ larg, data = df.complets) reg.coef <- signif(summary(fit)$adj.r.squared, 5) mytit <- paste0("supports dimensions in cm (height x width) with numeros (",nrow(df)," supports)", "\nlinear regression (R2 = ",round(reg.coef,2),") for complete supports", "\nmarginal plots show heights (right) and widths (bottom) for complete supports", " with averages in cm (in red)", "\n",shapiro.L,"\n",shapiro.l, "\nanthropomophic supports are displayed by squares", "\ntransparent and italic decorations names identify incomplete supports", " (",nrow(df.incomplets)," incompletes)") # BLUE OR GREY) if(flag.dendro.color){mytit <- paste0(mytit,"\ncolors refer to dendrogram classification except black symbols out of classification")} # scatterplot gg.dim.2 <- ggplot(df,aes(x=larg,y=long,colour=color,shape=self.shp))+ ggtitle(mytit)+ stat_smooth(data=df.complets, method = "lm", col = "red", alpha=0.3)+ # incomplets geom_point(data=df.incomplets,cex=1.5,alpha=.5)+ geom_text_repel(data=df.incomplets,aes(label=idf,fontface ="italic"),alpha=.5,size=3)+ # complets geom_point(data=df.complets,cex=1.5)+ geom_text_repel(data=df.complets,aes(label=idf),size=3)+ theme_bw()+ xlab("width (cm)")+ylab("height (cm)")+ theme(plot.title = element_text(size = 9), axis.text = element_text(size = 7), axis.title = element_text(size = 8), axis.line = element_blank(), panel.border = element_blank(), panel.background = element_blank())+ scale_colour_identity()+ scale_shape_identity()+ scale_x_continuous(position = "top", limits = c(min(df$larg), max.l))+ ylim(min(df$long), max.L)+ theme(legend.position = "none") ## marginales plots # width/larg - horizontal marginal boxplot - to appear at the bottom of the chart hbp <- ggplot(df.complets, aes(x=factor(1),y=larg)) + geom_boxplot(outlier.colour = NA,lwd=0.3) + geom_jitter(position = position_jitter(width = 0.05)) + # mean geom_point(data=df.mean,x=1,y=df.mean$l,shape=3,size=4,color="red")+ geom_text_repel(data=df.mean, x=1,y=df.mean$l,label=round(df.mean$l,1), color="red",cex=3.5, nudge_x = 1.5) + ylim(min(df$larg), max.l) + coord_flip() + theme_bw()+ theme(axis.text = element_blank(), axis.title = element_blank(), axis.ticks = element_blank(), panel.border = element_blank()) # heights/long - vertical marginal boxplot - to appear at the right of the chart vbp <- ggplot(df.complets, aes(x=factor(1),y=long)) + geom_boxplot(outlier.colour = NA,lwd=0.3) + geom_jitter(position = position_jitter(width = 0.05)) + # mean geom_point(data=df.mean,x=1,y=df.mean$L,shape=3,size=4,color="red")+ geom_text_repel(data=df.mean, x=1,y=df.mean$L,label=round(df.mean$L,1), color="red",cex=3.5, nudge_x = -1)+ ylim(min(df$long), max.L)+ theme_bw()+ theme(axis.text = element_blank(), axis.title = element_blank(), axis.ticks = element_blank(), panel.border = element_blank()) gg.2reg <- ggpubr::ggarrange(gg.dim.2, vbp,hbp,NULL, ncol = 2, nrow = 2, align = "hv", widths = c(5,1), heights = c(5,1), common.legend = TRUE) g.out <- paste0(chm.analysis.o.dimensions,"obj_dim_lin.png") # save ggsave(file = g.out, gg.2reg, width = 12, height=12) } # gdim.reg(dim.obj.Ll,n.tot) # - - - - - - - - - - - - - - - - - - - - - - - - - gdim.tern <- function(df,n.tot){ # ternary diagram for epaisseur # TODO : plot self = anthropomorphe;closeup on data df.tri <- df[!is.na(df$long) & !is.na(df$larg) & !is.na(df$epai),] Tmax <- max(df.tri$long) Lmax <- max(df.tri$larg) Rmax <- max(df.tri$epai) tit <- paste0("supports dimensions in cm (height, width and depth)", "\nwith numeros of decorations", "\ntransparent and italic decorations names identify fragmentary supports") g.tern <-ggtern(data=df.tri,aes(long,larg,epai,colour=color)) + #geom_point() + ggtitle(tit)+ geom_text(aes(label=idf, alpha = ifelse(incomplet==0,1,.6), fontface = ifelse(incomplet==0,"plain","italic")), size=3)+ scale_colour_identity()+ scale_alpha_identity()+ theme_bw()+ theme_showarrows()+ theme(legend.position = "none")+ scale_alpha_identity() #tern_limits(T=max(Tmax), L=max(Lmax), R=max(Rmax)) g.out <- paste0(chm.analysis.o.dimensions,"obj_dim_ternaire.png") ggsave(file = g.out, width = 12, height=12) } #"ico_l_stele_bouclier" v.select.obj graphs.objects <- create.graph.view(v.select.obj,"family") # call function to create view objets <- objects.df(graphs.objects) # objects dim.obj <- subset(objets,select=c("idf", "numero", "lbl", "long", "larg", "epai", "self", "self.shp","incomplet")) dim.obj$idf <- as.integer(dim.obj$idf) n.tot <- nrow(dim.obj) dim.obj.Ll <- dim.obj[!is.na(dim.obj$long) & !is.na(dim.obj$larg),] dim.obj.Ll <- dim.obj.Ll[dim.obj.Ll$long > 0 & dim.obj.Ll$larg > 0,] #dim.obj.Ll <- dim.obj[is.na(dim.obj$lbl),] row.names(dim.obj.Ll) <- 1:nrow(dim.obj.Ll) # rename on selected dim.obj.Ll$grp <- ceiling(as.numeric(row.names(dim.obj.Ll))/10) # to plot formats #dim.obj.Ll$grp <- ceiling(dim.obj.Ll$idf/10) # to plot dim.obj.Ll <- f.dendro.color(flag.dendro.color, dim.obj.Ll) # call plots head(dim.obj.Ll) dim.obj.Ll <- dim.obj.Ll[dim.obj.Ll$numero %in% gr1.steles, ] gdim.formats(df = dim.obj.Ll, n.tot = n.tot) gdim.reg(dim.obj.Ll,n.tot) dim.obj.Lle <- dim.obj.Ll[!is.na(dim.obj.Ll$epai),] # gdim.tern(dim.obj.Lle,n.tot) # PRB with ggtern #shell.exec(g.out)
raw material
pie chart
l.objet <- family.df(select.family) mp.tab <- f.var("mp") df.objet.mp <- as.data.frame(table(l.objet$mp)) # effectifs # merge on type of mp df.objet.mp <- merge(df.objet.mp,mp.tab,by.x="Var1",by.y="mp",all.x=T) df.objet.mp$mp_colors[is.na(df.objet.mp$mp_colors)] <- 'white' nb.val <- length(unique(df.objet.mp$Freq)) # reorder df.objet.mp <- df.objet.mp[with(df.objet.mp, order(Freq)), ] df.objet.mp$mp_colors <- factor(df.objet.mp$mp_colors,levels = df.objet.mp$mp_colors) tit <- paste0("raw materials of '",select.family,"' family (n = ", nrow(l.objet[l.objet$mp != 'unknown',])," with raw material recorded)") # plot gg.mp <- ggplot(data = df.objet.mp, aes(x = "", y = Freq, fill = mp_colors)) + ggtitle(tit)+ geom_bar(stat = "identity") + #bck geom_text(aes(label = Freq, fontface="bold"), color="white",position = position_stack(vjust = 0.5),cex=4) + geom_text(aes(label = Freq), color="black",position = position_stack(vjust = 0.5),cex=4) + coord_polar(theta = "y") + blank_theme + theme(plot.title = element_text(size = 9), legend.title = element_text(size = 8), legend.text = element_text(size = 7), legend.key.size = unit(1,"line"), axis.text.x=element_blank())+ scale_fill_identity("mp",guide = "legend",labels = df.objet.mp$Var1) g.out <- paste0(chm.analysis.o.rawmaterial,"stat_raw_materials.png") ggsave(g.out, gg.mp) shell.exec(g.out)
spatial
# TODO: K-ripley map.type <- "family" m.var <- "mp" mp.tab <- f.var("mp") # named vector mp.colors <- mp.tab$mp_colors names(mp.colors) <- as.character(mp.tab$mp) family.spat <- family.df(select.family) # get objects coordinates for the family family.spat$idf <- as.integer(family.spat$idf.objects) # family.spat <- family.spat[c(1:15),] # sample sf.fd.carto <- f.spat.bck.grd("Europe") # load background g.map <- f.spat.distrib(family.spat,sf.fd.carto,map.type,select.family,m.var,25,8) # create map nb.miss.mp <- nrow(family.spat[family.spat$mp == 'unknown',]) # nb of missiong mp tit <- paste0("distribution of '",m.var,"' from '", map.type,"' objects from '",select.family,"' (n = ",nrow(family.spat)," )", "\n with ",nb.miss.mp," objects having a missing information for raw material (white symbols)") chm.out <- paste0(chm.analysis.o.rawmaterial,"spat_raw_materials.png") ggsave(file = chm.out, arrangeGrob(grobs = g.map, top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)), padding = unit(0.1, "line"),ncol = 1), width = 17,height =17) shell.exec(chm.out)
chronologie TODO
# chronology of objects ## TODO seriate, lbl, order... map.type <- "family" family.chr <- family.df(select.family) # get objects coordinates for the family family.chr$idf <- as.integer(row.names(family.chr)) #family.chr$lbl <- paste0(family.chr$site,'.',family.chr$numero) family.chr$lbl <- gsub(" ", "", family.chr$lbl, fixed = TRUE) family.chr$lbl <- gsub("(", "", family.chr$lbl, fixed = TRUE) family.chr$lbl <- gsub(")", "", family.chr$lbl, fixed = TRUE) #objets$lbl <- stringr::str_replace_all(objets$lbl, "[^[:alnum:]]", "") #gsub(" ", "", paste0(objets$site,'.',objets$numero), fixed = TRUE) tit <- paste0("chronology of '", map.type,"' objects from '",select.family,"' (n=",nrow(family.chr),")") g.chr <- ggplot(objets) + ggtitle(tit)+ geom_rect(aes(xmin = tpq, xmax = taq, ymin = idf-.4, ymax = idf+.4, fill=chr_1))+ geom_text(aes(x = tpq+(abs(tpq-taq)/2), y = idf, label = lbl), size=3,parse = TRUE)+ scale_y_continuous(breaks = seq(1, nrow(objets), by=1))+ theme_bw()+ theme(panel.grid.minor = element_blank()) g.out <- paste0(chm.analysis.o.chr,"obj_chrono_frise.png") ggsave(file = g.out, g.chr, width = 17,height =17) shell.exec(g.out)
DECORATIONS
Graph analysis
info
dataframe
# listing describing graphs # export listings of decors and list of common links as png # with or without attributes of the graphs (density, n of edges, etc.) # TODO: check rm.attributes on/off corpus <- "family" # choose 'objects' or 'family' graphs <- create.graph.view(v.select.obj,corpus) # call function to create view lgrph <- load.graphs(graphs)[[1]] # load graphs df.g.infos <- f.g.infos(lgrph) #fpng.df(df.g.infos,paste0(chm.analysis.histo,"info_graphs.png")) p.var <- f.corresp.tab(df.g.infos,50) tit <- paste0("graph informations for '",select.family,"' family", "\nonly for existing graphs, at least one edge (n = ",length(lgrph),")") #ifelse(rm.attributes, tit <- paste0(tit," without nodes/edges attributes"),tit) g.out <- paste0(chm.analysis.dec.histo,"all_graphs_info.png") ggsave(file = g.out, grid.arrange(top=tit, p.var), width=length(p.var)*10, height=ceiling(length(lgrph)/10)+9) shell.exec(g.out)
by decorations TODO
corpus <- "family" # choose 'objects' or 'family' graphs <- create.graph.view(v.select.obj,corpus) # call function to create view lgrph <- load.graphs(graphs)[[1]] # load graphs a.graph <- lgrph[[40]] df.g.infos <- f.g.infos(lgrph)
histograms
ug types
histo
# TODO: stacked with chr_1 # TODO: adapt for "objects" graphs.family <- create.graph.view(v.select.family,"family") # choose "family" or "objects" for (rm.att in c(T,F)){ # with attributes and withourt attributes # rm.att <- F # remove attributes family.ico <- family.ico.df(select.family) if (rm.att){ # rm attributes df.nd.attributs <- df.nodes.are.attributs(graphs.family) family.ico <- family.ico[family.ico$lbl %notin% df.nd.attributs$lbl,] att.text <- "without" } if (!rm.att){att.text <- ""} #a.family <- unique(family.ico$famille) tit <- paste0("number of themes from '",select.family, "' family objects, ",att.text, " counting nodes attributes (nb total of ugs = ",nrow(family.ico),")") df.family.ico <- as.data.frame(table(family.ico$type)) df.family.ico <- df.family.ico[df.family.ico$Var1 != 'indet',] # rm df.family.ico <- df.family.ico[df.family.ico$Var1 != 'ug',] # rm # reorder df.family.ico <- df.family.ico[rev(order(df.family.ico$Freq)),] df.family.ico$Var1 <- factor(df.family.ico$Var1,levels = df.family.ico$Var1) #rownames(df.family.ico) <- 1:nrow(df.family.ico) gg.histo <- ggplot(df.family.ico, aes(x=Var1,y=Freq)) + ggtitle(tit)+ geom_bar(stat = "identity",alpha=.3)+ geom_text(aes(label=Freq),hjust=0.5,vjust=-1,size=2.5,parse = F)+ blank_theme + theme(plot.title = element_text(size = 9), axis.text = element_text(size = 8), axis.text.x = element_text(angle = 90, hjust=1, vjust=0)) margin = theme(plot.margin = unit(c(0,0,0,0), "cm")) #out.histo <- paste0(chm.analysis.dec.histo,tit.typedg,"_histo",".png") out.histo <- paste0(chm.analysis.dec.histo,"nodes_",att.text,"_attributes_histo.png") ggsave(file = out.histo, width = 8, height=6) } shell.exec(out.histo)
listing TODO
# TODO
edges types
histograms
corpus <- "family" # choose 'objects' or 'family' thres <- 50 # only the x more numerous graphs <- create.graph.view(v.select.obj,corpus) # call function to create view lgrph <- load.graphs(graphs)[[1]] # load graphs studied.edg <- f.tot.edges(lgrph) # load all edges df.typ_edges <- f.typ.edges(studied.edg,lgrph) # call funct sum.col <- as.numeric(as.data.frame(df.typ_edges %>% summarise_all(funs(sum)))) nme.col <- colnames(df.typ_edges) df.typ_edges.count <- data.frame(typedge=nme.col, nb=sum.col, stringsAsFactors = F) for(typrel in c('=','+')){ # typrel <- '+' # subset typrel.regex <- paste0("\\",typrel) df.typ_edges.count.sel <- df.typ_edges.count[grep(typrel.regex,df.typ_edges.count$typedge),] df.typ_edges.count.sel <- df.typ_edges.count.sel[!is.na(df.typ_edges.count.sel$typedge),] nmax <- max(df.typ_edges.count.sel$nb) # reorder df.typ_edges.count.sel <- df.typ_edges.count.sel[rev(order(df.typ_edges.count.sel$nb)),] df.typ_edges.count.sel$typedge <- factor(df.typ_edges.count.sel$typedge, levels = df.typ_edges.count.sel$typedge) df.typ_edges.count.sel <- df.typ_edges.count.sel[c(1:thres),] df.typ_edges.count.sel <- df.typ_edges.count.sel[!is.na(df.typ_edges.count.sel$typedge),] #rownames(df.family.ico) <- 1:nrow(df.family.ico) if(typrel == '='){tit.typedg <- "edges_normal"} if(typrel == '+'){tit.typedg <- "edges_attributes"} tit <- paste0("number of the ",thres," more common '",tit.typedg, "' from the '",select.family,"' family objects", "\n(nb of '",typrel,"' edges = ",sum(df.typ_edges.count.sel$nb),")") gg.histo <- ggplot(df.typ_edges.count.sel, aes(x=typedge,y=nb)) + ggtitle(tit)+ geom_bar(stat = "identity",alpha=.3)+ geom_text(aes(label=nb),hjust=0.5,vjust=1.5,size=2.5,parse = F)+ geom_text(aes(label=typedge,angle = 45),hjust=0,vjust=-.5,size=3,parse = F)+ blank_theme+ theme(axis.text.x = element_blank())+ coord_cartesian(clip = 'off') + theme(plot.margin = unit(c(0,2,0,0), "cm"))+ scale_y_continuous(limits = c(0, nmax +20)) margin = theme(plot.margin = unit(c(0,0,0,0), "cm")) out.histo <- paste0(chm.analysis.dec.histo,tit.typedg,"_histo",".png") ggsave(file = out.histo, gg.histo, width = 10, height=6) } shell.exec(out.histo)
listing TODO
# export listings of decors and list of common links as png # with or without attributes of the graphs (density, n of edges, etc.) # TODO : check rm.attributes on/off corpus <- "family" # choose 'objects' or 'family' graphs <- create.graph.view(v.select.obj,corpus) # call function to create view lgrph <- load.graphs(graphs)[[1]] # load graphs studied.edg <- f.tot.edges(lgrph) # load all edges indet.rm <- grep("indet",studied.edg) if (length(indet.rm)>0){ studied.edg <- studied.edg[-indet.rm] # rm indet } df.typ_edges <- f.typ.edges(studied.edg,lgrph) # call funct ico.listing.var <- data.frame(idf=new.col.nmes[1:ncol(df.typ_edges)], var=colnames(df.typ_edges), stringsAsFactors = F) # usefull ? colnames(df.typ_edges) <- new.col.nmes[1:ncol(df.typ_edges)] # simplify colnames n.max.h <- 50 corres.tab <- f.corresp.tab(ico.listing.var,n.max.h) #n.row <- nrow(ico.listing.var)/n.max.h #fpng.df(ico.listing.var,paste0(chm.analysis.e.histo,"listing.png")) #p.var <- tableGrob(ico.listing.var,theme=ttheme_default(base_size = 7),rows=NULL) tit <- "edges informations" #ifelse(rm.attributes, tit <- paste0(tit," \nwithout edges from nodes attributes"),tit) g.out <- paste0(chm.analysis.dec.histo,"edges_listing.png") # chm.analysis.dec.histo ggsave(file = g.out, corres.tab, height = ceiling(nrow(ico.listing.var)/7)+3, width = (length(corres.tab)*4)+2) shell.exec(g.out)
Nodes analysis
Plot dendrogramm colors on objects identifiers if 'flag.dendro.color' is TRUE
types
spatial XXX
# list missing scales # map.type <- "type" # TODO: distinguish btw ug and attributes # TODO: change size depending on count in 'type' field m.var <- "type"; map.type <- "all" graphs.family <- create.graph.view(v.select.family,"family") # choose "family" or "objects" # with attributes and withourt attributes # rm.att <- T # remove attributes # recover the object number family.ico <- family.ico.df(select.family) family.ico$num.objects <- paste0(family.ico$site,'.',family.ico$decor) family.numb <- family.df(select.family) family.numb <- subset(family.numb, select=c(lbl,idf.objects)) family.ico <- merge(family.ico,family.numb,by.x="num.objects",by.y="lbl",all.x=T) # family.ico <- subset(family.ico, select=c(num.objects,site,decor,type)) # lgrph <- load.graphs(graphs)[[1]] # load graphs # rm attributes df.nd.attributs <- df.nodes.are.attributs(graphs.family) family.ico <- family.ico[family.ico$lbl %notin% df.nd.attributs$lbl,] att.text <- "without" # order on count nb.types <- as.data.frame(table(family.ico$type)) nb.types <- nb.types[with(nb.types, order(-Freq)), ] rownames(nb.types) <- 1:nrow(nb.types) # remove 'ug' and 'indet' nb.types <- nb.types[nb.types$Var1 %notin% c("indet","ug"),] ct <- 1 # for filenames # nb.types$Var1 <- head(nb.types$Var1,3) for (typ in nb.types$Var1){ # typ <- "bouclier" family.ico.sel <- family.ico[family.ico$type == typ,] # count by decoration family.ico.ct <- aggregate(type ~ idf.objects + site + decor + x + y, data = family.ico.sel, FUN = length) typ.tot <- sum(family.ico.ct$type) # total nub of occurences # family.ico.ct$idf <- 1:nrow(family.ico.ct) # to get the right number and ordered df family.ico.ct$idf <- family.ico.ct$idf.objects family.ico.ct <- family.ico.ct[with(family.ico.ct, order(idf.objects)), ] sf.fd.carto <- f.spat.bck.grd("Europe") # load background g.map <- f.spat.distrib(family.ico.ct,sf.fd.carto,map.type,select.family,m.var,25,8) # create map # family.ico.ct <- aggregate(x=family.ico.sel$type, # by=list(family.ico.sel$site,family.ico.sel$decor), # FUN = count) tit <- paste0("distribution of '",typ,"' from '", map.type,"' objects of '",select.family,"' (n=",nrow(family.ico.ct),")") chm.out <- paste0(chm.analysis.n.typo,"ugs_typ_",ct,"_",typ,"_(",typ.tot,"_occurences).png") ggsave(file = chm.out, arrangeGrob(grobs = g.map, top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)), padding = unit(0.1, "line"),ncol = 1), width = 17,height =17) ct <- ct+1 } # shell.exec(chm.out) # # } # if (!rm.att){att.text <- ""} # #a.family <- unique(family.ico$famille) # tit <- paste0("number of themes from '",select.family, # "' family objects, ",att.text, # " counting nodes attributes (nb total of ugs = ",nrow(family.ico),")") # df.family.ico <- as.data.frame(table(family.ico$type)) # df.family.ico <- df.family.ico[df.family.ico$Var1 != 'indet',] # rm # df.family.ico <- df.family.ico[df.family.ico$Var1 != 'ug',] # rm # # reorder # df.family.ico <- df.family.ico[rev(order(df.family.ico$Freq)),] # df.family.ico$Var1 <- factor(df.family.ico$Var1,levels = df.family.ico$Var1) # #rownames(df.family.ico) <- 1:nrow(df.family.ico) # } # # map.type <- "family";m.var <- "all" # family.spat <- family.df(select.family) # get objects coordinates for the family # # family.spat$idf <- as.integer(row.names(family.spat)) # family.spat$idf <- as.integer(family.spat$idf.objects) # family.spat <- family.spat[with(family.spat, order(idf)), ] # rownames(family.spat) <- family.spat$idf # sf.fd.carto <- f.spat.bck.grd("Europe") # load background # g.map <- f.spat.distrib(family.spat,sf.fd.carto,map.type,select.family,m.var) # create map # tit <- paste0("distribution of '",m.var,"' from '", # map.type,"' objects from '",select.family,"' (n=",nrow(family.spat),")") # if(map.type == "family"){ # chm.out <- paste0(chm.etude,"spat_",select.family,".png") # } # if(map.type != "family"){ # chm.out <- paste0(chm.etude,"_",select.family,"_spat.png") # } # ggsave(file = chm.out, # arrangeGrob(grobs = g.map, # top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)), # padding = unit(0.1, "line"),ncol = 1), # width = 17,height =17)
dimensions
missing scales
# list missing scales corpus <- "family" # choose 'objects' or 'family' graphs <- create.graph.view(v.select.obj,corpus) # call function to create view drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") # condition if (corpus == 'family'){ sqll.CONDITION <- paste0(" famille LIKE '",select.family,"' AND ") } if (corpus == 'objects'){ # create list lobj.sit <- paste0("('",paste0(graphs$site,collapse="','"),"')") lobj.num <- paste0("('",paste0(graphs$numero,collapse="','"),"')") # condition sqll.CONDITION <- paste0(" site IN ",lobj.sit," AND numero IN ",lobj.num," AND ") } # select sqll.SELECT <- paste0("SELECT site,numero FROM objets WHERE ",sqll.CONDITION, "(site,numero) IN (SELECT site,decor FROM table_echelles) ", "ORDER BY site,numero") sqll.SELECT.NOT <- paste0("SELECT site,numero FROM objets WHERE ",sqll.CONDITION, "(site,numero) NOT IN (SELECT site,decor FROM table_echelles) ", "ORDER BY site,numero") df.missing.scales <- dbGetQuery(con,sqll.SELECT.NOT) df.missing.scales$scale <- "MISSING" df.existing.scales <- dbGetQuery(con,sqll.SELECT) df.existing.scales$scale <- "EXISTS" dbDisconnect(con) print(paste0("there are ",nrow(df.existing.scales)," decors with EXISTING scales")) print(df.existing.scales) #print(df.missing.scales) #grid.arrange(top="missing.scales", tableGrob(df.missing.scales)) print(paste0("there are ",nrow(df.missing.scales)," decors with MISSING scales")) print(df.missing.scales)
lengths
by decorations
Compute the absolute or relative length for each ug of decorations
# study dimensions of ug # corpus <- "family" # choose 'objects' or 'family' # graphs <- create.graph.view(v.select.obj,corpus) # call function to create view # lgrph <- load.graphs(graphs) # load graphs # lgrph <- rm.specific.nd(lgrph,"indet") # remove 'indetx' # ugs <- ug.select.obj(graphs) # ugs$lbl <- paste0(ugs$site,'.',ugs$decor) # ugs <- merge(ugs,graphs,by="lbl") # ugs$lbl <- paste0(ugs$idf,'.',ugs$lbl) corpus <- "family" # choose 'objects' or 'family' graphs <- create.graph.view(v.select.obj,corpus) # call function to create view graphs <- graphs[graphs$numero %in% gr1.steles, ] #lgrph <- rm.specific.nd(lgrph,"indet") # remove 'indetx' ugs <- ug.select.obj(graphs) # ugs$lbl <- paste0(ugs$decor) ugs$lbl <- paste0(ugs$site,'.',ugs$decor) ugs <- merge(ugs, graphs,by = "lbl") ugs$lbl <- paste0(ugs$idf,'.',ugs$lbl) # ugs$lbl <- paste0(ugs$idf,'.',ugs$decor) #ugs <- ugs[!is.na(ugs$long_cm),] # remove NA if (length(grep("indet", ugs$type)) > 0){ ugs <- ugs[-grep("indet",ugs$type),] # remove 'indet*' } #ugs <- head(ugs,400) fg.dim.by.dec(ugs, corpus, "long_cm", "abs", text.size = 16, label.size.dimension = 4, label.size.type = 6) # 'long' or 'long_cm' | 'rel' or 'abs'
by types
# TODO: italic and alpha on incomplets corpus <- "family" # choose 'objects' or 'family' graphs <- create.graph.view(v.select.obj,corpus) # call function to create view ugs <- ug.select.obj(graphs) ugs$lbl <- paste0(ugs$site,'.',ugs$decor) ugs <- merge(ugs,graphs,by="lbl") ugs.long_cm <- ugs[!is.na(ugs$long_cm),] # remove NA if (length(grep("indet",ugs.long_cm$type))>0){ ugs.long_cm <- ugs.long_cm[-grep("indet",ugs.long_cm$type),] # remove 'indet*' } ugs.long_cm <- f.dendro.color(flag.dendro.color,ugs.long_cm) # classification colors if (flag.dendro.color){ # merge on dendrogramm colors #ugs.long_cm <- merge(ugs.long_cm,df.dist.mat.sel.ord,by.x="idf",by.y="idf") tit.colored <- paste0("\ncolors refer to the dendrogram reordered on '",orig.thm,"' distance except grey colors out of dendrogram") } if (!flag.dendro.color){ugs.long_cm$color <- "black"} # incomplets flag.incomplet <- F ugs.long_cm.incomp <- ugs.long_cm[ugs.long_cm$incomplet == 1,] # get incomplet if (nrow(ugs.long_cm.incomp)>0){ ugs.long_cm.incomp$idf.lbl <- paste0("italic('",as.character(ugs.long_cm.incomp$idf),"')") ugs.long_cm <- ugs.long_cm[ugs.long_cm$incomplet != 1,] # remove incomplet flag.incomplet <- T } # ugs.long_cm <- head(ugs.long_cm,100) # subset # counts on complete n.ugs <- nrow(ugs.long_cm) # nb of different ugs, ie nb of points, for ggplot height n.thm <- length(unique(ugs.long_cm$type)) # nb of different types, for ggplot width ugs.long_cm.mean <- aggregate(ugs.long_cm$long_cm, by=list(Category=ugs.long_cm$type), FUN=mean) ugs.long_cm.mean <- ugs.long_cm.mean[with(ugs.long_cm.mean, order(-x)), ] ugs.long_cm.mean$lbl <- paste0(" ",as.character(round(ugs.long_cm.mean$x,1))) # mean label for ggplot ugs.long_cm$type <- factor(ugs.long_cm$type, levels=ugs.long_cm.mean$Category) # order on mean n.obj <- length(unique(ugs.long_cm$lbl)) bxplt.w <- .3 pos <- position_jitter(width = bxplt.w, seed = 1) # title tit.corpus <- f.tit.corpus(corpus,length(unique(ugs.long_cm$decor)),n.ugs) tit.sup <- "\nwith numeros of decorations" if (flag.incomplet){ tit.sup <- paste0(tit.sup,"\nincomplete ugs are displayed in shaded italic") } tit <- paste0("seriation of length of ugs ",tit.corpus," by types of ugs, in cm",tit.sup) if (flag.dendro.color){tit <- paste0(tit,tit.colored)} # ugs.long_cm <- ugs.long_cm[c(1:50),] # sample # graph gg.ugs.dim.by.types <- ggplot(ugs.long_cm,aes(x=type,y=long_cm,color=color))+ ggtitle(tit)+ geom_boxplot(color="darkgrey", fill = NA, fatten = 1.5, width=bxplt.w,lwd=0.5,outlier.shape = NA) + # mean geom_point(data=ugs.long_cm.mean,aes(x=Category, y= x), pch =3, size=2, color="red")+ geom_text(data=ugs.long_cm.mean,aes(x=Category, y= x, label=lbl, hjust=0), size = 2.5, color = "red")+ # ugs geom_point(position = pos,size=1.5)+ # ugs geom_label_repel(aes(label=idf), force = .5, segment.size = .3, segment.alpha = .5, size = 3, label.size = NA, fill= NA, position = pos)+ theme_bw()+ theme(plot.title = element_text(size = 10))+ theme(axis.title.x = element_blank())+ theme(axis.text=element_text(size=7))+ scale_alpha_identity()+ scale_color_identity()+ scale_y_continuous(breaks = seq(0,max(ugs.long_cm$long_cm), by = 5)) if (flag.incomplet){ # add incomplets to the plot gg.ugs.dim.by.types <- gg.ugs.dim.by.types + geom_point(data=ugs.long_cm.incomp, aes(x=type,y=long_cm,alpha=alpha.incomp), size = 1.5) + geom_text_repel(data=ugs.long_cm.incomp, aes(x=type,y=long_cm, label=idf.lbl,alpha=alpha.incomp), size = 3,parse = TRUE) } for (dev in c(".png")){ g.out <- paste0(chm.analysis.n.dimensions,"ugs_abs_dim_by_types",dev) ggsave(g.out, gg.ugs.dim.by.types, height = (n.obj/5)+5, width = (n.obj/3)+6) } shell.exec(g.out)
relative dimensions groups TODO
Calculate the dimension group of ugs dependeing on their relative proportions
f.dim.proport <- function(listing.prop){ # read the listing of inter-ugs relative lengths # ex: if val=1 and proport.coef=2 then realistic proportions = [1/2:1*2]) # => [0.5:2] df.proport <- openxlsx::read.xlsx(paste0(chm.ug,listing.prop), sheet="proportions", colNames = T, skipEmptyRows=TRUE) #df.proport <- df.proport[-c(1,2),] df.names <- as.character(na.omit(df.proport[,1])) row.names(df.proport) <- df.names df.proport <- df.proport[,-1] # populate upper triangle with inverted proportions df.proport[upper.tri(df.proport)] <- 1/t(df.proport)[upper.tri(df.proport)] # replace 'NULL' values with NA df.proport <- df.proport %>% replace(.=="NULL", NA) return(df.proport) } f.dim.rules <- function(listing.prop){ # read the listing of inter-ugs relative dimensions rules # that will be eval() in R # ex: 'lance' > 'bouclier' means 'lance' must be superior to dim 'bouclier' # listing.prop <- proportions.rel df.proport <- openxlsx::read.xlsx(paste0(chm.ug,listing.prop), sheet="rules", colNames = T, skipEmptyRows=TRUE) return(df.proport) } f.dim.rules.test <- function(thm.a,thm.b,long.a,long.b){ # check if there is a specific rule for themes dim.rules <- F for (rule in 1:nrow(df.dim.rules)){ # loop through rules # rule <- 1 a.rule <- df.dim.rules[rule,] thm.a.in.rule <- str_detect(a.rule,thm.a) thm.b.in.rule <- str_detect(a.rule,thm.b) if (thm.a.in.rule & thm.b.in.rule){ dim.rules <- T # split in 3 parts, ex: 'lance' '>' 'bouclier' exp <- strsplit(a.rule, " ")[[1]] termA <- exp[1];oper <- exp[2];termB <- exp[3] if (thm.a == termA){ # normal exp.normal <- paste0(long.a,oper,long.b) rule.result <- eval(parse(text=exp.normal)) print(paste0("'",a.rule,"' with '", thm.a,"'(",long.a,"px) ", oper," '",thm.b,"'(",long.b,"px) gives: ", rule.result)) return(rule.result) } if (thm.a == termB){ # inverse # if(oper=='>'){not.oper <- "<"} # if(oper=='<'){not.oper <- ">"} # if(oper=='>='){not.oper <- "<="} # if(oper=='<='){not.oper <- ">="} exp.inverted <- paste0(long.b,oper,long.a) rule.result <- eval(parse(text=exp.inverted)) print(paste0("'",a.rule,"' with '", thm.b,"'(",long.b,"px) ", oper," '",thm.a,"'(",long.a,"px) gives: ", rule.result)) return(rule.result) } } return(NA) # no rules } }
# TODO: peut certainement etre simplifié proportions.rel <- "proportions.xlsx" # listing of inter-ugs relative lengths proport.coef <- 2 # coefficient of proportion verb <- T # verbose graphs.objects <- create.graph.view(v.select.obj,"objects") # call function to create view graphs <- graphs.objects # choose 'graphs.objects' or 'graphs.family' lgrph <- load.graphs(graphs)[[1]] # load graphs #plot(lgrph[[1]]) df.dim.proport <- f.dim.proport(proportions.rel) # load proportion listing df.dim.rules <- f.dim.rules(proportions.rel) # load proportion listing # loop through graphs graphs <- graphs[4,] for(a.g in 1:nrow(graphs)){ # a.g <- 1 lproport <- lreal.ids <- lirreal.ids <- lna.val <- list() # lists of OK, NOT OK and NA val a.sit <- graphs[a.g,"site"] a.dec <- graphs[a.g,"numero"] print(paste0(a.sit,".",a.dec)) # get nodes attributes drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") # get ugs sqll.ugs <- paste0("SELECT id,type,long FROM table_noeuds WHERE ", "site LIKE '",a.sit,"' AND decor LIKE '",a.dec,"' ", "AND long IS NOT NULL") df.ugs <- dbGetQuery(con,sqll.ugs) # clear gr_dim sqll.update <- paste0("UPDATE table_noeuds SET gr_dim=NULL WHERE ", "site LIKE '",a.sit,"' AND decor LIKE '",a.dec,"'") dbGetQuery(con,sqll.update) dbDisconnect(con) #df.ugs$prop.family <- NA # all pairwise combinations df.compar.ugs <- as.data.frame(t(combn(df.ugs$id, 2))) colnames(df.compar.ugs) <- c('a','b') for (a.ug in 1:nrow(df.compar.ugs)){ # loop through id # a.ug <- 1 # get row id.a <- df.compar.ugs[a.ug,"a"] id.b <- df.compar.ugs[a.ug,"b"] # get thm min and max proportions in 'df.dim.proport' thm.a <- df.ugs[df.ugs$id == id.a,"type"] long.a <- df.ugs[df.ugs$id == id.a,"long"] thm.b <- df.ugs[df.ugs$id == id.b,"type"] long.b <- df.ugs[df.ugs$id == id.b,"long"] if(is.na(long.a)){long.a <- "XX"};if(is.na(long.b)){long.b <- "XX"} long.exist <- (is.numeric(long.a) & is.numeric(long.b)) # exist numerical values val <- as.numeric(df.dim.proport[thm.a,thm.b]) if (verb){ print(paste0("row ",a.ug,": ", "[",id.a,"] ",thm.a," (",long.a,"px) - *", val," - [",id.b,"] ",thm.b," (",long.b,"px)")) } # first, test on rules if exist - - - - - - - - - - - - - - - - - if(long.exist){ res.rule <- f.dim.rules.test(thm.a,thm.b,long.a,long.b) if (!is.na(res.rule)){ # if res.rule = NA means there's no rule yet for these thm if(res.rule){ # # in one sublists # if (length(lproport) == 0){ # lproport[[length(lproport)+1]] <- c(id.a,id.b) # } # if (length(lproport) > 0){ # # find index # } lreal.ids[[length(lreal.ids)+1]] <- c(id.a,id.b) } if(!res.rule){ # # in two different sublists # if (length(lproport) == 0){ # lproport[[length(lproport)+1]] <- id.a # lproport[[length(lproport)+1]] <- id.b # } # if (length(lproport) > 0){ # # find index # } # useful ? lirreal.ids[[length(lirreal.ids)+1]] <- c(id.a,id.b) } } } # if no rules, test on proportions - - - - - - - - - - - - - - - - - - - - # thm exist in 'df.dim.proport' exist.thm <- (thm.a %in% row.names(df.dim.proport) & thm.b %in% row.names(df.dim.proport)) if(exist.thm & is.na(res.rule)){ if(!is.na(val) & long.exist){ if(val>=1){ # normal dim.max <- long.a/(val/proport.coef) dim.min <- long.a/(val*proport.coef) } if(val<1){ # inverse dim.min <- long.a*(1/(val*proport.coef)) dim.max <- long.a*(1/(val/proport.coef)) } realistic.prop <- (long.b >= dim.min & long.b <= dim.max) if (realistic.prop){ # strore ids with realistic proportions lreal.ids[[length(lreal.ids)+1]] <- c(id.a,id.b) if (verb){ print(paste0(" Yes realistic : coef= ",round(val,2),", ",thm.b, " btw ",round(dim.min,2),"px and ",round(dim.max,2),"px")) } } if (!realistic.prop){ if (verb){ print(paste0(" NO irrealistic : coef= ",round(val,2),", ",thm.b, " btw ",round(dim.min,2),"px and ",round(dim.max,2),"px")) } } } } } # # group ids with realistic proportions reduced <- T ; thick <- 1 while (reduced){ # loop until impossible to reduce length of list if (thick == 1){ # start # all pairwise combinations if(length(lreal.ids)>1){ df.in <- as.data.frame(t(combn(c(1:length(lreal.ids)), 2))) colnames(df.in) <- c("g1","g2") } if(length(lreal.ids)==1){ df.in <- data.frame(g1=lreal.ids[[1]][1], g2=lreal.ids[[1]][2]) } ll.in <- lreal.ids } if (thick > 1){ # steps df.in <- as.data.frame(t(combn(c(1:length(ll.out)), 2))) colnames(df.in) <- c("g1","g2") ll.in <- ll.out } lenIN <- length(ll.in) if (verb){print(paste0("loop ",thick," - length of IN list : ",lenIN))} ll.out <- list() # new out list # compare groups and merge intersected group in new list for (r in 1:nrow(df.in)){ # r <- 1 g1 <- df.in[r,"g1"];g2 <- df.in[r,"g2"] if(length(ll.in)>1){ same.grp <- intersect(ll.in[[g1]],ll.in[[g2]]) # pick in the list if(length(same.grp)>0){ grp <- sort(unique(c(ll.in[[g1]],ll.in[[g2]]))) #names(my_list) ll.out[[length(ll.out)+1]] <- grp } } } ll.out <- unique(ll.out) # merge with nodes existing in ll.in if(length(ll.in)>0){ # ex: not Substantio for (i in 1:length(unique(ll.in))){ #i <- 1 #already.in <- length(intersect(ll.in[[i]],ll.out)) already.in <- length(intersect(ll.in[[i]],unlist(ll.out))) if (already.in == 0){ # add ll.out[[length(ll.out)+1]] <- ll.in[[i]] } } } lenOUT <- length(ll.out) if (verb){print(paste0(" length of OUT list : ",lenOUT))} thick <- thick+1 # increment if (lenOUT == 1 | lenIN == lenOUT){ # two possible conditions to break while loop # - out.list.length == 1, then impossible to reduce # - out.list.length == in.list.length, then impossible to reduce reduced <- F } } # append isolated ug if exist, if long exist, etc. ugs.with.gr_dim <- unlist(ll.out) ugs.all <- df.ugs$id isolated.ug <- setdiff(ugs.all,ugs.with.gr_dim) for (n in isolated.ug){ # - must be in the proportion table ug.exist.in.df.proport <- n %in% rownames(df.dim.proport) # - must have a long ug.has.long <- !is.na(df.ugs[df.ugs$id == n,"long"]) if(ug.exist.in.df.proport & ug.has.long){ print (paste0(" append [",isolated.ug,"] in the list of 'gr_dim'")) ll.out[[length(ll.out)+1]] <- isolated.ug } } # update 'gr_dim' in Pg print (" ugs dimension groups: ") if (length(ll.out)>0){ for (gr in 1:length(ll.out)){ # loop through list of same proportions # gr <- 1 for (idf in ll.out[[gr]]){ sql.gr.dim <- paste0("UPDATE table_noeuds SET gr_dim = ",gr, " WHERE site LIKE '",a.sit,"' AND decor LIKE '",a.dec,"' AND", " id = ",idf) # print(sql.gr.dim) drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") dbGetQuery(con,sql.gr.dim);dbDisconnect(con) print(paste0(" [",idf,"] gr_dim:",gr)) } } } }
orientations/sens
by decorations
gr1.steles <- c("Baracal", "Arroyo Bonaval-Almendralejo", "El Carneril_Trujillo", "Cordoba 2_Ribera Alta", "Foios", "Granja De Cespedes-Badajoz", "Ibahernando", "Robledillo De Trujillo") # create a stack of images with the direction of different selected types of ugs # TODO : probably split by chunk when corpus too numerous # TODO: the ggplot -> img function mess up corpus <- "family" siz.of.img <- 2 # size of images in inch n.img <- 3 # number of images in row #df.icos <- f.df.ico() if(corpus=="objects"){ graphs <- create.graph.view(v.select.obj,"objects") # call function to create view objets <- objects.df(graphs) df.icos <- f.df.ico(v.select.obj) # select the theme that will be studied (ex. épée) from a list thms.selected <- f.thm.orient.select(select.obj) } # 'graphs.objects' or 'graphs.family' if(corpus=="family"){ graphs <- create.graph.view(v.select.family,"family") # call function to create view objets <- objects.df(graphs) df.icos <- f.df.ico(v.select.family) # select the theme that will be studied (ex. épée) from a list thms.selected <- f.thm.orient.select(select.family) } objets <- objets[objets$numero %in% gr1.steles, ] df.icos <- df.icos[df.icos$numero %in% gr1.steles, ] #objets <- objects.df(graphs.objects) # objects #ugs.selected.all <- f.thm.orient.select() # thms.selected <- f.thm.orient.select("stele bouclier") # select the theme that will be studied (ex. épée) #thms.selected <- f.thm.orient.select(select.obj) # select the theme that will be studied (ex. épée) lg.angles <- list() # list themes with orientations thm.with.orientations <- c() n.tot <- nrow(objets) # n.tot <- 10 for (i in 1:n.tot){ #i <- 1 sit.a <- objets[i,"site"];num.a <- objets[i,"numero"] #color.a <- objets[i,"color"] img.a <- df.icos[df.icos$site == sit.a & df.icos$num == num.a,]$img ugs <- nodes.df(sit.a,num.a) # get nodes data ugs <- ugs[ugs$type %in% thms.selected,] # select in thm if (length(ugs) > 0){ # at least 1 ug ugs <- ugs[!is.na(ugs$sens),] # remove orientation = NA thm.with.orientations <- unique(c(thm.with.orientations,ugs$type)) } } # colors as named vectors n.colors <- brewer.pal(length(thm.with.orientations),"Set1") # color ramp for thm n.colors <- n.colors[1:length(thm.with.orientations)] # remove NA names(n.colors) <- thm.with.orientations # plot for (i in 1:n.tot){ #i <- 6 id.a <- objets[i,"idf"] sit.a <- objets[i,"site"] num.a <- objets[i,"numero"] color.a <- objets[i,"color"] print(paste0(" ",i,") read ",sit.a,".",num.a)) img.a <- df.icos[df.icos$site == sit.a & df.icos$num == num.a,]$img ugs <- nodes.df(sit.a,num.a) ugs <- ugs[ugs$type %in% thm.with.orientations,] # select in thm.with.orientations # colors idf.dec <- paste0(id.a,'.',sit.a,'\n',num.a) if (length(rownames(ugs))>0){ g.angle <- ggplot(ugs, aes(x = sens, y = .8)) + ggtitle(idf.dec)+ geom_text_repel(aes(x=sens, y=.9, label=id, color = type, fontface="bold"), alpha=.7, segment.color = 'transparent', force=0.1, cex=3)+ geom_segment(aes(y = 0, xend = sens, yend = .7,color = type), size=.8, alpha=.7, arrow=arrow(length = unit(0.1,"cm")))+ scale_color_manual(values = n.colors)+ geom_point(aes(0,0),color="black") + coord_polar() + theme_bw()+ theme(plot.title = element_text(size = 8, color=color.a), axis.line = element_blank(), axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.grid.major = element_blank(), panel.grid.minor = element_blank(), panel.border = element_blank(), panel.background = element_blank())+ scale_x_continuous(breaks = seq(45, 360, 45), limits = c(0, 360)) # take the legend #leg <- get_legend(g.angle) # remove the legend g.angle <- g.angle+theme(legend.position="none") # add to list lg.angles[[length(lg.angles)+1]] <- g.angle } } # how many empty images to complete the line add.empty <- length(lg.angles) %% n.img if(add.empty > 0){ n.empty.img <- n.img - add.empty for (n.img.empty in 1:n.empty.img){ lg.angles[[length(lg.angles)+1]] <- ggplot() + theme_void() } } # create a legend - - - - - - - - - - - - - - - - - - - color.col <- n.colors[!is.na(n.colors)] color.legend <- as.data.frame(color.col) color.legend$idf <- 1:nrow(color.legend) color.legend$thm <- rownames(color.legend) leg <- ggplot(color.legend, aes(x=0,y=idf,colour=color.col)) + geom_point() + geom_text(aes(label=paste0(" ",thm),hjust=0),cex=2)+ xlim(0,0.05)+ blank_theme+ theme(axis.text = element_blank())+ scale_colour_identity() # thumbnails of thms - - - - - - - - - - - - - - - - - - ll.sign <- list() # all or selected theme with orientation without NA values thms.selected <- intersect(thm.with.orientations,thms.selected) for (ug in thms.selected){ a.color <- as.character(color.col[ug]) # color of the thm a.sign <- image_read(paste0(chm.signes,ug,".jpg")) a.sign <- image_scale(a.sign,"200x200") a.sign <- image_trim(a.sign) a.sign <- image_border(a.sign,a.color, "10x10") # add white margins a.sign <- image_border(a.sign,"#FFFFFF", "100x100") # add white margins # a.sign <- image_border(a.sign,a.color, "10x10") # add white margins # a.sign <- image_flip(a.sign) # a.sign.tag <- image_annotate(a.sign, ug, size = 35,gravity="center", # color = a.color, boxcolor = "white") # plot(a.sign) # gg.a.sign.tag <- image_graph(a.sign.tag) gg.a.sign.tag <- image_ggplot(a.sign) # plot(gg.a.sign.tag) # a.sign.tag <- image_annotate(a.sign, ug, size = 25,gravity="southwest",color = "black") ll.sign[[length(ll.sign)+1]] <- gg.a.sign.tag } tit.corpus <- f.tit.corpus(corpus,length(lg.angles),length(thm.with.orientations) * length(lg.angles)) the.tit <- paste0("themes orientations for ",tit.corpus," with numeros of ugs", #"\for themes: ",paste0(thms.selected,collapse = ', '), "\ncolors refer to ugs themes: ",paste0(thms.selected,collapse = ', '), " (see legend below)", "\nthe defaut orientation (0°) is given by thumbnails with colored squares", " (see legend below)\n") # lg.complete <- lg.angles #lg.complete[[length(lg.complete)+1]] <- leg # add the legend to the list #lg.complete[[length(lg.complete)+1]] <- as_ggplot(leg) # add the legend to the list #lg.complete <- append(lg.complete, ll.sign) # add signs thumbnails dim.h <- (ceiling(length(lg.angles)/n.img)+ceiling(length(ll.sign)/n.img))*siz.of.img margin = theme(plot.margin = unit(c(0,0,0,0), "cm")) langles <- lapply(lg.angles, "+", margin) #llegend <- for (dev in c(".png")){ out.plot <- paste0(chm.analysis.n.orientations, "ugs_orient_by_decorations", dev) ggsave(file = out.plot, arrangeGrob(grobs = c(langles,ll.sign), top = grid::textGrob(the.tit,x=0,hjust=0,gp = gpar(fontsize =9)), padding = unit(0, "line"), ncol = n.img), width = siz.of.img * n.img, height = dim.h ) } shell.exec(out.plot)
by types
# radar plot of cumulated orientations by themes g.add.thumb.thm <- function(thm){ # create a thumbnail of the theme with cardinal orientations orient.sz <- 15 thumbnail.thm <- paste0(chm.signes,thm,".jpg") if(!file.exists(thumbnail.thm)){ thumbnail.thm <- paste0(chm.signes,"zz_img.jpg") } if(file.exists(thumbnail.thm)){ thumb.thm <- image_read(thumbnail.thm) thumb.thm <- image_scale(thumb.thm,"x150") thumb.thm <- image_border(thumb.thm,"#FFFFFF", "20x20") # add white margins thumb.thm <- image_annotate(thumb.thm,"0/360°","north",size=orient.sz) thumb.thm <- image_annotate(thumb.thm,"90°","east",size=orient.sz) thumb.thm <- image_annotate(thumb.thm,"180°","south",size=orient.sz) thumb.thm <- image_annotate(thumb.thm,"270°","west",size=orient.sz) } return(thumb.thm) } corpus <- "family" # select ugs of family if(corpus=="objects"){ ugs <- ugs.select.df(select.obj,corpus) # tit.selec.corpus <- paste0("of '",select.obj,"' selected objects") } if(corpus=="family"){ ugs <- ugs.select.df(select.family,corpus) # tit.selec.corpus <- paste0("of all '",select.family,"' family") } #ugs <- ugs_x_family.df(select.family) # select ugs of family ugs <- subset(ugs, select=c("site","decor","id","type","sens")) ugs$lbl <- paste0(ugs$site,'.',ugs$decor) ugs <- ugs[!is.na(ugs$sens),] # remove # get the different thms ordered by n t.thm <- as.data.frame(table(ugs$type)) t.thm <- t.thm[with(t.thm, rev(order(Freq))), ] # cleanup t.thm <- t.thm[t.thm$Freq>1,] # rm when only 1 t.thm <- t.thm[t.thm$Var1 != "indet",] # rm indet print("* orientations of themes *") #t.thm$Var1 # c("bouclier") for(thm in t.thm$Var1){ # thm <- "anciforme" n.thm <- t.thm[t.thm$Var1 == thm,"Freq"] n.dec <- length(unique(ugs[ugs$type == thm,]$lbl)) tit.corpus <- f.tit.corpus(corpus,n.dec,n.thm) the.tit <- paste0("'",thm,"' orientations \n",tit.corpus) print(paste0(" ",thm)) ugs.thm <- ugs[ugs$type == thm,] # select thm ugs.thm <- as.data.frame(table(ugs.thm$sens)) ugs.thm$Var1 <- as.numeric(as.character(ugs.thm$Var1)) # factor to numeric names(ugs.thm)[names(ugs.thm) == 'Freq'] <- "nb.total" a.interval <- 15 orient.classes <- seq(0,360, by=a.interval) # center on vertical orient.classes.centred <- c(orient.classes[length(orient.classes)], orient.classes[-length(orient.classes)]) gr.2x <- seq(from=2,to=length(orient.classes.centred), by =2) orient.classes.centred.g <- orient.classes.centred[-gr.2x] orient.classes.centred.g <- orient.classes.centred.g[-1] ugs.thm$orient <- cut(ugs.thm$Var1, orient.classes.centred.g, labels = F,right = F) # na = 350-10 #ugs.thm[is.na(ugs.thm)] <- 1 ugs.thm$orient.class.inf <- orient.classes.centred.g[ugs.thm[,"orient"]] ugs.thm$orient.class.sup <- orient.classes.centred.g[ugs.thm[,"orient"]+1] #ugs.thm$orient.class.mean <- ugs.thm$orient.class.inf+(a.interval/2) # replace 370 ugs.thm[is.na(ugs.thm$orient.class.inf),"orient.class.inf"] <- 345 ugs.thm[is.na(ugs.thm$orient.class.sup),"orient.class.sup"] <- 15 ugs.thm$orient.class.med <- ugs.thm$orient.class.inf+a.interval if (nrow(ugs.thm)>0){ ugs.thm$orient.lbl <- paste0("[",as.character(ugs.thm$orient.class.inf), "-",as.character(ugs.thm$orient.class.sup),"[") } # group ugs.thm <- ugs.thm %>% group_by(orient.lbl,orient.class.med) %>% summarise(nb.total = sum(nb.total)) # aggregate(ugs.thm$nb.total, by=list(Category=ugs.thm$orient.lbl), FUN=sum) # ugs.thm$orient <- NULL #gg.radar <- ggplot(data = ugs.thm, aes(x = log10(nb.total), y = orient.class.inf)) + gg.radar <- ggplot(data = ugs.thm, aes(x = nb.total, y = orient.class.med)) + #ggtitle(the.tit)+ geom_point(stat = "identity",aes(size=nb.total/3),color="darkgrey") + geom_text(aes(label = orient.lbl), color="black", segment.alpha = .7, vjust=-1, cex=1) + geom_text(aes(label = nb.total), color="black", segment.alpha = .7, vjust=.75, cex=1.3) + coord_polar(theta = "y") + scale_y_continuous(breaks = orient.classes,limits = c(0,360))+ scale_x_continuous(breaks = c(1,2,3,4,5,10,15,20,30,50), limits = c(0,max(ugs.thm$nb.total))) + #scale_x_log10()+ # log #scale_x_log10(limits = c(0,max(ugs.thm$nb.total)))+ # log theme_bw()+ theme(#plot.title = element_text(size = 7,hjust=0,margin = margin(0.1,-1,0.1,0.1)), #legend.title = element_text(size = 8), #legend.text = element_text(size = 7), axis.title.x =element_blank(), axis.text.x = element_text(size = 4, vjust= 1), axis.title.y = element_text(size = 5, hjust=0.75), axis.text.y = element_text(size = 4), axis.ticks.length=unit(.05, "cm"), legend.key.size = unit(1,"line"), panel.border = element_blank())+ theme(legend.position = "none") img.gg.radar <- ggsave_to_variable(gg.radar,1000,1000,300) # ggplot -> magick-image img.gg.radar <- image_annotate(img.gg.radar,the.tit,"northwest",size=24) thumb.thm <- g.add.thumb.thm(thm) # add annotated thumbnail # img.comp <- image_composite(img.gg.radar, thumb.thm, gravity = "southwest") img.comp <- image_composite(img.gg.radar, thumb.thm, offset = "+20+20", gravity = "southwest") #plot(img.comp) out.orient <- paste0(chm.analysis.n.orientations, "ugs_orient_by_types_",thm,".png") #out.orient <- paste0(chm.analysis.n.orientations,"ugs_",select.family,"_",thm,"_orientations.png") image_write(img.comp, out.orient, format = "png") } # plot if (length(rownames(t.thm))>0){shell.exec(out.orient)}
relative node positions
Explore x and y values of ug in the GIS to identify top most ugs (y-axis, ie relative deepness) and centered most ugs (x-axis, ie relative centre)
centreness TODO
# based on the 'x' variable of nodes
deepness
# based on the 'y' variable of nodes corpus <- "family" # choose 'objects' or 'family' graphs <- create.graph.view(v.select.obj,corpus) # call function to create view lgrph <- load.graphs(graphs)[[1]] # load graphs #lgrph <- rm.specific.nd(lgrph,"indet") # remove indet ugs <- ug.select.obj(graphs) if (length(grep("indet",ugs$type))>0){ ugs <- ugs[-grep("indet",ugs$type),] # remove 'indet*' } # to get and remove nodes which are attributes ugs$lbl <- paste0(ugs$site,'.',ugs$decor,'.',ugs$id) df.nd.are.attr <- df.nodes.are.attributs(graphs) ugs <- ugs[ugs$lbl %notin% df.nd.are.attr$lbl,] sel.ugs.all <- data.frame(dec=character(0), type=character(0), rel.h=numeric(0)) # ugs <- head(ugs,100) # loop throug objects for (i in 1:length(lgrph)){ # i <- 11 g <- lgrph[[i]] print(paste0(i,") ",g$name,", nb nodes (without attributes nodes): ",gorder(g)," ; nb of edges: ",gsize(g))) # get the vertex id df.all <- as.data.frame(vertex_attr(g)) # updated graph by removing some nodes g <- rm.by.edge.type(g,'+') #;g <- rm.by.edge.type(g,'>') if (gorder(g)==0){print(paste0(" 0 nodes -> NEXT")) ; next} df <- as.data.frame(vertex_attr(g)) a.sit <- as.character(df[1,"site"]) a.dec <- as.character(df[1,"decor"]) sel.ugs <- ugs[ugs$site == a.sit & ugs$decor == a.dec,] if (nrow(sel.ugs)==0){print(paste0(" only 'indent' nodes -> NEXT")) ; next} # only nodes in the updated graph sel.ugs <- sel.ugs[sel.ugs$id %in% df$id,] sel.ugs <- sel.ugs[with(sel.ugs, order(-y_ug)), ] sel.ugs$rel.h <- 1:nrow(sel.ugs) # record the order sel.ugs$dec <- as.character(df[1,"idf"]) # the idf of the object sel.ugs <- subset(sel.ugs,select=c(dec,type,rel.h)) sel.ugs.all <- rbind(sel.ugs.all,sel.ugs) } # df.dist.mat.sel # mean of closeness by thm mean.by.var <- aggregate(sel.ugs.all$rel.h, by=list(thm=sel.ugs.all$type), FUN=mean) # reorder mean.by.var <- mean.by.var[with(mean.by.var,order(x)), ] mean.by.var$thm <- factor(mean.by.var$thm,levels = mean.by.var$thm) # reorder sel.ugs.all$type <- factor(sel.ugs.all$type,levels = mean.by.var$thm) max.d <- max(sel.ugs.all$rel.h) n.thm <- length(unique(sel.ugs.all$type)) tit.corpus <- f.tit.corpus(corpus,length(unique(sel.ugs.all$dec)),nrow(sel.ugs.all)) tit.sup <- "\nwith numeros of decorations" tit.corpus <- paste0(tit.corpus,tit.sup) the.tit <- paste0("relative deepness seriation of ugs types",tit.corpus) if (flag.dendro.color){ # merge on dendrogramm colors sel.ugs.all <- merge(sel.ugs.all,df.dist.mat.sel.ord,by.x="dec",by.y="idf") the.tit <- paste0(the.tit,"and colors refer to the dendrogramm except grey colors out of dendrogram") } if (!flag.dendro.color){sel.ugs.all$color <- "black"} #pos <- position_jitter(w=0,h=.1) gg.heights <- ggplot(sel.ugs.all, aes(x=type, y=rel.h, colour=color)) + ggtitle(the.tit)+ geom_point(data=mean.by.var, aes(x=thm,y=x), pch =3, size=2, color="red")+ geom_point(size=.7, alpha=.5)+ geom_label_repel(data=sel.ugs.all, #position = pos, # jitter label=sel.ugs.all$dec, segment.alpha = .5,segment.size = .2, min.segment.length = 0, size=3, label.size=NA,fill = NA, # no box, no frame force=0.01, # repulsion between lables box.padding=0.1, #direction="y", # move only on y-axis hjust= 0 )+ geom_text_repel(data=mean.by.var, aes(x=thm,y=x,label=round(x,2)), color="red", size=3)+ theme_bw() + theme(axis.text.x = element_text(size = 7,hjust = 1, vjust=0))+ ylab(paste0("relative deepness indice"))+ theme(plot.title = element_text(size = 9))+ theme(axis.title.y = element_text(size=6))+ theme(axis.text.y = element_text(size = 7, vjust = 0, hjust=0.5))+ theme(axis.title.x = element_blank())+ theme(axis.ticks.length = unit(2, "pt"))+ theme(axis.ticks = element_line(colour = "black", size = 0.2))+ theme(panel.border=element_rect(colour="black",size=0.2))+ theme(panel.grid.minor = element_blank())+ theme(panel.grid.major = element_line(colour = "lightgrey", size = 0.1))+ theme(panel.spacing = unit(2, "mm"))+ theme(strip.text = element_text(size=8), strip.background = element_rect(colour="black",size=0.2))+ theme(legend.position = "none")+ scale_colour_identity()+ #scale_y_continuous(breaks=rev(seq(1,max.d))) scale_y_reverse(breaks=rev(seq(1,max.d))) #scale_x_continuous(breaks=-seq(0,max.d,by=0.05))+ #scale_x_continuous(breaks=seq(1,max.d))+ #expand_limits(x = c(.1,max.d+.1)) for (dev in c(".png",".pdf")){ g.out <- paste0(chm.analysis.n.centralities,"ugs_rel_deepness_by_types",dev) ggsave(g.out, gg.heights, height = (nrow(mean.by.var)/2)+4, width = n.thm+8) } shell.exec(g.out)
graph analysis
Graph analysis
ug centralities
# realize different graph centralities measures and make a seriation on values corpus <- "family" # choose 'objects' or 'family' graphs <- create.graph.view(v.select.obj,corpus) # call function to create view lgrph <- load.graphs(graphs)[[1]] # load graphs dist.df <- f.dist.df(lgrph) # get distances btw nodes # # get colors # if (flag.dendro.color){ # # merge on dendrogramm colors # df.colors <- subset(df.dist.mat.sel.ord,select=c("idf","color")) # dist.df <- merge(dist.df,df.colors,by.x="dec",by.y="idf") # } # if (!flag.dendro.color){dist.df$color <- "black"} dist.df <- subset(dist.df,select=c("dec","color")) dist.df <- dist.df[!duplicated(dist.df), ] #lgrph <- lgrph[1:10] # subset gt.index.df <- c("closeness","betweenness","degree") # names of the graph analysis functions # gt.index.df <- c("closeness") # names of the graph analysis functions for (gt.i in gt.index.df){ # gt.i <- "closeness" print(paste0("'",gt.i,"' measurement centralities")) gt.index.df <- data.frame(gt.index=numeric(0), dec=character(0), thm=character(0)) ugs <- ug.select.obj(graphs) ugs.types <- unique(ugs$type) for (i in 1:length(lgrph)){ # i <- 1 g <- lgrph[[i]] # print(paste0(" ",i,") read '",gt.i,"' for graph ",g$name)) #idf.g <- unique(vertex_attr(g, "idf", index = V(g))) # idf g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>') # path name of the function gt.i.val <- eval(parse(text = paste0("as.data.frame(",gt.i,"(g))"))) colnames(gt.i.val)[1] <- "stat.graph" # modify function name #clos <- as.data.frame(closeness(g)) gt.i.val$dec <- unique(vertex_attr(g, "idf", index = V(g))) # idf #clos$dec <- g$name gt.i.val$thm <- row.names(gt.i.val) #names(gt.i.val)[names(clos) == 'closeness(g)'] <- "closeness" gt.index.df <- rbind(gt.index.df,gt.i.val) } gt.index.df <- gt.index.df[gt.index.df$thm %in% ugs.types,] # ? # mean of graph index by thm mean.by.var <- aggregate(gt.index.df$stat.graph, by=list(thm=gt.index.df$thm), FUN=mean) # reorder mean.by.var <- mean.by.var[with(mean.by.var,order(x)), ] mean.by.var$thm <- factor(mean.by.var$thm,levels = mean.by.var$thm) gt.index.df$thm <- factor(gt.index.df$thm,levels = mean.by.var$thm) # if (flag.dendro.color){ # # merge on dendrogramm colors # df.colors <- subset(df.dist.mat.sel.ord,select=c("idf","color")) # dist.df <- merge(dist.df,df.colors,by.x="dec",by.y="idf") # } # if (!flag.dendro.color){dist.df$color <- "black"} # dist.df <- subset(dist.df,select=c("dec","color")) # dist.df <- dist.df[!duplicated(dist.df), ] gt.index.df <- merge(gt.index.df,dist.df,by="dec",all.x=T) # get colors max.d <- max(gt.index.df$stat.graph) pos <- position_jitter(w=0,h=.1) nb.dec <- length(lgrph);nb.ugs <- nrow(gt.index.df) tit.corpus <- f.tit.corpus(corpus,nb.dec,nb.ugs) the.tit <- paste0("'",gt.i,"' average index seriation ",tit.corpus,"\nwith numero of decorations") if (flag.dendro.color){the.tit <- paste0(the.tit," and colors refer to dendrogramm classification")} gg.glob <- ggplot(gt.index.df, aes(x=stat.graph, y=thm, colour=color)) + ggtitle(the.tit)+ geom_point(data=mean.by.var, aes(x=x,y=thm), pch=3, size=2, color="red")+ geom_point(size=1, position = pos)+ geom_label_repel(data=gt.index.df, position = pos, # jitter label=gt.index.df$dec, segment.alpha = .5,segment.size = .2, min.segment.length = 0, size=3, label.size=NA,fill = NA, # no box, no frame force=0.01, # repulsion between lables box.padding=0.1, #direction="y", # move only on y-axis hjust= 0 )+ geom_text_repel(data=mean.by.var, aes(x=x,y=thm,label=round(x,1)), color="red", size=3)+ theme_bw() + theme(axis.text.x = element_text(size = 7,hjust = 1, vjust=0))+ xlab(paste0(gt.i," indice"))+ theme(plot.title = element_text(size = 9))+ theme(axis.title.x = element_text(size=6))+ theme(axis.text.y = element_text(size = 7, vjust = 0, hjust=0.5))+ theme(axis.title.y = element_blank())+ theme(axis.ticks.length = unit(2, "pt"))+ theme(axis.ticks = element_line(colour = "black", size = 0.2))+ theme(panel.border=element_rect(colour="black",size=0.2))+ theme(panel.grid.minor = element_blank())+ theme(panel.grid.major = element_line(colour = "lightgrey", size = 0.1))+ theme(panel.spacing = unit(2, "mm"))+ theme(strip.text = element_text(size=8), strip.background = element_rect(colour="black",size=0.2))+ scale_colour_identity()+ scale_x_reverse() #scale_x_continuous(breaks=-seq(0,max.d,by=0.05))+ #scale_x_continuous(breaks=seq(1,max.d))+ #expand_limits(x = c(.1,max.d+.1)) for (dev in c(".png",".pdf")){ g.out <- paste0(chm.analysis.n.centralities,"ugs_",gt.i, "_centralities_by_decorations",dev) ggsave(g.out, gg.glob, height = (nrow(mean.by.var)/2)+5, width = 12) } } shell.exec(g.out)
ug proximities
Calculate the averages of shortestpaths between a each types of nodes
corpus <- "family" # choose 'objects' or 'family' graphs <- create.graph.view(v.select.obj,corpus) # call function to create view lgrph <- load.graphs(graphs)[[1]] # load graphs lgrph.no.att <- list() # remove node attributes for (i in 1:length(lgrph)){ #i <- 1 g <- lgrph[[i]] g <- rm.by.edge.type(g,'+');g <- rm.by.edge.type(g,'>') lgrph.no.att[[length(lgrph.no.att)+1]] <- g } dist.df <- f.dist.df(lgrph.no.att) # get distances btw nodes # remove indet dist.df$Var2 <- as.character(dist.df$Var2) if (length(grep("indet",dist.df$Var2))>0){ dist.df <- dist.df[-grep("indet",dist.df$Var2),] } dist.df$Var1 <- as.character(dist.df$Var1) if (length(grep("indet",dist.df$Var1))>0){ dist.df <- dist.df[-grep("indet",dist.df$Var1),] } #unique(dist.df$value) # TODO: add colors of dendog lthms <- sort(unique(dist.df$Var1)) # unique thm sorted # lthms for (thm in lthms){ #thm <- "bouclier" dist.df.thm <- dist.df[dist.df$Var1 == thm,] # remove 'indet*' if exist #print(paste0("theme '",thm,"', number of other thms: ",nrow(dist.df.thm))) #my.width <- ceiling(nrow(dist.df.thm)/30) mean.by.var <- aggregate(dist.df.thm$value, by=list(thm=dist.df.thm$Var2), FUN=mean) # reorder mean.by.var <- mean.by.var[with(mean.by.var,order(-x)), ] mean.by.var$thm <- factor(mean.by.var$thm,levels = mean.by.var$thm) #print(nrow(dist.df.thm)) dist.df.thm$Var1 <- NULL count.by.var <- as.data.frame(t(table(dist.df.thm$Var2))) # effectives names(count.by.var)[names(count.by.var) == 'Freq'] <- "nb" sum.by.var <- aggregate(dist.df.thm$value, by=list(Var2=dist.df.thm$Var2), FUN=sum) names(sum.by.var)[names(sum.by.var) == 'x'] <- "x" relfreq.by.var <- merge(sum.by.var,count.by.var,by="Var2") # reorder proximite.moyenne <- relfreq.by.var$x/relfreq.by.var$nb # reoder on average of proximities and effectives relfreq.by.var <- relfreq.by.var[with(relfreq.by.var,order(-proximite.moyenne, x)), ] #relfreq.by.var <- relfreq.by.var[rev(order(relfreq.by.var$x/relfreq.by.var$Freq)),] dist.df.thm$Var2 <- factor(dist.df.thm$Var2,levels = relfreq.by.var$Var2) tit.corpus <- f.tit.corpus(corpus,length(unique(dist.df.thm$dec)),nrow(dist.df.thm)) the.tit <- paste0("distance between '",thm,"' and other types of ugs ", tit.corpus,"\nwith numero of decorations, colors refer to dendrogram") max.d <- max(dist.df.thm$value) pos <- position_jitter(w=0,h=.2) llgg <- list() if (nrow(dist.df.thm)>1){ # if not: Viewport has zero dimension(s) ggplot gg.dist <- ggplot(dist.df.thm, aes(x=value, y=Var2, colour=color)) + #ggplot(dist.df.thm, aes(x=value, y=Var2)) + ggtitle(the.tit)+ # the mean geom_point(data=mean.by.var, aes(x=x,y=thm), pch=3, size=2, color="red")+ geom_text_repel(data=mean.by.var, aes(x=x,y=thm,label=round(x,1)), color="red", size=2)+ # the ugs geom_point(size=1, position = pos)+ geom_label_repel(data=dist.df.thm, position = pos, # jitter label=dist.df.thm$dec, segment.alpha = .5,segment.size = .2, #min.segment.length = 0, size=3, label.size=NA,fill = NA, # no box, no frame #force=0.01, # repulsion between lables box.padding=0.1, #direction="y", # move only on y-axis hjust= 0 )+ theme_bw() + theme(plot.title = element_text(size = 9, hjust = 0))+ theme(axis.text.x = element_text(size = 7,hjust = 1, vjust=0))+ xlab("distance")+ theme(axis.title.x = element_text(size=7))+ theme(axis.text.y = element_text(size = 7, vjust = 0, hjust=0.5))+ theme(axis.title.y = element_blank())+ theme(axis.ticks.length = unit(2, "pt"))+ theme(axis.ticks = element_line(colour = "black", size = 0.2))+ theme(panel.border=element_rect(colour="black",size=0.2))+ theme(panel.grid.minor = element_blank())+ theme(panel.grid.major = element_line(colour = "lightgrey", size = 0.1))+ theme(panel.spacing = unit(2, "mm"))+ theme(strip.text = element_text(size=8), strip.background = element_rect(colour="black",size=0.2))+ scale_colour_identity()+ scale_x_continuous(breaks=seq(1,max.d+1))+ expand_limits(x = c(.5,max.d+1.5)) llgg[[length(llgg)+1]] <- gg.dist for (dev in c(".png")){ #for (dev in c(".png",".pdf")){ g.out <- paste0(chm.analysis.n.proximities,"ugs_prox_from_",thm,"_by_types",dev) ggsave(g.out, gg.dist, height = ceiling(length(unique(dist.df.thm$dec))/10)+10, width =ceiling(length(unique(dist.df.thm$dec))/10)+10 ) } # ggsave(paste0(chm.analysis.n.proximities,thm,"_prox.png"), # gg.dist,width =max.d/1.5) } } shell.exec(g.out)
chronologie
# plot dated (left column) and undated ugs (rigth column) by objects #nme.dec <- paste0(chm.etude,"1-temps_ugs.png") graphs.objects <- create.graph.view(v.select.obj,"family") # call function to create view objets <- objects.df(graphs.objects) # objects #objets <- head(objets,30) # png(nme.dec,res=150,height = nrow(objets)*90,width = 2500 ) df.ugs <- ug.select.obj(objets) df.ugs$lbl <- paste0(df.ugs$site,'.',df.ugs$decor) df.ugs <- merge(df.ugs,graphs,by='lbl',all.x=T) # get the idf from graphs/objects df.tp.aq <- df.ugs.dat.miss.merged <- df.ugs[0, ] # loop through objects df.ugs.tp.aq <- df.ugs[!is.na(df.ugs$tpq),] df.ugs.dat.miss <- df.ugs[is.na(df.ugs$tpq),] # append df.tp.aq <- rbind(df.tp.aq,df.ugs.tp.aq) df.ugs.dat.miss.merged <- rbind(df.ugs.dat.miss.merged,df.ugs.dat.miss) # dated ugs mtpq <- min(df.tp.aq$tpq)-500 Mtaq <- max(df.tp.aq$taq) # chr_1 <- chr_tpq-chr_taq for (i in 1:nrow(df.tp.aq)){ if (df.tp.aq[i,"chr_1"] == 'xxx' & df.tp.aq[i,"tpq_cul"] != 'xxx'){ df.tp.aq[i,"chr_1"] <- paste0(df.tp.aq[i,"tpq_cul"],'-',df.tp.aq[i,"taq_cul"]) } } g.dated.ugs <- ggplot(df.tp.aq, aes(fill=chr_1)) + ggtitle("ugs with chronological attribution")+ geom_rect(aes(xmin = tpq, xmax = taq, ymin = idf-.3, ymax = idf+.3, color=chr_1), fill=NA,size=0.7,linetype=5,alpha=0.3)+ geom_label_repel(aes(x = tpq, y = idf,label =paste0(id,'.',type),colour=chr_1),segment.alpha=.5, size=2.5,box.padding=0,label.padding = 0.1, label.size = NA, fill="white",parse = F)+ geom_text(data=objets, aes(x =mtpq, y =as.integer(objets$idf), label=objets$lbl), size=2.5,hjust=0)+ scale_y_continuous(trans = "reverse", breaks = rev(unique(df.ugs$idf)))+ scale_x_continuous(limits=c(mtpq,Mtaq))+ theme_bw()+ guides(colour = guide_legend(override.aes = list(size = 5)))+ theme(panel.grid.minor = element_blank())+ theme(legend.key=element_rect(fill=NA), legend.position="bottom") # undated ugs - - - - - - - - - - g.undated.ugs <- ggplot(df.ugs.dat.miss.merged) + ggtitle("ugs without chronological attribution")+ geom_point(aes(id,idf))+ geom_text_repel(aes(id,idf,label=paste0(id,'.',type)),segment.alpha=.5, cex=2.5)+ scale_y_continuous(trans = "reverse", breaks = rev(unique(df.ugs$idf)))+ scale_x_continuous(breaks=seq(1,max(df.ugs.dat.miss.merged$id)))+ theme_bw()+ theme(panel.grid.minor = element_blank()) legend <- g_legend(g.dated.ugs) # extract legend g.dated.ugs <- g.dated.ugs+theme(legend.position ='none') # remove legend g.date.ugs <- grid.arrange(g.dated.ugs,g.undated.ugs,legend, ncol=2,nrow=2, heights=c(10,1)) n.height <- ceiling(nrow(df.tp.aq)/8)+10 # height n.width.dat <- df.tp.aq %>% count(lbl) n.width.undat <- df.ugs.dat.miss.merged %>% count(lbl) n.width <- max(max(n.width.undat$n),max(n.width.dat$n)) n.width <- ceiling(n.width/2)+10 # height for (dev in c(".png",".pdf")){ g.out <- paste0(chm.analysis.n.chrono,"ugs_chrono_by_decorations",dev) ggsave(file = g.out, g.date.ugs, height = n.height, width = n.width) } shell.exec(g.out)
Edges analysis
heatmaps
on common edges
# plot the heatmap of common links between gaphs # renomme colonnes et lignes # TODO : seriate, see: "D:/Projet Art Rupestre/scripts/scripts_r/seriate_heatmap" # TODO : show (real) numeros of graphs corpus <- "family" # choose 'objects' or 'family' graphs <- create.graph.view(v.select.obj,corpus) # call function to create view # graphs <- head(graphs,30) lgrph <- load.graphs(graphs)[[1]] # load graphs # graphs names lnames.ok <- lnames.no <-c() for (i in 1:length(lgrph)){ lnames.ok <- c(lnames.ok,lgrph[[i]]$name) } # selection of hmap types loop.matrix <- c("all_decor","only_matching_decor") loop.attribut <- c(c("+"),c("")) # loop.matrix <- c("all_decor") # loop.attribut <- c(c("+")) for (zero in loop.matrix){ # for (zero in c("all_decor","only_matching_decor")){ # matrix of all decors or matrix of ddecor that match a leats once for (att in loop.attribut){ # loop on different attributes #without.attr <- c("+") # choose "+", "", etc. to suppress attributes # att <- c(""); att <- c("+") df.same_edges <- f.same.edges(lgrph,att) if (zero == "only_matching_decor"){ # get where sum is null to remove from df sums <- as.integer(apply(df.same_edges, 1, sum, na.rm = T)) # row sum sum.is.0 <- which(!is.na(match(sums, 0))) df.same_edges <- df.same_edges[-c(sum.is.0),] # rm row df.same_edges <- df.same_edges[,-c(sum.is.0)] # rm col tit.match_typ <- "\nwith decorations having at least one common edge with the orthers" df.tab <- lnames.ok[-sum.is.0] } if (zero == "all_decor"){ # no transformations tit.match_typ <- "\nwith decorations having at least one common edge with the orthers" df.tab <- lnames.ok } # df.same_edges <- df.same_edges[df.same_edges$sum > 0,] # df.same_edges[nrow(df.same_edges) + 1,] = apply(df.same_edges, 2, sum, na.rm = T) # row sum # df.same_edges <- f.same.edges(lgrph,c("+")) df.same_edges[lower.tri(df.same_edges,diag=T)] <- NA #df.same_edges <- as.data.frame(mat.same_edges) rownames(df.same_edges) <- seq(1:nrow(df.same_edges)) names(df.same_edges) <- seq(1:ncol(df.same_edges)) melt.df.same_edges <- reshape2::melt(as.matrix(df.same_edges)) ifelse(att == "+", tit.attr <- "_without_attributes", tit.attr <- "_with_attributes") tit <- paste0("hmap_common_e_",zero,tit.attr) # tit for filename tit.plot <- paste0("heatmap on decoration common edges", "\nfor '",zero,"' of the family '",select.family,"'", "\ncommon edges are counted '",tit.attr,"'", "\nnb of objects: ",nrow(graphs)," ; nb of graphs: ",length(lgrph),"\n") # heatmap heat.mat <- ggplot(data = melt.df.same_edges, aes(x=Var1, y=Var2, fill=value)) + ggtitle(tit.plot)+ geom_tile(na.rm = T) + scale_fill_gradient2(#low = "blue", high = "red", name="Symetric matrix\nof the intersections\nbetween graphs", na.value = 'white', breaks=c(1,3,8,12,18))+ geom_text(aes(Var1, Var2, label = value), color = "black", size = 3)+ theme_minimal()+ theme(axis.title = element_blank())+ theme(legend.position = "none")+ scale_x_discrete(position = "top", limits=seq(1:nrow(df.same_edges)))+ scale_y_discrete(limits=seq(1:nrow(df.same_edges))) ## save # heatmap dim.hmp <- 3+(nrow(df.same_edges)/4) out.gg <- paste0(chm.clustering,tit,".png") ggsave(out.gg, width = dim.hmp, height = dim.hmp, units = "in") # correspondance table df.tab.c <- as.data.frame(df.tab) df.tab.c$df.tab <- as.character(df.tab.c$df.tab) df.tab.c$idf <- rownames(df.tab.c) df.tab.c$site <- sub("\\..*", "", df.tab.c$df.tab) df.tab.c$decor <- sub(".*\\.", "", df.tab.c$df.tab) df.tab.c <- subset(df.tab.c,select=c('idf','site','decor')) ltab <- f.split.df(df.tab.c,25) # split df dim.df <- ceiling(nrow(df.tab.c)/length(ltab)*.8) # for heights out.dd<- paste0(chm.clustering,tit,"_tab.png") # tgrob <- tableGrob(df.tab.c, # theme = ttheme_default(base_size = 8, # padding = unit(c(2,2), "mm")), # cols = NULL,rows=F) tgrob <- grid.arrange(grobs = ltab, ncol = length(ltab)) ggsave(out.dd,tgrob, height = dim.df/2,width = length(ltab)*4) } } shell.exec(out.dd);shell.exec(out.gg)
on edges similarities TODO
corpus <- "objects" # choose 'objects' or 'family' without.attr <- c("") # choose "+", "", etc. to suppress attributes graphs <- create.graph.view(v.select.obj,corpus) # call function to create view lgrph <- load.graphs(graphs)[[1]] # load graphs df.same_edges <- f.same.edges(lgrph,without.attr) df.same_edges[lower.tri(df.same_edges,diag=T)] <- NA around <- T # nb of same edges / total of edges df.same_edges.cor <- f.edge.similarity(df.same_edges,around) #diag(df.same_edges.cor) <- NA # remplit la diagonale df.same_edges.cor[lower.tri(df.same_edges.cor)] <- NA melt.df.same_edges.cor <- reshape2::melt(as.matrix(df.same_edges.cor)) # title ifelse(without.attr == "+", tit.attr <- "without_attributes", tit.attr <- "with_attributes") tit <- paste0("hmap_similarity_e_",tit.attr,".png") # heatmap heat.mat <- ggplot(data = melt.df.same_edges.cor, aes(x=Var1, y=Var2, fill=value)) + geom_tile(na.rm = T) + scale_fill_gradient2(#low = "blue", high = "red", name="Similarity matrix\nof the intersections\nbetween graphs", na.value = 'white' #breaks=c(1,3,8,12,18) )+ geom_text(aes(Var1, Var2, label = value), color = "black", size = 3)+ theme_minimal()+ theme(axis.title = element_blank())+ theme(legend.position = "none")+ scale_x_discrete(limits=seq(1:nrow(df.same_edges.cor)))+ scale_y_discrete(limits=seq(1:nrow(df.same_edges.cor))) # save out.gg <- paste0(chm.clustering,tit) ggsave(out.gg, width = 1+nrow(df.same_edges.cor)/4, height = 1+nrow(df.same_edges.cor)/4, units = "in") shell.exec(out.gg)
classifications on edges correlations
dendrogramm
# YYY # clustering/dendrogramm by edge betweenness # create the dataframe 'df.dist.mat.sel' with colors # cf. https://stackoverflow.com/questions/27004890/how-to-transform-the-following-similarity-matrix-to-distance-matrix-for-performi # TODO: show decoration numbers for "ordered.dendro <- F" # TODO: 'select.superfamily' # TODO: change Foios to Baracal as origin for warrior stelaes # chm.super.family # parameters - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - select.completness <- T # if TRUE apply the f.ugs.incomplete() function corpus <- "super.family" # choose 'objects' or 'family' or 'super.family' without.attr <- c("") # choose "+", "", etc. to suppress attributes dendro.cut <- T ; nb.clusters <- 3 # cut and color branches for nor reordened dendro col.clusters <- brewer.pal(nb.clusters,"Paired") # pastel colors for branches devs <- c('.png') # types of output files, ex: c('.png','.pdf') # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # if origin exists, order dendro leafs and branches on origin, a.select <- ifelse(corpus=="family", select.family, ifelse(corpus=="super.family",select.superfamily, ifelse(corpus=="objects",select.obj,NA))) idx <- findex(lorigins.all, a.select) # get the name of the origins if exists, for dendrogramm orig.thm <- lorigins.all[[idx]][[2]] # origin from where the distances/colors are computed ifelse(!is.null(orig.thm),ordered.dendro <- T,ordered.dendro <- F) #ordered.dendro <- F # - - - - - - - - - - - - - - - - - - - - - - - - graphs <- create.graph.view(v.select,corpus) # call function to create view lgrph <- load.graphs(graphs)[[1]] # load graphs if(select.completness){ lugs.incompl <- f.ugs.incomplete(lgrph, 0.75, FALSE, 10) # get index of most incomplet decoration lgrph <- lgrph[-lugs.incompl] # remove these incomplete decorations } # get names, and total number of nodes g.names <- c() ; g.nb.nd <- 0 for (i in 1:length(lgrph)){ # i <- 1 g <- lgrph[[i]] g.names <- c(g.names,g$name) g.nb.nd <- g.nb.nd+gorder(g) } tit.corpus <- f.tit.corpus(corpus,length(lgrph),g.nb.nd) df.same_edges <- f.same.edges(lgrph,without.attr) # get where sum is null to remove from df sums <- as.integer(apply(df.same_edges, 1, sum, na.rm = T)) # row sum sum.is.0 <- which(!is.na(match(sums, 0))) if(length(sum.is.0)>0){ df.same_edges <- df.same_edges[-c(sum.is.0),] # rm row df.same_edges <- df.same_edges[,-c(sum.is.0)] # rm col g.names <- g.names[-sum.is.0] } # sort(unique(as.vector(as.matrix(df.same_edges)))) df.same_edges.cor <- f.edge.similarity(df.same_edges,F) #lbls <- paste0(rownames(graphs),'.',graphs$site,'.',graphs$numero) row.names(df.same_edges.cor) <- colnames(df.same_edges.cor) <- g.names dist.mat <- dist(df.same_edges.cor) res <- hclust(as.dist(dist.mat)) # ,method="ward.D" # dendro parameter for ggplot label.siz <- max(nchar(res$labels)) # the max large label of the dendro height.siz <- max(res$height) # the height of the dendro # convert from "hclust" to "denddrogram" class dendro.bc <- as.dendrogram(res) # - - - - - - - - - - - - - - - - - - ifelse(without.attr == "+",tit.attr <- "without",tit.attr <- "with") ifelse(corpus == "objects", tit.corpus.typ <- paste0("selected objects from ",select.family," family "), tit.corpus.typ <- paste0("all objects from ",select.family," family ") ) # title on the file dendro.title <- "clustering of decoration's compositions based on the 'edge.similarity' index " dendro.title <- paste0(dendro.title,tit.attr," nodes attributes") tit <- paste0("clustering of ",tit.corpus.typ,tit.attr) # title of the file #ordered.dendro <- T if (!ordered.dendro){ # labels graphs.labels <- subset(graphs, select=c("idf","lbl","self","fam")) # remove graphs not in dendro # setdiff(labels(dendro.bc),graphs.labels$lbl) miss.in.dendro <- setdiff(graphs.labels$lbl,labels(dendro.bc)) graphs.labels <- subset(graphs.labels, lbl %notin% miss.in.dendro) # rm missing in dendro graphs.labels$lbl <- factor(graphs.labels$lbl,levels = labels(dendro.bc)) graphs.labels <- graphs.labels[with(graphs.labels, order(lbl)), ] # order graphs.labels$label <- paste0(graphs.labels$idf,'.',graphs.labels$lbl) # TODO: color on family # TODO: a function from text below if (select.choice == "select.superfamily"){ # studied families st.families <- paste0("('",paste0(unique(graphs.labels$fam),collapse = "','"),"')") drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") sqll <- paste0("SELECT * FROM famille WHERE famille IN ",st.families) # print(sqll) families.colors <- dbGetQuery(con,sqll) #print(paste0("'famille_super' field of 'object' table is updated for '",a.family,"' family")) dbDisconnect(con) # disconnect } graphs.labels <- merge(graphs.labels,families.colors,by.x="fam",by.y="famille",all.x=T) # TODO: anthropomorph graphs.labels$self[graphs.labels$self == "anthropomorphe"] <- 15 graphs.labels$self[is.na(graphs.labels$self)] <- 16 graphs.labels$self <- as.numeric(graphs.labels$self) # TODO: boxes by clusters # plot dendrogram gg.dend <- dendro.bc %>% set("branches_lwd", .5) %>% set("leaves_pch", graphs.labels$self) %>% set("leaves_cex", 1.5) %>% set("leaves_col", graphs.labels$famille_colors) %>% set("labels",graphs.labels$label) %>% set("labels_cex", .6) %>% set("labels_col", graphs.labels$famille_colors) if (dendro.cut){ # cut dendro clust <- cutree(res, k = nb.clusters, h = NULL) clust <- as.data.frame(clust) clust$lbl <- rownames(clust) # colors -> df df.col.clusters <- data.frame(clust=seq(1,length(col.clusters)), color=col.clusters) # merge colors of branches and decor, used in § spatial df.clust <- merge(clust,df.col.clusters,by.x="clust",by.y="clust",all.x=T) # add colors for branches gg.dend <- color_branches(gg.dend, k = 3, col = col.clusters) # gg.dend <- gg.dend %>% # set("branches_k_color", k=nb.clusters, col=c(3,1,4)) # plot(gg.dend) # rect.dendrogram(gg.dend , k=2, border = "red", lty = 5, lwd = 2) # gg.dend <- gg.dend %>% # plot %>% # rect.dendrogram(k=3,) } } if (ordered.dendro){ # plot a dendrogramm colored and reodered on a selected origin, ex: c("Foios","Foios") flag.dendro.color <- T # update flag for other ananlysis # dist matrix from the choosed origin orig.thm <- paste0(orig.thm,collapse=".") df.dist.mat <- melt(as.matrix(dist.mat), varnames = c("obj.A", "obj.B")) df.dist.mat.sel <- df.dist.mat[df.dist.mat$obj.A == orig.thm,] # title #orig.thm.lbl <- paste0(orig.thm,collapse=".") dendro.title <- paste0(dendro.title,"\nreordered and colored depending on '",orig.thm, "' decoration distances (ie, dissimilarities)") df.dist.mat.sel$obj.A <- NULL # create df or corresponding colors - - - - - nb.values <- unique(sort(df.dist.mat.sel$value)) color.offset <- 4 # to avoid too clear colors nb.colors <- rev(GetColors(n = length(nb.values)+color.offset,scheme = "smooth rainbow")) nb.colors <- nb.colors[c(1:(length(nb.colors)-color.offset))] # subset colors df.val.cols <- data.frame(value=nb.values, color=nb.colors, stringsAsFactors = F) # get 'self' to identify 'anthropomorphe' supports df.self <- subset(graphs,select=c("lbl","self")) df.self$self[df.self$self == "anthropomorphe"] <- 15 df.self$self[is.na(df.self$self)] <- 16 df.self$self <- as.integer(df.self$self) #df.self$lbl <- gsub(' ', '.', df.self$lbl) # replace ' ' by '.' # reorder on value df.dist.mat.sel <- df.dist.mat.sel[with(df.dist.mat.sel, order(value)), ] # df.dist.mat.sel$idf <- 1:nrow(df.dist.mat.sel) df.dist.mat.sel$ord <- 1:nrow(df.dist.mat.sel) # change rownames row.names(df.dist.mat.sel) <- df.dist.mat.sel$ord # order.dend <- as.numeric(row.names(df.dist.mat.sel)) # new order # merge with idf, colors and self df.dist.mat.sel <- merge(df.dist.mat.sel,df.val.cols,by="value",all.x=T) df.dist.mat.sel <- merge(df.dist.mat.sel,df.self,by.x="obj.B",by.y="lbl",all.x=T) # get original idf graphs.idf <- subset(graphs,select=c("lbl","idf")) df.dist.mat.sel <- merge(df.dist.mat.sel,graphs.idf,by.x='obj.B',by.y='lbl',all.x=T) # graphs.idf <- subset(graphs,select=c("idf","lbl")) # df.dist.mat.sel <- merge(df.dist.mat.sel,graphs.idf,by.x="obj.B",by.y="lbl",all.x=T) # order leaves/branches order.dend <- order.dendrogram(dendro.bc) val.max <- max(df.dist.mat.sel$value) ; val.min <- min(df.dist.mat.sel$value) df.wts <- c() # loop through values to assign weights and get order for (i in order.dend){ # i <- 21 enr <- df.dist.mat.sel[df.dist.mat.sel$ord == i,] if(enr$value == val.min){df.wts <- c(df.wts,1000)} # closest if(enr$value <= val.max/2 & enr$value != val.min){df.wts <- c(df.wts,100)} # first half if(enr$value > val.max/2 & enr$value != val.max){df.wts <- c(df.wts,10)} # second half if(enr$value == val.max){df.wts <- c(df.wts,0)} # farsest } # order dendro.bc.reorder <- reorder(dendro.bc, df.wts) # reverse order dendro.bc.reorder <- rev(dendro.bc.reorder) # reoder df from the dendr order.dend <- order.dendrogram(dendro.bc.reorder) df.dist.mat.sel.ord <- df.dist.mat.sel[match(order.dend,row.names(df.dist.mat.sel)),] # sample labels df.val.cols <- f.sample.coloramp.dist(df.val.cols) # color ramp from the origin to the highest value - - - - - - - - - - - - - - g.colormap <- ggplot() + geom_point(data=df.val.cols, aes(x=x, y=y, colour=color), size=2, show.legend = FALSE) + geom_text(data=df.val.cols, aes(x=x, y=y, label=lbl, angle=90), size=2, hjust=1, vjust=0,show.legend = FALSE) + scale_colour_identity(guide="legend",breaks=df.val.cols$color)+ scale_x_discrete(labels = df.val.cols$value)+ theme_bw()+ theme(panel.border = element_blank(), panel.background = element_blank(), panel.grid.major = element_blank(), panel.grid.minor = element_blank(), axis.ticks = element_blank(), axis.text = element_blank(), axis.title = element_blank())+ theme(plot.margin = unit(c(0,0,0,0), "cm")) # attributes for "dendrogram" class gg.dend <- dendro.bc.reorder %>% set("branches_lwd", .5) %>% set("leaves_pch", df.dist.mat.sel.ord$self) %>% set("leaves_cex", 1.5) %>% set("leaves_col", df.dist.mat.sel.ord$color) %>% set("labels",paste0(df.dist.mat.sel.ord$idf,'.',df.dist.mat.sel.ord$obj.B)) %>% set("labels_cex", .6) %>% set("labels_col", df.dist.mat.sel.ord$color) } # convert from "dendrogram" to "ggdend" class gg.dend.gg <- as.ggdend(gg.dend) # add to title dendro.title <- paste0(dendro.title,"\n",tit.corpus,"\nsquares identify 'anthropomorphic' supports") g.dendro <- ggplot2::ggplot(gg.dend.gg, horiz = TRUE, offset_labels = -0.6)+ # ggtitle(dendro.title)+ # theme(plot.margin = unit(c(-2,0,-2,2), "lines"), theme(plot.margin = unit(c(0.5,0.5,0.5,0.5), "lines"), plot.title = element_text(size=9))+ expand_limits(y = c(height.siz,-(label.siz/3)))+ scale_x_continuous(expand = c(0.01,0.01)) out.plot <- g.dendro # by default # save - - - - - - - - - - - - - - - - - - - - if(ordered.dendro){ # dendro + colormap out.plot <- ggarrange(g.dendro,g.colormap, heights=c(20,1),nrow=2) # out.plot <- annotate_figure(out.plot, # top = text_grob(dendro.title, size = 10)) } h.dend <- ceiling(length(lgrph)/10)+5 for (dev in devs){ g.out <- paste0(chm.clustering,tit,dev) ggsave(g.out, arrangeGrob(out.plot, top = grid:: textGrob(dendro.title,x=0,hjust=0,gp = gpar(fontsize =10))), width = 12, height = h.dend, units = "in") ext <- dev # for the 'shell.exec' } shell.exec(paste0(chm.clustering,tit,ext))
type of edges (presence/absence)
# selected edges lsme.edg <- list(list("stele bouclier", list("bouclier","epee"), list("bouclier","lance"), list("miroir","epee"), list("miroir","lance"), list("miroir","peigne"), list("personnage","personnage"), list("personnage","fibule"), list("personnage","epee"), #list("bouclier","fibule"), list("personnage","lance"), list("bouclier","personnage"), list("arc","personnage"), list("personnage","chariot_char")) ) # get the rigth list idx <- findex(lsme.edg,select.family) sme.edg <- lsme.edg[[idx]] sme.edg[[1]] <- NULL # (sic) g.colored.dend <- gg.dend.gg$labels for (i in 1:nrow(g.colored.dend)){ g.colored.dend[i,"idf"]<- unlist(strsplit(as.character(g.colored.dend[i,"label"]),'.',fixed = T))[1] g.colored.dend[i,"site"] <- unlist(strsplit(as.character(g.colored.dend[i,"label"]),'.',fixed = T))[2] g.colored.dend[i,"decor"] <- unlist(strsplit(as.character(g.colored.dend[i,"label"]),'.',fixed = T))[3] } g.colored.dend$lbl <- paste0(g.colored.dend$site,".",g.colored.dend$decor) # fill a df with graph attributes df.graphs <- igraph::as_data_frame(lgrph[[1]]) # template df.graphs <- df.graphs[0,] # template for (i in 1:length(lgrph)){ df.graphs <- rbind(df.graphs,igraph::as_data_frame(lgrph[[i]])) } df.graphs$lbl <- paste0(df.graphs$site,".",df.graphs$decor) l.sme.edges <- c() for (sel.edg in 1:length(sme.edg)){ # loop through selected egdes # sel.edg <- 7 a.edg <- unlist(sme.edg[[sel.edg]]) edg.nme <- paste0(a.edg[1],'.',a.edg[2]) # name of the selected edge g.colored.dend[,edg.nme]<-NA # new column l.sme.edges <- c(l.sme.edges,edg.nme) for (edg in 1:nrow(df.graphs)){ # edg <- 1 lbl <- df.graphs[edg,"lbl"] edg.thm <- c(df.graphs[edg,"from"],df.graphs[edg,"to"]) equal.edg <- setequal(edg.thm,a.edg) # test if equal if(equal.edg){ idx <- as.integer(row.names(g.colored.dend[match(lbl,g.colored.dend$lbl),])) g.colored.dend[idx,edg.nme] <- 1 #df.sme.edg$lbl <- df.graphs[edg,"lbl"] } } } lbls <- unique(g.colored.dend$lbl) sel.fields <- c("lbl",l.sme.edges) g.df <- subset(g.colored.dend,select=c(sel.fields)) rownames(g.df) <- g.df$lbl g.df$lbl <- NULL # melt tabla2 <- g.df %>% as.data.frame() %>% rownames_to_column() %>% gather(Column, Value, -rowname) order.col <- unique(tabla2$Column) # same order as list # get order g.df$idf <- 1:nrow(g.df) g.df <- subset(g.df,select=c("idf")) ggdf <- merge(tabla2,g.df,by="rowname",by.y="row.names") ggdf$Column <- factor(ggdf$Column, levels = order.col) # plot tit <- paste0("partly seriated matrix of presence/absence for a sample of edges", "decoration are ordered same as clustering dendrogram") gg.sme.edg <- ggplot(ggdf, aes(x = Column, y = idf, fill = Value)) + ggtitle(tit) + geom_tile() + scale_fill_gradientn(name = "", colors = terrain.colors(10), na.value = NA) + #"#FFFFFF" scale_y_discrete(limits=1:length(lbls),labels=lbls, position = "left")+ scale_x_discrete(name = "", position = "top")+ theme_bw()+ theme(axis.text = element_text(size = 8), axis.text.x = element_text(angle = 45, hjust=0), axis.title.y = element_blank(), legend.position = "none", panel.border = element_blank()) # out.plot <- ggarrange(g.dendro,gg.sme.edg,ncol=2,widths = c(4,2)) # out.plot <- annotate_figure(out.plot, # top = text_grob(dendro.title, size = 9)) g.out <- paste0(chm.clustering,"dataframe_of_presence_absence_edges",".png") ggsave(g.out,gg.sme.edg, width = 20, height = 17,units = "in") shell.exec(g.out)
dendrogramm + type of edges (presence/absence) TODO
# TODO: plot presence absences of selected edge aside dendrogram # selected edges lsme.edg <- list(list("stele bouclier", list("bouclier","epee"), list("bouclier","lance"), list("bouclier","personnage"), list("personnage","epee"), list("personnage","lance"), list("personnage","chariot_char"), list("miroir","peigne")) ) # get the rigth list idx <- findex(lsme.edg,select.obj) sme.edg <- lsme.edg[[idx]] g.colored.dend <- gg.dend.gg$labels for (i in 1:nrow(g.colored.dend)){ g.colored.dend[i,"idf"]<- unlist(strsplit(as.character(g.colored.dend[i,"label"]),'.',fixed = T))[1] g.colored.dend[i,"site"] <- unlist(strsplit(as.character(g.colored.dend[i,"label"]),'.',fixed = T))[2] g.colored.dend[i,"decor"] <- unlist(strsplit(as.character(g.colored.dend[i,"label"]),'.',fixed = T))[3] } g.colored.dend$lbl <- paste0(g.colored.dend$site,".",g.colored.dend$decor) # fill a df with graph attributes df.graphs <- igraph::as_data_frame(lgrph[[1]]) # template df.graphs <- df.graphs[0,] # template for (i in 1:length(lgrph)){ df.graphs <- rbind(df.graphs,igraph::as_data_frame(lgrph[[i]])) } df.graphs$lbl <- paste0(df.graphs$site,".",df.graphs$decor) l.sme.edges <- c() for (sel.edg in 1:length(sme.edg)){ # loop through selected egdes # sel.edg <- 7 a.edg <- unlist(sme.edg[[sel.edg]]) edg.nme <- paste0(a.edg[1],'.',a.edg[2]) # name of the selected edge g.colored.dend[,edg.nme]<-NA # new column l.sme.edges <- c(l.sme.edges,edg.nme) for (edg in 1:nrow(df.graphs)){ # edg <- 1 lbl <- df.graphs[edg,"lbl"] edg.thm <- c(df.graphs[edg,"from"],df.graphs[edg,"to"]) equal.edg <- setequal(edg.thm,a.edg) # test if equal if(equal.edg){ idx <- as.integer(row.names(g.colored.dend[match(lbl,g.colored.dend$lbl),])) g.colored.dend[idx,edg.nme] <- 1 #df.sme.edg$lbl <- df.graphs[edg,"lbl"] } } } lbls <- unique(g.colored.dend$lbl) sel.fields <- c("lbl",l.sme.edges) g.df <- subset(g.colored.dend,select=c(sel.fields)) rownames(g.df) <- g.df$lbl g.df$lbl <- NULL # melt tabla2 <- g.df %>% as.data.frame() %>% rownames_to_column() %>% gather(Column, Value, -rowname) # get order g.df$idf <- 1:nrow(g.df) g.df <- subset(g.df,select=c("idf")) ggdf <- merge(tabla2,g.df,by="rowname",by.y="row.names") # plot gg.sme.edg <- ggplot(ggdf, aes(x = Column, y = idf, fill = Value)) + geom_tile() + scale_fill_gradientn(name = "", colors = terrain.colors(10), na.value = NA) + #"#FFFFFF" scale_y_discrete(limits=1:length(lbls),labels=lbls, position = "right")+ scale_x_discrete(name = "", position = "top")+ theme_bw()+ theme(axis.text = element_text(size = 8), axis.text.x = element_text(angle = 45, hjust=0), axis.title.y = element_blank(), legend.position = "none", panel.border = element_blank()) out.plot <- ggarrange(g.dendro,gg.sme.edg,ncol=2,widths = c(4,2)) out.plot <- annotate_figure(out.plot, top = text_grob(dendro.title, size = 9)) g.out <- paste0(chm.clustering,"xxBOTH",".png") ggsave(g.out,out.plot, width = 20, height = 17,units = "in") shell.exec(g.out)
spatial family/object
# after classification, spatial # YYY map.type <- "super.family" # "family", "super.family" m.var <- "clss" if (map.type=="family"){ df.clss <- family.df(select.family) # get objects coordinates for the family df.clss <- merge(df.clss,df.dist.mat.sel,by.x="idf.objects",by.y="idf",all.x=T) select.corpus <- select.family } if (map.type=="super.family"){ df.xy <- objects.df(graphs) # reload to get x,y df.xy <- subset(df.xy,select=c("lbl","idf","site","numero","type","x","y","fam")) # setdiff(df.clust$lbl,df.xy$lbl);setdiff(df.xy$lbl,df.clust$lbl) df.clss <- merge(df.clust,df.xy,by="lbl",all.x=T) select.corpus <- select.superfamily } # merge with classification colors sel.field <- c("idf","site","numero","type","x","y","color","fam") # selected fields df.clss.spat <- subset(df.clss,select=sel.field) miss.clss <- sum(is.na(df.clss.spat$color)) df.clss.spat$color[is.na(df.clss.spat$color)] <- "#FFFFFF" # white df.clss.spat$fam <- gsub("stele","st",df.clss.spat$fam) # simplify families # df.clss.spat$idf <- as.integer(row.names(df.clss.spat)) # for df # df.clss.spat$color.from <- orig.thm # add the origin of the color (ex: Foios) df.clss.spat <- df.clss.spat[with(df.clss.spat,order(idf)), ] rownames(df.clss.spat) <- df.clss.spat$idf sf.fd.carto <- f.spat.bck.grd("Europe") # load background g.map <- f.spat.distrib(df.clss.spat,sf.fd.carto,map.type,select.corpus,m.var,42,8) # create map # nb.miss.mp <- nrow(family.spat[family.spat$mp == 'unknown',]) # nb of missiong mp tit <- paste0("distribution of '",m.var,"' from '",map.type, "' objects from '",select.corpus,"' (n = ",nrow(df.clss.spat)," )") if (ordered.dendro){tit <- paste0(tit,"\ncolor is function of khi2 distance from '", orig.thm,"' decoration")} chm.out <- paste0(chm.clustering,"spat_clustering.png") ggsave(file = chm.out, arrangeGrob(grobs = g.map, top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)), padding = unit(0.1, "line"),ncol = 1), width = 17,height =17) shell.exec(chm.out)
matrix TODO
calculate
# calculate the the pairwise matrix # ex. row 17 of ldecors: 'Madonna delle Grazie.item7' and 'Poggio Monaco.item95' have a common edge # export different images in 'matrix' folder size.margins <- "15x15" corpus <- "family" # choose 'objects' or 'family' graphs <- create.graph.view(v.select.obj,corpus) # call function to create view # graphs <- head(graphs,30) lgrph <- load.graphs(graphs)[[1]] # load graphs df.icos <- f.df.ico(v.select.obj) # lgrph <- load.graphs(graphs.objects)[1] # load graphs lgrph <- rm.specific.nd(lgrph,"indet") # remove indet # lgrph[[1]]$name lgrph_nmes <- c() for (i in 1:length(lgrph)){ lgrph_nmes <- c(lgrph_nmes,lgrph[[i]]$name) #print (lgrph[[i]]$name) } ldecors.comp <- t(combn(lgrph_nmes, 2)) # all pairwise comparisons print(paste0("there is ",nrow(ldecors.comp)," pairwise comparisons to compute")) for (dec in 1:nrow(ldecors.comp)){ #dec <- 1 a.compar <- paste0(ldecors.comp[dec,],collapse=' - ') print (paste0(" ",dec,") comparaison: ",a.compar)) #print (paste0(" ",dec,") decoration ",cat(ldecors[dec,],sep=" - "))) ledges <- lnodes <- list() # list of two graph edges/nodes # function call- - for(n in c(1,2)){ # n <- 1 sit.1 <- df.icos[which(df.icos$idf == ldecors.comp[dec,n]), "site"] num.1 <- df.icos[which(df.icos$idf == ldecors.comp[dec,n]), "numero"] image.dec <- df.icos[which(df.icos$idf == ldecors.comp[dec,n]), "img"] # image rast.1 <- as.raster(image_read(image.dec)) # image to raster offset.img <- dim(rast.1)[1] # offset depend on raster size #print (offset.img) ledges[[length(ledges)+1]] <- edges.df(n,dec,sit.1,num.1) lnodes[[length(lnodes)+1]] <- nodes.df(sit.1,num.1) } # common edges graph.a <- ledges[[1]];graph.b <- ledges[[2]] nme.a <- unique(paste0(graph.a$site,'.',graph.a$decor)) nme.b <- unique(paste0(graph.b$site,'.',graph.b$decor)) graphs.nmes <- c(paste0(nme.a,'_',nme.b),paste0(nme.b,'_',nme.a)) l.common.edges <- intersect(unique(graph.a$rel),unique(graph.b$rel)) for (j in c(1,2)){ #j <- 1 nodes.j <- lnodes[[j]];graph.j <- ledges[[j]] common.edges.j <- graph.j[which(graph.j$rel %in% l.common.edges),] a.img <- image_read(unique(graph.j$image.dec)) #image.dec.1 <- unique(graph.a$image.dec) #print(unique(graph.j$image.dec)) #dec.nme <- unique(paste0(graph.j$site,'.',graph.j$decor)) rast.j <- as.raster(a.img) # image to raster # decor + graph - - chm.out <- paste0(chm.matrix,graphs.nmes[j],'.png') png(chm.out);plot(rast.j) # add all edges for (edg in 1:nrow(graph.j)){ lines(c(graph.j[edg,"xa"],graph.j[edg,"xb"]), c(graph.j[edg,"ya"],graph.j[edg,"yb"]), lwd=4,col="orange") } # add common edges for (edg in 1:nrow(common.edges.j)){ lines(c(common.edges.j[edg,"xa"],common.edges.j[edg,"xb"]), c(common.edges.j[edg,"ya"],common.edges.j[edg,"yb"]), lwd=8,col="red") } # add nodes points(c(nodes.j$x), c(nodes.j$y), pch=16,cex=1.5,col="orange") dev.off() } } # trim images for (img in list.files(chm.matrix)){ img.dec <- image_read(paste0(chm.matrix,img)) img.dec <- image_trim(img.dec) # trim # add white margins img.dec <- image_border(img.dec,"#FFFFFF", size.margins) chm.out <- paste0(chm.matrix,img) image_write(img.dec, chm.out, format = "png") }
draw
# draw the square matrix planche df.icos <- f.df.ico(v.select.obj) df.mtrx <- data.frame(matrix(ncol = nrow(df.icos), nrow = nrow(df.icos))) rownames(df.mtrx) <- df.icos$idf colnames(df.mtrx) <- df.icos$idf limgs <- list() intitules <- textGrob(c(1:nrow(df.mtrx))) # intitules <- c("",LETTERS[1:nrow(df.mtrx)]) #limgs <- list("",textGrob(LETTERS[1:nrow(df.mtrx)])) # to store images # add first line # limgs[[length(limgs)+1]] <- textGrob("") # for (it in 1:nrow(df.mtrx)){ # limgs[[length(limgs)+1]] <- textGrob(it) # } objets <- objects.df(graphs) for (i in 1:nrow(objets)){ # save decor only to the 'matrix' folder for diag #i <- 1 sit.a<-objets[i,"site"];num.a<-objets[i,"numero"];lbl.a<-objets[i,"lbl"];idf.a<-objets[i,"idf"] img.diag <- paste0(chm.matrix,sit.a,'.',num.a,".png") img.a <- df.icos[df.icos$site == sit.a & df.icos$num == num.a,]$img img.a <- image_read(img.a) img.a <- image_trim(img.a) # trim # add white margins img.a <- image_border(img.a,"#FFFFFF", size.margins) # add border # add number img.a <- image_annotate(img.a, i, size = 60,gravity = "northwest", color = "black", boxcolor = "white") img.a <- image_negate(img.a) # invert diag image image_write(img.a, img.diag, format = "png") } #limgs[1:nrow(df.mtrx)] <- "",textGrob(LETTERS[1:nrow(df.mtrx)]) for (r in 1:nrow(df.mtrx)){ #r <- 1 #limgs[[length(limgs)+1]] <- textGrob(r) # add numbers for (c in 1:ncol(df.mtrx)){ if (r == c){ # the diagonal idf.diag <- df.icos[r,"idf"] img.diag <- image_read(paste0(chm.matrix,idf.diag,'.png')) #img.diag <- image_trim(img.diag) #img.diag <- image_border(img.diag, "black", "5x5") limgs[[length(limgs)+1]] <- image_ggplot(img.diag)+theme(plot.margin = unit(c(0,0,0,0), "cm")) } if (r != c){ # symetric idf.a <- rownames(df.mtrx)[r] idf.b <- colnames(df.mtrx)[c] idf.ab <- paste0(idf.a,"_",idf.b) img.ab <- image_read(paste0(chm.matrix,idf.ab,'.png')) img.ab <- image_background(img.ab, "grey") # add backgrond #img.ab <- image_trim(img.ab) limgs[[length(limgs)+1]] <- image_ggplot(img.ab)+theme(plot.margin = unit(c(0,0,0,0), "cm")) } } } # fill # diagonal with image only #grid.arrange(grobs = limgs, ncol = ncol(df.mtrx)) ifelse(ncol(df.mtrx)>49, s <- 49, s <-ncol(df.mtrx)) # ggsave(file = paste0(chm.groups,grp.name,"_spat.png"), # arrangeGrob(grobs = list(g.map+margin,tableGrob(objets.selected.tab,rows=NULL)), # top = grid::textGrob(grp.name,x=0,hjust=0,gp = gpar(fontsize =10)), # padding = unit(0.1, "line"),ncol = 1), # width = 6,height =nrow(objets.selected.tab)) #margin = theme(plot.margin = unit(c(0,0,0,0), "cm")) ggsave(paste0(chm.etude,"2-ico_matrix.png"), arrangeGrob(grobs = limgs, ncol = ncol(df.mtrx)), # arrangeGrob(grobs = limgs, ncol = ncol(df.mtrx)), width=s, height=s) shell.exec(paste0(chm.etude,"2-ico_matrix.png"))
UGS
Themes on decorations (ug) or real objects independently from 'famille' or 'selected objects'
# select.thms <- c("casque","epee","bouclier","carquois","lance","cuirasse","hallebarde","hache","poignard") #select.thms <- c("carquois","anciforme") #select.thms <- c("ciseau") select.thms <- c("piernabierto") # TODO: stats general Pg # select type, count (*) as tot from table_noeuds group by type order by tot desc
on decorations
corpus
# create an image with all object having the 'select.thm' #chm.ico.ug f.chm.ug(select.thms) # out folders contact.sheet.select.ugs(select.thms) # thms and number of img for a line for (select.thm in select.thms){ shell.exec(paste0(chm.ug.typo,select.thm)) # open the folder }
spatial
# spatial distribution of themes # select.thms <- "boucles_oreilles" map.type = "ugs" f.chm.ug(select.thms) # out folders for (select.thm in select.thms){ print(paste0("* read theme: ",select.thm," *")) ugs.spat <- f.ugs(select.thm) # get objects coordinates for the family sel.fields <- c("site.dec","site","decor","famille","x","y") ugs.spat <- subset(ugs.spat,select=sel.fields) df.ct <- as.data.frame(table(ugs.spat$site.dec)) # count of thm by decor ugs.spat.ct <- merge(ugs.spat,df.ct,by.x="site.dec",by.y="Var1") ugs.spat.ct <- ugs.spat.ct[!duplicated(ugs.spat.ct), ] # rm duplicated # ugs.spat <- aggregate(x=ugs.spat$site.dec, by=list(ugs.spat$site, # ugs.spat$decor, # ugs.spat$x, # ugs.spat$y), # FUN = count) # order by 'family','site','decor' ugs.spat.ct <- ugs.spat.ct[with(ugs.spat.ct, order(famille, site, decor)), ] rownames(ugs.spat.ct) <- 1:nrow(ugs.spat.ct) ugs.spat.ct$idf <- 1:nrow(ugs.spat.ct) # ugs.spat$lbl <- paste0(ugs.spat$site,'.',ugs.spat$decor) # n.obj <- length(unique(ugs.spat$lbl)) n.obj <- nrow(ugs.spat.ct) n.ugs <- sum(ugs.spat.ct$Freq) #family.spat$idf <- as.integer(row.names(family.spat)) sf.fd.carto <- f.spat.bck.grd("Europe") # load background #map.name <- unique(family.spat$famille) # nam for the output g.map <- f.spat.distrib(ugs.spat.ct,sf.fd.carto,map.type,select.thm,"all",25,8) # export map tit <- paste0("ugs distribution of '",select.thm,"' (n= ",n.ugs,") from ",n.obj," decorations") for (dev in c(".png",".pdf")){ g.out <- paste0(chm.ug.typo,select.thm,"/",map.type,"_spat",dev) # g.out <- paste0(chm.thm,select.thm,"_",map.type,"_spat",dev) ggsave(file = g.out, arrangeGrob(grobs = g.map, top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)), padding = unit(0.1, "line"),ncol = 1), width = ceiling(n.obj/10)+10,height =ceiling(n.obj/10)+10) } } # shell.exec(g.out)
stats
dimensions
within themes
# select.thms <- c("bracelet") for (select.thm in select.thms){ # select.thm <- c("carquois") print(paste0("* read theme: '",select.thm,"' *")) ugs.dim <- f.ugs(select.thm) # load ugs.dim$lbl <- paste0(ugs.dim$idf,".",ugs.dim$id) # like '1.5' ugs.dim.complets <- ugs.dim[ugs.dim$incomplet == 0,] # complet ugs.dim.complets <- ugs.dim.complets[!is.na(ugs.dim.complets$long_cm),] # cm exist ugs.dim.incomplets <- ugs.dim[ugs.dim$incomplet == 1,] # incomplets ugs.dim.incomplets <- ugs.dim.incomplets[!is.na(ugs.dim.incomplets$long_cm),] # cm exist exist.complets <- sum(ugs.dim.complets$long_cm,na.rm = T) exist.incomplets <- sum(ugs.dim.incomplets$long_cm,na.rm = T) # mean on complete ugs.long_cm.mean <- aggregate(ugs.dim.complets$long_cm, by=list(Category=ugs.dim.complets$type), FUN=mean) tit.res.test <- f.shapiro(ugs.dim.complets$long_cm,0.05,"long") # normality test # test.thres <- 0.05 # res.test <- shapiro.test(ugs.dim.complets$long_cm) # p.value <- round(res.test$p.value,2) # tit.test.incip <- "normality test shows distribution is " # tit.test.thres <- paste0("\nfor threshold '",test.thres,"' (p-value=",p.value,")") # tit.res.test <- ifelse(p.value > test.thres, # paste0(tit.test.incip,"'normal'",tit.test.thres), # paste0(tit.test.incip,"'not normal'",tit.test.thres) # ) # plot dim.max <- ceiling(max(ugs.dim$long_cm,na.rm = T))+1 dim.min <- ceiling(min(ugs.dim$long_cm,na.rm = T))-1 if(exist.complets>0){ tit <- paste0("dimensions of '",select.thm,"' ugs (n=",nrow(ugs.dim),") colored by families", "\nnumbers before '.' refers to decoration numeros", "\nnumbers after '.' refers to ugs numeros") # 1) boxplots - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - bxplt.w <- .02 pos <- position_jitter(width = .05, seed = 1) gg.dim.bp <- ggplot()+ ggtitle(tit)+ # boxplot on complete geom_boxplot(data=ugs.dim.complets, aes(y=long_cm), color="darkgrey", fill = NA, fatten = 1.5, width=0.2,lwd=0.5,outlier.shape = NA) + # mean geom_point(data=ugs.long_cm.mean, aes(x=0, y=x), pch =3, size=3, color="red") + geom_text(data=ugs.long_cm.mean, aes(x=0, y= x, label=round(x,2), hjust=-.5), size = 3, color = "red") + # complete ugs geom_point(data=ugs.dim.complets, aes(x=0,y=long_cm,color=famille), position = pos,size=2,stroke = 0) + # ugs geom_label_repel(data=ugs.dim.complets, aes(x=0,y=long_cm,label=lbl,color=famille), force = .5, segment.size = .3, segment.alpha = .5, size = 3, label.size = NA, fill= NA, position = pos) + theme_bw()+ theme(plot.title = element_text(size = 10))+ theme(axis.title.x = element_blank())+ theme(axis.text.x = element_blank())+ theme(axis.ticks.x = element_blank())+ theme(axis.text=element_text(size=7))+ theme(legend.position="bottom")+ scale_alpha_identity()+ # scale_color_identity()+ scale_y_continuous(breaks = seq(dim.min,dim.max, by = 2)) + #ylim(dim.min,dim.max)+ # scale_y_continuous(breaks = seq(0,max(ugs.dim$long_cm), by = 5)) + #scale_y_continuous(breaks = seq(0,max(ugs.dim$long_cm,na.rm = T),by =2)) scale_x_continuous(breaks = NULL) # 2) histo - - - - - - - - - - - - - - - - - - - - - - - - gg.dim.hist <- ggplot(ugs.dim.complets, aes(x = long_cm)) + geom_histogram(colour = "black", fill = "grey", binwidth = 2,alpha=.5)+ geom_vline(data=ugs.dim.complets,aes(color=famille), xintercept = ugs.long_cm.mean$x)+ stat_function(fun = dnorm, args = list(mean = mean(ugs.dim.complets$long_cm), sd = sd(ugs.dim.complets$long_cm)))+ scale_x_continuous(breaks = seq(dim.min,dim.max,by=2))+ theme_bw()+ coord_flip() } if(exist.incomplets>0){ # add points to boxplots ugs.dim.incomplets$lbl <- paste0("italic('",as.character(ugs.dim.incomplets$lbl),"')") gg.dim.bp <- gg.dim.bp + geom_point(data=ugs.dim.incomplets, aes(x=0,y=long_cm,alpha=.5,color=famille), position = pos,size=2,stroke = 0) + # ugs geom_label_repel(data=ugs.dim.incomplets, aes(x=0,y=long_cm,label=lbl,color=famille), force = .5, segment.size = .3, segment.alpha = .5, size = 3, label.size = NA, fill= NA, position = pos, alpha=.5, parse = TRUE) } if(exist.complets>0){ # save ugs.dim.tab <- subset(ugs.dim,select=c("lbl","site.dec")) # 3) dataset - - - - - - - - - - - - - - - - - - - - - - t.grob <- f.corresp.tab(ugs.dim.tab,50) # tableGrob # 4) test result - - - - - - - - - - - - - - tit.res.test.grob <- textGrob(tit.res.test, gp = gpar(fontsize = 8)) # add all to list plist <- list(gg.dim.bp,gg.dim.hist,t.grob,tit.res.test.grob) h <- ceiling(nrow(ugs.dim.tab)/3)+5 w <- 5*2 for (dev in c(".png",".pdf")){ # dev <- ".png" g.out <- paste0(chm.ug.typo,select.thm,"/ugs_dim",dev) # g.out <- paste0(chm.thm,select.thm,"_",map.type,"_spat",dev) ggsave(file = g.out, arrangeGrob(grobs = plist, nrow = 2), width = w,height =h) } } } #shell.exec(g.out)
between themes
# TODO: plot distributions of different themes in the same plot #select.thms <- c("carquois","anciforme") ugs.dim.all <- data.frame(site=character(0), decor=character(0), type=character(0), incomplet=numeric(0), long_cm=numeric(0), stringsAsFactors = F) for (select.thm in select.thms){ # select.thm <- "carquois" print(paste0("* read theme: '",select.thm,"' *")) ugs.dim <- f.ugs(select.thm) # load #ugs.dim$lbl <- paste0(ugs.dim$idf,".",ugs.dim$id) # like '1.5' #ugs.dim.complets <- ugs.dim[ugs.dim$incomplet == 0,] # complet ugs.dim <- subset(ugs.dim,select=c("site","decor","type","incomplet","long_cm")) ugs.dim.all <- rbind(ugs.dim.all,ugs.dim) } ugs.dim.all.complets <- ugs.dim.all[ugs.dim.all$incomplet == 0,] # complet ugs.dim.all.complets.cm <- ugs.dim.all.complets[!is.na(ugs.dim.all.complets$long_cm),] # cm exist nme.families <- paste0(select.thms,collapse=", ") # 1) boxplot - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # 2) histo - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - tit.hist <- paste0("density distribution with normal curve for:\n'",nme.families,"' families", "\ncolored by themes") gg.dim.hist <- ggplot(ugs.dim.all.complets.cm, aes(long_cm, fill = type)) + ggtitle(tit.hist)+ geom_histogram(alpha = 0.5, aes(y = ..density..), position = 'identity')+ stat_function(fun = dnorm, args = list(mean = mean(ugs.dim.all.complets.cm$long_cm), sd = sd(ugs.dim.all.complets.cm$long_cm)))+ theme_bw()+ coord_flip() g.out <- paste0(chm.doc,"ugs_dim.png") # g.out <- paste0(chm.thm,select.thm,"_",map.type,"_spat",dev) ggsave(file = g.out, gg.dim.hist, width = 10,height =10) # ggplot(vegLengths, aes(length, fill = veg)) + # geom_histogram(alpha = 0.5, aes(y = ..density..), position = 'identity')
real objects
corpus
contact.sheet.real.objects(select.thms) # thms and number of img for a line
listing TODO
# tableau des objets véritables # select.thm <- c("casque") drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") sql_obj <- paste0("SELECT objets.site,objets.structure,objets.numero,objets.type,ST_X(objets.geom) as x,ST_Y(objets.geom) as y, tpq,taq FROM objets WHERE objets.type LIKE '",select.thm,"'") all_obj <- dbGetQuery(con,sql_obj) # met 'chrono' = 1 quand l'interval correspond all_obj$chrono <- NA for (i in seq(1,nrow(all_obj))){ all_obj[i,"chrono"] <- ifelse(Overlap(chrono.limit,c(all_obj[i,"tpq"],all_obj[i,"taq"])) > 0, 1, 0) } all_obj <- subset(all_obj, chrono == 1) all_obj$chrono <- NULL tab_obj <- subset(all_obj,select=c("site","structure","numero","tpq","taq")) ktab_obj <- kable(tab_obj, "html", booktabs = TRUE, longtable = TRUE, caption = paste0("Objets véritables identiques au thème <b>",select.thm,"</b>")) %>% kable_styling(latex_options = c("hold_position", "repeat_header")) #tt <- ttheme_default(colhead=list(fg_params = list(parse=TRUE))) #grid.table(ktab_dec,theme=mythm) #print(paste("les noeuds qui ont aucun lien avec les autres thèmes sont:",ug_ss_liens)) ktab_obj invisible(dbDisconnect(con))
spatial
map.type <- "archeo" drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") #select.thms <- c("bouclier") for (select.thm in select.thms){ print(paste0("* read theme: ",select.thm," *")) sqll <- paste0("SELECT site,numero,type,ST_X(geom) as x,ST_Y(geom) as y FROM objets ", "wHERE type LIKE '",select.thm,"'") select.thm.spat <- dbGetQuery(con,sqll) if (nrow(select.thm.spat)>0){ # at least one object to plot # ugs.spat <- f.ugs(select.thm) # get objects coordinates select.thm.spat$idf <- 1:nrow(select.thm.spat) # ugs.spat$lbl <- paste0(ugs.spat$site,'.',ugs.spat$decor) n.obj <- nrow(select.thm.spat) #family.spat$idf <- as.integer(row.names(family.spat)) sf.fd.carto <- f.spat.bck.grd("Europe") # load background #map.name <- unique(family.spat$famille) # nam for the output g.map <- f.spat.distrib(select.thm.spat,sf.fd.carto,map.type,select.thm,"all",25,8) # export map tit <- paste0("real objects distribution of '",select.thm,"' (n= ",nrow(select.thm.spat),")") for (dev in c(".png",".pdf")){ g.out <- paste0(chm.thm,select.thm,"_",map.type,"_spat",dev) ggsave(file = g.out, arrangeGrob(grobs = g.map, top = grid::textGrob(tit,x=0,hjust=0,gp = gpar(fontsize =10)), padding = unit(0.1, "line"),ncol = 1), width = 17,height =17) } } } dbDisconnect(con) shell.exec(g.out)
COMPARISONS
Procustean analysis
library(png) # chm.procust <- "D:/Cultures_9/Epees/(Etude)/epees_poignees_branderm/" chm.procust <- "D:/Cultures_9/Armatures/(Etude)/armatures_clement/" # chm.procust.orig <- paste0(chm.procust,'originaux/') chm.procust.etude <- paste0(chm.procust,'(Etude)/') chm.procust.etude.png <- paste0(chm.procust.etude,'1_1/') # classification parameters - - - - - - - - - - - - - - - # essai: "minkowski"*"complete" -> BOF # "euclidian"*"complete" -> PAS MAL dist.meth <- "euclidian" # "euclidian" clust.meth <- "complete" # "ward.D2", "complete", "min" # clusters n_clust <- 5 # nb clusters, look to python result clust.colors <- c("blue","red","green","orange","violet","grey35","brown") # matrice des distances procusteenne issue de Python mat.dist <- paste0(chm.procust.etude,"mat_dist.xlsx") dist.mtx <- openxlsx::read.xlsx(mat.dist, skipEmptyRows=TRUE) # chm.procust.etude.png <- paste0(getwd(),'/1_1/',sep='') row.names(dist.mtx) <- as.character(dist.mtx[,1]) dist.mtx[,1]<- NULL list.figs <- as.list(colnames(dist.mtx)) # simplify names colnames(dist.mtx) <- rownames(dist.mtx) <- gsub(x = names(dist.mtx), pattern = ".tif", replacement = "") fig.tot <- length(list.figs) fig.silex <- 0 fig.comp <- 0 # - - - - - - - - - - - - - - - - - - - - # classify on hc dendr <- as.dist(t(dist.mtx),dist.meth) %>% scale %>% dist %>% hclust(clust.meth) dend1 <- dendr %>% as.dendrogram # créé un 'dendrogram' # 'df.clusters' get colors on clusters df.clusters <- as.data.frame(cutree(dend1, k = n_clust, h = NULL)) # enregistre les clusters colnames(df.clusters)[1] <- 'cluster.hc' df.clusters$objects <- row.names(df.clusters) df.clusters$ord <- seq(1,nrow(df.clusters)) # ord initial df.clusters$ord <- factor(df.clusters$ord, levels = order.dendrogram(dend1)) df.clusters <- df.clusters[order(df.clusters$ord),] df.clusters$cluster.hc <- as.integer(as.character(df.clusters$cluster.hc)) # convert to integer df.clusters$color <- clust.colors[df.clusters[,"cluster.hc"]] dend1 <- dend1 %>% set("branches_lwd", .2) %>% set("labels_cex", 0.7) %>% #.3 set("labels_col", df.clusters$color) # get colors of df.clusters # functions - - - - - - - - - - - - - - - #diag(dist_mtx) <- 0 f <- function(m) { m[lower.tri(m)] <- t(m)[lower.tri(m)] m } #nmes_img <- row.names(dist_mtx) # nom des images fS <- function(dx,sl){ # informations sur les matrices et le dataset if (sl == "all"){ select.s <- "[0-9]$" } if (sl == "silex"){ select.s <- "^p[0-9]" } if (sl == "statue"){ select.s <- "stat[0-9]*$" } if (sl == "statue_a"){ #print ("ggkj") select.s <- "a$" } if (sl == "kh_ag"){ # Kharaysin et Ain Ghazal # supprime les statues_a #dx <- dist_mtx dist.s <- dx[,c(grep("[0-9]$",names(dx))), drop=F] # colonnes dist.s <- dist.s[grep("^s[0-9]", row.names(dist.s)),] # lignes dist.s <- dist.s[,c(grep("^stat",names(dist.s))), drop=F] # colonnes # quand on veut comparer les deux dataset (kh et ag), on ne supprime que # les colonnes ou que les lignes # supprime les statues (en col) # dist.s <- dist.s[,c(grep("^s[0-9]",names(dx))), drop=F] # colonnes # dist.s <- dist.s[grep("^s[0-9]", row.names(dist.s)),] # lignes # dist.s <- dist.s[-grep("^stat", row.names(dist.s)),] # lignes # dist.s <- dist.s[,c(-grep("^s[0-9]",names(dist.s))), drop=F] # colonnes # dist.s <- dist.s[,c(-grep("a$",names(dist.s))), drop=F] # colonnes } if (sl != "kh_ag"){ dist.s <- dx[,c(grep(select.s,names(dx))), drop=F] # colonnes dist.s <- dist.s[grep(select.s, row.names(dist.s)),] # lignes } #View(dist.s) # Min Mmin.s <- which(dist.s== min(dist.s,na.rm = TRUE), arr.ind = TRUE) Mmin.s.val <- dist.s[Mmin.s[1],Mmin.s[2]]*100 Mmin.s.a <- rownames(Mmin.s) Mmin.s.b <- colnames(dist.s[Mmin.s[2]]) # total nb.s <- ncol(dist.s) return(unique(c(Mmin.s.a,Mmin.s.b,nb.s))) } fMDS_init <- function(dist_mtx,n_clust){ # dataframe with coordinates and images # dist_mtx ; n_clust <- nclustsA c <- as.dist(t(dist_mtx),dist.meth) # matrice des distances d <- dist(c) res <- hclust(as.dist(t(dist_mtx))) #res <- hclust(d,method=clust.meth) res$call <-NULL # pour ne pas que cela s'affiche n <- nrow(dist_mtx) # pour couper l'arbre MidPoint = (res$height[n-n_clust] + res$height[n-n_clust+1]) / 2 cluster.mds <- cutree(res, k = n_clust, h = NULL) # enregistre les clusters mds = isoMDS(c,trace = F) # mds_dat <- as.data.frame(mds$points) mds_dat <- cbind(mds_dat,as.data.frame(cluster.mds)) #mds_dat$cluster.mds = as.factor(mds_dat$clusters.mds) # ajoute les images et le lbl mds_dat$img <- NA mds_dat$img_nme <- NA list_png <- list.files(chm.procust.etude.png) for (png_ in list_png){ # png_ <- "poign104_aad.png" # match with object name, without bib ref and extension j <- gsub(".png", replacement = "", png_) mds_dat[j,"img"] <- paste(chm.procust.etude.png,png_,sep='') # a simple label lbl <- gsub("poign", replacement = "p", j) mds_dat[j,"img_nme"] <- lbl } #nme_mds_dat <- gsub(".tif", replacement = "", x = rownames(mds_dat)) return(mds_dat) } zoom_clust <- FALSE if (zoom_clust){ # subset num_clus <- 1 # le num?ro du cluster s?lectionn? mds_dat_clust <- mds_dat[mds_dat[, "clusters"] == num_clus,] } # return factorial map fPlotMDS <- function(mds_dat_clust,dim_img_stat,dim_img_s){ # mds_dat_clust,img_nme,image,dim_img_stat,dim_img_s # add white space to plot images a.buff <- .02 maxV1 <- max(mds_dat_clust$V1)+a.buff;minV1 <- min(mds_dat_clust$V1)-a.buff maxV2 <- max(mds_dat_clust$V2)+a.buff;minV2 <- min(mds_dat_clust$V2)-a.buff p <- ggplot(mds_dat_clust, aes(V1, V2, label = img_nme)) + geom_point(aes(colour = color), size=1)+ theme_bw()+ xlim(minV1, maxV1)+ylim(minV2, maxV2) # remplit une liste pour les images param <- list() for (i in 1:nrow(mds_dat_clust)){ # i <- 1 image <- mds_dat_clust[i,"img"] # distingue statues et silex if (!grepl("stat", image)){ x_min <- mds_dat_clust[i,"V1"]-dim_img_s x_max <- mds_dat_clust[i,"V1"]+dim_img_s y_min <- mds_dat_clust[i,"V2"]-dim_img_s y_max <- mds_dat_clust[i,"V2"]+dim_img_s } if (grepl("stat", image)){ x_min <- mds_dat_clust[i,"V1"]-dim_img_stat x_max <- mds_dat_clust[i,"V1"]+dim_img_stat y_min <- mds_dat_clust[i,"V2"]-dim_img_stat y_max <- mds_dat_clust[i,"V2"]+dim_img_stat } img1 <- readPNG(image,native = TRUE) g1 <- rasterGrob(img1, interpolate=FALSE) param <- list(param,annotation_custom(g1,x_min,x_max,y_min,y_max)) } # plot images and labels gMDS <- p+param+ # geom_point(size=1,color = mds_dat_clust$clusters)+ geom_label_repel(aes(colour = color), size=3, segment.alpha=0.5, label.padding = 0.1, label.size = NA, fill = NA)+ scale_color_identity("clusters",guide = "legend") #scale_color_identity() # scale_colour_manual(values = clust.colors) #geom_text_repel(size=3, segment.alpha=0.5) return(gMDS) # obj ggplot }
Corpus
mat1 <- paste0(chm.procust.orig,'BIB 2892 Brandherm Epees poignees.jpg') include_graphics(mat1)
Analysis
Dendrogramm
```rDendrogram on the matrix of procustean distances for the complete arrow heads"}
select.s <- "p[0-9]*a" # toutes sans les transformées
dist_mtx_kh <- dist_mtx[-grep(select.s, rownames(dist_mtx)), ]
dist_mtx_kh <- dist_mtx_kh[,-grep(select.s, colnames(dist_mtx_kh)) ]
dendrogramme
gg.dend.gg <- as.ggdend(dend1) g.dendro <- ggplot2::ggplot(gg.dend.gg, horiz = TRUE)+ theme(plot.margin = unit(c(0.5,0.5,0.5,0.5), "lines"), plot.title = element_text(size=12))
g.hc <- fPlotDendro(dist_mtx,nclustsA,mds_dat_clust)
g.procust.hc <- paste0(chm.procust.etude,"_herachical_clustering.png") ggsave(g.procust.hc, g.dendro, width = 10, height = 10) shell.exec(g.procust.hc)
#### MDS plotting ```rMultidimensional scaling on the matrix of procustean distances for the complete arrow heads"} dim_img_stat <- dim_img_s <- 0.025 # va servir a la taill de l'image statue et silex # plan mds_dat_clust <- fMDS_init(dist.mtx,n_clust) # avec le nb de clustersMDS mds_dat_clust_color <- merge(mds_dat_clust,df.clusters,by="row.names") #mds_dat_clust$color.mds <- clust.colors[mds_dat_clust[,"clusters"]] # colors of clusters g.mds <- fPlotMDS(mds_dat_clust_color,dim_img_stat,dim_img_s) # fonction plot g.procust.mds <- paste0(chm.procust.etude,"_multidimentional_scaling.png") ggsave(g.procust.mds, g.mds, width = (nrow(mds_dat_clust)/1.5)+1, height = (nrow(mds_dat_clust)/1.5)+1) shell.exec(g.procust.mds)
DATATIONS 14C
library(RPostgreSQL) library(Bchron) C14.bd <- T C14.ucl <- !C14.bd if (C14.bd){ # read Pg BD drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") sqll <- paste0("SELECT site,us,id,bp,delta,taxon,code,culture,bib FROM datations") df.datations <- dbGetQuery(con,sqll) dbDisconnect(con) # sort(unique(df.datations$bib)) # calibrate a.enr <- df.datations[1,] a.dat <- BchronCalibrate(ages=a.enr$bp, ageSds=a.enr$delta, calCurves=c('intcal13')) plot(a.dat) } if (C14.ucl){ print ("kgkggkgkj") }
TODO: classer ces chunks
groups
distances
# found the max distances between objects in a group and other objects #df.dist.mat lgroups.decors <- lgroups[[3]][[2]] # get numero of objects df.dist.mat.selected <- df.dist.mat[df.dist.mat$obj.A %in% lgroups.decors,] df.dist.mat.selected <- df.dist.mat.selected[with(df.dist.mat.selected, order(obj.A,-value)), ] # order on A and dist
images & spatial
# create a stack of image from a selection of decorations # selected groups of decorations #spat.admin <- paste0(chm.spatial,"Europe_2012.shp") #fond.carto <- st_read(spat.admin) #fond.carto <- as_Spatial(s.sf$geom) (s.sf, 'Spatial') #fond.carto <- SpatialPolygons(as(s.sf, 'Spatial'), proj4string=CRS("+proj=longlat +datum=WGS84 +no_defs")) #all objets for (i in 1:length(lgroups.all)){ if (lgroups.all[[i]][[1]] == select.obj){ for (j in 2:length(lgroups.all[[i]])){ grp.name <- lgroups.all[[i]][[j]][[1]] grp.num.decs <- lgroups.all[[i]][[j]][[2]] # } # grp.name <- lgroups.all[[i]][[2]][[1]] # grp.num.decs <- lgroups.all[[i]][[2]][[2]] ll.decs <- list() # images - - - - - - - - for (gd in grp.num.decs){ # loop through decorations num.dec <- paste0(gd,'_',objets[gd,"lbl"],'.png') #num.dec <- gsub(" ", "", num.dec, fixed = TRUE) # num.dec <- gsub("(", "", num.dec, fixed = TRUE) # num.dec <- gsub(")", "", num.dec, fixed = TRUE) # read images and convert to ggplot print(paste0(chm.corpus,num.dec)) img <- image_ggplot(image_read(paste0(chm.corpus,num.dec))) ll.decs[[length(ll.decs)+1]] <- img } margin = theme(plot.margin = unit(c(0,0,0,0), "cm")) ggsave(file = paste0(chm.groups,grp.name,"_ico.png"), arrangeGrob(grobs = lapply(ll.decs, "+", margin), top = grid::textGrob(grp.name,x=0,hjust=0,gp = gpar(fontsize =10)), padding = unit(0.1, "line"), ncol = 4), width = 2+length(grp.num.decs)/1.5, height = 2+length(grp.num.decs)/3) } } }
ca
#perCA <- data.frame(perCA1=0,perCA2=0) # enregistre les % des axes ca <- CA(df.typ_edges,graph = FALSE) # AFC inertCA1 <- round(as.numeric(ca$eig[,2][1]),1) inertCA2 <- round(as.numeric(ca$eig[,2][2]),1) # pour afficher les % perCA <- data.frame(perCA1=inertCA1, perCA2=inertCA2) coords_ind_ca <- as.data.frame(ca$row$coord) coords_var_ca <- as.data.frame(ca$col$coord) coords_ca <- rbind(coords_ind_ca,coords_var_ca) colnames(coords_ca)[1] <- 'CA1' colnames(coords_ca)[2] <- 'CA2' coords_ca$num <- rownames(coords_ca) coords_ca$color <- coords_ca$shape <- NA # fill color and shapes for (i in seq(1,nrow(coords_ca))){ if(rownames(coords_ca)[i] %in% new.col.nmes){ # variables coords_ca[i,"color"] <- "grey" coords_ca[i,"shape"] <- 17 # } if(!(rownames(coords_ca)[i] %in% new.col.nmes)){ # individuals coords_ca[i,"color"] <- "black" coords_ca[i,"shape"] <- 16 # } } coords_ca$shape <- as.factor(coords_ca$shape) coords_ca$color <- as.factor(coords_ca$color) # graphes CA gca <- ggplot(coords_ca,aes(CA1, CA2)) + geom_point(aes(CA1, CA2, colour=color, fill=color, stroke = .5, pch = as.numeric(levels(coords_ca$shape))[coords_ca$shape]), size = 1.5) + # 1.5 geom_text_repel(aes(CA1, CA2,label=num), cex=2, segment.size = 0.1, segment.alpha = 0.5)+ geom_hline(yintercept=0, linetype="dashed", size=0.2, alpha=0.3)+ geom_vline(xintercept=0, linetype="dashed",size=0.2, alpha=0.3)+ geom_text(data=perCA, mapping = aes(x = 0, y = -Inf, label = paste0(perCA1,"%")), vjust=-1, size=2, alpha=0.5 )+ geom_text(data=perCA, mapping = aes(x = -Inf, y = 0, label = paste0(perCA2,"%")), vjust=1, angle=90, size=2, alpha=0.5)+ theme(axis.text=element_text(size=5), axis.title.x=element_text(size=8), axis.title.y=element_text(size=8))+ theme(axis.ticks = element_line(size = 0.2))+ theme(legend.position = "none")+ theme(strip.text.x = element_text(size=8), strip.text.y = element_blank())+ theme(panel.border = element_rect(colour='black',fill=NA,size = 0.2))+ theme(panel.background = element_rect(fill = 'transparent'))+ theme(panel.spacing.y = unit(0,"lines"))+ # scale_x_continuous(limits = c(-1, 2), expand = c(0, 0))+ # scale_y_continuous(limits = c(-1, 1), expand = c(0, 0))+ scale_colour_identity()+ scale_shape_identity()+ scale_fill_identity() #facet_grid(per ~ .) # create a composite figure listing.sz <- .6 # size of text # theme for tableGrob mytheme.listing <- gridExtra::ttheme_default( core = list(fg_params=list(cex = listing.sz), padding=unit(c(.5, .5), "mm")), colhead = list(fg_params=list(cex = listing.sz)), rowhead = list(fg_params=list(cex = listing.sz))) # create tableGrob ico.listing.ind <- data.frame(idf=seq(1:nrow(df.same_edges)), ind=rownames(df.same_edges), stringsAsFactors = F) listing.ind <- tableGrob(ico.listing.ind,rows = NULL, theme = mytheme.listing) listing.var <- tableGrob(ico.listing.var,rows = NULL, theme = mytheme.listing) # combine listings listing.all <- gtable_combine(listing.ind,listing.var, along=2) # arrange ca and listings gca.listings <- grid.arrange(gca, listing.all, ncol=2, widths=c(3,0.5)) # save ggsave(paste0(chm.etude,"4-AF_ca.png"), gca.listings, width = nrow(df.typ_edges)/2, height = nrow(df.typ_edges)/2) shell.exec(paste0(chm.etude,"4-AF_ca.png")) # # dataset.p <- merge(df_lda.per,coords_ca,by="row.names",all.y=T) # dataset.ps <- merge(dataset.p,typsit_symb,by.x="Type.site",by.y="tsite",all.x=T) # dataset.ps$per <- per # dataset.ps$color <- as.character(dataset.ps$color)
spatial
# a new Postgis table for Qgis spatialization select.obj.tab <- paste0("z_",v.select.obj) drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") out.tab <- dbGetQuery(con,paste0("select site,numero,ST_X(geom) as x,ST_Y(geom) as y from ",v.select.obj)) # pg.tab.obj <- paste0("DROP TABLE IF EXISTS ",select.obj.tab) # dbGetQuery(con,pg.tab.obj) # join dataframe with clusters df.clusts.obj <- data.frame(idf=names(clusters.obj), clust=clusters.obj) out.tab.1 <- merge(out.tab,df.clusts.obj,by.x="row.names",by.y="idf") colnames(out.tab.1)[which(names(out.tab.1) == "Row.names")] <- "idf" out.tab.1$id <- NULL coords <- SpatialPoints(out.tab.1[, c("x", "y")]) spdf <- SpatialPointsDataFrame(coords, out.tab.1) # insert into postgres pgInsert(con, name = c("public", select.obj.tab), data.obj = spdf, overwrite=T) # add PK for Qgis dbGetQuery(con,paste0("ALTER TABLE ",select.obj.tab," ADD PRIMARY KEY (idf)")) dbDisconnect(con) # disconnect
themes
représentations
# identification des noeuds qui sont isolés # tableau des objets qui représente ce thème ug_ss_liens <- c() col_nmes <- dcol_nmes <- c() drv <- dbDriver("PostgreSQL") con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") # MAJ des structures quand = NA invisible(dbGetQuery(con,"UPDATE table_liens SET structure='xxx' WHERE structure is Null")) sql_nds <- paste0("SELECT table_noeuds.site,table_noeuds.structure,table_noeuds.decor,table_noeuds.id,table_noeuds.type,ST_X(objets.geom) as x,ST_Y(objets.geom) as y,table_noeuds.tpq,table_noeuds.taq FROM table_noeuds,objets WHERE table_noeuds.type LIKE '",select.thm,"' AND table_noeuds.site = objets.site AND table_noeuds.structure=objets.structure AND table_noeuds.decor = objets.numero") all_nds <- dbGetQuery(con,sql_nds) # met 'chrono' = 1 quand l'interval correspond all_nds$chrono <- NA for (i in seq(1,nrow(all_nds))){ all_nds[i,"chrono"] <- ifelse(Overlap(chrono,c(all_nds[i,"tpq"],all_nds[i,"taq"])) > 0, 1, 0) } all_nds <- subset(all_nds, chrono == 1) all_nds$chrono <- NULL #all_nds$label <- apply(all_nds, 1, function(x) paste0(x[trimws(x) != ""], 1)) # faire un concat #dout <- data.frame(decor=all_nds$decor) invisible(dbDisconnect(con)) l <- c() for (i in seq(1,nrow(all_nds))){ #print (as.character(all_nds[i,"decor"])) con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") sit <- all_nds[i,"site"] struct <- all_nds[i,"structure"] dec <- all_nds[i,"decor"] idf <- all_nds[i,"id"] lbl <- paste(sit, struct,dec,idf, sep="_") # on ne prend que les noeuds contemporains (typ = NA) sql_liens <- paste0("SELECT site,structure,decor,typ,a,b FROM table_liens WHERE site='",sit,"' AND structure='",struct,"' AND decor='",dec,"' AND typ is Null AND (a=",idf," OR b=",idf,")") liens <- dbGetQuery(con,sql_liens) linktest <- as.character(liens) #print (is.na(linktest)) if (length(linktest) == 0){ ug_ss_liens <- c(ug_ss_liens,paste0(sit,"_",struct,"_",dec,"_",idf)) } #print (paste("---------------", linktest)) invisible(dbDisconnect(con)) other_nds <- unique(liens$a) other_nds <- c(other_nds,unique(liens$b)) other_nds <- unique(other_nds) other_nds <- other_nds[other_nds != idf] # tous moins le noeud initial # subset les noeuds if (!is.null(other_nds)){ for (nd in other_nds){ con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") sql_nd <- paste0("SELECT type FROM table_noeuds WHERE id=",nd," AND site='",sit,"' AND structure='",struct,"' AND decor='",dec,"'") #print(paste("----------------------------",sql_nd)) typo_nd <- dbGetQuery(con,sql_nd) l <- c(typo_nd,l) l <- as.character(l) dl <- do.call("cbind",list(l)) invisible(dbDisconnect(con)) } } invisible(dbDisconnect(con)) } # le tableau de toutes les fa col_nmes <- sort(unique(l)) dcol_nmes <- as.data.frame(do.call("rbind",list(col_nmes))) #dcol_nmes <- as.data.frame(sapply(dcol_nmes, as.character)) # chnage le type des colonnes for (nme in seq(1,ncol(dcol_nmes))){ colnames(dcol_nmes)[nme] <- as.character(dcol_nmes[1,nme]) } indx <- sapply(dcol_nmes, is.factor) dcol_nmes[indx] <- lapply(dcol_nmes[indx], function(x) as.numeric(as.character(x))) dcol_nmes[is.na(dcol_nmes)] <- 0 df_typo <- dcol_nmes all_nds_ <- all_nds all_nds_$lbl <- paste(all_nds$site, all_nds$structure, all_nds$decor, sep="_") tb_nb <- as.data.frame(table(all_nds_$lbl)) # compte colnames(tb_nb)[which(names(tb_nb)=="Var1")] <- 'lbl' colnames(tb_nb)[which(names(tb_nb)=="Freq")] <- 'nb' tab_dec <- merge(all_nds_,tb_nb,by='lbl',all.y=TRUE) tab_dec <- subset(tab_dec,select=c("site","structure","decor","type","tpq","taq","nb")) #tab_dec <- subset(tab_dec,select=c("site","structure","decor","nb")) tab_dec <- tab_dec[!duplicated(tab_dec), ] # sans les doublons # tbaleau des objets qui présente ce thème ktab_dec <- kable(tab_dec, "html", booktabs = TRUE, longtable = TRUE, caption = paste0("Présence du thème <b>",select.thm,"</b>")) %>% kable_styling(latex_options = c("hold_position", "repeat_header")) #tt <- ttheme_default(colhead=list(fg_params = list(parse=TRUE))) #grid.table(ktab_dec,theme=mythm) #print(paste("les noeuds qui ont aucun lien avec les autres thèmes sont:",ug_ss_liens)) ktab_dec
UG proches
j <- c() #df_typo <- essai # on remplit le tableau pour chaque decor for (i in seq(1,nrow(all_nds))){ con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") d <- c() sit <- all_nds[i,"site"] struct <- all_nds[i,"structure"] dec <- all_nds[i,"decor"] idf <- all_nds[i,"id"] # on ne prend que les noeuds contemporains (typ = NA) sql_liens <- paste0("SELECT site,structure,decor,typ,a,b FROM table_liens WHERE site='",sit,"' AND structure='",struct,"' AND decor='",dec,"' AND typ is Null AND (a=",idf," OR b=",idf,")") liens <- dbGetQuery(con,sql_liens) other_nds <- unique(liens$a) other_nds <- c(other_nds,unique(liens$b)) other_nds <- unique(other_nds) other_nds <- other_nds[other_nds != idf] # tous moins le noeud initial invisible(dbDisconnect(con)) # subset les noeuds attributs for (nd in other_nds){ con <- dbConnect(drv, dbname="mailhac_9", host="localhost", port=5432, user="postgres", password="postgres") sql_nd <- paste0("SELECT type FROM table_noeuds WHERE id=",nd," AND site='",sit,"' AND structure='",struct,"' AND decor='",dec,"'") typo_nd <- dbGetQuery(con,sql_nd) d <- c(typo_nd,d) d <- as.character(d) invisible(dbDisconnect(con)) #print (paste(dec, j)) } df_typo[nrow(df_typo)+1,] <- rep(0,ncol(df_typo)) # créé un nouveau row lbl <- paste(sit, struct,dec,idf, sep="_") row.names(df_typo)[i] <- lbl # renomme le row avec le décor #print (paste(i, lbl)) for (pars_col in seq(1,ncol(df_typo))){ for (thm_ in d){ # /!\ _na -> X_na #print (paste0(" ",thm_)) if (colnames(df_typo)[pars_col] == thm_ | colnames(df_typo)[pars_col] == paste0('X',thm_)){ df_typo[i,pars_col] <- df_typo[i,pars_col]+1 # ajoute +1 } } #df_typo[nrow(df_typo)+1,] <- rep(0,ncol(df_typo)) # créé un nouveau row #print (paste(dec, d)) # on remplit #dcol_nmes <- rbind(dcol_nmes, rep(0,ncol(dcol_nmes))) # créé un nouveau row dcol_nmes[is.na(dcol_nmes)] <- 0 # remplace NA par 0 invisible(dbDisconnect(con)) } } #View(df_typo) df_typo_1 <- df_typo df_typo$tot <- rowSums(df_typo) df_typo <- df_typo[df_typo$tot != 0, ] df_typo$tot <- NULL #df_typo_1 <- df_typo[rowSums(df_typo)!=0,] # supprime les row artefacts #View(df_typo_1) testdt <- data.frame(x = as.character(colnames(df_typo)), count = as.integer(colSums(df_typo))) testdt <- testdt[rev(order(testdt$count)),] # réorganise sur le total des colonnes rownames(testdt) <- 1:nrow(testdt) testdt$x <- factor(testdt$x,levels = testdt$x) # réordonne les levels tit <- paste0("thèmes à proximité du thème '",select.thm,"'") ghist <- ggplot(data = testdt) + ggtitle(tit)+ geom_bar(aes(x = x, y = count), stat = "identity")+ theme(axis.text.x = element_text(angle = 45, hjust = 1)) #theme(plot.title = element_text(face = "bold")) df_typo <- t_reduce_col(df_typo) ktab_typo <- kable(df_typo, "html", booktabs = TRUE, longtable = TRUE, caption = paste0("Présence du thème <b>",select.thm,"/<b>")) %>% kable_styling(latex_options = c("hold_position", "repeat_header")) ktab_typo #df_typoGrob <- tableGrob(df_typo,theme = mythm) #grid.arrange(df_typoGrob, ghist, nrow = 2, heights=c(7,3)) ghist invisible()
Spatialisation représentations et objets véritables
Distribution spatial des sites
# spatial all_nds.SP <- st_as_sf(all_nds, coords = c('x', 'y'), crs = 4326) all_objs.SP <- st_as_sf(all_obj, coords = c('x', 'y'), crs = 4326) # tmap_leaflet(tm_shape(all_nds.SP) + # tm_dots(size=0.1,col="red")+ # tm_text("site")) tmap_leaflet( # représentation tm_shape(all_nds.SP) + tm_dots(size=0.1,col="red")+ tm_text("site")+ # objets veritables tm_shape(all_objs.SP) + tm_dots(size=0.1,col="green")+ tm_text("site") )
vérifications
noeuds isolés
# vérifications print ("\ ") print("les noeuds qui ont aucun lien avec les autres thèmes sont:") print ("\ ") for (ug_ss_lien in sort(ug_ss_liens)){ print (paste(" ",ug_ss_lien)) }
\newpage \blandscape
données attributs
# va lire un fichier créé par python fich <- paste0("AF_",select.thm,"_attributs.xlsx") # le fichier créé par la fonction 'AFthm' de Python df <- openxlsx::read.xlsx(paste0("D:/Projet Art Rupestre/decors/stats/",fich),skipEmptyRows=TRUE) #head_df <- subset(df,select=c("site","structure","decor","id_a")) # ,"tpq_a","taq_a","chr_1_a" head_df <- subset(df,select=c("num","grp")) # ,"tpq_a","taq_a","chr_1_a" df.disj <- acm.disjonctif(df[7]) names(df.disj) <- gsub(x = names(df.disj), pattern = "type_b\\.", replacement = "") df_ <- cbind(head_df,df.disj) # aggrégation par ug dataf <- df_ %>% group_by(num,grp) %>% #summarise_each(funs(sum)) summarise_all(funs(sum)) dataf <- as.data.frame(dataf) dataf$num <- gsub('xxx', 'x', dataf$num) # simplifie les numeros de structures row.names(dataf) <- as.character(dataf$num) dataf$num <- NULL ########## Subset # dataf_ <- dataf[c(2,4,8,9),] # que des groupes # dataf_ <- dataf_[,c(1,2,4,5,7)] # séléction des sumCol > 0 ########## Subset dataf_ <- dataf ana_pca <- TRUE ana_ca <- TRUE ana_lda <- FALSE # tableau de données mydf <- t_reduce_col(dataf_) mydf$grp <- NULL # supprime pour l'affichage # total des colonnes colsums <- colSums(mydf) mydf_ <- rbind(mydf, colsums) r_names <- row.names(mydf_) r_names[length(r_names)] <- "TOTAL" # le dernier row.names(mydf_) <- r_names # renomme # total des lignes rowsums <- rowSums(mydf_[,-1]) mydf_ <- cbind(mydf_, rowsums) colnames(mydf_)[ncol(mydf_)] <- 'TOTAL' # le dernier # la table kable(mydf_,"html") %>% kable_styling(full_width = FALSE, latex_options=c("scale_down"), position = "center", font_size=7) %>% column_spec(ncol(mydf_)+1, bold = T) %>% column_spec(1, bold = T) %>% row_spec(0, bold = T) %>% row_spec(nrow(mydf_), bold = T)
# suppression des individus et variables ci-dessous, utile en fonction des résultat des AF # individus supplémentaires - - - - - - - - - - - - - - - - - - - sup_ind <- c("Ategua_x_Ategua_3") #dataf_ <- www dataf_ <- dataf_[!rownames(dataf_) %in% sup_ind, ] # supprime ind dt <- dataf_[,-1] # on va travailler sur les noms de row et de col # variables supplémentaires - - - - - - - - - - - - - - - - - - - supp_var <- colnames(dt[,colSums(dt)==0,]) # les colonnes sum = 0 # ajouter des themes à supprimer supp_var <- c(supp_var,"fleche","arc","epee_langue_carpe","cheval") dataf_ <- dataf_[ , !(names(dataf_) %in% supp_var)] # supprime les colonnes #dataf_ <- dataf_[ , -which(names(dataf_) %in% supp_var)] # supprime les colonnes # individus df_sup_ind <- dataf_[ rowSums(dataf_[,-1])==0, ] # qd row = 0 alors suppression supp_ind <- paste(row.names(df_sup_ind),sup_ind) # stocke dataf_ <- dataf_[apply(dataf_[,-1], 1, function(x) !all(x==0)),] # supprime les lignes qd sum = 0 #supp_var <- dataf_[,colSums(dataf_[,-1])==0 ] # kable(df_sup_ind,"latex") %>% # kable_styling(full_width = FALSE, # latex_options=c("stripped","scale_down"), # position = "center", # font_size=7)
\newpage
# tableau de données mydf <- dataf_ mydf$grp <- NULL # supprime pour l'affichage # total des colonnes colsums <- colSums(mydf) mydf_ <- rbind(mydf, colsums) r_names <- row.names(mydf_) r_names[length(r_names)] <- "TOTAL" # le dernier row.names(mydf_) <- r_names # renomme # total des lignes rowsums <- rowSums(mydf_[,-1]) mydf_ <- cbind(mydf_, rowsums) colnames(mydf_)[ncol(mydf_)] <- 'TOTAL' # le dernier # la table kable(mydf_,"html") %>% kable_styling(full_width = FALSE, latex_options=c("scale_down"), position = "center", font_size=7) %>% column_spec(ncol(mydf_)+1, bold = T) %>% column_spec(1, bold = T) %>% row_spec(0, bold = T) %>% row_spec(nrow(mydf_), bold = T)
\elandscape
Analyses factorielles
# out.width = "100%", out.height = "100%", # tableau de données xdat <- dataf_[ , -which(names(dataf_) %in% c("grp"))] # PCA - - - - - - - pca <- PCA(xdat,graph = FALSE,ncp = 2) inertPCA1 <- as.numeric(pca$eig[,2][1]) inertPCA2 <- as.numeric(pca$eig[,2][2]) coords_pca <- rbind(pca$ind$coord,pca$var$coord) colnames(coords_pca)[1] <- 'PCA1' colnames(coords_pca)[2] <- 'PCA2' # CA - - - - - - - - ca <- CA(xdat,graph = FALSE,ncp = 2) # AFC inertCA1 <- as.numeric(ca$eig[,2][1]) inertCA2 <- as.numeric(ca$eig[,2][2]) coords_ca <- rbind(ca$row$coord,ca$col$coord) colnames(coords_ca)[1] <- 'CA1' colnames(coords_ca)[2] <- 'CA2' # LDA if (ana_lda){ r <- lda(formula = grp ~ ., data = dataf_) #analyse discriminante prop.lda = r$svd^2/sum(r$svd^2) #analyse en composantes principales plda <- predict(object = r, newdata = dataf_) coords_lda <- plda$x } if (!ana_lda){ # on créé des coordonnées vides coords_lda <- data.frame(row.names = row.names(dataf_), LD1 = rep(0,nrow(dataf_)), LD2 = rep(0,nrow(dataf_)) ) } #dataset.p <- mergcoords_ldae(ff,plda$x,by="row.names") # PCA + CA + LDA + grp df_grp <- subset(dataf_,select=("grp")) df_ca_grp <- merge(df_grp,coords_ca,by="row.names",all.y=TRUE) row.names(df_ca_grp) <- df_ca_grp$Row.names df_ca_grp$Row.names <- NULL df_ca_pca <- merge(coords_pca,df_ca_grp,by="row.names") row.names(df_ca_pca) <- df_ca_pca$Row.names df_ca_pca$Row.names <- NULL df_ca_pca_lda <- merge(df_ca_pca,coords_lda,by.x="row.names",by.y="row.names", all.x=TRUE) dataset.p <- df_ca_pca_lda dataset.p$grp <- as.factor(dataset.p[,"grp"]) #dataset.p$var_et <- NULL # si 2 groupes uniquement if (nlevels(dataset.p$grp) < 3){ (jCustom <- with(dataset.p, data.frame(grp = levels(grp), color = c("blue","red"), shapes = seq(1,nlevels(grp))))) } # 3 groupes ou plus mais < 13 if (nlevels(dataset.p$grp) > 2 & nlevels(dataset.p$grp) < 13){ (jCustom <- with(dataset.p, data.frame(grp = levels(grp), color = I(brewer.pal(nlevels(grp), name = 'Paired')), shapes = seq(1,nlevels(grp))))) } if (nlevels(dataset.p$grp) > 12){ jCustom <- with(dataset.p, data.frame(grp = levels(grp), color = seq(1,nlevels(grp)), shapes = seq(1,nlevels(grp)))) } jCustom[,"grp"] <- as.character(jCustom[,"grp"]) jCustom[,"shapes"] <- as.character(jCustom[,"shapes"]) sel.typ <- unique(dataset.p$grp) jCustom <-jCustom[jCustom$grp %in% sel.typ,] dataset.q <- merge(dataset.p,jCustom,by="grp",all.x=TRUE) dataset.q$idf <- as.character(seq(1,nrow(dataset.q))) # les idf # les variables # remplace les valeurs NA dataset.q$shapes <- as.integer(dataset.q$shapes) dataset.q[["shapes"]][is.na(dataset.q[["shapes"]])] <- 25 dataset.q$color <- as.character(dataset.q$color) dataset.q[["color"]][is.na(dataset.q[["color"]])] <- 'black' dataset.q$grp <- as.character(dataset.q$grp) dataset.q[["grp"]][is.na(dataset.q[["grp"]])] <- 'var' # remplace les idf des variables par leur valeurs pour l'affichage dataset.q <- dataset.q %>% mutate(idf = ifelse(grp == "var", Row.names, idf)) jCustom[,"grp"] <- as.factor(jCustom[,"grp"]) # sinon erreur jCustom[,"shapes"] <- as.factor(jCustom[,"shapes"]) # sinon erreur dataset.q$shapes <- as.factor(dataset.q$shapes) dataset.q$color <- as.factor(dataset.q$color) dataset.q$grp <- as.factor(dataset.q$grp) # la table - -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - df.table <- dataset.q[ , -which(names(dataset.q) %in% c("color","shapes"))] df.table <- df.table[complete.cases(df.table), ] df.table$numero <- df.table$Row.names df.table <- subset(df.table,select=c("idf","numero")) sit.df.plot <- fdat.columned(df.table,nb.col.tab) # en n colnnes tgrob <- tableGrob(sit.df.plot, theme = ttheme_default(base_size = size.txt.tab, padding = unit(c(padd.tab,padd.tab), "mm")), cols = NULL, rows = NULL) find_cell <- function(table, row, col, name="core-fg"){ l <- table$layout which(l$t==row & l$l==col & l$name==name) } sel_col <- c() # met en gras les colonnes des idf if (nb.col.tab == 1){sel_col <- c(1)} if (nb.col.tab == 2){sel_col <- c(1,3)} if (nb.col.tab == 3){sel_col <- c(1,3,5)} if (nb.col.tab == 4){sel_col <- c(1,3,5,7)} for (col_ in sel_col){ for (row_ in seq(1,nrow(sit.df.plot))){ ind <- find_cell(tgrob, row_, col_, "core-fg") tgrob$grobs[ind][[1]][["gp"]] <- gpar(fontsize=size.txt.tab+1, fontface="bold") } } # graphe # LDA if (ana_lda){ dg <- dataset.q[complete.cases(dataset.q), ] #couleurs contours myColorss <- unique(dg$color) names(myColorss) <- unique(dg$shapes) #shapes myShapes <- unique(dg$shapes) names(myShapes) <- unique(dg$shapes) g.lda <- ggplot(dg,aes(LD1, LD2)) + ggtitle(titre)+ #ggplot(dataset.q,aes(CA1, CA1)) + geom_point(aes(LD1, LD2, colour = shapes, pch = shapes), size = symb.size) + geom_text_repel(aes(LD1, LD2,label=idf), cex=siz.txt, segment.size = 0.5, segment.alpha = 0.3, segment.colour = jCustom[match(dataset.q$grp,jCustom$grp),"color"])+ scale_colour_manual(labels = jCustom$grp, name = grp,values = myColorss)+ scale_shape_manual(labels = jCustom$grp, name = grp, values = myShapes)+ geom_hline(yintercept=0, linetype="dashed",alpha=0.5)+ geom_vline(xintercept=0, linetype="dashed",alpha=0.5)+ labs(color = "type de site\n", x = paste("LD1 (", percent(prop.lda[1]), ")", sep=""), y = paste("LD2 (", percent(prop.lda[2]), ")", sep=""))+ # cette légénde sera réutilisées theme(plot.title = element_text(size = 10), axis.text=element_text(size=6), axis.title.x=element_text(size=8), axis.title.y=element_text(size=8), legend.direction = "horizontal", legend.position="bottom", legend.title = element_text(size=lgd.size+2), legend.text=element_text(size=lgd.size+1), panel.background = element_rect(fill = 'transparent')) } if (ana_pca){ #dg <- dataset.q[complete.cases(dataset.q), ] #dg <- dataset.q #couleurs contours myColorss <- unique(dataset.q$color) names(myColorss) <- unique(dataset.q$shapes) #shapes myShapes <- unique(dataset.q$shapes) names(myShapes) <- unique(dataset.q$shapes) g.pca <- ggplot(dataset.q,aes(PCA1, PCA2)) + #ggplot(dataset.q,aes(CA1, CA1)) + geom_point(aes(PCA1, PCA2, colour = shapes, pch = shapes), size = symb.size) + geom_text_repel(aes(PCA1, PCA2,label=idf), cex=siz.txt, segment.size = 0.5, segment.alpha = 0.3, segment.colour = jCustom[match(dataset.q$grp,jCustom$grp),"color"])+ scale_colour_manual(name = "shapes",values = myColorss)+ scale_shape_manual(name = "shapes", values = myShapes)+ geom_hline(yintercept=0, linetype="dashed",alpha=0.5)+ geom_vline(xintercept=0, linetype="dashed",alpha=0.5)+ labs(x = paste("PCA1 (", percent(inertPCA1), ")", sep=""), y = paste("PCA2 (", percent(inertPCA2), ")", sep=""))+ # cette légénde sera réutilisées theme(plot.title = element_text(size = 10), axis.text=element_text(size=6), axis.title.x=element_text(size=8), axis.title.y=element_text(size=8), legend.direction = "horizontal", legend.position="bottom", legend.title = element_text(size=lgd.size+2), legend.text=element_text(size=lgd.size+1), panel.background = element_rect(fill = 'transparent')) # theme(axis.text=element_text(size=6), # axis.title.x=element_text(size=8), # axis.title.y=element_text(size=8)) #theme(legend.position="none") } # CA if (ana_ca){ #couleurs contours myColorss <- unique(dataset.q$color) names(myColorss) <- unique(dataset.q$shapes) #shapes myShapes <- unique(dataset.q$shapes) names(myShapes) <- unique(dataset.q$shapes) g.ca <- ggplot(dataset.q,aes(CA1, CA2)) + geom_point(aes(CA1, CA2, colour = shapes, pch = shapes), size = symb.size) + geom_text_repel(aes(CA1, CA2,label=idf), cex=siz.txt, segment.size = 0.5, segment.alpha = 0.3, segment.colour = jCustom[match(dataset.q$grp,jCustom$grp),"color"])+ scale_colour_manual(name = "shapes",values = myColorss)+ scale_shape_manual(name = "shapes", values = myShapes)+ geom_hline(yintercept=0, linetype="dashed",alpha=0.5)+ geom_vline(xintercept=0, linetype="dashed",alpha=0.5)+ labs(x = paste0("CA1 (", round(inertCA1,2), "%)", sep=""), y = paste0("CA2 (", round(inertCA2,2), "%)", sep=""))+ # scale_x_continuous(limits = c(-1, 1.5))+ # scale_y_continuous(limits = c(-1, 1))+ # cette légénde sera réutilisées theme(plot.title = element_text(size = 10), axis.text=element_text(size=6), axis.title.x=element_text(size=8), axis.title.y=element_text(size=8), legend.direction = "horizontal", legend.position="bottom", legend.title = element_text(size=lgd.size+2), legend.text=element_text(size=lgd.size+1), panel.background = element_rect(fill = 'transparent')) # theme(axis.text=element_text(size=6), # axis.title.x=element_text(size=8), # axis.title.y=element_text(size=8)) #theme(legend.position="none") } #mylegend <- g_legend(g.ca) # récupère la légende if (ana_lda){ g.lda <- g.lda + theme(legend.position="none") # efface legend } if (ana_ca){ g.ca <- g.ca + theme(legend.position="none") # efface legend } if (ana_pca){ g.pca <- g.pca + theme(legend.position="none") # efface legend } # les paramètres de la grid grap_sz <- 16 tabgrob_sz <- 10 #legend_sz <- 4 # n'affiche pas la légende # combine les AF if (ana_pca & ana_ca){ #grid.arrange(g1,g2,mylegend,dataf,nrow=4,heights=c(10,10,1,3)) library(cowplot) plot_grid(g.ca,g.pca,tgrob, align = "v", nrow = 3, rel_heights = c(2/5, 2/5, 1/5)) #grid.arrange(g.ca,g.pca,tgrob,nrow=3,heights=c(grap_sz,grap_sz,tabgrob_sz)) } if (ana_lda & ana_ca){ grid.arrange(g.ca,g.lda,nrow=3,heights=c(grap_sz,grap_sz,tabgrob_sz)) } if (ana_lda & ana_pca){ # affiche avec la légende de ca grid.arrange(g.pca,g.lda,tgrob,nrow=3,heights=c(grap_sz,grap_sz,tabgrob_sz)) } #grid.arrange(g.lda, g.pca,dataf,ncol=1) #print(plot_grid(g.lda,g.mult,dataf, ncol = 1, nrow = 3, rel_heights=c(2,2,1)))
\newpage
Il faut choisir le nb de cluster sur le dendrogramme :
# clustering nclust <- 3 # choisir le nb de clust #rownames(dataset.q) <- dataset.q$Row.names dataset.q$Row.names <- NULL #xdat <- dataset.q[,c(oc,bota,sudo,"idf")] xdat$idf <- as.character(seq(1,nrow(xdat))) # les idf rownames(xdat) <- xdat$idf xdat$idf <- NULL xxdat <- xdat labs = paste("",1:nrow(xxdat),sep="") #new labels rownames(xxdat)<-labs #set new row names xxdat <- xxdat[complete.cases(xxdat), ] hc <- hclust(dist(xxdat), method = "complete") clusters <- cutree(hc, k = nclust) xxdat$clust <- NA for (i in seq(1,length(clusters))){ xxdat[i,"clust"] <- clusters[[i]] } dendr <- dendro_data(hc, type="rectangle") #convert cluster object to use with ggplot g.hier <- ggplot(segment(dendr)) + geom_segment(aes(x=x, y=y, xend=xend, yend=yend)) + coord_flip() + scale_x_continuous(breaks = ggdendro::label(dendr)$x, labels = ggdendro::label(dendr)$label, position = "top") + scale_y_reverse(expand = c(0, 0)) + theme_minimal() + theme(axis.title = element_blank(), axis.text.y = element_text(size = rel(1)), panel.grid = element_blank()) print(plot_grid(g.hier,tgrob, ncol = 1, nrow = 2, rel_heights=c(3,1))) #plot(g.hier)
Cartographie
xdat_ <- xdat[complete.cases(xdat), ] res.pca <- CA(xdat_,graph = FALSE) res.hcpc <- HCPC(res.pca, nb.clust=nclust, metric="euclidean", method = "complete", graph=FALSE) carto_graph <- fviz_cluster(res.hcpc, repel = TRUE, show.clust.cent = TRUE, palette = "jco", ggtheme = theme_minimal(), main = "titre") #group_col<-c("#E67AA1","#5BBFF3","#962786","#6FBBC0","#304552","#7EB440","#1266B4","#E67AA1","#5BBFF3","#962786") # les couleurs de "jco" res.hcpc$data.clust_ <- merge(res.hcpc$data.clust,dataset.q,by.x="row.names",by.y="idf") clusts <- res.hcpc$data.clust_[,c("Row.names","clust")] colnames(clusts)[which(names(clusts)=="Row.names")] <- 'idf' colo <- c("gold","steelblue1","seagreen3","red","grey","darkorchid","brown","grey30") clusts$color <- sapply(clusts$clust, function(x) colo[x]) # map les couleurs col <- as.character(clusts$color) names(col) <- as.character(clusts$clust) grid.arrange(carto_graph,tgrob,ncol=1)
# réalise la carte si spatial == TRUE # coordonnées if (spatial){ xmin <- as.numeric(min(df$x)) ymin <- as.numeric(min(df$y)) xmax <- as.numeric(max(df$x)) ymax <- as.numeric(max(df$y)) roi <- c(0.0,3.5,40.3,42.5) # zone d'intérêt #roi <- c(xmin,xmax,ymin,ymax) # zone d'intérêt #xy_sites <- df_ca_pca_lda[,c(tsit,"x","y")] xy_sites <- coords_lda[,c(tsit,"x","y")] #xy_sites.1 <- merge(xy_sites,df.table,by.x="row.names",by.y="site") xy_sites.1 <- merge(xy_sites,df.table,by.x="row.names",by.y="site") shps <- dataset.q[c("shapes","idf")] df_sig.1 <- merge(xy_sites.1,clusts,by="idf") df_sig <- merge(df_sig.1,shps,by="idf") df_sig$x <- as.numeric(df_sig$x) df_sig$y <- as.numeric(df_sig$y) coordinates(df_sig)<-~x+y proj4string(df_sig)<-CRS("+proj=longlat +datum=WGS84 +no_defs +ellps=WGS84 +towgs84=0,0,0") df_sig.bis <-data.frame(df_sig) names(df_sig.bis)[names(df_sig.bis)=="longitude"]<-"x" names(df_sig.bis)[names(df_sig.bis)=="latitude"]<-"y" roi.geo <- readOGR(paste0(doss_geo,"Europe_2012.shp")) #roi.geo <- readOGR(paste0(doss,"ESP_adm3.shp")) roi.geo <- crop(roi.geo, extent(roi)) # recoupe #couleurs contours myColorss <- unique(df_sig.bis$color) names(myColorss) <- unique(df_sig.bis$clust) #shapes myShapes <- unique(df_sig.bis$clust) names(myShapes) <- unique(df_sig.bis$clust) carto_carto <- ggplot() + ggtitle("titre")+ geom_polygon(data=roi.geo, aes(x=long, y=lat, group=group),fill = "grey90")+ geom_point(data=df_sig.bis,aes(x, y, color = clust), size = symb.size+1) + scale_colour_manual(name = "clust",values = myColorss)+ #scale_shape_manual(name = "clust", values = myShapes)+ #scale_colour_manual(values=col) + geom_text_repel(data=df_sig.bis, aes(x,y, colour=clust, label=idf), cex=siz.txt+1, fontface='bold', alpha=0.9, segment.alpha=0.5)+ theme(legend.position="bottom", axis.text.x=element_blank(), axis.text.y=element_blank(), panel.background = element_rect(fill = 'transparent')) grid.arrange(carto_carto +coord_fixed(ratio = 1.5),dataf,ncol=1,heights=c(7,2)) }
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.