library(assertthat)
library(dplyr)
library(readxl)
Weight factors
The factors affecting the weighting of individual features are the following:
| THS |
Threat status |
| END |
Endemicity |
| ED |
Evolutionary distinctiveness |
| AGG |
Function, ecosystem service, count) |
The formula for constructing weight \(w\) for species \(i\) in taxon \(t\) is:
\[ w_{it} = \frac{THS \times END \times ED \times AGG}{N_{t}} \]
where \(N_{t}\) is the total number of species in taxon \(t\).
THS - Threat status
This is the Japanese IUCN Red List status.
Possible values: NE, DD, LC, NT, VU, EN, CR, EW, and EX.
END - Endemicity
Value indicates the endemicity of the species.
Possible values: non-endemic species = 1, endemic species = 4
ED - Evolutionary distinctivenes
Standardized values of evolutionary distinctiveness
Possible values: in range [1, 4]
AGG - Function, ecosystem service, count
An subjective view on what is the general value factor (AGG) for each taxa. The values were drafted in the meating in Helsinki in the beginning of February 2016. Following values are used:
| Function |
3 |
2 |
1 |
0 |
0 |
1 |
| Ecosystem service |
6 |
1 |
1 |
0 |
0 |
5 |
| Count |
3 |
0 |
1 |
0 |
0 |
1 |
| Aggregation |
13 |
4 |
4 |
1 |
1 |
5 |
The final row Aggregation is the sum of other categories + 1 (the base-level). Note: while all other components are species-specific, AGG is taxon specific.
Constructing the species specific weights
# First, get just the Aggregation data for each taxon
agg_weights <- agg_weights %>%
# Get only the last (sum) row
dplyr::filter(agg_category == "Aggregation") %>%
# Select everything but agg_category
dplyr::select(-agg_category) %>%
# Turn table into long format
tidyr::gather(taxon, agg_value)
# Second, join the Aggregation data to the actual data
all_taxa <- all_taxa %>%
dplyr::left_join(., agg_weights)
Joining by: "taxon"
# Third, calculate species-specific weight w
all_taxa <- all_taxa %>%
# Group by taxon because the number of species per taxon is needed
dplyr::group_by(taxon) %>%
dplyr::mutate(weight = (THS * END * ED * agg_value) / n())
Plot the top 6 species per each taxon.
plot_taxa <- all_taxa %>%
top_n(6, weight) %>%
arrange(taxon, desc(weight))
plot_taxa %>%
ggplot(aes(x = weight, y = reorder(st.species, weight))) +
geom_point(stat = "identity", size = 2) +
facet_grid(taxon~., scales = "free", space = "free") +
ylab("Species\n") + xlab("\nWeight")

Boxplot of weights per taxon:
all_taxa %>%
ggplot(aes(x = taxon, y = weight)) + geom_boxplot() + coord_flip()

