library(assertthat)
library(dplyr)
library(readxl)

Weight factors

The factors affecting the weighting of individual features are the following:

Code Description
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:

agg_category plant mammal bird reptile amphibian freshwater_fish
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==