/* *************************************************************** */
/*  mwsug94.sas  - responds to a request from an HTML form and     */
/*   returns either a table of data or a PostScript map.           */
/*   This must be called from a script which sets appropriate      */
/*   environment variables and redirects std IO without buffering. */
/*                                                                 */
/*        Larry Hoyle, IPPBR, University of Kansas  May 1994       */
/*         revised 7-19-94  to fix problems with listing program   */
/* *************************************************************** */


%global maxlen;   /* maximum length of name or value string from httpd */
%let maxlen=200;

%global annofmt scalfac; /* parameters for a map */
%let annofmt=9.1;        /* format for data labels in the map */
%let scalfac=0.0014;     /* a scaling parameter for placing map objects */
%global sasvar;   /*  the name of the SAS variable to be displayed */
%global saslabl;  /*  the label of the variable to be displayed */
%global request;  /* the type of request eg. "map" or "table" */


/* *********************************************************** */
/*   read the environment variables into SAS macro variables.  */
/* *********************************************************** */

%global rqmeth; /* request method environment variable */
%let rqmeth=%sysget(REQUEST_METHOD);


%global cnttyp; /* content type   environment variable */
%let cnttyp=%sysget(CONTENT_TYPE);

%global cntlen; /* content length environment variable */
%let cntlen=%sysget(CONTENT_LENGTH);


libname cgibin '/homea/lhoyle/public_html/cgi-bin';

data _null_;
 put 'request method = ' "&rqmeth";
 put 'content type = ' "&cnttyp";
 put 'content length = ' "&cntlen";



/* *********************************************************** */
/*   read the data from the form and create a dataset          */
/*   with name-value pairs.                                    */
/* *********************************************************** */



data namevals;
   length name $ &maxlen value $ &maxlen  hexstr $ 2;
   array s{2} name value;
   keep name value;
   length c $ 1;
   retain ixs name value;
   keep name value;

   infile stdin lrecl=1 recfm=f;

   ixs=1;
   name=' ';
   value=' ';

   do ixc=1 to &cntlen;
      input c $char1. @@;
      put c=;

      select(c);
         when('&')do;
                     name=left(name);
                     value=left(value);
                     output;
                     put value=;
                     ixs=1;
                     name=' ';
                     value=' ';
                  end; /* when '&' */

         when('=')do;
                     put name=;
                     ixs=2;
                  end; /* when '=' */

         when('%')do;
                     input c  $CHAR1.;
                     substr(hexstr,1,1)=c;
                     input c  $CHAR1.;
                     substr(hexstr,2,1)=c;
                     c=input(hexstr,$HEX2.);

                     s(ixs)=trim(s(ixs))||c;
                     ixc=ixc+2;
                     if ixc gt &cntlen then do;
                                         /* ixc is the index var */
                                         /* if it increments past */
                                         /* &cntlen something is wrong */
                                               put 'index loop overrun';
                                               abort;
                                            end;  /* if ixc */
                  end; /* when '%' */

         otherwise do;
                     s(ixs)=trim(s(ixs))||c;
                   end; /* otherwise */

      end; /* select(c) */
   end;  /* do ixc */
                       /* the last name value pair has no trailing & */
                       /* output them now */
   name=left(name);
   value=left(value);
   output;
   put value=;
   stop; /* no more input after loop */

/* *********************************************************** */
/*   process the name value pairs                              */
/* *********************************************************** */

data _null_;
   set namevals;

   select(name);
      when('sasvar')do;
                      call symput(name,trim(value));
                    end;

      when('request')do;
                      call symput(name,trim(value));
                    end;
   end; /* select */


/* ************************************************************  */
/*   put the label of the selected variable in a macro variable  */
/* ************************************************************  */

data _null_;
   set cgibin.demobak;

   length lbl $ 40;
   call label(&sasvar,lbl);
   call symput('saslabl',trim(lbl));
run;



/* ************************************************************  */
/*   echo all macro variables to the log                         */
/* ************************************************************  */


data _null_;
   put "sasvar=&sasvar"/"saslabl=&saslabl" /"request=&request";
run;
           /* use a copy of the dataset for this test (can be sorted) */
data demo;
   set cgibin.demobak;
run;


/* macro reply generates an appropriate response to the HTML form */
/* based on the contents of the macro variable reqtyp */

%macro reply;

/* ***************************************************** */
/*   begin the table section (reqtype=table)              */
/* ***************************************************** */

%if %upcase(&request)=TABLE %then
%do;  /* table section */

   data _null_;
   put 'Executing table section';

   proc sort data=demo; by county;

   data _null_;
   file STDOUT line=curline col=curcol pagesize=50 n=ps;
