forked from AaronGullickson/system_generation
-
Notifications
You must be signed in to change notification settings - Fork 0
/
produce_systems.R
1449 lines (1317 loc) · 56.7 KB
/
produce_systems.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
#This script will read in the original planets XML data and use our system generation
#functions to generate data where it is missing.
#Eventually this script will also use projection forwards and backwards in time to change
#population and USILR values, but for the moment we are just going to take a static snapshot
library(xml2)
library(magrittr)
library(dplyr)
library(rlist)
library(here)
library(tibble)
library(stringr)
source(here("functions","system_creation_functions.R"))
source(here("functions","data_functions.R"))
source(here("functions","naming_functions.R"))
source(here("functions","network_functions.R"))
#set a seed to allow for reproducing the results
set.seed(3050)
options(nwarnings = 1000)
planets <- read_xml(here("output","planets_initial.xml"))
connectors <- read_xml(here("output","connectors_initial.xml"))
waystations <- read_xml(here("output","waystations.xml"))
events <- read_xml(here("output","planetevents_initial.xml"))
name_changes <- read_xml(here("input","0999_namechanges.xml"))
terran_system <- read_xml(here("input","terran_system.xml"))
canon_populations <- read.csv(here("input","canon_populations.csv"), row.names=1)
waystation_data <- read.csv(here("input","waystations.csv"))
planet.table <- NULL
target.year <- 3047
target_date <- as.Date(paste(target.year,"01","01",sep="-"))
hpg_data <- data.frame(id=character(),
x=numeric(),
y=numeric(),
hpg=character(),
faction_type=character(),
tech=character(),
pop=numeric(),
founding_year=numeric(),
abandon_year=numeric(),
canon=logical())
#all events will now go into the master event table and then
#be processed after the initial looping. This is because MHQ
#doesn't allow for separate events with the same date and will
#just overwrite earlier ones with later ones. So we need to
#collect all events before writing them to identify ones with the
#same date. This is especially important for the founding date because
#that will always have faction, population, and SIC.
event_table <- tibble(id=character(),
sys_pos=numeric(),
date=character(),
etype=character(),
event=character(),
canon=logical())
#for recolonization
# a list of recolonization faction events for later processing
recolonization <- list()
# a list of primary planets for recolonization
recolonized_planets <- list()
#prepare the XML systems output
systems <- xml_new_document() %>% xml_add_child("systems")
systems_events <- xml_new_document() %>% xml_add_child("systems")
systems_name_changes <- xml_new_document() %>% xml_add_child("systems")
systems_connectors <- xml_new_document() %>% xml_add_child("systems")
small_sample <- sample(1:xml_length(planets), 10)
for(i in 1:xml_length(planets)) {
#for(i in small_sample) {
#### Read in a planet's data ####
#technical identification
planet <- xml_children(planets)[[i]]
id <- xml_text(xml_find_first(planet, "id"))
name <- xml_text(xml_find_first(planet, "name"))
x <- as.numeric(xml_text(xml_find_first(planet, "xcood")))
y <- as.numeric(xml_text(xml_find_first(planet, "ycood")))
cat(paste(id,"\n\treading in XML data..."))
#system information
star <- xml_text(xml_find_first(planet, "spectralType"))
sys_pos <- as.numeric(xml_text(xml_find_first(planet, "sysPos")))
#planetary information - is this all Canon?
life <- xml_text(xml_find_first(planet, "lifeForm"))
water <- xml_text(xml_find_first(planet, "percentWater"))
gravity <- as.numeric(xml_text(xml_find_first(planet, "gravity")))
temperature <- xml_text(xml_find_first(planet, "temperature"))
pressure <- factor(xml_text(xml_find_first(planet, "pressure")),
levels=0:5,
labels=c("Vacuum","Trace","Low","Normal","High","Very High"))
landmasses <- xml_find_all(planet, "landMass")
continents <- NULL
for(landmass in landmasses) {
continents <- c(continents, xml_text(landmass))
}
moons <- NULL
satellites <- xml_find_all(planet, "satellite")
for(satellite in satellites) {
moons <- c(moons, xml_text(satellite))
}
#social information
#First see if it is in the planet data
faction <- xml_text(xml_find_first(planet, "faction"))
hpg <- xml_text(xml_find_first(planet, "hpg"))
sic <- xml_text(xml_find_first(planet, "socioIndustrial"))
nadir_charge
nadir_charge <- xml_text(xml_find_first(planet, "nadirCharge"))=="true"
zenith_charge <- xml_text(xml_find_first(planet, "zenithCharge"))=="true"
#it seems like all planets were given a default FALSE value here, which makes it difficult
#to sort out canon cases of no recharge stations. We will have to assume that where both
#are false its non-canon and therefore ignore them
if(!is.na(nadir_charge) && !nadir_charge && !is.na(zenith_charge) && !zenith_charge) {
nadir_charge <- NA
zenith_charge <- NA
}
#check for faction change events
faction_table <- get_event_data(events, id, "faction")
founding_year <- NA
terran_hegemony <- FALSE
abandon_year <- NA
is_recolonized <- FALSE
if(!is.null(faction_table)) {
founding_year <- get_year(faction_table$date[1])
if("ABN" %in% faction_table$event) {
#in order to handle cases of abandoned planets that are re-founded and potentially abandoned
#again we need to truncate the faction table
#probably a better way to handle this than a for loop but damned if I can figure it out
splits <- which(faction_table$event=="ABN")
temp <- list()
for(j in length(splits):1) {
if(splits[j]==nrow(faction_table)) {
next
}
temp[[j]] <- faction_table[(splits[j]+1):nrow(faction_table),]
faction_table <- faction_table[1:splits[j],]
}
if(length(temp)>0) {
recolonization[[id]] <- temp
is_recolonized <- TRUE
}
abandon_year <- get_year(subset(faction_table, event=="ABN")$date)
}
#we allow_later=TRUE so we don't lose planets with founding dates later than target_date
#remove any cases of ABN from what we feed in here as well so we get the faction before abandonment
temp <- get_closest_event(subset(faction_table, event!="ABN"),
target_date, allow_later = TRUE)
#take the first faction in cases of multiple factions
if(!is.na(temp)) {
faction <- strsplit(temp,",")[[1]][1]
}
#figure out if this was Terran Hegemony world in 2750
terran_hegemony <- grepl("(^TH$|TH,|,TH)",
get_closest_event(subset(faction_table, event!="ABN"),
as.Date(paste(2750,"01","01",sep="-"))))
}
hpg_table <- get_event_data(events, id, "hpg")
if(!is.null(hpg_table)) {
temp <- get_closest_event(hpg_table, target_date)
if(!is.na(temp)) {
hpg <- temp
}
}
sic_table <- get_event_data(events, id, "socioIndustrial")
if(!is.null(sic_table)) {
#SIC must be between 3045 and 3080 to use
temp <- get_closest_event(sic_table, as.Date(paste(3080,"01","01",sep="-")),
as.Date(paste(3045,"01","01",sep="-")))
if(!is.na(temp)) {
sic <- temp
}
}
desc <- xml_text(xml_find_first(planet, "desc"))
# do some checks, if fail then skip for now
#drop if they are missing x or y coordinates (shouldnt happen)
if(is.na(x) | is.na(y)) {
warning(paste("ERROR:", id, "is missing an x or y value. Skipping.\n"))
next
}
#drop if they are missing founding year
if(is.na(founding_year)) {
warning(paste("ERROR:", id, "has a missing founding year. Skipping.\n"))
next
}
# ignore abandoned places or those with UND or NONE factions (mostly highways which
# should be in the connector file not here)
if(is.na(faction) | faction=="UND" | faction=="NONE") {
warning(paste("ERROR:", id, "has a missing or unknown faction. Skipping.\n"))
next
}
if(faction=="ABN") {
warning(paste(id, "is abandoned. Skipping.\n"))
next
}
cat("done\n\tOrganizing data...")
#### Generate the System ####
distance_terra <- sqrt(x^2+y^2)
#this would be easier to do with an %in% but not going to mess with it now
faction_type <- get_faction_type(faction)
#Check for bad stellar types and correct
if(is.na(star)) {
star <- NULL
} else if(!is_star_valid(star)) {
warning(paste("star type of", star, "not valid for", id))
star <- NULL
}
#This is a bit of a hack, but non-canon star types were generated for pretty much every
#system at some point. To figure out which are actually canon, we will use sys_pos
if(is.na(sys_pos)) {
star <- NULL
}
## Fix founding year
# There was considerable amounts of heaping in founding years because these were
# determined in many cases by changes between maps with the faction change only
# occurring at the latter date. We want to allow these founding dates to vary between
# the map dates, probably by drawing from uniform distribution.
founding_year <- fix_founding_heaping(founding_year, distance_terra)
#also check for heaping on abandon year. This function will return NA if abandon_year is NA
#already. We also need to feed in founding year to make sure we don't end up with abandonment
#before founding
abandon_year <- fix_abandoned_heaping(abandon_year, founding_year)
#read in canon population data
if(id %in% rownames(canon_populations)) {
canon_population <- canon_populations[id,]
} else {
canon_population <- NULL
}
# use the name of the planet to determine if there is a specific system position to be filled
temp <- gsub("\\(.*\\)", "", name)
#first look for roman numerals
canon_pos <- NA
roman <- str_trim(str_extract(temp, "\\s+(I|II|III|IV|V|VI|VII|VIII|IX|X|XI|XII|XIII|XIV|XV)$"))
if(!is.na(roman)) {
canon_pos <- convert_roman2arabic(roman)
}
#now look for arabic numbering - it turns out this is problematic because it is used for
#things like Star Cluster 643. The only valid case we have at the moment is Baker 3 so
#lets just look for that specifically
#arabic <- str_trim(str_extract(temp, "Baker 3$"))
#if(!is.na(arabic)) {
if(grepl("^Baker 3$", name)) {
canon_pos <- 3
}
if(!is.na(sys_pos)) {
canon_pos <- sys_pos
}
cat("done\n\tGenerating base system and colonization data...")
#base system
system <- generate_system(star=star, habitable=TRUE, habit_pos=canon_pos)
#add colonization
system <- add_colonization(system, distance_terra, 3047, founding_year,
faction_type, abandon_year)
#name stuff
system <- generate_system_names(system, id)
primary_slot <- which(system$planets$population==max(system$planets$population, na.rm=TRUE))[1]
#### Output XML ####
cat("done\n\tOutputing base data to XML...")
#create a system node
system_event_node <- xml_add_child(systems_events, "system")
xml_add_child(system_event_node, "id", id)
if(id=="Terra") {
#if Terra, ignore what we generated and put in correct values from file
xml_add_child(systems, terran_system)
} else {
system_node <- xml_add_child(systems, "system")
write_system_xml(system_node, system, id, x, y, primary_slot,
star, gravity, pressure, temperature, water,
life, continents, moons, desc)
}
#### Project Social Data in Time ####
#we add these events to event_table initially, so we can do some post-processing
for(j in which(!is.na(system$planets$population))) {
planet <- system$planets[j,]
if(!is.null(faction_table)) {
#put in a new founding year as it may have been changed for heaping
faction_table$date[1] <- paste(founding_year,"01","01",sep="-")
#if there is an abandonment in the table it may also have changed
if("ABN" %in% faction_table$event) {
faction_table$date[faction_table$event=="ABN"] <- paste(abandon_year,"01","01",sep="-")
}
for(idx in 1:nrow(faction_table)) {
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=j,
date=as.character(faction_table$date[idx]),
etype="faction",
event=as.character(faction_table$event[idx]),
canon=TRUE))
if(id=="Terra") {
#add in the same table for mars and venus if within their lifespan
year <- get_year(faction_table$date[idx])
#check mars
if(year>2201) {
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=4,
date=as.character(faction_table$date[idx]),
etype="faction",
event=as.character(faction_table$event[idx]),
canon=TRUE))
}
#check venus
if(year>2205 & year<3030) {
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=as.character(faction_table$date[idx]),
etype="faction",
event=as.character(faction_table$event[idx]),
canon=TRUE))
}
}
}
if(id=="Terra") {
#put in starting (and ending) dates for mars and venus
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=4,
date=paste(2201,"01","01",sep="-"),
etype="faction",
event="TA",
canon=FALSE))
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=paste(2205,"01","01",sep="-"),
etype="faction",
event="TA",
canon=FALSE))
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=paste(3030,"01","01",sep="-"),
etype="faction",
event="ABN",
canon=FALSE))
#add terraforming stuff here as well
#mars terraforming
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=4,
date=paste(2201,"01","01",sep="-"),
etype="pressure",
event="Thin",
canon=FALSE))
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=4,
date=paste(2201,"01","01",sep="-"),
etype="atmosphere",
event="Breathable",
canon=TRUE))
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=4,
date=paste(2201,"01","01",sep="-"),
etype="water",
event="39",
canon=TRUE))
#venus terraforming
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=paste(2205,"01","01",sep="-"),
etype="water",
event="30",
canon=TRUE))
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=paste(2205,"01","01",sep="-"),
etype="dayLength",
event="48",
canon=TRUE))
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=paste(2205,"01","01",sep="-"),
etype="temperature",
event="40",
canon=TRUE))
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=paste(2205,"01","01",sep="-"),
etype="atmosphere",
event="Breathable",
canon=TRUE))
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=paste(2205,"01","01",sep="-"),
etype="pressure",
event="Standard",
canon=TRUE))
#lets assume venus decays by 2950
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=paste(2950,"01","01",sep="-"),
etype="temperature",
event="250",
canon=TRUE))
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=paste(2950,"01","01",sep="-"),
etype="atmosphere",
event="Toxic (Poisonous)",
canon=TRUE))
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=paste(2950,"01","01",sep="-"),
etype="pressure",
event="Very High",
canon=TRUE))
}
}
border_distance <- distance_to_border(x, y, faction)
#population
p2750 <- NULL
p3025 <- NULL
p3067 <- NULL
p3079 <- NULL
p3145 <- NULL
if(!is.null(canon_population) & j==primary_slot) {
if(!is.na(canon_population$X2750)) {
p2750 <- canon_population$X2750
}
if(!is.na(canon_population$X3025)) {
p3025 <- canon_population$X3025
}
if(!is.na(canon_population$X3067)) {
p3067 <- canon_population$X3067
}
if(!is.na(canon_population$X3079)) {
p3079 <- canon_population$X3079
}
if(!is.na(canon_population$X3145)) {
p3145 <- canon_population$X3145
}
}
pop <- project_population(planet$population, founding_year, faction_type,
border_distance, planet$agriculture,
terran_hegemony = terran_hegemony,
abandon_year = abandon_year,
p2750 = p2750, p3025 = p3025, p3067 = p3067,
p3079 = p3079, p3145 = p3145,
is_terra=(id=="Terra"))
if(id=="Terra") {
## Populate Mars ##
#according to SL and JHS: Terra, Mars was founded around 2201
#it had a population of "over a million" by the beginning of SL (2571),
pop_mars <- (10000 * runif(1, 0.95,1.05)) *
exp(cumsum(c(0,
get_gompertz_rates(1300000, 10000, 2571-2200)+
growth_simulation(0, 2571-2201, 0.75))))
while(pop_mars[length(pop_mars)]<1000000) {
pop_mars <- (10000 * runif(1, 0.95,1.05)) *
exp(cumsum(c(0,
get_gompertz_rates(1000000, 10000, 2571-2200)+
growth_simulation(0, 2571-2201, 0.75))))
}
#it had a population of 70 million at the height of SL (2765)
rate <- log(70000000/pop_mars[length(pop_mars)])/(2765-2571)
temp <- pop_mars[length(pop_mars)]* exp(cumsum(growth_simulation(rate, 2765-2571, 0.1)))
while(max(temp)>80000000 | max(temp) < 70000000) {
temp <- pop_mars[length(pop_mars)]* exp(cumsum(growth_simulation(rate, 2765-2571, 0.1)))
}
pop_mars <- c(pop_mars, temp)
#it had a population of 4.25 million in 3077 - the 1 million figure for 3025 is explicitly
#said to be inaccurate in JHS Terra
rate <- log(4250000/pop_mars[length(pop_mars)])/(3077-2765)
temp <- pop_mars[length(pop_mars)]* exp(cumsum(growth_simulation(rate, 3077-2765, 0.2)))
while(temp[length(temp)]>4300000 | temp[length(temp)] < 4200000) {
temp <- pop_mars[length(pop_mars)]* exp(cumsum(growth_simulation(rate, 3077-2765, 0.2)))
}
pop_mars <- c(pop_mars, temp)
#assume standard low-growth until 3145
pop_mars <- c(pop_mars,
4250000*exp(cumsum(growth_simulation(0.001, 3145-3077, messiness=2))))
names(pop_mars) <- paste(2201:3145)
#subtract mars population from tarra pop
pop[names(pop_mars)] <- pop[names(pop_mars)]-pop_mars
#add Mars population to event table
census_years <- c(2201, seq(from=2210, to=3140, by=10), 3145)
census_pop <- round(pop_mars[paste(census_years)])
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=4,
date=paste(census_years,"01","01",sep="-"),
etype="population",
event=paste(census_pop),
canon=FALSE))
#add in canon 3077 population
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=4,
date=paste(3077,"01","01",sep="-"),
etype="population",
event=paste(pop_mars["3077"]),
canon=TRUE))
## Populate Venus ##
#we dont have an exact colonization date for Venus, but should be close
#to Mars, lets put it at 2205.
#202.5 million at star league peak
pop_venus <- (10000 * runif(1, 0.95,1.05)) *
exp(cumsum(c(0,
get_gompertz_rates(202500000, 10000, 2765-2204)+
growth_simulation(0, 2765-2205, 0.75))))
while(pop_venus[length(pop_venus)]<202500000 | pop_venus[length(pop_venus)]>215000000) {
pop_venus <- (10000 * runif(1, 0.95,1.05)) *
exp(cumsum(c(0,
get_gompertz_rates(202500000, 10000, 2765-2204)+
growth_simulation(0, 2765-2205, 0.75))))
}
#declines to 9000ish by 3025
rate <- log(9000/pop_venus[length(pop_venus)])/(3025-2765)
temp <- pop_venus[length(pop_venus)]* exp(cumsum(growth_simulation(rate, 3025-2765, 0.2)))
while(temp[length(temp)]>10000 | temp[length(temp)] < 7000) {
temp <- pop_venus[length(pop_venus)]* exp(cumsum(growth_simulation(rate, 3025-2765, 0.2)))
}
pop_venus<- c(pop_venus, temp)
names(pop_venus) <- paste(2205:3025)
#subtract mars population from tarra pop
pop[names(pop_venus)] <- pop[names(pop_venus)]-pop_venus
#add Venus population to event table
census_years <- c(2205, seq(from=2210, to=3020, by=10))
census_pop <- round(pop_venus[paste(census_years)])
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=paste(census_years,"01","01",sep="-"),
etype="population",
event=paste(census_pop),
canon=FALSE))
#we dont no exact abandonment date, but lets say it was zero by 3030
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=2,
date=paste("3030","01","01",sep="-"),
etype="population",
event="0",
canon=FALSE))
}
#collect population values at 10 year intervals, plus the starting and final values.
first_census_year <- founding_year + 10*(ceiling(founding_year/10)-(founding_year/10))
last_year <- as.numeric(names(pop)[length(pop)])
last_census_year <- 10*floor(last_year/10)
if(last_census_year<=first_census_year) {
#if colony died quickly or was founded close to 3145, this won't work so just put first population
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=j,
date=paste(founding_year,"01","01",sep="-"),
etype="population",
event=paste(pop[1]),
canon=FALSE))
} else {
#otherwise add census years to event list
census_years <- c(founding_year, seq(from=first_census_year, to=last_census_year, by=10), last_year)
census_pop <- round(pop[paste(census_years)])
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=j,
date=paste(census_years,"01","01",sep="-"),
etype="population",
event=paste(census_pop),
canon=FALSE))
}
#add in canon populations
if(!is.null(p2750)) {
sl_peak <- 2785
if(terran_hegemony) {
sl_peak <- 2767
}
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=j,
date=paste(sl_peak,"01","01",sep="-"),
etype="population",
event=paste(p2750),
canon=FALSE))
}
if(!is.null(p3025)) {
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=j,
date=paste(3025,"01","01",sep="-"),
etype="population",
event=paste(p3025),
canon=FALSE))
}
if(!is.null(p3067)) {
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=j,
date=paste(3067,"01","01",sep="-"),
etype="population",
event=paste(p3067),
canon=FALSE))
}
if(!is.null(p3079)) {
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=j,
date=paste(3079,"01","01",sep="-"),
etype="population",
event=paste(p3079),
canon=FALSE))
}
if(!is.null(p3145)) {
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=j,
date=paste(3145,"01","01",sep="-"),
etype="population",
event=paste(p3145),
canon=FALSE))
}
#if abandoned, add in abandonment year
if(!is.na(abandon_year)) {
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=j,
date=paste(abandon_year,"01","01",sep="-"),
etype="population",
event="0",
canon=TRUE))
}
#SIC Codes
tech <- planet$tech
industry <- planet$industry
raw <- planet$raw
output <- planet$output
agriculture <- planet$agriculture
if(!is.na(sic)) {
canon_sics <- separate_sics(sic)
tech <- canon_sics$tech
industry <- canon_sics$industry
raw <- canon_sics$raw
output <- canon_sics$output
agriculture <- canon_sics$agriculture
}
sics_projections <- project_sics(tech, industry, raw, output, agriculture,
founding_year, abandon_year, pop, faction_type)
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=j,
date=paste(sics_projections$year,"01","01",sep="-"),
etype="socioIndustrial",
event=paste(sics_projections$sics),
canon=!is.na(sic) &
(sics_projections$year>=3040 & sics_projections$year<3050)))
# HPG - We need to do some extra work below to make sure the
# first circuit is connected so for the moment, we just want
# to build a dataset of HPG information for later
if((!is.na(planet$hpg) | !is.na(hpg)) & j==primary_slot) {
canon <- TRUE
if(is.na(hpg)) {
hpg <- planet$hpg
canon <- FALSE
}
hpg_data <- rbind(hpg_data,
data.frame(id=as.character(id),
x=as.numeric(x),
y=as.numeric(y),
hpg=as.character(hpg),
faction_type=as.character(faction_type),
tech=as.character(tech),
pop=max(pop),
founding_year=founding_year,
abandon_year=abandon_year,
canon=canon))
}
#Recharge Stations - this should only be checked on the primary slot,
#but should have a sys_pos of zero so it will be written to the system
if(j==primary_slot) {
#first check to see if we have canon data for either recharge station
#and replace if so
if(!is.na(nadir_charge)) {
system$recharge$nadir <- nadir_charge
}
if(!is.na(zenith_charge)) {
system$recharge$zenith <- zenith_charge
}
recharge_data <- project_recharge(system$recharge, faction_type,
founding_year, sics_projections,
pop, abandon_year)
event_table <- event_table %>%
bind_rows(tibble(id=as.character(id),
sys_pos=0,
date=paste(recharge_data$year,"01","01",sep="-"),
etype=recharge_data$etype,
event=paste(recharge_data$event),
canon=FALSE))
}
if(j==primary_slot && is_recolonized) {
#we need to save the planet information so that we can re-access it later for recolonization
planet$previous_abandon_year <- abandon_year
planet$border_distance <- border_distance
planet$terran_hegemony <- terran_hegemony
if(!is.na(sic)) {
canon_sics <- separate_sics(sic)
planet$tech <- canon_sics$tech
planet$industry <- canon_sics$industry
planet$raw <- canon_sics$raw
planet$output <- canon_sics$output
planet$agriculture <- canon_sics$agriculture
}
planet$nadir <- system$recharge$nadir
planet$zenith <- system$recharge$zenith
planet$distance_terra <- distance_terra
planet$primary_slot <- primary_slot
recolonized_planets[[id]] <- planet
}
}
#get name changes and move them over
planet_name_changes <- get_planet_id(name_changes, id)
if(length(planet_name_changes)>0) {
system_name_node <- xml_add_child(systems_name_changes, "system")
xml_add_child(system_name_node, "id", id)
primary_planet_name_node <- xml_add_child(system_name_node, "planet")
xml_add_child(primary_planet_name_node, "sysPos", primary_slot)
for(planet_name_change in xml_find_all(planet_name_changes, "event")) {
xml_add_child(primary_planet_name_node, planet_name_change)
#check to see if changed to numeric style
date <- xml_text(xml_find_first(planet_name_change, "date"))
temp <- xml_text(xml_find_first(planet_name_change, "name"))
roman <- grepl("\\s+(I|II|III|IV|V|VI|VII|VIII|IX|X|XI|XII|XIII|XIV|XV)$",
temp)
arabic <- grepl("\\s+\\d+$", temp)
if(roman || arabic) {
#change all the remaining system names except asteroid belts
base_name <- ""
if(roman) {
base_name <- trimws(gsub("\\s+(I|II|III|IV|V|VI|VII|VIII|IX|X|XI|XII|XIII|XIV|XV)$",
"", temp))
}
if(arabic) {
base_name <- trimws(gsub("\\s+\\d+$", "", temp))
}
pos <- 1
for(j in 1:nrow(system$planets)) {
if(j==primary_slot) {
pos <- pos+1
next
}
if(system$planets$type[j]=="Asteroid Belt") {
next
}
planet_node <- xml_add_child(system_name_node, "planet")
xml_add_child(planet_node, "sysPos", j)
event <- xml_add_child(planet_node, "event")
xml_add_child(event, "date", date)
if(roman) {
xml_add_child(event, "name", paste(base_name, convert_arabic2roman(pos)), source="noncanon")
} else {
xml_add_child(event, "name", paste(base_name, pos), source="noncanon")
}
pos <- pos+1
}
}
}
}
cat("\n\tdone\n")
}
#### Fill in HPG Network ####
cat("\nFilling in gaps in HPG First Circuit...")
#hpg_data_backup <- hpg_data
hpg_data <- hpg_data[order(hpg_data$pop, decreasing = TRUE),]
hpg_data <- subset(hpg_data, !duplicated(hpg_data$id))
hpg_data$tech <- factor(hpg_data$tech,
levels=c("X","F","D","C","B","A"),
ordered = TRUE)
hpg_data$hpg <- toupper(as.character(hpg_data$hpg))
hpg_data$hpg[hpg_data$hpg=="NONE"] <- "X"
hpg_network <- get_network(hpg_data)
## Connect the First Circuit
#we grab the nearest system not connected to the terra network and then identify
#its whole network. We then take the two closest planets from each network and
#try to find a set of candidates that are within 50LY of each and select the
#best one by tech and population. If we can't connect the two with one
#intermediate, then we select from candidates that get the isolated network
#closer to the Terra network. We then reconstruct the network and do this all
#over again, until we have no more isolates. All of this is only done for IS
#systems.
while(sum(hpg_network$first$connect_terra==FALSE)>0) {
#get the isolated network of the first unconnected planet
isolate <- which(!hpg_network$first$connect_terra)[1]
temp <- get_all_connected_nodes(hpg_network$network, isolate)
if(!is.na(temp[1])) {
isolate <- c(isolate, temp)
}
isolated_network <- hpg_network$first[isolate, c("id","x","y")]
terra_network <- hpg_network$first[hpg_network$first$connect_terra,
c("id","x","y")]
closest_points <- find_closest_points(terra_network, isolated_network)
candidates <- find_all_overlaps(closest_points)
#if we have candidates, then pick one (for now randomly)
if(nrow(candidates)>0) {
#choose highest tech and use population as tiebreaker
nominee <- candidates[order(candidates$tech, candidates$pop,
decreasing = TRUE),"id"][1]
} else {
candidates <- find_closer_planets(closest_points)
if(nrow(candidates)>0) {
#generally we want to choose higher tech, but first set up a
#tier of 20 or more from ego system so that they are not piled up to close
candidates$far_enough <- candidates$distance_iso>=20
nominee <- candidates[order(candidates$far_enough, candidates$tech,
candidates$pop, decreasing = TRUE),"id"][1]
} else {
#If we can't find anyway to connect this, then the closest point
#should not be on the First Circuit
hpg_data$hpg[hpg_data$id==closest_points$iso$id[1]] <- "B"
hpg_network <- get_network(hpg_data)
next
}
}
#you have been promoted!
hpg_data$hpg[hpg_data$id==nominee] <- "A"
hpg_network <- get_network(hpg_data)
}
cat("done\n")
#once this is done then we can loop through hpg_data and use it to
#project HPG events for each system and then add to event_table
cat("\nAdding HPG information to event data\n")
hpg_data$id <- as.character(hpg_data$id)
for(i in 1:nrow(hpg_data)) {
hpg <- hpg_data[i,]
cat("\t")
cat(hpg$id)
cat("....")
#retrieve events for this system and planet - assume primary
#planet has the HPG
primary <- as.numeric(xml_text(xml_find_first(get_system_id(systems, hpg$id),
"primarySlot")))
#project the HPG information
hpg_history <- project_hpg(hpg$hpg, sqrt(hpg$x^2+hpg$y^2),
hpg$founding_year,
as.character(hpg$faction_type),
hpg$abandon_year)
hpg_history$day <- "01"
hpg_history$month <- "01"
#if 3132 and X assume Gray Monday August 7
hpg_history$day[hpg_history$year==3132 & hpg_history$hpg=="X"] <- "07"
hpg_history$month[hpg_history$year==3132 & hpg_history$hpg=="X"] <- "08"
#add to event_table
event_table <- event_table %>%
bind_rows(tibble(id=as.character(hpg$id),
sys_pos=primary,
date=paste(hpg_history$year, hpg_history$month, hpg_history$day, sep="-"),
etype="hpg",
event=paste(hpg_history$hpg),
canon=hpg$canon))
cat("done\n")
}
#### Handle Recolonization Cases ####
cat("\nHandling Recolonization Efforts\n")
#I am getting 56 cases of recolonization and one of those cases is a double recolonization
recol_ids <- names(recolonization)
for(recol_id in recol_ids) {
cat(recol_id)
recol_attempts <- recolonization[[recol_id]]
planet <- recolonized_planets[[recol_id]]
#for now just do the first one - figure out the one case of double recolonization later
for(i in 1:length(recol_attempts)) {
faction_table <- recol_attempts[[i]]
#some of these (e.g. Afleir) are just showing an abandoned event which makes no sense unless ABN was
#in this case we have an abandoned date of 2860 and then one immediately after for 2864.
#added twice
#check for singular abandoned factions from bad data
if(nrow(faction_table==1) && faction_table$event[1]=="ABN") {
next
}
#get faction
temp <- get_closest_event(subset(faction_table, event!="ABN"),
target_date, allow_later = TRUE)
#take the first faction in cases of multiple factions
if(!is.na(temp)) {
faction <- strsplit(temp,",")[[1]][1]
}
faction_type <- get_faction_type(faction)
founding_year <- get_year(faction_table$date[1])
abandon_year <- NA
if("ABN" %in% faction_table$event) {
abandon_year <- get_year(subset(faction_table, event=="ABN")$date)
}
#read in canon population data
if(id %in% rownames(canon_populations)) {
canon_population <- canon_populations[id,]
} else {
canon_population <- NULL
}
#deal with potential founding year heaping, but be careful
#not to go back before previous abandonment date
founding_corrected <- fix_founding_heaping(founding_year, planet$distance_terra)
if(founding_corrected != founding_year) {
if(!is.na(planet$previous_abandon_year) && founding_corrected<=planet$previous_abandon_year) {
#add around 50 years (on average) to the abandon date and take the minimum of this value and
#the original founding year
founding_year <- min(planet$previous_abandon_year+ceiling(rexp(1,1/50)), founding_year)
} else {
founding_year <- founding_corrected
}
}
#now address abandon year heaping
abandon_year <- fix_abandoned_heaping(abandon_year, founding_year)
## Creat the colony
#faction history
if(!is.null(faction_table)) {
#fix founding year in case changed due to heaping
faction_table$date[1] <- paste(founding_year,"01","01",sep="-")