fribble selection
Martin Zettersten
17 June, 2024
## useful functions
get_file_size <- function(path) {
temp <- file.info(path)$size
return(temp)
}
imageEntropy<-function(histogram){
nonzeroCounts<-histogram$counts[histogram$counts > 0]
probs<-nonzeroCounts / sum(nonzeroCounts)
-sum(probs * log2(probs))
}
imageToIntensity<-function(image, method="perceptual"){
if(method == "mean"){
(image[,,1] + image[,,2] + image[,,3]) / 3
} else if(method == "perceptual") {
(image[,,1] * .3) + (image[,,2] * .59) + (image[,,3] * .11)
} else {
simpleError(paste("Unknown imageToIntensity method:", method))
}
}
#based on https://rdrr.io/rforge/CulturalAnalytics/man/imageEntropy.html
get_png_entropy <- function(path) {
img <- readPNG(path)
histogram<-hist(imageToIntensity(img), breaks=0:255/255, plot=FALSE)
entropy<-imageEntropy(histogram)
return(entropy)
}Complexity measures
Compute some measures of complexity for each image: * compression complexity * image entropy
#image paths
base_path <- here()
image_path <- here(base_path,"images")
d <- data.frame(
file_name = list.files(path = image_path),
path = image_path
) %>%
mutate(
rel_path = paste0("images/",file_name),
full_path = here(image_path,file_name))
d <- d %>%
mutate(file_size = lapply(full_path, function(path) get_file_size(path))) %>%
mutate(
image_html = paste('<img src="',rel_path,'" style="width:50px" class="center"></image>',sep="")
) %>%
mutate(file_size = as.numeric(file_size)) %>%
mutate(compression_complexity = as.numeric(lapply(full_path, function(path) img_complexity(path)))) %>%
mutate(entropy = as.numeric(lapply(full_path, function(path) get_png_entropy(path))))Plot
Plot the various fractals based on a couple of complexity metrics
d <- d %>%
#remove the .png element from file_name
mutate(file_name_clean = gsub(".png","",file_name)) %>%
#split on _
separate(file_name_clean, c("base","complexity"), sep="_",remove=FALSE)
ggplot(d, aes(x=compression_complexity,y=entropy,image=full_path, label=file_name,color=complexity)) +
geom_point(stat="identity")+
geom_label()+
#geom_image(size=.20)+
xlab("Compression Complexity")+
ylab("Image Entropy")+
theme_cowplot()
Compression Complexity
ggplot(d,aes(complexity,compression_complexity,label=file_name,color=complexity))+
geom_violin()+
geom_line(aes(group=base),color="black")+
geom_jitter(width=.1)+
geom_label()+
xlab("Complexity")+
ylab("Compression Complexity")
Image Entropy
ggplot(d,aes(complexity,entropy,label=file_name,color=complexity))+
geom_violin()+
geom_line(aes(group=base),color="black")+
geom_jitter(width=.1)+
geom_label()+
xlab("Complexity")+
ylab("Entropy")
Table
Table to sort fractals by various complexity metrics
d %>%
select(-path, -full_path) %>%
DT::datatable(escape=F)Dream Sim Pairwise Similarity
https://dreamsim-nights.github.io/
dreamsim <- read_csv(here("data","new_fribbles_dreamsim_image_pairwise_distances.csv")) %>%
mutate(
image_base_name_1=str_remove(basename(image_1),".png"),
image_base_name_2=str_remove(basename(image_2),".png"),
) %>%
separate(image_base_name_1,c("base_1","complexity_1"),sep="_",remove=FALSE) %>%
separate(image_base_name_2,c("base_2","complexity_2"),sep="_",remove=FALSE) %>%
mutate(
base_match = ifelse(base_1==base_2,"same base","different base")
)Plot
ggplot(dreamsim,aes(x=base_match,y=distance))+
geom_violin()+
geom_jitter(width=.05,alpha=0.5)+
ylab("Dream Sim Distance")+
xlab("Base Match")
p2 <- ggplot(filter(dreamsim,complexity_1=="high"&complexity_2=="high"),aes(base_1,base_2,fill=distance))+
geom_tile()+
scale_fill_viridis()+
theme(axis.text.x = element_text(angle = 90,hjust=1,vjust=0.5))
p1 <- ggplot(filter(dreamsim,complexity_1=="low"&complexity_2=="low"),aes(base_1,base_2,fill=distance))+
geom_tile()+
scale_fill_viridis()+
theme(axis.text.x = element_text(angle = 90,hjust=1,vjust=0.5))
plot_grid(p1,p2)
Base Pairs
base_pairings <- dreamsim %>%
filter((complexity_1=="high" & complexity_2=="high") | (complexity_1=="low" & complexity_2=="low")) %>%
unite("base_pair",base_1,base_2,sep="_", remove=FALSE) %>%
mutate(complexity=complexity_1) %>%
distinct(base_pair,base_1,base_2,complexity,distance) %>%
group_by(base_1) %>%
mutate(
mean_distance = mean(distance),
median_distance = median(distance)
)
similarity_1 <- ggplot(filter(base_pairings,complexity=="high"),aes(x=reorder(base_1,mean_distance),y=distance))+
geom_violin()+
geom_jitter(width=.05,alpha=0.5)+
ylab("Dream Sim Distance")+
xlab("Base")+
ggtitle("High Complexity")+
theme_cowplot()+
theme(axis.text.x = element_text(angle = 90,hjust=1,vjust=0.5))
similarity_2 <- ggplot(filter(base_pairings,complexity=="low"),aes(x=reorder(base_1,mean_distance),y=distance))+
geom_violin()+
geom_jitter(width=.05,alpha=0.5)+
ylab("Dream Sim Distance")+
xlab("Base")+
ggtitle("Low Complexity")+
theme_cowplot()+
theme(axis.text.x = element_text(angle = 90,hjust=1,vjust=0.5))
plot_grid(similarity_2,similarity_1)
# ggplot(filter(base_pairings,complexity=="low"),aes(x=reorder(base_pair,distance),y=distance))+
# geom_violin()+
# geom_point(alpha=0.5)+
# geom_text_repel(aes(label = base_pair),
# box.padding = 1,
# show.legend = FALSE)+
# ylab("Dream Sim Distance")+
# xlab("Base Pair")+
# ggtitle("Low Complexity Items")+
# theme_cowplot()+
# theme(axis.text.x = element_text(angle = 90,hjust=1))
ggplot(base_pairings,aes(x=complexity,y=distance))+
geom_violin()+
geom_point(alpha=0.5)+
geom_text_repel(aes(label = base_pair),
box.padding = 1,
show.legend = FALSE)+
ylab("Dream Sim Distance")+
xlab("Complexity")+
theme_cowplot()+
theme(axis.text.x = element_text(angle = 90,hjust=1))
base_pairings %>%
DT::datatable(escape=F)Session Info
sessionInfo()## R version 4.3.2 (2023-10-31)
## Platform: aarch64-apple-darwin20 (64-bit)
## Running under: macOS Sonoma 14.4.1
##
## Matrix products: default
## BLAS: /Library/Frameworks/R.framework/Versions/4.3-arm64/Resources/lib/libRblas.0.dylib
## LAPACK: /Library/Frameworks/R.framework/Versions/4.3-arm64/Resources/lib/libRlapack.dylib; LAPACK version 3.11.0
##
## locale:
## [1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
##
## time zone: America/New_York
## tzcode source: internal
##
## attached base packages:
## [1] stats graphics grDevices utils datasets methods base
##
## other attached packages:
## [1] ggrepel_0.9.5 viridis_0.6.5 viridisLite_0.4.2 DT_0.33
## [5] cowplot_1.1.3 knitr_1.45 imagefluency_0.2.5 png_0.1-8
## [9] here_1.0.1 lubridate_1.9.3 forcats_1.0.0 stringr_1.5.1
## [13] dplyr_1.1.4 purrr_1.0.2 readr_2.1.5 tidyr_1.3.1
## [17] tibble_3.2.1 tidyverse_2.0.0 ggimage_0.3.3 ggplot2_3.5.0
##
## loaded via a namespace (and not attached):
## [1] gtable_0.3.4 xfun_0.43 bslib_0.7.0 htmlwidgets_1.6.4
## [5] tzdb_0.4.0 crosstalk_1.2.1 vctrs_0.6.5 tools_4.3.2
## [9] generics_0.1.3 yulab.utils_0.1.4 parallel_4.3.2 fansi_1.0.6
## [13] highr_0.10 pkgconfig_2.0.3 R.oo_1.26.0 ggplotify_0.1.2
## [17] lifecycle_1.0.4 farver_2.1.1 compiler_4.3.2 munsell_0.5.1
## [21] ggfun_0.1.4 htmltools_0.5.8.1 sass_0.4.9 yaml_2.3.8
## [25] crayon_1.5.2 pillar_1.9.0 jquerylib_0.1.4 R.utils_2.12.3
## [29] cachem_1.0.8 magick_2.8.3 tidyselect_1.2.1 digest_0.6.35
## [33] stringi_1.8.3 labeling_0.4.3 rprojroot_2.0.4 fastmap_1.1.1
## [37] grid_4.3.2 colorspace_2.1-0 cli_3.6.2 magrittr_2.0.3
## [41] utf8_1.2.4 withr_3.0.0 scales_1.3.0 bit64_4.0.5
## [45] timechange_0.3.0 rmarkdown_2.26 bit_4.0.5 gridExtra_2.3
## [49] R.methodsS3_1.8.2 hms_1.1.3 memoise_2.0.1 evaluate_0.23
## [53] gridGraphics_0.5-1 rlang_1.1.3 Rcpp_1.0.12 glue_1.7.0
## [57] vroom_1.6.5 rstudioapi_0.16.0 jsonlite_1.8.8 R6_2.5.1
## [61] fs_1.6.3