/* filename dirout '$HOME/public_html/cgi-bin/dirout.prn';    */
/* file dirOUT line=curline col=curcol pagesize=50 n=ps; */
   set demo end=last;
   retain firstlin c;
   length cr $ 1;
   cr='0D'x;
   if _n_ = 1 then do;
      put 'content-type: text/html';
      put;
      put '<' 'h1>';
      put "&saslabl";
      put '<' '/h1>';
      put '<' 'pre>';
      firstlin=curline;      /* this is the first line of the table */
      c=1;                   /* this is the column in which to print */

   end;

   if curline ge (firstlin + 35) then do;
      put #(firstlin) @;
      c=c+25;
   end;  /* if curlin */

   put @c cntynm @(c+14) &sasvar best9.;

   if last then put @1 #(firstlin + 36) '<' '/pre>';
   run;
%end; /* table section */



/* ***************************************************** */
/*   begin the file  section (reqtype=file)              */
/* ***************************************************** */

%if %upcase(&request)=FILE %then
%do;  /* file section */

   data _null_;
   put 'Executing file section';

   proc sort data=demo; by county;

   data _null_;
   file STDOUT;
   set demo;
   length cr $ 1;
   cr='0D'x;
   if _n_ = 1 then do;
      put 'content-type: text/html';
      put;
      put 'Read these data into Lotus using /File Import Text' CR;
      put 'Delete the " at the beginning of the format line' CR;
      put 'Use /Data Parse on the table below to convert to numbers' CR;
      put "&saslabl" CR;
      put '"|L>>>>>>>>>>>>>V>>>>>>>>>' CR;
   end;
   put cntynm @15 &sasvar best10. CR;
   run;
%end; /* file section */





/* ***************************************************** */
/*   begin the map section (reqtype=map)                 */
/* ***************************************************** */

