/* COPYRIGHT ALAN M. SHERKOW, 1998-2002 */ /* This program is free software; you can redistribute it and/or modify*/ /* it under the terms of the GNU General Public License as published by*/ /* the Free Software Foundation; either version 2 of the License, or */ /* (at your option) any later version. */ /* */ /* This program is distributed in the hope that it will be useful, */ /* but WITHOUT ANY WARRANTY; without even the implied warranty of */ /* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ /* GNU General Public License for more details. */ /* */ /* You can download the GNU GPL From */ /* http://www.gnu.org/licenses/gpl.txt */ /* */ /* You should have received a copy of the GNU General Public License */ /* along with this program; if not, write to the */ /* Free Software Foundation, Inc. */ /* 59 Temple Place, Suite 330 */ /* Boston, MA 02111-1307 USA */ *----------------------------------------------------------------------; *--AL SHERKOW ; *--4942 N. HOLLYWOOD AVENUE ; *--WHITEFISH BAY, WI 53217-5935 ; *--VOICE: (414) 332-3062 FAX: (414) 332-8771 ; *--EMAIL: AL@SHERKOW.COM ; *----------------------------------------------------------------------; *--PROGRAM NAME : CBGenrt.SAS ; *--COMPONENT OF : General Use Color Band Generator for Sharing ; *--AUTHOR : ALAN M. SHERKOW ; *--PURPOSE : Generate Color Band Sequences ; *-- We purchased color bands from Avinet. Some were one solid color, ; *-- others had two colors(striped). We decided we wanted at most 3 ; *-- colors on a leg. That is each leg could have two bands: ; *-- two solid bands ; *-- one silver band and one solid band ; *-- one silver band and one striped band ; *-- one solid band and one striped band ; *-- note also that the striped band can have both colors towards the ; *-- foot. That is Yellow/Orange, used below can be put on as Y/O or as; *-- O/Y ; *----------------------------------------------------------------------; *-- To use this program you need to do the following: ; *-- 1. Update the SAS format with the colors you want to use. ; *-- 2. Update the macro variables directly above the format to ; *-- indicate the number of solid colors and striped colors ; *-- 3. Update the macro variable "twolegs" to indicate if you want ; *-- color bands on both legs. Otherwise Color bands will only be ; *-- developed for one leg (the silver could be in the pattern or ; *-- on the other leg ; *-- 4. To merge in your own data, you need to update the section ; *-- of the program that begins with DATA MYDATA ; *----------------------------------------------------------------------; *-- Please contact us if you find any errors ; *----------------------------------------------------------------------; *-- tested with SAS 8.02, TS Level 02M0 on Windows 98 ; *-- (this is expected to work on all recent levels of SAS and all ; *-- platforms) ; *----------------------------------------------------------------------; *--HISTORY: ; *-- ORIGINAL: ddmmm1997 ALAN M. SHERKOW ; *--22Jan98: removed R/Y and Y/R as generated patterns, ; *-- we do not have any more bands ; *--22Jan98: added DPK/B ; *--09Feb98: Changed report order by adding special sortkey ; *--18Feb98: Removed y/o and o/y, out of those badns ; *-- added Y/G and PU/G as new patters ; *--11Mar98: Added code to not generate PU/W patterns ; *-- Also no 'dpk/r' which are hard to see ; *-- change G/Y to 'LG/Y' and 'g'pu' to 'LG/PU' ; *--02Jun98: Upgrade for EzBand Data ; *--16Jun98: Change Variable Names to Merge with Old ; *-- Analysis Program ; *--14Oct99: Added support for colors on both legs ; *-- REVISION: 13Mar2002 Alan M. Sherkow ; *-- Generalized version to share via BirdBand ; *-- REVISION: ddmmm20?? Alan M. Sherkow ; *-- WHAT. ; *-- ; *----------------------------------------------------------------------; options nocenter symbolgen; %let twolegs=Y; *--color bands on one or two legs?; *--define the 'colors' you need to use; *--first number the solid colors; *--the silver band should always be #1; %let silver=1; *--set macro variable to highest numbered solid band; %let solid_hi=9; *--set macro variable to highest numbered striped band; %let stripe_hi=16; proc format; value cb 1='S' 2='Y' 3='LG' 4='LB' 5='O' 6='PK' 7='R' 8='B' 9='MV' 10='PU/W' 11='B/DPK' 12='DPK/B' 13='Y/O' 14='O/Y' 15='LG/PU' 16='LG/Y' OTHER=" "; RUN; DATA pass1; KEEP BAND1 BAND2 ; FORMAT BAND1 BAND2 I J CB.; *--chng numbers to letters for printing; *--first loop through with solid towards the foot; DO I=1 TO &solid_hi; BAND1=I; BAND2=.; IF I NE &silver THEN DO; *--NOT SILVER ALONE!; PUT BAND1; *--print to the SAS Log; OUTPUT; *--output each color to dataset; END; DO J=1 TO &stripe_hi; IF I NE J THEN DO; BAND2=J; OUTPUT; *--output each pair; PUT I J; END; END; *--loop through all colors and stripes; END; *--loop through the solids; DO I=%eval(&solid_hi+1) TO &stripe_hi; BAND1=I; BAND2=.; IF I NE &silver THEN DO; *--NOT SILVER ALONE!; PUT BAND1; *--print to the SAS Log; OUTPUT; *--output each color to dataset; END; *--since these are striped only put solids above them; DO J=1 TO &solid_hi; IF I NE J THEN DO; BAND2=J; OUTPUT; *--output each pair; PUT I J; END; END; *--loop through solids only; END; *--loop through the solids; RUN; *--make sure that two of the same color are not together; *--the rows being dropped are written to the log; DATA genned; SET pass1; LENGTH pattern $12; pattern=PUT(BAND1,CB.); IF BAND2 NE . THEN pattern=PUT(BAND1,CB.)||"/"||PUT(BAND2,CB.); pattern=COMPRESS(pattern); length s1 s2 s3 $12; s1=scan(pattern,1,"/"); s2=scan(pattern,2,"/"); s3=scan(pattern,3,"/"); if s2 ne " " then do; if s1=s2 then do; put "Deleting Duplicate: " pattern= s1= s2=; delete; end; if s3 ne " " then do; if s2=s3 then do; put "Deleting Duplicate: " pattern= s2= s3=; delete; end; end; end; if s1 ne " " then do; if s1=s3 then do; put "Deleting Duplicate: " pattern= s1= s3=; delete; end; end; run; proc sort data=genned; by pattern; run; %macro badcombo(pattern); x=index(&pattern,"/PK/O"); *--note the first "/", this finds these ; *--colors in the &pattern ; *--the 'if' statement below also checks the ; *--the beginning of the color &pattern ; if (x ne 0) or (substr(&pattern,1,4)="PK/O") then do; put "bad &pattern>> " _all_ ; delete; end; x=index(&pattern,"/DPK/R"); if (x ne 0) or (substr(&pattern,1,5)="DPK/R") then do; put "bad &pattern>> " _all_ ; delete; end; x=index(&pattern,"/LB/B"); if (x ne 0) or (substr(&pattern,1,5)="LB/B") then do; put "bad &pattern>> " _all_ ; delete; end; x=index(&pattern,"/B/LB"); if (x ne 0) or (substr(&pattern,1,5)="B/LB") then do; put "bad &pattern>> " _all_ ; delete; end; %mend badcombo; %macro notavail(pattern); *--check here to delete patterns we no longer have such as y/r, r/y; *--if we are out of some striped bands, remove them here; x=index(pattern,"PU/W"); if (x ne 0) or (substr(pattern,1,4)="PU/W") then do; put "no more bands >> " pattern= ; delete; end; x=index(pattern,"W/PU"); if (x ne 0) or (substr(pattern,1,4)="W/PU") then do; put "no more bands >> " pattern= ; delete; end; %mend notavail; *--now delete patterns that do not show up well; data oneleg; set genned; by pattern; if not (first.pattern and last.pattern) then put "not only pattern>> " _all_; keep pattern; %badcombo(pattern); %notavail(pattern); run; %macro bothlegs; %IF %upcase(&twolegs.) eq %upcase(Y) %THEN %DO; DATA xgenned; SET oneleg(rename=(pattern=leg1)); FORMAT BAND1 BAND2 I J CB.; *--chng numbers to letters for printing; retain banddleg 0; *--which leg is banded??; *--find the colors in the first leg; length leg1clr1 leg1clr2 leg1clr3 $12; banddleg=2; *--default to band being on leg 2; leg1clr1=scan(leg1,1,"/"); if leg1clr1="S" then banddleg=1; leg1clr2=scan(leg1,2,"/"); if leg1clr2="S" then banddleg=1; leg1clr3=scan(leg1,3,"/"); if leg1clr3="S" then banddleg=1; *--generate for the other leg, use one or two bands; *--do not use any of the existing colors; if banddleg=2 then do; *--special case, add one band; do J=1 TO &stripe_hi; IF I NE &silver THEN DO; *-do not put on two silvers; if ((put(j,cb.) ne leg1clr1) and (put(j,cb.) ne leg1clr2) and (put(j,cb.) ne leg1clr3)) then do; *--this color is not on the bird; band1=&silver; band2=j; output; put _n_= leg1= band1= band2=; *--now switch the order ; band1=j; band2=&silver; output; put _n_= leg1= band1= band2=; end; *--check for dupl colors; END; *--if not silver; END; *--loop through all colors and stripes; *--done with this bird, do not continue; return; *--in this sas data step ; end; *--if bandleg=2 ....; *--first loop through with solid towards the foot; DO I=1 TO &solid_hi; if ((put(I,cb.) ne leg1clr1) and (put(I,cb.) ne leg1clr2) and (put(I,cb.) ne leg1clr3)) then do; *--color is not on leg 1; BAND1=I; BAND2=.; IF I NE &silver THEN DO; *--NOT SILVER ALONE!; PUT BAND1; *--print to the SAS Log; put _n_= leg1= band1= band2=; OUTPUT; *--output each color to dataset; END; DO J=1 TO &stripe_hi; if ((put(j,cb.) ne leg1clr1) and (put(j,cb.) ne leg1clr2) and (put(j,cb.) ne leg1clr3)) then do; *--this color is not on the bird; IF I NE J THEN DO; BAND2=J; OUTPUT; *--output each pair; put _n_= leg1= band1= band2=; END; ENd; *--color is not on leg1; END; *--loop through all colors and stripes; END; *--color is not on leg1; END; *--loop through the solids; run; *--make sure that two of the same color are not together; *--the rows being dropped are written to the log; DATA leg2; SET xgenned; keep banddleg leg1 leg2; LENGTH leg2 $12; leg2=PUT(BAND1,CB.); IF BAND2 NE . THEN leg2=PUT(BAND1,CB.)||"/"||PUT(BAND2,CB.); leg2=COMPRESS(leg2); *--check for bad color combinations; %badcombo(leg2); *--make sure we have all the colors for this leg; %notavail(leg2); length leg2clr1 leg2clr2 leg2clr3 $12; array leg1clr (ii) leg1clr1-leg1clr3; array leg2clr (jj) leg2clr1-leg2clr3; leg2clr1=scan(leg2,1,"/"); leg2clr2=scan(leg2,2,"/"); leg2clr3=scan(leg2,3,"/"); *--make sure there are no duplicate colors on leg2; if leg2clr2 ne " " then do; if leg2clr1=leg2clr2 then do; put "Deleting Duplicate: " pattern= leg2clr1= leg2clr2=; delete; end; if leg2clr3 ne " " then do; if leg2clr2=leg2clr3 then do; put "Deleting Duplicate: " pattern= leg2clr2= leg2clr3=; delete; end; end; end; if leg2clr1 ne " " then do; if leg2clr1=leg2clr3 then do; put "Deleting Duplicate: " pattern= leg2clr1= leg2clr3=; delete; end; end; *--make sure there are no duplicate colors on bird; do ii=1 to 3; if (leg1clr ne " ") then do jj=1 to 3; if leg1clr=leg2clr then do; put _n_= "duplicate color " leg1= leg2= banddleg=; delete; end; end; end; *--do i; run; proc sort data=leg2 nodups; by banddleg leg1 leg2; run; proc print data=leg2; var banddleg leg1 leg2; title "Patterns for color bands on two legs"; title2 "Based on available color band combinations"; run; %END; %Else %do; proc sort data=oneleg nodups; by pattern; run; proc print data=oneleg; title "Patterns for color bands on one legs"; title2 "Based on available color band combinations"; run; %END; %mend bothlegs; %bothlegs; *--proc print data=oneleg; title2 "Generated Banding Patterns"; run; proc sort data=oneleg nodups; by pattern; run; data; set oneleg; by pattern; *--should only have one row per pattern as they are unique; *--messages from this dataset probably are a logic error; if not (first.pattern and last.pattern) then put _all_; run; *--if you have patterns you have already used you can merge those; *--with the generated patterns so you do not use them again ; *--I have included some sample data to demonstrate how this works; data mydata; length pattern $12; format dband date9.; informat dband date9.; input @1 prefix $4. @6 serial $5. @13 dband date9. @23 pattern; cards; 1860 34949 18MAY1996 S/Y 2140 77508 14JAN1998 W/PU/S 2140 77523 21JAN1998 Y/R/LG 2140 77527 21JAN1998 Y/R/LB 2140 77528 21JAN1998 Y/O/LG 2140 77538 04FEB1998 B/DPK 2140 77541 10FEB1998 Y/O/PK 2140 77544 10FEB1998 S/R 2140 77548 18FEB1998 S/LG 2140 77551 04MAR1998 B/DPK/LG 2140 77552 04MAR1998 B/DPK/PK 2140 77553 11MAR1998 PU/W/O 2140 77554 11MAR1998 B/DPK/Y 2140 77556 25MAR1998 DPK/B/LB 2140 77561 08APR1998 LG/Y/PK 2140 77577 13MAY1998 LG/Y/R 2140 77601 04MAR1998 LG/Y 2140 77607 27MAY1998 LG/Y/O 2140 77612 10JUN1998 LG/Y/LB 2140 77615 17JUN1998 LG/Y/LG 2140 77622 01JUL1998 Y/LG/R 2140 77625 15JUL1998 Y/LG/O 2140 77630 29JUL1998 LG/PU/Y 2390 87301 02APR1997 R/Y/LB 2390 87304 02APR1997 LG/PU/LG 2390 87309 02APR1997 DPK/B 2390 87310 02APR1997 LB 2390 87311 02APR1997 LG/O 2390 87313 02APR1997 PU/W/LG 2390 87318 02APR1997 R/Y/PK 2390 87320 02APR1997 R/LG 2390 87321 02APR1997 PU/W 2390 87323 02APR1997 O/LG/S 2390 87327 02APR1997 Y/B/DPK 2390 87328 02APR1997 R/Y 2390 87329 30APR1997 O/LG 2390 87331 30APR1997 B/DPK/LB 2390 87332 30APR1997 R/LB ; run; *--generate band numbers, also keep the most recent date; *--for use in report titles ; data onbird(label="these patterns are on birds"); set mydata end=dend; keep pattern onbird dband ; onbird=prefix||"-"||serial; retain mxdt 0; format dband mxdt date9.; mxdt=max(dband ,mxdt); *--keep the maximum date of color band; if dend then do; *--no more data, write to log and store in ; *--macro variable for titles ; put "end of data, oldest date is: " mxdt; call symput("mxdt",put(mxdt,date9.)); end; run; proc sort data=onbird; by pattern; run; *--sort for merging; data m(label="onbirds and new patterns"); length pattern $16; merge onbird oneleg; by pattern; *--should only have one row per pattern; *--messages from this dataset probably are a logic error; if not (first.pattern and last.pattern) then put _all_; run; data SrtKey; set m; if dband =. then sortkey=1; else sortkey=2; proc sort nodups data=SrtKey; by sortkey pattern onbird dband ; run; proc print data=SrtKey; var pattern onbird dband; title "Color Band Patterns (including bandings through &mxdt)"; run;