Write out the data:
readr::write_csv(all_taxa, "../../../Data.150928/all_taxa_weights.csv")
LS0tCnRpdGxlOiBHZW5lcmF0aW5nIHdlaWdodHMgZm9yIGRpZmZlcmVudCB0YXhhCmRhdGU6ICJNYXkgMjMsIDIwMTYiCm91dHB1dDogCiAgaHRtbF9ub3RlYm9vawotLS0KCmBgYHtyIHNldHVwLCBlY2hvPVRSVUUsbWVzc2FnZT1GQUxTRSx3YXJuaW5nPUZBTFNFfQpsaWJyYXJ5KGFzc2VydHRoYXQpCmxpYnJhcnkoZHBseXIpCmxpYnJhcnkoZ2dwbG90MikKbGlicmFyeShrbml0cikKbGlicmFyeShyZWFkcikKbGlicmFyeShyZWFkeGwpCmxpYnJhcnkodGlkeXIpCgojIFdoZXJlIGlzIHRoZSBkYXRhIHJlYWQgZnJvbT8KYXV4X2V4Y2VsX2ZpbGUgPC0gIi4uLy4uLy4uL0RhdGEuMTUwOTI4L0FVQyZSTC54bHN4IgphZ2dfZXhjZWxfZmlsZSA8LSAiLi4vLi4vLi4vRGF0YS4xNTA5Mjgvd2VpZ2h0aW5nLnhsc3giCgojIFJlYWQgaW4gdGhlIGF1eGlsaWFyeSBkYXRhIGZvciBkaWZmZXJlbnQgdGF4YQpyZWFkX3RheG9uIDwtIGZ1bmN0aW9uKHRheG9uX25hbWUpIHsKICAjIFJlYWQgaW4gdGF4b24gZGF0YQogIGRhdCA8LSByZWFkeGw6OnJlYWRfZXhjZWwoYXV4X2V4Y2VsX2ZpbGUsIHRheG9uX25hbWUpCiAgIyBBZGQgdGF4b24gbmFtZSBhcyBhIGNvbHVtbgogIGRhdCR0YXhvbiA8LSB0YXhvbl9uYW1lCiAgcmV0dXJuKGRhdCkKfQphbGxfdGF4YSA8LSBsYXBwbHkoYygicGxhbnQiLCAibWFtbWFsIiwgImJpcmQiLCAicmVwdGlsZSIsICJhbXBoaWJpYW4iLCAiZnJlc2h3YXRlcl9maXNoIiksCiAgICAgICAgICAgICAgICAgICByZWFkX3RheG9uKQphbGxfdGF4YSA8LSBkcGx5cjo6YmluZF9yb3dzKGFsbF90YXhhKQoKIyBSZWFkIGluIHRoZSBBR0cgd2VpZ2h0aW5nIGRhdGEKYWdnX3dlaWdodHMgPC0gcmVhZHhsOjpyZWFkX2V4Y2VsKGFnZ19leGNlbF9maWxlLCAiYWdnX3dlaWdodHMiKQpgYGAKCiMjIFdlaWdodCBmYWN0b3JzCgpUaGUgZmFjdG9ycyBhZmZlY3RpbmcgdGhlIHdlaWdodGluZyBvZiBpbmRpdmlkdWFsIGZlYXR1cmVzIGFyZSB0aGUgZm9sbG93aW5nOgoKfCBDb2RlIHwgRGVzY3JpcHRpb24gICAgICAgICAgICAgICAgICAgICAgICAgfAp8LS0tLS0tfC0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS0tLS18CnwgVEhTICB8IFRocmVhdCBzdGF0dXMgICAgICAgICAgICAgICAgICAgICAgIHwKfCBFTkQgIHwgRW5kZW1pY2l0eSAgICAgICAgICAgICAgICAgICAgICAgICAgfAp8IEVEICAgfCBFdm9sdXRpb25hcnkgZGlzdGluY3RpdmVuZXNzICAgICAgICB8CnwgQUdHICB8IEZ1bmN0aW9uLCBlY29zeXN0ZW0gc2VydmljZSwgY291bnQpIHwKClRoZSBmb3JtdWxhIGZvciBjb25zdHJ1Y3Rpbmcgd2VpZ2h0ICR3JCBmb3Igc3BlY2llcyAkaSQgaW4gdGF4b24gJHQkIGlzOgoKJCQgd197aXR9ID0gXGZyYWN7VEhTIFx0aW1lcyBFTkQgXHRpbWVzIEVEIFx0aW1lcyBBR0d9e05fe3R9fSAkJAoKd2hlcmUgJE5fe3R9JCBpcyB0aGUgdG90YWwgbnVtYmVyIG9mIHNwZWNpZXMgaW4gdGF4b24gJHQkLgoKLS0tLQoKIyMjIyBUSFMgLSBUaHJlYXQgc3RhdHVzCgpUaGlzIGlzIHRoZSBKYXBhbmVzZSBJVUNOIFJlZCBMaXN0IHN0YXR1cy4gCgpQb3NzaWJsZSB2YWx1ZXM6IGBORWAsIGBERGAsIGBMQ2AsIGBOVGAsIGBWVWAsIGBFTmAsIGBDUmAsIGBFV2AsIGFuZCBgRVhgLgoKIyMjIyBFTkQgLSBFbmRlbWljaXR5CgpWYWx1ZSBpbmRpY2F0ZXMgdGhlIGVuZGVtaWNpdHkgb2YgdGhlIHNwZWNpZXMuICAKClBvc3NpYmxlIHZhbHVlczogYG5vbi1lbmRlbWljIHNwZWNpZXMgPSAxYCwgYGVuZGVtaWMgc3BlY2llcyA9IDRgCgojIyMjIEVEIC0gRXZvbHV0aW9uYXJ5IGRpc3RpbmN0aXZlbmVzCgpTdGFuZGFyZGl6ZWQgdmFsdWVzIG9mIGV2b2x1dGlvbmFyeSBkaXN0aW5jdGl2ZW5lc3MKClBvc3NpYmxlIHZhbHVlczogaW4gcmFuZ2UgYFsxLCA0XWAKCiMjIyMgQUdHIC0gRnVuY3Rpb24sIGVjb3N5c3RlbSBzZXJ2aWNlLCBjb3VudAoKQW4gc3ViamVjdGl2ZSB2aWV3IG9uIHdoYXQgaXMgdGhlIGdlbmVyYWwgdmFsdWUgZmFjdG9yIChgQUdHYCkgZm9yIGVhY2ggdGF4YS4gVGhlIHZhbHVlcyB3ZXJlIGRyYWZ0ZWQgaW4gdGhlIG1lYXRpbmcgaW4gSGVsc2lua2kgaW4gdGhlIGJlZ2lubmluZyBvZiBGZWJydWFyeSAyMDE2LiBGb2xsb3dpbmcgdmFsdWVzIGFyZSB1c2VkOgoKYGBge3Igb3V0cHV0LWFkZC13ZWlnaHRzLGVjaG89RkFMU0UscmVzdWx0cz0iYXNpcyJ9CmtuaXRyOjprYWJsZShhZ2dfd2VpZ2h0cywgYWxpZ24gPSBjKCdsJywgJ2MnLCAnYycsICdjJywgJ2MnLCAnYycsICdjJykpCgpgYGAKClRoZSBmaW5hbCByb3cgYEFnZ3JlZ2F0aW9uYCBpcyB0aGUgc3VtIG9mIG90aGVyIGNhdGVnb3JpZXMgKyAxICh0aGUgYmFzZS1sZXZlbCkuICoqTm90ZSoqOiB3aGlsZSBhbGwgb3RoZXIgY29tcG9uZW50cyBhcmUgc3BlY2llcy1zcGVjaWZpYywgYEFHR2AgaXMgdGF4b24gc3BlY2lmaWMuCgojIyBDb25zdHJ1Y3RpbmcgdGhlIHNwZWNpZXMgc3BlY2lmaWMgd2VpZ2h0cwoKYGBge3IgY29uc3RydWN0LXdlaWdodHN9CiMgRmlyc3QsIGdldCBqdXN0IHRoZSBBZ2dyZWdhdGlvbiBkYXRhIGZvciBlYWNoIHRheG9uCmFnZ193ZWlnaHRzIDwtIGFnZ193ZWlnaHRzICU+JSAKICAjIEdldCBvbmx5IHRoZSBsYXN0IChzdW0pIHJvdwogIGRwbHlyOjpmaWx0ZXIoYWdnX2NhdGVnb3J5ID09ICJBZ2dyZWdhdGlvbiIpICU+JSAKICAjIFNlbGVjdCBldmVyeXRoaW5nIGJ1dCBhZ2dfY2F0ZWdvcnkKICBkcGx5cjo6c2VsZWN0KC1hZ2dfY2F0ZWdvcnkpICU+JQogICMgVHVybiB0YWJsZSBpbnRvIGxvbmcgZm9ybWF0CiAgdGlkeXI6OmdhdGhlcih0YXhvbiwgYWdnX3ZhbHVlKQoKIyBTZWNvbmQsIGpvaW4gdGhlIEFnZ3JlZ2F0aW9uIGRhdGEgdG8gdGhlIGFjdHVhbCBkYXRhCmFsbF90YXhhIDwtIGFsbF90YXhhICU+JSAKICBkcGx5cjo6bGVmdF9qb2luKC4sIGFnZ193ZWlnaHRzKQoKIyBUaGlyZCwgY2FsY3VsYXRlIHNwZWNpZXMtc3BlY2lmaWMgd2VpZ2h0IHcKYWxsX3RheGEgPC0gYWxsX3RheGEgJT4lIAogICMgR3JvdXAgYnkgdGF4b24gYmVjYXVzZSB0aGUgbnVtYmVyIG9mIHNwZWNpZXMgcGVyIHRheG9uIGlzIG5lZWRlZAogIGRwbHlyOjpncm91cF9ieSh0YXhvbikgJT4lIAogIGRwbHlyOjptdXRhdGUod2VpZ2h0ID0gKFRIUyAqIEVORCAqIEVEICogYWdnX3ZhbHVlKSAvIG4oKSkKYGBgCgpQbG90IHRoZSB0b3AgNiBzcGVjaWVzIHBlciBlYWNoIHRheG9uLgoKYGBge3IgcGxvdC1wZXItdGF4b24sZmlnLmhlaWdodD03fQpwbG90X3RheGEgPC0gYWxsX3RheGEgJT4lIAogIHRvcF9uKDYsIHdlaWdodCkgJT4lIAogIGFycmFuZ2UodGF4b24sIGRlc2Mod2VpZ2h0KSkKCnBsb3RfdGF4YSAlPiUgCiAgZ2dwbG90KGFlcyh4ID0gd2VpZ2h0LCB5ID0gcmVvcmRlcihzdC5zcGVjaWVzLCB3ZWlnaHQpKSkgKyAKICAgIGdlb21fcG9pbnQoc3RhdCA9ICJpZGVudGl0eSIsIHNpemUgPSAyKSArIAogICAgZmFjZXRfZ3JpZCh0YXhvbn4uLCBzY2FsZXMgPSAiZnJlZSIsIHNwYWNlID0gImZyZWUiKSArCiAgICB5bGFiKCJTcGVjaWVzXG4iKSArIHhsYWIoIlxuV2VpZ2h0IikKICAKYGBgCgpCb3hwbG90IG9mIHdlaWdodHMgcGVyIHRheG9uOgoKYGBge3IgZGVzY3JpcHRpdmUtc3RhdHN9CmFsbF90YXhhICU+JSAKICBnZ3Bsb3QoYWVzKHggPSB0YXhvbiwgeSA9IHdlaWdodCkpICsgZ2VvbV9ib3hwbG90KCkgKyBjb29yZF9mbGlwKCkKCmBgYAoKCldyaXRlIG91dCB0aGUgZGF0YToKCmBgYHtyIHdyaXRlLWRhdGF9CnJlYWRyOjp3cml0ZV9jc3YoYWxsX3RheGEsICIuLi8uLi8uLi9EYXRhLjE1MDkyOC9hbGxfdGF4YV93ZWlnaHRzLmNzdiIpCmBgYAoKCg==