I am working with the R programming language.
In the "datasets" library in R, there is a data set called "eurodist" that contains the distance between each combination of cities :
library(datasets)
This data set can be then converted into a "matrix":
eurodist = as.matrix(eurodist)
Athens Barcelona Brussels Calais Cherbourg Cologne Copenhagen Geneva Gibraltar Hamburg Hook of Holland Lisbon Lyons Madrid Marseilles Milan Munich Paris Rome Stockholm Vienna
Athens 0 3313 2963 3175 3339 2762 3276 2610 4485 2977 3030 4532 2753 3949 2865 2282 2179 3000 817 3927 1991
Barcelona 3313 0 1318 1326 1294 1498 2218 803 1172 2018 1490 1305 645 636 521 1014 1365 1033 1460 2868 1802
Brussels 2963 1318 0 204 583 206 966 677 2256 597 172 2084 690 1558 1011 925 747 285 1511 1616 1175
Calais 3175 1326 204 0 460 409 1136 747 2224 714 330 2052 739 1550 1059 1077 977 280 1662 1786 1381
Cherbourg 3339 1294 583 460 0 785 1545 853 2047 1115 731 1827 789 1347 1101 1209 1160 340 1794 2196 1588
Cologne 2762 1498 206 409 785 0 760 1662 2436 460 269 2290 714 1764 1035 911 583 465 1497 1403 937
Copenhagen 3276 2218 966 1136 1545 760 0 1418 3196 460 269 2971 1458 2498 1778 1537 1104 1176 2050 650 1455
Geneva 2610 803 677 747 853 1662 1418 0 1975 1118 895 1936 158 1439 425 328 591 513 995 2068 1019
Gibraltar 4485 1172 2256 2224 2047 2436 3196 1975 0 2897 2428 676 1817 698 1693 2185 2565 1971 2631 3886 2974
Hamburg 2977 2018 597 714 1115 460 460 1118 2897 0 550 2671 1159 2198 1479 1238 805 877 1751 949 1155
Hook of Holland 3030 1490 172 330 731 269 269 895 2428 550 0 2280 863 1730 1183 1098 851 457 1683 1500 1205
Lisbon 4532 1305 2084 2052 1827 2290 2971 1936 676 2671 2280 0 1178 668 1762 2250 2507 1799 2700 3231 2937
Lyons 2753 645 690 739 789 714 1458 158 1817 1159 863 1178 0 1281 320 328 724 471 1048 2108 1157
Madrid 3949 636 1558 1550 1347 1764 2498 1439 698 2198 1730 668 1281 0 1157 1724 2010 1273 2097 3188 2409
Marseilles 2865 521 1011 1059 1101 1035 1778 425 1693 1479 1183 1762 320 1157 0 618 1109 792 1011 2428 1363
Milan 2282 1014 925 1077 1209 911 1537 328 2185 1238 1098 2250 328 1724 618 0 331 856 586 2187 898
Munich 2179 1365 747 977 1160 583 1104 591 2565 805 851 2507 724 2010 1109 331 0 821 946 1754 428
Paris 3000 1033 285 280 340 465 1176 513 1971 877 457 1799 471 1273 792 856 821 0 1476 1827 1249
Rome 817 1460 1511 1662 1794 1497 2050 995 2631 1751 1683 2700 1048 2097 1011 586 946 1476 0 2707 1209
Stockholm 3927 2868 1616 1786 2196 1403 650 2068 3886 949 1500 3231 2108 3188 2428 2187 1754 1827 2707 0 2105
Vienna 1991 1802 1175 1381 1588 937 1455 1019 2974 1155 1205 2937 1157 2409 1363 898 428 1249 1209 2105 0
My Question: Suppose I have 6 cities and the Longitude/Latitude for each of these cities :
data_1 = data.frame(id = c(1,2,3), long = rnorm(3, -74, 1 ), lat = rnorm(3, 40, 1 ))
data_2 = data.frame(id = c(4,5,6), long = rnorm(3, -78, 1 ), lat = rnorm(3, 42, 1 ))
final_data = rbind(data_1, data_2)
final_data$names <- c("city_1", "city_2", "city_3", "city_4", "city_5", "city_6")
id long lat names
1 1 -75.28447 40.21079 city_1
2 2 -73.29385 40.09104 city_2
3 3 -75.12737 38.88355 city_3
4 4 -79.42325 42.61917 city_4
5 5 -77.82508 41.11707 city_5
6 6 -77.62831 39.94935 city_6
I can also make a similar matrix for these cities that contains the distance between each pair of cities:
library(geosphere)
N <- nrow(final_data)
dists <- outer(seq_len(N), seq_len(N), function(a,b) {
geosphere::distHaversine(final_data[a,2:3], final_data[b,2:3]) # Notes 1, 2
})
D <- as.matrix(dists)
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0.0 169895.7 148361.1 437239.3 237056.7 201742.0
[2,] 169895.7 0.0 207068.8 584183.9 399577.9 369814.4
[3,] 148361.1 207068.8 0.0 551356.0 338698.3 245620.3
[4,] 437239.3 584183.9 551356.0 0.0 213326.6 332955.7
[5,] 237056.7 399577.9 338698.3 213326.6 0.0 131051.7
[6,] 201742.0 369814.4 245620.3 332955.7 131051.7 0.0
How can I make my matrix look the same way as the "eurodist" matrix?
I had thought of the following way to do this:
colnames(dists) <- c("city_1", "city_2", "city_3", "city_4", "city_5", "city_6")
rownames(dists) <- c("city_1", "city_2", "city_3", "city_4", "city_5", "city_6")
city_1 city_2 city_3 city_4 city_5 city_6
city_1 0.0 169895.7 148361.1 437239.3 237056.7 201742.0
city_2 169895.7 0.0 207068.8 584183.9 399577.9 369814.4
city_3 148361.1 207068.8 0.0 551356.0 338698.3 245620.3
city_4 437239.3 584183.9 551356.0 0.0 213326.6 332955.7
city_5 237056.7 399577.9 338698.3 213326.6 0.0 131051.7
city_6 201742.0 369814.4 245620.3 332955.7 131051.7 0.0
In the end, I would like to use the above matrix as input for a customized Travelling Salesman Problem (R: Customizing the Travelling Salesman Problem) - e.g. Try to find the optimal path when you are forced to start at "city 4" and the third city should be "city 5":
D <- dists
transformMatrix <- function(fixed_points, D){
if(length(fixed_points) == 0) return(D)
p <- integer(nrow(D))
pos <- match(names(fixed_points), colnames(D))
p[fixed_points] <- pos
p[-fixed_points] <- sample(setdiff(seq_len(nrow(D)), pos))
D[p, p]
}
fixed_points <- c(
"city_4" = 1, "city_5" = 3
)
D_perm <- transformMatrix(fixed_points, D)
feasiblePopulation <- function(n, size, fixed_points){
positions <- setdiff(seq_len(n), fixed_points)
m <- matrix(0, size, n)
if(length(fixed_points) > 0){
m[, fixed_points] <- rep(fixed_points, each = size)
for(i in seq_len(size))
m[i, -fixed_points] <- sample(positions)
} else {
for(i in seq_len(size))
m[i,] <- sample(positions)
}
m
}
mutation <- function(n, fixed_points){
positions <- setdiff(seq_len(n), fixed_points)
function(obj, parent){
vec <- obj#population[parent,]
if(length(positions) < 2) return(vec)
indices <- sample(positions, 2)
replace(vec, indices, vec[rev(indices)])
}
}
fitness <- function(tour, distMatrix) {
tour <- c(tour, tour[1])
route <- embed(tour, 2)[,2:1]
1/sum(distMatrix[route])
}
popSize = 500
res <- ga(
type = "permutation",
fitness = fitness,
distMatrix = D_perm,
lower = 1,
upper = nrow(D_perm),
mutation = mutation(nrow(D_perm), fixed_points),
crossover = gaperm_pmxCrossover,
suggestions = feasiblePopulation(nrow(D_perm), popSize, fixed_points),
popSize = popSize,
maxiter = 5000,
run = 500,
pmutation = 0.2
)
colnames(D_perm)[res#solution[1,]]
This results in the following error:
Error in if (object#run >= run) break :
missing value where TRUE/FALSE needed
In addition: Warning messages:
1: In max(fitness) : no non-missing arguments to max; returning -Inf
2: In max(Fitness, na.rm = TRUE) :
no non-missing arguments to max; returning -Inf
3: In max(fitness) : no non-missing arguments to max; returning -Inf
4: In max(x, na.rm = TRUE) :
no non-missing arguments to max; returning -Inf
Is the above error because I have not made "distance matrix" (i.e. "D") properly? Is there a different way to name the columns and rows of a matrix in R?
Thanks!
Note : If anyone knows another way to solve this constraint Travelling Salesman Problem with custom cities using the Genetic Algorithm in R (e.g. different objective function, different way to specify constraints, etc.), please let me know. I am open to different ways to solving this problem!
That’s not the problem. The error says the it encountered code:
if (object#run >= run) break
… and either object#run or run had length 0 which the if function cannot handle gracefully. It may be an error in the ga function itself or in the arguments to it.
To address the direct question about how to make the distance matrix look like the example in eurodist: There is a dimnames attribute for matrices. You need to assign a list with a rownames and a colnames value in it and assign that list to the dimnames attribute.
dimnames(D) <- list(rownames=final_data$names,
colnames=final_data$names)
Then when you run your code you get an error from the ga(...) call:
Error in gaperm_pmxCrossover_Rcpp(object, parents) : index error
Looking at the problem setup, your population size appears much larger than needed. If you drop it down a bit to say 100 or 200, then the results begin to be computed.
popSize=200;
# now calculate a res
colnames(D_perm)[res#solution[1,]]
#[1] "city_4" "city_6" "city_5" "city_1" "city_3" "city_2"
popSize=100
colnames(D_perm)[res#solution[1,]]
#[1] "city_4" "city_6" "city_5" "city_1" "city_3" "city_2"
popSiz=20
colnames(D_perm)[res#solution[1,]]
#[1] "city_4" "city_6" "city_5" "city_1" "city_3" "city_2"
It doesn't seem "proper" that a population size larger than needed should cause an obscure error, so you might contact the package maintainer with your example (now that it has been "dressed up" properly.)
Related
I am trying to convert a time series into a hierarchical one using the hts package and my structure is as follows:
My data is already stored as a ts object in R with a weekly frequency and all columns are labeled:
Then I try to make the hts object but I get this error message, probably because I do not fully understand how to split the columns in the argument "characters".
x <- hts(abc, c(1,1,2,2))
Since argument characters are not specified, the default labelling system is used.
Error: Argument nodes must be a list.
Thanks in advance
First you need to use the argument characters. It is not the second argument of hts(). Second, you need to specify characters according to the names of your columns. In this case, the first character is the first level of disaggregation (A, B, C, D, E), while the next two characters specify the next level of disaggregation. So your argument should be characters = c(1,2).
Here is an example with synthetic data, but with the same structure as yours.
library(hts)
abc <- matrix(sample(1:100, 32*140, replace=TRUE), ncol=32)
colnames(abc) <- c(
paste0("A0",1:5),
paste0("B0",1:9),"B10",
paste0("C0",1:8),
paste0("D0",1:5),
paste0("E0",1:4)
)
abc <- ts(abc, start=2019, frequency=365.25/7)
x <- hts(abc, characters = c(1,2))
x
#> Hierarchical Time Series
#> 3 Levels
#> Number of nodes at each level: 1 5 32
#> Total number of series: 38
#> Number of observations per series: 140
#> Top level series:
#> Time Series:
#> Start = 2019
#> End = 2021.66392881588
#> Frequency = 52.1785714285714
#> [1] 1735 1645 1472 1638 1594 1722 1525 1761 1500 1746 1331 1567 1853 1652 1587
#> [16] 1540 1453 1989 1629 1587 1596 1474 1320 1599 1762 1419 1931 1447 2102 1608
#> [31] 1439 1909 1331 1742 1428 1677 1534 1657 1741 1612 1574 1954 1542 2067 1512
#> [46] 1850 1650 1666 1321 1332 1924 1786 1496 1695 1363 1437 1740 1448 1260 1371
#> [61] 1661 1726 1786 1641 1463 1616 1641 1895 1503 1430 1972 1705 1722 1447 1515
#> [76] 1636 1544 1727 1960 1647 1682 1569 1616 1628 1706 1837 1738 1659 1574 1716
#> [91] 1409 1428 1411 1708 1606 1501 1413 1707 1552 1567 1693 1748 2034 1557 1402
#> [106] 1649 1637 1653 1857 1401 1519 1600 1844 1585 1796 1612 1456 1626 1390 1368
#> [121] 1492 1765 1644 1773 1302 2027 1810 1652 1819 1628 1574 1655 1650 1817 1605
#> [136] 1422 1793 1999 1489 1667
Created on 2021-10-18 by the reprex package (v2.0.1)
A large number can be comma formatted to read more easily into groups of three. E.g. 1050 = 1,050 and 10200 = 10,200.
The sum of each of these groups of three would be:
1050=1,050 gives: 1+50=51
10200=10,200 gives: 10+200=210
I need to search for matches in the sum of the groups of threes.
Namely, if I am searching for 1234, then I am looking for numbers whose sum of threes = 1234.
The smallest match is 235,999 since 235+999=1234. No other integer less than 235,999 gives a sum of threes equal to 1234.
The next smallest match is 236,998 since 236+998=1234.
One can add 999 each time, but this fails after reaching 999 since an extra digit of 1 is added to the number due to overflow in the 999.
More generally, I am asking for the solutions (smallest to highest) to:
a+b+c+d… = x
where a,b,c,d… is an arbitrary number of integers between 0-999 and x
is a fixed integer
Note there are infinite solutions to this for any positive integer x.
How would one get the solutions to this beginning with the smallest number solutions (for y number of solutions where y can be an arbitrarily large number)?
Is there a way to do this without brute force looping one by one? I'm dealing with potentially very large numbers, which could take years to loop through in a straight loop. Ideally, one should do this without failed attempts.
The problem is easier to think about if instead of groups of 3 digits, you just consider 1 digit at a time.
An algorithm:
Start by filling the 0 digit group with x.
Create a loop that each time prints the next solution.
"Normalize" the groups by moving all that is too large from the right to the left, leaving only the maximum value at the right.
Output the solution
Repeat:
Add 1 to the penultimate group
This can carry to the left if a group gets too large (e.g.999+1 is too large)
Check whether the result didn't get too large (a[0] should be able to absorb what was added)
If the result got too large, set the group to zero and continue incrementing the earlier groups
Calculate the last group to absorb the surplus (can be positive or negative)
Some Python code for illustration:
x = 1234
grouping = 3
max_iterations = 200
max_in_group = 10**grouping - 1
a = [x]
while max_iterations > 0:
#step 1: while a[0] is too large: redistribute to the left
i = 0
while a[i] > max_in_group:
if i == len(a) - 1:
a.append(0)
a[i + 1] += a[i] - max_in_group
a[i] = max_in_group
i += 1
num = sum(10**(grouping*i) * a[i] for i, n in enumerate(a))
print(f"{num} {num:,}")
# print("".join([str(t) for t in a[::-1]]), ",".join([str(t) for t in a[::-1]]))
# step 2: add one to the penultimate group, while group already full: set to 0 and increment the
# group left of it;
# while the surplus is too large (because a[0] is too small) repeat the incrementing
i0 = 1
surplus = 0
while True: # needs to be executed at least once, and repeated if the surplus became too large
i = i0
while True: # increment a[i] by 1, which can carry to the left
if i == len(a):
a.append(1)
surplus += 1
break
else:
if a[i] == max_in_group:
a[i] = 0
surplus -= max_in_group
i += 1
else:
a[i] += 1
surplus += 1
break
if a[0] >= surplus:
break
else:
surplus -= a[i0]
a[i0] = 0
i0 += 1
#step 3: a[0] should absorb the surplus created in step 1, although a[0] can get out of bounds
a[0] -= surplus
surplus = 0
max_iterations -= 1
Abbreviated output:
235,999 236,998 ... 998,236 999,235 ... 1,234,999 1,235,998 ... 1,998,235 1,999,234 2,233,999 2,234,998 ...
Output for grouping=3 and x=3456:
459,999,999,999 460,998,999,999 460,999,998,999 460,999,999,998 461,997,999,999
461,998,998,999 461,998,999,998 461,999,997,999 461,999,998,998 461,999,999,997
462,996,999,999 ...
Output for grouping=1 and x=16:
79 88 97 169 178 187 196 259 268 277 286 295 349 358 367 376 385 394 439 448 457 466
475 484 493 529 538 547 556 565 574 583 592 619 628 637 646 655 664 673 682 691 709
718 727 736 745 754 763 772 781 790 808 817 826 835 844 853 862 871 880 907 916 925
934 943 952 961 970 1069 1078 1087 1096 1159 1168 1177 1186 1195 1249 1258 1267 1276
1285 1294 1339 1348 1357 1366 1375 1384 1393 1429 1438 1447 1456 1465 1474 1483 1492
1519 1528 1537 1546 1555 1564 1573 1582 1591 1609 1618 1627 1636 1645 1654 1663 1672
1681 1690 1708 1717 1726 1735 1744 1753 1762 1771 1780 1807 1816 1825 1834 1843 1852
1861 1870 1906 1915 1924 1933 1942 1951 1960 2059 2068 2077 2086 2095 2149 2158 2167
2176 2185 2194 2239 2248 2257 2266 2275 2284 2293 2329 2338 2347 2356 2365 2374 2383
2392 2419 2428 2437 2446 2455 2464 2473 2482 2491 2509 2518 2527 2536 2545 2554 2563
2572 2581 2590 2608 2617 2626 2635 2644 2653 2662 2671 2680 2707 2716 2725 2734 ...
I have a data, where SAS Proc shewhart is implemented, I want to implement the same in R program, below is the data and sas code
> valueid date dis_id sales_amount yymm (year month)
> 868 5-Mar-18 2 956 1803
868 6-Apr-17 2 473 1704
868 22-Dec-16 2 524 1612
914 17-Dec-15 2 1768 1512
914 18-Aug-16 2 477 1608
914 12-Jan-17 2 804 1701
870 1-May-17 2 1373 1705
870 8-Sep-17 2 323 1709
870 29-Feb-16 2 1718 1602
870 26-Jan-16 2 1242 1601
870 1-Apr-16 2 995 1604
800 22-Apr-16 2 356 1604
925 10-May-16 2 1487 1605
928 30-May-16 2 1210 1605
928 29-Jun-16 2 1935 1606
928 28-Nov-16 2 1149 1611
928 13-Dec-16 2 835 1612
987 10-Jul-17 2 1023 1707
987 27-Jul-17 2 389 1707
987 22-Sep-17 2 1191 1709
Below is the Program use to implement XSCHART
proc shewhart data=sales_revenue;
by valueid;
xschart sales_amount*yymm/ nochart outtable= newoutput;
id dis_id;
run;
I need to convert this shewhart with xschart into R. kindly help me.
I'd like to define a series of variables in a for loop. (create a array as dictionary. Convert tops to d1 as shown below)
Firstly, I assign values to them (d1~d11);
then I try to define the names of these variables.
How should I call specific variables in the names() function to make it work like "names(d1)<-..."
for (i = 1:11)
{
assign(paste("d",i,sep=""),tops[,2*i])
names(eval(parse(text=paste("d",i,sep=""))))<-tops[,2*i-1]
}
> tops[,c(1,2)]
V1 V2 V3 V4 V5 V6
1 shift 2136 shift 2211 shift 2324
2 bed 1463 k 1551 plant 1664
3 run 1338 bed 1527 run 1466
4 plant 1309 run 1504 k 1456
5 k 1294 hr 1484 bed 1390
6 hr 1285 clean 1464 hr 1366
7 check 1255 plant 1386 clean 1359
8 clean 1203 check 1261 s 1254
9 s 1052 s 1205 check 1048
10 unload 1024 start 1115 end 1028
11 chang 1023 fine 1113 fine 1020
12 fine 960 chang 1104 start 1006
13 end 924 end 1050 chang 977
14 start 905 stop 974 stop 950
15 pellet 878 pellet 915 pellet 897
16 work 866 work 907 remov 874
17 due 856 screen 900 sinter 862
18 stop 853 bwr 888 side 841
19 complet 772 side 888 due 809
20 remov 750 due 861 conveyor 792
21 requir 726 complet 841 work 777
22 sinter 711 sinter 834 north 771
23 south 710 conveyor 775 south 760
24 side 688 north 768 west 738
25 issu 682 remov 764 belt 737
26 t 675 ok 759 carri 735
27 belt 672 t 753 screen 727
28 carri 668 requir 750 stock 725
29 strand 649 unload 749 unload 719
30 conveyor 646 chute 747 chute 688
> d1
shift bed run plant k hr check clean s
2136 1463 1338 1309 1294 1285 1255 1203 1052
unload chang fine end start pellet work due stop
1024 1023 960 924 905 878 866 856 853
complet remov requir sinter south side issu t belt
772 750 726 711 710 688 682 675 672
carri strand conveyor
668 649 646
> length(d1)
[1] 30
I hope I make it clear. if not, please free to ask me
As David mentioned, don't assign 11 different variables; create a list with 11 elements. This will simplify your code considerably.
d <- lapply(1:11, function(i) tops[, 2 * i = 1])
Here is my input, question is below:
Targets <- read.csv("miR155Aicda.csv", row.names=1, sep="", header=T)
head(Targets)
T0h T0.25h T0.5h T1h T2h T3h T6h T12h T24h T48h C0h C0.25h C0.5h C1h C2h
Aicda 785 1150 707 513 1265 3268 8294 8625 7387 4397 677 911 673 737 1782
mmu-miR-155-3p 622 548 558 1213 1195 1172 1115 1883 3257 1900 499 562 584 543 580
Targets.m <- melt(Targets)
> head(Targets.m)
variable value
1 T0h 9.616549
2 T0h 9.280771
3 T0.25h 10.167418
4 T0.25h 9.098032
5 T0.5h 9.465566
6 T0.5h 9.124121
Question: How do I add Aicda and mmu-mIR-155-2p as a variable?
I want this:
ID variable value
1 Aicda T0h 9.616549
2 mmu-miR-155-3p T0h 9.280771
3 Aicda T0.25h 10.167418
4 mmu-miR-155-3p T0.25h 9.098032
5 Aicda T0.5h 9.465566
6 mmu-miR-155-3p T0.5h 9.124121
You need to put the rownames in a column and then specify an id variable for melt:
DF <- read.table(text=" T0h T0.25h T0.5h T1h T2h T3h T6h T12h T24h T48h C0h C0.25h C0.5h C1h C2h
Aicda 785 1150 707 513 1265 3268 8294 8625 7387 4397 677 911 673 737 1782
mmu-miR-155-3p 622 548 558 1213 1195 1172 1115 1883 3257 1900 499 562 584 543 580",header=TRUE)
DF$ID <- rownames(DF)
library(reshape2)
melt(DF,id="ID")