%if %upcase(&request)=MAP %then
%do;  /* map section */

   data _null_;
   put 'Executing map   section';

   data _null_;
   file STDOUT;
   put 'content-type: application/postscript';
   put;
   run;


   goptions device=ps      gsfname=STDOUT gsfmode=append;
   goptions nodisplay gaccess=sasgaedt gsflen=80  penmounts=255;
   goptions characters chartype=9;  /* 9 is helvetica, 11  helv bold*/

   /*   for testing
   goptions device=xcolor;   */



   run;
   /* set graphics options */
   filename shades TEMP;

                         /* note SAS scales Helvetica as wide characters */
                         /* use hpos=200 in landscape to narrow them */


                                   /* generate a continuous shaded map */
    /*--------------------------------------------------------------------*/
    /* macro SHADES                                                       */
    /* This macro is used for generating "continuous shaded" maps.It maps */
    /* a variable into integers in the right range for gray colors for    */
    /* a PostScript printer. It also generates a list of color names.     */
    /* Inputs are:                                                        */
    /*         var=      the variable to use for shading.                 */
    /*         lablvar=  the variable to print in each state.             */
    /*         data=     the data set containing these variables          */
    /*         loshade=  the lowest shade value to use                    */
    /*         hishade=  the highest shade value to use                   */
    /* Output is a dataset named RAWPLUS with the original variables plus:*/
    /*         rval      the value of the shading variable (real)         */
    /*         lablvar   the value to be used for labeling                */
    /*         ival      rval mapped onto the interval loshade<->hishade  */
    /*         shade     the "GRAYxx" color value to be used              */
    /*  and an output file named SHADES with values for a COLOR statement */
    /*--------------------------------------------------------------------*/

   %macro shades(var=, lablvar=,  data=, loshade=32, hishade=241);
                                  /* %let locolor=&loshade; */
                                  /* %let hicolor=&hishade; */
   %if %length(&lablvar)=0 %then %do;
      %let lablvar = &var;
      %end;   /* %if %length(&lablvar)   */

     proc sort data=&data; by &var;
     proc summary data=&data;
       var &var;
       output out=minmax min(&var)=xmin max(&var)=xmax;
    /* proc print data=minmax; */
     run;
     data rawplus;
       set &data;
       if _n_ = 1 then set minmax;
       drop _type_;        /*----------------------------------------------*/
                           /* RVAL contains the real value of the plot     */
       rval=&var;          /*      variable to be used for sorting.        */
                           /* LABVAL contains a value for labeling.        */
       lablval=&lablvar;   /* IVAL contains the integer transformed value. */
                           /*----------------------------------------------*/
       ival=int(.499999 + &loshade +
        (&var-xmin) * ( (&hishade-&loshade)/(xmax-xmin) ));
                                      /*reverse the order  */
       shade =  'gray' || put(&hishade - ival + &loshade, hex2.);

     data _null_;
       set rawplus end=last;
       by ival;
       file shades;
       if _n_=1 then put 'goptions colors=(';
       if first.ival then put shade;
       if last then put ');';
     run;
   %mend shades;
       /*--------------------------------------------------------------------*/
       /*     End the macro shades.                                          */
       /*     Read in the data for shading.                                  */
       /*--------------------------------------------------------------------*/

     /*---------------------------------------------------------------*/
     /* Invoke the macro.                                             */
     /*---------------------------------------------------------------*/

   %shades(data=demo, var=&sasvar)


   %include shades;

      /* adjust annotate file here */
   proc sort data=cgibin.ksanno;  by county;

   proc sort data=rawplus; by county;

   data preanno;
     length color $8;
     merge cgibin.ksanno rawplus
     (keep=county ival rval lablval shade);
     BY COUNTY;
     /*---------------------------------------------------------------*/
                                     /*  fix up the county names */
     /*---------------------------------------------------------------*/
     size=.65;
     /* y = y - (&scalfac);   */
     color='black';                     /* use contrasting label colors */
     if ival > 140 then color = 'white';
     if county = 103 then color = 'black';  /* Leavenworth */
     if county = 209 then color = 'black';  /* Wyandotte */
     if county = 5 then y=y+(&scalfac*0.3);    /* Atchison */
     if county = 43 then y=y+(&scalfac*0.65);  /* Doniphan */
     if county = 45 then y=y+(&scalfac*0.2);   /* Douglas */
     if county = 47 then y=y+(&scalfac*0.2);   /* Edwards */
     if county = 61 then y=y+(&scalfac*0.5);   /* Geary */
     if county = 79 then y=y+(&scalfac*0.1);   /* Harvey */
     if county = 91 then y=y+(&scalfac*0.3);   /* Johnson */
     if county = 91 then x=x+(&scalfac*1.0);   /* Johnson */
     if county = 103 then y=y+(&scalfac*0.2);  /* Leavenworth */
     if county = 145 then y=y+(&scalfac*0.2);  /* Pawnee */
     if county = 177 then x=x+(&scalfac*0.25); /* Shawnee */
     if county = 209 then y=y+(&scalfac*0.8);  /* Wyandotte */
     output;
           /* put text 'RVAL=' RVAL ' ival=' ival ' lablval = 'lablval
                '  shade=' shade '  color=' color;  */

     /*---------------------------------------------------------------*/
                                           /* then place the values */
     /*---------------------------------------------------------------*/
     if upcase(function) = 'LABEL' then do;
          text = '  ' || left(put(lablval, &annofmt));
                    /* !!!!NOTE!!!! THE VALUE &scalfac */
                    /* .0018 IS 15% OF THE HEIGHT OF RAWLINS COUNTY */
                    /* IT MAY CHANGE WITH MAPS.KSCOUNTY */
          y = y - (&scalfac);
          if l_tag='LV' then x = x + .5*(maxx - minx);
          if l_tag='WY' then x = x + .5*(maxx - minx);
          output;
       end;
   run;
        /*    now do the map  */

   title1  h=.5 in font=none c=black "&saslabl";
   pattern1 v=s;
   pattern2 v=m1x;
   proc gmap map=cgibin.kscounty data=rawplus anno=preanno       all;
     id county;
     choro ival / discrete
            missing
            nolegend
            ctext=black
            cempty=white
            coutline=black    ;
   run;
   quit;
%end; /* map section */

/* ***************************************************** */
/*   begin the source section (reqtype=source)           */
/* ***************************************************** */

%if %upcase(&request)=SOURCE %then
%do;  /* SOURCE section */

   filename mwsug94 '$HOME/public_html/cgi-bin/mwsug94.sas' recfm=n;
   data _null_;
   put 'Executing source section';
data _null_;
   infile mwsug94  end=last ;
   file STDOUT ;
   length cr $ 1;
  length c $ 1;
   cr='0D'x;
   if _n_ = 1 then do;
      put 'content-type: text/html';
      put;
      put '<' 'title> SAS code serving the MWSUG94.html form </title>';
      put '<' 'pre>';
   end;
/* *********************************************** */
  input c $1. @@;
  select(c);                       /* escape the codes for tags */
     when('<') put '&#60;'@@;
     when('>') put '&#62;'@@;
     when('&') put '&#38;'@@;
     when('0A'x) put ;
     otherwise put c $1. @@;
  end;
/* *********************************************** */
   if last then put '<' '/pre>';
   run;
%end; /* source section */

%mend reply;

%reply